Merge branch 'master' of git://factorcode.org/git/factor

db4
Slava Pestov 2008-07-05 05:04:18 -05:00
commit 0f535da33f
30 changed files with 559 additions and 503 deletions

View File

@ -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"

View File

@ -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

View File

@ -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 ;

View File

@ -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"

25
extra/models/delay/delay.factor Executable file
View File

@ -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 ;

View File

@ -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"

View File

@ -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

View File

@ -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 ;

View File

@ -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"

View File

@ -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

View File

@ -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) ;

View File

@ -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

View File

@ -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 ;

View File

@ -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 }

View File

@ -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

View File

@ -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 ;

View File

@ -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"

View File

@ -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

41
extra/models/range/range.factor Executable file
View File

@ -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 ;

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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 ;

View File

@ -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 )

View File

@ -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 ;

View File

@ -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

View File

@ -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

View File

@ -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 ;

View File

@ -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

View File

@ -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 )
{