I have got these functions
(define force!
(lambda (thunk)
(thunk)))
(define stream-head
(lambda (s n)
(if (zero? n)
'()
(cons (car s)
(stream-head (force! (cdr s))
(1- n))))))
(define make-stream
(lambda (seed next)
(letrec ([produce (lambda (current)
(cons current
(lambda ()
(produce (next current)))))])
(produce seed))))
(define make-traced-stream
(lambda (seed next)
(letrec ([produce (trace-lambda produce (current)
(cons current
(lambda ()
(produce (next current)))))])
(produce seed))))
(define stream-of-even-natural-numbers
(make-traced-stream 0
(lambda (n)
(+ n 2))))
(define stream-of-odd-natural-numbers
(make-traced-stream 1
(lambda (n)
(+ n 2))))
And I need to make a function that merges the last two, so that if I run
(stream-head (merge-streams stream-of-even-natural-numbers stream-of-odd-natural-numbers) 10)
I must get the output (0 1 2 3 4 5 6 7 8 9).. how is this done?
The best idea I had, which is wrong, have been:
(define merge-streams
(lambda (x y)
(cons (car x)
(merge-streams y (cdr x)))))
Here is a suggestion:
(define (merge-streams s1 s2)
(cond
[(empty-stream? s1) s2)] ; nothing to merge from s1
[(empty-stream? s2) s1)] ; nothing to merge from s2
[else (let ([h1 (stream-car s1)]
[h2 (stream-car s2)])
(cons h1
(lambda ()
(cons h2
(stream-merge (stream-rest s1)
(stream-rest s2))))))]))
It uses some helper functions that must be defined first.
Related
I have to write a scheme function which does the following:
Define a SCHEME function, named (rev p), which takes a pair as an argument and evaluates to
another pair with the first and second elements in the pair p in reverse order. For instance,
( rev ( cons 1 2))
> (2 . 1)
Here is my code:
(define (rev p)
(cond ((null? p) '())
(not (pair? (car p)) p)
(else (append (rev (cdr p)) (list (rev (car p))))
However, my code returns (1 . 2) when I test it when it should be returning (2 . 1).
(define rev
(lambda (l acc)
(if (null? l)
acc
(rev (cdr l)(cons (car l) acc)))))
(rev '(1 2 3) '())
And here is an apparently obfuscate version, but the ideas may be useful.
(define rev
(lambda (l k)
(if (null? l)
(k (lambda (x) x))
(rev (cdr l)
(lambda (k0)
(k (lambda (r) (k0 (cons (car l) r)))))))))
((rev '(1 2 3) (lambda (x) x)) '())
--
As suggested by Will, here is other variant, non-tail recursive, hence not completely cps'd, it's a combination of classic recursion and cps.
(define rev
(lambda (l k)
(if (null? l)
(k '())
(rev (cdr l)
(lambda (r)
(cons (car l)
(k r)))))))
If it's just a pair that you want to reverse, it's pretty simple, you don't even need to do recursion! And remember to use cons, not append:
(define (rev p)
(cond ((not (pair? p)) p)
(else (cons (cdr p) (car p)))))
For example:
(rev '())
=> '()
(rev 5)
=> 5
(rev (cons 1 2))
=> '(2 . 1)
Or the same expressed as:
(define (rev p)
(if (pair? p)
(cons (cdr p) (car p))
p))
All you need to do for this function is use the car and cdr function for your pair p.
(define (rev p)
(cons (cdr p) (car p))
)
I'm trying to write function for insertion sort with and without primitive functions.
My code with primitive functions is below.
(define (insert n d)
(cond ((null? n) d)
((null? d) n)
(else (< (car n) (car d)) (cons (car n) (insert (cdr n) d)) (cons (car d) (insert (cdr d) n)))))
(define (sort n)
(cond ((null? n) '())
(else (insert (list (car n)) (sort (cdr n))))))
How should I revise insert and sort to not use car, cdr, and cons?
Edit: I tried to write the insert function. This is what I have so far.
(define (insert n d)
(let ((rest-digit (truncate (/ n 10))))
(if (null? n) 0
(+ rest-digit (insert (- n 1) d)))))
(insert '(3 2 1) '5)
Edit #2: I think I can use the built-in function expt.
Ultimately you will be using primitive functions. To illustrate let me show you a trick that actually uses cons, car, and cdr under the hood:
(define (my-car lst)
(apply (lambda (a . d) a) lst))
(define (my-cdr lst)
(apply (lambda (a . d) d) lst))
(define (my-cons a d)
(apply (lambda l l) a d))
(define test (my-cons 1 '(2 3)))
test ; ==> (1 2 3)
(my-car test) ; ==> 1
(my-cdr test) ; ==> (2 3)
This abuses the fact that apply takes a list as the final arguments and that rest arguments are cons-ed onto a list in order. cons doesn't work for all pairs:
(my-cons 1 2) ; ERROR: expected list?, got 1
You can make cons, car, and cdr such that they adher to the same rules as primitive cons, but that they are not made of pairs at all. Barmar suggested closures:
(define (ccons a d)
(lambda (f) (f a d))
(define (ccar cc)
(cc (lambda (a d) a)))
(define (ccdr cc)
(cc (lambda (a d) d)))
(define test2 (ccons 1 2))
test2 ; ==> #<function...>
(ccar test2) ; ==> 1
(ccdr test2) ; ==> 2
This works since a and d gets closed over in the returned function and that function passes those values and thus the function acts as an object with two attributes. The challenge with this is that you cannot just pass a list since only "lists" made with ccons will work with ccar and ccdr.
A less classical way is to use vectors:
(define vtag (make-vector 0))
(define (vcons a d)
(let ((v (make-vector 3)))
(vector-set! v 0 vtag)
(vector-set! v 1 a)
(vector-set! v 2 d)
v))
(define (vcar vl)
(vector-ref vl 1))
(define (vcdr vl)
(vector-ref vl 2))
(define (vpair? vl)
(eq? vtag (vector-ref vl 0)))
Or you can use records:
(define-record-type :rpair
(rcons a d)
rpair?
(a rcar)
(d rcdr))
(define test (rcons 1 2))
(rpair? test) ; ==> #t
(rcar test) ; ==> 1
(rcdr test) ; ==> 2
Now I think records just syntax sugar and abstractions and that under the hood you are doing exactly the same as the vector version with less code, but that isn't a bad thing.
EDIT
So from the comments if the only restriction is to avoid car, cdr, and cons, but no restrictions on their sisters we might as well implement with them:
(define (sort lst)
(define (insert e lst)
(if (null? lst)
(list e)
(let ((a (first lst)))
(if (>= a e)
(list* e lst)
(list* a (insert e (rest lst)))))))
(foldl insert
'()
lst))
(sort '(1 5 3 8 5 0 2))
; ==> (0 1 2 3 5 5 8)
And of course my first suggestion works in its place:
(define (sort lst)
(define (my-car lst)
(apply (lambda (a . d) a) lst))
(define (my-cdr lst)
(apply (lambda (a . d) d) lst))
(define (my-cons a d)
(apply (lambda l l) a d))
(define (insert e lst)
(if (null? lst)
(my-cons e '())
(let ((a (my-car lst)))
(if (>= a e)
(my-cons e lst)
(my-cons a (insert e (my-cdr lst)))))))
(foldl insert
'()
lst))
And of course, using substitution rules you can make it utterly ridiculous:
(define (sort lst)
;; insert element e into lst in order
(define (insert e lst)
(if (null? lst)
((lambda l l) e)
(let ((a (apply (lambda (a . d) a) lst)))
(if (>= a e)
(apply (lambda l l) e lst)
(apply (lambda l l)
a
(insert e (apply (lambda (a . d) d) lst)))))))
;; main loop of sort
;; insert every element into acc
(let loop ((lst lst) (acc '()))
(if (null? lst)
acc
(loop (apply (lambda (a . d) d) lst)
(insert (apply (lambda (a . d) a) lst)
acc)))))
I simulated a state-programming solution from On Lisp to solve tree-flatten:
#lang racket
(define (flat-tree-generator tr)
(define initial? #t)
(define state '())
(define (resume)
(if (null? state)
'()
(let ((cont (car state)))
(set! state (cdr state))
(cont))))
(define (recur tr)
(cond
((null? tr) (resume))
((not (pair? tr)) tr)
(else (call/cc
(lambda (k)
(set! state
(cons
(lambda () (k (recur (cdr tr))))
state))
(recur (car tr)))))))
(define (dispatch)
(if initial?
(begin (set! initial? #f) (recur tr))
(resume)))
dispatch)
(define g1 (flat-tree-generator '((0 (1 2)) (3 4))))
(define g2 (flat-tree-generator '(0 1 2 3 4)))
OK, now if you try:
(g1)(g2)(g1)(g2)(g1)(g2)(g1)(g2)(g1)(g2)
It will work as expected (output lines 0011223344). However, if you try this:
(for ([e1 (in-producer g1 '())]
[e2 (in-producer g2 '())])
(printf "e1: ~a e2: ~a\n" e1 e2))
You will get:
e1: 0 e2: 0
e1: 0 e2: 1
e1: 0 e2: 2
e1: 0 e2: 3
e1: 0 e2: 4
Or you try:
(define (test)
(g1)(g2)(g1)(g2)(g1)(g2)(g1)(g2)(g1)(g2))
(test)
You will get:
'()
I am really confused.. Why?
When you do call-with-current-continuation in REPL you have guards between each statement while in test you will end up after the first (g2) after executing the second unless tr is null. Eg. it will execute the second (g2) and (g1) in a loop since you end up before the code you just executed until you hit (not (pair? tr)) then the you do g2 and g1 3 times with emty list.
You really don't need call/cc to do this at all. It's enough with closures:
(define (flat-tree-generator tr)
(define initial? #t)
(define state '())
(define (resume)
(if (null? state)
'()
(let ((cont (car state)))
(set! state (cdr state))
(cont))))
(define (recur tr)
(cond
((null? tr) (resume))
((not (pair? tr)) tr)
(else (set! state
(cons
(lambda () (recur (cdr tr)))
state))
(recur (car tr)))))
(define (dispatch)
(if initial?
(begin (set! initial? #f) (recur tr))
(resume)))
dispatch)
Or you really can use Rackets generator features. This code works in the same manner:
(require racket/generator)
(define (flat-tree-generator tr)
(generator ()
(let rec ((tr tr))
(cond ((null? tr) tr)
((pair? (car tr)) (rec (car tr))
(rec (cdr tr)))
(else (yield (car tr))
(rec (cdr tr)))))))
In both you get the expected behaviour:
(for ([e1 (in-producer g1 '())]
[e2 (in-producer g2 '())])
(printf "e1: ~a e2: ~a\n" e1 e2))
; ==> void, side effect prints:
e1: 0 e2: 0
e1: 1 e2: 1
e1: 2 e2: 2
e1: 3 e2: 3
e1: 4 e2: 4
To solve this with continuations, I find it helpful to use continuations both in the producer and in the dispatcher; this way you flip-flop between both. But it's slightly mind-bending, and non-cc-based solutions are definitely way easier to understand.
A sample implementation is below. I recommend using the Racket debugger step-by-step to completely understand the flow of execution.
(define (flat-tree lst)
; main procedure
(define (go lst k-dp)
(cond
((null? lst) k-dp)
((pair? lst) (go (cdr lst) (go (car lst) k-dp)))
(else (let/cc k-go (k-dp (cons lst k-go))))))
; saved continuation
(define k-go #f)
; dispatcher
(thunk
(define ret (let/cc k-dp (if k-go (k-go k-dp) (go lst k-dp))))
(if (pair? ret)
(begin
(set! k-go (cdr ret))
(car ret))
null)))
testing:
(define g1 (flat-tree '((a (b c)) (d e (f (g (h)))))))
(define g2 (flat-tree '(0 1 2 3 4 (5 (6 . 7)))))
(for ([e1 (in-producer g1 null)] [e2 (in-producer g2 null)])
(printf "e1: ~a e2: ~a\n" e1 e2))
yields
e1: a e2: 0
e1: b e2: 1
e1: c e2: 2
e1: d e2: 3
e1: e e2: 4
e1: f e2: 5
e1: g e2: 6
e1: h e2: 7
Just for reference. In my solution, when I wrap the whole dispatch body in a continuation and save it in yield, and in recur I force its return value to go to dispatch's continuation i.e. yield, every thing works fine:
(define (flat-tree-generator tr)
(define initial? #t)
(define state '())
(define yield #f) ; here is change 1
(define (resume)
(if (null? state)
'()
(let ((cont (car state)))
(set! state (cdr state))
(cont))))
(define (recur tr)
(cond
((null? tr) (resume))
((not (pair? tr)) tr)
(else (call/cc
(lambda (k)
(set! state
(cons
(lambda () (k (recur (cdr tr))))
state))
(yield (recur (car tr)))))))) ;here is the change 2
(define (dispatch)
(call/cc (lambda (cc) ;here is the change 3
(set! yield cc)
(if initial?
(begin (set! initial? #f) (recur tr))
(resume)))))
dispatch)
This is inspired by the far more elegant solution of the book Teach Yourself Scheme in Fixnum Days, (also I recommend this book for scheme beginners, it's easy to understand and the examples are good):
(define tree->generator
(lambda (tree)
(let ((caller '*))
(letrec
((generate-leaves
(lambda ()
(let loop ((tree tree))
(cond ((null? tree) 'skip)
((pair? tree)
(loop (car tree))
(loop (cdr tree)))
(else
(call/cc
(lambda (rest-of-tree)
(set! generate-leaves
(lambda ()
(rest-of-tree 'resume)))
(caller tree))))))
(caller '()))))
(lambda ()
(call/cc
(lambda (k)
(set! caller k)
(generate-leaves))))))))
Finally, this is my experience in this problem: if a procedure A(such as dispatch) will enter a previous continuation (via calling resume) to get some data, you'd better make sure you can go back with these data to A's continuation.
I need to write a scheme function that returns as a function which then takes another argument, eg a list and in turn return the desired result. In this example (c?r "arg") would return -- (car(cdr -- which then subsequently takes the list argument to return 2
> ((c?r "ar") '(1 2 3 4))
2
> ((c?r "ara") '((1 2) 3 4))
2
The problem I have is how can I return a function that accepts another arg in petite?
Here's how you might write such a function:
(define (c?r cmds)
(lambda (lst)
(let recur ((cmds (string->list cmds)))
(if (null? cmds)
lst
(case (car cmds)
((#\a) (car (recur (cdr cmds))))
((#\d) (cdr (recur (cdr cmds))))
(else (recur (cdr cmds))))))))
Note that I'm using d to signify cdr, not r (which makes no sense, to me). You can also write this more succinctly using string-fold-right (requires SRFI 13):
(define (c?r cmds)
(lambda (lst)
(string-fold-right (lambda (cmd x)
(case cmd
((#\a) (car x))
((#\d) (cdr x))
(else x)))
lst cmds)))
Just wanted to add my playing with this. Uses SRFI-1.
(import (rnrs)
(only (srfi :1) fold)) ;; require fold from SRFI-1
(define (c?r str)
(define ops (reverse (string->list str)))
(lambda (lst)
(fold (lambda (x acc)
((if (eq? x #\a) car cdr) ; choose car or cdr for application
acc))
lst
ops)))
Its very similar to Chris' version (more the previous fold-right) but I do the reverseso i can use fold in the returned procedure. I choose which of car or cdr to call by looking at the character.
EDIT
Here is an alternative version with much more preprocessing. It uses tail-ref and list-tail as shortcuts when there are runs of #\d's.
(define (c?r str)
(let loop ((druns 0) (ops (string->list str)) (funs '()))
(cond ((null? ops)
(let ((funs (reverse
(if (zero? druns)
funs
(cons (lambda (x)
(list-tail x druns))
funs)))))
(lambda (lst)
(fold (lambda (fun lst)
(fun lst))
lst
funs))))
((eq? (car ops) #\d) (loop (+ druns 1) (cdr ops) funs))
((= druns 0) (loop 0 (cdr ops) (cons car funs)))
(else (loop 0 (cdr ops) (cons (lambda (x)
(list-ref x druns))
funs))))))
This can be made even simpler in #!racket. we skip the reverse and just do (apply compose1 funs).
(define (c?r str)
(let loop ((druns 0) (ops (string->list str)) (funs '()))
(cond ((null? ops)
(let ((funs (if (zero? druns)
funs
(cons (lambda (x)
(list-tail x druns))
funs))))
(apply compose1 funs)))
((eq? (car ops) #\d) (loop (+ druns 1) (cdr ops) funs))
((= druns 0) (loop 0 (cdr ops) (cons car funs)))
(else (loop 0 (cdr ops) (cons (lambda (x)
(list-ref x druns))
funs))))))
Assuming a compose procedure:
(define (compose funs . args)
(if (null? funs)
(apply values args)
(compose (cdr funs) (apply (car funs) args))))
(compose (list cdr car) '(1 2 3 4))
=> 2
c?r can be defined in terms of compose like so:
(define (c?r funs)
(lambda (e)
(compose
(map
(lambda (f) (if (char=? f #\a) car cdr))
(reverse (string->list funs)))
e)))
then
((c?r "ar") '(1 2 3 4))
=> 2
((c?r "ara") '((1 2) 3 4))
=> 2
Although the following code works perfectly well in DrRacket environment, it generates the following error in WeScheme:
Inside a cond branch, I expect to see a question and an answer, but I see more than two things here.
at: line 15, column 4, in <definitions>
How do I fix this? The actual code is available at http://www.wescheme.org/view?publicId=gutsy-buddy-woken-smoke-wrest
(define (insert l n e)
(if (= 0 n)
(cons e l)
(cons (car l)
(insert (cdr l) (- n 1) e))))
(define (seq start end)
(if (= start end)
(list end)
(cons start (seq (+ start 1) end))))
(define (permute l)
(cond
[(null? l) '(())]
[else (define (silly1 p)
(define (silly2 n) (insert p n (car l)))
(map silly2 (seq 0 (length p))))
(apply append (map silly1 (permute (cdr l))))]))
Another option would be to restructure the code, extracting the inner definitions (which seem to be a problem for WeScheme) and passing around the missing parameters, like this:
(define (insert l n e)
(if (= 0 n)
(cons e l)
(cons (car l)
(insert (cdr l) (- n 1) e))))
(define (seq start end)
(if (= start end)
(list end)
(cons start (seq (+ start 1) end))))
(define (permute l)
(cond
[(null? l) '(())]
[else (apply append (map (lambda (p) (silly1 p l))
(permute (cdr l))))]))
(define (silly1 p l)
(map (lambda (n) (silly2 n p l))
(seq 0 (length p))))
(define (silly2 n p l)
(insert p n (car l)))
The above will work in pretty much any Scheme implementation I can think of, it's very basic, standard Scheme code.
Use local for internal definitions in the teaching languages.
If you post your question both here and at the mailing list,
remember to write you do so. If someone answers here, there
is no reason why persons on the mailing list should take
time to answer there.
(define (insert l n e)
(if (= 0 n)
(cons e l)
(cons (car l)
(insert (cdr l) (- n 1) e))))
(define (seq start end)
(if (= start end)
(list end)
(cons start (seq (+ start 1) end))))
(define (permute2 l)
(cond
[(null? l) '(())]
[else
(local [(define (silly1 p)
(local [(define (silly2 n) (insert p n (car l)))]
(map silly2 (seq 0 (length p)))))]
(apply append (map silly1 (permute2 (cdr l)))))]))
(permute2 '(3 2 1))