USING: help.syntax help.markup kernel math classes classes.tuple
-calendar ;
+calendar sequences growable ;
IN: models
HELP: 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." } ;
[ 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
"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
+
: ((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 )
: 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* ;
+