knight.lisp

;; Knight's tour using Warnsdorff's rule.
;; https://en.wikipedia.org/wiki/Knight%27s_tour

(defconstant +board-sz+ 8)

(defparameter *board* (make-array `(,+board-sz+ ,+board-sz+) :initial-element 0))

(defconstant +knight-moves+
  '(#(1 -2) #(2 -1) #(2 1) #(1 2) #(-1 2) #(-2 1) #(-2 -1) #(-1 -2)))

(defun board-at (x y)
  (aref *board* y x))

(defun board-set (x y val)
  (setf (aref *board* y x) val))

(defun print-board ()
  (dotimes (y +board-sz+)
    (dotimes (x +board-sz+)
      (format t "[~d] " (board-at x y))) (terpri)))

(defun is-valid-sq (x y)
  (and (>= x 0) (>= y 0) (< x +board-sz+) (< y +board-sz+) (zerop (board-at x y))))

(defun get-moves (x y)
  (remove-if-not (lambda (lst)
                   (apply #'is-valid-sq lst))
                 (mapcar (lambda (mvmt)
                           (let ((new-x (+ x (aref mvmt 0)))
                                 (new-y (+ y (aref mvmt 1))))
                             (list new-x new-y))) +knight-moves+)))

(defun get-min-move (moves)
  (if (null moves)
      nil
      (apply #'min (mapcar (lambda (move)
                             (length (get-moves (car move) (second move)))) moves))))

(defun next-sq (x y)
  (let* ((moves (get-moves x y))
         (min-move (get-min-move moves)))
    (when (null moves)
      (return-from next-sq nil))
    (dolist (move moves)
      (when (= min-move (length (get-moves (car move) (second move))))
        (return-from next-sq move)))))

(defun sq-name (x y)
  (format nil "~C~D" (code-char (+ (char-int #\a) x)) (abs (- y +board-sz+))))

(defun begin-tour (x y)
  (format t "Moved to ~A~%" (sq-name x y))
  (let ((next (next-sq x y)))
    (board-set x y 1)
    (print-board)
    (when (null next)
      (format t "No more moves!~%") (quit))
    (apply #'begin-tour next)))

(begin-tour 0 0)