I have a problem with some part of my lisp code. It is a sudoku table generator. It works fine until this part:
(loop for e in entries do
(if (and (not (member e sub))
(not (member e col)))
(progn (setq choices (nconc choices (list e)))
(print choices)))
(if (= (length choices) 1)
(setq pick (car choices))
(if (not (= (length choices) 0))
(setq pick (nth (random (+ 0 (length choices))) choices))))
Basically, I am on a row x and a column y, and I need to insert an element. I watch the submatrix for this element and for column, and I choose the number that isn't appearing in any of the above and put it there. That's the "pick" variable. The problem is that sometimes the "choices" variable gets NIL value although in entries loop it has the right value. When it gets NIL, the pick value stays the same as it was in last loop (I am looping in columns and rows, above this snippet), making my final table have invalidated output (double values in a row, for example). How can I track where the choices variable changes? I work with it only in this snippet and I don't understand why it changes suddenly to nil.
For instance, I usually have:
in entries loop: choices (5)
Out of entries loop: choices (5)
in entries loop: choices (6 7)
Out of entries loop: choices (6 7) and after that this one:
in entries loop: choices nil.
Thank you.
First, some reformatting:
(loop for e in entries do
(if (and (not (member e sub))
(not (member e col)))
(progn (setq choices (nconc choices (list e)))
(print choices)))
(if (= (length choices) 1)
(setq pick (car choices))
(if (not (= (length choices) 0))
(setq pick (nth (random (+ 0 (length choices))) choices))))
Then, if you don't need the alternative clause of if, but want a progn, you can use when:
(loop for e in entries do
(when (and (not (member e sub))
(not (member e col)))
(setq choices (nconc choices (list e)))
(print choices))
(if (= (length choices) 1)
(setq pick (car choices))
(if (not (= (length choices) 0))
(setq pick (nth (random (+ 0 (length choices))) choices))))
The last two if clauses are mutually exclusive, so either cond or case would be appropriate (I'll use cond for now):
(loop for e in entries do
(when (and (not (member e sub))
(not (member e col)))
(setq choices (nconc choices (list e)))
(print choices))
(cond ((= (length choices) 1)
(setq pick (car choices)))
((not (= (length choices) 0))
(setq pick (nth (random (+ 0 (length choices))) choices))))
There is a zerop predicate:
(loop for e in entries do
(when (and (not (member e sub))
(not (member e col)))
(setq choices (nconc choices (list e)))
(print choices))
(cond ((= (length choices) 1)
(setq pick (car choices)))
((not (zerop (length choices)))
(setq pick (nth (random (+ 0 (length choices))) choices))))
I don't see what adding 0 to some value should accomplish:
(loop for e in entries do
(when (and (not (member e sub))
(not (member e col)))
(setq choices (nconc choices (list e)))
(print choices))
(cond ((= (length choices) 1)
(setq pick (car choices)))
((not (zerop (length choices)))
(setq pick (nth (random (length choices)) choices))))
Unless you are sure that pick is set to a sensible default to begin with, you should perhaps have a default case (this may be one of your problems):
(loop for e in entries do
(when (and (not (member e sub))
(not (member e col)))
(setq choices (nconc choices (list e)))
(print choices))
(cond ((= (length choices) 1)
(setq pick (car choices)))
((not (zerop (length choices)))
(setq pick (nth (random (length choices)) choices)))
(t
(setq pick nil))
Instead of using setq and nconc, you can use push (this puts the new element at the start of the list, but since you pick randomly anyway, this shouldn't be a concern):
(loop for e in entries do
(when (and (not (member e sub))
(not (member e col)))
(push e choices)
(print choices))
(cond ((= (length choices) 1)
(setq pick (car choices)))
((not (zerop (length choices)))
(setq pick (nth (random (length choices)) choices)))
(t
(setq pick nil))
I suspect that at the start of this snippet, choices is supposed to be (), that you don't need choices after this snippet, and that printing choices is just for debugging, so you could do this in a different way by using remove-if and changing the condition:
(let ((choices (remove-if (lambda (e)
(or (member e sub)
(member e col)))
entries)))
(print choices)
(cond ((= (length choices) 1)
(setq pick (car choices)))
((not (zerop (length choices)))
(setq pick (nth (random (length choices)) choices)))
(t
(setq pick nil)))
If choices is printed as () now, it means that there are no choices left here, so you will have to do some backtracking then (or whatever your algorithm does when a dead end is reached).
Finally, since (length choices) can only be non-negative integers, you can use case instead of cond if you test the cases in different order:
(let ((choices (remove-if (lambda (e)
(or (member e sub)
(member e col)))
entries)))
(print choices)
(case (length choices)
(0 (setq pick nil))
(1 (setq pick (car choices)))
(otherwise (setq pick (nth (random (length choices)) choices)))))
Update by request.
As Rainer points out, this is basically the body of a pick function, so we can get rid of all the free variables. Also, instead of car, you can use the (for lists) more descriptive name first:
(defun pick (entries sub col)
(let ((choices (remove-if (lambda (e)
(or (member e sub)
(member e col)))
entries)))
(print choices)
(case (length choices)
(0 nil)
(1 (first choices))
(otherwise (nth (random (length choices)) choices)))))
This function would be defined elsewhere, and in the snippet's place, it would be called like this:
(pick entries sub col)
In order not to compute (length choices) twice, we can put that into the let (which needs to become let* for serial evaluation):
(defun pick (entries sub col)
(let* ((choices (remove-if (lambda (e)
(or (member e sub)
(member e col)))
entries))
(choices-length (length choices)))
(print choices)
(case choices-length
(0 nil)
(1 (first choices))
(otherwise (nth (random choices-length) choices)))))
A final step (really optional, but perhaps you discover that you have more sequences reducing your choices, e.g. row) would be a little generalization:
(defun pick (entries &rest exclusion-sequences)
(let* ((choices (remove-if (lambda (e)
(some #'identity
(mapcar (lambda (seq)
(member e seq))
exclusion-sequences)))
entries))
(choices-length (length choices)))
(print choices)
(case choices-length
(0 nil)
(1 (first choices))
(otherwise (nth (random choices-length) choices)))))
The call to this function is of the same shape, but you can now use any number of exclusion sequences:
(pick entries col sub row ver ima fou)
A potential source of trouble is NCONC.
nconc is destructively modifying the first list. If that is unwanted, use APPEND instead.
A second source of problem with NCONC is the use of literal lists.
Example:
(defun foo (bar) (let ((l '(1 2 3))) ...))
Here '(1 2 3) is a literal list. The effects of destructively modifying such a list is undefined in Common Lisp. Thus it should be avoided. What to do instead?
cons the list: (list 1 2 3)
copy the literal list: (copy-list l)
use non destructive operations (APPEND instead of NCONC, ...)
My Lisp is quite rusty, but I don't see any backtracking there... and I think you cannot just start putting numbers randomly and expect that they will make a proper sudoku game.
It seems that the list is nil because there are no possible options and thus is not created. You should handle that.
This is not a proper answer, but I did fix the indentation to make the code a bit more legible to myself and other answerers:
(loop for e in entries do
(if (and (not (member e sub)) (not (member e col)))
(progn (setq choices (nconc choices (list e)))
(print choices) ))
(if (= (length choices) 1) (setq pick (car choices))
(if (not (=(length choices) 0))
(setq pick (nth (random (+ 0 (length choices))) choices))))
Questions:
Is entries a list of lists? Does each list represent a row?
What are the values 'sub' and 'col' set to?
Related
I'm writing a macro to generate codes used by another macro in Common Lisp. But I'm new at this and have difficulty in constructing a macro that takes in a list (bar1 bar2 ... barn) and produces the following codes by a loop.
`(foo
,#bar1
,#bar2
...
,#barn)
I wonder whether this can be achieved not involving implement-dependent words such as SB-IMPL::UNQUOTE-SPLICE in sbcl.
Maybe I didn't give a clear description about my problem. In fact I want to write a macro gen-case such that
(gen-case
(simple-array simple-vector)
('(dotimes ($1 $5)
(when (and (= (aref $4 $2 $1) 1) (zerop (aref $3 $1)))
$0))
'(dolist ($1 (aref $4 $2))
(when (zerop (aref $3 $1))
$0)))
objname body)
produces something like
`(case (car (type-of ,objname))
(simple-array
,#(progn
(setf temp
'(dotimes ($1 $5)
(when (and (= (aref $4 $2 $1) 1) (zerop (aref $3 $1)))
$0)))
(code-gen body)))
(simple-vector
,#(progn
(setf temp
'(dolist ($1 (aref $4 $2))
(when (zerop (aref $3 $1))
$0)))
(code-gen body))))
In general cases, the lists taken in by gen-case may contain more than two items.
I have tried
``(case (car (type-of ,,objname))
,',#(#|Some codes that produce target codes|#))
but the target codes are inserted to the quote block and thus throw an exception in the macro who calls the macro gen-case. Moreover, I have no way to insert ,# to the target codes as a straightforward insertion will cause a "comma not inside a backquote" exception.
The codes generated are part of another macro
(defmacro DSI-Layer ((obj-name tag-name) &body body)
"Data Structure Independent Layer."
(let ((temp))
(defun code-gen (c)
(if (atom c) c
(if (eq (car c) tag-name)
(let ((args (cadr c)) (codes (code-gen (cddr c))) (flag nil))
(defun gen-code (c)
(if (atom c) c
(if (eq (car c) *arg*)
(let ((n (cadr c)))
(if (zerop n) (progn (setf flag t) codes)
(nth (1- n) args)))
(let ((h (gen-code (car c))))
(if flag
(progn
(setf flag nil)
(append h (gen-code (cdr c))))
(cons h (gen-code (cdr c))))))))
(gen-code temp))
(cons (code-gen (car c)) (code-gen (cdr c))))))
`(case (car (type-of ,obj-name))
(simple-array
,#(progn
(setf temp
'(dotimes ($1 $5)
(when (and (= (aref $4 $2 $1) 1) (zerop (aref $3 $1)))
$0)))
(code-gen body)))
(simple-vector
,#(progn
(setf temp
'(dolist ($1 (aref $4 $2))
(when (zerop (aref $3 $1))
$0)))
(code-gen body))))))
and I've set up a read-macro
(defvar *arg* (make-symbol "ARG"))
(set-macro-character #\$
#'(lambda (stream char)
(declare (ignore char))
(list *arg* (read stream t nil t))))
The intention of DSI-Layer is to add a piece of code to determine the type of input parameters. For example, the codes
(defun BFS (G v)
(let* ((n (car (array-dimensions G)))
(visited (make-array n :initial-element 0))
(queue (list v))
(vl nil))
(incf (aref visited v))
(DSI-Layer (G next-vertex)
(do nil ((null queue) nil)
(setf v (pop queue)) (push v vl)
(next-vertex (i v visited G n)
(setf queue (nconc queue (list i)))
(incf (aref visited i)))))
vl))
will be converted to
(defun BFS (G v)
(let* ((n (car (array-dimensions G)))
(visited (make-array n :initial-element 0))
(queue (list v))
(vl nil))
(incf (aref visited v))
(case (car (type-of G))
(simple-array
(do nil ((null queue) nil)
(setf v (pop queue))
(push v vl)
(dotimes (i n)
(when (and (= (aref G v i) 1) (zerop (aref visited i)))
(setf queue (nconc queue (list i)))
(incf (aref visited i))))))
(simple-vector
(do nil ((null queue) nil)
(setf v (pop queue))
(push v vl)
(dolist (i (aref G v))
(when (zerop (aref visited i))
(setf queue (nconc queue (list i)))
(incf (aref visited i)))))))))
Now I just wonder that whether the DSI-Layer can be generated from another macro gen-case by passing the type names and corresponding code templates to it or not.
By the way, I don't think the specific meaning of generated codes matters in my problem. They are just treated as data.
Don't be tempted to use internal details of backquote. If you have the lists you want to append in distinct variables, simply append them:
`(foo
,#(append b1 b2 ... bn))
If you have a list of them in some single variable (for instance if they've come from an &rest or &body argument) then do something like
`(foo
,#(loop for b in bs
appending b))
I see your problem - you need it not for a function call
but for a macro-call with case.
One cannot use dynamically macros - in a safe way.
One has to use eval but it is not safe for scoping.
#tfb as well as me answered in this question for type-case
lengthily.
previous answer (wrong for this case)
No need for a macro.
`(foo
,#bar1
,#bar2
...
,#barn)
with evaluation of its result
by pure functions would be:
(apply foo (loop for bar in '(bar1 bar2 ... barn)
nconc bar))
nconc or nconcing instead of collect fuses lists together and is very useful in loop. - Ah I see my previous answerer used append btw appending - nconc nconcing however is the "destructive" form of "append". Since the local variable bar is destructed here which we don't need outside of the loop form, using the "destructive" form is safe here - and comes with a performance advantage (less elements are copied than when using append). That is why I wired my brain always to use nconc instead of append inside a loop.
Of course, if you want to get the code construct, one could do
`(foo ,#(loop for bar in list-of-lists
nconc bar))
Try it out:
`(foo ,#(loop for bar in '((1 2 3) (a b c) (:a :b :c)) nconc bar))
;; => (FOO 1 2 3 A B C :A :B :C)
The answers of all of you inspired me, and I came up with a solution to my problem. The macro
(defmacro Layer-Generator (obj-name tag-name callback body)
(let ((temp (gensym)) (code-gen (gensym)))
`(let ((,temp))
(defun ,code-gen (c)
(if (atom c) c
(if (eq (car c) ,tag-name)
(let ((args (cadr c)) (codes (,code-gen (cddr c))) (flag nil))
(defun gen-code (c)
(if (atom c) c
(if (eq (car c) *arg*)
(let ((n (cadr c)))
(if (zerop n) (progn (setf flag t) codes)
(nth (1- n) args)))
(let ((h (gen-code (car c))))
(if flag
(progn
(setf flag nil)
(append h (gen-code (cdr c))))
(cons h (gen-code (cdr c))))))))
(gen-code ,temp))
(cons (,code-gen (car c)) (,code-gen (cdr c))))))
(list 'case `(car (type-of ,,obj-name))
,#(let ((codes nil))
(dolist (item callback)
(push
`(cons ',(car item)
(progn
(setf ,temp ,(cadr item))
(,code-gen ,body)))
codes))
(nreverse codes))))))
produces codes which are not the same as DSI-Layer but produce codes coincident with what the latter produces. Because the codes
`(case (car (type-of ,obj-name))
(tag1
,#(#|codes1|#))
(tag2
,#(#|codes2|#))
...)
are equivalent to
(list 'case `(car (type-of ,obj-name))
(cons 'tag1 (#|codes1|#))
(cons 'tag2 (#|codes2|#))
...)
And now we can use a loop to generate it just as what the Layer-Generator does.
Preface
I am working on implementing the Genetic Algorithm for the Traveling Salesman problem. I am making some base line assumption such as you can travel to any city from any city. While this is for an assignment, I have extended this to a personal project as the deadline is past and I have chosen to use Lisp which definitely was not required. The point of encoding my data in this way listed below is to easily perform cross-over later in the algorithm.
Problem
Suppose you have a list of cities, given similar to the following
(defvar *data* (list
'(A 20 10)
'(B 5 16)
'(C 12 18)
'(D x y)
'(E x y)
...
I want to encode this data in a way similar to this:
and I for the life of me cannot figure out how to implement this in Lisp. If anyone has some insight, it would be much appreciated. If there is a better way to create my *data* set that would make this easier feel free to include it!
Now I understood it. Here is the solution:
(defparameter *data* (list
'(A 20 10)
'(B 5 16)
'(C 12 18)
'(D x y)
'(E x y)))
For one step you need a function which looks up index position of the city in the city-list (*data*) and also removes its entry in the city-list and returns the updated city-list.
(defun choose-city (city-list city-name)
"Return city-name with its index position
and city-list with the chosen city removed, keeping the order."
(let* ((cities (mapcar #'car city-list))
(pos (position city-name cities)))
(list city-name
pos
(append (subseq city-list 0 pos)
(subseq city-list (+ pos 1) (length city-list))))))
;; improved version by #Kaz - thanks! (lispier)
(defun choose-city (city-list city-name)
(list city-name
(positiion city-name city-list :key #'car :test #'eql)
(remove city-name city-list :key #'car :test #'eql)))
Then, you need a function which applies the previous function
over and over again while collecting the index positions and updates from step to step the city-list by removing the matched current-city in the city-sequence.
A typical pattern occuring in lisp for this is
to define the to-be-mutated variable as a local variable in a let expression and from the body of the let-expression to update the variable value using setf (setf-ing).
(defun choose-cities-subsequently (city-list city-sequence)
"Return sequence of subsequent-index-positions of the cities
given in city-sequence. After choosing a sequence, the city is
removed from the city-list and its index position of the previous
pool taken for record."
(let ((index-positions '()) ; initiate collector variable
(current-city-list city-list)) ; current state of city-list
(loop for current-city in city-sequence
do (progn
;; call `choose-city` and capture its results
(destructuring-bind
(name index new-city-list) ; capturing vars
;; and in the following the function call:
(choose-city current-city-list current-city)
;; update collector variable and
;; current-city-list using the captured values
(setf index-positions (cons index index-positions))
(setf current-city-list new-city-list)))
;; if city-sequence processed in this way,
;; return the collected index-positions.
;; remark: cons-ing during collecting and
;; at the end nreverse-ing the result
;; when/while returning
;; is a very typical lisp idiom
finally (return (nreverse index-positions)))))
;; improved version by #Kaz - thanks!
(defun choose-cities-subsequently (city-list city-sequence)
(let ((index-positions '()) ; initiate collector variable
(current-city-list city-list)) ; current state of city-list
(loop for current-city in city-sequence
collect (destructuring-bind
(name index new-city-list)
(choose-city current-city-list current-city)
(setf current-city-list new-city-list)
index)
into index-positions
finally (return index-positions)))))
Now, if you run
(choose-cities-subsequently *data* '(A D E B C))
it returns correctly:
(0 2 2 0 0)
By defining more let-variables in the last function and
setf-fing to those in the destructuring-bind expression's body, and returning the final value in the final list,
you can collect more informations and make them visibile.
Tried to simplify a little and recursive definition
(defparameter *data* (list
'(A 20 10)
'(B 5 16)
'(C 12 18)
'(D x y)
'(E x y)))
(defun choose-city (city-list city-name)
(list (position city-name city-list :key #'car :test #'eql)
(remove city-name city-list :key #'car :test #'eql)))
;; when city names are strings use `:test #'string=
(defun choose-cities-subsequently (city-list city-sequence)
(let ((current-cities city-list))
(loop for current-city in city-sequence
for (idx updated-cities) = (choose-city current-cities current-city)
collect (progn (setf current-cities updated-cities)
idx)
into index-positions
finally (return index-positions))))
(choose-cities-subsequently *cities* '(A D E B C))
;; (0 2 2 0 0)
;; a tail-call recursive version:
(defun choose-cities-subsequently (cities city-sequence
&key (acc-cities '())
(acc-positions '())
(pos-counter 0)
(test #'eql))
(cond ((or (null city-sequence) (null cities)) (nreverse acc-positions))
((funcall test (car city-sequence) (car cities))
(choose-cities-subsequently (append (nreverse acc-cities) (cdr cities))
(cdr city-sequence)
:acc-cities '()
:acc-positions (cons pos-counter acc-positions)
:pos-counter 0
:test test))
(t (choose-cities-subsequently (cdr cities)
city-sequence
:acc-cities (cons (car cities) acc-cities)
:acc-positions acc-positions
:pos-counter (1+ pos-counter)
:test test))))
(defun suma (L)
(setq var 0)
(do
((i 0 (+ i 1)))
((= i (length L)))
(+ var (nth i L)))
var)
Why does it always returns 0?
Shouldn't it return sum of list L?
+ does not modify its arguments, so, since you never modify var, its initial value of 0 is returned.
You need to replace (+ var (nth i L)) with (incf var (nth i L)), of, equivalently, (setq var (+ var (nth i L))).
See incf.
Note that you should bind var with let instead of making it global with setq.
Most importantly, note that your algorithm is quadratic in the length of the list argument (because nth scans your list every time from the start).
Here are some better implementations:
(defun sum-1 (l)
(reduce #'+ l))
(defun sum-2 (l)
(loop for x in l sum x))
(defun sum-3 (l)
(let ((sum 0))
(dolist (x l sum)
(incf sum x))))
Here is a bad implementation:
(defun sum-4 (l)
(apply #'+ l))
The problem with sum-4 is that it will fail if the length of the supplied list is larger than call-arguments-limit.
I thought this would be a comment for the full learning experience, but I was not able to put code in the comment.
There is a way to do sums without modifying any argument, and that is by doing it recursively:
(defun recsum (list)
(if list
(+ (first list) (recsum (rest list)))
0))
This version can be tail call optimized by the compiler, and as fast as a loop:
(defun recsum2 (list &optional (accumulator 0))
(if list
(recsum2 (rest list) (+ accumulator (first list)))
accumulator))
What you are trying to do could be done with do like this:
(defun suma (l)
(do
((var 0)
(i 0 (+ i 1)))
((= i (length l)) var)
(incf var (nth i l))))
But we don't usually do anything in dos body, so it's like this then:
(defun suma (l)
(do
((i 0 (+ i 1))
(var 0 (+ var (nth i l))))
((= i (length l)) var)))
But nth and length are slow, so better do it this way:
(defun suma (l)
(do*
((var (first l) (+ var (first list)))
(list (rest l) (rest list)))
((null list) var)))
This one is without the * in do, and returns 0 on empty list:
(defun suma (l)
(do
((acc 0 (+ acc (first list)))
(list l (rest list)))
((null list) acc)))
But my favorite is the reduce version from #sds which also can return 0 on empty list with :initial-value 0
EDIT: recsum2 did not return anything, so it needed a fix.
I'm new to lisp, and have been trying to learn Common Lisp by diving in and writing some code. I've read plenty of documentation on the subject, but it's taking a while to really sink in.
I have written a couple of macros (? and ??) for performing unit tests, but I'm having some difficulty. The code is at the end of the post, to avoid cluttering the actual question.
Here is an example of usage:
(??
(? "Arithmetic tests"
(? "Addition"
(= (+ 1 2) 3)
(= (+ 1 2 3) 6)
(= (+ -1 -3) -4))))
And an example of output:
[Arithmetic tests]
[Addition]
(PASS) '(= (+ 1 2) 3)'
(PASS) '(= (+ 1 2 3) 6)'
(PASS) '(= (+ -1 -3) -4)'
Results: 3 tests passed, 0 tests failed
Now, the existing code works. Unfortunately, the (? ...) macro is ugly, verbose, resistant to change - and I'm pretty sure also badly structured. For example, do I really have to use a list to store pieces of output code and then emit the contents at the end?
I'd like to modify the macro to permit description strings (or symbols) to optionally follow each test, whereupon it would replace the test literal in the output, thus:
(??
(? "Arithmetic tests"
(? "Addition"
(= (+ 1 2) 3) "Adding 1 and 2 results in 3"
(= (+ 1 2 3) 6)
(= (+ -1 -3) -4))))
Output:
[Arithmetic tests]
[Addition]
(PASS) Adding 1 and 2 results in 3
(PASS) '(= (+ 1 2 3) 6)'
(PASS) '(= (+ -1 -3) -4)'
But unfortunately I can't find a sensible place in the macro to insert this change. Depending on where I put it, I get errors like you're not inside a backquote expression, label is not defined or body-forms is not defined. I know what these errors mean, but I can't find a way to avoid them.
Also, I'll be wanting to handle exceptions in the test, and treat that as a failure. Currently, there is no exception handling code - the test result is merely tested against nil. Again, it is not clear how I should add this functionality.
I'm thinking that maybe this macro is over-complex, due to my inexperience in writing macros; and perhaps if I simplify it, modification will be easier. I don't really want to separate it out into several smaller macros without good reason; but maybe there's a terser way to write it?
Can anyone help me out here, please?
A complete code listing follows:
(defmacro with-gensyms ((&rest names) &body body)
`(let ,(loop for n in names collect `(,n (gensym)))
,#body))
(defmacro while (condition &body body)
`(loop while ,condition do (progn ,#body)))
(defun flatten (L)
"Converts a list to single level."
(if (null L)
nil
(if (atom (first L))
(cons (first L) (flatten (rest L)))
(append (flatten (first L)) (flatten (rest L))))))
(defun starts-with-p (str1 str2)
"Determine whether `str1` starts with `str2`"
(let ((p (search str2 str1)))
(and p (= 0 p))))
(defmacro pop-first-char (string)
`(with-gensyms (c)
(if (> (length ,string) 0)
(progn
(setf c (schar ,string 0))
(if (> (length ,string) 1)
(setf ,string (subseq ,string 1))
(setf ,string ""))))
c))
(defmacro pop-chars (string count)
`(with-gensyms (result)
(setf result ())
(dotimes (index ,count)
(push (pop-first-char ,string) result))
result))
(defun format-ansi-codes (text)
(let ((result ()))
(while (> (length text) 0)
(cond
((starts-with-p text "\\e")
(push (code-char #o33) result)
(pop-chars text 2)
)
((starts-with-p text "\\r")
(push (code-char 13) result)
(pop-chars text 2)
)
(t (push (pop-first-char text) result))
))
(setf result (nreverse result))
(coerce result 'string)))
(defun kv-lookup (values key)
"Like getf, but works with 'keys as well as :keys, in both the list and the supplied key"
(setf key (if (typep key 'cons) (nth 1 key) key))
(while values
(let ((k (pop values)) (v (pop values)))
(setf k (if (typep k 'cons) (nth 1 k) k))
(if (eql (symbol-name key) (symbol-name k))
(return v)))))
(defun make-ansi-escape (ansi-name)
(let ((ansi-codes '( :normal "\\e[00m" :white "\\e[1;37m" :light-grey "\\e[0;37m" :dark-grey "\\e[1;30m"
:red "\\e[0;31m" :light-red "\\e[1;31m" :green "\\e[0;32m" :blue "\\e[1;34m" :dark-blue "\\e[1;34m"
:cyan "\\e[1;36m" :magenta "\\e[1;35m" :yellow "\\e[0;33m"
:bg-dark-grey "\\e[100m"
:bold "\\e[1m" :underline "\\e[4m"
:start-of-line "\\r" :clear-line "\\e[2K" :move-up "\\e[1A")))
(format-ansi-codes (kv-lookup ansi-codes ansi-name))
))
(defun format-ansi-escaped-arg (out-stream arg)
(cond
((typep arg 'symbol) (format out-stream "~a" (make-ansi-escape arg)))
((typep arg 'string) (format out-stream arg))
(t (format out-stream "~a" arg))
))
(defun format-ansi-escaped (out-stream &rest args)
(while args
(let ((arg (pop args)))
(if (typep arg 'list)
(let ((first-arg (eval (first arg))))
(format out-stream first-arg (second arg))
)
(format-ansi-escaped-arg out-stream arg)
))
))
(defmacro while-pop ((var sequence &optional result-form) &rest forms)
(with-gensyms (seq)
`(let (,var)
(progn
(do () ((not ,sequence))
(setf ,var (pop ,sequence))
(progn ,#forms))
,result-form))))
(defun report-start (form)
(format t "( ) '~a'~%" form))
(defun report-result (result form)
(format-ansi-escaped t "(" (if result :green :red) `("~:[FAIL~;PASS~]" ,result) :normal `(") '~a'~%" ,form))
result)
(defmacro ? (name &body body-forms)
"Run any number of test forms, optionally nested within further (?) calls, and print the results of each test"
(with-gensyms (result indent indent-string)
(if (not body-forms)
:empty
(progn
(setf result () indent 0 indent-string " ")
(cond
((typep (first body-forms) 'integer)
(setf indent (pop body-forms))))
`(progn
(format t "~v#{~A~:*~}" ,indent ,indent-string)
(format-ansi-escaped t "[" :white ,name :normal "]~%")
(with-gensyms (test-results)
(setf test-results ())
,(while-pop (body-form body-forms `(progn ,#(nreverse result)))
(cond
( (EQL (first body-form) '?)
(push `(progn
(setf test-results (append test-results (? ',(nth 1 body-form) ,(1+ indent) ,#(nthcdr 2 body-form))))
(format t "~%")
test-results
) result)
)
(t
(push `(progn
(format t "~v#{~A~:*~}" ,(1+ indent) ,indent-string)
(report-start ',body-form)
(with-gensyms (result label)
(setf result ,body-form)
(format-ansi-escaped t :move-up :start-of-line :clear-line)
(format t "~v#{~A~:*~}" ,(1+ indent) ,indent-string)
(push (report-result result ',body-form) test-results)
test-results
)) result))))))))))
(defun ?? (&rest results)
"Run any number of tests, and print a summary afterward"
(setf results (flatten results))
(format-ansi-escaped t "~&" :white "Results: " :green `("~a test~:p passed" ,(count t results)) :normal ", "
(if (find NIL results) :red :normal) `("~a test~:p failed" ,(count NIL results))
:yellow `("~[~:;, ~:*~a test~:p not run~]" ,(count :skip results))
:brown `("~[~:;, ~:*~a empty test group~:p skipped~]" ,(count :empty results))
:normal "~%"))
For my part, the ? macro is rather technical and it's hard to follow the logic behind the formatting functions. So instead of tracking errors I'd like to suggest my own attempt, perhaps it'll be of use.
I think that actually your ?? doesn't want to evaluate anything, but rather to treat its body as individual tests or sections. If the body includes a list starting with ?, this list represents a section; other elements are test forms optionally followed by descriptions. So in my implementation ?? will be a macro, and ? will be just a symbol.
I start with wishful thinking. I suppose I can create individual tests using a function make-test-item and test sections using a function make-test-section (their implementation is unimportant for now), that I can display them using an auxiliary function display-test and compute results using the function results, which returns two values: the total number of tests and the number of passed ones. Then I'd like the code
(??
(? "Arithmetic tests"
(? "Addition"
(= (+ 1 2) 3) "Adding 1 and 2 results in 3"
(= (+ 1 2 3) 6)
(= (+ -1 -3) 4))
(? "Subtraction"
(= (- 1 2) 1)))
(= (sin 0) 0) "Sine of 0 equals 0")
to expand into something like
(let ((tests (list (make-test-section :header "Arithmetic tests"
:items (list (make-test-section :header "Addition"
:items (list (make-test-item :form '(= (+ 1 2) 3)
:description "Adding 1 and 2 results in 3"
:passp (= (+ 1 2) 3))
(make-test-item :form '(= (+ 1 2 3) 6)
:passp (= (+ 1 2 3) 6))
(make-test-item :form '(= (+ -1 -3) 4)
:passp (= (+ -1 -3) 4))))
(make-test-section :header "Subtraction"
:items (list (make-test-item :form '(= (- 1 2) 1)
:passp (= (- 1 2) 1))))))
(make-test-item :form '(= (sin 0) 0)
:passp (= (sin 0) 0)
:description "Sine of 0 equals 0"))))
(loop for test in tests
with total = 0
with passed = 0
do (display-test test 0 t)
do (multiple-value-bind (ttl p) (results test)
(incf total ttl)
(incf passed p))
finally (display-result total passed t)))
Here a list of tests is created; then we traverse it printing each test (0 denotes the zero level of indentation and t is as in format) and keeping track of the results, finally displaying the total results. I don't think explicit eval is needed here.
It may not be the most exquisite piece of code ever, but it seems manageable. I supply missing definitions below, they are rather trivial (and can be improved) and have nothing to do with macros.
Now we pass on to the macros. Consider both pieces of code as data, then we want a list processing function which would turn the first one into the second. A few auxiliary functions would come in handy.
The major task is to parse the body of ?? and generate the list of test to go inside the let.
(defun test-item-form (form description)
`(make-test-item :form ',form :description ,description :passp ,form))
(defun test-section-form (header items)
`(make-test-section :header ,header :items (list ,#items)))
(defun parse-test (forms)
(let (new-forms)
(loop
(when (null forms)
(return (nreverse new-forms)))
(let ((f (pop forms)))
(cond ((and (listp f) (eq (first f) '?))
(push (test-section-form (second f) (parse-test (nthcdr 2 f))) new-forms))
((stringp (first forms))
(push (test-item-form f (pop forms)) new-forms))
(t (push (test-item-form f nil) new-forms)))))))
Here parse-test essentially absorbs the syntax of ??. Each iteration consumes one or two forms and collects corresponding make-... forms. The functions can be easily tested in REPL (and, of course, I did test them while writing).
Now the macro becomes quite simple:
(defmacro ?? (&body body)
`(let ((tests (list ,#(parse-test body))))
(loop for test in tests
with total = 0
with passed = 0
do (display-test test 0 t)
do (multiple-value-bind (ttl p) (results test)
(incf total ttl)
(incf passed p))
finally (display-result total passed t))))
It captures a few symbols, both in the variable name space and in the function one (the expansion may contain make-test-item and make-test-section). A clean solution with gensyms would be cumbersome, so I'd suggest just moving all the definitions in a separate package and exporting only ?? and ?.
For completeness, here is an implementation of the test API. Actually, it's what I started coding with and proceeded until I made sure the big let-form works; then I passed on to the macro part. This implementation is fairly sloppy; in particular, it doesn't support terminal colours and display-test can't even output a section into a string.
(defstruct test-item form description passp)
(defstruct test-section header items)
(defun results (test)
(etypecase test
(test-item (if (test-item-passp test)
(values 1 1)
(values 1 0)))
(test-section (let ((items-count 0)
(passed-count 0))
(dolist (i (test-section-items test) (values items-count passed-count))
(multiple-value-bind (i p) (results i)
(incf items-count i)
(incf passed-count p)))))))
(defparameter *test-indent* 2)
(defun display-test-item (i level stream)
(format stream "~V,0T~:[(FAIL)~;(PASS)~] ~:['~S'~;~:*~A~]~%"
(* level *test-indent*)
(test-item-passp i)
(test-item-description i)
(test-item-form i)))
(defun display-test-section-header (s level stream)
(format stream "~V,0T[~A]~%"
(* level *test-indent*)
(test-section-header s)))
(defun display-test (test level stream)
(etypecase test
(test-item (display-test-item test level stream))
(test-section
(display-test-section-header test level stream)
(dolist (i (test-section-items test))
(display-test i (1+ level) stream)))))
(defun display-result (total passed stream)
(format stream "Results: ~D test~:P passed, ~D test~:P failed.~%" passed (- total passed)))
All the code is licenced under WTFPL.
beginner in LISP here. I'm preparing myself for my upcoming exam in LISP and I've come across a problem I can't solve, so I was hoping someone more experienced might help me out.
Anyways, here is my problem :
You are given a list that may contain lists as elements. Your task is to delete an atomic element at a given position.
The list and the position are given as input parameters.
Example : Position=5 , List=(1 (2 3) ((4)) (5 (6))) , should return (1 (2 3) ((4)) ((6))).
Here is what i got so far...(PS the code below works thanks to the assistance of imMaw , you can check edit to see my previous mistake ).
(defun number_of_atoms(List)
(atoms List 0)
)
(defun atoms(List Number)
(cond
((null List) Number)
((atom (car List)) (atoms (cdr List) (+ 1 Number)))
((+ (atoms (car List) Number) (atoms (cdr List) 0)))
)
)
(defun deleteElement(Pos List)
(deleteElementAcc Pos 1 List)
)
(defun deleteElementAcc(Pos CurrPos List)
(cond
((null List) nil)
((and (atom (car List)) (not(eql CurrPos Pos))) (cons (car List) (deleteElementAcc Pos (+ CurrPos 1) (cdr List))))
((and (atom (car List)) (eql CurrPos Pos)) (deleteElementAcc Pos (+ CurrPos 1) (cdr List)))
((cons (deleteElementAcc Pos CurrPos (car List))
(deleteElementAcc Pos (+ CurrPos (number_of_atoms(car List))) (cdr List))))
)
)
Why are you spelling Pos and CurrPos with z's in half the places?
And the problem in your code lies in the last branch of the cond. When you recurse on the cdr of List, CurrPos needs to be advanced by the number of elements in (car List). And a simple (length List) won't work, because it needs to recursively count elements in sublists.
Edit: more elaboration
Say we call
(deleteElement 3 '((1 2) (3 4)))
You turn this into
(deleteElementPos 3 1 '((1 2) (3 4))),
which falls into the last case of the cond, and you get
(cons (deleteElementAcc 3 1 '(1 2))
(deleteElementAcc 3 1 '((3 4))))
notice that currPos is wrong for the cdr of the list - it should be 3, not 1. You actually want your code to turn into
(cons (deleteElementAcc 3 1 '(1 2))
(deleteElementAcc 3 (+ 1 2) '((3 4))))
because (car List) has 2 elements in it.
So, you just need to change
(deleteElementAcc Pos CurrPos (cdr List))
into
(deleteElementAcc Pos (+ CurrPos (recursive-length (car List))) (cdr List))
and program recursive-length, which is a pretty simple function. It should count elements in sublists, so for example (recursive-length '((1 2) ((3)))) returns 3.
While solving this problem in just any way isn't particularly difficult, it is really non-trivial to solve it well. By well I mean both big O's and code complexity, just as well as handling of corner cases. I'm not sure this code will handle even improper lists, and it has parts that could be certainly reduced in verbosity, but, technically, it is there. It walks through the tree in exactly O(n), where n is the number of elements in the tree, and it uses O(n + 2 * (maximum depth)) space, i.e. it will use the memory already used by the tree and in addition the memory proportional to the maximum depth of the tree.
No attempt was made to identify cyclic lists or duplicates:
(defun remove-from-tree-linear (tree &rest positions)
(loop with node = tree
with nilcar = (gensym)
with positions = (sort (remove-duplicates positions) #'<)
with counter = 0
with copy = nil
with root = nil
with stack = nil
with backrefs = nil
while (or node stack) do
(cond
((null node)
(setf backrefs (cdr backrefs))
(when (car stack)
(setf copy (car backrefs)))
(setf node (car stack) stack (cdr stack)))
((consp (car node))
(if copy
(if (eq (car copy) nilcar)
(setf (car copy) (list nilcar)
copy (car copy)
(car backrefs) copy)
(setf (cdr copy) (list nilcar)
copy (cdr copy)
(car backrefs) copy))
(setf copy (list nilcar)
root copy))
(setf backrefs (cons copy backrefs))
(setf stack (cons (cdr node) stack)
node (car node)))
(t (if (and positions (= counter (car positions)))
(setf positions (cdr positions))
(if copy
(progn
(if (eq (car copy) nilcar)
(setf (car copy) (list (car node))
copy (car copy))
(setf (cdr copy) (list (car node))
copy (cdr copy)))
(setf (car backrefs) copy))
(setf copy (list (car node))
root copy
backrefs (list copy))))
(setf node (cdr node))))
(incf counter)
finally (return root)))