failing like never before

16Nov/094

Knight’s Tour in Lisp

For those of you unfamilar with the Knight's tour, here's a brief overview of the problem. The Knight's Tour invovles placing a knight on a chessboard and then having the knight move to each and every square on the chessboard once and only once. There are a suprisingly huge number of possible paths that a single Knight can take on a standard chessboard so of course, a blind, exhaustive search is generally out of the question. 

The program I have written below explores the Open Knight's Tour, where the knight simply has to reach each and every square once and only once (the Closed Tour would add the additional requirement that the knight end on the square he started on). I will admit that my Lisp code isn't exactly the best or the most efficient, but it works fairly deccent. My method of solving the tour, uses backtracking (which is very similar to Depth First Search) and a herustic known as Minimum Remaining Value. This herustic is sometimes known as Warnsdorff's algorithm when used in the Knight's Tour. Warnsdorff's algorithm selects as the knight's next move, the square that would present the fewest possible moves following the move to that square. Essentially, the herustic is trying to eliminate dead end's earlier on. And so here's my code (most of which is comments, [Hey, it was written for a class]):

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; FIND-KNIGHTS-TOUR2                                                      ;;; 
;;; using minimum remaining value herustics (aka most constrained variable) ;;;
;;;                                                                         ;;; 
;;; on my laptop, this implementation can find a solution to                ;;;
;;; 100x100 board, starting from (1 1) in under three minutes               ;;;
;;; and can solve 50x50 in about 16 seconds on SEAS                         ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; you can run the knights tour with:
; (find-knights-tour ([rows in board] [cols in board] [row_pos] [col_pos])

(setq steps 0)
(setq visited-list ()) 


; generate a list of all possible moves for knight
; given that current position of knight is (row col)
; note that this function will generate "wrong" move values, like
; moving off the board or moving to an old spot.
;
; function get_values(number:x number:y):((num num) (num num) )
(defun get_values (row col)
  (list 
    ; there are at most eight possible move values 
    (list (+ row 2) (+ col 1))
    (list (+ row 2) (- col 1))
    (list (+ row 1) (+ col 2))
    (list (+ row 1) (- col 2))

    (list (- row 2) (+ col 1))
    (list (- row 2) (- col 1))
    (list (- row 1) (+ col 2))
    (list (- row 1) (- col 2))) )

; val is a list of possible move values for a knight variable
;   and should be generated by get_values function
; m_row is max number of rows in the board
; m_col is max number of columns in the board
;
; test_valid_values will return a list containing only the valid
; values allowed, removing those values that have already been
; visited and are not on the board
;
; function test_valid_values( 
;       ((num num) (num num) ):vals
;       number:m_row
;       number:m_col):((num num) (num num) )
(defun test_valid_values (vals m_row m_col)
  (let 
    ; grab the first value out of the vals list
    ((v (car vals)))
  (cond
    ((null vals) ()) 
    ; test for out of bound values, or already traversed
    ; if value is out of bound, remove it (cdr vals) 
    ((or (> (car v)  m_row) (<= (car v)  0) 
         (> (cadr v) m_col) (<= (cadr v) 0)
         (list_member v visited-list))
            (test_valid_values (cdr vals) m_row m_col))
    ; value is valid, add to our "valid" list
    (t (cons (car vals) 
             (test_valid_values (cdr vals) m_row m_col))))) )


; check if "l" is a member of "visited"
; return 't' if so, 'nil' otherwise
;
; function list_member( 
;       (number number):l
;       ((num num) (num num) ):visited) :t/nil
(defun list_member (l visited)
  (cond
    ((null visited) nil)
    ((equal (car visited) l) t)
    (t (list_member l (cdr visited)))) )


;minimum remaining value herustic, or the most constrained variable
;instead of just returning randomnly arranged list of possible moves from
;   current location (as in above without herustics) arrange possible moves
;   in the list so that the move that will offer the least number of moves in
;   the next iteration comes first, with the move that offers the most of 
;   moves coming last in the list
;   
;function min_remaining_val(number:m_row number:m_col): 
;       ((number number) (number number) )
(defun min_remaining_val (m_row m_col)
  (let
    ; get valid values
    ((vals (test_valid_values 
        (get_values 
        (car (car (last visited-list))) (cadr (car (last visited-list)))) 
             m_row m_col)))
    ; then call call mrv_helper to attach assign a value to each move
    ; mrv_sort to arrange moves 
    (mrv_sort (mrv_helper vals m_row m_col))
))

; determines number of possible moves allowed if we move to a position in
; the vals list
;
; function mrv_helper(
;   ((num num) (num num) ):vals
;   number:m_row
;   number:m_col) :
;   ((num (num num)) (num (num num)) )
(defun mrv_helper (vals m_row m_col)
  (let 
    ((len 
       ; calculate the number of possible moves from a position in the 
       ; "vals" list
       (length 
         (test_valid_values 
           (get_values (car (car vals)) (cadr (car vals))) 
         m_row m_col))))
    (cond 
      ; if no more moves in "vals", just return it and done
      ((null (cdr vals)) (list (cons len (list (car vals)))))
      ; else add move and length value to list and keep recursing
      (t (cons (cons len (list (car vals))) 
                 (mrv_helper (cdr vals) m_row m_col))))) )

;finds the move with the minimum value in the list "vals"
;i.e. if "vals" is ( (1 (2 4)) (2 (5 2)) (4 (3 2)) )
;   then min_vals would return (1 (2 4)) because its move value is "1"
;
;function min_val(
;   ((num (num num)) (num (num num)) ):vals) :
;       (num (num num))
(defun min_val (vals)
  (cond
    ; base case, return the only move in "vals"
    ((null (cdr vals)) (car vals))
    (t
      (let
        ; calculate the min_val in the rest of the list
        ; store it in "p"
        ((p (min_val (cdr vals))))
        (cond
          ; if the current minimum value is less then previous
          ; min val, then use current min val
          ((<= (car (car vals)) (car p)) (car vals))
          ; else use previous min val
          (t p))))) )

; remove from list 'l' the element that matches 'r'
; this is because we are not allowed to use "remove" function
;
;function remove_list(list:r list:l):list
(defun remove_list (r l)
  (cond
    ; if equal, then done
    ((equal r (car l)) (cdr l))
    ; reached the end and couldn't find a match
    ((null (cdr l)) l)
    ; else keep recursing
    (t (cons (car l) (remove_list r (cdr l))))) ) 

; sort the moves in "vals" list based on their move length values
; and then strips out their "length values
;
; i.e., if "vals" is ((3 (2 3)) (2 (1 2)) (5 (3 4)) (1 (2 1)) (2 (2 2)))
;then mrv_sort returns:
;   ((2 1) (1 2) (2 2) (2 3) (3 4) )

;function mrv_sort(
;   ((num (num num)) (num (num num))  ):vals) :
;   ((num num) (num num) )
(defun mrv_sort (vals)
  (cond
    ; base case, return the last move in "vals"
    ((null (cdr vals)) (cdr (car vals)))
    (t 
      (let
        ;else keep sorting, using min_val function 
        ;v is the min val in "vals"
        ((v (min_val vals)))
        (append (cdr v) (mrv_sort (remove_list v vals)))))) )


; recurse down the search tree, expand out the children for last
; visited spot
;
; m_row is number of rows in board
; m_col is number of cols in board
;
; function recurse_down(number:m_row number:m_col):t/nil
(defun recurse_down (m_row m_col)
  ; get the valid values, store as val
  (let
    ((vals (min_remaining_val m_row m_col)))
    (cond
      ; no valid values, backtrack 
      ; note, that we test for sucessful completion before this 
      ((null vals) nil)
      ; else recurse across
      (t (recurse_across vals m_row m_col)))) ) 

; this function is exactly the same as recurse_across except
; that it calls recurse_down instead of recurse_down
;
;vals is valid moves, having the form:
;     ((number number) (num num) etc.)
; m_row is number of rows in board
; m_col is number of cols in board
;
; function recurse_across(
;       ((num num) (num num) ):vals
;       number:m_row
;       number:m_col) : t/nil
(defun recurse_across (vals m_row m_col)
  (cond
    ; no more valid moves, backtrack
    ((null vals) nil)
    (t 
      (cond
      ; if number of steps taken equals number of squares on board
      ; then we're done
      ((equal (+ steps 1) (* m_row m_col)) 
        ; increment number of steps, add new visited square
        (setq steps (+ steps 1)) 
        (setq visited-list (append visited-list (list (car vals)))) 
        ; return t 
        t)
      (t
        ; else continue moving until end
        ; increment steps and add to visited-list 
        (setq steps (+ steps 1)) 
        (setq visited-list (append visited-list (list (car vals)))) 
        (cond 
          ; recurse down, return t if recurse_down found solution
          ((recurse_down m_row m_col) t)
          (t 
            ; if recurse_down did not find solution, backtrack, removing
            ; moves from visited-list and from "steps" as we backtrack
            ; and then recurse_across
            (setq steps (- steps 1))
            (setq visited-list (reverse (cdr (reverse visited-list))))
            (recurse_across (cdr vals) m_row m_col))))))) ) 

;find the knights tour given board size of (m_row m_col) and 
;starting position (row col)
;use herustics
;
;function find-knights-tour(number:m_row number:m_col number:row number:col) :
;       ((number number) (number number) )
(defun find-knights-tour (m_row m_col row col)
  ; set the global variables
  (setq visited-list (list (list row col)))
  (setq steps 1)
  ; start searching...
  (cond
    ((recurse_down m_row m_col) visited-list)
    (t nil)) )
Comments (4) Trackbacks (0)
  1. I know you did this a couple of years ago, but I have to comment. This code looks a thousand times better than that I came up with in java a few days ago. How do you feel about lisp. I am currently teaching myself haskell and was wondering if ys ou prefer functional languages, or you just chose lisp because it kind of lends it’s self to this kind of problem

  2. Do you know the Knigths problem, where we have 4 night(2 black, 2 white) and we have to switch places? (black and white)

  3. Hi,

    thanks for the code! Your code doesn’t do any backtracking and won’t find possible solutions for certain starting points on a board with dimensions different from 8×8. So I went ahead and reimplemented it using lists of coordinates for representing the moves and the unvisited board positions. This results in fairly elegant and general code as the backtracking just pushes and pops from the list but is slower than using arrays. An additional optimization is used from this (german) page: http://www.axel-conrad.de/springer/springer.html

    This optimization removes a move if there is any unvisited position which can’t be reached by a concatenation of direct knight moves starting at the move.

    Since the code backtracks, it will find many solutions breaking on every solution and printing the board. All solutions are collected as a list of coordinates in the special variable *solutions*.

    The board size can be specified as a keyword argument. Below the code are some examples. Note the *board-size* has to be declared special, as it is used by some functions without *board-size* being a global variable. Make sure not to use impossible board-sizes (see Schwenks prove in the Wikipedia article on “knight’s tour”)

    “on-board?” and “direct-connections” are shortened versions of “on-board-p” and “moves” of your code.

    (defparameter *solutions* nil)

    (defun on-board? (pos)
    “check if pos is on the board.”
    (destructuring-bind (x y) pos
    (and (< -1 x (first *board-size*))
    (< -1 y (second *board-size*)))))

    (defun direct-connections (pos)
    "return all direct knight moves on the board from pos."
    (remove-if-not #'on-board?
    (mapcar (lambda (offs)
    (mapcar #'+ pos offs))
    '((1 2) (-1 2) (1 -2) (-1 -2)
    (2 1) (2 -1) (-2 1) (-2 -1)))))

    (defun remove-members (pool list)
    "removes elements from list which are contained in pool. returns a
    new modified list."
    (remove-if (lambda (x) (member x pool :test #'equal)) list))

    (defun all-unused-reachable? (pos unused)
    "Are all unused positions reachable with a concatenation of knight
    moves from pos? This doesn't mean that we will find a solution as two
    different unused fields might be reachable only from the same previous
    field. It only means that there can't be a solution if this function
    returns nil."
    (loop
    with checked = nil
    with unused = unused
    ;;; in each iteration we get the newly reached positions by appending
    ;;; the unique positions of all direct connections of the previously
    ;;; reached positions which have not yet been checked:
    for reached = (list pos) then (remove-duplicates
    (apply
    #'append
    (mapcar
    (lambda (pos)
    (remove-members checked (direct-connections pos)))
    reached))
    :test #'equal)
    do (progn
    (setf unused (remove-members reached unused))
    (setf checked (append checked reached)))
    until (or (not unused) (not reached))
    finally (return (if unused nil t))))

    (defun print-board (solution)
    (let ((board (make-array (list
    (first *board-size*)
    (second *board-size*)))))
    (loop
    for count from 1
    for move in solution
    do (destructuring-bind (x y) move
    (setf (aref board x y) count)))
    (with-output-to-string (str)
    (dotimes (y (second *board-size*))
    (dotimes (x (first *board-size*))
    (format str "~2D " (aref board x y)))
    (format str "~%"))
    (format str "~%"))))

    ;;; Main backtracking algorithm:

    (defun knight-bt-routine (used unused)
    (cond
    ((null unused) (progn
    (push (reverse used) *solutions*)
    (break "solution found: ~%~%~a "
    (print-board (first *solutions*)))))
    (t (mapcar (lambda (pos)
    (knight-bt-routine
    (cons pos used)
    (remove pos unused :test #'equal)))
    (remove-if-not
    (lambda (p)
    (all-unused-reachable? p unused))
    ;;; Warnsdorff-Rule: Prefer moves which have less possible connections
    (sort (remove-members used (direct-connections (first used)))
    (lambda (x y) (< (length (remove-members used (direct-connections x)))
    (length (remove-members used (direct-connections y)))))))))))

    (defun solve-knight-problem (startpos &key (board-size '(8 8)))
    (let* ((*board-size* board-size)
    (unused (loop for x from 0 below (first *board-size*)
    append (loop
    for y below (second *board-size*)
    collect (list x y)))))
    (declare (special *board-size*))
    (setf *solutions* nil)
    (knight-bt-routine (list startpos) (remove startpos unused :test #'equal))))

    #|
    ;;; Examples:

    ;;; Standard 8×8 board:

    (solve-knight-problem '(0 0))

    ;;; smallest possible board:

    (solve-knight-problem '(0 0) :board-size '(8 5))

    ;;; all results of a call are collected into the parameter *solutions*

    |#

    • Sorry, I was actually posting to the wrong blog: Your code of course is backtracking! I had the code of somebody else and did’t realize that I was not posting on his blog. Apologies for that!

      Orm


Leave a comment


Security Code:

Trackbacks are disabled.