I have a grammar:
#S(GRAMMAR
:START '
:SYMBOLS (i ) ( F * T + E)
:NONTS (F T E')
:PRODUCTIONS (#S(PRODUCTION :NONT ' :SENTENTIAL (# E))
#S(PRODUCTION :NONT E :SENTENTIAL (# E + T))
#S(PRODUCTION :NONT E :SENTENTIAL (# T))
#S(PRODUCTION :NONT T :SENTENTIAL (# T * F))
#S(PRODUCTION :NONT T :SENTENTIAL (# F))
#S(PRODUCTION :NONT F :SENTENTIAL (# ( E )))
#S(PRODUCTION :NONT F :SENTENTIAL (# i))))
And this function:
(defun mgoto (s sym)
(princ "Computing GOTO on: ")
(princ sym)
(princ #\Newline)
(let ((result '())
(st (copy-State s)))
(map '()
#'(lambda (x)
(let ((dot (position sym (Production-sentential x))))
(when (not (null dot))
(setq dot (1- dot))
(when (and (>= dot 0)
(char= #\#
(nth dot (Production-sentential x))))
(let ((copy (copy-Production x)))
(rotatef (nth dot (Production-sentential copy))
(nth (1+ dot) (Production-sentential copy)))
(format t "~A~%~%" copy)
(push copy result))))))
(State-productions st))
(make-state :name (list 'I (incf *COUNT*)) :productions result)))
which takes a state and a grammar symbol. The initial state looks like:
#S(STATE
:NAME (I 0)
:PRODUCTIONS (#S(PRODUCTION :NONT ' :SENTENTIAL (# E))
#S(PRODUCTION :NONT E :SENTENTIAL (# T))
#S(PRODUCTION :NONT E :SENTENTIAL (# E + T))
#S(PRODUCTION :NONT T :SENTENTIAL (# F))
#S(PRODUCTION :NONT T :SENTENTIAL (# T * F))
#S(PRODUCTION :NONT F :SENTENTIAL (# I))
#S(PRODUCTION :NONT F :SENTENTIAL (# ( E )))))
and is generated from:
(defun closure (g-prod gr)
(let ((j (list (copy-Production (first g-prod))))
(len0 0)
(grammar gr))
(loop do
(setq len0 (length j))
(map '()
#'(lambda (jprod)
(map '()
#'(lambda (prod2)
(if (not (member prod2 j :test 'tree-equal))
(setq j (append j (list prod2)))))
(get-productions
(1+ (position #\# (Production-sentential jprod)))
(Production-sentential jprod) grammar)))
j)
until (= (length j) len0))
(list (make-State :name (list 'I (incf *COUNT*)) :productions j))))
mgoto on alpha will swap # with alpha for each production in state iff # is immediately before alpha. When I perform this operation on the state structure, the production in the original grammar also changes to reflect the changes I made them in mgoto.
I have tried to copy my structures as much as possible in order to leave the original grammar intact, but despite this, my grammar is always being modified when I compute the goto.
Note: In closure, the gr argument is passed in from a call to
(copy-Grammar)
Reference: I am computing the LR(0) set of items for a bottom-up parser:
http://www.ittc.ku.edu/~kulkarni/teaching/EECS665/assignments/LR0Items/output.txt
Do you have any suggestions for what I'm doing incorrectly?
EDIT:
The call to rotatef in mgoto I suspect is the problem.
Test case:
(rotatef (nth 0 (Production-Sentential (first (State-Productions any-state)))
(nth 1 (Production-Sentential (first (State-Productions any-state))))
When I printed the original grammar and the modified state, both structures were modified.
Is there a way to make rotatef only modify the state structure?
I guess that your copy-production does only a shallow copy, i. e. it copies the top-level structure of a production, but the sententials inside are copied as references.
Related
So I have to count the occurrence of a word(or character, to be more specific) in a list in lisp. For example, the input:
(freq 'c '(a c c c c (c c c e)))
should produce a count of 7, since there are 7 c's in the list argument. The code I have is the following but it does not work. I can count the 4 c's that are base elements and the 3 c's that are in the sublist, but I dont know how to add them together. Also, I'm using only primitive data types.
(defun freq (a L)
(cond
((null L) 0)
((listp (car L)) ( (freq a (car L))) ((freq a (cdr L))))
((eq a (car L))(+ 1 (freq a (cdr L))))
(t ((freq a (cdr L))))))
If it's a character then it's should be written with this prefix -> #\
and the sequence would be a string so there is no need recursion here.
(count #\c "(a c c c c (c c c e))") => 7
What you're dealing with in your example is symbol (with a single quote) through a list which contains other symbols or cons. So if you need to count all the same symbol you could write something like that :
(defparameter *nb* 0)
(defun look-deeper (test seq)
(loop for i in seq do
(compare test i)))
(defun compare (test item)
(let ((type (type-of item)))
(case type
(symbol (when (eql test item) (incf *nb*)))
(cons (look-deeper test item)))))
(look-deeper 'c '(a c c c c (c c c e))) => NIL
*nb* => 7
Or something better..
(defun count-occurences (obj lst)
(let ((acc 0))
(labels ((test (obj-2)
(eq obj obj-2)))
(dolist (x lst)
(if (consp x)
(let ((sample (remove-if-not #'test x)))
(if sample
(incf acc (length sample))))
(if (eq x obj)
(incf acc 1)))))
acc))
We could create a function that takes an obj to test and a lst as the argument and create a local accumulator to keep track of how many times the obj occurs in the list. Then we could create a local function that tests to see if the obj we pass to it is eq to the obj passed as an argument to the global function (also note that if you are working with strings you might want to use string-equal or equal because eq will not work since they are not the same object, but eq will work with symbols which you used in your example). We can then iterate through the list, and if the element in the list is a cons we can use remove-if-not to remove any element that doesn't pass our test (is not eq to the obj), and based on the length of the list increment our accumulator accordingly. If it is not a cons and is eq to our obj we will also increment the accumulator, then we can return the value of our accumulator.
And if we test it:
CL-USER> (count-occurences 'c '(a c c c c (c c c)))
7
Your logic is actually correct, there are just some small mis-parenthesis problems in your code. The only change you need for your code to work is to change you listp and t clauses from
((listp (car L)) ( (freq a (car L))) ((freq a (cdr L))))
into
((listp (car L)) (+ (freq a (car L)) (freq a (cdr L))))
and from
(t ((freq a (cdr L))))
into
(t (freq a (cdr L)))
Then evaluating your function works just as you expect:
(defun freq (a L)
(cond
((null L) 0)
((listp (car L)) (+ (freq a (car L)) (freq a (cdr L))))
((eq a (car L))(+ 1 (freq a (cdr L))))
(t (freq a (cdr L)))))
(freq 'c '((a (c f c)) c c c (c c (d c f (c 8 c) c) e))) ; => 11 (4 bits, #xB, #o13, #b1011)
I came across Pascal Bourguignon's solutions of the 99 Lisp problems and was wondering if his recursive solution of problem 27 using a nested mapcan-mapcar-construct could also be written using nested loops.
His solution is definitely very elegant:
(defun group (set sizes)
(cond
((endp sizes)
(error "Not enough sizes given."))
((endp (rest sizes))
(if (= (first sizes) (length set))
(list (list set))
(error "Cardinal mismatch |set| = ~A ; required ~A"
(length set) (first sizes))))
(t
(mapcan (lambda (combi)
(mapcar (lambda (group) (cons combi group))
(group (set-difference set combi) (rest sizes))))
(combinations (first sizes) set)))))
The function combinations is defined here as:
(defun combinations (count list)
(cond
((zerop count) '(())) ; one combination of zero element.
((endp list) '()) ; no combination from no element.
(t (nconc (mapcar (let ((item (first list)))
(lambda (combi) (cons item combi)))
(combinations (1- count) (rest list)))
(combinations count (rest list))))))
I started with a simple approach:
(defun group-iter (set sizes)
(loop :with size = (first sizes)
:for subgroup :in (combination size set)
:for remaining = (set-difference set subgroup)
:collect (list subgroup remaining) :into result
:finally (return result)))
which results in:
> (group-iter '(a b c d e f) '(2 2 2))
(((A B) (F E D C)) ((A C) (F E D B)) ((A D) (F E C B)) ((A E) (F D C B))
((A F) (E D C B)) ((B C) (F E D A)) ((B D) (F E C A)) ((B E) (F D C A))
((B F) (E D C A)) ((C D) (F E B A)) ((C E) (F D B A)) ((C F) (E D B A))
((D E) (F C B A)) ((D F) (E C B A)) ((E F) (D C B A)))
But now I am totally failing to implement the nesting which takes care of the further processing of remaining. As far as I understood there is always a way to express a recursion with a iteration but how does it look like here?
Structure Definition:
(define-struct movie (title genre stars))
;; title is a nonempty string
;; genre is a nonempty string
;; stars us a list of nonempty strings
I am trying to write a scheme function that consumes a list of movies and produces the genre that occurs most often.
So far, I have the following:
(define (popular-gnere movies)
(local
[(define acc movies genre)
(cond
[(empty? movies) genre]
[(equal? genre (movie-genre (first movies)))
(acc (rest movies genre)))
I'm stuck as to how I can keep count of how many times a specific genre has appeared in a given list of movies.
I understand that accumulated recursion in this case would be most efficient but am having trouble completing my accumulator.
Why don't you fix your parentheses problem and indent the code properly. Press CRTL+i. Where the identation is wrong you probably have missing parentheses. Press Run to evaluate and you'd get proper error messages. When you have something that doesn't produce errors, update this question.
The answer your question you add more parameters to your local procedures than the global. That way you hae a parameter that can hold a count that you increase when you find the search element in the current element.eg.
(define (length lst)
(define (length-aux lst cnt)
(if (null? lst)
cnt
(length-aux (cdr lst) (add1 cnt))))
(length-aux lst 0))
Or better with named let
(define (length lst)
(let length-aux ((lst lst) (cnt 0))
(if (null? lst)
cnt
(length-aux (cdr lst) (add1 cnt)))))
EDIT
I recommend having at least 4 helper procedures that takes each their part of a problem. (Less if you make use racket's own remove, count, and argmax). Note that there are probably many other ways to solve this but this is how I would have solved it without a hash table.
Since you are only interested in genre the first thing to imagine is that you can do (map movie-genre lst) so that you get a list of genres to work with in your main helper.
In your main helper you can build up a list of cons having genre and count. To do that you use a helper count that (count 'c '(a b c d c c a) 0) ==> 3 and you just take the first genre and count the list for those as the first accumulated value, then process the result of (remove 'c '(a b c d c c a) '()) ==> (a d b a) on the rest of the list.
When processing is done you have in your accumulator ((a . 4) (b . 6) ...) and you need a helper (max-genre 'a 4 '((b . 6) (c . 20) (d . 10))) ; ==> c
The main helper would look something like this:
(define (aux lst acc)
(if (null? lst)
(max-genre (caar acc) (cdar acc) (cdr acc))
(aux (remove (car lst) lst '())
(cons (cons (car lst) (count (car lst) lst 0)) acc))))
Now you could do it a lot simpler with a hash table in one pass. You'd still have to have max-genre/argmax after reading all elements once.
First you need to settle on a key-value datatype. You could use association lists, but hash tables are a more efficient choice.
Let's start with a short list:
(define-struct movie (title genre stars))
(define films
(list
(make-movie "Godfater" "Crime" '("Marlon Brando" "Al Pacino"))
(make-movie "Rambo" "Thriller" '("Sylvester Stallone"))
(make-movie "Silence of the Lambs" "Crime" '("Jodie Foster" "Anthony Hopkins"))))
and create an empty hash table
(define h (make-hash))
Now we process every film, updating the hash table as we go:
> (for-each (lambda (e) (hash-update! h e add1 0)) (map movie-genre films))
> h
'#hash(("Thriller" . 1) ("Crime" . 2))
Now we need to find the highest count:
> (hash-values h)
'(1 2)
> (define most (foldl (lambda (e r) (if (> e r) e r)) 0 (hash-values h)))
> most
2
So 2 is our highest count. Now we create a list of all genres with count 2:
> (hash->list h)
'(("Thriller" . 1) ("Crime" . 2))
> (foldl
(lambda (e r) (if (= (cdr e) most) (cons (car e) r) r))
null
(hash->list h))
'("Crime")
Putting it all together:
(define (count-by-genre lst)
(define h (make-hash))
(for-each (lambda (e) (hash-update! h e add1 0)) (map movie-genre lst))
(define most (foldl (lambda (e r) (if (> e r) e r)) 0 (hash-values h)))
(foldl
(lambda (e r) (if (= (cdr e) most) (cons (car e) r) r))
null
(hash->list h)))
But this is quite inefficient, for several reasons:
after updating the hash table, we have to re-iterate over it, create a list and then apply foldl just to find the highest value, whereas we could have just kept note of it while updating the hash table
then again we create a full list (hash->list) and a final result list using foldl.
Lots of consing and stuff. An alternative, more efficient version using Racket-specific for constructs, could be:
(define (count-by-genre lst)
(define h (make-hash))
(define most
(for/fold ((highest 0)) ((e (in-list (map movie-genre lst))))
(define new (add1 (hash-ref h e 0)))
(hash-set! h e new)
(max highest new)))
(for/fold ((res null)) (((k v) (in-hash h)))
(if (= v most) (cons k res) res)))
I need to find all nodes that are children of selected node. Graph is created like this:
(setq graf1 '((A(B C)) (B(D E)) (C (F G )) (D (H)) (E(I)) (F(J)) (G(J)) (H()) (I(J)) (J())))
So, all children from node B are (on first level) D,E, on 2nd H,I, third J.
Here's the code for finding first level children, but as i'm begineer in lisp i cant make it work for other ones.
(defun sledG (cvor graf obradjeni)
(cond ((null graf) '())
((equal (caar graf) cvor)
(dodaj (cadar graf) obradjeni))
(t(sledG cvor (cdr graf) obradjeni)))
(defun dodaj (potomci obradjeni)
(cond ((null potomci) '())
((member (car potomci) obradjeni)
(dodaj (cdr potomci) obradjeni )
(t(cons (car potomci)
(dodaj (cdr potomci) obradjeni) ))))
(setq graf1 '((A(B C)) (B(D E)) (C (F G )) (D (H)) (E(I)) (F(J)) (G(J)) (H()) (I(J)) (J())))
Using alexandria package:
(defvar *graf*
'((a (b c)) (b (d e)) (c (f g)) (d (h)) (e (i)) (f (j)) (g (j)) (h nil) (i (j)) (j nil)))
(defun descendants (tree label)
(let ((generation
(mapcan #'cadr
(remove-if-not
(alexandria:compose (alexandria:curry #'eql label) #'car)
tree))))
(append generation (mapcan (alexandria:curry #'descendants tree) generation))))
;; (D E H I J)
I believe, this is what you wanted to do. This will work for acyclic graphs, but it will recur "forever", if you have a cycle in it. If you wanted to add depth counter, you could add it as one more argument to descendants or in the last mapcan transform the resulting list by inserting the depth counter.
With depth included:
(defun descendants (tree label)
(labels ((%descendants (depth label)
(let ((generation
(mapcan #'cadr
(remove-if-not
(alexandria:compose
(alexandria:curry #'eql label) #'car)
tree))))
(append (mapcar (alexandria:compose
#'nreverse
(alexandria:curry #'list depth))
generation)
(mapcan (alexandria:curry #'%descendants (1+ depth))
generation)))))
(%descendants 0 label)))
;; ((D 0) (E 0) (H 1) (I 1) (J 2))
As I read it, the graph is a directed graph. So to find the children (directed edges) of the graph (in the example),
(defun children (node graph) (second (assoc node graph)))
then
(children 'b graf1) ; with graf1 from the OP
returns (D E). All you have to do then is to loop over the children, something like (very quick and dirty)
(defun all-children (node graph)
(let ((c (children node graph)))
(if (null c) nil
(union c (loop for x in c appending (all-children x graph))))))
This returns (J I H D E) as children of B.
I am learning Lisp. I have implemented a Common Lisp function that merges two strings that are ordered alphabetically, using recursion. Here is my code, but there is something wrong with it and I didn't figure it out.
(defun merge (F L)
(if (null F)
(if (null L)
F ; return f
( L )) ; else return L
;else if
(if (null L)
F) ; return F
;else if
(if (string< (substring F 0 1) (substring L 0 1)
(concat 'string (substring F 0 1)
(merge (substring F 1 (length F)) L)))
(
(concat 'string (substring L 0 1)
(merge F (substring L 1 (length L)) ))
))))
Edit :
I simply want to merge two strings such as the
inputs are string a = adf and string b = beg
and the result or output should be abdefg.
Thanks in advance.
Using string< is an overkill, char< should be used instead, as shown by Kaz. Recalculating length at each step would make this algorithm quadratic, so should be avoided. Using sort to "fake it" makes it O(n log n) instead of O(n). Using concatenate 'string all the time probably incurs extra costs of unneeded traversals too.
Here's a natural recursive solution:
(defun str-merge (F L)
(labels ((g (a b)
(cond
((null a) b)
((null b) a)
((char< (car b) (car a))
(cons (car b) (g a (cdr b))))
(t (cons (car a) (g (cdr a) b))))))
(coerce (g (coerce F 'list) (coerce L 'list))
'string)))
But, Common Lisp does not have a tail call optimization guarantee, let alone tail recursion modulo cons optimization guarantee (even if the latter was described as early as 1974, using "Lisp 1.6's rplaca and rplacd field assignment operators"). So we must hand-code this as a top-down output list building loop:
(defun str-merge (F L &aux (s (list nil)) ) ; head sentinel
(do ((p s (cdr p))
(a (coerce F 'list) (if q a (cdr a)))
(b (coerce L 'list) (if q (cdr b) b ))
(q nil))
((or (null a) (null b))
(if a (rplacd p a) (rplacd p b))
(coerce (cdr s) 'string)) ; FTW!
(setq q (char< (car b) (car a))) ; the test result
(if q
(rplacd p (list (car b)))
(rplacd p (list (car a))))))
Judging by your comments, it looks like you're trying to use if with a series of conditions (like a series of else ifs in some other languages). For that, you probably want cond.
I replaced that if with cond and cleaned up some other errors, and it worked.
(defun empty (s) (= (length s) 0))
(defun my-merge (F L)
(cond
((empty F)
(if (empty L)
F
L))
((empty L)
F)
(t
(if (string< (subseq F 0 1) (subseq L 0 1))
(concatenate 'string (subseq F 0 1) (my-merge (subseq F 1 (length F)) L))
(concatenate 'string (subseq L 0 1) (my-merge F (subseq L 1 (length L))))))))
Your test case came out as you wanted it to:
* (my-merge "adf" "beg")
"abdefg"
There were quite a few good answers, so why would I add one more? Well, the below is probably more efficient then the other answers here.
(defun merge-strings (a b)
(let* ((lena (length a))
(lenb (length b))
(len (+ lena lenb))
(s (make-string len)))
(labels
((safe-char< (x y)
(if (and x y) (char< x y)
(not (null x))))
(choose-next (x y)
(let ((ax (when (< x lena) (aref a x)))
(by (when (< y lenb) (aref b y)))
(xy (+ x y)))
(cond
((= xy len) s)
((safe-char< ax by)
(setf (aref s xy) ax)
(choose-next (1+ x) y))
(t
(setf (aref s xy) by)
(choose-next x (1+ y)))))))
(choose-next 0 0))))
(merge-strings "adf" "beg")
It is more efficient specifically in the sense of memory allocations - it only allocates enough memory to write the result string, never coerces anything (from list to string or from array to string etc.) It may not look very pretty, but this is because it is trying to do every calculation only once.
This is, of course, not the most efficient way to write this function, but programming absolutely w/o efficiency in mind is not going to get you far.
A recursive way to do it (fixed according to comment- other solutions can get an IF form as well).
(defun merge-strings (a b)
(concatenate 'string
(merge-strings-under a b)))
(defun merge-strings-under (a b)
(when (and
(= (length a)
(length b))
(> (length a) 0))
(append (if (string< (aref a 0) (aref b 0))
(list (aref a 0) (aref b 0))
(list (aref b 0) (aref a 0)))
(merge-strings-under (subseq a 1)
(subseq b 1)))))
Here's a iterative way to do it.
(concatenate 'string
(loop for i across "adf" for j across "beg" nconc (list i j)))
Note that these rely on building the string into a list of characters, then vectorizing it ( a string is a vector of characters).
You can also write a more C-esque approach...
(defun merge-strings-vector (a b)
(let ((retstr (make-array (list (+
(length a)
(length b)))
:element-type 'character)))
(labels ((merge-str (a b i)
(when (and
(= (length a)
(length b))
(/= i (length a)))
(setf (aref retstr (* 2 i)) (aref a i))
(setf (aref retstr (1+ (* 2 i))) (aref b i))
(merge-str a b (1+ i)))))
(merge-str a b 0)
retstr)))
Note that this one - unlike the other 2 - has side effects within the function. It also, imo, is more difficult to understand.
All 3 take varying numbers of cycles to execute on SBCL 56; each seems to take between 6K and 11K on most of my trials. I'm not sure why.