modulization of ui.frp

diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor
index edd4932c66a05a7451168d24a79fea2614044dee..bf7eed8f8aa6ac31324c7c6f5d781b15855e0639 100644 (file)
--- a/basis/functors/functors.factor
+++ b/basis/functors/functors.factor
@@ -4,8 +4,8 @@ USING: accessors arrays classes.mixin classes.parser
 classes.tuple classes.tuple.parser combinators effects
 effects.parser fry generic generic.parser generic.standard
 interpolate io.streams.string kernel lexer locals.parser
 classes.tuple classes.tuple.parser combinators effects
 effects.parser fry generic generic.parser generic.standard
 interpolate io.streams.string kernel lexer locals.parser

-locals.rewrite.closures locals.types make namespaces parser
-quotations sequences vocabs.parser words words.symbol ;
+locals.rewrite.closures locals.types make macros namespaces
+parser quotations sequences vocabs.parser words words.symbol ;

 IN: functors
 
 ! This is a hack
 IN: functors
 
 ! This is a hack


@@ -111,6 +111,11 @@ SYNTAX: `GENERIC:
     complete-effect parsed
     \ define-simple-generic* parsed ;
 
     complete-effect parsed
     \ define-simple-generic* parsed ;
 

+SYNTAX: `MACRO:
+    scan-param parsed
+    parse-declared*
+    \ define-macro parsed ;
+

 SYNTAX: `inline [ word make-inline ] over push-all ;
 
 SYNTAX: `call-next-method T{ fake-call-next-method } parsed ;
 SYNTAX: `inline [ word make-inline ] over push-all ;
 
 SYNTAX: `call-next-method T{ fake-call-next-method } parsed ;


@@ -142,6 +147,7 @@ DEFER: ;FUNCTOR delimiter
         { "SYNTAX:" POSTPONE: `SYNTAX: }
         { "SYMBOL:" POSTPONE: `SYMBOL: }
         { "inline" POSTPONE: `inline }
         { "SYNTAX:" POSTPONE: `SYNTAX: }
         { "SYMBOL:" POSTPONE: `SYMBOL: }
         { "inline" POSTPONE: `inline }

+        { "MACRO:" POSTPONE: `MACRO: }

         { "call-next-method" POSTPONE: `call-next-method }
     } ;
 
         { "call-next-method" POSTPONE: `call-next-method }
     } ;
 

diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor
index 51df59627836f32c306385108ac8c4d211178a4b..a86c5012583c41bd5ca494065d9a39a890dc78cb 100755 (executable)
--- a/core/sequences/sequences.factor
+++ b/core/sequences/sequences.factor
@@ -927,4 +927,6 @@ PRIVATE>
     list empty?
     [ identity ]
     [ list rest identity quot reduce-r list first quot call ] if ;
     list empty?
     [ identity ]
     [ list rest identity quot reduce-r list first quot call ] if ;

-    inline recursive
\ No newline at end of file
+    inline recursive
+
+:: combos ( list1 list2 -- result ) list2 [ [ 2array ] curry list1 swap map ] map concat ;
\ No newline at end of file

diff --git a/extra/modules/util/util.factor b/extra/modules/util/util.factor
new file mode 100644 (file)
index 0000000..ef5a3f3
--- /dev/null
+++ b/extra/modules/util/util.factor
@@ -0,0 +1,7 @@
+USING: accessors assocs kernel lexer locals namespaces sequences
+vocabs vocabs.parser ;
+IN: modules.util
+SYNTAX: EXPORT-FROM: [let | v [ in get ] |
+   v vocab words>> ";" parse-tokens
+   [ load-vocab vocab-words [ clone v >>vocabulary ] assoc-map ] map
+   assoc-combine update ] ;
\ No newline at end of file

diff --git a/extra/monads/monads.factor b/extra/monads/monads.factor
index 6b35772596f92e59e06c18b8ff6055e19ab6720d..f4503cbdd3f1f1f552f91f3a96002d95332de64f 100644 (file)
--- a/extra/monads/monads.factor
+++ b/extra/monads/monads.factor
@@ -22,6 +22,7 @@ M: monad return monad-of return ;
 M: monad fail   monad-of fail   ;
 
 : bind ( mvalue quot -- mvalue' ) swap >>= call( quot -- mvalue ) ;
 M: monad fail   monad-of fail   ;
 
 : bind ( mvalue quot -- mvalue' ) swap >>= call( quot -- mvalue ) ;

+: bind* ( mvalue quot -- mvalue' ) '[ drop @ ] bind ;

 : >>   ( mvalue k -- mvalue' ) '[ drop _ ] bind ;
 
 :: lift-m2 ( m1 m2 f monad -- m3 )
 : >>   ( mvalue k -- mvalue' ) '[ drop _ ] bind ;
 
 :: lift-m2 ( m1 m2 f monad -- m3 )

diff --git a/extra/ui/frp/frp-docs.factor b/extra/ui/frp/frp-docs.factor
deleted file mode 100644 (file)
index fb63d7f..0000000
--- a/extra/ui/frp/frp-docs.factor
+++ /dev/null
@@ -1,46 +0,0 @@
-USING: help.markup help.syntax models monads sequences
-ui.gadgets.buttons ui.gadgets.tracks ;
-IN: ui.frp
-
-! Layout utilities
-
-HELP: ,
-{ $values { "uiitem" "a gadget or model" } }
-{ $description "Used in a series of gadgets created by a box, accumulating the gadget" } ;
-HELP: ->
-{ $values { "uiitem" "a gadget or model" } { "model" model } }
-{ $description "Like " { $link , } "but passes its model on for further use." } ;
-HELP: <hbox>
-{ $values { "gadgets" "a list of gadgets" } { "track" track } }
-{ $syntax "[ gadget , gadget , ... ] <hbox>" }
-{ $description "Creates an horizontal track containing the gadgets listed in the quotation" } ;
-HELP: <vbox>
-{ $values { "gadgets" "a list of gadgets" } { "track" track } }
-{ $syntax "[ gadget , gadget , ... ] <hbox>" }
-{ $description "Creates an vertical track containing the gadgets listed in the quotation" } ;
-
-! Gadgets
-HELP: <frp-button>
-{ $values { "text" "the button's label" } { "button" button } }
-{ $description "Creates an button whose model updates on clicks" } ;
-
-HELP: <merge>
-{ $values { "models" "a list of models" } { "model" basic-model } }
-{ $description "Creates a model that merges the updates of others" } ;
-
-HELP: <filter>
-{ $values { "model" model } { "quot" "quotation with stack effect ( a b -- c )" } { "filter-model" filter-model } }
-{ $description "Creates a model that uses the updates of another model when they satisfy a given predicate" } ;
-
-HELP: <fold>
-{ $values { "oldval" "starting value" } { "quot" "applied to update and previous values" } { "model" model } { "model'" model } }
-{ $description "Similar to " { $link reduce } " but works on models, applying a quotation to the previous and new values at each update" } ;
-
-HELP: <switch>
-{ $values { "signal1" model } { "signal2" model } { "signal'" model } }
-{ $description "Creates a model that starts with the behavior of model1 and switches to the behavior of model2 on its update" } ;
-
-ARTICLE: { "frp" "instances" } "FRP Instances"
-"Models are all functors, as " { $link fmap } " corresponds directly to the " { $link "models.arrow" } " vocabulary. "
-"Also, a gadget is a monad. Binding recieves a model and creates a new gadget." ;
-

diff --git a/extra/ui/frp/frp.factor b/extra/ui/frp/frp.factor
index ccae6fe4b069901cfe8c57bc913240b21ac260d1..f97dccdc033f9936bc516f03d0c8341101f9af38 100644 (file)
--- a/extra/ui/frp/frp.factor
+++ b/extra/ui/frp/frp.factor
@@ -1,167 +1,4 @@
-USING: accessors arrays colors fonts fry generalizations kernel
-lexer macros math math.parser models models.product monads
-sequences ui.gadgets ui.gadgets.buttons ui.gadgets.buttons.private
-ui.gadgets.editors ui.gadgets.scrollers ui.gadgets.tables
-ui.gadgets.tracks ;
-QUALIFIED: make
+USING: modules.util ui.frp.functors monads ;

 IN: ui.frp
 IN: ui.frp

-
-! !!! Model utilities
-TUPLE: multi-model < model ;
-GENERIC: (model-changed) ( model observer -- )
-: <multi-model> ( models kind -- model ) f swap new-model [ [ add-dependency ] curry each ] keep ;
-M: multi-model model-changed over value>> [ (model-changed) ] [ 2drop ] if ;
-M: multi-model model-activated dup dependencies>> dup length 1 =
-   [ first swap model-changed ] [ 2drop ] if ;
-
-TUPLE: basic-model < multi-model ;
-M: basic-model (model-changed) [ value>> ] dip set-model ;
-: <merge> ( models -- model ) basic-model <multi-model> ;
-: <basic> ( value -- model ) basic-model new-model ;
-
-TUPLE: filter-model < multi-model quot ;
-M: filter-model (model-changed) [ value>> ] dip 2dup quot>> call( a -- ? )
-   [ 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 ] [ >>value ] bi ;
-
-TUPLE: updater-model < multi-model values updates ;
-M: updater-model (model-changed) tuck updates>> =
-   [ [ values>> value>> ] keep set-model ]
-   [ drop ] if ;
-: <updates> ( values updates -- updater ) [ 2array updater-model <multi-model> ] 2keep
-   [ >>values ] [ >>updates ] bi* ;
-
-TUPLE: switch-model < multi-model original switcher on ;
-M: switch-model (model-changed) 2dup switcher>> =
-   [ [ value>> ] [ t >>on ] bi* set-model ]
-   [ dup on>> [ 2drop ] [ [ value>> ] dip set-model ] if ] if ;
-: <switch> ( signal1 signal2 -- signal' ) [ 2array switch-model <multi-model> ] 2keep
-   [ >>original ] [ >>switcher ] bi* ;
-M: switch-model model-activated [ original>> ] keep model-changed ;
-
-TUPLE: mapped-model < multi-model model quot ;
-: new-mapped-model ( model quot class -- const-model ) [ over 1array ] dip
-   <multi-model> swap >>quot swap >>model ;
-: <mapped> ( model quot -- mapped ) mapped-model new-mapped-model ;
-M: mapped-model (model-changed)
-    [ [ value>> ] [ quot>> ] bi* call( old -- new ) ] [ nip ] 2bi
-    set-model ;
-
-TUPLE: side-effect-model < mapped-model ;
-M: side-effect-model (model-changed) [ [ value>> ] [ quot>> ] bi* call( old -- ) ] keep t swap set-model ;
-: $> ( model quot -- side-effect-model ) side-effect-model new-mapped-model ;
-
-TUPLE: quot-model < mapped-model ;
-M: quot-model (model-changed) nip [ quot>> call( -- b ) ] keep set-model ;
-: <$ ( model quot -- quot-model ) quot-model new-mapped-model ;
-
-TUPLE: frp-product < multi-model ;
-: <frp-product> ( models -- product ) frp-product <multi-model> ;
-M: frp-product model-changed
-    nip
-    dup dependencies>> [ value>> ] all?
-    [ dup [ value>> ] product-value >>value notify-connections
-    ] [ drop ] if ;
-M: frp-product update-model
-    dup value>> swap [ set-model ] set-product-value ;
-M: frp-product model-activated dup model-changed ;
-
-TUPLE: action-value < basic-model parent ;
-: <action-value> ( parent value -- model ) action-value new-model swap >>parent ;
-M: action-value model-activated dup parent>> dup activate-model model-changed ; ! a fake dependency of sorts
-
-! Update at start
-TUPLE: action < multi-model quot ;
-M: action (model-changed) [ [ value>> ] [ quot>> ] bi* call( a -- b ) ] keep value>>
-   [ swap add-connection ] 2keep model-changed ;
-: <action> ( model quot -- action ) [ 1array action <multi-model> ] dip >>quot dup f <action-value> >>value value>> ;
-
-! Gadgets
-TUPLE: frp-button < button hook ;
-: <frp-button> ( text -- button ) [
-      [ dup hook>> [ call( button -- ) ] [ drop ] if* ] keep
-      t swap set-control-value
-   ] frp-button new-button border-button-theme f <basic> >>model ;
-
-TUPLE: frp-table < table { quot initial: [ ] } { val-quot initial: [ ] } 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 ) ] [ drop f ] if* ;
-M: frp-table row-value val-quot>> [ call( a -- b ) ]  [ drop f ] if* ;
-M: frp-table row-color color-quot>> [ call( a -- b ) ]  [ drop f ] if* ;
-
-: <frp-table> ( model -- table ) f frp-table new-table dup >>renderer
-   V{ } clone <basic> >>selected-values V{ } clone <basic> >>selected-indices* ;
-: <frp-table*> ( -- table ) V{ } clone <model> <frp-table> ;
-: <frp-list> ( model -- table ) <frp-table> [ 1array ] >>quot ;
-: <frp-list*> ( -- table ) V{ } clone <model> <frp-list> ;
-: indexed ( table -- table ) f >>val-quot ;
-
-: <frp-field> ( -- field ) "" <model> <model-field> ;
-
-! Layout utilities
-TUPLE: layout gadget width ; C: <layout> layout
-
-GENERIC: output-model ( gadget -- model )
-M: gadget output-model model>> ;
-M: table output-model dup multiple-selection?>>
-   [ dup val-quot>> [ selected-values>> ] [ selected-indices*>> ] if ]
-   [ dup val-quot>> [ selected-value>> ] [ selected-index*>> ] if ] if ;
-M: model-field output-model field-model>> ;
-M: scroller output-model viewport>> children>> first output-model ;
-
-GENERIC: , ( uiitem -- )
-M: gadget , f <layout> make:, ;
-M: model , activate-model ;
-
-SYNTAX: ,% scan string>number [ <layout> make:, ] curry over push-all ;
-SYNTAX: ->% scan string>number '[ [ _ <layout> make:, ] [ output-model ] bi ] over push-all ;
-
-GENERIC: -> ( uiitem -- model )
-M: gadget -> dup , output-model ;
-M: model -> dup , ;
-
-: <spacer> ( -- ) <gadget> 1 <layout> make:, ;
-: <box> ( gadgets type -- track )
-   [ { } make:make ] dip <track> swap [ [ gadget>> ] [ width>> ] bi track-add ] each ; inline
-: <box*> ( gadgets type -- track ) [ <box> ] [ [ model>> ] map <product> ] bi >>model ; inline
-: <hbox> ( gadgets -- track ) horizontal <box> ; inline
-: <hbox*> ( gadgets -- track ) horizontal <box*> ; inline
-: <vbox> ( gadgets -- track ) vertical <box> ; inline
-: <vbox*> ( gadgets -- track ) vertical <box*> ; inline
-
-! Instances
-M: model fmap <mapped> ;
-M: model >>= [ swap <action> ] curry ;
-
-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 ; 
-
-! Macros
-: lift ( int -- quot ) dup
-   '[ [ _ narray <frp-product> ] dip [ _ firstn ] prepend ] ; inline
-
-MACRO: liftA-n ( int -- quot ) lift [ <mapped> ] append ;
-
-MACRO: $>-n ( int -- quot ) lift [ $> ] append ;
-
-MACRO: <$-n ( int -- quot ) lift [ <$ ] append ;
-
-: liftA2 ( a b quot -- arrow ) 2 liftA-n ; inline
-: liftA3 ( a b c quot -- arrow ) 3 liftA-n ; inline
-
-: $>2 ( a b quot -- arrow ) 2 $>-n ; inline
-: $>3 ( a b c quot -- arrow ) 3 $>-n ; inline
-
-: <$2 ( a b quot -- arrow ) 2 <$-n ; inline
-: <$3 ( a b c quot -- arrow ) 3 <$-n ; inline
\ No newline at end of file
+EXPORT-FROM: ui.frp.signals ui.frp.gadgets ui.frp.instances ui.frp.layout ;
+FMAPS: $> <$ fmap FOR & | ;
\ No newline at end of file

diff --git a/extra/ui/frp/functors/functors.factor b/extra/ui/frp/functors/functors.factor
new file mode 100644 (file)
index 0000000..2808faf
--- /dev/null
+++ b/extra/ui/frp/functors/functors.factor
@@ -0,0 +1,25 @@
+USING: fry functors generalizations kernel macros peg peg-lexer
+sequences ;
+IN: ui.frp.functors
+
+FUNCTOR: fmaps ( W P -- )
+W        IS ${W}
+<p>      IS <${P}>
+w-n      DEFINES ${W}-n-${P}
+w-2      DEFINES 2${W}-${P}
+w-3      DEFINES 3${W}-${P}
+w-4      DEFINES 4${W}-${P}
+WHERE
+MACRO: w-n ( int -- quot ) dup '[ [ _ narray <p> ] dip [ _ firstn ] prepend W ] ;
+: w-2 ( a b quot -- mapped ) 2 w-n ; inline
+: w-3 ( a b c quot -- mapped ) 3 w-n ; inline
+: w-4 ( a b c d quot -- mapped ) 4 w-n ; inline
+;FUNCTOR
+
+ON-BNF: FMAPS:
+tokenizer = <foreign factor>
+token = !("FOR"|";").
+middle = "FOR" => [[ drop ignore ]]
+endexpr = ";" => [[ drop ignore ]]
+expr = token* middle token* endexpr => [[ first2 combos [ first2 fmaps ] each ignore ]]
+;ON-BNF
\ No newline at end of file

diff --git a/extra/ui/frp/gadgets/gadgets.factor b/extra/ui/frp/gadgets/gadgets.factor
new file mode 100644 (file)
index 0000000..02bc8f4
--- /dev/null
+++ b/extra/ui/frp/gadgets/gadgets.factor
@@ -0,0 +1,26 @@
+USING: accessors arrays kernel models ui.frp.signals ui.gadgets
+ui.gadgets.buttons ui.gadgets.buttons.private
+ui.gadgets.editors ui.gadgets.tables ;
+IN: ui.frp.gadgets
+
+TUPLE: frp-button < button hook ;
+: <frp-button> ( text -- button ) [
+      [ dup hook>> [ call( button -- ) ] [ drop ] if* ] keep
+      t swap set-control-value
+   ] frp-button new-button border-button-theme f <basic> >>model ;
+
+TUPLE: frp-table < table { quot initial: [ ] } { val-quot initial: [ ] } 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 ) ] [ drop f ] if* ;
+M: frp-table row-value val-quot>> [ call( a -- b ) ]  [ drop f ] if* ;
+M: frp-table row-color color-quot>> [ call( a -- b ) ]  [ drop f ] if* ;
+
+: <frp-table> ( model -- table ) f frp-table new-table dup >>renderer
+   V{ } clone <basic> >>selected-values V{ } clone <basic> >>selected-indices* ;
+: <frp-table*> ( -- table ) V{ } clone <model> <frp-table> ;
+: <frp-list> ( model -- table ) <frp-table> [ 1array ] >>quot ;
+: <frp-list*> ( -- table ) V{ } clone <model> <frp-list> ;
+: indexed ( table -- table ) f >>val-quot ;
+
+: <frp-field> ( -- field ) "" <model> <model-field> ;
\ No newline at end of file

diff --git a/extra/ui/frp/instances/instances.factor b/extra/ui/frp/instances/instances.factor
new file mode 100644 (file)
index 0000000..8ab7531
--- /dev/null
+++ b/extra/ui/frp/instances/instances.factor
@@ -0,0 +1,12 @@
+USING: accessors kernel models monads ui.frp.signals ui.frp.layout ui.gadgets ;
+IN: ui.frp.instances
+
+M: model >>= [ swap <action> ] curry ;
+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 >>= output-model [ swap call( x -- y ) ] curry ; 

diff --git a/extra/ui/frp/layout/layout.factor b/extra/ui/frp/layout/layout.factor
new file mode 100644 (file)
index 0000000..508f30b
--- /dev/null
+++ b/extra/ui/frp/layout/layout.factor
@@ -0,0 +1,34 @@
+USING: accessors fry kernel lexer math.parser models sequences
+ui.frp.signals ui.gadgets ui.gadgets.editors ui.gadgets.scrollers
+ui.gadgets.tables ui.gadgets.tracks ;
+QUALIFIED: make
+IN: ui.frp.layout
+TUPLE: layout gadget width ; C: <layout> layout
+
+GENERIC: output-model ( gadget -- model )
+M: gadget output-model model>> ;
+M: table output-model dup multiple-selection?>>
+   [ dup val-quot>> [ selected-values>> ] [ selected-indices*>> ] if ]
+   [ dup val-quot>> [ selected-value>> ] [ selected-index*>> ] if ] if ;
+M: model-field output-model field-model>> ;
+M: scroller output-model viewport>> children>> first output-model ;
+
+GENERIC: , ( uiitem -- )
+M: gadget , f <layout> make:, ;
+M: model , activate-model ;
+
+SYNTAX: ,% scan string>number [ <layout> make:, ] curry over push-all ;
+SYNTAX: ->% scan string>number '[ [ _ <layout> make:, ] [ output-model ] bi ] over push-all ;
+
+GENERIC: -> ( uiitem -- model )
+M: gadget -> dup , output-model ;
+M: model -> dup , ;
+
+: <spacer> ( -- ) <gadget> 1 <layout> make:, ;
+: <box> ( gadgets type -- track )
+   [ { } make:make ] dip <track> swap [ [ gadget>> ] [ width>> ] bi track-add ] each ; inline
+: <box*> ( gadgets type -- track ) [ <box> ] [ [ model>> ] map <|> ] bi >>model ; inline
+: <hbox> ( gadgets -- track ) horizontal <box> ; inline
+: <hbox*> ( gadgets -- track ) horizontal <box*> ; inline
+: <vbox> ( gadgets -- track ) vertical <box> ; inline
+: <vbox*> ( gadgets -- track ) vertical <box*> ; inline
\ No newline at end of file

diff --git a/extra/ui/frp/signals/signals.factor b/extra/ui/frp/signals/signals.factor
new file mode 100644 (file)
index 0000000..461b8f0
--- /dev/null
+++ b/extra/ui/frp/signals/signals.factor
@@ -0,0 +1,81 @@
+USING: accessors arrays kernel models models.product sequences ;
+IN: ui.frp.signals
+
+TUPLE: multi-model < model ;
+GENERIC: (model-changed) ( model observer -- )
+: <multi-model> ( models kind -- model ) f swap new-model [ [ add-dependency ] curry each ] keep ;
+M: multi-model model-changed over value>> [ (model-changed) ] [ 2drop ] if ;
+M: multi-model model-activated dup dependencies>> dup length 1 =
+   [ first swap model-changed ] [ 2drop ] if ;
+
+TUPLE: basic-model < multi-model ;
+M: basic-model (model-changed) [ value>> ] dip set-model ;
+: <merge> ( models -- model ) basic-model <multi-model> ;
+: <basic> ( value -- model ) basic-model new-model ;
+
+TUPLE: filter-model < multi-model quot ;
+M: filter-model (model-changed) [ value>> ] dip 2dup quot>> call( a -- ? )
+   [ 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 ] [ >>value ] bi ;
+
+TUPLE: updater-model < multi-model values updates ;
+M: updater-model (model-changed) tuck updates>> =
+   [ [ values>> value>> ] keep set-model ]
+   [ drop ] if ;
+: <updates> ( values updates -- updater ) [ 2array updater-model <multi-model> ] 2keep
+   [ >>values ] [ >>updates ] bi* ;
+
+TUPLE: switch-model < multi-model original switcher on ;
+M: switch-model (model-changed) 2dup switcher>> =
+   [ [ value>> ] [ t >>on ] bi* set-model ]
+   [ dup on>> [ 2drop ] [ [ value>> ] dip set-model ] if ] if ;
+: <switch> ( signal1 signal2 -- signal' ) [ 2array switch-model <multi-model> ] 2keep
+   [ >>original ] [ >>switcher ] bi* ;
+M: switch-model model-activated [ original>> ] keep model-changed ;
+
+TUPLE: mapped-model < multi-model model quot ;
+: new-mapped-model ( model quot class -- const-model ) [ over 1array ] dip
+   <multi-model> swap >>quot swap >>model ;
+: <mapped> ( model quot -- mapped ) mapped-model new-mapped-model ;
+M: mapped-model (model-changed)
+    [ [ value>> ] [ quot>> ] bi* call( old -- new ) ] [ nip ] 2bi
+    set-model ;
+
+TUPLE: side-effect-model < mapped-model ;
+M: side-effect-model (model-changed) [ [ value>> ] [ quot>> ] bi* call( old -- ) ] keep t swap set-model ;
+: $> ( model quot -- side-effect-model ) side-effect-model new-mapped-model ;
+
+TUPLE: quot-model < mapped-model ;
+M: quot-model (model-changed) nip [ quot>> call( -- b ) ] keep set-model ;
+: <$ ( model quot -- quot-model ) quot-model new-mapped-model ;
+
+TUPLE: action-value < basic-model parent ;
+: <action-value> ( parent value -- model ) action-value new-model swap >>parent ;
+M: action-value model-activated dup parent>> dup activate-model model-changed ; ! a fake dependency of sorts
+
+TUPLE: action < multi-model quot ;
+M: action (model-changed) [ [ value>> ] [ quot>> ] bi* call( a -- b ) ] keep value>>
+   [ swap add-connection ] 2keep model-changed ;
+: <action> ( model quot -- action ) [ 1array action <multi-model> ] dip >>quot dup f <action-value> >>value value>> ;
+
+TUPLE: | < multi-model ;
+: <|> ( models -- product ) | <multi-model> ;
+M: | model-changed
+    nip
+    dup dependencies>> [ value>> ] all?
+    [ dup [ value>> ] product-value >>value notify-connections
+    ] [ drop ] if ;
+M: | update-model
+    dup value>> swap [ set-model ] set-product-value ;
+M: | model-activated dup model-changed ;
+
+TUPLE: & < | ;
+: <&> ( models -- product ) & <multi-model> ;
+M: & model-changed [ call-next-method ] keep
+   [ dependencies>> [ f swap set-model ] each ] with-locked-model ;
\ No newline at end of file

diff --git a/extra/ui/frp/xfrp-docs.factor b/extra/ui/frp/xfrp-docs.factor
new file mode 100644 (file)
index 0000000..fb63d7f
--- /dev/null
+++ b/extra/ui/frp/xfrp-docs.factor
@@ -0,0 +1,46 @@
+USING: help.markup help.syntax models monads sequences
+ui.gadgets.buttons ui.gadgets.tracks ;
+IN: ui.frp
+
+! Layout utilities
+
+HELP: ,
+{ $values { "uiitem" "a gadget or model" } }
+{ $description "Used in a series of gadgets created by a box, accumulating the gadget" } ;
+HELP: ->
+{ $values { "uiitem" "a gadget or model" } { "model" model } }
+{ $description "Like " { $link , } "but passes its model on for further use." } ;
+HELP: <hbox>
+{ $values { "gadgets" "a list of gadgets" } { "track" track } }
+{ $syntax "[ gadget , gadget , ... ] <hbox>" }
+{ $description "Creates an horizontal track containing the gadgets listed in the quotation" } ;
+HELP: <vbox>
+{ $values { "gadgets" "a list of gadgets" } { "track" track } }
+{ $syntax "[ gadget , gadget , ... ] <hbox>" }
+{ $description "Creates an vertical track containing the gadgets listed in the quotation" } ;
+
+! Gadgets
+HELP: <frp-button>
+{ $values { "text" "the button's label" } { "button" button } }
+{ $description "Creates an button whose model updates on clicks" } ;
+
+HELP: <merge>
+{ $values { "models" "a list of models" } { "model" basic-model } }
+{ $description "Creates a model that merges the updates of others" } ;
+
+HELP: <filter>
+{ $values { "model" model } { "quot" "quotation with stack effect ( a b -- c )" } { "filter-model" filter-model } }
+{ $description "Creates a model that uses the updates of another model when they satisfy a given predicate" } ;
+
+HELP: <fold>
+{ $values { "oldval" "starting value" } { "quot" "applied to update and previous values" } { "model" model } { "model'" model } }
+{ $description "Similar to " { $link reduce } " but works on models, applying a quotation to the previous and new values at each update" } ;
+
+HELP: <switch>
+{ $values { "signal1" model } { "signal2" model } { "signal'" model } }
+{ $description "Creates a model that starts with the behavior of model1 and switches to the behavior of model2 on its update" } ;
+
+ARTICLE: { "frp" "instances" } "FRP Instances"
+"Models are all functors, as " { $link fmap } " corresponds directly to the " { $link "models.arrow" } " vocabulary. "
+"Also, a gadget is a monad. Binding recieves a model and creates a new gadget." ;
+