optimise knight-tour LISP - recursion

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)))

Related

Arrays vs. lists in Lisp: Why are lists so much faster in the code below?

I got an unexpected result while solving Problem 75 in Project Euler. My code does find the correct solution, but it behaves strangely.
My solution consists of traversing a Pythagorean tree (Barning's matrices) until the perimeter limit is reached, counting the numbers of times the perimeter assumed each value, and, lastly, counting the perimeter lengths that occurred only once. My admittedly untidy but functioning code is:
(defparameter *barning-matrixes*
'(#(1 -2 2) #(2 -1 2) #(2 -2 3)
#(1 2 2) #(2 1 2) #(2 2 3)
#(-1 2 2) #(-2 1 2) #(-2 2 3)))
(defparameter *lengths* (make-array 1500001 :initial-element 0))
(defun expand-node (n)
"Takes a primitive Pythagorean triple in a vector and traverses subsequent nodes in the the tree of primitives until perimeter > 1,500,000"
(let ((perimeter (reduce #'+ n)))
(unless (> perimeter 1500000)
(let ((next-nodes (mapcar #'(lambda (x)
(reduce #'+ (map 'vector #'* n x))) *barning-matrixes*)))
(loop for i from perimeter to 1500000 by perimeter
do (incf (aref *lengths* i)))
(expand-node (subseq next-nodes 0 3))
(expand-node (subseq next-nodes 3 6))
(expand-node (subseq next-nodes 6 9))))))
(expand-node #(3 4 5)) ; Takes too darn long :-(
(count 1 *lengths*)
I expected the tree expansion to run in a few milliseconds, but the expand-node function took 8.65 seconds--a lot more than expected--to traverse a not very large tree.
However, I was surprised when I tweaked the code to remove the vectors...
(defparameter *barning-matrixes*
'((1 -2 2) (2 -1 2) (2 -2 3)
(1 2 2) (2 1 2) (2 2 3)
(-1 2 2) (-2 1 2) (-2 2 3)))
(defparameter *lengths* (make-array 1500001 :initial-element 0))
(defun expand-node (n)
"Takes a primitive Pythagorean triple in a list and traverses subsequent nodes in the the tree of primitives until perimeter > 1,500,000"
(let ((perimeter (reduce #'+ n)))
(unless (> perimeter 1500000)
(let ((next-nodes (mapcar #'(lambda (x) (reduce #'+ (mapcar #'* n x))) *barning-matrixes*)))
(loop for i from perimeter to 1500000 by perimeter
do (incf (aref *lengths* i)))
(expand-node (subseq next-nodes 0 3))
(expand-node (subseq next-nodes 3 6))
(expand-node (subseq next-nodes 6 9))))))
(expand-node '(3 4 5)) ; Much faster, but why?!
(count 1 *lengths*)
...and the traversing went hugely faster, taking only 35 ms. I'm intrigued by this massive difference and am hoping someone out there can explain why it happened.
Thanks,
Paulo
PS: I'm using CCL for all this.
You didn't say which implementation you were using.
You would need to find out, where the time is spend.
But for me it looks like the implementation of MAP of a list and a vector of equal length to a new vector in your Common Lisp might be very inefficient.
Even when consing a new vector, which has some overhead, the implementation can be much faster.
Try to implement the vector operation as a LOOP and compare:
(loop with v = (make-array (length n))
for n1 across n
for x1 across x
for i from 0
do (setf (aref v i) (* n1 x1))
finally (return v))
This faster version conses too, but has replaced the list operations with vector operations:
(defparameter *barning-matrixes*
#(#(1 -2 2) #(2 -1 2) #(2 -2 3) #(1 2 2) #(2 1 2) #(2 2 3) #(-1 2 2) #(-2 1 2) #(-2 2 3)))
(defparameter *lengths* (make-array 1500001 :initial-element 0))
(defun expand-node (n)
"Takes a primitive Pythagorean triple in a vector and traverses subsequent nodes in the the tree of primitives until perimeter > 1,500,000"
(let ((perimeter (reduce #'+ n)))
(unless (> perimeter 1500000)
(let ((next-nodes
(loop with v = (make-array (length *barning-matrixes*))
for e across *barning-matrixes*
for i from 0
do (setf (aref v i)
(reduce #'+
(loop with v = (make-array (length n))
for n1 across n
for x1 across e
for i from 0
do (setf (aref v i) (* n1 x1))
finally (return v))))
finally (return v))))
(loop for i from perimeter to 1500000 by perimeter
do (incf (aref *lengths* i)))
(expand-node (subseq next-nodes 0 3))
(expand-node (subseq next-nodes 3 6))
(expand-node (subseq next-nodes 6 9))))))
(time (expand-node #(3 4 5)))
Let's look at your code:
(defun expand-node (n)
; here we don't know of which type N is. You call it from the toplevel
; with a vector, but recursive calls call it with a list
"Takes a primitive Pythagorean triple in a vector and traverses
subsequent nodes in the the tree of primitives until perimeter > 1,500,000"
(let ((perimeter (reduce #'+ n)))
(unless (> perimeter 1500000)
(let ((next-nodes (mapcar #'(lambda (x) ; this mapcar creates a list
(reduce #'+
(map 'vector
#'*
n ; <- list or vector
x))) ; <- vector
*barning-matrixes*)))
(loop for i from perimeter to 1500000 by perimeter
do (incf (aref *lengths* i)))
(expand-node (subseq next-nodes 0 3)) ; this subseq returns a list most of the times...
(expand-node (subseq next-nodes 3 6))
(expand-node (subseq next-nodes 6 9))))))
So you call MAP with a list and a vector most of the times.
What is the size of the result vector? MAP has to find out by traversing the list or by some other way. The result vector length is the shortest of the argument sequence lengths. Then it has to iterate over the list and the vector. If MAP now uses generic sequence operations, the element access into the list is always traversing the list. Obviously one can write an optimized version, which does all that faster, but a Common Lisp implementation might choose to provide only a generic implementation of MAP...
Welcome to the intricacies of Common Lisp optimization!
The first thing to note is about the different program optimization strategies performed by the different implementations: I tried your examples in SBCL, and both of them performed very efficiently with almost the same time, while in CCL the vector version was executed much much slower than the list version. I do not know which implementation you have tried, but you can try to use different implementations to see very different execution times.
From a few tests in CCL it seems to me that the main problem arises from this form:
(map 'vector #'* n x)
which is executed much much slowly than the corresponding list version:
(mapcar #'* n x)
Using time I have seen that the vector version conses a lot.
This first impression has been confirmed by simply changing map with map-into, using an auxiliary vector. Actually the following version is slightly faster in CCL than the list version:
(defun expand-node (n)
"Takes a primitive Pythagorean triple in a vector and traverses subsequent nodes in the the tree of primitives until perimeter > 1,500,000"
(let ((perimeter (reduce #'+ n))
(temp-vector (make-array 3 :initial-element 0)))
(unless (> perimeter 1500000)
(let ((next-nodes (mapcar #'(lambda (x)
(reduce #'+ (map-into temp-vector #'* n x))) *barning-matrixes*)))
(loop for i from perimeter to 1500000 by perimeter
do (incf (aref *lengths* i)))
(expand-node (subseq next-nodes 0 3))
(expand-node (subseq next-nodes 3 6))
(expand-node (subseq next-nodes 6 9))))))
Inspecting vector #(1 2 3) on SBCL gives:
Dimensions: (3)
Element type: T
Total size: 3
Adjustable: NIL
Fill pointer: NIL
Contents:
0: 1
1: 2
2: 3
You can see that there are a little more data to store than in a list, even though the exact internal representation of vectors varies among implementations. For small vectors that keep being copied like in your example, you are likely to end up allocating more memory than with lists, which is visible in the bytes consed lines below. Allocating memory contributes to the run time. In my tests, note that the difference in time is not as big as in your tests.
;; VECTORS
(time (expand-node #(3 4 5)))
;; Evaluation took:
;; 2.060 seconds of real time
;; 2.062500 seconds of total run time (1.765625 user, 0.296875 system)
;; [ Run times consist of 0.186 seconds GC time, and 1.877 seconds non-GC time. ]
;; 100.10% CPU
;; 4,903,137,055 processor cycles
;; 202,276,032 bytes consed
;; LISTS
(time (expand-node* '(3 4 5)))
;; Evaluation took:
;; 0.610 seconds of real time
;; 0.609375 seconds of total run time (0.609375 user, 0.000000 system)
;; [ Run times consist of 0.016 seconds GC time, and 0.594 seconds non-GC time. ]
;; 99.84% CPU
;; 1,432,603,387 processor cycles
;; 80,902,560 bytes consed
Everyone already answered while I was trying to optimize the code, so I'll just put this version here without bothering to explain too much. It should run pretty fast, at least on SBCL.
(declaim (optimize (speed 3) (safety 0) (debug 0)))
(declaim (type (simple-array (simple-array fixnum 1) 1) *barning-matrixes*))
(defparameter *barning-matrixes*
(map '(simple-array (simple-array fixnum 1) 1)
(lambda (list)
(make-array 3 :element-type 'fixnum
:initial-contents list))
'((1 -2 2) (2 -1 2) (2 -2 3)
(1 2 2) (2 1 2) (2 2 3)
(-1 2 2) (-2 1 2) (-2 2 3))))
(declaim (type (simple-array fixnum 1) *lengths*))
(defparameter *lengths* (make-array 1500001 :element-type 'fixnum
:initial-element 0))
(declaim (ftype (function ((simple-array fixnum 1))) expand-node))
(defun expand-node (n)
"Takes a primitive Pythagorean triple in a vector and traverses subsequent nodes in the the tree of primitives until perimeter > 1,500,000"
(loop with list-of-ns = (list n)
for n = (pop list-of-ns)
while n
do (let ((perimeter (let ((result 0))
(declare (type fixnum result))
(dotimes (i (length n) result)
(incf result (aref n i))))))
(declare (type fixnum perimeter))
(unless (> perimeter 1500000)
(let ((next-nodes
(let ((result (list)))
(dotimes (matrix 9 (nreverse result))
(let ((matrix (aref *barning-matrixes* matrix)))
(push (let ((result 0))
(declare (type fixnum result))
(dotimes (i 3 result)
(incf result
(the fixnum
(* (the fixnum (aref matrix i))
(the fixnum (aref n i)))))))
result))))))
(declare (type list next-nodes))
(loop for i from perimeter to 1500000 by perimeter
do (incf (aref *lengths* i)))
(dotimes (i 3)
(push (make-array 3 :element-type 'fixnum
:initial-contents (list (pop next-nodes)
(pop next-nodes)
(pop next-nodes)))
list-of-ns))))))
(values))
On my slow laptop,
CL-USER> (load (compile-file #P"e75.lisp"))
; ...compilation notes...
CL-USER> (time (expand-node (make-array 3 :element-type 'fixnum
:initial-contents '(3 4 5))))
Evaluation took:
0.274 seconds of real time
0.264000 seconds of total run time (0.264000 user, 0.000000 system)
96.35% CPU
382,768,596 processor cycles
35,413,600 bytes consed
; No values
CL-USER> (count 1 *lengths*)
161667 (18 bits, #x27783)
The original code ran at around ~1.8 seconds with vectors, and 0.8 seconds with lists.

How to recursively tile a defective chessboard in DrRacket

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!!

0/1 Knapsack in Scheme

Am in on the right track for programming the knapsack problem in scheme? My program doesn't have to account for objects "values" , only their weights. The goal is to take the best combination of items so that I have approximately half of the weight in my bag.
(define (split-equip wlst)
(define (sum lst)
(define (sum-h accum lst1)
(if (null? lst)
(/ accum (length lst))
(sum-h (+ (car lst1) accum) (cdr lst1))))
(sum-h 0 lst))
(define (split-equip-h)
(let ((target-w (/ (sum wlst) 2)))
I am tempted to write my program to output a list with all of the different combinations of weights possible and then traversing the list until I find the best set of weights, but not sure how to implement this.
Since this is already your second attempt at this (the first question was deleted), I'll show you a solution in Racket. You should read it like pseudo-code and translate it into the Scheme variant you have been taught.
Disclaimer: I suck at these kind of exercises. That should be another reason for you to understand and reformulate this. But the results of my code still seem correct.
Here's the code:
#lang racket
(define (knapsack lst)
(define half (/ (apply + lst) 2)) ; compute half of total
(printf "list : ~a\nhalf : ~a\n" lst half)
(define (combs lst1 (lst2 null)) ; compute all the combinations
(if (null? lst1)
(if (null? lst2)
null
(list (reverse lst2)))
(append
(combs (cdr lst1) lst2) ; case 1 -> we don't carry the iten
(combs (cdr lst1) (cons (car lst1) lst2))))) ; case 2 -> we do
(for/fold ((delta half) (res null)) ((c (in-list (combs lst)))) ; determine the best fit
(let* ((sm (apply + c)) (newdelta (abs (- half sm))))
(cond
((< newdelta delta) (values newdelta (list c)))
((= newdelta delta) (values delta (cons c res)))
(else (values delta res))))))
(time
(let-values (((delta res) (knapsack (cdr (range 0 24 3)))))
(printf "result: ~a\ndelta : ~a\n" res delta)))
and here's what it says:
list : (3 6 9 12 15 18 21)
half : 42
result: ((3 6 12 21) (3 6 15 18) (3 9 12 18) (3 18 21) (6 9 12 15) (6 15 21) (9 12 21) (9 15 18))
delta : 0
cpu time: 6 real time: 5 gc time: 0
Hope this helps. Don't hesitate to ask questions if there's something you don't get!

What is the easiest way to promise a Common Lisp compiler that the result of an arithmetic expression is a fixnum?

I wanted to tell sbcl that the following function will only be called with fixnum values for which the result fits in a fixnum:
(defun layer (x y z n)
(+ (* 2 (+ (* x y) (* y z) (* x z)))
(* 4 (+ x y z n -2) (1- n))))
My first attempt was to do
(defun layer (x y z n)
(declare (fixnum x y z n))
(the fixnum
(+ (* 2 (+ (* x y) (* y z) (* x z)))
(* 4 (+ x y z n -2) (1- n))))
But that return type declaration doesn't promise that all intermediate results will also be fixnums, as I found out by looking at the wonderfully useful compilation notes sbcl produced. So then I did this:
(defmacro fixnum+ (&rest args)
(reduce
(lambda (x y) `(the fixnum (+ ,x ,y)))
args))
(defmacro fixnum* (&rest args)
(reduce
(lambda (x y) `(the fixnum (* ,x ,y)))
args))
(defun layer (x y z n)
(declare (fixnum x y z n))
(fixnum+ (fixnum* 2 (fixnum+ (fixnum* x y) (fixnum* y z) (fixnum* x z)))
(fixnum* 4 (fixnum+ x y z n -2) (the fixnum (1- n)))))
And that worked just fine. My question is: is there an easier, more idiomatic way to do this?
For example, maybe I can redeclare the types of +, -, *, 1- to promise fixnum results? (I know that's a bad idea in general, but I might want to do it in certain programs.) CHICKEN scheme has (declare (fixnum-arithmetic)) that does what I want: it (unsafely) assumes that the results of all arithmetic operations on fixnums are fixnums.
You can declare types for functions using FTYPE.
Example:
(defun foo (a b)
(declare (ftype (function (&rest fixnum) fixnum) + * 1-)
(type fixnum a b)
(inline + * 1-)
(optimize (speed 3) (safety 0) (debug 0) (space 0)))
(+ a (* a (1- b))))
Does that make a difference?
In his book ANSI Common Lisp, Paul Graham shows the macro with-type, that wraps an expression and all its sub-expressions inthe forms, also ensuring that operators given more than two arguments are properly handled.
E.g. (with-type fixnum (+ 1 2 3)) will expand to the form
(the fixnum (+ (the fixnum (+ (the fixnum 1) (the fixnum 2)))
(the fixnum 3))
The code for the macro with helper functions is
(defmacro with-type (type expr)
`(the ,type ,(if (atom expr)
expr
(expand-call type (binarize expr)))))
(defun expand-call (type expr)
`(,(car expr) ,#(mapcar #'(lambda (a)
`(with-type ,type ,a))
(cdr expr))))
(defun binarize (expr)
(if (and (nthcdr 3 expr)
(member (car expr) '(+ - * /)))
(destructuring-bind (op a1 a2 . rest) expr
(binarize `(,op (,op ,a1 ,a2) ,#rest)))
expr))
A link to the code from the book in found at http://www.paulgraham.com/acl.html
A comment in the code states that "This code is copyright 1995 by Paul Graham, but anyone who wants
to use it is free to do so."
Try this:
(defun layer (x y z n)
(declare (optimize speed) (fixnum x y z n))
(logand most-positive-fixnum
(+ (* 2 (+ (* x y) (* y z) (* x z)))
(* 4 (+ x y z n -2) (1- n)))))
See SBCL User Manual, Sec 6.3 Modular arithmetic.
Edit:
As mentioned in the comments, SBCL-1.1.9 (or later) is required for this to work. Also, it's possible to shave another ~40% time off by inlining the subroutines:
;;; From: https://gist.github.com/oantolin/6073417
(declaim (optimize (speed 3) (safety 0)))
(defmacro with-type (type expr)
(if (atom expr)
expr
(let ((op (car expr)))
(reduce
(lambda (x y)
`(the ,type
(,op ,#(if x (list x) '())
(with-type ,type ,y))))
(cdr expr)
:initial-value nil))))
(defun layer (x y z n)
(declare (fixnum x y z n))
(with-type fixnum
(+ (* 2 (+ (* x y) (* y z) (* x z)))
(* 4 (+ x y z n -2) (1- n)))))
(defun cubes (n)
(declare (fixnum n))
(let ((count (make-array (+ n 1) :element-type 'fixnum)))
(loop for x of-type fixnum from 1 while (<= (layer x x x 1) n) do
(loop for y of-type fixnum from x while (<= (layer x y y 1) n) do
(loop for z of-type fixnum from y while (<= (layer x y z 1) n) do
(loop for k of-type fixnum from 1 while (<= (layer x y z k) n) do
(incf (elt count (layer x y z k)))))))
count))
(defun first-time (x)
(declare (fixnum x))
(loop for n of-type fixnum = 1000 then (* 2 n)
for k = (position x (cubes n))
until k
finally (return k)))
;;; With modarith and inlining
(defun first-time/inline (x)
(declare (fixnum x))
(labels
((layer (x y z n)
(logand #.(1- (ash 1 (integer-length most-positive-fixnum)))
(+ (* 2 (+ (* x y) (* y z) (* x z)))
(* 4 (+ x y z n -2) (1- n)))))
(cubes (n)
(let ((count (make-array (+ n 1) :element-type 'fixnum)))
(loop for x of-type fixnum from 1 while (<= (layer x x x 1) n) do
(loop for y of-type fixnum from x while (<= (layer x y y 1) n) do
(loop for z of-type fixnum from y while (<= (layer x y z 1) n) do
(loop for k of-type fixnum from 1 while (<= (layer x y z k) n)
do (incf (elt count (layer x y z k)))))))
count)))
(declare (inline layer cubes))
(loop for n of-type fixnum = 1000 then (* 2 n)
thereis (position x (cubes n)))))
#+(or)
(progn
(time (print (first-time 1000)))
(time (print (first-time/inline 1000))))
;; 18522
;; Evaluation took:
;; 0.448 seconds of real time
;; 0.448028 seconds of total run time (0.448028 user, 0.000000 system)
;; 100.00% CPU
;; 1,339,234,815 processor cycles
;; 401,840 bytes consed
;;
;;
;; 18522
;; Evaluation took:
;; 0.259 seconds of real time
;; 0.260016 seconds of total run time (0.260016 user, 0.000000 system)
;; 100.39% CPU
;; 776,585,475 processor cycles
;; 381,024 bytes consed
Declaring the layer function inline results in a much faster speed even when block compilation is on.
On my Apple Air M1 with layer inlined and block compilation on it runs in 0.06 second under the Arm64 version of SBCL 2.1.2.
CL-USER> (time (first-time 1000))
Evaluation took:
0.060 seconds of real time
0.060558 seconds of total run time (0.060121 user, 0.000437 system)
101.67% CPU
303,456 bytes consed
I've just remembered that declaring the count array in cube should help as well.
(declare (type (simple-array fixnum (*)) count))
Without inlining the layer function it is around 0.2 second.
CL-USER> (time (first-time 1000))
Evaluation took:
0.201 seconds of real time
0.201049 seconds of total run time (0.200497 user, 0.000552 system)
100.00% CPU
251,488 bytes consed
Or converting the layer function to a macro makes it even faster.
(defmacro layer (x y z n)
(declare (fixnum x y z n))
`(logand #.(1- (ash 1 (integer-length most-positive-fixnum)))
(+ (* 2 (+ (* ,x ,y) (* ,y ,z) (* ,x ,z)))
(* 4 (+ ,x ,y ,z ,n -2) (1- ,n)))))
CL-USER> (time (first-time 1000))
Evaluation took:
0.047 seconds of real time
0.047032 seconds of total run time (0.046854 user, 0.000178 system)
100.00% CPU
312,576 bytes consed
Benchmarked with trivial-benchmark on average it runs just bellow 0.04 second:
CL-USER> (benchmark:with-timing (100) (first-time 1000))
- SAMPLES TOTAL MINIMUM MAXIMUM MEDIAN AVERAGE DEVIATION
REAL-TIME 100 3.985173 0.039528 0.06012 0.039595 0.039852 0.002046
RUN-TIME 100 3.985848 0.039534 0.06014 0.039605 0.039858 0.002048
USER-RUN-TIME 100 3.975407 0.039466 0.059829 0.039519 0.039754 0.002026
SYSTEM-RUN-TIME 100 0.010469 0.00005 0.000305 0.000088 0.000105 0.00005
PAGE-FAULTS 100 0 0 0 0 0 0.0
GC-RUN-TIME 100 0 0 0 0 0 0.0
BYTES-CONSED 100 50200736 273056 504320 504320 502007.38 23010.477
EVAL-CALLS 100 0 0 0 0 0 0.0

translate list comprehension into Common Lisp loop

I have very recently started learning lisp. Like many others, I am trying my hand at Project Euler problems, however I am a bit stuck at Problem 14 : Longest Collatz Sequence.
This is what I have so far:
(defun collatz (x)
(if (evenp x)
(/ x 2)
(+ (* x 3) 1)))
(defun collatz-sequence (x)
(let ((count 1))
(loop
(setq x (collatz x))
(incf count)
(when (= x 1)
(return count)))))
(defun result ()
(loop for i from 1 to 1000000 maximize (collatz-sequence i)))
This will correctly print the longest sequence (525) but not the number producing the longest sequence.
What I want is
result = maximum [ (collatz-sequence n, n) | n <- [1..999999]]
translated into Common Lisp if possible.
With some help from macros and using iterate library, which allows you to extend its loop-like macro, you could do something like the below:
(defun collatz (x)
(if (evenp x) (floor x 2) (1+ (* x 3))))
(defun collatz-path (x)
(1+ (iter:iter (iter:counting (setq x (collatz x))) (iter:until (= x 1)))))
(defmacro maximizing-for (maximized-expression into (cause result))
(assert (eq 'into into) (into) "~S must be a symbol" into)
`(progn
(iter:with ,result = 0)
(iter:reducing ,maximized-expression by
(lambda (so-far candidate)
(if (> candidate so-far)
(progn (setf ,result i) candidate) so-far)) into ,cause)))
(defun euler-14 ()
(iter:iter
(iter:for i from 1000000 downto 1)
(maximizing-for (collatz-path i) into (path result))
(iter:finally (return (values result path)))))
(Presented without claim of generality. :))
The LOOP variant is not that pretty:
(defun collatz-sequence (x)
(1+ (loop for x1 = (collatz x) then (collatz x1)
count 1
until (= x1 1))))
(defun result ()
(loop with max-i = 0 and max-x = 0
for i from 1 to 1000000
for x = (collatz-sequence i)
when (> x max-x)
do (setf max-i i max-x x)
finally (return (values max-i max-x))))
A late answer but a 'pretty' one, albeit a losing one:
(defun collatz-sequence (x)
(labels ((collatz (x)
(if (evenp x)
(/ x 2)
(+ (* 3 x) 1))))
(recurse scan ((i x) (len 1) (peak 1) (seq '(1)))
(if (= i 1)
(values len peak (reverse seq))
(scan (collatz i) (+ len 1) (max i peak) (cons i seq))))))
(defun collatz-check (n)
(recurse look ((i 1) (li 1) (llen 1))
(if (> i n)
(values li llen)
(multiple-value-bind (len peak seq)
(collatz-sequence i)
(if (> len llen)
(look (+ i 1) i len)
(look (+ i 1) li llen))))))
(defmacro recurse (name args &rest body)
`(labels ((,name ,(mapcar #'car args) ,#body))
(,name ,#(mapcar #'cadr args))))

Resources