LazyK

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 cons* '(L (L (L (A (A (V 0) (V 2)) (V 1))))))

(define car* '(L (A (V 0) (L (L (V 1))))))

(define cdr* '(L (A (V 0) (L (L (V 0))))))

(define nil* '(L (L (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 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)]))

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

(define (L->number n)
  (L->number* (L-body (L-body n))))

(define (L->number* n)
  (cond
   [(V? n) 0]
   [(A? n) (+ (L->number* (A-arg n)) 1)]))

(define (number->L n)
  (if (zero? n)
      n-0
      (eval `(A ,succ ,(number->L (- n 1))))))

(define (char->L c)
  (number->L (char->integer c)))

(define (L->char c)
  (integer->char (L->number c)))

(define (list->L list)
  (if (null? list)
      nil*
      (eval `(A (A ,cons* ,(car list)) ,(list->L (cdr list))))))

(define (L->list L)
  (if (equal? L nil*)
      '()
      (cons (eval `(A ,car* ,L))
	    (L->list (eval `(A ,cdr* ,L))))))

(define (string->L s)
  (list->L (map char->L (string->list s))))

(define (L->string L)
  (list->string (map L->char (L->list L))))


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


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

(define K '(L (L (V 1))))

(define I '(L (V 0)))

(define (parse str)
  (with-input-from-port (open-input-string str) (lambda () (parse* I))))

(define (parse* acc)
  (let ([c (read-char)])
    (if (or (eof-object? c) (char=? c #\)))
	acc
	(case c
	  [(#\S) (parse* `(A ,acc ,S))]
	  [(#\K) (parse* `(A ,acc ,K))]
	  [(#\I) (parse* `(A ,acc ,I))]
	  [(#\() (parse* I)]
	  [else  (parse* acc)]))))

(define (main args)
  (let ([program (parse (cadr args))]
	[input   (string->L (read-line))])
    (print (L->string (eval `(A ,program ,input))))))