arrows in the UI, and various cleanups

TODO.FACTOR.txt

@@ -17,11 +17,15 @@
 
 + ui:
 
+- tabular output
+- arrows in outliner and scrollbars
+- completion
+- debugger should use outlining
+- support nested incremental layouts more efficiently
 - make-pane should not need world-theme
 - fix up the min thumb size hack
 - long lines of text fail in draw-surface
 - only redraw dirty gadgets
-- faster mouse tracking
 - off-by-one error in pick-up?
 - closing ui does not stop timers
 - adding/removing timers automatically for animated gadgets

library/help/tutorial.factor

@@ -33,8 +33,8 @@ M: general-list tutorial-line
 
 : <page> ( list -- gadget )
     [ tutorial-line ] map
-    <pile> 1 over set-pack-fill [ add-gadgets ] keep
+    make-pile 1 over set-pack-fill
-    empty-border ;
+    gap-border ;
 
 : tutorial-pages
     [

library/styles.factor

@@ -4,7 +4,9 @@ IN: styles
 
 ! Colors are RGB triples.
 : black      @{ 0   0   0   }@ ;
+: dark-gray  @{ 64  64  64  }@ ;
 : gray       @{ 128 128 128 }@ ;
+: light-gray @{ 192 192 192 }@ ;
 : white      @{ 255 255 255 }@ ;
 : red        @{ 255 0   0   }@ ;
 : green      @{ 0   255 0   }@ ;

library/test/errors.factor

@@ -14,7 +14,7 @@ USE: memory
 
 [ t ] [
     [ "Hello" throw ] catch drop
-    global [ "error" get ] bind
+    global [ error get ] bind
     "Hello" =
 ] unit-test
 

library/tools/debugger.factor

@@ -5,6 +5,9 @@ USING: generic inspector kernel kernel-internals lists math
 namespaces parser prettyprint sequences io sequences-internals
 strings vectors words ;
 
+SYMBOL: error
+SYMBOL: error-continuation
+
 : expired-error. ( obj -- )
     "Object did not survive image save/load: " write . ;
 
@@ -100,10 +103,12 @@ M: string error. ( error -- ) print ;
 
 M: object error. ( error -- ) . ;
 
-: :s ( -- ) "error-datastack" get stack. ;
+: :s ( -- ) error-continuation get continuation-data stack. ;
-: :r ( -- ) "error-callstack" get stack. ;
 
-: :get ( var -- value ) "error-namestack" get (get) ;
+: :r ( -- ) error-continuation get continuation-call stack. ;
+
+: :get ( var -- value )
+    error-continuation get continuation-name (get) ;
 
 : debug-help ( -- )
     ":s :r show stacks at time of error." print
@@ -122,21 +127,10 @@ M: object error. ( error -- ) . ;
     #! and return to the caller.
     [ print-error debug-help ] recover ;
 
-: save-error ( error ds rs ns cs -- )
+: save-error ( error continuation -- )
-    #! Save the stacks and parser state for post-mortem
+    global [ error-continuation set error set ] bind ;
-    #! inspection after an error.
-    global [
-        "error-catchstack" set
-        "error-namestack" set
-        "error-callstack" set
-        "error-datastack" set
-        "error" set
-    ] bind ;
 
 : init-error-handler ( -- )
     ( kernel calls on error )
-    [
+    [ dup continuation save-error rethrow ] 5 setenv
-        datastack dupd callstack namestack catchstack
-        save-error rethrow
-    ] 5 setenv
     kernel-error 12 setenv ;

library/tools/describe.factor

@@ -51,9 +51,6 @@ DEFER: describe
     #! Outlining word browser.
     vocabs [ f over [ words. ] curry write-outliner ] each ;
 
-: stack. ( seq -- seq )
-    reverse-slice >array describe ;
-
 : usage. ( word -- )
     #! Outlining usages browser.
     usage [ usage. ] object-outline ;
@@ -62,5 +59,8 @@ DEFER: describe
     #! Outlining call hierarchy browser.
     uses [ uses. ] object-outline ;
 
+: stack. ( seq -- seq )
+    reverse-slice >array describe ;
+
 : .s datastack stack. ;
 : .r callstack stack. ;

library/ui/books.factor

@@ -2,24 +2,17 @@
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets-books
 USING: gadgets gadgets-buttons gadgets-labels gadgets-layouts
-generic kernel lists math matrices sequences ;
+generic kernel lists math matrices namespaces sequences ;
 
 TUPLE: book page ;
 
 C: book ( pages -- book )
-    <gadget> over set-delegate
+    <stack> over set-delegate
-    0 over set-book-page
+    0 over set-book-page [ add-gadgets ] keep ;
-    [ add-gadgets ] keep ;
-
-M: book pref-dim ( book -- dim )
-    gadget-children [ pref-dim ] map @{ 0 0 0 }@ [ vmax ] reduce ;
 
 M: book layout* ( book -- )
-    dup rect-dim over gadget-children [
+    dup delegate layout*
-        f over set-gadget-visible?
+    dup gadget-children [ f swap set-gadget-visible? ] each
-        @{ 0 0 0 }@ over set-rect-loc
-        set-gadget-dim
-    ] each-with
     dup book-page swap gadget-children nth
     [ t swap set-gadget-visible? ] when* ;
 
@@ -42,12 +35,11 @@ TUPLE: book-browser book ;
 
 : <book-buttons> ( book -- gadget )
     [
-        { "|<" [ find-book first-page ] }
+        |left  <polygon-gadget> [ find-book first-page ] <button> ,
-        { "<"  [ find-book prev-page  ] }
+        left   <polygon-gadget> [ find-book prev-page  ] <button> ,
-        { ">"  [ find-book next-page  ] }
+        right  <polygon-gadget> [ find-book next-page  ] <button> ,
-        { ">|" [ find-book last-page  ] }
+        right| <polygon-gadget> [ find-book last-page  ] <button> ,
-    ] [ first2 >r <label> r> <button> ] map
+    ] { } make make-shelf ;
-    <shelf> [ add-gadgets ] keep ;
 
 C: book-browser ( book -- gadget )
     <frame> over set-delegate

library/ui/borders.factor

@@ -6,19 +6,24 @@ math namespaces vectors ;
 
 TUPLE: border size ;
 
-C: border ( child delegate size -- border )
+C: border ( delegate size -- border )
     [ set-border-size ] keep
-    [ set-delegate ] keep
+    [ set-delegate ] keep ;
-    [ add-gadget ] keep ;
+
+: make-border ( child delegate size -- boder )
+    <border> [ add-gadget ] keep ;
 
 : empty-border ( child -- border )
-    <gadget> @{ 5 5 0 }@ <border> ;
+    <gadget> @{ 0 0 0 }@ make-border ;
+
+: gap-border ( child -- border )
+    <gadget> @{ 5 5 0 }@ make-border ;
 
 : line-border ( child -- border )
-    <etched-gadget> @{ 5 5 0 }@ <border> ;
+    <etched-gadget> @{ 5 5 0 }@ make-border ;
 
 : bevel-border ( child -- border )
-    <bevel-gadget> @{ 5 5 0 }@ <border> ;
+    <bevel-gadget> @{ 5 5 0 }@ make-border ;
 
 : layout-border-loc ( border -- )
     dup border-size swap gadget-child set-rect-loc ;

library/ui/buttons.factor

@@ -11,12 +11,8 @@ lists math namespaces sdl sequences sequences styles threads ;
 : button-pressed? ( button -- ? )
     #! Return true if the mouse was clicked on the button, and
     #! is currently over the button.
-    dup mouse-over? [
+    dup mouse-over? 1 button-down? and
-        1 button-down?
+    [ hand hand-clicked child? ] [ drop f ] if ;
-        [ hand hand-clicked child? ] [ drop f ] if
-    ] [
-        drop f
-    ] if ;
 
 : button-update ( button -- )
     dup dup mouse-over? rollover set-paint-prop
@@ -52,11 +48,12 @@ lists math namespaces sdl sequences sequences styles threads ;
 TUPLE: button ;
 
 C: button ( gadget quot -- button )
-    rot bevel-border over set-delegate
+    <bevel-gadget> @{ 5 5 0 }@ <border> over set-delegate
-    dup button-theme [ swap button-gestures ] keep ;
+    dup button-theme [ swap button-gestures ] keep
+    [ add-gadget ] keep ;
 
 : <roll-button> ( gadget quot -- button )
-    >r dup roll-button-theme dup r> button-gestures ;
+    >r empty-border dup roll-button-theme dup r> button-gestures ;
 
 : repeat-button-down ( button -- )
     dup 100 add-timer button-clicked ;

library/ui/editors.factor

@@ -74,7 +74,8 @@ TUPLE: editor line caret ;
         [[ [ gain-focus ] [ focus-editor ] ]]
         [[ [ lose-focus ] [ unfocus-editor ] ]]
         [[ [ button-down 1 ] [ click-editor ] ]]
-        [[ [ "BACKSPACE" ] [ [ backspace ] with-editor ] ]]
+        [[ [ "BACKSPACE" ] [ [ delete-prev ] with-editor ] ]]
+        [[ [ "DELETE" ] [ [ delete-next ] with-editor ] ]]
         [[ [ "LEFT" ] [ [ left ] with-editor ] ]]
         [[ [ "RIGHT" ] [ [ right ] with-editor ] ]]
         [[ [ "CTRL" "k" ] [ [ line-clear ] with-editor ] ]]

library/ui/frames.factor

@@ -33,7 +33,7 @@ C: frame ( -- frame )
 : get-bottom ( frame -- gadget ) 1 2 frame-child ;
 
 : reduce-grid ( grid -- seq )
-    [ @{ 0 0 0 }@ [ vmax ] reduce ] map ;
+    [ max-dim ] map ;
 
 : frame-pref-dim ( grid -- dim )
     reduce-grid @{ 0 0 0 }@ [ v+ ] reduce ;

library/ui/gadgets.factor

@@ -21,9 +21,11 @@ M: array rect-dim drop @{ 0 0 0 }@ ;
 : >absolute ( rect -- rect )
     rect-bounds >r origin get v+ r> <rect> ;
 
+: |v-| ( vec vec -- vec ) v- [ 0 max ] map ;
+
 : intersect ( rect rect -- rect )
     [ rect-extent ] 2apply swapd vmin >r vmax dup r>
-    swap v- @{ 0 0 0 }@ vmax <rect> ;
+    swap |v-| <rect> ;
 
 : intersects? ( rect/point rect -- ? )
     [ rect-extent ] 2apply swapd vmin >r vmax r> v-
@@ -73,3 +75,5 @@ M: gadget children-on ( rect/point gadget -- list )
             [ nip pick-up ] [ rot 2drop ] if
         ] with-scope
     ] [ 2drop f ] if ;
+
+: max-dim ( dims -- dim ) @{ 0 0 0 }@ [ vmax ] reduce ;

library/ui/layouts.factor

@@ -98,13 +98,16 @@ C: pack ( vector -- pack )
 
 : <pile> ( -- pack ) @{ 0 1 0 }@ <pack> ;
 
+: make-pile ( children -- pack ) <pile> [ add-gadgets ] keep ;
+
 : <shelf> ( -- pack ) @{ 1 0 0 }@ <pack> ;
 
+: make-shelf ( children -- pack ) <shelf> [ add-gadgets ] keep ;
+
 M: pack pref-dim ( pack -- dim )
     [
         [
-            pref-dims
+            pref-dims [ max-dim ] keep
-            [ @{ 0 0 0 }@ [ vmax ] reduce ] keep
             [ @{ 0 0 0 }@ [ v+ ] reduce ] keep length 1 - 0 max
         ] keep pack-gap n*v v+
     ] keep pack-vector set-axis ;

library/ui/line-editor.factor

@@ -106,10 +106,15 @@ SYMBOL: history-index
     >r line-text get head r> append
     line-text set ;
 
-: backspace ( -- )
+: delete-prev ( -- )
     #! Call this in the line editor scope.
     caret get dup 0 = [ drop ] [ 1- 1 line-remove ] if ;
 
+: delete-next ( -- )
+    #! Call this in the line editor scope.
+    caret get dup line-text get length =
+    [ drop ] [ 1 line-remove ] if ;
+
 : left ( -- )
     #! Call this in the line editor scope.
     caret [ 1- 0 max ] change ;

library/ui/menus.factor

@@ -16,7 +16,7 @@ gadgets-labels generic kernel lists math namespaces sequences ;
 
 : fit-bounds ( loc dim max -- loc )
     #! Adjust loc to fit inside max.
-    swap v- @{ 0 0 0 }@ vmax vmin ;
+    swap |v-| vmin ;
 
 : menu-loc ( menu -- loc )
     hand rect-loc swap rect-dim world get rect-dim fit-bounds ;
@@ -31,7 +31,7 @@ gadgets-labels generic kernel lists math namespaces sequences ;
     #! Given an association list mapping labels to quotations.
     #! Prepend a call to hide-menu to each quotation.
     [ uncons \ hide-glass swons >r <label> r> <roll-button> ] map
-    <pile> 1 over set-pack-fill [ add-gadgets ] keep ;
+    make-pile 1 over set-pack-fill ;
 
 : menu-theme ( menu -- )
     << solid >> interior set-paint-prop ;

library/ui/outliner.factor

@@ -33,7 +33,8 @@ TUPLE: outliner gadget quot pile expanded? ;
 : find-outliner [ outliner? ] find-parent ;
 
 : <expand-button> ( -- gadget )
-    "+" <label> [ find-outliner toggle-outliner ] <roll-button> ;
+    right <polygon-gadget>
+    [ find-outliner toggle-outliner ] <roll-button> ;
 
 C: outliner ( gadget quot -- gadget )
     #! The quotation generates child gadgets.

library/ui/paint.factor

@@ -1,8 +1,9 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
-USING: generic hashtables io kernel lists math matrices
+USING: alien arrays gadgets-layouts generic hashtables io kernel
-namespaces sdl sequences strings styles vectors ;
+lists math matrices namespaces sdl sequences strings styles
+vectors ;
 
 SYMBOL: clip
 
@@ -137,17 +138,15 @@ TUPLE: bevel width ;
 SYMBOL: bevel-1
 SYMBOL: bevel-2
 
-: bevel-up ( gadget -- rgb )
+: bevel-color ( gadget ? -- rgb )
-    dup reverse-video paint-prop bevel-1 bevel-2 ? paint-prop rgb ;
+    >r dup reverse-video paint-prop bevel-1 bevel-2
-
+    r> [ swap ] when ? paint-prop rgb ;
-: bevel-down ( gadget -- rgb )
-    dup reverse-video paint-prop bevel-2 bevel-1 ? paint-prop rgb ;
 
 : draw-bevel ( v1 v2 gadget -- )
-    [ >r x1/x2/y1 r> bevel-up   hlineColor ] keep
+    [ >r x1/x2/y1 r> f bevel-color hlineColor ] keep
-    [ >r x1/x2/y2 r> bevel-down hlineColor ] keep
+    [ >r x1/x2/y2 r> t bevel-color hlineColor ] keep
-    [ >r x1/y1/y2 r> bevel-up   vlineColor ] keep
+    [ >r x1/y1/y2 r> f bevel-color vlineColor ] keep
-    [ >r x2/y1/y2 r> bevel-down vlineColor ] keep
+    [ >r x2/y1/y2 r> t bevel-color vlineColor ] keep
     3drop ;
 
 M: bevel draw-boundary ( gadget boundary -- )
@@ -172,8 +171,49 @@ M: gadget draw-gadget* ( gadget -- )
 : <bevel-gadget> ( -- gadget )
     <plain-gadget> dup << bevel f 2 >> boundary set-paint-prop ;
 
-: draw-line ( from to color -- )
+! Polygon pen
-    >r >r >r surface get r> first2 r> first2 r> rgb lineColor ;
+TUPLE: polygon points ;
 
-: draw-fanout ( from tos color -- )
+: >short-array ( seq -- short-array )
-    -rot [ >r 2dup r> rot draw-line ] each 2drop ;
+    dup length <short-array> over length [
+        [ tuck >r >r swap nth r> r> swap set-short-nth ] 3keep
+    ] repeat nip ;
+
+: polygon-x/y ( polygon -- vx vy n )
+    polygon-points [
+        origin get swap [ v+ ] map-with
+        dup [ first ] map swap [ second ] map
+        [ >short-array ] 2apply
+    ] keep length ;
+
+: (polygon) ( gadget polygon -- surface vx vy n gadget )
+    swap >r surface get swap polygon-x/y r> ;
+
+M: polygon draw-boundary ( gadget polygon -- )
+    (polygon) fg rgb polygonColor ;
+
+M: polygon draw-interior ( gadget polygon -- )
+    (polygon) bg rgb filledPolygonColor ;
+
+: up    @{ @{ 4 0 0 }@ @{ 8 8 0 }@ @{ 0 8 0 }@ }@ ;
+: right @{ @{ 0 0 0 }@ @{ 8 4 0 }@ @{ 0 8 0 }@ }@ ;
+: down  @{ @{ 0 0 0 }@ @{ 8 0 0 }@ @{ 4 8 0 }@ }@ ;
+: left  @{ @{ 0 4 0 }@ @{ 8 0 0 }@ @{ 8 8 0 }@ }@ ;
+
+: right|
+    @{
+        @{ 0 0 0 }@ @{ 0 8 0 }@ @{ 8 4 0 }@
+        @{ 8 8 0 }@ @{ 8 0 0 }@ @{ 8 4 0 }@
+    }@ ;
+
+: |left
+    @{
+        @{ 8 0 0 }@ @{ 8 8 0 }@ @{ 0 4 0 }@
+        @{ 0 8 0 }@ @{ 0 0 0 }@ @{ 0 4 0 }@
+    }@ ;
+
+: <polygon-gadget> ( points -- gadget )
+    dup max-dim >r <polygon> <gadget> r> over set-rect-dim
+    dup rot interior set-paint-prop
+    dup gray background set-paint-prop
+    dup light-gray rollover-bg set-paint-prop ;

library/ui/panes.factor

@@ -19,7 +19,7 @@ TUPLE: pane output active current input continuation scrolls? ;
 : add-output 2dup set-pane-output add-gadget ;
 
 : <active-line> ( current input -- line )
-    [ 2array ] [ 1array ] if* <shelf> [ add-gadgets ] keep ;
+    [ 2array ] [ 1array ] if* make-shelf ;
 
 : init-active-line ( pane -- )
     dup pane-active unparent

library/ui/sliders.factor

@@ -14,8 +14,6 @@ TUPLE: slider vector elevator thumb value max page ;
 
 : find-slider [ slider? ] find-parent ;
 
-: thumb-min @{ 12 12 0 }@ ;
-
 : slider-scale ( slider -- n )
     #! A scaling factor such that if x is a slider co-ordinate,
     #! x*n is the screen position of the thumb, and conversely
@@ -61,7 +59,7 @@ SYMBOL: slider-changed
 
 : elevator-theme ( elevator -- )
     dup << solid f >> interior set-paint-prop
-    @{ 128 128 128 }@ background set-paint-prop ;
+    light-gray background set-paint-prop ;
 
 : slide-by ( amount gadget -- )
     #! The gadget can be any child of a slider.
@@ -83,32 +81,42 @@ C: elevator ( -- elevator )
     <plain-gadget> over set-delegate
     dup elevator-theme dup elevator-actions ;
 
+: (layout-thumb) ( slider n -- n )
+    over slider-vector n*v swap slider-thumb ;
+
 : thumb-loc ( slider -- loc )
     dup slider-value swap slider>screen ;
 
+: layout-thumb-loc ( slider -- )
+    dup thumb-loc (layout-thumb) set-rect-loc ;
+
 : thumb-dim ( slider -- h )
     dup slider-page swap slider>screen ;
 
+: layout-thumb-dim ( slider -- )
+    dup dup thumb-dim (layout-thumb)
+    >r >r dup rect-dim r> rot slider-vector set-axis r>
+    set-gadget-dim ;
+
 : layout-thumb ( slider -- )
-    dup thumb-loc over slider-vector n*v
+    dup layout-thumb-loc layout-thumb-dim ;
-    over slider-thumb set-rect-loc
-    dup thumb-dim over slider-vector n*v thumb-min vmax
-    swap slider-thumb set-gadget-dim ;
 
 M: elevator layout* ( elevator -- )
     find-slider layout-thumb ;
 
-M: elevator pref-dim drop thumb-min ;
-
 : slide-by-line ( -1/1 slider -- ) >r 32 * r> slide-by ;
 
-: <up-button>
+: slider-vertical? slider-vector @{ 0 1 0 }@ = ;
-    <gadget> [ -1 swap slide-by-line ] <repeat-button> ;
+
+: <up-button> ( slider -- button )
+    slider-vertical? up left ? <polygon-gadget>
+    [ -1 swap slide-by-line ] <repeat-button> ;
 
 : add-up @{ 1 1 1 }@ over slider-vector v- first2 set-frame-child ;
 
-: <down-button>
+: <down-button> ( slider -- button )
-    <gadget> [ 1 swap slide-by-line ] <repeat-button> ;
+    slider-vertical? down right ? <polygon-gadget>
+    [ 1 swap slide-by-line ] <repeat-button> ;
 
 : add-down @{ 1 1 1 }@ over slider-vector v+ first2 set-frame-child ;
 
@@ -123,8 +131,8 @@ C: slider ( vector -- slider )
     0 over set-slider-page
     0 over set-slider-max
     <elevator> over add-elevator
-    <up-button> over add-up
+    dup <up-button> over add-up
-    <down-button> over add-down
+    dup <down-button> over add-down
     <thumb> over add-thumb ;
 
 : <x-slider> ( -- slider ) @{ 1 0 0 }@ <slider> ;