layout alignments

TODO.FACTOR.txt

@@ -19,7 +19,6 @@
 
 - #jump-f #jump-f-label
 - extract word inside M:, C:, and structure browsing for these
-- fix checkbox alignment
 - each-slot combinator
 - references primitive
 - fix completion invoke in middle of word

examples/gadget-test.factor

@@ -66,8 +66,8 @@ USE: words
 : make-shapes ( -- )
     f world get set-gadget-children
     
-    default-gap <pile> "pile" set
+    0 default-gap <pile> "pile" set
-    default-gap <shelf> "shelf" set
+    <default-shelf> "shelf" set
     "Close" [ "dialog" get world get remove-gadget ] <button> "shelf" get add-gadget
     "New Rectangle" [ drop 100 100 100 100 <funny-rect> dup [ 255 255 0 ] background set-paint-property world get add-gadget ] <button> "shelf" get add-gadget
     "New Ellipse" [ drop 100 100 200 100 <funny-ellipse> dup [ 0 255 0 ] background set-paint-property world get add-gadget ] <button> "shelf" get add-gadget

library/ui/buttons.factor

@@ -75,7 +75,7 @@ TUPLE: checkbox bevel selected? delegate ;
     update-checkbox ;
 
 C: checkbox ( label -- checkbox )
-    default-gap <shelf> over set-checkbox-delegate
+    <default-shelf> over set-checkbox-delegate
     [ >r <label> r> add-gadget ] keep
     [ f bevel-border swap init-checkbox-bevel ] keep
     dup [ toggle-checkbox ] button-actions

library/ui/fields.factor

@@ -4,8 +4,6 @@ IN: gadgets
 USING: generic kernel lists math namespaces sdl line-editor
 strings ;
 
-TUPLE: field active? editor delegate ;
-
 TUPLE: editor line caret delegate ;
 
 : editor-text ( editor -- text )
@@ -69,32 +67,35 @@ M: editor layout* ( field -- )
 M: editor draw-shape ( label -- )
     dup [ editor-text draw-shape ] with-translation ;
 
+TUPLE: field active? editor delegate ;
+
+: with-editor ( editor quot -- )
+    swap [ editor-line swap bind ] keep relayout ; inline
+
+: set-caret-x ( x editor -- )
+    #! Move the caret to a clicked location.
+    [ line-text get x>offset caret set ] with-editor ;
+
+: click-editor ( editor -- )
+    my-hand
+    2dup relative-pos shape-x pick set-caret-x
+    request-focus ;
+
 : field-border ( gadget -- border )
     bevel-border dup f bevel-up? set-paint-property ;
 
-: with-field-editor ( field quot -- )
-    swap field-editor [ editor-line swap bind ] keep relayout ;
-
 M: field user-input* ( ch field -- ? )
-    [ insert-char ] with-field-editor f ;
+    field-editor [ insert-char ] with-editor f ;
-
-: set-caret-x ( x field -- )
-    #! Move the caret to a clicked location.
-    [ line-text get x>offset caret set ] with-field-editor ;
-
-: click-field ( field -- )
-    my-hand dup shape-x pick field-editor screen-pos shape-x -
-    pick set-caret-x  request-focus ;
 
 : field-gestures ( -- hash )
     {{
         [[ [ gain-focus ] [ field-editor focus-editor ] ]]
         [[ [ lose-focus ] [ field-editor unfocus-editor ] ]]
-        [[ [ button-down 1 ] [ click-field ] ]]
+        [[ [ button-down 1 ] [ field-editor click-editor ] ]]
-        [[ [ "BACKSPACE" ] [ [ backspace ] with-field-editor ] ]]
+        [[ [ "BACKSPACE" ] [ field-editor [ backspace ] with-editor ] ]]
-        [[ [ "LEFT" ] [ [ left ] with-field-editor ] ]]
+        [[ [ "LEFT" ] [ field-editor [ left ] with-editor ] ]]
-        [[ [ "RIGHT" ] [ [ right ] with-field-editor ] ]]
+        [[ [ "RIGHT" ] [ field-editor [ right ] with-editor ] ]]
-        [[ [ "CTRL" "k" ] [ [ line-clear ] with-field-editor ] ]]
+        [[ [ "CTRL" "k" ] [ field-editor [ line-clear ] with-editor ] ]]
     }} ;
 
 C: field ( text -- field )

library/ui/gadgets.factor

@@ -80,20 +80,8 @@ C: gadget ( shape -- gadget )
 : each-parent ( gadget quot -- ? )
     >r parent-list r> (each-parent) ; inline
 
-! : each-parent ( gadget quot -- ? )
+: relative-pos ( g1 g2 -- g2-p1 )
-!     #! Apply quotation to each parent of the gadget in turn,
+    shape-pos swap screen-pos - ;
-!     #! stopping when the quotation returns f. Return f if a
-!     #! quotation somewhere returned f; if the search bottoms
-!     #! out, return t.
-!     over [
-!         [ call ] 2keep rot [
-!             >r gadget-parent r> each-parent
-!         ] [
-!             2drop f ( quotation returns f )
-!         ] ifte
-!     ] [ 
-!         2drop t ( search bottomed out )
-!     ] ifte ; inline
 
 : screen-pos ( gadget -- point )
     #! The position of the gadget on the screen.

library/ui/layouts.factor

@@ -24,32 +24,48 @@ M: gadget layout* drop ;
 : default-gap 3 ;
 
 ! A pile is a box that lays out its contents vertically.
-TUPLE: pile gap delegate ;
+TUPLE: pile align gap delegate ;
 
-C: pile ( gap -- pile )
+C: pile ( align gap -- pile )
     0 0 0 0 <rectangle> <gadget> over set-pile-delegate
-    [ set-pile-gap ] keep ;
+    [ set-pile-gap ] keep
+    [ set-pile-align ] keep ;
+
+: <default-pile> ( -- pile )
+    1/2 default-gap <pile> ;
+
+: horizontal-layout ( gadget y box -- )
+    pick shape-w over shape-w swap - swap pile-align * >fixnum
+    swap rot move-gadget ;
 
 M: pile layout* ( pile -- )
     dup pile-gap over gadget-children run-heights >r >r
     dup gadget-children max-width r> pick resize-gadget
-    gadget-children r> zip [
+    dup gadget-children r> zip [
-        uncons 0 swap rot move-gadget
+        uncons rot horizontal-layout
-    ] each ;
+    ] each-with ;
 
 ! A shelf is a box that lays out its contents horizontally.
-TUPLE: shelf gap delegate ;
+TUPLE: shelf gap align delegate ;
 
-C: shelf ( gap -- pile )
+C: shelf ( align gap -- shelf )
     0 0 0 0 <rectangle> <gadget> over set-shelf-delegate
-    [ set-shelf-gap ] keep ;
+    [ set-shelf-gap ] keep
+    [ set-shelf-align ] keep ;
+
+: vertical-layout ( gadget x box -- )
+    pick shape-h over shape-h swap - swap shelf-align * >fixnum
+    rot move-gadget ;
+
+: <default-shelf> ( -- shelf )
+    1/2 default-gap <shelf> ;
 
 M: shelf layout* ( pile -- )
     dup shelf-gap over gadget-children run-widths >r >r
     dup gadget-children max-height r> swap pick resize-gadget
-    gadget-children r> zip [
+    dup gadget-children r> zip [
-        uncons 0 rot move-gadget
+        uncons pick vertical-layout
-    ] each ;
+    ] each drop ;
 
 ! A border lays out its children on top of each other, all with
 ! a 5-pixel padding.