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.
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 was asked to write a procedure that computes elements of Pascal's triangle by means of a recursive process. I may create a procedure that returns a single row in the triangle or a number within a particular row.
Here is my solution:
(define (f n)
(cond ((= n 1) '(1))
(else
(define (func i n l)
(if (> i n)
l
(func (+ i 1) n (cons (+ (convert (find (- i 1) (f (- n 1))))
(convert (find i (f (- n 1)))))
l))))
(func 1 n '()))))
(define (find n l)
(define (find i n a)
(if (or (null? a) (<= n 0))
'()
(if (>= i n)
(car a)
(find (+ i 1) n (cdr a)))))
(find 1 n l))
(define (convert l)
(if (null? l)
0
(+ l 0)))
This seems to work fine but it gets really inefficient to find elements of a larger row starting with (f 8). Is there a better procedure that solves this problem by means of a recursive process?
Also, how would I write it, if I want to use an iterative process (tail-recursion)?
There are several ways to optimize the algorithm, one of the best would be to use dynamic programming to efficiently calculate each value. Here is my own solution to a similar problem, which includes references to better understand this approach - it's a tail-recursive, iterative process. The key point is that it uses mutation operations for updating a vector of precomputed values, and it's a simple matter to adapt the implementation to print a list for a given row:
(define (f n)
(let ([table (make-vector n 1)])
(let outer ([i 1])
(when (< i n)
(let inner ([j 1] [previous 1])
(when (< j i)
(let ([current (vector-ref table j)])
(vector-set! table j (+ current previous))
(inner (add1 j) current))))
(outer (add1 i))))
(vector->list table)))
Alternatively, and borrowing from #Sylwester's solution we can write a purely functional tail-recursive iterative version that uses lists for storing the precomputed values; in my tests this is slower than the previous version:
(define (f n)
(define (aux tr tc prev acc)
(cond ((> tr n) '())
((and (= tc 1) (= tr n))
prev)
((= tc tr)
(aux (add1 tr) 1 (cons 1 acc) '(1)))
(else
(aux tr
(add1 tc)
(cdr prev)
(cons (+ (car prev) (cadr prev)) acc)))))
(if (= n 1)
'(1)
(aux 2 1 '(1 1) '(1))))
Either way it works as expected for larger inputs, it'll be fast for n values in the order of a couple of thousands:
(f 10)
=> '(1 9 36 84 126 126 84 36 9 1)
There are a number of soluitons presented already, and they do point out that usign dynamic programming is a good option here. I think that this can be written a bit more simply though. Here's what I'd do as a straightforward list-based solution. It's based on the observation that if row n is (a b c d e), then row n+1 is (a (+ a b) (+ b c) (+ c d) (+ d e) e). An easy easy to compute that is to iterate over the tails of (0 a b c d e) collecting ((+ 0 a) (+ a b) ... (+ d e) e).
(define (pascal n)
(let pascal ((n n) (row '(1)))
(if (= n 0) row
(pascal (- n 1)
(maplist (lambda (tail)
(if (null? (cdr tail)) 1
(+ (car tail)
(cadr tail))))
(cons 0 row))))))
(pascal 0) ;=> (1)
(pascal 1) ;=> (1 1)
(pascal 2) ;=> (1 2 1)
(pascal 3) ;=> (1 3 3 1)
(pascal 4) ;=> (1 4 6 4 1)
This made use of an auxiliary function maplist:
(define (maplist function list)
(if (null? list) list
(cons (function list)
(maplist function (cdr list)))))
(maplist reverse '(1 2 3))
;=> ((3 2 1) (3 2) (3))
I have very recently started learning lisp. Like many others, I am trying my hand at Project Euler problems, however I am a bit stuck at Problem 14 : Longest Collatz Sequence.
This is what I have so far:
(defun collatz (x)
(if (evenp x)
(/ x 2)
(+ (* x 3) 1)))
(defun collatz-sequence (x)
(let ((count 1))
(loop
(setq x (collatz x))
(incf count)
(when (= x 1)
(return count)))))
(defun result ()
(loop for i from 1 to 1000000 maximize (collatz-sequence i)))
This will correctly print the longest sequence (525) but not the number producing the longest sequence.
What I want is
result = maximum [ (collatz-sequence n, n) | n <- [1..999999]]
translated into Common Lisp if possible.
With some help from macros and using iterate library, which allows you to extend its loop-like macro, you could do something like the below:
(defun collatz (x)
(if (evenp x) (floor x 2) (1+ (* x 3))))
(defun collatz-path (x)
(1+ (iter:iter (iter:counting (setq x (collatz x))) (iter:until (= x 1)))))
(defmacro maximizing-for (maximized-expression into (cause result))
(assert (eq 'into into) (into) "~S must be a symbol" into)
`(progn
(iter:with ,result = 0)
(iter:reducing ,maximized-expression by
(lambda (so-far candidate)
(if (> candidate so-far)
(progn (setf ,result i) candidate) so-far)) into ,cause)))
(defun euler-14 ()
(iter:iter
(iter:for i from 1000000 downto 1)
(maximizing-for (collatz-path i) into (path result))
(iter:finally (return (values result path)))))
(Presented without claim of generality. :))
The LOOP variant is not that pretty:
(defun collatz-sequence (x)
(1+ (loop for x1 = (collatz x) then (collatz x1)
count 1
until (= x1 1))))
(defun result ()
(loop with max-i = 0 and max-x = 0
for i from 1 to 1000000
for x = (collatz-sequence i)
when (> x max-x)
do (setf max-i i max-x x)
finally (return (values max-i max-x))))
A late answer but a 'pretty' one, albeit a losing one:
(defun collatz-sequence (x)
(labels ((collatz (x)
(if (evenp x)
(/ x 2)
(+ (* 3 x) 1))))
(recurse scan ((i x) (len 1) (peak 1) (seq '(1)))
(if (= i 1)
(values len peak (reverse seq))
(scan (collatz i) (+ len 1) (max i peak) (cons i seq))))))
(defun collatz-check (n)
(recurse look ((i 1) (li 1) (llen 1))
(if (> i n)
(values li llen)
(multiple-value-bind (len peak seq)
(collatz-sequence i)
(if (> len llen)
(look (+ i 1) i len)
(look (+ i 1) li llen))))))
(defmacro recurse (name args &rest body)
`(labels ((,name ,(mapcar #'car args) ,#body))
(,name ,#(mapcar #'cadr args))))
The professor showed us a drawn-out method to find all permutations of a list, i.e. (a b c) => ((a b c) (a c b) (b a c) (b c a) (c b a) (c a b)), but she said it could be done much more efficiently with foldl or map.
Totally new to the functional mindset. I cannot figure this out for the life of me.
There are scheme versions (you mensioned "foldl" so there is haskell version too on this page) on http://rosettacode.org/wiki/Permutations#Scheme:
(define (insert l n e)
(if (= 0 n)
(cons e l)
(cons (car l)
(insert (cdr l) (- n 1) e))))
(define (seq start end)
(if (= start end)
(list end)
(cons start (seq (+ start 1) end))))
(define (permute l)
(if (null? l)
'(())
(apply append (map (lambda (p)
(map (lambda (n)
(insert p n (car l)))
(seq 0 (length p))))
(permute (cdr l))))))
How about this one?
#lang racket
(define l '(apple banana cheese desk))
(remove-duplicates (for/list ([i 1000000]) (shuffle l)))
Naturally, you'll want to increase the constant for long lists....
(#nothelpfulsorry)
Given a recursive function in scheme how do I change that function to tail recursive, and then how would I implement it using streams? Are there patterns and rules that you follow when changing any function in this way?
Take this function as an example which creates a list of numbers from 2-m (this is not tail recursive?)
Code:
(define listupto
(lambda (m)
(if (= m 2)
'(2)
(append (listupto (- m 1)) (list m)))))
I'll start off by explaining your example. It is definitely not tail recursive. Think of how this function executes. Each time you append you must first go back and make the recursive call until you hit the base case, and then you pull your way back up.
This is what a trace of you function would look like:
(listupto 4)
| (append (listupto(3)) '4)
|| (append (append (listupto(2)) '(3)) '(4))
||| (append (append '(2) '(3)) '(4))
|| (append '(2 3) '(4))
| '(2 3 4)
'(2 3 4)
Notice the V-pattern you see pulling in and then out of the recursive calls. The goal of tail recursion is to build all of the calls together, and only make one execution. What you need to do is pass an accumulator along with your function, this way you can only make one append when your function reaches the base case.
Here is the tail recursive version of your function:
(define listupto-tail
(lambda (m)
(listupto m '())))
# Now with the new accumulator parameter!
(define listupto
(lambda (m accu)
(if (= m 2)
(append '(2) accu)
(listupto (- m 1) (append (list m) accu)))))
If we see this trace, it will look like this:
(listupto 4)
| (listupto (3) '(4)) # m appended with the accu, which is the empty list currently
|| (listupto (2) '(3 4)) # m appended with accu, which is now a list with 4
||| (append '(2) '(3 4))
'(2 3 4)
Notice how the pattern is different, and we don't have to traverse back through the recursive calls. This saves us pointless executions. Tail recursion can be a difficult concept to grasp I suggest taking a look here. Chapter 5 has some helpful sections in it.
Generally to switch to a tail recursive form you transform the code so that it takes an accumulator parameter which builds the result up and is used as the final return value. This is generally a helper function which your main function delegates too.
Something of the form:
(define listupto
(lambda (m)
(listupto-helper m '())))
(define listupto-helper
(lambda (m l)
(if (= m 2)
(append '(2) l)
(listupto-helper (- m 1) (append (list m) l)))))
As the comments point out, the helper function can be replaced with a named let which is apparently (haven't done much/enough Scheme!) more idiomatic (and as the comments suggest cons is much better than creating a list and appending.
(define listupto
(lambda (n)
(let loop ((m n) (l '()))
(if (= m 2)
(append '(2) l)
(loop (- m 1) (cons m l))))))
You also ask about streams. You can find a SICP styled streams used e.g. here or here which have a from-By stream builder defined:
;;;; Stream Implementation
(define (head s) (car s))
(define (tail s) ((cdr s)))
(define-syntax s-cons
(syntax-rules ()
((s-cons h t) (cons h (lambda () t)))))
;;;; Stream Utility Functions
(define (from-By x s)
(s-cons x (from-By (+ x s) s)))
Such streams creation relies on macros, and they must be accessed by special means:
(define (take n s)
(cond ; avoid needless tail forcing for n == 1 !
((= n 1) (list (head s))) ; head is already forced
((> n 1) (cons (head s) (take (- n 1) (tail s))))
(else '())))
(define (drop n s)
(cond
((> n 0) (drop (- n 1) (tail s)))
(else s)))
But they aren't persistent, i.e. take and drop recalculate them on each access. One way to make streams persistent is to have a tailing closure surgically altering the last cons cell on access:
(1 . <closure>)
(1 . (2 . <closure>))
....
like this:
(define (make-stream next this state)
(let ((tcell (list (this state)))) ; tail sentinel cons cell
(letrec ((g (lambda ()
(set! state (next state))
(set-cdr! tcell (cons (this state) g))
(set! tcell (cdr tcell))
tcell)))
(set-cdr! tcell g)
tcell)))
(define (head s) (car s))
(define (tail s)
(if (or (pair? (cdr s))
(null? (cdr s)))
(cdr s)
((cdr s))))
We can now use it like this
(define a (make-stream (lambda (i) (+ i 1)) (lambda (i) i) 1))
;Value: a
a
;Value 13: (1 . #[compound-procedure 14])
(take 3 a)
;Value 15: (1 2 3)
a
;Value 13: (1 2 3 . #[compound-procedure 14])
(define b (drop 4 a))
;Value: b
b
;Value 16: (5 . #[compound-procedure 14])
a
;Value 13: (1 2 3 4 5 . #[compound-procedure 14])
(take 4 a)
;Value 17: (1 2 3 4)
a
;Value 13: (1 2 3 4 5 . #[compound-procedure 14])
Now, what does (make-stream (lambda (i) (list (cadr i) (+ (car i) (cadr i)))) car (list 0 1)) define?
update: in Daniel Friedman's 1994 slides "The Joys of Scheme, Cont'd" we find simpler implementation of these "memoized streams" (as they are called there), making the tail function itself store the forced stream in the tail sentinel, as
(define (tail s)
(if (or (pair? (cdr s))
(null? (cdr s)))
(cdr s)
(let ((n ((cdr s))))
(set-cdr! s n)
(cdr s))))
;; can be used as e.g. (https://ideone.com/v6pzDt)
(define fibs
(let next-fib ((a 0) (b 1))
(s-cons a (next-fib b (+ a b)))))
Here's a tail recursive form -
(define (listupto n)
(let run
((m 0)
(return identity))
(if (> m n)
(return null)
(run (add1 m)
(lambda (r) (return (cons m r)))))))
(listupto 9)
; '(0 1 2 3 4 5 6 7 8 9)
And here it is as a stream -
(define (listupto n)
(let run
((m 0))
(if (> m n)
empty-stream
(stream-cons m
(run (add1 m))))))
(stream->list (listupto 9))
; '(0 1 2 3 4 5 6 7 8 9)