text fields in the UI

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index 4f2f0aef39ca6ca51627129561c35d3b76e4ee24..0d0f43c90b887e2be6b6e9ca09de9eaadc00cad7 100644 (file)
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -8,8 +8,6 @@
 - special completion for USE:/IN:\r
 - vectors: ensure its ok with bignum indices\r
 - if gadgets are moved, added or deleted, update hand.\r
-- keyboard gestures\r
-- text fields\r
 - code gc\r
 - type inference fails with some assembler words;\r
   displaced, register and other predicates need to inherit from list\r
@@ -22,6 +20,11 @@
 - ppc register decls\r
 - rename f* words to stream-*\r
 \r
+- resize window: world not updated until mouse moved\r
+- x>offset\r
+- fix completion invoke in middle of word\r
+- html: word links\r
+- don't hardcode so many colors\r
 - ffi unicode strings: null char security hole\r
 - utf16 string boxing\r
 - slot compile problem\r

diff --git a/examples/gadget-test.factor b/examples/gadget-test.factor
index 8cea1637d4f8f2bf750a220bfceccd108505163b..dd53fab69b3aa0b994b7e31e34c14317d7436586 100644 (file)
--- a/examples/gadget-test.factor
+++ b/examples/gadget-test.factor
@@ -75,8 +75,8 @@ USE: words
     "Filled?" <checkbox> dup "filled" set "shelf" get add-gadget
     "shelf" get "pile" get add-gadget
     "Welcome to Factor " version cat2 <label> "pile" get add-gadget
-    "Welcome to Factor " version cat2 <field> "pile" get add-gadget
-    "Welcome to Factor " version cat2 <field> "pile" get add-gadget
+    "A field."  <field> "pile" get add-gadget
+    "Another field."  <field> "pile" get add-gadget
 
     "pile" get bevel-border dup "dialog" set dup  
  moving-actions

diff --git a/library/ui/buttons.factor b/library/ui/buttons.factor
index 683b49b7009783c9c3e3055071364797b899ddcd..f071c2db2649813a31d0b79247b53df61977c606 100644 (file)
--- a/library/ui/buttons.factor
+++ b/library/ui/buttons.factor
@@ -36,7 +36,7 @@ USING: generic kernel lists math namespaces sdl ;
     #! fire an action gesture.
     dup button-update
     dup mouse-over? [
-        [ action ] swap handle-gesture
+        [ action ] swap handle-gesture drop
     ] [
         drop
     ] ifte ;

diff --git a/library/ui/events.factor b/library/ui/events.factor
index c0994f910beaa5f144f6deb53fc93b519289a95f..c8ac076c811697e72efc19075e1a373f1b71f30f 100644 (file)
--- a/library/ui/events.factor
+++ b/library/ui/events.factor
@@ -19,7 +19,7 @@ M: resize-event handle-event ( event -- )
     world get redraw ;
 
 : button-gesture ( button gesture -- [ gesture button ] )
-    swap unit append my-hand hand-clicked handle-gesture ;
+    swap unit append my-hand hand-clicked handle-gesture drop ;
 
 M: button-down-event handle-event ( event -- )
     button-event-button dup my-hand button/
@@ -36,4 +36,13 @@ M: motion-event handle-event ( event -- )
     motion-event-pos my-hand move-hand ;
 
 M: key-down-event handle-event ( event -- )
-    keyboard-event>binding my-hand hand-focus handle-gesture ;
+    dup keyboard-event>binding
+    my-hand hand-focus handle-gesture [
+        keyboard-event-unicode dup 0 = [
+            drop
+        ] [
+            my-hand hand-focus user-input drop
+        ] ifte
+    ] [
+        drop
+    ] ifte ;

diff --git a/library/ui/fields.factor b/library/ui/fields.factor
index 73696f2693f7bb77ca9d670381ff6514149b1288..740ce9bf4bab4feab57acf0a70adcde4ae936865 100644 (file)
--- a/library/ui/fields.factor
+++ b/library/ui/fields.factor
@@ -1,11 +1,12 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
-USING: generic kernel lists math namespaces sdl line-editor ;
+USING: generic kernel lists math namespaces sdl line-editor
+strings ;
 
-TUPLE: field active? delegate ;
+TUPLE: field active? editor delegate ;
 
-TUPLE: editor line delegate ;
+TUPLE: editor line caret delegate ;
 
 : editor-text ( editor -- text )
     editor-line [ line-text get ] bind ;
@@ -13,13 +14,39 @@ TUPLE: editor line delegate ;
 : set-editor-text ( text editor -- )
     editor-line [ set-line-text ] bind ;
 
+: <caret> ( -- caret )
+    0 0 0 0 <plain-rect> <gadget>
+    dup red background set-paint-property ;
+
 C: editor ( text -- )
-    0 0 0 0 <rectangle> <gadget> over set-editor-delegate
+    0 0 0 0 <line> <gadget> over set-editor-delegate
     [ <line-editor> swap set-editor-line ] keep
+    [ <caret> swap set-editor-caret ] keep
     [ set-editor-text ] keep ;
 
-M: editor layout* ( label -- )
-    [ editor-text dup shape-w swap shape-h ] keep resize-gadget ;
+: focus-editor ( editor -- )
+    dup editor-caret over add-gadget
+    dup blue foreground set-paint-property relayout ;
+
+: unfocus-editor ( editor -- )
+    dup editor-caret unparent
+    dup black foreground set-paint-property relayout ;
+
+: offset>x ( offset editor -- x )
+    editor-line [ line-text get ] bind str-head
+    font get swap
+    size-string drop ;
+
+: caret-pos ( editor -- x y )
+    dup editor-line [ caret get ] bind swap offset>x 0 ;
+
+: caret-size ( editor -- w h )
+    0 swap shape-h ;
+
+M: editor layout* ( field -- )
+    dup [ editor-text dup shape-w swap shape-h ] keep resize-gadget
+    dup editor-caret over caret-size rot resize-gadget
+    dup editor-caret swap caret-pos rot move-gadget ;
 
 M: editor draw-shape ( label -- )
     dup [ editor-text draw-shape ] with-translation ;
@@ -27,12 +54,30 @@ M: editor draw-shape ( label -- )
 : field-border ( gadget -- border )
     bevel-border dup f bevel-up? set-paint-property ;
 
-C: field ( text -- field )
-    [ >r <editor> field-border r> set-field-delegate ] keep
+: 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 ;
+
+: click-field ( field -- )
+    my-hand request-focus ;
+
+: field-gestures ( -- hash )
     {{
-        [[ [ gain-focus ] [ dup blue foreground set-paint-property redraw ] ]]
-        [[ [ lose-focus ] [ dup black foreground set-paint-property redraw ] ]]
-        [[ [ button-down 1 ] [ my-hand request-focus ] ]]
-        [[ [ "RETURN" ] [ drop "foo!" USE: stdio print ] ]]
-        [[ [ "BACKSPACE" ] [ dup gadget-children car editor-line [ backspace ] bind redraw ] ]]
-    }} over set-gadget-gestures ;
+        [[ [ 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 ] ]]
+    }} ;
+
+C: field ( text -- field )
+    #! Note that we want the editor's parent to be the field,
+    #! not the border.
+    [ f field-border swap set-field-delegate ] keep
+    [ >r <editor> dup r> set-field-editor ] keep
+    [ add-gadget ] keep
+    [ field-gestures swap set-gadget-gestures ] keep ;

diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor
index 1683af160e282a66f12cf0bd923373e2889ccc59..20a8a55a2a6bd32e8aef426f4bd55e4b8204d41d 100644 (file)
--- a/library/ui/gadgets.factor
+++ b/library/ui/gadgets.factor
@@ -56,22 +56,24 @@ C: gadget ( shape -- gadget )
     tuck (add-gadget)
     relayout ;
 
-: each-parent ( gadget quot -- )
+: each-parent ( gadget quot -- ? )
     #! Apply quotation to each parent of the gadget in turn,
-    #! stopping when the quotation returns f.
+    #! 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
+            2drop f ( quotation returns f )
         ] ifte
     ] [ 
-        2drop
+        2drop t ( search bottomed out )
     ] ifte ; inline
 
 : screen-pos ( gadget -- point )
     #! The position of the gadget on the screen.
-    0 swap [ shape-pos + t ] each-parent ;
+    0 swap [ shape-pos + t ] each-parent drop ;
 
 : child? ( parent child -- ? )
     dup [

diff --git a/library/ui/gestures.factor b/library/ui/gestures.factor
index e4afe052e329d4a600afb2404e8b2a89acf9fbcd..cc243221f1a715b9b01ffddc2c219d007301414e 100644 (file)
--- a/library/ui/gestures.factor
+++ b/library/ui/gestures.factor
@@ -16,11 +16,18 @@ USING: alien generic hashtables kernel lists math sdl-event ;
         2drop t
     ] ifte ;
 
-: handle-gesture ( gesture gadget -- )
+: handle-gesture ( gesture gadget -- ? )
     #! If a gadget's handle-gesture* generic returns t, the
     #! event was not consumed and is passed on to the gadget's
-    #! parent.
-    [ dupd handle-gesture* ] each-parent drop ;
+    #! parent. This word returns t if no gadget handled the
+    #! gesture, otherwise returns f.
+    [ dupd handle-gesture* ] each-parent nip ;
+
+GENERIC: user-input* ( ch gadget -- ? )
+M: gadget user-input* 2drop f ;
+
+: user-input ( ch gadget -- ? )
+    [ dupd user-input* ] each-parent nip ;
 
 ! Mouse gestures are lists where the first element is one of:
 SYMBOL: motion
@@ -41,7 +48,7 @@ SYMBOL: button-down
     [
         [ shape-pos + ] keep
         2dup inside? [ mouse-enter ] hierarchy-gesture
-    ] each-parent drop ;
+    ] each-parent 2drop ;
 
 : mouse-leave ( point gadget -- )
     #! If the new point is inside the old gadget, do not fire a
@@ -50,7 +57,7 @@ SYMBOL: button-down
     [
         [ shape-pos + ] keep
         2dup inside? [ mouse-leave ] hierarchy-gesture
-    ] each-parent drop ;
+    ] each-parent 2drop ;
 
 : lose-focus ( new old -- )
     #! If the old focus owner is a child of the new owner, do
@@ -59,7 +66,7 @@ SYMBOL: button-down
     #! parent.
     [
         2dup child? [ lose-focus ] hierarchy-gesture
-    ] each-parent drop ;
+    ] each-parent 2drop ;
 
 : gain-focus ( old new -- )
     #! If the old focus owner is a child of the new owner, do
@@ -68,4 +75,4 @@ SYMBOL: button-down
     #! to the parent.
     [
         2dup child? [ gain-focus ] hierarchy-gesture
-    ] each-parent drop ;
+    ] each-parent 2drop ;

diff --git a/library/ui/hand.factor b/library/ui/hand.factor
index b6461eb1db3318d0c2c3c0ff1b16a9480bba0fc0..6fd738bab6a399b2dbbfeb0a8c4940642455b3a4 100644 (file)
--- a/library/ui/hand.factor
+++ b/library/ui/hand.factor
@@ -74,7 +74,7 @@ C: hand ( world -- hand )
     dup world get pick-up swap set-hand-gadget ;
 
 : fire-motion ( hand -- )
-    [ motion ] swap hand-gadget handle-gesture ;
+    [ motion ] swap hand-gadget handle-gesture drop ;
 
 : move-hand ( x y hand -- )
     dup shape-pos >r