我是LISP的新手，我在下面的代码中遇到了这个问题。
(defun knights-tour-brute (x y m n)
(setq height m)
(setq width n)
(setq totalmoves (* height width))
(setq steps 1)
(setq visited-list (list (list x y)))
(tour-brute (list (list x y))))
(defun tour-brute (L)
(cond
((null L) NIL)
((= steps totalmoves) L)
(t
(let ((nextmove (generate L)))
(cond ((null nextmove) (backtrack (car (last L)))
(tour-brute (reverse (cdr (reverse L)))))
(t (setq visited-list (append visited-list (list nextmove)))
(tour-brute (append L (list nextmove)))))))))
(defun generate (L)
(let ((x (caar (last L)))
(y (cadar (last L))))
(setq steps (+ 1 steps))
(cond
((correct-state(+ x 2) (+ y 1) L) (list (+ x 2) (+ y 1)))
((correct-state (+ x 2) (- y 1) L) (list (+ x 2) (- y 1)))
((correct-state (- x 1) (+ y 2) L) (list (- x 1) (+ y 2)))
((correct-state (+ x 1) (+ y 2) L) (list (+ x 1) (+ y 2)))
((correct-state (+ x 1) (- y 2) L) (list (+ x 1) (- y 2)))
((correct-state (- x 1) (- y 2) L) (list (- x 1) (- y 2)))
((correct-state (- x 2) (+ y 1) L) (list (- x 2) (+ y 1)))
((correct-state (- x 2) (- y 1) L) (list (- x 2) (- y 1)))
(t (setq steps (- steps 2)) NIL))))
(defun correct-state (x y L)
(if (and (<= 1 x)
(<= x height)
(<= 1 y)
(<= y width)
(not (visited (list x y) L))
(not (visited (list x y)
(tail (car (last L)) visited-list)))) (list (list x y)) NIL))
(defun tail (L stateslist)
(cond
((equal L (car stateslist)) (cdr stateslist))
(t (tail L (cdr stateslist)))))
(defun visited (L stateslist)
(cond
((null stateslist) NIL)
((equal L (car stateslist)) t)
(t (visited L (cdr stateslist)))))
(defun backtrack (sublist)
(cond
((null visited-list) t)
((equal sublist (car (last visited-list))) t)
(t (setq visited-list (reverse (cdr (reverse visited-list))))
(backtrack sublist))))
它返回一个错误*** - 程序堆栈溢出。重启。当我在谷歌上搜索时，我意识到这是递归的结果。但是，我不确定应该如何优化此代码来解决此问题。非常感谢任何帮助。
嗨，上面是更新后的代码。这是测试代码。 （knights-tour-brute 5 5 1 1）
答案 0 :(得分：3)
正如我在评论中提到的那样，问题是缺乏Tail Call Optimisation (TCO)。您可以使用
启用它(declaim (optimize (speed 3)))
但这取决于你的实施。我不确定CLISP。
编辑：其他答案有更有效的方法来解决问题，但仍然值得阅读这个答案，以便更好地编写原始解决方案
无论如何，我对代码进行了优化。您仍然需要有TCO才能运行它。这是使用这种递归的固有问题。它应该至少在SBCL下运行良好。只需将其保存到文件中，然后执行
(load (compile-file "file.lisp"))
它的运行速度必须比原始代码快，并且内存分配要少得多。 (time (knights-tour-brute 1 1 6 6))与您的代码相关的数字：
4,848,466,907 processor cycles
572,170,672 bytes consed
我的代码：
1,155,406,109 processor cycles
17,137,776 bytes consed
在大多数情况下，我将代码保留原样。我所做的改变主要是：
visited-list。当你不理解Lisp中单链表如何工作时，这看起来可能很直观，但效率非常低（那些(reverse (cdr (reverse list)))真的在吃性能）。你应该阅读一些关于列表的Lisp书。我按相反的顺序保留它，然后最后用nreverse将其反转。然而，它仍然是相同的强力算法，因此对于较大的电路板来说它会非常慢。你应该研究那些更智能的算法。
(declaim (optimize (speed 3) (space 0) (safety 0) (debug 0)))
(declaim (type fixnum *height* *width* *total-moves* *steps*))
(declaim (type list *visited-list*))
(declaim (ftype (function (fixnum fixnum fixnum fixnum) list)
knights-tour-brute))
(declaim (ftype (function (list) list)
tour-brute))
(declaim (ftype (function (list) (or pos null))
generate))
(declaim (ftype (function (fixnum fixnum list) (or t null))
correct-state))
(declaim (ftype (function (fixnum fixnum list) (or t null))
visited))
(declaim (ftype (function (pos) t)
backtrack))
(declaim (ftype (function (fixnum fixnum pos) (or t null))
vis-2))
(declaim (ftype (function (pos pos) (or t null))
pos=))
(declaim (ftype (function (pos fixnum fixnum) (or t null))
pos=*))
(defstruct pos
(x 0 :type fixnum)
(y 0 :type fixnum))
(defmethod print-object ((pos pos) stream)
(format stream "(~d ~d)" (pos-x pos) (pos-y pos)))
(defparameter *height* 0)
(defparameter *width* 0)
(defparameter *total-moves* 0)
(defparameter *steps* 0)
(defparameter *visited-list* '())
(defun knights-tour-brute (x y m n)
(let ((*height* m)
(*width* n)
(*total-moves* (* m n))
(*steps* 1)
(*visited-list* (list (make-pos :x x :y y))))
(nreverse (tour-brute (list (make-pos :x x :y y))))))
(defun tour-brute (l)
(cond
((null l) nil)
((= *steps* *total-moves*) l)
(t (let ((nextmove (generate l)))
(cond
((null nextmove)
(backtrack (first l))
(tour-brute (rest l)))
(t (push nextmove *visited-list*)
(tour-brute (cons nextmove l))))))))
(defun generate (l)
(let ((x (pos-x (first l)))
(y (pos-y (first l))))
(declare (type fixnum x y))
(incf *steps*)
(cond
((correct-state (+ x 2) (+ y 1) l) (make-pos :x (+ x 2) :y (+ y 1)))
((correct-state (+ x 2) (- y 1) l) (make-pos :x (+ x 2) :y (- y 1)))
((correct-state (- x 1) (+ y 2) l) (make-pos :x (- x 1) :y (+ y 2)))
((correct-state (+ x 1) (+ y 2) l) (make-pos :x (+ x 1) :y (+ y 2)))
((correct-state (+ x 1) (- y 2) l) (make-pos :x (+ x 1) :y (- y 2)))
((correct-state (- x 1) (- y 2) l) (make-pos :x (- x 1) :y (- y 2)))
((correct-state (- x 2) (+ y 1) l) (make-pos :x (- x 2) :y (+ y 1)))
((correct-state (- x 2) (- y 1) l) (make-pos :x (- x 2) :y (- y 1)))
(t (decf *steps* 2)
nil))))
(defun correct-state (x y l)
(and (<= 1 x *height*)
(<= 1 y *width*)
(not (visited x y l))
(vis-2 x y (first l))))
(defun visited (x y stateslist)
(loop
for state in stateslist
when (pos=* state x y) do (return t)))
;;---TODO: rename this
(defun vis-2 (x y l-first)
(loop
for state in *visited-list*
when (pos= l-first state) do (return t)
when (pos=* state x y) do (return nil)))
(defun backtrack (sublist)
(loop
for state in *visited-list*
while (not (pos= sublist state))
do (pop *visited-list*)))
(defun pos= (pos1 pos2)
(and (= (pos-x pos1)
(pos-x pos2))
(= (pos-y pos1)
(pos-y pos2))))
(defun pos=* (pos1 x y)
(and (= (pos-x pos1) x)
(= (pos-y pos1) y)))
编辑：我改进了correct-state，以便两次不查看同一个列表。显着减少了消耗。
Edit2：我转而使用结构位置而不是使用cons-cells。这大大提高了性能。
它可能会进行更多优化，但对于6x6以上的电路板来说应该足够快。如果您需要更好的性能，我认为切换到不同的算法比尝试优化强力解决方案更有效率。如果有人确实想要优化它，这里有一些分析结果。
sb-sprof的结果表明大部分时间花在检查平等上。我认为还有很多工作要做。 visited也需要相当多的时间。也许将访问过的位置存储在一个数组中会加快速度，但我还没有尝试过。
Self Total Cumul
Nr Count % Count % Count % Calls Function
------------------------------------------------------------------------
1 1631 40.8 3021 75.5 1631 40.8 - VISITED
2 1453 36.3 1453 36.3 3084 77.1 - POS=*
3 337 8.4 3370 84.3 3421 85.5 - CORRECT-STATE
4 203 5.1 3778 94.5 3624 90.6 - GENERATE
5 101 2.5 191 4.8 3725 93.1 - VIS-2
6 95 2.4 95 2.4 3820 95.5 - POS=
7 88 2.2 3990 99.8 3908 97.7 - TOUR-BRUTE
8 44 1.1 74 1.9 3952 98.8 - BACKTRACK
9 41 1.0 41 1.0 3993 99.8 - MAKE-POS
：ALLOC模式没有提供太多有用的信息：
Self Total Cumul
Nr Count % Count % Count % Calls Function
------------------------------------------------------------------------
1 1998 50.0 3998 99.9 1998 50.0 - TOUR-BRUTE
2 1996 49.9 1996 49.9 3994 99.9 - MAKE-POS
sb-profile表明generate完成了大部分工作，而visited占用了大部分时间（请注意，由于实施原因，当然几秒钟之后）：
seconds | gc | consed | calls | sec/call | name
-------------------------------------------------------------
8.219 | 0.000 | 524,048 | 1,914,861 | 0.000004 | VISITED
0.414 | 0.000 | 32,752 | 663,273 | 0.000001 | VIS-2
0.213 | 0.000 | 32,768 | 266,832 | 0.000001 | BACKTRACK
0.072 | 0.000 | 0 | 1,505,532 | 0.000000 | POS=
0.000 | 0.000 | 0 | 1 | 0.000000 | TOUR-BRUTE
0.000 | 0.024 | 17,134,048 | 533,699 | 0.000000 | GENERATE
0.000 | 0.000 | 32,768 | 3,241,569 | 0.000000 | CORRECT-STATE
0.000 | 0.000 | 32,752 | 30,952,107 | 0.000000 | POS=*
0.000 | 0.000 | 0 | 1 | 0.000000 | KNIGHTS-TOUR-BRUTE
-------------------------------------------------------------
8.918 | 0.024 | 17,789,136 | 39,077,875 | | Total
答案 1 :(得分：2)
list-based answer 来自@jkiiski采用与OP相同的方法并大大优化 它。这里的目标是不同的：我尝试使用另一个 表示问题的方式（但仍然是暴力），我们可以看到矢量和 矩阵，我们可以解决更难问题更好，更快和更强 1
我也应用了与其他答案相同的启发式方法，这大大减少了寻找解决方案所需的工作量。
(defpackage :knight (:use :cl))
(in-package :knight)
(declaim (optimize (speed 3) (debug 0) (safety 0)))
(deftype board () '(simple-array bit *))
(deftype delta () '(integer -2 2))
;; when we add -2, -1, 1 or 2 to a board index, we assume the
;; result can still fit into a fixnum, which is not always true in
;; general.
(deftype frontier () (list 'integer -2 most-positive-fixnum))
接下来，我们定义一个类来保存Knight's Tour问题的实例 以及工作数据，即高度，宽度，矩阵表示 董事会，包含0（空）或1（访问），以及 当前巡视，由大小为 height x width 的矢量表示 fill-pointer初始化为零。由于内部板已经存储了这些尺寸，因此这个尺寸并不是绝对必要的。
(defclass knights-tour ()
((visited-cells :accessor visited-cells)
(board :accessor board)
(height :accessor height :initarg :height :initform 8)
(width :accessor width :initarg :width :initform 8)))
(defmethod initialize-instance :after ((knight knights-tour)
&key &allow-other-keys)
(with-slots (height width board visited-cells) knight
(setf board (make-array (list height width)
:element-type 'bit
:initial-element 0)
visited-cells (make-array (* height width)
:element-type `(integer ,(* height width))
:fill-pointer 0))))
顺便说一句，我们还专门研究print-object：
(defmethod print-object ((knight knights-tour) stream)
(with-slots (width height visited-cells) knight
(format stream "#<knight's tour: ~dx~d, tour: ~d>" width height visited-cells)))
(declaim (inline visit unvisit))
访问位于 x 和 y 的单元格意味着在设置一个 在板上的适当位置和推动当前单元格 坐标到 visited-cell 向量。我存储了行主索引 而不是几个坐标，因为它分配较少的内存（实际上差异并不重要）。
(defmethod visit ((knight knights-tour) x y)
(let ((board (board knight)))
(declare (board board))
(setf (aref board y x) 1)
(vector-push-extend (array-row-major-index board y x)
(visited-cells knight))))
取消访问单元格意味着在板中设置零并减少 被访问单元序列的填充指针。
(defun unvisit (knight x y)
(let ((board (board knight)))
(declare (board board))
(setf (aref board y x) 0)
(decf (fill-pointer (visited-cells knight)))))
递归访问功能如下。它首先访问 当前单元格，在每个可用的有效邻居上递归调用自身 最后在离开之前不会访问自己。该函数接受a 找到解决方案时调用回调函数（编辑：我不会重构，但我认为回调函数应存储在 knights-tour 类的插槽中）。
(declaim (ftype
(function (knights-tour fixnum fixnum function)
(values &optional))
brute-visit))
(defun brute-visit (knight x y callback
&aux (board (board knight))
(cells (visited-cells knight)))
(declare (function callback)
(board board)
(type (vector * *) cells)
(fixnum x y))
(visit knight x y)
(if (= (fill-pointer cells) (array-total-size cells))
(funcall callback knight)
(loop for (i j) of-type delta
in '((-1 -2) (1 -2) (-2 -1) (2 -1)
(-2 1) (2 1) (-1 2) (1 2))
for xx = (the frontier (+ i x))
for yy = (the frontier (+ j y))
when (and (array-in-bounds-p board yy xx)
(zerop (aref board yy xx)))
do (brute-visit knight xx yy callback)))
(unvisit knight x y)
(values))
(defun knights-tour (x y callback &optional (h 8) (w 8))
(let ((board (make-instance 'knights-tour :height h :width w)))
(brute-visit board x y callback)))
以下测试要求找到6x6板的解决方案：
(time (block nil
(knights-tour 0 0 (lambda (k) (return k)) 6 6)))
Evaluation took:
0.097 seconds of real time
0.096006 seconds of total run time (0.096006 user, 0.000000 system)
[ Run times consist of 0.008 seconds GC time, and 0.089 seconds non-GC time. ]
98.97% CPU
249,813,780 processor cycles
47,005,168 bytes consed
相比之下，其他版本的版本运行如下 （原点是相同的，但我们以不同的方式索引单元格）：
(time (knights-tour-brute 1 1 6 6))
Evaluation took:
0.269 seconds of real time
0.268017 seconds of total run time (0.268017 user, 0.000000 system)
99.63% CPU
697,461,700 processor cycles
17,072,128 bytes consed
对于较大的电路板，差异更明显。如果我们要求找到8x8电路板的解决方案，上述版本在我的机器上的作用如下：
> (time (block nil (knights-tour 0 0 (lambda (k) (return k)) 8 8)))
Evaluation took:
8.416 seconds of real time
8.412526 seconds of total run time (8.412526 user, 0.000000 system)
[ Run times consist of 0.524 seconds GC time, and 7.889 seconds non-GC time. ]
99.96% CPU
21,808,379,860 processor cycles
4,541,354,592 bytes consed
#<knight's tour: 8x8, tour: #(0 10 4 14 20 3 9 19 2 8 18 1 11 5 15 21 6 12 22 7
13 23 29 35 25 40 34 17 27 33 16 26 32 49 43 28
38 55 61 44 59 53 63 46 31 37 47 30 36 51 57 42
48 58 52 62 45 39 54 60 50 56 41 24)>
原始的基于列表的方法没有返回，十分钟后我被杀了 工人线程。
仍然有改进的余地（参见实际的研究论文以获得更多信息），在这里我会像@ jkiiski的更新版本那样对邻居进行排序，看看会发生什么。接下来的内容只是抽象迭代邻居的一种方法，因为我们将不止一次地使用它，并且不同：
(defmacro do-neighbourhood ((xx yy) (board x y) &body body)
(alexandria:with-unique-names (i j tx ty)
`(loop for (,i ,j) of-type delta
in '((-1 -2) (1 -2) (-2 -1) (2 -1)
(-2 1) (2 1) (-1 2) (1 2))
for ,tx = (the frontier (+ ,i ,x))
for ,ty = (the frontier (+ ,j ,y))
when (and (array-in-bounds-p ,board ,ty ,tx)
(zerop (aref ,board ,ty ,tx)))
do (let ((,xx ,tx)
(,yy ,ty))
,@body))))
我们需要一种方法来计算可能的邻居数量：
(declaim (inline count-neighbours)
(ftype (function (board fixnum fixnum ) fixnum)
count-neighbours))
(defun count-neighbours (board x y &aux (count 0))
(declare (fixnum count x y)
(board board))
(do-neighbourhood (xx yy) (board x y)
(declare (ignore xx yy))
(incf count))
count)
以下是替代搜索实现：
(defstruct next
(count 0 :type fixnum)
(x 0 :type fixnum)
(y 0 :type fixnum))
(defun brute-visit (knight x y callback
&aux (board (board knight))
(cells (visited-cells knight)))
(declare (function callback)
(board board)
(type (vector * *) cells)
(fixnum x y))
(visit knight x y)
(if (= (fill-pointer cells) (array-total-size cells))
(funcall callback knight)
(let ((moves (make-array 8 :element-type 'next
:fill-pointer 0)))
(do-neighbourhood (xx yy) (board x y)
(vector-push-extend (make-next :count (count-neighbours board xx yy)
:x xx
:y yy)
moves))
(map nil
(lambda (next)
(brute-visit knight
(next-x next)
(next-y next)
callback)
(cerror "CONTINUE" "Backtrack detected"))
(sort moves
(lambda (u v)
(declare (fixnum u v))
(<= u v))
:key #'next-count)
)))
(unvisit knight x y)
(values))
尝试以前的测试时，结果是立即。 例如，使用 64x64 电路板：
knight> (time
(block nil
(knights-tour
0 0
(lambda (k) (return))
64 64)))
Evaluation took:
0.012 seconds of real time
0.012001 seconds of total run time (0.012001 user, 0.000000 system)
100.00% CPU
29,990,030 processor cycles
6,636,048 bytes consed
为5x5电路板寻找1728解决方案需要42秒。
这里我保留了回溯机制，为了查看是否需要它，我在搜索中添加了cerror表达式，以便在搜索尝试其他路径时立即通知我们。以下测试会触发错误：
(time
(dotimes (x 8)
(dotimes (y 8)
(block nil
(knights-tour
x y
(lambda (k) (return))
8 8)))))
报告错误的 x 和 y 的值分别为 2 和 1 。< / p>
1 有关参考，请参阅Daft Punk。
答案 2 :(得分：2)
我决定将此添加为另一个答案，而不是对我的其他答案进行如此重大的编辑。
事实证明，有heuristic解决问题。你只需要尽可能少地移动到正方形。
我转而使用某种特殊图表来表示电路板。方块包含骑士可以前往的方格的边缘。通过这种方式可以预先建造电路板，实际的搜索并不需要关心骑士可以移动的位置的细节（只需跟随边缘）。没有必要保留单独的路径列表，因为边缘保留了必要的信息以便回溯。
由于实施图表，它相当冗长，但相关部分为find-tour和backtrack。
使用(knights-tour:knights-tour 0 0 8 8)将返回square s的二维数组，这可能本身并不是非常有用。您应该通过knights-tour:print-board或knights-tour:path-as-list传递它。
(let ((tour (knights-tour:knights-tour 0 0 8 8)))
(knights-tour:print-board tour)
(knights-tour:path-as-list tour))
;; 1 54 15 32 61 28 13 30
;; 16 33 64 55 14 31 60 27
;; 53 2 49 44 57 62 29 12
;; 34 17 56 63 50 47 26 59
;; 3 52 45 48 43 58 11 40
;; 18 35 20 51 46 41 8 25
;; 21 4 37 42 23 6 39 10
;; 36 19 22 5 38 9 24 7
;; => ((0 . 0) (1 . 2) (0 . 4) (1 . 6) (3 . 7) (5 . 6) (7 . 7) (6 . 5) (5 . 7)
;; (7 . 6) (6 . 4) (7 . 2) (6 . 0) (4 . 1) (2 . 0) (0 . 1) (1 . 3) (0 . 5)
;; (1 . 7) (2 . 5) (0 . 6) (2 . 7) (4 . 6) (6 . 7) (7 . 5) (6 . 3) (7 . 1)
;; (5 . 0) (6 . 2) (7 . 0) (5 . 1) (3 . 0) (1 . 1) (0 . 3) (1 . 5) (0 . 7)
;; (2 . 6) (4 . 7) (6 . 6) (7 . 4) (5 . 5) (3 . 6) (4 . 4) (3 . 2) (2 . 4)
;; (4 . 5) (5 . 3) (3 . 4) (2 . 2) (4 . 3) (3 . 5) (1 . 4) (0 . 2) (1 . 0)
;; (3 . 1) (2 . 3) (4 . 2) (5 . 4) (7 . 3) (6 . 1) (4 . 0) (5 . 2) (3 . 3)
;; (2 . 1))
如果找不到解决方案（例如，在5x5板上（1,0）），knights-tour将返回nil。
正方形为零索引。
(declaim (optimize (speed 3) (space 0) (safety 0) (debug 0)))
(defpackage :knights-tour
(:use :cl)
(:export :knights-tour
:print-board
:path-as-list))
(in-package :knights-tour)
;;; Function types
(declaim (ftype (function (fixnum fixnum fixnum fixnum) (or board null))
knights-tour))
(declaim (ftype (function (square fixnum)) find-tour))
(declaim (ftype (function (square) square) backtrack))
(declaim (ftype (function (square) fixnum) count-valid-moves))
(declaim (ftype (function (square) list) neighbours))
(declaim (ftype (function (edge square) (or square null)) other-end))
(declaim (ftype (function (edge square)) set-travelled))
(declaim (ftype (function (edge square) (or (member :from :to) null)) travelled))
(declaim (ftype (function (fixnum fixnum) board) make-board))
(declaim (ftype (function ((or board null))) print-board))
(declaim (ftype (function ((or board null)) list) path-as-list))
;;; Types, Structures and Conditions
(deftype board () '(array square (* *)))
(defstruct square
"Represents a square on a chessboard.
VISITED contains the number of moves left when this `square' was
visited, or 0 if it has not been visited.
EDGES contains a list of edges to `square's that a knight can move to
from this `square'.
"
(visited 0 :type fixnum)
(edges (list) :type list)
(tries 0 :type fixnum)
(x 0 :type fixnum)
(y 0 :type fixnum))
(defstruct edge
"Connects two `square's that a knight can move between.
An `edge' has two ends, TO and FROM. Both contain a `square'.
TRAVELLED contains either :FROM or :TO to signal that this edge has
been travelled from the `square' in FROM or TO slots respectively to
the other one. Contains NIL if this edge has not been travelled.
TRAVELLED should be set and read with SET-TRAVELLED and TRAVELLED.
"
(to nil :type square)
(from nil :type square)
(travelled nil :type (or keyword null))
(backtracked nil :type boolean))
(define-condition no-solution (error) ()
(:documentation "Error raised when there is no solution."))
(define-condition too-many-tries (error) ()
(:documentation "Error raised after too many attempts to backtrack."))
;;; Main program
(defun knights-tour (x y width height)
"Finds a knights tour starting from point X, Y on board size WIDTH x HEIGHT.
X and Y are zero indexed.
When a path is found, returns a two-dimensional array of
`square's. When no path is found, returns NIL.
"
(let ((board (make-board width height)))
(handler-case (find-tour (aref board y x) (* width height))
(no-solution () (return-from knights-tour nil))
(too-many-tries () (return-from knights-tour nil)))
board))
(defun find-tour (current-square moves-left)
"Find a knights tour starting from CURRENT-SQUARE, taking MOVES-LEFT moves.
Returns nothing. The `square's are mutated to show how many moves were
left when the knight passed through it.
"
(when (or (not (square-p current-square))
(minusp moves-left))
(return-from find-tour))
(setf (square-visited current-square) moves-left)
;; If the same square has been tried 1000 times, assume we're in an
;; infinite backtracking loop.
(when (> (incf (square-tries current-square)) 1000)
(error 'too-many-tries))
(let ((next-moves (1- moves-left)))
(unless (zerop next-moves)
(find-tour
(loop
with least-moves = 9
with least-square = nil
with least-edge = nil
for (edge . neighbour) in (neighbours current-square)
for valid-moves = (if (not (travelled-from edge current-square))
(count-valid-moves neighbour)
9)
when (< valid-moves least-moves) do
(setf least-moves valid-moves
least-square neighbour
least-edge edge)
finally (if least-square
(progn (set-travelled least-edge current-square)
(return least-square))
(progn (incf next-moves)
(return (backtrack current-square)))))
next-moves))))
(defun backtrack (square)
"Return the `square' from where the knight travelled to SQUARE.
Also unmarks SQUARE and all `edge's travelled from SQUARE.
"
(setf (square-visited square) 0)
(loop
with to-edge = nil
for edge in (square-edges square)
;; Unmark edges travelled from this square.
when (travelled-from edge square) do
(setf (edge-travelled edge) nil
(edge-backtracked edge) nil)
;; Find the edge used to travel to this square...
when (and (travelled-to edge square)
(not (edge-backtracked edge))) do
(setf to-edge edge)
;; and finally return the other end of that edge.
finally (if to-edge
(progn (setf (edge-backtracked to-edge) t)
(return (other-end to-edge square)))
(error 'no-solution))))
;;; Helpers
(defun count-valid-moves (square)
"Count valid moves from SQUARE."
(length (neighbours square)))
(defun neighbours (square)
"Return a list of neighbours of SQUARE."
(loop
for edge in (square-edges square)
for other = (other-end edge square)
when (zerop (square-visited other)) collect (cons edge other)))
(defun other-end (edge square)
"Return the other end of EDGE when looking from SQUARE."
(if (eq (edge-to edge)
square)
(edge-from edge)
(edge-to edge)))
(defun set-travelled (edge square)
"Set EDGE as travelled from SQUARE."
(setf (edge-travelled edge)
(if (eq (edge-to edge)
square)
:to :from)))
(defun travelled (edge square)
"Has the EDGE been travelled, and from which end."
(when (edge-travelled edge)
(if (eq (edge-to edge)
square)
(if (eql (edge-travelled edge) :to)
:from :to)
(if (eql (edge-travelled edge) :from)
:to :from))))
(defun travelled-from (edge square)
"Has EDGE been travelled from SQUARE."
(eql :from (travelled edge square)))
(defun travelled-to (edge square)
"Has EDGE been travelled to SQUARE."
(eql :to (travelled edge square)))
(defun make-board (width height)
"Make a board with given WIDTH and HEIGHT."
(let ((board (make-array (list height width)
:element-type 'square)))
(dotimes (i height)
(dotimes (j width)
(let ((this-square (make-square :x j :y i)))
(setf (aref board i j)
this-square)
(loop
for (x-mod . y-mod) in '((-2 . -1) (2 . -1) (-1 . -2) (1 . -2))
for target-x = (+ j x-mod)
for target-y = (+ i y-mod)
when (array-in-bounds-p board target-y target-x) do
(let* ((target-square (aref board target-y target-x))
(edge (make-edge :to target-square
:from this-square)))
(push edge (square-edges this-square))
(push edge (square-edges target-square)))))))
board))
(defun print-board (board)
"Print a text representation of BOARD."
(when board
(loop
with (height width) = (array-dimensions board)
with moves = (1+ (* height width))
with col-width = (ceiling (log moves 10))
for y from 0 below height
do (loop
for x from 0 below width
do (format t " ~vd " col-width
(- moves (square-visited (aref board y x)))))
do (format t "~%"))))
(defun path-as-list (board)
"Return a list of coordinates representing the path taken."
(when board
(mapcar #'cdr
(sort (loop
with (height width) = (array-dimensions board)
with result = (list)
for y from 0 below height
do (loop
for x from 0 below width
do (push (cons (square-visited (aref board y x))
(cons x y))
result))
finally (return result))
#'>
:key #'car))))
;;; Printers
(defmethod print-object ((square square) stream)
(declare (type stream stream))
(format stream "<(~d, ~d) ~d>"
(square-x square)
(square-y square)
(square-visited square)))
(defmethod print-object ((edge edge) stream)
(declare (type stream stream))
(format stream "<edge :from ~a :to ~a :travelled ~a>"
(edge-from edge)
(edge-to edge)
(edge-travelled edge)))