From ddc565eb9912639600a3e5418a49ce3689b6b27b Mon Sep 17 00:00:00 2001 From: Sam Anklesaria Date: Fri, 24 Apr 2009 23:25:16 -0500 Subject: [PATCH] frp library --- extra/ui/frp/authors.txt | 1 + extra/ui/frp/frp-docs.factor | 36 ++++++++++++++++ extra/ui/frp/frp.factor | 80 ++++++++++++++++++++++++++++++++++++ extra/ui/frp/frp.factor copy | 73 ++++++++++++++++++++++++++++++++ extra/ui/frp/summary.txt | 1 + 5 files changed, 191 insertions(+) create mode 100644 extra/ui/frp/authors.txt create mode 100644 extra/ui/frp/frp-docs.factor create mode 100644 extra/ui/frp/frp.factor create mode 100644 extra/ui/frp/frp.factor copy create mode 100644 extra/ui/frp/summary.txt diff --git a/extra/ui/frp/authors.txt b/extra/ui/frp/authors.txt new file mode 100644 index 0000000000..2300f69f11 --- /dev/null +++ b/extra/ui/frp/authors.txt @@ -0,0 +1 @@ +Sam Anklesaria diff --git a/extra/ui/frp/frp-docs.factor b/extra/ui/frp/frp-docs.factor new file mode 100644 index 0000000000..ac3306a54a --- /dev/null +++ b/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: +{ $syntax "[ gadget , gadget , ... ] " } +{ $description "Creates an horizontal track containing the gadgets listed in the quotation" } ; +HELP: +{ $syntax "[ gadget , gadget , ... ] " } +{ $description "Creates an vertical track containing the gadgets listed in the quotation" } ; + +! Gadgets +HELP: +{ $description "Creates an button whose model updates on clicks" } ; + +HELP: +{ $description "Creates a model that merges the updates of two others" } ; + +HELP: +{ $description "Creates a model that uses the updates of another model when they satisfy a given predicate" } ; + +HELP: +{ $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." ; + diff --git a/extra/ui/frp/frp.factor b/extra/ui/frp/frp.factor new file mode 100644 index 0000000000..685d9af124 --- /dev/null +++ b/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 , ; + +: ( models type -- track ) + [ { } make:make ] dip swap dup [ model>> ] map + [ [ f track-add ] each ] dip >>model ; inline +: ( models -- track ) horizontal ; inline +: ( models -- track ) vertical ; inline + +! Gadgets +: ( text -- button ) [ t swap set-control-value ] f >>model ; +TUPLE: frp-table < table quot ; +M: frp-table row-columns quot>> call( a -- b ) ; +: ( model quot -- table ) + frp-table new-line-gadget dup >>renderer swap >>quot swap >>model + f >>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 ; +: ( 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 ; +: ( models -- model ) merge-model ; + +TUPLE: filter-model < multi-model quot ; +M: filter-model model-changed [ value>> ] dip [ quot>> call( val -- bool ) ] 2keep + [ set-model ] [ 2drop ] if ; +: ( model quot -- filter-model ) [ 1array filter-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 ; +: ( oldval quot model -- model' ) 1array fold-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 ] keep >>switcher ; + +TUPLE: mapped < model model quot ; + +: ( 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 ; + +SINGLETON: gadget-monad +INSTANCE: gadget-monad monad +INSTANCE: gadget monad +M: gadget monad-of drop gadget-monad ; +M: gadget-monad return drop swap >>model ; +M: gadget >>= model>> '[ _ swap call( x -- y ) ] ; + +! ! list (model = Columns), listContent (model = contents) + diff --git a/extra/ui/frp/frp.factor copy b/extra/ui/frp/frp.factor copy new file mode 100644 index 0000000000..3ebb33e2d6 --- /dev/null +++ b/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 , ; + +: ( models type -- track ) + [ { } make:make ] dip swap dup [ model>> ] map + [ [ f track-add ] each ] dip >>model ; inline +: ( models -- track ) horizontal ; inline +: ( models -- track ) vertical ; inline + +! Gadgets +: ( text -- button ) [ t swap set-control-value ]