Merge branch 'master' of git://factorcode.org/git/factor
Slava Pestov
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
|
||||
{ $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
|
||||
{ { $link model-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." }
|
||||
{ { $link model-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 "value" } " - the value of the model. Use " { $link set-model } " to change the value." }
|
||||
{ { $snippet "connections" } " - a sequence of objects implementing the " { $link model-changed } " generic word, to be notified when the model's value changes." }
|
||||
{ { $snippet "dependencies" } " - a sequence of models which should have this model added to their sequence of connections when activated." }
|
||||
{ { $snippet "ref" } " - a reference count tracking the number of models which depend on this one." }
|
||||
}
|
||||
"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 } "." }
|
||||
{ $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
|
||||
{ $values { "model" model } { "value" object } }
|
||||
{ $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." }
|
||||
{ $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"
|
||||
"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
|
||||
|
|
@ -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:"
|
||||
{ $subsection activate-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" } ;
|
||||
|
||||
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"
|
||||
"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
|
||||
"Models can execute hooks when activated:"
|
||||
{ $subsection model-activated }
|
||||
|
|
|
|||
|
|
@ -31,144 +31,3 @@ T{ model-tester f f } "tester" set
|
|||
"tester" get
|
||||
"model-c" get model-value
|
||||
] 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.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: generic kernel math sequences arrays assocs alarms
|
||||
calendar math.order ;
|
||||
USING: accessors generic kernel math sequences arrays assocs
|
||||
alarms calendar math.order ;
|
||||
IN: models
|
||||
|
||||
TUPLE: model < identity-tuple
|
||||
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 )
|
||||
V{ } clone V{ } clone 0 f model boa ;
|
||||
model new-model ;
|
||||
|
||||
M: model hashcode* drop model hashcode* ;
|
||||
|
||||
|
|
@ -96,107 +103,6 @@ M: model update-model drop ;
|
|||
: construct-model ( value class -- instance )
|
||||
>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-page-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-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 )
|
||||
[ range-min-value max ] keep
|
||||
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
|
||||
sequences math namespaces.private continuations.private
|
||||
concurrency.messaging quotations kernel.private words
|
||||
sequences.private assocs models arrays accessors
|
||||
sequences.private assocs models models.filter arrays accessors
|
||||
generic generic.standard definitions ;
|
||||
IN: tools.walker
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
USING: accessors arrays ui.gadgets ui.gadgets.viewports
|
||||
ui.gadgets.frames ui.gadgets.grids ui.gadgets.theme
|
||||
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
|
||||
|
||||
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
|
||||
|
||||
HELP: elevator
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
USING: accessors arrays ui.gestures ui.gadgets ui.gadgets.buttons
|
||||
ui.gadgets.frames ui.gadgets.grids math.order
|
||||
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
|
||||
|
||||
TUPLE: elevator direction ;
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors models sequences ui.gadgets.labels
|
||||
ui.gadgets.theme ui.gadgets.tracks ui.gadgets.worlds ui.gadgets
|
||||
ui kernel calendar ;
|
||||
USING: accessors models models.delay models.filter
|
||||
sequences ui.gadgets.labels ui.gadgets.theme ui.gadgets.tracks
|
||||
ui.gadgets.worlds ui.gadgets ui kernel calendar ;
|
||||
IN: ui.gadgets.status-bar
|
||||
|
||||
: <status-bar> ( model -- gadget )
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
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.buttons compiler.units assocs words vocabs
|
||||
accessors ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
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
|
||||
namespaces ui.gadgets.editors ui.gadgets.borders ui.gestures
|
||||
ui.commands assocs ui.gadgets.tracks ui ui.tools.listener
|
||||
|
|
|
|||
|
|
@ -2,12 +2,12 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs combinators continuations documents
|
||||
hashtables io io.styles kernel math math.order math.vectors
|
||||
models namespaces parser lexer prettyprint quotations sequences
|
||||
strings threads listener classes.tuple ui.commands ui.gadgets
|
||||
ui.gadgets.editors ui.gadgets.presentations ui.gadgets.worlds
|
||||
ui.gestures definitions calendar concurrency.flags
|
||||
concurrency.mailboxes ui.tools.workspace accessors sets
|
||||
destructors ;
|
||||
models models.delay namespaces parser lexer prettyprint
|
||||
quotations sequences strings threads listener classes.tuple
|
||||
ui.commands ui.gadgets ui.gadgets.editors
|
||||
ui.gadgets.presentations ui.gadgets.worlds ui.gestures
|
||||
definitions calendar concurrency.flags concurrency.mailboxes
|
||||
ui.tools.workspace accessors sets destructors ;
|
||||
IN: ui.tools.interactor
|
||||
|
||||
! 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.
|
||||
USING: accessors assocs ui.tools.interactor ui.tools.listener
|
||||
ui.tools.workspace help help.topics io.files io.styles kernel
|
||||
models namespaces prettyprint quotations sequences sorting
|
||||
source-files definitions strings tools.completion tools.crossref
|
||||
classes.tuple ui.commands ui.gadgets ui.gadgets.editors
|
||||
ui.gadgets.lists ui.gadgets.scrollers ui.gadgets.tracks
|
||||
ui.gestures ui.operations vocabs words vocabs.loader
|
||||
tools.vocabs unicode.case calendar ui ;
|
||||
models models.delay models.filter namespaces prettyprint
|
||||
quotations sequences sorting source-files definitions strings
|
||||
tools.completion tools.crossref classes.tuple ui.commands
|
||||
ui.gadgets ui.gadgets.editors ui.gadgets.lists
|
||||
ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.operations
|
||||
vocabs words vocabs.loader tools.vocabs unicode.case calendar ui
|
||||
;
|
||||
IN: ui.tools.search
|
||||
|
||||
TUPLE: live-search field list ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel concurrency.messaging inspector ui.tools.listener
|
||||
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
|
||||
namespaces tools.walker assocs combinators ;
|
||||
IN: ui.tools.walker
|
||||
|
|
|
|||
|
|
@ -207,9 +207,9 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ;
|
|||
wParam keystroke>gesture <key-up>
|
||||
hWnd window-focus send-gesture drop ;
|
||||
|
||||
: set-window-active ( hwnd uMsg wParam lParam ? -- n )
|
||||
>r 4dup r> 2nip nip
|
||||
swap window set-world-active? DefWindowProc ;
|
||||
:: set-window-active ( hwnd uMsg wParam lParam ? -- n )
|
||||
? hwnd window set-world-active?
|
||||
hwnd uMsg wParam lParam DefWindowProc ;
|
||||
|
||||
: handle-wm-syscommand ( hWnd uMsg wParam lParam -- n )
|
||||
{
|
||||
|
|
|
|||
Loading…
Reference in New Issue