UI work

library/collections/slicing.factor

@@ -105,3 +105,12 @@ M: object tail ( index seq -- seq ) [ tail-slice ] keep like ;
 : drop-prefix ( seq1 seq2 -- seq1 seq2 )
     2dup mismatch dup -1 = [ drop 2dup min-length ] when
     tuck swap tail-slice >r swap tail-slice r> ;
+
+IN: strings
+
+: completion? ( partial completion quot -- ? )
+    #! Test if 'partial' is a completion of 'completion', by
+    #! comparing each "-"-delimited chunk using 'quot'. The
+    #! quotation is usually either [ subseq? ] or [ swap head? ].
+    >r [ "-" split ] 2apply 2dup [ length ] 2apply <=
+    [ r> 2map [ ] all? ] [ r> 3drop f ] if ; inline

library/help/tutorial.factor

@@ -373,4 +373,4 @@ M: general-list tutorial-line
 
 : <tutorial-button>
     "Tutorial" <label>
-    [ drop [ tutorial ] pane get pane-call ] <button> ;
+    [ drop [ tutorial ] pane get pane-call ] <bevel-button> ;

library/opengl/opengl-utils.factor

@@ -89,7 +89,7 @@ USING: alien errors kernel math namespaces opengl sdl sequences ;
     GL_LINE_LOOP (gl-poly) ;
 
 : gl-set-clip ( loc dim -- )
-    dup first2 ( 1+ ) >r >r
+    dup first2 1+ >r >r
     over second swap second + height get swap - >r
     first r> r> r> glScissor ;
 

library/styles.factor

@@ -14,9 +14,6 @@ IN: styles
 
 SYMBOL: foreground ! Used for text and outline shapes.
 SYMBOL: background ! Used for filled shapes.
-SYMBOL: rollover-bg
-SYMBOL: rollover
-SYMBOL: reverse-video
 
 SYMBOL: font
 SYMBOL: font-size

library/syntax/see.factor

@@ -2,7 +2,7 @@
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: prettyprint
 USING: generic hashtables io kernel lists math namespaces
-sequences styles words ;
+sequences strings styles words ;
 
 : declaration. ( word prop -- )
     tuck word-name word-prop [ pprint-word ] [ drop ] if ;
@@ -128,7 +128,7 @@ M: word class. drop ;
     ] with-pprint ;
 
 : (apropos) ( substring -- seq )
-    all-words [ word-name subseq? ] subset-with ;
+    all-words [ word-name [ subseq? ] completion? ] subset-with ;
 
 : apropos ( substring -- )
     #! List all words that contain a string.

library/ui/books.factor

@@ -35,7 +35,7 @@ TUPLE: book-browser book ;
 
 : <book-button> ( polygon quot -- button )
     \ find-book swons >r <polygon-gadget> dup icon-theme r>
-    <button> ;
+    <bevel-button> ;
 
 : <book-buttons> ( book -- gadget )
     [

library/ui/buttons.factor

@@ -5,25 +5,24 @@ USING: gadgets gadgets-borders gadgets-layouts gadgets-theme
 generic io kernel lists math namespaces sequences sequences
 styles threads ;
 
+TUPLE: button rollover? pressed? ;
+
 : button-down? ( n -- ? ) hand get hand-buttons member? ;
 
 : mouse-over? ( gadget -- ? ) hand get hand-gadget child? ;
 
-: button-pressed? ( button -- ? )
-    #! Return true if the mouse was clicked on the button, and
-    #! is currently over the button.
-    dup mouse-over? 1 button-down? and
-    [ hand get hand-clicked child? ] [ drop f ] if ;
+: mouse-clicked? ( gadget -- ? ) hand get hand-clicked child? ;
 
 : button-update ( button -- )
-    dup dup mouse-over? rollover set-paint-prop
-    dup dup button-pressed? reverse-video set-paint-prop
+    dup mouse-over? over set-button-rollover?
+    dup button-rollover? 1 button-down? and
+    over mouse-clicked? and over set-button-pressed?
     relayout-1 ;
 
 : button-clicked ( button -- )
     #! If the mouse is released while still inside the button,
     #! fire an action gesture.
-    dup button-update dup mouse-over?
+    dup button-update dup button-rollover?
     [ [ action ] swap handle-gesture ] when drop ;
 
 : button-action ( action -- quot )
@@ -36,18 +35,18 @@ styles threads ;
     dup [ button-update ] [ mouse-leave ] set-action
     [ button-update ] [ mouse-enter ] set-action ;
 
-TUPLE: button ;
-
 C: button ( gadget quot -- button )
-    rot <border> dup button-theme
-    over set-gadget-delegate
+    rot <border> over set-gadget-delegate
     [ swap button-gestures ] keep ;
 
-: <roll-button> ( gadget quot -- button )
-    >r dup roll-button-theme dup r> button-gestures ;
-
 : <highlight-button> ( gadget quot -- button )
-    dupd button-gestures ;
+    <button> @{ 0 0 0 }@ over set-border-size ;
+
+: <roll-button> ( gadget quot -- button )
+    <highlight-button> dup roll-button-theme ;
+
+: <bevel-button> ( gadget quot -- button )
+    <button> dup bevel-button-theme ;
 
 : repeat-button-down ( button -- )
     dup 100 add-timer button-clicked ;
@@ -62,6 +61,21 @@ C: button ( gadget quot -- button )
 : <repeat-button> ( gadget quot -- button )
     #! Button that calls the quotation every 100ms as long as
     #! the mouse is held down.
-    <button> dup repeat-actions ;
+    <bevel-button> dup repeat-actions ;
 
 M: button tick ( ms object -- ) nip button-clicked ;
+
+TUPLE: button-paint plain rollover pressed ;
+
+: button-paint ( button paint -- button paint )
+    @{
+        @{ [ over button-pressed? ] [ button-paint-pressed ] }@
+        @{ [ over button-rollover? ] [ button-paint-rollover ] }@
+        @{ [ t ] [ button-paint-plain ] }@
+    }@ cond ;
+
+M: button-paint draw-interior ( button paint -- )
+    button-paint draw-interior ;
+
+M: button-paint draw-boundary ( button paint -- )
+    button-paint draw-boundary ;

library/ui/editors.factor

@@ -144,8 +144,7 @@ M: editor layout* ( editor -- )
 M: editor label-text ( editor -- string )
     editor-text ;
 
-M: editor draw-gadget* ( editor -- )
-    dup delegate draw-gadget* draw-label ;
+M: editor draw-gadget* ( editor -- ) draw-label ;
 
 : set-possibilities ( possibilities editor -- )
     #! Set completion possibilities.

library/ui/labels.factor

@@ -22,10 +22,10 @@ M: label pref-dim ( label -- dim )
     label-size ;
 
 : draw-label ( label -- )
-    dup fg gl-color dup gadget-font swap label-text draw-string ;
+    dup foreground paint-prop gl-color
+    dup gadget-font swap label-text draw-string ;
 
-M: label draw-gadget* ( label -- )
-    dup delegate draw-gadget* draw-label ;
+M: label draw-gadget* ( label -- ) draw-label ;
 
 M: label set-message ( string/f label -- )
     set-label-text* ;

library/ui/line-editor.factor

@@ -140,16 +140,12 @@ M: document-elt prev-elt* 3drop 0 ;
     history-index get dup 1+ history-length >=
     [ drop ] [ 1+ goto-history ] if ;
 
-: completion? ( partial completion -- ? )
-    [ "-" split ] 2apply 2dup [ length ] 2apply <=
-    [ [ swap head? ] 2map [ ] all? ] [ 2drop f ] if ;
-
 : completions ( -- seq )
     << word-elt >> prev-elt@ 2dup = [
         2drop f
     ] [
-        line-text get subseq
-        possibilities get [ completion? ] subset-with
+        line-text get subseq possibilities get
+        [ [ swap head? ] completion? ] subset-with
     ] if ;
 
 : complete ( completion -- )

library/ui/listener.factor

@@ -63,8 +63,7 @@ C: display ( -- display )
     1/2 <x-splitter> ;
 
 : <status-bar> ( -- gadget )
-    "" <label> dup solid-interior
-    dup t reverse-video set-paint-prop ;
+    "" <label> dup solid-interior dup reverse-video-theme ;
 
 : listener-application ( -- )
     t t <pane> dup pane global set-hash

library/ui/paint.factor

@@ -5,11 +5,27 @@ io kernel lists math namespaces opengl sdl sequences strings
 styles vectors ;
 IN: gadgets
 
+GENERIC: draw-gadget* ( gadget -- )
+
+M: gadget draw-gadget* ( gadget -- ) drop ;
+
+SYMBOL: interior
+SYMBOL: boundary
+
+GENERIC: draw-interior ( gadget interior -- )
+GENERIC: draw-boundary ( gadget boundary -- )
+
 SYMBOL: clip
 
 : visible-children ( gadget -- seq ) clip get swap children-on ;
 
-GENERIC: draw-gadget* ( gadget -- )
+DEFER: draw-gadget
+
+: (draw-gadget) ( gadget -- )
+    dup dup interior paint-prop* draw-interior
+    dup dup boundary paint-prop* draw-boundary
+    dup draw-gadget*
+    visible-children [ draw-gadget ] each ;
 
 : do-clip ( gadget -- )
     >absolute clip [ rect-intersect dup ] change
@@ -24,12 +40,9 @@ GENERIC: draw-gadget* ( gadget -- )
 : draw-gadget ( gadget -- )
     clip get over inside? [
         [
-            dup do-clip [
-                dup draw-gadget*
-                visible-children [ draw-gadget ] each
-            ] with-translation
+            dup do-clip [ dup (draw-gadget) ] with-translation
         ] with-scope
-    ] [ drop ] if ;
+    ] when drop ;
 
 : paint-prop* ( gadget key -- value ) swap gadget-paint ?hash ;
 
@@ -51,24 +64,7 @@ GENERIC: draw-gadget* ( gadget -- )
 : add-paint ( gadget hash -- )
     dup [ >r init-paint r> hash-update ] [ 2drop ] if ;
 
-: fg ( gadget -- color )
-    dup reverse-video paint-prop
-    background foreground ? paint-prop ;
-
-: bg ( gadget -- color )
-    dup reverse-video paint-prop [
-        foreground
-    ] [
-        dup rollover paint-prop rollover-bg background ?
-    ] if paint-prop ;
-
 ! Pen paint properties
-SYMBOL: interior
-SYMBOL: boundary
-
-GENERIC: draw-interior ( gadget interior -- )
-GENERIC: draw-boundary ( gadget boundary -- )
-
 M: f draw-interior 2drop ;
 M: f draw-boundary 2drop ;
 
@@ -76,28 +72,14 @@ M: f draw-boundary 2drop ;
 TUPLE: solid ;
 
 : rect>screen ( shape -- x1 y1 x2 y2 )
-    >r origin get dup r> rect-dim v+
-    [ first2 ] 2apply ( [ 1 - ] 2apply ) ;
+    >r origin get dup r> rect-dim v+ [ first2 ] 2apply ;
 
 ! Solid pen
 M: solid draw-interior
-    drop dup bg gl-color rect-dim gl-fill-rect ;
+    drop dup background paint-prop gl-color rect-dim gl-fill-rect ;
 
 M: solid draw-boundary
-    drop dup fg gl-color rect-dim ( @{ 1 1 0 }@ v- ) gl-rect ;
-
-! Rollover only
-TUPLE: rollover-only ;
-
-C: rollover-only << solid >> over set-delegate ;
-
-M: rollover-only draw-interior ( gadget interior -- )
-    over rollover paint-prop
-    [ delegate draw-interior ] [ 2drop ] if ;
-
-M: rollover-only draw-boundary ( gadget boundary -- )
-    over rollover paint-prop
-    [ delegate draw-boundary ] [ 2drop ] if ;
+    drop dup foreground paint-prop gl-color rect-dim gl-rect ;
 
 ! Gradient pen
 TUPLE: gradient colors ;
@@ -106,19 +88,14 @@ M: gradient draw-interior ( gadget gradient -- )
     over gadget-orientation swap gradient-colors rot rect-dim
     gl-gradient ;
 
-M: gadget draw-gadget* ( gadget -- )
-    dup
-    dup interior paint-prop* draw-interior
-    dup boundary paint-prop* draw-boundary ;
-
 ! Polygon pen
 TUPLE: polygon points ;
 
 M: polygon draw-boundary ( gadget polygon -- )
-    swap fg gl-color polygon-points gl-poly ;
+    swap foreground paint-prop gl-color polygon-points gl-poly ;
 
 M: polygon draw-interior ( gadget polygon -- )
-    swap bg gl-color polygon-points gl-fill-poly ;
+    swap background paint-prop gl-color polygon-points gl-fill-poly ;
 
 : arrow-up    @{ @{ 3 0 0 }@ @{ 6 6 0 }@ @{ 0 6 0 }@ }@ ;
 : arrow-right @{ @{ 0 0 0 }@ @{ 6 3 0 }@ @{ 0 6 0 }@ }@ ;

library/ui/presentations.factor

@@ -28,15 +28,15 @@ TUPLE: command-button object ;
     <menu> show-hand-menu ;
 
 C: command-button ( gadget object -- button )
-    [ set-command-button-object ] keep
+    [
+        set-command-button-object
+        [ command-menu ] <roll-button>
+    ] keep
     [ set-gadget-delegate ] keep
-    dup [ command-menu ] button-gestures
-    dup roll-button-theme
     dup menu-button-actions ;
 
 M: command-button gadget-help ( button -- string )
-    command-button-object
-    dup word? [ synopsis ] [ summary ] if ;
+    command-button-object dup word? [ synopsis ] [ summary ] if ;
 
 : init-commands ( gadget -- gadget )
     dup presented paint-prop [ <command-button> ] when* ;

library/ui/sliders.factor

@@ -55,7 +55,9 @@ SYMBOL: slider-changed
 
 : <thumb> ( vector -- thumb )
     <gadget> [ set-gadget-orientation ] keep
-    t over set-gadget-root? dup button-theme dup thumb-actions ;
+    t over set-gadget-root?
+    dup thumb-theme
+    dup thumb-actions ;
 
 : slide-by ( amount gadget -- )
     #! The gadget can be any child of a slider.

library/ui/theme.factor

@@ -1,5 +1,8 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
+IN: gadgets-buttons
+DEFER: <button-paint>
+
 IN: gadgets-theme
 USING: arrays gadgets kernel sequences styles ;
 
@@ -9,20 +12,44 @@ USING: arrays gadgets kernel sequences styles ;
 : solid-boundary ( gadget -- )
     << solid >> boundary set-paint-prop ;
 
-: button-theme ( gadget -- )
+: plain-gradient
     << gradient f @{
         @{ 240 240 240 }@
         @{ 192 192 192 }@
         @{ 192 192 192 }@
         @{ 96 96 96 }@
-    }@ >> interior set-paint-prop ;
+    }@ >> ;
+
+: rollover-gradient
+    << gradient f @{
+        @{ 255 255 255 }@
+        @{ 216 216 216 }@
+        @{ 216 216 216 }@
+        @{ 112 112 112 }@
+    }@ >> ;
+
+: pressed-gradient
+    << gradient f @{
+        @{ 112 112 112 }@
+        @{ 216 216 216 }@
+        @{ 216 216 216 }@
+        @{ 255 255 255 }@
+    }@ >> ;
+
+: bevel-button-theme ( gadget -- )
+    plain-gradient rollover-gradient pressed-gradient
+    <button-paint> interior set-paint-prop ;
+
+: thumb-theme ( thumb -- )
+    plain-gradient interior set-paint-prop ;
 
 : editor-theme ( editor -- )
     bold font-style set-paint-prop ;
 
 : roll-button-theme ( button -- )
-    dup <rollover-only> interior set-paint-prop
-    <rollover-only> boundary set-paint-prop ;
+    dup << button-paint f f << solid >> << solid >> >> boundary set-paint-prop
+    dup << button-paint f f f << solid >> >> interior set-paint-prop
+    @{ 236 230 232 }@ background set-paint-prop ;
 
 : caret-theme ( caret -- )
     dup solid-interior
@@ -36,8 +63,12 @@ USING: arrays gadgets kernel sequences styles ;
     }@ >> interior set-paint-prop
     light-gray background set-paint-prop ;
 
+: reverse-video-theme ( gadget -- )
+    dup black background set-paint-prop
+    white foreground set-paint-prop ;
+
 : divider-theme ( divider -- )
-    dup solid-interior t reverse-video set-paint-prop ;
+    dup solid-interior reverse-video-theme ;
 
 : display-title-theme
     dup @{ 216 232 255 }@ background set-paint-prop
@@ -50,15 +81,12 @@ USING: arrays gadgets kernel sequences styles ;
 
 : icon-theme ( gadget -- )
     dup gray background set-paint-prop
-    dup light-gray rollover-bg set-paint-prop
     gray foreground set-paint-prop ;
 
 : world-theme
     {{
         [[ background @{ 255 255 255 }@ ]]
-        [[ rollover-bg @{ 236 230 232 }@ ]]
         [[ foreground @{ 0 0 0 }@ ]]
-        [[ reverse-video f ]]
         [[ font "Monospaced" ]]
         [[ font-size 12 ]]
         [[ font-style plain ]]