USING: accessors arrays delegate delegate.protocols
io.pathnames kernel locals sequences
-vectors make strings ui.frp.signals ui.frp.gadgets
+vectors make strings models.combinators ui.gadgets.controls
sequences.extras ;
IN: file-trees
go-to-path ;
: <dir-table> ( tree-model -- table )
- <frp-list*> [ node>> 1array ] >>quot
- [ selected-value>> [ file? not ] <filter> swap <switch> ]
+ <list*> [ node>> 1array ] >>quot
+ [ selected-value>> [ file? not ] filter-model swap switch-models ]
[ swap >>model ] bi ;
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
--- /dev/null
+USING: help.markup help.syntax models models.arrow sequences monads ;
+IN: models.combinators
+
+HELP: merge
+{ $values { "models" "a list of models" } { "model" basic-model } }
+{ $description "Creates a model that merges the updates of others" } ;
+
+HELP: filter-model
+{ $values { "model" model } { "quot" "quotation with stack effect ( a b -- c )" } { "filter-model" filter-model } }
+{ $description "Creates a model that uses the updates of another model only when they satisfy a given predicate" } ;
+
+HELP: fold
+{ $values { "oldval" "starting value" } { "quot" "applied to update and previous values" } { "model" model } { "model" model } }
+{ $description "Similar to " { $link reduce } " but works on models, applying a quotation to the previous and new values at each update" } ;
+
+HELP: switch-models
+{ $values { "model1" model } { "model2" model } { "model'" model } }
+{ $description "Creates a model that starts with the behavior of model2 and switches to the behavior of model1 on its update" } ;
+
+HELP: <mapped>
+{ $values { "model" model } { "quot" "applied to model's value on updates" } { "model" model } }
+{ $description "An expanded version of " { $link <arrow> } ". Use " { $link fmap } " instead." } ;
+
+HELP: when-model
+{ $values { "model" model } { "quot" "called on the model if the quot yields true" } { "cond" "a quotation called on the model's value, yielding a boolean value" } }
+{ $description "Calls quot when model updates if its value meets the condition set in cond" } ;
+
+HELP: with-self
+{ $values { "quot" "quotation that recieves its own return value" } { "model" model } }
+{ $description "Fixed points for models: the quot reacts to the same model to gives" } ;
+
+HELP: #1
+{ $values { "model" model } { "model'" model } }
+{ $description "Moves a model to the top of its dependencies' connections, thus being notified before the others" } ;
+
+ARTICLE: "models.combinators" "Extending models"
+"The " { $vocab-link "models.combinators" } " library expands models to have discrete start and end times. "
+"Also, it provides methods of manipulating and combining models, expecially useful when programming user interfaces: "
+"The output models of some gadgets (see " { $vocab-link "ui.gadgets.controls" } " ) can be manipulated and used as the input models of others. " ;
+
+ABOUT: "models.combinators"
\ No newline at end of file
--- /dev/null
+USING: accessors arrays kernel models models.product monads
+sequences sequences.extras ;
+FROM: syntax => >> ;
+IN: models.combinators
+
+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: models.combinators
+
+TUPLE: basic-model < multi-model ;
+M: basic-model (model-changed) [ value>> ] dip set-model ;
+: merge ( models -- model ) basic-model <multi-model> ;
+: 2merge ( model1 model2 -- model ) 2array merge ;
+: <basic> ( value -- model ) basic-model new-model ;
+
+TUPLE: filter-model < multi-model quot ;
+M: filter-model (model-changed) [ value>> ] dip 2dup quot>> call( a -- ? )
+ [ set-model ] [ 2drop ] if ;
+: filter-model ( model quot -- filter-model ) [ 1array \ filter-model <multi-model> ] dip >>quot ;
+
+TUPLE: fold-model < multi-model quot base values ;
+M: fold-model (model-changed) 2dup base>> =
+ [ [ [ value>> ] [ [ values>> ] [ quot>> ] bi ] bi* swapd reduce* ] keep set-model ]
+ [ [ [ value>> ] [ values>> ] bi* push ]
+ [ [ [ value>> ] [ [ value>> ] [ quot>> ] bi ] bi* call( val oldval -- newval ) ] keep set-model ] 2bi
+ ] if ;
+M: fold-model model-activated drop ;
+: new-fold-model ( deps -- model ) fold-model <multi-model> V{ } clone >>values ;
+: fold ( model oldval quot -- model ) rot 1array new-fold-model swap >>quot
+ swap >>value ;
+: fold* ( model oldmodel quot -- model ) over [ [ 2array new-fold-model ] dip >>quot ]
+ dip [ >>base ] [ value>> >>value ] bi ;
+
+TUPLE: updater-model < multi-model values updates ;
+M: updater-model (model-changed) [ tuck updates>> =
+ [ [ values>> value>> ] keep set-model ]
+ [ drop ] if ] keep f swap (>>value) ;
+: updates ( values updates -- model ) [ 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 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-models ( model1 model2 -- model' ) swap [ 2array switch-model <multi-model> ] 2keep
+ [ [ value>> >>value ] [ >>original ] bi ] [ >>switcher ] bi* ;
+M: switch-model model-activated [ original>> ] keep model-changed ;
+: >behavior ( event -- behavior ) t >>value ;
+
+TUPLE: mapped-model < multi-model model quot ;
+: new-mapped-model ( model quot class -- mapped-model ) [ over 1array ] dip
+ <multi-model> swap >>quot swap >>model ;
+: <mapped> ( model quot -- model ) mapped-model new-mapped-model ;
+M: mapped-model (model-changed)
+ [ [ value>> ] [ quot>> ] bi* call( old -- new ) ] [ nip ] 2bi
+ set-model ;
+
+TUPLE: side-effect-model < mapped-model ;
+M: side-effect-model (model-changed) [ value>> ] dip [ quot>> call( old -- ) ] 2keep set-model ;
+
+TUPLE: quot-model < mapped-model ;
+M: quot-model (model-changed) nip [ quot>> call( -- b ) ] keep set-model ;
+
+TUPLE: action-value < basic-model parent ;
+: <action-value> ( parent value -- model ) action-value new-model swap >>parent ;
+M: action-value model-activated dup parent>> dup activate-model model-changed ; ! a fake dependency of sorts
+
+TUPLE: action < multi-model quot ;
+M: action (model-changed) [ [ value>> ] [ quot>> ] bi* call( a -- b ) ] keep value>>
+ [ swap add-connection ] 2keep model-changed ;
+: <action> ( model quot -- action-model ) [ 1array action <multi-model> ] dip >>quot dup f <action-value> >>value value>> ;
+
+TUPLE: collection < multi-model ;
+: <collection> ( models -- product ) collection <multi-model> ;
+M: collection (model-changed)
+ nip
+ dup dependencies>> [ value>> ] all?
+ [ dup [ value>> ] product-value swap set-model ]
+ [ drop ] if ;
+M: collection model-activated dup (model-changed) ;
+
+! for side effects
+TUPLE: (when-model) < multi-model quot cond ;
+: when-model ( model quot cond -- model ) rot 1array (when-model) <multi-model> swap >>cond swap >>quot ;
+M: (when-model) (model-changed) [ quot>> ] 2keep
+ [ value>> ] [ cond>> ] bi* call( a -- ? ) [ call( model -- ) ] [ 2drop ] if ;
+
+! only used in construction
+: with-self ( quot: ( model -- model ) -- model ) [ f <basic> dup ] dip call swap [ add-dependency ] keep ; inline
+
+USE: models.combinators.templates
+<< { "$>" "<$" "fmap" } [ fmaps ] each >>
\ No newline at end of file
--- /dev/null
+Model combination and manipulation
\ No newline at end of file
--- /dev/null
+USING: kernel sequences functors fry macros generalizations ;
+IN: models.combinators.templates
+FROM: models.combinators => <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
\ No newline at end of file
: register-loads-thread ( -- )
[ [ receive vocab ] keep reply-synchronous t ] "load-words" spawn-server "loads-thread" swap register-process ;
-: add-vocabs-hook ( -- )
- [ 9012 start-node
- register-gets-thread
- register-does-thread
- register-loads-thread
- ] "start-serving-vocabs" add-init-hook ;
PRIVATE>
-SYNTAX: service add-vocabs-hook
- current-vocab name>> serving-vocabs get-global adjoin ;
+SYNTAX: service current-vocab name>> serving-vocabs get-global adjoin ;
+
+[ 9012 start-node
+ register-gets-thread
+ register-does-thread
+ register-loads-thread
+] "start-serving-vocabs" add-init-hook
\ No newline at end of file
USING: accessors arrays colors.constants combinators db.queries
-db.info db.tuples db.types kernel locals math
-monads persistency sequences sequences.extras ui ui.frp.gadgets
-ui.frp.layout ui.frp.signals ui.gadgets.labels
-ui.gadgets.scrollers ui.pens.solid ;
+db.sqlite db.tuples db.types kernel locals math
+monads persistency sequences sequences.extras ui ui.gadgets.controls
+ui.gadgets.layout models.combinators ui.gadgets.labels
+ui.gadgets.scrollers ui.pens.solid io.files.temp ;
FROM: sets => prune ;
IN: recipes
STORED-TUPLE: recipe { title { VARCHAR 100 } } { votes INTEGER } { txt TEXT } { genre { VARCHAR 100 } } ;
: <recipe> ( title genre text -- recipe ) recipe new swap >>txt swap >>genre swap >>title 0 >>votes ;
-get-psql-info recipe define-db
+"recipes.db" temp-file <sqlite-db> recipe define-db
: top-recipes ( offset search -- recipes ) <query> T{ recipe } rot >>title >>tuple
"votes" >>order 30 >>limit swap >>offset get-tuples ;
: top-genres ( -- genres ) f f top-recipes [ genre>> ] map prune 4 (head-slice) ;
$ BODY $
$ BUTTON $
] <vbox> ,
- ] <frp-book*> { 350 245 } >>pref-dim ;
+ ] <book*> { 350 245 } >>pref-dim ;
:: recipe-browser ( -- ) [ [
interface
- <frp-table*> :> tbl
- "okay" <frp-border-button> BUTTON -> :> ok
- IMG-FRP-BTN: submit [ store-tuple ] >>value TOOLBAR -> :> submit
- IMG-FRP-BTN: love 1 >>value TOOLBAR ->
- IMG-FRP-BTN: hate -1 >>value -> 2array <merge> :> votes
- IMG-FRP-BTN: back -> [ -30 ] <$
- IMG-FRP-BTN: more -> [ 30 ] <$ 2array <merge> :> viewed
- <spacer> <frp-field*> ->% 1 :> search
- submit ok [ [ drop ] ] <$ 2array <merge> [ drop ] >>value :> quot
- viewed 0 [ + ] <fold> search ok t <basic> "all" <frp-button> ALL ->
+ <table*> :> tbl
+ "okay" <model-border-btn> BUTTON -> :> ok
+ IMG-MODEL-BTN: submit [ store-tuple ] >>value TOOLBAR -> :> submit
+ IMG-MODEL-BTN: love 1 >>value TOOLBAR ->
+ IMG-MODEL-BTN: hate -1 >>value -> 2array merge :> votes
+ IMG-MODEL-BTN: back -> [ -30 ] <$
+ IMG-MODEL-BTN: more -> [ 30 ] <$ 2array merge :> viewed
+ <spacer> <model-field*> ->% 1 :> search
+ submit ok [ [ drop ] ] <$ 2array merge [ drop ] >>value :> quot
+ viewed 0 [ + ] fold search ok t <basic> "all" <model-btn> 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 [ <frp-button> GENRES -> ] map <merge> ] bind*
+ 4array merge
+ [ drop [ f ] [ "%" dup surround <pattern> ] if-empty top-recipes ] 3fmap :> ups
+ ups [ top-genres [ <model-btn> GENRES -> ] map merge ] bind*
[ text>> T{ recipe } swap >>genre get-tuples ] fmap
- tbl swap updates 2array <merge> >>model
+ tbl swap ups 2merge >>model
[ [ title>> ] [ genre>> ] bi 2array ] >>quot
{ "Title" "Genre" } >>column-titles dup <scroller> RECIPES ,% 1 actions>>
- submit [ "" dup dup <recipe> ] <$ 2array <merge>
- { [ [ title>> ] fmap <frp-field> TITLE ->% .5 ]
- [ [ genre>> ] fmap <frp-field> GENRE ->% .5 ]
- [ [ txt>> ] fmap <frp-editor> BODY ->% 1 ]
+ submit [ "" dup dup <recipe> ] <$ 2array merge
+ { [ [ title>> ] fmap <model-field> TITLE ->% .5 ]
+ [ [ genre>> ] fmap <model-field> GENRE ->% .5 ]
+ [ [ txt>> ] fmap <model-editor> BODY ->% 1 ]
} cleave
[ <recipe> ] 3fmap
[ [ 1 ] <$ ]
- [ quot ok <updates> #1 [ call( recipe -- ) 0 ] 2fmap ] bi
- 2array <merge> 0 <basic> <switch> >>model
+ [ quot ok updates #1 [ call( recipe -- ) 0 ] 2fmap ] bi
+ 2merge 0 <basic> switch-models >>model
] with-interface "recipes" open-window ] with-ui ;
MAIN: recipe-browser
\ No newline at end of file
USING: accessors arrays combinators.short-circuit grouping kernel lists
lists.lazy locals math math.functions math.parser math.ranges
-models.product monads random sequences sets ui ui.frp.gadgets
-ui.frp.layout ui.frp.signals ui.gadgets.alerts vectors fry
-ui.gadgets.labels memoize ;
+models.product monads random sequences sets ui ui.gadgets.controls
+ui.gadgets.layout models.combinators ui.gadgets.alerts vectors fry
+ui.gadgets.labels ;
IN: sudokus
: row ( index -- row ) 1 + 9 / ceiling ;
: near ( a pos -- ? ) { [ [ row ] bi@ = ] [ [ col ] bi@ = ] [ [ sq ] bi@ = ] } 2|| ;
: nth-or-lower ( n seq -- elt ) [ length 1 - 2dup > [ nip ] [ drop ] if ] keep nth ;
-MEMO:: solutions ( puzzle random? -- solutions )
+:: solutions ( puzzle random? -- solutions )
f puzzle random? [ indices [ f ] [ random? swap nth-or-lower ] if-empty ] [ index ] if
[ :> pos
1 9 [a,b] 80 iota [ pos near ] filter [ puzzle nth ] map prune diff
[ 1array puzzle pos cut-slice rest surround ] map >list [ random? solutions ] bind
] [ puzzle list-monad return ] if* ;
-: solution ( puzzle random? -- solution ) dupd solutions dup +nil+ = [ drop "Unsolvable" alert* ] [ nip car ] if \ solutions reset-memoized ;
+: solution ( puzzle random? -- solution ) dupd solutions dup +nil+ = [ drop "Unsolvable" alert* ] [ nip car ] if ;
: hint ( puzzle -- puzzle' ) [ [ f swap indices random dup ] [ f solution ] bi nth ] keep swapd >vector [ set-nth ] keep ;
: create ( difficulty -- puzzle ) 81 [ f ] replicate
40 random solution [ [ dup length random f spin set-nth ] curry times ] keep ;
: do-sudoku ( -- ) [ [
[
- 81 [ "" ] replicate <basic> <switch> [ [ <basic> ] map 9 group [ 3 group ] map 3 group
- [ [ [ <spacer> [ [ <frp-field> ->% 2 [ string>number ] fmap ]
+ 81 [ "" ] replicate <basic> switch-models [ [ <basic> ] map 9 group [ 3 group ] map 3 group
+ [ [ [ <spacer> [ [ <model-field> ->% 2 [ string>number ] fmap ]
map <spacer> ] map concat ] <hbox> , ] map concat <spacer> ] map concat <product>
- [ "Difficulty:" <label> , "1" <basic> <frp-field> -> [ string>number 1 or 1 + 10 * ] fmap
- "Generate" <frp-border-button> -> <updates> [ create ] fmap <spacer>
- "Hint" <frp-border-button> -> "Solve" <frp-border-button> -> ] <hbox> ,
- roll [ swap <updates> ] curry bi@
- [ [ hint ] fmap ] [ [ f solution ] fmap ] bi* 3array <merge> [ [ [ number>string ] [ "" ] if* ] map ] fmap
+ [ "Difficulty:" <label> , "1" <basic> <model-field> -> [ string>number 1 or 1 + 10 * ] fmap
+ "Generate" <model-border-btn> -> updates [ create ] fmap <spacer>
+ "Hint" <model-border-btn> -> "Solve" <model-border-btn> -> ] <hbox> ,
+ roll [ swap updates ] curry bi@
+ [ [ hint ] fmap ] [ [ f solution ] fmap ] bi* 3array merge [ [ [ number>string ] [ "" ] if* ] map ] fmap
] bind
] with-self , ] <vbox> { 280 220 } >>pref-dim
"Sudoku Sleuth" open-window ] with-ui ;
+++ /dev/null
-Sam Anklesaria
+++ /dev/null
-USING: accessors help.markup help.syntax ui.gadgets.buttons
-ui.gadgets.editors ui.frp.gadgets models ui.gadgets ;
-IN: ui.frp.gadgets
-
-HELP: <frp-button>
-{ $values { "gadget" "the button's label" } { "button" button } }
-{ $description "Creates an button whose signal updates on clicks. " } ;
-
-HELP: <frp-border-button>
-{ $values { "text" "the button's label" } { "button" button } }
-{ $description "Creates an button whose signal updates on clicks. " } ;
-
-HELP: <frp-table>
-{ $values { "model" "values the table is to display" } { "table" frp-table } }
-{ $description "Creates an " { $link frp-table } } ;
-
-HELP: <frp-table*>
-{ $values { "table" frp-table } }
-{ $description "Creates an " { $link frp-table } " with no initial values to display" } ;
-
-HELP: <frp-list>
-{ $values { "column-model" "values the table is to display" } { "table" frp-table } }
-{ $description "Creates an " { $link frp-table } " with a val-quot that renders each element as its own row" } ;
-
-HELP: <frp-list*>
-{ $values { "table" frp-table } }
-{ $description "Creates an frp-list with no initial values to display" } ;
-
-HELP: indexed
-{ $values { "table" frp-table } }
-{ $description "Sets the output model of an frp-table to the selected-index, rather than the selected-value" } ;
-
-HELP: <frp-field>
-{ $values { "model" model } { "gadget" model-field } }
-{ $description "Creates a field with an initial value" } ;
-
-HELP: <frp-field*>
-{ $values { "field" model-field } }
-{ $description "Creates a field with an empty initial value" } ;
-
-HELP: <empty-field>
-{ $values { "model" model } { "field" model-field } }
-{ $description "Creates a field with an empty initial value that switches to another signal on its update" } ;
-
-HELP: <frp-editor>
-{ $values { "model" model } { "gadget" model-field } }
-{ $description "Creates an editor with an initial value" } ;
-
-HELP: <frp-editor*>
-{ $values { "editor" "an editor" } }
-{ $description "Creates a editor with an empty initial value" } ;
-
-HELP: <empty-editor>
-{ $values { "model" model } { "editor" "an editor" } }
-{ $description "Creates a field with an empty initial value that switches to another signal on its update" } ;
-
-HELP: <frp-action-field>
-{ $values { "field" action-field } }
-{ $description "Field that updates its model with its contents when the user hits the return key" } ;
-
-HELP: IMG-FRP-BTN:
-{ $syntax "IMAGE-BUTTON: filename" }
-{ $description "Creates a button using a tiff image named as specified found in the icons subdirectory of the vocabulary path" } ;
-
-HELP: IMG-BTN:
-{ $syntax "[ do-something ] IMAGE-BUTTON: filename" }
-{ $description "Creates a button using a tiff image named as specified found in the icons subdirectory of the vocabulary path, calling the specified quotation on click" } ;
-
-HELP: output-model
-{ $values { "gadget" gadget } { "model" model } }
-{ $description "Returns the model a gadget uses for output. Often the same as " { $link model>> } } ;
\ No newline at end of file
+++ /dev/null
-USING: accessors assocs arrays kernel models monads sequences
-ui.frp.signals ui.gadgets ui.gadgets.borders ui.gadgets.buttons
-ui.gadgets.buttons.private ui.gadgets.editors words images.loader
-ui.gadgets.scrollers ui.gadgets.tables ui.images vocabs.parser lexer
-models.range ui.gadgets.sliders ;
-IN: ui.frp.gadgets
-
-TUPLE: frp-button < button hook value ;
-: <frp-button> ( gadget -- button ) [
- [ dup hook>> [ call( button -- ) ] [ drop ] if* ]
- [ [ [ value>> ] [ ] bi or ] keep set-control-value ]
- [ model>> f swap (>>value) ] tri
- ] 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 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* ;
-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* ;
-
-: new-frp-table ( model class -- table ) f swap new-table dup >>renderer
- V{ } clone <basic> >>selected-values V{ } clone <basic> >>selected-indices*
- f <basic> >>actions dup [ actions>> set-model ] curry >>action ;
-: <frp-table> ( model -- table ) frp-table new-frp-table ;
-: <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 ;
-: 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 ]
- [ dup frp-model>> add-connection ] tri ;
-M: frp-field ungraft*
- [ dup editor>> model>> remove-connection ]
- [ dup frp-model>> remove-connection ] bi ;
-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 ) "" <model> <frp-field> ;
-: <empty-field> ( model -- field ) "" <model> <switch> <frp-field> ;
-: <frp-editor> ( model -- gadget )
- frp-field [ <multiline-editor> ] dip new-border dup gadget-child >>editor
- field-theme swap init-field >>frp-model { 1 0 } >>align ;
-: <frp-editor*> ( -- editor ) "" <model> <frp-editor> ;
-: <empty-editor> ( model -- editor ) "" <model> <switch> <frp-editor> ;
-
-: <frp-action-field> ( -- field ) f <action-field> dup [ set-control-value ] curry >>quot
- f <model> >>model ;
-
-: <frp-slider> ( init page min max step -- slider ) <range> horizontal <slider> ;
-
-: image-prep ( -- image ) scan current-vocab name>> "vocab:" "/icons/" surround ".tiff" surround <image-name> dup cached-image drop ;
-SYNTAX: IMG-FRP-BTN: image-prep [ <frp-button> ] curry over push-all ;
-
-SYNTAX: IMG-BTN: image-prep [ swap <button> ] curry over push-all ;
-
-GENERIC: output-model ( gadget -- model )
-M: gadget output-model model>> ;
-M: table output-model dup multiple-selection?>>
- [ dup val-quot>> [ selected-values>> ] [ selected-indices*>> ] if ]
- [ dup val-quot>> [ selected-value>> ] [ selected-index*>> ] if ] if ;
-M: frp-field output-model frp-model>> ;
-M: scroller output-model viewport>> children>> first output-model ;
-M: slider output-model model>> range-model ;
-
-IN: accessors
-M: frp-button text>> children>> first text>> ;
-
-IN: ui.frp.gadgets
-
-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 ;
\ No newline at end of file
+++ /dev/null
-Gadgets using signals as their models
\ No newline at end of file
+++ /dev/null
-Sam Anklesaria
+++ /dev/null
-USING: help.markup help.syntax models ui.gadgets.tracks ui.frp.layout ;
-IN: ui.frp.layout
-
-HELP: ,
-{ $values { "item" "a gadget or model" } }
-{ $description "Used in a series of gadgets created by a box, accumulating the gadget" } ;
-
-HELP: ,%
-{ $syntax "gadget ,% width" }
-{ $description "Like ',' but stretches the gadget to always fill a percent of the parent" } ;
-
-HELP: ->
-{ $values { "uiitem" "a gadget or model" } { "model" model } }
-{ $description "Like ',' but passes its model on for further use." } ;
-
-HELP: ->%
-{ $syntax "gadget ,% width" }
-{ $description "Like '->' but stretches the gadget to always fill a percent of the parent" } ;
-
-HELP: <spacer>
-{ $description "Grows to fill any empty space in a box" } ;
-
-HELP: <hbox>
-{ $values { "gadgets" "a list of gadgets" } { "track" track } }
-{ $syntax "[ gadget , gadget , ... ] <hbox>" }
-{ $description "Creates an horizontal track containing the gadgets listed in the quotation" } ;
-
-HELP: <vbox>
-{ $values { "gadgets" "a list of gadgets" } { "track" track } }
-{ $syntax "[ gadget , gadget , ... ] <hbox>" }
-{ $description "Creates an vertical track containing the gadgets listed in the quotation" } ;
-
-HELP: $
-{ $syntax "$ PLACEHOLDER-NAME $" }
-{ $description "Defines an insertion point in a template named PLACEHOLDER-NAME which can be used by calling its name" } ;
-
-HELP: with-interface
-{ $values { "quot" "quotation that builds a template and inserts into it" } }
-{ $description "Create templates, used with " { $link POSTPONE: $ } } ;
-
-ARTICLE: "ui.frp.layout" "GUI Layout"
-"Laying out GUIs works the same way as building lists with " { $vocab-link "make" }
-". Gadgets are layed out using " { $vocab-link "ui.gadgets.tracks" } " through " { $link <hbox> } " and " { $link <vbox> } ", which allow both fixed and percentage widths. "
-{ $link , } " and " { $link -> } " add a signal or gadget to the gadget you're building. "
-"Also, books can be made with " { $link <frp-book> } ". "
-{ $link <spacer> } "s add flexable space between items. " $nl
-"Using " { $link with-interface } ", one can pre-build templates to add items to later: "
-"Like in the StringTemplate framework for java, placeholders are defined using $ PLACERHOLDER-NAME $ "
-"Using PLACEHOLDER-NAME again sets it as the current insertion point. "
-"For examples using normal layout, see the " { $vocab-link "sudokus" } " demo. "
-"For examples of templating, see " { $vocab-link "recipes" } " demo. " ;
-
-ABOUT: "ui.frp.layout"
\ No newline at end of file
+++ /dev/null
-USING: accessors assocs arrays fry kernel lexer make math.parser
-models monads namespaces parser sequences
-sequences.extras ui.frp.gadgets ui.frp.signals ui.gadgets
-ui.gadgets.books ui.gadgets.tracks words ;
-QUALIFIED: make
-IN: ui.frp.layout
-
-SYMBOL: templates
-TUPLE: layout gadget size ; C: <layout> layout
-TUPLE: placeholder < gadget members ;
-: <placeholder> ( -- placeholder ) placeholder new V{ } clone >>members ;
-
-: (remove-members) ( placeholder members -- ) [ [ model? ] filter swap parent>> model>> [ remove-connection ] curry each ]
- [ nip [ gadget? ] filter [ unparent ] 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 ;
-
-: , ( item -- ) make:, ;
-: make* ( quot -- list ) { } make ; inline
-
-! Just take the previous mentioned placeholder and use it
-! If there is no previously mentioned placeholder, we're probably making a box, and will create the placeholder ourselves
-DEFER: with-interface
-: insertion-quot ( quot -- quot' ) make:building get [ [ placeholder? ] find-last nip [ <placeholder> dup , ] unless*
- templates get spin '[ [ _ templates set _ , @ ] with-interface ] ] when* ;
-
-SYNTAX: ,% scan string>number [ <layout> , ] curry over push-all ;
-SYNTAX: ->% scan string>number '[ [ _ <layout> , ] [ output-model ] bi ] over push-all ;
-
-GENERIC: -> ( uiitem -- model )
-M: gadget -> dup , output-model ;
-M: model -> dup , ;
-
-: <spacer> ( -- ) <gadget> 1 <layout> , ;
-
-: 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 ]
- [ [ dup gadget? [ gadget>> ] unless ] map ] if ;
-: 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 [ add-layout ] each
- swap [ <collection> >>model ] unless-empty ; inline
-: <hbox> ( gadgets -- track ) horizontal <box> ; inline
-: <vbox> ( gadgets -- track ) vertical <box> ; inline
-
-: 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
-
-ERROR: not-in-template word ;
-SYNTAX: $ CREATE-WORD dup
- [ [ dup templates get at [ nip , ] [ not-in-template ] if* ] curry (( -- )) define-declared "$" expect ]
- [ [ <placeholder> [ swap templates get set-at ] keep , ] 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 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" throw ]
- [ 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
- [ add-member ] 2keep (insert-item) ;
-
-: insert-items ( makelist -- ) t swap [ dup placeholder? [ nip ] [ over insert-item ] if ] each drop ;
-
-: with-interface ( quot -- ) [ make* ] curry H{ } clone templates rot with-variable [ insert-items ] with-scope ; inline
-
-M: model >>= [ swap insertion-quot <action> ] curry ;
-M: model fmap insertion-quot <mapped> ;
-M: model $> insertion-quot side-effect-model new-mapped-model ;
-M: model <$ insertion-quot quot-model new-mapped-model ;
\ No newline at end of file
+++ /dev/null
-Syntax for easily building GUIs and using templates
\ No newline at end of file
+++ /dev/null
-Sam Anklesaria
+++ /dev/null
-USING: help.markup help.syntax models models.arrow sequences ui.frp.signals monads ;
-IN: ui.frp.signals
-
-HELP: <merge>
-{ $values { "models" "a list of models" } { "signal" basic-model } }
-{ $description "Creates a signal that merges the updates of others" } ;
-
-HELP: <filter>
-{ $values { "model" model } { "quot" "quotation with stack effect ( a b -- c )" } { "filter-signal" filter-model } }
-{ $description "Creates a signal that uses the updates of another model only when they satisfy a given predicate" } ;
-
-HELP: <fold>
-{ $values { "oldval" "starting value" } { "quot" "applied to update and previous values" } { "model" model } { "signal" model } }
-{ $description "Similar to " { $link reduce } " but works on models, applying a quotation to the previous and new values at each update" } ;
-
-HELP: <switch>
-{ $values { "signal1" model } { "signal2" model } { "signal'" model } }
-{ $description "Creates a signal that starts with the behavior of signal2 and switches to the behavior of signal1 on its update" } ;
-
-HELP: <mapped>
-{ $values { "model" model } { "quot" "applied to model's value on updates" } { "signal" model } }
-{ $description "The signal version of an " { $link <arrow> } } ;
-
-HELP: $>
-{ $values { "model" model } { "quot" "applied to model's value on updates" } { "signal" model } }
-{ $description "Like " { $link <mapped> } ", but doesn't produce a new value" } ;
-
-HELP: <$
-{ $values { "model" model } { "quot" "applied to model's value on updates" } { "signal" model } }
-{ $description "Opposite of " { $link <$ } "- gives output, but takes no input" } ;
-
-HELP: frp-when
-{ $values { "model" model } { "quot" "called on the model if the quot yields true" } { "cond" "a quotation called on the model's value, yielding a boolean value" } }
-{ $description "Calls quot when model updates if its value meets the condition set in cond" } ;
-
-HELP: with-self
-{ $values { "quot" "quotation that recieves its own return value" } { "model" model } }
-{ $description "Fixed points for signals: the quot reacts to the same signal to gives" } ;
-
-HELP: #1
-{ $values { "model" model } { "model'" model } }
-{ $description "Moves a signal to the top of its dependencies' connections, thus being notified before the others" } ;
-
-ARTICLE: "signals" "FRP Signals"
-"Unlike models, which always have a value, signals have discrete start and end times. "
-"They are the core of the frp library: program flow using frp is controlled entirely through manipulating and combining signals. "
-"The output signals of some gadgets (see " { $vocab-link "ui.frp.gadgets" } " ) can be manipulated and used as the input signals of others. " ;
-
-ABOUT: "signals"
\ No newline at end of file
+++ /dev/null
-USING: accessors arrays kernel models models.product monads
-sequences sequences.extras ;
-FROM: syntax => >> ;
-IN: ui.frp.signals
-
-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> ;
-: <2merge> ( model1 model2 -- signal ) 2array <merge> ;
-: <basic> ( value -- signal ) basic-model new-model ;
-
-TUPLE: filter-model < multi-model quot ;
-M: filter-model (model-changed) [ value>> ] dip 2dup quot>> call( a -- ? )
- [ set-model ] [ 2drop ] if ;
-: <filter> ( model quot -- filter-signal ) [ 1array filter-model <multi-model> ] dip >>quot ;
-
-TUPLE: fold-model < multi-model quot base values ;
-M: fold-model (model-changed) 2dup base>> =
- [ [ [ value>> ] [ [ values>> ] [ quot>> ] bi ] bi* swapd reduce* ] keep set-model ]
- [ [ [ value>> ] [ values>> ] bi* push ]
- [ [ [ value>> ] [ [ value>> ] [ quot>> ] bi ] bi* call( val oldval -- newval ) ] keep set-model ] 2bi
- ] if ;
-M: fold-model model-activated drop ;
-: new-fold-model ( deps -- model ) fold-model <multi-model> V{ } clone >>values ;
-: <fold> ( model oldval quot -- signal ) rot 1array new-fold-model swap >>quot
- swap >>value ;
-: <fold*> ( model oldmodel quot -- signal ) over [ [ 2array new-fold-model ] dip >>quot ]
- dip [ >>base ] [ value>> >>value ] bi ;
-
-TUPLE: updater-model < multi-model values updates ;
-M: updater-model (model-changed) [ tuck updates>> =
- [ [ values>> value>> ] keep set-model ]
- [ drop ] if ] keep f swap (>>value) ;
-: <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 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* ;
-M: switch-model model-activated [ original>> ] keep model-changed ;
-: >behavior ( event -- behavior ) t >>value ;
-
-TUPLE: mapped-model < multi-model model quot ;
-: new-mapped-model ( model quot class -- mapped-model ) [ over 1array ] dip
- <multi-model> swap >>quot swap >>model ;
-: <mapped> ( model quot -- signal ) mapped-model new-mapped-model ;
-M: mapped-model (model-changed)
- [ [ value>> ] [ quot>> ] bi* call( old -- new ) ] [ nip ] 2bi
- set-model ;
-
-TUPLE: side-effect-model < mapped-model ;
-M: side-effect-model (model-changed) [ value>> ] dip [ quot>> call( old -- ) ] 2keep set-model ;
-
-TUPLE: quot-model < mapped-model ;
-M: quot-model (model-changed) nip [ quot>> call( -- b ) ] keep set-model ;
-
-TUPLE: action-value < basic-model parent ;
-: <action-value> ( parent value -- model ) action-value new-model swap >>parent ;
-M: action-value model-activated dup parent>> dup activate-model model-changed ; ! a fake dependency of sorts
-
-TUPLE: action < multi-model quot ;
-M: action (model-changed) [ [ value>> ] [ quot>> ] bi* call( a -- b ) ] keep value>>
- [ swap add-connection ] 2keep model-changed ;
-: <action> ( model quot -- action-signal ) [ 1array action <multi-model> ] dip >>quot dup f <action-value> >>value value>> ;
-
-TUPLE: collection < multi-model ;
-: <collection> ( models -- product ) collection <multi-model> ;
-M: collection (model-changed)
- nip
- dup dependencies>> [ value>> ] all?
- [ dup [ value>> ] product-value swap set-model ]
- [ drop ] if ;
-M: collection model-activated dup (model-changed) ;
-
-! 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 ;
-
-! only used in construction
-: with-self ( quot: ( model -- model ) -- model ) [ f <basic> dup ] dip call swap [ add-dependency ] keep ; inline
-
-USE: ui.frp.signals.templates
-<< { "$>" "<$" "fmap" } [ fmaps ] each >>
\ No newline at end of file
+++ /dev/null
-Utilities for functional reactive programming in user interfaces
+++ /dev/null
-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
\ No newline at end of file
USING: accessors models monads macros generalizations kernel
-ui ui.frp.gadgets ui.frp.signals ui.frp.layout ui.gadgets
+ui ui.gadgets.controls models.combinators ui.gadgets.layout ui.gadgets
ui.gadgets.labels ui.gadgets.editors ui.gadgets.buttons
ui.gadgets.packs locals sequences fonts io.styles
wrap.strings ;
:: 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> ] |
- btn -> [ fldm swap <updates> ]
+ fldm [ <model-field*> ->% 1 ]
+ btn [ "okay" <model-border-btn> ] |
+ btn -> [ fldm swap updates ]
[ [ drop lbl close-window ] $> , ] bi
] ] <vbox> { 161 86 } >>pref-dim "" open-window ;
MACRO: ask-buttons ( buttons -- quot ) dup length [
[ swap
[ 22 wrap-lines <label> T{ font { name "sans-serif" } { size 18 } } >>font ,
- [ [ <frp-border-button> [ close-window ] >>hook -> ] map ] <hbox> , ] <vbox>
+ [ [ <model-border-btn> [ close-window ] >>hook -> ] map ] <hbox> , ] <vbox>
"" open-window
] dip firstn
] 2curry ;
\ No newline at end of file
USING: accessors arrays kernel math.rectangles sequences
-ui.frp.gadgets ui.frp.signals ui.gadgets ui.gadgets.glass
-ui.gadgets.labels ui.gadgets.tables ui.gestures ;
+ui.gadgets.controls models.combinators ui.gadgets ui.gadgets.glass
+ui.gadgets.labels ui.gestures ;
+QUALIFIED-WITH: ui.gadgets.tables tbl
IN: ui.gadgets.comboboxes
-TUPLE: combo-table < frp-table spawner ;
+TUPLE: combo-table < table spawner ;
M: combo-table handle-gesture [ call-next-method drop ] 2keep swap
T{ button-up } = [
[ spawner>> ]
- [ selected-row [ swap set-control-value ] [ 2drop ] if ]
+ [ tbl:selected-row [ swap set-control-value ] [ 2drop ] if ]
[ hide-glass ] tri
] [ drop ] if t ;
} set-gestures
: <combobox> ( options -- combobox ) [ first [ combobox new-label ] keep <basic> >>model ] keep
- <basic> combo-table new-frp-table [ 1array ] >>quot >>table ;
\ No newline at end of file
+ <basic> combo-table new-table [ 1array ] >>quot >>table ;
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
--- /dev/null
+USING: accessors help.markup help.syntax ui.gadgets.buttons
+ui.gadgets.editors models ui.gadgets ;
+IN: ui.gadgets.controls
+
+HELP: <model-btn>
+{ $values { "gadget" "the button's label" } { "button" button } }
+{ $description "Creates an button whose signal updates on clicks. " } ;
+
+HELP: <model-border-btn>
+{ $values { "text" "the button's label" } { "button" button } }
+{ $description "Creates an button whose signal updates on clicks. " } ;
+
+HELP: <table>
+{ $values { "model" "values the table is to display" } { "table" table } }
+{ $description "Creates an " { $link table } } ;
+
+HELP: <table*>
+{ $values { "table" table } }
+{ $description "Creates an " { $link table } " with no initial values to display" } ;
+
+HELP: <list>
+{ $values { "column-model" "values the table is to display" } { "table" table } }
+{ $description "Creates an " { $link table } " with a val-quot that renders each element as its own row" } ;
+
+HELP: <list*>
+{ $values { "table" table } }
+{ $description "Creates an model-list with no initial values to display" } ;
+
+HELP: indexed
+{ $values { "table" table } }
+{ $description "Sets the output model of an table to the selected-index, rather than the selected-value" } ;
+
+HELP: <model-field>
+{ $values { "model" model } { "gadget" model-field } }
+{ $description "Creates a field with an initial value" } ;
+
+HELP: <model-field*>
+{ $values { "field" model-field } }
+{ $description "Creates a field with an empty initial value" } ;
+
+HELP: <empty-field>
+{ $values { "model" model } { "field" model-field } }
+{ $description "Creates a field with an empty initial value that switches to another signal on its update" } ;
+
+HELP: <model-editor>
+{ $values { "model" model } { "gadget" model-field } }
+{ $description "Creates an editor with an initial value" } ;
+
+HELP: <model-editor*>
+{ $values { "editor" "an editor" } }
+{ $description "Creates a editor with an empty initial value" } ;
+
+HELP: <empty-editor>
+{ $values { "model" model } { "editor" "an editor" } }
+{ $description "Creates a field with an empty initial value that switches to another signal on its update" } ;
+
+HELP: <model-action-field>
+{ $values { "field" action-field } }
+{ $description "Field that updates its model with its contents when the user hits the return key" } ;
+
+HELP: IMG-MODEL-BTN:
+{ $syntax "IMAGE-MODEL-BTN: filename" }
+{ $description "Creates a button using a tiff image named as specified found in the icons subdirectory of the vocabulary path" } ;
+
+HELP: IMG-BTN:
+{ $syntax "[ do-something ] IMAGE-BTN: filename" }
+{ $description "Creates a button using a tiff image named as specified found in the icons subdirectory of the vocabulary path, calling the specified quotation on click" } ;
+
+HELP: output-model
+{ $values { "gadget" gadget } { "model" model } }
+{ $description "Returns the model a gadget uses for output. Often the same as " { $link model>> } } ;
\ No newline at end of file
--- /dev/null
+USING: accessors assocs arrays kernel models monads sequences
+models.combinators ui.gadgets ui.gadgets.borders ui.gadgets.buttons
+ui.gadgets.buttons.private ui.gadgets.editors words images.loader
+ui.gadgets.scrollers ui.images vocabs.parser lexer
+models.range ui.gadgets.sliders ;
+QUALIFIED-WITH: ui.gadgets.sliders slider
+QUALIFIED-WITH: ui.gadgets.tables tbl
+EXCLUDE: ui.gadgets.editors => model-field ;
+IN: ui.gadgets.controls
+
+TUPLE: model-btn < button hook value ;
+: <model-btn> ( gadget -- button ) [
+ [ dup hook>> [ call( button -- ) ] [ drop ] if* ]
+ [ [ [ value>> ] [ ] bi or ] keep set-control-value ]
+ [ model>> f swap (>>value) ] tri
+ ] model-btn new-button f <basic> >>model ;
+: <model-border-btn> ( text -- button ) <model-btn> border-button-theme ;
+
+TUPLE: table < tbl:table { quot initial: [ ] } { val-quot initial: [ ] } color-quot column-titles column-alignment actions ;
+M: table tbl:column-titles column-titles>> ;
+M: table tbl:column-alignment column-alignment>> ;
+M: table tbl:row-columns quot>> [ call( a -- b ) ] [ drop f ] if* ;
+M: table tbl:row-value val-quot>> [ call( a -- b ) ] [ drop f ] if* ;
+M: table tbl:row-color color-quot>> [ call( a -- b ) ] [ drop f ] if* ;
+
+: new-table ( model class -- table ) f swap tbl:new-table dup >>renderer
+ V{ } clone <basic> >>selected-values V{ } clone <basic> >>selected-indices*
+ f <basic> >>actions dup [ actions>> set-model ] curry >>action ;
+: <table> ( model -- table ) table new-table ;
+: <table*> ( -- table ) V{ } clone <model> <table> ;
+: <list> ( column-model -- table ) <table> [ 1array ] >>quot ;
+: <list*> ( -- table ) V{ } clone <model> <list> ;
+: indexed ( table -- table ) f >>val-quot ;
+
+TUPLE: model-field < field model* ;
+: init-field ( field -- field' ) [ [ ] [ "" ] if* ] change-value ;
+: <model-field> ( model -- gadget ) model-field new-field swap init-field >>model* ;
+M: model-field graft*
+ [ [ model*>> value>> ] [ editor>> ] bi set-editor-string ]
+ [ dup editor>> model>> add-connection ]
+ [ dup model*>> add-connection ] tri ;
+M: model-field ungraft*
+ [ dup editor>> model>> remove-connection ]
+ [ dup model*>> remove-connection ] bi ;
+M: model-field model-changed 2dup model*>> =
+ [ [ value>> ] [ editor>> ] bi* set-editor-string ]
+ [ nip [ editor>> editor-string ] [ model*>> ] bi set-model ] if ;
+
+: <model-field*> ( -- field ) "" <model> <model-field> ;
+: <empty-field> ( model -- field ) "" <model> switch-models <model-field> ;
+: (model-editor) ( model class -- gadget )
+ model-field [ new-editor ] dip new-border dup gadget-child >>editor
+ field-theme swap init-field >>model* { 1 0 } >>align ;
+: <model-editor> ( model -- gadget ) multiline-editor (model-editor) ;
+: <model-editor*> ( -- editor ) "" <model> <model-editor> ;
+: <empty-editor> ( model -- editor ) "" <model> switch-models <model-editor> ;
+
+: <model-action-field> ( -- field ) f <action-field> dup [ set-control-value ] curry >>quot
+ f <model> >>model ;
+
+: <slider> ( init page min max step -- slider ) <range> horizontal slider:<slider> ;
+
+: image-prep ( -- image ) scan current-vocab name>> "vocab:" "/icons/" surround ".tiff" surround <image-name> dup cached-image drop ;
+SYNTAX: IMG-MODEL-BTN: image-prep [ <model-btn> ] curry over push-all ;
+
+SYNTAX: IMG-BTN: image-prep [ swap <button> ] curry over push-all ;
+
+GENERIC: output-model ( gadget -- model )
+M: gadget output-model model>> ;
+M: table output-model dup multiple-selection?>>
+ [ dup val-quot>> [ selected-values>> ] [ selected-indices*>> ] if ]
+ [ dup val-quot>> [ selected-value>> ] [ selected-index*>> ] if ] if ;
+M: model-field output-model model*>> ;
+M: scroller output-model viewport>> children>> first output-model ;
+M: slider output-model model>> range-model ;
+
+IN: accessors
+M: model-btn text>> children>> first text>> ;
+
+IN: ui.gadgets.controls
+
+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 ;
\ No newline at end of file
--- /dev/null
+Gadgets with expanded model usage
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
--- /dev/null
+USING: help.markup help.syntax models ui.gadgets.tracks ;
+IN: ui.gadgets.layout
+
+HELP: ,
+{ $values { "item" "a gadget or model" } }
+{ $description "Used in a series of gadgets created by a box, accumulating the gadget" } ;
+
+HELP: ,%
+{ $syntax "gadget ,% width" }
+{ $description "Like ',' but stretches the gadget to always fill a percent of the parent" } ;
+
+HELP: ->
+{ $values { "uiitem" "a gadget or model" } { "model" model } }
+{ $description "Like ',' but passes its model on for further use." } ;
+
+HELP: ->%
+{ $syntax "gadget ,% width" }
+{ $description "Like '->' but stretches the gadget to always fill a percent of the parent" } ;
+
+HELP: <spacer>
+{ $description "Grows to fill any empty space in a box" } ;
+
+HELP: <hbox>
+{ $values { "gadgets" "a list of gadgets" } { "track" track } }
+{ $syntax "[ gadget , gadget , ... ] <hbox>" }
+{ $description "Creates an horizontal track containing the gadgets listed in the quotation" } ;
+
+HELP: <vbox>
+{ $values { "gadgets" "a list of gadgets" } { "track" track } }
+{ $syntax "[ gadget , gadget , ... ] <hbox>" }
+{ $description "Creates an vertical track containing the gadgets listed in the quotation" } ;
+
+HELP: $
+{ $syntax "$ PLACEHOLDER-NAME $" }
+{ $description "Defines an insertion point in a template named PLACEHOLDER-NAME which can be used by calling its name" } ;
+
+HELP: with-interface
+{ $values { "quot" "quotation that builds a template and inserts into it" } }
+{ $description "Create templates, used with " { $link POSTPONE: $ } } ;
+
+ARTICLE: "ui.gadgets.layout" "GUI Layout"
+"Laying out GUIs works the same way as building lists with " { $vocab-link "make" }
+". Gadgets are layed out using " { $vocab-link "ui.gadgets.tracks" } " through " { $link <hbox> } " and " { $link <vbox> } ", which allow both fixed and percentage widths. "
+{ $link , } " and " { $link -> } " add a model or gadget to the gadget you're building. "
+"Also, books can be made with " { $link <book> } ". "
+{ $link <spacer> } "s add flexable space between items. " $nl
+"Using " { $link with-interface } ", one can pre-build templates to add items to later: "
+"Like in the StringTemplate framework for java, placeholders are defined using $ PLACERHOLDER-NAME $ "
+"Using PLACEHOLDER-NAME again sets it as the current insertion point. "
+"For examples using normal layout, see the " { $vocab-link "sudokus" } " demo. "
+"For examples of templating, see the " { $vocab-link "recipes" } " demo. " ;
+
+ABOUT: "ui.gadgets.layout"
\ No newline at end of file
--- /dev/null
+USING: accessors assocs arrays fry kernel lexer make math.parser
+models monads namespaces parser sequences
+sequences.extras models.combinators ui.gadgets
+ui.gadgets.tracks words ui.gadgets.controls ;
+QUALIFIED: make
+QUALIFIED-WITH: ui.gadgets.books book
+IN: ui.gadgets.layout
+
+SYMBOL: templates
+TUPLE: layout gadget size ; C: <layout> layout
+TUPLE: placeholder < gadget members ;
+: <placeholder> ( -- placeholder ) placeholder new V{ } clone >>members ;
+
+: (remove-members) ( placeholder members -- ) [ [ model? ] filter swap parent>> model>> [ remove-connection ] curry each ]
+ [ nip [ gadget? ] filter [ unparent ] 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 ;
+
+: , ( item -- ) make:, ;
+: make* ( quot -- list ) { } make ; inline
+
+! Just take the previous mentioned placeholder and use it
+! If there is no previously mentioned placeholder, we're probably making a box, and will create the placeholder ourselves
+DEFER: with-interface
+: insertion-quot ( quot -- quot' ) make:building get [ [ placeholder? ] find-last nip [ <placeholder> dup , ] unless*
+ templates get spin '[ [ _ templates set _ , @ ] with-interface ] ] when* ;
+
+SYNTAX: ,% scan string>number [ <layout> , ] curry over push-all ;
+SYNTAX: ->% scan string>number '[ [ _ <layout> , ] [ output-model ] bi ] over push-all ;
+
+GENERIC: -> ( uiitem -- model )
+M: gadget -> dup , output-model ;
+M: model -> dup , ;
+
+: <spacer> ( -- ) <gadget> 1 <layout> , ;
+
+: 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 ]
+ [ [ dup gadget? [ gadget>> ] unless ] map ] if ;
+: 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 [ add-layout ] each
+ swap [ <collection> >>model ] unless-empty ; inline
+: <hbox> ( gadgets -- track ) horizontal <box> ; inline
+: <vbox> ( gadgets -- track ) vertical <box> ; inline
+
+: make-book ( models gadgets model -- book ) book:<book> swap [ "No models in books" throw ] unless-empty ;
+: <book> ( quot: ( -- model ) -- book ) f make-layout rot 0 >>value make-book ; inline
+: <book*> ( quot -- book ) f make-layout f make-book ; inline
+
+ERROR: not-in-template word ;
+SYNTAX: $ CREATE-WORD dup
+ [ [ dup templates get at [ nip , ] [ not-in-template ] if* ] curry (( -- )) define-declared "$" expect ]
+ [ [ <placeholder> [ swap templates get set-at ] keep , ] 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 ( placeholder -- number parent ) dup parent>> [ children>> index ] keep ;
+
+GENERIC# add-gadget-at 1 ( item location -- )
+M: gadget add-gadget-at dup parent>> track? [ [ f <layout> ] dip add-gadget-at ]
+ [ insertion-point rot [ add-gadget ] keep insert-gadget ] if ;
+M: layout add-gadget-at insertion-point rot [ add-layout ] keep [ gadget>> insert-gadget ] [ size>> insert-size ] 3bi ;
+M: model add-gadget-at parent>> dup book:book? [ "No models in books" throw ]
+ [ dup model>> dup collection? [ nip swap add-connection ] [ drop [ 1array <collection> ] dip (>>model) ] if ] if ;
+: track-add-at ( item location size -- ) swap [ <layout> ] dip add-gadget-at ;
+: insert-item ( item location -- ) [ dup get [ drop ] [ remove-members ] if ] [ on ] [ ] tri
+ [ add-member ] 2keep add-gadget-at ;
+
+: insert-items ( makelist -- ) t swap [ dup placeholder? [ nip ] [ over insert-item ] if ] each drop ;
+
+: with-interface ( quot -- ) [ make* ] curry H{ } clone templates rot with-variable [ insert-items ] with-scope ; inline
+
+M: model >>= [ swap insertion-quot <action> ] curry ;
+M: model fmap insertion-quot <mapped> ;
+M: model $> insertion-quot side-effect-model new-mapped-model ;
+M: model <$ insertion-quot quot-model new-mapped-model ;
\ No newline at end of file
--- /dev/null
+Syntax for easily building GUIs and using templates
\ No newline at end of file
projects / factor.git / commitdiff