diff options
| -rw-r--r-- | snake-cube.tl | 128 |
1 files changed, 114 insertions, 14 deletions
diff --git a/snake-cube.tl b/snake-cube.tl index dfaae2e..8a01209 100644 --- a/snake-cube.tl +++ b/snake-cube.tl @@ -1,13 +1,47 @@ +;; Snake Cube Solver +;; +;; Copyright 2021 +;; Kaz Kylheku <kaz@kylheku.com> +;; Vancouver, Canada +;; All rights reserved. +;; +;; Redistribution and use in source and binary forms, with or without +;; modification, are permitted provided that the following conditions are met: +;; +;; 1. Redistributions of source code must retain the above copyright notice, this +;; list of conditions and the following disclaimer. +;; +;; 2. Redistributions in binary form must reproduce the above copyright notice, +;; this list of conditions and the following disclaimer in the documentation +;; and/or other materials provided with the distribution. +;; +;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +;; Context object specifies problem parameters, +;; and provides a container for gathering solutions +;; during the recursive search. + (defstruct (solve-context l w h) () - l w h - vol - sz - sols + l w h ;; dimensions of rectangular prism to be filled + vol ;; product of dimensions + sz ;; "size" -- longest dimension + sols ;; list of solutions (:postinit (me) (set me.vol (* me.l me.w me.h)) (set me.sz (max me.l me.w me.h))) + ;; Solutions are themselves lists of piece objects linked via their parent + ;; fields, in reverse. This method converts the list of solutions + ;; into a list of ordinary Lisp lists. (:method sol-lists (me) (build (each ((s me.sols)) @@ -15,20 +49,27 @@ (for ((i s)) (i) ((set i i.parent)) (add* i)))))))) +;; Map from piece type to its symbolic nickname, e.g. straight-piece -> s. (defvarl type-to-sym (hash)) + +;; Reverse map: e.g. s -> straight-piece. (defvarl sym-to-type (hash)) +;; base class for piecews. (defstruct piece () - parent - x y z - max-x max-y max-z - min-x min-y min-z - l w h - (orientation :z0) + parent ;; previous piece in the chain being constructed. + x y z ;; coordinates of bottom-left-lower corner of piece + max-x max-y max-z ;; bounding box minima and maxima of this piece + min-x min-y min-z ;; and all its parent ancestors. + l w h ;; bounding box expressed as length-width-height + (orientation :z0) ;; orientation for next piece: z0, z1, y0, y1, x0, x1. + ;; print piece incondensed notation: just nickname sym and coordinates (:method print (me stream pretty-p) (print ^(,me.sym ,me.x ,me.y ,me.z) stream pretty-p)) + ;; initialize piece: calculate the bounding box and volume + ;; of the combination of this piece and its parent. (:postinit (me) (set me.max-x (succ me.x) me.max-y (succ me.y) @@ -47,19 +88,27 @@ me.l (- me.max-y me.min-y) me.h (- me.max-z me.min-z))) + ;; Check piece for invalid intersections. Returns true if okay, + ;; otherwise nils. (:method intersect-check (me ctx) (and - ;; no self intersection + ;; No self-intersection of snake chain allowed. (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 + ;; Bounding box of chain must not exceed box size. + ;; This check isn't necessary, but vastly speeds up the search. (<= me.l ctx.sz) (<= me.w ctx.sz) (<= me.h ctx.sz))) + ;; Shape check: has the chain produced the required box? + ;; This is only tested at the end of the chain when all the pieces + ;; are in place. We know that the chain has the right number of + ;; pieces, e.g. 27 for 3x3x3 box from the outset. We check for + ;; the box only when all pieces are added to the chain (:method shape-check (me ctx) (let ((mw me.w) (ml me.l) (mh me.h) (w ctx.w) (l ctx.l) (h ctx.h)) @@ -70,46 +119,85 @@ (and (eql mw h) (eql ml w) (eql mh l)) (and (eql mw h) (eql ml l) (eql mh w))))) + ;; Solution check done at end of chain: if there is + ;; a shape match in any orientation, then add the chain + ;; to the list of solutions. (:method solved-check (me ctx) (if me.(shape-check ctx) (push me ctx.sols))) + ;; Derived hook: add the nickname and type of the piece type + ;; to the hashes. (:function derived (super sub) (let ((sym (static-slot sub 'sym))) (set [sym-to-type sym] sub [type-to-sym sub] sym)))) +;; Straight piece class. (defstruct straight-piece piece - (:static sym 's) + (:static sym 's) ;; nickname symbol is s. + (:method solve (me symbols ctx) (if symbols + ;; If there are pieces left in the chain, + ;; continue the solution search by constructing the next + ;; piece in the list, and adding it to this straight + ;; piece according to the configuration. Then + ;; recurse to the new piece's solution method. (let* ((ori me.orientation) (x me.x) (y me.y) (z me.z) (nx-loc (caseq ori + ;; There are six possible orientations + ;; wher the next piece may go, two + ;; for each axis. For each orientation, + ;; pick the xyz coordinates for the next piece. (: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))))) + ;; Construct piece from the calculated xyz coordinates. + ;; The parent of the piece is this one, and its orientation + ;; is inherited from this one, since this one is straight. (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))) + ;; The chain can only continue by recursing into + ;; the next piece's solve method, if the intersection + ;; check passes. If we hit self-intersection or + ;; exceed the bounding box, we bail out and backtrack. (if nx.(intersect-check ctx) nx.(solve (cdr symbols) ctx))))) - me.(solved-check ctx)))) + ;; No pieces left: check if the chain is a solution + ;; and add it to the list if so. + me.(solved-check ctx)))) +;; Elbow piece class: more tricky than straight piece. (defstruct elbow-piece piece (:static sym 'e) (:method solve (me symbols ctx) (if symbols + ;; If there are pieces left in the chain, + ;; continue the solution search by constructing four + ;; new pieces, for every possible rotation of the + ;; elbow. Try all four ways of continuing by recursing + ;; on the solution method of all four ways, or + ;; at least those which don't fail the intersection + ;; criteria. (let* ((ori me.orientation) (x me.x) (y me.y) (z me.z) (nx-ori-loc (caseq ori + ;; The elbow piece may be oriented + ;; along any of the three axes, + ;; and provides four rotations. + ;; For each rotation we calculate + ;; the next orientation and xyz + ;; coordinates. ((:z0 :z1) ^#(#(:x0 ,(pred x) ,y ,z) #(:x1 ,(succ x) ,y ,z) #(:y0 ,x ,(pred y) ,z) @@ -122,20 +210,32 @@ #(:x1 ,(succ x) ,y ,z) #(:z0 ,x ,y ,(pred z)) #(:z1 ,x ,y ,(succ z))))))) + ;; Iterate over the four rotations, and construct + ;; the next piece, using the orientation and coordinates + ;; from each rotation. (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))))) + ;; Same as with straight piece: check for solution. me.(solved-check ctx)))) +;; Main solve function: takes a list of symbol nicknames and length-width-height +;; parameters. (defun solve (symbols l w h) (let ((len (length symbols)) (ctx (new (solve-context l w h)))) (cond + ;; empty list of symbols means no solutions ((null symbols) symbols) + ;; length of list doesn't correspond to solution volume: no solution. ((neq ctx.vol len) nil) + ;; Convert first symbol to a class, then call the solve method + ;; for the rest of the symbols. (t (let ((piece (new* ([sym-to-type (car symbols)]) orientation :z1 x 0 y 0 z 0))) piece.(solve (rest symbols) ctx) + ;; Extract and return list of solutions, in simplified + ;; list structure ctx.(sol-lists)))))) |