From 8d139c621af8946eb9727877ab2b6a48b2a330f3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 20 Feb 2005 00:57:26 +0000
Subject: [PATCH] layout alignments

---
 TODO.FACTOR.txt             |  1 -
 examples/gadget-test.factor |  4 ++--
 library/ui/buttons.factor   |  2 +-
 library/ui/fields.factor    | 39 ++++++++++++++++++------------------
 library/ui/gadgets.factor   | 16 ++-------------
 library/ui/layouts.factor   | 40 ++++++++++++++++++++++++++-----------
 6 files changed, 53 insertions(+), 49 deletions(-)

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index 9d68ae5aee..2f668bcd31 100644
--- a/TODO.FACTOR.txt
+++ b/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
diff --git a/examples/gadget-test.factor b/examples/gadget-test.factor
index 7a46689dc9..b1bd2a1a7f 100644
--- a/examples/gadget-test.factor
+++ b/examples/gadget-test.factor
@@ -66,8 +66,8 @@ USE: words
 : make-shapes ( -- )
     f world get set-gadget-children
     
-    default-gap <pile> "pile" set
-    default-gap <shelf> "shelf" set
+    0 default-gap <pile> "pile" 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
diff --git a/library/ui/buttons.factor b/library/ui/buttons.factor
index 99aa6ffd91..fbb118179a 100644
--- a/library/ui/buttons.factor
+++ b/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
diff --git a/library/ui/fields.factor b/library/ui/fields.factor
index 4f8c1e2102..4843891ab6 100644
--- a/library/ui/fields.factor
+++ b/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 ;
-
-: 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-editor [ insert-char ] with-editor f ;
 
 : field-gestures ( -- hash )
     {{
         [[ [ gain-focus ] [ field-editor focus-editor ] ]]
         [[ [ lose-focus ] [ field-editor unfocus-editor ] ]]
-        [[ [ button-down 1 ] [ click-field ] ]]
-        [[ [ "BACKSPACE" ] [ [ backspace ] with-field-editor ] ]]
-        [[ [ "LEFT" ] [ [ left ] with-field-editor ] ]]
-        [[ [ "RIGHT" ] [ [ right ] with-field-editor ] ]]
-        [[ [ "CTRL" "k" ] [ [ line-clear ] with-field-editor ] ]]
+        [[ [ button-down 1 ] [ field-editor click-editor ] ]]
+        [[ [ "BACKSPACE" ] [ field-editor [ backspace ] with-editor ] ]]
+        [[ [ "LEFT" ] [ field-editor [ left ] with-editor ] ]]
+        [[ [ "RIGHT" ] [ field-editor [ right ] with-editor ] ]]
+        [[ [ "CTRL" "k" ] [ field-editor [ line-clear ] with-editor ] ]]
     }} ;
 
 C: field ( text -- field )
diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor
index 8b2ec6ddca..13a2093ece 100644
--- a/library/ui/gadgets.factor
+++ b/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 -- ? )
-!     #! Apply quotation to each parent of the gadget in turn,
-!     #! 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
+: relative-pos ( g1 g2 -- g2-p1 )
+    shape-pos swap screen-pos - ;
 
 : screen-pos ( gadget -- point )
     #! The position of the gadget on the screen.
diff --git a/library/ui/layouts.factor b/library/ui/layouts.factor
index c2dfe3d378..45af8449cb 100644
--- a/library/ui/layouts.factor
+++ b/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 [
-        uncons 0 swap rot move-gadget
-    ] each ;
+    dup gadget-children r> zip [
+        uncons rot horizontal-layout
+    ] 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 [
-        uncons 0 rot move-gadget
-    ] each ;
+    dup gadget-children r> zip [
+        uncons pick vertical-layout
+    ] each drop ;
 
 ! A border lays out its children on top of each other, all with
 ! a 5-pixel padding.