Permalink
Browse files

fix code

  • Loading branch information...
1 parent 7bf5775 commit 9a47040d34354e3cab838c141b2fa8a50c8df025 @likerivers12 likerivers12 committed Aug 12, 2011
Showing with 117 additions and 66 deletions.
  1. +117 −66 ch04/4.3/amb-eval-likerivers12.scm
@@ -2,63 +2,63 @@
;; racket -l r5rs/run
-;;;<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+(load "../4.1/basic-eval-likerivers12.scm")
+(load "../4.1/basic-eval-anal-likerivers12.scm")
+;;===================================================================
-(define-syntax amb
- (syntax-rules ()
- ((amb) (try-again))
- ((amb x) x)
- ((amb x . xs)
- (amb+ (lambda () x)
- (lambda () (amb . xs))))))
+(define (my-eval exp env)
+ ((analyze exp) env))
-(define (try-again)
- (if (null? amb-stack)
- (error "amb search tree exhausted")
- (let ((r (car amb-stack)))
- (set! amb-stack (cdr amb-stack))
- (r))))
+(define (analyze exp)
+ (cond ((self-evaluating? exp)
+ (analyze-self-evaluating exp))
+ ((quoted? exp) (analyze-quoted exp))
+ ((variable? exp) (analyze-variable exp))
+ ((assignment? exp) (analyze-assignment exp))
+ ((definition? exp) (analyze-definition exp))
+ ((if? exp) (analyze-if exp))
+ ((lambda? exp) (analyze-lambda exp))
+ ((begin? exp) (analyze-sequence (begin-actions exp)))
+ ((cond? exp) (analyze (cond->if exp)))
-(define (amb-reset)
- (set! amb-stack '()))
-
-(define amb-stack '())
+ ((let? exp) (analyze (let->combination exp))) ;**
-(define (amb+ a b)
- (define s '())
- (set! s amb-stack)
- (call/cc
- (lambda (r)
- (call/cc
- (lambda (c)
- (set! amb-stack
- (cons c amb-stack))
- (r (a))))
- (set! amb-stack s)
- (b))))
+ ;; analyze에 추가
+ ((amb? exp) (analyze-amb exp))
+
+ ((application? exp) (analyze-application exp))
+ (else
+ (error "Unknown expression type -- ANALYZE" exp))))
-(define call/cc call-with-current-continuation)
-;;;>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+;; let 문법 추가 - from longfin's code
+(define (let? exp) (tagged-list? exp 'let))
+(define (let-bindings exp) (cadr exp))
+(define (let-body exp) (cddr exp))
+(define (let-var binding) (car binding))
+(define (let-val binding) (cadr binding))
+(define (make-combination operator operands) (cons operator operands))
+(define (let->combination exp)
+ ;;make-combination defined in earlier exercise
+ (let ((bindings (let-bindings exp)))
+ (make-combination (make-lambda (map let-var bindings)
+ (let-body exp))
+ (map let-val bindings))))
+;;===================================================================
;;;;;;;;;;;;;;;;;
;;; 실행기의 구조
;;; p560
(define (amb? exp) (tagged-list? exp 'amb))
-
(define (amb-choices exp) (cdr exp))
-;; analyze에 추가
-;;((amb? exp) (analyze-amb exp))
-
-
(define (ambeval exp env succeed fail)
((analyze exp) env succeed fail))
@@ -260,33 +260,82 @@
-;; (load "../4.1/basic-eval-likerivers12.scm")
-;; (load "../4.1/basic-eval-anal-likerivers12.scm")
-;; (load "./amb-eval-likerivers12.scm")
+
+
+
+
+(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list 'list list)
+ (list 'memq memq)
+ (list 'member member)
+ (list 'not not)
+ (list '+ +)
+ (list '- -)
+ (list '* *)
+ (list '= =)
+ (list '> >)
+ (list '< <)
+ (list '>= >=)
+ (list 'abs abs)
+ (list 'remainder remainder)
+ (list 'integer? integer?)
+ (list 'sqrt sqrt)
+ (list 'eq? eq?)
+ (list 'display display)
+ (list 'newline newline)
+ (list 'reverse reverse)
+ (list 'even? even?)
+;; more primitives
+ ))
+
+
+(define the-global-environment (setup-environment))
+
+;; add error procedure
+
+(define (error reason . args)
+ (display "Error: ")
+ (display reason)
+ (for-each (lambda (arg)
+ (display " ")
+ (write arg))
+ args)
+ (newline)
+ (scheme-report-environment 5))
+
+'amb-eval-loaded
+
+
+
;;;--------------------------------
-;;;
-(define (require p)
- (if (not p) (amb)))
-
-(define (an-element-of items)
- (require (not (null? items)))
- (amb (car items) (an-element-of (cdr items))))
-
-(define (an-integer-starting-from n)
- (amb n (an-integer-starting-from (+ n 1))))
-
-;;; 피타고라스 수
-;;; i^2 + j^2 = k^2
-(define (a-pythagorean-triple-between low high)
- ((lambda (i)
- ((lambda (j)
- ((lambda (k)
- (require (= (+ (* i i) (* j j)) (* k k)))
- (list i j k))
- (an-integer-between j high)))
- (an-integer-between i high)))
- (an-integer-between low high)))
+;;; amb 실행기에서 수행
+
+;; (define (require p)
+;; (if (not p) (amb)))
+
+;; (define (an-element-of items)
+;; (require (not (null? items)))
+;; (amb (car items) (an-element-of (cdr items))))
+
+;; (define (an-integer-starting-from n)
+;; (amb n (an-integer-starting-from (+ n 1))))
+
+;; ;;; 피타고라스 수
+;; ;;; i^2 + j^2 = k^2
+;; ;; (define (a-pythagorean-triple-between low high)
+;; ;; ((lambda (i)
+;; ;; ((lambda (j)
+;; ;; ((lambda (k)
+;; ;; (require (= (+ (* i i) (* j j)) (* k k)))
+;; ;; (list i j k))
+;; ;; (an-integer-between j high)))
+;; ;; (an-integer-between i high)))
+;; ;; (an-integer-between low high)))
;; (define (a-pythagorean-triple-between low high)
;; (let ((i (an-integer-between low high)))
@@ -296,10 +345,12 @@
;; (list i j k)))))
-(define (an-integer-between low high)
- (require (not (> low high)))
- (amb low (an-integer-between (+ 1 low) high)))
+;; (define (an-integer-between low high)
+;; (require (not (> low high)))
+;; (amb low (an-integer-between (+ 1 low) high)))
+
+;; (a-pythagorean-triple-between 1 10)
+
-(a-pythagorean-triple-between 1 10)
;;;
;;;-------------------------------------------------------

0 comments on commit 9a47040

Please sign in to comment.