Beeing new to CL and having tried several mapping approaches I still couldn't figure it out.
Is it possible to collect from a nested list all first elements as shown below? Conceptually speaking:
How can one gather a parent node and all its child-nodes from a (not necessarily binary) tree-like structure in CL.
(defparameter *nested-list* (list "a" (list "b" (list "c" "d"))
(list "e" (list "f")
(list "g" "h"))))
The function call...
(defun collect-firsts (*nested-list*)
; ...
)
...should result in something like this:
:-> (('start "a") ("a" "b" "e") ("b" "c") ("c" "d")
("e" "f" "g")("f") ("g" "h"))
Thanks in advance!
How about something like this?
(defun immediate-children (object &aux (result '()))
(labels ((f (object)
(cond
((consp object)
(push (list* (first object)
(mapcar #'f (rest object)))
result)
(first object))
(t object))))
(f object)
result))
CL-USER> (immediate-children *nested-list*)
(("a" "b" "e") ("e" "f" "g") ("g" "h") ("f") ("b" "c") ("c" "d"))
The result isn't exactly what you provided in the question, but I think it still makes sense. It includes ("f") in the results, which is probably reasonable, since there's a node labeled "f" with no children. The traversal order is different too, but if this is just a list of lists of the form (parent child+), then that's probably not a problem.
I have tested the following in emacs and in common-lisp.
The output can be inspected at https://ideone.com/hNEQTJ.
(defparameter *nested-list* (list "a" (list "b" (list "c" "d"))
(list "e" (list "f")
(list "g" "h"))))
(defun collect-firsts (*nested-list*)
(let ((ret `((start ,(car *nested-list*)))))
(labels ((recursion (x)
;; 1st generate list of the name and the cars
(setq ret (append ret
(list (cons (car x)
(mapcar (lambda (el)
(if (listp el) (car el) el))
(cdr x))))))
;; 2nd recurse if required
(mapc (lambda (el)
(when (and (listp el) (cdr el))
(recursion el))) x)
ret))
(recursion *nested-list*)
ret)))
(collect-firsts *nested-list*)
Related
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 have a project about huffman coding, and I am stuck, I don't understand why my code is not working.
This is the exercise:
Write a function add1 which, given a character, adds 1 to its frequency in a frequency list. If the character is not yet in the list of frequencies, it is added.
(add1 "e" '(("l" 1) ("e" 2) ("x" 1))) → (("l" 1) ("e" 3) ("x" 1))
(add1 "e" '(("a" 4) ("b" 3))) → (("a" 4) ("b" 3) ("e" 1))
What I wrote:
(define add1
(lambda (c l)
(if (null? l)
'()
(if (member? c l)
(if (equal? c (caar l))
(+ 1 (cadar l))
(add1 c (cdr l)))
(append l '((c 1)))))
))
The result:
(list (list "l" 1) (list "e" 2) (list "x" 1) (list 'c 1))
It's a bad idea to call add1 the procedure, that clashes with a built-in procedure of the same name. Try this instead:
(define add-one
(lambda (c l)
(cond ((null? l)
(list (list c 1)))
((equal? (caar l) c)
(cons (list c (+ 1 (cadar l))) (cdr l)))
(else
(cons (car l) (add-one c (cdr l)))))))
See how, if we reach an empty list, it's because the character wasn't found in the list, so we must add it at the end. The other two cases are self-explanatory: either the character is the current one, or the character is in the rest of the list. By writing the solution in this way, it's not necessary to use member?. It works as expected:
(add-one "e" '(("l" 1) ("e" 2) ("x" 1)))
=> (("l" 1) ("e" 3) ("x" 1))
(add-one "e" '(("a" 4) ("b" 3)))
=> (("a" 4) ("b" 3) ("e" 1))
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.
(define-struct binding
(
let ; a string
num ; a number
)
)
(define Bind-A (make-binding empty 1))
(define Bind-B (make-binding "A" 2))
(define Bind-C (make-binding "F" 1))
(define Bind-D (make-binding "A" 1))
(define Bind-E (make-binding "C" 1))
(define Bind-F (make-binding "E" 3))
(define Bind-All (list Bind-A Bind-B Bind-C Bind-D Bind-E Bind-F))
So I have a struct for something I will call "binding" and a list which holds all the "bindings" I created. Now for the question: lets say I wanted to create a list which held the letter in each Binding that has the same number as I call a function with. For example:
;;-----------------------------------------------------------------------------
;; Return a string containing the letters (in alphabetical order, separated by a
;; space) of all bindings with the same number in pool of "bindings".
;; If either letter is unknown or if no bindings have the same number
;; Return the null string ("").
;;-----------------------------------------------------------------------------
(define (same-num ; string
which-binding) ; binding to check
pool ; list of all bindings
)
(cond
[(empty? (binding-let which-binding)) ""]
[(equal? (binding-let which-binding) (binding-let (first pool)) ... ]
[else ... ]
)
)
(check-expect (same-num Bind-E Bind-all) "A F")
(check-expect (same-num Bind-F Bind-all) "")
(check-expect (same-num Bind-A Bind-all) "")
I hope this makes sense the way I explained it.. I've been struggling with this for hours and I feel like it is really simple I just don't understand the language enough.
Something like that (I cannot test it right now, but the idea should be clear):
(define (same-num which-binding pool)
(define (iter which lst result)
(cond
((null? (binding-let which-binding)) result)
((null? lst) result)
((equal? (binding-let which-binding)
(binding-let (car lst)))
(iter which (cdr lst) (cons (binding-let (car lst)) result)))
(else (iter which (cdr lst) result))))
(iter which-binding pool null))
This one will return a list of letters. You will have to sort them and join to string yourself :)