diff options
| -rw-r--r-- | snake-cube.tl | 141 |
1 files changed, 141 insertions, 0 deletions
diff --git a/snake-cube.tl b/snake-cube.tl new file mode 100644 index 0000000..dfaae2e --- /dev/null +++ b/snake-cube.tl @@ -0,0 +1,141 @@ +(defstruct (solve-context l w h) () + l w h + vol + sz + sols + + (:postinit (me) + (set me.vol (* me.l me.w me.h)) + (set me.sz (max me.l me.w me.h))) + + (:method sol-lists (me) + (build + (each ((s me.sols)) + (add (build + (for ((i s)) (i) ((set i i.parent)) + (add* i)))))))) + +(defvarl type-to-sym (hash)) +(defvarl sym-to-type (hash)) + +(defstruct piece () + parent + x y z + max-x max-y max-z + min-x min-y min-z + l w h + (orientation :z0) + + (:method print (me stream pretty-p) + (print ^(,me.sym ,me.x ,me.y ,me.z) stream pretty-p)) + + (:postinit (me) + (set me.max-x (succ me.x) + me.max-y (succ me.y) + me.max-z (succ me.z) + me.min-x me.x + me.min-y me.y + me.min-z me.z) + (whenlet ((par me.parent)) + (upd me.max-x (max par.max-x)) + (upd me.max-y (max par.max-y)) + (upd me.max-z (max par.max-z)) + (upd me.min-x (min par.min-x)) + (upd me.min-y (min par.min-y)) + (upd me.min-z (min par.min-z))) + (set me.w (- me.max-x me.min-x) + me.l (- me.max-y me.min-y) + me.h (- me.max-z me.min-z))) + + (:method intersect-check (me ctx) + (and + ;; no self intersection + (for ((par me.parent) (ok t)) ((and par ok) ok) ((set par par.parent)) + (when (and (eql me.x par.x) + (eql me.y par.y) + (eql me.z par.z)) + (zap ok))) + ;; no out of bounds + (<= me.l ctx.sz) + (<= me.w ctx.sz) + (<= me.h ctx.sz))) + + (:method shape-check (me ctx) + (let ((mw me.w) (ml me.l) (mh me.h) + (w ctx.w) (l ctx.l) (h ctx.h)) + (or (and (eql mw w) (eql ml l) (eql mh h)) + (and (eql mw w) (eql ml h) (eql mh l)) + (and (eql mw l) (eql ml w) (eql mh h)) + (and (eql mw l) (eql ml h) (eql mh w)) + (and (eql mw h) (eql ml w) (eql mh l)) + (and (eql mw h) (eql ml l) (eql mh w))))) + + (:method solved-check (me ctx) + (if me.(shape-check ctx) + (push me ctx.sols))) + + (:function derived (super sub) + (let ((sym (static-slot sub 'sym))) + (set [sym-to-type sym] sub + [type-to-sym sub] sym)))) + +(defstruct straight-piece piece + (:static sym 's) + (:method solve (me symbols ctx) + (if symbols + (let* ((ori me.orientation) + (x me.x) + (y me.y) + (z me.z) + (nx-loc (caseq ori + (:z0 ^#(,x ,y ,(pred z))) + (:z1 ^#(,x ,y ,(succ z))) + (:x0 ^#(,(pred x) ,y ,z)) + (:x1 ^#(,(succ x) ,y ,z)) + (:y0 ^#(,x ,(pred y) ,z)) + (:y1 ^#(,x ,(succ y) ,z))))) + (when-match #(@nx @ny @nz) nx-loc + (let ((nx (new* ([sym-to-type (car symbols)]) + parent me orientation ori x nx y ny z nz))) + (if nx.(intersect-check ctx) + nx.(solve (cdr symbols) ctx))))) + me.(solved-check ctx)))) + +(defstruct elbow-piece piece + (:static sym 'e) + (:method solve (me symbols ctx) + (if symbols + (let* ((ori me.orientation) + (x me.x) + (y me.y) + (z me.z) + (nx-ori-loc (caseq ori + ((:z0 :z1) ^#(#(:x0 ,(pred x) ,y ,z) + #(:x1 ,(succ x) ,y ,z) + #(:y0 ,x ,(pred y) ,z) + #(:y1 ,x ,(succ y) ,z))) + ((:x0 :x1) ^#(#(:y0 ,x ,(pred y) ,z) + #(:y1 ,x ,(succ y) ,z) + #(:z0 ,x ,y ,(pred z)) + #(:z1 ,x ,y ,(succ z)))) + ((:y0 :y1) ^#(#(:x0 ,(pred x) ,y ,z) + #(:x1 ,(succ x) ,y ,z) + #(:z0 ,x ,y ,(pred z)) + #(:z1 ,x ,y ,(succ z))))))) + (each-match (#(@nori @nx @ny @nz) nx-ori-loc) + (let ((nx (new* ([sym-to-type (car symbols)]) + parent me orientation nori x nx y ny z nz))) + (if nx.(intersect-check ctx) + nx.(solve (cdr symbols) ctx))))) + me.(solved-check ctx)))) + +(defun solve (symbols l w h) + (let ((len (length symbols)) + (ctx (new (solve-context l w h)))) + (cond + ((null symbols) symbols) + ((neq ctx.vol len) nil) + (t (let ((piece (new* ([sym-to-type (car symbols)]) + orientation :z1 x 0 y 0 z 0))) + piece.(solve (rest symbols) ctx) + ctx.(sol-lists)))))) |