From 0b2300cedf4ac808fe6bfdcdac1ce33d0f427fb6 Mon Sep 17 00:00:00 2001
From: "U-SLAVA-DFB8FF805\\Slava" <Slava@slava-dfb8ff805.(none)>
Date: Fri, 4 Jul 2008 17:58:37 -0500
Subject: [PATCH 01/17] Split up models vocabulary
---
extra/models/compose/compose-docs.factor | 31 +++
extra/models/compose/compose-tests.factor | 24 +++
extra/models/compose/compose.factor | 49 +++++
extra/models/delay/delay-docs.factor | 29 +++
extra/models/delay/delay.factor | 25 +++
extra/models/filter/filter-docs.factor | 27 +++
extra/models/filter/filter-tests.factor | 24 +++
extra/models/filter/filter.factor | 16 ++
extra/models/history/history-docs.factor | 36 ++++
extra/models/history/history-tests.factor | 37 ++++
extra/models/history/history.factor | 29 +++
extra/models/mapping/mapping-tests.factor | 34 ++++
extra/models/mapping/mapping.factor | 20 ++
extra/models/models-docs.factor | 172 +----------------
extra/models/models-tests.factor | 141 --------------
extra/models/models.factor | 180 +-----------------
extra/models/range/range-docs.factor | 58 ++++++
extra/models/range/range-tests.factor | 36 ++++
extra/models/range/range.factor | 41 ++++
extra/tools/walker/walker.factor | 2 +-
extra/ui/gadgets/scrollers/scrollers.factor | 3 +-
extra/ui/gadgets/sliders/sliders-docs.factor | 2 +-
extra/ui/gadgets/sliders/sliders.factor | 3 +-
extra/ui/gadgets/status-bar/status-bar.factor | 6 +-
extra/ui/tools/browser/browser.factor | 2 +-
extra/ui/tools/deploy/deploy.factor | 2 +-
extra/ui/tools/interactor/interactor.factor | 12 +-
extra/ui/tools/search/search.factor | 13 +-
extra/ui/tools/walker/walker.factor | 2 +-
extra/ui/windows/windows.factor | 6 +-
30 files changed, 559 insertions(+), 503 deletions(-)
create mode 100755 extra/models/compose/compose-docs.factor
create mode 100755 extra/models/compose/compose-tests.factor
create mode 100755 extra/models/compose/compose.factor
create mode 100755 extra/models/delay/delay-docs.factor
create mode 100755 extra/models/delay/delay.factor
create mode 100755 extra/models/filter/filter-docs.factor
create mode 100755 extra/models/filter/filter-tests.factor
create mode 100755 extra/models/filter/filter.factor
create mode 100755 extra/models/history/history-docs.factor
create mode 100755 extra/models/history/history-tests.factor
create mode 100755 extra/models/history/history.factor
create mode 100755 extra/models/mapping/mapping-tests.factor
create mode 100755 extra/models/mapping/mapping.factor
create mode 100755 extra/models/range/range-docs.factor
create mode 100755 extra/models/range/range-tests.factor
create mode 100755 extra/models/range/range.factor
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 <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"
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 <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
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 ;
+
+: <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 <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"
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 ;
+
+: <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 ;
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 <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"
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 <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
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 ;
+
+: <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 ;
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 <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"
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> "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 ;
+
+: <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) ;
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 <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
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 ;
+
+: <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 ;
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 <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 }
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> "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
-
-
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
+
: <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 ;
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 <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"
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 <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
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 ;
+
+: <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 ;
diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor
index 07a5759af2..f3cfb88cef 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
: <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 <key-up>
hWnd window-focus send-gesture drop ;
-: set-window-active ( hwnd uMsg wParam lParam ? -- n )
- >r 4dup r> 2nip nip
- swap window set-world-active? DefWindowProc ;
+:: set-window-active ( hwnd uMsg wParam lParam ? -- n )
+ ? hwnd window set-world-active?
+ hwnd uMsg wParam lParam DefWindowProc ;
: handle-wm-syscommand ( hWnd uMsg wParam lParam -- n )
{
From 86f476a23db20a8bdd15978c1d415be7ed8159d3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 4 Jul 2008 22:36:55 -0500
Subject: [PATCH 02/17] Fix bug in <displaced-alien> found by Joe
---
core/alien/alien-tests.factor | 6 +++++-
vm/alien.c | 2 +-
2 files changed, 6 insertions(+), 2 deletions(-)
diff --git a/core/alien/alien-tests.factor b/core/alien/alien-tests.factor
index 9be2885888..5a880fa5a9 100755
--- a/core/alien/alien-tests.factor
+++ b/core/alien/alien-tests.factor
@@ -1,5 +1,5 @@
IN: alien.tests
-USING: alien alien.accessors alien.syntax byte-arrays arrays
+USING: accessors alien alien.accessors alien.syntax byte-arrays arrays
kernel kernel.private namespaces tools.test sequences libc math
system prettyprint layouts ;
@@ -65,6 +65,10 @@ cell 8 = [
[ f ] [ 0 B{ 1 2 3 } <displaced-alien> pinned-c-ptr? ] unit-test
+[ f ] [ 0 B{ 1 2 3 } <displaced-alien> 1 swap <displaced-alien> pinned-c-ptr? ] unit-test
+
+[ t ] [ 0 B{ 1 2 3 } <displaced-alien> 1 swap <displaced-alien> underlying>> byte-array? ] unit-test
+
[ "( displaced alien )" ] [ 0 B{ 1 2 3 } <displaced-alien> unparse ] unit-test
[ f ] [ DLL" fadfasdfsada" dll-valid? ] unit-test
diff --git a/vm/alien.c b/vm/alien.c
index 7fdf9ccdb2..5b4ff3b832 100755
--- a/vm/alien.c
+++ b/vm/alien.c
@@ -62,7 +62,7 @@ CELL allot_alien(CELL delegate, CELL displacement)
{
F_ALIEN *delegate_alien = untag_object(delegate);
displacement += delegate_alien->displacement;
- alien->alien = F;
+ alien->alien = delegate_alien->alien;
}
else
alien->alien = delegate;
From bae00e8bab84775d844ed8757e7abf861fc55987 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 4 Jul 2008 23:03:03 -0500
Subject: [PATCH 03/17] Better optimizer report
---
extra/reports/optimizer/optimizer.factor | 27 ++++++++++++++++++------
1 file changed, 20 insertions(+), 7 deletions(-)
diff --git a/extra/reports/optimizer/optimizer.factor b/extra/reports/optimizer/optimizer.factor
index 5016371052..ec3668b83b 100755
--- a/extra/reports/optimizer/optimizer.factor
+++ b/extra/reports/optimizer/optimizer.factor
@@ -2,20 +2,31 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs words sequences arrays compiler
tools.time io.styles io prettyprint vocabs kernel sorting
-generator optimizer math math.order ;
+generator optimizer math math.order math.statistics combinators ;
IN: report.optimizer
: count-optimization-passes ( nodes n -- n )
>r optimize-1
[ r> 1+ count-optimization-passes ] [ drop r> ] if ;
-: results
- [ [ second ] prepose compare ] curry sort 20 tail*
- print
+: table. ( alist -- )
+ 20 short tail*
standard-table-style
[
[ [ [ pprint-cell ] each ] with-row ] each
- ] tabular-output ; inline
+ ] tabular-output ;
+
+: results ( results quot title -- )
+ print
+ [ second ] prepose
+ [ [ compare ] curry sort table. ]
+ [
+ map
+ [ "Mean: " write mean >float . ]
+ [ "Median: " write median >float . ]
+ [ "Standard deviation: " write std >float . ]
+ tri
+ ] 2bi ; inline
: optimizer-measurements ( -- alist )
all-words [ compiled>> ] filter
@@ -26,8 +37,10 @@ IN: report.optimizer
] { } map>assoc ;
: optimizer-measurements. ( alist -- )
- [ [ first ] "Worst number of optimizer passes:" results ]
- [ [ second ] "Worst compile times:" results ] bi ;
+ {
+ [ [ first ] "Optimizer passes:" results ]
+ [ [ second ] "Compile times:" results ]
+ } cleave ;
: optimizer-report ( -- )
optimizer-measurements optimizer-measurements. ;
From b0d11073d693095018e31aa0d30c4ab2f65e75e8 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 5 Jul 2008 00:59:28 -0500
Subject: [PATCH 04/17] Fix step-into on generic words and call-next-method in
walker
---
core/generic/standard/standard-tests.factor | 8 ++++++++
core/generic/standard/standard.factor | 4 +++-
extra/tools/walker/walker-tests.factor | 6 +++++-
extra/tools/walker/walker.factor | 4 ++++
4 files changed, 20 insertions(+), 2 deletions(-)
diff --git a/core/generic/standard/standard-tests.factor b/core/generic/standard/standard-tests.factor
index 9cee497d6d..54fc3c8ca3 100644
--- a/core/generic/standard/standard-tests.factor
+++ b/core/generic/standard/standard-tests.factor
@@ -309,3 +309,11 @@ M: xref-tuple-2 xref-test (xref-test) ;
\ xref-test
\ xref-tuple-2 \ xref-test method [ usage unique ] closure key?
] unit-test
+
+[ t ] [
+ { } \ nth effective-method nip \ sequence \ nth method eq?
+] unit-test
+
+[ t ] [
+ \ + \ nth effective-method nip dup \ nth "default-method" word-prop eq? and
+] unit-test
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index 89c2a2a396..f8b3c00c31 100644
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -105,7 +105,9 @@ ERROR: no-next-method class generic ;
] [ ] make ;
: single-effective-method ( obj word -- method )
- [ order [ instance? ] with find-last nip ] keep method ;
+ [ [ order [ instance? ] with find-last nip ] keep method ]
+ [ "default-method" word-prop ]
+ bi or ;
TUPLE: standard-combination # ;
diff --git a/extra/tools/walker/walker-tests.factor b/extra/tools/walker/walker-tests.factor
index 2d4a6c3396..7f154a4dbf 100755
--- a/extra/tools/walker/walker-tests.factor
+++ b/extra/tools/walker/walker-tests.factor
@@ -1,6 +1,7 @@
USING: tools.walker io io.streams.string kernel math
math.private namespaces prettyprint sequences tools.test
-continuations math.parser threads arrays tools.walker.debug ;
+continuations math.parser threads arrays tools.walker.debug
+generic.standard ;
IN: tools.walker.tests
[ { } ] [
@@ -97,6 +98,9 @@ IN: tools.walker.tests
[ { 6 } ]
[ [ [ 3 throw ] [ 2 * ] recover ] test-walker ] unit-test
+[ { T{ no-method f + nth } } ]
+[ [ [ 0 \ + nth ] [ ] recover ] test-walker ] unit-test
+
[ { } ] [
[ "a" "b" set "c" "d" set [ ] test-walker ] with-scope
] unit-test
diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor
index 07a5759af2..3d7ee035dc 100755
--- a/extra/tools/walker/walker.factor
+++ b/extra/tools/walker/walker.factor
@@ -83,6 +83,9 @@ M: object add-breakpoint ;
: (step-into-continuation) ( -- )
continuation callstack >>call break ;
+: (step-into-call-next-method) ( class generic -- )
+ next-method-quot (step-into-quot) ;
+
! Messages sent to walker thread
SYMBOL: step
SYMBOL: step-out
@@ -132,6 +135,7 @@ SYMBOL: +stopped+
{ if [ (step-into-if) ] }
{ dispatch [ (step-into-dispatch) ] }
{ continuation [ (step-into-continuation) ] }
+ { (call-next-method) [ (step-into-call-next-method) ] }
} [ "step-into" set-word-prop ] assoc-each
{
From 44c1c1f679c32e069d07d61c0af15e1b6946a19d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 5 Jul 2008 00:59:39 -0500
Subject: [PATCH 05/17] Move tuple-class to classes.tuple where it belongs
---
core/classes/algebra/algebra.factor | 106 ++++++------------
core/classes/builtin/builtin.factor | 26 ++++-
core/classes/classes-docs.factor | 4 -
core/classes/classes.factor | 3 -
core/classes/intersection/intersection.factor | 2 +-
core/classes/predicate/predicate.factor | 10 +-
core/classes/tuple/tuple-docs.factor | 4 +
core/classes/tuple/tuple.factor | 17 ++-
core/classes/union/union.factor | 2 +-
core/generator/registers/registers.factor | 2 +-
core/slots/slots-docs.factor | 2 +-
extra/delegate/delegate.factor | 6 +-
12 files changed, 93 insertions(+), 91 deletions(-)
diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor
index b7e4bebe15..9dbe72d9cb 100755
--- a/core/classes/algebra/algebra.factor
+++ b/core/classes/algebra/algebra.factor
@@ -1,10 +1,22 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel classes classes.builtin combinators accessors
-sequences arrays vectors assocs namespaces words sorting layouts
-math hashtables kernel.private sets math.order ;
+USING: kernel classes combinators accessors sequences arrays
+vectors assocs namespaces words sorting layouts math hashtables
+kernel.private sets math.order ;
IN: classes.algebra
+TUPLE: anonymous-union members ;
+
+C: <anonymous-union> anonymous-union
+
+TUPLE: anonymous-intersection participants ;
+
+C: <anonymous-intersection> anonymous-intersection
+
+TUPLE: anonymous-complement class ;
+
+C: <anonymous-complement> anonymous-complement
+
: 2cache ( key1 key2 assoc quot -- value )
>r >r 2array r> [ first2 ] r> compose cache ; inline
@@ -18,10 +30,19 @@ DEFER: (class-not)
: class-not ( class -- complement )
class-not-cache get [ (class-not) ] cache ;
-DEFER: (classes-intersect?) ( first second -- ? )
+GENERIC: (classes-intersect?) ( first second -- ? )
+
+: normalize-class ( class -- class' )
+ {
+ { [ dup members ] [ members <anonymous-union> ] }
+ { [ dup participants ] [ participants <anonymous-intersection> ] }
+ [ ]
+ } cond ;
: classes-intersect? ( first second -- ? )
- classes-intersect-cache get [ (classes-intersect?) ] 2cache ;
+ classes-intersect-cache get [
+ normalize-class (classes-intersect?)
+ ] 2cache ;
DEFER: (class-and)
@@ -33,18 +54,6 @@ DEFER: (class-or)
: class-or ( first second -- class )
class-or-cache get [ (class-or) ] 2cache ;
-TUPLE: anonymous-union members ;
-
-C: <anonymous-union> anonymous-union
-
-TUPLE: anonymous-intersection participants ;
-
-C: <anonymous-intersection> anonymous-intersection
-
-TUPLE: anonymous-complement class ;
-
-C: <anonymous-complement> anonymous-complement
-
: superclass<= ( first second -- ? )
>r superclass r> class<= ;
@@ -63,13 +72,6 @@ C: <anonymous-complement> anonymous-complement
: anonymous-complement<= ( first second -- ? )
[ class>> ] bi@ swap class<= ;
-: normalize-class ( class -- class' )
- {
- { [ dup members ] [ members <anonymous-union> ] }
- { [ dup participants ] [ participants <anonymous-intersection> ] }
- [ ]
- } cond ;
-
: normalize-complement ( class -- class' )
class>> normalize-class {
{ [ dup anonymous-union? ] [
@@ -116,40 +118,15 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
} cond
] if ;
-: anonymous-union-intersect? ( first second -- ? )
+M: anonymous-union (classes-intersect?)
members>> [ classes-intersect? ] with contains? ;
-: anonymous-intersection-intersect? ( first second -- ? )
+M: anonymous-intersection (classes-intersect?)
participants>> [ classes-intersect? ] with all? ;
-: anonymous-complement-intersect? ( first second -- ? )
+M: anonymous-complement (classes-intersect?)
class>> class<= not ;
-: tuple-class-intersect? ( first second -- ? )
- {
- { [ over tuple eq? ] [ 2drop t ] }
- { [ over builtin-class? ] [ 2drop f ] }
- { [ over tuple-class? ] [ [ class<= ] [ swap class<= ] 2bi or ] }
- [ swap classes-intersect? ]
- } cond ;
-
-: builtin-class-intersect? ( first second -- ? )
- {
- { [ 2dup eq? ] [ 2drop t ] }
- { [ over builtin-class? ] [ 2drop f ] }
- [ swap classes-intersect? ]
- } cond ;
-
-: (classes-intersect?) ( first second -- ? )
- normalize-class {
- { [ dup anonymous-union? ] [ anonymous-union-intersect? ] }
- { [ dup anonymous-intersection? ] [ anonymous-intersection-intersect? ] }
- { [ dup anonymous-complement? ] [ anonymous-complement-intersect? ] }
- { [ dup tuple-class? ] [ tuple-class-intersect? ] }
- { [ dup builtin-class? ] [ builtin-class-intersect? ] }
- { [ dup superclass ] [ superclass classes-intersect? ] }
- } cond ;
-
: anonymous-union-and ( first second -- class )
members>> [ class-and ] with map <anonymous-union> ;
@@ -225,26 +202,13 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
tuck [ class<= ] with all? [ peek ] [ drop f ] if
] if ;
-DEFER: (flatten-class)
-DEFER: flatten-builtin-class
+GENERIC: (flatten-class) ( class -- )
-: flatten-intersection-class ( class -- )
- participants [ flatten-builtin-class ] map
- dup empty? [
- drop builtins get [ (flatten-class) ] each
- ] [
- unclip [ assoc-intersect ] reduce [ swap set ] assoc-each
- ] if ;
+M: anonymous-union (flatten-class)
+ members>> [ (flatten-class) ] each ;
-: (flatten-class) ( class -- )
- {
- { [ dup tuple-class? ] [ dup set ] }
- { [ dup builtin-class? ] [ dup set ] }
- { [ dup members ] [ members [ (flatten-class) ] each ] }
- { [ dup participants ] [ flatten-intersection-class ] }
- { [ dup superclass ] [ superclass (flatten-class) ] }
- [ drop ]
- } cond ;
+M: word (flatten-class)
+ normalize-class (flatten-class) ;
: flatten-class ( class -- assoc )
[ (flatten-class) ] H{ } make-assoc ;
@@ -258,7 +222,7 @@ DEFER: flatten-builtin-class
flatten-builtin-class keys
[ "type" word-prop ] map natural-sort ;
-: class-tags ( class -- tag/f )
+: class-tags ( class -- seq )
class-types [
dup num-tags get >=
[ drop \ hi-tag tag-number ] when
diff --git a/core/classes/builtin/builtin.factor b/core/classes/builtin/builtin.factor
index acbbc5e841..f349d0a126 100644
--- a/core/classes/builtin/builtin.factor
+++ b/core/classes/builtin/builtin.factor
@@ -1,7 +1,8 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: classes words kernel kernel.private namespaces
-sequences math math.private ;
+USING: accessors classes classes.algebra words kernel
+kernel.private namespaces sequences math math.private
+combinators assocs ;
IN: classes.builtin
SYMBOL: builtins
@@ -31,3 +32,24 @@ M: builtin-class rank-class drop 0 ;
M: builtin-class instance?
class>type builtin-instance? ;
+
+M: builtin-class (flatten-class) dup set ;
+
+M: builtin-class (classes-intersect?)
+ {
+ { [ 2dup eq? ] [ 2drop t ] }
+ { [ over builtin-class? ] [ 2drop f ] }
+ [ swap classes-intersect? ]
+ } cond ;
+
+M: anonymous-intersection (flatten-class)
+ participants>>
+ participants [ flatten-builtin-class ] map
+ dup empty? [
+ drop builtins get sift [ (flatten-class) ] each
+ ] [
+ unclip [ assoc-intersect ] reduce [ swap set ] assoc-each
+ ] if ;
+
+M: anonymous-complement (flatten-class)
+ drop builtins get sift [ (flatten-class) ] each ;
diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor
index 5f02212bad..fcad00bb18 100755
--- a/core/classes/classes-docs.factor
+++ b/core/classes/classes-docs.factor
@@ -65,10 +65,6 @@ HELP: classes
{ $values { "seq" "a sequence of class words" } }
{ $description "Finds all class words in the dictionary." } ;
-HELP: tuple-class
-{ $class-description "The class of tuple class words." }
-{ $examples { $example "USING: classes prettyprint ;" "IN: scratchpad" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ;
-
HELP: update-map
{ $var-description "Assoc mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ;
diff --git a/core/classes/classes.factor b/core/classes/classes.factor
index 56c3b0a0ab..34f2fcf196 100755
--- a/core/classes/classes.factor
+++ b/core/classes/classes.factor
@@ -32,9 +32,6 @@ SYMBOL: implementors-map
PREDICATE: class < word
"class" word-prop ;
-PREDICATE: tuple-class < class
- "metaclass" word-prop tuple-class eq? ;
-
: classes ( -- seq ) implementors-map get keys ;
: predicate-word ( word -- predicate )
diff --git a/core/classes/intersection/intersection.factor b/core/classes/intersection/intersection.factor
index 0eae1b62d3..5df580d82f 100644
--- a/core/classes/intersection/intersection.factor
+++ b/core/classes/intersection/intersection.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: words sequences kernel assocs combinators classes
-namespaces arrays math quotations ;
+classes.algebra classes.builtin namespaces arrays math quotations ;
IN: classes.intersection
PREDICATE: intersection-class < class
diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor
index 3067b7d9dd..e6d6b5a0d4 100755
--- a/core/classes/predicate/predicate.factor
+++ b/core/classes/predicate/predicate.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: classes kernel namespaces words sequences quotations
-arrays kernel.private assocs combinators ;
+USING: classes classes.algebra kernel namespaces words sequences
+quotations arrays kernel.private assocs combinators ;
IN: classes.predicate
PREDICATE: predicate-class < class
@@ -51,3 +51,9 @@ M: predicate-class rank-class drop 1 ;
M: predicate-class instance?
2dup superclass instance?
[ predicate-instance? ] [ 2drop f ] if ;
+
+M: predicate-class (flatten-class)
+ superclass (flatten-class) ;
+
+M: predicate-class (classes-intersect?)
+ superclass classes-intersect? ;
diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor
index 8c2525731e..fd8b450eed 100755
--- a/core/classes/tuple/tuple-docs.factor
+++ b/core/classes/tuple/tuple-docs.factor
@@ -332,6 +332,10 @@ $nl
ABOUT: "tuples"
+HELP: tuple-class
+{ $class-description "The class of tuple class words." }
+{ $examples { $example "USING: classes prettyprint ;" "IN: scratchpad" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ;
+
HELP: tuple=
{ $values { "tuple1" tuple } { "tuple2" tuple } { "?" "a boolean" } }
{ $description "Low-level tuple equality test. User code should use " { $link = } " instead." }
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 83d85b68d8..e85905a551 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -3,10 +3,13 @@
USING: arrays definitions hashtables kernel kernel.private math
namespaces sequences sequences.private strings vectors words
quotations memory combinators generic classes classes.algebra
-classes.private slots.deprecated slots.private slots
-compiler.units math.private accessors assocs effects ;
+classes.builtin classes.private slots.deprecated slots.private
+slots compiler.units math.private accessors assocs effects ;
IN: classes.tuple
+PREDICATE: tuple-class < class
+ "metaclass" word-prop tuple-class eq? ;
+
M: tuple class 1 slot 2 slot { word } declare ;
ERROR: not-a-tuple object ;
@@ -289,6 +292,16 @@ M: tuple-class rank-class drop 0 ;
M: tuple-class instance?
dup tuple-layout echelon>> tuple-instance? ;
+M: tuple-class (flatten-class) dup set ;
+
+M: tuple-class (classes-intersect?)
+ {
+ { [ over tuple eq? ] [ 2drop t ] }
+ { [ over builtin-class? ] [ 2drop f ] }
+ { [ over tuple-class? ] [ [ class<= ] [ swap class<= ] 2bi or ] }
+ [ swap classes-intersect? ]
+ } cond ;
+
M: tuple clone
(clone) dup delegate clone over set-delegate ;
diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor
index 6ae4e1bdc3..e3deb25e7a 100755
--- a/core/classes/union/union.factor
+++ b/core/classes/union/union.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: words sequences kernel assocs combinators classes
-namespaces arrays math quotations ;
+classes.algebra namespaces arrays math quotations ;
IN: classes.union
PREDICATE: union-class < class
diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor
index 61e2b82f4f..550bab72f4 100755
--- a/core/generator/registers/registers.factor
+++ b/core/generator/registers/registers.factor
@@ -563,7 +563,7 @@ M: loc lazy-store
] if ;
: class-tag ( class -- tag/f )
- class-tags dup length 1 = [ first ] [ drop f ] if ;
+ dup [ class-tags dup length 1 = [ first ] [ drop f ] if ] when ;
: class-matches? ( actual expected -- ? )
{
diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor
index b11d656b03..39a501c7f8 100755
--- a/core/slots/slots-docs.factor
+++ b/core/slots/slots-docs.factor
@@ -2,7 +2,7 @@ USING: help.markup help.syntax generic kernel.private parser
words kernel quotations namespaces sequences words arrays
effects generic.standard classes.builtin
slots.private classes strings math assocs byte-arrays alien
-math ;
+math classes.tuple ;
IN: slots
ARTICLE: "accessors" "Slot accessors"
diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor
index 915ad0c648..6cea58058e 100755
--- a/extra/delegate/delegate.factor
+++ b/extra/delegate/delegate.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors parser generic kernel classes words slots assocs
-sequences arrays vectors definitions prettyprint
-math hashtables sets macros namespaces ;
+USING: accessors parser generic kernel classes classes.tuple
+words slots assocs sequences arrays vectors definitions
+prettyprint math hashtables sets macros namespaces ;
IN: delegate
: protocol-words ( protocol -- words )
From d9bb18b193838be76511535345ba17930692ee21 Mon Sep 17 00:00:00 2001
From: slava <slava@slava-laptop.(none)>
Date: Sat, 5 Jul 2008 03:07:10 -0500
Subject: [PATCH 06/17] More aggressive tree shaker
---
extra/tools/deploy/shaker/shaker.factor | 37 +++++++++++++++++++++----
1 file changed, 31 insertions(+), 6 deletions(-)
diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor
index 05bf3c9642..2dd334d024 100755
--- a/extra/tools/deploy/shaker/shaker.factor
+++ b/extra/tools/deploy/shaker/shaker.factor
@@ -4,7 +4,7 @@ USING: accessors qualified io.streams.c init fry namespaces
assocs kernel parser lexer strings.parser tools.deploy.config
vocabs sequences words words.private memory kernel.private
continuations io prettyprint vocabs.loader debugger system
-strings sets ;
+strings sets vectors quotations byte-arrays ;
QUALIFIED: bootstrap.stage2
QUALIFIED: classes
QUALIFIED: command-line
@@ -79,8 +79,8 @@ IN: tools.deploy.shaker
[
[
props>> swap
- '[ drop , member? not ] assoc-filter
- sift-assoc f assoc-like
+ '[ drop , member? not ] assoc-filter sift-assoc
+ dup assoc-empty? [ drop f ] [ >alist >vector ] if
] keep (>>props)
] with each ;
@@ -93,7 +93,10 @@ IN: tools.deploy.shaker
"compiled-uses"
"constraints"
"declared-effect"
+ "default"
+ "default-method"
"default-output-classes"
+ "derived-from"
"identities"
"if-intrinsics"
"infer"
@@ -103,15 +106,18 @@ IN: tools.deploy.shaker
"loc"
"members"
"methods"
+ "method-class"
+ "method-generic"
"combination"
"cannot-infer"
- "default-method"
+ "no-compile"
"optimizer-hooks"
"output-classes"
"participants"
"predicate"
"predicate-definition"
"predicating"
+ "tuple-dispatch-generic"
"slots"
"slot-names"
"specializer"
@@ -127,6 +133,8 @@ IN: tools.deploy.shaker
strip-prettyprint? [
{
+ "break-before"
+ "break-after"
"delimiter"
"flushable"
"foldable"
@@ -265,13 +273,27 @@ IN: tools.deploy.shaker
21 setenv
] [ drop ] if ;
+: compress ( pred string -- )
+ "Compressing " prepend show
+ instances
+ dup H{ } clone [ [ ] cache ] curry map
+ become ; inline
+
+: compress-byte-arrays ( -- )
+ [ byte-array? ] "byte arrays" compress ;
+
+: compress-quotations ( -- )
+ [ quotation? ] "quotations" compress ;
+
+: compress-strings ( -- )
+ [ string? ] "strings" compress ;
+
: finish-deploy ( final-image -- )
"Finishing up" show
>r { } set-datastack r>
{ } set-retainstack
V{ } set-namestack
V{ } set-catchstack
-
"Saving final image" show
[ save-image-and-exit ] call-clear ;
@@ -295,7 +317,10 @@ SYMBOL: deploy-vocab
deploy-vocab get vocab-main set-boot-quot*
stripped-word-props >r
stripped-globals strip-globals
- r> strip-words ;
+ r> strip-words
+ compress-byte-arrays
+ compress-quotations
+ compress-strings ;
: (deploy) ( final-image vocab config -- )
#! Does the actual work of a deployment in the slave
From 8321a41db08fea8ff3043717a4119901a11f5eea Mon Sep 17 00:00:00 2001
From: slava <slava@slava-laptop.(none)>
Date: Sat, 5 Jul 2008 03:07:25 -0500
Subject: [PATCH 07/17] Tweak to reduce image size; don't produce prototypes
for tuples with all slots set to f
---
core/classes/tuple/tuple.factor | 6 ++++--
1 file changed, 4 insertions(+), 2 deletions(-)
diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor
index 83d85b68d8..b77fa3ecbd 100755
--- a/core/classes/tuple/tuple.factor
+++ b/core/classes/tuple/tuple.factor
@@ -135,7 +135,8 @@ ERROR: bad-superclass class ;
dup boa-check-quot "boa-check" set-word-prop ;
: tuple-prototype ( class -- prototype )
- [ all-slots [ initial>> ] map ] keep slots>tuple ;
+ [ all-slots [ initial>> ] map ] keep
+ over [ ] contains? [ slots>tuple ] [ 2drop f ] if ;
: define-tuple-prototype ( class -- )
dup tuple-prototype "prototype" set-word-prop ;
@@ -304,7 +305,8 @@ M: tuple hashcode*
] recursive-hashcode ;
M: tuple-class new
- "prototype" word-prop (clone) ;
+ dup "prototype" word-prop
+ [ (clone) ] [ tuple-layout <tuple> ] ?if ;
M: tuple-class boa
[ "boa-check" word-prop call ]
From db0d714eba8311b5d22f81a3097fcd076826c53f Mon Sep 17 00:00:00 2001
From: slava <slava@slava-laptop.(none)>
Date: Sat, 5 Jul 2008 03:07:34 -0500
Subject: [PATCH 08/17] Output relocation data size
---
vm/code_gc.c | 6 ++++++
1 file changed, 6 insertions(+)
diff --git a/vm/code_gc.c b/vm/code_gc.c
index e0abdc5a61..03661999c5 100755
--- a/vm/code_gc.c
+++ b/vm/code_gc.c
@@ -308,6 +308,8 @@ DEFINE_PRIMITIVE(code_room)
/* Dump all code blocks for debugging */
void dump_heap(F_HEAP *heap)
{
+ CELL size = 0;
+
F_BLOCK *scan = first_block(heap);
while(scan)
@@ -319,9 +321,11 @@ void dump_heap(F_HEAP *heap)
status = "free";
break;
case B_ALLOCATED:
+ size += object_size(block_to_compiled(scan)->relocation);
status = "allocated";
break;
case B_MARKED:
+ size += object_size(block_to_compiled(scan)->relocation);
status = "marked";
break;
default:
@@ -333,6 +337,8 @@ void dump_heap(F_HEAP *heap)
scan = next_block(heap,scan);
}
+
+ printf("%ld bytes of relocation data\n",size);
}
/* Compute where each block is going to go, after compaction */
From 0dec9230dc33b3c48ac648fcd4d486c833a101a7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 5 Jul 2008 03:44:54 -0500
Subject: [PATCH 09/17] Stricter deploy size tests (I'm such a masochist)
---
extra/tools/deploy/deploy-tests.factor | 28 ++++++++++----------------
1 file changed, 11 insertions(+), 17 deletions(-)
diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor
index 86691e89a0..8a0f0e5468 100755
--- a/extra/tools/deploy/deploy-tests.factor
+++ b/extra/tools/deploy/deploy-tests.factor
@@ -12,42 +12,36 @@ namespaces continuations layouts accessors ;
] with-directory ;
: small-enough? ( n -- ? )
- >r "test.image" temp-file file-info size>> r> <= ;
+ >r "test.image" temp-file file-info size>> r> cell 4 / * <= ;
[ ] [ "hello-world" shake-and-bake ] unit-test
-[ t ] [
- cell 8 = 8 5 ? 100000 * small-enough?
-] unit-test
+[ t ] [ 50000 small-enough? ] unit-test
[ ] [ "sudoku" shake-and-bake ] unit-test
-[ t ] [
- cell 8 = 20 10 ? 100000 * small-enough?
-] unit-test
+[ t ] [ 80000 small-enough? ] unit-test
[ ] [ "hello-ui" shake-and-bake ] unit-test
+[ t ] [ 130000 small-enough? ] unit-test
+
[ "staging.math-compiler-ui-strip.image" ] [
"hello-ui" deploy-config
[ bootstrap-profile staging-image-name file-name ] bind
] unit-test
-[ t ] [
- cell 8 = 35 17 ? 100000 * small-enough?
-] unit-test
-
[ ] [ "maze" shake-and-bake ] unit-test
-[ t ] [
- cell 8 = 30 15 ? 100000 * small-enough?
-] unit-test
+[ t ] [ 120000 small-enough? ] unit-test
+
+[ ] [ "tetris" shake-and-bake ] unit-test
+
+[ t ] [ 120000 small-enough? ] unit-test
[ ] [ "bunny" shake-and-bake ] unit-test
-[ t ] [
- cell 8 = 50 30 ? 100000 * small-enough?
-] unit-test
+[ t ] [ 250000 small-enough? ] unit-test
{
"tools.deploy.test.1"
From 33655a7044d04f4eb57bf62f1d4750e175aac145 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 5 Jul 2008 03:47:09 -0500
Subject: [PATCH 10/17] Fix Unix I/O on 64-bit
---
extra/io/unix/backend/backend.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor
index 2128142615..7f130fc7e3 100755
--- a/extra/io/unix/backend/backend.factor
+++ b/extra/io/unix/backend/backend.factor
@@ -168,7 +168,7 @@ M: stdin dispose
: wait-for-stdin ( stdin -- n )
[ control>> CHAR: X over io:stream-write1 io:stream-flush ]
- [ size>> "uint" heap-size swap io:stream-read *uint ]
+ [ size>> "size_t" heap-size swap io:stream-read *uint ]
bi ;
:: refill-stdin ( buffer stdin size -- )
From 33603b9a28188cfefb0cf0a761f76452efbdabbc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 5 Jul 2008 03:47:15 -0500
Subject: [PATCH 11/17] Fix benchmark load errors
---
extra/benchmark/dispatch1/dispatch1.factor | 2 +-
extra/benchmark/dispatch5/dispatch5.factor | 2 +-
2 files changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/benchmark/dispatch1/dispatch1.factor b/extra/benchmark/dispatch1/dispatch1.factor
index 1c8701f73f..430162892d 100644
--- a/extra/benchmark/dispatch1/dispatch1.factor
+++ b/extra/benchmark/dispatch1/dispatch1.factor
@@ -1,4 +1,4 @@
-USING: classes kernel sequences vocabs math ;
+USING: classes classes.tuple kernel sequences vocabs math ;
IN: benchmark.dispatch1
GENERIC: g ( obj -- obj )
diff --git a/extra/benchmark/dispatch5/dispatch5.factor b/extra/benchmark/dispatch5/dispatch5.factor
index 727d288765..8b6bd76f3a 100755
--- a/extra/benchmark/dispatch5/dispatch5.factor
+++ b/extra/benchmark/dispatch5/dispatch5.factor
@@ -1,4 +1,4 @@
-USING: classes kernel sequences vocabs math ;
+USING: classes classes.tuple kernel sequences vocabs math ;
IN: benchmark.dispatch5
MIXIN: g
From c99215667d4f6974ca614c1e2692da8f6e29bbfd Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 5 Jul 2008 03:59:49 -0500
Subject: [PATCH 12/17] Oops, all sizes were off by an order of magnitude
---
extra/tools/deploy/deploy-tests.factor | 12 ++++++------
1 file changed, 6 insertions(+), 6 deletions(-)
diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor
index 8a0f0e5468..ebcc924ce2 100755
--- a/extra/tools/deploy/deploy-tests.factor
+++ b/extra/tools/deploy/deploy-tests.factor
@@ -16,15 +16,15 @@ namespaces continuations layouts accessors ;
[ ] [ "hello-world" shake-and-bake ] unit-test
-[ t ] [ 50000 small-enough? ] unit-test
+[ t ] [ 500000 small-enough? ] unit-test
[ ] [ "sudoku" shake-and-bake ] unit-test
-[ t ] [ 80000 small-enough? ] unit-test
+[ t ] [ 800000 small-enough? ] unit-test
[ ] [ "hello-ui" shake-and-bake ] unit-test
-[ t ] [ 130000 small-enough? ] unit-test
+[ t ] [ 1300000 small-enough? ] unit-test
[ "staging.math-compiler-ui-strip.image" ] [
"hello-ui" deploy-config
@@ -33,15 +33,15 @@ namespaces continuations layouts accessors ;
[ ] [ "maze" shake-and-bake ] unit-test
-[ t ] [ 120000 small-enough? ] unit-test
+[ t ] [ 1200000 small-enough? ] unit-test
[ ] [ "tetris" shake-and-bake ] unit-test
-[ t ] [ 120000 small-enough? ] unit-test
+[ t ] [ 1200000 small-enough? ] unit-test
[ ] [ "bunny" shake-and-bake ] unit-test
-[ t ] [ 250000 small-enough? ] unit-test
+[ t ] [ 2500000 small-enough? ] unit-test
{
"tools.deploy.test.1"
From 48671cfca7c56aed6d34f2aa893f63d80bf32855 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 5 Jul 2008 04:42:58 -0500
Subject: [PATCH 13/17] Fix classes.algebra unit tests
---
core/classes/algebra/algebra-tests.factor | 3 ++-
core/classes/builtin/builtin.factor | 3 +--
2 files changed, 3 insertions(+), 3 deletions(-)
diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor
index 05c254f225..78da6ee9b3 100755
--- a/core/classes/algebra/algebra-tests.factor
+++ b/core/classes/algebra/algebra-tests.factor
@@ -3,7 +3,8 @@ kernel math namespaces parser prettyprint sequences strings
tools.test vectors words quotations classes classes.algebra
classes.private classes.union classes.mixin classes.predicate
vectors definitions source-files compiler.units growable
-random inference effects kernel.private sbufs math.order ;
+random inference effects kernel.private sbufs math.order
+classes.tuple ;
IN: classes.algebra.tests
\ class< must-infer
diff --git a/core/classes/builtin/builtin.factor b/core/classes/builtin/builtin.factor
index f349d0a126..b0e4754682 100644
--- a/core/classes/builtin/builtin.factor
+++ b/core/classes/builtin/builtin.factor
@@ -43,8 +43,7 @@ M: builtin-class (classes-intersect?)
} cond ;
M: anonymous-intersection (flatten-class)
- participants>>
- participants [ flatten-builtin-class ] map
+ participants>> [ flatten-builtin-class ] map
dup empty? [
drop builtins get sift [ (flatten-class) ] each
] [
From 28c86d07f5d07cbf94e4a6fb93797953451a690d Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sat, 5 Jul 2008 06:45:47 -0500
Subject: [PATCH 14/17] combinators.cleave: ncleave
---
extra/combinators/cleave/cleave.factor | 10 +++++++++-
1 file changed, 9 insertions(+), 1 deletion(-)
diff --git a/extra/combinators/cleave/cleave.factor b/extra/combinators/cleave/cleave.factor
index 8018adaaa4..2f9e027211 100644
--- a/extra/combinators/cleave/cleave.factor
+++ b/extra/combinators/cleave/cleave.factor
@@ -1,8 +1,16 @@
-USING: kernel arrays sequences macros combinators ;
+USING: kernel combinators quotations arrays sequences locals macros
+ shuffle combinators.lib ;
IN: combinators.cleave
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+:: [ncleave] ( SEQ N -- quot )
+ SEQ [ [ N nkeep ] curry ] map concat [ N ndrop ] append >quotation ;
+
+MACRO: ncleave ( seq n -- quot ) [ncleave] ;
+
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Cleave into array
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
From 0b6d405537c2c33a16edbd02fe5729ba712646fb Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sat, 5 Jul 2008 07:25:10 -0500
Subject: [PATCH 15/17] combinators.cleave: narr and arity variants
---
extra/combinators/cleave/cleave.factor | 23 +++++++++++++++++------
1 file changed, 17 insertions(+), 6 deletions(-)
diff --git a/extra/combinators/cleave/cleave.factor b/extra/combinators/cleave/cleave.factor
index 2f9e027211..9b8a790760 100644
--- a/extra/combinators/cleave/cleave.factor
+++ b/extra/combinators/cleave/cleave.factor
@@ -1,13 +1,19 @@
-USING: kernel combinators quotations arrays sequences locals macros
- shuffle combinators.lib ;
+USING: kernel combinators words quotations arrays sequences locals macros
+ shuffle combinators.lib arrays.lib fry ;
IN: combinators.cleave
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: >quot ( obj -- quot ) dup word? [ 1quotation ] when ;
+
+: >quots ( seq -- seq ) [ >quot ] map ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
:: [ncleave] ( SEQ N -- quot )
- SEQ [ [ N nkeep ] curry ] map concat [ N ndrop ] append >quotation ;
+ SEQ >quots [ [ N nkeep ] curry ] map concat [ N ndrop ] append >quotation ;
MACRO: ncleave ( seq n -- quot ) [ncleave] ;
@@ -15,11 +21,16 @@ MACRO: ncleave ( seq n -- quot ) [ncleave] ;
! Cleave into array
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-USING: words quotations fry arrays.lib ;
+: [narr] ( seq n -- quot ) over length '[ , , ncleave , narray ] ;
-: >quot ( obj -- quot ) dup word? [ 1quotation ] when ;
+MACRO: narr ( seq n -- array ) [narr] ;
-: >quots ( seq -- seq ) [ >quot ] map ;
+MACRO: 0arr ( seq -- array ) 0 [narr] ;
+MACRO: 1arr ( seq -- array ) 1 [narr] ;
+MACRO: 2arr ( seq -- array ) 2 [narr] ;
+MACRO: 3arr ( seq -- array ) 3 [narr] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MACRO: <arr> ( seq -- )
[ >quots ] [ length ] bi
From 05798b88d92f2017c99a27720d3aaaa21d105540 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sat, 5 Jul 2008 07:52:50 -0500
Subject: [PATCH 16/17] combinators.cleave-tests: add tests for arr
---
extra/combinators/cleave/cleave-tests.factor | 19 +++++++++++++++++++
1 file changed, 19 insertions(+)
create mode 100644 extra/combinators/cleave/cleave-tests.factor
diff --git a/extra/combinators/cleave/cleave-tests.factor b/extra/combinators/cleave/cleave-tests.factor
new file mode 100644
index 0000000000..94d8c3eae0
--- /dev/null
+++ b/extra/combinators/cleave/cleave-tests.factor
@@ -0,0 +1,19 @@
+
+USING: kernel math math.functions tools.test combinators.cleave ;
+
+IN: combinators.cleave.tests
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: unit-test* ( input output -- ) swap unit-test ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+[ { [ 1 ] [ 2 ] [ 3 ] [ 4 ] } 0arr ] [ { 1 2 3 4 } ] unit-test*
+
+[ 3 { 1+ 1- 2^ } 1arr ] [ { 4 2 8 } ] unit-test*
+
+[ 3 4 { [ + ] [ - ] [ ^ ] } 2arr ] [ { 7 -1 81 } ] unit-test*
+
+[ 1 2 3 { [ + + ] [ - - ] [ * * ] } 3arr ] [ { 6 2 6 } ] unit-test*
+
From d532c819a2b56dd14f733470252befed30fd2ef4 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sat, 5 Jul 2008 11:06:30 -0500
Subject: [PATCH 17/17] newfx: insert and splice
---
extra/newfx/newfx.factor | 6 ++++++
1 file changed, 6 insertions(+)
diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor
index 9335c61025..9cc63fd57e 100644
--- a/extra/newfx/newfx.factor
+++ b/extra/newfx/newfx.factor
@@ -237,3 +237,9 @@ METHOD: as-mutate { object object assoc } set-at ;
: prepend! ( a b -- ba ) over append 0 pick copy ;
: prepended! ( a b -- ) over append 0 rot copy ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: insert ( seq i obj -- seq ) >r cut r> prefix append ;
+
+: splice ( seq i seq -- seq ) >r cut r> prepend append ;
\ No newline at end of file