frp library

extra/ui/frp/authors.txt

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

extra/ui/frp/frp-docs.factor

@@ -0,0 +1,36 @@
+USING: ui.frp help.syntax help.markup monads sequences ;
+IN: ui.frp
+
+! Layout utilities
+
+HELP: ,
+{ $description "Used in a series of gadgets created by a box, accumulating the gadget" } ;
+HELP: ->
+{ $description "Like " { $link , } "but passes its model on for further use." } ;
+HELP: <hbox>
+{ $syntax "[ gadget , gadget , ... ] <hbox>" }
+{ $description "Creates an horizontal track containing the gadgets listed in the quotation" } ;
+HELP: <vbox>
+{ $syntax "[ gadget , gadget , ... ] <hbox>" }
+{ $description "Creates an vertical track containing the gadgets listed in the quotation" } ;
+
+! Gadgets
+HELP: <model-button>
+{ $description "Creates an button whose model updates on clicks" } ;
+
+HELP: <merge>
+{ $description "Creates a model that merges the updates of two others" } ;
+
+HELP: <filter>
+{ $description "Creates a model that uses the updates of another model when they satisfy a given predicate" } ;
+
+HELP: <fold>
+{ $description "Similar to " { $link reduce } " but works on models, applying a quotation to the previous and new values at each update" } ;
+
+HELP: switch
+{ $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." ;
+

extra/ui/frp/frp.factor

@@ -0,0 +1,80 @@
+USING: accessors arrays fry kernel models models.product
+monads sequences ui.gadgets ui.gadgets.buttons ui.gadgets.tracks
+ui.gadgets.tables ;
+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
+: <frp-button> ( text -- button ) [ t swap set-control-value ] <bevel-button> f <model> >>model ;
+TUPLE: frp-table < table quot ;
+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 ;
+: <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)
+

extra/ui/frp/frp.factor copy

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

extra/ui/frp/summary.txt

@@ -0,0 +1 @@
+Utilities for functional reactive programming in user interfaces