I'm working on an iterative solution to the n queens problem. I've decided to represent the state space as an array of 0's and 1's, such that a 1 represents the presence of a queen. The plan is to generate all permutations of the array and then write a verifier to prune incorrect solutions. I'm trying to do this is common lisp, even though I had never touched functional programming before today.
In order to generate the permutations, I chose to try and implement this algorithm, using the first pseudocode example: http://www.quickperm.org/
Here is my attempt:
(defun permute (n)
(setf total (* n n))
(let ((a (make-array total :initial-element 0)) ;list of objects to permute
(p (make-array total :initial-element 0))) ;array to control iteration
(dotimes (i n) (setf (aref a i) 1))
(loop for index from 1 while (< index total) do
(setf (aref p index) (- (aref p index) 1)) ;decrement p[i] by 1
(if (= (rem index 2) 1) ;if index is odd
(setf j (aref p index)) ;j = p[index]
(setf j 0)) ;else j = 0
(rotatef (aref a index) (aref a j)) ;swap a[index] & a[j]
(setf index 1) ;index = 1
(loop while (= (aref p index) 0) do ;while p[index] == 0
(setf (aref p index) index) ;p[index] = i
(setf index (+ index 1))) ;index++
print a)))
(permute 4)
Currently, I'm getting the error: AREF: index -1 for #array, which seems to be caused by the (setf (aref p index) (- (aref p index) 1)) line. In pseudocode, that line seems to implement p[index] = p[index] - 1. This is the only subtraction operation I have, but it shouldn't be operating on index itself, just on the value at its location.
What am I missing?
EDIT: I initialized every element of p to 0. Each element is actually supposed to be equal to its index. Will post updated code when completed.
It's been a long time since I've written CL, but here is a version that uses some idiomatic forms.
(defun permute (n)
(let ((a (make-array n)) ;list of objects to permute
(p (make-array (1+ n)))) ;array to control iteration
(dotimes (i n) (setf (aref a i) (1+ i)))
(dotimes (i (1+ n)) (setf (aref p i) i))
(setf i 1)
(loop with i = 1 and j = 0 while (< i n) do
(decf (aref p i)) ;decrement p[i] by 1
(setf j (if (oddp i) (aref p i) 0)) ;j = odd(i) ? a[i] : 0
(rotatef (aref a i) (aref a j)) ;swap a[i] & a[j]
(setf i 1) ;i = 1
(loop while (zerop (aref p i)) do ;while p[i] == 0
(setf (aref p i) i) ;p[i] = i
(incf i)) ;index++
(verif a n))))
Here's the final product, in case any sad sap stumbles here some day.
(defun permute (n)
(let ((a (make-array n)) ;list of objects to permute
(p (make-array (+ 1 n)))) ;array to control iteration
(dotimes (i n) (setf (aref a i) (+ i 1)))
(dotimes (i (+ n 1)) (setf (aref p i) i))
(setf index 1)
(loop while (< index n) do
(setf (aref p index) (- (aref p index) 1)) ;decrement p[i] by 1
(if (= (rem index 2) 1) ;if index is odd
(setf j (aref p index)) ;j = p[index]
(setf j 0)) ;else j = 0
(rotatef (aref a index) (aref a j)) ;swap a[index] & a[j]
(setf index 1) ;index = 1
(loop while (= (aref p index) 0) do ;while p[index] == 0
(setf (aref p index) index) ;p[index] = i
(setf index (+ index 1))) ;index++
(verif a n))))
Related
I am using a function from an external library returning a vector of four numbers and I want to access these values directly like it would be possible with destructuring-bind. See this pointless example:
(defun a-vector ()
(vector 1 2 3 4))
(defun a-list ()
(list 1 2 3 4))
(destructuring-bind (a b c d)
(a-list)
(format t "~D ~D ~D ~D~%" a b c d))
(destructuring-bind (a b c d)
(coerce (a-vector) 'list)
(format t "~D ~D ~D ~D~%" a b c d))
If I coerce the vector into a list it is possible and as performance isn't a problem here, it is maybe fine. But I was wondering if there is a more simple way?
You can bind variables to each cell as follows:
(defmacro with-aref ((&rest indices) array &body body)
(let ((a (gensym)))
`(let ((,a ,array))
(symbol-macrolet
,(loop
for n from 0
for i in indices
collect (list i `(aref ,a ,n)))
,#body))))
You would use it as follows:
(with-aref (w x y z) vec
(setf w (+ x y z)))
With a bit more work, you can also support indices and different categories of accessors. Let's say each binding is a triple (i n k) where i is an identifier, n a number (or nil) that represents the numerical index and k is either :place, :value or nil; :place binds the symbol with symbol-macrolet, :value just binds it with let.
First, let's help the user by providing shortcut notations:
x stands for (x nil nil)
(x o) either stands for (x o nil) or (x nil o), depending on whether option o is a number or a symbol (at macroexpansion time).
Besides, we may want to automatically ignore the nil identifier, the empty symbol || or symbols starting with an underscore (e.g. _, _var).
Here is the normalization function:
(defun normalize-index (index)
(flet ((ret (i n k)
(let ((ignored (or (null i)
(string= i "")
(char= #\_ (char (string i) 0)))))
(list (if ignored (gensym) i) n k ignored))))
(let ((index (alexandria:ensure-list index)))
(typecase index
(null (ret nil nil nil))
(cons (destructuring-bind (i &optional n (k nil kp)) index
(if kp
(ret i n k)
(etypecase n
(symbol (ret i nil n))
((integer 0) (ret i n nil))))))))))
We can apply this normalization to a list of indices, and keep track of ignored symbols:
(defun normalize (indices)
(loop
for i in indices
for norm = (normalize-index i)
for (index number kind ignore) = norm
collect norm into normalized
when ignore
collect index into ignored
finally (return (values normalized ignored))))
Then, we take care of nil numbers in normalized entries. We want the indices to increase from the last used index, or be given explicitly by the user:
(defun renumber (indices)
(loop
for (v n k) in indices
for next = nil then (1+ index)
for index = (or n next 0)
collect (list v index k)))
For example:
(renumber (normalize '(a b c)))
((A 0 NIL) (B 1 NIL) (C 2 NIL))
(renumber (normalize '((a 10) b c)))
((A 10 NIL) (B 11 NIL) (C 12 NIL))
(renumber (normalize '((a 10) (b 3) c)))
((A 10 NIL) (B 3 NIL) (C 4 NIL))
We do the same for the kind of variable we bind:
(defun rekind (indices)
(loop
for (v n k) in indices
for next = nil then kind
for kind = (or k next :place)
collect (list v n kind)))
For example:
(rekind (normalize '(a b c)))
((A NIL :PLACE) (B NIL :PLACE) (C NIL :PLACE))
(rekind (normalize '(a (b :value) c)))
((A NIL :PLACE) (B NIL :VALUE) (C NIL :VALUE))
Finally, all those steps are combined in parse-indices:
(defun parse-indices (indices)
(multiple-value-bind (normalized ignored) (normalize indices)
(values (rekind (renumber normalized))
ignored)))
Finally, the macro is as follows:
(defmacro with-aref ((&rest indices) array &body body)
(multiple-value-bind (normalized ignored) (parse-indices indices)
(labels ((ignored (b) (remove-if-not #'ignoredp (mapcar #'car b)))
(ignoredp (s) (member s ignored)))
(loop
with a = (gensym)
for (i n k) in normalized
for binding = `(,i (aref ,a ,n))
when (eq k :value) collect binding into values
when (eq k :place) collect binding into places
finally (return
`(let ((,a ,array))
(let ,values
(declare (ignore ,#(ignored values)))
(symbol-macrolet ,places
(declare (ignore ,#(ignored places)))
,#body))))))))
For example:
(let ((vec (vector 0 1 2 3 4 5 6 7 8 9 10)))
(prog1 vec
(with-aref ((a 2) (b :value) c _ _ d (e 0) (f 1)) vec
(setf a (list a b c d e f)))))
The above is macroexpanded as:
(LET ((VEC (VECTOR 0 1 2 3 4 5 6 7 8 9 10)))
(LET ((#:G1898 VEC))
(LET ((#:G1901 VEC))
(LET ((B (AREF #:G1901 3))
(C (AREF #:G1901 4))
(#:G1899 (AREF #:G1901 5))
(#:G1900 (AREF #:G1901 6))
(D (AREF #:G1901 7))
(E (AREF #:G1901 0))
(F (AREF #:G1901 1)))
(DECLARE (IGNORE #:G1899 #:G1900))
(SYMBOL-MACROLET ((A (AREF #:G1901 2)))
(DECLARE (IGNORE))
(LET* ((#:G19011902 #:G1901)
(#:NEW1 (LIST (AREF #:G1901 2) B C D E F)))
(FUNCALL #'(SETF AREF) #:NEW1 #:G19011902 2)))))
#:G1898))
It produces the following result
#(0 1 (2 3 4 7 0 1) 3 4 5 6 7 8 9 10)
coredump's answer is lovely. This is a variant of it which binds variables rather than accessors, and also lets you optionally specify indices. So
(with-vector-elements ((a 3) b) x
...)
will bind a to the result of (aref x 3) and b to the result of (aref x 4), for instance.
This is really only useful over coredump's answer if you're intending to (a) not write back to the vector and (b) use the bindings a lot, so you want to avoid a lot of possible arefs (which I don't think compilers can generally optimize away without some fairly strong assumptions).
(defmacro with-vector-elements ((&rest indices) vector &body forms)
(let ((canonical-indices
(loop with i = 0
for index in indices
collect (etypecase index
(symbol
(prog1
`(,index ,i)
(incf i)))
(cons
(destructuring-bind (var idx) index
(assert (and (symbolp var)
(typep idx '(and fixnum (integer 0))))
(var idx) "Invalid index spec")
(prog1
index
(setf i (1+ idx))))))))
(vname (gensym "V")))
`(let ((,vname ,vector))
(let ,(loop for (var index) in canonical-indices
collect `(,var (aref ,vname ,index)))
,#forms))))
There is also a package called metabang-bind - with nickname bind - in which the function bind can handle much more destructuring situations:
(ql:quickload :metabang-bind)
(in-package :metabang-bind)
(bind ((#(a b c) #(1 2 3)))
(list a b c))
;; => (1 2 3)
If not using in-package, you can call the function as bind:bind.
The function bind you can think of roughly as a destructuring-let* (similar idea to clojure's let, however not so clean in syntax but understandable because it has also to handle structs and classes and also values).
All the other use cases it can handle are described here.
(defun modsum2 (n)
(let ((summ 0))
(if (>= n 3)
(if (or (zerop (mod n 3)) (zerop (mod n 5)))
(progn (setq summ (+ n summ))
(modsum2 (1- n)))
(modsum2 (1- n)))
(print summ))))
I am trying to get the sum of multiples of 3 and 5 below the given number. But the code always returns to 0. What is the problem with it?
(defun modsum2 (n)
(let ((summ 0))
(if (>= n 3)
(if (or (zerop (mod n 3)) (zerop (mod n 5)))
(progn (setq summ (+ n summ))
(modsum2 (1- n)))
(modsum2 (1- n)))
(print summ))))
Right, now you got it indented. Let's trace it:
* (trace modsum2)
(MODSUM2)
* (modsum2 4)
0: (MODSUM2 4)
1: (MODSUM2 3)
2: (MODSUM2 2)
0 2: MODSUM2 returned 0
1: MODSUM2 returned 0
0: MODSUM2 returned 0
0
You can see that 0 gets printed when the argument to n is 2. Since the print form is also the last form, the function returns its value. (print 0) returns 0. Since the return value is in your function used, it just gets returned from each recursive call.
A typical way to repair it would be to have a local recursive function using labels inside the let. You then need to call the function. Later you would need to return the summ.
;; your function has some flaws
(defun modsum2 (n)
(let ((summ 0)) ;; in every call, `summ` is put to `0`!
(if (>= n 3) ;; for n = 2, the alternative `(print summ)` is executed
(if (or (zerop (mod n 3)) (zerop (mod n 5)))
(progn (setq summ (+ n summ))
(modsum2 (1- n)))
(modsum2 (1- n)))
(print summ)))) ;; for n = 2 already this is called
;; since summ is set to `0` for this last modsum2 call, it prints 0
;; tail call recursion with inner function
(defun modsum2 (n)
(let ((summ 0))
(labels ((.modsum2 (.n)
(cond ((zerop .n) summ)
((or (zerop (mod .n 3)) (zerop (mod .n 5)))
(setq summ (+ .n summ))
(.modsum2 (1- .n)))
(t (.modsum2 (1- .n))))))
(print (.modsum2 n)))))
;; tail call recursion with optional accumulator for the proper start
(defun modsum2 (n &optional (acc 0))
(cond ((zerop n) acc)
((or (zerop (mod n 3))
(zerop (mod n 5)))
(modsum2 (1- n) (+ acc n)))
(t (modsum2 (1- n) acc))))
;; using loop
(defun modsum2 (n)
(loop for x from 1 to n
when (or (zerop (mod x 3)) (zerop (mod x 5)))
sum x into res
finally (return res)))
;; which is equivalent to (thanks #Rainer Joswig):
(defun modsum2 (n)
(loop for x from 1 to n
when (or (zerop (mod x 3)) (zerop (mod x 5)))
sum x))
;; using reduce or apply
(defun modsum2 (n)
(reduce #'+ (remove-if-not #'(lambda (x) (or (zerop (mod x 3))
(zerop (mod x 5))))
(loop for x from 1 to n))))
;; instead of `reduce`, `apply` would work, too.
You’re doing far too much work. Just do inclusion-exclusion:
(defun modsum2 (max)
(let ((a (floor max 3))
(b (floor max 5))
(c (floor max 15)))
(/ (- (+ (* 3 a (1+ a))
(* 5 b (1+ b)))
(* 15 c (1+ c)))
2)))
To extend this a bit to more than just 3,5:
(defun multsum (k max)
"The sum of multiples of `k' below `max'"
(let ((a (floor max k)))
(* k a (1+ a))))
(defun subsequences-reduce (f items)
(unless items (return ()))
(loop for (item . rest) on items
collect (cons 1 item)
nconc (loop for (len . val) in (subsequences-reduce f rest)
collect (cons (1+ len) (funcall f item val)))))
(defun modsum (max &rest nums)
(loop for (len . lcm) in (subsequences-reduce #'lcm nums)
sum (* (if (oddp len) 1 -1) (multsum lcm max))))
(defun modsum2 (max) (modsum max 3 5))
I have solved the same problem last week for project euler. I have noticed the way I wrote it does not included in answers. Dropping it here, it might be useful.
;;finds the multiple of 3's and 5's below the number n
;;since "or" turns t, whenever one of its arguments returns t. No need to substract multiple of 15.
(defun modsum2 (n)
(cond ((< n 3) 0)
(t (do ((i 3 (1+ i))
(summ 0))
((> i n) summ)
(cond ((or (zerop (mod i 3))
(zerop (mod i 5)))
(setq summ (+ summ i))))))))
I wrote the following code for quicksort pretty much similar to the C code. But here it only reads elements to the list.after that it says that the partition function should be a lambda function.I' m new to lisp. Please help me.My code is:-
(print "Enter the elements of the array")
(setq k 10)
(setq A (make-array '(10)))
(setq i 0)
(loop
(if (>= i 10) (return))
(setq x (read))
(setf (aref A i) x)
(incf i)
)
(defun quicksort(start end)
(if (< start end)
((setq pindex (lambda (start end)))
(quicksort(start (- pindex 1)))
(quicksort((+ pindex 1) end))))
)
(defun partition(start end)
(setq pivot (aref A end))
(setq pindex start)
(setq j 0)
(loop
(if (>= j end) return)
(if (< (aref A j) pivot)
((setq temp (aref A pindex))
(setq pindex (aref A j))
(setq (aref A j) temp)
(incf pindex)))
(incf j)
)
(setq temp (aref A pindex))
(setq (aref A pindex) pivot)
(setq (aref A end) temp)
)
(quicksort 0 10)
And want to know whats this lambda function.whether it's just an anonymous name given to a function that is not yet defined
I'll do this step by step. First, use standard formatting:
(print "Enter the elements of the array")
(setq k 10)
(setq A (make-array '(10)))
(setq i 0)
(loop
(if (>= i 10) (return))
(setq x (read))
(setf (aref A i) x)
(incf i))
(defun quicksort (start end)
(if (< start end)
((setq pindex (lambda (start end)))
(quicksort(start (- pindex 1)))
(quicksort((+ pindex 1) end)))))
(defun partition (start end)
(setq pivot (aref A end))
(setq pindex start)
(setq j 0)
(loop
(if (>= j end) return)
(if (< (aref A j) pivot)
((setq temp (aref A pindex))
(setq pindex (aref A j))
(setq (aref A j) temp)
(incf pindex)))
(incf j))
(setq temp (aref A pindex))
(setq (aref A pindex) pivot)
(setq (aref A end) temp))
(quicksort 0 10)
Put out the current problem: parentheses always surround forms, they do not
group forms by themselves.
(print "Enter the elements of the array")
(setq k 10)
(setq A (make-array '(10)))
(setq i 0)
(loop
(if (>= i 10) (return))
(setq x (read))
(setf (aref A i) x)
(incf i))
(defun quicksort (start end)
(if (< start end)
(progn
(setq pindex (lambda (start end)))
(quicksort(start (- pindex 1)))
(quicksort((+ pindex 1) end)))))
(defun partition (start end)
(setq pivot (aref A end))
(setq pindex start)
(setq j 0)
(loop
(if (>= j end) return)
(if (< (aref A j) pivot)
(progn
(setq temp (aref A pindex))
(setq pindex (aref A j))
(setq (aref A j) temp)
(incf pindex)))
(incf j))
(setq temp (aref A pindex))
(setq (aref A pindex) pivot)
(setq (aref A end) temp))
(quicksort 0 10)
Some errors, line by line:
(print "Enter the elements of the array")
(setq k 10) ; warning: no variable K
(setq A (make-array '(10))) ; warning: no variable A
(setq i 0) ; warning: no variable I
(loop
(if (>= i 10) (return))
(setq x (read))
(setf (aref A i) x)
(incf i)) ; warning: k never used
(defun quicksort (start end)
(if (< start end)
(progn
(setq pindex (lambda (start end))) ; this lambda always returns nil
(quicksort (start (- pindex 1))) ; START is not a function
(quicksort ((+ pindex 1) end))))) ; (+ PINDEX 1) is not a function
(defun partition (start end)
(setq pivot (aref A end)) ; warning: no variable PIVOT
(setq pindex start) ; warning: no variable PINDEX
(setq j 0) ; warning: no variable J
(loop
(if (>= j end) return) ; warning: no variable RETURN
(if (< (aref A j) pivot)
(progn
(setq temp (aref A pindex)) ; warning: no variable TEMP
(setq pindex (aref A j))
(setq (aref A j) temp)
(incf pindex)))
(incf j))
(setq temp (aref A pindex))
(setq (aref A pindex) pivot)
(setq (aref A end) temp))
(quicksort 0 10)
Get rid of the "no variable" warnings. Setq does not introduce variables.
Most Common Lisp implementations do something useful so that this seems to work,
but it is undefined behaviour. You could declare these variables globally
special with defvar or defparameter, but what you actually need here is a
function to read user input inside which you can use let to make local
bindings. It also returns the read array instead of setting global state. I
also chose to use K as a parameter for some flexibility of use. Finish-output
ensures that the prompt is displayed before the first number is to be entered.
(defun read-integers (k)
(print "Enter the elements of the array.")
(finish-output)
(let ((a (make-array (list k)))
(i 0))
(loop
(if (>= i k)
(return))
(let ((x (read)))
(setf (aref a i) x)
(incf i)))
a))
This still leaves much room for improvement, but at least it works.
Next: repair quicksort. Since it does not use partition anywhere but sports
an empty lambda form, I assume that you wanted to call partition there. I
also repair the calling forms and missing binding:
(defun quicksort (start end)
(if (< start end)
(let ((pindex (partition start end)))
(quicksort start (- pindex 1))
(quicksort (+ pindex 1) end))))
This operates on a global array that you do not see mentioned anywhere in its
body. This is very confusing and makes the code very unreadable and
unmaintainable. It is much better to give the array as a parameter, so that you
call it as (quicksort (read-integers 10) 0 10).
For performance, we need to operate on it in place, which is unusual enough that
it ought to be mentioned in the docstring. I return the array so that the usual
semantics of sort can be used for it. An IF without alternative clause is
better written as a WHEN.
(defun quicksort (array start end)
"Destructively sorts ARRAY in place."
(when (< start end)
(let ((pindex (partition array start end)))
(quicksort array start (- pindex 1))
(quicksort array (+ pindex 1) end)))
array)
This still contains an off-by-one error, but I'll look at partition now.
First, address the usual binding problems:
(defun partition (array start end)
"Chooses an arbitrary pivot element from array between START and END, then
destructively partitions the elements of ARRAY between START and END
in-place into those smaller than the pivot, then the pivot, then those
bigger than the pivot. Finally returns the index of the pivot."
;; FIXME: doesn't work
(let ((pivot (aref array end))
(pindex start)
(j 0))
(loop
(if (>= j end) (return))
(if (< (aref array j) pivot)
(let ((temp (aref array pindex)))
(setf pindex (aref array j))
(setf (aref array j) temp)
(incf pindex)))
(incf j))
(let ((temp (aref array pindex)))
(setf (aref array pindex) pivot)
(setf (aref array end) temp))))
This is just wrong. Please look up how quicksort works.
Hints:
you need two index variables
you should not reference parts of the array outside of START and END
tip: instead of manual swapping through an explicit temporary place, use rotatef
tip: position-if might be useful. Look it up in the Hyperspec.
tip: test partition by itself. When it works, fix quicksort.
If you want to use multiple statements in the body of an if, you can't just wrap ( ) around them. In Lisp, parens have meaning; they're not for grouping.
Your choices are
(if (< (aref A j) pivot)
(progn
(setq temp (aref A pindex))
(setq pindex (aref A j))
(setq (aref A j) temp)
(incf pindex)))
or
(when (< (aref A j) pivot)
(setq temp (aref A pindex))
(setq pindex (aref A j))
(setq (aref A j) temp)
(incf pindex))
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))))
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.