Related
Simple program for binary search.
elements contain no. of elements
then array contains those elements
then q contains no. of queries
search contains element to be searched.
Why this error is coming about high and low has no value after some iterations.
Kindly help :)
My Code :-
(setf elements (parse-integer (read-line)))
(setf array (make-array elements :fill-pointer 0))
(dotimes (i elements) (vector-push (parse-integer (read-line)) array))
(setf q (parse-integer (read-line)))
(defvar *mid*)
(dotimes (i q)
(setf search (parse-integer (read-line)))
(do ((low 0)
(high (- elements 1))
(mid (floor (+ low high) 2)
(floor (+ low high) 2)))
((>= low high) (setf *mid* nil))
(cond
((eql (elt array mid) search) (setf *mid* mid))
((< (elt array mid) search) (setf high (- mid 1)))
(t (setf low (+ mid 1)))))
(format t "~a" *mid*))
Your code is a fine example of an old adage:
the determined Real Programmer can write FORTRAN programs in any language.
Unfortunately Lisp programmers are generally quiche-eating hippies: so here is one quiche-eater's solution to this problem, using notions not present when FORTRAN IV was handed down to us from above on punched stones. These notions are therefore clearly heretical, but nonetheless useful.
Assuming this is homework, you probably will not be able to submit this answer.
Reading the data
First of all we'll write some functions which read the specification of the problem from a stream or file. I have inferred what it is from your code.
(defun stream->search-spec (stream)
;; Read a search vector from a stream: return a vector to be searched
;; and a vector of elements to search for.
;;
;; This function defines what is in files: each line contains an
;; integer, and the file contains a count followed by that many
;; lines, which specifies first the vector to be searched, and then
;; the things to search for.
;;
;; This relies on PARSE-INTEGER & READ-LINE to puke appropriately.
(flet ((read-vector ()
(let* ((elts (parse-integer (read-line stream)))
(vec (make-array elts :element-type 'integer))) ;won't help
(dotimes (i elts vec)
(setf (aref vec i) (parse-integer (read-line stream)))))))
(values (read-vector) (read-vector))))
(defun file->search-spec (file)
;; Read a search vector from a file. This is unused below but is
;; useful to have.
(with-open-file (in file)
(stream->search-spec in)))
(defun validate-sorted-vector (v)
;; check that V is a sorted vector
(dotimes (i (- (length v) 1) v)
(unless (<= (aref v i) (aref v (1+ i)))
(return-from validate-sorted-vector nil))))
The last function is used below to sanity check the data, since the search algorithm assumes the vector is sorted.
The search function
This implements binary search in the same way yours tries to do. Rather than doing it with loops and explicit assignemnt it does it using a local recursive function, which is far easier to understand. There are also various sanity checks and optionally debugging output. In any implementation which optimises tail calls this will be optimised to a loop; in implementations which don't then there will be a few extra function calls but stack overflow problems are very unlikely (think about why: how big would the vector need to be?).
(defun search-sorted-vector-for (vector for &key (debug nil))
;; search a sorted vector for some value. If DEBUG is true then
;; print what we're doing. Return the index, or NIL if FOR is not
;; present.
(when debug
(format *debug-io* "~&* ~D:~%" for))
(labels ((search (low mid high)
(when debug
(format *debug-io* "~& ~10D ~10D ~10D~%" low mid high))
(if (<= low mid high)
;; more to do
(let ((candidate (aref vector mid)))
(cond ((= candidate for)
;; found it
mid)
((< candidate for)
;; look higher
(search (1+ mid) (floor (+ high mid 1) 2) high))
((> candidate for)
;; look lower
(search low (floor (+ low mid) 2) (1- mid)))
(t
;; can't happen
(error "mutant death"))))
;; low = high: failed
nil)))
(let ((high (1- (length vector))))
(search 0 (floor high 2) high))))
Putting the previous two things together.
search-sorted-vector-with-search-vector will repeatedly search using the two vectors that the *->search-spec functions return. stream->search-results uses stream->search-spec and then calls this on its values. file->search-results does it all from a file.
(defun search-sorted-vector-with-search-vector (vector searches &key (debug nil))
;; do a bunch of searches, returning a vector of results.
(let ((results (make-array (length searches))))
(dotimes (i (length searches) results)
(setf (aref results i) (search-sorted-vector vector (aref searches i)
:debug debug)))))
(defun stream->search-results (stream &key (debug nil))
;; Read search specs from a stream, and search according to them.
;; Return the vector of results, the vector being searched and the
;; vector of search specifications.
(multiple-value-bind (to-search search-specs) (stream->search-spec stream)
(when debug
(format *debug-io* "~&searching ~S~% for ~S~&" to-search search-specs))
(assert (validate-sorted-vector to-search) (to-search) "not sorted")
(values (search-sorted-vector-with-search-vector to-search search-specs
:debug debug)
to-search search-specs)))
(defun file->search-results (file &key (debug nil))
;; sort from a file
(with-open-file (in file)
(stream->search-results in :debug debug)))
Using it
Given a file /tmp/x.dat with:
9
1
10
100
101
102
103
200
201
400
6
10
102
200
1
400
99
then:
> (file->search-results "/tmp/x.dat" :debug t)
searching #(1 10 100 101 102 103 200 201 400)
for #(10 102 200 1 400 99)
* 10:
0 4 8
0 2 3
0 1 1
* 102:
0 4 8
* 200:
0 4 8
5 6 8
* 1:
0 4 8
0 2 3
0 1 1
0 0 0
* 400:
0 4 8
5 6 8
7 7 8
8 8 8
* 99:
0 4 8
0 2 3
0 1 1
2 1 1
#(1 4 6 0 8 nil)
#(1 10 100 101 102 103 200 201 400)
#(10 102 200 1 400 99)
You can see that the last search failed (99 is not in the vector).
I am trying to write a function that creates a list of the fibonacci sequence but stops when a certain value is found in the list, then returns that list (I hope that makes sense).
So for example if I give it fib-list(55), the function should return:
(1 1 2 3 5 8 13 21 34 55)
So it's not the 55th fibonacci number I want, its the list UP TO the value 55.
The code I have for returning the list so far looks like this:
; Create a list of the fibonacci sequence up to n.
(define (fib-list n)
; n = n, f2 = 1, f1 = 1, fs = a list.
(let loop ((n n) (f2 1) (f1 1) (fs (list)))
(cond
; If n = 0, return reversed list.
((zero? n) (reverse fs))
; Check if n is in list. If so, return list.
((equal? n (car fs)) fs)
;Else, find the next fibonacci number and add it to the list.
(else (loop (- n 1) f1 (+ f2 f1) (cons f2 fs))))))
(display (fib-list 55))
My main problem is finding if an element is in the list, because at the moment I just get an error on the line where I am trying to write the ((equal? statement.
The error says:
mcar: contract violation
expected: mpair?
given: '()
I am still very VERY new to Scheme, so my understanding of the language as a whole isn't great. So please be gentle when telling me why my code sucks/doesn't make sense.
(list) creates an empty list, and on the first iteration you get to (car fs), which tries to apply car to an empty list, and that's an error.
Your code seems a bit confused about the nature of n.
Your description says that it's the largest number you want, but you're recursing like you want the n:th Fibonacci number - terminating on (zero? n) and recursing on (- n 1).
When you're recursing you're still looking for numbers up to the same limit.
Thus, you should not decrement your limit and terminate on zero, you should leave the limit alone and terminate when you reach larger numbers.
Here's how I would write it:
The initial list is (1 1)
At each step:
Compute the next fibonacci number
If this is greater than the limit, reverse the accumulator list and return it
Otherwise, cons it to the accumulator and recurse with the "new" last two fibonacci number.
In code:
(define (fib-list n)
(let loop ((f2 1) (f1 1) (fs '(1 1)))
(let ((next (+ f1 f2)))
(if (> next n)
(reverse fs)
(loop f1 next (cons next fs))))))
Here's another way you can do it using continuation-passing style. By adding a continuation parameter to our loop, we effectively create our own return mechanism. One unique property of this implementation is the output list is built in forward order and does not need to be reversed when n reaches zero.
(define (fib-list n)
(let loop ((n n) (a 0) (b 1) (return identity))
(if (zero? n)
(return empty)
(loop (sub1 n)
b
(+ a b)
(lambda (rest) (return (cons a rest)))))))
(fib-list 10)
;; '(0 1 1 2 3 5 8 13 21 34)
Reading your question a little closer, in fib-list(N) you need N to be the stopping condition for your loop, not the Nth term in the list. This is actually easier to implement as there's no need to count the number of terms generated.
(define (fib-list max)
(let loop ((a 0) (b 1) (return identity))
(if (> a max)
(return empty)
(loop b
(+ a b)
(lambda (rest) (return (cons a rest)))))))
(fib-list 55)
;; '(0 1 1 2 3 5 8 13 21 34 55)
(fib-list 1000)
;; '(0 1 1 2 3 5 8 13 21 34 55 89 144 233 377 610 987)
What's going wrong with the car function?
The car function takes the first element of a list, but if the list is empty it doesn't have a first element. The fs list starts out as empty. When you try to take the first element of an empty list you get this error message:
> (car (list))
mcar: contract violation
expected: mpair?
given: ()
If the list isn't empty, then it has a first element, and it's fine:
> (car (list 4 5 6))
4
Following what you meant in the comment
However, your comment "Check if n is in list" leads me to believe that (equal? n (car fs)) is not what you want anyway. The function for determining whether an element is in a list is called member.
#!r6rs
(import (rnrs base)
(rnrs lists))
> (if (member 4 (list 1 2 4 8))
"it's in the list"
"go fish")
"it's in the list"
> (if (member 5 (list 1 2 4 8))
"it's in the list"
"go fish")
"go fish"
So with that (equal? n (car fs)) test replaced with (member n fs), your code looks like:
; Create a list of the fibonacci sequence up to n.
(define (fib-list n)
; n = n, f2 = 1, f1 = 1, fs = a list.
(let loop ((n n) (f2 1) (f1 1) (fs (list)))
(cond
; If n = 0, return reversed list.
((zero? n) (reverse fs))
; Check if n is in list. If so, return list.
((member n fs) fs)
;Else, find the next fibonacci number and add it to the list.
(else (loop (- n 1) f1 (+ f2 f1) (cons f2 fs))))))
> (fib-list 55)
(10946 6765 4181 2584 1597 987 610 377 233 144 89 55 34 21 13 8 5 3 2 1 1)
This is not the answer you wanted though; you wanted (1 1 2 3 5 8 13 21 34 55).
Why is the list going past 55?
One of the problems is that the n is shadowed, in the same way that in this expression:
> (let ([n 5])
(let ([n 10])
n))
10
The n in the body refers to 10 instead of 5.
The result is going past 55 because inside the loop n is shadowed and has become a different number. I'm guessing in your comment about "check if n is in list", you meant "check if the original n is in list". To do that you have to rename one of the ns:
> (let ([orig-n 5])
(let ([n 10])
orig-n))
5
In the context of your code:
; Create a list of the fibonacci sequence up to n.
(define (fib-list orig-n)
; n = n, f2 = 1, f1 = 1, fs = a list.
(let loop ((n orig-n) (f2 1) (f1 1) (fs (list)))
(cond
; If n = 0, return reversed list.
((zero? n) (reverse fs))
; Check if orig-n is in list. If so, return list.
((member orig-n fs) fs)
;Else, find the next fibonacci number and add it to the list.
(else (loop (- n 1) f1 (+ f2 f1) (cons f2 fs))))))
> (fib-list 55)
(55 34 21 13 8 5 3 2 1 1)
Reversing
This is closer, but it's reversed. You have two base cases, the (zero? n) case and the (member orig-n fs) case. In one of those it's reversed and in one of them it's not. Changing them both to call reverse fixes it:
; Create a list of the fibonacci sequence up to n.
(define (fib-list orig-n)
; n = n, f2 = 1, f1 = 1, fs = a list.
(let loop ((n orig-n) (f2 1) (f1 1) (fs (list)))
(cond
; If n = 0, return reversed list.
((zero? n) (reverse fs))
; Check if orig-n is in list. If so, return reversed list.
((member orig-n fs) (reverse fs))
;Else, find the next fibonacci number and add it to the list.
(else (loop (- n 1) f1 (+ f2 f1) (cons f2 fs))))))
> (fib-list 55)
(1 1 2 3 5 8 13 21 34 55)
Small numbers
This is correct on large Fibonacci numbers like 55, but it still does something weird on small numbers:
> (fib-list 2)
(1 1)
> (fib-list 3)
(1 1 2)
If you only want it to stop when it gets to orig-n, then maybe the decreasing n argument is not needed, and is actually making it stop too early. Removing it (and removing the zero check for it) makes the member check the only stopping case.
This is dangerous, because it could go into an infinite loop if you give it a non-Fibonacci number as input. However, it fixes the small-number examples:
; Create a list of the fibonacci sequence up to n.
; The `orig-n` MUST be a fibonacci number to begin with,
; otherwise this loops forever.
(define (fib-list orig-n)
; f2 = 1, f1 = 1, fs = a list.
(let loop ((f2 1) (f1 1) (fs (list)))
(cond
; Check if orig-n is in list. If so, return reversed list.
((member orig-n fs) (reverse fs))
;Else, find the next fibonacci number and add it to the list.
(else (loop f1 (+ f2 f1) (cons f2 fs))))))
> (fib-list 55)
(1 1 2 3 5 8 13 21 34 55)
> (fib-list 2)
(1 1 2)
> (fib-list 3)
(1 1 2 3)
And finally, consider what happens vs. what should happen if you give it a number like 56.
> (fib-list 56)
;infinite loop
This is a design decision that you have not specified in your question (yet), but there are ways of solving it either way.
Update: orig-n or greater
I should have specified that I need to check if there is a number that is greater than OR equal to orig-n. Can I still use the member function to check for this or will I need to use something different?
You will have to use something different. Just above member in the documentation is the memp function (you could also use exists in this case). The mem is short for member, and the p is short for "predicate". It determines whether any member of the list matches a certain predicate.
> (if (memp positive? (list -4 -2 -3 5 -1))
"one of them is positive"
"go fish")
"one of them is positive"
> (if (memp positive? (list -4 -2 -3 -5 -1))
"one of them is positive"
"go fish")
"go fish"
> (define (five-or-greater? n)
(>= n 5))
> (if (memp five-or-greater? (list -4 -2 -3 6 -1))
"one of them is equal to 5 or greater"
"go fish")
"one of them is equal to 5 or greater"
> (if (memp five-or-greater? (list -4 -2 -3 4 -1))
"one of them is equal to 5 or greater"
"go fish")
"go fish"
To use it for "orig-n or greater", you would have to define a function like:
(define (orig-n-or-greater? n)
(>= n orig-n))
As a local function inside your main function, so that it can refer to orig-n. Then you can use it like (memp orig-n-or-greater? fs).
; Create a list of the fibonacci sequence up to n.
(define (fib-list orig-n)
(define (orig-n-or-greater? n)
(>= n orig-n))
; f2 = 1, f1 = 1, fs = a list.
(let loop ((f2 1) (f1 1) (fs (list)))
(cond
; Check if orig-n or greater is in list. If so, return reversed list.
((memp orig-n-or-greater? fs) (reverse fs))
;Else, find the next fibonacci number and add it to the list.
(else (loop f1 (+ f2 f1) (cons f2 fs))))))
> (fib-list 3)
(1 1 2 3)
> (fib-list 55)
(1 1 2 3 5 8 13 21 34 55)
> (fib-list 56)
(1 1 2 3 5 8 13 21 34 55 89)
I want to write a function in Racket which takes an amount of money and a list of specific bill-values, and then returns a list with the amount of bills used of every type to make the given amount in total. For example (calc 415 (list 100 10 5 2 1)) should return '(4 1 1 0 0).
I tried it this way but this doesn't work :/ I think I haven't fully understood what you can / can't do with set! in Racket, to be honest.
(define (calc n xs)
(cond ((null? xs) (list))
((not (pair? xs))
(define y n)
(begin (set! n (- n (* xs (floor (/ n xs)))))
(list (floor (/ y xs))) ))
(else (append (calc n (car xs))
(calc n (cdr xs))))))
Your procedure does too much and you use mutation which is uneccesary. If you split the problem up.
(define (calc-one-bill n bill)
...)
;; test
(calc-one-bill 450 100) ; ==> 4
(calc-one-bill 450 50) ; ==> 9
Then you can make:
(define (calc-new-n n bill amount)
...)
(calc-new-n 450 100 4) ; ==> 50
(calc-new-n 450 50 9) ; ==> 0
Then you can reduce your original implememntation like this:
(define (calc n bills)
(if (null? bills)
(if (zero? n)
'()
(error "The unit needs to be the last element in the bills list"))
(let* ((bill (car bills))
(amount (calc-one-bill n bill)))
(cons amount
(calc (calc-new-n n bill amount)
(cdr bills))))))
This will always choose the solution with fewest bills, just as your version seems to do. Both versions requires that the last element in the bill passed is the unit 1. For a more complex method, that works with (calc 406 (list 100 10 5 2)) and that potentially can find all combinations of solutions, see Will's answer.
This problem calls for some straightforward recursive non-deterministic programming.
We start with a given amount, and a given list of bill denominations, with unlimited amounts of each bill, apparently (otherwise, it'd be a different problem).
At each point in time, we can either use the biggest bill, or not.
If we use it, the total sum lessens by the bill's value.
If the total is 0, we've got our solution!
If the total is negative, it is invalid, so we should abandon this path.
The code here will follow another answer of mine, which finds out the total amount of solutions (which are more than one, for your example as well). We will just have to mind the solutions themselves as well, whereas the code mentioned above only counted them.
We can code this one as a recursive-backtracking procedure, calling a callback with each successfully found solution from inside the deepest level of recursion (tantamount to the most deeply nested loop in the nested loops structure created with recursion, which is the essence of recursive backtracking):
(define (change sum bills callback)
(let loop ([sum sum] [sol '()] [bills bills]) ; "sol" for "solution"
(cond
((zero? sum) (callback sol)) ; process a solution found
((< sum 0) #f)
((null? bills) #f)
(else
(apply
(lambda (b . bs) ; the "loop":
;; 1. ; either use the first
(loop (- sum b) (cons b sol) bills) ; denomination,
;; 2. ; or,
(loop sum sol bs)) ; after backtracking, don't!
bills)))))
It is to be called through e.g. one of
;; construct `the-callback` for `solve` and call
;; (solve ...params the-callback)
;; where `the-callback` is an exit continuation
(define (first-solution solve . params)
(call/cc (lambda (return)
(apply solve (append params ; use `return` as
(list return)))))) ; the callback
(define (n-solutions n solve . params) ; n assumed an integer
(let ([res '()]) ; n <= 0 gets ALL solutions
(call/cc (lambda (break)
(apply solve (append params
(list (lambda (sol)
(set! res (cons sol res))
(set! n (- n 1))
(cond ((zero? n) (break)))))))))
(reverse res)))
Testing,
> (first-solution change 406 (list 100 10 5 2))
'(2 2 2 100 100 100 100)
> (n-solutions 7 change 415 (list 100 10 5 2 1))
'((5 10 100 100 100 100)
(1 2 2 10 100 100 100 100)
(1 1 1 2 10 100 100 100 100)
(1 1 1 1 1 10 100 100 100 100)
(5 5 5 100 100 100 100)
(1 2 2 5 5 100 100 100 100)
(1 1 1 2 5 5 100 100 100 100))
Regarding how this code is structured, cf. How to generate all the permutations of elements in a list one at a time in Lisp? It creates nested loops with the solution being accessible in the innermost loop's body.
Regarding how to code up a non-deterministic algorithm (making all possible choices at once) in a proper functional way, see How to do a powerset in DrRacket? and How to find partitions of a list in Scheme.
I solved it this way now :)
(define (calc n xs)
(define (calcAssist n xs usedBills)
(cond ((null? xs) usedBills)
((pair? xs)
(calcAssist (- n (* (car xs) (floor (/ n (car xs)))))
(cdr xs)
(append usedBills
(list (floor (/ n (car xs)))))))
(else
(if ((= (- n (* xs (floor (/ n xs)))) 0))
(append usedBills (list (floor (/ n xs))))
(display "No solution")))))
(calcAssist n xs (list)))
Testing:
> (calc 415 (list 100 10 5 2 1))
'(4 1 1 0 0)
I think this is the first program I wrote when learning FORTRAN! Here is a version which makes no bones about using everything Racket has to offer (or, at least, everything I know about). As such it's probably a terrible homework solution, and it's certainly prettier than the FORTRAN I wrote in 1984.
Note that this version doesn't search, so it will get remainders even when it does not need to. It never gets a remainder if the lowest denomination is 1, of course.
(define/contract (denominations-of amount denominations)
;; split amount into units of denominations, returning the split
;; in descending order of denomination, and any remainder (if there is
;; no 1 denomination there will generally be a remainder).
(-> natural-number/c (listof (integer-in 1 #f))
(values (listof natural-number/c) natural-number/c))
(let handle-one-denomination ([current amount]
[remaining-denominations (sort denominations >)]
[so-far '()])
;; handle a single denomination: current is the balance,
;; remaining-denominations is the denominations left (descending order)
;; so-far is the list of amounts of each denomination we've accumulated
;; so far, which is in ascending order of denomination
(if (null? remaining-denominations)
;; we are done: return the reversed accumulator and anything left over
(values (reverse so-far) current)
(match-let ([(cons first-denomination rest-of-the-denominations)
remaining-denominations])
(if (> first-denomination current)
;; if the first denomination is more than the balance, just
;; accumulate a 0 for it and loop on the rest
(handle-one-denomination current rest-of-the-denominations
(cons 0 so-far))
;; otherwise work out how much of it we need and how much is left
(let-values ([(q r)
(quotient/remainder current first-denomination)])
;; and loop on the remainder accumulating the number of bills
;; we needed
(handle-one-denomination r rest-of-the-denominations
(cons q so-far))))))))
Why is it not possible to push directly on a list like '(1 2 3) or NIL?
Specifically:
Why is possible to do
> (let ((some-list nil))
(push 42 some-list))
(42)
but not to do something like
(push 42 nil)
or
(push 42 '(1 2 3))
What is the reasoning behind this implementation?
With macro push the second argument needs to be a place to be modified. Here are some examples:
Lets make two variables:
(defparameter *v* (list 2 4))
(defparameter *v-copy* *v*)
Then we push 0
(push 1 *v*) ; ==> (1 2 4)
*v-copy* ; ==> (2 4) (unaltered)
; the reason is that the variable is changed, not its value
(macroexpand '(push 1 v))
; ==> (setq v (cons 1 v))
push can use other things as second argument. Lets try a cons
(push 3 (cdr *v-copy*))
*v-copy* ; ==> (2 3 4)
; since the tail of *v* is the *v-copy* *v* is changed too
*v* ; ==> (1 2 3 4)
(macroexpand-1 '(push 2 (cdr *v-copy*)))
; ==> (rplacd v (cons 2 (cdr *v-copy*)))
If your examples were valid, what should it really have done? Lets do the nil first:
(macroexpand '(push 42 nil))
; ==> (setq nil (cons 42 nil))
This treats nil just as any other variable and if this worked nil would never be the empty list again. It would have been a list with one element, 42 and a different value than (). In Common Lisp nil is a constant and cannot be mutated. I've created a lisp once where nil was a variable like any other and a small typo redefined nil making the programs behave strange with no apparent reason.
Lets try your literal quoted list.
(macroexpand '(push 42 (quote (1 2 3))))
; ==> (let ((tmp (1 2 3)))
; (funcall #'(setf quote) (cons 42 'tmp) tmp))
It doesn't seem the push macro differentiates between special form quote and those types that has set their setf function. It won't work and it doesn't make sense. Anyway in the same manner as mutating the binding nil if this changed the literal data '(1 2 3) to '(43 1 2 3) would you then expect to get (43 1 2 3) every time you evaluated (1 2 3) from there on? I imagine that would be the only true effect of mutating a constant. If this was allowed you should be allowed to redefine 4 to be 5 so that evaluating 4 or (+ 2 2) shows the result 5.
I am new to LISP and I encounter this problem with the below code.
(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))))
It returns me an error *** - Program stack overflow. RESET. When I was googling around, I realise that this is the result of recursion. However I am not sure how should I optimise this code to resolve this issue. Any help is deeply appreciated.
Hi, above is the updated code. This is the test code.
(knights-tour-brute 5 5 1 1)
As I mentioned in the comments, the problem is lacking Tail Call Optimisation (TCO). You might be able to enable that with
(declaim (optimize (speed 3)))
But it depends on your implementation. I'm not sure about CLISP.
Edit: The other answers have more efficient ways for solving the problem, but it's still worth reading this answer for ways to write the original solution better
Anyway, I optimised the code a bit. You will still need to have TCO in order to run it. That's an inherent problem of using recursion like this. It should run well under SBCL at least. Just save it into a file, and do
(load (compile-file "file.lisp"))
It should run must faster than your original code, and do much less memory allocation. The relevant numbers for (time (knights-tour-brute 1 1 6 6)) with your code:
4,848,466,907 processor cycles
572,170,672 bytes consed
And my code:
1,155,406,109 processor cycles
17,137,776 bytes consed
For most part I left your code as is. The changes I made are mostly:
I actually declared the global variables and cleaned up some bits of the code.
In your version you build visited-list in order. That might seem intuitive when you don't understand how the singly linked lists in Lisp work, but it's very inefficient (those (reverse (cdr (reverse list))) were really eating performance). You should read some Lisp book regarding Lists. I keep it in reverse order, and then finally reverse it with nreverse at the end.
You used lists for the coordinates. I use a struct instead. Performance is very greatly increased.
I added type declarations for everything. It improves performance a little.
However, it is still the same brute force algorithm, so it will be very slow for larger boards. You should look into smarter algorithms for those.
(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)))
Edit: I improved correct-state so as to not look through the same list twice. Reduces consing significantly.
Edit2: I switched to using a struct for positions instead of using cons-cells. That improves performance dramatically.
It could probably be optimised more, but it should be sufficiently fast for boards up 6x6. If you need better performance, I think switching to a different algorithm would be more productive than trying to optimize a brute force solution. If someone does want to optimize this anyway, here are some results from profiling.
Results from sb-sprof show that majority of time is spent in checking equality. I don't think there's much to be done about that. visited also takes quite a bit of time. Maybe storing the visited positions in an array would speed it up, but I haven't tried it.
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 mode doesn't give much usefull information:
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 shows that generate does most of the consing, while visited takes most of the time (note that the seconds of course are way off due to the instumentation):
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
The list-based answer
from #jkiiski takes the same approach as OP and greatly optimizes
it. Here the goal is different: I try to use another
way to represent the problem (but still brute force) and we can see that with vectors and
matrices, we can solve harder problems better, faster and stronger1.
I also applied the same heuristics as in the other answer, which significantly reduces the effort required to find solutions.
Data-structures
(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))
Next, we define a class to hold instances of a Knight's Tour problem
as well as working data, namely height, width, a matrix representing
the board, containing either 0 (empty) or 1 (visited), as well as the
current tour, represented by a vector of size height x width with a
fill-pointer initialized to zero. The dimensions are not strictly necessary in this class since the internal board already stores them.
(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))))
By the way, we also specialize 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)))
Auxiliary functions
(declaim (inline visit unvisit))
Visiting a cell at position x and y means setting a one at the
appropriate location in the board and pushing current cell's
coordinate into the visited-cell vector. I store the row-major index
instead of a couple of coordinates because it allocates less memory (in fact the difference is not important).
(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))))
Unvisiting a cell means setting a zero in the board and decreasing the
fill-pointer of the sequence of 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)))))
Exhaustive search
The recursive visiting function is the following one. It first visits
current cell, recursively calls itself on each free valid neighbour
and finally unvisits itself before exiting. The function accepts a
callback function to be called whenever a solution is found (edit: I won't refactor, but I think the callback function should be stored in a slot of the knights-tour class).
(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))
Entry point
(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)))
Tests 1
The following test asks to find a solution for a 6x6 board:
(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
Comparatively, the version from the other versions runs as follows
(the origin point is the same, but we index cells differently):
(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
Tests 2
For larger boards, the difference is more visible. If we ask to find a solution for an 8x8 board, the above versions acts as follows on my machine:
> (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)>
The original list-based approach did not return and after ten minutes I killed
the worker thread.
Heuristics
There are still room for improvements (see actual research papers to have more information) and here I'll sort the neighbors like #jkiiski's updated version to see what happens. What follows is just a way to abstract iterating over neighbours, because we will use it more than once, and differently:
(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))))
We need a way to count the number of possible neighbors:
(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)
And here is the alternative search implementation:
(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))
The results are immediate when trying previous tests.
For example, with a 64x64 board:
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
Finding the 1728 solutions for a 5x5 board takes 42 seconds.
Here I keep the backtrack mechanism, and in order to see if we need it, I added a cerror expression in the search, so that we are notified as soon as the search tries another path. The following test triggers the error:
(time
(dotimes (x 8)
(dotimes (y 8)
(block nil
(knights-tour
x y
(lambda (k) (return))
8 8)))))
The values for x and y for which the error is reported are respectively 2 and 1.
1 For reference, see Daft Punk.
I decided to add this as another answer instead of doing such a major edit of my other answer.
It turns out there is a heuristic for solving the problem. You simply always move to the square with the least possible moves onward.
I switched to using sort of an ad hoc graph for representing the board. The squares contain edges to squares that a knight can travel to. This way the board can be built beforehand, and the actual search doesn't need to care about the details of where the knight can move (just follow the edges). There is no need to keep a separate list of the path taken, since the edges keep the necessary information to backtrack.
It's rather lengthy due to implementing the graph, but the relevant parts are find-tour and backtrack.
Using (knights-tour:knights-tour 0 0 8 8) will return a two-dimensional array of squares, which probably isn't very useful by itself. You should pass it through knights-tour:print-board or 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))
If it can't find a solution (for example (1, 0) on 5x5 board), knights-tour returns nil.
The squares are zero indexed.
(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)))