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
-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"
USING: fry functors generalizations kernel macros peg peg-lexer
sequences ;
+FROM: ui.frp.signals => #1 ;
IN: ui.frp.functors
FUNCTOR: fmaps ( W 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 <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
+MACRO: w-n* ( int -- quot ) dup '[ [ _ narray <p> #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:
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 ;
: <frp-button> ( 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 <basic> >>model ;
: <frp-border-button> ( text -- button ) <frp-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* ;
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* ;
+ V{ } clone <basic> >>selected-values V{ } clone <basic> >>selected-indices*
+ f <basic> >>actions dup [ actions>> set-model ] curry >>action ;
: <frp-table*> ( -- table ) V{ } clone <model> <frp-table> ;
: <frp-list> ( column-model -- table ) <frp-table> [ 1array ] >>quot ;
: <frp-list*> ( -- table ) V{ } clone <model> <frp-list> ;
: indexed ( table -- table ) f >>val-quot ;
TUPLE: frp-field < field frp-model ;
-: <frp-field> ( model -- gadget ) frp-field new-field swap >>frp-model ;
+: init-field ( field -- field' ) [ [ ] [ "" ] if* ] change-value ;
+: <frp-field> ( 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 ]
[ [ value>> ] [ editor>> ] bi* set-editor-string ]
[ nip [ editor>> editor-string ] [ frp-model>> ] bi set-model ] if ;
-: <frp-field*> ( -- field ) f <model> <frp-field> ;
+: <frp-field*> ( -- field ) "" <model> <frp-field> ;
: <empty-field> ( model -- field ) "" <model> <switch> <frp-field> ;
: <empty-field*> ( -- field ) "" <model> <frp-field> ;
: <frp-editor> ( model -- gadget )
frp-field [ <multiline-editor> ] dip new-border dup gadget-child >>editor
- field-theme swap >>frp-model { 1 0 } >>align ;
-: <frp-editor*> ( -- editor ) f <model> <frp-editor> ;
+ field-theme swap init-field >>frp-model { 1 0 } >>align ;
+: <frp-editor*> ( -- editor ) "" <model> <frp-editor> ;
: <empty-editor*> ( -- field ) "" <model> <frp-editor> ;
: <empty-editor> ( model -- field ) "" <model> <switch> <frp-editor> ;
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 <gadget> swap >>model ;
+M: gadget >>= output-model [ swap call( x -- y ) ] curry ;
\ No newline at end of file
+++ /dev/null
-Sam Anklesaria
+++ /dev/null
-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 <mapped> } $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
+++ /dev/null
-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 ;
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
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 ;
-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 -- )
: <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>> [ 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 ;
: <merge> ( models -- signal ) basic-model <multi-model> ;
: <updates> ( values updates -- signal ) [ 2array updater-model <multi-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 ;
: <switch> ( signal1 signal2 -- signal' ) swap [ 2array switch-model <multi-model> ] 2keep
[ [ value>> >>value ] [ >>original ] bi ] [ >>switcher ] bi* ;
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 ) & <multi-model> ;
-M: & models-changed dependencies>> [ f swap (>>value) ] each ;
+M: & models-changed dependencies>> [ [ null-val ] keep (>>value) ] each ;
PRIVATE>
+
+M: model >>= [ swap <action> ] curry ;
+M: model fmap <mapped> ;
FMAPS: $> <$ fmap FOR & | product ;
\ No newline at end of file
projects / factor.git / commitdiff