1 USING: accessors ui.gadgets ui.gadgets.private ui.gadgets.packs
2 ui.gadgets.worlds tools.test namespaces models kernel dlists deques
3 math sets math.parser ui sequences hashtables assocs io arrays
4 prettyprint io.streams.string math.rectangles ui.gadgets.private
10 ! c contains b contains a
13 "b" get "a" get add-gadget drop
15 "c" get "b" get add-gadget drop
18 "a" get { 100 200 } >>loc drop
19 "b" get { 200 100 } >>loc drop
21 ! give c a loc, it doesn't matter
22 "c" get { -1000 23 } >>loc drop
24 ! what is the location of a inside c?
25 "a" get "c" get relative-loc
29 "g1" get { 10 10 } >>loc
32 "g2" get { 20 20 } >>loc
35 "g3" get { 100 200 } >>dim drop
37 "g2" get "g1" get add-gadget drop
38 "g3" get "g2" get add-gadget drop
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
51 "g1" get { 300 300 } >>dim drop
53 "g1" get "g2" get add-gadget drop
54 "g2" get { 20 20 } >>loc
57 "g1" get "g3" get add-gadget drop
58 "g3" get { 100 100 } >>loc
61 [ t ] [ { 30 30 } "g2" get contains-point? ] unit-test
63 [ t ] [ { 30 30 } "g1" get pick-up "g2" get eq? ] unit-test
65 [ t ] [ { 30 30 } "g1" get pick-up "g2" get eq? ] unit-test
67 [ t ] [ { 110 110 } "g1" get pick-up "g3" get eq? ] unit-test
70 "g2" get "g4" get add-gadget drop
71 "g4" get { 5 5 } >>loc
74 [ t ] [ { 25 25 } "g1" get pick-up "g4" get eq? ] unit-test
76 TUPLE: mock-gadget < gadget graft-called ungraft-called ;
78 : <mock-gadget> ( -- gadget )
79 mock-gadget new 0 >>graft-called 0 >>ungraft-called ;
82 [ 1+ ] change-graft-called drop ;
84 M: mock-gadget ungraft*
85 [ 1+ ] change-ungraft-called drop ;
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...
91 <dlist> \ graft-queue [
92 [ ] [ <mock-gadget> dup queue-graft unqueue-graft ] unit-test
93 [ t ] [ graft-queue deque-empty? ] unit-test
96 <dlist> \ graft-queue [
97 [ t ] [ graft-queue deque-empty? ] unit-test
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
122 : add-some-children ( gadget -- gadget )
124 <mock-gadget> over <model> >>model
125 "g" get over add-gadget drop
126 swap 1+ number>string set
129 : status-flags ( -- seq )
130 { "g" "1" "2" "3" } [ get graft-state>> ] map prune ;
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 [ V{ { f f } } ] [ status-flags ] unit-test
138 [ ] [ "g" get graft ] unit-test
139 [ V{ { 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 [ V{ { t t } } ] [ status-flags ] unit-test
153 { { f f } { f t } { t f } { t t } } [ notify-combo ] assoc-each
154 ] with-string-writer print
156 \ <gadget> must-infer
157 \ unparent must-infer
158 \ add-gadget must-infer
159 \ add-gadgets must-infer
160 \ clear-gadget must-infer
162 \ relayout must-infer
163 \ relayout-1 must-infer
164 \ pref-dim must-infer
167 \ ungraft* must-infer