New project: snake sube solver.

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))))))