I tried to implement a natural sort:
Break 21 [92]> (defparameter *sss* '("1.txt" "10.txt" "13.txt" "12.txt" "2.txt" "23.txt"))
*SSS*
Break 21 [92]> (sort *sss* #'string-lessp)
("1.txt" "10.txt" "12.txt" "13.txt" "2.txt" "23.txt")
Break 21 [92]>
Unfortunately, the code above does not work.
Could someone help me to get a natural sort function?
Here is a general string-natural-lessp:
(defun string-natural-lessp (string-a string-b
&key
(start-a 0)
(end-a (length string-a))
(start-b 0)
(end-b (length string-b)))
(do ((a-index start-a)
(b-index start-b))
((or (>= a-index end-a)
(>= b-index end-b))
(not (>= b-index end-b)))
(multiple-value-bind (a-int a-pos)
(parse-integer string-a
:start a-index
:junk-allowed t)
(multiple-value-bind (b-int b-pos)
(parse-integer string-b
:start b-index
:junk-allowed t)
(if (and a-int b-int)
(if (= a-int b-int)
(setf a-index a-pos
b-index b-pos)
(return-from string-natural-lessp (< a-int b-int)))
(if (char-equal (aref string-a a-index)
(aref string-b b-index))
(progn
(incf a-index)
(incf b-index))
(return-from string-natural-lessp
(char-lessp (aref string-a a-index)
(aref string-b b-index)))))))))
Depends on the use case, I guess. I'd try something like
(defun natural-compare (a b)
(labels ((int (str) (parse-integer str :junk-allowed t)))
(let ((n-a (int a))
(n-b (int b)))
(if (and n-a n-b (/= n-a n-b))
(<= n-a n-b)
(string<= a b)))))
(defun natural-sort (strings)
(sort (copy-list strings) #'natural-compare))
It works:
CL-USER> (defparameter *sss* '("1.txt" "test.txt" "36-test.txt" "36-taste.txt" "sicp.pdf" "answers.txt" "10.txt" "13.txt" "12.txt" "2.txt" "23.txt"))
*SSS*
CL-USER> (natural-sort *sss*)
("1.txt" "2.txt" "10.txt" "12.txt" "13.txt" "23.txt" "36-taste.txt"
"36-test.txt" "answers.txt" "sicp.pdf" "test.txt")
CL-USER>
but does a bit more work than it really needs to. Note that natural-sort copies the input list because sort is a destructive procedure.
Generate a proper sorting key for every element and then use those for comparison:
(defun skip-zeros (string offset length)
(do ((i offset (1+ i)))
((or (>= i length)
(not (eql (aref string i) #\0)))
i)))
(defun skip-digits (string offset length)
(do ((i offset (1+ i)))
((or (>= i length)
(not (digit-char-p (aref string i))))
i)))
(defun skip-alphas (string offset length)
(do ((i offset (1+ i)))
((or (>= i length)
(not (alpha-char-p (aref string i))))
i)))
(defun make-natural-sorting-key (string)
(let* ((length (length string))
(key (make-array (+ length 5)
:element-type 'character
:fill-pointer 0
:adjustable t))
(offset 0))
(do ()
((>= offset length) (coerce key 'simple-string))
(block eater
(let ((c (aref string offset))
(end))
(cond
((digit-char-p c) (setf offset (skip-zeros string offset length))
(setf end (skip-digits string offset length))
(do ((digits (- end offset) (- digits 9)))
((< digits 9) (vector-push-extend (digit-char digits) key))
(vector-push-extend #\9 key)))
((alpha-char-p c) (setf end (skip-alphas string offset length)))
(t (incf offset)
(return-from eater)))
(do ((i offset (1+ i)))
((>= i end))
(vector-push-extend (aref string i) key))
(vector-push-extend #\nul key)
(setf offset end))))))
(sort data #'string< :key #'make-natural-sorting-key)
Though, ensure that your sort implementation caches the keys.
Unfortunately, the code above does not work.
It looks like it worked. After all, you explicitly asked to sort by string comparison, and according to a string comparison, "2.txt" is between "13.txt", and "23.txt". If you want to sort numerically, you could use a key function that would read the number from the beginning of the string. Also, sort is destructive, so you shouldn't use it on literal data (like a quoted list).
At any rate, it's not too hard to cobble together something that will get you the sort of sorting that you're looking for. Here's a definition for a natural-string-lessp function:
(defun natural-string-lessp (a b)
(multiple-value-bind (ai aend)
(parse-integer a :junk-allowed t)
(multiple-value-bind (bi bend)
(parse-integer b :junk-allowed t)
(or (and ai
(or (not bi)
(and bi
(or (< ai bi)
(and (= ai bi)
(string-lessp a b :start1 aend :start2 bend))))))
(and (not ai)
(not bi)
(string-lessp a b))))))
It only handles the leading numbers, and not numbers in the middle of a string, so, e.g., "a-100-foo.txt" will still come before "a-3-foo.txt", but it might be sufficient for your needs. Here's an example of its use:
(let ((sss (copy-list '("1.txt" "10.txt" "13.txt" "12.txt"
"2.txt" "23.txt"))))
(sort sss #'natural-string-lessp))
;=> ("1.txt" "2.txt" "10.txt" "12.txt" "13.txt" "23.txt")
The documentation for parse-integer and the keyword arguments for string-lessp may be helpful.
A more robust implementation would figure out how to turn each string into a sequence of strings and numbers, (e.g., "12.txt" → (12 ".txt")) and then sort those lists lexicographically with an ordering among types (e.g., numbers before strings), and with an ordering within each type.
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))))
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.
(defun merge-matrix (matrix-1 matrix-2)
(if (not (or (eql (matrix-rows matrix-1) (matrix-rows matrix-2)) (null matrix-1) (null matrix-2))) (error "Invalid dimensions."))
(cond
((null matrix-1) (copy-tree matrix-2))
((null matrix-2) (copy-tree matrix-1))
(t (let ((result (copy-tree matrix-1)))
(dotimes (i (matrix-rows matrix-1))
(setf (nth i result) (nconc (nth i result) (nth i matrix-2))))
result))))
(merge-matrix '((3 1) (1 3)) '((4 2) (1 1)))
*** - EVAL: variable NULL has no value
I receive an error like that how I can fix the problem, thanks
The OP's code works for me. However I felt motivated to improve it and
I implemented the same idea (but a bit more powerful).
The semantics are the same as Matlab's vertcat.
The function appends all arguments into one big matrix.
Note that due to the declarations my code should be super efficient.
(deftype mat ()
"Non-square matrices. Last index is columns, i.e. row-major order."
`(simple-array single-float 2))
(defun are-all-elements-typep (type ls)
(reduce #'(lambda (b x) (and b (typep x type)))
ls))
(defun are-all-matrix-heights-equalp (ls)
(let ((first-height (array-dimension (first ls) 0)))
(reduce #'(lambda (b x) (and b
(= first-height
(array-dimension x 0))))
ls)))
(defun vertcat (&rest rest)
(declare (type cons rest))
(unless (are-all-elements-typep 'mat rest)
(break "At least one of the arguments isn't a matrix."))
(unless (are-all-matrix-heights-equalp rest)
(break "All Matrices must have the same number of rows."))
(let* ((height (array-dimension (first rest) 0))
(widths (mapcar #'(lambda (mat) (array-dimension mat 1)) rest))
(result (make-array (list height
(reduce #'+ widths))
:element-type 'single-float))
(current-width 0))
(dotimes (m (length rest))
(let ((e (elt rest m)))
(destructuring-bind (y x) (array-dimensions e)
(dotimes (j y)
(dotimes (i x)
(setf (aref result j (+ current-width i))
(aref e j i))))
(incf current-width (elt widths m)))))
(the mat result)))
#+nil
(let ((a (make-array '(2 3)
:initial-contents '((1s0 2s0 3s0)
(2s0 4s0 5s0))
:element-type 'single-float))
(b (make-array '(2 2)
:initial-contents '((6s0 7s0)
(9s0 8s0))
:element-type 'single-float)))
(vertcat a b a))
;=> #2A ((1.0 2.0 3.0 6.0 7.0 1.0 2.0 3.0) (2.0 4.0 5.0 9.0 8.0 2.0 4.0 5.0))
The error message you're getting suggests that lisp is trying to treat one of your calls to null as a variable. I was able to replicate this behavior by defining matrix-rows like Frank Shearar did and deleting the parentheses around the ((null matrix-1) (copy-tree matrix-2)) s-expression, for example. I'd suggest you check your parentheses, either manually or using something like SLIME, which gave me a warning when I tried to compile the function.
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?