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