I am trying to implement a dictionary using lists in Common Lisp. The program is supposed to take a list of words and create a word histogram with frequency of each unique word.
This is the program:
(defparameter *histo* '())
(defun scanList (list)
(loop for word in list
do (if (assoc word histo)
((setf pair (assoc word histo))
(remove pair histo)
(setf f (+ 1 (second pair)))
(setf pair ((car pair) f))
(append histo pair))
((setf pair (word '1)) (append histo pair)))))
The error I get is: (SETF PAIR (ASSOC WORD *HISTO*)) should be a lambda expression.
Where is the syntax or semantic error exactly ?
(defun scanList (list the fox jumped over the other fox))
(princ *histo*)
Use hash-table for creating the dictionary and then transform to an association-list (alist) to sort it by key or value.
(defun build-histo (l)
(let ((dict (make-hash-table :test 'equal)))
(loop for word in l
do (incf (gethash word dict))
finally (return dict))))
;; which was simplification (by #Renzo) of
;; (defun build-histo (l)
;; (let ((dict (make-hash-table :test 'equal)))
;; (loop for word in l
;; for count = (1+ (gethash word dict 0))
;; do (setf (gethash word dict) count)
;; finally (return dict))))
(defparameter *histo* (build-histo '("a" "b" "c" "a" "a" "b" "b" "b")))
(defun hash-table-to-alist (ht)
(maphash #'(lambda (k v) (cons k v)) ht))
;; which is the same like:
;; (defun hash-table-to-alist (ht)
;; (loop for k being each hash-key of ht
;; for v = (gethash k ht)
;; collect (cons k v)))
;; sort the alist ascending by value
(sort (hash-table-to-alist *histo*) #'< :key #'cdr)
;; => (("c" . 1) ("a" . 3) ("b" . 4))
;; sort the alist descending by value
(sort (hash-table-to-alist *histo*) #'> :key #'cdr)
;; => (("b" . 4) ("a" . 3) ("c" . 1))
;; sort the alist ascending by key
(sort (hash-table-to-alist *histo*) #'string< :key #'car)
;; => (("a" . 3) ("b" . 4) ("c" . 1))
;; sort the alist descending by key
(sort (hash-table-to-alist *histo*) #'string> :eky #'car)
;; => (("c" . 1) ("b" . 4) ("a" . 3))
The posted code has a whole lot of problems. The reported error is caused by superfluous parentheses. Parentheses can't be added arbitrarily to expressions in Lisps without causing problems. In this case, these are the offending expressions:
((setf pair (assoc word histo))
(remove pair histo)
(setf f (+ 1 (second pair)))
(setf pair ((car pair) f)
(append histo pair))
((setf pair (word '1)) (append histo pair))
In both of these expressions, the results of the calls to setf are placed in the function position of a list, so the code attempts to call that result as if it is a function, leading to the error.
There are other issues. It looks like OP code is trying to pack expressions into the arms of an if form; this is probably the origin of the extra parentheses noted above. But, if forms can only take a single expression in each arm. You can wrap multiple expressions in a progn form, or use a cond instead (which does allow multiple expressions in each arm). There are some typos: *histo* is mistyped as histo in most of the code; f and pair are not defined anyplace; (setf pair (word '1)) quotes the 1 unnecessarily (which will work, but is semantically wrong).
Altogether, the code looks rather convoluted. This can be made much simpler, still following the same basic idea:
(defparameter *histo* '())
(defun build-histogram (words)
(loop :for word :in words
:if (assoc word *histo*)
:do (incf (cdr (assoc word *histo*)))
:else
:do (push (cons word 1) *histo*)))
This code is almost self-explanatory. If a word has already been added to *histo*, increment its counter. Otherwise add a new entry with the counter initialized to 1. This code isn't ideal, since it uses a global variable to store the frequency counts. A better solution would construct a new list of frequency counts and return that:
(defun build-histogram (words)
(let ((hist '()))
(loop :for word :in words
:if (assoc word hist)
:do (incf (cdr (assoc word hist)))
:else
:do (push (cons word 1) hist))
hist))
Of course, there are all kinds of other ways you might go about solving this.
Related
From the book "ANSI Common Lisp", p. 100 ch 6.1 :
Suppose that a marble is a structure with a single field called color.
The function UNIFORM-COLOR takes a list of marbles and returns
their color, if they all have the same color, or nil if they have
different colors.
UNIFORM-COLOR is usable on a setf place in order to make the color
of each element of list of marbles be a specific color.
(defstruct marble color)
(defun uniform-color (lst &optional (color (and lst (marble-color (car lst)))))
(every #'(lambda (m) (equal (marble-color m) color)) lst))
(defun (setf uniform-color) (color lst)
(mapc #'(lambda (m) (setf (marble-color m) color)) lst))
How could you implement the defun (setf uniform) in a tail-recursive way instead of using the mapc applicative operator ?
This question is specific to the case of (defun (setf ...)), it is not a question about how recursion or tail-recursion work in general.
i guess you can just call setf recursively:
(defun (setf all-vals) (v ls)
(when ls
(setf (car ls) v)
(setf (all-vals (cdr ls)) v)))
CL-USER> (let ((ls (list 1 2 3 4)))
(setf (all-vals ls) :new-val)
ls)
;;=> (:NEW-VAL :NEW-VAL :NEW-VAL :NEW-VAL)
this is how sbcl expands this:
(defun (setf all-vals) (v ls)
(if ls
(progn
(sb-kernel:%rplaca ls v)
(let* ((#:g328 (cdr ls)) (#:new1 v))
(funcall #'(setf all-vals) #:new1 #:g328)))))
For the specific case of marbles:
(defun (setf uniform-color) (color lst)
(when lst
(setf (marble-color (car lst)) color)
(setf (uniform-color (cdr lst)) color)))
General case
The answer is the same for setf functions and regular functions.
Let's say you have another function f that you want to call to print all the values in a list:
(defun f (list)
(mapc 'print list))
You can rewrite it recursively, you have to consider the two distinct case of recursion for a list, either it is nil or a cons cell:
(defun f (list)
(etypecase list
(null ...)
(cons ...)))
Typically in the null case (this is a type), you won't do anything.
In the general cons case (this is also a type), you have to process the first item and recurse:
(defun f (list)
(etypecase list
(null nil)
(cons
(print (first list))
(f (rest list)))))
The call to f is in tail position: its return value is the return value of the enclosing f, no other processing is done to the return value.
You can do the same with your function.
Note
It looks like the setf function defined in the book does not return the value being set (the color), which is bad practice as far as I know:
all that is guaranteed is that the expansion is an update form that works for that particular implementation, that the left-to-right evaluation of subforms is preserved, and that the ultimate result of evaluating setf is the value or values being stored.
5.1.1 Overview of Places and Generalized Reference
Also, in your specific case you are subject to 5.1.2.9 Other Compound Forms as Places, which also says:
A function named (setf f) must return its first argument as its only value in order to preserve the semantics of setf.
In other words (setf uniform-color) should return color.
But apart from that, the same section guarantees that a call to (setf (uniform-color ...) ...) expands into a call to the function named (setf uniform-color), so it can be a recursive function too. This could have been a problem if this was implemented as macro that expands into the body of your function, but fortunately this is not the case.
Implementation
Setting all the colors in a list named marbles to "yellow" is done as follows:
(setf (uniform-color marbles) "yellow")
You can define (setf uniform-color) recursively by first setting the color of the first marble and then setting the color of the rest of the marbles.
A possible tail-recursive implementation that respects the semantics of setf is:
(defun (setf uniform-color) (color list)
(if list
(destructuring-bind (head . tail) list
(setf (marble-color head) color)
(setf (uniform-color tail) color))
color))
I am working on a complicated macro and have run into a roadblock.
(defmacro for-each-hashtable-band (body vars on &optional counter name)
`(block o
(with-hash-table-iterator (next-entry ,on)
(destructuring-bind
,(apply #'append vars)
(let ((current-band (list ,#(mapcar #'not (apply #'append vars)))))
(for (i 1 ,(length (apply #'append vars)) 2)
(multiple-value-bind
(succ k v) (next-entry)
(if succ
(progn
(setf (nth i current-band) k)
(setf (nth (+ 1 i) current-band) v))
(return-from o nil))))
current-band)
,#body))))
im getting "Evaluation aborted on #<UNDEFINED-FUNCTION NEXT-ENTRY {100229C693}>"
i dont understand why next-entry appears to be invisible to the macro i have created.
I've tried stripping down this to a small replicable example but i couldnt find a minimal scenario without the macro i created where next-entry would be invisible besides this scenario no matter what I tried, i've always managed to find a way to call next-entry in my other examples so im stumped as to why i cannot get it working here
I've tested the for macro ive created and it seems to generally work in most cases but for some reason it cannot see this next-entry variable. How do i make it visible?
In your code there are multiple places where the macro generates bindings in a way that is subject to variable capture (pdf).
(defmacro for-each-hashtable-band (body vars on &optional counter name)
`(block o ;; VARIABLE CAPTURE
(with-hash-table-iterator (next-entry ,on) ;; VARIABLE CAPTURE
(destructuring-bind ,(apply #'append vars)
(let ((current-band ;;; VARIABLE CAPTURE
(list ,#(mapcar #'not (apply #'append vars)))))
(for
(i ;;; VARIABLE CAPTURE
1 ,(length (apply #'append vars)) 2)
(multiple-value-bind (succ k v) ;;; VARIABLE CAPTURE
,(next-entry) ;;; WRONG EVALUATION TIME
(if succ
(progn
(setf (nth i current-band) k)
(setf (nth (+ 1 i) current-band) v))
(return-from o nil))))
current-band)
,#body))))
A simplified example of such a capture is:
`(let ((x 0)) ,#body)
Here above, the x variable is introduced, but if the code is expanded in a context where xis already bound, then body will not be able to reference that former x binding and will always see x bound to zero (you generally don't want this behavior).
Write a function instead
Instead of writing a big macro for this, let's first try understanding what you want to achieve and write instead a higher-order function, ie. a function that calls user-provided functions.
If I understand correctly, your function iterates over a hash-table by bands of entries. I assume vars holds a list of (key value) pairs of symbols, for example ((k1 v1) (k2 v2)). Then, body works on all the key/value pairs in the band.
In the following code, the function map-each-hashtable-band accepts a function, a hash-table, and instead of vars it accepts a size, the width of the band (the number of pairs).
Notice how in your code, you only have one loop, which builds a band using the hash-table iterator. But then, since the macro is named for-each-hashtable-band, I assume you also want to loop over all the bands. The macro with-hash-table-iterator provides an iterator but does not loop itself. That's why here I have two loops.
(defun map-each-hashtable-band (function hash-table band-size)
(with-hash-table-iterator (next-entry hash-table)
(loop :named outer-loop :do
(loop
:with key and value and next-p
:repeat band-size
:do (multiple-value-setq (next-p key value) (next-entry))
:while next-p
:collect key into current-band
:collect value into current-band
:finally (progn
(when current-band
(apply function current-band))
(unless next-p
(return-from outer-loop)))))))
For example:
(map-each-hashtable-band (lambda (&rest band) (print `(:band ,band)))
(alexandria:plist-hash-table
'(:a 0 :b 1 :c 2 :d 3 :e 4 :f 5 :g 6))
2)
NB. Iterating over a hash-table happens in an arbitrary order, there is no guarantee that you'll see the entries in any particular kind of order, this is implementation-dependant.
With my current version of SBCL this prints the following:
(:BAND (:A 0 :B 1))
(:BAND (:C 2 :D 3))
(:BAND (:E 4 :F 5))
(:BAND (:G 6))
Wrap the function in a macro
The previous function might not be exactly the behavior you want, so you need to adapt to your needs, but once it does what you want, you can wrap a macro around it.
(defmacro for-each-hashtable-band (vars hash-table &body body)
`(map-each-hashtable-band (lambda ,(apply #'append vars) ,#body)
,hash-table
,(length vars)))
For example:
(let ((test (alexandria:plist-hash-table '(:a 0 :b 1 :c 2 :d 3 :e 4 :f 5))))
(for-each-hashtable-band ((k1 v1) (k2 v2)) test
(format t "~a -> ~a && ~a -> ~a ~%" k1 v1 k2 v2)))
This prints:
A -> 0 && B -> 1
C -> 2 && D -> 3
E -> 4 && F -> 5
Macro-only solution, for completeness
If you want to have only one, single macro, you can start by inlining the body of the above function in the macro, you don't need to use apply anymore, but instead you need to establish bindings around the body, using destructuring-bind as you did. A first draft would be to simply as follows, but notice that this is not a proper solution:
(defmacro for-each-hashtable-band (vars hash-table &body body)
(let ((band-size (length vars)))
`(with-hash-table-iterator (next-entry ,hash-table)
(loop :named outer-loop :do
(loop
:with key and value and next-p
:repeat ,band-size
:do (multiple-value-setq (next-p key value) (next-entry))
:while next-p
:collect key into current-band
:collect value into current-band
:finally (progn
(when current-band
(destructuring-bind ,(apply #'append vars) current-band
,#body))
(unless next-p
(return-from outer-loop))))))))
In order to be free of variable capture problems with macros, each temporary variable you introduce must be named after a symbol that cannot exist in any context you expand your code. So instead we first unquote all the variables, making the macro definition fail to compile:
(defmacro for-each-hashtable-band (vars hash-table &body body)
(let ((band-size (length vars)))
`(with-hash-table-iterator (,next-entry ,hash-table)
(loop :named ,outer-loop :do
(loop
:with ,key and ,value and ,next-p
:repeat ,band-size
:do (multiple-value-setq (,next-p ,key ,value) (,next-entry))
:while ,next-p
:collect ,key into ,current-band
:collect ,value into ,current-band
:finally (progn
(when ,current-band
(destructuring-bind ,(apply #'append vars) ,current-band
,#body))
(unless ,next-p
(return-from ,outer-loop))))))))
When compiling the macro, the macro is supposed to inject symbols into the code, but here we have a compilation error that says undefined variables:
;; undefined variables: CURRENT-BAND KEY NEXT-ENTRY NEXT-P OUTER-LOOP VALUE
So now, those variables should be fresh symbols:
(defmacro for-each-hashtable-band (vars hash-table &body body)
(let ((band-size (length vars)))
(let ((current-band (gensym))
(key (gensym))
(next-entry (gensym))
(next-p (gensym))
(outer-loop (gensym))
(value (gensym)))
`(with-hash-table-iterator (,next-entry ,hash-table)
(loop :named ,outer-loop :do
(loop
:with ,key and ,value and ,next-p
:repeat ,band-size
:do (multiple-value-setq (,next-p ,key ,value) (,next-entry))
:while ,next-p
:collect ,key into ,current-band
:collect ,value into ,current-band
:finally (progn
(when ,current-band
(destructuring-bind ,(apply #'append vars) ,current-band
,#body))
(unless ,next-p
(return-from ,outer-loop)))))))))
This above is a bit verbose, but you could simplify that.
Here is what the previous for-each-hashtable-band example expands into with this new macro:
(with-hash-table-iterator (#:g1576 test)
(loop :named #:g1578
:do (loop :with #:g1575
and #:g1579
and #:g1577
:repeat 2
:do (multiple-value-setq (#:g1577 #:g1575 #:g1579) (#:g1576))
:while #:g1577
:collect #:g1575 into #:g1574
:collect #:g1579 into #:g1574
:finally (progn
(when #:g1574
(destructuring-bind
(k1 v1 k2 v2)
#:g1574
(format t "~a -> ~a && ~a -> ~a ~%" k1 v1 k2
v2)))
(unless #:g1577 (return-from #:g1578))))))
Each time you expand it, the #:gXXXX variables are different, and cannot possibly shadow existing bindings, so for example, the body can use variables named like current-band or value without breaking the expanded code.
So I have lists, looking like this:
((24 . 23) (9 . 6) ... )
and want to custom format the output to something looking like this:
"24/23 9/6 ..."
I tried:
(defun show-pair (ostream pair col-used atsign-used)
(declare (ignore col-used atsign-used))
(format ostream "~d/~d" (first pair) (second pair)))
(let ((x '( 1 . 2))) (format nil "~{~/show-pair/~^~}" (list x)))
as a simple warming up exercise to show a list with only 1 pair. But when trying this in the emacs slime repl, I get the error
The value
2
is not of type
LIST
[Condition of type TYPE-ERROR]
Which, of course is confusing as ~/show-pair/ was expected to handle one entry in the list, which is is the pair, passing the pair to show-pair. But it appears, something else is actually happening.
If you want to do it with format - the problem is to access first and second element of the alist using format directives. I didn't found how I could access them inside a format directive.
However, in such regularly formed structures like an alist, one could flatten the list first and then let format-looping directive consume two elements per looping - then one consumes the pair.
Since the famous :alexandria library doesn't count as dependency in Common Lisp world, one could directly use alexandria:flatten:
(defparameter *al* '((24 . 23) (9 . 6)))
(ql:quickload :alexandria) ;; import alexandria library
(format nil "~{~a/~a~^ ~}" (alexandria:flatten *al*))
;; => "24/23 9/6"
nil return as string
~{ ~} loop over the list
~a/~a the fraction
~^ empty space between the elements but not after last element
flatten by the way without :alexandria-"dependency" would be in this case:
(defun flatten (l)
(cond ((null l) nil)
((atom l) (list l))
(t (append (flatten (car l)) (flatten (cdr l))))))
While waiting for feedback, I found out, where the problem is coming from:
So far, I considered (second x) to behave exactly like (cdr x) but for tagged values, this assumption is wrong. If I change in show-pairs above (in the question) accordingly, it all works.
So, it is not a formatting problem at all, nor any surprises with how ~/foo~/ works.
(defun show-pair (ostream pair col-used atsign-used)
(declare (ignore col-used atsign-used))
(format ostream "~d/~d" (first pair) (cdr pair))) ;; second -> cdr fixes the problem
It is fairly seldom a good idea to use ~/.../ in format in my experience. It's probably much better to simply turn the list you have into the list you need and then process that directly. So, for instance:
> (format t "~&~:{~D/~D~:^, ~}~%"
(mapcar (lambda (p)
(list (car p) (cdr p)))
'((1 . 2) (3 . 4))))
1/2, 3/4
nil
Or if you want to use loop:
> (format t "~&~:{~D/~D~:^, ~}.~%"
(loop for (n . d) in '((1 . 2) (3 . 4))
collect (list n d)))
1/2, 3/4.
nil
The cost (and storage) associated with converting the list is likely to be absolutely tiny compared with the I/O cost of printing it.
Using hints from Redefinition of the print-object method for conses..., you could end up with something like this:
CL-USER> (let ((std-function (pprint-dispatch 'cons)))
(unwind-protect
(progn (set-pprint-dispatch
'cons
(lambda (s o) (format s "~d/~d" (car o) (cdr o))))
(format t "~{~a~%~}" '((23 . 24) (5 . 9))))
(set-pprint-dispatch 'cons std-function))
(format t "~{~a~%~}" '((23 . 24) (5 . 9))))
23/24
5/9
(23 . 24)
(5 . 9)
NIL
CL-USER>
Hiding the bookkeeping;
(defmacro with-fractional-conses (&body body)
(let ((std-function (gensym "std-function")))
`(let ((,std-function (pprint-dispatch 'cons)))
(unwind-protect
(progn (set-pprint-dispatch
'cons
(lambda (s o) (format s "~d/~d"
(car o)
(cdr o))))
,#body)
(set-pprint-dispatch 'cons ,std-function)))))
CL-USER> (with-fractional-conses
(format t "~{~a~%~}"
'((23 . 24) (5 . 9))))
23/24
5/9
NIL
CL-USER>
I wish to replace the first occurrence of a symbol within pairs. For example:
take
(define n '((a . b) . (a . d)))
and i define a method context to replace the first instance (left most) of X with '()
replacing a should give me:
((() . b) a . d)
however i am stuck as my method replaces ALL instances and i am not sure how to add a check for this.
my code is as follows:
(define (context s sym)
(cond ((null? s) #f)
((atom? s)
(if (equal? s sym) '() s ))
(else (cons (context (car s) sym)
(context (cdr s) sym)))))
which gives : ((() . b) () . d)
any help? Thank you
The quickest way is to use a flag indicating whether the replacement has already been done, something along the lines of:
(define (context sxp sym)
(define done #f)
(let loop ((sxp sxp))
(cond (done sxp)
((pair? sxp) (cons (loop (car sxp)) (loop (cdr sxp))))
((eq? sym sxp) (set! done #t) '())
(else sxp))))
It's not very elegant to use set!, but the alternative would be to have the procedure return 2 values, and the resulting let-values code would be even worse in terms of readability IMO.
Also note that I didn't use atom? because it's not defined in standard Scheme; the usual way is to successively test null? then pair?, and handle the atom case in the else clause.
This is a bit more general (you can replace things other than symbols, and you can customize the test, and you can specify any particular number of instances to replace, not just one), and may be a little bit more complicated at first glance than what you're looking for, but here's a solution that works by internally using a continuation-passing style helper function. The main function, subst-n takes a new element, and old element, a tree, a test, and a count. It replaces the first count occurrences of new (as compared with test) with old (or all, if count is not a non-negative integer).
(define (subst-n new old tree test count)
(let substs ((tree tree)
(count count)
(k (lambda (tree count) tree)))
(cond
;; If count is a number and zero, we've replaced enough
;; and can just "return" this tree unchanged.
((and (number? count) (zero? count))
(k tree count))
;; If the tree is the old element, then "return" the new
;; element, with a decremented count (if count is a number).
((test old tree)
(k new (if (number? count) (- count 1) count)))
;; If tree is a pair, then recurse on the left side,
;; with a continuation that will recurse on the right
;; side, and then put the sides together.
((pair? tree)
(substs (car tree) count
(lambda (left count)
(substs (cdr tree) count
(lambda (right count)
(k (cons left right) count))))))
;; Otherwise, there's nothing to do but return this
;; tree with the unchanged count.
(else
(k tree count)))))
> (display (subst-n '() 'a '((a . b) . (a . d)) eq? 1))
((() . b) a . d)
> (display (subst-n '() 'a '((a . b) . (a . d)) eq? 2))
((() . b) () . d)
For my class I need to write a function that accepts a string and add "op" after every consonant found in the string.
What I've got so far is a helper function that checks an individual letter to see if it is a consonant or a vowel. here it is:
(define (check-letter letter)
(if (null? letter)
'empty
(or (char=? letter #\a) (char=? letter #\e)
(char=? letter #\i) (char=? letter #\o)
(char=? letter #\u) (char=? letter #\y))))
So that will give me a true or false for a given letter but I'm not sure how to approach the rest of the problem.
I know I need to use the "string->list" function but I'm very bad with recursive functions.
If anybody could help out and point me in the right direction or somewhere on the internet that might help that would be fantastic
So your initial procedure checks if a char is a vowel. The parameter is a char, no need to check for null here. Also, it's a predicate (returning true or false) so let's call it vowel?:
(define (vowel? letter)
(or (char=? letter #\a) (char=? letter #\e)
(char=? letter #\i) (char=? letter #\o)
(char=? letter #\u) (char=? letter #\y)))
The wrapper function transforming a string to list and back is trivial:
(define (add-op str op)
(list->string
(add-op-list (string->list str) op)))
Now the recursive function, working on a list. You know that a list is constructed as:
`(cons elt1 (cons elt2 (cons elt3 (cons elt4 (.... (cons '() ))))))`
and that recursivity means that
you process the first element (obtained by car), and call the same procedure on the rest of the list (obtained by cdr)
until you reach your base case (here, list is null?, so add the final '())
So this leads to:
(define (add-op-list lst op)
(if (null? lst) ; list is empty: finally add '()
'()
(let ((c (car lst))) ; c is the first element of the list
(if (vowel? c) ; is it a vowel?
(cons c (add-op-list (cdr lst) op)) ; yes, just add it to the resulting list and proces the rest
(cons c (cons op (add-op-list (cdr lst) op))))))) ; no, add c and op
Trying:
> (add-op "Supercalifragilisticexpialidocious" #\!)
"S!up!er!c!al!if!r!ag!il!is!t!ic!ex!p!ial!id!oc!ious!"
Here is a tail-recursive solution (your teacher will surely give you extra-credit for using tail recursion!):
(define (vowel? c)
(member c '(#\a #\e #\i #\o #\u #\y)))
(define (homework-1 string punc)
(let extending ((letters (string->list string)) (result '()))
(cond ((null? letters)
(list->string (reverse result)))
((vowel? (car letters))
(extending (cdr letters)
(cons (car letters) result)))
(else
(extending (cdr letters)
(cons punc (cons (car letters) result))))
> (homework-1 "abc" #\-)
"ab-c-"