I am supposed to find the path from the root to a given node in LISP. Preferably using a purely functional approach.
The binary tree representation uses sublists, e.g.:
(A (B) (C (D) (E))) - A is the root, B the left child of A, C the right child of A, D the left child of C and E the right child of C.
It seems to me that there should be some way to avoid the duplication of the following function calls:
(get-path (cadr l) x)
(get-path (caddr l) x)
I am new to LISP and I don't know and can't seem to find a solution for this, but I think there must be a -purely- functional way to do it. Maybe using lambdas? Not sure how, though. Am I using a wrong approach? Any kind of help is highly appreciated.
;;; l is the list with the binary tree
;;; x is the node we are looking for
(defun get-path(l x)
(cond
;; nothing to search for anymore
((null l) nil)
;; found the node we were looking for
;; in this case we return a list containing only x
((equal (car l) x) (list x))
;; the node was found on the left branch
((not(equal (get-path (cadr l) x) nil))
(cons (car l) (get-path (cadr l) x)))
;; the node was found on the right branch
((not(equal (get-path (caddr l) x) nil))
(cons (car l) (get-path (caddr l) x)))))
What about this?
(defun root-path (tree element)
(when tree
(cons (first tree)
(unless (eql (first tree) element)
(or (root-path (second tree) element)
(root-path (third tree) element)
(return-from root-path nil))))))
You should even define meaningfully named functions, like tree-value left-subtree and right-subtree, but this is maybe overkill here.
In the above, note that when (resp. unless) is used for its nil value when the condition fails (resp. succeed). You can translate with cond or if expressions if you prefer. The only repetition here is the double (first tree) value, which might be optimized away by the compiler or manually with a surrounding let binding.
Edit
The original code was not working. The solution is to use Joshua's answer, but I won't copy paste it here, so I added the return-from expression. While it works, your teacher and/or coworker will probably not like this approach ;-)
Tests
(mapcar (lambda (n) (root-path '(A (B) (C (D) (E))) n))
'(a b c d e f))
=> ((a) (a b) (a c) (a c d) (a c e) nil)
I'd combine the final two cond clauses. You want to check the left side and see if there's a path there, and if there is, take it, and if there's not, check the right side. Then, whichever one of those yielded a path (if either did), you want to append to that. That could look like this. First, a couple of functions for convenience:
(defun element (tree)
(first tree))
(defun left (tree)
(second tree))
(defun right (tree)
(third tree))
Now, the real meat of the solution:
(defun get-path (element tree)
(cond
;; A null tree is empty and doesn't match anything.
((null tree) '())
;; If the element of this tree is the element, then we have a
;; partial path of length 1: (ELEMENT).
((eql element (element tree)) (list element))
;; Othweise, let PATH be the path on the left or the path on the
;; right, whichever exists.
(t (let ((path (or (get-path element (left tree))
(get-path element (right tree)))))
;; If there's no path on either side, then return NIL.
;; Otherwise, prepend the current element onto the path that
;; exists.
(if (null path) '()
(list* (element tree) path))))))
Note that list* does the same thing as cons, but it makes it clearer that you're working with lists, not just cons cells. You could use cons just as well.
We can confirm that this works as expected:
(defparameter *tree* '(A (B) (C (D) (E))))
(get-path 'c *tree*) ;;=> (A C)
(get-path 'd *tree*) ;;=> (A C D)
(get-path 'f *tree*) ;;=> NIL
Use labels for interior (local) functions:
(defun get-path(l x)
(labels ((prepend-path (elt)
(cons (car l) (get-path elt x))))
(cond
;; nothing to search for anymore
((null l) nil)
;; found the node we were looking for
;; in this case we return a list containing only x
((equal (car l) x) (list x))
;; the node was found on the left branch
((not(equal (get-path (cadr l) x) nil))
(prepend-path (cadr l)))
;; the node was found on the right branch
((not(equal (get-path (caddr l) x) nil))
(prepend-path (caddr l))))))
Alternatively, you could use flet instead of labels because you don't have interior functions that refer to each other. Personally, I use labels and hardly ever use flet for that reason (plus the overhead of re-indenting the function.)
What you can do is replicate the anaphoric conda and ifa macros from TXR Lisp in Common Lisp. (Source code here; good luck!)enter link description here
Then you can write it like this, referring to the get-path expressions using the anaphoric it variable.
(conda
;; nothing to search for anymore
((null l) nil)
;; found the node we were looking for
;; in this case we return a list containing only x
((equal (car l) x) (list x))
;; the node was found on the left branch
((not (equal (get-path (cadr l) x) nil)) (cons (car l) it))
;; the node was found on the right branch
((not (equal (get-path (caddr l) x) nil)) (cons (car l) it)))
conda is clever about expressions of the form (not x) and (null x) (also (false x) in TXR Lisp). If the test expression is one of these, then it recurses into the x do ferret out the "anaphoric it".
Note that it binds to places not just to values. Not only is the target of it not evaluated more than once, if the target is a place, then it refers to that place:
(ifa (< x 10)
(inc it)) ;; increments x.
This aspect of ifa is achieved with the help of the placelet macro, which doesn't exist in Common Lisp. A quick and dirty substitute would be to use symbol-macrolet. The only problem is that that a symbol macro denoting a place allows multiple evaluation of the place whereas placelet evaluates a place once. The resulting lexical symbol then denotes the storage location, rather than the overall expression.
ifa was designed to either wipe the floor with Paul Graham's aif, or else to complement it; conda is trivially based on ifa.
By the way, do not write expressions like
(not (equal whatever nil))
in Lisp! Firstly, equal equality is not particularly meaningful if you are comparing with nil; only nil is equal to nil, and that is according to eq equality, so you might as well have:
(not (eq whatever nil))
Secondly, for something not to be eq to nil means that the something is true. That is to say:
(if (not (eq foo nil)) do-this) ---same-as--> (if foo do-this)
!
If we refactor your code to get rid of this stuff, then it's better if we have the Paul Graham Style anaphoric if aif (and an acond based on it). That is to say:
(ifa (not (equal (get-path whatever) nil))) (list it))
becomes:
(aif (get-path whatever) (list it))
where the it trivially to the value of the entire test expression, rather than a somewhat cleverly selected constituent of that expression.
Under ifa, this is expressed slightly more verbosely using:
(ifa (true (get-path whatever)) (list it))
Where true can be defined as
(defun true (x) (identity x)).
Without this extra wrapping, ifa will bind it to whatever.
Related
I'm trying to create a function that would test whether the given list is circular with a re-starting point being the beginning of the list.
Expected results:
(setq liste '(a b c))
(rplacd (cddr liste) liste)
(circular liste) => t
(circular '(a b c a b c)) => nil
As I simply want to test if any subsequent item is 'eq' to the first one, I don't want to build the whole tortoise and hare algorithm.
Here is my code :
(defun circular (liste)
(let (beginningliste (car liste)))
(labels ( (circ2 (liste)
(cond
((atom liste) nil)
((eq (car liste) beginningliste) t)
(t (circ2 (cdr liste)))
) ) ) ) )
It doesn't give the expected result but I don't understand where my error is
I'm not sure I'm using 'labels' correctly
Is there a way to do that without using 'labels'?
Edit. I guess I have answered my third question as I think I have found a simpler way. Would this work?
(defun circular (liste)
(cond
((atom liste) nil)
((eq (car liste) (cadr liste)) t)
(t (circular (rplacd liste (cddr liste))))
)
)
First, the behavior is undefined when you mutate constant data: when you quote something (here the list), the Lisp environment has the right to treat it as a constant. See also this question for why defparameter or defvar is preferred over setq. And so...
(setq list '(a b c))
(rplacd (cddr list) list)
... would be better written as:
(defparameter *list* (copy-list '(a b c)))
(setf (cdr (last *list*)) *list*)
Second, your code is badly formatted and has bad naming conventions (please use dashes to separate words); here it is with a conventional layout, with the help of emacs:
(defun circularp (list)
(let (first (car list)))
(labels ((circ2 (list)
(cond
((atom list) nil)
((eq (car list) first) t)
(t (circ2 (cdr list))))))))
With that formatting, two things should be apparent:
The let contains no body forms: you define local variables and never use them; you could as well delete the let line.
Furthermore, the let is missing one pair of parenthesis: what you wrote defines a variable name first and another one named car, bound to list. I presume you want to define first as (car list).
You define a local circ2 function but never use it. I would expect the circularp function (the -p is for "predicate", like numberp, stringp) to call (circ2 (cdr list)). I prefer renaming circ2 as visit (or recurse), because it means something.
With the above corrections, that would be:
(defun circularp (list)
(let ((first (car list)))
(labels ((visit (list)
(cond
((atom list) nil)
((eq (car list) first) t)
(t (visit (cdr list))))))
(visit (cdr list)))))
However, if your list is not circular but contains the same element multiple times (like '(a a b)), you will report it as circular, because you inspect the data it holds instead of the structure only. Don't look into the CAR here:
(defun circularp (list)
(let ((first list))
(labels ((visit (list)
(cond
((atom list) nil)
((eq list first) t)
(t (visit (cdr list))))))
(visit (cdr list)))))
Also, the inner function is tail recursive but there is no guarantee that a Common Lisp implementation automatically eliminates tail calls (you should check with your implementation; most can do it on request). That means you risk allocating as many call stack frames as you have elements in the list, which is bad. Better use a loop directly:
(defun circularp (list)
(loop
for cursor on (cdr list)
while (consp cursor)
thereis (eq cursor list)))
Last, but not least: your approach is a very common one but fails when the list is not one big circular chain of cells, but merely contains a loop somewhere. Consider for example:
CL-USER> *list*
#1=(A B C . #1#)
CL-USER> (push 10 *list*)
(10 . #1=(A B C . #1#))
CL-USER> (push 20 *list*)
(20 10 . #1=(A B C . #1#))
(see that answer where I explain what #1= and #1# mean)
The lists with numbers in front exhibit circularity but you can't just use the first cons cell as a marker, because you will be looping forever inside the sublist that is circular. This is the kind or problems the Tortoise and Hare algorithm solves (there might be other techniques, the most common being storing visited elements in a hash table).
After your last edit, here is what I would do if I wanted to check for circularity, in a recursive fashion, without labels:
(defun circularp (list &optional seen)
(and (consp list)
(or (if (member list seen) t nil)
(circularp (cdr list) (cons list seen)))))
We keep track of all the visited cons cells in seen, which is optional and initialized to NIL (you could pass another value, but that can be seen as a feature).
Then, we say that a list is circular with respect to seen if it is a cons cell which either: (i) already exists in seen, or (ii) is such that its CDR is circular with respect to (cons list seen).
The only additional trick here is to ensure the result is a boolean, and not the return value of member (which is the sublist where the element being searched for is the first element): if your environment has *PRINT-CIRCLE* set to NIL and the list is actually circular, you don't want it to try printing the result.
Instead of (if (member list seen) t nil), you could also use:
(when (member list seen))
(position list seen)
and of course (not (not (member list seen)))
I want to ask why this function doesn't work...
(defun nenum(ls)
(cond
((null ls) nil)
((listp car(ls)) (nenum (rest ls)))
((numberp car(ls)) (nenum (rest ls)))
(t (cons (car ls) (nenum (rest ls))))))
Example: (nenum '(l 1 i (b) (5) s -2 p)) --> (l i s p)
Thank you!
Looking at the predicate you have in one of your cond terms:
(listp car (ls))
Thus apply the function listp with the two arguments car and the result of calling the function ls with no arguments. car and ls both need to be free variables and listp needs to be a different function than the one defined in CLHS since it only takes one argument.
Perhaps you have though you were writing Algol? An Algol function call look like operator(operand) but not CL. CL is a LISP dialect and we have this form on our function calls:
(operand operator)
If we nest we do the same:
(operand (operand operator))
You got it right in the alternative (cons (car ls) (nenum (rest ls)))
Replace car(ls) with (car ls).
Here's a much easier way to write that function:
(defun nenum (list)
(remove-if (lambda (item)
(or (listp item)
(numberp item)))
list))
Note that NIL doesn't need its own test because listp covers it.
There's no need to write a function like this from scratch. Common Lisp already provides remove-if, and you can give it a predicate that matches numbers and non-atoms:
CL-USER> (remove-if #'(lambda (x)
(or (numberp x)
(not (atom x))))
'(l 1 i (b) (5) s -2 p))
;=> (L I S P)
Or, to make it even clearer that you're keeping non-numeric atoms, you can use remove-if-not with a predicate that checks for numeric atoms:
CL-USER> (remove-if-not #'(lambda (x)
(and (atom x)
(not (numberp x))))
'(l 1 i (b) (5) s -2 p))
;=> (L I S P)
Note that the empty list, which is often written as (), is just the symbol nil. As such, it too is a non-numeric atom. If you'd want to keep other symbols, e.g.,
CL-USER> (remove-if-not #'(lambda (x)
(and (atom x)
(not (numberp x))))
'(li (b) -1 (5) sp))
;=> (LI SP)
then you'll probably want to keep nil as well:
CL-USER> (remove-if-not #'(lambda (x)
(and (atom x)
(not (numberp x))))
'(van (b) () (5) a))
;=> (VAN NIL A)
I'm a beginner in lisp and I need somebody to explain to me how the prog form works, step by step. What is the initial value of l1 ? Nil ?
The problem outputs T if the list has an even number of elements on the first level, nil if not.
(defun nr_par (l)
(prog ((l1 l))
ciclu
(cond
((null l1) (return T))
((null (cdr l1)) (return NIL))
((null (cddr l1)) (return T))
(T (setf l1 (cddr l1))
(go ciclu)))))
On console:
(nr_par '(1 2 3 4 5 6 7 8))
T
The program is straightforward, but not very idiomatic lisp (it is rather imperative instead of functional). Step by step goes as follows.
prog uses a series of variable bindings, in this case, l1 is assigned the value of l initially. Then, a series of statements in which a loop starts (again, not very lisp idiomatic).
This type of loops use a tag (ciclu) and a goto instruction (go), again, not recommended, but it is there. After that, the cond checks a series of cases. When the list is empty (null), you return true, in other cases, you check if the length is even or odd, and return the value in consequence.
In the case that the list is longer than one or two elements (neither of the cases is null), the l1 list is adjusted to point to the next of the next element of itself (the cddr function).
Finally, the go function turns the program back to the ciclu tag.
The program will finish when any of the cond clauses is met, returning either T or NIL.
See PROG in CLHS: L1 is var, L is init-form, so the initial value of L1 is the value of L.
As the CLHS page for prog says, it does three things: lets you have local vars and initialize them; lets you have tags as in tagbody and use go; and lets you use return as inside a block named NIL:
(defun nr_par (l)
(prog ((l1 l)) ; local binding(s)
ciclu
(if (null l1) (return T)) ; return
(if (null (cdr l1)) (return NIL))
(setf l1 (cddr l1))
(go ciclu))) ; go
(defun nr_par1 (l) ; directly equivalent
(labels ((ciclu (l1)
(if (null l1) (return-from ciclu T))
(if (null (cdr l1)) (return-from ciclu NIL))
(ciclu (cddr l1))))
(ciclu l)))
(defun nr_par2 (l) ; also equivalent
(do ((l1 l (cddr l1)))
(NIL) ; while T ...
(cond
((null l1) (return T))
((null (cdr l1)) (return NIL)))))
Function call is a glorified goto after all, isn't it?
See also Longest decreasing sequence in Lisp for an example representing several mutually-recursive functions hand-compiled into a prog with a bunch of GO statements.
I have a lisp homework I am having a hard time with it.
I have to write a function that perform a union operation. The function takes 2 inputs, either in the form of either atom or list and unions every element, preserving the order and stripping off all levels of parenthesis.
The output for the function:
(my-union 'a 'b) ;; (a b)
(my-union 'a '(b)) ;; (a b)
(my-union '(a b) '(b c)) ;; (a b c)
(my-union '(((a))) '(b(c((d e))a))) ;; (a b c d e)
I am fairly new to lisp.
Here is what I have written so far and it works only for the third example:
(defun new-union (a b)
(if (not b)
a
(if (member (car b) a)
(new-union a (cdr b))
(new-union (append a (list (car b))) (cdr b)))))
Any help would be appreciated!
Since this is your first homework, and you are new to Lisp, here is a very simple top-down approach, not worrying about performance, and making good use of the tools CL offers:
In Common Lisp, there is already a function which removes duplicates: remove-duplicates. Using it with the :from-end keyword-argument will "preserve order". Now, imagine you had a function flatten, which flattens arbitrarily nested lists. Then the solution to your question would be:
(defun new-union (list1 list2)
(remove-duplicates (flatten (list list1 list2)) :from-end t))
This is how I would approach the problem when no further restrictions are given, and there is no real reason to worry much about performance. Use as much of the present toolbox as possible and do not reinvent wheels unless necessary.
If you approach the problem like this, it boils down to writing the flatten function, which I will leave as an exercise for you. It is not too hard, one easy option is to write a recursive function, approaching the problem like this:
If the first element of the list to be flattened is itself a list, append the flattened first element to the flattened rest. If the first element is not a list, just prepend it to the flattened rest of the list. If the input is not a list at all, just return it.
That should be a nice exercise for you, and can be done in just a few lines of code.
(If you want to be very correct, use a helper function to do the work and check in the wrapping function whether the argument really is a list. Otherwise, flatten will work on atoms, too, which may or may not be a problem for you.)
Now, assuming you have written flatten:
> (defun new-union (list1 list2)
(remove-duplicates (flatten (list list1 list2)) :from-end t))
NEW-UNION
> (new-union 'a 'b)
(A B)
> (new-union 'a '(b))
(A B)
> (new-union '(a b) '(b c))
(A B C)
> (new-union '(((a))) '(b (c ((d e)) a)))
(A B C D E)
One way to approach this is to separate your concerns. One is flattening; another is duplicates-removing; yet another is result-building.
Starting with empty list as your result, proceed to add into it the elements of the first list, skipping such elements that are already in the result.
Then do the same with the second list's elements, adding them to the same result list.
(defun my-union (a b &aux (res (list 1)) (p res))
(nadd-elts p a)
(nadd-elts p b)
(cdr res))
nadd-elts would add to the end of list, destructively updating its last cell (pointed to by p) using e.g. rplacd. An example is here.
To add elements, nadd-elts would emulate the flattening procedure, and add each leaf element into p after checking res for duplicates.
Working in functional style, without destructive update, the general approach stays the same: start with empty result list, add first list into it - without duplicates - then second.
(defun my-union (a b &aux res)
(setq res (add-into res a))
(setq res (add-into res b))
res)
Now we're left with implementing the add-into function.
(defun add-into (res a &aux r1 r2)
(cond
((atom a) .... )
(T (setq r1 (add-into res (car a)))
(setq r2 (............ (cdr a)))
r2)))
The above can be re-written without the auxiliary variables and without set primitives. Try to find out how... OK here's what I meant by that:
(defun my-union (a b) (add-into NIL (cons a b)))
(defun add-into (res a)
(cond
((atom a) .... )
(T (add-into (add-into res (car a))
(cdr a)))))
Unless you are not allowed to use hash table (for some reason I've encountered this as a requirement before), you could come up with an ordering function that will help you build the resulting set in the way, that you don't have to repeat the search over and over again.
Also, since nested lists are allowed your problem scales down to only removing duplicates in a tree (as you can simply append as many lists as you want before you start processing them.
Now, I'll try to show few examples of how you could do it:
;; Large difference between best and worst case.
;; Lists containing all the same items will be processed
;; in square time
(defun union-naive (list &rest lists)
(when lists (setf list (append list lists)))
(let (result)
(labels ((%union-naive (tree)
(if (consp tree)
(progn
(%union-naive (car tree))
(when (cdr tree) (%union-naive (cdr tree))))
(unless (member tree result)
(setq result (cons tree result))))))
(%union-naive list) result)))
;; Perhaps the best solution, it is practically linear time
(defun union-hash (list &rest lists)
(when lists (setf list (append list lists)))
(let ((hash (make-hash-table)) result)
(labels ((%union-hash (tree)
(if (consp tree)
(progn
(%union-hash (car tree))
(when (cdr tree) (%union-hash (cdr tree))))
(setf (gethash tree hash) t))))
(%union-hash list))
(maphash
#'(lambda (a b)
(declare (ignore b))
(push a result)) hash)
result))
;; This will do the job in more time, then the
;; solution with the hash-map, but it requires
;; significantly less memory. Memory is, in fact
;; a more precious resource some times, but you
;; have to decide what algo to use based on the
;; data size
(defun union-flatten (list &rest lists)
(when lists (setf list (append list lists)))
(labels ((%flatten (tree)
(if (consp tree)
(if (cdr tree)
(nconc (%flatten (car tree))
(%flatten (cdr tree)))
(%flatten (car tree)))
(list tree))))
;; the code below is trying to do something
;; that you could've done using
;; (remove-duplicates (%flatten list))
;; however sorting and then removing duplicates
;; may prove to be more efficient
(reduce
#'(lambda (a b)
(cond
((atom a) (list a))
((eql (car a) b) b)
(t (cons b a))))
(sort (%flatten list)
#'(lambda (a b)
(string< (symbol-name a)
(symbol-name b)))))))
(union-naive '(((a))) '(b(c((d e))a)))
(union-hash '(((a))) '(b(c((d e))a)))
(union-flatten '(((a))) '(b(c((d e))a)))
Notice that the function I've used to order elements is not universal, but you would probably be able to come up with an alternative function for any sort of data. Any fast hashing function in general would do, I've used this one for simplicity.
How can I remove nested parentheses recursively in Common LISP Such as
(unnest '(a b c (d e) ((f) g))) => (a b c d e f g)
(unnest '(a b)) => (a b)
(unnest '(() ((((a)))) ())) => (a)
Thanks
Here's what I'd do:
(ql:quickload "alexandria")
(alexandria:flatten list)
That works mainly because I have Quicklisp installed already.
(defun flatten (l)
(cond ((null l) nil)
((atom l) (list l))
(t (loop for a in l appending (flatten a)))))
I realize this is an old thread, but it is one of the first that comes up when I google lisp flatten. The solution I discovered is similar to those discussed above, but the formatting is slightly different. I will explain it as if you are new to lisp, as I was when I first googled this question, so it's likely that others will be too.
(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))))))
For those new to lisp, this is a brief summary.
The following line declares a function called flatten with argument L.
(defun flatten (L)
The line below checks for an empty list.
(if (null L)
The next line returns nil because cons ATOM nil declares a list with one entry (ATOM). This is the base case of the recursion and lets the function know when to stop. The line after this checks to see if the first item in the list is an atom instead of another list.
(if (atom (first L))
Then, if it is, it uses recursion to create a flattened list of this atom combined with the rest of the flattened list that the function will generate. cons combines an atom with another list.
(cons (first L) (flatten (rest L)))
If it's not an atom, then we have to flatten on it, because it is another list that may have further lists inside of it.
(append (flatten (first L)) (flatten (rest L))))))
The append function will append the first list to the start of the second list.
Also note that every time you use a function in lisp, you have to surround it with parenthesis. This confused me at first.
You could define it like this for example:
(defun unnest (x)
(labels ((rec (x acc)
(cond ((null x) acc)
((atom x) (cons x acc))
(t (rec (car x) (rec (cdr x) acc))))))
(rec x nil)))
(defun flatten (l)
(cond ((null l) nil)
((atom (car l)) (cons (car l) (flatten (cdr l))))
(t (append (flatten (car l)) (flatten (cdr l))))))
Lisp has the function remove to remove things. Here I use a version REMOVE-IF that removes every item for which a predicate is true. I test if the thing is a parenthesis and remove it if true.
If you want to remove parentheses, see this function:
(defun unnest (thing)
(read-from-string
(concatenate
'string
"("
(remove-if (lambda (c)
(member c '(#\( #\))))
(princ-to-string thing))
")")))
Note, though, as Svante mentions, one does not usually 'remove' parentheses.
Most of the answers have already mentioned a recursive solution to the Flatten problem. Using Common Lisp Object System's multiple dispatching you could solve the problem recursively by defining 3 methods for 3 possible scenarios:
(defmethod flatten ((tree null))
"Tree is empty list."
())
(defmethod flatten ((tree list))
"Tree is a list."
(append (flatten (car tree))
(flatten (cdr tree))))
(defmethod flatten (tree)
"Tree is something else (atom?)."
(list tree))
(flatten '(2 ((8) 2 (9 (d (s (((((a))))))))))) ; => (2 8 2 9 D S A)
Just leaving this here as I visited this question with the need of only flattening one level and later figure out for myself that (apply 'concatenate 'list ((1 2) (3 4) (5 6 7))) is a cleaner solution in that case.
This is a accumulator based approach. The local function %flatten keeps an accumulator of the tail (the right part of the list that's already been flattened). When the part remaining to be flattened (the left part of the list) is empty, it returns the tail. When the part to be flattened is a non-list, it returns that part prefixed onto the tail. When the part to be flattened is a list, it flattens the rest of the list (with the current tail), then uses that result as the tail for flattening the first part of the list.
(defun flatten (list)
(labels ((%flatten (list tail)
(cond
((null list) tail)
((atom list) (list* list tail))
(t (%flatten (first list)
(%flatten (rest list)
tail))))))
(%flatten list '())))
CL-USER> (flatten '((1 2) (3 4) ((5) 6) 7))
(1 2 3 4 5 6 7)
I know this question is really old but I noticed that nobody used the push/nreverse idiom, so I am uploading that here.
the function reverse-atomize takes out each "atom" and puts it into the output of the next call. At the end it produces a flattened list that is backwards, which is resolved with the nreverse function in the atomize function.
(defun reverse-atomize (tree output)
"Auxillary function for atomize"
(if (null tree)
output
(if (atom (car tree))
(reverse-atomize (cdr tree) (push (car tree) output))
(reverse-atomize (cdr tree) (nconc (reverse-atomize (car tree)
nil)
output)))))
(defun atomize (tree)
"Flattens a list into only the atoms in it"
(nreverse (reverse-atomize tree nil)))
So calling atomize '((a b) (c) d) looks like this:
(A B C D)
And if you were to call reverse-atomize with reverse-atomize '((a b) (c) d) this would occur:
(D C B A)
People like using functions like push, nreverse, and nconc because they use less RAM than their respective cons, reverse, and append functions. That being said the double recursive nature of reverse-atomize does come with it's own RAMifications.
This popular question only has recursive solutions (not counting Rainer's answer).
Let's have a loop version:
(defun flatten (tree &aux todo flat)
(check-type tree list)
(loop
(shiftf todo tree nil)
(unless todo (return flat))
(dolist (elt todo)
(if (listp elt)
(dolist (e elt)
(push e tree))
(push elt flat))))))
(defun unnest (somewhat)
(cond
((null somewhat) nil)
((atom somewhat) (list somewhat))
(t
(append (unnest (car somewhat)) (unnest (cdr somewhat))))))
I couldn't resist adding my two cents. While the CL spec does not require tail call optimization (TCO), many (most?) implementations have that feature.
So here's a tail recursive version that collects the leaf nodes of a tree into a flat list (which is one version of "removing parentheses"):
(defun flatten (tree &key (include-nil t))
(check-type tree list)
(labels ((%flatten (lst accum)
(if (null lst)
(nreverse accum)
(let ((elem (first lst)))
(if (atom elem)
(%flatten (cdr lst) (if (or elem include-nil)
(cons elem accum)
accum))
(%flatten (append elem (cdr lst)) accum))))))
(%flatten tree nil)))
It preserves null leaf nodes by default, with the option to remove them. It also preserves the left-to-right order of the tree's leaf nodes.
Note from Google lisp style guide about TCO:
You should favor iteration over recursion.
...most serious implementations (including SBCL and CCL) do implement proper tail calls, but with restrictions:
The (DECLARE (OPTIMIZE ...)) settings must favor SPEED enough and not favor DEBUG too much, for some compiler-dependent meanings of "enough" and "too much".
And this from SBCL docs:
... disabling tail-recursion optimization ... happens when the debug optimization quality is greater than 2.