I can't think of way how to split list equally, for example this list:
(("6" "S") ("7" "S") ("8" "S") ("9" "S") ("10" "S") ("J" "S") ("K" "S")
("A" "S") ("6" "C") ("7" "C") ("8" "C") ("9" "C") ("10" "C") ("J" "C")
("Q" "C") ("K" "C") ("A" "C") ("6" "H") ("7" "H") ("8" "H") ("9" "H")
("10" "H") ("J" "H") ("Q" "H") ("K" "H") ("A" "H")("6" "D") ("7" "D")
("8" "D") ("9" "D") ("10" "D") ("J" "D") ("Q" "D") ("K" "D"))
into n lists, for example in 3 or 4 depending how much it is needed to split in.
If in 3 lists then then list that should be returned should look like this:
(("6" "S") ("7" "S") ("8" "S") ("9" "S") ("10" "S") ("J" "S") ("K" "S")
("A" "S") ("6" "C") ("7" "C") ("8" "C") ("9" "C"))
(("10" "C") ("J" "C") ("Q" "C") ("K" "C") ("A" "C")("6" "H") ("7" "H")
("8" "H") ("9" "H") ("10" "H") ("J" "H") ("Q" "H"))
(("K" "H") ("A" "H")("6" "D") ("7" "D") ("8" "D") ("9" "D") ("10" "D")
("J" "D") ("Q" "D") ("K" "D"))
The first list will contain 12 elements, second 12 and the third one 11.
if you look into scheme's take and drop functions you can achieve what you want. for example observe this simple procedure:
(define (splitparts lst num)
(letrec ((recurse
(lambda (lst num acc)
(if (null? lst)
acc
(recurse (drop lst num) num (append acc (list (take lst num))))))))
(recurse lst num '())))
> (splitparts '(1 2 3 4) 2)
((1 2) (3 4))
> (splitparts '(1 2 3 4 5 6 7 8) 2)
((1 2) (3 4) (5 6) (7 8))
now the problem with this is that you if take and drop expect the list to have at least the number of elements that you are requesting.
so we can write our own versions that take up to some number of elements and if they get less they don't care. here is such an implementation of take as inspired by this thread with a properly tail recursive implementation
(define (takeup to lst)
(letrec ((recurse
(lambda (to lst acc)
(if (or (zero? to) (null? lst))
acc
(recurse (- to 1) (cdr lst) (append acc (list (car lst))))))))
(recurse to lst '())))
> (takeup 5 '(1 2 3))
(1 2 3)
> (takeup 5 '(1 2 3 4 5 6 7))
(1 2 3 4 5)
now you can easily write your splitparts function when you implement a similar dropupto function. In common lisp you have the subseq function that you can use to achieve functionality similar to take and drop.
EDIT: common lisp implementations of simple take and drop (please excuse my very non idiomatic CL)
;; recursive implemention of take just for demo purposes.
(defun takeinner (lst num acc)
(if (or (= num 0) (null lst))
acc
(takeinner (cdr lst) (- num 1) (append acc (list (car lst))))))
(defun take (lst num)
(takeinner lst num '()))
;; of course take can be implemented using subseq as drop.
(define take-alternative (lst num)
(subseq lst 0 num))
(defun drop (lst num)
(subseq lst num))
(defun splitpartsinner (lst num acc)
(if (null lst)
acc
(splitpartsinner (drop lst num) num (append acc (list (take lst num))))))
(defun splitparts (lst num)
(splitpartsinner lst num '()))
> (splitparts '(1 2 3 4) 2)
((1 2) (3 4))
this will suffer from the problem described above so you still have to implement the -up-to versions.
Here is a simple CL implementation using loop: this should be easy to understand I think. This kind of collect-a-bunch-of-things is what loop is particularly good at.
(defun partition-list (list parts &key (last-part-longer nil))
;; Partition LIST into PARTS parts. They will all be the same
;; length except the last one which will be shorter or, if
;; LAST-PART-LONGER is true, longer. Doesn't deal with the case
;; where there are less than PARTS elements in LIST at all (it does
;; something, but it may not be sensible).
(loop with size = (if last-part-longer
(floor (length list) parts)
(ceiling (length list) parts))
and tail = list
for part upfrom 1
while tail
collect (loop for pt on tail
for i upfrom 0
while (or (and last-part-longer (= part parts))
(< i size))
collect (first pt)
finally (setf tail pt))))
Try this
(multiple-value-bind (sub-list-size inc)
// returns the sublist size and the adjustment you may use on the last list
// size is the number of lists you wish to create
(round (length list) size)
(let ((iteration 1)
(final-list '())
(sub-list '()))
(dotimes (x (length list))
(cond ((< iteration size)
// if its not the last list, add to the sublist until you reach the limit
(cond ((< (length sub-list) sub-list-size)
(push (nth x list) sub-list))
(t
// when you reach the limit, increment the iteration number and start a new sub list with the current number
(push (reverse sub-list) final-list)
(incf iteration)
(setf sub-list (list (nth x list))))))
(t
// in the last iteration, add to the sub list until you have no more elements
(push (nth x list) sub-list))))
(push (reverse sub-list) final-list)
(reverse final-list)))
i would probably do it this way (though it is more verbose than some of the solutions, i find it more readable and reusable)
first some utility functions:
(defun split-at (n data)
(labels ((split-rec (n acc rest)
(if (or (null rest) (zerop n))
(cons (nreverse acc) rest)
(split-rec (1- n) (cons (car rest) acc) (cdr rest)))))
(split-rec n () data)))
;; this one would count the needed chunk sizes to cover different input cases
(defun chunk-lengths (data-len parts)
(let ((chunk-size (floor (/ data-len parts)))
(longer-chunks (rem data-len parts)))
(nconc (loop :repeat longer-chunks :collect (1+ chunk-size))
(loop :repeat (- parts longer-chunks) :collect chunk-size))))
and the partitioning function:
(defun split-into (chunks-count data)
(nreverse
(car
(reduce (lambda (acc len)
(destructuring-bind (res . remaining-items) acc
(destructuring-bind (l . r) (split-at len remaining-items)
(cons (push l res) r))))
(chunk-lengths (length data) chunks-count)
:initial-value (cons nil data)))))
CL-USER> (split-into 6 '(1 2 3 4 5 6 7 8 9))
;;=> ((1 2) (3 4) (5 6) (7) (8) (9))
CL-USER> (split-into 10 '(1 2 3 4 5))
;;=> ((1) (2) (3) (4) (5) NIL NIL NIL NIL NIL)
notice that this solution guarantees that you get just as many chunks as you requested (even if the collection is shorter than chunks count)
The following function splits a list into sublists of length len. If you want to use the number of sublists s instead of the length of each one of them, call it with (/ (length list) s):
(defun split-list (list len)
;; (split-list '(a b c d e f g) 3) => ((A B C) (D E F) (G))
"Splits the list into sublists of length len. The last element might have fewer than len elements."
(do* ((n 1 (1+ n))
(l list (cdr l))
(l1 nil)
(res nil) )
((null l) (progn (when l1 (push (nreverse l1) res))(nreverse res)))
(push (car l) l1)
(when (= n len)
(push (nreverse l1) res)
(setq l1 nil)
(setq n 0) )))
Related
I'm not been able to make this working on. I'm defining a predicate using deftype SameType(x y) method, which evaluates whether the elements of list x and list y are of the same type, and in the same position. The problem comes when I try to call the predicate for testing. I receive an error ERROR: SameType is undefined This is my code:
(deftype SameType (x y)
`(cond
((and (null x) (null y) T))
(
(and (numberp (car x)) (numberp (car y)))
(SameType (cdr x) (cdr y) )
)
(
(and (stringp (car x)) (stringp (car y)))
(SameType (cdr x) (cdr y) )
)
(
(and (atom (car x)) (atom (car y)))
(SameType (cdr x) (cdr y) )
)
(T nil)
)
)
And this is how I'm calling it
(SameType '(A B C 1 2 4 A) '('() G 2 5 6 A B))
I already checked on various onine resources, even related questions on this site.
deftype can be used to define a type, not a predicate. For instance, to define the type of the lists with only integers, you could write something like:
(defun intlistp (l)
"predicate to check if l is a list consisting only of integers"
(and (listp l) ; l is a list and
(every #'integerp l))) ; every element of l is an integer
(deftype integer-list ()
"the type of list of integers"
`(satisfies intlistp))
and then you can check if a value satisfies this type:
CL-USER> (typep '(1 2 3) 'integer-list)
T
CL-USER> (typep '(1 2.5 3) 'integer-list)
NIL
If you want to check if two lists have the same type according to your definition, then you could define a regular function:
(defun same-type (l1 l2)
"check if lists l1 and l2 have the same length and corresponding
elements of the same CL type"
(cond ((null l1) ; if l1 is null
(null l2)) ; returns true only if also l2 is null
((and (consp l1) ; if l1 is a cons
(consp l2) ; and l2 is a cons too,
(typep (car l1) (type-of (car l2)))) ; and their cars have the same CL type
(same-type (cdr l1) (cdr l2))))) ; go recursively on their cdrs
CL-USER> (same-type '(1 a 3) '(2 b 4))
T
CL-USER> (same-type '(1 "a" 3) '(2 "b" 3))
T
CL-USER> (same-type '(1 a 3) '(2 b 4.5))
NIL
CL-USER> (same-type '(1 a 3) '(2 b 4 3))
NIL
CL-USER> (same-type '(1 2 (3 4)) '(1 6 (4 5)))
T
CL-USER> (same-type '(1 2 (3 4)) '(1 6 (4 5 6)))
T
Note that, as you can see from the last example, the type is checked only for the first level of the list.
Given two lists, return a list whose elements are lists of size two, such that for the i-th list, the first element is the i-th element of the first original list, and the second element is the i-th element of the second original list. If one list is smaller than the other, the resulting list is of the smallest size; and so if one of the lists is empty, return an empty list. For example:
> (zip '(1 2) '(3 4))
'((1 3) (2 4))
> (zip '(1 2 3) '())
'()
> (zip '() '(4 5 6))
'()
> (zip '(8 9) '(3 2 1 4))
'((8 3) (9 2))
> (zip '(8 9 1 2) '(3 4))
'((8 3) (9 4))
Try so:
(map cons '(1 2 3) '(a b c))
or so:
(map list '(1 2 3) '(a b c))
(define zip (lambda (l1 l2) (map list l1 l2)))
->(zip '(1 2 3) '(x y z))
'((1 x) (2 y) (3 z))
Because you didn't post the code you've written, I'm guessing this is homework. I'll give you some hints to get started, this is the general structure of the solution, fill-in the blanks - it'll be much more fun if you reach the correct answer by your own means!
(define (zip lst1 lst2)
(cond ((<???> lst1) ; if the first list is empty
<???>) ; then return the empty list
((<???> lst2) ; if the second list is empty
<???>) ; then also return the empty list
(else ; otherwise
(cons (list ; cons a list with two elements:
<???> ; the first from the first list
<???>) ; and the first from the second list
(zip <???> <???>))))) ; advance recursion over both lists
I tested the above implementation with the sample inputs, and the results are as expected:
(zip '(1 2) '(3 4))
=> '((1 3) (2 4))
(zip '(1 2 3) '())
=> '()
(zip '() '(4 5 6))
=> '()
(zip '(8 9) '(3 2 1 4))
=> '((8 3) (9 2))
(zip '(8 9 1 2) '(3 4))
=> '((8 3) (9 4))
If you've solved the problem for the first element then you can recurse on the rest of the list:
(define (zip l1 l2)
(if (or (null? l1) (null? l2))
'()
(cons (list (car l1) (car l2))
(zip (cdr l1) (cdr l2)))))
provided you handle the base case where either list is empty.
> (zip '(1 2 3 4) '(a b))
((1 a) (2 b))
> (zip '() '(a b))
()
If we accept Racket functions, and also relax the requirement of returning 2-tuples in favor of a more general zip, then I would check out for/list. Here are examples zipping or interleaving two or three lists, stopping at the shortest list.
(define l1 '(a b c))
(define l2 '(1 2 3))
(define l3 '(true false))
;; → '((a 1 true) (b 2 false))
(for/list ([i l1] [j l2] [k l3])
(list i j k))
;; → '((a 1) (b 2) (c 3))
(for/list ([i l1] [j l2])
(list i j))
;; → '()
(for/list ([i l1] [j l2] [k null])
(list i j k))
If your map implementation stops at the shortest list, then zip can be defined with map, Scheme's list procedure and apply. Here's a hint:
(define (zip . lsts)
(apply <??> <??> lsts))
SRFI-1's map is sufficient. So in Racket you add (require (only-in srfi/1 map))
Today, I came across the same exercise and did my own implementation which is different from all the ones people posted here. All the other answers are great. I really liked the most voted one from #Alinsoar.
Definitely, the other answers are actually better than my implementation. But I will post it anyway. Maybe, this can help someone trying to learn Racket.
(define (shorter-list xs ys)
(if (> (length xs) (length ys))
ys
xs))
(define (zip xs ys)
(cond [(null? (shorter-list xs ys)) null]
[true (cons (list (car xs) (car ys)) (zip (cdr xs) (cdr ys)))]))
I'm starting scheme for Gimp script-fu and I don't find a simple way to remove item from a vector.
My only solution is to:
Convert vector to list
Remove item from the list (http://stackoverflow.com/questions/1905222/how-to-delete-an-element-from-a-list-in-scheme)
Convert list to vector
Is it a simplier way?
Here is my code:
(set! myvector (list->vector (delete item (vector->list myvector))))
(define delete
(lambda (item list)
(cond
((equal? item (car list)) (cdr list))
(else (cons (car list) (delete item (cdr list)))))))
That's the way: you need to create a new vector without the element that needs to be removed, copying all the others. But in your code, you're missing the case where the element is not present in the vector, also you don't need to create an intermediate list, go from vector to vector directly. I wrote this with Racket using standard Scheme, it should be easy enough to adapt for script-fu:
(define (vector-delete vec elt)
(let ((new-vec (if (> (vector-length vec) 0)
(make-vector (- (vector-length vec) 1))
(vector))))
(define (loop i j)
(cond ((= i (vector-length vec))
new-vec)
((equal? (vector-ref vec i) elt)
(loop (+ i 1) j))
((< j (vector-length new-vec))
(vector-set! new-vec j (vector-ref vec i))
(loop (+ i 1) (+ j 1)))
(else vec)))
(loop 0 0)))
Use it like this:
(define myvector #(1 2 3))
(set! myvector (vector-delete myvector 3))
myvector
=> '#(1 2)
Or by a more intuitive way :
(define (vector-delete v i)
(vector-append (vector-take v i) (vector-drop v (+ i 1))))
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.
I am having problem to print out all the possible paths. Currently I am only able to print out one path, and if (path-demo "J" "I"), the program will shown this error mcdr: expects argument of type <mutable-pair>; given #f
(define net
'(("A" "B")
("B" "A" "C")
("C" "B" "D")
("D" "C" "E" "F")
("F" "I" "D")
("I" "F")
("E" "D" "J")
("J" "E" "G")
("G" "J" "H")))
(define (path-demo start finish)
(for-each (lambda (x) (display x) (display " "))
(cons "Route:" (shortest-path start finish net))))
(define (shortest-path start end net)
(bfs end (list (list start)) net))
;; Breadth-first search
(define (bfs end queue net)
(display queue) (newline) (newline) ; entertainment
(if (null? queue)
'()
(let ((path (car queue)))
(let ((node (car path)))
(if (equal? node end) ;; Graham used CL eql
(reverse path)
(bfs end
(append (cdr queue)
(new-paths path node net))
net))))))
(define (new-paths path node net)
(map (lambda (n) (cons n path)) (cdr (assoc node net))))
;;
(path-demo "J" "I")
In your definition of net you have forgotten to list the nodes to which H is connected.
When the error occurs node and net have the following values:
node: H
net: ((A B) (B A C) (C B D) (D C E F) (F I D) (I F) (E D J)
(J E G) (G J H)))
Thus
(assoc node net))
will return #f because H has no associations in net.
And this leads to the error from cdr:
cdr: expects argument of type <pair>; given #f
It is likely that the following returns #f:
(cdr (assoc node net))
Regarding comment (for formatting):
(define (new-paths path node net)
(write node)
(newline)
(map (lambda (n) (cons n path)) (cdr (assoc node net))))