[ list rest identity quot reduce-r list first quot call ] if ;
inline recursive
-:: combos ( list1 list2 -- result ) list2 [ [ 2array ] curry list1 swap map ] map concat ;
\ No newline at end of file
+:: 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
-USING: assocs io.pathnames fry namespaces namespaces.private kernel sequences parser ;
+USING: assocs io.pathnames fry namespaces namespaces.private kernel sequences parser hashtables ;
IN: closures
SYMBOL: |
! Selective Binding
-: delayed-bind-with ( vars quot -- quot' ) '[ _ dup [ get ] map zip [ _ bind ] curry ] ;
+: delayed-bind-with ( vars quot -- quot' ) '[ _ dup [ get ] map zip >hashtable [ _ bind ] curry ] ;
SYNTAX: C[ | parse-until parse-quotation delayed-bind-with over push-all ;
! Common ones
SYNTAX: DIR[ parse-quotation { current-directory } swap delayed-bind-with over push-all ;
IN: persistency
TUPLE: persistent id ;
-UNION: bool word POSTPONE: f ;
-UNION: short-string string ;
-: db-ize ( class -- db-class ) {
- { bool [ BOOLEAN ] }
- { short-string [ { VARCHAR 100 } ] }
- { string [ TEXT ] }
- { float [ DOUBLE ] }
- { timestamp [ TIMESTAMP ] }
- { fixnum [ INTEGER ] }
- { byte-array [ BLOB ] }
- { url [ URL ] }
- [ drop FACTOR-BLOB ]
-} case ;
-
-: add-types ( table -- table' ) [ [ first dup >upper ] [ second db-ize ] bi 3array ] map
-{ "id" "ID" +db-assigned-id+ } prefix ;
+: add-types ( table -- table' ) [ dup array? [ first ] when dup >upper FACTOR-BLOB 3array ] map
+ { "id" "ID" +db-assigned-id+ } prefix ;
SYNTAX: STORED-TUPLE: parse-tuple-definition [ drop persistent ] dip [ define-tuple-class ]
[ nip [ dup unparse >upper ] [ add-types ] bi* define-persistent ] 3bi ;
-: define-db ( database class -- ) swap [ [ recreate-table ] with-db ] [ "database" set-word-prop ] 2bi ;
+: define-db ( database class -- ) swap [ [ ensure-table ] with-db ] [ "database" set-word-prop ] 2bi ;
: query>tuple ( tuple/query -- tuple ) dup query? [ tuple>> ] when ;
: w/db ( query quot -- ) [ dup query>tuple class "database" word-prop ] dip with-db ; inline
M: frp-field model-changed 2dup frp-model>> =
[ [ value>> ] [ editor>> ] bi* set-editor-string ]
[ nip [ editor>> editor-string ] [ frp-model>> ] bi set-model ] if ;
-: after-empty ( model quot -- model' ) fmap "" <model> <switch> ; inline ! pattern for editors, labels
-: <frp-field*> ( -- field ) "" <model> <frp-field> ;
+: <frp-field*> ( -- field ) f <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 ;
-: <empty-editor> ( model -- editor ) "" <model> <switch> <frp-editor> ;
-: <frp-editor*> ( -- editor ) "" <model> <frp-editor> ;
+: <frp-editor*> ( -- editor ) f <model> <frp-editor> ;
+: <empty-editor*> ( -- field ) "" <model> <frp-editor> ;
+: <empty-editor> ( model -- field ) "" <model> <switch> <frp-editor> ;
GENERIC: output-model ( gadget -- model )
M: gadget output-model model>> ;
-USING: accessors assocs arrays fry kernel lexer make math math.parser
-models models.product namespaces parser sequences
-ui.frp.gadgets ui.gadgets ui.gadgets.books ui.gadgets.tracks
-words tools.continuations ;
+USING: accessors 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 ;
+QUALIFIED: make
IN: ui.frp.layout
TUPLE: layout gadget size ; C: <layout> layout
-ERROR: no-models models ;
+TUPLE: placeholder < gadget ;
+ERROR: no-models-in-books models ;
+
+DEFER: insert-item
+HOOK: , building ( uiitem -- )
+M: vector , make:, ;
+M: f , dup placeholder? [ building set ] [ "No location to add UI item" throw ] if ;
+M: placeholder , [ building get insert-item ] keep relayout ;
SYNTAX: ,% scan string>number [ <layout> , ] curry over push-all ;
SYNTAX: ->% scan string>number '[ [ _ <layout> , ] [ output-model ] bi ] over push-all ;
: <spacer> ( -- ) <gadget> 1 <layout> , ;
-SYMBOL: wordnames
-: insert-layout ( track layout -- track ) [ gadget>> ] [ size>> ] bi track-add ; inline
+: add-layout ( track layout -- track ) [ gadget>> ] [ size>> ] bi track-add ; inline
: layouts ( sized? gadgets -- layouts ) [ [ gadget? ] [ layout? ] bi or ] filter swap
[ [ dup layout? [ f <layout> ] unless ] map ] when ;
-: make-layout ( building sized? -- models words layouts ) [ swap layouts ] curry
- [ { } make [ [ model? ] filter ] [ [ word? ] filter ] ] dip tri ; inline
-: handle-words ( words gadget -- gadget ) tuck
- [ [ swap 2array ] curry wordnames get swap change-at ] curry each ;
+: make-layout ( building sized? -- models layouts ) [ swap layouts ] curry
+ [ { } make [ [ model? ] filter ] ] dip bi ; inline
: <box> ( gadgets type -- track )
[ t make-layout ] dip <track>
- swap [ insert-layout ] each
- handle-words
+ swap [ add-layout ] each
swap [ <product> >>model ] unless-empty ; inline
: <hbox> ( gadgets -- track ) horizontal <box> ; inline
: <vbox> ( gadgets -- track ) vertical <box> ; inline
-: <frp-book> ( quot: ( -- model ) -- book ) f make-layout roll dup activate-model <book> handle-words
- swap [ no-models ] unless-empty ; inline
-: <frp-book*> ( quot -- book ) f make-layout f <book> handle-words
- swap [ no-models ] unless-empty ; inline
+: make-book ( models gadgets model -- book ) <book> swap [ no-models-in-books ] 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 dup [ , ] curry (( -- )) define-declared "$" expect
- word [ [ building get length swap wordnames get set-at ] [ , ] bi ] curry over push-all ;
+SYNTAX: $ CREATE-WORD placeholder new
+ [ [ , ] curry (( -- )) define-declared "$" expect ]
+ [ [ , ] curry ] bi over push-all ;
: insert-gadget ( number parent gadget -- ) -rot [ but-last insert-nth ] change-children drop ;
: 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 first book? [ first2 spin [ add-gadget ] keep insert-gadget ]
- [ [ f <layout> ] dip insert-item ] if ;
-M: layout insert-item first2 spin [ insert-layout ] keep [ gadget>> insert-gadget ] [ size>> insert-size ] 3bi ;
-M: model insert-item dup first book? [ no-models ]
+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 dup first book? [ no-models-in-books ]
[ first model>> swap add-connection ] if ;
-: insert-items ( makelist -- ) f swap [ dup word?
- [ nip ] [
- over [ wordnames get at insert-item ] [ wordnames get [ first2 1 + 2array ] change-at ] bi
- ] if ] each drop ;
-
-: with-interface ( quot: ( -- gadget ) -- gadget ) H{ } clone wordnames
- [ { } make insert-items ] with-variable ; inline
+: insert-items ( makelist -- ) f swap [ dup placeholder? [ nip ] [ over insert-item ] if ] each drop ;
-! while children are changed, sizes aren't
\ No newline at end of file
+: with-interface ( quot: ( -- gadget ) -- gadget ) { } make insert-items ; inline
\ No newline at end of file
USING: accessors arrays kernel monads models models.product sequences ui.frp.functors ;
+FROM: models.product => product ;
IN: ui.frp.signals
TUPLE: multi-model < model ;
[ [ value>> ] dip over [ t >>on set-model ] [ nip [ original>> ] keep f >>on model-changed ] if ]
[ dup on>> [ 2drop ] [ [ value>> ] dip over [ set-model ] [ 2drop ] if ] if ] if ;
: <switch> ( signal1 signal2 -- signal' ) swap [ 2array switch-model <multi-model> ] 2keep
- [ >>original ] [ >>switcher ] bi* ;
+ [ [ value>> >>value ] [ >>original ] bi ] [ >>switcher ] bi* ;
M: switch-model model-activated [ original>> ] keep model-changed ;
: >behavior ( event -- behavior ) t <model> <switch> ;
[ swap add-connection ] 2keep model-changed ;
: <action> ( model quot -- action-signal ) [ 1array action <multi-model> ] dip >>quot dup f <action-value> >>value value>> ;
<PRIVATE
+
TUPLE: | < multi-model ;
: <|> ( models -- product ) | <multi-model> ;
GENERIC: models-changed ( product -- )
: <&> ( models -- product ) & <multi-model> ;
M: & models-changed dependencies>> [ f swap (>>value) ] each ;
PRIVATE>
-FMAPS: $> <$ fmap FOR & | ;
\ No newline at end of file
+FMAPS: $> <$ fmap FOR & | product ;
\ No newline at end of file
-USING: accessors models macros make generalizations kernel
+USING: accessors models macros generalizations kernel
ui ui.frp.gadgets ui.frp.signals ui.frp.layout ui.gadgets
ui.gadgets.labels ui.gadgets.editors ui.gadgets.buttons
ui.gadgets.packs locals sequences fonts io.styles
: alert* ( str -- ) [ ] swap alert ;
-:: ask-user* ( model string -- model' )
+:: ask-user ( string -- model' )
[ [let | lbl [ string <label> T{ font { name "sans-serif" } { size 14 } } >>font dup , ]
fldm [ <frp-field*> ->% 1 ]
- btn [ "okay" <frp-border-button> model >>model ] |
+ btn [ "okay" <frp-border-button> ] |
btn -> [ fldm swap <updates> ]
[ [ drop lbl close-window ] $> , ] bi
] ] <vbox> { 161 86 } >>pref-dim "" open-window ;
-: ask-user ( string -- model ) f <model> swap ask-user* ;
-
MACRO: ask-buttons ( buttons -- quot ) dup length [
[ swap
[ 22 wrap-lines <label> T{ font { name "sans-serif" } { size 18 } } >>font ,
projects / factor.git / commitdiff