vallog: memo, call/cc, named let, do

2010/03/25

(define (my-reverse ls)
  (let/cc return
   (let ((r #f))
     (let ((l ls) (acc '()))
       (let/cc continue
        (set! r continue))
       (and (null? l) (return acc))
       (set! acc (cons (car l) acc))
       (set! l (cdr l))
       (r '())))))

Scheme:

;; named let
(define (my-reverse ls)
  (let loop ((l ls) (acc '()))
    (if (null? l)
        acc
        (loop (cdr l) (cons (car l) acc)))))
 
(display (my-reverse '(1 2 3 4 5)))
(newline)

;; do
(define (my-reverse ls)
  (do ((l ls (cdr l))
       (acc '() (cons (car l) acc)))
      ((null? l) acc)))

(display (my-reverse '(1 2 3 4 5)))
(newline)

(define (my-reverse ls)
  (do ((l ls (cdr l))
       (acc '() (cons (car l) acc)))
      ((null? l) acc)
    (for-each (lambda (x)
  (for-each display x)
  (newline)) `(("l => " ,l) ("acc => " ,acc)))))

(my-reverse '(1 2 3 4 5))

Output:

(5 4 3 2 1)
(5 4 3 2 1)
l => (1 2 3 4 5)
acc => ()
l => (2 3 4 5)
acc => (1)
l => (3 4 5)
acc => (2 1)
l => (4 5)
acc => (3 2 1)
l => (5)
acc => (4 3 2 1)

(define (depth* l)
  (let loop ((e l) (d 1) (acc '(1)))
    (if (null? e)
 (apply max acc)
 (let ((kar (car e)))
   (let ((recur (if (pair? kar) (depth* kar) 0)))
     (loop (cdr e) (+ d recur) (cons d acc)))))))

(define (leftmost l)
  (let/cc skip
   (let loop ((l l))
     (let ((kar (car (if (null? l) (skip l) l))))
       (cond ((pair? kar) (loop kar) (loop (cdr l)))
      (else (skip kar)))))))

(define (filter* pred? l)
  (let loop ((l l))
    (if (null? l)
 '()
 (let ((kar (car l))
       (kdr (cdr l)))
   (let ((fd (loop kdr)))
     ;; let/cc (あるいは call/cc) をここに被せる
     (let/cc skip
      (cons (cond ((pair? kar) (loop kar))
    ((pred? kar) kar)
    ;; 脱出
    (else (skip fd)))
     fd)))))))

vallog

2010/03/25

memo, call/cc, named let, do

0 件のコメント:

コメントを投稿