steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

ui.frp connection reordering supported

db4
Sam Anklesaria 2009-06-14 11:42:31 -05:00
parent c03ec9f053
commit b265e3afea
9 changed files with 64 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
core/sequences/sequences.factor
View File

@ -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 ;
: (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

2
extra/ui/frp/functors/functors-docs.factor
View File

@ -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"

9
extra/ui/frp/functors/functors.factor
View File

@ -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 <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:

35
extra/ui/frp/gadgets/gadgets.factor
View File

@ -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 ;
: <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* ;
@ -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* ;
: <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 ]
@ -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 ;
: <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> ;
@ -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 ;
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 ;

1
extra/ui/frp/instances/authors.txt
View File

@ -1 +0,0 @@
Sam Anklesaria

9
extra/ui/frp/instances/instances-docs.factor
View File

@ -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 <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" }

12
extra/ui/frp/instances/instances.factor
View File

@ -1,12 +0,0 @@
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 ;

4
extra/ui/frp/layout/layout.factor
View File

@ -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 ;

33
extra/ui/frp/signals/signals.factor
View File

@ -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 -- )
: <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> ;
@ -32,9 +50,10 @@ M: updater-model (model-changed) tuck updates>> =
: <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* ;
@ -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 ) & <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 ;