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

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

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

extra/models/compose/compose.factor

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

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

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 ;
+
+: <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 ;

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

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

extra/models/filter/filter.factor

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

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

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

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 ;
+
+: <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) ;

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

extra/models/mapping/mapping.factor

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

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." }
+        { { $snippet "value" } " - the value of the model. Use " { $link set-model } " to change the value." }
-        { { $link model-connections } " - a sequence of objects implementing the " { $link model-changed } " generic word, to be notified when the model's value changes." }
+        { { $snippet "connections" } " - a sequence of objects implementing the " { $link model-changed } " generic word, to be notified when the model's value changes." }
-        { { $link model-dependencies } " - a sequence of models which should have this model added to their sequence of connections when activated." }
+        { { $snippet "dependencies" } " - a sequence of models which should have this model added to their sequence of connections when activated." }
-        { { $link model-ref } " - a reference count tracking the number of models which depend on this one." }
+        { { $snippet "ref" } " - a reference count tracking the number of models which depend on this one." }
     }
 "Other classes may delegate to " { $link model } "."
 } ;
@@ -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 }

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

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
+USING: accessors generic kernel math sequences arrays assocs
-calendar math.order ;
+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 ;

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

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

extra/models/range/range.factor

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

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
 

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 ;

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

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 ;

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
+USING: accessors models models.delay models.filter
-ui.gadgets.theme ui.gadgets.tracks ui.gadgets.worlds ui.gadgets
+sequences ui.gadgets.labels ui.gadgets.theme ui.gadgets.tracks
-ui kernel calendar ;
+ui.gadgets.worlds ui.gadgets ui kernel calendar ;
 IN: ui.gadgets.status-bar
 
 : <status-bar> ( model -- gadget )

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 ;

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

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
+models models.delay namespaces parser lexer prettyprint
-strings threads listener classes.tuple ui.commands ui.gadgets
+quotations sequences strings threads listener classes.tuple
-ui.gadgets.editors ui.gadgets.presentations ui.gadgets.worlds
+ui.commands ui.gadgets ui.gadgets.editors
-ui.gestures definitions calendar concurrency.flags
+ui.gadgets.presentations ui.gadgets.worlds ui.gestures
-concurrency.mailboxes ui.tools.workspace accessors sets
+definitions calendar concurrency.flags concurrency.mailboxes
-destructors ;
+ui.tools.workspace accessors sets destructors ;
 IN: ui.tools.interactor
 
 ! If waiting is t, we're waiting for user input, and invoking

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
+models models.delay models.filter namespaces prettyprint
-source-files definitions strings tools.completion tools.crossref
+quotations sequences sorting source-files definitions strings
-classes.tuple ui.commands ui.gadgets ui.gadgets.editors
+tools.completion tools.crossref classes.tuple ui.commands
-ui.gadgets.lists ui.gadgets.scrollers ui.gadgets.tracks
+ui.gadgets ui.gadgets.editors ui.gadgets.lists
-ui.gestures ui.operations vocabs words vocabs.loader
+ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.operations
-tools.vocabs unicode.case calendar ui ;
+vocabs words vocabs.loader tools.vocabs unicode.case calendar ui
+;
 IN: ui.tools.search
 
 TUPLE: live-search field list ;

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

extra/ui/windows/windows.factor

@@ -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 )
+:: set-window-active ( hwnd uMsg wParam lParam ? -- n )
-    >r 4dup r> 2nip nip
+    ? hwnd window set-world-active?
-    swap window set-world-active? DefWindowProc ;
+    hwnd uMsg wParam lParam DefWindowProc ;
 
 : handle-wm-syscommand ( hWnd uMsg wParam lParam -- n )
     {