Clean up Core Text rendering code, and factor our basis/cache and basis/opengl/texture-cache

basis/cache/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/cache/cache-tests.factor

@@ -0,0 +1,4 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test cache ;
+IN: cache.tests

basis/cache/cache.factor

@@ -0,0 +1,36 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel assocs math accessors destructors fry ;
+IN: cache
+
+SLOT: age
+
+GENERIC: age ( obj -- )
+
+M: object age [ 1+ ] change-age drop ;
+
+TUPLE: cache-assoc assoc max-age disposed ;
+
+: <cache-assoc> ( -- cache )
+    H{ } clone 10 f cache-assoc boa ;
+
+M: cache-assoc assoc-size assoc>> assoc-size ;
+
+M: cache-assoc at* assoc>> at* [ dup [ 0 >>age ] when ] dip ;
+
+M: cache-assoc set-at dup check-disposed assoc>> set-at ;
+
+M: cache-assoc clear-assoc assoc>> clear-assoc ;
+
+M: cache-assoc >alist assoc>> >alist ;
+
+INSTANCE: cache-assoc assoc
+
+: purge-cache ( cache -- )
+    dup max-age>> '[
+        [ nip dup age age>> _ >= ] assoc-partition
+        [ values dispose-each ] dip
+    ] change-assoc drop ;
+
+M: cache-assoc dispose*
+    assoc>> [ values dispose-each ] [ clear-assoc ] bi ;

basis/core-text/core-text.factor

@@ -3,7 +3,7 @@
 USING: arrays alien alien.c-types alien.syntax kernel
 destructors accessors fry words hashtables strings
 sequences memoize assocs math math.functions locals init
-namespaces combinators fonts colors core-foundation
+namespaces combinators fonts colors cache core-foundation
 core-foundation.strings core-foundation.attributed-strings
 core-foundation.utilities core-graphics core-graphics.types
 core-text.fonts core-text.utilities ;
@@ -47,7 +47,7 @@ ERROR: not-a-string object ;
         CTLineCreateWithAttributedString
     ] with-destructors ;
 
-TUPLE: line font line metrics dim bitmap age refs disposed ;
+TUPLE: line font line metrics dim bitmap age disposed ;
 
 : compute-line-metrics ( line -- line-metrics )
     0 <CGFloat> 0 <CGFloat> 0 <CGFloat>
@@ -92,38 +92,16 @@ TUPLE: line font line metrics dim bitmap age refs disposed ;
                     [ [ line ] dip CTLineDraw ]
                 } cleave
             ] with-bitmap-context
-            [ open-font line metrics dim ] dip 0 0 f
+            [ open-font line metrics dim ] dip 0 f
         ]
         line boa
     ] with-destructors ;
 
 M: line dispose* [ font>> CFRelease ] [ line>> CFRelease ] bi ;
 
-: ref/unref-line ( line n -- )
-    '[ _ + ] change-refs 0 >>age drop ;
-
-: ref-line ( line -- ) 1 ref/unref-line ;
-: unref-line ( line -- ) -1 ref/unref-line ;
-
 SYMBOL: cached-lines
 
 : cached-line ( font string -- line )
     cached-lines get [ <line> ] 2cache ;
 
-CONSTANT: max-line-age 10
+[ <cache-assoc> cached-lines set-global ] "core-text" add-init-hook
-
-: 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 ; inline
-
-: age-lines ( -- )
-    cached-lines global [ [ age-line ] age-assoc ] change-at ;
-
-[ H{ } clone cached-lines set-global ] "core-text" add-init-hook

basis/opengl/texture-cache/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/opengl/texture-cache/texture-cache-tests.factor

@@ -0,0 +1,4 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test opengl.texture-cache ;
+IN: opengl.texture-cache.tests

basis/opengl/texture-cache/texture-cache.factor

@@ -0,0 +1,56 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs cache colors.constants destructors fry
+kernel locals opengl opengl.gl ;
+IN: opengl.texture-cache
+
+TUPLE: texture texture display-list age disposed ;
+
+: make-texture-display-list ( dim texture -- dlist )
+    GL_COMPILE [
+        GL_TEXTURE_2D [
+            GL_TEXTURE_BIT [
+                GL_TEXTURE_COORD_ARRAY [
+                    COLOR: white gl-color
+                    GL_TEXTURE_2D swap glBindTexture
+                    init-texture rect-texture-coords
+                    fill-rect-vertices (gl-fill-rect)
+                    GL_TEXTURE_2D 0 glBindTexture
+                ] do-enabled-client-state
+            ] do-attribs
+        ] do-enabled
+    ] make-dlist ;
+
+:: <texture> ( dim bitmap format type -- texture )
+    dim bitmap format type make-texture
+    dim over make-texture-display-list 0 f texture boa ;
+
+M: texture dispose*
+    [ texture>> delete-texture ]
+    [ display-list>> delete-dlist ] bi ;
+
+TUPLE: texture-cache format type renderer cache disposed ;
+
+: <texture-cache> ( -- cache )
+    texture-cache new
+        <cache-assoc> >>cache ;
+
+GENERIC: render-texture ( key renderer -- dim bitmap )
+
+: get-texture ( key texture-cache -- dlist )
+    dup check-disposed
+    [ cache>> ] keep
+    '[
+        _
+        [ renderer>> render-texture ]
+        [ format>> ]
+        [ type>> ]
+        tri <texture>
+    ] cache
+    display-list>> ;
+
+M: texture-cache dispose*
+    cache>> values dispose-each ;
+
+: purge-texture-cache ( texture-cache -- )
+    cache>> purge-cache ;

basis/ui/gadgets/worlds/worlds.factor

@@ -10,7 +10,7 @@ TUPLE: world < track
 active? focused?
 glass
 title status
-fonts handle
+text-handle handle
 window-loc ;
 
 : find-world ( gadget -- world/f ) [ world? ] find-parent ;
@@ -42,11 +42,11 @@ M: world request-focus-on ( child gadget -- )
     vertical swap new-track
         t >>root?
         t >>active?
-        H{ } clone >>fonts
         { 0 0 } >>window-loc
         swap >>status
         swap >>title
         swap 1 track-add
+    dup init-text-rendering
     dup request-focus ;
 
 : <world> ( gadget title status -- world )

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

@@ -2,64 +2,36 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs accessors alien core-graphics.types core-text
 core-text.fonts kernel hashtables namespaces sequences
-ui.gadgets.worlds ui.text ui.text.private opengl opengl.gl destructors
+ui.gadgets.worlds ui.text ui.text.private opengl opengl.gl
-combinators core-foundation core-foundation.strings memoize math
+opengl.texture-cache destructors combinators core-foundation
-math.vectors init colors colors.constants ;
+core-foundation.strings math math.vectors init colors colors.constants
+cache arrays ;
 IN: ui.text.core-text
 
 SINGLETON: core-text-renderer
 
+M: core-text-renderer init-text-rendering
+    <texture-cache>
+        GL_BGRA_EXT >>format
+        GL_UNSIGNED_INT_8_8_8_8_REV >>type
+        core-text-renderer >>renderer
+    >>text-handle drop ;
+
 M: core-text-renderer string-dim
     [ " " string-dim { 0 1 } v* ] [ cached-line dim>> ] if-empty ;
 
-TUPLE: rendered-line line texture display-list age disposed ;
+M: core-text-renderer render-texture
-
+    drop first2 cached-line [ dim>> ] [ bitmap>> ] bi ;
-: make-line-display-list ( line texture -- dlist )
-    GL_COMPILE [
-        GL_TEXTURE_2D [
-            GL_TEXTURE_BIT [
-                GL_TEXTURE_COORD_ARRAY [
-                    COLOR: white gl-color
-                    GL_TEXTURE_2D swap glBindTexture
-                    init-texture rect-texture-coords
-                    dim>> fill-rect-vertices (gl-fill-rect)
-                    GL_TEXTURE_2D 0 glBindTexture
-                ] do-enabled-client-state
-            ] do-attribs
-        ] do-enabled
-    ] make-dlist ;
-
-: make-core-graphics-texture ( dim bitmap -- texture )
-    GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8_REV make-texture ;
-
-: <rendered-line> ( line -- texture )
-    #! Note: we only ref-line if make-texture and make-line-display-list
-    #! succeed
-    [
-        dup [ dim>> ] [ bitmap>> ] bi make-core-graphics-texture
-        2dup make-line-display-list
-        0 f \ rendered-line boa
-    ] keep ref-line ;
-
-M: rendered-line dispose*
-    [ line>> unref-line ]
-    [ texture>> delete-texture ]
-    [ display-list>> delete-dlist ] tri ;
-
-: rendered-line ( font string -- rendered-line )
-    world get fonts>>
-    [ cached-line <rendered-line> ] 2cache 0 >>age ;
-
-: age-rendered-lines ( world -- )
-    [ [ age ] age-assoc ] change-fonts drop ;
 
 M: core-text-renderer finish-text-rendering
-    age-rendered-lines age-lines ;
+    text-handle>> purge-texture-cache
+    cached-lines get purge-cache ;
+
+: rendered-line ( font string -- display-list )
+    2array world get text-handle>> get-texture ;
 
 M: core-text-renderer draw-string ( font string loc -- )
-    [
+    [ rendered-line glCallList ] with-translation ;
-        rendered-line display-list>> glCallList
-    ] with-translation ;
 
 M: core-text-renderer x>offset ( x font string -- n )
     [ 2drop 0 ] [
@@ -76,7 +48,4 @@ M: core-text-renderer line-metrics ( font string -- metrics )
     [ cached-line metrics>> ]
     if-empty ;
 
-M: core-text-renderer free-fonts ( fonts -- )
-    values dispose-each ;
-
 core-text-renderer font-renderer set-global

basis/ui/text/text.factor

@@ -8,6 +8,8 @@ IN: ui.text
 
 SYMBOL: font-renderer
 
+HOOK: init-text-rendering font-renderer ( world -- )
+
 HOOK: finish-text-rendering font-renderer ( world -- )
 
 M: object finish-text-rendering drop ;

basis/ui/tools/listener/listener-tests.factor

@@ -9,7 +9,7 @@ IN: ui.tools.listener.tests
 \ <interactor> must-infer
 
 [
-    [ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
+    [ ] [ <interactor> <pane> <pane-stream> >>output "interactor" set ] unit-test
 
     [ ] [ "interactor" get register-self ] unit-test
 
@@ -35,7 +35,7 @@ IN: ui.tools.listener.tests
 ] with-interactive-vocabs
 
 [
-    [ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
+    [ ] [ <interactor> <pane> <pane-stream> >>output "interactor" set ] unit-test
 
     [ ] [ "interactor" get register-self ] unit-test
 
@@ -56,7 +56,7 @@ IN: ui.tools.listener.tests
 ] with-interactive-vocabs
 
 ! Hang
-[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
+[ ] [ <interactor> <pane> <pane-stream> >>output "interactor" set ] unit-test
 
 [ ] [ [ "interactor" get stream-read-quot drop ] "A" spawn drop ] unit-test
 
@@ -66,7 +66,7 @@ IN: ui.tools.listener.tests
 
 [ ] [ "interactor" get interactor-eof ] unit-test
 
-[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
+[ ] [ <interactor> <pane> <pane-stream> >>output "interactor" set ] unit-test
 
 : text "Hello world.\nThis is a test." ;
 
@@ -91,7 +91,7 @@ IN: ui.tools.listener.tests
 
 [ t ] [ "promise" get 2 seconds ?promise-timeout text = ] unit-test
 
-[ ] [ <pane> <pane-stream> <interactor> "interactor" set ] unit-test
+[ ] [ <interactor> <pane> <pane-stream> >>output "interactor" set ] unit-test
 
 [ ] [ text "interactor" get set-editor-string ] unit-test
 
@@ -115,7 +115,7 @@ IN: ui.tools.listener.tests
 [ ] [ <listener-gadget> "listener" set ] unit-test
 
 "listener" get [
-    <pane> <interactor> "i" set
+    <interactor> <pane> <pane-stream> >>output "i" set
 
     [ t ] [ "i" get interactor? ] unit-test
 
@@ -148,7 +148,7 @@ IN: ui.tools.listener.tests
     [ ] [ "listener" get com-end ] unit-test
 ] with-grafted-gadget
 
-[ ] [ \ + <pane> <interactor> vocabs>> use-if-necessary ] unit-test
+[ ] [ \ + <interactor> vocabs>> use-if-necessary ] unit-test
 
 [ ] [ <listener-gadget> "l" set ] unit-test
 [ ] [ "l" get com-scroll-up ] unit-test

basis/ui/ui.factor

@@ -3,8 +3,9 @@
 USING: arrays assocs io kernel math models namespaces make dlists
 deques sequences threads sequences words continuations init call
 combinators hashtables concurrency.flags sets accessors calendar fry
-ui.gadgets ui.gadgets.private ui.gadgets.worlds ui.gadgets.tracks
+destructors ui.gadgets ui.gadgets.private ui.gadgets.worlds
-ui.gestures ui.backend ui.render ui.text ui.text.private ;
+ui.gadgets.tracks ui.gestures ui.backend ui.render ui.text
+ui.text.private ;
 IN: ui
 
 ! Assoc mapping aliens to gadgets
@@ -55,14 +56,12 @@ M: world graft*
 : reset-world ( world -- )
     #! This is used when a window is being closed, but also
     #! when restoring saved worlds on image startup.
-    [ fonts>> clear-assoc ]
+    f >>handle unfocus-world ;
-    [ unfocus-world ]
-    [ f >>handle drop ] tri ;
 
 : (ungraft-world) ( world -- )
     {
         [ handle>> select-gl-context ]
-        [ fonts>> free-fonts ]
+        [ text-handle>> dispose ]
         [ hand-clicked close-global ]
         [ hand-gadget close-global ]
     } cleave ;
@@ -95,7 +94,7 @@ M: world ungraft*
     children>> [ restore-gadget ] each ;
 
 : restore-world ( world -- )
-    dup reset-world restore-gadget ;
+    [ reset-world ] [ init-text-rendering ] [ restore-gadget ] tri ;
 
 : update-hand ( world -- )
     dup hand-world get-global eq?