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))))
Related
I am trying to make my own pattern-matching system in Scheme. To begin I am making a parser for s-expressions that divides them into tokens like this:
'(1 2 b (3 4)) => '(number number symbol (number number))
It should be noted that I have not used define-syntax before in Scheme so that may be where I am messing up. Chez Scheme throws me this error:
Exception: invalid syntax classify at line 21, char 4 of pmatch.scm. Note that the line numbers won't correspond exactly to the snippet here. Does anyone know what I am doing wrong?
(define-syntax classify
(syntax-rules ()
((_ checker replacement)
((checker (car sexpr)) (cons replacement (classify-sexpr (cdr sexpr)))))))
(define (classify-sexpr sexpr)
(cond
((null? sexpr) sexpr)
(classify list? (classify-sexpr (car sexpr)))
(classify number? 'number)
(classify symbol? 'symbol)
(else
(cons 'symbol (classify-sexpr (cdr sexpr))))))
(display (classify-sexpr '(1 (b 3) (4 5) 6)))
Your code is hugely confused. In fact it's so confused I'm not sure what you're trying to do completely: I've based my answer on what you say the classifier should produce at the start of your question.
First of all your macro refers to sexpr which has no meaning in the macro, and because Scheme macros are hygienic it will definitely not refer to the sexpr which is the argument to classify-sexpr.
Secondly you don't need a macro at all here. I suspect that you may be thinking that because you are trying to write a macro you must use macros in its construction: that's not necessarily true and often a bad idea.
Thirdly the syntax of your cond is botched beyond repair: I can't work out what it's trying to do.
Finally the list classification will never be needed: if you want to classify (1 2 3 (x)) as (number number number (symbol)) then you'll simply never reach a case where you have a list which you want to classify since you must walk into it to classify its elements.
Instead just write the obvious functions do do what you want:
(define classification-rules
;; an alist of predicate / replacement which drives classigy
`((,number? number)
(,symbol? symbol)))
(define (classify thing)
;; classify thing using classification-rules
(let loop ([tail classification-rules])
(cond [(null? tail)
'something]
[((first (first tail)) thing)
(second (first tail))]
[else
(loop (rest tail))])))
(define (classify-sexpr sexpr)
;; classify a sexpr using classify.
(cond
[(null? sexpr) '()]
[(cons? sexpr) (cons (classify-sexpr (car sexpr))
(classify-sexpr (cdr sexpr)))]
[else (classify sexpr)]))
And now
> (classify-sexpr '(1 2 3 (x 2) y))
'(number number number (symbol number) symbol)
It may be that what you really want is something which classifies (1 2 (x 2)) as (list number number (list symbol number)) say. You can do this fairly easily:
(define atomic-classification-rules
;; an alist of predicate / replacements for non-conses
`((,number? number)
(,symbol? symbol)))
(define (classify-sexpr sexpr)
(cond
[(null? sexpr) '()]
[(list? sexpr)
`(list ,#(map classify-sexpr sexpr))]
[(cons? sexpr)
`(cons ,(classify-sexpr (car sexpr))
,(classify-sexpr (cdr sexpr)))]
[else
(let caloop ([rtail atomic-classification-rules])
(cond [(null? rtail)
'unknown]
[((first (first rtail)) sexpr)
(second (first rtail))]
[else
(caloop (rest rtail))]))]))
And now
> (classify-sexpr '(1 2 3 (x 2) y))
'(list number number number (list symbol number) symbol)
> (classify-sexpr '(1 2 3 (x 2) . y))
'(cons number (cons number (cons number (cons (list symbol number) symbol))))
Is there a standard function in Common Lisp that can check against improper lists (i.e. circular and dotted lists) without signaling an error? list-length can check against circular lists (it returns nil for them), but signals type-error when given a dotted list.
Scheme's list? traverses the whole list to make sure it is not dotted or circular; Common Lisp's listp only checks that it's given nil or a cons cell.
Here's the simplest I could come up with:
(defun proper-list-p (x)
(not (null (handler-case (list-length x) (type-error () nil)))))
Since several implementations have been suggested and many unexpected problems have been found, here's a test suite for aspiring proper-list-p writers:
(defun circular (xs)
(let ((xs (copy-list xs)))
(setf (cdr (last xs)) xs)
xs))
(assert (eql t (proper-list-p '())))
(assert (eql t (proper-list-p '(1))))
(assert (eql t (proper-list-p '(1 2))))
(assert (eql t (proper-list-p '(1 2 3))))
(assert (not (proper-list-p 1)))
(assert (not (proper-list-p '(1 . 2))))
(assert (not (proper-list-p '(1 2 . 3))))
(assert (not (proper-list-p '(1 2 3 . 4))))
(assert (not (proper-list-p (circular '(1)))))
(assert (not (proper-list-p (circular '(1 2)))))
(assert (not (proper-list-p (circular '(1 2 3)))))
(assert (not (proper-list-p (list* 1 (circular '(2))))))
(assert (not (proper-list-p (list* 1 2 (circular '(3 4))))))
There is no standard function to do this, perhaps because such a function was seen as rather expensive if it was to be correct, but, really, this just seems like am omission from the language to me.
A minimal (not very performant) implementation, which does not rely on handling errors (Python people think that's a reasonable way to program, I don't, although this is a stylistic choice), is, I think
(defun proper-list-p (l)
(typecase l
(null t)
(cons
(loop for tail = l then (cdr tail)
for seen = (list tail) then (push tail seen)
do (cond ((null tail)
(return t))
((not (consp tail))
(return nil))
((member tail (rest seen))
(return nil)))))))
This takes time quadratic in the length of l, and conses proportional to the length of l. You can obviously do better using an hashtable for the occurs check, and you can use a tortoise-&-hare algorithm do avoid the occurs check (but I'm not sure what the complexity of that is off the top of my head).
I am sure there are much better functions than this in libraries. In particular Alexandria has one.
While thinking about this question, I also wrote this function:
(defun classify-list (l)
"Classify a possible list, returning four values.
The first value is a symbol which is
- NULL if the list is empty;
- LIST if the list is a proper list;
- CYCLIC-LIST if it contains a cycle;
- IMPROPER-LIST if it does not end with nil;
- NIL if it is not a list.
The second value is the total number of conses in the list (following
CDRs only). It will be 0 for an empty list or non-list.
The third value is the cons at which the cycle in the list begins, or
NIL if there is no cycle or the list isn't a list.
The fourth value is the number if conses in the cycle, or 0 if there is no cycle.
Note that you can deduce the length of the leading element of the list
by subtracting the total number of conses from the number of conses in
the cycle: you can then use NTHCDR to pull out the cycle."
;; This is written as a tail recursion, I know people don't like
;; that in CL, but I wrote it for me.
(typecase l
(null (values 'null 0 nil 0 0))
(cons
(let ((table (make-hash-table)))
(labels ((walk (tail previous-tail n)
(typecase tail
(null
(values 'list n nil 0))
(cons
(let ((m (gethash tail table nil)))
(if m
(values 'cyclic-list n tail (- n m))
(progn
(setf (gethash tail table) n)
(walk (cdr tail) tail (1+ n))))))
(t
(values 'improper-list n previous-tail 0)))))
(walk l nil 0))))
(t (values nil 0 nil 0))))
This can be used to get a bunch of information about a list: how long it is, if it is proper, if not if it's cyclic, and where the cycle is. Beware that in the cases of cyclic lists this will return circular structure as its third value. I believe that you need to use an occurs check to do this – tortoise & hare will tell you if a list is cyclic, but not where the cycle starts.
in addition, something slightly less verbose, than the accepted answer:
(defun improper-tail (ls)
(do ((x ls (cdr x))
(visited nil (cons x visited)))
((or (not (consp x)) (member x visited)) x)))
(defun proper-list-p (ls)
(null (improper-tail ls)))
or just like this:
(defun proper-list-p (ls)
(do ((x ls (cdr x))
(visited nil (cons x visited)))
((or (not (consp x)) (member x visited)) (null x))))
seen to pass all the op's test assertions
After our hopeless attempts with tailp, here, sth which uses the
sharp-representation of circular lists :) .
With regex (to detect circular sublist)
(setf *print-circle* t)
(ql:quickload :cl-ppcre)
(defun proper-listp (lst)
(or (null lst) ; either a `'()` or:
(and (consp lst) ; a cons
(not (cl-ppcre::scan "#\d+=(" (princ-to-string lst)))) ; not circular
(null (cdr (last lst)))))) ; not a dotted list
Without regex (cannot detect circular sublists)
(defun proper-listp (lst)
(or (null lst) ; either a `'()` or:
(and (consp lst) ; a cons
(not (string= "#" (subseq (princ-to-string lst) 0 1))) ; not circular
(null (cdr (last lst)))))) ; not a dotted list
(tailp l (cdr l)) is t for circular lists but nil for non-circular lists.
Credits to #tfp and #RainerJoswig who taught me this here .
So, your function would be:
(defun proper-listp (lst)
(or (null lst) ; either a `'()` or:
(and (consp lst) ; a cons
(not (tailp lst (cdr lst))) ; not circular
(null (cdr (last lst)))))) ; not a dotted list
By the way, I use proper-listp by purpose. Correct would be - by convetion proper-list-p. However, this name is already occupied in the CLISP implementation by SYSTEM::%PROPER-LIST-Pwhy the definition of the function raises a continuable error.
Conclusion of our discussion in the comment section:
The behavior of tailp for circular lists is undefined. Therefore this answer is wrong! Thank you #Lassi for figuring this out!
I'm trying to reverse a list in Lisp, but I get the error: " Error: Exception C0000005 [flags 0] at 20303FF3
{Offset 25 inside #}
eax 108 ebx 200925CA ecx 200 edx 2EFDD4D
esp 2EFDCC8 ebp 2EFDCE0 esi 628 edi 628 "
My code is as follows:
(defun rev (l)
(cond
((null l) '())
(T (append (rev (cdr l)) (list (car l))))))
Can anyone tell me what am I doing wrong? Thanks in advance!
Your code as written is logically correct and produces the result that you'd want it to:
CL-USER> (defun rev (l)
(cond
((null l) '())
(T (append (rev (cdr l)) (list (car l))))))
REV
CL-USER> (rev '(1 2 3 4))
(4 3 2 1)
CL-USER> (rev '())
NIL
CL-USER> (rev '(1 2))
(2 1)
That said, there are some issues with it in terms of performance. The append function produces a copy of all but its final argument. E.g., when you do (append '(1 2) '(a b) '(3 4)), you're creating a four new cons cells, whose cars are 1, 2, a, and b. The cdr of the final one is the existing list (3 4). That's because the implementation of append is something like this:
(defun append (l1 l2)
(if (null l1)
l2
(cons (first l1)
(append (rest l1)
l2))))
That's not exactly Common Lisp's append, because Common Lisp's append can take more than two arguments. It's close enough to demonstrate why all but the last list is copied, though. Now look at what that means in terms of your implementation of rev, though:
(defun rev (l)
(cond
((null l) '())
(T (append (rev (cdr l)) (list (car l))))))
This means that when you're reversing a list like (1 2 3 4), it's like you're:
(append '(4 3 2) '(1)) ; as a result of (1)
(append (append '(4 3) '(2)) '(1)) ; and so on... (2)
Now, in line (2), you're copying the list (4 3). In line one, you're copying the list (4 3 2) which includes a copy of (4 3). That is, you're copying a copy. That's a pretty wasteful use of memory.
A more common approach uses an accumulator variable and a helper function. (Note that I use endp, rest, first, and list* instead of null, cdr, car, and cons, since it makes it clearer that we're working with lists, not arbitrary cons-trees. They're pretty much the same (but there are a few differences).)
(defun rev-helper (list reversed)
"A helper function for reversing a list. Returns a new list
containing the elements of LIST in reverse order, followed by the
elements in REVERSED. (So, when REVERSED is the empty list, returns
exactly a reversed copy of LIST.)"
(if (endp list)
reversed
(rev-helper (rest list)
(list* (first list)
reversed))))
CL-USER> (rev-helper '(1 2 3) '(4 5))
(3 2 1 4 5)
CL-USER> (rev-helper '(1 2 3) '())
(3 2 1)
With this helper function, it's easy to define rev:
(defun rev (list)
"Returns a new list containing the elements of LIST in reverse
order."
(rev-helper list '()))
CL-USER> (rev '(1 2 3))
(3 2 1)
That said, rather than having an external helper function, it would probably be more common to use labels to define a local helper function:
(defun rev (list)
(labels ((rev-helper (list reversed)
#| ... |#))
(rev-helper list '())))
Or, since Common Lisp isn't guaranteed to optimize tail calls, a do loop is nice and clean here too:
(defun rev (list)
(do ((list list (rest list))
(reversed '() (list* (first list) reversed)))
((endp list) reversed)))
In ANSI Common Lisp, you can reverse a list using the reverse function (nondestructive: allocates a new list), or nreverse (rearranges the building blocks or data of the existing list to produce the reversed one).
> (reverse '(1 2 3))
(3 2 1)
Don't use nreverse on quoted list literals; it is undefined behavior and may behave in surprising ways, since it is de facto self-modifying code.
You've likely run out of stack space; this is the consequence of calling a recursive function, rev, outside of tail position. The approach to converting to a tail-recursive function involves introducing an accumulator, the variable result in the following:
(defun reving (list result)
(cond ((consp list) (reving (cdr list) (cons (car list) result)))
((null list) result)
(t (cons list result))))
You rev function then becomes:
(define rev (list) (reving list '()))
Examples:
* (reving '(1 2 3) '())
(3 2 1)
* (reving '(1 2 . 3) '())
(3 2 1)
* (reving '1 '())
(1)
If you can use the standard CL library functions like append, you should use reverse (as Kaz suggested).
Otherwise, if this is an exercise (h/w or not), you can try this:
(defun rev (l)
(labels ((r (todo)
(if todo
(multiple-value-bind (res-head res-tail) (r (cdr todo))
(if res-head
(setf (cdr res-tail) (list (car todo))
res-tail (cdr res-tail))
(setq res-head (list (car todo))
res-tail res-head))
(values res-head res-tail))
(values nil nil))))
(values (r l))))
PS. Your specific error is incomprehensible, please contact your vendor.
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.
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?