I'm writing a duplicator function using racket. The duplicator function takes a nested list of symbols and numbers L, and produces a nested list of symbols and numbers by "immediately duplicating" each atom (symbol or number) at all levels.
For example:
(duplicator '(a 1 b 2 c 3)) produces (a a 1 1 b b 2 2 c c 3 3),
(duplicator '( (a 1) b ((c)) 2) produces ( (a a 1 1) b b ((c c)) 2 2).
Here is my function:
(define (duplicator ls)
(if (null? ls)
'()
(cons (car ls)
(cons (car ls)
(duplicator (cdr ls))))))
The problem I have is the output for (duplicator '( (a 1) b ((c)) 2)) is '((a 1) (a 1) b b ((c)) ((c)) 2 2), which is not what I want.
Can anyone tell me how to get it right, please?
Here is a solution:
(define (duplicator ls)
(cond ((null? ls) '())
((list? (car ls)) (cons (duplicator (car ls)) (duplicator (cdr ls))))
(else (cons (car ls) (cons (car ls) (duplicator (cdr ls)))))))
(duplicator '((a 1) b ((c)) 2)) ; produces ((a a 1 1) b b ((c c)) 2 2)
Related
I'm trying to create a LISP function that creates from a list all possible pairs.
Example of what I'm trying to achieve: (a b c d) --> ((a b) (a c) (a d) (b c) (b d) (c d))
Any advice please? I'm not sure how to approach this problem
Here is a simple solution:
(defun make-couples (x l)
"makes a list of couples whose first element is x and the second is each element of l in turn"
(loop for y in l collect (list x y)))
(defun all-pairs (l)
"makes a list of all the possible pairs of elements of list l"
(loop for (x . y) on l nconc (make-couples x y)))
A recursive solution is:
(defun make-couples (x l)
"makes a list of couples whose first element is x and the second is each element of l in turn"
(if (null l)
nil
(cons (cons x (first l)) (make-couples x (rest l)))))
(defun all-pairs (l)
"makes a list of all the possible pairs of elements of list l"
(if (null l)
nil
(nconc (make-couples (first l) (rest l))
(all-pairs (rest l)))))
Here is a version (this is quite closely related to Gwang-Jin Kim's) which has two nice properties:
it is tail recursive;
it walks no list more than once;
it allocates no storage that it does not use (so there are no calls to append and so on);
it uses no destructive operations.
It does this by noticing that there's a stage in the process where you want to say 'prepend a list of pairs of this element with the elements of this list to this other list' and that this can be done without using append or anything like that.
It does return the results in 'reversed' order, which I believe is inevitable given the above constraints.
(defun all-pairs (l)
(all-pairs-loop l '()))
(defun all-pairs-loop (l results)
(if (null (rest l))
results
(all-pairs-loop (rest l)
(prepend-pairs-to (first l) (rest l) results))))
(defun prepend-pairs-to (e them results)
(if (null them)
results
(prepend-pairs-to e (rest them) (cons (list e (first them))
results))))
the simplest tail recursive variant without explicit loops / mapcar could also look like this:
(defun pairs (data)
(labels ((rec (ls a bs res)
(cond
((null ls) (nreverse res))
((null bs) (rec
(cdr ls)
(car ls)
(cdr ls)
res))
(t (rec
ls
a
(cdr bs)
(cons (cons a (car bs)) res))))))
(rec data nil nil nil)))
CL-USER> (pairs (list 1 2 3 4))
;; ((1 . 2) (1 . 3) (1 . 4) (2 . 3) (2 . 4) (3 . 4))
Tail call recursive solution:
(defun pairs (lst &key (acc '()))
(if (null (cdr lst))
(nreverse acc)
(pairs (cdr lst)
:acc (append (nreverse
(mapcar #'(lambda (el)
(list (car lst) el))
(cdr lst)))
acc))))
Both nreverses are there just for aesthetics (for a nicer looking output). They can be left out.
Try it with:
(pairs '(a b c d))
;; => ((A B) (A C) (A D) (B C) (B D) (C D))
General Combinations
(defun pair (el lst)
"Pair el with each element of lst."
(mapcar (lambda (x) (cons el x)) lst))
(defun dedup (lst &key (test #'eql))
"Deduplicate a list of lists by ignoring order
and comparing the elements by test function."
(remove-duplicates lst :test (lambda (x y) (null (set-difference x y :test test)))))
(defun comb (lst &key (k 3) (acc '()) (test #'eql))
"Return all unique k-mer combinations of the elements in lst."
(labels ((%comb (lst &key (k k) (acc '()) (test #'eql) (total lst))
(let ((total (if total total lst)))
(cond ((or (null (cdr lst)) (zerop k)) (nreverse acc))
((= k 1) (mapcar #'list lst))
(t (let* ((el (car lst))
(rst (remove-if (lambda (x) (funcall test x el)) total)))
(dedup (%comb (cdr lst)
:k k
:total total
:test test
:acc (append (pair el (comb rst :k (1- k) :test test))
acc)))))))))
(%comb lst :k k :acc acc :test test :total lst)))
The number of combinations are calculatable with the combinations formula:
(defun fac (n &key (acc 1) (stop 1))
"n!/stop!"
(if (or (= n stop) (zerop n))
acc
(fac (1- n) :acc (* acc n) :stop stop)))
(defun cnr (n r)
"Number of all r-mer combinations given n elements.
nCr with n and r given"
(/ (fac n :stop r) (fac (- n r))))
We can test and count:
(comb '(a b c d) :k 2)
;; => ((A D) (B D) (B A) (C D) (C B) (C A))
(comb '(a b c d e f) :k 3)
;; => ((B A F) (C B A) (C B F) (C A F) (D C A) (D C B)
;; => (D C F) (D B A) (D B F) (D A F) (E D A) (E D B)
;; => (E D C) (E D F) (E C A) (E C B) (E C F) (E B A)
;; => (E B F) (E A F))
(= (length (comb '(a b c d e f) :k 3)) (cnr 6 3)) ;; => T
(= (length (comb '(a b c d e f g h i) :k 6)) (cnr 9 6)) ;; => T
I want to merge and sort two sorted association lists with Common Lisp.
I made code. But result is not same with my thought.
(defun MERGEALIST (K L)
(cond ((and (eq nil K) (eq nil L)) nil)
((eq nil K) L)
((eq nil L) K)
((<= (car (car K)) (car (car L)))
(cons K (MERGEALIST (cdr K) L)))
((> (car (car K)) (car (car L)))
(cons L (MERGEALIST K (cdr L))))))
Function's input K and L is sorted association lists.
For example,
K is ((1 . a) (3 . c) (5 . e))
L is ((2 . b) (4 . d)).
I expected that result is ((1 . a) (2 . b) (3 . c) (4 . d) (5 . e)).
But result is completely different.
Why this result is come out?
thanks.
You can simplify it a bit. The main change is like in the comment from jkiiski.
CL-USER 5 > (defun MERGEALIST (K L)
(cond ((and (null K) (null L)) nil)
((null K) L)
((null L) K)
((<= (caar K) (caar L))
(cons (car K) (MERGEALIST (cdr K) L)))
((> (caar K) (caar L))
(cons (car L) (MERGEALIST K (cdr L))))))
MERGEALIST
CL-USER 6 > (mergealist '((1 . a) (3 . c) (5 . e)) '((2 . b) (4 . d)))
((1 . A) (2 . B) (3 . C) (4 . D) (5 . E))
The built-in function merge does it:
CL-USER 9 > (merge 'list
'((1 . a) (3 . c) (5 . e))
'((2 . b) (4 . d))
#'<
:key #'car)
((1 . A) (2 . B) (3 . C) (4 . D) (5 . E))
(cons K (MERGEALIST (cdr K) L))
Here you put the complete list K in front of the "rest" of your computation. You only want the first element of it (that you just tested to "come before" the first element of L):
(cons (car K) (MERGEALIST (cdr K) L))
Though note that you could simplify that a lot:
(defun merge-alists (k l)
(cond
;; Common case first, if both alists are not empty, then select
;; the first element of that alist, whose car is less. Then, recurse.
((and (consp k) (consp l))
(if (<= (caar k) (caar l))
(cons (car k) (merge-alists (cdr k) l))
(cons (car l) (merge-alists k (cdr l)))))
;; One of the alists is empty, use either the not-empty one or ...
((consp k) k)
;; ... just the other (when k is empty or both are empty)
(t l)))
(The last two cond clauses could be simplified to (t (or k l)) ... but that could be a bit too concise to be clearly understandable.)
Or, as already pointed out, use merge.
Please, help me with one simple exercise on the Scheme.
Write function, that return count of atoms on the each level in the
list. For example:
(a (b (c (d e (f) k 1 5) e))) –> ((1 1) (2 1) (3 2) (4 5) (5 1))
My Solution:
(define (atom? x)
(and (not (pair? x)) (not (null? x))))
(define (count L)
(cond ((null? L) 0)
((pair? (car L))
(count (cdr L)))
(else
(+ 1 (count (cdr L))))))
(define (fun L level)
(cons
(list level (count L))
(ololo L level)))
(define (ololo L level)
(if (null? L)
'()
(if (atom? (car L))
(ololo (cdr L) level)
(fun (car L) (+ level 1)))))
(fun '(a (b (c (d e (f) k 1 5) e))) 1)
It's work fine, but give not correctly answer for this list:
(a (b (c (d e (f) (k) 1 5) e)))
is:
((1 1) (2 1) (3 2) (4 4) (5 1))
But we assume that 'f' and 'k' on the one level, and answer must be:
((1 1) (2 1) (3 2) (4 4) (5 2))
How should I edit the code to make it work right?
UPD (29.10.12):
My final solution:
(define A '(a (b (c (d e (f) k 1 5) e))))
(define (atom? x)
(and (not (pair? x)) (not (null? x))))
(define (unite L res)
(if (null? L) (reverse res)
(unite (cdr L) (cons (car L) res))))
(define (count-atoms L answ)
(cond ((null? L) answ)
((pair? (car L))
(count-atoms (cdr L) answ))
(else
(count-atoms (cdr L) (+ answ 1)))))
(define (del-atoms L answ)
(cond ((null? L) answ)
((list? (car L))
(begin
(del-atoms (cdr L) (unite (car L) answ))))
(else
(del-atoms (cdr L) answ))))
(define (count L)
(define (countme L level answ)
(if (null? L) (reverse answ)
(countme (del-atoms L '()) (+ level 1) (cons (cons level (cons (count-atoms L 0) '())) answ))))
(countme L 1 '()))
(count A)
What can you say about this?
Do you know what you get if you run this?
(fun '(a (b (c (d e (f) k 1 5) e)) (a (b (c)))) 1)
You get this:
((1 1) (2 1) (3 2) (4 5) (5 1))
The whole extra nested structure that I added on the right has been ignored. Here is why...
Each recursion of your function does two things:
Count all the atoms at the current "level"
Move down the level till you find an s-expression that is a pair (well, not an atom)
Once it finds a nested pair, it calls itself on that. And so on
What happens in oLoLo when fun returns from the first nested pair? Why, it returns! It does not keep going down the list to find another.
Your function will never find more than the first list at any level. And if it did, what would you to do add the count from the first list at that level to the second? You need to think carefully about how you recur completely through a list containing multiple nested lists and about how you could preserve information at each level. There's more than one way to do it, but you haven't hit on any of them yet.
Note that depending on your implementation, the library used here may need to be imported in some other way. It might be painstakingly difficult to find the way it has to be imported and what are the exact names of the functions you want to use. Some would have it as filter and reduce-left instead. require-extension may or may not be Guile-specific, I don't really know.
(require-extension (srfi 1))
(define (count-atoms source-list)
(define (%atom? x) (not (or (pair? x) (null? x))))
(define (%count-atoms source-list level)
(if (not (null? source-list))
(cons (list level (count %atom? source-list))
(%count-atoms (reduce append '()
(filter-map
(lambda (x) (if (%atom? x) '() x))
source-list)) (1+ level))) '()))
(%count-atoms source-list 1))
And, of course, as I mentioned before, it would be best to do this with hash-tables. Doing it with lists may have some didactic effect. But I have a very strong opposition to didactic effects that make you write essentially bad code.
I've given the assingment to write a function in common lisp to compare two lists to see if they are equal and I have been bared from using the "equal" predicate I can only use "eq" and I seem to come to a wall. I get this error with my code EVAL: variable SETF has no value
The following restarts are available:
and he code:
(defun check(L1 L2)
(cond
((eq L nil) nil)
(setq x (first L1))
(setq y (first L2))
(setf L1 (rest L1))
(setf L2 (rest L2))
(if (eq x y) (check L1 L2))))
(defun b(L1 L2)
(cond
((eq L1 nil) nil)
(setf x (first L1))
(setf y (first L2))
(setf L1 (rest L1))
(setf L2 (rest L2))
(if (and (list x) (list y)
(check(x y))
(if (eq x y) (b(L1 L2))))))
I guess this is what you are looking for:
(defun compare-lists (list1 list2)
(if (and (not (null list1))
(not (null list2)))
(let ((a (car list1)) (b (car list2)))
(cond ((and (listp a) (listp b))
(and (compare-lists a b)
(compare-lists (cdr list1) (cdr list2))))
(t
(and (eq a b)
(compare-lists (cdr list1) (cdr list2))))))
(= (length list1) (length list2))))
Tests:
? (compare-lists '(1 2 3) '(1 2 3))
T
? (compare-lists '(1 2 3) '(1 2 3 4))
NIL
? (compare-lists '(1 2 3) '(1 2 (3)))
NIL
? (compare-lists '(1 2 (3)) '(1 2 (3)))
T
? (compare-lists '(1 2 (a b c r)) '(1 2 (a b c (r))))
NIL
? (compare-lists '(1 2 (a b c (r))) '(1 2 (a b c (r))))
T
Given a list, how would I select a new list, containing a slice of the original list (Given offset and number of elements) ?
EDIT:
Good suggestions so far. Isn't there something specified in one of the SRFI's? This appears to be a very fundamental thing, so I'm surprised that I need to implement it in user-land.
Strangely, slice is not provided with SRFI-1 but you can make it shorter by using SRFI-1's take and drop:
(define (slice l offset n)
(take (drop l offset) n))
I thought that one of the extensions I've used with Scheme, like the PLT Scheme library or Swindle, would have this built-in, but it doesn't seem to be the case. It's not even defined in the new R6RS libraries.
The following code will do what you want:
(define get-n-items
(lambda (lst num)
(if (> num 0)
(cons (car lst) (get-n-items (cdr lst) (- num 1)))
'()))) ;'
(define slice
(lambda (lst start count)
(if (> start 1)
(slice (cdr lst) (- start 1) count)
(get-n-items lst count))))
Example:
> (define l '(2 3 4 5 6 7 8 9)) ;'
()
> l
(2 3 4 5 6 7 8 9)
> (slice l 2 4)
(3 4 5 6)
>
You can try this function:
subseq sequence start &optional end
The start parameter is your offset. The end parameter can be easily turned into the number of elements to grab by simply adding start + number-of-elements.
A small bonus is that subseq works on all sequences, this includes not only lists but also string and vectors.
Edit: It seems that not all lisp implementations have subseq, though it will do the job just fine if you have it.
(define (sublist list start number)
(cond ((> start 0) (sublist (cdr list) (- start 1) number))
((> number 0) (cons (car list)
(sublist (cdr list) 0 (- number 1))))
(else '())))
Try something like this:
(define (slice l offset length)
(if (null? l)
l
(if (> offset 0)
(slice (cdr l) (- offset 1) length)
(if (> length 0)
(cons (car l) (slice (cdr l) 0 (- length 1)))
'()))))
Here's my implementation of slice that uses a proper tail call
(define (slice a b xs (ys null))
(cond ((> a 0) (slice (- a 1) b (cdr xs) ys))
((> b 0) (slice a (- b 1) (cdr xs) (cons (car xs) ys)))
(else (reverse ys))))
(slice 0 3 '(A B C D E F G)) ;=> '(A B C)
(slice 2 4 '(A B C D E F G)) ;=> '(C D E F)