; knight rider
; Given a chessboard, find a path of knight jumps visiting all fields of the
; board. A normal chessboard has 8 rows and 8 columns. Generalize the
; knight rider such as to acccept a square board of arbitrary size.
; When forming a path, for each element of the path found so far, the list of
; moves yet to be tried must be remembered (movelists).
; Make the path finder such as to return either a complete path or
; #f when no path is found. Keep trying other moves as long as no path is found.
; If from a given starting field no path is found, then try another starting
((_ test body ...)
(if test (begin body ...)))))
(define (add1 x) (+ x 1))
(define (sub1 x) (- x 1))
(define (sqr x) (* x x))
(define sort #f)
(define merge #f)
(lambda (pred? ls n)
(if (= n 1)
(list (car ls))
(let ((i (quotient n 2)))
(dosort pred? ls i)
(dosort pred? (list-tail ls i) (- n i)))))))
(lambda (pred? l1 l2)
((null? l1) l2)
((null? l2) l1)
((pred? (car l2) (car l1))
(cons (car l2) (domerge pred? l1 (cdr l2))))
(else (cons (car l1) (domerge pred? (cdr l1) l2))))))
(lambda (pred? l)
(if (null? l) l (dosort pred? l (length l)))))
(lambda (pred? l1 l2)
(domerge pred? l1 l2))))
(define (make-matrix rows columns . value)
(do ((m (make-vector rows)) (i 0 (+ i 1)))
((= i rows) m)
(if (null? value)
(vector-set! m i (make-vector columns))
(vector-set! m i (make-vector columns (car value))))))
(define (matrix-ref m i j) (vector-ref (vector-ref m i) j))
(define (matrix-set! m i j x) (vector-set! (vector-ref m i) j x))
(define (any? proc list . lists)
(if (null? list) #f
(let loop ((x list) (y lists))
(let ((r (apply proc (car x) (map car lists))))
(if (null? (cdr x)) r
(or r (loop (cdr x) (map cdr lists))))))))
(define (filter proc list)
((null? list) '())
((proc (car list)) (cons (car list) (filter proc (cdr list))))
(else (filter proc (cdr list)))))
; The knight rider
; Given a chessboard of boardside rows and boarsize columns,
; find a path of a knight passing allong all fields of the board.
(define (knight-rider boardsize)
(define max-index (sub1 boardsize))
(define nr-of-fields (sqr boardsize))
; Rows and columns are repesented by numbers 0 up to but not including
; the boardsize. At top level procedure main is called as (main 0 0)
; Fields are represented as (row . col).
; Jumps are represented as (row-difference . col-difference)
(define (main) ; Try all possible starting fields.
(let loop ((row 0) (col 0))
(and (< row boardsize) ; If all starting fields have been tried, return #f.
(if (= col boardsize) (loop (add1 row) 0) ; Try starting fields in next row.
(or (find-path row col) (loop row (add1 col)))))))
(define (find-path row col)
(let ((start (cons row col))) ; Fields are represented as (row . col).
(occupy! start) ; Mark the starting field occupied.
((path (list start)) ; Notice that the path will be build in reversed order.
(move-lists (list (get-sorted-moves start)))
; n is the length of the path found so far.
; Move-lists has as many elements as the path.
; Each move-list shows which jumps yet to try if the last jump fails.
((zero? n) #f) ; Return #f when no path is found from current start.
((= n nr-of-fields) (reverse path)) ; Path has been found.
((null? (car move-lists)) ; End of path has no more moves to try,
(clear! (car path)) ; hence backtrack by removing the last jump.
(path-loop (cdr path) (cdr move-lists) (sub1 n)))
((let ((field (caar move-lists))) ; Try the next move.
(cons field path) ; Add one move to the path.
(get-sorted-moves field) ; Why sorting? See get-sorted-moves.
; Below: remove the move just made from its move-list.
(cons (cdar move-lists) (cdr move-lists)))
(or result (begin (clear! field) #f)))))
(else ; Previous move did not work, hence try next move.
(path-loop path (cons (cdar move-lists) (cdr move-lists)) n))))))
(define jumps '((1 . 2) (-1 . 2) (1 . -2) (-1 . -2)
(2 . 1) (-2 . 1) (2 . -1) (-2 . -1)))
; Procedure add-jump computes the field reached when making a jump from a
; given field. It returns #f if the jump cannot be made from the field.
(define (add-jump field jump)
((x (+ (car field) (car jump)))
(y (+ (cdr field) (cdr jump))))
(and (<= 0 x max-index) (<= 0 y max-index) (cons x y))))
; Procedure get-moves returns all non occupied fields we can jump to
; from a given field.
(define (get-moves field)
(lambda (move) (and move (board-ref move)))
(map (lambda (jump) (add-jump field jump)) jumps)))
; Procedure get-sorted-moves provides the following heuristic:
; The feasible moves from the last field of the path
; (id est (car path)) are sorted such as to try those moves first
; that allow as less remaining moves as possible.
; This heuristic speeds up very much. It works well for boardsize < 35.
; For some boardsizes greater than 34, the speedup may not work.
(define (get-sorted-moves p)
(lambda (p q) (< (length (get-moves p)) (length (get-moves q))))
; The board is a boardsize x boardsize matrix.
; At all stages the board shows #f for occupied fields and #t for free fields.
(define board (make-matrix boardsize boardsize #t))
(define (occupy! field) (matrix-set! board (car field) (cdr field) #f))
(define (clear! field) (matrix-set! board (car field) (cdr field) #t))
(define (board-ref field) (matrix-ref board (car field) (cdr field)))
(display (knight-rider 8))