+++ /dev/null
-Sam Anklesaria
\ No newline at end of file
+++ /dev/null
-USING: accessors models models.arrow inverse kernel ;
-IN: models.illusion
-
-TUPLE: illusion < arrow ;
-
-: <illusion> ( model quot -- illusion )
- illusion new V{ } clone >>connections V{ } clone >>dependencies 0 >>ref
- swap >>quot over >>model [ add-dependency ] keep ;
-
-: <activated-illusion> ( model quot -- illusion ) <illusion> dup activate-model ;
-
-: backtalk ( value object -- )
- [ quot>> [undo] call( a -- b ) ] [ model>> ] bi set-model ;
-
-M: illusion update-model ( model -- ) [ [ value>> ] keep backtalk ] with-locked-model ;
\ No newline at end of file
+++ /dev/null
-Two Way Arrows
\ No newline at end of file
+++ /dev/null
-USING: tools.deploy.config ;
-H{
- { deploy-name "drills" }
- { deploy-c-types? t }
- { "stop-after-last-window?" t }
- { deploy-unicode? t }
- { deploy-threads? t }
- { deploy-reflection 6 }
- { deploy-word-defs? t }
- { deploy-math? t }
- { deploy-ui? t }
- { deploy-word-props? t }
- { deploy-io 3 }
-}
+++ /dev/null
-USING: arrays cocoa.dialogs combinators continuations
-fry grouping io.encodings.utf8 io.files io.styles kernel math
-math.parser models models.arrow models.history namespaces random
-sequences splitting ui ui.gadgets.alerts ui.gadgets.book-extras
-ui.gadgets.books ui.gadgets.buttons ui.gadgets.frames
-ui.gadgets.grids ui.gadgets.labels ui.gadgets.tracks fonts
-wrap.strings system ;
-EXCLUDE: accessors => change-model ;
-IN: drills.deployed
-SYMBOLS: it startLength ;
-: big ( gadget -- gadget ) T{ font { name "sans-serif" } { size 30 } } >>font ;
-: card ( model quot -- button ) <arrow> <label-control> big [ next ] <book-btn> ;
-: op ( quot str -- gadget ) <label> big swap <book-bevel-btn> ;
-
-: show ( model -- gadget ) dup it set-global [ random ] <arrow>
- { [ [ first ] card ]
- [ [ second ] card ]
- [ '[ |<< it get _ model-changed ] "No" op ]
- [ '[ |<< [ it get [
- _ value>> swap remove
- [ [ it get go-back ] "Drill Complete" alert return ] when-empty
- ] change-model ] with-return ] "Yes" op ]
- } cleave
-2array { 1 0 } <track> swap [ 0.5 track-add ] each
-3array <book*> 3 3 <frame> { 1 1 } >>filled-cell { 450 175 } >>pref-dim swap { 1 1 } grid-add
-it get [ length startLength get swap - number>string "/" startLength get number>string 3append ] <arrow> <label-control> { 1 2 } grid-add ;
-
-: drill ( -- ) [
- open-panel [
- [ utf8 file-lines [ "\t" split [ 25 wrap-string ] map ] map dup [ first2 swap 2array ] map append ] map concat
- [ length startLength set-global ] keep <history> [ add-history ] [ show ] bi
- "Got it?" open-window
- ] [ 0 exit ] if*
-] with-ui ;
-
-MAIN: drill
\ No newline at end of file
+++ /dev/null
-unportable
+++ /dev/null
-USING: arrays cocoa.dialogs combinators continuations
-fry grouping io.encodings.utf8 io.files io.styles kernel math
-math.parser models models.arrow models.history namespaces random
-sequences splitting ui ui.gadgets.alerts ui.gadgets.book-extras
-ui.gadgets.books ui.gadgets.buttons ui.gadgets.frames
-ui.gadgets.grids ui.gadgets.labels ui.gadgets.tracks fonts
-wrap.strings ;
-EXCLUDE: accessors => change-model ;
-
-IN: drills
-SYMBOLS: it startLength ;
-: big ( gadget -- gadget ) T{ font { name "sans-serif" } { size 30 } } >>font ;
-: card ( model quot -- button ) <arrow> <label-control> big [ next ] <book-btn> ;
-: op ( quot str -- gadget ) <label> big swap <book-border-btn> ;
-
-: show ( model -- gadget ) dup it set-global [ random ] <arrow>
- { [ [ first ] card ]
- [ [ second ] card ]
- [ '[ |<< it get _ model-changed ] "No" op ]
- [ '[ |<< [ it get [
- _ value>> swap remove
- [ [ it get go-back ] "Drill Complete" alert return ] when-empty
- ] change-model ] with-return ] "Yes" op ]
- } cleave
-2array { 1 0 } <track> swap [ 0.5 track-add ] each
-3array <book*> 3 3 <frame> { 1 1 } >>filled-cell { 450 175 } >>pref-dim swap { 1 1 } grid-add
-it get [ length startLength get swap - number>string "/" startLength get number>string 3append ] <arrow> <label-control> { 1 2 } grid-add ;
-
-: drill ( -- ) [
- open-panel [
- [ utf8 file-lines [ "\t" split [ 25 wrap-string ] map ] map dup [ first2 swap 2array ] map append ] map concat
- [ length startLength set-global ] keep <history> [ add-history ] [ show ] bi
- "Got it?" open-window
- ] when*
-] with-ui ;
-
-MAIN: drill
\ No newline at end of file
+++ /dev/null
-unportable
+++ /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 { "model" model } { "oldval" "starting value" } { "quot" "applied to update and previous values" } { "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"
+++ /dev/null
-USING: accessors arrays kernel models models.product monads
-sequences sequences.extras shuffle ;
-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 >>
+++ /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
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+USING: accessors models models.arrow inverse kernel ;
+IN: models.illusion
+
+TUPLE: illusion < arrow ;
+
+: <illusion> ( model quot -- illusion )
+ illusion new V{ } clone >>connections V{ } clone >>dependencies 0 >>ref
+ swap >>quot over >>model [ add-dependency ] keep ;
+
+: <activated-illusion> ( model quot -- illusion ) <illusion> dup activate-model ;
+
+: backtalk ( value object -- )
+ [ quot>> [undo] call( a -- b ) ] [ model>> ] bi set-model ;
+
+M: illusion update-model ( model -- ) [ [ value>> ] keep backtalk ] with-locked-model ;
\ No newline at end of file
--- /dev/null
+Two Way Arrows
\ No newline at end of file
+++ /dev/null
-Sam Anklesaria
\ No newline at end of file
+++ /dev/null
-USING: accessors arrays colors.constants combinators
-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 ;
-"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 short head-slice ;
-
-: interface ( -- book ) [
- [
- [ $ TOOLBAR $ ] <hbox> COLOR: AliceBlue <solid> >>interior ,
- [ "Genres:" <label> , <spacer> $ ALL $ $ GENRES $ ] <hbox>
- { 5 0 } >>gap COLOR: gray <solid> >>interior ,
- $ RECIPES $
- ] <vbox> ,
- [
- [ "Title:" <label> , $ TITLE $ "Genre:" <label> , $ GENRE $ ] <hbox> ,
- $ BODY $
- $ BUTTON $
- ] <vbox> ,
- ] <book*> { 350 245 } >>pref-dim ;
-
-:: recipe-browser ( -- ) [ [
- interface
- <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 selection>> votes [ [ + ] curry change-votes modify-tuple ] 2$>
- 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 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 <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
- 2merge 0 <basic> switch-models >>model
- ] with-interface "recipes" open-window ] with-ui ;
-
-MAIN: recipe-browser
\ No newline at end of file
+++ /dev/null
-Database backed recipe sharing
\ No newline at end of file
+++ /dev/null
-Sam Anklesaria
\ No newline at end of file
+++ /dev/null
-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.gadgets.controls
-ui.gadgets.layout models.combinators ui.gadgets.alerts vectors fry
-ui.gadgets.labels shuffle ;
-IN: sudokus
-
-: row ( index -- row ) 1 + 9 / ceiling ;
-: col ( index -- col ) 9 mod 1 + ;
-: sq ( index -- square ) [ row ] [ col ] bi [ 3 / ceiling ] bi@ 2array ;
-: near ( a pos -- ? ) { [ [ row ] bi@ = ] [ [ col ] bi@ = ] [ [ sq ] bi@ = ] } 2|| ;
-: nth-or-lower ( n seq -- elt ) [ length 1 - 2dup > [ nip ] [ drop ] if ] keep nth ;
-
-:: 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 ;
-: 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 [ [ f swap [ length random ] keep set-nth ] curry times ] keep ;
-
-: do-sudoku ( -- ) [ [
- [
- 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> <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 ;
-
-MAIN: do-sudoku
+++ /dev/null
-graphical sudoku solver
\ No newline at end of file
+++ /dev/null
-USING: accessors models monads macros generalizations kernel
-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 ;
-
-IN: ui.gadgets.alerts
-:: alert ( quot string -- ) <pile> { 10 10 } >>gap 1 >>align
- string 22 wrap-lines <label> T{ font { name "sans-serif" } { size 18 } } >>font { 200 100 } >>pref-dim add-gadget
- "okay" [ close-window ] quot append <border-button> add-gadget "" open-window ;
-
-: alert* ( str -- ) [ ] swap alert ;
-
-:: ask-user ( string -- model' )
- [
- string <label> T{ font { name "sans-serif" } { size 14 } } >>font dup , :> lbl
- <model-field*> ->% 1 :> fldm
- "okay" <model-border-btn> :> 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 ,
- [ [ <model-border-btn> [ close-window ] >>hook -> ] map ] <hbox> , ] <vbox>
- "" open-window
- ] dip firstn
- ] 2curry ;
+++ /dev/null
-Sam Anklesaria
\ No newline at end of file
+++ /dev/null
-Really simple dialog boxes
\ No newline at end of file
+++ /dev/null
-Sam Anklesaria
\ No newline at end of file
+++ /dev/null
-USING: accessors arrays kernel math.rectangles sequences
-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 < table spawner ;
-
-M: combo-table handle-gesture [ call-next-method drop ] 2keep swap
- T{ button-up } = [
- [ spawner>> ]
- [ tbl:selected-row [ swap set-control-value ] [ 2drop ] if ]
- [ hide-glass ] tri
- ] [ drop ] if t ;
-
-TUPLE: combobox < label-control table ;
-combobox H{
- { T{ button-down } [ dup table>> over >>spawner <zero-rect> show-glass ] }
-} set-gestures
-
-: <combobox> ( options -- combobox ) [ first [ combobox new-label ] keep <basic> >>model ] keep
- <basic> combo-table new-table [ 1array ] >>quot >>table ;
\ No newline at end of file
+++ /dev/null
-Combo boxes have a model choosen from a list of options
\ 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 ui.gadgets.editors.private
-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
- 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 ( model -- model' ) [ [ ] [ "" ] 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 ;
-
-: (new-field) ( editor field -- gadget ) [ new-editor ] dip new-border dup gadget-child >>editor
- field-theme { 1 0 } >>align ; inline
-: <model-field*> ( -- field ) "" <model> <model-field> ;
-: <empty-field> ( model -- field ) "" <model> switch-models <model-field> ;
-: <model-editor> ( model -- gadget ) multiline-editor model-field (new-field) swap init-field >>model* ;
-: <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 append! ;
-
-SYNTAX: IMG-BTN: image-prep [ swap <button> ] curry append! ;
-
-GENERIC: output-model ( gadget -- model )
-M: gadget output-model model>> ;
-M: table output-model dup val-quot>> [ selection>> ] [ selection-index>> ] 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 ;
+++ /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 delete-all ] 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 ] 2dip swap '[ [ _ templates set _ , @ ] with-interface ] ] when* ;
-
-SYNTAX: ,% scan string>number [ <layout> , ] curry append! ;
-SYNTAX: ->% scan string>number '[ [ _ <layout> , ] [ output-model ] bi ] append! ;
-
-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 ;
-: 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 append! ;
-
-: 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: >layout ( gadget -- layout )
-M: gadget >layout f <layout> ;
-M: layout >layout ;
-
-GENERIC# (add-gadget-at) 2 ( parent item n -- )
-M: gadget (add-gadget-at) -rot [ add-gadget ] keep insert-gadget ;
-M: track (add-gadget-at) -rot >layout [ add-layout ] keep [ gadget>> insert-gadget ] [ size>> insert-size ] 3bi ;
-
-GENERIC# add-gadget-at 1 ( item location -- )
-M: object add-gadget-at insertion-point -rot (add-gadget-at) ;
-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 ;
-: (track-add-at) ( parent item n 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 ;
+++ /dev/null
-Syntax for easily building GUIs and using templates
\ No newline at end of file
+++ /dev/null
-Sam Anklesaria
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Sam Anklesaria
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays accessors combinators kernel math
-models models.combinators namespaces sequences
-ui.gadgets ui.gadgets.controls ui.gadgets.layout
-ui.gadgets.tracks ui.gestures ui.gadgets.line-support ;
-EXCLUDE: ui.gadgets.editors => model-field ;
-IN: ui.gadgets.poppers
-
-TUPLE: popped < model-field { fatal? initial: t } ;
-TUPLE: popped-editor < multiline-editor ;
-: <popped> ( text -- gadget ) <basic> init-field popped-editor popped (new-field) swap >>model* ;
-
-: set-expansion ( popped size -- ) over dup parent>> [ children>> index ] [ sizes>> ] bi set-nth relayout ;
-: new-popped ( popped -- ) insertion-point "" <popped>
- [ rot 1 + f (track-add-at) ] keep [ relayout ] [ request-focus ] bi ;
-: focus-prev ( popped -- ) dup parent>> children>> length 1 =
- [ drop ] [
- insertion-point [ 1 - dup -1 = [ drop 1 ] when ] [ children>> ] bi* nth
- [ request-focus ] [ editor>> end-of-document ] bi
- ] if ;
-: initial-popped ( popper -- ) "" <popped> [ f track-add drop ] keep request-focus ;
-
-TUPLE: popper < track { unfocus-hook initial: [ drop ] } ;
-! list of strings is model (make shown objects implement sequence protocol)
-: <popper> ( model -- popper ) vertical popper new-track swap >>model ;
-
-M: popped handle-gesture swap {
- { gain-focus [ 1 set-expansion f ] }
- { lose-focus [ dup parent>>
- [ [ unfocus-hook>> call( a -- ) ] curry [ f set-expansion ] bi ]
- [ drop ] if* f
- ] }
- { T{ key-up f f "RET" } [ dup editor>> delete-previous-character new-popped f ] }
- { T{ key-up f f "BACKSPACE" } [ dup editor>> editor-string "" =
- [ dup fatal?>> [ [ focus-prev ] [ unparent ] bi ] [ t >>fatal? drop ] if ]
- [ f >>fatal? drop ] if f
- ] }
- [ swap call-next-method ]
-} case ;
-
-M: popper handle-gesture swap T{ button-down f f 1 } =
- [ hand-click# get 2 = [ initial-popped ] [ drop ] if ] [ drop ] if f ;
-
-M: popper model-changed
- [ children>> [ unparent ] each ]
- [ [ value>> [ <popped> ] map ] dip [ f track-add ] reduce request-focus ] bi ;
-
-M: popped pref-dim* editor>> [ pref-dim* first ] [ line-height ] bi 2array ;
-M: popper focusable-child* children>> [ t ] [ first ] if-empty ;
\ No newline at end of file
--- /dev/null
+USING: tools.deploy.config ;
+H{
+ { deploy-name "drills" }
+ { deploy-c-types? t }
+ { "stop-after-last-window?" t }
+ { deploy-unicode? t }
+ { deploy-threads? t }
+ { deploy-reflection 6 }
+ { deploy-word-defs? t }
+ { deploy-math? t }
+ { deploy-ui? t }
+ { deploy-word-props? t }
+ { deploy-io 3 }
+}
--- /dev/null
+USING: arrays cocoa.dialogs combinators continuations
+fry grouping io.encodings.utf8 io.files io.styles kernel math
+math.parser models models.arrow models.history namespaces random
+sequences splitting ui ui.gadgets.alerts ui.gadgets.book-extras
+ui.gadgets.books ui.gadgets.buttons ui.gadgets.frames
+ui.gadgets.grids ui.gadgets.labels ui.gadgets.tracks fonts
+wrap.strings system ;
+EXCLUDE: accessors => change-model ;
+IN: drills.deployed
+SYMBOLS: it startLength ;
+: big ( gadget -- gadget ) T{ font { name "sans-serif" } { size 30 } } >>font ;
+: card ( model quot -- button ) <arrow> <label-control> big [ next ] <book-btn> ;
+: op ( quot str -- gadget ) <label> big swap <book-bevel-btn> ;
+
+: show ( model -- gadget ) dup it set-global [ random ] <arrow>
+ { [ [ first ] card ]
+ [ [ second ] card ]
+ [ '[ |<< it get _ model-changed ] "No" op ]
+ [ '[ |<< [ it get [
+ _ value>> swap remove
+ [ [ it get go-back ] "Drill Complete" alert return ] when-empty
+ ] change-model ] with-return ] "Yes" op ]
+ } cleave
+2array { 1 0 } <track> swap [ 0.5 track-add ] each
+3array <book*> 3 3 <frame> { 1 1 } >>filled-cell { 450 175 } >>pref-dim swap { 1 1 } grid-add
+it get [ length startLength get swap - number>string "/" startLength get number>string 3append ] <arrow> <label-control> { 1 2 } grid-add ;
+
+: drill ( -- ) [
+ open-panel [
+ [ utf8 file-lines [ "\t" split [ 25 wrap-string ] map ] map dup [ first2 swap 2array ] map append ] map concat
+ [ length startLength set-global ] keep <history> [ add-history ] [ show ] bi
+ "Got it?" open-window
+ ] [ 0 exit ] if*
+] with-ui ;
+
+MAIN: drill
\ No newline at end of file
--- /dev/null
+unportable
--- /dev/null
+USING: arrays cocoa.dialogs combinators continuations
+fry grouping io.encodings.utf8 io.files io.styles kernel math
+math.parser models models.arrow models.history namespaces random
+sequences splitting ui ui.gadgets.alerts ui.gadgets.book-extras
+ui.gadgets.books ui.gadgets.buttons ui.gadgets.frames
+ui.gadgets.grids ui.gadgets.labels ui.gadgets.tracks fonts
+wrap.strings ;
+EXCLUDE: accessors => change-model ;
+
+IN: drills
+SYMBOLS: it startLength ;
+: big ( gadget -- gadget ) T{ font { name "sans-serif" } { size 30 } } >>font ;
+: card ( model quot -- button ) <arrow> <label-control> big [ next ] <book-btn> ;
+: op ( quot str -- gadget ) <label> big swap <book-border-btn> ;
+
+: show ( model -- gadget ) dup it set-global [ random ] <arrow>
+ { [ [ first ] card ]
+ [ [ second ] card ]
+ [ '[ |<< it get _ model-changed ] "No" op ]
+ [ '[ |<< [ it get [
+ _ value>> swap remove
+ [ [ it get go-back ] "Drill Complete" alert return ] when-empty
+ ] change-model ] with-return ] "Yes" op ]
+ } cleave
+2array { 1 0 } <track> swap [ 0.5 track-add ] each
+3array <book*> 3 3 <frame> { 1 1 } >>filled-cell { 450 175 } >>pref-dim swap { 1 1 } grid-add
+it get [ length startLength get swap - number>string "/" startLength get number>string 3append ] <arrow> <label-control> { 1 2 } grid-add ;
+
+: drill ( -- ) [
+ open-panel [
+ [ utf8 file-lines [ "\t" split [ 25 wrap-string ] map ] map dup [ first2 swap 2array ] map append ] map concat
+ [ length startLength set-global ] keep <history> [ add-history ] [ show ] bi
+ "Got it?" open-window
+ ] when*
+] with-ui ;
+
+MAIN: drill
\ No newline at end of file
--- /dev/null
+unportable
--- /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 { "model" model } { "oldval" "starting value" } { "quot" "applied to update and previous values" } { "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"
--- /dev/null
+USING: accessors arrays kernel models models.product monads
+sequences sequences.extras shuffle ;
+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 >>
--- /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
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+USING: accessors arrays colors.constants combinators
+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 ;
+"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 short head-slice ;
+
+: interface ( -- book ) [
+ [
+ [ $ TOOLBAR $ ] <hbox> COLOR: AliceBlue <solid> >>interior ,
+ [ "Genres:" <label> , <spacer> $ ALL $ $ GENRES $ ] <hbox>
+ { 5 0 } >>gap COLOR: gray <solid> >>interior ,
+ $ RECIPES $
+ ] <vbox> ,
+ [
+ [ "Title:" <label> , $ TITLE $ "Genre:" <label> , $ GENRE $ ] <hbox> ,
+ $ BODY $
+ $ BUTTON $
+ ] <vbox> ,
+ ] <book*> { 350 245 } >>pref-dim ;
+
+:: recipe-browser ( -- ) [ [
+ interface
+ <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 selection>> votes [ [ + ] curry change-votes modify-tuple ] 2$>
+ 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 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 <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
+ 2merge 0 <basic> switch-models >>model
+ ] with-interface "recipes" open-window ] with-ui ;
+
+MAIN: recipe-browser
\ No newline at end of file
--- /dev/null
+Database backed recipe sharing
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+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.gadgets.controls
+ui.gadgets.layout models.combinators ui.gadgets.alerts vectors fry
+ui.gadgets.labels shuffle ;
+IN: sudokus
+
+: row ( index -- row ) 1 + 9 / ceiling ;
+: col ( index -- col ) 9 mod 1 + ;
+: sq ( index -- square ) [ row ] [ col ] bi [ 3 / ceiling ] bi@ 2array ;
+: near ( a pos -- ? ) { [ [ row ] bi@ = ] [ [ col ] bi@ = ] [ [ sq ] bi@ = ] } 2|| ;
+: nth-or-lower ( n seq -- elt ) [ length 1 - 2dup > [ nip ] [ drop ] if ] keep nth ;
+
+:: 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 ;
+: 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 [ [ f swap [ length random ] keep set-nth ] curry times ] keep ;
+
+: do-sudoku ( -- ) [ [
+ [
+ 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> <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 ;
+
+MAIN: do-sudoku
--- /dev/null
+graphical sudoku solver
\ No newline at end of file
--- /dev/null
+USING: accessors models monads macros generalizations kernel
+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 ;
+
+IN: ui.gadgets.alerts
+:: alert ( quot string -- ) <pile> { 10 10 } >>gap 1 >>align
+ string 22 wrap-lines <label> T{ font { name "sans-serif" } { size 18 } } >>font { 200 100 } >>pref-dim add-gadget
+ "okay" [ close-window ] quot append <border-button> add-gadget "" open-window ;
+
+: alert* ( str -- ) [ ] swap alert ;
+
+:: ask-user ( string -- model' )
+ [
+ string <label> T{ font { name "sans-serif" } { size 14 } } >>font dup , :> lbl
+ <model-field*> ->% 1 :> fldm
+ "okay" <model-border-btn> :> 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 ,
+ [ [ <model-border-btn> [ close-window ] >>hook -> ] map ] <hbox> , ] <vbox>
+ "" open-window
+ ] dip firstn
+ ] 2curry ;
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+Really simple dialog boxes
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+USING: accessors arrays kernel math.rectangles sequences
+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 < table spawner ;
+
+M: combo-table handle-gesture [ call-next-method drop ] 2keep swap
+ T{ button-up } = [
+ [ spawner>> ]
+ [ tbl:selected-row [ swap set-control-value ] [ 2drop ] if ]
+ [ hide-glass ] tri
+ ] [ drop ] if t ;
+
+TUPLE: combobox < label-control table ;
+combobox H{
+ { T{ button-down } [ dup table>> over >>spawner <zero-rect> show-glass ] }
+} set-gestures
+
+: <combobox> ( options -- combobox ) [ first [ combobox new-label ] keep <basic> >>model ] keep
+ <basic> combo-table new-table [ 1array ] >>quot >>table ;
\ No newline at end of file
--- /dev/null
+Combo boxes have a model choosen from a list of options
\ 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 ui.gadgets.editors.private
+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
+ 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 ( model -- model' ) [ [ ] [ "" ] 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 ;
+
+: (new-field) ( editor field -- gadget ) [ new-editor ] dip new-border dup gadget-child >>editor
+ field-theme { 1 0 } >>align ; inline
+: <model-field*> ( -- field ) "" <model> <model-field> ;
+: <empty-field> ( model -- field ) "" <model> switch-models <model-field> ;
+: <model-editor> ( model -- gadget ) multiline-editor model-field (new-field) swap init-field >>model* ;
+: <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 append! ;
+
+SYNTAX: IMG-BTN: image-prep [ swap <button> ] curry append! ;
+
+GENERIC: output-model ( gadget -- model )
+M: gadget output-model model>> ;
+M: table output-model dup val-quot>> [ selection>> ] [ selection-index>> ] 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 ;
--- /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 delete-all ] 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 ] 2dip swap '[ [ _ templates set _ , @ ] with-interface ] ] when* ;
+
+SYNTAX: ,% scan string>number [ <layout> , ] curry append! ;
+SYNTAX: ->% scan string>number '[ [ _ <layout> , ] [ output-model ] bi ] append! ;
+
+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 ;
+: 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 append! ;
+
+: 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: >layout ( gadget -- layout )
+M: gadget >layout f <layout> ;
+M: layout >layout ;
+
+GENERIC# (add-gadget-at) 2 ( parent item n -- )
+M: gadget (add-gadget-at) -rot [ add-gadget ] keep insert-gadget ;
+M: track (add-gadget-at) -rot >layout [ add-layout ] keep [ gadget>> insert-gadget ] [ size>> insert-size ] 3bi ;
+
+GENERIC# add-gadget-at 1 ( item location -- )
+M: object add-gadget-at insertion-point -rot (add-gadget-at) ;
+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 ;
+: (track-add-at) ( parent item n 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 ;
--- /dev/null
+Syntax for easily building GUIs and using templates
\ No newline at end of file
--- /dev/null
+Sam Anklesaria
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Sam Anklesaria
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays accessors combinators kernel math
+models models.combinators namespaces sequences
+ui.gadgets ui.gadgets.controls ui.gadgets.layout
+ui.gadgets.tracks ui.gestures ui.gadgets.line-support ;
+EXCLUDE: ui.gadgets.editors => model-field ;
+IN: ui.gadgets.poppers
+
+TUPLE: popped < model-field { fatal? initial: t } ;
+TUPLE: popped-editor < multiline-editor ;
+: <popped> ( text -- gadget ) <basic> init-field popped-editor popped (new-field) swap >>model* ;
+
+: set-expansion ( popped size -- ) over dup parent>> [ children>> index ] [ sizes>> ] bi set-nth relayout ;
+: new-popped ( popped -- ) insertion-point "" <popped>
+ [ rot 1 + f (track-add-at) ] keep [ relayout ] [ request-focus ] bi ;
+: focus-prev ( popped -- ) dup parent>> children>> length 1 =
+ [ drop ] [
+ insertion-point [ 1 - dup -1 = [ drop 1 ] when ] [ children>> ] bi* nth
+ [ request-focus ] [ editor>> end-of-document ] bi
+ ] if ;
+: initial-popped ( popper -- ) "" <popped> [ f track-add drop ] keep request-focus ;
+
+TUPLE: popper < track { unfocus-hook initial: [ drop ] } ;
+! list of strings is model (make shown objects implement sequence protocol)
+: <popper> ( model -- popper ) vertical popper new-track swap >>model ;
+
+M: popped handle-gesture swap {
+ { gain-focus [ 1 set-expansion f ] }
+ { lose-focus [ dup parent>>
+ [ [ unfocus-hook>> call( a -- ) ] curry [ f set-expansion ] bi ]
+ [ drop ] if* f
+ ] }
+ { T{ key-up f f "RET" } [ dup editor>> delete-previous-character new-popped f ] }
+ { T{ key-up f f "BACKSPACE" } [ dup editor>> editor-string "" =
+ [ dup fatal?>> [ [ focus-prev ] [ unparent ] bi ] [ t >>fatal? drop ] if ]
+ [ f >>fatal? drop ] if f
+ ] }
+ [ swap call-next-method ]
+} case ;
+
+M: popper handle-gesture swap T{ button-down f f 1 } =
+ [ hand-click# get 2 = [ initial-popped ] [ drop ] if ] [ drop ] if f ;
+
+M: popper model-changed
+ [ children>> [ unparent ] each ]
+ [ [ value>> [ <popped> ] map ] dip [ f track-add ] reduce request-focus ] bi ;
+
+M: popped pref-dim* editor>> [ pref-dim* first ] [ line-height ] bi 2array ;
+M: popper focusable-child* children>> [ t ] [ first ] if-empty ;
\ No newline at end of file
projects / factor.git / commitdiff