I need to compare two lists and equalp doing just fine when I have the nested lists in order, but I need a custom function that returns T when I have the order of nested lists mixed. Something like;
(setq temp1 '(((BCAT S) (FEATS NIL)) (DIR FS) (MODAL STAR)
(((BCAT S) (FEATS NIL)) (MODAL STAR) (DIR BS) ((FEATS NIL) (BCAT NP)))))
(setq temp2 '((DIR FS) ((BCAT S) (FEATS NIL)) (MODAL STAR)
(((BCAT S) (FEATS NIL)) (DIR BS) (MODAL STAR) ((BCAT NP) (FEATS NIL)))))
(equalp-customized temp1 temp2) ; gotta make this return T
I had tried to find the source code of equalp, it was not a good idea I guess, I then could have altered it to support my needs. Now I have no clue where to start. Appreciate any help :)
I think that doing this naively, by recursively comparing all elements, is likely too slow, as it is quadratic on every level.
Instead, I'd propose to bring these trees into a canonical form first, and then use equalp. A canonical form means that the order is made consistent across all trees.
It looks like your input trees are composed only of atomic 2-element lists at the lowest level. If so, you can simply flatten the trees into plists and then check for equal sets. (However, if the lowest level lists can contain an arbitrary number of atoms, then you would need to extract those lists by walking the input trees first.)
The Alexandria library contains the function flatten, but it would remove the nil entries in the inputs. Here is an alternate function to do the same thing, but respecting NILs. The result is a plist of the input 2-element lists.
(defun level-out (tree)
"Flattens a tree respecting NILs."
(loop for item in tree
when (consp item)
if (atom (car item))
append item
else append (level-out item)))
So now, for example:
(setq flat1 (level-out temp1)) -> (BCAT S FEATS NIL DIR FS MODAL STAR BCAT S FEATS NIL MODAL STAR DIR BS FEATS NIL BCAT NP)
The following function then collects the pairs:
(defun pair-up (plist)
(loop for (1st 2nd) on plist by #'cddr
collect (list 1st 2nd)))
giving:
(setq pairs1 (pair-up flat1)) -> ((BCAT S) (FEATS NIL) (DIR FS) (MODAL STAR) (BCAT S) (FEATS NIL) (MODAL STAR) (DIR BS) (FEATS NIL) (BCAT NP))
The pairs are now in a form for testing set equality using Alexandria:
(defun nested-pairs-equal-p (tree1 tree2)
(alexandria:set-equal (pair-up (level-out tree1))
(pair-up (level-out tree2))
:test #’equal))
(nested-pairs-equal-p temp1 temp2) -> T
Extracting Nested Lists
Actually, it may be more straightforward to extract the nested lists directly with:
(defun level-out-nested-lists (tree)
(loop for item in tree
if (and (consp item) (atom (car item)))
collect item
else append (level-out-nested-lists item)))
before checking for alexandria:set-equal.
Extracting Nested Lists Indexed by Level
The basic idea again is to walk the two input lists extracting the lowest level items, but associating each extracted item with its level in the tree. The following function purports to create an alist of items where the car is the level and the cdr is the list of items appearing at that level:
(defun associate-tree-items-by-level (tree)
"Returns an alist of items in tree indexed by level."
(let (alist)
(labels ((associate-tree-items-by-level-1 (tree level)
(loop for item in tree
when (consp item)
if (atom (car item))
do (let ((pair (assoc level alist)))
(if pair
(rplacd pair (push item (cdr pair)))
(push (cons level (list item)) alist)))
else do (associate-tree-items-by-level-1 item (1+ level)))))
(associate-tree-items-by-level-1 tree 1)
(sort alist #'< :key #'first))))
So then:
(associate-tree-items-by-level
'(((BCAT S) (FEATS NIL)) (DIR BS) (MODAL STAR) (((BCAT S) (FEATS NIL)) (MODAL STAR) (DIR FS) ((FEATS NIL) (BCAT NP)))))
-> ((1 (MODAL STAR) (DIR BS))
(2 (DIR FS) (MODAL STAR) (FEATS NIL) (BCAT S))
(3 (BCAT NP) (FEATS NIL) (FEATS NIL) (BCAT S)))
All of the items are now grouped into bags (not sets because of possible repetitions) and indexed by level. The next function should test for equal bags of items:
(defun bag-equal-p (bag-list1 bag-list2)
(and (= (length bag-list1) (length bag-list2))
(loop with remainder = (copy-list bag-list2)
for item1 in bag-list1
do (alexandria:deletef remainder item1 :test #'equal :count 1)
finally (return (not remainder)))))
To check equality of the inputs, you can then do something like:
(every #'bag-equal-p
(associate-tree-items-by-level input1)
(associate-tree-items-by-level input2))
(ps: I haven’t really tested the above code, so you may need to make some adjustments. It’s only offered as prototyping.)
Related
As a beginner, I am struggling with lips, in my program I have a list like :
(((NIL (B) (C) (B)) (A)) (E) (G))
But what I want to construct is n-dimensional list (3-dim in this case):
((B C B)(A)(E G))
I have tried flattening the list but it does not seem to be correct. I will appreciate any help.
As you have not really given the specification of what your program is meant to do, here is something that turns the structure you have into the one you want, on the assumption that something else is giving you this structure.
Your structure is a cons, the car of which is either null, if there's no more structure, or a structure. The cdr of the structure list of single-element lists and we want those elements.
I've called the structure a BLOB-TREE and each CDR is a BLOB.
(defun blob-to-list (blob)
;; a blob is a list of single-element lists, and we want the elements
(mapcar (lambda (e)
(assert (and (listp e) (null (rest e))))
(first e))
blob))
(defun blob-tree-to-list (blobs)
;; BLOB-TREE is some horrible tree: what we need to do is split it into
;; its car & cdr, and then convert the cdr to a list with
;; blob-to-list, then recurse on the car, until we get a null car.
(labels ((extract-blobs (remains accum)
(etypecase remains
(null accum)
(cons
(extract-blobs (car remains) (cons (blob-to-list (cdr remains))
accum))))))
(extract-blobs blobs '())))
And now
> (blob-tree-to-list '(((NIL (B) (C) (B)) (A)) (E) (G)))
((b c b) (a) (e g))
I rather doubt that this is actually what you want to do.
As a check, I wrote a function which takes a list in the form you want and converts it into a blob-tree. You can use this to check that things round-trip properly.
(defun list-to-blob-tree (l)
(labels ((list-to-blob (es)
(mapcar #'list es))
(build-blob-tree (tail accum)
(if (null tail)
accum
(build-blob-tree (rest tail)
(cons accum (list-to-blob (first tail)))))))
(build-blob-tree l '())))
If you really want to deal with things like this (which, in real life, you sometimes have to), a good approach is to write a bunch of accessor functions which let you abstract away the shonky data structures you've been given.
In this case we can write functions to deal with blobs:
;;; Blobs are lists are lists where each element is wrapped in a
;;; single-element list
(defun blob->element-list (blob)
;; a blob is a list of single-element lists, and we want the elements
(mapcar (lambda (e)
(assert (and (listp e) (null (rest e))))
(first e))
blob))
(defun element-list->blob (list)
;; turn a list into a blob
(mapcar #'list list))
And another set of functions to deal with blob trees, which (it turns out) are just lists built with their cars & cdrs swapped:
;;; Blob trees are lists, built backwards
;;;
(deftype blob-tree ()
'(or cons null))
(defconstant null-blob-tree nil)
(defun blob-tree-car (blob-tree)
(cdr blob-tree))
(defun blob-tree-cdr (blob-tree)
(car blob-tree))
(defun blob-tree-cons (car cdr)
(cons cdr car))
(defun blob-tree-null-p (blob-tree)
(null blob-tree))
In both cases I've only written the functions I need: there are readers but no writers for instance.
And now we can write the functions we need in terms of these abstractions:
(defun blob-tree->element-list (blob-tree)
(labels ((extract-blobs (tree accum)
(assert (typep tree 'blob-tree))
(if (blob-tree-null-p tree)
accum
(extract-blobs (blob-tree-cdr tree)
(cons (blob->element-list (blob-tree-car tree))
accum)))))
(extract-blobs blob-tree '())))
(defun element-list->blob-tree (el)
(labels ((build-blob-tree (elt accum)
(if (null elt)
accum
(build-blob-tree (rest elt)
(blob-tree-cons
(element-list->blob (first elt))
accum)))))
(build-blob-tree el null-blob-tree)))
This means that if the representation changes these two mildly hairy functions don't.
This works for me:
(defun peculiar-transform (input-list)
(destructuring-bind (((ignore (xb) (xc) (xb)) (xa)) (xe) (xg)) input-list
`((,xb ,xc ,xb) (,xa) (,xe ,xg))))
Test:
[1]> (peculiar-transform '(((NIL (B) (C) (B)) (A)) (E) (G)))
((B C B) (A) (E G))
[2]> (peculiar-transform '(((NIL (2) (3) (2)) (1)) (5) (7)))
((2 3 2) (1) (5 7))
I've renamed your variables to XA, XB, ... just to reduce confusion when we use the A, B, ... occur in the input test case.
Here we are taking advantage destructuring-bind to use your input pattern directly (just with the variables renamed) as the specification for how to extract the elements, and then we use the backquote syntax to produce a template that has the required output shape, with the extracted pieces inserted into the right places.
Given I have the list that might vary in its' structure- it might have multiple lists within list, how do I iterate through every element?
Example of the list: (or (and (not a) (not b)) (or (and x) t)))
It's a tipical situation for maptree function.
(defun maptree (fn tree)
(cond
((null tree) tree)
((atom tree) (funcall fn tree))
(t (cons
(maptree fn (first tree))
(maptree fn (rest tree))))))
So you can do (maptree #'what-to-do your-list).
I will just print all elements, you can provide any function you want, it'll b executed on each element of your tree.
CL-USER> (let ((lis
'(or (and (not a) (not b)) (or (and x) t))))
(maptree #'print lis))
OR
AND
NOT
A
NOT
B
OR
AND
X
T
This is a good case for a recursive function. You probably want something like this:
(defun iterate (l) (if (atom l) (do-something-with l) (mapcar #'iterate l)))
The function do-something-with obviously defines what you want to do with each element. Further, the mapcar could be replaced by another mapping function, depending on whether you want to accumulate the results of do-something-with or not.
From SICP I remember accumulate-tree which can be considered a reduce for trees. In CL it might look like this:
(defun accumulate-tree (tree term combiner null-value)
(labels ((rec (tree)
(cond ((null tree) null-value)
((atom tree) (funcall term tree))
(t (funcall combiner (rec (car tree))
(rec (cdr tree)))))))
(rec tree)))
You can do stuff like adding all numbers in the tree:
(defparameter *value-tree* '(1 2 (3 4 (5 6)) 3))
(accumulate-tree *value-tree*
(lambda (x) (if (numberp x) x 0))
#'+
0) ; => 24
To implement #coredumps map-tree you use cons as combiner and nil ass nil value:
(defun map-tree (function tree)
(accumulate-tree tree function #'cons nil))
I want to write a recursive function that checks the list and either returns true if the list is in ascending order or NIL otherwise. If the list is empty it is still true. I am completely new to Lisp, so its still very confusing.
(defun sorted (x)
(if (null x)
T
(if (<= car x (car (cdr x)))
(sorted (cdr x))
nil)))
The recursive version:
(defun sorted (list)
(or (endp list)
(endp (cdr list))
(and (<= (first list) (second list))
(sorted (cdr list)))))
The more idiomatic loop-based predicate accepting a :test argument:
(defun sortedp (list &key (test #'<=))
(loop for (a b) on list
while b
always (funcall test a b)))
The version accepting a :key; we only call the key function once per visited element:
(defun sortedp (list &key (test #'<=) (key #'identity))
(loop for x in list
for old = nil then new
for new = (funcall key x)
for holdp = T then (funcall test old new)
always holdp))
Some tests:
(loop for k in '(()
((1))
((1) (2))
((2) (1))
((1) (2) (3))
((3) (2) (1)))
collect (sortedp k :test #'> :key #'car))
=> (T T NIL T NIL T)
This one also works with other kinds of sequences:
(defun sortedp (sequence &key (test #'<=) (key #'identity))
(reduce (lambda (old x &aux (new (funcall key x)))
(if (or (eq old t)
(funcall test old new))
new
(return-from sortedp nil)))
sequence
:initial-value t))
The above test gives:
(T 1 NIL 1 NIL 1)
... which is a correct result thanks to generalized booleans.
If you are doing your homework (seems so), then the above answers are fine. If you are just learning Lisp, and don't have constraints about recursivity, then the following might give you a glimpse about the power of Lisp:
(defun sorted (l)
(or (null l) (apply #'< l)))
The first problem with your solution is the base case You need to stop not at the end of the list, but when looking at the last to elements, as you need to elements to do the comparison. Also the parens are missing in the call to (car x)
(defun sorted (list)
(if (endp (cddr list))
(<= (car list) (cadr list))
(and (<= (car list) (cadr list))
(sorted (cdr list)))))
Bare in mind that recursive solutions are discouraged in CL
I'm trying to figure out how to obtain the last (non-empty) list from within another list, or return nil if there is no such list (recursively). This is an homework assignment, and as such I am looking for help on the method, not necessarily the code for it. Example:
(lastele '(1 (2 3) 4 5)) ;=> (2 3)
(lastele '(1 (2 3) (4 5)) ;=> (4 5)
(lastele '(1 2 3 4 5)) ;=> NIL
I was trying to run through the list, and if I encountered a sublist, I would check to see if the rest of the list contained any more non-empty sublists, if it did, continue with setting the list to that, and repeating until we had a null list.
(defun lastele2 (L)
(if (null L)
'()
(if (hasMoreLists (rest L))
(lastele2 (rest L))
(first L))))
It seems as if I can't get hasMoreLists to work, though. Returning t or f within is just erroring. Is this the best way to go about this?
First of all, note that you're implicitly assuming that none of the sublists are the empty list; if they could be the empty list, then nil is an ambiguous result, because you can't tell whether your function returned nil because there were no sublists, or because there were, and the last one was empty. E.g.,
(fn '(1 2 3 4 5)) ;=> nil because there are no sublists
(fn '(1 2 3 () 5)) ;=> nil because there are sublists, and the last one is nil
So, under the assumption that there are no non-null sublists in the toplevel list, we can continue.
A non-homework solution using standard functions
You don't need to write this. You can just use find-if with the predicate listp and specify that you want to search from the end by using the keyword argument :from-end t:
CL-USER> (find-if 'listp '(1 (2 3) 4 5) :from-end t)
(2 3)
CL-USER> (find-if 'listp '(1 (2 3) (4 5)) :from-end t)
(4 5)
CL-USER> (find-if 'listp '(1 2 3 4 5) :from-end t)
NIL
Writing your own
If you need to write something like this, your best bet is to use a recursive function that searches a list and keeps track of the most recent list element that you've seen as the result (the starting value would be nil) and when you finally reach the end of the list, you'd return that result. E.g.,
(defun last-list (list)
(labels ((ll (list result) ; ll takes a list and a "current result"
(if (endp list) ; if list is empty
result ; then return the result
(ll (cdr list) ; else continue on the rest of list
(if (listp (car list)) ; but with a "current result" that is
(car list) ; (car list) [if it's a list]
result))))) ; and the same result if it's not
(ll list nil))) ; start with list and nil
The local function ll here is tail recursive, and some implementations will optimize it into a loop, but would be more idiomatic to use a genuine looping construct. E.g., with do, you'd write:
(defun last-list (list)
(do ((result nil (if (listp (car list)) (car list) result))
(list list (cdr list)))
((endp list) result)))
If you don't want to use labels, you can define this as two functions:
(defun ll (list result)
(if (endp list)
result
(ll (cdr list)
(if (listp (car list))
(car list)
result))))
(defun last-list (list)
(ll list nil))
Alternatively, you could make last-list and ll be the same functions by having last-list take the result as an optional parameter:
(defun last-list (list &optional result)
(if (endp list)
result
(last-list (cdr list)
(if (listp (car list))
(car list)
result))))
In all of these cases, the algorithm that you're implementing is essentially iterative. It's
Input: list
result ← nil
while ( list is not empty )
if ( first element of list is a list )
result ← first element of list
end if
list ← rest of list
end while
return result
Something based on the code in the question
We can still find something that's a bit closer to your original approach (which will use more stack space), though. First, your original code with proper indentation (and some newlines, but there's more flexible in coding styles there):
(defun lastele2 (L)
(if (null L)
'()
(if (hasMoreLists (rest L))
(lastele2 (rest L))
(first L))))
The approach it looks like you're trying to use is to define the last sublist of a list L as:
nil, if L is empty;
if (rest L) has some sublists, whatever the last sublist of (rest L) is; and
if (rest L) doesn't have some sublists, then (first L).
That last line isn't quite right, though. It needs to be
if (rest L) doesn't have some sublists, then (first L) if (first L) is a list, and nil otherwise.
Now, you've already got a way to check whether (rest L) has any (non-null) sublists; you just check whether (lastele2 (rest L)) returns you nil or not. If it returns nil, then it didn't contain any (non-null) sublists. Otherwise it returned one of the lists. This means that you can write:
(defun last-list (list)
(if (endp list) ; if list is empty
nil ; then return nil
(let ((result (last-list (rest list)))) ; otherwise, see what (last-list (rest list)) returns
(if (not (null result)) ; if it's not null, then there were more sublists, and
result ; last-list returned the result that you wantso return it
(if (listp (first list)) ; otherwise, if (first list) is a list
(first list) ; return it
nil))))) ; otherwise return nil
This is implementing the an essentially recursive algorithm; the value of the subproblem is returned, and then lastList returns a value after examining it that result:
Function: lastList(list)
if ( list is empty )
return nil
else
result ← lastList(list)
if ( result is not nil )
return result
else if ( first element of list is a list )
return first element of list
else
return nil
end if
end if
No, it's not the best way to go about this. To find whether the rest of list has more lists, you need to search it - and if it has, you restart scanning over the rest of your list.
I.e. you do a lot of back and forth.
Instead, just search along, and update a side variable to point to any list you find along the way.
(defun lastele (lst &aux a) ; a is NIL initially
(dolist (e lst a) ; return a in the end
(if (consp e) (setq a e))))
How to reverse a list such that every sublist is also reversed? This is what I have so far:
(defun REV (L)
(cond
((null L) nil)
((listp L)
(append
(REV (cdr L))
(list (car L))))
(t
(append
(REV (cdr L))
(list (car L))))))
You are on the right track, but your last two conditions have the same action, which should give an indication that one of them is not doing what it should. Indeed, the second condition, the listp case, is not right, because when it's a list, you need to append the reverse of that list instead of the unmodified list. A possible solution:
(defun my-reverse (l)
(cond ((null l) nil)
((listp (car l)) (append (my-reverse (cdr l))
(list (my-reverse (car l)))))
(t
(append (my-reverse (cdr l))
(list (car l))))))
> (my-reverse '((1 2 3) (4 5 6)))
((6 5 4) (3 2 1))
As you can see, the only difference is that you test if the first element is a list, and if it is, you reverse the first element before appending it.
I'd write it this way:
(defun reverse-all (list)
(loop
with result = nil
for element in list
if (listp element)
do (push (reverse-all element) result)
else do (push element result)
finally (return result)))
Sounds like a homework problem :)
Looks like you started by writing the regular reverse code. I'll give you a hint: The second condition (listp L) isn't quite right (it'll always be true). You want to be checking if something else is a list.
dmitry_vk's answer (which probably is faster in most lisps than using append in the previous examples) in a more lispish way:
(defun reverse-all (list)
(let ((result nil))
(dolist (element list result)
(if (listp element)
(push (reverse-all element) result)
(push element result)))))
Or even:
(defun reverse-all (list)
(let ((result nil))
(dolist (element list result)
(push
(if (listp element) (reverse-all element) element)
result))))