UI layout management work

library/collections/lists.factor

@@ -160,8 +160,5 @@ M: general-list nth ( n list -- element )
     uncons >r cons r> cons ;
 
 : deque ( queue -- obj queue )
-    uncons [
-        uncons swapd cons
-    ] [
-        reverse uncons f swons
-    ] ifte* ;
+    uncons
+    [ uncons swapd cons ] [ reverse uncons f swons ] ifte* ;

library/test/lists/queues.factor

@@ -1,7 +1,13 @@
 IN: temporary
-USING: kernel lists test ;
+USING: kernel lists math sequences test ;
 
 [ [ 1 2 3 4 5 ] ] [
     <queue> [ 1 2 3 4 5 ] [ swap enque ] each
     5 [ drop deque swap ] project nip
 ] unit-test
+
+[ [ 1 4 9 16 25 ] ] [
+    <queue> [ 1 2 3 4 5 ] [ swap enque ] each
+    [ sq ] que-map
+    5 [ drop deque swap ] project nip
+] unit-test

library/test/test.factor

@@ -76,7 +76,8 @@ SYMBOL: failures
 : tests
     [
         "lists/cons" "lists/lists" "lists/assoc"
-        "lists/namespaces" "lists/combinators" "combinators"
+        "lists/namespaces" "lists/combinators" "lists/queues"
+        "combinators"
         "continuations" "errors" "hashtables" "strings"
         "namespaces" "generic" "tuple" "files" "parser"
         "parse-number" "image" "init" "io/io"

library/ui/borders.factor

@@ -15,7 +15,7 @@ C: border ( child delegate size -- border )
     0 0 0 0 <etched-rect> <gadget> { 5 5 0 } <border> ;
 
 : layout-border-loc ( border -- )
-    dup border-size swap gadget-child set-gadget-loc ;
+    dup border-size swap gadget-child set-shape-loc ;
 
 : layout-border-dim ( border -- )
     dup shape-dim over border-size 2 v*n v-

library/ui/editors.factor

@@ -76,11 +76,12 @@ C: editor ( text -- )
 : offset>x ( gadget offset str -- x )
     head >r gadget-font r> size-string drop ;
 
-: caret-pos ( editor -- x y )
-    dup editor-line [ caret get line-text get ] bind offset>x 0 ;
+: caret-loc ( editor -- x y )
+    dup editor-line [ caret get line-text get ] bind offset>x
+    0 0 3vector ;
 
-: caret-size ( editor -- w h )
-    1 swap shape-h ;
+: caret-dim ( editor -- w h )
+    shape-dim { 0 1 1 } v* { 1 0 0 } v+ ;
 
 M: editor user-input* ( ch editor -- ? )
     [ [ insert-char ] with-editor ] keep
@@ -90,8 +91,8 @@ M: editor pref-dim ( editor -- dim )
     dup editor-text label-size { 1 0 0 } v+ ;
 
 M: editor layout* ( editor -- )
-    dup editor-caret over caret-size rot resize-gadget
-    dup editor-caret swap caret-pos rot move-gadget ;
+    dup editor-caret over caret-dim swap set-gadget-dim
+    dup editor-caret swap caret-loc swap set-shape-loc ;
 
 M: editor draw-shape ( editor -- )
     [ dup gadget-font swap editor-text ] keep

library/ui/events.factor

@@ -2,7 +2,7 @@
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
 USING: alien generic kernel lists math namespaces prettyprint
-sdl sequences ;
+sdl sequences vectors ;
 
 GENERIC: handle-event ( event -- )
 
@@ -14,7 +14,7 @@ M: quit-event handle-event ( event -- )
 
 M: resize-event handle-event ( event -- )
     dup resize-event-w swap resize-event-h
-    [ world get resize-gadget ] 2keep
+    [ 0 3vector world get set-gadget-dim ] 2keep
     0 SDL_HWSURFACE SDL_RESIZABLE bitor init-screen
     world get relayout ;
 

library/ui/frames.factor

@@ -83,7 +83,7 @@ SYMBOL: frame-bottom-run
     var-frame-bottom ;
 
 : reshape-gadget ( x y w h gadget -- )
-    [ resize-gadget ] keep move-gadget ;
+    [ >r 0 3vector r> set-gadget-dim ] keep move-gadget ;
 
 : pos-frame-center
     >r \ frame-left get \ frame-top get

library/ui/gadgets.factor

@@ -7,30 +7,28 @@ sequences vectors ;
 ! A gadget is a shape, a paint, a mapping of gestures to
 ! actions, and a reference to the gadget's parent. A gadget
 ! delegates to its shape.
-TUPLE: gadget paint gestures relayout? redraw? parent children ;
+TUPLE: gadget
+    paint gestures
+    relayout? redraw? root?
+    parent children ;
 
 : gadget-child gadget-children car ;
 
 C: gadget ( shape -- gadget )
     [ set-delegate ] keep
-    [ <namespace> swap set-gadget-paint ] keep
-    [ <namespace> swap set-gadget-gestures ] keep
-    [ t swap set-gadget-relayout? ] keep
-    [ t swap set-gadget-redraw? ] keep ;
+    <namespace> over set-gadget-paint
+    <namespace> over set-gadget-gestures ;
 
 : <empty-gadget> ( -- gadget ) 0 0 0 0 <rectangle> <gadget> ;
 
 : <plain-gadget> ( -- gadget ) 0 0 0 0 <plain-rect> <gadget> ;
 
-: redraw ( gadget -- )
-    #! Redraw a gadget before the next iteration of the event
-    #! loop.
-    dup gadget-redraw? [
-        drop
-    ] [
+DEFER: relayout
+DEFER: add-invalid
+
+: invalidate ( gadget -- )
     t over set-gadget-redraw?
-        gadget-parent [ redraw ] when*
-    ] ifte ;
+    t swap set-gadget-relayout? ;
 
 : relayout ( gadget -- )
     #! Relayout and redraw a gadget and its parent before the
@@ -38,28 +36,23 @@ C: gadget ( shape -- gadget )
     dup gadget-relayout? [
         drop
     ] [
-        t over set-gadget-redraw?
-        t over set-gadget-relayout?
-        gadget-parent [ relayout ] when*
+        dup invalidate
+        dup gadget-root?
+        [ world get add-invalid ]
+        [ gadget-parent [ relayout ] when* ] ifte
     ] ifte ;
 
-: relayout* ( gadget -- )
+: relayout-down ( gadget -- )
     #! Relayout a gadget and its children.
-    dup relayout gadget-children [ relayout* ] each ;
-
-: set-gadget-loc ( loc gadget -- )
-    2dup shape-loc =
-    [ 2drop ] [ [ set-shape-loc ] keep redraw ] ifte ;
+    dup world get add-invalid
+    dup invalidate gadget-children [ relayout-down ] each ;
 
 : move-gadget ( x y gadget -- )
-    >r 0 3vector r> set-gadget-loc ;
+    >r 0 3vector r> set-shape-loc ;
 
 : set-gadget-dim ( dim gadget -- )
     2dup shape-dim =
-    [ 2drop ] [ [ set-shape-dim ] keep relayout* ] ifte ;
-
-: resize-gadget ( w h gadget -- )
-    >r 0 3vector r> set-gadget-dim ;
+    [ 2drop ] [ [ set-shape-dim ] keep relayout-down ] ifte ;
 
 : paint-prop ( gadget key -- value )
     over [

library/ui/incremental.factor

@@ -31,8 +31,10 @@ C: incremental ( pack -- incremental )
 
 : incremental-loc ( gadget incremental -- )
     dup incremental-cursor dup rot pack-vector v* v-
-    swap set-gadget-loc ;
+    swap set-shape-loc ;
 
 : add-incremental ( gadget incremental -- )
-    ( 2dup add-gadget ) (  over prefer )  f over set-gadget-relayout?
-    ( 2dup incremental-loc ) ( update-cursor ) 2drop ;
+    2dup add-gadget
+    >r dup dup pref-dim swap set-shape-dim r>
+    f over set-gadget-relayout?
+    2dup incremental-loc update-cursor ;

library/ui/layouts.factor

@@ -54,7 +54,7 @@ TUPLE: pack align fill vector ;
 
 : packed-locs ( gadget sizes -- )
     over gadget-children >r (packed-locs) r>
-    zip [ uncons set-gadget-loc ] each ;
+    zip [ uncons set-shape-loc ] each ;
 
 : packed-layout ( gadget sizes -- )
     2dup packed-locs packed-dims ;

library/ui/menus.factor

@@ -3,16 +3,9 @@
 IN: gadgets
 USING: generic kernel lists math namespaces sequences ;
 
-: hide-menu ( -- )
-    world get
-    dup hide-glass
-    [ world-menu unparent f ] keep set-world-menu ;
-
 : show-menu ( menu -- )
-    hide-menu
-    world get
-    2dup set-world-menu
-    2dup world-hand screen-loc swap set-gadget-loc
+    hide-glass
+    hand screen-loc over set-shape-loc
     show-glass ;
 
 : menu-item-border ( child -- border )
@@ -24,7 +17,7 @@ USING: generic kernel lists math namespaces sequences ;
 TUPLE: menu ;
 
 : menu-actions ( menu -- )
-    [ drop hide-menu ] [ button-down 1 ] set-action ;
+    [ drop world get hide-glass ] [ button-down 1 ] set-action ;
 
 : assoc>menu ( assoc menu -- )
     #! Given an association list mapping labels to quotations.

library/ui/paint.factor

@@ -4,6 +4,16 @@ IN: gadgets
 USING: generic hashtables kernel lists math namespaces sdl
 io strings sequences ;
 
+: redraw ( gadget -- )
+    #! Redraw a gadget before the next iteration of the event
+    #! loop.
+    dup gadget-redraw? [
+        drop
+    ] [
+        t over set-gadget-redraw?
+        gadget-parent [ redraw ] when*
+    ] ifte ;
+
 ! Clipping
 
 SYMBOL: clip

library/ui/panes.factor

@@ -73,9 +73,9 @@ M: pane focusable-child* ( pane -- editor )
     [ over pane-terpri pane-write ] [ 3drop ] ifte ;
 
 ! Panes are streams.
-M: pane stream-flush ( stream -- ) relayout ;
+M: pane stream-flush ( stream -- ) drop ;
 
-M: pane stream-auto-flush ( stream -- ) stream-flush ;
+M: pane stream-auto-flush ( stream -- ) drop ;
 
 M: pane stream-readln ( stream -- line )
     [ over set-pane-continuation stop ] callcc1 nip ;

library/ui/scrolling.factor

@@ -22,7 +22,8 @@ TUPLE: viewport origin ;
     [ fix-scroll ] keep [ set-viewport-origin ] keep relayout ;
 
 C: viewport ( content -- viewport )
-    [ <empty-gadget> swap set-delegate ] keep
+    <empty-gadget> over set-delegate
+    t over set-gadget-root?
     [ add-gadget ] keep
     { 0 0 0 } over set-viewport-origin ;
 
@@ -30,7 +31,7 @@ M: viewport pref-dim gadget-child pref-dim ;
 
 M: viewport layout* ( viewport -- )
     dup viewport-origin
-    swap gadget-child dup prefer set-gadget-loc ;
+    swap gadget-child dup prefer set-shape-loc ;
 
 M: viewport focusable-child* ( viewport -- gadget )
     gadget-child ;
@@ -73,6 +74,7 @@ TUPLE: slider viewport thumb vector ;
 
 : <thumb> ( -- thumb )
     <plain-gadget>
+    t over set-gadget-root?
     dup gray background set-paint-prop
     dup thumb-actions ;
 
@@ -105,7 +107,7 @@ M: slider pref-dim drop slider-dim ;
 
 M: slider layout* ( slider -- )
     dup thumb-loc over slider-vector v*
-    over slider-thumb set-gadget-loc
+    over slider-thumb set-shape-loc
     dup thumb-dim over slider-vector v* slider-dim vmax
     swap slider-thumb set-gadget-dim ;
 

library/ui/world.factor

@@ -7,24 +7,40 @@ threads sequences ;
 
 ! The world gadget is the top level gadget that all (visible)
 ! gadgets are contained in. The current world is stored in the
-! world variable. The menu slot ensures that only one menu is
-! open at any one time.
-TUPLE: world running? hand menu glass ;
+! world variable. The invalid slot is a list of gadgets that
+! need to be layout.
+TUPLE: world running? hand glass invalid ;
 
 C: world ( -- world )
     f <stack> over set-delegate
     t over set-world-running?
+    t over set-gadget-root?
     dup <hand> over set-world-hand ;
 
+: add-invalid ( gadget world -- )
+    [ world-invalid cons ] keep set-world-invalid ;
+
+: pop-invalid ( world -- list )
+    [ world-invalid f ] keep set-world-invalid ;
+
+: layout-world ( world -- )
+    dup world-invalid [
+        dup pop-invalid [ layout ] each layout-world
+    ] [
+        drop
+    ] ifte ;
+
 : add-layer ( gadget -- )
     world get add-gadget ;
 
-: show-glass ( gadget world -- )
-    >r <empty-gadget> [ add-gadget ] keep
-    r> 2dup set-world-glass add-gadget ;
+: show-glass ( gadget -- )
+    <empty-gadget> dup
+    world get 2dup add-gadget set-world-glass
+    add-gadget ;
 
-: hide-glass ( world -- )
-    [ world-glass unparent f ] keep set-world-glass ;
+: hide-glass ( -- )
+    world get world-glass unparent f
+    world get set-world-glass ;
 
 M: world inside? ( point world -- ? ) 2drop t ;
 
@@ -32,18 +48,16 @@ M: world inside? ( point world -- ? ) 2drop t ;
 
 : draw-world ( world -- )
     dup gadget-redraw? [
-        [ draw-gadget ] with-surface
+        [
+            dup 0 0 width get height get <rectangle> clip set-paint-prop
+            draw-gadget
+        ] with-surface
     ] [
         drop
     ] ifte ;
 
 DEFER: handle-event
 
-: layout-world ( world -- )
-    dup
-    0 0 width get height get <rectangle> clip set-paint-prop
-    layout ;
-
 : world-step ( world -- ? )
     world get dup world-running? [
         dup layout-world draw-world  t