basis/ui/gadgets/gadgets-tests.factor

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