I have a problem with this function two-similar-p.
(defun two-similar-p (list1 list2)
(mapcar
(lambda (e)
(mapcar
(lambda (e1)
(if (equal e e1) t))
list2))
list1))
But is not correct use mapcar because this function returns a new list with T or NIL, but I need only to return a true or false.
ex.
(two-similar-p '(2 1 3) '(1 2 3))
==> ((NIL T NIL) (T NIL NIL) (NIL NIL T))
I was thinking to use recursion to compare the various elements, but I have no idea how to do that.
My function needs to work like:
(two-similar-p '(1 2 3) '(1 4 5)) ; ==> nil
(two-similar-p '(1 2 5) '(1 4 5)) ; ==> t
(two-similar-p '(1 2 6) '(6 4 2)) ; ==> t
Any advice?
The easiest "off-the-shelf" solution is to check that the intersection contains at least two elements:
(defun two-similar-p (l1 l2)
(consp (cdr (intersection l1 l2 :test #'equal))))
A slightly less OTS solution is to use hash tables:
(defun two-similar-p (l1 l2)
(let ((h1 (make-hash-table :test 'equal))
(common 0))
(dolist (x l1)
(setf (gethash x h1) t))
(dolist (x l2)
(when (gethash x h1)
(incf common))
(when (>= common 2)
(return t)))))
The advantage of the second approach is that its complexity is O(len(l1) + len(l2)),
while the mapcar approach will be O(len(l1) * len(l2)).
The standard does not specify the complexity of intersection and friends, but most implementations take good care of their users here (IOW, the complexity will be linear, not quadratic).
Related
I have a list of two element sublists which will change and grow in the course of the program. I want to write a macro which takes a key and generates a case dynamically like:
;; This is the List for saving CASE clauses
(setf l '((number 2) (symbol 3)))
;; and i want to have the following expansion
(typecase 'y
(number 2)
(symbol 3))
I could have a macro which only refers to the global l:
(defmacro m (x)
`(typecase ,x ,#l))
which would expand correctly
(m 'y) ;expands to (TYPECASE 'Y (number 2) (symbol 3))
But how can i write the macro with a parameter for the list l so that it would work with other lists as well?
;; A macro which should generate the case based on the above list
(defmacro m (x l)
`(typecase ,x ,#l))
This doesn't work since l in the arguments list i a symbol and a call to (m 'y l) will expand to (TYPECASE 'Y . L).
Wanting to adhere to typecase mechanism, my workaround was as follows:
(setf types-x '(((integer 0 *) 38)
((eql neli) "Neli in X")
(symbol 39))
)
(setf types-y '(((eql neli) "Neli in Y")
((array bit *) "A Bit Vector")))
(defmacro m (x types-id)
(case types-id
(:x `(typecase ,x ,#types-x))
(:y `(etypecase ,x ,#types-y))))
(m 'neli :x) ;"Neli in X"
(m 'neli :y) ;"Neli in Y"
(m 'foo :x) ;39
Any hints and comments is appreciated.
You don't need a macro for what you're trying to do: use a function.
For instance, given
(defvar *type-matches*
'((float 0)
(number 1)
(t 3)))
Then
(defun type-match (thing &optional (against *type-matches*))
(loop for (type val) in against
when (typep thing type)
return (values val type)
finally (return (values nil nil))))
Will match a thing against a type:
> (type-match 1.0)
0
float
> (type-match 1)
1
number
You want to keep the variables sorted by type, which you can do by, for instance:
(setf *type-matches* (sort *type-matches* #'subtypep :key #'car))
You want to keep the matches sorted of course.
If you want to delay the execution of the forms then you can do something like this (this also deals with sorting the types):
(defvar *type-matches*
'())
(defmacro define-type-match (type/spec &body forms)
;; define a type match, optionally in a specified list
(multiple-value-bind (type var)
(etypecase type/spec
(symbol (values type/spec '*type-matches*))
(cons (values (first type/spec) (second type/spec))))
(let ((foundn (gensym "FOUND")))
`(let ((,foundn (assoc ',type ,var :test #'equal)))
(if ,foundn
(setf (cdr ,foundn) (lambda () ,#forms))
(setf ,var (sort (acons ',type (lambda () ,#forms) ,var)
#'subtypep :key #'car)))
',type/spec))))
(defun type-match (thing &optional (against *type-matches*))
(loop for (type . f) in against
when (typep thing type)
return (values (funcall f) type)
finally (return (values nil nil))))
The actual problem that you face is that if you do
(setf l '((number 2) (symbol 3)))
already on toplevel, if you evaluate l, you don't come further than
((number 2) (symbol 3))
So if you use l in a macro as an argument, you can't come further
than this. But what you need is to evaluate this form (modified after adding a typecase and an evaluated x upfront) once more within the macro.
This is, why #tfb suggested to write a function which actually evaluates the matching of the types specified in l.
So, we could regard his type-match function as a mini-interpreter for the type specifications given in l.
If you do a simple (defmacro m (x l) `(typecase ,x ,#l))
you face exactly that problem:
(macroexpand-1 '(m 1 l))
;; (typecase 1 . l)
but what we need is that l once more evaluated.
(defmacro m (x l)
`(typecase ,x ,#(eval l)))
Which would give the actually desired result:
(macroexpand-1 '(m 1 l))
;; (TYPECASE 1 (NUMBER 2) (SYMBOL 3)) ;
;; T
;; and thus:
(m 1 l) ;; 2
So far, it seems to work. But somewhere in the backhead it becomes itchy, because we know from books and community: "Don't use eval!! Eval in the code is evil!"
Trying around, you will find out when it will bite you very soon:
# try this in a new session:
(defmacro m (x l) `(typecase ,x ,#(eval l)))
;; m
;; define `l` after definition of the macro works:
(setf l '((number 2) (symbol 3)))
;; ((NUMBER 2) (SYMBOL 3))
(m 1 l)
;; 2 ;; so our `eval` can handle definitions of `l` after macro was stated
(m '(1 2) l)
;; NIL
;; even redefining `l` works!
(setf l '((number 2) (symbol 3) (list 4)))
;; ((NUMBER 2) (SYMBOL 3) (LIST 4))
(m 1 l)
;; 2
(m '(1 2) l)
;; 4 ;; and it can handle re-definitions of `l` correctly.
;; however:
(let ((l '((number 2) (symbol 3)))) (m '(1 2) l))
;; 4 !!! this is clearly wrong! Expected is NIL!
;; so our `eval` in the macro cannot handle scoping correctly
;; which is a no-go for usage!
;; but after re-defining `l` globally to:
(setf l '((number 2) (symbol 3)))
;; ((NUMBER 2) (SYMBOL 3))
(m '(1 2) l)
;; NIL ;; it behaves correctly
(let ((lst '((number 2) (symbol 3) (list 4)))) (m '(1 2) lst))
;; *** - EVAL: variable LST has no value
;; so it becomes clear: `m` is looking in the scoping
;; where it was defined - the global scope (the parent scope of `m` when `m` was defined or within the scope of `m`).
So the conclusion is:
The given macro with eval is NOT working correctly!!
Since it cannot handle local scoping.
So #tfb's answer - writing a mini-evaluator-function for l is the probably only way to handle this in a proper, safe, correct way.
Update
It seems to me that doing:
(defmacro m (x l)
`(typecase ,x ,#l))
(defun m-fun (x l)
(eval `(m ,x ,l)))
(m-fun ''y l) ;; 3
(m-fun 'y l) ;; error since y unknown
(let ((l '((number 2) (symbol 3) (list 4))))
(m-fun ''(1 2) l)) ;; => 4 since it is a list
(let ((l '((number 2) (symbol 3))))
(m-fun ''(1 2) l)) ;; => NIL since it is a list
(let ((l '((number 2) (symbol 3))))
(m-fun ''y l)) ;; => 3 since it is a symbol
(let ((n 12))
(m-fun n l)) ;; => 2 since it is a number
;; to improve `m-fun`, one could define
(defun m-fun (x l)
(eval `(m ',x ,l)))
;; then, one has not to do the strangely looking double quote
;; ''y but just one quote 'y.
(let ((l '((number 2) (symbol 3) (list 4))))
(m-fun '(1 2) l)) ;; => 4 since it is a list
;; etc.
at least hides the eval within a function.
And one does not have to use backquote in the main code.
Macro expansion happens at compile time, not run time, thus if the case clause list changes over the course of the program, the macro expansion will not change to reflect it.
If you want to dynamically select an unevaluated but changeable value, you can use assoc in the expansion instead of case:
(defmacro m (x l)
`(second (assoc ,x ,l)))
Sample expansion:
(m x l)
->
(SECOND (ASSOC X L))
Output of (assoc x l) with the value of l in your question and x = 'x:
(let ((x 'x))
(m x l))
->
2
However if you did decide to do it this way, you could simplify things and replace the macro with a function:
(defun m (x l)
(second (assoc x l)))
UPDATE FOR QUESTION EDIT:
Replace assoc as follows:
(defun m (x l)
(second (assoc-if (lambda (type)
(typep x type))
l)))
Hello i am trying to create a function in common-lisp that takes two lists, and output their intersections, assuming there is no repetition in each list without using intersection function. It seems that it is not working. Can anyone help?
(defun isect (lst_1 lst_2)
(setq newlist nil)
(dolist (x lst_1 newlist)
(dolist (y lst_2)
(if (equal x y) (setf newlist (append newlist x)))
)
)
)
I assume isect with both arguments being the same list should return an equal list and not one that is flattened. In that case (append newlist x) is not adding an element to the end of a list. Here is my suggestion:
(defun intersect (lst-a lst-b &aux result)
(dolist (a lst-a (nreverse result))
(dolist (b lst-b)
(when (equal a b)
(push a result)))))
This is O(n^2) while you can do it in O(n) using a hash table.
A built-in way (that won't work for homeworks ;) ) is to use intersection: https://lispcookbook.github.io/cl-cookbook/data-structures.html#intersection-of-lists
What elements are both in list-a and list-b ?
(defparameter list-a '(0 1 2 3))
(defparameter list-b '(0 2 4))
(intersection list-a list-b)
;; => (2 0)
If you can ensure that the lists are sorted (ascending) you could do something like
(defun isect (l1 l2 acc)
(let ((f1 (car l1))
(f2 (car l2))
(r1 (cdr l1))
(r2 (cdr l2)))
(cond ((or (null l1) (null l2)) acc)
((= f1 f2) (isect r1 r2 (cons f1 acc)))
((< f1 f2) (isect r1 l2 acc))
((> f1 f2) (isect l1 r2 acc)))))
Note though, that the result is in reversed order. Also, the example assumes that the
elements are numbers. If you wanted to generalize, you could pass an ordering as an optional argument to make it work with arbitrary elements.
NB: A solution using loop would likely be faster but I could not think of how to partially "advance" the lists when the cars are different.
;; the key function for simple lists
(defun id (x) x)
;; the intersect function for two lists
;; with sorting included:
;; you need an equality-test:
;; default is #'eql (for simple numbers or symbols this is sufficient)
;; - for numbers only #'=
;; - for characters only #'char=
;; - for strings only #'string=
;; - for lists #'equal
;; - for nearly everything #'equalp (case insensitive for char/strings!)
;; then you need also a sorting tester:
;; - increasing number: #'<
;; - decreasing number: #'>
;; - increasing char: #'char<
;; - decreasing char: #'char>
;; - increasing strings: #'string<
;; - decreasing strings: #'string>
;; - other cases I haven't think of - does somebody have an idea?
;; (one could sort by length of element etc.)
;; so sort-test should be a diadic function (function taking 2 arguments to compare)
;; then you also need an accessor function
;; so, how withing each element the to-be-sorted element should be accessed
;; for this, I prepared the `id` - identity - function because this is the
;; sort-key when simple comparison of the elements of the two lists
;; should be compared - and this function is also used for testing
;; for equality in the inner `.isect` function.
(defun isect (lst-1 lst-2 &key (equality-test #'eql) (sort-test #'<) (sort-key #'id))
(let ((lst-1-sorted (stable-sort lst-1 sort-test :key sort-key))
(lst-2-sorted (stable-sort lst-2 sort-test :key sort-key)))
(labels ((.isect (l1 l2 acc)
(cond ((or (null l1) (null l2)) (nreverse acc))
(t (let ((l1-element (funcall sort-key (car l1)))
(l2-element (funcall sort-key (car l2))))
(cond ((funcall sort-test l1-element l2-element)
(.isect (cdr l1) l2 acc))
((funcall equality-test l1-element l2-element)
(.isect (cdr l1) (cdr l2) (cons (car l1) acc)))
(t (.isect l1 (cdr l2) acc))))))))
(.isect lst-1-sorted lst-2-sorted '()))))
Simple tests:
(isect '(0 1 2 3 4 5 6) '(9 0 3 5 12 24 8 6))
;; => (0 3 5 6)
(isect '(#\a #\c #\h #\t #\e #\r #\b #\a #\h #\n)
'(#\a #\m #\s #\e #\l #\s #\t #\a #\r)
:equality-test #'char=
:sort-test #'char<
:key #'id)
;; => (#\a #\a #\e #\r #\t)
(isect '("this" "is" "just" "a" "boring" "test")
'("this" "boring" "strings" "are" "to" "be" "intersected")
:equality-test #'string=
:sort-test #'string<
:key #'id)
;; => ("boring" "this")
I'm having trouble finding my error.
This keeps returning nil:
(even-greater-n 5 '(1 2 3 4 5 6 7))
(defun even-greater-n (n L)
(cond ((null L) nil)
((and (> (car L) n) (evenp n)) (car L))
(t (even-greater-n n (cdr L)))))
Your error
You are passing to evenp n
instead of (car L).
Iteration
This is relatively easy to implement using
loop:
(defun even-greater (n l)
(loop for k in l
when (and (< n k)
(evenp k))
return k))
(even-greater 5 '(1 2 3 4 5 6 7 8))
==> 6
Recursion
If you are required to use recursion, you can do it too:
(defun even-greater (n l)
(cond ((endp l) nil)
((and (< n (first l))
(evenp (first l)))
(first l))
(t (even-greater n (rest l)))))
(even-greater 3 '(1 2 3 4 5 6 7 8))
==> 4
Library
And, of course, Lisp has a very powerful library, including
find-if:
(defun even-greater (n l)
(find-if (lambda (k)
(and (< n k)
(evenp k)))
l))
(even-greater 2 '(1 2 3 4 5 6 7 8))
==> 4
You must look for (car L) is even or not.
Using find-if and a single, open-coded lambda function:
(defun even-greater (n list)
(find-if (lambda (item) (and (> item n) (evenp item))) list))
Using functional combinators:
;; Combine multiple functions with AND:
;; Returns a function of one-argument which
;; passes that argument to the functions in the list,
;; one by one. If any function returns nil, it stops
;; and returns nil. Otherwise it returns the value
;; returned by the last function:
(defun andf (&rest functions)
(lambda (arg)
(let (res)
(dolist (f functions res)
(unless (setf res (funcall f arg))
(return))))))
;; Returns a one-argument function which tests
;; whether its argument is greater than quant.
(defun greater (quant)
(lambda (arg) (> arg quant)))
;; "find it, if it is greater than n, and even"
(defun even-greater (n list)
(find-if (andf (greater n) #'evenp) list))
so I have a program:
(defun add (L)
(cond((endp L) nil)
(t(cons(1+(first L)))(add(rest L)))))
that will add 1 to each member of the list. I want to check if the list is all numbers and return nil if not, and don't know how to go about doing that within the defun.
I thought of doing
(defun add (L)
(cond((endp L) nil)
((not(numberp(first L))) nil)
(t(cons(1+(first L)))(add(rest L)))))
but that will still return the beginning of the list if the non number is in the middle. How would I pre check and return nil at the beginning?
You can wrap it in a condition-case
(defun add (L)
(condition-case nil
(mapcar '1+ L)
(error nil)))
Another possibility is to use iteration:
(defun add (l)
(loop for x in l
if (numberp x)
collect (1+ x)
else do (return-from add nil)))
The function is immediately exited with nil on the first non numeric element.
You would not implement iteration using recursion, since Lisp already provides iteration constructs. Example: MAPCAR.
Common Lisp also provides control flow constructs like RETURN-FROM, where you return from a block. A function defined by DEFUN has a block with its name and BLOCK can also create a named block explicitly. Examples for both:
CL-USER 62 > (block mapping
(mapcar (lambda (item)
(if (numberp item)
(1+ item)
(return-from mapping nil)))
'(1 2 3 nil 5 6)))
NIL
CL-USER 63 > (block mapping
(mapcar (lambda (item)
(if (numberp item)
(1+ item)
(return-from mapping nil)))
'(1 2 3 4 5 6)))
(2 3 4 5 6 7)
As function:
CL-USER 64 > (defun increment-list (list)
(mapcar (lambda (item)
(if (numberp item)
(1+ item)
(return-from increment-list nil)))
list))
INCREMENT-LIST
CL-USER 65 > (increment-list '(1 2 3 4 5 6))
(2 3 4 5 6 7)
CL-USER 66 > (increment-list '(1 2 3 nil 5 6))
NIL
I'd say that an idiomatic way, in Common Lisp, of checking that all elements in a list are numbers would be (every #'numberp the-list), so I would probably write this as:
(defun add-1 (list)
(when (every #'numberp list)
(mapcar #'1+ list)))
It would be possible to use (if ...) or (and ...), but in this case I would argue that (when ...) makes for the clearest code.
The difficulty is that propagating nil results in the nil at the end of the list causing everything to be nil. One solution is to check that add returns nil but (rest xs) is not nil. However, IMO it is more straightforward to just iterate over the list twice, checking for numbers the first time and then doing the addition on the second iteration.
Try this:
(defun add (xs)
(cond ((endp xs) nil)
((not (numberp (car xs))) nil)
(t (let ((r (add (rest xs))))
(cond ((and (not r) (rest xs)) nil)
(t (cons (1+ (first xs)) r)))))))
Barring mistakes on my end, this results in:
(add '()) => nil
(add '(1 2)) => '(2 3)
(add '(x y)) => nil
(add '(1 2 y)) => nil
EDIT: Without let. This results in 2^(n+1)-1 calls to add for a list of length n.
(defun add (xs)
(cond ((endp xs) nil)
((not (numberp (car xs))) nil)
(t (cond ((and (not (add (rest xs))) (rest xs)) nil)
(t (cons (1+ (first xs)) (add (rest xs)))))))))
I have a list of lists: (setq xs (list (list 1 2 3) (list 4 5 6) (list 7 8 9))). I want to remove a first element from each list to get ((2 3) (5 6) (8 9)). It's easy to do it non-destructively: (mapcar 'cdr xs). But I want mutate the original list. I tried:
(mapcar (lambda (x) (setf x (cdr x))) xs)
(mapcar (lambda (x) (pop x)) xs)
But it doesn't work. How to change each list of xs variable in-place, without creating any temporary lists, as efficiently as possible?
Use MAP-INTO:
CL-USER 16 > (let ((s (list (list 1 2 3)
(list 4 5 6)
(list 7 8 9))))
(map-into s #'rest s))
((2 3) (5 6) (8 9))
#Rainer Joswig's answer is correct, use map-into. The link gives example implementation using loop macro. If you want to implement map-into from scratch, or you use Emacs Lisp, you can also do it using dotimes. In Emacs Lisp dotimes is implemented in subr.el and doesn't require CL package. This is map-into with 1 sequence to map into the result sequence:
(defun map-into (r f xs)
(dotimes (i (min (length r) (length xs)) r)
(setf (elt r i)
(funcall f (elt xs i)))))
For version with variable amount of sequences we must sprinkle our code with apply and mapcar:
(defun map-into (r f &rest xss)
(dotimes (i (apply 'min (length r) (mapcar 'length xss)) r)
(setf (elt r i)
(apply f (mapcar (lambda (s) (elt s i))
xss)))))
We see, however, that elt inside dotimes makes our algorithm work in O(n2). We can optimize it to work in O(n) by using mapl (thanks #Joshua Taylor).
(defun map-into (rs f xs)
(mapl (lambda (r x) (setf (car r) (funcall f (car x)))) rs xs))
(defun map-into (rs f &rest xss)
(mapl (lambda (r xs)
(setf (car r)
(apply f (car xs))))
rs
(apply 'mapcar 'list xss))) ;; transpose a list of lists
The reason setf doesn't work inside mapcar is that setf is a complex macro that expands into expression that can manipulate the data it mutates. In a lambda scope inside mapcar it has access only to a variable, local to this lambda, not to the sequence passed to mapcar itself, so how should it know, where to put a modified value back? That's why mapcar code in the question returns modified list of lists but doesn't mutate it in-place. Just try (macroexpand '(setf (elt xs 0) (funcall 'cdr (elt xs 0)))) and see for yourself.