LazyK with Scheme

gistfile1.scm

;---------------------------------------------------------------
; debug print

(define (show-recursion1 f)
  (let ([*nest* 0])
    (lambda (arg)
      (dotimes (i *nest*) (display "   "))
      (print arg)
      (set! *nest* (+ *nest* 1))
      (let ([result (f arg)])
	(set! *nest* (- *nest* 1))
	result))))

;----------------------------------------------------------------


(define n-0 '(L (L (V 0))))

(define n-1 '(L (L (A (V 1) (V 0)))))

(define n-2 '(L (L (A (V 1) (A (V 1) (V 0))))))

(define n-3 '(L (L (A (V 1) (A (V 1) (A (V 1) (V 0)))))))

(define succ '(L (L (L (A (V 1) (A (A (V 2) (V 1)) (V 0)))))))


(define (V? x) (eq? (car x) 'V))

(define (A? x) (eq? (car x) 'A))

(define (L? x) (eq? (car x) 'L))

(define (A-proc x) (cadr x))

(define (A-arg x) (caddr x))

(define (L-body x) (cadr x))

(define (V-index x) (cadr x))

(define eval
  (show-recursion1
   (lambda (expr)
     (cond
      [(A? expr)
       (let ([proc (eval (A-proc expr))])
	 (if (L? proc)
	     (eval (subst 0 (L-body proc) (eval (A-arg expr))))
	     `(A ,proc ,(eval (A-arg expr)))))]
      [(L? expr)
       `(L ,(eval (L-body expr)))]
      [(V? expr)
       expr]))))

(define (subst nest expr val)
  (cond
   [(L? expr)
    `(L ,(subst (+ nest 1) (L-body expr) val))]
   [(A? expr)
    `(A ,(subst nest (A-proc expr) val) ,(subst nest (A-arg expr) val))]
   [(V? expr)
    (cond
     [(= nest (V-index expr))
      (subst* 0 nest val)]
     [(> nest (V-index expr))
      expr]
     [(< nest (V-index expr))
      `(V ,(- (V-index expr) 1))])]))

(define (subst* nest base expr)
  (cond
   [(L? expr)
    `(L ,(subst* (+ nest 1) base (L-body expr)))]
   [(A? expr)
    `(A ,(subst* nest base (A-proc expr)) ,(subst* nest base (A-arg expr)))]
   [(V? expr)
    (if (>= (V-index expr) nest)
	`(V ,(+ (V-index expr) base))
	expr)]))