I was reading the book On Lisp by Paul Graham. In Chapter 4, Utility Functions, he gives examples of small functions that operate on lists, which would be helpful while writing a larger program.
One of them is flatten. Given a nested list at any arbitrary level as argument, flatten will remove all the nested elements and put them on the top level.
Below is my attempt at implementing flatten:
(defun flatten (lst)
(labels ((rflatten (lst1 acc)
(dolist (el lst1)
(if (listp el)
(rflatten el acc)
(push el acc)))
acc))
(reverse (rflatten lst nil))))
But the above function does not flatten lists properly.
; returns (1) instead of (1 2)
(print (flatten '(1 (2))))
(1)
Calling the function with (1 (2)) returns (1) instead of (1 2).
I cannot find what's wrong with my implementation of flatten. Is it the way I am using
labels? Or is it the the way I am using the dolist macro? The dolist macro always returns nil. But that should not matter as I am using an accumulator acc to store the flattened list.
push changes the symbol binding in scope. Thus the recursion (rflatten el acc) has it's own acc which is the result there but you don't do anything with the returned result and it doesn't alter the callee acc.
Perhaps a (setf acc (rflatten el acc)) would fix that:
(defun flatten (lst)
(labels ((rflatten (lst1 acc)
(dolist (el lst1)
(if (listp el)
(setf acc (rflatten el acc))
(push el acc)))
acc))
(reverse (rflatten lst nil))))
You're actually very close. As Sylwester mentions, the issue is that (push el acc) only modifies the local binding of el (of which there's a new one for each call to rflatten. As Rainer mentions, it's not really an accumulator in the traditional sense, so I'm going not going to call it acc, but result. Since you're already defining a local function, there's no reason not to define result in a wider scope:
(defun flatten (lst)
(let ((result '()))
(labels ((rflatten (lst1)
(dolist (el lst1)
(if (listp el)
(rflatten el)
(push el result)))))
(rflatten lst)
(nreverse result))))
There are actually a few ways to clean this up, too. The first is a matter of style and taste, but I'd use an &aux variable to bind result, so
(defun flatten (lst &aux (result '()))
...)
The next is that dolist can take a third argument, a form to evaluate as for the return value. This is often used in a "push to create a list, then reverse for the return value" idiom, e.g.,
(let ((result '()))
(dolist (x list (nreverse result))
...
(push ... result)))
You don't want to reverse after every dolist, but you can still return result from the dolist, and thus from rflatten. Then you can simply call nreverse with the result of rflatten:
(defun flatten (lst &aux (result '()))
(labels ((rflatten (lst1)
(dolist (el lst1 result)
(if (listp el)
(rflatten el)
(push el result)))))
(nreverse (rflatten lst))))
A non-recursive code which builds the result by conses, following comments and starting from a code by user:Sylwester:
(defun flatten (lst &optional back acc)
(loop
(cond
((consp lst) (psetq lst (cdr lst) ; parallel assignment
back (cons (car lst) back)))
(back
(if (consp (car back))
(psetq lst (cdar back)
back (cons (caar back) (cdr back)))
(psetq acc (if (car back) (cons (car back) acc) acc)
back (cdr back))))
(t
(return acc))))) ; the result
It's not pretty, but it seems to work. Parallel assignment PSETQ is used to simulate tail-recursive call frame update without worrying about precise sequencing.
Implements the same process as the one encoded nicely by
(defun flatten2 (l z)
(cond
((endp l) z)
((listp (car l)) (flatten2 (car l) (flatten2 (cdr l) z)))
((atom (car l)) (cons (car l) (flatten2 (cdr l) z)))))
(defun flatten (l)
(flatten2 l nil))
with implicit stack operations explicated as list structure manipulations among the variables.
I discovered a solution which does not use helper functions or variable assignment, and constructs the list in a forward manner, which I think is easier to understand.
(defun flatten (lst &aux (re '()))
(cond
((null lst) '())
((listp (car lst))
(append (flatten (car lst))
(append (flatten (cdr lst))
re)))
(t (cons (car lst)
(append (flatten (cdr lst)) re)))))
And we can easily adapt it to control the depth of the flattening!
(defun flatten* (lst depth &aux (re '()))
(cond
((null lst) '())
((listp (car lst))
(append (cond
((= 0 depth) ; flatten none
(list (car lst)))
((< 0 depth) ; flatten down
(flatten* (car lst) (- depth 1)))
((= -1 depth) ; flatten all
(flatten* (car lst) depth))
((< depth -1) ; flatten up
(list (flatten* (car lst) (+ depth 1)))))
(append (flatten* (cdr lst) depth)
re)))
(t (cons (car lst)
(append (flatten* (cdr lst) depth) re)))))
Related
I am trying to define the rule 3 of "MIU System" of "Gödel, Escher, Bach" (Douglas Hofstadter), which says:
Replace any III with a U
Example:
MIIIIU → MUIU and MIIIIU → MIUU
Main code:
(define (rule-tree lst)
(if (<= 3 (counter lst #\I))
(append (delete #\I lst) (list #\U))
(append lst empty)))
(define (delete x lst)
(cond [(empty? lst) lst]
[(eq? (first lst) x) (delete x (rest lst))]
[else (append (list (first lst)) (delete x (rest lst)))]))
(define (counter lst target)
(if (empty? lst)
0
(+ (counter (rest lst) target)
(let ((x (first lst)))
(if (list? x)
(counter x target)
(if (eqv? x target) 1 0))))))
With this expression there is no problem:
>(rule-tree '(#\M #\I #\I #\I))
'(#\M #\U)
But I don't know how to determine the position that the "U" should take when finding the 3 "I".
Any suggestion will be very helpful :)
Here is an alternative recursive version, where repl2 encodes the information “we have just encountered one #\I”, while repl3 encodes the information “we have just encountered two #\I”:
(define (repl lst)
(cond ((empty? lst) lst)
((eqv? (first lst) #\I) (repl2 (rest lst)))
(else (cons (first lst) (repl (rest lst))))))
(define (repl2 lst)
(cond ((empty? lst) (list #\I))
((eqv? (first lst) #\I) (repl3 (rest lst)))
(else (cons #\I (cons (first lst) (repl (rest lst)))))))
(define (repl3 lst)
(cond ((empty? lst) (list #\I #\I))
((eqv? (first lst) #\I) (cons #\U (repl (rest lst))))
(else (cons #\I (cons #\I (cons (first lst) (repl (rest lst))))))))
Of course this solution is some kind of hack and cannot scale to a greater number of repetitions. But looking at the structure of this solution and simply generalizing the three functions we can produce a general solution:
(define (repl lst n from to)
(define (helper lst k)
(cond ((empty? lst) (repeat from (- n k)))
((eqv? (first lst) from)
(if (= k 1)
(cons to (helper (rest lst) n))
(helper (rest lst) (- k 1))))
(else (append (repeat from (- n k))
(cons (first lst) (helper (rest lst) n))))))
(define (repeat x n)
(if (= n 0)
'()
(cons x (repeat x (- n 1)))))
We define a function repl that takes a list, the number of copies to replace (n), the element to replace (from) and the element that must be substituted (to). Then we define a helper function to do all the work, and that has as parameters the list to be processed and the number of copies that must be still found (k).
Each time the function encounters a copy it checks if we have finished with the number of copies and substitutes the element, restarting its work, otherwise it decrements the number of copies to find and continues.
If it founds an element different from from it recreates the list with the elements “consumed” until this point (maybe 0) with repeat and then continues its work.
Note that the previous version of the helper function had an error in the final case, when lst is null. Instead of returning simply the empty list, we must return the possibly skipped from elements.
Essentially I am trying to remove the first and last element in a list. I have currently been able to determine how to remove the last element in the list but i'm struggling how to remove the first element in the list with the last element in the list.
Here is the code I have so far. Is there a way I can modify my code so I am able to include removing the first element in the list.
(define (rid L)
(cond
[(empty? L) '()]
[(empty? (rest L)) '()]
[(cons (first L) (rid (rest L)))]))
Here is the results I am expecting with my code
(check-expect (rid (list 1 2 3 4 5)) (list 2 3 4))
(check-expect (rid (list "cat" "dog" "giraffe")) (list "dog"))
Just for fun - In Racket you can solve this problem without using explicit recursion. Always try to use existing procedures to solve your problems:
(define (rid L)
(rest (drop-right L 1)))
(rid '(1 2 3 4 5 6))
=> '(2 3 4 5)
With many recursive algorithms, it is not uncommon to actually implement them with two procedures: one to set up the initial conditions and a second one to do the actual recursion, like so:
(define (rid-inner li)
(cond
[(empty? li) '()]
[(empty? (rest li)) '()]
[(cons (first li) (rid-inner (rest li)))]))
(define (rid1 L)
(define r (if (empty? L) '() (rest L)))
(rid-inner r))
With (define r (if (empty? L) '() (rest L))) we strip off the first element of the list; no recursion is actually necessary for this step. Then we define the same procedure you had before with a different name and call it with our new list that already has the first element stripped off. If you want the first element stripped off, just strip off the first element; don't overthink it :) .
In a language like Racket that allows closures and nested procedures, you don't actually even need to define both procedures at the top "global" module scope; just define your recursive procedure inside your initial procedure and call it from there. Example:
(define (rid2 L)
(define r (if (empty? L) '() (rest L)))
(define (rid-inner li)
(cond
[(empty? li) '()]
[(empty? (rest li)) '()]
[(cons (first li) (rid-inner (rest li)))]))
(rid-inner r))
Another, somewhat cleaner, way to do the above is to use a named let, which allows us to simultaneously set up our initial conditions, create a named procedure, and then call that procedure immediately from within itself. We do that like so:
(define (rid3 L)
(let rid-inner ([li (if (empty? L) '() (rest L))])
(cond
[(empty? li) '()]
[(empty? (rest li)) '()]
[(cons (first li) (rid-inner (rest li)))])))
To those unfamiliar with Racket, Scheme, or a related Lisp, the named let in rid3 may be more cryptic at first since it is really doing two or three things at once. You can find the docs for it here. Don't be fooled though, it works exactly the same as rid2. Named let exists precisely because this pattern is so common.
(define (rid L)
(if (< (length L) 3)
'()
(reverse (rest (reverse (rest L))))))
;;; recursion inside and more general
;;; you can setting which position 0~n-1 you want to remove
(define (rid-v2 L)
(local ((define remove-index-list (list 0 (- (length L) 1)))
(define (auxf L k)
(cond
[(empty? L) '()]
[(memq k remove-index-list) (auxf (rest L) (+ k 1))]
[else (cons (first L)
(auxf (rest L) (+ k 1)))])))
(auxf L 0)))
tail call recursive version
(define (rid lst (acc '()))
(cond ((empty? lst) acc)
((empty? (cdr lst)) (cdr (reverse acc)))
(else (rid (cdr lst) (cons (car lst) acc)))))
with elementar lisp (not the most efficient)
(define (rid1 lst)
(cdr (reverse (cdr (reverse lst))))
My program works with all lists except the improper lists (which have an atom in the cdr field of the last cons cell). Please help upgrade this program to work with the improper lists:
(define (ndelete lst)
(let recur ((i 1) (rest lst))
(cond ((null? rest) '())
((= i 2) (recur 1 (cdr rest)))
(else (cons (car rest) (recur (+ i 1) (cdr rest)))))))
You just need to fix your base condition, (null? rest). If you want to support improper lists, you should check for (not (pair? rest)) instead.
Of course, this has an annoying side-effect of making your function handle any object - not just lists. For any non-list object, it just returns nil. If that's a problem for you, you'll need to encapsulate your recursive function and make sure lst is in fact a list. Like so:
(define (ndelete lst)
(letrec ((recur (lambda (i rest)
(cond ((not (pair? rest)) '())
((= i 2) (recur 1 (cdr rest)))
(else (cons (car rest) (recur (+ i 1) (cdr rest))))))))
(if (pair? lst)
(recur 1 lst)
(raise (condition (make-error)
(make-message-condition `(,lst is not a pair)))))))
This program takes a list where elements are repeated, e.g L = (a a a b b b c c c d), and output a list of items and number of repetition e.g ((a 3)(b 3)(c 3) d)
(define counter 0)
(define (compress liste)
(if (or (null? liste) (null? (cdr liste)))
liste
(let ((compressed-cdr (compress (cdr liste))))
(if (equal? (car liste) (car compressed-cdr))
((+ counter 1) compressed-cdr)
((cons (car liste) counter) (= counter 0) (compressed-cdr))))
))
However, I get this error:
Error: application: not a procedure; expected a procedure that can be applied to arguments
given: 1 arguments ...
The error is at the true predicate of the second if condition.
Building the result list in a top-down manner, with the "head-sentinel trick", for simplicity:
(define (rle lst)
(if (null? lst)
'()
(let ((res (list 1))) ; head sentinel
(let loop ((p res) ; result's last cons cell
(elt (car lst))
(cnt 1)
(lst (cdr lst)))
(if (and (not (null? lst))
(equal? elt (car lst)))
(loop p elt (+ cnt 1) (cdr lst))
(begin
(set-cdr! p (list (if (= 1 cnt) elt (list elt cnt))))
(if (null? lst)
(cdr res) ; skip the head in result, on return
(loop (cdr p) (car lst) 1 (cdr lst)))))))))
As #uselpa explained, this is called run-length encoding; for the uniformity of the result I'd suggest using (x 1) representation for non-repeating elements.
And the error "Error: application: not a procedure; expected a procedure", as others have said, means that the system expected to find a procedure but found something else, so can't apply it. Scheme expects to find a procedure as the first form in a list: (proc args ...), and tries to apply it to the arguments. But in your code it is not a procedure, but some other type of data.
If your Scheme has left fold, or reduce, you can run through it twice - first collecting the uniform results, and then applying your special format while reversing (left fold's results are usually built in reversed order):
(define (fold f init lst) ; if fold is not defined,
(reduce f init (cons init lst))) ; define it in terms of reduce
(define (rle lst)
(fold (lambda (x acc) ; NB! MIT-Scheme: (acc x)
(if (= 1 (cadr x)) (cons (car x) acc) (cons x acc)))
'()
(fold (lambda (x acc) ; NB! MIT-Scheme: (acc x)
(if (or (null? acc) (not (equal? (caar acc) x)))
(cons (list x 1) acc)
(cons (list x (+ (cadar acc) 1)) (cdr acc))))
'()
lst)))
As the error message says, the problem is located "at the true predicate of the second if condition":
((+ counter 1) compressed-cdr)
In this case, (+ counter 1) should evaluate to a procedure but it evaluates to a number. I think the problem is that you don't know how to increment the counter.
Your false predicate has the same problem:
((cons (car liste) counter) (= counter 0) (compressed-cdr))))))
where (cons (car liste) counter) yields a list and not a procedure.
I don't think we could really work with this code. I suggest looking at R Sahu's answer, which is close. Alternatively, I can show you a tail-recursive version which you could also have a look at. BTW, this is called run-length encoding, hence I've called my procedure rle:
(define (rle lst)
(define (newres prv cnt res)
(case cnt
((0) res)
((1) (cons prv res))
(else (cons (list prv cnt) res))))
(let loop ((lst lst) (prv null) (cnt 0) (res null))
(if (null? lst)
(if (zero? cnt)
(reverse res)
(loop null null 0 (newres prv cnt res)))
(let ((c (car lst)))
(if (eq? c prv)
(loop (cdr lst) prv (add1 cnt) res)
(loop (cdr lst) c 1 (newres prv cnt res)))))))
It was hard for me to figure out where the problem is in your code. I tried the following that seems to work.
(define (compress liste)
(define (helper in prev out)
(if (null? in)
(list (list (car out) (length out)))
(if (equal? prev (car in))
(helper (cdr in) prev (append out (list (car in))))
(cons (list (car out) (length out)) (compress in)))))
(if (null? liste)
'()
(helper (cdr liste) (car liste) (list (car liste))))
)
It uses helper to gather the output for matching items. When it finds a mismatch, it calls the main function to process the rest of the list. helper simply prepends its results to the results obtained from the main function.
A slightly improved version:
(define (compress liste)
(define (helper in prev out)
(if (null? in)
(list (list prev out))
(if (equal? prev (car in))
(helper (cdr in) prev (+ 1 out))
(cons (list prev out) (compress in)))))
(if (null? liste)
'()
(helper (cdr liste) (car liste) 1))
)
Here's tail-recursive version:
(define (compress liste)
(define (helper-1 in out)
(if (null? in)
'()
(helper-2 (cdr in) (car in) 1 out)))
(define (helper-2 in prev count out)
(if (null? in)
(append out (list (list prev count)))
(if (equal? prev (car in))
(helper-2 (cdr in) prev (+ 1 count) out)
(helper-1 in (append out (list (list prev count)))))))
(helper-1 liste '()))
I'd like to create a Scheme function that yields true if it is passed a list that is composed entirely of identical elements. Such a list would be '(1 1 1 1). It would yield false with something like '(1 2 1 1).
This is what I have so far:
(define (list-equal? lst)
(define tmp (car lst))
(for-each (lambda (x)
(equal? x tmp))
lst)
)
Clearly this is incorrect, and I'm new to this. I guess I'm unable to express the step where I'm supposed to return #t or #f.
Thanks in advance!
EDIT:
I fiddled a bit and found a solution that seems to work very well, and with a minimal amount of code:
(define (list-equal? lst)
(andmap (lambda (x)
(equal? x (car lst)))
lst))
Thanks again for the help everyone.
Minimal amount of code, if you don't care that it only works for numbers:
(define (list-equel? lst)
(apply = lst))
Examples:
> (list-equel? '(1 1 2 1))
#f
> (list-equel? '(1 1 1 1))
#t
> (list-equel? '(1))
#t
The andmap solution is nice, but if andmap is not available, you can use this. It uses basic operations (and, or, null check, equality check) and handles empty lists and one element lists. Similar to Sean's implementation, but no helper definition is necessary.
(define (list-equal? args)
(or (or (null? args)
(null? (cdr args)))
(and (eq? (car args) (cadr args))
(list-equal? (cdr args)))))
Try something like this:
(define (list-equal? lst)
(define (helper el lst)
(or (null? lst)
(and (eq? el (car lst))
(helper (car lst) (cdr lst)))))
(or (null? lst)
(helper (car lst) (cdr lst))))
This might not be the cleanest implementation, but I think it will correctly handle the cases of empty lists and one-element lists.
In R6RS there's the for-all function, which takes a predicate and a list, and returns #t if the predicate returns true for all elements in the list and #f otherwise, which is exactly what you need here.
So if you're using R6RS (or any other scheme dialect that has the for-all function), you can just replace for-each with for-all in your code and it will work.
(define (list-equal? lst)
(if (= (cdr lst) null)
true
(and (equal? (car lst) (cadr lst))
(list-equal? (cdr lst)))))
Something like this should work:
(define (list-equal? lst)
(cond ((< (length lst) 2) #t)
(#t (and (equal? (car lst) (cadr lst))
(list-equal? (cdr lst))))))
The other answers in this thread all seem too complicated (I read through them all), so here's my take on it:
(define (all-equal? lst)
(define item (car lst))
(let next ((lst (cdr lst)))
(cond ((null? lst) #t)
((equal? item (car lst)) (next (cdr lst)))
(else #f))))
(It does not work with an empty list, by design. It's easy to add a (if (null? lst) #t ...) if necessary.)
A short, concise solution:
#lang racket
(define (all-equal? lst)
(for/and
([i (in-permutations lst)])
(equal? (first i) (second i))))
; TEST CASES
(require rackunit)
(check-false (all-equal? '(1 2 3)))
(check-true (all-equal? '(1 1 1)))
(check-true (all-equal? '()))
Note that this uses racket, so this may not work with your scheme implementation.
Yet another solution:
(define (all-same ls)
(cond
((or (null? ls)
(null? (cdr ls))) #t)
(else (and (equal? (car ls) (next ls))
(all-same (cdr ls)))))))
(define (next ls)
(cond
((or (null? ls)
(null? (cdr ls))) '())
(else (cadr ls)))))
For is bad in these languages. Try
(define list-equal?
(lambda (lst)
(if (= lst null)
(true)
(foldr = (car lst) (cdr lst))
)))