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