some UI cleanups

TODO.FACTOR.txt

@@ -5,10 +5,17 @@
 - faster completion
 - [ [ dup call ] dup call ] infer hangs
 - code gc
-- don't hardcode so many colors
 - ffi unicode strings: null char security hole
 - utf16 string boxing
 
++ ui:
+
+- fix up the min thumb size hack
+- fix up initial layout of slider
+- clicking in scroll bar: jump
+- clicking thumb: drag
+- console: scroll to bottom
+
 + compiler/ffi:
 
 - more accurate types for various words
@@ -31,6 +38,8 @@
 
 + i/o:
 
+- udp
+- ipv6
 - stream server can hang because of exception handler limitations
 - better i/o scheduler
 - nicer way to combine two paths

examples/gadget-test.factor

@@ -48,15 +48,6 @@ USE: words
 : <funny-line>
     <line> <gadget> dup moving-actions ;
 
-: junk
-    <pane>
-    dup [
-        [
-            print-banner
-            listener
-        ] in-thread
-    ] with-stream ;
-
 
 : make-shapes ( -- )
     f world get set-gadget-children
@@ -73,7 +64,7 @@ USE: words
 !    "Welcome to Factor " version cat2 <label> "pile" get add-gadget
 !    "A field."  <field> "pile" get add-gadget
 !    "Another field."  <field> "pile" get add-gadget
-    junk <scroller> "pile" get add-gadget
+    <console-pane> <scroller> "pile" get add-gadget
 
     "pile" get bevel-border dup "dialog" set ! dup  
 ! moving-actions

library/ui/buttons.factor

@@ -14,12 +14,6 @@ USING: generic kernel lists math namespaces sdl ;
 
 : mouse-over? ( gadget -- ? ) my-hand hand-gadget child? ;
 
-: button-rollover? ( button -- ? )
-    mouse-over? 1 button-down? not and ;
-
-: rollover-update ( button -- )
-    dup button-rollover? blue black ? foreground set-paint-property ;
-
 : button-pressed? ( button -- ? )
     #! Return true if the mouse was clicked on the button, and
     #! is currently over the button.
@@ -33,11 +27,8 @@ USING: generic kernel lists math namespaces sdl ;
         drop f
     ] ifte ;
 
-: bevel-update ( button -- )
-    dup button-pressed? not bevel-up? set-paint-property ;
-
 : button-update ( button -- )
-    dup rollover-update dup bevel-update redraw ;
+    dup button-pressed? not bevel-up? set-paint-property redraw ;
 
 : button-clicked ( button -- )
     #! If the mouse is released while still inside the button,

library/ui/editors.factor

@@ -56,7 +56,7 @@ TUPLE: editor line caret delegate ;
     2dup relative shape-x pick set-caret-x
     request-focus ;
 
-: editor-gestures ( -- hash )
+: editor-actions ( editor -- )
     {{
         [[ [ gain-focus ] [ focus-editor ] ]]
         [[ [ lose-focus ] [ unfocus-editor ] ]]
@@ -65,7 +65,7 @@ TUPLE: editor line caret delegate ;
         [[ [ "LEFT" ] [ [ left ] with-editor ] ]]
         [[ [ "RIGHT" ] [ [ right ] with-editor ] ]]
         [[ [ "CTRL" "k" ] [ [ line-clear ] with-editor ] ]]
-    }} ;
+    }} clone swap set-gadget-gestures ;
 
 : <caret> ( -- caret )
     0 0 0 0 <plain-rect> <gadget>
@@ -76,7 +76,7 @@ C: editor ( text -- )
     [ <line-editor> swap set-editor-line ] keep
     [ <caret> swap set-editor-caret ] keep
     [ set-editor-text ] keep
-    [ editor-gestures swap set-gadget-gestures ] keep ;
+    dup editor-actions ;
 
 : offset>x ( offset str -- x )
     str-head font get swap size-string drop ;

library/ui/paint.factor

@@ -158,10 +158,21 @@ SYMBOL: clip
     #! the second is screen.
     [ intersect-x ] 2keep intersect-y clip-rect ;
 
+: set-clip ( rect -- ? )
+    #! The top/left corner of the clip rectangle is the location
+    #! of the gadget on the screen. The bottom/right is the
+    #! intersected clip rectangle. Return t if the clip region
+    #! is an empty region.
+    surface get swap [ >sdl-rect SDL_SetClipRect drop ] keep
+    dup shape-w 0 = swap shape-h 0 = or ;
+
 : with-clip ( shape quot -- )
-    #!  All drawing done inside the quotation is clipped to the
-    #! shape's bounds.
-    [ >r clip [ intersect ] change r> call ] with-scope ; inline
+    #! All drawing done inside the quotation is clipped to the
+    #! shape's bounds. The quotation is called with a boolean
+    #! that is set to false if 
+    [
+        >r clip [ intersect dup ] change set-clip r> call
+    ] with-scope ; inline
 
 : >sdl-rect ( rectangle -- sdlrect )
     [ rectangle-x ] keep
@@ -170,22 +181,19 @@ SYMBOL: clip
     rectangle-h
     make-rect ;
 
-: set-clip ( -- )
-    #! The top/left corner of the clip rectangle is the location
-    #! of the gadget on the screen. The bottom/right is the
-    #! intersected clip rectangle.
-    surface get clip get >sdl-rect SDL_SetClipRect drop ;
-
 : draw-gadget ( gadget -- )
     #! All drawing done inside draw-shape is done with the
     #! gadget's paint. If the gadget does not have any custom
     #! paint, just call the quotation.
     dup gadget-paint [
         dup [
-            set-clip
-            dup draw-shape
-            dup [
-                gadget-children [ draw-gadget ] each
-            ] with-trans
+            [
+                drop
+            ] [
+                dup draw-shape
+                dup [
+                    gadget-children [ draw-gadget ] each
+                ] with-trans
+            ] ifte
         ] with-clip
     ] bind ;

library/ui/panes.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
-USING: kernel line-editor lists namespaces streams strings
-threads ;
+USING: kernel line-editor listener lists namespaces stdio
+streams strings threads ;
 
 ! A pane is an area that can display text.
 
@@ -30,9 +30,12 @@ TUPLE: pane output current input continuation delegate ;
     pane-continuation call ;
  
 : pane-actions ( line -- )
-    dup
-    [ pane-input click-editor ] [ button-down 1 ] set-action
-    [ pane-return ] [ "RETURN" ] set-action ;
+    {{
+        [[ [ button-down 1 ] [ pane-input click-editor ] ]]
+        [[ [ "RETURN" ] [ pane-return ] ]]
+        [[ [ "UP" ] [ pane-input [ history-prev ] with-editor ] ]]
+        [[ [ "DOWN" ] [ pane-input [ history-next ] with-editor ] ]]
+    }} clone swap set-gadget-gestures ;
 
 C: pane ( -- pane )
     <line-pile> over set-pane-delegate
@@ -72,3 +75,8 @@ M: pane stream-write-attr ( string style stream -- )
     nip swap "\n" split pane-write ;
 
 M: pane stream-close ( stream -- ) drop ;
+
+: <console-pane> ( -- pane )
+    <pane> dup [
+        [ print-banner listener ] in-thread
+    ] with-stream ;

library/ui/scrolling.factor

@@ -5,19 +5,6 @@ USING: kernel lists math namespaces threads ;
 
 TUPLE: viewport x y delegate ;
 
-C: viewport ( content -- viewport )
-    [ <empty-gadget> swap set-viewport-delegate ] keep
-    [ add-gadget ] keep
-    0 over set-viewport-x
-    0 over set-viewport-y
-    640 480 pick resize-gadget ;
-
-M: viewport layout* ( viewport -- )
-    dup gadget-children [
-        >r dup viewport-x swap viewport-y r>
-        move-gadget
-    ] each-with ;
-
 : viewport-h ( viewport -- h ) gadget-children max-height ;
 : viewport-w ( viewport -- w ) gadget-children max-width ;
 
@@ -33,6 +20,31 @@ M: viewport layout* ( viewport -- )
     [ set-viewport-y ] keep
     relayout ;
 
+: scroll>bottom ( viewport -- )
+    1 swap scroll-viewport ;
+
+: viewport-actions ( viewport -- )
+    {{
+        [[ [ scroll>bottom ] [ scroll>bottom ] ]]
+    }} clone swap set-gadget-gestures ;
+
+C: viewport ( content -- viewport )
+    [ <empty-gadget> swap set-viewport-delegate ] keep
+    [ add-gadget ] keep
+    0 over set-viewport-x
+    0 over set-viewport-y
+    dup viewport-actions
+    640 480 pick resize-gadget ;
+
+M: viewport layout* ( viewport -- )
+    dup gadget-children [
+        >r dup viewport-x swap viewport-y r>
+        move-gadget
+    ] each-with ;
+
+: scroll>bottom ( viewport -- )
+    dup viewport-h swap scroll-viewport ;
+
 ! A slider scrolls a viewport.
 
 ! The offset slot is the y co-ordinate of the mouse relative to
@@ -106,4 +118,3 @@ C: scroller ( gadget -- scroller )
     [ <default-shelf> swap set-scroller-delegate ] keep
     [ >r <viewport> r> add-viewport ] keep
     [ dup scroller-viewport <slider> swap add-slider ] keep ;
-