merged control extras into basis

basis/ui/gadgets/buttons/buttons.factor

@@ -1,12 +1,13 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel math models namespaces sequences
-strings quotations assocs combinators classes colors colors.constants
-classes.tuple opengl opengl.gl math.vectors ui.commands ui.gadgets
-ui.gadgets.borders ui.gadgets.labels ui.gadgets.tracks
-ui.gadgets.packs ui.gadgets.worlds ui.gestures ui.pens ui.pens.solid
-ui.pens.image ui.pens.tile math.rectangles locals fry
-combinators.smart ;
+USING: accessors arrays assocs classes classes.tuple colors
+colors.constants combinators combinators.smart fry kernel lexer
+locals math math.rectangles math.vectors models namespaces
+opengl opengl.gl quotations sequences strings ui.commands
+ui.gadgets ui.gadgets.borders ui.gadgets.labels
+ui.gadgets.packs ui.gadgets.tracks ui.gadgets.worlds
+ui.gestures ui.images ui.pens ui.pens.image ui.pens.solid
+ui.pens.tile vocabs.parser ;
 FROM: models => change-model ;
 IN: ui.gadgets.buttons
 
@@ -48,11 +49,14 @@ button H{
 } set-gestures
 
 : new-button ( label quot class -- button )
-    [ swap >label ] dip new-border swap >>quot ; inline
+    [ swap >label ] dip new-border swap >>quot
+    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 ;
@@ -160,6 +164,14 @@ 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 )
@@ -250,3 +262,12 @@ 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 field-model>> value>> ] unit-test
+    [ "hello" ] [ "field" get 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 -- gadget )
-    [ <editor> ] dip new-border
+: new-field ( class editor-class -- gadget )
+    new-editor swap new-border
         dup gadget-child >>editor
-        field-theme ; inline
+        field-theme { 1 0 } >>align ; inline
 
 ! For line-gadget-width
 M: field font>> editor>> font>> ;
@@ -594,26 +594,33 @@ M: field pref-dim*
     [ line-gadget-width ] [ drop second ] 2bi 2array
     border-pref-dim ;
 
-TUPLE: model-field < field field-model ;
+TUPLE: model-field < field ;
+
+: init-model ( object -- object ) [ [ ] [ "" ] if* ] change-value ;
 
 : <model-field> ( model -- gadget )
-    model-field new-field swap >>field-model ;
+    model-field editor new-field swap
+    init-model >>model ;
+
+: <model-field*> ( -- gadget ) "" <model> <model-field> ;
 
 M: model-field graft*
-    [ [ field-model>> value>> ] [ editor>> ] bi set-editor-string ]
+    [ [ model>> value>> ] [ editor>> ] bi set-editor-string ]
     [ dup editor>> model>> add-connection ]
-    bi ;
+    [ dup model>> add-connection ] tri ;
 
 M: model-field ungraft*
-    dup editor>> model>> remove-connection ;
+    [ dup editor>> model>> remove-connection ]
+    [ dup model>> remove-connection ] bi ;
 
-M: model-field model-changed
-    nip [ editor>> editor-string ] [ field-model>> ] bi set-model ;
+M: model-field model-changed 2dup model>> =
+    [ [ value>> ] [ editor>> ] bi* set-editor-string ]
+    [ nip [ editor>> editor-string ] [ model>> ] bi set-model ] if ;
 
-TUPLE: action-field < field quot ;
+TUPLE: action-field < field { quot initial: [ dup set-control-value ] } ;
 
 : <action-field> ( quot -- gadget )
-    action-field new-field swap >>quot ;
+    action-field editor new-field swap >>quot ;
 
 : invoke-action-field ( field -- )
     [ editor>> editor-string ]
@@ -624,3 +631,7 @@ TUPLE: action-field < field quot ;
 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,6 +43,9 @@ 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

@@ -99,7 +99,7 @@ M: scroller layout*
     [ call-next-method ] [
         dup follows>>
         [ update-scroller ] [ >>follows drop ] 2bi
-    ] bi ; 
+    ] bi ;
 
 M: scroller focusable-child*
     viewport>> ;
@@ -129,22 +129,29 @@ M: scroller model-changed
     <scroller-model> >>model
     swap >>column-header ; inline
 
-: build-children ( gadget scroller -- scroller )
-    dup model>> dependencies>>
-    [ first horizontal <slider> >>x ]
-    [ second vertical <slider> >>y ] bi
-    [ nip ] [ model>> <viewport> ] 2bi >>viewport ; inline
-
 PRIVATE>
 
-: <scroller> ( gadget -- scroller )
-    dup viewport-column-header
-    dup [ 2 3 ] [ 2 2 ] if scroller new-frame
+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 ]
+    [ second vertical (build-children) >>y ] bi
+    [ nip ] [ model>> <viewport> ] 2bi >>viewport ; inline
+PRIVATE>
+
+: new-scroller ( gadget class -- scroller )
+    [ dup viewport-column-header
+    dup [ 2 3 ] [ 2 2 ] if ] dip 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
@@ -165,3 +172,5 @@ 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>
 
-: <slider> ( range orientation -- slider )
-    slider new-track
+: new-slider ( range orientation class -- slider )
+    new-track
         swap >>model
         32 >>line
         dup orientation>> {
@@ -245,3 +245,8 @@ 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

@@ -50,6 +50,8 @@ mouse-index
 focused?
 multiple-selection? ;
 
+M: table output-model selection>> ;
+
 <PRIVATE
 
 : push-selected-index ( table n -- table ) swap
@@ -74,6 +76,8 @@ PRIVATE>
 
 : <table> ( rows renderer -- table ) table new-table ;
 
+: <table*> ( renderer -- table ) { } <model> swap <table> ;
+
 <PRIVATE
 
 GENERIC: cell-width ( font cell -- x )
@@ -478,4 +482,36 @@ M: table viewport-column-header
     dup renderer>> column-titles
     [ <column-headers> ] [ drop f ] if ;
 
-PRIVATE>
+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,7 +1,6 @@
 USING: accessors arrays delegate delegate.protocols
-io.pathnames kernel locals sequences
-vectors make strings models.combinators ui.gadgets.controls
-sequences.extras ;
+io.pathnames kernel locals make models.combinators sequences
+sequences.extras strings ui.gadgets.tables vectors ;
 IN: file-trees
 
 TUPLE: walkable-vector vector father ;
@@ -45,5 +44,5 @@ DEFER: (tree-insert)
 
 : <dir-table> ( tree-model -- table )
    <list*> [ node>> 1array ] >>quot
-   [ selected-value>> [ file? not ] filter-model swap switch-models ]
+   [ selection>> [ file? not ] filter-model swap switch-models ]
    [ swap >>model ] bi ;

extra/recipes/recipes.factor

@@ -1,8 +1,9 @@
-USING: accessors arrays colors.constants combinators
-db.sqlite db.tuples db.types kernel locals math
-monads persistency sequences sequences.extras ui ui.gadgets.controls
-ui.gadgets.layout models.combinators ui.gadgets.labels
-ui.gadgets.scrollers ui.pens.solid io.files.temp ;
+USING: accessors arrays colors.constants combinators db.sqlite
+db.tuples db.types io.files.temp kernel locals math
+models.combinators monads persistency sequences
+sequences.extras ui ui.gadgets.buttons ui.gadgets.editors
+ui.gadgets.labels ui.gadgets.layout ui.gadgets.scrollers
+ui.gadgets.tables ui.pens.solid ;
 FROM: sets => prune ;
 IN: recipes
 
@@ -23,34 +24,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
-      <table*> :> tbl
-      "okay" <model-border-btn> BUTTON -> :> ok
-      IMG-MODEL-BTN: submit [ store-tuple ] >>value TOOLBAR -> :> submit
-      IMG-MODEL-BTN: love 1 >>value TOOLBAR ->
-      IMG-MODEL-BTN: hate -1 >>value -> 2array merge :> votes
-      IMG-MODEL-BTN: back -> [ -30 ] <$
-      IMG-MODEL-BTN: more -> [ 30 ] <$ 2array merge :> viewed
+      <quot-table*> :> tbl
+      "okay" <border-button*> BUTTON* -> :> ok
+      IMG-BUTTON*: submit [ store-tuple ] >>value TOOLBAR -> :> submit
+      IMG-BUTTON*: love 1 >>value TOOLBAR ->
+      IMG-BUTTON*: hate -1 >>value -> 2array merge :> votes
+      IMG-BUTTON*: back -> [ -30 ] <$
+      IMG-BUTTON*: 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" <model-btn> ALL ->
+      viewed 0 [ + ] fold search ok t <basic> "all" <button*> 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 [ <model-btn> GENRES -> ] map merge ] bind*
-        [ text>> T{ recipe } swap >>genre get-tuples ] fmap
+      ups [ top-genres [ <button*> GENRES -> ] map merge ] bind*
+        [ button-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 <model-editor> BODY ->% 1 ]
+          [ [ txt>> ] fmap <multiline-field> BODY ->% 1 ]
         } cleave
         [ <recipe> ] 3fmap
       [ [ 1 ] <$ ]

extra/sudokus/sudokus.factor

@@ -1,8 +1,8 @@
-USING: accessors arrays combinators.short-circuit grouping kernel lists
-lists.lazy locals math math.functions math.parser math.ranges
-models.product monads random sequences sets ui ui.gadgets.controls
-ui.gadgets.layout models.combinators ui.gadgets.alerts vectors fry
-ui.gadgets.labels ;
+USING: accessors arrays combinators.short-circuit fry grouping
+kernel lists lists.lazy locals math math.functions math.parser
+math.ranges models.combinators models.product monads random
+sequences sets ui ui.gadgets.alerts ui.gadgets.buttons
+ui.gadgets.editors ui.gadgets.labels ui.gadgets.layout vectors ;
 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" <model-border-btn> -> updates [ create ] fmap <spacer>
-               "Hint" <model-border-btn> -> "Solve" <model-border-btn> -> ] <hbox> ,
+               "Generate" <border-button*> -> updates [ create ] fmap <spacer>
+               "Hint" <border-button*> -> "Solve" <border-button*> -> ] <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 ui.gadgets.controls models.combinators ui.gadgets.layout ui.gadgets
+ui 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" <model-border-btn> ] |
+            btn  [ "okay" <border-button*> ] |
          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 ,
-         [ [ <model-border-btn> [ close-window ] >>hook -> ] map ] <hbox> , ] <vbox>
+         [ [ <border-button*> [ [ dup close-window ] prepend ] change-quot -> ] map ] <hbox> , ] <vbox>
          "" open-window
       ] dip firstn
    ] 2curry ;

extra/ui/gadgets/comboboxes/comboboxes.factor

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

extra/ui/gadgets/controls/authors.txt

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

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

@@ -1,71 +0,0 @@
-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

@@ -1,83 +0,0 @@
-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

@@ -1 +0,0 @@
-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.controls ;
+ui.gadgets.tracks words ;
 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.controls ui.gadgets.layout
-ui.gadgets.tracks ui.gestures ui.gadgets.line-support ;
-EXCLUDE: ui.gadgets.editors => model-field ;
+ui.gadgets ui.gadgets.layout ui.gadgets.tracks
+ui.gestures ui.gadgets.line-support
+ui.gadgets.editors ;
 IN: ui.gadgets.poppers
 
 TUPLE: popped < model-field { fatal? initial: t } ;
 TUPLE: popped-editor < multiline-editor ;
-: <popped> ( text -- gadget ) <basic> init-field popped-editor popped (new-field) swap >>model* ;
+: <popped> ( text -- gadget ) <basic> init-model popped popped-editor new-field swap >>model t >>clipped? ;
 
 : set-expansion ( popped size -- ) over dup parent>> [ children>> index ] [ sizes>> ] bi set-nth relayout ;
 : new-popped ( popped -- ) insertion-point "" <popped>
@@ -25,26 +25,27 @@ 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 ;
 
-M: popped handle-gesture swap {
-    { gain-focus [ 1 set-expansion f ] }
+popped H{
+    { gain-focus [ 1 set-expansion ] }
     { lose-focus [ dup parent>>
         [ [ unfocus-hook>> call( a -- ) ] curry [ f set-expansion ] bi ]
-        [ drop ] if* f
+        [ drop ] if*
     ] }
-    { T{ key-up f f "RET" } [ dup editor>> delete-previous-character new-popped f ] }
+    { T{ key-up f f "RET" } [ dup editor>> delete-previous-character new-popped ] }
     { 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
+        [ f >>fatal? drop ] if
     ] }
-    [ swap call-next-method ]
-} case ;
+} set-gestures
 
 M: popper handle-gesture swap T{ button-down f f 1 } =
-    [ hand-click# get 2 = [ initial-popped ] [ drop ] if ] [ drop ] if f ;
+[ hand-click# get 2 = [ initial-popped ] [ drop ] if ] [ drop ] if t ;
 
 M: popper model-changed
     [ children>> [ unparent ] each ]
     [ [ value>> [ <popped> ] map ] dip [ f track-add ] reduce request-focus ] bi ;
 
-M: popped pref-dim* editor>> [ pref-dim* first ] [ line-height ] bi 2array ;
+M: popped pref-dim* editor>>
+    [ pref-dim* first ] [ line-height ] bi 2array ;
+
 M: popper focusable-child* children>> [ t ] [ first ] if-empty ;