basis/ui/gadgets/gadgets-tests.factor

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