3

我是 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))))

它返回一个错误 *** - 程序堆栈溢出。重置。当我在谷歌上搜索时,我意识到这是递归的结果。但是我不确定我应该如何优化这段代码来解决这个问题。任何帮助都深表感谢。

你好,上面是更新的代码。这是测试代码。(骑士巡演蛮力 5 5 1 1)

4

3 回答 3

3

正如我在评论中提到的,问题在于缺少尾调用优化 (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

在大多数情况下,我将您的代码保持原样。我所做的更改主要是:

  1. 我实际上声明了全局变量并清理了一些代码。
  2. 在您的版本中,您visited-list按顺序构建。当您不了解 Lisp 中的单链表如何工作时,这可能看起来很直观,但它的效率非常低(那些(reverse (cdr (reverse list)))真的很吃性能)。你应该阅读一些关于列表的 Lisp 书籍。我把它保持在相反的顺序,然后最后把它颠倒过来nreverse
  3. 您使用列表作为坐标。我改用结构。性能大大提高。
  4. 我为所有内容添加了类型声明。它稍微提高了性能。

但是,它仍然是相同的蛮力算法,因此对于较大的板来说它会很慢。您应该为这些研究更智能的算法。

(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大部分的consing,同时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
于 2016-02-16T21:14:03.193 回答
2

@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(已访问),以及当前的游览,由大小为高 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))))

顺便说一句,我们还专注于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))

访问位置xy的单元意味着在板中的适当位置设置一个并将当前单元的坐标推入访问单元向量。我存储行主要索引而不是几个坐标,因为它分配的内存更少(实际上差异并不重要)。

(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)))))

详尽的搜索

递归访问函数如下。它首先访问当前单元,在每个空闲的有效邻居上递归调用自己,最后在退出之前取消访问。该函数接受一个回调函数,只要找到解决方案就调用(编辑:我不会重构,但我认为回调函数应该存储在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)))

测试 1

以下测试要求为 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

测试 2

对于较大的电路板,差异更加明显。如果我们要求找到 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)))))

报告错误的xy值分别为21


1作为参考,请参阅Daft Punk

于 2016-02-18T23:12:33.037 回答
2

我决定将此添加为另一个答案,而不是对我的另一个答案进行如此重大的编辑。

事实证明,存在解决问题的启发式方法。您只需始终以尽可能少的移动速度移动到正方形。

我转而使用一种临时图表来表示董事会。方格包含骑士可以前往的方格的边缘。这样棋盘就可以事先搭建好,实际搜索不需要关心马可以移动的细节(只要沿着边缘走)。不需要单独保留所走路径的列表,因为边缘保留了回溯所需的信息。

由于实现了图表,它相当冗长,但相关部分是find-tourbacktrack

Using(knights-tour:knights-tour 0 0 8 8)将返回一个二维数组squares,它本身可能不是很有用。你应该把它通过knights-tour:print-boardor 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)))
于 2016-02-19T07:08:58.450 回答