summaryrefslogtreecommitdiffstats
path: root/ps04_combinators_amb/repl-amb.scm
blob: 90311b0372c2c4c9c01110002932a258561e5463 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
(declare (usual-integrations write write-line pp eval))

(define write
  (make-generic-operator 1
    (access write user-initial-environment)))

(define write-line
  (make-generic-operator 1
    (access write-line user-initial-environment)))

(define pp
  (make-generic-operator 1
    (access pp user-initial-environment)))

(define (procedure-printable-representation procedure)
  `(compound-procedure
    ,(procedure-parameters procedure)
    ,(procedure-body procedure)
    <procedure-environment>))

(defhandler write
  (compose write procedure-printable-representation)
  compound-procedure?)

(defhandler write-line
  (compose write-line procedure-printable-representation)
  compound-procedure?)

(defhandler pp
  (compose pp procedure-printable-representation)
  compound-procedure?)

 
(define (read) (prompt-for-command-expression "eval> "))

(define the-global-environment)


;;; Initialization and driver loop

(define (evaluator exp succeed fail)
  ((analyze exp)
   the-global-environment
   succeed
   fail))

(define input-prompt ";;; Amb-Eval input:\n")

(define output-prompt "\n;;; Amb-Eval value:\n")

(define (init)
  (set! the-global-environment
	(extend-environment '() '() the-empty-environment))
  (driver-loop))

(define (driver-loop)
  (define (internal-loop try-again)
    (let ((input
           (prompt-for-command-expression input-prompt)))
      (if (eq? input 'try-again)
          (try-again)
          (begin
            (newline)
            (display ";;; Starting a new problem ")
            (evaluator
             input
             (lambda (val next-alternative)
               (display output-prompt)
	       (show-amb-count)
               (pp val)
               (internal-loop next-alternative))
             (lambda ()
               (display ";;; There are no more values of ")
               (pp input)
               (driver-loop)))))))
  (internal-loop
   (lambda ()
     (display ";;; There is no current problem")
     (driver-loop))))

(define go driver-loop)