diff --git a/extra/models/compose/compose-docs.factor b/extra/models/compose/compose-docs.factor new file mode 100755 index 0000000000..8c07b2f09e --- /dev/null +++ b/extra/models/compose/compose-docs.factor @@ -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 } "." +$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 ;" + ": 100 over set-slider-max ;" + " 2array" + "dup make-pile gadget." + "dup [ gadget-model ] map [ unparse ] " + " gadget." + } +} ; + +HELP: +{ $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 } ; + +ABOUT: "models-compose" diff --git a/extra/models/compose/compose-tests.factor b/extra/models/compose/compose-tests.factor new file mode 100755 index 0000000000..25ba001d5d --- /dev/null +++ b/extra/models/compose/compose-tests.factor @@ -0,0 +1,24 @@ +IN: models.compose.tests +USING: arrays generic kernel math models namespaces sequences assocs +tools.test models.compose ; + +! Test compose +[ ] [ + 1 "a" set + 2 "b" set + "a" get "b" get 2array "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 diff --git a/extra/models/compose/compose.factor b/extra/models/compose/compose.factor new file mode 100755 index 0000000000..0dfc65548d --- /dev/null +++ b/extra/models/compose/compose.factor @@ -0,0 +1,49 @@ +USING: models kernel sequences ; +IN: models.compose + +TUPLE: 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 ; diff --git a/extra/models/delay/delay-docs.factor b/extra/models/delay/delay-docs.factor new file mode 100755 index 0000000000..1f7aff1286 --- /dev/null +++ b/extra/models/delay/delay-docs.factor @@ -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 } "." } +{ $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 ;" + ": " + " 0 0 0 100 500 over set-slider-max ;" + " dup gadget." + "gadget-model 1/2 seconds [ number>string ] " + " gadget." + } +} ; + +HELP: +{ $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 } ; + +ABOUT: "models-delay" diff --git a/extra/models/delay/delay.factor b/extra/models/delay/delay.factor new file mode 100755 index 0000000000..40b669d915 --- /dev/null +++ b/extra/models/delay/delay.factor @@ -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 ; + +: ( 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 ; diff --git a/extra/models/filter/filter-docs.factor b/extra/models/filter/filter-docs.factor new file mode 100755 index 0000000000..8c50aac65b --- /dev/null +++ b/extra/models/filter/filter-docs.factor @@ -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 } "." } +{ $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 [ sq ] [ number>string ] " + " 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: +{ $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 } ; + +ABOUT: "models-filter" diff --git a/extra/models/filter/filter-tests.factor b/extra/models/filter/filter-tests.factor new file mode 100755 index 0000000000..bdf3273fae --- /dev/null +++ b/extra/models/filter/filter-tests.factor @@ -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 "x" set +"x" get [ 2 * ] dup "z" set +[ 1+ ] "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 "x" set +"x" get [ sq ] "y" set + +4 "x" get set-model + +"y" get activate-model +[ 16 ] [ "y" get model-value ] unit-test +"y" get deactivate-model diff --git a/extra/models/filter/filter.factor b/extra/models/filter/filter.factor new file mode 100755 index 0000000000..78b1ce09e5 --- /dev/null +++ b/extra/models/filter/filter.factor @@ -0,0 +1,16 @@ +USING: models kernel ; +IN: models.filter + +TUPLE: filter model quot ; + +: ( 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 ; diff --git a/extra/models/history/history-docs.factor b/extra/models/history/history-docs.factor new file mode 100755 index 0000000000..d1577298c2 --- /dev/null +++ b/extra/models/history/history-docs.factor @@ -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 } "." } ; + +HELP: +{ $values { "value" object } { "history" "a new " { $link history } } } +{ $description "Creates a new history model with an initial value." } ; + +{ 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 } +"Recording history:" +{ $subsection add-history } +"Navigating the history:" +{ $subsection go-back } +{ $subsection go-forward } ; + +ABOUT: "models-history" diff --git a/extra/models/history/history-tests.factor b/extra/models/history/history-tests.factor new file mode 100755 index 0000000000..40d1176667 --- /dev/null +++ b/extra/models/history/history-tests.factor @@ -0,0 +1,37 @@ +IN: models.history.tests +USING: arrays generic kernel math models namespaces sequences assocs +tools.test models.history ; + +f "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 + diff --git a/extra/models/history/history.factor b/extra/models/history/history.factor new file mode 100755 index 0000000000..067b76c2ec --- /dev/null +++ b/extra/models/history/history.factor @@ -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 ; + +: ( 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) ; diff --git a/extra/models/mapping/mapping-tests.factor b/extra/models/mapping/mapping-tests.factor new file mode 100755 index 0000000000..43c1883bb1 --- /dev/null +++ b/extra/models/mapping/mapping-tests.factor @@ -0,0 +1,34 @@ +IN: models.mapping.tests +USING: arrays generic kernel math models namespaces sequences assocs +tools.test models.mapping ; + +! Test mapping +[ ] [ + [ + 1 "one" set + 2 "two" set + ] H{ } make-assoc + "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 diff --git a/extra/models/mapping/mapping.factor b/extra/models/mapping/mapping.factor new file mode 100755 index 0000000000..4e12dbccc1 --- /dev/null +++ b/extra/models/mapping/mapping.factor @@ -0,0 +1,20 @@ +USING: models kernel assocs ; +IN: models.mapping + +TUPLE: mapping assoc ; + +: ( 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 ; diff --git a/extra/models/models-docs.factor b/extra/models/models-docs.factor index da275e934a..c31ae3e733 100755 --- a/extra/models/models-docs.factor +++ b/extra/models/models-docs.factor @@ -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 } "." } -{ $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 [ sq ] [ number>string ] " - " 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: -{ $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 } "." -$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 ;" - ": 100 over set-slider-max ;" - " 2array" - "dup make-pile gadget." - "dup [ gadget-model ] map [ unparse ] " - " gadget." - } -} ; - -HELP: -{ $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 } "." } ; - -HELP: -{ $values { "value" object } { "history" "a new " { $link history } } } -{ $description "Creates a new history model with an initial value." } ; - -{ 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 } "." } -{ $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 ;" - ": " - " 0 0 0 100 500 over set-slider-max ;" - " dup gadget." - "gadget-model 1/2 seconds [ number>string ] " - " gadget." - } -} ; - -HELP: -{ $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 } "." } -{ $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 } ; - -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 } ; - -ARTICLE: "models-history" "History models" -"History models record previous values." -{ $subsection history } -{ $subsection } -"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 } ; - -ARTICLE: "models-range" "Range models" -"Range models ensure their value is a real number within a fixed range." -{ $subsection range } -{ $subsection } -"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 } diff --git a/extra/models/models-tests.factor b/extra/models/models-tests.factor index 7964f8929e..637cb8f17a 100755 --- a/extra/models/models-tests.factor +++ b/extra/models/models-tests.factor @@ -31,144 +31,3 @@ T{ model-tester f f } "tester" set "tester" get "model-c" get model-value ] unit-test - -f "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 "x" set -"x" get [ 2 * ] dup "z" set -[ 1+ ] "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 "x" set -"x" get [ sq ] "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 "a" set - 2 "b" set - "a" get "b" get 2array "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 "one" set - 2 "two" set - ] H{ } make-assoc - "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 -: setup-range 0 0 0 255 ; - -! 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 - - diff --git a/extra/models/models.factor b/extra/models/models.factor index 2caf6e9940..48c43d9368 100755 --- a/extra/models/models.factor +++ b/extra/models/models.factor @@ -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 + : ( 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 { set-delegate } r> construct ; inline -TUPLE: filter model quot ; - -: ( 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 ; - -: ( 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 ; - -: ( 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 ; - -: ( 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 ; - -: ( 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 ; - -: ( value min max page -- range ) - 4array [ ] map - { 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 ; diff --git a/extra/models/range/range-docs.factor b/extra/models/range/range-docs.factor new file mode 100755 index 0000000000..6a767b2e13 --- /dev/null +++ b/extra/models/range/range-docs.factor @@ -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 } "." } +{ $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 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" diff --git a/extra/models/range/range-tests.factor b/extra/models/range/range-tests.factor new file mode 100755 index 0000000000..c8a2d1acc6 --- /dev/null +++ b/extra/models/range/range-tests.factor @@ -0,0 +1,36 @@ +IN: models.range.tests +USING: arrays generic kernel math models namespaces sequences assocs +tools.test models.range ; + +! Test +: setup-range 0 0 0 255 ; + +! 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 diff --git a/extra/models/range/range.factor b/extra/models/range/range.factor new file mode 100755 index 0000000000..761e077948 --- /dev/null +++ b/extra/models/range/range.factor @@ -0,0 +1,41 @@ +USING: kernel models arrays sequences math math.order +models.compose ; +IN: models.range + +TUPLE: range ; + +: ( value min max page -- range ) + 4array [ ] map + { 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 ; diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor index 3d7ee035dc..f9055fb6cf 100755 --- a/extra/tools/walker/walker.factor +++ b/extra/tools/walker/walker.factor @@ -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 diff --git a/extra/ui/gadgets/scrollers/scrollers.factor b/extra/ui/gadgets/scrollers/scrollers.factor index e58fbc5925..2492348d56 100755 --- a/extra/ui/gadgets/scrollers/scrollers.factor +++ b/extra/ui/gadgets/scrollers/scrollers.factor @@ -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 ; diff --git a/extra/ui/gadgets/sliders/sliders-docs.factor b/extra/ui/gadgets/sliders/sliders-docs.factor index e5de7c2208..e58e4fe7e9 100755 --- a/extra/ui/gadgets/sliders/sliders-docs.factor +++ b/extra/ui/gadgets/sliders/sliders-docs.factor @@ -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 diff --git a/extra/ui/gadgets/sliders/sliders.factor b/extra/ui/gadgets/sliders/sliders.factor index eb22a5a823..120e8e8a4c 100755 --- a/extra/ui/gadgets/sliders/sliders.factor +++ b/extra/ui/gadgets/sliders/sliders.factor @@ -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 ; diff --git a/extra/ui/gadgets/status-bar/status-bar.factor b/extra/ui/gadgets/status-bar/status-bar.factor index 417826a680..12c365c6a4 100755 --- a/extra/ui/gadgets/status-bar/status-bar.factor +++ b/extra/ui/gadgets/status-bar/status-bar.factor @@ -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 : ( model -- gadget ) diff --git a/extra/ui/tools/browser/browser.factor b/extra/ui/tools/browser/browser.factor index ae39b3e116..5cc955e031 100755 --- a/extra/ui/tools/browser/browser.factor +++ b/extra/ui/tools/browser/browser.factor @@ -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 ; diff --git a/extra/ui/tools/deploy/deploy.factor b/extra/ui/tools/deploy/deploy.factor index f0454f5cc2..12d327ab43 100755 --- a/extra/ui/tools/deploy/deploy.factor +++ b/extra/ui/tools/deploy/deploy.factor @@ -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 diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor index fcd3f9ab22..791d9bcfd7 100755 --- a/extra/ui/tools/interactor/interactor.factor +++ b/extra/ui/tools/interactor/interactor.factor @@ -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 diff --git a/extra/ui/tools/search/search.factor b/extra/ui/tools/search/search.factor index f432027367..d08384913e 100755 --- a/extra/ui/tools/search/search.factor +++ b/extra/ui/tools/search/search.factor @@ -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 ; diff --git a/extra/ui/tools/walker/walker.factor b/extra/ui/tools/walker/walker.factor index 8d205daebf..4398afa3e0 100755 --- a/extra/ui/tools/walker/walker.factor +++ b/extra/ui/tools/walker/walker.factor @@ -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 diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index dda9a1dc0e..f8228b3177 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -207,9 +207,9 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ; wParam keystroke>gesture 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 ) {