4.3.3 amb評価器の実装とcall-with-current-continuation

SICP 4.3.3を読んでamb評価器を実装しました。
またほとんど教科書からの書き写しですが、そこそこちゃんと動くと思います。
(amb-loop)を評価して評価器を実行します。

ここのポイントはreadマクロで得られた木をanalyzeすると、
継続による処理のシリアライズが完了するところだと思います。

そしてシリアライズされた一連の手続きが継続で手に入るということは、
評価途中の継続を保存すると、それ以降の手続きも全て保存できるということです。
つまり call-with-current-continuation が実装できるってことですね。

というわけでamb評価器とcall/ccを実装しました。
動作はMIT-schemeで確認しています。

いやー長いこと call-with-current-continuation が何をやってるのかしっくり来てなかったんですが、
やっと少しですが理解が進んだ気がします。

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; println
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (println . exps)
  (let loop ((exps exps))
    (if (null? exps)
	(newline)
	(begin
	  (display (car exps))
	  (loop (cdr exps))))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; boolean and comparison functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (false? val)
  (equal? val 'false))
(define (true? val)
  (not (false? val)))

(define (primitive-not val)
  (if (true? val) 'false 'true))

(define (make-comparison compare)
  (lambda (base . comparison-values)
    (let loop ((vs comparison-values))
      (cond 
       ((null? vs) 'true)
       ((compare base (car vs)) (loop (cdr vs)))
       (else 'false)))))

(define >? (make-comparison >))
(define <? (make-comparison <))
(define =? (make-comparison =))

(define (primitive-equal? l r)
  (if (equal? l r) 'true 'false))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; environment 
;
; environment structure:
; '(((a . 1) (b . 1))          <= newest frame
;   ((a . 2) (b . 2) (c . 3))
;      .... )
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (setup-environment)
  `(((true   . true) 
     (false  . false)
     (car    . (primitive . ,car))
     (cdr    . (primitive . ,cdr))
     (cons   . (primitive . ,cons))
     (+      . (primitive . ,+))
     (-      . (primitive . ,-))
     (*      . (primitive . ,*))
     (/      . (primitive . ,/))
     (>      . (primitive . ,>?))
     (<      . (primitive . ,<?))
     (equal? . (primitive . ,primitive-equal?))
     (=      . (primitive . ,=?))
     (not    . (primitive . ,primitive-not)))))

(define (lookup-var-val var env)
  (let loop ((frames env))
    (cond
     ((null? frames) (error "not found " var))
     (else
      (let ((var-val (assoc var (car frames))))
	(if var-val 
	    (cdr var-val)
	    (loop (cdr frames))))))))

(define (set-var-val! var val env)
  (let loop ((frames env))
    (if (null? frames) 
	(error "unbounded variable" var)
	(let ((var-val (assoc var (car frames))))
	  (if var-val
	      (let ((ret (cdr var-val)))
		(set-cdr! var-val val)
		ret)
	      (loop (cdr frames)))))))

(define (define-var-val! var val env)
  (set-car! env (cons (cons var val) (car env))))

(define (extend-env vars vals env)
  (cons (map cons vars vals) env))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; analyze
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (analyze exp)
  (cond
   ((self-evaluating? exp) (analyze-self-evaluating exp))
   ((symbol? exp)          (analyze-symbol exp))
   ((quoted? exp)          (analyze-quoted exp))
   ((if? exp)              (analyze-if exp))
   ((define? exp)          (analyze-define exp))
   ((set!? exp)            (analyze-set! exp))
   ((begin? exp)           (analyze-begin exp))
   ((lambda? exp)          (analyze-lambda exp))
   ((call/cc? exp)         (analyze-call/cc exp))
   ((amb? exp)             (analyze-amb exp))
   ((require? exp)         (analyze-require exp))
   ((application? exp)     (analyze-application exp))
   (else
    (error "analyze: " exp))))

; analyze support

(define (self-evaluating? exp)  (or (string? exp) 
				    (number? exp)))
(define (quoted? exp)      (equal? (car exp) 'quote))
(define (if? exp)          (equal? (car exp) 'if))
(define (define? exp)      (equal? (car exp) 'define))
(define (set!? exp)        (equal? (car exp) 'set!))
(define (begin? exp)       (equal? (car exp) 'begin))
(define (lambda? exp)      (equal? (car exp) 'lambda))
(define (delay? exp)       (equal? (car exp) 'delay))
(define (force? exp)       (equal? (car exp) 'force))
(define (call/cc? exp)     (equal? (car exp) 'call/cc))
(define (amb? exp)         (equal? (car exp) 'amb))
(define (require? exp)     (equal? (car exp) 'require))
(define (application? exp) (pair? exp))

; there are not new procedures, 
; so this function doesn't make new continuation.

(define (analyze-self-evaluating exp)
  (lambda (env succeed fail)
    (succeed exp fail)))

(define (analyze-quoted exp)
  (let ((qvs (cadr exp)))
    (lambda (env succeed fail)
      (succeed qvs fail))))

(define (analyze-symbol exp)
  (lambda (env succeed fail)
    (succeed (lookup-var-val exp env) fail)))

(define (analyze-if exp)
  (let ((pproc (analyze (cadr exp)))
	(cproc (analyze (caddr exp)))
	(aproc (if (null? (cdddr exp))
		   (lambda (env succeed fail)
		     (succeed 'ok fail))
		   (analyze (cadddr exp)))))
    (lambda (env succeed fail)
      (pproc env
	     (lambda (pred-value fail2)
	       (if (true? pred-value)
		   (cproc env succeed fail2)
		   (aproc env succeed fail2)))
	     fail))))

(define (make-procedure vars procs env)
  (list 'procedure vars procs env))

(define (analyze-lambda exp)
  (let ((vars (cadr exp))
	(procs (analyze-sequence (cddr exp))))
    (lambda (env succeed fail)
      (succeed
       (make-procedure vars procs env)
       fail))))

(define (ambeval exp env succeed fail)
  ((analyze exp) env succeed fail))

(define (analyze-sequence exps)
  (let ((procs (map analyze exps))
	(sequentially
	 (lambda (a b)
	   (lambda (env succeed fail)
	     (a env
		(lambda (a-value fail2)
		  (b env succeed fail2))
		fail)))))
    (if (null? procs)
	(error "Empty sequence --ANALYZE")
	(let loop ((first-proc (car procs))
		   (rest-procs (cdr procs)))
	  (if (null? rest-procs)
	      first-proc
	      (loop
	       (sequentially first-proc
			     (car rest-procs))
	       (cdr rest-procs)))))))

(define (analyze-define exps)
  (if (symbol? (cadr exps))
      (let ((var (cadr exps))
	    (vproc (analyze (caddr exps))))
	(lambda (env succeed fail)
	  (vproc env
		 (lambda (val fail2)
		   (define-var-val! var val env)
		   (succeed 'ok fail2))
		 fail)))
      (let ((var (caadr exps))
	    (args (cdadr exps))
	    (body (analyze-sequence (cddr exps))))
	(lambda (env succeed fail)
	  (define-var-val! 
	    var 
	    (make-procedure args body env)
	    env)
	  (succeed 'ok fail)))))
	
(define (analyze-set! exp)
  (let ((var (cadr exp))
	(vproc (analyze (caddr exp))))
    (lambda (env succeed fail)
      (vproc env
	     (lambda (val fail2)
	       (let ((old-value
		      (lookup-var-val var env)))
		 (set-var-val! var val env)
		 (succeed 'ok
			  (lambda ()
			    (set-var-val! var
					  old-value
					  env)
			    (fail2)))))
	     fail))))

(define (analyze-application exp)
  (let ((pproc  (analyze (car exp)))
	(aprocs (map analyze (cdr exp))))
    (lambda (env succeed fail)
      (pproc env
	     (lambda (proc fail2)
	       (get-args aprocs
			 env
			 (lambda (args fail3)
			   (execute 
			    proc 
			    args 
			    succeed 
			    fail3))
			 fail2))
	     fail))))

(define (get-args aprocs env succeed fail)
  (if (null? aprocs)
      (succeed '() fail)
      ((car aprocs) 
       env
       (lambda (arg fail2)
	 (get-args (cdr aprocs)
		   env
		   (lambda (args fail3)
		     (succeed (cons arg args)
			      fail3))
		   fail2))
       fail)))

(define (execute proc args succeed fail)
  (cond
   ((equal? 'primitive (car proc))
    (succeed (apply (cdr proc) args) fail))
   ((equal? 'procedure (car proc))
    ((caddr proc)
     (extend-env
      (cadr proc) args (cadddr proc))
     succeed
     fail))
   (else 
    (error 
     "Unknown procedure type -- EXEC APPL"
     proc))))

(define (analyze-amb exp)
  (let ((args (map analyze (cdr exp))))
    (lambda (env succeed fail)
      (let try-next ((choices args))
	(if (null? choices)
	    (fail)
	    ((car choices) env
			   succeed
			   (lambda ()
			     (try-next (cdr choices)))
			   ))))))

(define (analyze-require exp)
  (let ((proc (analyze-sequence (cdr exp))))
    (lambda (env succeed fail)
      (proc env
	    (lambda (satisfied fail2)
	      (if (true? satisfied)
		  (succeed 'ok fail2)
		  (fail)))
	    fail))))
      
	       

; for exercise

(define (analyze-begin exp)
  (let ((procs (map analyze (cdr exp)))
	(sequence
	 (lambda (a b)
	   (lambda (env succeed fail)
	     (a env
		(lambda (a-value fail2)
		  (b env succeed fail2))
		fail)))))
    (if (null? procs) 
	(lambda (env succeed fail)
	  (succeed 'ok fail))
	(let loop ((first-proc (car procs))
		   (rest-proc (cdr procs)))
	  (if (null? rest-proc)
	      (lambda (env succeed fail)
		(first-proc env succeed fail))
	      (loop 
	       (sequence first-proc
			 (car rest-proc))
	       (cdr rest-proc)))))))
		  
(define (analyze-call/cc exp)
  (let ((proc (analyze-lambda (cadr exp))))
    (lambda (env succeed fail)
      (proc env
	    (lambda (executable fail2)
	      (execute
	       executable
	       (list (cons 'primitive
			   (lambda (x)
			     (succeed x fail))))
	       succeed
	       fail2))
	    fail))))

;(define (analyze-force exp))
;(define (analyze-delay exp))

(define (amb-loop)
  (let ((the-global-environment (setup-environment)))
    (let driver-loop ()
      (let loop ((try-again 
		  (lambda ()
		    (display ";;; Threre is no current problem")
		    (newline)
		    (driver-loop))))
	(display ";;; input: ")
	(newline)
	(let ((input (read)))
	  (if (eq? input 'try-again)
	      (try-again)
	      (begin
	       (println ";;; Starting a new problem")
	       (ambeval input
			the-global-environment
			(lambda (val next-alternative)
			  (println ";;; value:")
			  (println val)
			  (loop next-alternative))
			(lambda ()
			  (println ";;; Threre are no more value")
			  (display input)
			  (newline)
			  (driver-loop))))))))))