;;;; solve the Blue Snafooz puzzle (www.snafooz.com)

; Copyright 2002  Peter Olson <peabo@peabo.com>

; This is a deterministic algorithm using a general purpose
; permutation routine (contrasted with Ken Williams' solution
; using the amb construct).  It's based on the canonical
; way of solving the Eight Queens problem in chess.

; Management summary
;  The solution Ken wrote runs faster than mine most of the time
;  by a factor of 20% or so.  Sometimes it runs slower, by a factor of
;  5% or so.  It seems to depend on the amount of garbage collection
;  going on.  My version doesn't seem to trigger GC.

;  Ken's solution of how to input the puzzle is better than mine,
;  because it doesn't require as much auditing.  If his input
;  looks right, it is right.

;  I had a lot of trouble with my coding of the edges (it just goes
;  to show that you can write FORTRAN in any language :-)  My premature
;  optimization just made things trickier, and I spent a lot of
;  time debugging why the program didn't produce any solutions.  On
;  the other hand, the first time it produced any solutions at all
;  they were the correct solutions.  I can only attribute that to the
;  design of the puzzle.

(define (dbg) #f)       ; set true to enable debug output (2741 lines output)
(define (audit) #f)     ; set true to output a display of the puzzle package

; Puzzle pieces are labeled
;   A B C
;   D E F
; as they appear in the 2-D frame.
; Each piece has 8 orientations
;   0 as it appears in the 2-D frame
;   1 quarter turn clockwise
;   2 half turn clockwise
;   3 three quarter turn clockwise
;   4 flipped over on horizontal axis
;   5 flipped, followed by quarter turn counter-clockwise
;   6 flipped, followed by half turn counter-clockwise
;   7 flipped, followed by three quarter turn counter-clockwise
; For example, showing piece F: in orientations F0 and F5:
;
;  F   F F            F   F
;  F F  0  F F      F F 5 F
;    3 --- F      F 4 --- F F
;    F --- 1 F    F F --- 6 F
;  F F  2  F        F 7 F F
;      F F          F     F F 
;
; This program solves the puzzle by assuming that the "A" piece
; is oriented with 0 up (or flipped, with 4 up; as we found
; out at the December meeting, all the A4 solutions are trivial
; variations of the A0 solutions, by turning the cube inside-out).
; Then, three more pieces are selected to make a horizonal
; band around the cube rotating it clockwise as seen from above.
; Then the top piece is put on (its orientation is specified
; relative to the top of the A piece, and finally the bottom piece
; is attached, orientated towards the bottom of the A piece).
;                 F3
; One solution is A0 C2 B1 D3
;                 E3

; If you run this program with audit set to true, it displays the
; 2-D frame with the puzzle pieces as they are shipped:
; -  -  A  A  -  B  B  -  B  -  B  -  C  C  -  C 
; A  -  -  -  -  B  -  -  -  -  B  -  -  -  -  C 
; -  -  -  -  -  A  -  -  -  -  C  -  -  -  -  - 
; -  -  -  -  -  A  -  -  -  -  B  -  -  -  -  - 
; A  -  -  -  -  B  -  -  -  -  C  -  -  -  -  C 
; -  A  D  D  A  D  E  B  B  E  F  C  F  F  C  C 
; D  -  -  -  -  D  -  -  -  -  F  -  -  -  -  F 
; -  -  -  -  -  E  -  -  -  -  E  -  -  -  -  - 
; -  -  -  -  -  E  -  -  -  -  E  -  -  -  -  F 
; D  -  -  -  -  D  -  -  -  -  F  -  -  -  -  - 
; D  D  -  -  D  D  -  E  E  -  -  -  F  F  -  -

; If you run it with audit set to false, it solves the problem:
;(A0 B4 F6 E0 D5 C6)   ; NOTE A: see below
;(A0 B4 F6 E6 D5 C6)
;(A0 C2 B1 D3 F3 E3)   ; symmetry of the E piece doubles
;(A0 C2 B1 D3 F3 E5)   ; the number of solutions from 4 to 8
;(A0 D2 F1 C3 B3 E3)
;(A0 D2 F1 C3 B3 E5)
;(A0 F4 B6 E0 C5 D6)   ; NOTE A: symmetry of B and F together
;(A0 F4 B6 E6 C5 D6)   ; doubles number of solutions from 2 to 4
; The following only appear if you constrain A to be A0 and A4
; rather than only A0; to get them, just add 4 to the orientation
; of each face in the preceding list.
;(A4 B0 F2 E2 C0 D1)
;(A4 B0 F2 E4 C0 D1)
;(A4 C6 B7 D5 E1 F7)
;(A4 C6 B7 D5 E7 F7)
;(A4 D6 F7 C5 E1 B7)
;(A4 D6 F7 C5 E7 B7)
;(A4 F0 B2 E2 D0 C1)
;(A4 F0 B2 E4 D0 C1)
;16

; Two different data structures are built depending on the value of audit.
(define make-puzzle (if (audit) list append))
(define make-row list)

(define (make-edge-set face-name front back . edges)
  (define (build-edges face)
    (map build-one-edge face))
  
  (define (build-one-edge edge)
    (cons (car edge) (build-edge-key 0 (cdr edge))))
  
  (define (matching-key n result key)  ; reverses bit ordering and inverts
    (cond ((zero? n) result)           ; outermost n is width of bit-field
          (else (matching-key
                 (- n 1)
                 (+ result result (if (odd? key) 0 1))
                 (quotient key 2)))))
  
  (define (build-edge-key key edge)    ; (left-notch right-notch key key-match)
    (cond ((null? (cdr edge)) (list (car edge) key (matching-key 4 0 key)))
          (else (build-edge-key (+ key key (car edge)) (cdr edge)))))
  
  (define (build-flips face)           ; half the rotation, half the flips of them
    (append (build-rotations face) (build-rotations (build-flip face))))
  
  ; this is a mess because of the reflections that occur when flipping the piece
  (define (build-flip face)            ; flip the piece inside-out
    (define (flip-key n result key)
      (cond ((zero? n) result)
            (else (flip-key (- n 1) (+ result result (if (odd? key) 1 0)) (quotient key 2)))))
    (define (flip-edge edge)
      (list (cadr edge) (car edge) (flip-key 4 0 (caddr edge)) (flip-key 4 0 (cadddr edge))))
    (map flip-edge (list (caddr face) (cadr face) (car face) (cadddr face))))
  
  (define (build-rotations face)       ; rotations 0 / 90 / 180 / 270 degrees
    (list (vector (car face) (cadr face) (caddr face) (cadddr face))
          (vector (cadr face) (caddr face) (cadddr face) (car face))
          (vector (caddr face) (cadddr face) (car face) (cadr face))
          (vector (cadddr face) (car face) (cadr face) (caddr face))))
  
  ; combine the label with the geometry
  (cons (list face-name front back)    ; label
        (list->vector (build-flips (build-edges edges)))   ; geometry
        ))

(define make-face (if (audit) list make-edge-set))
(define make-edge (if (audit) list list))

; here's the Blue puzzle
(define puzzle
  (make-puzzle
   (make-row
    (make-face "A" "One search..." ""
               (make-edge 0 0 1 1 0 0)
               (make-edge 0 0 1 1 0 0)
               (make-edge 0 1 0 0 1 0)
               (make-edge 0 1 0 0 1 0))
    (make-face "B" "We put ..." ""
               (make-edge 1 1 0 1 0 1)
               (make-edge 1 1 0 1 0 0)
               (make-edge 0 0 1 1 0 0)
               (make-edge 0 1 0 0 1 1))
    (make-face "C" "" ""
               (make-edge 0 0 1 1 0 1)
               (make-edge 1 1 0 0 1 1)
               (make-edge 1 1 0 0 1 0)
               (make-edge 0 1 0 1 0 0)))
   (make-row
    (make-face "D" "" ""
               (make-edge 0 0 1 1 0 1)
               (make-edge 1 1 0 0 1 1)
               (make-edge 1 1 0 0 1 1)
               (make-edge 1 1 0 0 1 0))
    (make-face "E" "" ""
               (make-edge 0 1 0 0 1 0)
               (make-edge 0 0 1 1 0 0)
               (make-edge 0 0 1 1 0 0)
               (make-edge 0 0 1 1 0 0))
    (make-face "F" "SinglePoint ..." ""
               (make-edge 1 0 1 1 0 0)
               (make-edge 0 1 0 1 0 0)
               (make-edge 0 0 1 1 0 0)
               (make-edge 0 1 0 0 1 1)))))

;(map (lambda (x) (display x) (newline) (caar x)) puzzle)

;; permutation generator
; proc-before can return (permute-no-deeper ...)
;  to prune the permutation on the right-hand-side;
;  if args are present, they are included in the result --
;  this turns out to be very handy during debugging, because you
;  can return a reason why the tree was pruned using the same
;  mechanism for returning solutions to the puzzle.
(define (permute-no-deeper . args) (cons 'permute-no-deeper args))
; proc-after can return (permute-replace-results ...)
;  if args are present, they replace the entire accumulated result
(define (permute-replace-results . args) (cons 'permute-replace-results args))
; I don't actually use this feature, but it seemed like a useful
;  thing to put into the program for another time.

(define (permute        ; compute outer product of permutations of ls with xls
         proc-before    ; called before each left-partial permutation
         proc-during    ; called for each fully permuted list
         proc-after     ; called after each left-partial permutation
         context        ; list with same length as ls but which is not permuted
         ls             ; elements mapped into car of outer product (this list gets permuted)
         xls)           ; elements mapped into cdr of outer product
  
  ; if context is '() generate a usable context of the proper length
  (define (permute-default-context ctx n ls)
    (cond ((null? ls) (reverse ctx))
          (else (permute-default-context (cons n ctx) (+ n 1) (cdr ls)))))
  
  ; sorry for all the nested bindings of the same names
  ; I originally wrote all the defines at the top level and
  ; only brought them into scope later
  (define (permute1 proc-before proc-during proc-after context)
    (define (permute-outer-product results m ls1 ls2 ctx1 ctx2)
      (define (permute-outer-product1 results m ls1 ls2 ctx1 ctx2)
        (define (permute-pnext results m ls1 ls2 ctx1 ctx2 rxls)
          (define (permute-loop ls n ls2)
            (define (permute-rotate)
              (cond ((< (length ls2) 2) ls2)
                    (else (append (cdr ls2) (list (car ls2))))))
            ; permute-loop, select each rotation of the remainder of the
            ; list in turn, and apply the permutation to the right sublist;
            ; if a complete permutation is presented, call the application
            ; proc-during to evaluate it and possibly return a result
            (cond ((zero? m)
                   (let ((result (proc-during ls1 ctx1)))
                     (cond ((null? result) ls)
                           (else (cons result ls)))))
                  ((> n m) ls)
                  (else (permute-loop (permute-outer-product ls m ls1 ls2 ctx1 ctx2)
                                      (+ n 1) (permute-rotate)))))
          ; permute-pnext, apply the next element of xls to form an outer
          ; product with the current partial permutation
          (cond ((null? rxls) (permute-loop results 1 ls2))
                (else (permute-pnext (permute-loop results 1 ls2)
                                     m
                                     (cons (cons (caar ls1) (car rxls)) (cdr ls1))
                                     ls2 ctx1 ctx2 (cdr rxls)))))
        ; permute-outer-product1, really do the work
        (permute-pnext results (- m 1)
                       (cons (cons (car ls2) (car xls)) ls1)
                       (cdr ls2)
                       (cons (car ctx2) ctx1) (cdr ctx2)
                       (cdr xls)))
      ; permute-outer-product, wrap recursion so proc-before and proc-after get called
      ;; there are calls to proc-before and proc-after which repeat calculations
      ;; already done previously, but this may be an advantage in some applications
      (let* ((before-results results)
             (result (proc-before ls1 ls2 ctx1 ctx2))
             (pre-after-results (cond ((and (pair? result)
                                            (eq? 'permute-no-deeper (car result)))
                                       (cond ((null? (cdr result)) results)
                                             (else (cons result results))))
                                      (else (permute-outer-product1
                                             (cond ((null? result) results)
                                                   (else (cons result results)))
                                             m ls1 ls2 ctx1 ctx2))))
             (after-result (proc-after ls1 ls2 ctx1 ctx2 pre-after-results before-results)))
        (cond ((and (pair? after-result)
                    (eq? 'permute-replace-results (car after-result)))
               (cdr after-result))
              ((null? after-result) pre-after-results)
              (else (cons after-result pre-after-results)))))
    ; permute1, check for degenerate cases and otherwise fire off the permutation
    (cond ((null? xls) '())
          ((null? ls) '())
          (else (reverse (permute-outer-product '() (length ls) '() ls '() context)))))
  ; permute, interpret defaults passed in by caller
  (permute1 (if (null? proc-before) (lambda (ls1 ls2 ctx1 ctx2) '()) proc-before)
            (if (null? proc-during) (lambda (ls1 ctx1) ls1) proc-during)
            (if (null? proc-after) (lambda (ls1 ls2 ctx1 ctx2 pre-after before) '()) proc-after)
            (if (null? context) (permute-default-context '() 1 ls) context)))

;; test procedures
;(define (permute-before ls1 ls2 ctx1 ctx2)
;  (if (null? ls2) (write (list "#@# cannot be null: " ls2 " ")))
;  (write (list 'before ls1 ls2 ctx1 ctx2)) (newline)
;  (if (dbg) (list 'before (reverse ls1) ls2 (reverse ctx1) ctx2) '()))
;
;(define (permute-test ls1 ctx1)
;  (if (null? ls1) (write (list "#@# cannot be null: " ls1 " ")))
;  (write (list 'during ls1 ctx1)) (newline)
;  (list 'during (reverse ls1) (reverse ctx1)))
;
;(define (permute-after ls1 ls2 ctx1 ctx2 after-results before-results)
;  (if (null? ls2) (write (list "#@# cannot be null: " ls2 " ")))
;  (write (list 'after ls1 ls2 ctx1 ctx2)) (newline)
;  (if (dbg) (list 'after (reverse ls1) ls2 (reverse ctx1) ctx2) '()))
;
;; test degenerate cases to make sure they do what I think
;(permute permute-before permute-test permute-after '() '() '())
;(permute permute-before permute-test permute-after '() '(a) '())
;(permute permute-before permute-test permute-after '() '() '(1))
;(permute permute-before permute-test permute-after '() '(a) '(1))
;(permute permute-before permute-test permute-after '() '(a b) '(1))
;(permute permute-before permute-test permute-after '() '(a) '(1 2))
;(permute permute-before permute-test permute-after '() '(a b) '(1 2))
;; test the first really interesting case
;(define ptest (permute permute-before permute-test permute-after '() '(a b c) '(1 2 3)))
;ptest
;(length ptest)
;; test bigger permutation where the size of ls and xls are different
; (permute permute-before permute-test permute-after '() '(a b c d) '(1 2 3)))

; back to solving the puzzle

;(write puzzle) (newline)

; Handy accessors for the objects that come out of the permutation;
; face-flip is the dotted pair that represents of outer product of
; a face and its orientation.
(define face-flip->face caar)
(define face-flip->name caaar)
(define face-flip->front cadaar)
(define face-flip->back (lambda (ff) (car (cddaar ff))))
(define face-flip->flip cdr)
(define face-flip->edges-vector cdar)
(define face-flip->id (lambda (ff) (string-append (face-flip->name ff)
                                                  (number->string (face-flip->flip ff)))))
(define face-flip->one-edge-vector
  (lambda (face-flip) (vector-ref (face-flip->edges-vector face-flip)
                                  (face-flip->flip face-flip))))
(define face-flip->edge
  (lambda (face-flip which-edge)
    (vector-ref (face-flip->one-edge-vector face-flip) which-edge)))

(define edge->left-corner car)
(define edge->right-corner cadr)
(define edge->key caddr)
(define edge->key-mate cadddr)

;; test accessors on face A orientation 2
;(define ff (cons (car puzzle) '2))
;(display "face is ") (write (face-flip->face ff)) (newline)
;(display "face name is ") (write (face-flip->name ff)) (newline)
;(display "face front string is ") (write (face-flip->front ff)) (newline)
;(display "face back string is ") (write (face-flip->back ff)) (newline)
;(display "face flip is ") (write (face-flip->flip ff)) (newline)
;(display "face flip edges vector is ") (write (face-flip->edges-vector ff)) (newline)
;(define ffe (face-flip->edge ff 3))
;(display "face flip edge ") (write ffe) (newline)
;(display "face flip edge lc ") (write (edge->left-corner ffe)) (newline)
;(display "face flip edge rc ") (write (edge->right-corner ffe)) (newline)
;(display "face flip edge key ") (write (edge->key ffe)) (newline)
;(display "face flip edge key-match ") (write (edge->key-mate ffe)) (newline)

; This tests the key (interior four notches) for exact match and tests for no
; conflict at the corners -- I use this when building the four horizontal faces
; of the box; the final test of the corners occurs when placing top and bottom.
; Return '() if the faces match.
; If dbg is true, return a failure reason that the caller can pass to
; permute-no-deeper, otherwise just return #t for failure.
(define (edge-test-side ff1 fe1 ff2 fe2)
  (let ((e1 (face-flip->edge ff1 fe1))
        (e2 (face-flip->edge ff2 fe2)))
    (cond ((= (edge->key e1) (edge->key-mate e2))
           (cond ((= 2 (+ (edge->left-corner e1) (edge->right-corner e2)))
                  (if (dbg) (list "left corner" e1 "right corner" e2) #t))
                 ((= 2 (+ (edge->right-corner e1) (edge->left-corner e2)))
                  (if (dbg) (list "right corner" e1 "left corner" e2) #t))
                 (else '())))   ; got a match
          (else (if (dbg) (list "key mismatch" e1 e2) #t)))))

(define (make-validator)
  (list 
   ; This is a list of procedures to apply when snapping each face into
   ; place.  There are six in all.  The first one constrains the placement
   ; of A as the first face.  All but the last are used in the proc-before
   ; context to prune the search tree of unusable hypotheses.  The last is
   ; used in the proc-during context to decide if this is a solution.
   (lambda (when ls1 ls2 ctx1 ctx2 . args)
     ; Rotations don't matter, only inversion, also accept only the A face.
     ; Ken points out that the flip doesn't matter either, since every
     ; solution with A unflipped has a corresponding solution with all the
     ; faces flipped (turning the puzzle inside-out).
     (let* ((ff (car ls1))
            (flip (face-flip->flip ff)))
       ;      (cond ((and (or (= flip 0) (= flip 4))  ; explore only original face and its flip
       (cond ((and (= flip 0)             ; explore only the original face, not its flip
                   (string=? (face-flip->name ff) "A"))   ; choose A as the first face
              '() ;(list 1 (face-flip->id ff))   ; to debug, return list instead of nil
              )                       
             (else (permute-no-deeper)))))
   (lambda (when ls1 ls2 ctx1 ctx2 . args)
     (if (null? (edge-test-side (cadr ls1) 1 (car ls1) 3))
         '() ;(list 2 (map face-flip->id ls1) (map caar ls2))
         (permute-no-deeper)))
   (lambda (when ls1 ls2 ctx1 ctx2 . args)
     (if (null? (edge-test-side (cadr ls1) 1 (car ls1) 3))
         '() ;(list 3 (map face-flip->id ls1) (map caar ls2))
         (permute-no-deeper)))
   (lambda (when ls1 ls2 ctx1 ctx2 . args)
     ; face 4 has to match with face 3 and face 1 as well
     (if (and (null? (edge-test-side (cadr ls1) 1 (car ls1) 3))
              (null? (edge-test-side (cadddr ls1) 3 (car ls1) 1)))
         '() ;(list 4 (map face-flip->id ls1) (map caar ls2))
         (permute-no-deeper)))
   (lambda (when ls1 ls2 ctx1 ctx2 . args)
     ; this is the top face
     ; all these c*r's to reference the other faces are not much fun!
     (if (and (null? (edge-test-side (cadr ls1) 0 (car ls1) 1))
              (null? (edge-test-side (caddr ls1) 0 (car ls1) 2))
              (null? (edge-test-side (cadddr ls1) 0 (car ls1) 3))
              (null? (edge-test-side (car (cddddr ls1)) 0 (car ls1) 0)))
         (if (dbg) (list 5 (map face-flip->id ls1) (map caar ls2)) '())
         (if (and (dbg) (string=? "B" (face-flip->name (cadddr ls1)))) ; selective debugging
             (permute-no-deeper (map face-flip->id ls1)
                                (edge-test-side (cadr ls1) 0 (car ls1) 3)
                                (edge-test-side (caddr ls1) 0 (car ls1) 2)
                                (edge-test-side (cadddr ls1) 0 (car ls1) 1)
                                (edge-test-side (car (cddddr ls1)) 0 (car ls1) 0))
             (permute-no-deeper))))
   (lambda (when ls1 ctx1 . args)
     ; this is the bottom face
     (if (and (null? (edge-test-side (caddr ls1) 2 (car ls1) 3))
              (null? (edge-test-side (cadddr ls1) 2 (car ls1) 2))
              (null? (edge-test-side (car (cddddr ls1)) 2 (car ls1) 1))
              (null? (edge-test-side (cadr (cddddr ls1)) 2 (car ls1) 0)))
         (reverse (map face-flip->id ls1))   ; A SOLUTION!
         (if (dbg) (list "NO" (map face-flip->id ls1)
                         (edge-test-side (caddr ls1) 2 (car ls1) 3)
                         (edge-test-side (cadddr ls1) 2 (car ls1) 2)
                         (edge-test-side (car (cddddr ls1)) 2 (car ls1) 1)
                         (edge-test-side (cadr (cddddr ls1)) 2 (car ls1) 0))
             '())))))

; here we solve the problem
(define (make-solutions)
  (define (before ls1 ls2 ctx1 ctx2)
    (if (null? ctx1) '()
        (begin
          ((car ctx1) 'before ls1 ls2 ctx1 ctx2))))
  (define (during ls1 ctx1) ((car ctx1) 'during ls1 ctx1))
  (define (after . arglist) '())
  
  (permute before during after (make-validator)
           puzzle
           '(0 1 2 3 4 5 6 7)))

; Since I build two different kinds of data structures depending on whether
; I'm auditing the puzzle definition or solving the puzzle, I have to do
; either the audit or the solution, not both.

(if (audit)
    (begin
      (display puzzle) (newline))
    (begin
      (if (dbg) (make-solutions)   ; easier to read when debugging
          (let ((solutions (time (make-solutions))))
            (map (lambda (x) (display x) (newline)) solutions)
            (display (length solutions)) (newline)))))

; all the rest of the program is only used when auditing the puzzle specification
; this is a brute force algorithm

(define (audit-puzzle puzzle)
  (define (audit-line cline nline ncol)
    (cond ((>= cline nline))
          (else (audit-cell cline 0 ncol) (newline)
                (audit-line (+ 1 cline) nline ncol))))
  
  (define (audit-cell cline ccol ncol)
    (cond ((>= ccol ncol))
          (else (display-cell cline ccol)
                (audit-cell cline (+ 1 ccol) ncol))))
  
  (define (display-cell cline ccol)
    (let ((f (intersect-puzzle (list "-") puzzle 0 0 cline ccol)))
      (display " ") (display(car f)) (display " ")))
  
  (define (intersect-puzzle ls rows line col cline ccol)
    (cond ((null? rows) ls)
          (else (intersect-puzzle
                 (intersect-row ls (car rows) line col cline ccol)
                 (cdr rows) (+ 5 line) col cline ccol))))
  
  ; offsets in each face to the positions of the notches on each edge
  (define edge-orientation
    '(((0 0) (0 1) (0 2) (0 3) (0 4) (0 5))
      ((0 5) (1 5) (2 5) (3 5) (4 5) (5 5))
      ((5 5) (5 4) (5 3) (5 2) (5 1) (5 0))
      ((5 0) (4 0) (3 0) (2 0) (1 0) (0 0))))
  
  (define (intersect-row ls faces line col cline ccol)
    (cond ((null? faces) ls)
          (else (intersect-row
                 (intersect-face ls (cdddar faces) line col cline ccol
                                 (caar faces) edge-orientation)
                 (cdr faces) line (+ 5 col) cline ccol))))
  
  (define (intersect-face ls edges line col cline ccol face-name orientation)
    (cond ((null? edges) ls)
          (else (intersect-face
                 (intersect-edge ls (car edges) line col cline ccol face-name (car orientation))
                 (cdr edges) line col cline ccol face-name (cdr orientation)))))
  
  (define (intersect-edge ls notches line col cline ccol face-name notch-offsets)
    (cond ((null? notches) ls)
          (else (intersect-edge
                 (intersect-notch ls (car notches)
                                  (+ line (caar notch-offsets))
                                  (+ col (cadar notch-offsets))
                                  cline ccol face-name)
                 (cdr notches) line col cline ccol face-name (cdr notch-offsets)))))
  
  (define (intersect-notch ls notch line col cline ccol face-name)
    (cond ((and (= line cline) (= col ccol) (= 1 notch)
                (not (equal? face-name (car ls))))
           (if (string=? " " (car ls))
               (list face-name)
               (cons face-name ls)))
          (else ls)))
  ; audit-puzzle
  (audit-line 0
              (+ 1 (* 5 (length puzzle)))
              (+ 1 (* 5 (length (car puzzle))))))

(if (audit) (audit-puzzle puzzle))

; fini