Recursion 优化骑士之旅口齿不清
我是LISP新手，在下面的代码中遇到了这个问题Recursion 优化骑士之旅口齿不清,recursion,lisp,common-lisp,Recursion,Lisp,Common Lisp,我是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 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))))
（德芬骑士巡演野兽（x y m n）
（setq高度m）
（设置宽度n）
（setq totalmoves（*高宽））
（setq步骤1）
（setq访问列表（列表（列表x y）））
（tour brute（列表（列表x y）））
（图1）
（续）
（（空L）无）
（（=总移动步数）L）
（t
（let（（nextmove（generate L）））
（条件（（空下一个移动）（回溯（汽车（最后一个L）））
（巡演暴力（反向（cdr（反向L '））））
（t（setq访问列表（追加访问列表（下一步列表）））
（tour brute（附加L（列表下一步()(())()))((())
（defun生成（L）
（让（（x（caar（最后一个L）））
（y（尸体（最后一个L）））
（setq步数（+1步））
（续）
（（正确状态（+x2）（+y1）L）（列表（+x2）（+y1）））
（（正确状态（+x2）（-y1）L）（列表（+x2）（-y1）））
（（正确状态（-x1）（+y2）L）（列表（-x1）（+y2）））
（（正确状态（+x1）（+y2）L）（列表（+x1）（+y2）））
（（正确状态（+x1）（-y2）L）（列表（+x1）（-y2）））
（（正确状态（-x1）（-y2）L）（列表（-x1）（-y2）））
（（正确状态（-x2）（+y1）L）（列表（-x2）（+y1）））
（（正确状态（-x2）（-y1）L）（列表（-x2）（-y1）））
（t（设置q步（-steps 2））NIL）
（卸载正确状态（x y L）
（如果（和（正如我在评论中提到的，这个问题是缺少的。您可以使用
(declaim (optimize (speed 3)))
但这取决于您的实现。我不确定CLISP
编辑：其他答案有更有效的解决问题的方法，但阅读此答案仍然值得，以更好地编写原始解决方案
无论如何，我对代码进行了一些优化。您仍然需要有TCO才能运行它。这是像这样使用递归的固有问题。它至少应该在以下条件下运行良好。只需将其保存到文件中，然后执行以下操作
(load (compile-file "file.lisp"))
它的运行速度必须比您的原始代码快，并且内存分配要少得多。与您的代码相关的（time（knights tour brute 1 1 6））
：
4,848,466,907 processor cycles
572,170,672 bytes consed
我的代码是：
1,155,406,109 processor cycles
17,137,776 bytes consed
在大多数情况下，我保留了您的代码。我所做的更改主要是：
我实际上声明了全局变量并清理了一些代码
在您的版本中，您按顺序构建了访问列表
。当您不了解Lisp中的单链接列表是如何工作的时，这似乎很直观，但效率很低（那些（反向（cdr（反向列表）））
真的影响了性能）.你应该读一些关于列表的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)))
：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
进行了大部分考虑，而访问
占用了大部分时间（注意，由于仪器原因，秒数当然相差很远）：
from@jkiiski采用与OP相同的方法，极大地优化了
这里的目标是不同的：我尝试使用另一个
表示问题的方法（但仍然是蛮力），我们可以通过向量和
矩阵，我们可以更好、更快、更强地解决更难的问题
我还应用了与另一个答案相同的启发式方法，这大大减少了寻找解决方案所需的工作量
数据结构
接下来，我们定义一个类来保存骑士之旅问题的实例
以及工作数据，即高度、宽度，表示
包含0（空）或1（已访问）以及
当前巡更，由大小为高度x宽度的向量表示，带有
填充指针初始化为零。由于内部电路板已经存储了这些尺寸，因此此类中严格不需要这些尺寸
(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))))
顺便说一下，我们还专门处理打印对象(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)))
(defun unvisit (knight x y)
(let ((board (board knight)))
(declare (board board))
(setf (aref board y x) 0)
(decf (fill-pointer (visited-cells knight)))))
(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 (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)>
(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)
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
(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))
cerror(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)))
(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
> (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)>
(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))
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
(time
(dotimes (x 8)
(dotimes (y 8)
(block nil
(knights-tour
x y
(lambda (k) (return))
8 8)))))
(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))
(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)))