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.
Related
I want to show the last appearance of an element from a given list. For example: For the list '(1 1 2 1 3 3 4 3 5 6), the result will be '(2 1 4 3 5 6)
This is the code I have:
(define (func L res)
(if (not (null? L))
(foldl (lambda (e)
(if (not (member e (cdr L)))
(cons e (remove-duplicates-right (cdr L)))
(remove-duplicates-right (cdr L))))
res L)
res))
(define (show-last-app L)
(func L '()))
The next error occurs: "foldl: given procedure does not accept 2 arguments"
This is how I solved it only with recursion but I want to use only foldl or filter and don't use functions with side effects:
(define (show-last-app L)
(cond
((null? L)
'())
((not (member (car L) (cdr L)))
(append (list (car L)) (show-last-app (cdr L))))
(else (show-last-app (cdr L)))))
I think you misunderstand how folds work in Scheme. This is closer to what you were aiming for:
(define (show-last-app L)
(foldr (lambda (e acc)
(if (not (member e acc))
(cons e acc)
acc))
'()
L))
If you really, really have to use foldl:
(define (show-last-app L)
(foldl (lambda (e acc)
(if (not (member e acc))
(cons e acc)
acc))
'()
(reverse L)))
Either way, it works as expected:
(show-last-app '(1 2 4 1 5 3 1 6 2))
=> (4 5 3 1 6 2)
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.
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
I am getting "Error: Invalid lambda: (lambda (insert-all))."
(define permutations
(lambda (L)
(let
((insert-all
(lambda (e Ls)
(let
((insert-one
(lambda (L)
(letrec
((helper
(lambda(L R)
(if (null? R)
(list (append L(list e)R))
(helper (append L (list (car R) ) ) (cdr R) )
))))
(helper '() L)))))
(apply append(map insert-one Ls)))))))
(cond ((null? L) '() )
((null?(cdr L)) (list L))
(else (insert-all (car L) (permutations ((cdr L))))))))
It is supposed to return all permutations of a given list.
The form that you have provided in not valid scheme. Specifically, your highest-level let form does not have a body. You might be thinking that the cond clause is the body but owing to your parenthesis it is not part of the let. Honestly, this is the fault of your formatting. Here is a 'properly' formatted Scheme form:
(define (permutations L)
(let ((insert-all
(lambda (e Ls)
(let ((insert-one
(lambda (L)
(let helper ((L '()) (R L))
(if (null? R)
(list (append L (list e) R))
(helper (append L (list (car R)))
(cdr R)))))))
(apply append (map insert-one Ls))))))
(cond ((null? L) '())
((null? (cdr L)) (list L))
(else (insert-all (car L)
(permutations (cdr L)))))))
At least it compiles and runs, although it doesn't produce the right answer (although I don't know what the proper input it):
> (permutations '(a b c))
((c b a))
> (permutations '((a b) (1 2)))
(((1 2) (a b)))
Here is an implementation that works:
(define (permutations L)
(define (insert-all e Ls)
(apply append
(map (lambda (e)
(map (lambda (x) (cons e x)) Ls))
e)))
(cond ((null? L) '())
((null? (cdr L)) (map list (car L)))
(else (insert-all (car L)
(permutations (cdr L))))))
> (permutations '((a b) (1 2) (x y)))
((a 1 x) (a 1 y) (a 2 x) (a 2 y) (b 1 x) (b 1 y) (b 2 x) (b 2 y))
The basic structure of your code was fine; just the implementation of your insert-one and helper were lacking.
(define filter-in
(lambda (predicate list)
(let((f
(lambda (l)
(filter-in-sexpr predicate l))))
(map f list))))
(define filter-in-aux
(lambda (pred lst)
(if (null? lst) '()
(cons (filter-in-sexpr pred (car lst))
(filter-in-aux pred (cdr lst))))))
(define filter-in-sexpr
(lambda (pred sexpr)
(if (equal? (pred sexpr) #t)
sexpr
'())))
Calling (filter-in number? ’(a 2 (1 3) b 7)) produces ( () 2 () () 7).
How I can skip null elements from the generated list to get final outcome of (2 7) ?
The problem is that you're mapping filter-in-sxpr over the list. You can either run another filter pass to remove the nulls, or use a modified filter-in-aux like this:
(define filter-in-aux
(lambda (pred lst)
(if (null? lst) '()
(let ((h (filter-in-sexpr pred (car lst)))
(t (filter-in-aux pred (cdr lst))))
(if (null? h) t
(cons h t))))))