Add texture aging

basis/core-text/core-text.factor

@@ -114,7 +114,7 @@ TUPLE: typographic-bounds width ascent descent leading ;
     [ CTLineGetTypographicBounds ] 3keep [ *CGFloat ] tri@
     typographic-bounds boa ;
 
-TUPLE: line string font line bounds dim bitmap age disposed ;
+TUPLE: line string font line bounds dim bitmap age refs disposed ;
 
 : bounds>dim ( bounds -- dim )
     [ width>> ] [ [ ascent>> ] [ descent>> ] bi + ] bi
@@ -131,31 +131,36 @@ TUPLE: line string font line bounds dim bitmap age disposed ;
         2dup white <CTLine> |CFRelease
         dup line-typographic-bounds
         dup bounds>dim 3dup [ draw-line ] with-bitmap-context
-        0 f line boa
+        0 0 f line boa
     ] with-destructors ;
 
-M: line dispose*
-    [ font>> ] [ line>> ] bi 2array dispose-each ;
+M: line dispose* line>> CFRelease ;
 
-<PRIVATE
+: ref/unref-line ( line n -- )
+    '[ _ + ] change-refs 0 >>age drop ;
 
-MEMO: (cached-line) ( string font -- line ) <line> ;
+: ref-line ( line -- ) 1 ref/unref-line ;
+: unref-line ( line -- ) -1 ref/unref-line ;
 
-: cached-lines ( -- assoc )
-    \ (cached-line) "memoize" word-prop ;
+SYMBOL: cached-lines
 
-: set-cached-lines ( assoc -- )
-    \ (cached-line) "memoize" set-word-prop ;
+: cached-line ( string font -- line )
+    cached-lines get [ <line> ] 2cache ;
 
 CONSTANT: max-line-age 5
 
-PRIVATE>
+: age ( obj -- ? )
+    [ 1+ ] change-age age>> max-line-age >= ;
+
+: age-line ( line -- ? )
+    #! Outputs t whether the line is dead.
+    dup refs>> 0 = [ age ] [ drop f ] if ;
+
+: age-assoc ( assoc quot -- assoc' )
+    '[ nip @ ] assoc-partition
+    [ values dispose-each ] dip ;
 
 : age-lines ( -- )
-    cached-lines
-    [ nip [ 1+ ] change-age age>> max-line-age <= ] assoc-filter
-    set-cached-lines ;
+    cached-lines global [ [ age-line ] age-assoc ] change-at ;
 
-: cached-line ( string font -- line ) (cached-line) 0 >>age ;
-
-[ \ (cached-line) reset-memoized ] "core-text" add-init-hook
+[ H{ } clone cached-lines set-global ] "core-text" add-init-hook

basis/ui/gadgets/worlds/worlds.factor

@@ -1,9 +1,9 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs continuations kernel math models
-namespaces opengl sequences io combinators fry math.vectors
-ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
-math.geometry.rect ;
+namespaces opengl sequences io combinators combinators.short-circuit
+fry math.vectors ui.gadgets ui.gestures ui.render ui.text ui.text.private
+ui.backend ui.gadgets.tracks math.geometry.rect ;
 IN: ui.gadgets.worlds
 
 TUPLE: world < track
@@ -54,9 +54,7 @@ M: world request-focus-on ( child gadget -- )
 
 M: world layout*
     dup call-next-method
-    dup glass>> [
-        [ dup rect-dim ] dip (>>dim)
-    ] when* drop ;
+    dup glass>> dup [ swap dim>> >>dim drop ] [ 2drop ] if ;
 
 M: world focusable-child* gadget-child ;
 
@@ -64,13 +62,13 @@ M: world children-on nip children>> ;
 
 : (draw-world) ( world -- )
     dup handle>> [
-        [ dup init-gl ] keep draw-gadget
+        [ init-gl ] [ draw-gadget ] [ finish-text-rendering ] tri
     ] with-gl-context ;
 
 : draw-world? ( world -- ? )
     #! We don't draw deactivated worlds, or those with 0 size.
     #! On Windows, the latter case results in GL errors.
-    [ active?>> ] [ handle>> ] [ dim>> [ 0 > ] all? ] tri and and ;
+    { [ active?>> ] [ handle>> ] [ dim>> [ 0 > ] all? ] } 1&& ;
 
 TUPLE: world-error error world ;
 
@@ -86,16 +84,12 @@ ui-error-hook global [ [ rethrow ] or ] change-at
 : draw-world ( world -- )
     dup draw-world? [
         dup world [
-            [
-                (draw-world)
-            ] [
+            [ (draw-world) ] [
                 over <world-error> ui-error
                 f >>active? drop
             ] recover
         ] with-variable
-    ] [
-        drop
-    ] if ;
+    ] [ drop ] if ;
 
 world H{
     { T{ key-down f { C+ } "x" } [ T{ cut-action } send-action ] }

basis/ui/render/render.factor

@@ -18,17 +18,19 @@ SYMBOL: viewport-translation
 
 : do-clip ( -- ) clip get flip-rect gl-set-clip ;
 
-: init-clip ( clip-rect rect -- )
-    GL_SCISSOR_TEST glEnable
-    [ rect-intersect ] keep
-    dim>> dup { 0 1 } v* viewport-translation set
-    { 0 0 } over gl-viewport
-    0 swap first2 0 gluOrtho2D
-    clip set
+: init-clip ( clip-rect -- )
+    [
+        dim>>
+        [ { 0 1 } v* viewport-translation set ]
+        [ [ { 0 0 } ] dip gl-viewport ]
+        [ [ 0 ] dip first2 0 gluOrtho2D ] tri
+    ]
+    [ clip set ] bi
     do-clip ;
 
-: init-gl ( clip-rect rect -- )
+: init-gl ( clip-rect -- )
     GL_SMOOTH glShadeModel
+    GL_SCISSOR_TEST glEnable
     GL_BLEND glEnable
     GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc
     GL_VERTEX_ARRAY glEnableClientState

basis/ui/text/core-text/core-text.factor

@@ -51,13 +51,24 @@ M: core-text-renderer string-dim
 TUPLE: line-texture line texture age disposed ;
 
 : <line-texture> ( line -- texture )
-    dup [ dim>> ] [ bitmap>> ] bi GL_RGBA make-texture
-    0 f \ line-texture boa ;
+    #! Note: we only ref-line if make-texture succeeds
+    [
+        dup [ dim>> ] [ bitmap>> ] bi GL_RGBA make-texture
+        0 f \ line-texture boa
+    ] keep ref-line ;
 
-M: line-texture dispose* texture>> delete-texture ;
+M: line-texture dispose*
+    [ line>> unref-line ]
+    [ texture>> delete-texture ] bi ;
 
 : line-texture ( string open-font -- texture )
-    world get fonts>> [ cached-line <line-texture> ] 2cache ;
+    world get fonts>> [ cached-line <line-texture> ] 2cache 0 >>age ;
+
+: age-line-textures ( world -- )
+    [ [ age ] age-assoc ] change-fonts drop ;
+
+M: core-text-renderer finish-text-rendering
+    age-line-textures age-lines ;
 
 : draw-line-texture ( line-texture -- )
     GL_TEXTURE_2D [

basis/ui/text/text.factor

@@ -11,6 +11,10 @@ TUPLE: font name size bold? italic? ;
 
 SYMBOL: font-renderer
 
+HOOK: finish-text-rendering font-renderer ( world -- )
+
+M: object finish-text-rendering drop ;
+
 HOOK: open-font font-renderer ( font -- open-font )
 
 HOOK: string-dim font-renderer ( open-font string -- dim )