core/ui/test/models.factor

   1 IN: temporary
   2 USING: arrays generic kernel math models namespaces sequences
   3 test ;
   4
   5 TUPLE: model-tester hit? ;
   6
   7 C: model-tester ;
   8
   9 M: model-tester model-changed t swap set-model-tester-hit? ;
  10
  11 [ T{ model-tester f t } ]
  12 [
  13     T{ model-tester f f } 3 <model> 2dup add-connection
  14     5 swap set-model
  15 ] unit-test
  16
  17 3 <model> "model-a" set
  18 4 <model> "model-b" set
  19 "model-a" get "model-b" get 2array <compose> "model-c" set
  20
  21 "model-c" get activate-model
  22 [ { 3 4 } ] [ "model-c" get model-value  ] unit-test
  23 "model-c" get deactivate-model
  24
  25 T{ model-tester f f } "tester" set
  26
  27 [ T{ model-tester f t } { 6 4 } ]
  28 [
  29     "tester" get "model-c" get add-connection
  30     6 "model-a" get set-model
  31     "tester" get
  32     "model-c" get model-value
  33 ] unit-test
  34
  35 f <history> "history" set
  36
  37 "history" get add-history
  38
  39 [ t ] [ "history" get history-back empty? ] unit-test
  40 [ t ] [ "history" get history-forward empty? ] unit-test
  41
  42 "history" get add-history
  43 3 "history" get set-model
  44
  45 [ t ] [ "history" get history-back empty? ] unit-test
  46 [ t ] [ "history" get history-forward empty? ] unit-test
  47
  48 "history" get add-history
  49 4 "history" get set-model
  50
  51 [ f ] [ "history" get history-back empty? ] unit-test
  52 [ t ] [ "history" get history-forward empty? ] unit-test
  53
  54 "history" get go-back
  55
  56 [ 3 ] [ "history" get model-value ] unit-test
  57
  58 [ t ] [ "history" get history-back empty? ] unit-test
  59 [ f ] [ "history" get history-forward empty? ] unit-test
  60
  61 "history" get go-forward
  62
  63 [ 4 ] [ "history" get model-value ] unit-test
  64
  65 [ f ] [ "history" get history-back empty? ] unit-test
  66 [ t ] [ "history" get history-forward empty? ] unit-test
  67
  68 ! Test multiple filters
  69 3 <model> "x" set
  70 "x" get [ 2 * ] <filter> dup "z" set
  71 [ 1+ ] <filter> "y" set
  72 [ ] [ "y" get activate-model ] unit-test
  73 [ t ] [ "z" get "x" get model-connections memq? ] unit-test
  74 [ 7 ] [ "y" get model-value ] unit-test
  75 [ ] [ 4 "x" get set-model ] unit-test
  76 [ 9 ] [ "y" get model-value ] unit-test
  77 [ ] [ "y" get deactivate-model ] unit-test
  78 [ f ] [ "z" get "x" get model-connections memq? ] unit-test
  79
  80 3 <model> "x" set
  81 "x" get [ sq ] <filter> "y" set
  82
  83 4 "x" get set-model
  84
  85 "y" get activate-model
  86 [ 16 ] [ "y" get model-value ] unit-test
  87 "y" get deactivate-model