separated behaviors and events in frp
parent
06359c0850
commit
bd92f6c8cc
|
@ -1,7 +1,7 @@
|
|||
USING: accessors arrays colors fonts fry kernel models
|
||||
USING: accessors arrays colors fonts kernel models
|
||||
models.product monads sequences ui.gadgets ui.gadgets.buttons
|
||||
ui.gadgets.editors ui.gadgets.line-support ui.gadgets.tables
|
||||
ui.gadgets.tracks ui.render ;
|
||||
ui.gadgets.tracks ui.render ui.gadgets.scrollers ;
|
||||
QUALIFIED: make
|
||||
IN: ui.frp
|
||||
|
||||
|
@ -27,6 +27,8 @@ M: frp-table row-color color-quot>> [ call( a -- b ) ] [ drop f ] if* ;
|
|||
GENERIC: output-model ( gadget -- model )
|
||||
M: gadget output-model model>> ;
|
||||
M: frp-table output-model selected-value>> ;
|
||||
M: model-field output-model field-model>> ;
|
||||
M: scroller output-model children>> first model>> ;
|
||||
|
||||
GENERIC: , ( uiitem -- )
|
||||
M: gadget , make:, ;
|
||||
|
@ -41,13 +43,16 @@ M: table -> dup , selected-value>> ;
|
|||
[ { } make:make ] dip <track> swap [ f 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
|
||||
|
||||
! Model utilities
|
||||
! !!! 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 ;
|
||||
|
||||
! Events- discrete model utilities
|
||||
|
||||
TUPLE: merge-model < multi-model ;
|
||||
M: merge-model model-changed [ value>> ] dip set-model ;
|
||||
: <merge> ( models -- model ) merge-model <multi-model> ;
|
||||
|
@ -57,15 +62,21 @@ M: filter-model model-changed [ value>> ] dip [ quot>> call( val -- bool ) ] 2ke
|
|||
[ set-model ] [ 2drop ] if ;
|
||||
: <filter> ( model quot -- filter-model ) [ 1array filter-model <multi-model> ] dip >>quot ;
|
||||
|
||||
! Behaviors - continuous model utilities
|
||||
|
||||
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 ;
|
||||
: <fold> ( oldval quot model -- model' ) 1array fold-model <multi-model> swap >>quot
|
||||
swap [ >>oldval ] [ >>value ] bi ;
|
||||
|
||||
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: 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 ;
|
||||
M: switch-model model-activated [ original>> ] keep model-changed ;
|
||||
: switch ( signal1 signal2 -- signal' ) [ 2array switch-model <multi-model> ] 2keep
|
||||
[ >>original ] [ >>switcher ] bi* ;
|
||||
|
||||
TUPLE: mapped < model model quot ;
|
||||
|
||||
|
@ -87,4 +98,4 @@ 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 ) ] ;
|
||||
M: gadget >>= output-model [ swap call( x -- y ) ] curry ;
|
Loading…
Reference in New Issue