Remove filter models to arrow models, and rename compose models to product models
Slava Pestov
parent
e0cfad4676
commit
b19ef56870
|
|
@ -0,0 +1,27 @@
|
|||
USING: help.syntax help.markup kernel math classes classes.tuple
|
||||
calendar models ;
|
||||
IN: models.arrow
|
||||
|
||||
HELP: arrow
|
||||
{ $class-description "Arrow model values are computed by applying a quotation to the value of another model. Arrows are automatically updated when the underlying model changes. Arrows are constructed by " { $link <arrow> } "." }
|
||||
{ $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 ] <arrow> [ number>string ] <arrow>"
|
||||
"<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: <arrow>
|
||||
{ $values { "model" model } { "quot" { $quotation "( obj -- newobj )" } } { "arrow" "a new " { $link arrow } } }
|
||||
{ $description "Creates a new instance of " { $link arrow } ". The value of the new arrow model is computed by applying the quotation to the value." }
|
||||
{ $examples "See the example in the documentation for " { $link arrow } "." } ;
|
||||
|
||||
ARTICLE: "models.arrow" "Arrow models"
|
||||
"Arrow model values are computed by applying a quotation to the value of another model."
|
||||
{ $subsection arrow }
|
||||
{ $subsection <arrow> } ;
|
||||
|
||||
ABOUT: "models.arrow"
|
||||
|
|
@ -1,11 +1,10 @@
|
|||
USING: arrays generic kernel math models namespaces sequences assocs
|
||||
tools.test models.filter accessors ;
|
||||
IN: models.filter.tests
|
||||
tools.test models.arrow accessors ;
|
||||
IN: models.arrow.tests
|
||||
|
||||
! Test multiple filters
|
||||
3 <model> "x" set
|
||||
"x" get [ 2 * ] <filter> dup "z" set
|
||||
[ 1+ ] <filter> "y" set
|
||||
"x" get [ 2 * ] <arrow> dup "z" set
|
||||
[ 1+ ] <arrow> "y" set
|
||||
[ ] [ "y" get activate-model ] unit-test
|
||||
[ t ] [ "z" get "x" get connections>> memq? ] unit-test
|
||||
[ 7 ] [ "y" get value>> ] unit-test
|
||||
|
|
@ -15,7 +14,7 @@ IN: models.filter.tests
|
|||
[ f ] [ "z" get "x" get connections>> memq? ] unit-test
|
||||
|
||||
3 <model> "x" set
|
||||
"x" get [ sq ] <filter> "y" set
|
||||
"x" get [ sq ] <arrow> "y" set
|
||||
|
||||
4 "x" get set-model
|
||||
|
||||
|
|
@ -1,18 +1,18 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors models kernel call ;
|
||||
IN: models.filter
|
||||
IN: models.arrow
|
||||
|
||||
TUPLE: filter < model model quot ;
|
||||
TUPLE: arrow < model model quot ;
|
||||
|
||||
: <filter> ( model quot -- filter )
|
||||
f filter new-model
|
||||
: <arrow> ( model quot -- arrow )
|
||||
f arrow new-model
|
||||
swap >>quot
|
||||
over >>model
|
||||
[ add-dependency ] keep ;
|
||||
|
||||
M: filter model-changed
|
||||
M: arrow model-changed
|
||||
[ [ value>> ] [ quot>> ] bi* call( old -- new ) ] [ nip ] 2bi
|
||||
set-model ;
|
||||
|
||||
M: filter model-activated [ model>> ] keep model-changed ;
|
||||
M: arrow model-activated [ model>> ] keep model-changed ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Arrow models apply a quotation to the value of an underlying model
|
||||
|
|
@ -1,36 +0,0 @@
|
|||
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 models.compose models.range ui.gadgets"
|
||||
"ui.gadgets.labels ui.gadgets.packs ui.gadgets.panes"
|
||||
"ui.gadgets.sliders ;"
|
||||
""
|
||||
": <funny-model> ( -- model ) 0 10 0 100 <range> ;"
|
||||
": <funny-slider> ( model -- slider ) horizontal <slider> ;"
|
||||
""
|
||||
"<funny-model> <funny-model> 2array"
|
||||
"[ <pile> [ horizontal <slider> add-gadget ] reduce gadget. ]"
|
||||
"[ <compose> [ unparse ] <filter> <label-control> gadget. ]"
|
||||
"bi"
|
||||
}
|
||||
} ;
|
||||
|
||||
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 the " { $snippet "value" } " slot accessor 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"
|
||||
|
|
@ -1,55 +0,0 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors models kernel sequences ;
|
||||
IN: models.compose
|
||||
|
||||
TUPLE: compose < model ;
|
||||
|
||||
: new-compose ( models class -- compose )
|
||||
f swap new-model
|
||||
swap clone >>dependencies ; inline
|
||||
|
||||
: <compose> ( models -- compose )
|
||||
compose new-compose ;
|
||||
|
||||
: composed-value [ dependencies>> ] dip map ; inline
|
||||
|
||||
: set-composed-value [ dependencies>> ] dip 2each ; inline
|
||||
|
||||
M: compose model-changed
|
||||
nip
|
||||
dup [ value>> ] composed-value >>value
|
||||
notify-connections ;
|
||||
|
||||
M: compose model-activated dup model-changed ;
|
||||
|
||||
M: compose update-model
|
||||
dup 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 ;
|
||||
|
|
@ -1 +0,0 @@
|
|||
Composed models combine the values of a sequence of models into one
|
||||
|
|
@ -7,7 +7,7 @@ HELP: 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 models.delay models.filter models.range"
|
||||
"USING: models models.delay models.arrow models.range"
|
||||
"ui.gadgets ui.gadgets.labels ui.gadgets.sliders ui.gadgets.panes"
|
||||
"math.parser calendar ;"
|
||||
""
|
||||
|
|
@ -15,7 +15,7 @@ HELP: delay
|
|||
" 0 10 0 100 <range> horizontal <slider> ;"
|
||||
""
|
||||
"<funny-slider> dup gadget."
|
||||
"model>> 1/2 seconds <delay> [ unparse ] <filter>"
|
||||
"model>> 1/2 seconds <delay> [ unparse ] <arrow>"
|
||||
"<label-control> gadget."
|
||||
}
|
||||
} ;
|
||||
|
|
|
|||
|
|
@ -1,27 +0,0 @@
|
|||
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" { $quotation "( 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"
|
||||
|
|
@ -1 +0,0 @@
|
|||
Filter models apply a quotation to the value of an underlying model
|
||||
|
|
@ -130,8 +130,8 @@ $nl
|
|||
{ $subsection activate-model }
|
||||
{ $subsection deactivate-model }
|
||||
{ $subsection "models-impl" }
|
||||
{ $subsection "models-filter" }
|
||||
{ $subsection "models-compose" }
|
||||
{ $subsection "models.arrow" }
|
||||
{ $subsection "models.product" }
|
||||
{ $subsection "models-history" }
|
||||
{ $subsection "models-range" }
|
||||
{ $subsection "models-delay" } ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: arrays generic kernel math models models.compose
|
||||
USING: arrays generic kernel math models models.product
|
||||
namespaces sequences assocs accessors tools.test ;
|
||||
IN: models.tests
|
||||
|
||||
|
|
@ -16,7 +16,7 @@ M: model-tester model-changed nip t >>hit? drop ;
|
|||
|
||||
3 <model> "model-a" set
|
||||
4 <model> "model-b" set
|
||||
"model-a" get "model-b" get 2array <compose> "model-c" set
|
||||
"model-a" get "model-b" get 2array <product> "model-c" set
|
||||
|
||||
"model-c" get activate-model
|
||||
[ { 3 4 } ] [ "model-c" get value>> ] unit-test
|
||||
|
|
|
|||
|
|
@ -0,0 +1,36 @@
|
|||
USING: help.syntax help.markup kernel math classes classes.tuple
|
||||
calendar models ;
|
||||
IN: models.product
|
||||
|
||||
HELP: product
|
||||
{ $class-description "Product model values are computed by collecting the values from a sequence of underlying models into a new sequence. Product models are automatically updated when underlying models change. Product models are constructed by " { $link <product> } "."
|
||||
$nl
|
||||
"A product 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 models.product models.range ui.gadgets"
|
||||
"ui.gadgets.labels ui.gadgets.packs ui.gadgets.panes"
|
||||
"ui.gadgets.sliders ;"
|
||||
""
|
||||
": <funny-model> ( -- model ) 0 10 0 100 <range> ;"
|
||||
": <funny-slider> ( model -- slider ) horizontal <slider> ;"
|
||||
""
|
||||
"<funny-model> <funny-model> 2array"
|
||||
"[ <pile> [ horizontal <slider> add-gadget ] reduce gadget. ]"
|
||||
"[ <product> [ unparse ] <arrow> <label-control> gadget. ]"
|
||||
"bi"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: <product>
|
||||
{ $values { "models" "a sequence of models" } { "product" "a new " { $link product } } }
|
||||
{ $description "Creates a new instance of " { $link product } ". The value of the new product model is obtained by mapping the " { $snippet "value" } " slot accessor over the given sequence of models." }
|
||||
{ $examples "See the example in the documentation for " { $link product } "." } ;
|
||||
|
||||
ARTICLE: "models.product" "Product models"
|
||||
"Product model values are computed by collecting the values from a sequence of underlying models into a new sequence."
|
||||
{ $subsection product }
|
||||
{ $subsection <product> } ;
|
||||
|
||||
ABOUT: "models.product"
|
||||
|
|
@ -1,12 +1,11 @@
|
|||
USING: arrays generic kernel math models namespaces sequences assocs
|
||||
tools.test models.compose accessors locals ;
|
||||
IN: models.compose.tests
|
||||
tools.test models.product accessors locals ;
|
||||
IN: models.product.tests
|
||||
|
||||
! Test compose
|
||||
[ ] [
|
||||
1 <model> "a" set
|
||||
2 <model> "b" set
|
||||
"a" get "b" get 2array <compose> "c" set
|
||||
"a" get "b" get 2array <product> "c" set
|
||||
] unit-test
|
||||
|
||||
[ ] [ "c" get activate-model ] unit-test
|
||||
|
|
@ -30,7 +29,7 @@ M: an-observer model-changed nip [ 1+ ] change-i drop ;
|
|||
[ 1 0 ] [
|
||||
[let* | m1 [ 1 <model> ]
|
||||
m2 [ 2 <model> ]
|
||||
c [ { m1 m2 } <compose> ]
|
||||
c [ { m1 m2 } <product> ]
|
||||
o1 [ an-observer new ]
|
||||
o2 [ an-observer new ] |
|
||||
|
||||
|
|
@ -0,0 +1,57 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors models kernel sequences ;
|
||||
IN: models.product
|
||||
|
||||
TUPLE: product < model ;
|
||||
|
||||
: new-product ( models class -- product )
|
||||
f swap new-model
|
||||
swap clone >>dependencies ; inline
|
||||
|
||||
: <product> ( models -- product )
|
||||
product new-product ;
|
||||
|
||||
: product-value ( model quot -- seq )
|
||||
[ dependencies>> ] dip map ; inline
|
||||
|
||||
: set-product-value ( seq model quot -- )
|
||||
[ dependencies>> ] dip 2each ; inline
|
||||
|
||||
M: product model-changed
|
||||
nip
|
||||
dup [ value>> ] product-value >>value
|
||||
notify-connections ;
|
||||
|
||||
M: product model-activated dup model-changed ;
|
||||
|
||||
M: product update-model
|
||||
dup value>> swap [ set-model ] set-product-value ;
|
||||
|
||||
M: product range-value
|
||||
[ range-value ] product-value ;
|
||||
|
||||
M: product range-page-value
|
||||
[ range-page-value ] product-value ;
|
||||
|
||||
M: product range-min-value
|
||||
[ range-min-value ] product-value ;
|
||||
|
||||
M: product range-max-value
|
||||
[ range-max-value ] product-value ;
|
||||
|
||||
M: product range-max-value*
|
||||
[ range-max-value* ] product-value ;
|
||||
|
||||
M: product set-range-value
|
||||
[ clamp-value ] keep
|
||||
[ set-range-value ] set-product-value ;
|
||||
|
||||
M: product set-range-page-value
|
||||
[ set-range-page-value ] set-product-value ;
|
||||
|
||||
M: product set-range-min-value
|
||||
[ set-range-min-value ] set-product-value ;
|
||||
|
||||
M: product set-range-max-value
|
||||
[ set-range-max-value ] set-product-value ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Product models combine the values of a sequence of models into one
|
||||
|
|
@ -1,13 +1,13 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel models arrays sequences math math.order
|
||||
models.compose ;
|
||||
models.product ;
|
||||
IN: models.range
|
||||
|
||||
TUPLE: range < compose ;
|
||||
TUPLE: range < product ;
|
||||
|
||||
: <range> ( value page min max -- range )
|
||||
4array [ <model> ] map range new-compose ;
|
||||
4array [ <model> ] map range new-product ;
|
||||
|
||||
: range-model ( range -- model ) dependencies>> first ;
|
||||
: range-page ( range -- model ) dependencies>> second ;
|
||||
|
|
|
|||
|
|
@ -1,12 +1,12 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays fry kernel models.compose models.filter
|
||||
USING: arrays fry kernel models.product models.arrow
|
||||
sequences unicode.case ;
|
||||
IN: models.search
|
||||
|
||||
: <search> ( values search quot -- model )
|
||||
[ 2array <compose> ] dip
|
||||
'[ first2 _ curry filter ] <filter> ;
|
||||
[ 2array <product> ] dip
|
||||
'[ first2 _ curry filter ] <arrow> ;
|
||||
|
||||
: <string-search> ( values search quot -- model )
|
||||
'[ swap @ [ >case-fold ] bi@ subseq? ] <search> ;
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays fry kernel models.compose models.filter
|
||||
USING: arrays fry kernel models.product models.arrow
|
||||
sequences sorting ;
|
||||
IN: models.sort
|
||||
|
||||
: <sort> ( values sort -- model )
|
||||
2array <compose> [ first2 sort ] <filter> ;
|
||||
2array <product> [ first2 sort ] <arrow> ;
|
||||
Loading…
Reference in New Issue