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)))
I want my function (named try) to make sure that:
cell is not in cells
the coordinates of cell are between 0 and maze-size 1
cell touches exactly one Cell in cells.
Definitions:
(define maze-size 15)
(define-struct Cell (x y))
(define (random-element a-list)
(list-ref a-list (random (length a-list))))
(define (random-adjacent cell)
(let ((neighbors (adjacents cell)))
(list-ref neighbors (random (length neighbors)))))
(define (count-in cell cells)
(cond
[(member? cell cells) 1]
[else 0]))
(define (touches cell cells)
(+
(count-in (make-Cell (Cell-x cell) (+ (Cell-y cell) 1)) cells)
(count-in (make-Cell (Cell-x cell) (+ (Cell-y cell) -1)) cells)
(count-in (make-Cell (+ (Cell-x cell) -1) (Cell-y cell)) cells)
(count-in (make-Cell (+ (Cell-x cell) 1) (Cell-y cell)) cells)))
Here is what I have:
(define (try cell cells)
(cond [(=? 1(touches cell cells)) (member? cell cells) (=? 1(cell-post))]
[(zero? (random (sqr maze-size))) cells]
[else (extend cells)]))
and yes I know the syntax is wrong in the first condition, my cond statements aren't strong.
What is the syntax needed in this case?
Keep in mind it should also work for this code:
(define (extend cells)
(try (random-adjacent cells) cells))
Not tested, but what you describe would be expressed as
(define (try cell cells)
(and (not (member? cell cells))
(<= 0 (Cell-x cell) maze-size)
(<= 0 (Cell-y cell) maze-size)
(= 1 (touches cell cells))))
I have a homework problem which is really messing with me right now, and I could use some help in how to implement it in DrRacket. I do not wish for code, just guidance, as I am very new to DrRacket.
The assignment is to implement this phrase:
"If n = 0, return the empty tiling (list of tile structs). Otherwise, place a tromino (L-shaped domino) in the center of the chessboard so that it covers the three quadrants of the chessboard that have no missing tile in them, and tile each of the quadrants."
as recursive code using the two .rkt files given. We are permitted to use any of the functions found within tromino.rkt.
We are also told that the following functions will be necessary to write our code, and so I have included a description of what each does:
(center-tile n row column)
This function produces a single tile structure that represents a properly oriented tromino placed at the center of a 2n × 2n chessboard when the chessboard has its missing tile in the specified row and column. Remember that rows and columns are numbered starting at zero. This function does quite a bit of work for you: It figures out which quadrant the missing cell is in, determines the proper orientation of the tromino to be placed at the center of the board so that that quadrant is not covered, and returns a tile structure that represents that tromino in the proper position on the board.
(missing-cell-within-quadrant n row column quadrant-row quadrant-column)
The 2n × 2n chessboard is divided into four quadrants that are indexed just as the rows and columns are. Specifically, the upper-left quadrant corresponds to
(quadrant-row, quadrant-column) set to (0, 0). The other quadrants are (0, 1) for upper right, (1, 0) for lower-left, and (1, 1) for lower-right. The function missing-cell-within-quadrant answers the following question:
What are the (row, column) coordinates within quadrant (quadrant-row, quadrant-column) of the missing or covered cell within that quadrant, after the tile produced by center-tile has been placed?
The answer is in the form of a list with two coordinates, expressed in the frame of reference of each quadrant. For instance if the missing cell in a 23 × 23 board is at row 2, column 5, then after placement of the center tile the four calls
(missing-cell-within-quadrant 3 2 5 0 0)
(missing-cell-within-quadrant 3 2 5 0 1)
(missing-cell-within-quadrant 3 2 5 1 0)
(missing-cell-within-quadrant 3 2 5 1 1)
return the following four lists, respectively:
'(3 3)
'(2 1)
'(0 3)
'(0 0)
(upgrade-tiling tiling m quadrant-row quadrant-column)
Given a tiling — that is, a list of tromino tiles — of one of the four 2m × 2m quadrants of a 2n × 2n chessboard, where m = n−1, this function transforms all the tiles in the tiling so that their coordinates refer to the full chessboard.
You are given a file, tromino.rkt, which is as follows
#lang racket
(require racket/draw)
(define thickness 6)
(define offset (floor (/ thickness 2)))
(define one 100)
(define two (* 2 one))
(define a 0)
(define b one)
(define c (- two thickness))
(define (mirror coordinates)
(map (lambda (z) (- one z thickness)) coordinates))
(define x-00 (list c c a a b b))
(define y-00 (list a c c b b a))
(define x-01 (mirror x-00))
(define y-01 y-00)
(define x-10 x-00)
(define y-10 (mirror y-00))
(define x-11 x-01)
(define y-11 y-10)
(define (make-tromino-path x y)
(let ((p (new dc-path%)))
(send p move-to (first x) (first y))
(send p line-to (second x) (second y))
(send p line-to (third x) (third y))
(send p line-to (fourth x) (fourth y))
(send p line-to (fifth x) (fifth y))
(send p line-to (sixth x) (sixth y))
(send p close)
p))
(define tromino-path-00 (make-tromino-path x-00 y-00))
(define tromino-path-01 (make-tromino-path x-01 y-01))
(define tromino-path-10 (make-tromino-path x-10 y-10))
(define tromino-path-11 (make-tromino-path x-11 y-11))
(define (tromino-path missing-row missing-column)
(cond ((and (= missing-row 0) (= missing-column 0)) tromino-path-00)
((and (= missing-row 0) (= missing-column 1)) tromino-path-01)
((and (= missing-row 1) (= missing-column 0)) tromino-path-10)
((and (= missing-row 1) (= missing-column 1)) tromino-path-11)
(else (error 'tromino-path "Called with arguments ~a, ~a (must each be either 0 or 1)"
missing-row missing-column))))
(define (draw-board n dc)
(cond ((= n 1)
(begin
(send dc set-smoothing 'unsmoothed)
(send dc set-pen "white" 0 'solid)
(send dc set-brush "white" 'solid)
(send dc draw-rectangle 0 0 two two)
(send dc set-pen "black" 0 'solid)
(send dc set-brush "black" 'solid)
(send dc draw-rectangle 0 0 one one)
(send dc draw-rectangle one one one one)))
(else
(begin
(draw-board (- n 1) dc)
(let ((side (* one (expt 2 (- n 1)))))
(send dc copy 0 0 side side side 0)
(send dc copy 0 0 (* 2 side) side 0 side))))))
(struct tile (row column missing-cell-row missing-cell-column))
(define (show-tile t)
(printf "(row ~a column ~a missing-cell-row ~a missing-cell-column ~a)\n"
(tile-row t) (tile-column t)
(tile-missing-cell-row t) (tile-missing-cell-column t)))
(define (quadrant n row column)
(let ((half (lambda (n coordinate)
(cond ((bitwise-bit-set? coordinate (- n 1)) 1)
(else 0)))))
(list (half n row) (half n column))))
(define (center-tile n row column)
(let ((q (quadrant n row column))
(base (- (expt 2 (- n 1)) 1)))
(tile (+ base (first q)) (+ base (second q)) (first q) (second q))))
(define (missing-cell-within-quadrant n row column quadrant-row quadrant-column)
(let ((q (quadrant n row column))
(base (- (expt 2 (- n 1)) 1))
(sub-coordinate (lambda (coord quad)
(cond ((= quad 1) (- coord (expt 2 (- n 1))))
(else coord)))))
(cond ((and (= (first q) quadrant-row) (= (second q) quadrant-column))
(list (sub-coordinate row (first q))
(sub-coordinate column (second q))))
(else (list (cond ((= 0 quadrant-row) base)
(else 0))
(cond ((= 0 quadrant-column) base)
(else 0)))))))
(define (upgrade-tiling tiling m quadrant-row quadrant-column)
(let* ((shift (expt 2 m))
(row-shift (* quadrant-row shift))
(column-shift (* quadrant-column shift)))
(map (lambda (t)
(tile (+ (tile-row t) row-shift)
(+ (tile-column t) column-shift)
(tile-missing-cell-row t)
(tile-missing-cell-column t)))
tiling)))
(define (make-tiling-png n tiles basename)
(cond ((or (<= n 0) (empty? tiles))
(printf "Warning: make-tiling-png called with n too small or an empty tiling. No picture produced\n"))
(else
(begin
(define side (* (expt 2 n) one))
(define bmap (make-bitmap side side))
(define dc (new bitmap-dc% (bitmap bmap)))
(draw-board n dc)
(send dc set-pen "black" 1 'solid)
(send dc set-brush "white" 'transparent)
(send dc draw-rectangle 0 0 side side)
(send dc set-pen (new pen% (color "red") (width thickness)
(style 'solid) (cap 'projecting) (join 'miter)))
(send dc set-brush "gray" 'solid)
(send dc set-smoothing 'unsmoothed)
(map (lambda (t) (send dc draw-path (tromino-path (tile-missing-cell-row t)
(tile-missing-cell-column t))
(+ offset (* one (tile-column t)))
(+ offset (* one (tile-row t)))))
tiles)
(send bmap save-file (string-append basename ".png") 'png)))))
(provide tile
tile-row
tile-column
tile-missing-cell-row
tile-missing-cell-column
show-tile
quadrant
center-tile
missing-cell-within-quadrant
upgrade-tiling
make-tiling-png)
You are also given a file, template.rkt, which is as follows:
#lang racket
(require "./tromino.rkt")
(define test-tiling (list (tile 2 5 0 1)))
(make-tiling-png 3 test-tiling "test-tiling")
**; Your code replaces the null in the following definition**
(define (tile-board n row column)
null)
(define (make-and-show-tiling n row column)
(make-tiling-png n
(tile-board n row column)
(format "tiling-~a-~a-~a" n row column)))
; Initially, these calls will produce no picture
; because tile-board returns an empty tiling
(make-and-show-tiling 1 1 1)
(make-and-show-tiling 2 0 0)
(make-and-show-tiling 3 5 2)
(make-and-show-tiling 3 6 2)
(make-and-show-tiling 4 5 10)
(make-and-show-tiling 5 24 21)
I have a very good idea of the concept behind how this works, whereby you split the 2n × 2n chessboard into 4 separate quadrants, and then place a tromino at the center of the chessboard such that every quadrant now has either one missing cell or one cell that is covered by part of the tromino. Then, call the recursive function to tile each quadrant. The end goal is to have the code run such that each call of (make-and-show-tiling) function at the end of my template.rkt file will produce a picture of the chessboard produced.
I think I am just getting super confused because I have only learnt Java and Python before this, and the format/syntax of DrRacket is so far removed from those languages. I am completely stuck so any help other than actually writing the code for me would be incredibly welcome and gratefully accepted.
Thank you in advance!!
I'm getting crazy with a small problem here,
I keep getting an error and I cant seem to figure out why,
the code is supposed to change the range of a list,
so if we give it a list with values (1 2 3 4) and we want to change the range in 11 to fourteen the result would be (11 12 13 14)
the problem is that the last function called scale-list will give back an error saying:
Debugger entered--Lisp error: (wrong-type-argument number-or-marker-p nil)
anybody has a clue why?
I use aquamacs as an editor
thanks in advance
;;finds minimum in a list
(defun minimum (list)
(car (sort list #'<)))
;;finds maximum in a list
(defun maximum (list)
(car (sort list #'>)))
;;calculates the range of a list
(defun range (list)
(- (maximum list) (minimum list)))
;;scales one value to another range
(defun scale-value (list low high n)
(+ (/ (* (- (nth (- n 1) list)
(minimum list))
(- high low))
(range list))
low))
;;is supposed to scale the whole list to another range
(defun scale-list (list low high n)
(unless (= n 0)
(cons (scale-value list low high n)
(scale-list list low high (- n 1)))))
(scale-list '(1 2 3 4) 21 24 4)
The definitions of maximum and minimum need to be improved. SORT is destructive. It is also wrong to call SORT with a literal constant like '(1 2 3 4) - again, SORT is destructive.
Better definitions:
(defun minimum (list)
(reduce #'min list))
(defun maximum (list)
(reduce #'max list))
A more efficient definition of range:
(defun range (list)
(loop for e in list
maximize e into max
minimize e into min
finally (return (- max min))))
SCALE-LIST and SCALE-VALUE are also not Lisp-like.
If you call NTH like this in a recursive function then something is wrong. You should recurse over the list, not the index. SCALE-VALUE calls RANGE and MINIMUM for each call. Why?
Check this variant:
;;scales one value to another range
(defun scale-value (item low high min range)
(+ (/ (* (- item min)
(- high low))
range)
low))
;;is supposed to scale the whole list to another range
(defun scale-list (list low high)
(let ((min (minimum list))
(range (range list)))
(labels ((scale-list-aux (list)
(when list
(cons (scale-value (first list) low high min range)
(scale-list-aux (rest list))))))
(scale-list-aux list))))
(scale-list '(1 2 3 4) 21 24)
What can you improve more? For example I would get rid of the recursion and replace it with MAPCAR.
I re post the code because something went wrong...
;;finds minimum in a list
(defun minimum(list)
(car (sort list #'<)))
;;finds maximum in a list
(defun maximum(list)
(car (sort list #'>)))
;;calculates the range of a list
(defun range(list)
(- (maximum list) (minimum list)))
;;scales one value to another range
(defun scale-value(list low high n)
(+ (/ (* (- (nth (- n 1) list) (minimum list)) (- high low)) (range list)) low))
;;is supposed to scale the whole list to another range
(defun scale-list(list low high n)
(unless (= n 0)
(cons (scale-value list low high n) (scale-list list low high (- n 1)))))
(scale-list '(1 2 3 4) 21 24 4)
Your actual stack trace is something like:
-(nil 0.1)
(* (- (nth ... list) (minimum list)) (- high low))
(/ (* (- ... ...) (- high low)) (range list))
(+ (/ (* ... ...) (range list)) low)
scale-value((0.1) 20 30 3)
I guess you determine a wrong nth element and this returns nil, which messes up the subtraction.