I'm new to scheme and stuck on this problem:
Input list = (a b c)
output = (a b c c b a )
Trying to use (reverse) and got the reversed list , but have no idea how to make the list become palindrome.
Simply append the original list to the reversed list.
(define (palindrome lst)
(append lst (reverse lst)))
(define (reverse lst)
(define (iter lst res)
(cond ((null? lst)res)
(else
(iter (cdr lst) (cons (car lst)res)))))
(iter lst '()))
> (palindrome '(1 2 3))
'(1 2 3 3 2 1)
There are many ways to do it. I write my preferred solution here, but you can find other solutions as well.
(define mk/pali
(lambda (l)
((lambda (s) (s s l (lambda (r) (r '()))))
(lambda (s l* ret)
(if (null? l*)
(ret (lambda (x) x))
(s s (cdr l*)
(lambda (r0)
(ret (lambda (y)
(cons (car l*)
(r0 (cons (car l*) y))))))))))))
Because I know that people love to see iterative processes to recursive processes, I eliminated the stacking and I also have a full tail recursive variant. You can choose that that you like the most.
(define mk/pali/tail
(lambda (l)
((lambda (s) (s s l (lambda (r) (r '() (lambda (pali) pali)))))
(lambda (s l* ret)
(if (null? l*)
(ret (lambda (x r) (r x)))
(s s (cdr l*)
(lambda (r0)
(ret (lambda (y r1)
(r0 (cons (car l*) y)
(lambda (z)
(r1 (cons (car l*) z)))))))))))))
Here is a test:
% mit-scheme < mk-pali.scm
MIT/GNU Scheme running under GNU/Linux
....
1 ]=> (mk/pali '(a b c))
;Value: (a b c c b a)
1 ]=> (mk/pali/tail '(a b c))
;Value: (a b c c b a)
Related
This program is meant to multiply all the elements of an array together in scheme and output the total but so far it has only been returning 0 as the output.
(define (mult-list lst)
(if (null? lst)
0
(* (car lst)
(mult-list (cdr lst)))) )
The problem is that 0 * <anything> is still 0, and the multiplication by 0 gets propagated up the function calls since the last function call will always return 0 (which then gets multiplied by the next number, which is still 0, and the next, still 0, etc).
The solution to this would be to return 1 instead of 0, since 1 is the multiplicative identity the same way 0 is the additive identity. Since anything multiplied by 1 is itself, this will mean that the last item in the list gets multiplied by 1 (still = to the last item) which then gets multiplied by the second-to-last item, etc.
Alternatively, instead of returning 1 when the list is empty, you can return the only item in the list ((car lst)) when the list has 1 item left in it ((null? (cdr lst))).
I'm more a fan of Church numerals, which are, along with arithmetic operations on them, expressed as applications of functions in the elegant and fundamental lambda calculus. Note the absence of *.
(define (mult-list lst)
(letrec ((mul (lambda (m n) (lambda (f) (lambda (x) ((m (n f)) x)))))
(church (lambda (n)
(if (= n 0)
(lambda (f) (lambda (x) x))
(lambda (f) (lambda (x) (f (((church (- n 1)) f) x)))))))
(unchurch (lambda (cn) ((cn (lambda (x) (+ x 1))) 0))))
(let loop ((lst (map church lst))
(acc (church 1)))
(if (null? lst)
(unchurch acc)
(loop (cdr lst) (mul (car lst) acc))))))
(write (mult-list '(2 3 4)) ; 24
You might also be interested in the use of a named let to express recursion instead of calling the top-level function directly. Very useful in more complicated functions.
(define mul1 (lambda (l) (apply * l)))
(define mul2 (lambda (l) (reduce-left * 1 l)))
(define mul3
(lambda (l)
((lambda (s) (s s l))
(lambda (s l)
(or (and (null? l) 1)
(* (car l) (s s (cdr l))))))))
And here I wrote the Peano multiplication that looks more complicated, but in fact it is simpler, as it multiplies by using recursive addition! It uses only the operator SUCC, the predicate EQUALP and the constructor ZERO.
(define mul/peano
(lambda (l)
(define SUCC (lambda (x) (+ x 1)))
(define EQUALP =)
(define ZERO 0)
;; Peano Axioms
(define ZEROP (lambda (x) (EQUALP x ZERO)))
(define ONE (SUCC ZERO))
(define SUB1 (lambda (x)
((lambda (s)
(if (ZEROP x) ZERO (s s ONE)))
(lambda (s x+)
(if (EQUALP x x+)
ZERO
(SUCC (s s (SUCC x+))))))))
(define ADD
(lambda (a b r)
((lambda (s) (s s a r))
(lambda (s a c)
(or (and (ZEROP a) (c b))
(s s (SUB1 a)
(lambda (x)
(c (SUCC x)))))))))
((lambda (s) (s s l (lambda (total) total)))
(lambda (s l ret)
(or (and (null? l) (ret ONE))
(and (ZEROP (car l)) (ret ZERO))
(s s (cons (SUB1 (car l)) (cdr l))
(lambda (r1)
(s s (cdr l)
(lambda (r2)
(ADD r1 r2 ret))))))))))
Note that I defined 0-1=0, as this is how Peano does.
If we're willing to count in unary as in the other answers, we might as well just count in unary -- with length:
(define (mult-list lst)
(length
(crossProduct
(map mkList lst))))
(define (mkList n)
(cond ((> n 0) (cons n (mkList (- n 1))))
(else (list))))
(define (crossProduct xs)
(cond
((null? xs) (list (list)))
(else
(let* ((a (car xs))
(d (cdr xs))
(p (crossProduct d)))
(apply append
(map (lambda (x)
(map (lambda (q) (cons x q))
p))
a))))))
Testing:
> (mult-list '(2 3 4))
24
> (crossProduct (map mkList '(2)))
'((2) (1))
> (crossProduct (map mkList '(2 3)))
'((2 3) (2 2) (2 1) (1 3) (1 2) (1 1))
> (crossProduct (map mkList '(2 0 3)))
'()
Related to this question I would like to count the number of matches between the elements of two different lists of lists in a certain position.
For instance:
'((a b c) (d e c) (f g h)) '((a e k) (l f c) (g p c))
would return 2 whenever we specify the matching position as the third one on every list (no matter what the other positions contain).
Is there a function doing this operation? I cannot find it. Thank you.
Solution
I don't know of any readily made functions. So I wrote own.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; filter list of list by inner list element position
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (position-filter lol pos)
(map (lambda (l) (list-ref l pos)) lol))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; intersect two lists (duplicate-preserved)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; without duplicates would be `set-intersect`
(define (list-intersect l1 l2 (acc '()) (test equal?))
(cond ((or (null? l1) (null? l2)) (reverse acc))
((member (car l1) l2 test)
(list-intersect (cdr l1) (remove (car l1) l2) (cons (car l1) acc) test))
(else (list-intersect (cdr l1) l2 acc test))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; intersect two position-filtered lols
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (lol-intersect-at-pos lol-1 lol-2 pos)
(let ((l1 (position-filter lol-1 pos))
(l2 (position-filter lol-2 pos)))
(list-intersect l1 l2)))
;; you can count then how many elements are common by `length`
That's it.
Testing
Since I was too "lazy" to write lol with strings, I wrote a convenience function:
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; convert lol elements to strings
;; convenience function
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(require racket/format) ;; for ~a
(define to-string ~a)
(define (as-strings nested-list (acc '()))
(cond ((null? nested-list) (reverse acc))
((list? (car nested-list))
(as-strings (cdr nested-list)
(cons (as-strings (car nested-list))
acc)))
(else
(as-strings (cdr nested-list)
(cons (to-string (car nested-list))
acc)))))
Equipped with this, we can try out lols with symbols:
(lol-intersect-at-pos '((a b c) (d e c) (f g h))
'((a e k) (l f c) (g p c))
2)
;;'(c c) ;; length is 2
lols with numbers as elements:
(lol-intersect-at-pos '((1 2 3) (4 5 3) (6 7 8))
'((1 5 19) (18 7 3) (29 39 3))
2)
;;'(3 3) ;; length is 2
and lols with strings as elements:
(lol-intersect-at-pos (as-strings '((a b c) (d e c) (f g h)))
(as-strings '((a e k) (l f c) (g p c)))
2)
;;'("c" "c") ;; length is 2
even mixed lols:
(lol-intersect-at-pos '((a b c) (a b "c") (d e 3) (f g "3"))
'((d c c) ("a" "b" c) (1 3 3) (2 4 3))
2)
;;'(c 3) ;; length of that is 2
More complicated Solution with sorting (requires conversion symbol->string with all its complications)
Before that, I wrote this. I leave it for history.
#lang racket
(define (get-position-values lol pos) ; to extract elements at pos in inner lists
(map (lambda (l) (list-ref l pos)) lol))
; to determine all elements common between two lists
; set-intersect would remove duplicates, so I had to write an list-intersect
(define (list-intersect l1 l2 (acc '()) (test-equality equal?) (test-smaller <))
(let ((lst1 (sort l1 test-smaller))
(lst2 (sort l2 test-smaller)))
(cond ((or (null? lst1) (null? lst2)) (reverse acc))
((test-equality (car lst1) (car lst2))
(list-intersect (cdr lst1) (cdr lst2) (cons (car lst1) acc) test-equality test-smaller))
((test-smaller (car lst1) (car lst2))
(list-intersect (cdr lst1) lst2 acc test-equality test-smaller))
(else
(list-intersect lst1 (cdr lst2) acc test-equality test-smaller)))))
; to determine all elements common between two list of lists at position pos
; transformer is the function applied to the extracted list elements (necessary when symbols are used,
; since symbols don't have a test-smaller test, only equality test, but sorting would improve performance ...
; so this function doesn't allow to mixup strings and symbols, because symbols would be converted to strings
; so indistinguishable from strings when applying equality test.
; if one wants better equality test, then one has to construct a more complex test-smaller test function which
; can handle strings, symbols, numbers etc. - and one needs also such a more complex test-equality function -
; and then the transformer can be the identity function.
(define (match-element-lol-pos lol-1 lol-2 pos (test-equality string=?) (test-smaller string<?) (transformer symbol->string))
(let* ((l1 (get-position-values lol-1 pos))
(l2 (get-position-values lol-2 pos))
(sl1 (map transformer l1))
(sl2 (map transformer l2))
(commons (list-intersect sl1 sl2 '() test-equality test-smaller)))
(values (length commons) commons)))
This you can apply then to your example pair of list of lists.
(match-element-lol-pos '((a b c) (d e c) (f g h)) '((a e k) (l f c) (g p c)) 2)
; 2 for third element of inner lists!
Which gives:
;; 2
;; '("c" "c")
List of lists with numbers as elements, one can call like this:
(match-element-lol-pos '((1 2 3) (4 5 3) (6 7 8)) '((1 5 19) (18 7 3) (29 39 3)) 2 = < identity)
;; 2
;; '(3 3)
List of lists with strings as elements, one calls like this.
For convenient reasons, I wrote a function as-strings which converts all elements in a nested list into strings. I was just too lazy to wrap "" around each symbol ...
;; convert all list elements of any nested-list into strings
(require racket/format) ;; for ~a
(define to-string ~a)
(define (as-strings nested-list (acc '()))
(cond ((null? nested-list) (reverse acc))
((list? (car nested-list)) (as-strings (cdr nested-list) (cons (as-strings (car nested-list)) acc)))
(else (as-strings (cdr nested-list) (cons (to-string (car nested-list)) acc)))))
So this can be used then like this:
(match-element-lol-pos (as-strings '((a b c) (d e c) (f g h))) (as-strings '((a e k) (l f c) (g p c))) 2 string=? string<? identity)
;; 2
;; '("c" "c")
I'm trying to duplicate all the entries in a list using Scheme:
This is the code I have:
(define double
(lambda (l)
(cond [(null? l) '()]
[(not (pair? l)) (list l l)]
[else (cons (double (car l)) (double (cdr l)))])))
If my input is (double '(a((b)(c d)(((e)))))), I get back ((a a) (((b b)) ((c c) (d d)) ((((e e)))))).
I want to get (a a((b b)(c c d d)(((e e))))).
How would I do this? If I replace cons with append or list, it messes up even more. I can only use the commands you see up there and commands such as let (and other variations of let), map, atom, if and other logical operators.
The second condition has to be handled a bit differently for this to work, in essence, we have to stop not when we reach an atom, but when we reach a list whose first element is an atom - in this way we can rebuild the output list as needed. Try this:
(define double
(lambda (l)
(cond [(null? l) '()]
[(not (pair? (car l)))
(cons (car l)
(cons (car l)
(double (cdr l))))]
[else (cons (double (car l))
(double (cdr l)))])))
Now it works as expected:
(double '(a ((b) (c d) (((e))))))
=> '(a a ((b b) (c c d d) (((e e)))))
I know this question has been asked before, and my solution is the same as many of the answers but I have a special test case that won't work correctly with the common solution to this problem.
The solution that I have found for the zip problem like many others is
(define (zip l1 l2)(map list l1 l2))
. . .which works great with given arguments such as
(zip '(a b c) '(1 2 3)) => ((a 1) (b 2) (c 3))
but I also want the zip function to work for cases where my arguments do not match length like
(zip '(a b c) '(1)) => ((a 1) (b ()) (c ()))
I have not found a solution to this problem and not really sure how to approach it where each list can be any length.
First, a simple iterative version that works for 2 lists only:
(define (zip lst1 lst2 (placeholder '()))
(define (my-car lst)
(if (empty? lst) placeholder (car lst)))
(define (my-cdr lst)
(if (empty? lst) lst (cdr lst)))
(let loop ((lst1 lst1) (lst2 lst2) (res '()))
(if (and (empty? lst1) (empty? lst2))
(reverse res)
(loop (my-cdr lst1) (my-cdr lst2)
(cons (list (my-car lst1) (my-car lst2)) res)))))
such as
(zip '(a b c) '(1 2 3))
=> '((a 1) (b 2) (c 3))
(zip '(a b c) '(1))
=> '((a 1) (b ()) (c ()))
From this, you can generalise to n lists, but to avoid keyword parameters you have to put the placeholder parameter first:
(define (zip placeholder . lsts)
(define (my-car lst)
(if (empty? lst) placeholder (car lst)))
(define (my-cdr lst)
(if (empty? lst) lst (cdr lst)))
(let loop ((lsts lsts) (res '()))
(if (andmap empty? lsts)
(reverse res)
(loop (map my-cdr lsts)
(cons (apply list (map my-car lsts)) res)))))
such as
(zip '() '(a b c) '(1 2 3))
==> '((a 1) (b 2) (c 3))
(zip '() '(a b c) '(1))
==> '((a 1) (b ()) (c ()))
(zip '() '(a b c) '(1) '(x y))
=> '((a 1 x) (b () y) (c () ()))
I believe that andmap is the only Racket-specific function here, which probably has some Scheme or SRFI equivalent depending on your implementation.
EDIT
Since the solution is based on creating lists of equal length, instead of duplicating the zip algorithm, you can also first add the placeholders to the lists before doing the classic map-list stuff:
(define (zip placeholder . lsts)
(let* ((max-len (apply max (map length lsts))) ; the length of the longest lists
(equal-length-lists ; adjusts all lists to the same length,
(map ; filling with placeholder
(lambda (lst) (append lst (make-list (- max-len (length lst)) placeholder)))
lsts)))
(apply map list equal-length-lists))) ; classical zip
It's not semantically correct to have (zip '(a b c) '(1)) => ((a 1) (b ()) (c ())) (unless you're specifically using () as a placeholder value); it's more sensible to have ((a 1) (b) (c)). Here's an implementation that achieves that:
(define (zip-with-uneven . lists)
(define (advance lst)
(if (null? lst)
lst
(cdr lst)))
(define (firsts lists)
(let loop ((lists lists)
(result '()))
(cond ((null? lists) (reverse result))
((null? (car lists)) (loop (cdr lists) result))
(else (loop (cdr lists) (cons (caar lists) result))))))
(let loop ((lists lists)
(results '()))
(if (andmap null? lists)
(reverse results)
(loop (map advance lists)
(cons (firsts lists) results)))))
andmap is from Racket. If you're not using Racket, you can use every from SRFI 1 instead.
If you really want to use a placeholder, here's a (Racket-specific) version that supports placeholders. The default placeholder is (void), which I presume is never a valid value you'd want to put in your result list.
(define (zip-with-uneven #:placeholder (ph (void)) . lists)
(define (advance lst)
(if (null? lst)
lst
(cdr lst)))
(define (cons-with-placeholder a d)
(if (void? a)
d
(cons a d)))
(define (firsts lists)
(let loop ((lists lists)
(result '()))
(cond ((null? lists) (reverse result))
((null? (car lists))
(loop (cdr lists) (cons-with-placeholder ph result)))
(else (loop (cdr lists) (cons (caar lists) result))))))
(let loop ((lists lists)
(results '()))
(if (andmap null? lists)
(reverse results)
(loop (map advance lists)
(cons (firsts lists) results)))))
I'm trying to write a scheme function that will return the unique atoms found in the input list such that.
> (unique-atoms '(a (b) b ((c)) (a (b))))
(a c b)
> (unique-atoms '(a . a))
(a)
> (unique-atoms '())
()
I was thinking something like this as a start
(define (unique-atoms l)
(if (null? l)
'()
(eq? (car (l) unique-atoms(cdr (l))))))
but I don't know how to collect the atoms that are unique, and create a new list while checking everything recursively.
The following walks list, term by term. If the next value is a list itself, then a recursive call is made with (append next rest) - that is, as list is walked we are flattening sublists at the same time.
We use a (tail) recursive function, looking, to walk the list and to accumulate the rslt. We add to the result when next is not alreay in rslt.
(define (uniquely list)
(let looking ((rslt '()) (list list))
(if (null? list)
rslt
(let ((next (car list))
(rest (cdr list)))
(if (list? next)
(looking rslt (append next rest))
(looking (if (memq next rslt)
rslt
(cons next rslt))
rest))))))
> (uniquely '(a b (a b) ((((a))))))
(b a)
If you really want the code to work for 'improper lists' like '(a . a) then the predicates null? and list? probably need to change.
This problem has two parts:
You need to find a way to visit each element of the given form, recursing into sublists.
You need a way to collect the unique elements being visited.
Here's a solution to the first part:
(define (recursive-fold visitor initial x)
(let recur ((value initial)
(x x))
(cond ((null? x) value)
((pair? x) (recur (recur value (car x)) (cdr x)))
(else (visitor x value)))))
I leave it for you to implement the second part.
I found a half solution where the non unique items are removed, although this wont work for an atom b and a list with b such as '(b (b))
(define (uniqueAtoms l)
(cond ((null? l)
'())
((member (car l) (cdr l))
(uniqueAtoms (cdr l)))
(else
(cons (car l) (uniqueAtoms (cdr l))))))
The easiest way to solve this problem with all kinds of list structures is to divide it into two parts
1) flatten then list - this results in a proper list with no sublists
; if you use Racket, you can use the build-in flatten procedure
; otherwise this one should do
(define (flatten expr)
(let loop ((expr expr) (res '()))
(cond
((empty? expr) res)
((pair? expr) (append (flatten (car expr)) (flatten (cdr expr))))
(else (cons expr res)))))
2) find all unique members of this proper list
(define (unique-atoms lst)
(let loop ((lst (flatten lst)) (res '()))
(if (empty? lst)
(reverse res)
(let ((c (car lst)))
(loop (cdr lst) (if (member c res) res (cons c res)))))))
Tests:
; unit test - Racket specific
(module+ test
(require rackunit)
(check-equal? (unique-atoms '(a (b) b ((c)) (a (b)))) '(a b c))
(check-equal? (unique-atoms '(a (b) b ((c . q)) (a (b . d)))) '(a b c q d))
(check-equal? (unique-atoms '(a . a)) '(a))
(check-equal? (unique-atoms '(a b (a b) ((((a)))))) '(a b))
(check-equal? (unique-atoms '()) '()))