steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

models: add push-model and pop-model words

db4
Joe Groff 2010-06-23 20:07:19 -07:00
parent 50323dda6d
commit 5956e3b3d4
3 changed files with 42 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
basis/models/models-docs.factor
View File

@ -1,5 +1,5 @@
USING: help.syntax help.markup kernel math classes classes.tuple
calendar ;
calendar sequences growable ;
IN: models
HELP: model
@ -64,17 +64,29 @@ HELP: set-model
{ $values { "value" object } { "model" model } }
{ $description "Changes the value of a model and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ;
{ set-model change-model (change-model) } related-words
{ set-model change-model change-model* (change-model) push-model pop-model } related-words
HELP: change-model
{ $values { "model" model } { "quot" { $quotation "( obj -- newobj )" } } }
{ $values { "model" model } { "quot" { $quotation "( ..a obj -- ..b newobj )" } } }
{ $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, and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ;
HELP: change-model*
{ $values { "model" model } { "quot" { $quotation "( ..a obj -- ..b )" } } }
{ $description "Applies the quotation to the current value of the model and calls " { $link model-changed } " on all observers registered with " { $link add-connection } " without actually changing the value of the model. This is useful for notifying observers of operations that mutate a value, as in " { $link push-model } " and " { $link pop-model } "." } ;
HELP: (change-model)
{ $values { "model" model } { "quot" { $quotation "( obj -- newobj )" } } }
{ $values { "model" model } { "quot" { $quotation "( ..a obj -- ..b newobj )" } } }
{ $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: push-model
{ $values { "value" object } { "model" model } }
{ $description { $link push } "es " { $snippet "value" } " onto the " { $link growable } " sequence stored as the value of " { $snippet "model" } " and calls " { $link model-changed } " on all observers registered for the model with " { $link add-connection } "." } ;
HELP: pop-model
{ $values { "model" model } { "value" object } }
{ $description { $link pop } "s the topmost " { $snippet "value" } " off of the " { $link growable } " sequence stored as the value of " { $snippet "model" } " and calls " { $link model-changed } " on all observers registered for the model with " { $link add-connection } "." } ;
HELP: range-value
{ $values { "model" model } { "value" object } }
{ $contract "Outputs the current value of a range model." } ;

15
basis/models/models-tests.factor
View File

@ -10,7 +10,7 @@ M: model-tester model-changed nip t >>hit? drop ;
[ T{ model-tester f t } ]
[
T{ model-tester f f } 3 <model> 2dup add-connection
T{ model-tester f f } clone 3 <model> 2dup add-connection
5 swap set-model
] unit-test
@ -31,3 +31,16 @@ T{ model-tester f f } "tester" set
"tester" get
"model-c" get value>>
] unit-test
[ T{ model-tester f t } V{ 5 } ]
[
T{ model-tester f f } clone V{ } clone <model> 2dup add-connection
5 swap [ push-model ] [ value>> ] bi
] unit-test
[ T{ model-tester f t } 5 V{ } ]
[
T{ model-tester f f } clone V{ 5 } clone <model> 2dup add-connection
[ pop-model ] [ value>> ] bi
] unit-test

14
basis/models/models.factor
View File

@ -90,10 +90,10 @@ M: model update-model drop ;
: ((change-model)) ( model quot -- newvalue model )
over [ [ value>> ] dip call ] dip ; inline
: change-model ( model quot -- )
: change-model ( ..a model quot: ( ..a obj -- ..b newobj ) -- ..b )
((change-model)) set-model ; inline
: (change-model) ( model quot -- )
: (change-model) ( ..a model quot: ( ..a obj -- ..b newobj ) -- ..b )
((change-model)) value<< ; inline
GENERIC: range-value ( model -- value )
@ -108,3 +108,13 @@ GENERIC: set-range-max-value ( value model -- )
: clamp-value ( value range -- newvalue )
[ range-min-value ] [ range-max-value* ] bi clamp ;
: change-model* ( ..a model quot: ( ..a obj -- ..b ) -- ..b )
'[ _ keep ] change-model ; inline
: push-model ( value model -- )
[ push ] change-model* ;
: pop-model ( model -- value )
[ pop ] change-model* ;