control gadget refactoring

extra/color-picker/color-picker.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math math.functions math.parser models sequences
-ui ui.gadgets ui.gadgets.controls ui.gadgets.frames
+ui ui.gadgets ui.gadgets.frames
 ui.gadgets.labels ui.gadgets.packs ui.gadgets.sliders ui.render
 ;
 IN: color-picker
@@ -11,9 +11,14 @@ IN: color-picker
 : <color-slider> ( model -- gadget )
     <x-slider> 1 over set-slider-line ;
 
+TUPLE: color-preview ;
+
 : <color-preview> ( model -- gadget )
-    <gadget> { 100 100 } over set-rect-dim
+    <gadget> color-preview construct-control
-    [ set-gadget-interior ] <control> ;
+    { 100 100 } over set-rect-dim ;
+
+M: color-preview model-changed
+    dup control-value over set-gadget-interior relayout-1 ;
 
 : <color-model> ( model -- model )
     [ [ 256 /f ] map 1 add <solid> ] <filter> ;

extra/slides/slides.factor

@@ -1,6 +1,6 @@
 USING: arrays hashtables help.markup help.stylesheet io
 io.styles kernel math models namespaces sequences ui ui.gadgets
-ui.gadgets.books ui.gadgets.controls ui.gadgets.panes
+ui.gadgets.books ui.gadgets.panes
 ui.gestures ui.render ;
 IN: slides
 

extra/ui/gadgets/books/books-docs.factor

@@ -1,4 +1,4 @@
-USING: ui.gadgets.books ui.gadgets.controls help.markup
+USING: ui.gadgets.books help.markup
 help.syntax ui.gadgets models ;
 
 HELP: book

extra/ui/gadgets/books/books.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2006, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences models ui.gadgets ui.gadgets.controls ;
+USING: kernel sequences models ui.gadgets ;
 IN: ui.gadgets.books
 
 TUPLE: book ;

extra/ui/gadgets/buttons/buttons.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays ui.commands ui.gadgets ui.gadgets.borders
-ui.gadgets.controls ui.gadgets.labels ui.gadgets.theme
+ui.gadgets.labels ui.gadgets.theme
 ui.gadgets.tracks ui.gadgets.packs ui.gadgets.worlds ui.gestures
 ui.render kernel math models namespaces sequences strings
 quotations assocs combinators classes colors tuples opengl
@@ -131,13 +131,18 @@ M: checkmark-paint draw-interior
     { 5 5 } over set-pack-gap
     1/2 swap set-pack-align ;
 
+TUPLE: checkbox ;
+
 : <checkbox> ( model label -- checkbox )
     <checkmark>
     label-on-right
     over [ toggle-model drop ] curry <button>
-    [ set-button-selected? ] <control>
+    checkbox construct-control
     dup checkbox-theme ;
 
+M: checkbox model-changed
+    dup control-value over set-button-selected? relayout-1 ;
+
 TUPLE: radio-paint color ;
 
 C: <radio-paint> radio-paint
@@ -165,9 +170,18 @@ M: radio-paint draw-boundary
     dup radio-knob-theme
     { 16 16 } over set-gadget-dim ;
 
-: <radio-control> ( model value gadget quot -- control )
+TUPLE: radio-control value ;
-    >r dupd [ set-control-value ] curry* r> call
+
-    [ >r = r> set-button-selected? ] curry* <control> ; inline
+: <radio-control> ( value model gadget quot -- control )
+    >r pick [ swap set-control-value ] curry r> call
+    radio-control construct-control
+    tuck set-radio-control-value ; inline
+
+M: radio-control model-changed
+    dup control-value
+    over radio-control-value =
+    over set-button-selected?
+    relayout-1 ;
 
 : <radio-controls> ( model assoc quot -- gadget )
     swapd [ >r -rot r> call gadget, ] 2curry assoc-each ; inline

extra/ui/gadgets/controls/authors.txt

@@ -1 +0,0 @@
-Slava Pestov

extra/ui/gadgets/controls/controls-docs.factor

@@ -1,51 +0,0 @@
-USING: ui.gadgets help.markup help.syntax models kernel classes
-tuples ;
-IN: ui.gadgets.controls
-
-HELP: control
-{ $class-description "A control is a " { $link gadget } " linked to a " { $link model } " stored in the " { $link control-model } " slot. Changes to the model are reflected in the appearance and behavior of the control, and the control may in turn change the value of the model in response to user input."
-$nl
-"Controls are created by calling " { $link <control> } " and " { $link construct-control } "."
-$nl
-"Objects may delegate to " { $link control } " instances, in which case the " { $link control-self } " slot must be set to the frontmost object in the delegation chain. This ensures that the correct object receives notification of model changes." } ;
-
-HELP: <control>
-{ $values { "model" model } { "gadget" gadget } { "quot" "a quotation with stack effect " { $snippet "( value control -- )" } } }
-{ $description "Creates a new control linked to the given model. The gadget parameter becomes the control's delegate. The quotation is called when the model value changes," }
-{ $examples
-    "The following example creates a gadget whose fill color is determined by the value of a model:"
-    { $code
-        "USING: ui.gadgets ui.gadgets.panes models ;"
-        ": set-fill-color >r <solid> r> set-gadget-interior ;"
-        "{ 1.0 0.0 0.5 1.0 } <model>"
-        "<gadget> [ set-fill-color ] <control>"
-        "{ 100 100 } over set-rect-dim"
-        "gadget."
-    }
-    "The " { $vocab-link "color-picker" } " module extends this example into an elaborate color choose."
-} ;
-
-{ <control> construct-control control-value set-control-value } related-words
-
-HELP: control-value
-{ $values { "control" control } { "value" object } }
-{ $description "Outputs the value of the control's model." } ;
-
-HELP: set-control-value
-{ $values { "value" object } { "control" control } }
-{ $description "Sets the value of the control's model." } ;
-
-ARTICLE: "ui-control-impl" "Implementing controls"
-"A control is a gadget which is linked to an underlying " { $link model } "."
-{ $subsection control }
-"There are two ways to implement a new control. First, an existing gadget can be wrapped in a control:"
-{ $subsection <control> }
-"Second, a new tuple class can be defined, whose instances delegate to controls:"
-{ $subsection construct-control }
-"Some utility words useful in control implementations:"
-{ $subsection control-model }
-{ $subsection control-value }
-{ $subsection set-control-value }
-{ $see-also "models" } ;
-
-ABOUT: "ui-control-impl"

extra/ui/gadgets/controls/controls.factor

@@ -1,37 +0,0 @@
-! Copyright (C) 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel models ui.gadgets ;
-IN: ui.gadgets.controls
-
-TUPLE: control self model quot ;
-
-: (construct-control)
-    construct dup dup set-control-self ; inline
-
-: <control> ( model gadget quot -- gadget )
-    {
-        set-control-model set-gadget-delegate set-control-quot
-    } control (construct-control) ;
-
-: control-value ( control -- value )
-    control-model model-value ;
-
-: set-control-value ( value control -- )
-    control-model set-model ;
-
-M: control graft*
-    control-self dup dup control-model add-connection
-    model-changed ;
-
-M: control ungraft*
-    control-self dup control-model remove-connection ;
-
-M: control model-changed
-    control-self
-    [ control-value ] keep
-    [ dup control-quot call ] keep
-    relayout ;
-
-: construct-control ( model underlying class -- tuple )
-    >r [ 2drop ] <control> { set-gadget-delegate } r>
-    (construct-control) ; inline

extra/ui/gadgets/controls/summary.txt

@@ -1 +0,0 @@
-Controls display a view of an underlying model

extra/ui/gadgets/editors/editors-docs.factor

@@ -1,6 +1,5 @@
 USING: documents help.markup help.syntax ui.gadgets
-ui.gadgets.scrollers ui.gadgets.controls
+ui.gadgets.scrollers models strings ui.commands ;
-models strings ui.commands ;
 IN: ui.gadgets.editors
 
 HELP: editor

extra/ui/gadgets/editors/editors.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays documents ui.clipboards ui.commands ui.gadgets
 ui.gadgets.borders ui.gadgets.buttons ui.gadgets.labels
-ui.gadgets.scrollers ui.gadgets.theme ui.gadgets.controls
+ui.gadgets.scrollers ui.gadgets.theme
 ui.render ui.gestures io kernel math models namespaces opengl
 opengl.gl sequences strings io.styles math.vectors sorting
 colors combinators ;

extra/ui/gadgets/gadgets.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays hashtables kernel models math namespaces sequences
 timers quotations math.vectors combinators sorting vectors
-dlists ;
+dlists models ;
 IN: ui.gadgets
 
 TUPLE: rect loc dim ;
@@ -43,12 +43,15 @@ M: array rect-dim drop { 0 0 } ;
 TUPLE: gadget
 pref-dim parent children orientation state focus
 visible? root? clipped? grafted?
-interior boundary ;
+interior boundary
+model ;
 
 M: gadget equal? 2drop f ;
 
 M: gadget hashcode* drop gadget hashcode* ;
 
+M: gadget model-changed drop ;
+
 : gadget-child ( gadget -- child ) gadget-children first ;
 
 : nth-gadget ( n gadget -- child ) gadget-children nth ;
@@ -63,7 +66,24 @@ M: gadget hashcode* drop gadget hashcode* ;
     } gadget construct ;
 
 : construct-gadget ( class -- tuple )
-    >r <gadget> { set-delegate } r> construct ; inline
+    >r <gadget> r> construct-delegate ; inline
+
+: construct-control ( model gadget class -- control )
+    >r tuck set-gadget-model r> construct-delegate ; inline
+
+: activate-control ( gadget -- )
+    dup gadget-model dup [ dupd add-connection ] when
+    model-changed ;
+
+: deactivate-control ( gadget -- )
+    dup gadget-model dup [ dupd remove-connection ] when
+    drop ;
+
+: control-value ( control -- value )
+    gadget-model model-value ;
+
+: set-control-value ( value control -- )
+    gadget-model set-model ;
 
 : relative-loc ( fromgadget togadget -- loc )
     2dup eq? [
@@ -228,6 +248,7 @@ M: gadget graft* drop ;
 : graft ( gadget -- )
     t over set-gadget-grafted?
     dup graft*
+    dup activate-control
     [ graft ] each-child ;
 
 GENERIC: ungraft* ( gadget -- )
@@ -237,6 +258,7 @@ M: gadget ungraft* drop ;
 : ungraft ( gadget -- )
     dup gadget-grafted? [
         dup [ ungraft ] each-child
+        dup deactivate-control
         dup ungraft*
         f over set-gadget-grafted?
     ] when drop ;

extra/ui/gadgets/labelled/labelled-docs.factor

@@ -1,5 +1,5 @@
 USING: ui.gadgets help.markup help.syntax strings models
-ui.gadgets.panes ui.gadgets.controls ;
+ui.gadgets.panes ;
 IN: ui.gadgets.labelled
 
 HELP: labelled-gadget

extra/ui/gadgets/labels/labels-docs.factor

@@ -1,5 +1,4 @@
-USING: ui.gadgets.controls help.markup
+USING: help.markup help.syntax strings ui.gadgets models ;
-help.syntax strings ui.gadgets models ;
 IN: ui.gadgets.labels
 
 HELP: label

extra/ui/gadgets/labels/labels.factor

@@ -2,8 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays hashtables io kernel math namespaces
 opengl sequences io.streams.lines strings splitting
-ui.gadgets ui.gadgets.controls ui.gadgets.tracks
+ui.gadgets ui.gadgets.tracks ui.gadgets.theme ui.render colors ;
-ui.gadgets.theme ui.render colors ;
 IN: ui.gadgets.labels
 
 ! A label gadget draws a string.
@@ -37,8 +36,13 @@ M: label draw-gadget*
 
 M: label gadget-text* label-string % ;
 
+TUPLE: label-control ;
+
+M: label-control model-changed
+    dup control-value over set-label-text relayout ;
+
 : <label-control> ( model -- gadget )
-    "" <label> [ set-label-string ] <control> ;
+    "" <label> label-control construct-control ;
 
 : text-theme ( gadget -- )
     black over set-label-color

extra/ui/gadgets/lists/lists-docs.factor

@@ -1,6 +1,5 @@
-USING: ui.commands help.markup help.syntax
+USING: ui.commands help.markup help.syntax ui.gadgets
-ui.gadgets ui.gadgets.presentations ui.gadgets.controls
+ui.gadgets.presentations ui.operations kernel models classes ;
-ui.operations kernel models classes ;
 IN: ui.gadgets.lists
 
 HELP: +secondary+

extra/ui/gadgets/lists/lists.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: ui.commands ui.gestures ui.render ui.gadgets
-ui.gadgets.controls ui.gadgets.labels ui.gadgets.scrollers
+ui.gadgets.labels ui.gadgets.scrollers
 kernel sequences models opengl math namespaces
 ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs
 math.vectors tuples ;

extra/ui/gadgets/panes/panes-docs.factor

@@ -1,5 +1,5 @@
-USING: ui.gadgets.controls ui.gadgets models
+USING: ui.gadgets models help.markup help.syntax io kernel
-help.markup help.syntax io kernel quotations ;
+quotations ;
 IN: ui.gadgets.panes
 
 HELP: pane

extra/ui/gadgets/panes/panes.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays ui.gadgets ui.gadgets.borders ui.gadgets.buttons
-ui.gadgets.labels ui.gadgets.controls ui.gadgets.scrollers
+ui.gadgets.labels ui.gadgets.scrollers
 ui.gadgets.paragraphs ui.gadgets.incremental ui.gadgets.packs
 ui.gadgets.theme ui.clipboards ui.gestures ui.traverse ui.render
 hashtables io kernel namespaces sequences io.styles strings
@@ -137,8 +137,14 @@ M: duplex-stream write-gadget
 : <scrolling-pane> ( -- pane )
     <pane> t over set-pane-scrolls? ;
 
+TUPLE: pane-control quot ;
+
+M: pane-control model-changed
+    dup control-value swap dup pane-control-quot with-pane ;
+
 : <pane-control> ( model quot -- pane )
-    [ with-pane ] curry <pane> swap <control> ;
+    >r <pane> pane-control construct-control r>
+    over set-pane-control-quot ;
 
 : do-pane-stream ( pane-stream quot -- )
     >r pane-stream-pane r> keep scroll-pane ; inline

extra/ui/gadgets/scrollers/scrollers-tests.factor

@@ -1,5 +1,5 @@
 IN: temporary
-USING: ui.gadgets ui.gadgets.scrollers ui.gadgets.controls
+USING: ui.gadgets ui.gadgets.scrollers
 namespaces tools.test kernel models ui.gadgets.viewports math
 math.vectors arrays sequences ;
 

extra/ui/gadgets/scrollers/scrollers.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2005, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays ui.gadgets ui.gadgets.controls
+USING: arrays ui.gadgets
 ui.gadgets.viewports ui.gadgets.frames ui.gadgets.grids
 ui.gadgets.theme ui.gadgets.sliders ui.gestures kernel math
 namespaces sequences models combinators math.vectors ;

extra/ui/gadgets/sliders/sliders-docs.factor

@@ -1,5 +1,4 @@
-USING: ui.gadgets.controls help.markup help.syntax ui.gadgets
+USING: help.markup help.syntax ui.gadgets models ;
-models ;
 IN: ui.gadgets.sliders
 
 HELP: elevator

extra/ui/gadgets/sliders/sliders.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays ui.gestures ui.gadgets ui.gadgets.buttons
-ui.gadgets.controls ui.gadgets.frames ui.gadgets.grids
+ui.gadgets.frames ui.gadgets.grids
 ui.gadgets.theme ui.render kernel math namespaces sequences
 vectors models math.vectors math.functions quotations colors ;
 IN: ui.gadgets.sliders

extra/ui/gadgets/slots/slots.factor

@@ -3,7 +3,7 @@
 USING: namespaces ui.gadgets ui.gestures ui.commands kernel
 ui.gadgets.scrollers parser prettyprint ui.gadgets.buttons
 sequences arrays ui.gadgets.borders ui.gadgets.tracks
-ui.gadgets.editors ui.gadgets.controls io math
+ui.gadgets.editors io math
 definitions math.vectors assocs refs ;
 IN: ui.gadgets.slots
 

extra/ui/gadgets/viewports/viewports-docs.factor

@@ -1,4 +1,4 @@
-USING: ui.gadgets.viewports ui.gadgets.controls help.markup
+USING: ui.gadgets.viewports help.markup
 help.syntax ui.gadgets models ;
 
 HELP: viewport

extra/ui/gadgets/viewports/viewports.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: ui.gadgets.viewports
-USING: arrays ui.gadgets ui.gadgets.borders ui.gadgets.controls
+USING: arrays ui.gadgets ui.gadgets.borders
 kernel math namespaces sequences models math.vectors ;
 
 : viewport-gap { 3 3 } ; inline

extra/ui/tools/deploy/deploy.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: ui.gadgets colors kernel ui.render namespaces
-ui.gadgets.controls models sequences ui.gadgets.buttons
+models sequences ui.gadgets.buttons
 ui.gadgets.packs ui.gadgets.labels tools.deploy.config
 namespaces ui.gadgets.editors ui.gadgets.borders ui.gestures
 ui.commands assocs ui.gadgets.tracks ui ui.tools.listener
@@ -52,7 +52,7 @@ TUPLE: deploy-gadget vocab settings ;
             reflection-settings
             advanced-settings
         ] make-pile dup deploy-settings-theme
-        namespace <mapping> swap [ 2drop ] <control>
+        namespace <mapping> over set-gadget-model
     ] bind ;
 
 : find-deploy-gadget

extra/ui/tools/interactor/interactor.factor

@@ -4,7 +4,7 @@ USING: arrays assocs combinators continuations documents
 ui.tools.workspace hashtables io io.styles kernel math
 math.vectors models namespaces parser prettyprint quotations
 sequences strings threads listener tuples ui.commands
-ui.gadgets ui.gadgets.controls ui.gadgets.editors
+ui.gadgets ui.gadgets.editors
 ui.gadgets.presentations ui.gadgets.worlds ui.gestures ;
 IN: ui.tools.interactor
 

extra/ui/tools/listener/listener-tests.factor

@@ -1,7 +1,7 @@
 USING: continuations documents ui.tools.interactor
 ui.tools.listener hashtables kernel namespaces parser sequences
-timers tools.test ui.commands ui.gadgets.controls
+timers tools.test ui.commands ui.gadgets.editors
-ui.gadgets.editors ui.gadgets.panes vocabs words ;
+ui.gadgets.panes vocabs words ;
 IN: temporary
 
 timers [ init-timers ] unless

extra/ui/tools/search/search-tests.factor

@@ -1,6 +1,6 @@
 USING: assocs ui.tools.search help.topics io.files io.styles
 kernel namespaces sequences source-files threads timers
-tools.test ui.gadgets ui.gadgets.controls ui.gestures vocabs
+tools.test ui.gadgets ui.gestures vocabs
 vocabs.loader words ;
 IN: temporary
 

extra/ui/tools/search/search.factor

@@ -4,7 +4,7 @@ USING: assocs ui.tools.interactor ui.tools.listener
 ui.tools.workspace help help.topics io.files io.styles kernel
 models namespaces prettyprint quotations sequences sorting
 source-files strings tools.completion tools.crossref tuples
-ui.commands ui.gadgets ui.gadgets.controls ui.gadgets.editors
+ui.commands ui.gadgets ui.gadgets.editors
 ui.gadgets.lists ui.gadgets.scrollers ui.gadgets.tracks
 ui.gestures ui.operations vocabs words vocabs.loader
 tools.browser ;

extra/ui/tools/tools-tests.factor

@@ -1,13 +1,13 @@
 USING: ui.tools ui.tools.interactor ui.tools.listener
 ui.tools.search ui.tools.workspace kernel models namespaces
 sequences timers tools.test ui.gadgets ui.gadgets.buttons
-ui.gadgets.controls ui.gadgets.labelled ui.gadgets.presentations
+ui.gadgets.labelled ui.gadgets.presentations
 ui.gadgets.scrollers vocabs ;
 IN: temporary
 
 [
     [ f ] [
-        0 <model> <gadget> [ 2drop ] <control> gadget set
+        0 <model> <gadget> [ set-gadget-model ] keep gadget set
         <workspace-tabs> gadget-children empty?
     ] unit-test 
 ] with-scope

extra/ui/tools/tools.factor

@@ -5,7 +5,7 @@ ui.tools.operations ui.tools.browser ui.tools.inspector
 ui.tools.listener ui.tools.profiler ui.tools.walker
 ui.tools.operations inspector io kernel math models namespaces
 prettyprint quotations sequences ui ui.commands ui.gadgets
-ui.gadgets.books ui.gadgets.buttons ui.gadgets.controls
+ui.gadgets.books ui.gadgets.buttons
 ui.gadgets.labelled ui.gadgets.scrollers ui.gadgets.tracks
 ui.gadgets.worlds ui.gadgets.presentations ui.gestures words
 vocabs.loader tools.test ui.gadgets.buttons

extra/ui/tools/traceback/traceback.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: continuations kernel models namespaces prettyprint ui
-ui.commands ui.gadgets ui.gadgets.controls ui.gadgets.labelled
+ui.commands ui.gadgets ui.gadgets.labelled
 ui.gadgets.tracks ui.gestures ;
 IN: ui.tools.traceback
 

extra/ui/tools/workspace/workspace.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: classes continuations help help.topics kernel models
 sequences ui ui.backend ui.tools.debugger ui.gadgets
-ui.gadgets.books ui.gadgets.buttons ui.gadgets.controls
+ui.gadgets.books ui.gadgets.buttons
 ui.gadgets.labelled ui.gadgets.panes ui.gadgets.scrollers
 ui.gadgets.tracks ui.gadgets.worlds ui.gadgets.presentations
 ui.gadgets.status-bar ui.commands ui.gestures assocs arrays