;; -*- Mode: Irken -*-

(require "lib/basis.scm")

;; one tough puzzle.  nine-piece jigsaw puzzle.

;; diamonds hearts clubs spades.
;; male & female pieces
;;
;; encoding:
;;
;;      M   F
;; D    0   7
;; H    1   6
;; C    2   5
;; S    3   4

;; two edges match if they sum to 7

;;    0
;; 1     5
;;    5
;;
;; means, clockwise from the top:
;;   male diamond
;;   female club
;;   female club
;;   male heart

(define pieces
  (list
   (list 0 5 5 1) ;; 0
   (list 2 5 7 0) ;; 1
   (list 3 4 5 1) ;; 2
   (list 0 7 6 1) ;; 3
   (list 1 4 6 2) ;; 4
   (list 0 4 6 3) ;; 5
   (list 1 7 5 2) ;; 6
   (list 3 6 5 3) ;; 7
   (list 0 6 7 3) ;; 8
   ))

(define (print-piece i p)
  (define i2nub
    0 -> (:tuple "♦" #t)
    7 -> (:tuple "♢" #f)
    1 -> (:tuple "♥" #t)
    6 -> (:tuple "♡" #f)
    2 -> (:tuple "♣" #t)
    5 -> (:tuple "♧" #f)
    3 -> (:tuple "♠" #t)
    4 -> (:tuple "♤" #f)
    _ -> (impossible)
    )
  (define (format-nub nub)
    (match (i2nub nub) with
      (:tuple symbol #t)
      -> (format (ansi red symbol))
      (:tuple symbol #f)
      -> (format (ansi cyan symbol))
      ))

  (printf "    " (format-nub (nth p 0)) "\n")
  (printf "  " (format-nub (nth p 3)) " " (int i) " " (format-nub (nth p 1)) "\n")
  (printf "    " (format-nub (nth p 2)) "\n")
  )

;;   a         d
;; d   b  => c   a
;;   c         b

(define rotations
  (a b c d)
  -> (list (list a b c d)
           (list d a b c)
           (list c d a b)
           (list b c d a))
  _ -> (impossible)
  )

(define pre-computed-rotations
  #((rotations (nth pieces 0))
    (rotations (nth pieces 1))
    (rotations (nth pieces 2))
    (rotations (nth pieces 3))
    (rotations (nth pieces 4))
    (rotations (nth pieces 5))
    (rotations (nth pieces 6))
    (rotations (nth pieces 7))
    (rotations (nth pieces 8))
    ))

;; ok, which two parts have to match for each pair of squares?
;;
;; 0 1 2
;; 3 4 5
;; 6 7 8

;; between pos 0 and pos 1, we must match locations 1 (right) in 0 (upper left) and 3 (left) in 1 (top middle).

(define constraints
  (list
   ;; pos 0:
   ;;    pos 1: 1, 3
   ;;    pos 3: 2, 0
   (list (:tuple 1 1 3) (:tuple 3 2 0))
   ;; pos 1:
   ;;    pos 2: 1, 3
   ;;    pos 4: 2, 0
   (list (:tuple 2 1 3) (:tuple 4 2 0))
   ;; pos 2:
   ;;    pos 5: 2, 0
   (list (:tuple 5 2 0))
   ;; pos 3:
   ;;    pos 4: 1, 3
   ;;    pos 6: 2, 0
   (list (:tuple 4 1 3) (:tuple 6 2 0))
   ;; pos 4:
   ;;    pos 5: 1, 3
   ;;    pos 7: 2, 0
   (list (:tuple 5 1 3) (:tuple 7 2 0))
   ;; pos 5:
   ;;    pos 8: 2, 0
   (list (:tuple 8 2 0))
   ;; pos 6:
   ;;    pos 7: 1, 3
   (list (:tuple 7 1 3))
   ;; pos 7:
   ;;    pos 8: 1, 3
   (list (:tuple 8 1 3))
   ))

;; we need to solve nine positions
;; four possible rotations of each piece

(define (candidates psol n remain)
  ;; which pieces from <remain> can be fit with our partial solution <psol>
  ;; by placing them in position <n>?
  ;; psol is a list of solved pieces in reverse order,
  ;; e.g. n = 5, psol = (piece-for-6 piece-for-7 piece-for-8)
  ;; we know all the constraints are met for 6-7-8 here,
  ;; so we are matching in position 5.
  (let ((result (list:nil)))
    (for-list i remain
      ;; for each remaining piece
      (for-list rot pre-computed-rotations[i]
        ;; at each rotation
        (if (= n 8)
            ;; everyone's a candidate for pos 8!
            (push! result (:tuple i rot (remove-eq i remain)))
            (let ((pass #t))
              (for-list item (nth constraints n)
                (match item with
                  (:tuple opos a b)
                  ;; this is our constraint: a + b must equal 7.
                  ;; <a> in position n, <b> in position opos
                  ;; so for example, say n == 5, so we have only
                  ;; the one constraint: 8 1 3.  we need the piece
                  ;; at position 8, which is 8-5 or 3 in from psol
                  -> (let ((opiece (nth psol (- opos n 1)))
                           (piece-a (nth rot a))
                           (piece-b (nth opiece b)))
                       (when (not (= 7 (+ piece-a piece-b)))
                         ;; failed constraint.
                         (set! pass #f)))
                  ))
              (if pass ;; all constraints were met
                  (push! result (:tuple i rot (remove-eq i remain))))))))
    result))

(define (search psoli psol n remain kdone)
  ;; psol is our partial solution of length n-1
  ;; we are trying candidates for position <n>.
  ;; because of the way we defined our constraints,
  ;; we actually have to start with piece 8 in place,
  ;; and cons each additional piece in reverse order
  ;; as we solve.
  (if (= n -1)
      (kdone (:tuple psoli psol))
      (for-list cand (candidates psol n remain)
        (match cand with
          (:tuple index rot new-pieces)
          -> (search (list:cons index psoli) (list:cons rot psol) (- n 1) new-pieces kdone)
          ))
      )
  ;; this is pointless, just makes the typer happy.
  (:tuple psoli psol)
  )

(match (let/cc exit (search (list:nil) (list:nil) 8 (range 9) exit)) with
  (:tuple psoli psol)
  -> (for-range i (length psoli)
       (print-piece (nth psoli i) (nth psol i))
       (printf "\n")
       )
  )