summaryrefslogtreecommitdiffstats
path: root/snake-cube.tl
blob: 8a0120957c03f5e21ccf8a89387f89cbf3352ab2 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
;; 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 ;; 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))
        (add (build
               (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                ;; 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)
         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)))

  ;; Check piece for invalid intersections. Returns true if okay,
  ;; otherwise nils.
  (:method intersect-check (me ctx)
    (and
      ;; 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)))
      ;; 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))
      (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)))))

  ;; 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)      ;; 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)))))
      ;; 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)
                                         #(: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)))))))
        ;; 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))))))