Revert basis UI gadget changes

basis/ui/gadgets/buttons/buttons.factor

@@ -1,13 +1,12 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs classes classes.tuple colors
+USING: accessors arrays kernel math models namespaces sequences
-colors.constants combinators combinators.smart fry kernel lexer
+strings quotations assocs combinators classes colors colors.constants
-locals math math.rectangles math.vectors models namespaces
+classes.tuple opengl opengl.gl math.vectors ui.commands ui.gadgets
-opengl opengl.gl quotations sequences strings ui.commands
+ui.gadgets.borders ui.gadgets.labels ui.gadgets.tracks
-ui.gadgets ui.gadgets.borders ui.gadgets.labels
+ui.gadgets.packs ui.gadgets.worlds ui.gestures ui.pens ui.pens.solid
-ui.gadgets.packs ui.gadgets.tracks ui.gadgets.worlds
+ui.pens.image ui.pens.tile math.rectangles locals fry
-ui.gestures ui.images ui.pens ui.pens.image ui.pens.solid
+combinators.smart ;
-ui.pens.tile vocabs.parser ;
 FROM: models => change-model ;
 IN: ui.gadgets.buttons
 
@@ -49,14 +48,11 @@ button H{
 } set-gestures
 
 : new-button ( label quot class -- button )
-    [ swap >label ] dip new-border swap >>quot
+    [ swap >label ] dip new-border swap >>quot ; inline
-    f <model> >>model ; inline
 
 : <button> ( label quot -- button )
     button new-button ;
 
-: button-text ( button -- string ) children>> first text>> ;
-
 TUPLE: button-pen
 plain rollover
 pressed selected pressed-selected ;
@@ -164,14 +160,6 @@ repeat-button H{
     #! the mouse is held down.
     repeat-button new-button border-button-theme ;
 
-<PRIVATE
-: image-prep ( -- image ) scan current-vocab name>>
-    "vocab:" "/icons/" surround ".tiff" surround
-    <image-name> dup cached-image drop ;
-PRIVATE>
-
-SYNTAX: IMG-BUTTON: image-prep [ swap <button> ] curry over push-all ;
-
 <PRIVATE
 
 : <checkmark-pen> ( -- pen )
@@ -262,12 +250,3 @@ PRIVATE>
 
 : add-toolbar ( track -- track )
     dup <toolbar> { 3 3 } <border> align-left f track-add ;
-
-TUPLE: button* < button value ;
-
-: <button*> ( label -- button )
-    [ [ dup value>> or ] keep set-control-value ] button* new-button ;
-
-: <border-button*> ( label -- button ) <button*> border-button-theme ;
-
-SYNTAX: IMG-BUTTON*: image-prep [ <button*> ] curry over push-all ;

basis/ui/gadgets/editors/editors-tests.factor

@@ -45,7 +45,7 @@ IN: ui.gadgets.editors.tests
 "hello" <model> <model-field> "field" set
 
 "field" get [
-    [ "hello" ] [ "field" get model>> value>> ] unit-test
+    [ "hello" ] [ "field" get field-model>> value>> ] unit-test
 ] with-grafted-gadget
 
 [ "Hello world." ] [ "Hello    \n    world." join-lines ] unit-test

basis/ui/gadgets/editors/editors.factor

@@ -580,10 +580,10 @@ TUPLE: field < border editor min-cols max-cols ;
         { 1 0 } >>fill
         field-theme ;
 
-: new-field ( class editor-class -- gadget )
+: new-field ( class -- gadget )
-    new-editor swap new-border
+    [ <editor> ] dip new-border
         dup gadget-child >>editor
-        field-theme { 1 0 } >>align ; inline
+        field-theme ; inline
 
 ! For line-gadget-width
 M: field font>> editor>> font>> ;
@@ -594,33 +594,26 @@ M: field pref-dim*
     [ line-gadget-width ] [ drop second ] 2bi 2array
     border-pref-dim ;
 
-TUPLE: model-field < field ;
+TUPLE: model-field < field field-model ;
-
-: init-model ( object -- object ) [ [ ] [ "" ] if* ] change-value ;
 
 : <model-field> ( model -- gadget )
-    model-field editor new-field swap
+    model-field new-field swap >>field-model ;
-    init-model >>model ;
-
-: <model-field*> ( -- gadget ) "" <model> <model-field> ;
 
 M: model-field graft*
-    [ [ model>> value>> ] [ editor>> ] bi set-editor-string ]
+    [ [ field-model>> value>> ] [ editor>> ] bi set-editor-string ]
     [ dup editor>> model>> add-connection ]
-    [ dup model>> add-connection ] tri ;
+    bi ;
 
 M: model-field ungraft*
-    [ dup editor>> model>> remove-connection ]
+    dup editor>> model>> remove-connection ;
-    [ dup model>> remove-connection ] bi ;
 
-M: model-field model-changed 2dup model>> =
+M: model-field model-changed
-    [ [ value>> ] [ editor>> ] bi* set-editor-string ]
+    nip [ editor>> editor-string ] [ field-model>> ] bi set-model ;
-    [ nip [ editor>> editor-string ] [ model>> ] bi set-model ] if ;
 
-TUPLE: action-field < field { quot initial: [ dup set-control-value ] } ;
+TUPLE: action-field < field quot ;
 
 : <action-field> ( quot -- gadget )
-    action-field editor new-field swap >>quot ;
+    action-field new-field swap >>quot ;
 
 : invoke-action-field ( field -- )
     [ editor>> editor-string ]
@@ -631,7 +624,3 @@ TUPLE: action-field < field { quot initial: [ dup set-control-value ] } ;
 action-field H{
     { T{ key-down f f "RET" } [ invoke-action-field ] }
 } set-gestures
-
-: <multiline-field> ( model -- gadget ) model-field multiline-editor new-field swap init-model >>model ;
-
-: <multiline-field*> ( -- editor ) "" <model> <multiline-field> ;

basis/ui/gadgets/gadgets.factor

@@ -43,9 +43,6 @@ M: gadget model-changed 2drop ;
 : control-value ( control -- value )
     model>> value>> ;
 
-GENERIC: output-model ( gadget -- model )
-M: gadget output-model model>> ;
-
 : set-control-value ( value control -- )
     model>> set-model ;
 

basis/ui/gadgets/scrollers/scrollers.factor

@@ -129,29 +129,22 @@ M: scroller model-changed
     <scroller-model> >>model
     swap >>column-header ; inline
 
-PRIVATE>
-
-GENERIC# (build-children) 2 ( gadget range orientation -- gadget slider )
-M: scroller (build-children) <slider> ;
-
-<PRIVATE
 : build-children ( gadget scroller -- scroller )
     dup model>> dependencies>>
-    [ first horizontal (build-children) >>x ]
+    [ first horizontal <slider> >>x ]
-    [ second vertical (build-children) >>y ] bi
+    [ second vertical <slider> >>y ] bi
     [ nip ] [ model>> <viewport> ] 2bi >>viewport ; inline
+
 PRIVATE>
 
-: new-scroller ( gadget class -- scroller )
+: <scroller> ( gadget -- scroller )
-    [ dup viewport-column-header
+    dup viewport-column-header
-    dup [ 2 3 ] [ 2 2 ] if ] dip new-frame
+    dup [ 2 3 ] [ 2 2 ] if scroller new-frame
         init-scroller
         build-children
         dup column-header>>
         [ build-header-scroller ] [ build-scroller ] if ;
 
-: <scroller> ( gadget -- scroller ) scroller new-scroller ;
-
 : scroll>rect ( rect gadget -- )
     dup find-scroller* dup [
         [ relative-scroll-rect ] keep
@@ -172,5 +165,3 @@ PRIVATE>
 
 : scroll>top ( gadget -- )
     <zero-rect> swap scroll>rect ;
-
-M: scroller output-model viewport>> children>> first output-model ;

basis/ui/gadgets/sliders/sliders.factor

@@ -231,8 +231,8 @@ M: slider pref-dim*
 
 PRIVATE>
 
-: new-slider ( range orientation class -- slider )
+: <slider> ( range orientation -- slider )
-    new-track
+    slider new-track
         swap >>model
         32 >>line
         dup orientation>> {
@@ -245,8 +245,3 @@ PRIVATE>
             [ drop <gadget> { 1 1 } >>dim f track-add ]
         } cleave ;
 
-: <slider> ( range orientation -- slider ) slider new-slider ;
-
-: <slider*> ( init min max step -- slider ) 0 -roll <range> horizontal <slider> ; ! most common case
-
-M: slider output-model model>> range-model ;

basis/ui/gadgets/tables/tables.factor

@@ -49,8 +49,6 @@ mouse-index
 focused?
 multiple-selection? ;
 
-M: table output-model selection>> ;
-
 <PRIVATE
 
 : add-selected-index ( table n -- table )
@@ -84,8 +82,6 @@ PRIVATE>
 
 : <table> ( rows renderer -- table ) table new-table ;
 
-: <table*> ( renderer -- table ) { } <model> swap <table> ;
-
 <PRIVATE
 
 GENERIC: cell-width ( font cell -- x )
@@ -508,35 +504,3 @@ M: table viewport-column-header
     [ <column-headers> ] [ drop f ] if ;
 
 PRIVATE>
-
-! Using quots gives functional flavor
-! No reason to force an object oriented style
-TUPLE: quot-table < table
-{ quot initial: [ ] }
-{ val-quot initial: [ ] }
-{ color-quot initial: [ drop f ] }
-column-titles column-alignment actions hooks ;
-
-M: quot-table column-titles column-titles>> ;
-M: quot-table column-alignment column-alignment>> ;
-M: quot-table row-columns quot>> call( a -- b ) ;
-M: quot-table row-value val-quot>> call( a -- b ) ;
-M: quot-table row-color color-quot>> call( a -- b ) ;
-
-M: quot-table output-model dup val-quot>> [ selection>> ] [ selection-index>> ] if ;
-
-: indexed ( table -- table ) f >>val-quot ;
-
-: new-quot-table ( model class -- table )
-    f swap new-table dup >>renderer
-    f <model> >>actions f <model> >>hooks
-    dup actions>> [ set-model ] curry >>action
-    dup hooks>> [ set-model ] curry >>hook ;
-
-: <quot-table> ( model -- table ) quot-table new-quot-table ;
-
-: <quot-table*> ( -- table ) { } <model> <quot-table> ;
-
-: <list> ( model -- table ) <quot-table> [ 1array ] >>quot ;
-
-: <list*> ( -- table ) { } <model> <list> ;

extra/file-trees/file-trees.factor

@@ -1,6 +1,7 @@
 USING: accessors arrays delegate delegate.protocols
-io.pathnames kernel locals make models.combinators sequences
+io.pathnames kernel locals sequences
-sequences.extras strings ui.gadgets.tables vectors ;
+vectors make strings models.combinators ui.gadgets.controls
+sequences.extras ;
 IN: file-trees
 
 TUPLE: walkable-vector vector father ;
@@ -44,5 +45,5 @@ DEFER: (tree-insert)
 
 : <dir-table> ( tree-model -- table )
    <list*> [ node>> 1array ] >>quot
-   [ selection>> [ file? not ] filter-model swap switch-models ]
+   [ selected-value>> [ file? not ] filter-model swap switch-models ]
    [ swap >>model ] bi ;

extra/recipes/recipes.factor

@@ -1,9 +1,8 @@
-USING: accessors arrays colors.constants combinators db.sqlite
+USING: accessors arrays colors.constants combinators
-db.tuples db.types io.files.temp kernel locals math
+db.sqlite db.tuples db.types kernel locals math
-models.combinators monads persistency sequences
+monads persistency sequences sequences.extras ui ui.gadgets.controls
-sequences.extras ui ui.gadgets.buttons ui.gadgets.editors
+ui.gadgets.layout models.combinators ui.gadgets.labels
-ui.gadgets.labels ui.gadgets.layout ui.gadgets.scrollers
+ui.gadgets.scrollers ui.pens.solid io.files.temp ;
-ui.gadgets.tables ui.pens.solid ;
 FROM: sets => prune ;
 IN: recipes
 
@@ -24,34 +23,34 @@ STORED-TUPLE: recipe { title { VARCHAR 100 } } { votes INTEGER } { txt TEXT } {
      [
         [ "Title:" <label> , $ TITLE $ "Genre:" <label> , $ GENRE $ ] <hbox> ,
         $ BODY $
-        $ BUTTON* $
+        $ BUTTON $
      ] <vbox> ,
   ] <book*> { 350 245 } >>pref-dim ;
   
 :: recipe-browser ( -- ) [ [
     interface
-      <quot-table*> :> tbl
+      <table*> :> tbl
-      "okay" <border-button*> BUTTON* -> :> ok
+      "okay" <model-border-btn> BUTTON -> :> ok
-      IMG-BUTTON*: submit [ store-tuple ] >>value TOOLBAR -> :> submit
+      IMG-MODEL-BTN: submit [ store-tuple ] >>value TOOLBAR -> :> submit
-      IMG-BUTTON*: love 1 >>value TOOLBAR ->
+      IMG-MODEL-BTN: love 1 >>value TOOLBAR ->
-      IMG-BUTTON*: hate -1 >>value -> 2array merge :> votes
+      IMG-MODEL-BTN: hate -1 >>value -> 2array merge :> votes
-      IMG-BUTTON*: back -> [ -30 ] <$
+      IMG-MODEL-BTN: back -> [ -30 ] <$
-      IMG-BUTTON*: more -> [ 30 ] <$ 2array merge :> viewed
+      IMG-MODEL-BTN: more -> [ 30 ] <$ 2array merge :> viewed
       <spacer> <model-field*> ->% 1 :> search
       submit ok [ [ drop ] ] <$ 2array merge [ drop ] >>value :> quot
-      viewed 0 [ + ] fold search ok t <basic> "all" <button*> ALL ->
+      viewed 0 [ + ] fold search ok t <basic> "all" <model-btn> ALL ->
       tbl selection>> votes [ [ + ] curry change-votes modify-tuple ] 2$>
         4array merge
         [ drop [ f ] [ "%" dup surround <pattern> ] if-empty top-recipes ] 3fmap :> ups
-      ups [ top-genres [ <button*> GENRES -> ] map merge ] bind*
+      ups [ top-genres [ <model-btn> GENRES -> ] map merge ] bind*
-        [ button-text T{ recipe } swap >>genre get-tuples ] fmap
+        [ text>> T{ recipe } swap >>genre get-tuples ] fmap
       tbl swap ups 2merge >>model
         [ [ title>> ] [ genre>> ] bi 2array ] >>quot
         { "Title" "Genre" } >>column-titles dup <scroller> RECIPES ,% 1 actions>>
       submit [ "" dup dup <recipe> ] <$ 2array merge
         { [ [ title>> ] fmap <model-field> TITLE ->% .5 ]
           [ [ genre>> ] fmap <model-field> GENRE ->% .5 ]
-          [ [ txt>> ] fmap <multiline-field> BODY ->% 1 ]
+          [ [ txt>> ] fmap <model-editor> BODY ->% 1 ]
         } cleave
         [ <recipe> ] 3fmap
       [ [ 1 ] <$ ]

extra/sudokus/sudokus.factor

@@ -1,8 +1,8 @@
-USING: accessors arrays combinators.short-circuit fry grouping
+USING: accessors arrays combinators.short-circuit grouping kernel lists
-kernel lists lists.lazy locals math math.functions math.parser
+lists.lazy locals math math.functions math.parser math.ranges
-math.ranges models.combinators models.product monads random
+models.product monads random sequences sets ui ui.gadgets.controls
-sequences sets ui ui.gadgets.alerts ui.gadgets.buttons
+ui.gadgets.layout models.combinators ui.gadgets.alerts vectors fry
-ui.gadgets.editors ui.gadgets.labels ui.gadgets.layout vectors ;
+ui.gadgets.labels ;
 IN: sudokus
 
 : row ( index -- row ) 1 + 9 / ceiling ;
@@ -29,8 +29,8 @@ IN: sudokus
                [ [ [ <spacer> [ [ <model-field> ->% 2 [ string>number ] fmap ]
                     map <spacer> ] map concat ] <hbox> , ] map concat <spacer> ] map concat <product>
                [ "Difficulty:" <label> , "1" <basic> <model-field> -> [ string>number 1 or 1 + 10 * ] fmap
-               "Generate" <border-button*> -> updates [ create ] fmap <spacer>
+               "Generate" <model-border-btn> -> updates [ create ] fmap <spacer>
-               "Hint" <border-button*> -> "Solve" <border-button*> -> ] <hbox> ,
+               "Hint" <model-border-btn> -> "Solve" <model-border-btn> -> ] <hbox> ,
                roll [ swap updates ] curry bi@
                [ [ hint ] fmap ] [ [ f solution ] fmap ] bi* 3array merge [ [ [ number>string ] [ "" ] if* ] map ] fmap
            ] bind

extra/ui/gadgets/alerts/alerts.factor

@@ -1,5 +1,5 @@
 USING: accessors models monads macros generalizations kernel
-ui models.combinators ui.gadgets.layout ui.gadgets
+ui ui.gadgets.controls models.combinators ui.gadgets.layout ui.gadgets
 ui.gadgets.labels ui.gadgets.editors ui.gadgets.buttons
 ui.gadgets.packs locals sequences fonts io.styles
 wrap.strings ;
@@ -14,7 +14,7 @@ IN: ui.gadgets.alerts
 :: ask-user ( string -- model' )
    [ [let | lbl  [ string <label>  T{ font { name "sans-serif" } { size 14 } } >>font dup , ]
             fldm [ <model-field*> ->% 1 ]
-            btn  [ "okay" <border-button*> ] |
+            btn  [ "okay" <model-border-btn> ] |
          btn -> [ fldm swap updates ]
                 [ [ drop lbl close-window ] $> , ] bi
    ] ] <vbox> { 161 86 } >>pref-dim "" open-window ;
@@ -22,7 +22,7 @@ IN: ui.gadgets.alerts
 MACRO: ask-buttons ( buttons -- quot ) dup length [
       [ swap
          [ 22 wrap-lines <label> T{ font { name "sans-serif" } { size 18 } } >>font ,
-         [ [ <border-button*> [ [ dup close-window ] prepend ] change-quot -> ] map ] <hbox> , ] <vbox>
+         [ [ <model-border-btn> [ close-window ] >>hook -> ] map ] <hbox> , ] <vbox>
          "" open-window
       ] dip firstn
    ] 2curry ;

extra/ui/gadgets/comboboxes/comboboxes.factor

@@ -1,14 +1,15 @@
-USING: accessors arrays kernel math.rectangles
+USING: accessors arrays kernel math.rectangles sequences
-models.combinators sequences ui.gadgets ui.gadgets.glass
+ui.gadgets.controls models.combinators ui.gadgets ui.gadgets.glass
-ui.gadgets.labels ui.gadgets.tables ui.gestures ;
+ui.gadgets.labels ui.gestures ;
+QUALIFIED-WITH: ui.gadgets.tables tbl
 IN: ui.gadgets.comboboxes
 
-TUPLE: combo-table < quot-table spawner ;
+TUPLE: combo-table < table spawner ;
 
 M: combo-table handle-gesture [ call-next-method drop ] 2keep swap
    T{ button-up } = [
       [ spawner>> ]
-      [ selected-row [ swap set-control-value ] [ 2drop ] if ]
+      [ tbl:selected-row [ swap set-control-value ] [ 2drop ] if ]
       [ hide-glass ] tri
    ] [ drop ] if t ;
 
@@ -18,4 +19,4 @@ combobox H{
 } set-gestures
 
 : <combobox> ( options -- combobox ) [ first [ combobox new-label ] keep <basic> >>model ] keep
-    <basic> combo-table new-quot-table [ 1array ] >>quot >>table ;
+    <basic> combo-table new-table [ 1array ] >>quot >>table ;

extra/ui/gadgets/controls/authors.txt

@@ -0,0 +1 @@
+Sam Anklesaria

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

@@ -0,0 +1,71 @@
+USING: accessors help.markup help.syntax ui.gadgets.buttons
+ui.gadgets.editors models ui.gadgets ;
+IN: ui.gadgets.controls
+
+HELP: <model-btn>
+{ $values { "gadget" "the button's label" } { "button" button } }
+{ $description "Creates an button whose signal updates on clicks.  " } ;
+
+HELP: <model-border-btn>
+{ $values { "text" "the button's label" } { "button" button } }
+{ $description "Creates an button whose signal updates on clicks.  " } ;
+
+HELP: <table>
+{ $values { "model" "values the table is to display" } { "table" table } }
+{ $description "Creates an " { $link table } } ;
+
+HELP: <table*>
+{ $values { "table" table } }
+{ $description "Creates an " { $link table } " with no initial values to display" } ;
+
+HELP: <list>
+{ $values { "column-model" "values the table is to display" } { "table" table } }
+{ $description "Creates an " { $link table } " with a val-quot that renders each element as its own row" } ;
+
+HELP: <list*>
+{ $values { "table" table } }
+{ $description "Creates an model-list with no initial values to display" } ;
+
+HELP: indexed
+{ $values { "table" table } }
+{ $description "Sets the output model of an table to the selected-index, rather than the selected-value" } ;
+
+HELP: <model-field>
+{ $values { "model" model } { "gadget" model-field } }
+{ $description "Creates a field with an initial value" } ;
+
+HELP: <model-field*>
+{ $values { "field" model-field } }
+{ $description "Creates a field with an empty initial value" } ;
+
+HELP: <empty-field>
+{ $values { "model" model } { "field" model-field } }
+{ $description "Creates a field with an empty initial value that switches to another signal on its update" } ;
+
+HELP: <model-editor>
+{ $values { "model" model } { "gadget" model-field } }
+{ $description "Creates an editor with an initial value" } ;
+
+HELP: <model-editor*>
+{ $values { "editor" "an editor" } }
+{ $description "Creates a editor with an empty initial value" } ;
+
+HELP: <empty-editor>
+{ $values { "model" model } { "editor" "an editor" } }
+{ $description "Creates a field with an empty initial value that switches to another signal on its update" } ;
+
+HELP: <model-action-field>
+{ $values { "field" action-field } }
+{ $description "Field that updates its model with its contents when the user hits the return key" } ;
+
+HELP: IMG-MODEL-BTN:
+{ $syntax "IMAGE-MODEL-BTN: filename" }
+{ $description "Creates a button using a tiff image named as specified found in the icons subdirectory of the vocabulary path" } ;
+
+HELP: IMG-BTN:
+{ $syntax "[ do-something ] IMAGE-BTN: filename" }
+{ $description "Creates a button using a tiff image named as specified found in the icons subdirectory of the vocabulary path, calling the specified quotation on click" } ;
+
+HELP: output-model
+{ $values { "gadget" gadget } { "model" model } }
+{ $description "Returns the model a gadget uses for output. Often the same as " { $link model>> } } ;

extra/ui/gadgets/controls/controls.factor

@@ -0,0 +1,83 @@
+USING: accessors assocs arrays kernel models monads sequences
+models.combinators ui.gadgets ui.gadgets.borders ui.gadgets.buttons
+ui.gadgets.buttons.private ui.gadgets.editors words images.loader
+ui.gadgets.scrollers ui.images vocabs.parser lexer
+models.range ui.gadgets.sliders ;
+QUALIFIED-WITH: ui.gadgets.sliders slider
+QUALIFIED-WITH: ui.gadgets.tables tbl
+EXCLUDE: ui.gadgets.editors => model-field ;
+IN: ui.gadgets.controls
+
+TUPLE: model-btn < button hook value ;
+: <model-btn> ( gadget -- button ) [
+      [ dup hook>> [ call( button -- ) ] [ drop ] if* ]
+      [ [ [ value>> ] [ ] bi or ] keep set-control-value ]
+      [ model>> f swap (>>value) ] tri
+   ] model-btn new-button f <basic> >>model ;
+: <model-border-btn> ( text -- button ) <model-btn> border-button-theme ;
+
+TUPLE: table < tbl:table { quot initial: [ ] } { val-quot initial: [ ] } color-quot column-titles column-alignment actions ;
+M: table tbl:column-titles column-titles>> ;
+M: table tbl:column-alignment column-alignment>> ;
+M: table tbl:row-columns quot>> [ call( a -- b ) ] [ drop f ] if* ;
+M: table tbl:row-value val-quot>> [ call( a -- b ) ]  [ drop f ] if* ;
+M: table tbl:row-color color-quot>> [ call( a -- b ) ]  [ drop f ] if* ;
+
+: new-table ( model class -- table ) f swap tbl:new-table dup >>renderer
+   f <basic> >>actions dup actions>> [ set-model ] curry >>action ;
+: <table> ( model -- table ) table new-table ;
+: <table*> ( -- table ) V{ } clone <model> <table> ;
+: <list> ( column-model -- table ) <table> [ 1array ] >>quot ;
+: <list*> ( -- table ) V{ } clone <model> <list> ;
+: indexed ( table -- table ) f >>val-quot ;
+
+TUPLE: model-field < field model* ;
+: init-field ( model -- model' ) [ [ ] [ "" ] if* ] change-value ;
+: <model-field> ( model -- gadget ) model-field new-field swap init-field >>model* ;
+M: model-field graft*
+    [ [ model*>> value>> ] [ editor>> ] bi set-editor-string ]
+    [ dup editor>> model>> add-connection ]
+    [ dup model*>> add-connection ] tri ;
+M: model-field ungraft*
+   [ dup editor>> model>> remove-connection ]
+   [ dup model*>> remove-connection ] bi ;
+M: model-field model-changed 2dup model*>> =
+    [ [ value>> ] [ editor>> ] bi* set-editor-string ]
+    [ nip [ editor>> editor-string ] [ model*>> ] bi set-model ] if ;
+ 
+: (new-field) ( editor field -- gadget ) [ new-editor ] dip new-border dup gadget-child >>editor
+    field-theme { 1 0 } >>align ; inline
+: <model-field*> ( -- field ) "" <model> <model-field> ;
+: <empty-field> ( model -- field ) "" <model> switch-models <model-field> ;
+: <model-editor> ( model -- gadget ) multiline-editor model-field (new-field) swap init-field >>model* ;
+: <model-editor*> ( -- editor ) "" <model> <model-editor> ;
+: <empty-editor> ( model -- editor ) "" <model> switch-models <model-editor> ;
+
+: <model-action-field> ( -- field ) f <action-field> dup [ set-control-value ] curry >>quot
+    f <model> >>model ;
+
+: <slider> ( init page min max step -- slider ) <range> horizontal slider:<slider> ;
+
+: image-prep ( -- image ) scan current-vocab name>> "vocab:" "/icons/" surround ".tiff" surround <image-name> dup cached-image drop ;
+SYNTAX: IMG-MODEL-BTN: image-prep [ <model-btn> ] curry over push-all ;
+
+SYNTAX: IMG-BTN: image-prep [ swap <button> ] curry over push-all ;
+
+GENERIC: output-model ( gadget -- model )
+M: gadget output-model model>> ;
+M: table output-model dup val-quot>> [ selection>> ] [ selection-index>> ] if ;
+M: model-field output-model model*>> ;
+M: scroller output-model viewport>> children>> first output-model ;
+M: slider output-model model>> range-model ;
+
+IN: accessors
+M: model-btn text>> children>> first text>> ;
+
+IN: ui.gadgets.controls
+
+SINGLETON: gadget-monad
+INSTANCE: gadget-monad monad
+INSTANCE: gadget monad
+M: gadget monad-of drop gadget-monad ;
+M: gadget-monad return drop <gadget> swap >>model ;
+M: gadget >>= output-model [ swap call( x -- y ) ] curry ; 

extra/ui/gadgets/controls/summary.txt

@@ -0,0 +1 @@
+Gadgets with expanded model usage

extra/ui/gadgets/layout/layout.factor

@@ -1,7 +1,7 @@
 USING: accessors assocs arrays fry kernel lexer make math.parser
 models monads namespaces parser sequences
 sequences.extras models.combinators ui.gadgets
-ui.gadgets.tracks words ;
+ui.gadgets.tracks words ui.gadgets.controls ;
 QUALIFIED: make
 QUALIFIED-WITH: ui.gadgets.books book
 IN: ui.gadgets.layout

extra/ui/gadgets/poppers/poppers.factor

@@ -2,14 +2,14 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays accessors combinators kernel math
 models models.combinators namespaces sequences
-ui.gadgets ui.gadgets.layout ui.gadgets.tracks
+ui.gadgets ui.gadgets.controls ui.gadgets.layout
-ui.gestures ui.gadgets.line-support
+ui.gadgets.tracks ui.gestures ui.gadgets.line-support ;
-ui.gadgets.editors ;
+EXCLUDE: ui.gadgets.editors => model-field ;
 IN: ui.gadgets.poppers
 
 TUPLE: popped < model-field { fatal? initial: t } ;
 TUPLE: popped-editor < multiline-editor ;
-: <popped> ( text -- gadget ) <basic> init-model popped popped-editor new-field swap >>model t >>clipped? ;
+: <popped> ( text -- gadget ) <basic> init-field popped-editor popped (new-field) swap >>model* ;
 
 : set-expansion ( popped size -- ) over dup parent>> [ children>> index ] [ sizes>> ] bi set-nth relayout ;
 : new-popped ( popped -- ) insertion-point "" <popped>
@@ -25,27 +25,26 @@ TUPLE: popper < track { unfocus-hook initial: [ drop ] } ;
 ! list of strings is model (make shown objects implement sequence protocol)
 : <popper> ( model -- popper ) vertical popper new-track swap >>model ;
 
-popped H{
+M: popped handle-gesture swap {
-    { gain-focus [ 1 set-expansion ] }
+    { gain-focus [ 1 set-expansion f ] }
     { lose-focus [ dup parent>>
         [ [ unfocus-hook>> call( a -- ) ] curry [ f set-expansion ] bi ]
-        [ drop ] if*
+        [ drop ] if* f
     ] }
-    { T{ key-up f f "RET" } [ dup editor>> delete-previous-character new-popped ] }
+    { T{ key-up f f "RET" } [ dup editor>> delete-previous-character new-popped f ] }
     { T{ key-up f f "BACKSPACE" } [ dup editor>> editor-string "" =
         [ dup fatal?>> [ [ focus-prev ] [ unparent ] bi ] [ t >>fatal? drop ] if ]
-        [ f >>fatal? drop ] if
+        [ f >>fatal? drop ] if f
     ] }
-} set-gestures
+    [ swap call-next-method ]
+} case ;
 
 M: popper handle-gesture swap T{ button-down f f 1 } =
-[ hand-click# get 2 = [ initial-popped ] [ drop ] if ] [ drop ] if t ;
+    [ hand-click# get 2 = [ initial-popped ] [ drop ] if ] [ drop ] if f ;
 
 M: popper model-changed
     [ children>> [ unparent ] each ]
     [ [ value>> [ <popped> ] map ] dip [ f track-add ] reduce request-focus ] bi ;
 
-M: popped pref-dim* editor>>
+M: popped pref-dim* editor>> [ pref-dim* first ] [ line-height ] bi 2array ;
-    [ pref-dim* first ] [ line-height ] bi 2array ;
-
 M: popper focusable-child* children>> [ t ] [ first ] if-empty ;