--- /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
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs classes classes.tuple colors
-colors.constants combinators combinators.smart fry kernel lexer
-locals math math.rectangles math.vectors models namespaces
-opengl opengl.gl quotations sequences strings ui.commands
-ui.gadgets ui.gadgets.borders ui.gadgets.labels
-ui.gadgets.packs ui.gadgets.tracks ui.gadgets.worlds
-ui.gestures ui.images ui.pens ui.pens.image ui.pens.solid
-ui.pens.tile vocabs.parser ;
+USING: accessors arrays kernel math models namespaces sequences
+strings quotations assocs combinators classes colors colors.constants
+classes.tuple opengl opengl.gl math.vectors ui.commands ui.gadgets
+ui.gadgets.borders ui.gadgets.labels ui.gadgets.tracks
+ui.gadgets.packs ui.gadgets.worlds ui.gestures ui.pens ui.pens.solid
+ui.pens.image ui.pens.tile math.rectangles locals fry
+combinators.smart ;
FROM: models => change-model ;
IN: ui.gadgets.buttons
} set-gestures
: new-button ( label quot class -- button )
- [ swap >label ] dip new-border swap >>quot
- f <model> >>model ; inline
+ [ swap >label ] dip new-border swap >>quot ; inline
: <button> ( label quot -- button )
button new-button ;
-: button-text ( button -- string ) children>> first text>> ;
-
TUPLE: button-pen
plain rollover
pressed selected pressed-selected ;
#! the mouse is held down.
repeat-button new-button border-button-theme ;
-<PRIVATE
-: image-prep ( -- image ) scan current-vocab name>>
- "vocab:" "/icons/" surround ".tiff" surround
- <image-name> dup cached-image drop ;
-PRIVATE>
-
-SYNTAX: IMG-BUTTON: image-prep [ swap <button> ] curry over push-all ;
-
<PRIVATE
: <checkmark-pen> ( -- pen )
: add-toolbar ( track -- track )
dup <toolbar> { 3 3 } <border> align-left f track-add ;
-
-TUPLE: button* < button value ;
-
-: <button*> ( label -- button )
- [ [ dup value>> or ] keep set-control-value ] button* new-button ;
-
-: <border-button*> ( label -- button ) <button*> border-button-theme ;
-
-SYNTAX: IMG-BUTTON*: image-prep [ <button*> ] curry over push-all ;
"hello" <model> <model-field> "field" set
"field" get [
- [ "hello" ] [ "field" get model>> value>> ] unit-test
+ [ "hello" ] [ "field" get field-model>> value>> ] unit-test
] with-grafted-gadget
[ "Hello world." ] [ "Hello \n world." join-lines ] unit-test
{ 1 0 } >>fill
field-theme ;
-: new-field ( class editor-class -- gadget )
- new-editor swap new-border
+: new-field ( class -- gadget )
+ [ <editor> ] dip new-border
dup gadget-child >>editor
- field-theme { 1 0 } >>align ; inline
+ field-theme ; inline
! For line-gadget-width
M: field font>> editor>> font>> ;
[ line-gadget-width ] [ drop second ] 2bi 2array
border-pref-dim ;
-TUPLE: model-field < field ;
-
-: init-model ( object -- object ) [ [ ] [ "" ] if* ] change-value ;
+TUPLE: model-field < field field-model ;
: <model-field> ( model -- gadget )
- model-field editor new-field swap
- init-model >>model ;
-
-: <model-field*> ( -- gadget ) "" <model> <model-field> ;
+ model-field new-field swap >>field-model ;
M: model-field graft*
- [ [ model>> value>> ] [ editor>> ] bi set-editor-string ]
+ [ [ field-model>> value>> ] [ editor>> ] bi set-editor-string ]
[ dup editor>> model>> add-connection ]
- [ dup model>> add-connection ] tri ;
+ bi ;
M: model-field ungraft*
- [ dup editor>> model>> remove-connection ]
- [ dup model>> remove-connection ] bi ;
+ dup editor>> model>> remove-connection ;
-M: model-field model-changed 2dup model>> =
- [ [ value>> ] [ editor>> ] bi* set-editor-string ]
- [ nip [ editor>> editor-string ] [ model>> ] bi set-model ] if ;
+M: model-field model-changed
+ nip [ editor>> editor-string ] [ field-model>> ] bi set-model ;
-TUPLE: action-field < field { quot initial: [ dup set-control-value ] } ;
+TUPLE: action-field < field quot ;
: <action-field> ( quot -- gadget )
- action-field editor new-field swap >>quot ;
+ action-field new-field swap >>quot ;
: invoke-action-field ( field -- )
[ editor>> editor-string ]
action-field H{
{ T{ key-down f f "RET" } [ invoke-action-field ] }
} set-gestures
-
-: <multiline-field> ( model -- gadget ) model-field multiline-editor new-field swap init-model >>model ;
-
-: <multiline-field*> ( -- editor ) "" <model> <multiline-field> ;
\ No newline at end of file
: control-value ( control -- value )
model>> value>> ;
-GENERIC: output-model ( gadget -- model )
-M: gadget output-model model>> ;
-
: set-control-value ( value control -- )
model>> set-model ;
[ call-next-method ] [
dup follows>>
[ update-scroller ] [ >>follows drop ] 2bi
- ] bi ;
+ ] bi ;
M: scroller focusable-child*
viewport>> ;
<scroller-model> >>model
swap >>column-header ; inline
-PRIVATE>
-
-GENERIC# (build-children) 2 ( gadget range orientation -- gadget slider )
-M: scroller (build-children) <slider> ;
-
-<PRIVATE
: build-children ( gadget scroller -- scroller )
dup model>> dependencies>>
- [ first horizontal (build-children) >>x ]
- [ second vertical (build-children) >>y ] bi
+ [ first horizontal <slider> >>x ]
+ [ second vertical <slider> >>y ] bi
[ nip ] [ model>> <viewport> ] 2bi >>viewport ; inline
+
PRIVATE>
-: new-scroller ( gadget class -- scroller )
- [ dup viewport-column-header
- dup [ 2 3 ] [ 2 2 ] if ] dip new-frame
+: <scroller> ( gadget -- scroller )
+ dup viewport-column-header
+ dup [ 2 3 ] [ 2 2 ] if scroller new-frame
init-scroller
build-children
dup column-header>>
[ build-header-scroller ] [ build-scroller ] if ;
-: <scroller> ( gadget -- scroller ) scroller new-scroller ;
-
: scroll>rect ( rect gadget -- )
dup find-scroller* dup [
[ relative-scroll-rect ] keep
: scroll>top ( gadget -- )
<zero-rect> swap scroll>rect ;
-
-M: scroller output-model viewport>> children>> first output-model ;
\ No newline at end of file
PRIVATE>
-: new-slider ( range orientation class -- slider )
- new-track
+: <slider> ( range orientation -- slider )
+ slider new-track
swap >>model
32 >>line
dup orientation>> {
[ drop <gadget> { 1 1 } >>dim f track-add ]
} cleave ;
-: <slider> ( range orientation -- slider ) slider new-slider ;
-
-: <slider*> ( init min max step -- slider ) 0 -roll <range> horizontal <slider> ; ! most common case
-
-M: slider output-model model>> range-model ;
\ No newline at end of file
focused?
multiple-selection? ;
-M: table output-model selection>> ;
-
<PRIVATE
: add-selected-index ( table n -- table )
: <table> ( rows renderer -- table ) table new-table ;
-: <table*> ( renderer -- table ) { } <model> swap <table> ;
-
<PRIVATE
GENERIC: cell-width ( font cell -- x )
dup renderer>> column-titles
[ <column-headers> ] [ drop f ] if ;
-PRIVATE>
-
-! Using quots gives functional flavor
-! No reason to force an object oriented style
-TUPLE: quot-table < table
-{ quot initial: [ ] }
-{ val-quot initial: [ ] }
-{ color-quot initial: [ drop f ] }
-column-titles column-alignment actions hooks ;
-
-M: quot-table column-titles column-titles>> ;
-M: quot-table column-alignment column-alignment>> ;
-M: quot-table row-columns quot>> call( a -- b ) ;
-M: quot-table row-value val-quot>> call( a -- b ) ;
-M: quot-table row-color color-quot>> call( a -- b ) ;
-
-M: quot-table output-model dup val-quot>> [ selection>> ] [ selection-index>> ] if ;
-
-: indexed ( table -- table ) f >>val-quot ;
-
-: new-quot-table ( model class -- table )
- f swap new-table dup >>renderer
- f <model> >>actions f <model> >>hooks
- dup actions>> [ set-model ] curry >>action
- dup hooks>> [ set-model ] curry >>hook ;
-
-: <quot-table> ( model -- table ) quot-table new-quot-table ;
-
-: <quot-table*> ( -- table ) { } <model> <quot-table> ;
-
-: <list> ( model -- table ) <quot-table> [ 1array ] >>quot ;
-
-: <list*> ( -- table ) { } <model> <list> ;
\ No newline at end of file
+PRIVATE>
\ No newline at end of file
USING: accessors arrays delegate delegate.protocols
-io.pathnames kernel locals make models.combinators sequences
-sequences.extras strings ui.gadgets.tables vectors ;
+io.pathnames kernel locals sequences
+vectors make strings models.combinators ui.gadgets.controls
+sequences.extras ;
IN: file-trees
TUPLE: walkable-vector vector father ;
: <dir-table> ( tree-model -- table )
<list*> [ node>> 1array ] >>quot
- [ selection>> [ file? not ] filter-model swap switch-models ]
+ [ selected-value>> [ file? not ] filter-model swap switch-models ]
[ swap >>model ] bi ;
\ 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
-USING: accessors arrays colors.constants combinators db.sqlite
-db.tuples db.types io.files.temp kernel locals math
-models.combinators monads persistency sequences
-sequences.extras ui ui.gadgets.buttons ui.gadgets.editors
-ui.gadgets.labels ui.gadgets.layout ui.gadgets.scrollers
-ui.gadgets.tables ui.pens.solid ;
+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
[
[ "Title:" <label> , $ TITLE $ "Genre:" <label> , $ GENRE $ ] <hbox> ,
$ BODY $
- $ BUTTON* $
+ $ BUTTON $
] <vbox> ,
] <book*> { 350 245 } >>pref-dim ;
:: recipe-browser ( -- ) [ [
interface
- <quot-table*> :> tbl
- "okay" <border-button*> BUTTON* -> :> ok
- IMG-BUTTON*: submit [ store-tuple ] >>value TOOLBAR -> :> submit
- IMG-BUTTON*: love 1 >>value TOOLBAR ->
- IMG-BUTTON*: hate -1 >>value -> 2array merge :> votes
- IMG-BUTTON*: back -> [ -30 ] <$
- IMG-BUTTON*: more -> [ 30 ] <$ 2array merge :> viewed
+ <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" <button*> ALL ->
+ 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 [ <button*> GENRES -> ] map merge ] bind*
- [ button-text T{ recipe } swap >>genre get-tuples ] fmap
+ 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 <multiline-field> BODY ->% 1 ]
+ [ [ txt>> ] fmap <model-editor> BODY ->% 1 ]
} cleave
[ <recipe> ] 3fmap
[ [ 1 ] <$ ]
-USING: accessors arrays combinators.short-circuit fry grouping
-kernel lists lists.lazy locals math math.functions math.parser
-math.ranges models.combinators models.product monads random
-sequences sets ui ui.gadgets.alerts ui.gadgets.buttons
-ui.gadgets.editors ui.gadgets.labels ui.gadgets.layout vectors ;
+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 ;
IN: sudokus
: row ( index -- row ) 1 + 9 / ceiling ;
[ [ [ <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" <border-button*> -> updates [ create ] fmap <spacer>
- "Hint" <border-button*> -> "Solve" <border-button*> -> ] <hbox> ,
+ "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
USING: accessors models monads macros generalizations kernel
-ui models.combinators ui.gadgets.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 [ <model-field*> ->% 1 ]
- btn [ "okay" <border-button*> ] |
+ 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 ,
- [ [ <border-button*> [ [ dup close-window ] prepend ] change-quot -> ] 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
-models.combinators sequences ui.gadgets ui.gadgets.glass
-ui.gadgets.labels ui.gadgets.tables ui.gestures ;
+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 < quot-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-quot-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
+ 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 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 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 ;
\ No newline at end of file
--- /dev/null
+Gadgets with expanded model usage
\ No newline at end of file
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.tracks words ui.gadgets.controls ;
QUALIFIED: make
QUALIFIED-WITH: ui.gadgets.books book
IN: ui.gadgets.layout
! See http://factorcode.org/license.txt for BSD license.
USING: arrays accessors combinators kernel math
models models.combinators namespaces sequences
-ui.gadgets ui.gadgets.layout ui.gadgets.tracks
-ui.gestures ui.gadgets.line-support
-ui.gadgets.editors ;
+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-model popped popped-editor new-field swap >>model t >>clipped? ;
+: <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>
! list of strings is model (make shown objects implement sequence protocol)
: <popper> ( model -- popper ) vertical popper new-track swap >>model ;
-popped H{
- { gain-focus [ 1 set-expansion ] }
+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*
+ [ drop ] if* f
] }
- { T{ key-up f f "RET" } [ dup editor>> delete-previous-character new-popped ] }
+ { 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 >>fatal? drop ] if f
] }
-} set-gestures
+ [ 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 t ;
+ [ 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: 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