Greetings!
I would like to know if there is a way to list in the command box how many separate polylines are there, grouped by their linetype :)
Now it adds up the length but i would like the count.
(defun C:Csőhossz_számoló ( / SS aL i e itm ltp b )
(if
(setq SS
(ssget "_:L-I"
'((0 . "*POLYLINE")
(-4 . "<NOT")
(-4 . "<AND")
(0 . "POLYLINE")
(-4 . "&")
(70 . 80)
(-4 . "AND>")
(-4 . "NOT>")
)
)
)
(progn
(setq aL '())
(repeat (setq i (sslength SS))
(setq e (ssname SS (setq i (1- i))))
(setq itm
(cons
(setq ltp (cond ( (cdr (assoc 6 (entget e))) ) ( "ByLayer" ) ))
(+ (vlax-curve-getDistAtParam e
(vlax-curve-getEndParam e))
(setq b (cond ( (cdr (assoc ltp aL)) ) (0.))))
)
)
(if (zerop b)
(setq aL (cons itm aL))
(setq aL (subst itm (assoc (car itm) aL) aL))
)
)
(princ "\n============\n")
(foreach x (vl-sort aL ''((a b) (apply '< (mapcar 'car (list a b)))) )
(princ (car x)) (princ " : ") (princ (rtos (cdr x) 2 4))
(princ "\n")
)
(princ "============")
(textscr)
)
)
(princ)
)
(sslength SS)
returns number of entities. so just:
(print (sslength SS))
before
(setq aL '())
This will return the poly lines' name, count, and total length. I renamed the variables to better understand what they were holding.
(defun C:fcnSolution ( / ;-----------------------------; Inputs
SelectionSet iItr1 eEntity rLength bTrue ;-----; Miscellaneous
lDottedPair lLength lAllLengths lLineTypes ;---; Lists 1
lNewLT lNewLTs lExsistingLT lUpdateLT ;--------; Lists 2
sHandle sLineType sExsistingLT sLength ;-------; Strings
);local variables
(if
;; Condition - Collects only poly lines from selected objects
(setq SelectionSet
(ssget "_:L-I"
'((0 . "*POLYLINE")
(-4 . "<NOT")
(-4 . "<AND")
(0 . "POLYLINE")
(-4 . "&")
(70 . 80)
(-4 . "AND>")
(-4 . "NOT>")
);list
);ssget
);setq
;; Condition True
(progn ;true
;; Creating list variables
(setq lAllLengths '())
(setq lLineTypes (list))
;; Each filtered, selected item
(repeat (setq iItr1 (sslength SelectionSet))
;; Building dotted pair
(setq iItr1 (1- iItr1))
(setq eEntity (ssname SelectionSet iItr1));--------------------------; Entity's unique name
(setq sLineType (cdr (assoc 0 (entget eEntity))));-------------------; Name of the line type
(setq sHandle (cond ((cdr (assoc 6 (entget eEntity))) ) (sLineType))); Handle's name
(setq rLength (cond ((cdr (assoc sHandle lAllLengths))) (0.)));------; Length of the Polyline
(setq lDottedPair (cons sHandle (+ (vlax-curve-getDistAtParam eEntity (vlax-curve-getEndParam eEntity)) rLength)))
;; Total length of the combined line types per line type
(if (zerop rLength)
(setq lAllLengths (cons lDottedPair lAllLengths))
(setq lAllLengths (subst lDottedPair (assoc (car lDottedPair) lAllLengths) lAllLengths))
);if
;; Counts line types
(setq bTrue T)
(setq lNewLTs (list))
(foreach lExsistingLT lLineTypes
(setq sExsistingLT (car lExsistingLT)); Pulls first item from list (string variable)
(if (and (= sExsistingLT sLineType) bTrue); Updating exsisting line type
;; True - Updating exsisting line type
(progn
(setq lUpdateLT (cons sExsistingLT (1+ (cdr lExsistingLT))))
(setq lNewLTs (cons lUpdateLT lNewLTs))
(setq bTrue nil)
);progn
;; False - No change
(setq lNewLTs (cons lExsistingLT lNewLTs))
);if
);foreach
(if bTrue (setq lNewLTs (cons (cons sLineType 1) lLineTypes))); New Line Type
(setq lLineTypes lNewLTs)
);repeat
;; Printing Line types
(princ "\n============\n")
(foreach lExsistingLT lLineTypes
;; Related length
(foreach lLength lAllLengths
(if (= (car lExsistingLT)(car lLength))
(setq sLength (rtos (cdr lLength) 2 4))
);if
);foreach
;; Printing Results
(princ (strcat (car lExsistingLT) " : " (itoa (cdr lExsistingLT))));------; Line type and count
(princ (strcat " : " sLength))(terpri)
);foreach
(princ "\n============\n")
(textscr)
);progn - true
);if
(princ)
);C:fcnSolution
Related
Here is a task: a list is given, some of the elements are also lists. It's nescessary to replace the nested lists with the sum of the numbers in them, if all of them are even, using recursion. For example:
(1 2 NIL (2 4 6) 5 7) -> (1 2 NIL 12 5 7)
if the parent list matches the condition after the transformation:
(2 2 (4 4) (2 2)) -> (2 2 8 4) -> 16
Now i have the following code:
;; check for all list elements are even
(defun is-even-list (lst)
(cond ((null lst) t)
((and (numberp (car lst)) (evenp (car lst))) (is-even-list (cdr lst)))
(t nil)
)
)
;; list summing
(defun sum-list (lst)
(cond ((null lst) 0)
(t (+ (car lst) (sum-list (cdr lst))))
)
)
;; main func
(defun task (lst)
(cond ((null lst) nil)
((atom (car lst)) (cons (car lst) (task (cdr lst))))
((is-even-list (car lst)) (cons (list (sum-list (car lst))) (task (cdr lst))))
(t (cons (task (car lst)) (task (cdr lst))))
)
)
But now it processes only the “lowest” level of the list if it exists:
(2 4) -> (2 4)
(2 (2 4 6) 6) -> (2 12 6)
(2 (4 (6 8) 10) 12) -> (2 (4 14 10) 12)
(2 (4 6) (8 10) 12) -> (2 10 18 12)
How can i change this code to get "full" processing?
It's definitely not the best solution but it works:
(defun is-even-list (lst)
(cond ((null lst) t)
((and (numberp (car lst)) (evenp (car lst))) (is-even-list (cdr lst)))
(t nil)
)
)
(defun sum-list (lst)
(cond ((null lst) 0)
(t (+ (car lst) (sum-list (cdr lst))))
)
)
(defun test (lst)
(dotimes (i (list-length lst))
(cond
((not (atom (nth i lst))) (setf (nth i lst) (test (nth i lst))))
)
)
(cond
((is-even-list lst) (setf lst (sum-list lst)))
((not (is-even-list lst)) (setf lst lst))
)
)
Here's a solution which I think meets the requirements of the question: recursively sum a list each element of which is either an even number or a list meeting the same requirement. It also does this making only a single pass over the structure it is trying to sum. For large lists, it relies on tail-call elimination in the implementation which probably is always true now but is not required to be. sum-list-loop could be turned into something explicitly iterative if not.
(defun sum-list-if-even (l)
;; Sum a list if all its elements are either even numbers or lists
;; for which this function returns an even number. If that's not
;; true return the list. This assumes that the list is proper and
;; elements are numbers or lists which meet the same requirement but
;; it does not check this in cases where it gives up for other
;; reasons first: (sum-list-if-even '(2 "")) signals a type error
;; (but (sum-list-if-even '(1 "")) fails to do so)
(labels ((sum-list-loop (tail sum)
(etypecase tail
(null sum) ;all the elements of '() are even numbers
(cons
(let ((first (first tail)))
(etypecase first
(integer
;; Easy case: an integer is either an even number
;; or we give up immediately
(if (evenp first)
(sum-list-loop (rest tail) (+ sum first))
;; give up immediately
l))
(list
;; rerurse on the car ...
(let ((try (sum-list-if-even first)))
;; ... and check to see what we got to know if
;; we should recurse on the cdr
(if (not (eq try first))
(sum-list-loop (rest tail) (+ sum try))
l)))))))))
(sum-list-loop l 0)))
Allow me to show some improvements on your own answer.
First, use conventional formatting: no dangling parentheses, bodies indented two spaces, other argument forms aligned. Use appropriate line breaks.
(defun is-even-list (lst)
(cond ((null lst) t)
((and (numberp (car lst))
(evenp (car lst)))
(is-even-list (cdr lst)))
(t nil)))
(defun sum-list (lst)
(cond ((null lst) 0)
(t (+ (car lst)
(sum-list (cdr lst))))))
(defun test (lst)
(dotimes (i (list-length lst))
(cond ((not (atom (nth i lst)))
(setf (nth i lst) (test (nth i lst))))))
(cond ((is-even-list lst) (setf lst (sum-list lst)))
((not (is-even-list lst)) (setf lst lst))))
The first function checks two things: that every element is a number, and that every element is even. In this context, the first condition mainly means: no sublists.
(defun flat-all-even-p (list)
(and (every #'numberp list)
(every #'even list)))
The second function sums a list and assumes that all elements are numbers (sublists would signal an error here).
(defun sum (list)
(reduce #'+ list))
The third function does not test, it sums. Note that it only accidentally returns the answer, since setf returns the value it sets. Another problem is that you do index lookup on lists in a loop, which is very inefficient. Finally, you modify the list you were given, which will surprise your caller.
(defun sum-if-all-even (tree)
(if (listp tree)
(let ((recursed-tree (mapcar #'sum-if-all-even tree)))
(if (flat-all-even-p recursed-tree)
(sum recursed-tree)
recursed-tree))
tree)
Given a list L=(M,A1,A2,...,An). Find sublist if they exist L1=(Ai,Ai+1,...,Ai+k), i+k<=N, i>=1, for which M=Ai+Ai+1+...Ai+k
For example 1: L=(12 1 3 -16 5 7 8 2 2), M=12
Result: L=((1 3 -16)(5 7)(8 2 2))
for 1+3-16=12, 5+7=12, 8+2+2=12
Exemple L=(14 1 15 -1 14 5 6)
Result: L=((15 -1)(14))
for 1=14->no, 1+15=14->no, 1+15-1=14->no, 1+15-1+14=14->no, 1+15-1+14+5=14->no, 1+15-1+14+5+6=14->no
we move on to the next item 15=14->no, 15-1=14->YES! extract (15 -1)
we move on to the next item 14=14->YES! extract (14)
we move on to the next item 5=14->no, 5+6=14->no
Finish Result (15 -1) (14)
How resolve it in Lisp?
My code
(setq l '(6 1 2 3 6 14 3))
(setq comb nil)
(setq rez nil)
(defun sublist (lst)
(secondfunction (car lst) (cdr lst))
)
(defun pairnil (list1)
(mapcar #'(lambda (x) (cons x nil)) list1)
)
(defun pair (a list1)
(mapcar #'(lambda (x) (append x (list a))) list1)
)
(defun secondfunction (head other)
(run (cdr other) (cdr other) (pairnil other) (cdr(pairnil other)) (pairnil(car(pairnil other))))
(final comb head nil)
)
(defun final (lst el result)
(if (>(length lst) 0)
(progn
(if(eq(loop for x in (car lst) sum x) el) (final (cdr lst) el (append result (cons (car lst) nil)))
(if(>(length lst) 0)(final (cdr lst) el result )))
)
(setq rez result)
))
(final comb (car l) nil)
(defun run (lst1 ilst1 lst2 ilst2 temp)
(if (eq(car ilst1) nil) (setq comb lst2))
(when (>(length lst1)0)
(if (>(length ilst1)0) (run lst1 (cdr ilst1) (append lst2 (pair (car ilst1) temp)) ilst2 (append temp (pair (car ilst1) temp))))
(if (=(length ilst1)0) (run (cdr lst1) (cdr lst1) lst2 (cdr ilst2) (pairnil(car ilst2))))
))
(sublist l)
Result ((6) (1 2 3) (1 2 3) (3 3)), but this doesn't work correctly. In example I have explained how it should work.
A simple approach:
map over all sublists of list and append the results
map over all sublists of this reversed sublist and append the results
when the sum of the items is M then collect a list of the reverse sublist
Functions needed:
mapcon for mapping
reverse for reversing
reduce for summing
Solution:
(setq l '(6 1 2 3 4 5 6 7 -1))
(setq comb nil)
(setq rez nil)
(defun sublist (lst)
(secondfunction (car lst) (cdr lst))
)
(defun secondfunction (head other)
(run (cdr other) (cdr other) (list(car other)) (list(list(car other))))
(final comb head nil)
)
(defun final (lst el result)
(if (>(length lst) 0)
(progn
(if(eq(loop for x in (car lst) sum x) el) (final (cdr lst) el (append result (cons (car lst) nil)))
(if(>(length lst) 0)(final (cdr lst) el result )))
)
(setq rez result)
)
)
(final comb (car l) nil)
(defun run (lst1 lst2 temp r)
(if (not(eq(car lst1) nil))
(if (not(eq(car lst2) nil))
(run lst1 (cdr lst2) (append temp (list (car lst2))) (append r (list (append temp (list (car lst2))))))
(run (cdr lst1) (cdr lst1) (list(car lst1)) (append r (list(list (car lst1)))))
)
(setq comb r)
)
)
(sublist l)
I have 2 kinds of lists with key-value pairs:
(define pairs1 (list (list 1 2)(list 10 20)(list 100 200)))
(define pairs2 (list (cons 1 2)(cons 10 20)(cons 100 200)))
I want to search by value in both kinds of lists with one function. I tried following ('cdr' in one and 'second' in other fn), but they work with one list each:
(define (assoc_val1 val spair)
(for/list ((item spair) #:when (equal? (cdr item) val))
item))
(define (assoc_val2 val spair)
(for/list ((item spair) #:when (equal? (second item) val))
item))
Can I have a function which works for both kinds of lists? Also, is there a good link explaining difference between (list 1 2), (cons 1 2) and '(1 2)?
Edit: Modifying the answer provided by #Sylwester , following function can detect and work on both lists:
(define (assoc2* haystack needle [is-equal? equal?] )
(if (list? (car haystack))
(findf (λ (e) (is-equal? needle (second e))) haystack)
(findf (λ (e) (is-equal? needle (cdr e))) haystack)
))
(assoc2* pairs1 20)
(assoc2* pairs2 20)
Output:
'(10 20)
'(10 . 20)
Just add #:accessor as a keyword parameter or optional parameter:
;; Fully compatible with assoc but allows for searching any part
(define (assoc* haystack needle [is-equal? equal?] #:accessor [accessor car])
(findf (λ (e) (is-equal? needle (accessor e))) haystack))
(assoc* pairs1 20 #:accessor cadr) ; ==> (10 20)
(assoc* pairs2 20 #:accessor cdr) ; ==> (10 . 20)
I am doing this problem set in preparation for an exam. It's in the book. Basically it tells us to design a program that counts all occurrences of "hello" in an instance of XEnum.v2.
Everything works perfectly except this problem. I am having problems with this check expect
(check-expect (count-in-xitem xitem3) 3)
it says it expects a non-empty list, but given 'ol. It should absolutely give me 3. Why does it keep telling me it expects a non-empty list? I dumbfounded and can't figure out why.
;; An XEnum.v2 is one of:
;; – (cons 'ol [List-of XItem.v2])
;; – (cons 'ol (cons [List-of Attribute] [List-of XItem.v2]))
;; An XItem.v2 is one of:
;; – (cons 'li (cons XWord empty))
;; – (cons 'li (cons [List-of Attribute] (cons XWord empty)))
;; – (cons 'li (cons XEnum.v2 empty))
;; – (cons 'li (cons [List-of Attribute] (cons XEnum.v2 empty)))
;; A XWord is '(word ((text String)))
;; An Attribute is
;; - (cons Symbol (cons String empty))
(define xword1 '(word ((text "hello"))))
(define xword2 '(word ((text "Hello"))))
(define attr1 (cons 'Symbol (cons "hello" empty)))
(define attr2 (cons 'Symbol (cons "elo" empty)))
(define xitem1 (cons 'li (cons xword1 empty)))
(define xitem2 (cons 'li (cons (list attr1 attr2) (cons xword1 empty))))
(define xe1 (cons 'ol (list xitem1 xitem2))) ;; 3
(define xe2 (cons 'ol (cons (list attr1 attr2) (list xitem2 xitem1))))
(define xitem3 (cons 'li (cons xe1 empty))) ;; 1
(define xitem4 (cons 'li (cons (list attr1 attr2) (cons xe1 empty))))
;; X-Item.v2 -> Number
;; returns number of "hello" occurences in an X-Item.v2
(define (count-in-xitem xi)
(cond
[(is-xword? (second xi)) (count-in-xword (second xi))]
[(is-xenum? xi) (+ (count-in-xitem (second xi))
(count-in-xitem (second (rest xi))))]
[(is-attribute? (first (second xi))) (+ (count-in-loa (second xi))
(count-in-xword (first (rest (rest xi)))))]
[else (+ (count-in-loa (second xi))
(occurrences (second (rest xi))))]))
;; tests for count-in-xitem function
;(check-expect (count-in-xitem xitem1) 1)
;(check-expect (count-in-xitem xitem2) 2)
;(check-expect (count-in-xitem xe1) 3)
(check-expect (count-in-xitem xitem3) 3)
;; XWord -> Natural
;; returns 1 if string is "hello"
(define (count-in-xword x)
(if (string=? (second (first (first (rest x))))
"hello")
1
0))
;; tests for count-in-xword function
(check-expect (count-in-xword xword1) 1)
(check-expect (count-in-xword xword2) 0)
;; [List-of Attribute] -> Natural
;; returns 1 if occurrences of "hello" in the list of attributes
(define (count-in-loa loa)
(foldr (λ(s b) (if (string=? (second s) "hello") (+ 1 b) b)) 0 loa))
;; tests for count-in-loa function
(check-expect (count-in-loa (list attr2)) 0)
(check-expect (count-in-loa (list attr1
(cons 'b (cons "hello" empty)))) 2)
;; XEnum.v2 -> Number
;; counts all occurrences of "hello" in an instance of XEnum.v2
(define (occurrences xe)
(if (eqv? (rest (rest xe)) empty)
(xenum2 empty (rest xe))
(xenum2 (second xe) (rest (rest xe)))))
;; [List-of Attribute] [List-of XItem.v2] -> Number
;; returns number of "hello" occurences
(define (xenum2 atr item)
(+ (count-in-loa atr)
(count-in-xitem item)))
;; tests for xenum2 function
;(check-expect (xenum2 (list attr1 attr2) (list xitem1 xitem2)) 0)
;; [List-of Any] -> Boolean
;; checks if the list is an XEnum.v2
(define (is-xenum? xe)
(cond
[(empty? xe) false]
[(symbol? (first xe))
(symbol=? (first xe) 'ol)]))
;; tests for is-attribute? function
(check-expect (is-xenum? xe1) true)
(check-expect (is-xenum? xe2) true)
(check-expect (is-xenum? (cons 'al (list xitem1 xitem2))) false)
(check-expect (is-xenum? empty) false)
;; ATTRIBUTE
(define (is-attribute? xe)
(and (symbol? (first xe))
(string? (second xe))
(not (symbol=? (first xe) 'ol))))
;; tests for is-attribute? function
(check-expect (is-attribute? attr1) true)
(check-expect (is-attribute? attr2) true)
(check-expect (is-attribute? (cons 1 (cons "hi" empty))) false)
;; XWORD
(define (is-xword? xe)
(and (symbol? (first xe))
(symbol=? 'word (first xe))
(symbol=? 'text (first (first (second '(word ((text String)))))))
(symbol=? 'String (second (first (second '(word ((text String)))))))))
;; tests for is-xword? function
(check-expect (is-xword? xword1) true)
(check-expect (is-xword? xword2) true)
(check-expect (is-xword? '(world ((text "hello")))) false)
I think the problem is here
;; ATTRIBUTE
(define (is-attribute? xe)
(and (symbol? (first xe))
(string? (second xe))
(not (symbol=? (first xe) 'ol))))
It looks like you can track this problem down using the stepper.
Click the "step" button, and wait until all of the steps have been computed (you'll see the denominator stop changing in the step count). Then, choose "jump to end" from the drop-down menu. You'll see that your test case is asking for (first 'ol). To see how this arises, step backward; I can see that you're calling is-attribute? on 'ol, but I didn't step any further back to see why this was the case.
I am trying to write a function which compares two lists for homework. When the function run it should be something like this ;(cmp ‘(cat ?x mat ?x) ‘(cat bat mat bat)) => t ;(cmp ‘(cat ?x mat ?x) ‘(cat bat mat sat)) => nil. meaning that in the first list when equal to ?x and the second ?x return true if both are pointing to the same value.
When I run the program now is giving me "error while parsing arguments to special form if: invalid number of elements" Here is my code if you can give me some feedback. Thanks.
;cmp algorithm
;1 if the both lists are empty return true
;2 if only one of the lists is empty return fasle
;3 compare first of the list1 and the first of list2
;if equal go on to the rest of the list with recursive call else return false
(defun cmp (list1 list2)
(setq y '())
(setq z '())
(defparameter *counter* 0)
(cond
((and (null list1) (null list2))
t
)
((or (null list1) (null list2))
nil
)
((or (eq (first list1) (first list2))
(eq (first list1) '?x) )
(cmp (rest list1) (rest list2) )
;if (first list is equal to '?x)
;set the counter to 1
;give the value of (first(rest list2)) to y
;if (first list is equal to '?x) again
;set the counter to 2
;give the value of (first (rest list2)) to z
;i need to compare y and z if eq return true
(if (eq (first list1) '?x)
(princ (first list1 ))
(princ (first(rest list2)))
(1+ *counter*)
(set y (first(rest list2)))
(if (= *counter* 2)
(set z (first (rest list2)))
)
)
(if (= y z) t)
)
(t
nil)
)
)
;(cmp ‘(cat ?x mat ?x) ‘(cat bat mat bat)) => t
;(cmp ‘(cat ?x mat ?x) ‘(cat bat mat sat)) => nil
While reading the book or documentation will certainly help, sometimes looking at example code, especially after you already understand the problem can help too. So here's an unpretentious straight-forward solution:
(defun compare-using-wildcards (pattern matched)
(loop for p in pattern
for m in matched
with keys = (make-hash-table)
do (unless (eql p m) ; Doesn't matter
; if it starts with ?
; we still don't consider
; it a wildcart symbol, if
; it matches the symbol in
; the other list.
(if (and (symbolp p)
(char= (aref (symbol-name p) 0) #\?))
(multiple-value-bind (registered exists)
(gethash p keys)
(if exists
(unless (eql registered m)
(return))
(setf (gethash p keys) m)))
(return)))
finally (return t)))
(compare-using-wildcards '(cat ?x mat ?x) '(cat bat mat bat)) ; T
(compare-using-wildcards '(cat ?x mat ?x) '(cat bat mat sat)) ; NIL
(compare-using-wildcards '(cat ?x mat ?y) '(cat bat mat sat)) ; T
(compare-using-wildcards '(cat ?x max ?y) '(cat bat mat sat)) ; NIL
But there are lots and lots of ways to do this! For example, if lists are known to be short, it could be feasible to do this via destructuring-bind. Alternatively, you could've written a "zip" function (a higher order function that feeds cells from multiple lists to other function until it returns non-nil result) and so on.
And a somewhat contrived example. Well, it looks like it should work, unless I'm missing some corner case. It would compare multiple lists against the list with wildcards:
(every (let ((keys (make-hash-table)))
#'(lambda (&rest elements)
(let ((wildcard (car elements)))
(if (and (symbolp wildcard)
(char= (aref (symbol-name wildcard) 0) #\?))
(let ((replacement (gethash wildcard keys))
(i -1))
(if replacement
(every #'(lambda (x)
(eql x (aref replacement (incf i))))
(cdr elements))
(setf (gethash wildcard keys)
(coerce (cdr elements) 'vector))))
(every #'(lambda (x) (eql x wildcard)) elements)))))
'(cat ?x mat ?x)
'(cat bat mat bat)
'(cat bar mat bar)
'(cat bank mat bank)
'(cat bass mat boss))
You're almost there. You're missing how to match generically on any symbol whose first character is ? and how to pass matches to recursive calls.
You need to save your matches somewhere between calls. A possible approach is pass them in an optional association list of matches:
(defun cmp (list1 list2 &optional matches)
(cond ((and (null list1) (null list2))
t)
((or (null list1) (null list2))
nil)
((and (symbolp (first list1))
(plusp (length (symbol-name (first list1))))
(eql (char (symbol-name (first list1)) 0) #\?))
(let ((assoc (assoc (first list1) matches)))
(cond ((null assoc)
(cmp (rest list1) (rest list2)
(list* (cons (first list1) (first list2))
matches)))
((eql (cdr assoc) (first list2))
(cmp (rest list1) (rest list2) matches)))))
((eql (first list1) (first list2))
(cmp (rest list1) (rest list2) matches))))
A very similar approach to this one which uses a dynamic variable:
(defvar *matches* '())
(defun cmp (list1 list2)
(cond ((and (null list1) (null list2))
t)
((or (null list1) (null list2))
nil)
((and (symbolp (first list1))
(plusp (length (symbol-name (first list1))))
(eql (char (symbol-name (first list1)) 0) #\?))
(let ((assoc (assoc (first list1) matches)))
(cond ((null assoc)
(let ((*matches* (list* (cons (first list1) (first list2))
*matches*)))
(cmp (rest list1) (rest list2))))
((eql (cdr assoc) (first list2))
(cmp (rest list1) (rest list2))))))
((eql (first list1) (first list2))
(cmp (rest list1) (rest list2)))))
Both could be called this way:
> (cmp '(?x b ?x d ?y f ?y h)
'(a b c d e f g h))
nil
> (cmp '(?x b ?x d ?y f ?y h)
'(a b a d e f e h))
t
However, if you already start with an association list of matches, the first one is called like this:
> (cmp '(?x ?y)
'(a b)
'((?x . a)))
t
While the second one is to be used like this:
> (let ((*matches* '((?x . a))))
(cmp '(?x ?y)
'(a b)))
t
Exercise: Make cmp always match '? (a symbol whose name is solely the question mark) to anything.
This may be useful if you want an element to be there but you want to ignore it otherwise.
Exercise: Make cmp more useful and return the list of found associations instead of t:
> (cmp '(?x ?y)
'(a b))
((?x . a)
(?y . b))
;;; Assuming option one
> (cmp '(?x ?y)
'(a b)
'((?x . a)
(?z . c)))
((?x . a)
(?y . b))
> (cmp '(?x ?y)
'(c b)
'((?x . a)
(?z . c)))
nil
The idea is to return only the found associations, and not the unused ones. So, even though the second test returns non-nil, ?z doesn't appear in the result.