1#lang typed/racket/base
2
3(require (for-syntax racket/base racket/syntax racket/match racket/list)
4         racket/list racket/match racket/unsafe/ops
5         "type-doc.rkt"
6         "math.rkt"
7         "marching-utils.rkt")
8
9(provide heights->cube-polys
10         ;heights->cube-polys:doc
11         )
12
13(define-for-syntax (->datum x)
14  (if (syntax? x) (syntax->datum x) x))
15
16(define-for-syntax (t=? a b)
17  (eq? (->datum a) (->datum b)))
18
19;; edge vertexes
20
21(define-syntax-rule (edge-1-2 d d1 d2) (ann (vector (solve-t d d1 d2) 0 0) (Vectorof Real)))
22(define-syntax-rule (edge-2-3 d d2 d3) (ann (vector 1 (solve-t d d2 d3) 0) (Vectorof Real)))
23(define-syntax-rule (edge-3-4 d d3 d4) (ann (vector (solve-t d d4 d3) 1 0) (Vectorof Real)))
24(define-syntax-rule (edge-1-4 d d1 d4) (ann (vector 0 (solve-t d d1 d4) 0) (Vectorof Real)))
25
26(define-syntax-rule (edge-5-6 d d5 d6) (ann (vector (solve-t d d5 d6) 0 1) (Vectorof Real)))
27(define-syntax-rule (edge-6-7 d d6 d7) (ann (vector 1 (solve-t d d6 d7) 1) (Vectorof Real)))
28(define-syntax-rule (edge-7-8 d d7 d8) (ann (vector (solve-t d d7 d8) 1 1) (Vectorof Real)))
29(define-syntax-rule (edge-5-8 d d5 d8) (ann (vector 0 (solve-t d d5 d8) 1) (Vectorof Real)))
30
31(define-syntax-rule (edge-1-5 d d1 d5) (ann (vector 0 0 (solve-t d d1 d5)) (Vectorof Real)))
32(define-syntax-rule (edge-2-6 d d2 d6) (ann (vector 1 0 (solve-t d d2 d6)) (Vectorof Real)))
33(define-syntax-rule (edge-3-7 d d3 d7) (ann (vector 1 1 (solve-t d d3 d7)) (Vectorof Real)))
34(define-syntax-rule (edge-4-8 d d4 d8) (ann (vector 0 1 (solve-t d d4 d8)) (Vectorof Real)))
35
36#|
37Cube vertex numbers:
38
39   8--------7
40  /|       /|
41 5--------6 |
42 | |      | |      d  y
43 | 4------|-3      | /
44 |/       |/       |/
45 1--------2        +--- x
46|#
47
48(define-type Facet (Listof (Listof (Vectorof Real))))
49(define-type Facet-Fun (-> Real Real Real Real Real Real Real Real Real Facet))
50
51(: known-cube-0000-0000 Facet-Fun)
52(define (known-cube-0000-0000 d d1 d2 d3 d4 d5 d6 d7 d8) empty)
53
54(define known-cube-1111-1111 known-cube-0000-0000)
55
56(: known-cube-1000-0000 Facet-Fun)
57(define (known-cube-1000-0000 d d1 d2 d3 d4 d5 d6 d7 d8)
58  (list (list (edge-1-2 d d1 d2) (edge-1-5 d d1 d5) (edge-1-4 d d1 d4))))
59
60(define known-cube-0111-1111 known-cube-1000-0000)
61
62(: known-cube-1100-0000 Facet-Fun)
63(define (known-cube-1100-0000 d d1 d2 d3 d4 d5 d6 d7 d8)
64  (list (list (edge-1-5 d d1 d5) (edge-2-6 d d2 d6)
65              (edge-2-3 d d2 d3) (edge-1-4 d d1 d4))))
66
67(define known-cube-0011-1111 known-cube-1100-0000)
68
69(: known-cube-1110-0000 Facet-Fun)
70(define (known-cube-1110-0000 d d1 d2 d3 d4 d5 d6 d7 d8)
71  (list (list (edge-1-5 d d1 d5) (edge-2-6 d d2 d6) (edge-3-7 d d3 d7)
72              (edge-3-4 d d3 d4) (edge-1-4 d d1 d4))))
73
74(define known-cube-0001-1111 known-cube-1110-0000)
75
76(: known-cube-1111-0000 Facet-Fun)
77(define (known-cube-1111-0000 d d1 d2 d3 d4 d5 d6 d7 d8)
78  (list (list (edge-1-5 d d1 d5) (edge-2-6 d d2 d6)
79              (edge-3-7 d d3 d7) (edge-4-8 d d4 d8))))
80
81(define known-cube-0000-1111 known-cube-1111-0000)
82
83(: make-known-cube-1010-0000 (-> (-> Real Real Boolean) Facet-Fun))
84(define ((make-known-cube-1010-0000 test?) d d1 d2 d3 d4 d5 d6 d7 d8)
85  (define da (/ (+ d1 d2 d3 d4) 4))
86  (cond
87    [(test? da d)
88     (list (list (edge-1-2 d d1 d2) (edge-2-3 d d2 d3)
89                 (edge-3-7 d d3 d7) (edge-1-5 d d1 d5))
90           (list (edge-3-4 d d3 d4) (edge-1-4 d d1 d4)
91                 (edge-1-5 d d1 d5) (edge-3-7 d d3 d7)))]
92    [else
93     (list (list (edge-1-2 d d1 d2) (edge-1-5 d d1 d5) (edge-1-4 d d1 d4))
94           (list (edge-2-3 d d2 d3) (edge-3-4 d d3 d4) (edge-3-7 d d3 d7)))]))
95
96(define known-cube-1010-0000 (make-known-cube-1010-0000 >=))
97(define known-cube-0101-1111 (make-known-cube-1010-0000 <))
98
99(: known-cube-1000-0010 Facet-Fun)
100(define (known-cube-1000-0010 d d1 d2 d3 d4 d5 d6 d7 d8)
101  (list (list (edge-1-2 d d1 d2) (edge-1-5 d d1 d5) (edge-1-4 d d1 d4))
102        (list (edge-6-7 d d6 d7) (edge-3-7 d d3 d7) (edge-7-8 d d7 d8))))
103
104(define known-cube-0111-1101 known-cube-1000-0010)
105
106(: make-known-cube-1100-0010 (-> (-> Real Real Boolean) Facet-Fun))
107(define ((make-known-cube-1100-0010 test?) d d1 d2 d3 d4 d5 d6 d7 d8)
108  (define da (/ (+ d2 d6 d7 d3) 4))
109  (cond
110    [(test? da d)
111     (list (list (edge-1-5 d d1 d5) (edge-2-6 d d2 d6)
112                 (edge-6-7 d d6 d7) (edge-7-8 d d7 d8))
113           (list (edge-1-4 d d1 d4) (edge-2-3 d d2 d3)
114                 (edge-3-7 d d3 d7) (edge-7-8 d d7 d8))
115           (list (edge-1-5 d d1 d5) (edge-1-4 d d1 d4) (edge-7-8 d d7 d8)))]
116    [else
117     (list (list (edge-1-5 d d1 d5) (edge-2-6 d d2 d6)
118                 (edge-2-3 d d2 d3) (edge-1-4 d d1 d4))
119           (list (edge-6-7 d d6 d7) (edge-3-7 d d3 d7) (edge-7-8 d d7 d8)))]))
120
121(define known-cube-1100-0010 (make-known-cube-1100-0010 >=))
122(define known-cube-0011-1101 (make-known-cube-1100-0010 <))
123
124(: make-known-cube-1100-0011 (-> (-> Real Real Boolean) Facet-Fun))
125(define ((make-known-cube-1100-0011 test?) d d1 d2 d3 d4 d5 d6 d7 d8)
126  (define da (/ (+ d1 d5 d8 d4) 4))
127  (define db (/ (+ d2 d6 d7 d3) 4))
128  (cond
129    [(and (test? da d) (test? db d))
130     (list (list (edge-1-5 d d1 d5) (edge-5-8 d d5 d8)
131                 (edge-6-7 d d6 d7) (edge-2-6 d d2 d6))
132           (list (edge-1-4 d d1 d4) (edge-2-3 d d2 d3)
133                 (edge-3-7 d d3 d7) (edge-4-8 d d4 d8)))]
134    [(test? da d)
135     (define ec (v* (v+ (v+ (v+ (edge-1-5 d d1 d5) (edge-1-4 d d1 d4))
136                            (v+ (edge-4-8 d d4 d8) (edge-5-8 d d5 d8)))
137                        (v+ (v+ (edge-6-7 d d6 d7) (edge-2-6 d d2 d6))
138                            (v+ (edge-2-3 d d2 d3) (edge-3-7 d d3 d7))))
139                    1/8))
140     (list (list ec (edge-5-8 d d5 d8) (edge-6-7 d d6 d7))
141           (list ec (edge-1-5 d d1 d5) (edge-2-6 d d2 d6))
142           (list ec (edge-4-8 d d4 d8) (edge-3-7 d d3 d7))
143           (list ec (edge-1-4 d d1 d4) (edge-2-3 d d2 d3))
144           (list ec (edge-1-5 d d1 d5) (edge-5-8 d d5 d8))
145           (list ec (edge-1-4 d d1 d4) (edge-4-8 d d4 d8))
146           (list ec (edge-3-7 d d3 d7) (edge-6-7 d d6 d7))
147           (list ec (edge-2-3 d d2 d3) (edge-2-6 d d2 d6)))]
148    [(test? db d)
149     (define ec (v* (v+ (v+ (v+ (edge-1-5 d d1 d5) (edge-1-4 d d1 d4))
150                            (v+ (edge-4-8 d d4 d8) (edge-5-8 d d5 d8)))
151                        (v+ (v+ (edge-6-7 d d6 d7) (edge-2-6 d d2 d6))
152                            (v+ (edge-2-3 d d2 d3) (edge-3-7 d d3 d7))))
153                    1/8))
154     (list (list ec (edge-5-8 d d5 d8) (edge-6-7 d d6 d7))
155           (list ec (edge-1-5 d d1 d5) (edge-2-6 d d2 d6))
156           (list ec (edge-4-8 d d4 d8) (edge-3-7 d d3 d7))
157           (list ec (edge-1-4 d d1 d4) (edge-2-3 d d2 d3))
158           (list ec (edge-1-5 d d1 d5) (edge-1-4 d d1 d4))
159           (list ec (edge-4-8 d d4 d8) (edge-5-8 d d5 d8))
160           (list ec (edge-3-7 d d3 d7) (edge-2-3 d d2 d3))
161           (list ec (edge-6-7 d d6 d7) (edge-2-6 d d2 d6)))]
162    [else
163     (list (list (edge-1-5 d d1 d5) (edge-2-6 d d2 d6)
164                 (edge-2-3 d d2 d3) (edge-1-4 d d1 d4))
165           (list (edge-5-8 d d5 d8) (edge-6-7 d d6 d7)
166                 (edge-3-7 d d3 d7) (edge-4-8 d d4 d8)))]))
167
168(define known-cube-1100-0011 (make-known-cube-1100-0011 >=))
169(define known-cube-0011-1100 (make-known-cube-1100-0011 <))
170
171(: make-known-cube-1010-0101 (-> (-> Real Real Boolean) Facet-Fun))
172(define ((make-known-cube-1010-0101 test?) d d1 d2 d3 d4 d5 d6 d7 d8)
173  (define da (/ (+ d1 d2 d3 d4) 4))
174  (define db (/ (+ d1 d5 d8 d4) 4))
175  (define dc (/ (+ d3 d4 d8 d7) 4))
176  (define dd (/ (+ d1 d2 d6 d5) 4))
177  (define de (/ (+ d2 d3 d7 d6) 4))
178  (define df (/ (+ d5 d6 d7 d8) 4))
179  (append
180   (list (list (edge-1-5 d d1 d5) (edge-1-2 d d1 d2) (edge-1-4 d d1 d4))
181         (list (edge-2-3 d d2 d3) (edge-3-7 d d3 d7) (edge-3-4 d d3 d4))
182         (list (edge-5-6 d d5 d6) (edge-2-6 d d2 d6) (edge-6-7 d d6 d7))
183         (list (edge-7-8 d d7 d8) (edge-5-8 d d5 d8) (edge-4-8 d d4 d8)))
184   (if (test? da d)
185       (list (list (edge-1-2 d d1 d2) (edge-2-3 d d2 d3)
186                   (edge-3-4 d d3 d4) (edge-1-4 d d1 d4)))
187       empty)
188   (if (test? db d)
189       (list (list (edge-1-5 d d1 d5) (edge-5-8 d d5 d8)
190                   (edge-4-8 d d4 d8) (edge-1-4 d d1 d4)))
191       empty)
192   (if (test? dc d)
193       (list (list (edge-3-4 d d3 d4) (edge-3-7 d d3 d7)
194                   (edge-7-8 d d7 d8) (edge-4-8 d d4 d8)))
195       empty)
196   (if (test? dd d)
197       (list (list (edge-1-2 d d1 d2) (edge-2-6 d d2 d6)
198                   (edge-5-6 d d5 d6) (edge-1-5 d d1 d5)))
199       empty)
200   (if (test? de d)
201       (list (list (edge-2-3 d d2 d3) (edge-3-7 d d3 d7)
202                   (edge-6-7 d d6 d7) (edge-2-6 d d2 d6)))
203       empty)
204   (if (test? df d)
205       (list (list (edge-5-6 d d5 d6) (edge-6-7 d d6 d7)
206                   (edge-7-8 d d7 d8) (edge-5-8 d d5 d8)))
207       empty)))
208
209(define known-cube-1010-0101 (make-known-cube-1010-0101 >=))
210(define known-cube-0101-1010 (make-known-cube-1010-0101 <))
211
212(: make-known-cube-1110-0001 (-> (-> Real Real Boolean) Facet-Fun))
213(define ((make-known-cube-1110-0001 test?) d d1 d2 d3 d4 d5 d6 d7 d8)
214  (define da (/ (+ d1 d5 d8 d4) 4))
215  (define db (/ (+ d7 d8 d4 d3) 4))
216  (cond
217    [(and (test? da d) (test? db d))
218     (list (list (edge-1-5 d d1 d5) (edge-2-6 d d2 d6) (edge-3-7 d d3 d7))
219           (list (edge-1-5 d d1 d5) (edge-3-7 d d3 d7)
220                 (edge-7-8 d d7 d8) (edge-5-8 d d5 d8))
221           (list (edge-1-4 d d1 d4) (edge-3-4 d d3 d4) (edge-4-8 d d4 d8)))]
222    [(test? da d)
223     (define ec (v* (v+ (edge-1-5 d d1 d5) (edge-3-7 d d3 d7)) 1/2))
224     (list (list (edge-1-5 d d1 d5) (edge-2-6 d d2 d6) (edge-3-7 d d3 d7))
225           (list ec (edge-3-7 d d3 d7) (edge-3-4 d d3 d4) (edge-1-4 d d1 d4))
226           (list ec (edge-1-5 d d1 d5) (edge-5-8 d d5 d8) (edge-7-8 d d7 d8))
227           (list ec (edge-1-4 d d1 d4) (edge-4-8 d d4 d8) (edge-7-8 d d7 d8)))]
228    [(test? db d)
229     (define ec (v* (v+ (edge-1-5 d d1 d5) (edge-3-7 d d3 d7)) 1/2))
230     (list (list (edge-1-5 d d1 d5) (edge-2-6 d d2 d6) (edge-3-7 d d3 d7))
231           (list ec (edge-1-5 d d1 d5) (edge-1-4 d d1 d4) (edge-3-4 d d3 d4))
232           (list ec (edge-3-7 d d3 d7) (edge-7-8 d d7 d8) (edge-5-8 d d5 d8))
233           (list ec (edge-3-4 d d3 d4) (edge-4-8 d d4 d8) (edge-5-8 d d5 d8)))]
234    [else
235     (list (list (edge-1-5 d d1 d5) (edge-2-6 d d2 d6) (edge-3-7 d d3 d7))
236           (list (edge-1-5 d d1 d5) (edge-3-7 d d3 d7)
237                 (edge-3-4 d d3 d4) (edge-1-4 d d1 d4))
238           (list (edge-7-8 d d7 d8) (edge-5-8 d d5 d8) (edge-4-8 d d4 d8)))]))
239
240(define known-cube-1110-0001 (make-known-cube-1110-0001 >=))
241(define known-cube-0001-1110 (make-known-cube-1110-0001 <))
242
243(: known-cube-1110-0100 Facet-Fun)
244(define (known-cube-1110-0100 d d1 d2 d3 d4 d5 d6 d7 d8)
245  (list (list (edge-1-5 d d1 d5) (edge-5-6 d d5 d6) (edge-6-7 d d6 d7)
246              (edge-3-7 d d3 d7) (edge-3-4 d d3 d4) (edge-1-4 d d1 d4))))
247
248(define known-cube-0001-1011 known-cube-1110-0100)
249
250(: known-cube-1110-0010 Facet-Fun)
251(define (known-cube-1110-0010 d d1 d2 d3 d4 d5 d6 d7 d8)
252  (list (list (edge-1-5 d d1 d5) (edge-2-6 d d2 d6) (edge-6-7 d d6 d7)
253              (edge-7-8 d d7 d8) (edge-3-4 d d3 d4) (edge-1-4 d d1 d4))))
254
255(define known-cube-0001-1101 known-cube-1110-0010)
256
257(: make-known-cube-1010-0001 (-> (-> Real Real Boolean) Facet-Fun))
258(define ((make-known-cube-1010-0001 test?) d d1 d2 d3 d4 d5 d6 d7 d8)
259  (define da (/ (+ d1 d2 d3 d4) 4))
260  (define db (/ (+ d1 d5 d8 d4) 4))
261  (define dc (/ (+ d3 d4 d8 d7) 4))
262  (append
263   (list (list (edge-1-5 d d1 d5) (edge-1-2 d d1 d2) (edge-1-4 d d1 d4))
264         (list (edge-2-3 d d2 d3) (edge-3-7 d d3 d7) (edge-3-4 d d3 d4))
265         (list (edge-7-8 d d7 d8) (edge-5-8 d d5 d8) (edge-4-8 d d4 d8)))
266   (if (test? da d)
267       (list (list (edge-1-2 d d1 d2) (edge-2-3 d d2 d3)
268                   (edge-3-4 d d3 d4) (edge-1-4 d d1 d4)))
269       empty)
270   (if (test? db d)
271       (list (list (edge-1-5 d d1 d5) (edge-5-8 d d5 d8)
272                   (edge-4-8 d d4 d8) (edge-1-4 d d1 d4)))
273       empty)
274   (if (test? dc d)
275       (list (list (edge-3-4 d d3 d4) (edge-3-7 d d3 d7)
276                   (edge-7-8 d d7 d8) (edge-4-8 d d4 d8)))
277       empty)))
278
279(define known-cube-1010-0001 (make-known-cube-1010-0001 >=))
280(define known-cube-0101-1110 (make-known-cube-1010-0001 <))
281
282(define-for-syntax known-cubes
283  '((0 0 0 0 0 0 0 0)
284    (1 0 0 0 0 0 0 0)
285    (1 1 0 0 0 0 0 0)
286    (1 1 1 0 0 0 0 0)
287    (1 1 1 1 0 0 0 0)
288    (1 0 1 0 0 0 0 0)
289    (1 0 0 0 0 0 1 0)
290    (1 1 0 0 0 0 1 0)
291    (1 1 0 0 0 0 1 1)
292    (1 0 1 0 0 1 0 1)
293    (1 1 1 0 0 0 0 1)
294    (1 1 1 0 0 1 0 0)
295    (1 1 1 0 0 0 1 0)
296    (1 0 1 0 0 0 0 1)
297    (1 1 1 1 1 1 1 1)
298    (0 1 1 1 1 1 1 1)
299    (0 0 1 1 1 1 1 1)
300    (0 0 0 1 1 1 1 1)
301    (0 0 0 0 1 1 1 1)
302    (0 1 0 1 1 1 1 1)
303    (0 1 1 1 1 1 0 1)
304    (0 0 1 1 1 1 0 1)
305    (0 0 1 1 1 1 0 0)
306    (0 1 0 1 1 0 1 0)
307    (0 0 0 1 1 1 1 0)
308    (0 0 0 1 1 0 1 1)
309    (0 0 0 1 1 1 0 1)
310    (0 1 0 1 1 1 1 0)))
311
312;; cube transformations: mirror
313
314(: mirror-vec-d (-> (Vectorof Real) (Vectorof Real)))
315(define (mirror-vec-d v)
316  (match-define (vector x y d) v)
317  (vector x y (- 1 d)))
318
319(: mirror-cube-d (-> Facet-Fun Facet-Fun))
320(define ((mirror-cube-d f) d d1 d2 d3 d4 d5 d6 d7 d8)
321  (map (λ ([poly : (Listof (Vectorof Real))]) (map mirror-vec-d poly))
322       (f d d5 d6 d7 d8 d1 d2 d3 d4)))
323
324(: mirror-vec-y (-> (Vectorof Real) (Vectorof Real)))
325(define (mirror-vec-y v)
326  (match-define (vector x y d) v)
327  (vector x (- 1 y) d))
328
329(: mirror-cube-y (-> Facet-Fun Facet-Fun))
330(define ((mirror-cube-y f) d d1 d2 d3 d4 d5 d6 d7 d8)
331  (map (λ ([poly : (Listof (Vectorof Real))]) (map mirror-vec-y poly))
332       (f d d4 d3 d2 d1 d8 d7 d6 d5)))
333
334(: mirror-vec-x (-> (Vectorof Real) (Vectorof Real)))
335(define (mirror-vec-x v)
336  (match-define (vector x y d) v)
337  (vector (- 1 x) y d))
338
339(: mirror-cube-x (-> Facet-Fun Facet-Fun))
340(define ((mirror-cube-x f) d d1 d2 d3 d4 d5 d6 d7 d8)
341  (map (λ ([poly : (Listof (Vectorof Real))]) (map mirror-vec-x poly))
342       (f d d2 d1 d4 d3 d6 d5 d8 d7)))
343
344;; cube transformations: rotate clockwise (looking positively along axis)
345
346(: unrotate-vec-d (-> (Vectorof Real) (Vectorof Real)))
347(define (unrotate-vec-d v)
348  (match-define (vector x y d) v)
349  (vector (- 1 y) x d))
350
351(: rotate-cube-d (-> Facet-Fun Facet-Fun))
352(define ((rotate-cube-d f) d d1 d2 d3 d4 d5 d6 d7 d8)
353  (map (λ ([poly : (Listof (Vectorof Real))]) (map unrotate-vec-d poly))
354       (f d d2 d3 d4 d1 d6 d7 d8 d5)))
355
356(: unrotate-vec-y (-> (Vectorof Real) (Vectorof Real)))
357(define (unrotate-vec-y v)
358  (match-define (vector x y d) v)
359  (vector d y (- 1 x)))
360
361(: rotate-cube-y (-> Facet-Fun Facet-Fun))
362(define ((rotate-cube-y f) d d1 d2 d3 d4 d5 d6 d7 d8)
363  (map (λ ([poly : (Listof (Vectorof Real))]) (map unrotate-vec-y poly))
364       (f d d5 d1 d4 d8 d6 d2 d3 d7)))
365
366(: unrotate-vec-x (-> (Vectorof Real) (Vectorof Real)))
367(define (unrotate-vec-x v)
368  (match-define (vector x y d) v)
369  (vector x (- 1 d) y))
370
371(: rotate-cube-x (-> Facet-Fun Facet-Fun))
372(define ((rotate-cube-x f) d d1 d2 d3 d4 d5 d6 d7 d8)
373  (map (λ ([poly : (Listof (Vectorof Real))]) (map unrotate-vec-x poly))
374       (f d d4 d3 d7 d8 d1 d2 d6 d5)))
375
376;; cube transformations: rotate counterclockwise (looking negatively along axis)
377
378(: rotate-vec-d (-> (Vectorof Real) (Vectorof Real)))
379(define (rotate-vec-d v)
380  (match-define (vector x y d) v)
381  (vector y (- 1 x) d))
382
383(: unrotate-cube-d (-> Facet-Fun Facet-Fun))
384(define ((unrotate-cube-d f) d d1 d2 d3 d4 d5 d6 d7 d8)
385  (map (λ ([poly : (Listof (Vectorof Real))]) (map rotate-vec-d poly))
386       (f d d4 d1 d2 d3 d8 d5 d6 d7)))
387
388(: rotate-vec-y (-> (Vectorof Real) (Vectorof Real)))
389(define (rotate-vec-y v)
390  (match-define (vector x y d) v)
391  (vector (- 1 d) y x))
392
393(: unrotate-cube-y (-> Facet-Fun Facet-Fun))
394(define ((unrotate-cube-y f) d d1 d2 d3 d4 d5 d6 d7 d8)
395  (map (λ ([poly : (Listof (Vectorof Real))]) (map rotate-vec-y poly))
396       (f d d2 d6 d7 d3 d1 d5 d8 d4)))
397
398(: rotate-vec-x (-> (Vectorof Real) (Vectorof Real)))
399(define (rotate-vec-x v)
400  (match-define (vector x y d) v)
401  (vector x d (- 1 y)))
402
403(: unrotate-cube-x (-> Facet-Fun Facet-Fun))
404(define ((unrotate-cube-x f) d d1 d2 d3 d4 d5 d6 d7 d8)
405  (map (λ ([poly : (Listof (Vectorof Real))]) (map rotate-vec-x poly))
406       (f d d5 d6 d2 d1 d8 d7 d3 d4)))
407
408(define-for-syntax (cube-points-transform trans src)
409  (match-define (list j1 j2 j3 j4 j5 j6 j7 j8) src)
410  (cond [(t=? trans #'mirror-cube-d)    (list j5 j6 j7 j8 j1 j2 j3 j4)]
411        [(t=? trans #'mirror-cube-y)    (list j4 j3 j2 j1 j8 j7 j6 j5)]
412        [(t=? trans #'mirror-cube-x)    (list j2 j1 j4 j3 j6 j5 j8 j7)]
413        [(t=? trans #'rotate-cube-d)    (list j4 j1 j2 j3 j8 j5 j6 j7)]
414        [(t=? trans #'unrotate-cube-d)  (list j2 j3 j4 j1 j6 j7 j8 j5)]
415        [(t=? trans #'rotate-cube-y)    (list j2 j6 j7 j3 j1 j5 j8 j4)]
416        [(t=? trans #'unrotate-cube-y)  (list j5 j1 j4 j8 j6 j2 j3 j7)]
417        [(t=? trans #'rotate-cube-x)    (list j5 j6 j2 j1 j8 j7 j3 j4)]
418        [(t=? trans #'unrotate-cube-x)  (list j4 j3 j7 j8 j1 j2 j6 j5)]))
419
420(define-for-syntax known-transforms
421  (list #'mirror-cube-d
422        #'mirror-cube-y
423        #'mirror-cube-x
424        #'rotate-cube-d
425        #'rotate-cube-y
426        #'rotate-cube-x
427        #'unrotate-cube-d
428        #'unrotate-cube-y
429        #'unrotate-cube-x))
430
431(define-for-syntax (opposite-transform? t1 t2)
432  (or (and (t=? t1 #'mirror-d) (t=? t2 #'mirror-d))
433      (and (t=? t1 #'mirror-y) (t=? t2 #'mirror-y))
434      (and (t=? t1 #'mirror-x) (t=? t2 #'mirror-x))
435      (and (t=? t1 #'rotate-d) (t=? t2 #'unrotate-d))
436      (and (t=? t1 #'unrotate-d) (t=? t2 #'rotate-d))
437      (and (t=? t1 #'rotate-y) (t=? t2 #'unrotate-y))
438      (and (t=? t1 #'unrotate-y) (t=? t2 #'rotate-y))
439      (and (t=? t1 #'rotate-x) (t=? t2 #'unrotate-x))
440      (and (t=? t1 #'unrotate-x) (t=? t2 #'rotate-x))))
441
442(define-for-syntax (first-path-to-cube/src src dst depth)
443  (let/ec return
444    (let loop ([src src] [path empty] [depth depth])
445      ;(printf "path = ~v~n" path)
446      (cond [(or (equal? src dst) #;(equal? (invert-cube src) dst))  path]
447            [(zero? depth)  #f]
448            [else
449             (for ([move  (in-list known-transforms)]
450                   #:when (or (empty? path)
451                              (not (opposite-transform? move (first path)))))
452               (define new-src (cube-points-transform move src))
453               (define new-path (cons move path))
454               (if (or (equal? new-src dst)
455                       #;(equal? (invert-cube new-src) dst))
456                   (return new-path)
457                   (loop new-src new-path (sub1 depth))))
458             #f]))))
459
460(define-for-syntax (shortest-path-to-cube dst)
461  (let/ec return
462    (for ([depth  (in-list '(1 2 3))])
463      (for ([src  (in-list known-cubes)])
464        (define path (first-path-to-cube/src src dst depth))
465        (when path (return (cons src path)))))
466    (list #f #f)))
467
468(define-for-syntax (format-cube-id ctxt cube j1 j2 j3 j4 j5 j6 j7 j8)
469  (format-id ctxt "~a-~a~a~a~a-~a~a~a~a" cube
470             (->datum j1) (->datum j2)
471             (->datum j3) (->datum j4)
472             (->datum j5) (->datum j6)
473             (->datum j7) (->datum j8)))
474
475(define-syntax (define-all-cube-functions stx)
476  (syntax-case stx ()
477    [(id)
478     #`(begin
479         #,@(for*/list ([j8  (in-list '(0 1))]
480                        [j7  (in-list '(0 1))]
481                        [j6  (in-list '(0 1))]
482                        [j5  (in-list '(0 1))]
483                        [j4  (in-list '(0 1))]
484                        [j3  (in-list '(0 1))]
485                        [j2  (in-list '(0 1))]
486                        [j1  (in-list '(0 1))])
487              (define dst (list j1 j2 j3 j4 j5 j6 j7 j8))
488              (match-define (cons src path) (shortest-path-to-cube dst))
489              (cond [(or (empty? path) (first path))
490                     (with-syntax ([define-cube-function
491                                     (format-id #'id "define-cube-function")])
492                       #`(define-cube-function
493                           #,dst #,src #,path))]
494                    [else  (void)])))]))
495
496(define-syntax (define-cube-function stx)
497  (syntax-case stx ()
498    [(id (d1 d2 d3 d4 d5 d6 d7 d8)
499         (s1 s2 s3 s4 s5 s6 s7 s8)
500         path)
501     (with-syntax ([cube-dst  (format-cube-id #'id "cube"
502                                              #'d1 #'d2 #'d3 #'d4
503                                              #'d5 #'d6 #'d7 #'d8)]
504                   [cube-src  (format-cube-id #'id "known-cube"
505                                              #'s1 #'s2 #'s3 #'s4
506                                              #'s5 #'s6 #'s7 #'s8)])
507       (define new-stx
508         (syntax-case #'path ()
509           [()          #'(define cube-dst cube-src)]
510           [(t)         #'(define cube-dst (t cube-src))]
511           [(t2 t1)     #'(define cube-dst (t2 (t1 cube-src)))]
512           [(t3 t2 t1)  #'(define cube-dst (t3 (t2 (t1 cube-src))))]))
513       ;(printf "~a~n" (syntax->datum new-stx))
514       new-stx)]))
515
516
517(define-syntax (make-cube-dispatch-table stx)
518  (syntax-case stx ()
519    [(id)
520     #`(vector
521        #,@(for*/list ([j8  (in-list '(0 1))]
522                       [j7  (in-list '(0 1))]
523                       [j6  (in-list '(0 1))]
524                       [j5  (in-list '(0 1))]
525                       [j4  (in-list '(0 1))]
526                       [j3  (in-list '(0 1))]
527                       [j2  (in-list '(0 1))]
528                       [j1  (in-list '(0 1))])
529             (format-cube-id #'id "cube" j1 j2 j3 j4 j5 j6 j7 j8)))]))
530
531(define-all-cube-functions)
532
533(define cube-dispatch-table
534  (make-cube-dispatch-table))
535
536(define-syntax-rule (add-digit j idx)
537  (unsafe-fx+ (unsafe-fx* idx 2) j))
538
539(: do-heights->cube-polys Facet-Fun)
540(define (do-heights->cube-polys d d1 d2 d3 d4 d5 d6 d7 d8)
541  (define j1 (if (d1 . < . d) 0 1))
542  (define j2 (if (d2 . < . d) 0 1))
543  (define j3 (if (d3 . < . d) 0 1))
544  (define j4 (if (d4 . < . d) 0 1))
545  (define j5 (if (d5 . < . d) 0 1))
546  (define j6 (if (d6 . < . d) 0 1))
547  (define j7 (if (d7 . < . d) 0 1))
548  (define j8 (if (d8 . < . d) 0 1))
549  (define facet-num
550    (add-digit
551     j1 (add-digit
552         j2 (add-digit
553             j3 (add-digit
554                 j4 (add-digit
555                     j5 (add-digit
556                         j6 (add-digit j7 j8))))))))
557  (define f (vector-ref cube-dispatch-table facet-num))
558  (f d d1 d2 d3 d4 d5 d6 d7 d8))
559
560(:: heights->cube-polys (-> Real Real Real Real Real Real
561                            Real Real Real Real Real Real Real Real Real
562                            (Listof (Listof (Vector Real Real Real)))))
563(define (heights->cube-polys xa xb ya yb za zb d d1 d2 d3 d4 d5 d6 d7 d8)
564  (cond [(= d d1 d2 d3 d4 d5 d6 d7 d8)  empty]
565        [else
566         (define polys (do-heights->cube-polys d d1 d2 d3 d4 d5 d6 d7 d8))
567         (for/list ([poly  (in-list polys)])
568           (for/list : (Listof (Vector Real Real Real)) ([uvw  (in-list poly)])
569             (match-define (vector u v w) uvw)
570             (vector (unsolve-t xa xb u)
571                     (unsolve-t ya yb v)
572                     (unsolve-t za zb w))))]))
573