layouts

TODO.FACTOR.txt

@@ -16,6 +16,9 @@
 - doc comments of generics
 - proper ordering for classes
 - tuples: in/out syntax
+- tuples: gracefully handle changing shape
+- keep a list of getter/setter words
+- default constructor
 
 + ffi:
 
@@ -31,6 +34,7 @@
 
 + listener/plugin:
 
+- command to turn repl session into a source file
 - update plugin docs
 - extract word keeps indent
 - word preview for remote words

library/bootstrap/boot-stage2.factor

@@ -159,7 +159,8 @@ cpu "x86" = [
         "/library/ui/gestures.factor"
         "/library/ui/hand.factor"
         "/library/ui/world.factor"
-        "/library/ui/label.factor"
+        "/library/ui/labels.factor"
+        "/library/ui/piles.factor"
         "/library/ui/events.factor"
     ] [
         dup print

library/ui/boxes.factor

@@ -4,11 +4,13 @@ IN: gadgets
 USING: generic hashtables kernel lists namespaces ;
 
 ! A box is a gadget holding other gadgets.
-TUPLE: box contents delegate ;
+TUPLE: box children delegate ;
 
 C: box ( gadget -- box )
     [ set-box-delegate ] keep ;
 
+M: box gadget-children box-children ;
+
 M: general-list draw ( list -- )
     [ draw ] each ;
 
@@ -17,7 +19,7 @@ M: box draw ( box -- )
         dup [
             dup
             box-delegate draw
-            box-contents draw
+            box-children draw
         ] with-gadget
     ] with-translation ;
 
@@ -37,25 +39,23 @@ M: box pick-up* ( point box -- gadget )
     #! box, return f. Otherwise, see if the point is contained
     #! in any subgadget. If not, see if it is contained in the
     #! box delegate.
-    dup [
+    2dup inside? [
-        2dup inside? [
+        2dup [ translate ] keep box-children pick-up dup [
-            2dup box-contents pick-up dup [
+            2nip
-                2nip
-            ] [
-                drop box-delegate pick-up*
-            ] ifte
         ] [
-            2drop f
+            drop box-delegate pick-up*
         ] ifte
-    ] with-translation ;
+    ] [
+        2drop f
+    ] ifte ;
 
 : box- ( gadget box -- )
-    [ 2dup box-contents remq swap set-box-contents ] keep
+    [ 2dup box-children remq swap set-box-children ] keep
-    redraw
+    relayout
     f swap set-gadget-parent ;
 
 : (box+) ( gadget box -- )
-    [ box-contents cons ] keep set-box-contents ;
+    [ box-children cons ] keep set-box-children ;
 
 : unparent ( gadget -- )
     dup gadget-parent dup [ box- ] [ 2drop ] ifte ;
@@ -65,4 +65,4 @@ M: box pick-up* ( point box -- gadget )
     over unparent
     dup pick set-gadget-parent
     tuck (box+)
-    redraw ;
+    relayout ;

library/ui/gadgets.factor

@@ -3,6 +3,11 @@
 IN: gadgets
 USING: generic hashtables kernel lists namespaces ;
 
+! 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 parent relayout? redraw? delegate ;
+
 ! Gadget protocol.
 GENERIC: pick-up* ( point gadget -- gadget/t )
 
@@ -11,15 +16,31 @@ GENERIC: pick-up* ( point gadget -- gadget/t )
     #! exposed facade issue.
     tuck pick-up* dup t = [ drop ] [ nip ] ifte ;
 
-! A gadget is a shape, a paint, a mapping of gestures to
+GENERIC: gadget-children ( gadget -- list )
-! actions, and a reference to the gadget's parent. A gadget
+M: gadget gadget-children drop f ;
-! delegates to its shape.
+
-TUPLE: gadget paint gestures parent delegate ;
+GENERIC: layout* ( gadget -- )
+M: gadget layout* drop ;
+
+: layout ( gadget -- )
+    #! Set the gadget's width and height to its preferred width
+    #! and height. The gadget's children are laid out first.
+    #! Note that nothing is done if the gadget does not need to
+    #! be laid out.
+    dup gadget-relayout? [
+        f over set-gadget-relayout?
+        dup gadget-children [ layout ] each
+        layout*
+    ] [
+        drop
+    ] ifte ;
 
 C: gadget ( shape -- gadget )
     [ set-gadget-delegate ] keep
     [ <namespace> swap set-gadget-paint ] keep
-    [ <namespace> swap set-gadget-gestures ] keep ;
+    [ <namespace> swap set-gadget-gestures ] keep
+    [ t swap set-gadget-relayout? ] keep
+    [ t swap set-gadget-redraw? ] keep ;
 
 : paint-property ( gadget key -- value )
     swap gadget-paint hash ;
@@ -43,7 +64,19 @@ M: gadget draw ( gadget -- ) drop ;
 
 M: gadget pick-up* inside? ;
 
-DEFER: redraw ( gadget -- )
+: redraw ( gadget -- )
+    #! Redraw a gadget before the next iteration of the event
+    #! loop.
+    t over set-gadget-redraw?
+    gadget-parent [ redraw ] when* ;
+
+: relayout ( gadget -- )
+    #! Relayout a gadget before the next iteration of the event
+    #! loop. Since relayout also implies the visual
+    #! representation changed, we redraw the gadget too.
+    t over set-gadget-redraw?
+    t over set-gadget-relayout?
+    gadget-parent [ relayout ] when* ;
 
 : move-gadget ( x y gadget -- )
     [ move-shape ] keep

library/ui/gestures.factor

@@ -24,10 +24,6 @@ USING: alien generic hashtables kernel lists sdl-event ;
         2drop
     ] ifte ;
 
-! Redraw gesture. Don't handle this yourself.
-: redraw ( gadget -- )
-    \ redraw swap handle-gesture ;
-
 ! Mouse gestures are lists where the first element is one of:
 SYMBOL: motion
 SYMBOL: button-up

library/ui/labels.factor

@@ -7,18 +7,17 @@ USING: generic kernel lists math namespaces sdl ;
 ! box.
 TUPLE: label text delegate ;
 
-: size-label ( label -- )
+C: label ( text -- )
+    0 0 0 0 <rectangle> <gadget> over set-label-delegate
+    [ set-label-text ] keep ;
+
+M: label layout* ( label -- )
     [
         dup label-text swap gadget-paint
         [ font get lookup-font ] bind
         swap size-string
     ] keep resize-gadget ;
 
-C: label ( text -- )
-    0 0 0 0 <rectangle> <gadget> over set-label-delegate
-    [ set-label-text ] keep
-    [ size-label ] keep ;
-
 M: label draw ( label -- )
     dup shape-x x get +
     over shape-y y get +

library/ui/piles.factor

@@ -0,0 +1,17 @@
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: gadgets
+USING: generic hashtables kernel lists math namespaces ;
+
+! A pile is a box that lays out its contents vertically.
+TUPLE: pile delegate ;
+
+C: pile ( gadget -- pile )
+    [ >r <box> r> set-pile-delegate ] keep ;
+
+M: pile layout* ( pile -- )
+    dup gadget-children run-heights >r >r
+    dup gadget-children max-width r> pick resize-gadget
+    gadget-children r> zip [
+        uncons 0 swap rot move-gadget
+    ] each ;

library/ui/shapes.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
-USING: generic kernel math namespaces ;
+USING: generic kernel lists math namespaces ;
 
 ! Shape protocol. Shapes are immutable; moving or resizing a
 ! shape makes a new shape.
@@ -33,6 +33,21 @@ GENERIC: resize-shape ( w h shape -- shape )
         r> call
     ] with-scope ; inline
 
+: translate ( point shape -- point )
+    #! Translate a point relative to the shape.
+    #! The rect>'ing of the given point won't be necessary as
+    #! soon as all generics delegate.
+    >r dup shape-x swap shape-y rect> r>
+    dup shape-x swap shape-y rect> - ;
+
+: max-width ( list -- n )
+    #! The width of the widest shape.
+    [ shape-w ] map [ > ] top ;
+
+: run-heights ( list -- h list )
+    #! Compute a list of accumilative sums of heights of shapes.
+    [ 0 swap [ over , shape-h + ] each ] make-list ;
+
 ! A point, represented as a complex number, is the simplest type
 ! of shape.
 M: number inside? = ;

library/ui/world.factor

@@ -7,7 +7,7 @@ sdl-video ;
 ! The world gadget is the top level gadget that all (visible)
 ! gadgets are contained in. The current world is stored in the
 ! world variable.
-TUPLE: world running? hand delegate redraw? ;
+TUPLE: world running? hand delegate ;
 
 : <world-box> ( -- box )
     0 0 0 0 <rectangle> <everywhere> <stamp>
@@ -18,15 +18,14 @@ TUPLE: world running? hand delegate redraw? ;
 C: world ( -- world )
     <world-box> over set-world-delegate
     t over set-world-running?
-    t over set-world-redraw?
     dup <hand> over set-world-hand ;
 
 : my-hand ( -- hand ) world get world-hand ;
 
 : draw-world ( -- )
-    world get dup world-redraw? [
+    world get dup gadget-redraw? [
         [
-            f over set-world-redraw?
+            f over set-gadget-redraw?
             dup draw
             world-hand draw
         ] with-surface
@@ -36,10 +35,12 @@ C: world ( -- world )
 
 DEFER: handle-event
 
+: layout-world world get layout ;
+
 : run-world ( -- )
     world get world-running? [
         <event> dup SDL_WaitEvent 1 = [
-            handle-event draw-world run-world
+            handle-event draw-world layout-world run-world
         ] [
             drop
         ] ifte
@@ -47,8 +48,6 @@ DEFER: handle-event
 
 : init-world ( w h -- )
     t world get set-world-running?
-    t world get set-world-redraw?
-    world get [ t swap set-world-redraw? ] \ redraw set-action
     world get resize-gadget ;
 
 : world-flags SDL_HWSURFACE SDL_RESIZABLE bitor ;