felixm
/
SICP
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Finish 4.78 and skip 4.79

main
Felix Martin 2021-03-16 20:25:41 -04:00
parent 8139622b44
commit 4608399b2d
3 changed files with 99 additions and 114 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

185
ex-4_78-79.scm
View File

@ -19,30 +19,8 @@
(amball '(begin
(define input-prompt ";;; Query input:")
(define output-prompt ";;; Query results:")
(define (query-driver-loop)
(prompt-for-input input-prompt)
(let ((q (query-syntax-process (read))))
(cond ((assertion-to-be-added? q)
(add-rule-or-assertion! (add-assertion-body q))
(newline)
(display "Assertion added to data base.")
(query-driver-loop))
(else
(newline)
(display output-prompt)
;; [extra newline at end] (announce-output output-prompt)
(display-list
(map
(lambda (frame)
(instantiate q
frame
(lambda (v f)
(contract-question-mark v))))
(qeval q (singleton-list '()))))
(query-driver-loop)))))
(define (require p)
(if (null? p) (amb)))
(define (instantiate exp frame unbound-var-handler)
(define (copy exp)
@ -56,59 +34,42 @@
(else exp)))
(copy exp))
;;;SECTION 4.4.4.2
;;;The Evaluator
(define (qeval query frame-list)
;; (display "QEVAL ") (display query) (newline)
(define (qeval query frame)
(let ((qproc (get (type query) 'qeval)))
(if qproc
(qproc (contents query) frame-list)
(simple-query query frame-list))))
(qproc (contents query) frame)
(simple-query query frame))))
;;;Simple queries
(define (simple-query query-pattern frame)
;;(display "SIMPLE-QUERY ") (display query-pattern) (newline)
(let ((r (apply-rules query-pattern frame)))
(let ((a (find-assertions query-pattern frame)))
(let ((result (append a r)))
(require result)
result))))
(define (simple-query query-pattern frame-list)
;; (display "SIMPLE-QUERY ") (display query-pattern) (newline)
(flatmap
(lambda (frame)
(append
(find-assertions query-pattern frame)
(apply-rules query-pattern frame)))
frame-list))
;;;Compound queries
(define (conjoin conjuncts frame-list)
(define (conjoin conjuncts frame)
(if (empty-conjunction? conjuncts)
frame-list
frame
(conjoin (rest-conjuncts conjuncts)
(qeval (first-conjunct conjuncts)
frame-list))))
(qeval (first-conjunct conjuncts) frame))))
;;(put 'and 'qeval conjoin)
(define (disjoin disjuncts frame-list)
(define (disjoin disjuncts frame)
(if (empty-disjunction? disjuncts)
'()
(interleave
(qeval (first-disjunct disjuncts) '())
(disjoin (rest-disjuncts disjuncts) frame-list))))
(amb)
(let ((r1 (qeval (first-disjunct disjuncts) frame)))
(if (null? r1)
(disjoin (rest-disjuncts disjuncts) frame)
(amb r1 (disjoin (rest-disjuncts disjuncts) frame))))))
;;(put 'or 'qeval disjoin)
;;;Filters
(define (negate operands frame-list)
(flatmap
(lambda (frame)
(if (null? (qeval (negated-query operands)
(singleton-list frame)))
(singleton-list frame)
'()))
frame-list))
(define (negate operands frame)
(if (null? (qeval (negated-query operands) frame))
frame
(amb)))
(define (uniquely-asserted query frame-list)
(flatmap
@ -121,19 +82,15 @@
;;(put 'not 'qeval negate)
(define (lisp-value call frame-list)
(flatmap
(lambda (frame)
(if (execute
(instantiate
call
frame
(lambda (v f)
(error "Unknown pat var -- LISP-VALUE" v))))
(singleton-list frame)
'()))
frame-list))
(define (lisp-value call frame)
(if (execute
(instantiate
call
frame
(lambda (v f)
(error "Unknown pat var -- LISP-VALUE" v))))
frame
(amb)))
;;(put 'lisp-value 'qeval lisp-value)
(define (execute exp)
@ -153,16 +110,23 @@
(define (find-assertions pattern frame)
;; (display "FIND-ASSERTIONS ") (display pattern) (newline)
(flatmap
(lambda (datum) (check-an-assertion datum pattern frame))
(fetch-assertions pattern frame)))
(define (check xs)
(if (null? xs)
xs
(if (null? (car xs))
(check (cdr xs))
(cons (car xs) (check (cdr xs))))))
(lamb ;(check
(map (lambda (datum) (check-an-assertion datum pattern frame))
(fetch-assertions pattern frame))))
(define (check-an-assertion assertion query-pat query-frame)
(let ((match-result
(pattern-match query-pat assertion query-frame)))
(if (eq? match-result 'failed)
'()
(singleton-list match-result))))
match-result)))
(define (pattern-match pat dat frame)
(cond ((eq? frame 'failed) 'failed)
@ -676,41 +640,54 @@
((rule-to-be-added? q)
(add-rule-or-assertion! q))
(else
(display-list
(map
(lambda (frame)
(instantiate q
frame
(lambda (v f)
(contract-question-mark v))))
(qeval q (singleton-list '()))))))))
(initialize-data-base microshaft-data-base)
;; We are insided the non-deterministic evaluator here.
(instantiate
q
(qeval q '())
(lambda (v f) (contract-question-mark v)))))))
(display "\nex-4.78 - non-deterministic-query\n")
(display "[installed-query-system]\n")
(initialize-data-base microshaft-data-base)
(display "[installed-microshaft-data-base]\n")
; Query is working within non-deterministic evaluator. Now we can switch to
; amb.
;(eval-query '(supervisor ?x (bitdiddle ben)))
(eval-query
'(rule (big-shot ?p)
(and (job ?p (?div1 . ?rest1))
(supervisor ?p ?boss)
(job ?boss (?div2 . ?rest2))
(not (same ?div1 ?div2)))))
;(eval-query
; '(and (supervisor ?person (Bitdiddle Ben))
; (address ?person ?address)))
;(eval-query
; '(rule (big-shot ?p)
; (and (job ?p (?div1 . ?rest1))
; (supervisor ?p ?boss)
; (job ?boss (?div2 . ?rest2))
; (not (same ?div1 ?div2)))))
(eval-query
'(and (salary (Bitdiddle Ben) ?ben-amount)
(salary ?person ?amount)
(lisp-value > ?amount ?ben-amount)))
(eval-query '(big-shot ?x))
(newline)
))
;(eval-query '(big-shot ?x))
)) ;; Enf of non-deterministic evaluator
(define (display-line x)
(display x)
(newline))
(map display-line result)
; Regular queries work, but rules don't. I have to admit that this exercise is
; at the limit of my current capabilities and I have already spent a
; significantly longer time than I need for a regular exercise. I move on for
; now. Honestly, I am pretty proud that I was able to set up the query language
; within the non-deterministic evaluator. To make further progress I would need
; to understand the query-rule application better.
(display "\nex-4.79\n")
(display "[skipped]\n")
; I throw the towel on this one. 4.78 was challenging enough and I want to move
; on.

3
ex-5_01-xx.scm Normal file
View File

@ -0,0 +1,3 @@
(load "util.scm")
(display "\nex-5.1\n")

25
misc/sicp-ambeval.scm
View File

@ -363,23 +363,25 @@
;;;Code from SECTION 4.3.3, modified as needed to run it
(define (amb? exp) (tagged-list? exp 'amb))
(define (amb-choices exp) (cdr exp))
(define (ramb? exp) (tagged-list? exp 'ramb))
(define (ramb-choices exp) (cdr exp))
; The lamb statement takes a single list and treats each item as a value. So
; its the equivalent of (apply amb list) in Scheme. Since our evaluator does
; not support that expression we use lamb. Analyze-lamb calls analyze-amb.
;; lamb takes a list and treats each element as a separate amb-value
(define (lamb? exp) (tagged-list? exp 'lamb))
(define (lamb-choices exp) (cdr exp))
(define (lamb-arg exp) (cadr exp))
(define (analyze-lamb exp)
(analyze-amb (cons (car exp) (cadr exp))))
(let ((p (analyze (lamb-arg exp))))
(lambda (env succeed fail)
(define (try-options options fail2)
(if (null? options)
(fail)
(succeed (car options) (lambda () (try-options (cdr options) fail2)))))
(p env try-options fail))))
;; analyze from 4.1.6, with clause from 4.3.3 added
;; and also support for Let
;; analyze from 4.1.6, with clause from 4.3.3 added and also support for let
(define (analyze exp)
(cond ((self-evaluating? exp)
(analyze-self-evaluating exp))
@ -666,13 +668,14 @@
(list (list '* *)
(list '+ +)
(list '- -)
(list '< <)
(list '<= <=)
(list '= =)
(list '> >)
(list '>= >=)
(list 'abs abs)
(list 'assoc assoc)
(list 'append append)
(list 'assoc assoc)
(list 'caddr caddr)
(list 'cadr cadr)
(list 'car car)
@ -680,8 +683,8 @@
(list 'cdr cdr)
(list 'cons cons)
(list 'display display)
(list 'equal? equal?)
(list 'eq? eq?)
(list 'equal? equal?)
(list 'integer? integer?)
(list 'list list)
(list 'member member)
@ -689,12 +692,14 @@
(list 'newline newline)
(list 'not not)
(list 'null? null?)
(list 'number? number?)
(list 'pair? pair?)
(list 'remainder remainder)
(list 'set-car! set-car!)
(list 'set-cdr! set-cdr!)
(list 'sqrt sqrt)
(list 'string->symbol string->symbol)
(list 'string-append string-append)
(list 'string-length string-length)
(list 'string=? string=?)
(list 'substring substring)