product specifiers removed from frp signals

Sam Anklesaria 2009-07-21 19:40:06 -05:00
parent e81b3f8028
commit 64bf116a01
12 changed files with 45 additions and 81 deletions

View File

@ -39,9 +39,9 @@ STORED-TUPLE: recipe { title { VARCHAR 100 } } { votes INTEGER } { txt TEXT } {
<spacer> <frp-field*> ->% 1 :> search <spacer> <frp-field*> ->% 1 :> search
submit ok [ [ drop ] ] <$ 2array <merge> [ drop ] >>value :> quot submit ok [ [ drop ] ] <$ 2array <merge> [ drop ] >>value :> quot
viewed 0 [ + ] <fold> search ok t <basic> "all" <frp-button> ALL -> viewed 0 [ + ] <fold> search ok t <basic> "all" <frp-button> ALL ->
tbl selected-value>> votes [ [ + ] curry change-votes modify-tuple ] 2$>-| tbl selected-value>> votes [ [ + ] curry change-votes modify-tuple ] 2$>
4array <merge> 4array <merge>
[ drop [ f ] [ "%" dup surround <pattern> ] if-empty top-recipes ] 3fmap-| :> updates [ drop [ f ] [ "%" dup surround <pattern> ] if-empty top-recipes ] 3fmap :> updates
updates [ top-genres [ <frp-button> GENRES -> ] map <merge> ] bind* updates [ top-genres [ <frp-button> GENRES -> ] map <merge> ] bind*
[ text>> T{ recipe } swap >>genre get-tuples ] fmap [ text>> T{ recipe } swap >>genre get-tuples ] fmap
tbl swap updates 2array <merge> >>model tbl swap updates 2array <merge> >>model
@ -52,9 +52,9 @@ STORED-TUPLE: recipe { title { VARCHAR 100 } } { votes INTEGER } { txt TEXT } {
[ [ genre>> ] fmap <frp-field> GENRE ->% .5 ] [ [ genre>> ] fmap <frp-field> GENRE ->% .5 ]
[ [ txt>> ] fmap <frp-editor> BODY ->% 1 ] [ [ txt>> ] fmap <frp-editor> BODY ->% 1 ]
} cleave } cleave
[ <recipe> ] 3fmap-| [ <recipe> ] 3fmap
[ [ 1 ] <$ ] [ [ 1 ] <$ ]
[ quot ok <updates> #1 [ call( recipe -- ) 0 ] 2fmap-& ] bi [ quot ok <updates> #1 [ call( recipe -- ) 0 ] 2fmap ] bi
2array <merge> 0 <basic> <switch> >>model 2array <merge> 0 <basic> <switch> >>model
] with-interface "recipes" open-window ] with-ui ; ] with-interface "recipes" open-window ] with-ui ;

View File

@ -3,7 +3,7 @@ lists.lazy locals math math.functions math.parser math.ranges
models.product monads random sequences sets ui ui.frp.gadgets models.product monads random sequences sets ui ui.frp.gadgets
ui.frp.layout ui.frp.signals ui.gadgets.alerts vectors fry ui.frp.layout ui.frp.signals ui.gadgets.alerts vectors fry
ui.gadgets.labels memoize ; ui.gadgets.labels memoize ;
IN: gui-sudoku IN: sudokus
: row ( index -- row ) 1 + 9 / ceiling ; : row ( index -- row ) 1 + 9 / ceiling ;
: col ( index -- col ) 9 mod 1 + ; : col ( index -- col ) 9 mod 1 + ;

View File

@ -1 +0,0 @@
Sam Anklesaria

View File

@ -1,10 +0,0 @@
USING: help.markup help.syntax ui.frp.signals ;
IN: ui.frp.functors
ARTICLE: { "ui.frp.functors" "signal-collection" } "Signal Collection"
"While " { $vocab-link "models.arrow.smart" } " use arrows and products to apply a quotation to the values of more than one signal, frp has more than one kind of arrow, as well as more than one kind of product" $nl
"A simple pattern is used to generate the requisite 'smart mapping' functions: "
"if 'word' maps a function on a model, then '2word; would map on two models. "
"The product is specified on the end: '2word-product'. " { $link | } " updates when any of the model it collects updates, while " { $link & } " updates when all dependencies have new values. "
"Examples of collection functions are 2fmap-| and 2$>-&" ;
ABOUT: { "ui.frp.functors" "signal-collection" }

View File

@ -1,34 +0,0 @@
USING: fry functors generalizations kernel macros peg peg-lexer
sequences sequences.extras ;
FROM: ui.frp.signals => #1 ;
IN: ui.frp.functors
FUNCTOR: fmaps ( W P -- )
W IS ${W}
<p> IS <${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}
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:
tokenizer = <foreign factor>
token = !("FOR"|";").
middle = "FOR" => [[ drop ignore ]]
endexpr = ";" => [[ drop ignore ]]
expr = token* middle token* endexpr => [[ first2 combos [ first2 fmaps ] each ignore ]]
;ON-BNF

View File

@ -1 +0,0 @@
Used by ui.frp.signals to combine models

View File

@ -67,9 +67,6 @@ IN: accessors
M: frp-button text>> children>> first text>> ; M: frp-button text>> children>> first text>> ;
IN: ui.frp.gadgets IN: ui.frp.gadgets
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 SINGLETON: gadget-monad
INSTANCE: gadget-monad monad INSTANCE: gadget-monad monad

View File

@ -42,7 +42,7 @@ M: model -> dup , ;
: <box> ( gadgets type -- track ) : <box> ( gadgets type -- track )
[ t make-layout ] dip <track> [ t make-layout ] dip <track>
swap [ add-layout ] each swap [ add-layout ] each
swap [ <|> >>model ] unless-empty ; inline swap [ <collection> >>model ] unless-empty ; 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
@ -63,7 +63,7 @@ M: gadget (insert-item) dup parent>> track? [ [ f <layout> ] dip (insert-item) ]
[ insertion-point [ add-gadget ] keep insert-gadget ] if ; [ insertion-point [ add-gadget ] keep insert-gadget ] if ;
M: layout (insert-item) insertion-point [ add-layout ] keep [ gadget>> insert-gadget ] [ size>> insert-size ] 3bi ; M: layout (insert-item) insertion-point [ add-layout ] keep [ gadget>> insert-gadget ] [ size>> insert-size ] 3bi ;
M: model (insert-item) parent>> dup book? [ "No models in books" throw ] M: model (insert-item) parent>> dup book? [ "No models in books" throw ]
[ dup model>> dup |? [ nip swap add-connection ] [ drop [ 1array <|> ] dip (>>model) ] if ] if ; [ dup model>> dup collection? [ nip swap add-connection ] [ drop [ 1array <collection> ] dip (>>model) ] if ] if ;
: insert-item ( item location -- ) [ dup get [ drop ] [ remove-members ] if ] [ on ] [ ] tri : insert-item ( item location -- ) [ dup get [ drop ] [ remove-members ] if ] [ on ] [ ] tri
[ add-member ] 2keep (insert-item) ; [ add-member ] 2keep (insert-item) ;
@ -71,5 +71,4 @@ M: model (insert-item) parent>> dup book? [ "No models in books" throw ]
: with-interface ( quot -- ) make* [ insert-items ] with-scope ; inline : with-interface ( quot -- ) make* [ insert-items ] with-scope ; inline
M: model >>= [ swap insertion-quot <action> ] curry ; M: model >>= [ swap insertion-quot <action> ] curry ;
! Temporary places should be cleared at insertion, not on mention

View File

@ -1,11 +1,8 @@
USING: accessors arrays kernel models models.product monads USING: accessors arrays kernel models models.product monads
sequences sequences.extras ; sequences sequences.extras ;
FROM: models.product => product ; FROM: syntax => >> ;
IN: ui.frp.signals IN: ui.frp.signals
GENERIC: null-val ( gadget -- model )
M: model null-val drop f ;
TUPLE: multi-model < model important? ; TUPLE: multi-model < model important? ;
GENERIC: (model-changed) ( model observer -- ) GENERIC: (model-changed) ( model observer -- )
: <multi-model> ( models kind -- model ) f swap new-model [ [ add-dependency ] curry each ] keep ; : <multi-model> ( models kind -- model ) f swap new-model [ [ add-dependency ] curry each ] keep ;
@ -47,9 +44,9 @@ M: fold-model model-activated drop ;
dip [ >>base ] [ value>> >>value ] bi ; dip [ >>base ] [ value>> >>value ] bi ;
TUPLE: updater-model < multi-model values updates ; TUPLE: updater-model < multi-model values updates ;
M: updater-model (model-changed) tuck updates>> = M: updater-model (model-changed) [ tuck updates>> =
[ [ values>> value>> ] keep set-model ] [ [ values>> value>> ] keep set-model ]
[ drop ] if ; [ drop ] if ] keep f swap (>>value) ;
: <updates> ( values updates -- signal ) [ 2array updater-model <multi-model> ] 2keep : <updates> ( values updates -- signal ) [ 2array updater-model <multi-model> ] 2keep
[ >>values ] [ >>updates ] bi* ; [ >>values ] [ >>updates ] bi* ;
@ -61,7 +58,7 @@ M: switch-model (model-changed) 2dup switcher>> =
: <switch> ( signal1 signal2 -- signal' ) swap [ 2array switch-model <multi-model> ] 2keep : <switch> ( signal1 signal2 -- signal' ) swap [ 2array switch-model <multi-model> ] 2keep
[ [ value>> >>value ] [ >>original ] bi ] [ >>switcher ] bi* ; [ [ value>> >>value ] [ >>original ] bi ] [ >>switcher ] bi* ;
M: switch-model model-activated [ original>> ] keep model-changed ; M: switch-model model-activated [ original>> ] keep model-changed ;
: >behavior ( event -- behavior ) t <model> <switch> ; : >behavior ( event -- behavior ) t >>value ;
TUPLE: mapped-model < multi-model model quot ; TUPLE: mapped-model < multi-model model quot ;
: new-mapped-model ( model quot class -- mapped-model ) [ over 1array ] dip : new-mapped-model ( model quot class -- mapped-model ) [ over 1array ] dip
@ -89,20 +86,14 @@ M: action (model-changed) [ [ value>> ] [ quot>> ] bi* call( a -- b ) ] keep val
[ swap add-connection ] 2keep model-changed ; [ swap add-connection ] 2keep model-changed ;
: <action> ( model quot -- action-signal ) [ 1array action <multi-model> ] dip >>quot dup f <action-value> >>value value>> ; : <action> ( model quot -- action-signal ) [ 1array action <multi-model> ] dip >>quot dup f <action-value> >>value value>> ;
TUPLE: | < multi-model ; TUPLE: collection < multi-model ;
: <|> ( models -- product ) | <multi-model> ; : <collection> ( models -- product ) collection <multi-model> ;
GENERIC: models-changed ( product -- ) M: collection (model-changed)
M: | models-changed drop ;
M: | model-changed
nip nip
dup dependencies>> [ value>> ] all? dup dependencies>> [ value>> ] all?
[ [ dup [ value>> ] product-value swap set-model ] keep models-changed ] [ dup [ value>> ] product-value swap set-model ]
[ drop ] if ; [ drop ] if ;
M: | model-activated dup model-changed ; M: collection model-activated dup (model-changed) ;
TUPLE: & < | ;
: <&> ( models -- product ) & <multi-model> ;
M: & models-changed dependencies>> [ [ null-val ] keep (>>value) ] each ;
! for side effects ! for side effects
TUPLE: (frp-when) < multi-model quot cond ; TUPLE: (frp-when) < multi-model quot cond ;
@ -110,9 +101,9 @@ TUPLE: (frp-when) < multi-model quot cond ;
M: (frp-when) (model-changed) [ quot>> ] 2keep M: (frp-when) (model-changed) [ quot>> ] 2keep
[ value>> ] [ cond>> ] bi* call( a -- ? ) [ call( model -- ) ] [ 2drop ] if ; [ value>> ] [ cond>> ] bi* call( a -- ? ) [ call( model -- ) ] [ 2drop ] if ;
M: model fmap <mapped> ;
USE: ui.frp.functors
FMAPS: $> <$ fmap FOR & | product ;
! only used in construction ! only used in construction
: with-self ( quot: ( model -- model ) -- model ) [ f <basic> dup ] dip call swap [ add-dependency ] keep ; inline : with-self ( quot: ( model -- model ) -- model ) [ f <basic> dup ] dip call swap [ add-dependency ] keep ; inline
USE: ui.frp.signals.templates
M: model fmap <mapped> ;
<< { "$>" "<$" "fmap" } [ fmaps ] each >>

View File

@ -0,0 +1,23 @@
USING: kernel sequences functors fry macros generalizations ;
IN: ui.frp.signals.templates
FROM: ui.frp.signals => <collection> #1 ;
FUNCTOR: fmaps ( W -- )
W IS ${W}
w-n DEFINES ${W}-n
w-2 DEFINES 2${W}
w-3 DEFINES 3${W}
w-4 DEFINES 4${W}
w-n* DEFINES ${W}-n*
w-2* DEFINES 2${W}*
w-3* DEFINES 3${W}*
w-4* DEFINES 4${W}*
WHERE
MACRO: w-n ( int -- quot ) dup '[ [ _ narray <collection> ] 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 <collection> #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