Clean up UI a bit

extra/boids/ui/ui.factor

@@ -104,11 +104,11 @@ VARS: population-label cohesion-label alignment-label separation-label ;
     C[ [ run ] in-thread ] slate> set-slate-graft
     C[ loop off ]          slate> set-slate-ungraft
 
-  "" <label> dup reverse-video-theme >population-label update-population-label
+  "" <label> reverse-video-theme >population-label update-population-label
 
-  "" <label> dup reverse-video-theme >cohesion-label   update-cohesion-label
+  "" <label> reverse-video-theme >cohesion-label   update-cohesion-label
-  "" <label> dup reverse-video-theme >alignment-label  update-alignment-label
+  "" <label> reverse-video-theme >alignment-label  update-alignment-label
-  "" <label> dup reverse-video-theme >separation-label update-separation-label
+  "" <label> reverse-video-theme >separation-label update-separation-label
 
   <frame>
 

extra/gesture-logger/gesture-logger.factor

@@ -8,9 +8,9 @@ TUPLE: gesture-logger stream ;
 
 : <gesture-logger> ( stream -- gadget )
     \ gesture-logger construct-gadget
-    [ set-gesture-logger-stream ] keep
+    swap >>stream
-    { 100 100 } over set-rect-dim
+    { 100 100 } >>dim
-    dup black solid-interior ;
+    black solid-interior ;
 
 M: gesture-logger handle-gesture*
     drop

extra/lsys/ui/ui.factor

@@ -100,17 +100,17 @@ DEFER: empty-model
 
 {
 
-[ "Load" <label> dup reverse-video-theme ]
+[ "Load" <label> reverse-video-theme ]
 
 [ "Models" <label> [ drop model-chooser ] closed-quot <bevel-button> ]
 [ "Scenes" <label> [ drop scene-chooser ] closed-quot <bevel-button> ]
 
-[ "Model" <label> dup reverse-video-theme ]
+[ "Model" <label> reverse-video-theme ]
 
 [ "Iterate" <label> [ drop iterate build-model ] closed-quot <bevel-button> ]
 [ "Build model" <label> [ drop build-model ] closed-quot <bevel-button> ]
 
-[ "Camera" <label> dup reverse-video-theme ]
+[ "Camera" <label> reverse-video-theme ]
 
 [ "Turn left" <label> [ 5 turn-left ] camera-action <bevel-button> ]
 [ "Turn right" <label> [ 5 turn-right ] camera-action <bevel-button> ]

extra/ui/gadgets/buttons/buttons.factor

@@ -41,7 +41,7 @@ button H{
 
 : <button> ( gadget quot -- button )
     button new
-    [ set-button-quot ] keep
+    swap >>quot
     [ set-gadget-delegate ] keep ;
 
 TUPLE: button-paint plain rollover pressed selected ;
@@ -53,10 +53,10 @@ C: <button-paint> button-paint
 
 : button-paint ( button paint -- button paint )
     over find-button {
-        { [ dup button-pressed? ] [ drop button-paint-pressed ] }
+        { [ dup pressed?>> ] [ drop pressed>> ] }
-        { [ dup button-selected? ] [ drop button-paint-selected ] }
+        { [ dup selected?>> ] [ drop selected>> ] }
-        { [ dup button-rollover? ] [ drop button-paint-rollover ] }
+        { [ dup button-rollover? ] [ drop rollover>> ] }
-        [ drop button-paint-plain ]
+        [ drop plain>> ]
     } cond ;
 
 M: button-paint draw-interior
@@ -65,25 +65,26 @@ M: button-paint draw-interior
 M: button-paint draw-boundary
     button-paint draw-boundary ;
 
-: roll-button-theme ( button -- )
+: roll-button-theme ( button -- button )
-    f black <solid> dup f <button-paint>
+    f black <solid> dup f <button-paint> >>boundary ; inline
-    swap set-gadget-boundary ;
 
 : <roll-button> ( label quot -- button )
-    >r >label r>
+    >r >label r> <button> roll-button-theme ;
-    <button> dup roll-button-theme ;
 
-: bevel-button-theme ( gadget -- )
+: <bevel-button-paint> ( -- paint )
     plain-gradient
     rollover-gradient
     pressed-gradient
     selected-gradient
-    <button-paint> over set-gadget-interior
+    <button-paint> ;
-    faint-boundary ;
+
+: bevel-button-theme ( gadget -- gadget )
+    <bevel-button-paint> >>interior
+    faint-boundary ; inline
 
 : <bevel-button> ( label quot -- button )
     >r >label 5 <border> r>
-    <button> dup bevel-button-theme ;
+    <button> bevel-button-theme ;
 
 TUPLE: repeat-button ;
 

extra/ui/gadgets/canvas/canvas.factor

@@ -9,7 +9,7 @@ TUPLE: canvas dlist ;
 
 : <canvas> ( -- canvas )
     canvas construct-gadget
-    dup black solid-interior ;
+    black solid-interior ;
 
 : delete-canvas-dlist ( canvas -- )
     dup find-gl-context

extra/ui/gadgets/labelled/labelled.factor

@@ -13,7 +13,7 @@ TUPLE: labelled-gadget content ;
 : <labelled-gadget> ( gadget title -- newgadget )
     labelled-gadget new
     [
-        <label> dup reverse-video-theme f track,
+        <label> reverse-video-theme f track,
         g-> set-labelled-gadget-content 1 track,
     ] { 0 1 } build-track ;
 

extra/ui/gadgets/labels/labels.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2005, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays hashtables io kernel math namespaces
+USING: accessors arrays hashtables io kernel math namespaces
 opengl sequences strings splitting
 ui.gadgets ui.gadgets.tracks ui.gadgets.theme ui.render colors
 models ;
@@ -10,7 +10,7 @@ IN: ui.gadgets.labels
 TUPLE: label text font color ;
 
 : label-string ( label -- string )
-    label-text dup string? [ "\n" join ] unless ; inline
+    text>> dup string? [ "\n" join ] unless ; inline
 
 : set-label-string ( string label -- )
     CHAR: \n pick memq? [
@@ -19,21 +19,21 @@ TUPLE: label text font color ;
         set-label-text
     ] if ; inline
 
-: label-theme ( gadget -- )
+: label-theme ( gadget -- gadget )
-    black over set-label-color
+    sans-serif-font >>font
-    sans-serif-font swap set-label-font ;
+    black >>color ; inline
 
 : <label> ( string -- label )
     label construct-gadget
     [ set-label-string ] keep
-    dup label-theme ;
+    label-theme ;
 
 M: label pref-dim*
-    dup label-font open-font swap label-text text-dim ;
+    [ font>> open-font ] [ text>> ] bi text-dim ;
 
 M: label draw-gadget*
-    dup label-color gl-color
+    [ color>> gl-color ]
-    dup label-font swap label-text origin get draw-text ;
+    [ [ font>> ] [ text>> ] bi origin get draw-text ] bi ;
 
 M: label gadget-text* label-string % ;
 
@@ -45,12 +45,12 @@ M: label-control model-changed
 : <label-control> ( model -- gadget )
     "" <label> label-control construct-control ;
 
-: text-theme ( gadget -- )
+: text-theme ( gadget -- gadget )
-    black over set-label-color
+    black >>color
-    monospace-font swap set-label-font ;
+    monospace-font >>font ;
 
-: reverse-video-theme ( label -- )
+: reverse-video-theme ( label -- label )
-    white over set-label-color
+    white >>color
     black solid-interior ;
 
 GENERIC: >label ( obj -- gadget )

extra/ui/gadgets/lists/lists.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2006, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: ui.commands ui.gestures ui.render ui.gadgets
+USING: accessors ui.commands ui.gestures ui.render ui.gadgets
 ui.gadgets.labels ui.gadgets.scrollers
 kernel sequences models opengl math math.order namespaces
 ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs
@@ -27,17 +27,18 @@ TUPLE: list index presenter color hook ;
     swap set-list-index ;
 
 : list-presentation-hook ( list -- quot )
-    list-hook [ [ [ list? ] is? ] find-parent ] prepend ;
+    hook>> [ [ [ list? ] is? ] find-parent ] prepend ;
 
 : <list-presentation> ( hook elt presenter -- gadget )
     keep <presentation>
-    [ set-presentation-hook ] keep
+    swap >>hook
-    [ text-theme ] keep ;
+    text-theme ; inline
 
 : <list-items> ( list -- seq )
-    dup list-presentation-hook
+    [ list-presentation-hook ]
-    over list-presenter
+    [ presenter>> ]
-    rot control-value [
+    [ control-value ]
+    tri [
         >r 2dup r> swap <list-presentation>
     ] map 2nip ;
 

extra/ui/gadgets/menus/menus.factor

@@ -42,11 +42,11 @@ M: menu-glass layout* gadget-child prefer ;
     [ hand-clicked get find-world hide-glass ]
     3append <roll-button> ;
 
-: menu-theme ( gadget -- )
+: menu-theme ( gadget -- gadget )
-    dup light-gray solid-interior
+    light-gray solid-interior
     faint-boundary ;
 
 : <commands-menu> ( hook target commands -- gadget )
     [
         [ >r 2dup r> <menu-item> gadget, ] each 2drop
-    ] make-filled-pile 5 <border> dup menu-theme ;
+    ] make-filled-pile 5 <border> menu-theme ;

extra/ui/gadgets/panes/panes.factor

@@ -182,7 +182,7 @@ M: pane-stream make-span-stream
     foreground [ over set-label-color ] apply-style ;
 
 : apply-background-style ( style gadget -- style gadget )
-    background [ dupd solid-interior ] apply-style ;
+    background [ solid-interior ] apply-style ;
 
 : specified-font ( style -- font )
     [ font swap at "monospace" or ] keep
@@ -207,15 +207,15 @@ M: pane-stream make-span-stream
 
 : apply-wrap-style ( style pane -- style pane )
     wrap-margin [
-        2dup <paragraph> swap set-pane-prototype
+        2dup <paragraph> >>prototype drop
-        <paragraph> over set-pane-current
+        <paragraph> >>current
     ] apply-style ;
 
 : apply-border-color-style ( style gadget -- style gadget )
-    border-color [ dupd solid-boundary ] apply-style ;
+    border-color [ solid-boundary ] apply-style ;
 
 : apply-page-color-style ( style gadget -- style gadget )
-    page-color [ dupd solid-interior ] apply-style ;
+    page-color [ solid-interior ] apply-style ;
 
 : apply-path-style ( style gadget -- style gadget )
     presented-path [ <editable-slot> ] apply-style ;
@@ -224,9 +224,7 @@ M: pane-stream make-span-stream
     border-width [ <border> ] apply-style ;
 
 : apply-printer-style ( style gadget -- style gadget )
-    presented-printer [
+    presented-printer [ [ make-pane ] curry >>printer ] apply-style ;
-        [ make-pane ] curry over set-editable-slot-printer
-    ] apply-style ;
 
 : style-pane ( style pane -- pane )
     apply-border-width-style
@@ -294,11 +292,8 @@ M: pack dispose drop ;
 M: paragraph dispose drop ;
 
 : gadget-write ( string gadget -- )
-    over empty? [
+    over empty?
-        2drop
+    [ 2drop ] [ >r <label> text-theme r> add-gadget ] if ;
-    ] [
-        >r <label> dup text-theme r> add-gadget
-    ] if ;
 
 M: pack stream-write gadget-write ;
 
@@ -372,11 +367,11 @@ M: f sloppy-pick-up*
 
 : extend-selection ( pane -- )
     hand-moved? [
-        dup pane-selecting? [
+        dup selecting?>> [
             dup move-caret
         ] [
             dup hand-clicked get child? [
-                t over set-pane-selecting?
+                t >>selecting?
                 dup hand-clicked set-global
                 dup move-caret
                 dup caret>mark
@@ -386,10 +381,9 @@ M: f sloppy-pick-up*
     ] when drop ;
 
 : end-selection ( pane -- )
-    f over set-pane-selecting?
+    f >>selecting?
     hand-moved? [
-        dup com-copy-selection
+        [ com-copy-selection ] [ request-focus ] bi
-        request-focus
     ] [
         relayout-1
     ] if ;

extra/ui/gadgets/scrollers/scrollers.factor

@@ -46,7 +46,7 @@ scroller H{
             y-model <y-slider> g-> set-scroller-y @right frame,
             viewport,
         ] with-gadget
-    ] keep t over set-gadget-root? dup faint-boundary ;
+    ] keep t >>root? faint-boundary ;
 
 : scroll ( value scroller -- )
     [

extra/ui/gadgets/sliders/sliders.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2005, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays ui.gestures ui.gadgets ui.gadgets.buttons
+USING: accessors arrays ui.gestures ui.gadgets ui.gadgets.buttons
 ui.gadgets.frames ui.gadgets.grids math.order
 ui.gadgets.theme ui.render kernel math namespaces sequences
 vectors models math.vectors math.functions quotations colors ;
@@ -65,14 +65,15 @@ thumb H{
     { T{ drag } [ do-drag ] }
 } set-gestures
 
-: thumb-theme ( thumb -- )
+: thumb-theme ( thumb -- thumb )
-    plain-gradient over set-gadget-interior faint-boundary ;
+    plain-gradient >>interior
+    faint-boundary ; inline
 
 : <thumb> ( vector -- thumb )
     thumb construct-gadget
-    t over set-gadget-root?
+    swap >>orientation
-    dup thumb-theme
+    t >>root?
-    [ set-gadget-orientation ] keep ;
+    thumb-theme ;
 
 : slide-by ( amount slider -- )
     gadget-model move-by ;

extra/ui/gadgets/status-bar/status-bar.factor

@@ -1,14 +1,14 @@
 ! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: models sequences ui.gadgets.labels ui.gadgets.theme
+USING: accessors models sequences ui.gadgets.labels
-ui.gadgets.tracks ui.gadgets.worlds ui.gadgets ui kernel
+ui.gadgets.theme ui.gadgets.tracks ui.gadgets.worlds ui.gadgets
-calendar ;
+ui kernel calendar ;
 IN: ui.gadgets.status-bar
 
 : <status-bar> ( model -- gadget )
     1/10 seconds <delay> [ "" like ] <filter> <label-control>
-    dup reverse-video-theme
+    reverse-video-theme
-    t over set-gadget-root? ;
+    t >>root? ;
 
 : open-status-window ( gadget title -- )
     >r [

extra/ui/gadgets/theme/theme.factor

@@ -2,17 +2,17 @@
 ! Copyright (C) 2006, 2007 Alex Chapman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays kernel sequences io.styles ui.gadgets ui.render
-colors ;
+colors accessors ;
 IN: ui.gadgets.theme
 
-: solid-interior ( gadget color -- )
+: solid-interior ( gadget color -- gadget )
-    <solid> swap set-gadget-interior ;
+    <solid> >>interior ; inline
 
-: solid-boundary ( gadget color -- )
+: solid-boundary ( gadget color -- gadget )
-    <solid> swap set-gadget-boundary ;
+    <solid> >>boundary ; inline
 
-: faint-boundary ( gadget -- )
+: faint-boundary ( gadget -- gadget )
-    gray solid-boundary ;
+    gray solid-boundary ; inline
 
 : selection-color ( -- color ) light-purple ;