simplification of frp

db4
Sam Anklesaria 2009-06-24 20:06:12 -05:00
parent 2a26670099
commit ea052600bf
4 changed files with 38 additions and 48 deletions

View File

@ -2,7 +2,7 @@ USING: accessors arrays db.tuples db.sqlite persistency db.queries
io.files.temp kernel monads sequences ui ui.frp.gadgets
ui.frp.layout ui.frp.signals ui.gadgets.scrollers ui.gadgets.labels
colors.constants ui.pens.solid combinators math locals strings
ui.images db.types sequences.extras ;
ui.images db.types sequences.extras ui.tools.inspector ;
FROM: sets => prune ;
IN: recipes
STORED-TUPLE: recipe { title { VARCHAR 100 } } { votes INTEGER } { txt TEXT } { genre { VARCHAR 100 } } ;
@ -14,8 +14,8 @@ STORED-TUPLE: recipe { title { VARCHAR 100 } } { votes INTEGER } { txt TEXT } {
: interface ( -- book ) [
[
[ $ TOOLBAR $ <spacer> $ SEARCH $ ] <hbox> COLOR: AliceBlue <solid> >>interior ,
[ "Genres:" <label> , <spacer> $ GENRES $ ] <hbox>
[ $ TOOLBAR $ ] <hbox> COLOR: AliceBlue <solid> >>interior ,
[ "Genres:" <label> , <spacer> $ ALL $ $ GENRES $ ] <hbox>
{ 5 0 } >>gap COLOR: gray <solid> >>interior ,
$ RECIPES $
] <vbox> ,
@ -35,13 +35,13 @@ STORED-TUPLE: recipe { title { VARCHAR 100 } } { votes INTEGER } { txt TEXT } {
"hate" <image-button> -1 >>value -> 2array <merge> :> votes
"back" <image-button> -> [ -30 ] <$
"more" <image-button> -> [ 30 ] <$ 2array <merge> :> viewed
<frp-field*> SEARCH ->% 1 :> search
<spacer> <frp-field*> ->% 1 :> search
submit ok [ [ drop ] ] <$ 2array <merge> [ drop ] >>value :> quot
viewed 0 [ + ] <fold> search ok t <basic> "all" <frp-button> GENRES ->
viewed 0 [ + ] <fold> search ok t <basic> "all" <frp-button> ALL ->
tbl selected-value>> votes [ [ + ] curry change-votes modify-tuple ] 2$>-|
4array <merge>
[ drop [ f ] [ "%" dup surround <pattern> ] if-empty top-recipes ] 3fmap-| :> updates
updates [ top-genres UI[ <frp-button> GENRES ->? ] map <merge> ] bind*
updates [ top-genres [ <frp-button> GENRES -> ] map <merge> ] bind*
[ text>> T{ recipe } swap >>genre get-tuples ] fmap
tbl swap updates 2array <merge> >>model
[ [ title>> ] [ genre>> ] bi 2array ] >>quot

View File

@ -70,11 +70,6 @@ IN: accessors
M: frp-button text>> children>> first text>> ;
IN: ui.frp.gadgets
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: gadget null-val drop f ;
M: table null-val multiple-selection?>> [ V{ } clone ] [ f ] if ;
M: frp-field null-val drop "" ;

View File

@ -1,23 +1,24 @@
USING: accessors assocs arrays fry kernel lexer make math.parser models
models.product namespaces parser sequences ui.frp.gadgets
USING: accessors assocs arrays fry kernel make math.parser models
models.product namespaces sequences ui.frp.gadgets parser lexer
ui.gadgets ui.gadgets.books ui.gadgets.tracks vectors words
combinators ui.frp.signals ;
combinators ui.frp.signals monads sequences.extras ;
QUALIFIED: make
IN: ui.frp.layout
SYMBOL: inserting
TUPLE: layout gadget size ; C: <layout> layout
TUPLE: placeholder < gadget ;
ERROR: no-models-in-books models ;
TUPLE: placeholder < gadget members ;
: <placeholder> ( -- placeholder ) placeholder new V{ } clone >>members ;
DEFER: insert-item
: , ( uiitem -- ) inserting namespace at {
{ f [ make:, ] }
{ t [ dup placeholder? [ inserting set ] [ "No location to add UI item" throw ] if ] }
[ placeholder? [ [ inserting get insert-item ] keep relayout ] [ drop ] if ]
} case ;
: (remove-members) ( placeholder members -- ) [ [ model? ] filter swap parent>> model>> [ remove-connection ] curry each ]
[ [ gadget? ] filter swap parent>> children>> [ delete ] curry each ] 2bi ;
: remove-members ( placeholder -- ) dup members>> [ drop ] [ [ (remove-members) ] keep empty ] if-empty ;
: add-member ( obj placeholder -- ) over layout? [ [ gadget>> ] dip ] when members>> push ;
SYNTAX: UI[ parse-quotation '[ [ t inserting _ with-variable ] ] over push-all ;
: , ( item -- ) make:, ;
: make* ( quot -- list ) { } make ; inline
DEFER: with-interface
: insertion-quot ( quot -- quot' ) <placeholder> dup , swap '[ [ _ , @ ] with-interface ] ;
SYNTAX: ,% scan string>number [ <layout> , ] curry over push-all ;
SYNTAX: ->% scan string>number '[ [ _ <layout> , ] [ output-model ] bi ] over push-all ;
@ -26,11 +27,6 @@ GENERIC: -> ( uiitem -- model )
M: gadget -> dup , output-model ;
M: model -> dup , ;
: ,? ( uiitem -- ) inserting get parent>> children>> over
[ unique= ] curry find drop [ drop ] [ , ] if ;
: ->? ( uiitem -- model ) dup ,? output-model ;
: <spacer> ( -- ) <gadget> 1 <layout> , ;
: add-layout ( track layout -- track ) [ gadget>> ] [ size>> ] bi track-add ; inline
@ -38,7 +34,7 @@ M: model -> dup , ;
[ [ dup layout? [ f <layout> ] unless ] map ]
[ [ dup gadget? [ gadget>> ] unless ] map ] if ;
: make-layout ( building sized? -- models layouts ) [ swap layouts ] curry
[ { } make [ [ model? ] filter ] ] dip bi ; inline
[ make* [ [ model? ] filter ] ] dip bi ; inline
: <box> ( gadgets type -- track )
[ t make-layout ] dip <track>
swap [ add-layout ] each
@ -46,11 +42,11 @@ M: model -> dup , ;
: <hbox> ( gadgets -- track ) horizontal <box> ; inline
: <vbox> ( gadgets -- track ) vertical <box> ; inline
: make-book ( models gadgets model -- book ) <book> swap [ no-models-in-books ] unless-empty ;
: make-book ( models gadgets model -- book ) <book> swap [ "No models in books" throw ] unless-empty ;
: <frp-book> ( quot: ( -- model ) -- book ) f make-layout rot 0 >>value make-book ; inline
: <frp-book*> ( quot -- book ) f make-layout f make-book ; inline
SYNTAX: $ CREATE-WORD placeholder new
SYNTAX: $ CREATE-WORD <placeholder>
[ [ , ] curry (( -- )) define-declared "$" expect ]
[ [ , ] curry ] bi over push-all ;
@ -58,13 +54,18 @@ SYNTAX: $ CREATE-WORD placeholder new
: insert-size ( number parent size -- ) -rot [ but-last insert-nth ] change-sizes drop ;
: insertion-point ( gadget placeholder -- number parent gadget ) dup parent>> [ children>> index ] keep rot ;
GENERIC# insert-item 1 ( item location -- )
M: gadget insert-item dup parent>> track? [ [ f <layout> ] dip insert-item ]
GENERIC# (insert-item) 1 ( item location -- )
M: gadget (insert-item) dup parent>> track? [ [ f <layout> ] dip (insert-item) ]
[ 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: model insert-item parent>> dup book? [ no-models-in-books ]
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 ]
[ dup model>> dup product? [ nip swap add-connection ] [ drop [ 1array <product> ] dip (>>model) ] if ] if ;
: insert-item ( item location -- ) [ add-member ] 2keep (insert-item) ;
: insert-items ( makelist -- ) f swap [ dup placeholder? [ nip ] [ over insert-item ] if ] each drop ;
: insert-items ( makelist -- ) f swap [ dup placeholder?
[ nip [ dup get [ drop ] [ remove-members ] if ] [ on ] [ ] tri ]
[ over insert-item ] if ] each drop ;
: with-interface ( quot: ( -- gadget ) -- gadget ) { } make insert-items ; inline
: with-interface ( quot -- ) make* [ insert-items ] with-scope ; inline
M: model >>= [ swap insertion-quot <action> ] curry ;

View File

@ -3,11 +3,6 @@ sequences.extras ;
FROM: models.product => product ;
IN: ui.frp.signals
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 ;
@ -111,16 +106,15 @@ TUPLE: & < | ;
M: & models-changed dependencies>> [ [ null-val ] keep (>>value) ] each ;
PRIVATE>
M: model >>= [ swap <action> ] curry ;
M: model fmap <mapped> ;
USE: ui.frp.functors
FMAPS: $> <$ fmap FOR & | product ;
! for side effects
TUPLE: (frp-when) < multi-model quot cond ;
: frp-when ( model quot cond -- model ) rot 1array (frp-when) <multi-model> swap >>cond swap >>quot ;
M: (frp-when) (model-changed) [ quot>> ] 2keep
[ 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
: with-self ( quot: ( model -- model ) -- model ) [ f <basic> dup ] dip call swap [ add-dependency ] keep ; inline