Why does SBCL (or Common lisp in general?) dislike my loop? - common-lisp

Recursive find-dir-upwards works as expected, but find-dir-upwards-loop refuses to compile, complaining about type mismatch (even with added type annotations) under SBCL (Win64, Portacle 1.4, SBCL 2.0.0).
What did I do wrong ?
(defun find-dir-upwards-loop (dir marker-file)
(loop for prev = nil then curr
for curr = dir then (uiop:pathname-parent-directory-pathname curr)
until (equal curr prev)
with f = (merge-pathnames marker-file curr)
when (uiop:file-exists-p f) return curr))
(defun find-dir-upwards (dir marker-file)
(let ((f (merge-pathnames marker-file dir)))
(if (uiop:file-exists-p f)
dir
(let ((parent (uiop:pathname-parent-directory-pathname dir)))
(unless (equal dir parent)
(find-dir-upwards parent marker-file))))))

The WITH after FOR part of the answer:
(loop for x = 0 then (+ x 1)
with y = (+ x 1)
when (> x 10) return (list x y))
This is a sequence of events:
the X variable will be established
the Y variable will be established and initialized to (+ x 1)
the X variable will be set to 0
...
As you can see, in operation 1) X will be a variable, but it won't be initialized to 0. This would happen in operation 3). Thus in operation 2) X will not have been initialized to 0 -> its value might be NIL. Adding 1 to NIL is an error.

You can't (portably) put a with after an until. Look at the grammar in the Hyperspec:
loop [name-clause] {variable-clause}* {main-clause}* => result*
With is a variable-clause, but until is a termination-test, which is a main-clause. All main-clauses must come after all variable-clauses.

Simplified code
After some while thinking, I realized you can simplify your original function to:
(defun find-dir-upwards (dir marker-file)
(let ((parent (uiop:pathname-parent-directory-pathname dir)))
(unless (equal dir parent)
(if (probe-file (merge-pathnames marker-file dir))
dir
(find-dir-upwards parent marker-file)))))
And its correspoding loop function is:
(defun find-dir-upwards (dir marker-file)
(loop for parent = (uiop:pathname-parent-directory-pathname dir)
unless (equal dir parent)
do (if (probe-file (merge-pathnames marker-file dir))
(return dir)
(setf dir parent))))
As #Rezo pointed out in this post, probe-file is portable between different Common Lisp implementations, while uiop:file-exists-p is not.
Original answer
I would define the loop differently.
Use the (let ((dir dir)) (loop ... (setf dir (<some updater function>)))) idiom to have some reference variable(s) which are updated every run through the loop - until the condition is met.
(defun find-dir-upwards (dir marker-file)
(let ((f (merge-pathnames marker-file dir))
(dir dir))
(loop for parent = (uiop:pathname-parent-directory-pathname dir)
unless (equal dir parent)
do (if (uiop:file-exists-p f) ;; if marker-file in dir
(return dir) ;; then arrived at destination
(progn
(setf dir parent) ;; otherwise climb up one dir-level
(setf f (merge-pathnames marker-file dir)))))))
Which is then further dissectable to:
(defun marker-file-in-dir-p (dir marker-file)
(uiop:file-exists-p (merge-pathnames marker-file dir)))
(defun find-dir-upwards (dir marker-file)
(let ((dir dir))
(loop for parent = (uiop:pathname-parent-directory-pathname dir) ;; parent from dir
unless (equal dir parent)
do (if (marker-file-in-dir-p dir marker-file)
(return dir)
(setf dir parent)))))

Something about combining the step form of 'FOR' and a 'WITH' creates this problem. IT seems like it tried to initialize the 'with' before the 'for' creates x, but, not always. I haven't solved it, but I have had this issue before. For example:
(loop for x = 0 then (+ x 1)
with y = (+ x 1)
when (> x 10) return (list x y))
Yields:
Value of X in (+ X 1) is NIL, not a NUMBER.
[Condition of type SIMPLE-TYPE-ERROR]
Restarts:
0: [RETRY] Retry SLIME REPL evaluation request.
1: [*ABORT] Return to SLIME's top level.
2: [ABORT] abort thread (#<THREAD "new-repl-thread" RUNNING {10044CC083}>)
Backtrace:
0: (SB-C::%COMPILE-TIME-TYPE-ERROR (NIL) NUMBER #<unused argument> (X) "(+ X 1)" NIL)
1: ((LAMBDA ()))
2: (SB-INT:SIMPLE-EVAL-IN-LEXENV (LOOP FOR X = 0 THEN ...) #<NULL-LEXENV>)
3: (EVAL (LOOP FOR X = 0 THEN ...))
--more--
But removing either the step form, or the with, seems to work fine:
CL-USER> (loop for x from 0 to 10
with y = (+ x 1)
collect (list x y))
((0 1) (1 1) (2 1) (3 1) (4 1) (5 1) (6 1) (7 1) (8 1) (9 1) (10 1))
CL-USER> (loop for x = 0 then (+ x 1)
when (> x 10) return x)
11

Related

CLISP dfs gets program stack overflow

I'm new to Lisp and I'm trying to solve an 8-puzzle using simple dfs (depth-first search).
But I am getting a program stack overflow.
My code:
(setq used (list))
(defun is_used (state lst)
(cond
((null lst) nil)
((equalp (car lst) state) t)
(t (is_used state (cdr lst)))))
(defun move (lst direction)
(let* ( (zero (find_zero lst))
(row (floor zero 3))
(col (mod zero 3))
(res (copy-list lst)))
(cond
((eq direction 'L)
(if (> col 0)
(rotatef (elt res zero) (elt res (- zero 1)))))
((eq direction 'R)
(if (< col 2)
(rotatef (elt res zero) (elt res (+ zero 1)))))
((eq direction 'U)
(if (> row 0)
(rotatef (elt res zero) (elt res (- zero 3)))))
((eq direction 'D)
(if (< row 2)
(rotatef (elt res zero) (elt res (+ zero 3))))))
(if (equalp res lst)
(return-from move nil))
(return-from move res))
nil)
(defun dfs (cur d prev)
; (write (length used))
; (terpri)
(push cur used)
(let* ((ways '(L R U D)))
(loop for dir in ways
do (if (move cur dir)
(if (not (is_used (move cur dir) used))
(dfs (move cur dir) (+ d 1) cur))))))
state here is a list of 9 atoms.
With uncommented (write (length used)) it prints 723 - number of items in used before the stack overflow occurs.
Now, before solving 8-puzzle, I just want to iterate over all possible states (there are exactly 9! / 2 = 181440 possible states). Sure, it may take some time, but how can I avoid the stack overflow here?
This is a typical problem explained in some AI programming books. If you need to search a large / unbounded amount of states, you should not use recursion. Recursion in CL is limited by the stack depth. Some implementations can optimize tail recursion - but then you need architecture your code, so that it is tail recursive.
Typically a data structure for that will be called an agenda. It keeps the states still to explore. If you look at a state, you push all states to explore from there onto the agenda. Make sure the agenda is in some way sorted (this might determine if it is depths or breadths first). Then take the next state from the agenda and examine it. If the goal is reached, then you are done. If the agenda is empty before the goal is found, then there is no solution. Otherwise loop...
Your code, simplified, is
(setq *used* (list))
(defun move (position direction)
(let* ( (zero (position 0 position))
(row (floor zero 3))
(col (mod zero 3))
(command (find direction `((L ,(> col 0) ,(- zero 1))
(R ,(< col 2) ,(+ zero 1))
(U ,(> row 0) ,(- zero 3))
(D ,(< row 2) ,(+ zero 3)))
:key #'car)))
(if (cadr command)
(let ((res (copy-list position)))
(rotatef (elt res zero) (elt res (caddr command)))
res))))
(defun dfs-rec (cur_pos depth prev_pos)
(write (length *used*)) (write '_) (write depth) (write '--)
; (terpri)
(push cur_pos *used*)
(let* ((dirs '(L R U D)))
(loop for dir in dirs
do (let ((new_pos (move cur_pos dir)))
(if (and new_pos
(not (member new_pos *used* :test #'equalp)))
(dfs-rec new_pos (+ depth 1) cur_pos))))))
(print (dfs-rec '(0 1 2 3 4 5 6 7 8) 0 '()))
Instead of processing the four moves one by one while relying on recursion to keep track of what-to-do-next on each level, just push all the resulting positions at once to a to-do list, then pop and continue with the top one; repeating while the to-do list is not empty (i.e. there is something to do, literally):
(defun new-positions (position)
(let* ( (zero (position 0 position))
(row (floor zero 3))
(col (mod zero 3)) )
(mapcan
#'(lambda (command)
(if (cadr command)
(let ((res (copy-list position)))
(rotatef (elt res zero) (elt res (caddr command)))
(list res))))
`((L ,(> col 0) ,(- zero 1))
(R ,(< col 2) ,(+ zero 1))
(U ,(> row 0) ,(- zero 3))
(D ,(< row 2) ,(+ zero 3))) )))
; non-recursive dfs function skeleton
(defun dfs (start-pos &aux to-do curr new)
(setf to-do (list start-pos))
(loop while to-do
do (progn (setf curr (pop to-do))
(setf new (new-positions curr))
(setf to-do (nconc new to-do)))))
This way there's no more info to keep track of, with recursion -- it's all in the to-do list.
This means the generated positions will be processed in the LIFO order, i.e. the to-do list will be used as a stack, achieving the depth-first search strategy.
If you'd instead append all the new positions on each step at the end of the to-do list, it'd mean it being used as a queue, in a FIFO order, achieving the breadth-first search.

Recursive lisp-function to solve N-Queen

UPDATED: The code should compile now without errors or warnings. Sorry about the previous one. The problem I have now is that when a run (or with any other integer)
(NxNqueen-solver 10)
The function getqueencol will return nil because there are no queens on the board in the first place, hence there will be a (= number nil) in the queen-can-be-placed-here because tcol will be nil. I think this will happen everytime there is no queen in the row passed as argument to the queen-can-be-placed-here function.
Please share some advice on how to fix this problem. Thank you in advance.
Here is the code
(defvar *board* (make-array '(10 10) :initial-element nil))
(defun getqueencol (row n)
"Traverses through the columns of a certain row
and returns the column index of the queen."
(loop for i below n
do (if (aref *board* row i)
(return-from getqueencol i))))
(defun print-board (n)
"Prints out the solution, e.g. (1 4 2 5 3),
where 1 denotes that there is a queen at the first
column of the first row, and so on."
(let ((solutionlist (make-list n)))
(loop for row below n
do (loop for col below n
do (when (aref *board* row col)
(setf (nth row solutionlist) col))))
(print solutionlist)))
(defun queen-can-be-placed-here (row col n)
"Returns t if (row,col) is a possible place to put queen, otherwise nil."
(loop for i below n
do (let ((tcol (getqueencol i n)))
(if (or (= col tcol) (= (abs (- row i)) (abs (- col tcol))))
(return-from queen-can-be-placed-here nil)))))
(defun backtracking (row n)
"Solves the NxN-queen problem with backtracking"
(if (< row n)
(loop for i below n
do (when (queen-can-be-placed-here row i n)
(setf (aref *board* row i) 't)
(return-from backtracking (backtracking (+ row 1) n))
(setf (aref *board* row i) 'nil))
(print-board n))))
(defun NxNqueen-solver (k)
"Main program for the function call to the recursive solving of the problem"
(setf *board* (make-array '(k k) :initial-element nil))
(backtracking 0 k))
You say that you compiled your code. That can't be the case, since then you would have see the compiler complaining about errors. You want to make sure that you really compile the code and correct the code, such that it compiles without errors and warnings.
You might want to get rid of the errors/problems in the code (see Renzo's comment) and then look at the algorithmic problem. I makes very little sense to look into an algorithmic problem, when the code contains errors.
SETQ does not introduce a variable, the variable has to be defined somewhere
DEFVAR makes no sense inside a function.
Something like (let (x (sin a)) ...) definitely looks wrong. The syntax of LET requires a pair of parentheses around the bindings list.
RETURN-FROM takes as first argument the name of an existing block to return from. The optional second argument is a return value. Get the syntax right and return from the correct block.
in a call to MAKE-ARRAY specify the default value: (make-array ... :initial-element nil), otherwise it's not clear what it is.
The variable *board* is undefined
Style
in LOOP: for i to (1- n) is simpler for i below n
you don't need to quote NIL and T.
(if (eq foo t) ...) might be simpler written as (if foo ...). Especially if the value of foo is either NIL or T.
(if foo (progn ...)) is simply (when foo ...)
I'm not sure what you are doing to claim that your code compiles. It does not compile.
Every function has compiler warnings. You should check the compiler warnings and fix the problems.
(defun getqueencol (row)
"Traverses through the columns of a certain row
and returns the column index of the queen."
(loop for i below n
do (if (aref board row i)
(return-from getqueencol i))))
The compiler complains:
;;;*** Warning in GETQUEENCOL: N assumed special
;;;*** Warning in GETQUEENCOL: BOARD assumed special
Where is n defined? Where is board coming from?
(defun print-board (board)
"Prints out the solution, e.g. (1 4 2 5 3),
where 1 denotes that there is a queen at the first
column of the first row, and so on."
(let (solutionlist)
(setq solutionlist (make-list n)))
(loop for row below n
do (loop for col below n
do (when (aref board row col)
(setf (nth row solutionlist) col))))
(print solutionlist))
The LET makes no sense. (let (foo) (setq foo bar) ...) is (let ((foo bar)) ...).
Why is solutionlist not defined? Look at the LET... it does not make sense.
Where is n coming from?
(defun queen-can-be-placed-here (row col)
"Returns t if (row,col) is a possible place to put queen, otherwise nil."
(loop for i below n
do (let (tcol)
(setq tcol (getqueencol i)))
(if (or (= col tcol) (= (abs (- row i)) (abs (- col tcol))))
(return-from queen-can-be-placed-here nil))))
where is n coming from? The LET makes no sense.
(defun backtracking (row)
"Solves the NxN-queen problem with backtracking"
(if (< row n)
(loop for i below n
do (when (queen-can-be-placed-here row i)
(setf (aref board row i) 't)
(return-from backtracking (backtracking (+ row 1)))
(setf (aref board row i) 'nil))
(print-board board))))
Where is n coming from? Where is board defined?
(defun NxNqueen-solver (k)
"Main program for the function call to the recursive solving of the problem"
(let (n board)
(setq n k)
(setq board (make-array '(k k) :initial-element nil)))
(backtracking 0))
Why use setq when you have a let? The local variables n and board are unused.
MAKE-ARRAY expects a list of numbers, not a list of symbols.
I propose you use a basic Lisp introduction (Common Lisp: A Gentle Introduction to Symbolic Computation - free download) and a Lisp reference (CL Hyperspec).

Counter variable in LISP

Define the function 'occ' that takes a list L and a symbol A and counts the occurance of symbol A in L.
Example:
(occ '(((s) o ) d) 'f) --> 0
What i have gotten so far:
(defun occ(list a)
(setq counter 0)
;Checks if the given list is has an nested list
(if (consp list)
; Breaking the list down atom by atom and recursing
(or (occ a (car list))
(occ a (cdr list)))
; checks if symbols are the same
(if(eq a list)
(setq counter(1+ counter)))))
However My output keep saying Nil instead of displaying the counter value.
I cannot use any higher-functions of LISP.
First of all, don't use setq for variable initialization inside yout function, use let. Second, let's look why you doing it wrong, your code:
(defun occ(list a)
(setq counter 0) ;; You always setting counter to 0 on new
;; level of recursion
(if (consp list)
(or (occ a (car list)) ;; You reversed arguments order?
(occ a (cdr list))) ;; according to your definition it must be
;; (occ (car list) a)
(if(eq a list)
(setq counter(1+ counter)))))
Anyway, you don't need any counter variables to do what you want.
Right function may look like this (i changed arguments order becaus it looks better for me to find SYMBOL in LIST):
(defun occ (sym nested-list)
(cond
((consp nested-list)
(+ (occ sym (car nested-list)) (occ sym (cdr nested-list))))
((eq sym nested-list) 1)
(t 0)))
CL-USER> (occ 'x '(((s) o ((f ()) f)) d))
0
CL-USER> (occ 'f '(((s) o ((f (x (((f))))) f)) d f))
4
If you feed your definition to SBCL:
; in: DEFUN OCC
; (SETQ COUNTER 0)
;
; caught WARNING:
; undefined variable: COUNTER
;
; compilation unit finished
; Undefined variable:
; COUNTER
; caught 1 WARNING condition
So you are modifying a global undefined variable counter. When do the function return? Well, or will return the very first non nil return from recursion with car or cdr. What returns values? Well when it's not a cons it will evaluate to the intermediate value of a incf of counter when the symbol matches or nil when it doesn't.
Try doing it like this:
(defun occ (list a &optional (counter 0))
(cond ((equal list a) (1+ counter))
((atom list) counter)
(t (occ (cdr list)
a
(occ (car list)
a
counter)))))
counter is an optional accumulator that you use to hold the values. Since it's passed it isn't shared between the recursive calls but replaced with the updated value at each call making it functional and easy to follow. When you need to search both car and cdr you recurse car with the counter of this stage and the returning value will be used as the counter in the cdr. For lists of atom this will be tail recursive if the implementation supports it. This supports finding symbols as tails of lists. eg. (occ '((x . x) . x) 'x) ; ==> 3 If you are sure you have no dotted list (every list is nil terminated) you can use the loop macro:
(defun occ (list a)
(loop :for e :in list
:counting (equal e a) :into count
:if (consp e)
:summing (occ e a) :into sum
:finally (return (+ count sum))))
;; tests
(occ '(x (x x (x (x ) x)) y z) 'y) ; ==> 1
(occ '(x (x x (x (x ) x)) y z) 'x) ; ==> 6
(occ '((x . x) . x) 'x) ; ERROR like "A proper list must not end with X".

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

Dolist evaluation error

I'm a CommonLisp noob with a question. I have these two functions below.
A helper function:
(defun make-rests (positions rhythm)
"now make those positions negative numbers for rests"
(let ((resultant-rhythm rhythm))
(dolist (i positions resultant-rhythm)
(setf (nth i resultant-rhythm) (* (nth i resultant-rhythm) -1)))))
And a main function:
(defun test-return-rhythms (rhythms)
(let ((positions '((0 1) (0)))
(result nil))
(dolist (x positions (reverse result))
(push (make-rests x rhythms) result))))
When I run (test-return-rhythms '(1/4 1/8)), it evaluates to: ((1/4 -1/8) (1/4 -1/8))
However, I expected: (test-return-rhythms '(1/4 1/8)) to evaluate to: ((-1/4 -1/8) (-1/4 1/8)).
What am I doing wrong?
Your implementation of make-rests is destructive.
CL-USER> (defparameter *rhythm* '(1/4 1/4 1/4 1/4))
*RHYTHM*
CL-USER> (make-rests '(0 2) *rhythm*)
(-1/4 1/4 -1/4 1/4)
CL-USER> *rhythm*
(-1/4 1/4 -1/4 1/4)
So, if you run your test, the second iteration will see (-1/4 -1/8), and (make-rests '(0) '(-1/4 -1/8)) returns (1/4 -1/8). Your use of let in make-rests does not copy the list, it just creates a new binding that references it. Use copy-list in your let, or write a non-destructive version in the first place:
(defun make-rests (positions rhythm)
(loop for note in rhythm
for i from 0
collect (if (member i positions) (* note -1) note)))

Resources