2009-02-26 17:15:10 -05:00
|
|
|
USING: arrays generic kernel math models models.product
|
2008-09-02 02:53:43 -04:00
|
|
|
namespaces sequences assocs accessors tools.test ;
|
|
|
|
|
IN: models.tests
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
|
TUPLE: model-tester hit? ;
|
|
|
|
|
|
2009-03-23 01:34:02 -04:00
|
|
|
: <model-tester> ( -- model-tester ) model-tester new ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
2008-09-02 02:53:43 -04:00
|
|
|
M: model-tester model-changed nip t >>hit? drop ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
|
[ T{ model-tester f t } ]
|
|
|
|
|
[
|
2010-06-23 23:07:19 -04:00
|
|
|
T{ model-tester f f } clone 3 <model> 2dup add-connection
|
2007-09-20 18:09:08 -04:00
|
|
|
5 swap set-model
|
|
|
|
|
] unit-test
|
|
|
|
|
|
|
|
|
|
3 <model> "model-a" set
|
|
|
|
|
4 <model> "model-b" set
|
2009-02-26 17:15:10 -05:00
|
|
|
"model-a" get "model-b" get 2array <product> "model-c" set
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
|
"model-c" get activate-model
|
2008-09-02 02:53:43 -04:00
|
|
|
[ { 3 4 } ] [ "model-c" get value>> ] unit-test
|
2007-09-20 18:09:08 -04:00
|
|
|
"model-c" get deactivate-model
|
|
|
|
|
|
|
|
|
|
T{ model-tester f f } "tester" set
|
|
|
|
|
|
|
|
|
|
[ T{ model-tester f t } { 6 4 } ]
|
|
|
|
|
[
|
|
|
|
|
"tester" get "model-c" get add-connection
|
|
|
|
|
6 "model-a" get set-model
|
|
|
|
|
"tester" get
|
2008-09-02 02:53:43 -04:00
|
|
|
"model-c" get value>>
|
2007-09-20 18:09:08 -04:00
|
|
|
] unit-test
|
2010-06-23 23:07:19 -04:00
|
|
|
|
|
|
|
|
[ 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
|
|
|
|
|
|
