UI optimizations

library/ui/freetype/freetype-gl.factor

@@ -55,7 +55,7 @@ M: font = eq? ;
     } hash ;
 
 : ttf-path ( name -- string )
-    [ "/fonts/" % % ".ttf" % ] "" make resource-path ;
+    "/fonts/" swap ".ttf" append3 resource-path ;
 
 : open-face ( font style -- face )
     #! Open a TrueType font with the given logical name and

library/ui/gadgets.factor

@@ -40,7 +40,7 @@ M: array rect-dim drop { 0 0 } ;
 
 TUPLE: gadget
     pref-dim parent children orientation
-    visible? relayout? root? interior boundary ;
+    visible? relayout? root? clipped? interior boundary ;
 
 M: gadget = eq? ;
 

library/ui/gadgets/editors.factor

@@ -50,7 +50,8 @@ TUPLE: editor line caret font color ;
 : set-caret-x ( x editor -- )
     #! Move the caret to a clicked location.
     dup [
-        label-font* line-text get x>offset set-caret-pos
+        label-font lookup-font line-text get
+        x>offset set-caret-pos
     ] with-editor ;
 
 : click-editor ( editor -- )
@@ -88,7 +89,7 @@ C: editor ( text -- )
     [ set-editor-text ] keep ;
 
 : offset>x ( gadget offset str -- x )
-    head-slice >r label-font* r> string-width ;
+    head-slice >r label-font lookup-font r> string-width ;
 
 : caret-loc ( editor -- x y )
     dup editor-line [ caret-pos line-text get ] bind offset>x

library/ui/gadgets/labels.factor

@@ -16,16 +16,14 @@ C: label ( text -- label )
     2dup label-text =
     [ 2dup [ set-label-text ] keep relayout ] unless 2drop ;
 
-: label-font* ( label -- font ) label-font lookup-font ;
-
 : label-size ( gadget text -- dim )
-    dup label-font* dup font-height >r
+    dup label-font lookup-font dup font-height >r
     swap label-text string-width r> 2array ;
 
 M: label pref-dim* ( label -- dim ) label-size ;
 
 : draw-label ( label -- )
     dup label-color gl-color
-    dup label-font* swap label-text draw-string ;
+    dup label-font swap label-text draw-string ;
 
 M: label draw-gadget* ( label -- ) draw-label ;

library/ui/gadgets/paragraphs.factor

@@ -10,6 +10,8 @@ TUPLE: word-break-gadget ;
 C: word-break-gadget ( gadget -- gadget )
     [ set-delegate ] keep ;
 
+M: word-break-gadget draw-gadget* ( gadget -- ) drop ;
+
 ! A gadget that arranges its children in a word-wrap style.
 TUPLE: paragraph margin ;
 

library/ui/gadgets/tracks.factor

@@ -16,7 +16,8 @@ M: divider pref-dim* drop divider-size ;
 TUPLE: track sizes saved-sizes ;
 
 C: track ( orientation -- track )
-    [ delegate>pack ] keep 1 over set-pack-fill ;
+    [ delegate>pack ] keep 1 over set-pack-fill
+    t over set-gadget-clipped? ;
 
 : divider-sizes ( seq -- dim )
     length 1 [-] divider-size n*v ;

library/ui/gadgets/viewports.factor

@@ -10,7 +10,8 @@ TUPLE: viewport ;
 : viewport-dim gadget-child pref-dim ;
 
 C: viewport ( content -- viewport )
-    dup delegate>gadget [ add-gadget ] keep ;
+    dup delegate>gadget [ add-gadget ] keep
+    t over set-gadget-clipped? ;
 
 M: viewport layout* ( viewport -- )
     gadget-child prefer ;

library/ui/layouts.factor

@@ -136,13 +136,14 @@ M: pack layout* ( pack -- )
     dup gadget-children pref-dims packed-layout ;
 
 : fast-children-on ( dim axis gadgets -- i )
-    swapd [ rect-loc origin get v+ v- over v. ] binsearch nip ;
+    swapd [ rect-loc v- over v. ] binsearch nip ;
 
 M: pack children-on ( rect pack -- list )
     dup gadget-orientation swap gadget-children [
         3dup
-        >r >r dup rect-loc swap rect-dim v+ r> r> fast-children-on 1+
+        >r >r dup rect-loc swap rect-dim v+ origin get v- r> r> fast-children-on 1+
         >r
-        >r >r rect-loc r> r> fast-children-on 0 max
+        >r >r rect-loc origin get v- r> r> fast-children-on
+        0 max
         r>
     ] keep <slice> ;

library/ui/paint.factor

@@ -19,7 +19,7 @@ SYMBOL: clip
     GL_SMOOTH glShadeModel
     GL_BLEND glEnable
     GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc
-    ! GL_SCISSOR_TEST glEnable
+    GL_SCISSOR_TEST glEnable
     1.0 1.0 1.0 1.0 glClearColor
     GL_COLOR_BUFFER_BIT glClear ;
 
@@ -45,36 +45,44 @@ DEFER: draw-gadget
         dup dup gadget-interior draw-interior
         dup dup gadget-boundary draw-boundary
         dup draw-gadget*
-        gadget-children [ draw-gadget ] each
+        visible-children [ draw-gadget ] each
     ] with-translation ;
 
-: gl-set-clip ( loc dim -- )
+: change-clip ( gadget -- )
-    dup first2 1+ >r >r
+    >absolute clip [ rect-intersect ] change ;
-    over second swap second + world get rect-dim second
-    swap - >r first r> r> r> glScissor ;
 
-: do-clip ( gadget -- )
+: clip-x/y ( loc dim -- x y )
-    >absolute clip [ rect-intersect dup ] change
+    >r [ first ] keep r>
-    dup rect-loc swap rect-dim gl-set-clip ;
+    [ second ] 2apply + world get rect-dim second swap - ;
+
+: clip-w/h ( dim -- w h )
+    first2 1- ;
+
+: gl-set-clip ( loc dim -- )
+    dup clip-w/h >r >r clip-x/y r> r> glScissor ;
+
+: do-clip ( -- ) clip get rect-bounds gl-set-clip ;
+
+: with-clipping ( gadget quot -- )
+    clip get >r
+    over change-clip do-clip call
+    r> clip set do-clip ; inline
 
 : draw-gadget ( gadget -- )
-    ! clip get over inside? [
+    dup gadget-clipped? [
-    !    [
+        [ (draw-gadget) ] with-clipping
-     !       dup do-clip
+    ] [
-            
+        (draw-gadget)
-     (draw-gadget) ;
+    ] if ;
-   !     ] with-scope
-   ! ] when drop ;
 
 : draw-world ( world -- )
     [
-        [
+        dup world-handle [
-            dup world-handle [
+            dup rect-dim init-gl
-                dup rect-dim init-gl dup world set
+            dup world set
-                draw-gadget
+            draw-gadget
-            ] with-gl-context
+        ] with-gl-context
-        ] with-scope
+    ] with-scope ;
-    ] USE: test USE: prettyprint benchmark nip global [ . flush ] bind ;
 
 ! Pen paint properties
 M: f draw-interior 2drop ;

library/ui/world.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2005, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: gadgets
-USING: errors freetype gadgets-frames generic hashtables kernel
+USING: arrays errors freetype gadgets-frames generic hashtables
-math namespaces opengl sequences ;
+kernel math namespaces opengl sequences ;
 
 ! The world gadget is the top level gadget that all (visible)
 ! gadgets are contained in. There is one world per top-level
@@ -18,10 +18,7 @@ TUPLE: world gadget status focus focused? fonts handle loc ;
 
 : free-fonts ( world -- )
     dup world-handle select-gl-context
-    world-fonts hash-values [ free-sprites ] each ;
+    world-fonts hash-values [ second free-sprites ] each ;
-
-: font-sprites ( font world -- sprites )
-    world-fonts [ drop V{ } clone ] cache ;
 
 DEFER: request-focus
 
@@ -43,5 +40,8 @@ M: world pref-dim* ( world -- dim )
 : focused-ancestors ( world -- seq )
     world-focus parents <reversed> ;
 
-: draw-string ( open-fonts string -- )
+: font-sprites ( font world -- { open-font sprites } )
-    >r dup world get font-sprites r> (draw-string) ;
+    world-fonts [ lookup-font V{ } clone 2array ] cache ;
+
+: draw-string ( font string -- )
+    >r world get font-sprites first2 r> (draw-string) ;