Merge branch 'master' of git://factorcode.org/git/factor
commit
0f535da33f
|
@ -0,0 +1,31 @@
|
||||||
|
USING: help.syntax help.markup kernel math classes classes.tuple
|
||||||
|
calendar models ;
|
||||||
|
IN: models.compose
|
||||||
|
|
||||||
|
HELP: compose
|
||||||
|
{ $class-description "Composed model values are computed by collecting the values from a sequence of underlying models into a new sequence. Composed models are automatically updated when underlying models change. Composed models are constructed by " { $link <compose> } "."
|
||||||
|
$nl
|
||||||
|
"A composed model whose children are all " { $link "models-range" } " conforms to the " { $link "range-model-protocol" } " and represents a point in n-dimensional space which is bounded by a rectangle." }
|
||||||
|
{ $examples
|
||||||
|
"The following code displays a pair of sliders, and an updating label showing their current values:"
|
||||||
|
{ $code
|
||||||
|
"USING: models ui.gadgets.labels ui.gadgets.sliders ui.gadgets.panes ;"
|
||||||
|
": <funny-slider> <x-slider> 100 over set-slider-max ;"
|
||||||
|
"<funny-slider> <funny-slider> 2array"
|
||||||
|
"dup make-pile gadget."
|
||||||
|
"dup [ gadget-model ] map <compose> [ unparse ] <filter>"
|
||||||
|
"<label-control> gadget."
|
||||||
|
}
|
||||||
|
} ;
|
||||||
|
|
||||||
|
HELP: <compose>
|
||||||
|
{ $values { "models" "a sequence of models" } { "compose" "a new " { $link compose } } }
|
||||||
|
{ $description "Creates a new instance of " { $link compose } ". The value of the new compose model is obtained by mapping " { $link model-value } " over the given sequence of models." }
|
||||||
|
{ $examples "See the example in the documentation for " { $link compose } "." } ;
|
||||||
|
|
||||||
|
ARTICLE: "models-compose" "Composed models"
|
||||||
|
"Composed model values are computed by collecting the values from a sequence of underlying models into a new sequence."
|
||||||
|
{ $subsection compose }
|
||||||
|
{ $subsection <compose> } ;
|
||||||
|
|
||||||
|
ABOUT: "models-compose"
|
|
@ -0,0 +1,24 @@
|
||||||
|
IN: models.compose.tests
|
||||||
|
USING: arrays generic kernel math models namespaces sequences assocs
|
||||||
|
tools.test models.compose ;
|
||||||
|
|
||||||
|
! Test compose
|
||||||
|
[ ] [
|
||||||
|
1 <model> "a" set
|
||||||
|
2 <model> "b" set
|
||||||
|
"a" get "b" get 2array <compose> "c" set
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ ] [ "c" get activate-model ] unit-test
|
||||||
|
|
||||||
|
[ { 1 2 } ] [ "c" get model-value ] unit-test
|
||||||
|
|
||||||
|
[ ] [ 3 "b" get set-model ] unit-test
|
||||||
|
|
||||||
|
[ { 1 3 } ] [ "c" get model-value ] unit-test
|
||||||
|
|
||||||
|
[ ] [ { 4 5 } "c" get set-model ] unit-test
|
||||||
|
|
||||||
|
[ { 4 5 } ] [ "c" get model-value ] unit-test
|
||||||
|
|
||||||
|
[ ] [ "c" get deactivate-model ] unit-test
|
|
@ -0,0 +1,49 @@
|
||||||
|
USING: models kernel sequences ;
|
||||||
|
IN: models.compose
|
||||||
|
|
||||||
|
TUPLE: compose ;
|
||||||
|
|
||||||
|
: <compose> ( models -- compose )
|
||||||
|
f compose construct-model
|
||||||
|
swap clone over set-model-dependencies ;
|
||||||
|
|
||||||
|
: composed-value >r model-dependencies r> map ; inline
|
||||||
|
|
||||||
|
: set-composed-value >r model-dependencies r> 2each ; inline
|
||||||
|
|
||||||
|
M: compose model-changed
|
||||||
|
nip
|
||||||
|
dup [ model-value ] composed-value swap delegate set-model ;
|
||||||
|
|
||||||
|
M: compose model-activated dup model-changed ;
|
||||||
|
|
||||||
|
M: compose update-model
|
||||||
|
dup model-value swap [ set-model ] set-composed-value ;
|
||||||
|
|
||||||
|
M: compose range-value
|
||||||
|
[ range-value ] composed-value ;
|
||||||
|
|
||||||
|
M: compose range-page-value
|
||||||
|
[ range-page-value ] composed-value ;
|
||||||
|
|
||||||
|
M: compose range-min-value
|
||||||
|
[ range-min-value ] composed-value ;
|
||||||
|
|
||||||
|
M: compose range-max-value
|
||||||
|
[ range-max-value ] composed-value ;
|
||||||
|
|
||||||
|
M: compose range-max-value*
|
||||||
|
[ range-max-value* ] composed-value ;
|
||||||
|
|
||||||
|
M: compose set-range-value
|
||||||
|
[ clamp-value ] keep
|
||||||
|
[ set-range-value ] set-composed-value ;
|
||||||
|
|
||||||
|
M: compose set-range-page-value
|
||||||
|
[ set-range-page-value ] set-composed-value ;
|
||||||
|
|
||||||
|
M: compose set-range-min-value
|
||||||
|
[ set-range-min-value ] set-composed-value ;
|
||||||
|
|
||||||
|
M: compose set-range-max-value
|
||||||
|
[ set-range-max-value ] set-composed-value ;
|
|
@ -0,0 +1,29 @@
|
||||||
|
USING: help.syntax help.markup kernel math classes classes.tuple
|
||||||
|
calendar models ;
|
||||||
|
IN: models.delay
|
||||||
|
|
||||||
|
HELP: delay
|
||||||
|
{ $class-description "Delay models have the same value as their underlying model, however the value only changes after a timer expires. If the underlying model's value changes again before the timer expires, the timer restarts. Delay models are constructed by " { $link <delay> } "." }
|
||||||
|
{ $examples
|
||||||
|
"The following code displays a sliders and a label which is updated half a second after the slider stops changing:"
|
||||||
|
{ $code
|
||||||
|
"USING: models ui.gadgets.labels ui.gadgets.sliders ui.gadgets.panes calendar ;"
|
||||||
|
": <funny-slider>"
|
||||||
|
" 0 0 0 100 <range> <x-slider> 500 over set-slider-max ;"
|
||||||
|
"<funny-slider> dup gadget."
|
||||||
|
"gadget-model 1/2 seconds <delay> [ number>string ] <filter>"
|
||||||
|
"<label-control> gadget."
|
||||||
|
}
|
||||||
|
} ;
|
||||||
|
|
||||||
|
HELP: <delay>
|
||||||
|
{ $values { "model" model } { "timeout" duration } { "delay" delay } }
|
||||||
|
{ $description "Creates a new instance of " { $link delay } ". The timeout must elapse from the time the underlying model last changed to when the delay model value is changed and its connections are notified." }
|
||||||
|
{ $examples "See the example in the documentation for " { $link delay } "." } ;
|
||||||
|
|
||||||
|
ARTICLE: "models-delay" "Delay models"
|
||||||
|
"Delay models are used to implement delayed updating of gadgets in response to user input."
|
||||||
|
{ $subsection delay }
|
||||||
|
{ $subsection <delay> } ;
|
||||||
|
|
||||||
|
ABOUT: "models-delay"
|
|
@ -0,0 +1,25 @@
|
||||||
|
USING: kernel models alarms ;
|
||||||
|
IN: models.delay
|
||||||
|
|
||||||
|
TUPLE: delay model timeout alarm ;
|
||||||
|
|
||||||
|
: update-delay-model ( delay -- )
|
||||||
|
dup delay-model model-value swap set-model ;
|
||||||
|
|
||||||
|
: <delay> ( model timeout -- delay )
|
||||||
|
f delay construct-model
|
||||||
|
[ set-delay-timeout ] keep
|
||||||
|
[ set-delay-model ] 2keep
|
||||||
|
[ add-dependency ] keep ;
|
||||||
|
|
||||||
|
: cancel-delay ( delay -- )
|
||||||
|
delay-alarm [ cancel-alarm ] when* ;
|
||||||
|
|
||||||
|
: start-delay ( delay -- )
|
||||||
|
dup [ f over set-delay-alarm update-delay-model ] curry
|
||||||
|
over delay-timeout later
|
||||||
|
swap set-delay-alarm ;
|
||||||
|
|
||||||
|
M: delay model-changed nip dup cancel-delay start-delay ;
|
||||||
|
|
||||||
|
M: delay model-activated update-delay-model ;
|
|
@ -0,0 +1,27 @@
|
||||||
|
USING: help.syntax help.markup kernel math classes classes.tuple
|
||||||
|
calendar models ;
|
||||||
|
IN: models.filter
|
||||||
|
|
||||||
|
HELP: filter
|
||||||
|
{ $class-description "Filter model values are computed by applying a quotation to the value of another model. Filters are automatically updated when the underlying model changes. Filters are constructed by " { $link <filter> } "." }
|
||||||
|
{ $examples
|
||||||
|
"The following code displays a label showing the result of applying " { $link sq } " to the value 5:"
|
||||||
|
{ $code
|
||||||
|
"USING: models ui.gadgets.labels ui.gadgets.panes ;"
|
||||||
|
"5 <model> [ sq ] <filter> [ number>string ] <filter>"
|
||||||
|
"<label-control> gadget."
|
||||||
|
}
|
||||||
|
"An exercise for the reader is to keep the original model around on the stack, and change its value to 6, observing that the label will immediately display 36."
|
||||||
|
} ;
|
||||||
|
|
||||||
|
HELP: <filter>
|
||||||
|
{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } { "filter" "a new " { $link filter } } }
|
||||||
|
{ $description "Creates a new instance of " { $link filter } ". The value of the new filter model is computed by applying the quotation to the value." }
|
||||||
|
{ $examples "See the example in the documentation for " { $link filter } "." } ;
|
||||||
|
|
||||||
|
ARTICLE: "models-filter" "Filter models"
|
||||||
|
"Filter model values are computed by applying a quotation to the value of another model."
|
||||||
|
{ $subsection filter }
|
||||||
|
{ $subsection <filter> } ;
|
||||||
|
|
||||||
|
ABOUT: "models-filter"
|
|
@ -0,0 +1,24 @@
|
||||||
|
IN: models.filter.tests
|
||||||
|
USING: arrays generic kernel math models namespaces sequences assocs
|
||||||
|
tools.test models.filter ;
|
||||||
|
|
||||||
|
! Test multiple filters
|
||||||
|
3 <model> "x" set
|
||||||
|
"x" get [ 2 * ] <filter> dup "z" set
|
||||||
|
[ 1+ ] <filter> "y" set
|
||||||
|
[ ] [ "y" get activate-model ] unit-test
|
||||||
|
[ t ] [ "z" get "x" get model-connections memq? ] unit-test
|
||||||
|
[ 7 ] [ "y" get model-value ] unit-test
|
||||||
|
[ ] [ 4 "x" get set-model ] unit-test
|
||||||
|
[ 9 ] [ "y" get model-value ] unit-test
|
||||||
|
[ ] [ "y" get deactivate-model ] unit-test
|
||||||
|
[ f ] [ "z" get "x" get model-connections memq? ] unit-test
|
||||||
|
|
||||||
|
3 <model> "x" set
|
||||||
|
"x" get [ sq ] <filter> "y" set
|
||||||
|
|
||||||
|
4 "x" get set-model
|
||||||
|
|
||||||
|
"y" get activate-model
|
||||||
|
[ 16 ] [ "y" get model-value ] unit-test
|
||||||
|
"y" get deactivate-model
|
|
@ -0,0 +1,16 @@
|
||||||
|
USING: models kernel ;
|
||||||
|
IN: models.filter
|
||||||
|
|
||||||
|
TUPLE: filter model quot ;
|
||||||
|
|
||||||
|
: <filter> ( model quot -- filter )
|
||||||
|
f filter construct-model
|
||||||
|
[ set-filter-quot ] keep
|
||||||
|
[ set-filter-model ] 2keep
|
||||||
|
[ add-dependency ] keep ;
|
||||||
|
|
||||||
|
M: filter model-changed
|
||||||
|
swap model-value over filter-quot call
|
||||||
|
swap set-model ;
|
||||||
|
|
||||||
|
M: filter model-activated dup filter-model swap model-changed ;
|
|
@ -0,0 +1,36 @@
|
||||||
|
USING: help.syntax help.markup kernel math classes classes.tuple
|
||||||
|
calendar models ;
|
||||||
|
IN: models.history
|
||||||
|
|
||||||
|
HELP: history
|
||||||
|
{ $class-description "History models record a timeline of previous values on calls to " { $link add-history } ", and can travel back and forth on the timeline with " { $link go-back } " and " { $link go-forward } ". History models are constructed by " { $link <history> } "." } ;
|
||||||
|
|
||||||
|
HELP: <history>
|
||||||
|
{ $values { "value" object } { "history" "a new " { $link history } } }
|
||||||
|
{ $description "Creates a new history model with an initial value." } ;
|
||||||
|
|
||||||
|
{ <history> add-history go-back go-forward } related-words
|
||||||
|
|
||||||
|
HELP: go-back
|
||||||
|
{ $values { "history" history } }
|
||||||
|
{ $description "Restores the previous value and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ;
|
||||||
|
|
||||||
|
HELP: go-forward
|
||||||
|
{ $values { "history" history } }
|
||||||
|
{ $description "Restores the value set prior to the last call to " { $link go-back } " and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ;
|
||||||
|
|
||||||
|
HELP: add-history
|
||||||
|
{ $values { "history" history } }
|
||||||
|
{ $description "Adds the current value to the history." } ;
|
||||||
|
|
||||||
|
ARTICLE: "models-history" "History models"
|
||||||
|
"History models record previous values."
|
||||||
|
{ $subsection history }
|
||||||
|
{ $subsection <history> }
|
||||||
|
"Recording history:"
|
||||||
|
{ $subsection add-history }
|
||||||
|
"Navigating the history:"
|
||||||
|
{ $subsection go-back }
|
||||||
|
{ $subsection go-forward } ;
|
||||||
|
|
||||||
|
ABOUT: "models-history"
|
|
@ -0,0 +1,37 @@
|
||||||
|
IN: models.history.tests
|
||||||
|
USING: arrays generic kernel math models namespaces sequences assocs
|
||||||
|
tools.test models.history ;
|
||||||
|
|
||||||
|
f <history> "history" set
|
||||||
|
|
||||||
|
"history" get add-history
|
||||||
|
|
||||||
|
[ t ] [ "history" get history-back empty? ] unit-test
|
||||||
|
[ t ] [ "history" get history-forward empty? ] unit-test
|
||||||
|
|
||||||
|
"history" get add-history
|
||||||
|
3 "history" get set-model
|
||||||
|
|
||||||
|
[ t ] [ "history" get history-back empty? ] unit-test
|
||||||
|
[ t ] [ "history" get history-forward empty? ] unit-test
|
||||||
|
|
||||||
|
"history" get add-history
|
||||||
|
4 "history" get set-model
|
||||||
|
|
||||||
|
[ f ] [ "history" get history-back empty? ] unit-test
|
||||||
|
[ t ] [ "history" get history-forward empty? ] unit-test
|
||||||
|
|
||||||
|
"history" get go-back
|
||||||
|
|
||||||
|
[ 3 ] [ "history" get model-value ] unit-test
|
||||||
|
|
||||||
|
[ t ] [ "history" get history-back empty? ] unit-test
|
||||||
|
[ f ] [ "history" get history-forward empty? ] unit-test
|
||||||
|
|
||||||
|
"history" get go-forward
|
||||||
|
|
||||||
|
[ 4 ] [ "history" get model-value ] unit-test
|
||||||
|
|
||||||
|
[ f ] [ "history" get history-back empty? ] unit-test
|
||||||
|
[ t ] [ "history" get history-forward empty? ] unit-test
|
||||||
|
|
|
@ -0,0 +1,29 @@
|
||||||
|
USING: kernel models sequences ;
|
||||||
|
IN: models.history
|
||||||
|
|
||||||
|
TUPLE: history back forward ;
|
||||||
|
|
||||||
|
: reset-history ( history -- )
|
||||||
|
V{ } clone over set-history-back
|
||||||
|
V{ } clone swap set-history-forward ;
|
||||||
|
|
||||||
|
: <history> ( value -- history )
|
||||||
|
history construct-model dup reset-history ;
|
||||||
|
|
||||||
|
: (add-history) ( history to -- )
|
||||||
|
swap model-value dup [ swap push ] [ 2drop ] if ;
|
||||||
|
|
||||||
|
: go-back/forward ( history to from -- )
|
||||||
|
dup empty?
|
||||||
|
[ 3drop ]
|
||||||
|
[ >r dupd (add-history) r> pop swap set-model ] if ;
|
||||||
|
|
||||||
|
: go-back ( history -- )
|
||||||
|
dup history-forward over history-back go-back/forward ;
|
||||||
|
|
||||||
|
: go-forward ( history -- )
|
||||||
|
dup history-back over history-forward go-back/forward ;
|
||||||
|
|
||||||
|
: add-history ( history -- )
|
||||||
|
dup history-forward delete-all
|
||||||
|
dup history-back (add-history) ;
|
|
@ -0,0 +1,34 @@
|
||||||
|
IN: models.mapping.tests
|
||||||
|
USING: arrays generic kernel math models namespaces sequences assocs
|
||||||
|
tools.test models.mapping ;
|
||||||
|
|
||||||
|
! Test mapping
|
||||||
|
[ ] [
|
||||||
|
[
|
||||||
|
1 <model> "one" set
|
||||||
|
2 <model> "two" set
|
||||||
|
] H{ } make-assoc
|
||||||
|
<mapping> "m" set
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ ] [ "m" get activate-model ] unit-test
|
||||||
|
|
||||||
|
[ H{ { "one" 1 } { "two" 2 } } ] [
|
||||||
|
"m" get model-value
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ ] [
|
||||||
|
H{ { "one" 3 } { "two" 4 } }
|
||||||
|
"m" get set-model
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ H{ { "one" 3 } { "two" 4 } } ] [
|
||||||
|
"m" get model-value
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ H{ { "one" 5 } { "two" 4 } } ] [
|
||||||
|
5 "one" "m" get mapping-assoc at set-model
|
||||||
|
"m" get model-value
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ ] [ "m" get deactivate-model ] unit-test
|
|
@ -0,0 +1,20 @@
|
||||||
|
USING: models kernel assocs ;
|
||||||
|
IN: models.mapping
|
||||||
|
|
||||||
|
TUPLE: mapping assoc ;
|
||||||
|
|
||||||
|
: <mapping> ( models -- mapping )
|
||||||
|
f mapping construct-model
|
||||||
|
over values over set-model-dependencies
|
||||||
|
tuck set-mapping-assoc ;
|
||||||
|
|
||||||
|
M: mapping model-changed
|
||||||
|
nip
|
||||||
|
dup mapping-assoc [ model-value ] assoc-map
|
||||||
|
swap delegate set-model ;
|
||||||
|
|
||||||
|
M: mapping model-activated dup model-changed ;
|
||||||
|
|
||||||
|
M: mapping update-model
|
||||||
|
dup model-value swap mapping-assoc
|
||||||
|
[ swapd at set-model ] curry assoc-each ;
|
|
@ -5,10 +5,10 @@ IN: models
|
||||||
HELP: model
|
HELP: model
|
||||||
{ $class-description "A mutable cell holding a single value. When the value is changed, a sequence of connected objects are notified. Models have the following slots:"
|
{ $class-description "A mutable cell holding a single value. When the value is changed, a sequence of connected objects are notified. Models have the following slots:"
|
||||||
{ $list
|
{ $list
|
||||||
{ { $link model-value } " - the value of the model. Use " { $link set-model } " to change the value." }
|
{ { $snippet "value" } " - the value of the model. Use " { $link set-model } " to change the value." }
|
||||||
{ { $link model-connections } " - a sequence of objects implementing the " { $link model-changed } " generic word, to be notified when the model's value changes." }
|
{ { $snippet "connections" } " - a sequence of objects implementing the " { $link model-changed } " generic word, to be notified when the model's value changes." }
|
||||||
{ { $link model-dependencies } " - a sequence of models which should have this model added to their sequence of connections when activated." }
|
{ { $snippet "dependencies" } " - a sequence of models which should have this model added to their sequence of connections when activated." }
|
||||||
{ { $link model-ref } " - a reference count tracking the number of models which depend on this one." }
|
{ { $snippet "ref" } " - a reference count tracking the number of models which depend on this one." }
|
||||||
}
|
}
|
||||||
"Other classes may delegate to " { $link model } "."
|
"Other classes may delegate to " { $link model } "."
|
||||||
} ;
|
} ;
|
||||||
|
@ -79,84 +79,6 @@ HELP: (change-model)
|
||||||
{ $description "Applies the quotation to the current value of the model to yield a new value, then changes the value of the model to the new value without notifying any observers registered with " { $link add-connection } "." }
|
{ $description "Applies the quotation to the current value of the model to yield a new value, then changes the value of the model to the new value without notifying any observers registered with " { $link add-connection } "." }
|
||||||
{ $notes "There are very few reasons for user code to call this word. Instead, call " { $link change-model } ", which notifies observers." } ;
|
{ $notes "There are very few reasons for user code to call this word. Instead, call " { $link change-model } ", which notifies observers." } ;
|
||||||
|
|
||||||
HELP: filter
|
|
||||||
{ $class-description "Filter model values are computed by applying a quotation to the value of another model. Filters are automatically updated when the underlying model changes. Filters are constructed by " { $link <filter> } "." }
|
|
||||||
{ $examples
|
|
||||||
"The following code displays a label showing the result of applying " { $link sq } " to the value 5:"
|
|
||||||
{ $code
|
|
||||||
"USING: models ui.gadgets.labels ui.gadgets.panes ;"
|
|
||||||
"5 <model> [ sq ] <filter> [ number>string ] <filter>"
|
|
||||||
"<label-control> gadget."
|
|
||||||
}
|
|
||||||
"An exercise for the reader is to keep the original model around on the stack, and change its value to 6, observing that the label will immediately display 36."
|
|
||||||
} ;
|
|
||||||
|
|
||||||
HELP: <filter>
|
|
||||||
{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } { "filter" "a new " { $link filter } } }
|
|
||||||
{ $description "Creates a new instance of " { $link filter } ". The value of the new filter model is computed by applying the quotation to the value." }
|
|
||||||
{ $examples "See the example in the documentation for " { $link filter } "." } ;
|
|
||||||
|
|
||||||
HELP: compose
|
|
||||||
{ $class-description "Composed model values are computed by collecting the values from a sequence of underlying models into a new sequence. Composed models are automatically updated when underlying models change. Composed models are constructed by " { $link <compose> } "."
|
|
||||||
$nl
|
|
||||||
"A composed model whose children are all " { $link "models-range" } " conforms to the " { $link "range-model-protocol" } " and represents a point in n-dimensional space which is bounded by a rectangle." }
|
|
||||||
{ $examples
|
|
||||||
"The following code displays a pair of sliders, and an updating label showing their current values:"
|
|
||||||
{ $code
|
|
||||||
"USING: models ui.gadgets.labels ui.gadgets.sliders ui.gadgets.panes ;"
|
|
||||||
": <funny-slider> <x-slider> 100 over set-slider-max ;"
|
|
||||||
"<funny-slider> <funny-slider> 2array"
|
|
||||||
"dup make-pile gadget."
|
|
||||||
"dup [ gadget-model ] map <compose> [ unparse ] <filter>"
|
|
||||||
"<label-control> gadget."
|
|
||||||
}
|
|
||||||
} ;
|
|
||||||
|
|
||||||
HELP: <compose>
|
|
||||||
{ $values { "models" "a sequence of models" } { "compose" "a new " { $link compose } } }
|
|
||||||
{ $description "Creates a new instance of " { $link compose } ". The value of the new compose model is obtained by mapping " { $link model-value } " over the given sequence of models." }
|
|
||||||
{ $examples "See the example in the documentation for " { $link compose } "." } ;
|
|
||||||
|
|
||||||
HELP: history
|
|
||||||
{ $class-description "History models record a timeline of previous values on calls to " { $link add-history } ", and can travel back and forth on the timeline with " { $link go-back } " and " { $link go-forward } ". History models are constructed by " { $link <history> } "." } ;
|
|
||||||
|
|
||||||
HELP: <history>
|
|
||||||
{ $values { "value" object } { "history" "a new " { $link history } } }
|
|
||||||
{ $description "Creates a new history model with an initial value." } ;
|
|
||||||
|
|
||||||
{ <history> add-history go-back go-forward } related-words
|
|
||||||
|
|
||||||
HELP: go-back
|
|
||||||
{ $values { "history" history } }
|
|
||||||
{ $description "Restores the previous value and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ;
|
|
||||||
|
|
||||||
HELP: go-forward
|
|
||||||
{ $values { "history" history } }
|
|
||||||
{ $description "Restores the value set prior to the last call to " { $link go-back } " and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ;
|
|
||||||
|
|
||||||
HELP: add-history
|
|
||||||
{ $values { "history" history } }
|
|
||||||
{ $description "Adds the current value to the history." } ;
|
|
||||||
|
|
||||||
HELP: delay
|
|
||||||
{ $class-description "Delay models have the same value as their underlying model, however the value only changes after a timer expires. If the underlying model's value changes again before the timer expires, the timer restarts. Delay models are constructed by " { $link <delay> } "." }
|
|
||||||
{ $examples
|
|
||||||
"The following code displays a sliders and a label which is updated half a second after the slider stops changing:"
|
|
||||||
{ $code
|
|
||||||
"USING: models ui.gadgets.labels ui.gadgets.sliders ui.gadgets.panes calendar ;"
|
|
||||||
": <funny-slider>"
|
|
||||||
" 0 0 0 100 <range> <x-slider> 500 over set-slider-max ;"
|
|
||||||
"<funny-slider> dup gadget."
|
|
||||||
"gadget-model 1/2 seconds <delay> [ number>string ] <filter>"
|
|
||||||
"<label-control> gadget."
|
|
||||||
}
|
|
||||||
} ;
|
|
||||||
|
|
||||||
HELP: <delay>
|
|
||||||
{ $values { "model" model } { "timeout" duration } { "delay" delay } }
|
|
||||||
{ $description "Creates a new instance of " { $link delay } ". The timeout must elapse from the time the underlying model last changed to when the delay model value is changed and its connections are notified." }
|
|
||||||
{ $examples "See the example in the documentation for " { $link delay } "." } ;
|
|
||||||
|
|
||||||
HELP: range-value
|
HELP: range-value
|
||||||
{ $values { "model" model } { "value" object } }
|
{ $values { "model" model } { "value" object } }
|
||||||
{ $contract "Outputs the current value of a range model." } ;
|
{ $contract "Outputs the current value of a range model." } ;
|
||||||
|
@ -197,40 +119,6 @@ HELP: set-range-max-value
|
||||||
{ $description "Sets the maximum value of a range model." }
|
{ $description "Sets the maximum value of a range model." }
|
||||||
{ $side-effects "model" } ;
|
{ $side-effects "model" } ;
|
||||||
|
|
||||||
HELP: range
|
|
||||||
{ $class-description "Range models implement the " { $link "range-model-protocol" } " with real numbers as the minimum, current, maximum, and page size. Range models are created with " { $link <range> } "." }
|
|
||||||
{ $notes { $link "ui.gadgets.sliders" } " use range models." } ;
|
|
||||||
|
|
||||||
HELP: range-model
|
|
||||||
{ $values { "range" range } { "model" model } }
|
|
||||||
{ $description "Outputs a model holding a range model's current value." }
|
|
||||||
{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ;
|
|
||||||
|
|
||||||
HELP: range-min
|
|
||||||
{ $values { "range" range } { "model" model } }
|
|
||||||
{ $description "Outputs a model holding a range model's minimum value." }
|
|
||||||
{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ;
|
|
||||||
|
|
||||||
HELP: range-max
|
|
||||||
{ $values { "range" range } { "model" model } }
|
|
||||||
{ $description "Outputs a model holding a range model's maximum value." }
|
|
||||||
{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ;
|
|
||||||
|
|
||||||
HELP: range-page
|
|
||||||
{ $values { "range" range } { "model" model } }
|
|
||||||
{ $description "Outputs a model holding a range model's page size." }
|
|
||||||
{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ;
|
|
||||||
|
|
||||||
HELP: move-by
|
|
||||||
{ $values { "amount" real } { "range" range } }
|
|
||||||
{ $description "Adds a number to a range model's current value." }
|
|
||||||
{ $side-effects "range" } ;
|
|
||||||
|
|
||||||
HELP: move-by-page
|
|
||||||
{ $values { "amount" real } { "range" range } }
|
|
||||||
{ $description "Adds a multiple of the page size to a range model's current value." }
|
|
||||||
{ $side-effects "range" } ;
|
|
||||||
|
|
||||||
ARTICLE: "models" "Models"
|
ARTICLE: "models" "Models"
|
||||||
"The " { $vocab-link "models" } " vocabulary provides basic support for dataflow programming. A model is an observable value. Changing a model's value notifies other objects which depend on the model automatically, and models may depend on each other's values."
|
"The " { $vocab-link "models" } " vocabulary provides basic support for dataflow programming. A model is an observable value. Changing a model's value notifies other objects which depend on the model automatically, and models may depend on each other's values."
|
||||||
$nl
|
$nl
|
||||||
|
@ -246,60 +134,10 @@ $nl
|
||||||
"When using models which are not associated with controls (or when unit testing controls), you must activate and deactivate models manually:"
|
"When using models which are not associated with controls (or when unit testing controls), you must activate and deactivate models manually:"
|
||||||
{ $subsection activate-model }
|
{ $subsection activate-model }
|
||||||
{ $subsection deactivate-model }
|
{ $subsection deactivate-model }
|
||||||
"Special types of models:"
|
|
||||||
{ $subsection "models-filter" }
|
|
||||||
{ $subsection "models-compose" }
|
|
||||||
{ $subsection "models-history" }
|
|
||||||
{ $subsection "models-delay" }
|
|
||||||
{ $subsection "models-range" }
|
|
||||||
{ $subsection "models-impl" } ;
|
{ $subsection "models-impl" } ;
|
||||||
|
|
||||||
ARTICLE: "models-filter" "Filter models"
|
|
||||||
"Filter model values are computed by applying a quotation to the value of another model."
|
|
||||||
{ $subsection filter }
|
|
||||||
{ $subsection <filter> } ;
|
|
||||||
|
|
||||||
ARTICLE: "models-compose" "Composed models"
|
|
||||||
"Composed model values are computed by collecting the values from a sequence of underlying models into a new sequence."
|
|
||||||
{ $subsection compose }
|
|
||||||
{ $subsection <compose> } ;
|
|
||||||
|
|
||||||
ARTICLE: "models-history" "History models"
|
|
||||||
"History models record previous values."
|
|
||||||
{ $subsection history }
|
|
||||||
{ $subsection <history> }
|
|
||||||
"Recording history:"
|
|
||||||
{ $subsection add-history }
|
|
||||||
"Navigating the history:"
|
|
||||||
{ $subsection go-back }
|
|
||||||
{ $subsection go-forward } ;
|
|
||||||
|
|
||||||
ARTICLE: "models-delay" "Delay models"
|
|
||||||
"Delay models are used to implement delayed updating of gadgets in response to user input."
|
|
||||||
{ $subsection delay }
|
|
||||||
{ $subsection <delay> } ;
|
|
||||||
|
|
||||||
ARTICLE: "models-range" "Range models"
|
|
||||||
"Range models ensure their value is a real number within a fixed range."
|
|
||||||
{ $subsection range }
|
|
||||||
{ $subsection <range> }
|
|
||||||
"Range models conform to a protocol for getting and setting the current value, as well as the endpoints of the range."
|
|
||||||
{ $subsection "range-model-protocol" } ;
|
|
||||||
|
|
||||||
ARTICLE: "range-model-protocol" "Range model protocol"
|
|
||||||
"The range model protocol is implemented by the " { $link range } " and " { $link compose } " classes. User-defined models may implement it too."
|
|
||||||
{ $subsection range-value }
|
|
||||||
{ $subsection range-page-value }
|
|
||||||
{ $subsection range-min-value }
|
|
||||||
{ $subsection range-max-value }
|
|
||||||
{ $subsection range-max-value* }
|
|
||||||
{ $subsection set-range-value }
|
|
||||||
{ $subsection set-range-page-value }
|
|
||||||
{ $subsection set-range-min-value }
|
|
||||||
{ $subsection set-range-max-value } ;
|
|
||||||
|
|
||||||
ARTICLE: "models-impl" "Implementing models"
|
ARTICLE: "models-impl" "Implementing models"
|
||||||
"New types of models can be defined, along the lines of " { $link filter } " and such."
|
"New types of models can be defined, for example see " { $vocab-link "models.filter" } "."
|
||||||
$nl
|
$nl
|
||||||
"Models can execute hooks when activated:"
|
"Models can execute hooks when activated:"
|
||||||
{ $subsection model-activated }
|
{ $subsection model-activated }
|
||||||
|
|
|
@ -31,144 +31,3 @@ T{ model-tester f f } "tester" set
|
||||||
"tester" get
|
"tester" get
|
||||||
"model-c" get model-value
|
"model-c" get model-value
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
f <history> "history" set
|
|
||||||
|
|
||||||
"history" get add-history
|
|
||||||
|
|
||||||
[ t ] [ "history" get history-back empty? ] unit-test
|
|
||||||
[ t ] [ "history" get history-forward empty? ] unit-test
|
|
||||||
|
|
||||||
"history" get add-history
|
|
||||||
3 "history" get set-model
|
|
||||||
|
|
||||||
[ t ] [ "history" get history-back empty? ] unit-test
|
|
||||||
[ t ] [ "history" get history-forward empty? ] unit-test
|
|
||||||
|
|
||||||
"history" get add-history
|
|
||||||
4 "history" get set-model
|
|
||||||
|
|
||||||
[ f ] [ "history" get history-back empty? ] unit-test
|
|
||||||
[ t ] [ "history" get history-forward empty? ] unit-test
|
|
||||||
|
|
||||||
"history" get go-back
|
|
||||||
|
|
||||||
[ 3 ] [ "history" get model-value ] unit-test
|
|
||||||
|
|
||||||
[ t ] [ "history" get history-back empty? ] unit-test
|
|
||||||
[ f ] [ "history" get history-forward empty? ] unit-test
|
|
||||||
|
|
||||||
"history" get go-forward
|
|
||||||
|
|
||||||
[ 4 ] [ "history" get model-value ] unit-test
|
|
||||||
|
|
||||||
[ f ] [ "history" get history-back empty? ] unit-test
|
|
||||||
[ t ] [ "history" get history-forward empty? ] unit-test
|
|
||||||
|
|
||||||
! Test multiple filters
|
|
||||||
3 <model> "x" set
|
|
||||||
"x" get [ 2 * ] <filter> dup "z" set
|
|
||||||
[ 1+ ] <filter> "y" set
|
|
||||||
[ ] [ "y" get activate-model ] unit-test
|
|
||||||
[ t ] [ "z" get "x" get model-connections memq? ] unit-test
|
|
||||||
[ 7 ] [ "y" get model-value ] unit-test
|
|
||||||
[ ] [ 4 "x" get set-model ] unit-test
|
|
||||||
[ 9 ] [ "y" get model-value ] unit-test
|
|
||||||
[ ] [ "y" get deactivate-model ] unit-test
|
|
||||||
[ f ] [ "z" get "x" get model-connections memq? ] unit-test
|
|
||||||
|
|
||||||
3 <model> "x" set
|
|
||||||
"x" get [ sq ] <filter> "y" set
|
|
||||||
|
|
||||||
4 "x" get set-model
|
|
||||||
|
|
||||||
"y" get activate-model
|
|
||||||
[ 16 ] [ "y" get model-value ] unit-test
|
|
||||||
"y" get deactivate-model
|
|
||||||
|
|
||||||
! Test compose
|
|
||||||
[ ] [
|
|
||||||
1 <model> "a" set
|
|
||||||
2 <model> "b" set
|
|
||||||
"a" get "b" get 2array <compose> "c" set
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
[ ] [ "c" get activate-model ] unit-test
|
|
||||||
|
|
||||||
[ { 1 2 } ] [ "c" get model-value ] unit-test
|
|
||||||
|
|
||||||
[ ] [ 3 "b" get set-model ] unit-test
|
|
||||||
|
|
||||||
[ { 1 3 } ] [ "c" get model-value ] unit-test
|
|
||||||
|
|
||||||
[ ] [ { 4 5 } "c" get set-model ] unit-test
|
|
||||||
|
|
||||||
[ { 4 5 } ] [ "c" get model-value ] unit-test
|
|
||||||
|
|
||||||
[ ] [ "c" get deactivate-model ] unit-test
|
|
||||||
|
|
||||||
! Test mapping
|
|
||||||
[ ] [
|
|
||||||
[
|
|
||||||
1 <model> "one" set
|
|
||||||
2 <model> "two" set
|
|
||||||
] H{ } make-assoc
|
|
||||||
<mapping> "m" set
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
[ ] [ "m" get activate-model ] unit-test
|
|
||||||
|
|
||||||
[ H{ { "one" 1 } { "two" 2 } } ] [
|
|
||||||
"m" get model-value
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
[ ] [
|
|
||||||
H{ { "one" 3 } { "two" 4 } }
|
|
||||||
"m" get set-model
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
[ H{ { "one" 3 } { "two" 4 } } ] [
|
|
||||||
"m" get model-value
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
[ H{ { "one" 5 } { "two" 4 } } ] [
|
|
||||||
5 "one" "m" get mapping-assoc at set-model
|
|
||||||
"m" get model-value
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
[ ] [ "m" get deactivate-model ] unit-test
|
|
||||||
|
|
||||||
! Test <range>
|
|
||||||
: setup-range 0 0 0 255 <range> ;
|
|
||||||
|
|
||||||
! clamp-value should not go past range ends
|
|
||||||
[ 0 ] [ -10 setup-range clamp-value ] unit-test
|
|
||||||
[ 255 ] [ 2000 setup-range clamp-value ] unit-test
|
|
||||||
[ 14 ] [ 14 setup-range clamp-value ] unit-test
|
|
||||||
|
|
||||||
! range min/max/page values should be correct
|
|
||||||
[ 0 ] [ setup-range range-page-value ] unit-test
|
|
||||||
[ 0 ] [ setup-range range-min-value ] unit-test
|
|
||||||
[ 255 ] [ setup-range range-max-value ] unit-test
|
|
||||||
|
|
||||||
! should be able to set the value within the range and get back
|
|
||||||
[ 15 ] [ setup-range 15 over set-range-value range-value ] unit-test
|
|
||||||
[ 0 ] [ setup-range -15 over set-range-value range-value ] unit-test
|
|
||||||
[ 255 ] [ setup-range 4000 over set-range-value range-value ] unit-test
|
|
||||||
|
|
||||||
! should be able to change the range min/max/page value
|
|
||||||
[ 1 ] [ setup-range 1 over set-range-page-value range-page-value ] unit-test
|
|
||||||
[ 50 ] [ setup-range 50 over set-range-min-value range-min-value ] unit-test
|
|
||||||
[ 4000 ] [ setup-range 4000 over set-range-max-value range-max-value ] unit-test
|
|
||||||
|
|
||||||
! should be able to move by positive and negative values
|
|
||||||
[ 30 ] [ setup-range 30 over move-by range-value ] unit-test
|
|
||||||
[ 0 ] [ setup-range 30 over move-by -30 over move-by range-value ] unit-test
|
|
||||||
|
|
||||||
! should be able to move by a page of 10
|
|
||||||
[ 10 ] [
|
|
||||||
setup-range 10 over set-range-page-value
|
|
||||||
1 over move-by-page range-value
|
|
||||||
] unit-test
|
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -1,14 +1,21 @@
|
||||||
! Copyright (C) 2006, 2008 Slava Pestov.
|
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: generic kernel math sequences arrays assocs alarms
|
USING: accessors generic kernel math sequences arrays assocs
|
||||||
calendar math.order ;
|
alarms calendar math.order ;
|
||||||
IN: models
|
IN: models
|
||||||
|
|
||||||
TUPLE: model < identity-tuple
|
TUPLE: model < identity-tuple
|
||||||
value connections dependencies ref locked? ;
|
value connections dependencies ref locked? ;
|
||||||
|
|
||||||
|
: new-model ( value class -- model )
|
||||||
|
new
|
||||||
|
swap >>value
|
||||||
|
V{ } clone >>connections
|
||||||
|
V{ } clone >>dependencies
|
||||||
|
0 >>ref ; inline
|
||||||
|
|
||||||
: <model> ( value -- model )
|
: <model> ( value -- model )
|
||||||
V{ } clone V{ } clone 0 f model boa ;
|
model new-model ;
|
||||||
|
|
||||||
M: model hashcode* drop model hashcode* ;
|
M: model hashcode* drop model hashcode* ;
|
||||||
|
|
||||||
|
@ -96,107 +103,6 @@ M: model update-model drop ;
|
||||||
: construct-model ( value class -- instance )
|
: construct-model ( value class -- instance )
|
||||||
>r <model> { set-delegate } r> construct ; inline
|
>r <model> { set-delegate } r> construct ; inline
|
||||||
|
|
||||||
TUPLE: filter model quot ;
|
|
||||||
|
|
||||||
: <filter> ( model quot -- filter )
|
|
||||||
f filter construct-model
|
|
||||||
[ set-filter-quot ] keep
|
|
||||||
[ set-filter-model ] 2keep
|
|
||||||
[ add-dependency ] keep ;
|
|
||||||
|
|
||||||
M: filter model-changed
|
|
||||||
swap model-value over filter-quot call
|
|
||||||
swap set-model ;
|
|
||||||
|
|
||||||
M: filter model-activated dup filter-model swap model-changed ;
|
|
||||||
|
|
||||||
TUPLE: compose ;
|
|
||||||
|
|
||||||
: <compose> ( models -- compose )
|
|
||||||
f compose construct-model
|
|
||||||
swap clone over set-model-dependencies ;
|
|
||||||
|
|
||||||
: composed-value >r model-dependencies r> map ; inline
|
|
||||||
|
|
||||||
: set-composed-value >r model-dependencies r> 2each ; inline
|
|
||||||
|
|
||||||
M: compose model-changed
|
|
||||||
nip
|
|
||||||
dup [ model-value ] composed-value swap delegate set-model ;
|
|
||||||
|
|
||||||
M: compose model-activated dup model-changed ;
|
|
||||||
|
|
||||||
M: compose update-model
|
|
||||||
dup model-value swap [ set-model ] set-composed-value ;
|
|
||||||
|
|
||||||
TUPLE: mapping assoc ;
|
|
||||||
|
|
||||||
: <mapping> ( models -- mapping )
|
|
||||||
f mapping construct-model
|
|
||||||
over values over set-model-dependencies
|
|
||||||
tuck set-mapping-assoc ;
|
|
||||||
|
|
||||||
M: mapping model-changed
|
|
||||||
nip
|
|
||||||
dup mapping-assoc [ model-value ] assoc-map
|
|
||||||
swap delegate set-model ;
|
|
||||||
|
|
||||||
M: mapping model-activated dup model-changed ;
|
|
||||||
|
|
||||||
M: mapping update-model
|
|
||||||
dup model-value swap mapping-assoc
|
|
||||||
[ swapd at set-model ] curry assoc-each ;
|
|
||||||
|
|
||||||
TUPLE: history back forward ;
|
|
||||||
|
|
||||||
: reset-history ( history -- )
|
|
||||||
V{ } clone over set-history-back
|
|
||||||
V{ } clone swap set-history-forward ;
|
|
||||||
|
|
||||||
: <history> ( value -- history )
|
|
||||||
history construct-model dup reset-history ;
|
|
||||||
|
|
||||||
: (add-history) ( history to -- )
|
|
||||||
swap model-value dup [ swap push ] [ 2drop ] if ;
|
|
||||||
|
|
||||||
: go-back/forward ( history to from -- )
|
|
||||||
dup empty?
|
|
||||||
[ 3drop ]
|
|
||||||
[ >r dupd (add-history) r> pop swap set-model ] if ;
|
|
||||||
|
|
||||||
: go-back ( history -- )
|
|
||||||
dup history-forward over history-back go-back/forward ;
|
|
||||||
|
|
||||||
: go-forward ( history -- )
|
|
||||||
dup history-back over history-forward go-back/forward ;
|
|
||||||
|
|
||||||
: add-history ( history -- )
|
|
||||||
dup history-forward delete-all
|
|
||||||
dup history-back (add-history) ;
|
|
||||||
|
|
||||||
TUPLE: delay model timeout alarm ;
|
|
||||||
|
|
||||||
: update-delay-model ( delay -- )
|
|
||||||
dup delay-model model-value swap set-model ;
|
|
||||||
|
|
||||||
: <delay> ( model timeout -- delay )
|
|
||||||
f delay construct-model
|
|
||||||
[ set-delay-timeout ] keep
|
|
||||||
[ set-delay-model ] 2keep
|
|
||||||
[ add-dependency ] keep ;
|
|
||||||
|
|
||||||
: cancel-delay ( delay -- )
|
|
||||||
delay-alarm [ cancel-alarm ] when* ;
|
|
||||||
|
|
||||||
: start-delay ( delay -- )
|
|
||||||
dup [ f over set-delay-alarm update-delay-model ] curry
|
|
||||||
over delay-timeout later
|
|
||||||
swap set-delay-alarm ;
|
|
||||||
|
|
||||||
M: delay model-changed nip dup cancel-delay start-delay ;
|
|
||||||
|
|
||||||
M: delay model-activated update-delay-model ;
|
|
||||||
|
|
||||||
GENERIC: range-value ( model -- value )
|
GENERIC: range-value ( model -- value )
|
||||||
GENERIC: range-page-value ( model -- value )
|
GENERIC: range-page-value ( model -- value )
|
||||||
GENERIC: range-min-value ( model -- value )
|
GENERIC: range-min-value ( model -- value )
|
||||||
|
@ -207,72 +113,6 @@ GENERIC: set-range-page-value ( value model -- )
|
||||||
GENERIC: set-range-min-value ( value model -- )
|
GENERIC: set-range-min-value ( value model -- )
|
||||||
GENERIC: set-range-max-value ( value model -- )
|
GENERIC: set-range-max-value ( value model -- )
|
||||||
|
|
||||||
TUPLE: range ;
|
|
||||||
|
|
||||||
: <range> ( value min max page -- range )
|
|
||||||
4array [ <model> ] map <compose>
|
|
||||||
{ set-delegate } range construct ;
|
|
||||||
|
|
||||||
: range-model ( range -- model ) model-dependencies first ;
|
|
||||||
: range-page ( range -- model ) model-dependencies second ;
|
|
||||||
: range-min ( range -- model ) model-dependencies third ;
|
|
||||||
: range-max ( range -- model ) model-dependencies fourth ;
|
|
||||||
|
|
||||||
: clamp-value ( value range -- newvalue )
|
: clamp-value ( value range -- newvalue )
|
||||||
[ range-min-value max ] keep
|
[ range-min-value max ] keep
|
||||||
range-max-value* min ;
|
range-max-value* min ;
|
||||||
|
|
||||||
M: range range-value
|
|
||||||
[ range-model model-value ] keep clamp-value ;
|
|
||||||
|
|
||||||
M: range range-page-value range-page model-value ;
|
|
||||||
|
|
||||||
M: range range-min-value range-min model-value ;
|
|
||||||
|
|
||||||
M: range range-max-value range-max model-value ;
|
|
||||||
|
|
||||||
M: range range-max-value*
|
|
||||||
dup range-max-value swap range-page-value [-] ;
|
|
||||||
|
|
||||||
M: range set-range-value
|
|
||||||
[ clamp-value ] keep range-model set-model ;
|
|
||||||
|
|
||||||
M: range set-range-page-value range-page set-model ;
|
|
||||||
|
|
||||||
M: range set-range-min-value range-min set-model ;
|
|
||||||
|
|
||||||
M: range set-range-max-value range-max set-model ;
|
|
||||||
|
|
||||||
M: compose range-value
|
|
||||||
[ range-value ] composed-value ;
|
|
||||||
|
|
||||||
M: compose range-page-value
|
|
||||||
[ range-page-value ] composed-value ;
|
|
||||||
|
|
||||||
M: compose range-min-value
|
|
||||||
[ range-min-value ] composed-value ;
|
|
||||||
|
|
||||||
M: compose range-max-value
|
|
||||||
[ range-max-value ] composed-value ;
|
|
||||||
|
|
||||||
M: compose range-max-value*
|
|
||||||
[ range-max-value* ] composed-value ;
|
|
||||||
|
|
||||||
M: compose set-range-value
|
|
||||||
[ clamp-value ] keep
|
|
||||||
[ set-range-value ] set-composed-value ;
|
|
||||||
|
|
||||||
M: compose set-range-page-value
|
|
||||||
[ set-range-page-value ] set-composed-value ;
|
|
||||||
|
|
||||||
M: compose set-range-min-value
|
|
||||||
[ set-range-min-value ] set-composed-value ;
|
|
||||||
|
|
||||||
M: compose set-range-max-value
|
|
||||||
[ set-range-max-value ] set-composed-value ;
|
|
||||||
|
|
||||||
: move-by ( amount range -- )
|
|
||||||
[ range-value + ] keep set-range-value ;
|
|
||||||
|
|
||||||
: move-by-page ( amount range -- )
|
|
||||||
[ range-page-value * ] keep move-by ;
|
|
||||||
|
|
|
@ -0,0 +1,58 @@
|
||||||
|
USING: help.syntax help.markup kernel math classes classes.tuple
|
||||||
|
calendar models ;
|
||||||
|
IN: models.range
|
||||||
|
|
||||||
|
HELP: range
|
||||||
|
{ $class-description "Range models implement the " { $link "range-model-protocol" } " with real numbers as the minimum, current, maximum, and page size. Range models are created with " { $link <range> } "." }
|
||||||
|
{ $notes { $link "ui.gadgets.sliders" } " use range models." } ;
|
||||||
|
|
||||||
|
HELP: range-model
|
||||||
|
{ $values { "range" range } { "model" model } }
|
||||||
|
{ $description "Outputs a model holding a range model's current value." }
|
||||||
|
{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ;
|
||||||
|
|
||||||
|
HELP: range-min
|
||||||
|
{ $values { "range" range } { "model" model } }
|
||||||
|
{ $description "Outputs a model holding a range model's minimum value." }
|
||||||
|
{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ;
|
||||||
|
|
||||||
|
HELP: range-max
|
||||||
|
{ $values { "range" range } { "model" model } }
|
||||||
|
{ $description "Outputs a model holding a range model's maximum value." }
|
||||||
|
{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ;
|
||||||
|
|
||||||
|
HELP: range-page
|
||||||
|
{ $values { "range" range } { "model" model } }
|
||||||
|
{ $description "Outputs a model holding a range model's page size." }
|
||||||
|
{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ;
|
||||||
|
|
||||||
|
HELP: move-by
|
||||||
|
{ $values { "amount" real } { "range" range } }
|
||||||
|
{ $description "Adds a number to a range model's current value." }
|
||||||
|
{ $side-effects "range" } ;
|
||||||
|
|
||||||
|
HELP: move-by-page
|
||||||
|
{ $values { "amount" real } { "range" range } }
|
||||||
|
{ $description "Adds a multiple of the page size to a range model's current value." }
|
||||||
|
{ $side-effects "range" } ;
|
||||||
|
|
||||||
|
ARTICLE: "models-range" "Range models"
|
||||||
|
"Range models ensure their value is a real number within a fixed range."
|
||||||
|
{ $subsection range }
|
||||||
|
{ $subsection <range> }
|
||||||
|
"Range models conform to a protocol for getting and setting the current value, as well as the endpoints of the range."
|
||||||
|
{ $subsection "range-model-protocol" } ;
|
||||||
|
|
||||||
|
ARTICLE: "range-model-protocol" "Range model protocol"
|
||||||
|
"The range model protocol is implemented by the " { $link range } " and " { $link compose } " classes. User-defined models may implement it too."
|
||||||
|
{ $subsection range-value }
|
||||||
|
{ $subsection range-page-value }
|
||||||
|
{ $subsection range-min-value }
|
||||||
|
{ $subsection range-max-value }
|
||||||
|
{ $subsection range-max-value* }
|
||||||
|
{ $subsection set-range-value }
|
||||||
|
{ $subsection set-range-page-value }
|
||||||
|
{ $subsection set-range-min-value }
|
||||||
|
{ $subsection set-range-max-value } ;
|
||||||
|
|
||||||
|
ABOUT: "models-range"
|
|
@ -0,0 +1,36 @@
|
||||||
|
IN: models.range.tests
|
||||||
|
USING: arrays generic kernel math models namespaces sequences assocs
|
||||||
|
tools.test models.range ;
|
||||||
|
|
||||||
|
! Test <range>
|
||||||
|
: setup-range 0 0 0 255 <range> ;
|
||||||
|
|
||||||
|
! clamp-value should not go past range ends
|
||||||
|
[ 0 ] [ -10 setup-range clamp-value ] unit-test
|
||||||
|
[ 255 ] [ 2000 setup-range clamp-value ] unit-test
|
||||||
|
[ 14 ] [ 14 setup-range clamp-value ] unit-test
|
||||||
|
|
||||||
|
! range min/max/page values should be correct
|
||||||
|
[ 0 ] [ setup-range range-page-value ] unit-test
|
||||||
|
[ 0 ] [ setup-range range-min-value ] unit-test
|
||||||
|
[ 255 ] [ setup-range range-max-value ] unit-test
|
||||||
|
|
||||||
|
! should be able to set the value within the range and get back
|
||||||
|
[ 15 ] [ setup-range 15 over set-range-value range-value ] unit-test
|
||||||
|
[ 0 ] [ setup-range -15 over set-range-value range-value ] unit-test
|
||||||
|
[ 255 ] [ setup-range 4000 over set-range-value range-value ] unit-test
|
||||||
|
|
||||||
|
! should be able to change the range min/max/page value
|
||||||
|
[ 1 ] [ setup-range 1 over set-range-page-value range-page-value ] unit-test
|
||||||
|
[ 50 ] [ setup-range 50 over set-range-min-value range-min-value ] unit-test
|
||||||
|
[ 4000 ] [ setup-range 4000 over set-range-max-value range-max-value ] unit-test
|
||||||
|
|
||||||
|
! should be able to move by positive and negative values
|
||||||
|
[ 30 ] [ setup-range 30 over move-by range-value ] unit-test
|
||||||
|
[ 0 ] [ setup-range 30 over move-by -30 over move-by range-value ] unit-test
|
||||||
|
|
||||||
|
! should be able to move by a page of 10
|
||||||
|
[ 10 ] [
|
||||||
|
setup-range 10 over set-range-page-value
|
||||||
|
1 over move-by-page range-value
|
||||||
|
] unit-test
|
|
@ -0,0 +1,41 @@
|
||||||
|
USING: kernel models arrays sequences math math.order
|
||||||
|
models.compose ;
|
||||||
|
IN: models.range
|
||||||
|
|
||||||
|
TUPLE: range ;
|
||||||
|
|
||||||
|
: <range> ( value min max page -- range )
|
||||||
|
4array [ <model> ] map <compose>
|
||||||
|
{ set-delegate } range construct ;
|
||||||
|
|
||||||
|
: range-model ( range -- model ) model-dependencies first ;
|
||||||
|
: range-page ( range -- model ) model-dependencies second ;
|
||||||
|
: range-min ( range -- model ) model-dependencies third ;
|
||||||
|
: range-max ( range -- model ) model-dependencies fourth ;
|
||||||
|
|
||||||
|
M: range range-value
|
||||||
|
[ range-model model-value ] keep clamp-value ;
|
||||||
|
|
||||||
|
M: range range-page-value range-page model-value ;
|
||||||
|
|
||||||
|
M: range range-min-value range-min model-value ;
|
||||||
|
|
||||||
|
M: range range-max-value range-max model-value ;
|
||||||
|
|
||||||
|
M: range range-max-value*
|
||||||
|
dup range-max-value swap range-page-value [-] ;
|
||||||
|
|
||||||
|
M: range set-range-value
|
||||||
|
[ clamp-value ] keep range-model set-model ;
|
||||||
|
|
||||||
|
M: range set-range-page-value range-page set-model ;
|
||||||
|
|
||||||
|
M: range set-range-min-value range-min set-model ;
|
||||||
|
|
||||||
|
M: range set-range-max-value range-max set-model ;
|
||||||
|
|
||||||
|
: move-by ( amount range -- )
|
||||||
|
[ range-value + ] keep set-range-value ;
|
||||||
|
|
||||||
|
: move-by-page ( amount range -- )
|
||||||
|
[ range-page-value * ] keep move-by ;
|
|
@ -3,7 +3,7 @@
|
||||||
USING: threads kernel namespaces continuations combinators
|
USING: threads kernel namespaces continuations combinators
|
||||||
sequences math namespaces.private continuations.private
|
sequences math namespaces.private continuations.private
|
||||||
concurrency.messaging quotations kernel.private words
|
concurrency.messaging quotations kernel.private words
|
||||||
sequences.private assocs models arrays accessors
|
sequences.private assocs models models.filter arrays accessors
|
||||||
generic generic.standard definitions ;
|
generic generic.standard definitions ;
|
||||||
IN: tools.walker
|
IN: tools.walker
|
||||||
|
|
||||||
|
|
|
@ -3,7 +3,8 @@
|
||||||
USING: accessors arrays ui.gadgets ui.gadgets.viewports
|
USING: accessors arrays ui.gadgets ui.gadgets.viewports
|
||||||
ui.gadgets.frames ui.gadgets.grids ui.gadgets.theme
|
ui.gadgets.frames ui.gadgets.grids ui.gadgets.theme
|
||||||
ui.gadgets.sliders ui.gestures kernel math namespaces sequences
|
ui.gadgets.sliders ui.gestures kernel math namespaces sequences
|
||||||
models combinators math.vectors classes.tuple ;
|
models models.range models.compose
|
||||||
|
combinators math.vectors classes.tuple ;
|
||||||
IN: ui.gadgets.scrollers
|
IN: ui.gadgets.scrollers
|
||||||
|
|
||||||
TUPLE: scroller viewport x y follows ;
|
TUPLE: scroller viewport x y follows ;
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
USING: help.markup help.syntax ui.gadgets models ;
|
USING: help.markup help.syntax ui.gadgets models models.range ;
|
||||||
IN: ui.gadgets.sliders
|
IN: ui.gadgets.sliders
|
||||||
|
|
||||||
HELP: elevator
|
HELP: elevator
|
||||||
|
|
|
@ -3,7 +3,8 @@
|
||||||
USING: accessors arrays ui.gestures ui.gadgets ui.gadgets.buttons
|
USING: accessors arrays ui.gestures ui.gadgets ui.gadgets.buttons
|
||||||
ui.gadgets.frames ui.gadgets.grids math.order
|
ui.gadgets.frames ui.gadgets.grids math.order
|
||||||
ui.gadgets.theme ui.render kernel math namespaces sequences
|
ui.gadgets.theme ui.render kernel math namespaces sequences
|
||||||
vectors models math.vectors math.functions quotations colors ;
|
vectors models models.range math.vectors math.functions
|
||||||
|
quotations colors ;
|
||||||
IN: ui.gadgets.sliders
|
IN: ui.gadgets.sliders
|
||||||
|
|
||||||
TUPLE: elevator direction ;
|
TUPLE: elevator direction ;
|
||||||
|
|
|
@ -1,8 +1,8 @@
|
||||||
! Copyright (C) 2007, 2008 Slava Pestov.
|
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors models sequences ui.gadgets.labels
|
USING: accessors models models.delay models.filter
|
||||||
ui.gadgets.theme ui.gadgets.tracks ui.gadgets.worlds ui.gadgets
|
sequences ui.gadgets.labels ui.gadgets.theme ui.gadgets.tracks
|
||||||
ui kernel calendar ;
|
ui.gadgets.worlds ui.gadgets ui kernel calendar ;
|
||||||
IN: ui.gadgets.status-bar
|
IN: ui.gadgets.status-bar
|
||||||
|
|
||||||
: <status-bar> ( model -- gadget )
|
: <status-bar> ( model -- gadget )
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2006, 2008 Slava Pestov.
|
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: debugger ui.tools.workspace help help.topics kernel
|
USING: debugger ui.tools.workspace help help.topics kernel
|
||||||
models ui.commands ui.gadgets ui.gadgets.panes
|
models models.history ui.commands ui.gadgets ui.gadgets.panes
|
||||||
ui.gadgets.scrollers ui.gadgets.tracks ui.gestures
|
ui.gadgets.scrollers ui.gadgets.tracks ui.gestures
|
||||||
ui.gadgets.buttons compiler.units assocs words vocabs
|
ui.gadgets.buttons compiler.units assocs words vocabs
|
||||||
accessors ;
|
accessors ;
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2007 Slava Pestov.
|
! Copyright (C) 2007 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: ui.gadgets colors kernel ui.render namespaces
|
USING: ui.gadgets colors kernel ui.render namespaces
|
||||||
models sequences ui.gadgets.buttons
|
models models.mapping sequences ui.gadgets.buttons
|
||||||
ui.gadgets.packs ui.gadgets.labels tools.deploy.config
|
ui.gadgets.packs ui.gadgets.labels tools.deploy.config
|
||||||
namespaces ui.gadgets.editors ui.gadgets.borders ui.gestures
|
namespaces ui.gadgets.editors ui.gadgets.borders ui.gestures
|
||||||
ui.commands assocs ui.gadgets.tracks ui ui.tools.listener
|
ui.commands assocs ui.gadgets.tracks ui ui.tools.listener
|
||||||
|
|
|
@ -2,12 +2,12 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: arrays assocs combinators continuations documents
|
USING: arrays assocs combinators continuations documents
|
||||||
hashtables io io.styles kernel math math.order math.vectors
|
hashtables io io.styles kernel math math.order math.vectors
|
||||||
models namespaces parser lexer prettyprint quotations sequences
|
models models.delay namespaces parser lexer prettyprint
|
||||||
strings threads listener classes.tuple ui.commands ui.gadgets
|
quotations sequences strings threads listener classes.tuple
|
||||||
ui.gadgets.editors ui.gadgets.presentations ui.gadgets.worlds
|
ui.commands ui.gadgets ui.gadgets.editors
|
||||||
ui.gestures definitions calendar concurrency.flags
|
ui.gadgets.presentations ui.gadgets.worlds ui.gestures
|
||||||
concurrency.mailboxes ui.tools.workspace accessors sets
|
definitions calendar concurrency.flags concurrency.mailboxes
|
||||||
destructors ;
|
ui.tools.workspace accessors sets destructors ;
|
||||||
IN: ui.tools.interactor
|
IN: ui.tools.interactor
|
||||||
|
|
||||||
! If waiting is t, we're waiting for user input, and invoking
|
! If waiting is t, we're waiting for user input, and invoking
|
||||||
|
|
|
@ -2,12 +2,13 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors assocs ui.tools.interactor ui.tools.listener
|
USING: accessors assocs ui.tools.interactor ui.tools.listener
|
||||||
ui.tools.workspace help help.topics io.files io.styles kernel
|
ui.tools.workspace help help.topics io.files io.styles kernel
|
||||||
models namespaces prettyprint quotations sequences sorting
|
models models.delay models.filter namespaces prettyprint
|
||||||
source-files definitions strings tools.completion tools.crossref
|
quotations sequences sorting source-files definitions strings
|
||||||
classes.tuple ui.commands ui.gadgets ui.gadgets.editors
|
tools.completion tools.crossref classes.tuple ui.commands
|
||||||
ui.gadgets.lists ui.gadgets.scrollers ui.gadgets.tracks
|
ui.gadgets ui.gadgets.editors ui.gadgets.lists
|
||||||
ui.gestures ui.operations vocabs words vocabs.loader
|
ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.operations
|
||||||
tools.vocabs unicode.case calendar ui ;
|
vocabs words vocabs.loader tools.vocabs unicode.case calendar ui
|
||||||
|
;
|
||||||
IN: ui.tools.search
|
IN: ui.tools.search
|
||||||
|
|
||||||
TUPLE: live-search field list ;
|
TUPLE: live-search field list ;
|
||||||
|
|
|
@ -2,7 +2,7 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel concurrency.messaging inspector ui.tools.listener
|
USING: kernel concurrency.messaging inspector ui.tools.listener
|
||||||
ui.tools.traceback ui.gadgets.buttons ui.gadgets.status-bar
|
ui.tools.traceback ui.gadgets.buttons ui.gadgets.status-bar
|
||||||
ui.gadgets.tracks ui.commands ui.gadgets models
|
ui.gadgets.tracks ui.commands ui.gadgets models models.filter
|
||||||
ui.tools.workspace ui.gestures ui.gadgets.labels ui threads
|
ui.tools.workspace ui.gestures ui.gadgets.labels ui threads
|
||||||
namespaces tools.walker assocs combinators ;
|
namespaces tools.walker assocs combinators ;
|
||||||
IN: ui.tools.walker
|
IN: ui.tools.walker
|
||||||
|
|
|
@ -207,9 +207,9 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ;
|
||||||
wParam keystroke>gesture <key-up>
|
wParam keystroke>gesture <key-up>
|
||||||
hWnd window-focus send-gesture drop ;
|
hWnd window-focus send-gesture drop ;
|
||||||
|
|
||||||
: set-window-active ( hwnd uMsg wParam lParam ? -- n )
|
:: set-window-active ( hwnd uMsg wParam lParam ? -- n )
|
||||||
>r 4dup r> 2nip nip
|
? hwnd window set-world-active?
|
||||||
swap window set-world-active? DefWindowProc ;
|
hwnd uMsg wParam lParam DefWindowProc ;
|
||||||
|
|
||||||
: handle-wm-syscommand ( hWnd uMsg wParam lParam -- n )
|
: handle-wm-syscommand ( hWnd uMsg wParam lParam -- n )
|
||||||
{
|
{
|
||||||
|
|
Loading…
Reference in New Issue