; Copyright (c) 2002, Kenneth L. Williams
; A program to find all solutions to selected puzzle from the Snafooz
; foam cube puzzle (www.snafooz.com). Currently, piece descriptions
; are built in, and the program only solves one puzzle at a time.
(require (lib "extra.ss" "swindle"))
; This program requires Eli Barzilay's Swindle libraries for the amb,
; amb-assert, and amb-collect forms. See
;
; http://www.cs.cornell.edu/eli/Swindle/
;
; for details.
(define (split ls k); => first / second
; Splits the list ls into two sublists at the kth element; returns
; the first k elements in the first value and the rest of the
; elements in the second value.
(let loop ([n 0]
[front null]
[back ls])
(if (>= n k)
(values (reverse front) back)
(loop (+ n 1)
(cons (car back) front)
(cdr back)))))
(define (last ls); => item
; Returns the last item of a list
(car (last-pair ls)))
(define (def-piece name . edges); => piece
; Accepts a list of the edges of a piece as a sort of two-
; dimensional picture and returns the piece that the edges describe.
; NOTE: Currently, pieces are assumed to be square!
; compute the length of a side
(define n (add1 (/ (length edges) 4)))
(if (integer? n)
;+ it's a square
(let*-values ([(edges*) edges]
[(north west east south)
; process the top line
(let-values ([(top rest) (split edges* n)])
; loop to process the remaining lines
(let loop ([left (list (car top))]
[right (list (last top))]
[bot rest])
(if (> (length bot) n)
;+ process each line of left/right pairs
(loop
(cons (car bot) left) ; left
(cons (cadr bot) right) ; right
(cddr bot)) ; bot
;+ process the last line
(values top
(reverse (cons (car bot) left))
(reverse (cons (last bot) right))
bot)
)
))])
(make-piece name 0 " "
north east south west
))
;+ it's not a square--sorry
(raise (format "~a is not square: ~a" (length edges) n))))
(define-struct piece (name
angle ; angle (0, 90, 180, 270)
flip ; which side is up?
n-edge
e-edge
s-edge
w-edge
))
(define (piece-name-and-orientation p); => full-name
; Returns the full description (piece name and orientation) for piece p.
(let ([name (piece-name p)]
[flip (piece-flip p)]
[angle (piece-angle p)])
(string-append
name
flip
(case angle
[(0) " "]
[(90) "r"]
[(180) "i"]
[(270) "l"]))))
(define (display-piece p)
; Displays piece p in a "grapical" representation (needs to be
; improved).
(define fmt " ~s ~s ~s ~s ~s ~s~n")
(printf "~a:~n" (piece-name-and-orientation p))
(apply printf fmt (piece-n-edge p))
(let loop ([w (cdr (piece-w-edge p))]
[e (cdr (piece-e-edge p))])
(printf fmt (car w) '- '- '- '- (car e))
(if (> (length w) 2)
(loop (cdr w) (cdr e)))
)
(apply printf fmt (piece-s-edge p))
)
(define-struct cube (to le fr ri bo bk))
(define (display-solution-pair cube)
; Displays the layout of the given solution cube and its inverse to
; the current output port.
(define cube* (invert-cube cube))
(printf "=============~n")
(for-each
(lambda (label face)
(printf "~a ~a ~a~n"
label
(piece-name-and-orientation (face cube))
(piece-name-and-orientation (face cube*))))
(list "To" "Le" "Fr" "Ri" "Bo" "Bk")
(list cube-to cube-le cube-fr cube-ri cube-bo cube-bk)))
(define (display-cube cube)
; Displays a cube by listing its six pieces. Needs improvement.
(printf "=============~n")
(for-each (lambda (label face)
(printf "~a:~n" label)
(display-piece (face cube)))
(list "Top" "Left" "Front" "Right" "Bottom" "Back")
(list cube-to cube-le cube-fr cube-ri cube-bo cube-bk)))
(define (R p); => p*
; Rotates piece p right (90 degrees clockwise), returning a new
; piece p*.
; a b c g h a
; h d => f b
; g f e e d c
(let ([n (piece-n-edge p)]
[e (piece-e-edge p)]
[s (piece-s-edge p)]
[w (piece-w-edge p)])
(make-piece
(piece-name p)
(modulo (+ 90 (piece-angle p)) 360)
(piece-flip p)
(reverse w) n (reverse e) s )))
(define (L p); => p*
; Rotates piece p left (90 degrees counter clockwise), returning
; a new piece p*.
(R (R (R p))))
(define (I p); => p*
; Inverts piece p 180 degrees, returning a new piece p*.
(R (R p)))
(define (H p); => p*
; Flips a piece p horizontally, front to back, returning a new piece
; p*.
(let ([name (piece-name p)]
[angle (piece-angle p)]
[flip (piece-flip p)]
[n (piece-n-edge p)]
[e (piece-e-edge p)]
[s (piece-s-edge p)]
[w (piece-w-edge p)])
(make-piece
name
(modulo (- 360 angle) 360)
(if (string=? flip " ") "'" " ")
(reverse n) w (reverse s) e)))
(define (edge-match e1 e2); => Bool
; Determines whether two edges match. Two edges match if there are
; no bump clashes (but there may be "missing teeth").
(andmap (lambda (x y) (<= (+ x y) 1) ) e1 e2))
(define (v-edge-match p1 p2); => Bool
; Determines whether the pieces p1 and p2 match vertically along
; their south-north edges.
(edge-match (piece-s-edge p1) (piece-n-edge p2)))
(define (corner-match x y z); => Bool
; Determines whether the pieces x, y, and z match along their common
; edges and corner. The ordering of the pieces implies that the pieces
; when layed out flat look like this:
;
; c +---+
; \ | z |
; +---o---+ b
; | x | y |
; +---+---+
; a
;
; where the common corner is marked by the "o" and the edges by "a", "b", "c".
(let ([n-x (piece-n-edge x)]
[e-x (piece-e-edge x)]
[n-y (piece-n-edge y)]
[w-y (piece-w-edge y)]
[s-z (piece-s-edge z)]
[w-z (piece-w-edge z)])
(and
(edge-match e-x w-y) ; (edge a)
(edge-match s-z n-y) ; (edge b)
(edge-match n-x w-z) ; (edge c)
(= 1 (+ (car e-x) (car n-y) (car s-z))))))
(define (choose-one items); => item
; Ambiguosly chooses an item from the given list of items.
(if (null? items)
(amb)
(amb (car items)
(choose-one (cdr items)))))
(define (choose-piece pieces); => piece / pieces*
; Ambiguously chooses pieces from the given list of pieces,
; returning the chosen piece and an updated pieces* list
; (the pieces list with the chosen piece removed).
(unless (null? pieces)
(let* ([piece (choose-one pieces)]
[pieces* (remove piece pieces)])
(values piece pieces*))))
(define (choose-orientation p)
; Ambiguously chooses an orientation for the piece p from the eight
; possible orientations of a piece.
(define p* (H p))
(amb p (R p) (I p) (L p) p* (R p*) (I p*) (L p*)))
(define (choose-piece-and-orientation pieces); => piece / pieces*
(unless (null? pieces)
(let* ([piece (choose-one pieces)]
[pieces* (remove piece pieces)])
(values (choose-orientation piece) pieces*))))
(define (invert-cube c); => c*
; Inverts the cube c to its inside-out dual c*.
(apply make-cube (map H (list
(cube-to c) ; to
(cube-ri c) ; le <-+
(cube-fr c) ; fr |
(cube-le c) ; ri <-+
(cube-bo c) ; bo
(cube-bk c) ; bk
))))
(define A (def-piece "A"
0 0 1 1 0 0
1 0
0 1
0 1
1 0
0 1 0 0 1 0 ))
(define B (def-piece "B"
1 1 0 1 0 1
1 1
0 0
0 1
1 0
0 0 1 1 0 0 ))
(define C (def-piece "C"
0 0 1 1 0 1
0 1
1 0
0 0
1 1
0 1 0 0 1 1 ))
(define D (def-piece "D"
0 0 1 1 0 1
1 1
0 0
0 0
1 1
1 1 0 0 1 1 ))
(define E (def-piece "E"
0 1 0 0 1 0
0 0
1 1
1 1
0 0
0 0 1 1 0 0 ))
(define F (def-piece "F"
1 0 1 1 0 0
1 1
0 0
0 1
1 0
0 0 1 1 0 0 ))
(define (search); => cube
; Searches a subset of all possible solutions and returns a cube representing
; a fully-formed solution.
; The continuation of this program is saved in the amb tree (a parameter
; allocated by amb), so the remaining solutions may be gotten. All solutions
; can be obtained using amb-collect.
; The complete list of pieces (for this puzzle)
(define p6 (list A B C D E F))
;; == Front ==
; Fix the A piece onto the front face and leave the remaining
; five pieces in p5.
(define-values (Fr p5) (values (car p6) (cdr p6)))
;; == Top ==
(let-values ([(To p4) (choose-piece-and-orientation p5)])
(amb-assert (v-edge-match To Fr))
;; == Left ==
(let-values ([(Le p3) (choose-piece-and-orientation p4)])
(amb-assert (corner-match Le Fr To))
;; == Right ==
(let-values ([(Ri p2) (choose-piece-and-orientation p3)])
(amb-assert (corner-match Fr Ri (R To)))
;; == Bottom ==
(let-values ([(Bo p1) (choose-piece-and-orientation p2)])
(amb-assert (corner-match (L Le) Bo Fr))
(amb-assert (corner-match Bo (R Ri) (R Fr)))
;; == Back ==
(let-values ([(Bk p0) (choose-piece-and-orientation p1)])
(amb-assert (corner-match (I Le) Bk Bo))
(amb-assert (corner-match Bk (I Ri) (R Bo)))
(amb-assert (corner-match (R Le) To Bk))
(amb-assert (corner-match To (L Ri) (R Bk)))
;; Success: return this solution as a fully-formed cube
(make-cube To Le Fr Ri Bo Bk)
))))))
(define solutions (amb-collect (time (search))))
(printf "~nSOLUTIONS: ~a*2~n" (length solutions))
; Display each solution and its inside-out inverse
(for-each display-solution-pair solutions)