;;Another example jhe@jeremyenglish.org
;;Knight's tour

;;Wirth algorithm

;;;  procedure tryNextMove;
;;;  begin initialize selection of moves;
;;;    Repeat slect next candidate from list of next moves;
;;;      if acceptable then
;;;        record move;
;;;        if board not full then
;;;          tryNextMove;
;;;          if not successful then erase previous recording end
;;;        end
;;;      end
;;;    until (move was successful) or (no more candidates)
;;;  end tryNextMove

(use-package :chess-trace)

(defun field-visitedp (board x y)
  (/= (aref board x y) 0))

(defun board-not-fullp (i n)
  (< i (* n n)))

(defun acceptable (board x y n)
  (and (<= 0 x) (< x n) (<= 0 y) (< y n)
       (not (field-visitedp board x y))))

(defun record-move (board x y i)
  (setf (aref board x y) i))

(defun cancel-record (board x y)
  (setf (aref board x y) 0))

(defun memoize (fn)
  (let ((cache (make-hash-table :test #'equal)))
    #'(lambda (&rest args)
        (multiple-value-bind (val win) (gethash args cache)
          (if win
              val
              (setf (gethash args cache)
                    (apply fn args)))))))

(defun candid (x y)
  (let (can
        (d '((2 1) (1 2) (-1 2) (-2 1) (-2 -1) (-1 -2) (1 -2) (2 -1))))
        (dolist (i d)
          (let ((c (list (+ x (first i))
                            (+ y (second i)))))
            (push c can)))
        can))

(defvar candidate (memoize #'candid))

(defun knight-try(board i n x y)
  (let ((can (funcall candidate x y)))
    (dolist (c can)
      (let ((u (first c)) (v (second c)))
        (when (acceptable board u v n)
          (record-move board u v i)
          (if (board-not-fullp i n)
            (let ((successful
                   (knight-try board (1+ i) n u v)))
              (if successful
                  (return successful)
                  (cancel-record board u v)))
            (return t)))))))

(defun knights-tour (n x y)
  (let ((board (make-array (list n n))))
    (record-move board x y 1)
    (let ((successful (knight-try board 2 n x y)))
      (unless successful (format t "FAILED~%"))
      board)))

(defun gif-knights-tour (n x y filename)
  (let ((board (knights-tour n x y))
        (chess-board (make-chess-board :blocks n)))
    (dotimes (i (* n n))
      (let ((stop (1+ i)))
        (start-frame chess-board)
      (dotimes (x n)
        (dotimes (y n)
          (let ((move (aref board x y)))
            (cond
              ((= move stop) (put-piece-xy chess-board :name :knight :x x :y y :color :dark))
              ((< move stop) (put-piece-xy chess-board :name :cross :x x :y y))))))
      (end-frame chess-board :delay-time 30)))
    (add-frame-delay 500 chess-board)
    (output-board chess-board filename)))


