The particular problem I have is with creating a solution for question 4.16b of Structure and Interpretation of Computer Programs. Here a procedure needs to be created that transforms
(lambda (a b)
(define u 'u)
(define v 'v)
'e1))
Into:
(lambda (a b)
(let ((u '*unassigned*)
(v '*unassigned*))
(set! u 'u)
(set! v 'v)
'e1))
My procedure (see below) does not do this, but instead transforms it into:
(lambda (a b)
(let ((u *unassigned*)
(v *unassigned*))
((set! u 'u)
(set! v 'v))
('e1)))
Here we have a problem with the list of sets! produced by make-sets (see below) and the rest of the body (('e1) above) produced by cons current-element rest-of-body (see below). They are added into lists, while I want to have them as single statements, i.e., (set! u 'u) (set! v 'v) instead of ((set! u 'u) (set! v 'v)) and 'e1 instead of `('e1).
Procedure:
;; b. Write a procedure scan-out-defines that takes a procedure body and returns an
;; equivalent one that has no internal definitions, by making the transformation
;; described above.
(define (scan-out expr)
(let ((vars (cadr expr))
(body (cddr expr)))
(make-lambda vars
; loop over body,
; store all definition names and bodies of the defines
; once finished looping transform those into lets
; where the rest is added to the body
(let body-transform ((body-elements body)
(definition-names '())
(definition-bodies '())
(rest-of-body '()))
(if (null? body-elements)
(transform-define-into-let definition-names
definition-bodies
rest-of-body)
(let ((current-element (car body-elements)))
(if (tagged-list? current-element 'define)
(body-transform (cdr body-elements)
(cons (get-definition-name current-element)
definition-names)
(cons (get-definition-body current-element)
definition-bodies)
rest-of-body)
(body-transform (cdr body-elements)
definition-names
definition-bodies
(cons current-element rest-of-body)))))))))
(define (tagged-list? exp tag)
(if (pair? exp)
(eq? (car exp) tag)
false))
(define (get-definition-name expr)
(cadr expr))
(define (get-definition-body expr)
(caddr expr))
(define (transform-define-into-let vars vals rest-of-body)
(list (list 'let (make-unassigned-vars vars)
(make-sets vars vals)
rest-of-body)))
(define (make-unassigned-vars vars)
(let aux ((var-elements vars)
(unassigned-vars '()))
(if (null? var-elements)
unassigned-vars
(aux (cdr var-elements)
(cons (list (car var-elements) '*unassigned*) unassigned-vars)))))
(define (make-sets vars vals)
(let aux ((var-elements vars)
(val-elements vals)
(sets '()))
(if (null? var-elements)
sets
(aux (cdr var-elements)
(cdr val-elements)
(cons (list 'set! (car var-elements) (car val-elements)) sets)))))
(define (make-lambda parameters body)
(cons 'lambda (cons parameters body)))
; testing
(scan-out '(lambda (a b)
(define u 'u)
(define v 'v)
'e1))
; Should be transformed into:
; => (lambda (a b)
; (let ((u '*unassigned*)
; (v '*unassigned*))
; (set! u 'u)
; (set! v 'v)
; 'e1))
; But is transformed into:
; => (lambda (a b)
; (let ((u *unassigned*)
; (v *unassigned*))
; ((set! u (quote u))
; (set! v (quote v)))
; ((quote e1))))
What I tried is flattening the lists like so:
(define (transform-define-into-let definition-names definition-bodies rest-of-body)
(list (list 'let (make-unassigned-vars definition-names)
(append* (make-sets definition-names definition-bodies))
(append* rest-of-body))))
but then only the rest-of-body is stripped of its outer parentheses, make-sets is still a list: e.g.,
(lambda (a b)
(let ((u *unassigned*)
(v *unassigned*))
((set! u 'u)
(set! v 'v))
'e1))
What is the proper way to get rid of the outer parentheses?
If anyone can help me out with this that would be greatly appreciated.
You should change:
(define (transform-define-into-let vars vals rest-of-body)
(list (list 'let (make-unassigned-vars vars)
(make-sets vars vals)
rest-of-body)))
into:
(define (transform-define-into-let vars vals rest-of-body)
(list (append (list 'let (make-unassigned-vars vars))
(append (make-sets vars vals)
rest-of-body))))
and also:
(define (make-unassigned-vars vars)
(let aux ((var-elements vars)
(unassigned-vars '()))
(if (null? var-elements)
unassigned-vars
(aux (cdr var-elements)
(cons (list (car var-elements) '*unassigned*) unassigned-vars)))))
into
(define (make-unassigned-vars vars)
(let aux ((var-elements vars)
(unassigned-vars '()))
(if (null? var-elements)
unassigned-vars
(aux (cdr var-elements)
(cons (list (car var-elements) ''*unassigned*) unassigned-vars)))))
Finally note that 'u is identical to (quote u).
Related
last-non-zero takes a list of numbers and return the last cdr whose car is 0.
So, I can implement it using continuations, but how do I do this with natural recursion.
(define last-non-zero
(lambda (ls)
(let/cc return
(letrec
((lnz
(lambda (ls)
(cond
((null? ls) '())
((zero? (car ls)) ;; jump out when we get to last 0.
(return (lnz (cdr ls))))
(else
(cons (car ls) (lnz (cdr ls))))))))
(lnz ls)))))
Here's an obvious version which is not tail-recursive:
(define (last-non-zero l)
;; Return the last cdr of l which does not contain zero
;; or #f if there is none
(cond
((null? l)
#f)
((zero? (car l))
(let ((lnzc (last-non-zero (cdr l))))
;; This is (or lnzc (cdr l)) but that makes me feel bad
(if lnzc
lnzc
(cdr l))))
(else
(last-non-zero (cdr l)))))
Here is that version turned into a tail-recursive equivalent with also the zero test moved around a bit.
(define (last-non-zero l)
(let lnzl ([lt l]
[r #f])
(if (null? lt)
r
(lnzl (cdr lt) (if (zero? (car lt)) (cdr lt) r)))))
It's much clearer in this last version that the list is traversed exactly once.
Please indicate if I have correctly understood the problem:
#lang scheme
; returns cdr after last zero in lst
(define (last-non-zero lst)
; a helper function with 'saved' holding progress
(define (lnz-iter lst saved)
(if (null? lst)
saved
(if (zero? (car lst))
(lnz-iter (cdr lst) (cdr lst))
(lnz-iter (cdr lst) saved))))
(lnz-iter lst '()))
(last-non-zero '(1 2 3 0 7 9)) ; result (7 9)
Racket's takef-right can do it:
> (takef-right '(1 2 0 3 4 0 5 6 7) (lambda (n) (not (zero? n))))
'(5 6 7)
But assuming you have an assignment where you're supposed to write the logic yourself instead of just using a built in function, one easy if not very efficient approach is to reverse the list, build a new list out of everything up to the first zero, and return that. Something like:
(define (last-non-zero ls)
(let loop ([res '()]
[ls (reverse ls)])
(if (or (null? ls) (zero? (car ls)))
res
(loop (cons (car ls) res) (cdr ls)))))
Using your implementation where you return the argument in the event there are no zero you can just have a variable to keep the value you think has no zero values until you hit it and then update both:
(define (last-non-zero lst)
(let loop ((lst lst) (result lst))
(cond ((null? lst) result)
((zero? (car lst)) (loop (cdr lst) (cdr lst)))
(else (loop (cdr lst) result)))))
(last-non-zero '()) ; ==> ()
(last-non-zero '(2 3)) ; ==> (2 3)
(last-non-zero '(2 3 0)) ; ==> ()
(last-non-zero '(2 3 0 1 2)) ; ==> (1 2)
(define last-non-zero
(lambda (l)
((lambda (s) (s s l (lambda (x) x)))
(lambda (s l* ret)
(if (null? l*)
(ret '())
(let ((a (car l*))
(r (cdr l*)))
(if (zero? a)
(s s r (lambda (x) x))
(s s r
(lambda (r)
(ret (cons a r)))))))))))
Also possible, to use foldr:
(define (last-non-zero l)
(reverse (foldl (lambda (e res) (if (zero? e) '() (cons e res))) 0 l)))
Or use recursion:
(define (last-non-zero l (res '()))
(cond ((empty? l) res)
((zero? (car l)) (last-non-zero (cdr l) (cdr l)))
(else (last-non-zero (cdr l) res))))
I'm trying to implement a quick sort using scheme, some dudes here already helped me fixing my split function and now I'm asking for you help with combining everything into one working algorithm.
Here is my code so far:
(define quick-sort (lambda (lst)
(define pivot (lambda (lst)
(if (null? lst)
null
(car lst))))
(define split (lambda (lst pivot)
(define lst1 null)
(define lst2 null)
(define split-helper (lambda (lst pivot lst1 lst2)
(if (null? lst)
(list lst1 lst2)
(if (<= (car lst) pivot)
(split-helper (cdr lst) pivot (cons (car lst) lst1) lst2)
(split-helper (cdr lst) pivot lst1 (cons (car lst) lst2))))))
(split-helper lst pivot lst1 lst2)))
(if (null? lst)
null
(append (quick-sort (car (split lst (pivot lst)))) (quick-sort (cdr (split lst (pivot lst))))))))
As you can see, I'm choosing the pivot to simply be the first element in the list, the problem I'm facing is that the program ran into an infinite loop when the pivot is the smallest element in the list because it makes the program choose the same pivot over and over.
Also, the way it's currently implemented makes it be really un-efficient because the split function is called twice with the same lst in every ineration of quick-sort but I just don't have good enough control over Scheme to write it any other way.
I saw some posts about Quick-Sort in Scheme but they were implemented a bit different and I rather try and correct my own implementation than copying some other dude's work.
Thank you.
This is a classical mistake when it comes to quicksort. Your pivot should not be a part of the partitions. That way a one element list makes two empty partitions, one before and one after the pivot.
As for doing the same operation twice. Use let to buffer the split result and use the variable twice.
Removed excessive lambdas, aliases, bindings, and reformatted, but didn't change or annotate semantics (Sylwester already pointed out the bug):
(define (quick-sort lst)
(define (pivot lst)
(if (null? lst)
'()
(car lst) ))
(define (split lst pivot)
(let split-helper ((lst lst) ; Named let instead of internal
(lst1 '()) ; definition
(lst2 '()) )
(if (null? lst)
(cons lst1 list2)
(if (<= (car lst) pivot)
(split-helper (cdr lst)
(cons (car lst) lst1)
lst2)
(split-helper (cdr lst)
lst1
(cons (car lst) lst2) )))))
(if (null? lst)
'()
(let ((spl (split lst (pivot lst)))) ; Memoization of the `split`
(append (quick-sort (car spl))
(quick-sort (cdr spl)) ))))
I think you're trying to implement a partition:
(define (partition pred xs)
(let part ((ps '()) (ns '()) ; Initial "positives" `ps`, and "negatives" `ns`
(xs' xs) )
(if (null? xs')
(cons ps ns) ; Returning pair of lists
(let ((x (car xs'))) ; Memoization of `(car lst)`
(if (pred x)
(part (cons x ps) ns (cdr xs'))
(part ps (cons x ns) (cdr xs')) )))))
(define (quicksort xs)
(if (null? xs) '()
(let* ((x (car xs))
(pn (partition ; Memoization of `partition`
(lambda (x')
(< x' x) )
(cdr xs) )))
(append (quicksort (car pn)) ; Extracting positives from pair
(list x) ; Pivot
(quicksort (cdr pn)) )))) ; Negatives
(display
(quicksort (list 4 2 3 5 1)) ) ; (1 2 3 4 5)
part is inefficient in strict languages like Scheme; it copies all three of its arguments for every recursive step. Often, straightforward formulations in terms of basic folds like filter and map are most efficient. A much more efficient implementation using filter:
(define (quicksort xs)
(if (null? xs) '()
(let ((x (car xs))
(xs' (cdr xs)) )
(append (quicksort
(filter (lambda (x')
(< x' x) )
xs'))
(list x)
(quicksort
(filter (lambda (x')
(>= x' x) )
xs'))))))
This strategy famously happens to be very briefly expressible in functional languages.
In lazy Haskell, a single-traversal partition is actually more efficient than filtering twice.
select :: (a -> Bool) -> ([a], [a]) -> a -> ([a], [a])
select pred (ps, ns) x | pred x = (x : ps, ns)
| otherwise = (ps, x : ns)
partition :: (a -> Bool) -> [a] -> ([a], [a])
partition pred = foldl (select pred) ([], [])
quicksort :: Ord a => [a] -> [a]
quicksort [] = []
quicksort (x : xs) = let (lt, gt) = partition (< x) xs
in quicksort lt ++ [x] ++ quicksort gt
(define (nth n lst)
(if (= n 1)
(car lst)
(nth (- n 1)
(cdr lst) )))
is an unsafe partial function, n may go out of range. An error can be helpful,
(define (nth n lst)
(if (null? lst)
(error "`nth` out of range")
(if (= n 1)
(car lst)
(nth (- n 1)
(cdr lst) ))))
But what would a robust Scheme analogue to Haskell's Maybe data type look like?
data Maybe a = Nothing | Just a
nth :: Int -> [a] -> Maybe a
nth _ [] = Nothing
nth 1 (x : _) = Just x
nth n (_ : xs) = nth (n - 1) xs
Is just returning '() adequate?
(define (nth n lst)
(if (null? lst) '()
(if (= n 1)
(car lst)
(nth (- n 1)
(cdr lst) ))))
It's easy to break your attempt. Just create a list that contains an empty list:
(define lst '((1 2) () (3 4)))
(nth 2 lst)
-> ()
(nth 100 lst)
-> ()
The key point that you're missing is that Haskell's Maybe doesn't simply return a bare value when it exists, it wraps that value. As you said, Haskell defines Maybe like so:
data Maybe a = Nothing | Just a
NOT like this:
data Maybe a = Nothing | a
The latter is the equivalent of what you're doing.
To get most of the way to a proper Maybe, you can return an empty list if the element does not exist, as you were, but also wrap the return value in another list if the element does exist:
(define (nth n lst)
(if (null? lst) '()
(if (= n 1)
(list (car lst)) ; This is the element, wrap it before returning.
(nth (- n 1)
(cdr lst) ))))
This way, your result will be either an empty list, meaning the element did not exist, or a list with only one element: the element you asked for. Reusing that same list from above, we can distinguish between the empty list and a non-existant element:
(define lst '((1 2) () (3 4)))
(nth 2 lst)
-> (())
(nth 100 lst)
-> ()
Another way to signal, that no matching element was found, would be to use multiple return values:
(define (nth n ls)
(cond
((null? ls) (values #f #f))
((= n 1) (values (car ls) #t))
(else (nth (- n 1) ls))))
This comes at the expense of being a little bit cumbersome for the users of this function, since they now have to do a
(call-with-values (lambda () (nth some-n some-list))
(lambda (element found?)
... whatever ...))
but that can be alleviated by using some careful macrology. R7RS specifies the let-values syntax.
(let-values (((element found?) (nth some-n some-list)))
... whatever ...)
There are several ways to do this.
The direct equivalent would be to mimic the Miranda version:
#!r6rs
(library (sylwester maybe)
(export maybe nothing maybe? nothing?)
(import (rnrs base))
;; private tag
(define tag-maybe (list 'maybe))
;; exported tag and features
(define nothing (list 'nothing))
(define (maybe? v)
(and (pair? v)
(eq? tag-maybe (car v))))
(define (nothing? v)
(and (maybe? v)
(eq? nothing (cdr v))))
(define (maybe v)
(cons tag-maybe v)))
How to use it:
#!r6rs
(import (rnrs) (sylwester maybe))
(define (nth n lst)
(cond ((null? lst) (maybe nothing))
((zero? n) (maybe (car lst)))
(else (nth (- n 1) (cdr lst)))))
(nothing? (nth 2 '()))
; ==> #t
Exceptions
(define (nth n lst)
(cond ((null? lst) (raise 'nth-nothing))
((zero? n) (car lst))
(else (nth (- n 1) (cdr lst)))))
(guard (ex
((eq? ex 'nth-nothing)
"nothing-value"))
(nth 1 '())) ; ==> "nothing-value"
Default value:
(define (nth n lst nothing)
(cond ((null? lst) nothing)
((zero? n) (car lst))
(else (nth (- n 1) (cdr lst)))))
(nth 1 '() '())
; ==> '()
Deault value derived from procedure
(define (nth index lst pnothing)
(cond ((null? lst) (pnothing))
((zero? n) (car lst))
(else (nth (- n 1) (cdr lst)))))
(nth 1 '() (lambda _ "list too short"))
; ==> "list too short"
Combination of exception and default procedure
Racket, a Scheme decent, often has a default value option that defaults to an exception or a procedure thunk. It's possible to mimic that behavior:
(define (handle signal rest)
(if (and (not (null? rest))
(procedure? (car rest)))
((car rest))
(raise signal)))
(define (nth n lst . nothing)
(cond ((null? lst) (handle 'nth-nothing nothing))
((zero? n) (car lst))
(else (nth (- n 1) (cdr lst)))))
(nth 1 '() (lambda () 5)) ; ==> 5
(nth 1 '()) ; exception signalled
As a non-lisper I really can't say how idiomatic this is, but you could return the Church encoding of an option type:
(define (nth n ls)
(cond
((null? ls) (lambda (default f) default))
((= n 1) (lambda (default f) (f (car ls))))
(else (nth (- n 1) ls))))
But that's about as complicated to use as #Dirk's proposal. I'd personally prefer to just add a default argument to nth itself.
Im trying to write a function called removesub* which accepts two arguments (l1 and l2). The function needs to return the second list with the first occurence of the subsequence removed. So, if the first list is '(a b c), the first a if the second list is removed, the first b that appears after the removed a is removed, and the first c that appears after the removed b is removed - no matter how deep the atoms are nested.
Working Example
Input: (removesub* '(a b) '(w (x b) ((a) ((y z))) b a))
Output: (w (x b) (() ((y z))) a)
My current attempt doesnt seem to work because I have no way of sharing the l1 argument between nested recursive calls i.e. ((pair? (car l2)) (cons (removesub* l1 (car l2)) (removesub* l1 (cdr l2)))) splits l1 into two separate instances resulting in the following result. How can I share the l1 value so every recursive calls knows if the others have found the first instance of a value in l1?
Working Example
Input: (removesub* '(a b) '(w (x b) ((a) ((y z))) b a))
Output: (w (x b) (() ((y z))) b)
Attempted Solution - Scheme
(define removesub*
(lambda (l1 l2)
(cond
((or (null? l1) (null? l2)) l2)
((pair? (car l2)) (cons (removesub* l1 (car l2)) (removesub* l1 (cdr l2))))
((eq? (car l1) (car l2)) (removesub* (cdr l1) (cdr l2)))
(else (cons (car l2) (removesub* l1 (cdr l2)))))))
You need to pass the resulting symbols to search for to the next iteration. THere are many ways to do this.
You can use a compound return in the helper
(define (removesub* elements-in-order haystack)
;; just use a pair to pass result and the
;; elements to continue searching for
(define (result eio h)
(cons eio h))
(cdr
(let rec ((eio elements-in-order)
(h haystack))
(cond ((or (not (pair? eio))
(not (pair? h)))
(result eio h))
((pair? (car h))
(let* ((r (rec eio (car h)))
(r2 (rec (car r) (cdr h))))
(result (car r2) (cons (cdr r) (cdr r2)))))
((eq? (car eio) (car h))
(rec (cdr eio) (cdr h)))
(else
(let ((r (rec eio (cdr h))))
(result (car r) (cons (car h) (cdr r)))))))))
Notice I do car first then use both parts of the result to do the next.
Scheme/Racket can return more than one value with values
(define (removesub* elements-in-order haystack)
(define (helper eio h)
(cond ((or (not (pair? eio))
(not (pair? h)))
(values eio h))
((pair? (car h))
(let*-values ([(eiocar hcar) (helper eio (car h))]
[(eiocdr hcdr) (helper eiocar (cdr h))])
(values eiocdr (cons hcar hcdr))))
((eq? (car eio) (car h))
(helper (cdr eio) (cdr h)))
(else
(let-values ([(eiocdr hcdr) (helper eio (cdr h))])
(values eiocdr (cons (car h) hcdr))))))
(let-values ([(eio result) (helper elements-in-order haystack)])
result))
Not really a semantic difference over the first, but it might be a tad faster since in theory the results can stay on the stack rather than each result having to create a cons that can be GC-ed as fast as the stack unrolls.
You can use continuation passing style:
(define (removesub* elements-in-order haystack)
(let cps ((eio elements-in-order)
(h haystack)
(c (lambda (eio h) h)))
(cond ((or (not (pair? eio))
(not (pair? h)))
(c eio h))
((pair? (car h))
(cps eio
(car h)
(lambda (eio hcar)
(cps eio
(cdr h)
(lambda (eio hcdr)
(c eio (cons hcar hcdr)))))))
((eq? (car eio) (car h))
(cps (cdr eio) (cdr h) c))
(else
(cps eio
(cdr h)
(lambda (eio res)
(c eio (cons (car h) res))))))))
This works by the helper has a continuation argument. This is close to what many Scheme implementations actually do to your code before running.
You can use mutation
Probably the fastest and easiest, but then you need to use #!r6rs or another standard Scheme rather than #!racket as implementation language.
how to design a function content which
inputs a single list of atoms lat and which returns
the content of lat.Thus the content of '(a b c a b c d d) is '(a b c d).
The procedure content below should get you what you need.
(define (work x y)
(if (null? (cdr x))
(if (in? (car x) y)
y
(cons (car x) y))
(if (in? (car x) y)
(work (cdr x) y)
(work (cdr x) (cons (car x) y)))))
(define (in? x y)
(if (null? y)
#f
(if (equal? x (car y))
#t
(in? x (cdr y)))))
(define (content x) (work x (list)))
The procedure content accepts a list as a parameter. It sends the list to another procedure called work. This procedure processes the list and adds the items in the list to a new list (if they are not already in the new list). The work procedure makes use of yet another procedure called in, which checks to see if an item is a member of a list.
My solution essentially divides your problem into two sub-problems and makes use of procedures which operate at a lower level of abstraction than your original problem.
Hope that helps.
It is PLT Scheme solution:
(define (is_exists list element)
(cond
[(empty? list) false]
[else
(cond
[(= (first list) element) true]
[else (is_exists (rest list) element)])]))
(define (unique list target)
(cond
[(empty? list) target]
[else
(cond
[(is_exists target (first list)) (unique (rest list) target)]
[else (unique (rest list) (cons (first list) target))])]))
(define (create_unique list)
(unique list empty))
Check it:
> (define my_list (cons '1 (cons '2 (cons '3 (cons '2 (cons '1 empty))))))
> my_list
(list 1 2 3 2 1)
> (create_unique my_list)
(list 3 2 1)
How about little schemer style,
(define (rember-all a lat)
(cond
((null? lat) '())
((eq? a (car lat)) (rember-all a (cdr lat)))
(else (cons (car lat) (rember-all a (cdr lat))))))
(define (content lat)
(cond
((null? lat) '())
(else (cons (car lat)
(content (rember-all (car lat) (cdr lat)))))))
Start from a procedure that simply creates a copy of the passed-in list (very easy to do):
(define (unique-elements seq)
(define (loop ans rest)
(cond ((null? rest) ans)
(else
(loop (cons (car rest) ans)
(cdr rest)))))
(loop '() seq))
To ensure that the output list's elements are unique, we should skip the CONS if the head of REST is already a member of ANS. So we add another condition to do just that:
;;; Create list containing elements of SEQ, discarding duplicates.
(define (unique-elements seq)
(define (loop ans rest)
(cond ((null? rest) ans)
((member (car rest) ans) ; *new*
(loop ans (cdr rest))) ; *new*
(else
(loop (cons (car rest) ans)
(cdr rest)))))
(loop '() seq))
The following function takes in a list and returns a new list with only the unique inputs of it's argument using recursion:
(defun uniq (list)
(labels ((next (lst new)
(if (null lst)
new
(if (member (car lst) new)
(next (cdr lst) new)
(next (cdr lst) (cons (car lst) new))))))
(next list ())))
As was mentioned in the comments, common lisp already has this function:
(defun uniq (list)
(remove-duplicates list))
(define (remove-duplicates aloc)
(cond
((empty? aloc) '())
(else (cons (first aloc)
(remove-duplicates
(filter (lambda (x)
(cond
((eq? x (first aloc)) #f)
(else #t)))
(rest aloc)))))))