frp-table additions

extra/ui/frp/frp-docs.factor

@@ -15,7 +15,7 @@ HELP: <vbox>
 { $description "Creates an vertical track containing the gadgets listed in the quotation" } ;
 
 ! Gadgets
-HELP: <model-button>
+HELP: <frp-button>
 { $description "Creates an button whose model updates on clicks" } ;
 
 HELP: <merge>

extra/ui/frp/frp.factor

@@ -1,9 +1,26 @@
-USING: accessors arrays fry kernel models models.product
+USING: accessors arrays colors fonts fry kernel models
-monads sequences ui.gadgets ui.gadgets.buttons ui.gadgets.tracks
+models.product monads sequences ui.gadgets ui.gadgets.buttons
-ui.gadgets.tables ;
+ui.gadgets.editors ui.gadgets.line-support ui.gadgets.tables
+ui.gadgets.tracks ui.render ;
 QUALIFIED: make
 IN: ui.frp
 
+! Gadgets
+: <frp-button> ( text -- button ) [ t swap set-control-value ] <border-button> f <model> >>model ;
+TUPLE: frp-table < table quot val-quot color-quot column-titles column-alignment ;
+M: frp-table column-titles column-titles>> ;
+M: frp-table column-alignment column-alignment>> ;
+M: frp-table row-columns quot>> call( a -- b ) ;
+M: frp-table row-value val-quot>> call( a -- b ) ;
+M: frp-table row-color color-quot>> call( a -- b ) ;
+
+: <frp-table> ( model quot -- table )
+    frp-table new-line-gadget dup >>renderer swap >>quot swap >>model
+    f <model> >>selected-value sans-serif-font >>font
+    focus-border-color >>focus-border-color
+    transparent >>column-line-color ;
+: <frp-field> ( -- field ) f <model> <model-field> ;
+
 ! Layout utilities
 
 GENERIC: output-model ( gadget -- model )
@@ -17,6 +34,7 @@ M: model , activate-model ;
 GENERIC: -> ( object -- model )
 M: gadget -> dup make:, output-model ;
 M: model -> dup , ;
+M: table -> dup , selected-value>> ;
 
 : <box> ( models type -- track )
    [ { } make:make ] dip <track> swap dup [ model>> ] map <product>
@@ -24,18 +42,6 @@ M: model -> dup , ;
 : <hbox> ( models -- track ) horizontal <box> ; inline
 : <vbox> ( models -- track ) vertical <box> ; inline
 
-! Gadgets
-: <frp-button> ( text -- button ) [ t swap set-control-value ] <bevel-button> f <model> >>model ;
-TUPLE: frp-table < table quot column-titles column-alignment ;
-M: frp-table column-titles column-titles>> ;
-M: frp-table column-alignment column-alignment>> ;
-M: frp-table row-columns quot>> call( a -- b ) ;
-: <frp-table> ( model quot -- table )
-    frp-table new-line-gadget dup >>renderer swap >>quot swap >>model
-    f <model> >>selected-value sans-serif-font >>font
-    focus-border-color >>focus-border-color
-    transparent >>column-line-color ;
-
 ! Model utilities
 TUPLE: multi-model < model ;
 ! M: multi-model model-activated dup model-changed ;
@@ -80,7 +86,4 @@ INSTANCE: gadget-monad monad
 INSTANCE: gadget monad
 M: gadget monad-of drop gadget-monad ;
 M: gadget-monad return drop <gadget> swap >>model ;
-M: gadget >>= model>> '[ _ swap call( x -- y ) ] ; 
+M: gadget >>= model>> '[ _ swap call( x -- y ) ] ; 
- 
-! ! list (model = Columns), listContent (model = contents)
-

extra/ui/frp/frp.factor copy

@@ -1,73 +0,0 @@
-USING: accessors arrays fry kernel models models.product
-monads sequences ui.gadgets ui.gadgets.buttons ui.gadgets.tracks ;
-QUALIFIED: make
-IN: ui.frp
-
-! Layout utilities
-
-GENERIC: , ( object -- )
-M: gadget , make:, ;
-M: model , activate-model ;
-
-GENERIC: -> ( object -- model )
-M: gadget -> dup make:, model>> ;
-M: model -> dup , ;
-
-: <box> ( models type -- track )
-   [ { } make:make ] dip <track> swap dup [ model>> ] map <product>
-   [ [ f track-add ] each ] dip >>model ; inline
-: <hbox> ( models -- track ) horizontal <box> ; inline
-: <vbox> ( models -- track ) vertical <box> ; inline
-
-! Gadgets
-: <model-button> ( text -- button ) [ t swap set-control-value ] <button> f <model> >>model ;
-
-
-! Model utilities
-TUPLE: multi-model < model ;
-! M: multi-model model-activated dup model-changed ;
-: <multi-model> ( models kind -- model ) f swap new-model [ [ add-dependency ] curry each ] keep ;
-
-TUPLE: merge-model < multi-model ;
-M: merge-model model-changed [ value>> ] dip set-model ;
-: <merge> ( models -- model ) merge-model <multi-model> ;
-
-TUPLE: filter-model < multi-model quot ;
-M: filter-model model-changed [ value>> ] dip [ quot>> call( val -- bool ) ] 2keep
-   [ set-model ] [ 2drop ] if ;
-: <filter> ( model quot -- filter-model ) [ 1array filter-model <multi-model> ] dip >>quot ;
-
-TUPLE: fold-model < multi-model oldval quot ;
-M: fold-model model-changed [ [ value>> ] [ [ oldval>> ] [ quot>> ] bi ] bi*
-   call( val oldval -- newval ) ] keep set-model ;
-: <fold> ( oldval quot model -- model' ) 1array fold-model <multi-model> swap >>quot swap >>oldval ;
-
-TUPLE: switch-model < multi-model switcher on ;
-M: switch-model model-changed tuck [ switcher>> = ] 2keep
-   '[ on>> [ _ value>> _ set-model ] when ] [ t swap (>>on) ] if ;
-: switch ( signal1 signal2 -- signal' ) [ 2array switch-model <multi-model> ] keep >>switcher ;
-
-TUPLE: mapped < model model quot ;
-
-: <mapped> ( model quot -- arrow )
-    f mapped new-model
-        swap >>quot
-        over >>model
-        [ add-dependency ] keep ;
-
-M: mapped model-changed
-    [ [ value>> ] [ quot>> ] bi* call( old -- new ) ] [ nip ] 2bi
-    set-model ;
-
-! Instances
-M: model fmap <mapped> ;
-
-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 >>= model>> '[ _ swap call( x -- y ) ] ; 
- 
-! ! list (model = Columns), listContent (model = contents)
-