Skip to content

Instantly share code, notes, and snippets.

@hoehrmann
Created June 10, 2013 18:05
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
  • Save hoehrmann/5750907 to your computer and use it in GitHub Desktop.
Save hoehrmann/5750907 to your computer and use it in GitHub Desktop.
Solution for the knight's tour problem in Scheme written around 2003 as part of an assignment.
; Bjoern Hoehrmann -- <bjoern@hoehrmann.de> -- <http://bjoern.hoehrmann.de>
; Global constants and type definitions
(define empty-char 0)
(define HEIGHT 5)
(define WIDTH 5)
(define START-X 0)
(define START-Y 0)
(define-struct move (x y))
(define knightmoves
(list
(make-move -1 -2) (make-move 1 -2) (make-move 2 -1) (make-move 2 1)
(make-move 1 2) (make-move -1 2) (make-move -2 1) (make-move -2 -1)))
; greps all elements in l for which a comparison
; with comp yields in a true value
(define (grep l comp)
(if (null? l) ()
(let ((r (grep (cdr l) comp)))
(if (comp (car l)) (cons (car l) r) r))))
; creates a list with n elements using the function func to create each
; element. Function func takes one parameter indicating the number of
; elements still to be created including the current element.
(define (create-list n func)
(if (<= n 0) ()
(cons (func n) (create-list (- n 1) func))))
; creates a matrix with n,m fields using func
(define (create-list-xy n m func)
(create-list n (lambda(i) (create-list m func))))
; tests whether x,y is a position out of the boundaries of matrix l
(define (out-of-bounds? l x y)
(or
(< x 0) ; negative index
(< y 0) ; negative index
(>= y (length l)) ; less rows
(>= x (length (list-ref l y))))) ; less columns in row
; returns the value of the field at x,y of the matrix l or #<void>
; if x,y denotes a field outside the boundaries of the matrix
(define (list-ref-xy l x y)
(if (not (out-of-bounds? l x y))
(list-ref (list-ref l y) x)))
; first k elements of l or a copy of l if l has less than k elements
(define (list-head l k)
(if (and (> k 0) (not (null? l)))
(cons (car l) (list-head (cdr l) (- k 1)))
()))
; returns a modified copy of the list l where the i-th element is v
(define (set-element-at l i value)
(append (list-head l i) (list value) (list-tail l (+ i 1))))
; returns a modified copy of the matrix l where the field at x,y is v
(define (set-element-at-xy l x y value)
(set-element-at l y (set-element-at (list-ref l y) x value)))
; displays the matrix l
(define (display-matrix l)
(display "(")
(display (join " " (map fn (car l))))
(display ")\n")
(if (not (null? (cdr l)))
(display-matrix (cdr l)))
)
; converts the list of strings l to a single string by inserting the
; string s between all elements in l. E.g. (join "+" (list 1 2 3))
; would return the string "1+2+3".
(define (join s l)
(if (null? l) ""
(if (null? (cdr l)) (car l)
(string-append (car l) s (join s (cdr l))))))
; possible moves for player at poscolumn,posrow in field
(define (getlistofmoves poscolumn posrow field)
(grep knightmoves (lambda (m) (not (out-of-bounds?
field
(+ poscolumn (move-x m))
(+ posrow (move-y m)))))))
; right-aligns a number in a string
(define (fn x)
(if (> x 9) (number->string x) (string-append " " (number->string x))))
; a recursive solution for the "Springerproblem"
(define (turn field x y moves visited)
(cond
; turn should return #t in this case but (exit) is required...
((= visited (* WIDTH HEIGHT)) (display-matrix field) (exit))
((null? moves) #f)
(else
(let* ((nx (+ x (move-x (car moves)))) ; new x
(ny (+ y (move-y (car moves)))) ; new y
(nv (+ visited 1)) ; new visited
(nm (getlistofmoves nx ny field)) ; new moves
(nf (set-element-at-xy field nx ny nv)) ; new field
(uv (= (list-ref-xy field nx ny) empty-char))) ; unvisited?
; if the next field is visited or if it is unvisited and does not
; yield in a solution, try the next move in the list of moves
(if (or (and uv (not (turn nf nx ny nm nv))) (not uv))
(turn field x y (cdr moves) visited))))))
; Entry point, setup field/possible moves and place knight to start
(define (start)
(let ((field (create-list-xy HEIGHT WIDTH (lambda(x) empty-char))))
(if (not (turn (set-element-at-xy field START-X START-Y 1)
START-X START-Y (getlistofmoves START-X START-Y field) 1))
(display "There is no applicable solution\n"))))
(start)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment