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