From b265e3afea2cc0b65ecb61e29398799cde823067 Mon Sep 17 00:00:00 2001 From: Sam Anklesaria Date: Sun, 14 Jun 2009 11:42:31 -0500 Subject: [PATCH] ui.frp connection reordering supported --- core/sequences/sequences.factor | 4 ++- extra/ui/frp/functors/functors-docs.factor | 2 +- extra/ui/frp/functors/functors.factor | 9 +++++ extra/ui/frp/gadgets/gadgets.factor | 35 ++++++++++++-------- extra/ui/frp/instances/authors.txt | 1 - extra/ui/frp/instances/instances-docs.factor | 9 ----- extra/ui/frp/instances/instances.factor | 12 ------- extra/ui/frp/layout/layout.factor | 4 +-- extra/ui/frp/signals/signals.factor | 33 ++++++++++++++---- 9 files changed, 64 insertions(+), 45 deletions(-) delete mode 100644 extra/ui/frp/instances/authors.txt delete mode 100644 extra/ui/frp/instances/instances-docs.factor delete mode 100644 extra/ui/frp/instances/instances.factor diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 5c27079b45..ab4772de51 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -942,4 +942,6 @@ PRIVATE> inline recursive :: combos ( list1 list2 -- result ) list2 [ [ 2array ] curry list1 swap map ] map concat ; -: (head-slice) ( seq n -- seq' ) over length over < [ drop ] [ head-slice ] if ; \ No newline at end of file +: (head-slice) ( seq n -- seq' ) over length over < [ drop ] [ head-slice ] if ; +: find-all ( seq quot -- elts ) [ [ length iota ] keep ] dip + [ dupd call( a -- ? ) [ 2array ] [ 2drop f ] if ] curry 2map [ ] filter ; inline \ No newline at end of file diff --git a/extra/ui/frp/functors/functors-docs.factor b/extra/ui/frp/functors/functors-docs.factor index 256be95702..e6c5c0f8d5 100644 --- a/extra/ui/frp/functors/functors-docs.factor +++ b/extra/ui/frp/functors/functors-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax ui.frp.signals ; +USING: help.markup help.syntax ui.frp.signals ui.frp.signals.private ; IN: ui.frp.functors ARTICLE: { "ui.frp.functors" "signal-collection" } "Signal Collection" diff --git a/extra/ui/frp/functors/functors.factor b/extra/ui/frp/functors/functors.factor index 2808faf190..cda6a0effa 100644 --- a/extra/ui/frp/functors/functors.factor +++ b/extra/ui/frp/functors/functors.factor @@ -1,5 +1,6 @@ USING: fry functors generalizations kernel macros peg peg-lexer sequences ; +FROM: ui.frp.signals => #1 ; IN: ui.frp.functors FUNCTOR: fmaps ( W P -- ) @@ -9,11 +10,19 @@ w-n DEFINES ${W}-n-${P} w-2 DEFINES 2${W}-${P} w-3 DEFINES 3${W}-${P} w-4 DEFINES 4${W}-${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

] 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 +MACRO: w-n* ( int -- quot ) dup '[ [ _ narray

#1 ] 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: diff --git a/extra/ui/frp/gadgets/gadgets.factor b/extra/ui/frp/gadgets/gadgets.factor index d88c3dcb61..e5dae45b99 100644 --- a/extra/ui/frp/gadgets/gadgets.factor +++ b/extra/ui/frp/gadgets/gadgets.factor @@ -1,17 +1,17 @@ USING: accessors arrays kernel models monads ui.frp.signals ui.gadgets ui.gadgets.buttons ui.gadgets.buttons.private ui.gadgets.editors ui.gadgets.tables sequences splitting ui.gadgets.labels -ui.gadgets.scrollers ui.gadgets.borders classes ; +ui.gadgets.scrollers ui.gadgets.borders ; IN: ui.frp.gadgets -TUPLE: frp-button < button hook ; +TUPLE: frp-button < button hook value ; : ( gadget -- button ) [ - [ dup hook>> [ call( button -- ) ] [ drop ] if* ] keep - [ dup set-control-value ] [ f swap set-control-value ] bi + [ [ [ value>> ] [ ] bi or ] keep set-control-value ] + [ dup hook>> [ call( button -- ) ] [ drop ] if* ] bi ] frp-button new-button f >>model ; : ( text -- button ) border-button-theme ; -TUPLE: frp-table < table { quot initial: [ ] } { val-quot initial: [ ] } color-quot column-titles column-alignment ; +TUPLE: frp-table < table { quot initial: [ ] } { val-quot initial: [ ] } color-quot column-titles column-alignment actions ; 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* ; @@ -19,14 +19,16 @@ 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* ; : ( model -- table ) f frp-table new-table dup >>renderer - V{ } clone >>selected-values V{ } clone >>selected-indices* ; + V{ } clone >>selected-values V{ } clone >>selected-indices* + f >>actions dup [ actions>> set-model ] curry >>action ; : ( -- table ) V{ } clone ; : ( column-model -- table ) [ 1array ] >>quot ; : ( -- table ) V{ } clone ; : indexed ( table -- table ) f >>val-quot ; TUPLE: frp-field < field frp-model ; -: ( model -- gadget ) frp-field new-field swap >>frp-model ; +: init-field ( field -- field' ) [ [ ] [ "" ] if* ] change-value ; +: ( model -- gadget ) frp-field new-field swap init-field >>frp-model ; M: frp-field graft* [ [ frp-model>> value>> ] [ editor>> ] bi set-editor-string ] [ dup editor>> model>> add-connection ] @@ -38,13 +40,13 @@ M: frp-field model-changed 2dup frp-model>> = [ [ value>> ] [ editor>> ] bi* set-editor-string ] [ nip [ editor>> editor-string ] [ frp-model>> ] bi set-model ] if ; -: ( -- field ) f ; +: ( -- field ) "" ; : ( model -- field ) "" ; : ( -- field ) "" ; : ( model -- gadget ) frp-field [ ] dip new-border dup gadget-child >>editor - field-theme swap >>frp-model { 1 0 } >>align ; -: ( -- editor ) f ; + field-theme swap init-field >>frp-model { 1 0 } >>align ; +: ( -- editor ) "" ; : ( -- field ) "" ; : ( model -- field ) "" ; @@ -60,11 +62,18 @@ IN: accessors M: frp-button text>> children>> first text>> ; IN: ui.frp.gadgets -GENERIC: (unique) ( gadget -- a ) M: label (unique) text>> ; M: button (unique) text>> ; M: editor (unique) editor-string ; M: gadget (unique) children>> ; M: frp-field (unique) frp-model>> (unique) ; -M: model (unique) [ dependencies>> ] [ value>> ] bi@ 2array ; -: unique ( a -- b ) [ class ] [ (unique) ] bi 2array ; \ No newline at end of file +M: gadget null-val drop f ; +M: table null-val multiple-selection?>> [ V{ } clone ] [ f ] if ; +M: frp-field null-val drop "" ; + +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 >>= output-model [ swap call( x -- y ) ] curry ; \ No newline at end of file diff --git a/extra/ui/frp/instances/authors.txt b/extra/ui/frp/instances/authors.txt deleted file mode 100644 index 2300f69f11..0000000000 --- a/extra/ui/frp/instances/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Sam Anklesaria diff --git a/extra/ui/frp/instances/instances-docs.factor b/extra/ui/frp/instances/instances-docs.factor deleted file mode 100644 index 8b26d208ad..0000000000 --- a/extra/ui/frp/instances/instances-docs.factor +++ /dev/null @@ -1,9 +0,0 @@ -USING: help.markup help.syntax monads ui.frp.signals ; -IN: ui.frp.instances -IN: ui.frp.instances -ARTICLE: { "ui.frp.instances" "explanation" } "FRP Instances" -"Signals are all functors, as " { $link fmap } " corresponds directly to " { $link } $nl -"Moduls also impliment monad functionalities. " { $link bind } "ing switches between two models. " $nl -"Also, a gadget is a monad. Binding recieves a model and adds the resulting gadget onto the parent. " $nl -"Examples of these instances can be seen in the " { $vocab-link "darcs-ui" } " vocabulary." ; -ABOUT: { "ui.frp.instances" "explanation" } \ No newline at end of file diff --git a/extra/ui/frp/instances/instances.factor b/extra/ui/frp/instances/instances.factor deleted file mode 100644 index 8ab7531621..0000000000 --- a/extra/ui/frp/instances/instances.factor +++ /dev/null @@ -1,12 +0,0 @@ -USING: accessors kernel models monads ui.frp.signals ui.frp.layout ui.gadgets ; -IN: ui.frp.instances - -M: model >>= [ swap ] curry ; -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 >>= output-model [ swap call( x -- y ) ] curry ; diff --git a/extra/ui/frp/layout/layout.factor b/extra/ui/frp/layout/layout.factor index 30296cd11b..af7432ae43 100644 --- a/extra/ui/frp/layout/layout.factor +++ b/extra/ui/frp/layout/layout.factor @@ -1,7 +1,7 @@ USING: accessors arrays fry kernel lexer make math.parser models models.product namespaces parser sequences ui.frp.gadgets ui.gadgets ui.gadgets.books ui.gadgets.tracks vectors words -combinators ; +combinators ui.frp.signals ; QUALIFIED: make IN: ui.frp.layout @@ -26,7 +26,7 @@ M: gadget -> dup , output-model ; M: model -> dup , ; : ,? ( uiitem -- ) inserting get parent>> children>> over - [ [ unique ] bi@ = ] curry find drop [ drop ] [ , ] if ; + [ unique= ] curry find drop [ drop ] [ , ] if ; : ->? ( uiitem -- model ) dup ,? output-model ; diff --git a/extra/ui/frp/signals/signals.factor b/extra/ui/frp/signals/signals.factor index 61604a0b47..7777274c20 100644 --- a/extra/ui/frp/signals/signals.factor +++ b/extra/ui/frp/signals/signals.factor @@ -1,14 +1,32 @@ -USING: accessors arrays kernel monads models models.product sequences ui.frp.functors ; +USING: accessors arrays kernel monads models models.product sequences ui.frp.functors +classes ui.tools.inspector tools.continuations ; FROM: models.product => product ; IN: ui.frp.signals -TUPLE: multi-model < model ; +GENERIC: (unique) ( gadget -- a ) +M: model (unique) ; +: unique ( a -- b ) [ class ] [ (unique) ] bi 2array ; +: unique= ( a b -- ? ) [ unique ] bi@ = ; + +GENERIC: null-val ( gadget -- model ) +M: model null-val drop f ; + +TUPLE: multi-model < model important? ; GENERIC: (model-changed) ( model observer -- ) : ( 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>> [ value>> ] find nip [ swap model-changed ] [ drop ] if* ; +: #1 ( model -- model' ) t >>important? ; + +IN: models +: notify-connections ( model -- ) + dup connections>> dup [ dup multi-model? [ important?>> ] [ drop f ] if ] find-all + [ second tuck [ remove ] dip prefix ] each + [ model-changed ] with each ; +IN: ui.frp.signals + TUPLE: basic-model < multi-model ; M: basic-model (model-changed) [ value>> ] dip set-model ; : ( models -- signal ) basic-model ; @@ -32,9 +50,10 @@ M: updater-model (model-changed) tuck updates>> = : ( values updates -- signal ) [ 2array updater-model ] 2keep [ >>values ] [ >>updates ] bi* ; +SYMBOL: switch TUPLE: switch-model < multi-model original switcher on ; -M: switch-model model-changed 2dup switcher>> = - [ [ value>> ] dip over [ t >>on set-model ] [ nip [ original>> ] keep f >>on model-changed ] if ] +M: switch-model (model-changed) 2dup switcher>> = + [ [ value>> ] dip over switch = [ nip [ original>> ] keep f >>on model-changed ] [ t >>on set-model ] if ] [ dup on>> [ 2drop ] [ [ value>> ] dip over [ set-model ] [ 2drop ] if ] if ] if ; : ( signal1 signal2 -- signal' ) swap [ 2array switch-model ] 2keep [ [ value>> >>value ] [ >>original ] bi ] [ >>switcher ] bi* ; @@ -80,9 +99,11 @@ M: | update-model dup value>> swap [ set-model ] set-product-value ; M: | model-activated dup model-changed ; -! Only when everything's true does he make it false TUPLE: & < | ; : <&> ( models -- product ) & ; -M: & models-changed dependencies>> [ f swap (>>value) ] each ; +M: & models-changed dependencies>> [ [ null-val ] keep (>>value) ] each ; PRIVATE> + +M: model >>= [ swap ] curry ; +M: model fmap ; FMAPS: $> <$ fmap FOR & | product ; \ No newline at end of file