basis/ui/gadgets/gadgets-tests.factor

   1 IN: ui.gadgets.tests
   2 USING: accessors ui.gadgets ui.gadgets.packs ui.gadgets.worlds
   3 tools.test namespaces models kernel dlists deques math sets
   4 math.parser ui sequences hashtables assocs io arrays prettyprint
   5 io.streams.string math.geometry.rect ;
   6
   7 [ { 300 300 } ]
   8 [
   9     ! c contains b contains a
  10     <gadget> "a" set
  11     <gadget> "b" set
  12     "a" get "b" get swap add-gadget drop
  13     <gadget> "c" set
  14     "b" get "c" get swap add-gadget drop
  15
  16     ! position a and b
  17     { 100 200 } "a" get set-rect-loc
  18     { 200 100 } "b" get set-rect-loc
  19
  20     ! give c a loc, it doesn't matter
  21     { -1000 23 } "c" get set-rect-loc
  22
  23     ! what is the location of a inside c?
  24     "a" get "c" get relative-loc
  25 ] unit-test
  26
  27 <gadget> "g1" set
  28 { 10 10 } "g1" get set-rect-loc
  29 { 30 30 } "g1" get set-rect-dim
  30 <gadget> "g2" set
  31 { 20 20 } "g2" get set-rect-loc
  32 { 50 500 } "g2" get set-rect-dim
  33 <gadget> "g3" set
  34 { 100 200 } "g3" get set-rect-dim
  35
  36 "g1" get "g2" get swap add-gadget drop
  37 "g2" get "g3" get swap add-gadget drop
  38
  39 [ { 30 30 } ] [ "g1" get screen-loc ] unit-test
  40 [ { 30 30 } ] [ "g1" get screen-rect rect-loc ] unit-test
  41 [ { 30 30 } ] [ "g1" get screen-rect rect-dim ] unit-test
  42 [ { 20 20 } ] [ "g2" get screen-loc ] unit-test
  43 [ { 20 20 } ] [ "g2" get screen-rect rect-loc ] unit-test
  44 [ { 50 180 } ] [ "g2" get screen-rect rect-dim ] unit-test
  45 [ { 0 0 } ] [ "g3" get screen-loc ] unit-test
  46 [ { 0 0 } ] [ "g3" get screen-rect rect-loc ] unit-test
  47 [ { 100 200 } ] [ "g3" get screen-rect rect-dim ] unit-test
  48
  49 <gadget> "g1" set
  50 { 300 300 } "g1" get set-rect-dim
  51 <gadget> "g2" set
  52 "g2" get "g1" get swap add-gadget drop
  53 { 20 20 } "g2" get set-rect-loc
  54 { 20 20 } "g2" get set-rect-dim
  55 <gadget> "g3" set
  56 "g3" get "g1" get swap add-gadget drop
  57 { 100 100 } "g3" get set-rect-loc
  58 { 20 20 } "g3" get set-rect-dim
  59
  60 [ t ] [ { 30 30 } "g2" get inside? ] unit-test
  61
  62 [ t ] [ { 30 30 } "g1" get (pick-up) "g2" get eq? ] unit-test
  63
  64 [ t ] [ { 30 30 } "g1" get pick-up "g2" get eq? ] unit-test
  65
  66 [ t ] [ { 110 110 } "g1" get pick-up "g3" get eq? ] unit-test
  67
  68 <gadget> "g4" set
  69 "g4" get "g2" get swap add-gadget drop
  70 { 5 5 } "g4" get set-rect-loc
  71 { 1 1 } "g4" get set-rect-dim
  72
  73 [ t ] [ { 25 25 } "g1" get pick-up "g4" get eq? ] unit-test
  74
  75 TUPLE: mock-gadget < gadget graft-called ungraft-called ;
  76
  77 : <mock-gadget> ( -- gadget )
  78     mock-gadget new-gadget 0 >>graft-called 0 >>ungraft-called ;
  79
  80 M: mock-gadget graft*
  81     dup mock-gadget-graft-called 1+
  82     swap set-mock-gadget-graft-called ;
  83
  84 M: mock-gadget ungraft*
  85     dup mock-gadget-ungraft-called 1+
  86     swap set-mock-gadget-ungraft-called ;
  87
  88 ! We can't print to output-stream here because that might be a pane
  89 ! stream, and our graft-queue rebinding here would be captured
  90 ! by code adding children to the pane...
  91 [
  92     <dlist> \ graft-queue [
  93         [ ] [ <mock-gadget> dup queue-graft unqueue-graft ] unit-test
  94         [ t ] [ graft-queue deque-empty? ] unit-test
  95     ] with-variable
  96
  97     <dlist> \ graft-queue [
  98         [ t ] [ graft-queue deque-empty? ] unit-test
  99
 100         <mock-gadget> "g" set
 101         [ ] [ "g" get queue-graft ] unit-test
 102         [ f ] [ graft-queue deque-empty? ] unit-test
 103         [ { f t } ] [ "g" get gadget-graft-state ] unit-test
 104         [ ] [ "g" get graft-later ] unit-test
 105         [ { f t } ] [ "g" get gadget-graft-state ] unit-test
 106         [ ] [ "g" get ungraft-later ] unit-test
 107         [ { f f } ] [ "g" get gadget-graft-state ] unit-test
 108         [ t ] [ graft-queue deque-empty? ] unit-test
 109         [ ] [ "g" get ungraft-later ] unit-test
 110         [ ] [ "g" get graft-later ] unit-test
 111         [ ] [ notify-queued ] unit-test
 112         [ { t t } ] [ "g" get gadget-graft-state ] unit-test
 113         [ t ] [ graft-queue deque-empty? ] unit-test
 114         [ ] [ "g" get graft-later ] unit-test
 115         [ 1 ] [ "g" get mock-gadget-graft-called ] unit-test
 116         [ ] [ "g" get ungraft-later ] unit-test
 117         [ { t f } ] [ "g" get gadget-graft-state ] unit-test
 118         [ ] [ notify-queued ] unit-test
 119         [ 1 ] [ "g" get mock-gadget-ungraft-called ] unit-test
 120         [ { f f } ] [ "g" get gadget-graft-state ] unit-test
 121     ] with-variable
 122
 123     : add-some-children
 124         3 [
 125             <mock-gadget> over <model> over set-gadget-model
 126             dup "g" get swap add-gadget drop
 127             swap 1+ number>string set
 128         ] each ;
 129
 130     : status-flags
 131         { "g" "1" "2" "3" } [ get gadget-graft-state ] map prune ;
 132
 133     : notify-combo ( ? ? -- )
 134         nl "===== Combo: " write 2dup 2array . nl
 135         <dlist> \ graft-queue [
 136             <mock-gadget> "g" set
 137             [ ] [ add-some-children ] unit-test
 138             [ V{ { f f } } ] [ status-flags ] unit-test
 139             [ ] [ "g" get graft ] unit-test
 140             [ V{ { f t } } ] [ status-flags ] unit-test
 141             dup [ [ ] [ notify-queued ] unit-test ] when
 142             [ ] [ "g" get clear-gadget ] unit-test
 143             [ [ 1 ] [ graft-queue dlist-length ] unit-test ] unless
 144             [ [ ] [ notify-queued ] unit-test ] when
 145             [ ] [ add-some-children ] unit-test
 146             [ { f t } ] [ "1" get gadget-graft-state ] unit-test
 147             [ { f t } ] [ "2" get gadget-graft-state ] unit-test
 148             [ { f t } ] [ "3" get gadget-graft-state ] unit-test
 149             [ ] [ graft-queue [ "x" print notify ] slurp-deque ] unit-test
 150             [ ] [ notify-queued ] unit-test
 151             [ V{ { t t } } ] [ status-flags ] unit-test
 152         ] with-variable ;
 153
 154     { { f f } { f t } { t f } { t t } } [ notify-combo ] assoc-each
 155 ] with-string-writer print
 156
 157 \ <gadget> must-infer
 158 \ unparent must-infer
 159 \ add-gadget must-infer
 160 \ add-gadgets must-infer
 161 \ clear-gadget must-infer
 162
 163 \ relayout must-infer
 164 \ relayout-1 must-infer
 165 \ pref-dim must-infer