I am trying to delete second last ATOM from the given list -
(define (butSecondLastAtom lst1)
(cond
((null? lst1) '())
((null? (cdr lst1)) lst1)
((null? (cddr lst1))
(cond((not(pair? (car lst1))) (cdr lst1))
(else (cons(butLastAtom (car lst1)) (cdr lst1)))))
(else (cons (car lst1) (butSecondLastAtom(cdr lst1))))))
(define (butLastAtom x)
(cond ((null? (cdr x))
(cond ((not(pair? (car x))) '())
(else (cons (butLastAtom(car x)) '()))))
(else (cons (car x) (butLastAtom(cdr x))))))
This code do delete the second last atom but fails for following condition -
if input is like (a (b (c (d)))) then output should result in (a (b ((d)))).
Please update where i am being wrong or with a solution.
Here's a solution that's basically copying a tree. The trick to removing an element at a given position from the right is to decrement n each time we process a leaf. The element that we want to remove must be the car of some pair, so the part of the copying routine that rebuilds a pair just needs to be able to watch for when that happens. We can "signal" it by returning some special value instead of the nth item. What special value can we use? We've already defined an internal function that nothing else will have access to, so we can use it.
(define (rem n tree)
;; Returns a new tree similar to the input,
;; but without the nth leaf from the right.
(let rem ((tree tree))
(cond
;; Copy the empty tree by returning the empty tree.
((null? tree)
'())
;; Copy a pair by copying the right and left subtrees,
;; and then putting them back together. The exception
;; is when the car is the nth element (and the "copy" of
;; it is the special value). In that case, we just
;; return the copy of the right subtree.
((pair? tree)
(let ((r (rem (cdr tree))) ; copy the right subtree
(l (rem (car tree)))) ; copy the left subtree
(if (eq? l rem)
r
(cons l r))))
;; When we encounter a leaf, decrement the counter.
;; If it's zero (which means we want to discard this leaf),
;; then return the special value. Otherwise, return
;; the leaf.
(else
(set! n (- n 1))
(if (= n 0) rem tree)))))
> (rem 2 '(a (b (c (d)))))
(a (b ((d))))
After that, it's easy to define your more specific version:
(define (butSecondLastAtom lst1)
(rem 2 lst1))
> (butSecondLastAtom '(a b (c d) ((e f) (g))))
(a b (c d) ((e) (g)))
The following works for my understanding of the problem, but since you provide only one testcase please make sure this is what you want.
The solution has 2 passes:
pass 1 - count the number of atoms
Fairly classical, count how many atoms we have so that we can compute which one to drop later on:
(define (count-atoms sexp)
(cond
((null? sexp) 0)
((pair? sexp) (+ (count-atoms (car sexp)) (count-atoms (cdr sexp))))
(else 1)))
pass 2 - copy without the second last
First, I need an atom? predicate here:
(define (atom? x)
(not (or (pair? x) (null? x))))
Copying without dropping any element is very similar to the previous function:
(define (copy sexp)
(cond
((or (null? sexp) (atom? sexp)) sexp)
(else (cons (copy (car sexp)) (copy (cdr sexp))))))
In order to drop an element, we need to change the second clause, and introduce a counter so that we know when we meet the element to drop:
(define (butSecondLastAtom sexp)
(define n 1) ; counter of atoms
(define ignore (count-atoms sexp)) ; index of element to ignore
(define (sub sexp) ; the copy subroutine
(cond
((null? sexp) null)
((atom? sexp)
(set! n (add1 n)) ; increase n
sexp)
(else
(let* ((left (sub (car sexp))) ; process car of cons cell
(leftn n) ; keep track of n after processing car
(right (sub (cdr sexp))) ; process cdr of cons cell
(rightn n)) ; keep track of n after processing cdr
(cond
((and (atom? left) (= leftn ignore)) right)
((and (atom? right) (= rightn ignore)) left)
(else (cons left right)))))))
(sub sexp))
Here are my test cases:
(require rackunit)
(check-equal? (butSecondLastAtom null) null)
(check-equal? (butSecondLastAtom 1) 1)
(check-equal? (butSecondLastAtom '(a b)) '(b))
(check-equal? (butSecondLastAtom '(a . b)) 'b)
(check-equal? (butSecondLastAtom '(a (b . c))) '(a c))
(check-equal? (butSecondLastAtom '(1 2 (3 (4 5 (6 . 7))))) '(1 2 (3 (4 5 7))))
(check-equal? (butSecondLastAtom '(a (b (c) d))) '(a (b () d)))
(check-equal? (butSecondLastAtom '(a (c d) e)) '(a (c) e))
(check-equal? (butSecondLastAtom '(a (b (c (d))))) '(a (b ((d)))))
Related
How do I recursively merge jumping pairs of elements of a list of lists? I need to have
'((a b c) (e d f) (g h i))
from
'((a b) c (e d) f (g h) i)
My attempt
(define (f lst)
(if (or (null? lst)
(null? (cdr lst)))
'()
(cons (append (car lst) (list (cadr lst)))
(list (append (caddr lst) (cdddr lst))))))
works if I define
(define listi '((a b) c (d e) f))
from which I obtain
((a b c) (d e f))
by doing simply
(f listi)
but it does not work for longer lists. I know I need recursion but I don't know where to insert f again in the last sentence of my code.
A simpler case that your algorithm fails: (f '((1 2) 3)) should result in '((1 2 3)), but yours results in an error.
We will define some terms first:
An "element" is a regular element, like 1 or 'a.
A "plain list" is simply a list of "element"s with no nested list.
E.g., '(1 2 3) is a plain list. '((1 2) 3) is not a plain list.
A "plain list" is either:
an empty list
a cons of an "element" and the next "plain list"
A "list of jumping pairs" is a list of even length where the odd index has a "plain list", and the even index has an element. E.g., '((1) 2 (a) 4) is a "list of jumping pairs". A "list of jumping pairs" is either:
an empty list
a cons of
a "plain list"
a cons of an "element" and the next "list of jumping pairs"
We are done with terminology. Before writing the function, let's start with some examples:
(f '()) equivalent to (f empty)
should output '()
equivalent to empty
(f '((1 2) 3)) equivalent to (f (cons (cons 1 (cons 2 empty))
(cons 3
empty)))
should output '((1 2 3))
equivalent to (cons (cons 1 (cons 2 (cons 3 empty)))
empty)
(f '((1 2) 3 (4) a)) equivalent to (f (cons (cons 1 (cons 2 empty))
(cons 3
(cons (cons 4 empty)
(cons 'a
empty)))))
should output '((1 2 3) (4 a))
equivalent to (cons (cons 1 (cons 2 (cons 3 empty)))
(cons (cons 4 (cons 'a empty))
empty))
So, f is a function that consumes a "list of jumping pairs" and returns a list of "plain list".
Now we will write the function f:
(define (f lst)
???)
Note that the type of lst is a "list of jumping pairs", so we will perform a case analysis on it straightforwardly:
(define (f lst)
(cond
[(empty? lst) ???] ;; the empty list case
[else ??? ;; the cons case has
(first lst) ;; the "plain list",
(first (rest lst)) ;; the "element", and
(rest (rest lst)) ;; the next "list of jumping pairs"
???])) ;; that are available for us to use
From the example:
(f '()) equivalent to (f empty)
should output '()
equivalent to empty
we know that the empty case should return an empty list, so let's fill in the hole accordingly:
(define (f lst)
(cond
[(empty? lst) empty] ;; the empty list case
[else ??? ;; the cons case has
(first lst) ;; the "plain list",
(first (rest lst)) ;; the "element", and
(rest (rest lst)) ;; the next "list of jumping pairs"
???])) ;; that are available for us to use
From the example:
(f '((1 2) 3)) equivalent to (f (cons (cons 1 (cons 2 empty))
(cons 3
empty)))
should output '((1 2 3))
equivalent to (cons (cons 1 (cons 2 (cons 3 empty)))
empty)
we know that we definitely want to put the "element" into the back of the "plain list" to obtain the resulting "plain list" that we want:
(define (f lst)
(cond
[(empty? lst) empty] ;; the empty list case
[else ;; the cons case has:
???
;; the resulting "plain list" that we want
(append (first lst) (cons (first (rest lst)) empty))
;; the next "list of jumping pairs"
(rest (rest lst))
;; that are available for us to use
???]))
There's still the next "list of jumping pairs" left that we need to deal with, but we have a way to deal with it already: f!
(define (f lst)
(cond
[(empty? lst) empty] ;; the empty list case
[else ;; the cons case has:
???
;; the resulting "plain list" that we want
(append (first lst) (cons (first (rest lst)) empty))
;; the list of "plain list"
(f (rest (rest lst)))
;; that are available for us to use
???]))
And then we can return the answer:
(define (f lst)
(cond
[(empty? lst) empty] ;; the empty list case
[else ;; the cons case returns
;; the resulting list of "plain list" that we want
(cons (append (first lst) (cons (first (rest lst)) empty))
(f (rest (rest lst))))]))
Pattern matching (using match below) is insanely useful for this kind of problem -
(define (f xs)
(match xs
;; '((a b) c . rest)
[(list (list a b) c rest ...)
(cons (list a b c)
(f rest))]
;; otherwise
[_
empty]))
define/match offers some syntax sugar for this common procedure style making things even nicer -
(define/match (f xs)
[((list (list a b) c rest ...))
(cons (list a b c)
(f rest))]
[(_)
empty])
And a tail-recursive revision -
(define (f xs)
(define/match (loop acc xs)
[(acc (list (list a b) c rest ...))
(loop (cons (list a b c) acc)
rest)]
[(acc _)
acc])
(reverse (loop empty xs)))
Output for each program is the same -
(f '((a b) c (e d) f (g h) i))
;; '((a b c) (e d f) (g h i))
(f '((a b) c))
;; '((a b c))
(f '((a b) c x y z))
;; '((a b c))
(f '(x y z))
;; '()
(f '())
;; '()
As an added bonus, this answer does not use the costly append operation
There is no recursive case in your code so it will just work statically for a 4 element list. You need to support the following:
(f '()) ; ==> ()
(f '((a b c) d (e f g) h)) ; ==> (cons (append '(a b c) (list 'd)) (f '((e f g) h)))
Now this requires exactly even number of elements and that every odd element is a proper list. There is nothing wrong with that, but onw might want to ensure this by type checking or by adding code for what should happen when it isn't.
The code I've written:
(define (make-list lst)
(cond [(null? lst) '()]
[(member (car lst) (cdr lst)) (make-list (cdr L))]
[else (cons (car lst) (duplicates (cdr lst)))]))
I want (make-list '(a (a b b (c b) 3) 5 5.0 (e s) (s e s))))) to return:
(a (a b (c b) 3) 5 (e s))
But my procedure returns
'((a b b (c b) 3) 5 5.0 (e s) (s e s))
So it doesn't really do anything besides removing the first element, it doesn't go into the nested lists. Any help would be appreciated
I'm assuming duplicates and L are forgotten rename mistakes. make-list isn't really a good name since it is a well known procedure in the list library of R7RS, originally from SRFI-1 List library. remove-duplicates might be a better fit?
(define (remove-duplicates lst)
(cond [(null? lst) '()]
[(member (car lst) (cdr lst))
(remove-duplicates (cdr lst))]
[else
(cons (car lst) (remove-duplicates (cdr lst)))]))
Now this does all the elements in the given list and it only concerns itself with the top level list. sub lists are compared too:
(remove-duplicates '(a (b c) (b c) a))
; ==> ((b c) a)
You need to instead of just making a list with the first element also check if the first element is a list and do remove-duplicates on both parts. Thus you need to do add a term like this:
(define (remove-duplicates lst)
(cond [(null? lst) '()]
[(member (car lst) (cdr lst))
(remove-duplicates (cdr lst))]
[(list? (car lst)) ; or pair?
(cons (remove-duplicates (car lst))
(remove-duplicates (cdr lst)))]
[else
(cons (car lst)
(remove-duplicates (cdr lst)))]))
(remove-duplicates '((a b b a) (a b b a)))
; ==> ((b a))
I am learning Scheme and wanted to write a recursive program that reverses a given list.
In one test case however, I noticed that a (b c) e -> e (b c) a.
What I'm trying to get is a (b c) e -> e (c b) a.
This is what I have:
(define (deep-reverse lst)
(if (null? lst)
'()
(begin
(display (car lst))
(display "\n")
(if (null? (cdr lst))
'()
(append (deep-reverse (cdr lst)) (list (reverse (car lst))))
) //End of inner if
))) //End of begin, outer if, define
When I attempt to run the code with
(deep-reverse '(1 (b c) (a b)))
I get:
1
(b c)
(a b)
mcdr: contract violation
expected: mpair?
given: 1
The issue is with (list (reverse (car lst))), although in an isolated test case it works fine. Which leads me to believe that the issue may have to do with append.
Thank you in advance.
Edit: Going from (list (reverse (car lst))) to (reverse (list(car lst))) makes the code run without an error but doesn't reverse (a b) to (b a).
As the error message explains, your problem is that you are trying to reverse a number. Firstly, let's remove some of the unnecessary conditions and debugging stuff in your program, arriving at this simpler program. Let's step through this program to see what's going on:
(define (deep-reverse lst)
(if (null? lst)
'()
(append (deep-reverse (cdr lst)) (list (reverse (car lst))))))
We start with
(deep-reverse '(1 (b c) (a b)))
Substituting the argument we get
(if (null? '(1 (b c) (a b)))
'()
(append (deep-reverse (cdr '(1 (b c) (a b))))
(list (reverse (car '(1 (b c) (a b)))))))
Because the condition is #f, this simplifies to
(append (deep-reverse (cdr '(1 (b c) (a b))))
(list (reverse (car '(1 (b c) (a b))))))
To evaluate the first argument, first find the cdr, and call deep-reverse on that. I will skip the steps here but you should easily be able to test that it works correctly.
(append '((b a) (c b)) (list (reverse (car '(1 (b c) (a b))))))
Next we evaluate the car:
(append '((b a) (c b)) (list (reverse 1)))
And here we see what the problem is: we can't reverse a single number!
The issue is that your deep-reverse should have two distinct behaviours recursively:
on a number, or symbol, or other non-list entity, don't do anything, because it does not make sense to reverse a number
on a list, deep reverse it
There are two reasons why your current program does not do this properly:
it only does a shallow reverse on the elements of the list; that is, it won't deep reverse '(((a b) (c d)) ((e f) (g h))) correctly
it fails if it ever encounters a number or other non-list, like a symbol
The easy fix is to add a condition to check if it's a pair? first before attempting to reverse it. If it's not pair?, then lst must either be nil (which we may leave as-is) or a non-list object (which we may also leave as-is)
(define (deep-reverse lst)
(if (pair? lst)
(append (deep-reverse (cdr lst)) (list (deep-reverse (car lst))))
lst))
Finally, I should note that the pattern we are using here is really a foldr pattern. We can abstract away this pattern with foldr:
(define (deep-reverse xs)
(cond ((pair? xs)
(foldr (lambda (x y) (append y (list (deep-reverse x)))) '() xs))
(else xs)))
But we note also that this is inefficient, because append is an expensive operation. Modifying the algorithm to a tail recursive one makes it clear that this is actually a foldl:
(define (deep-reverse xs)
(cond ((pair? xs)
(foldl (lambda (x y) (cons (deep-reverse x) y)) '() xs))
(else xs)))
which is how such a function might be written in typical idiomatic Scheme, or as pointed out by Will Ness,
(define (deep-reverse xs)
(cond ((pair? xs) (reverse (map deep-reverse xs)))
(else xs)))
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 '()) '()))