commit 479e210ae8a264b0063274ae722b7213ac928370
parent 83aef65822262f7f81e6d50a82795bbbc2fd955a
Author: Yuval Langer <yuval.langer@gmail.com>
Date: Tue, 23 Jul 2024 00:23:59 +0300
Add exercise 4.6. solution. Also, make one of exercise 4.5. solution's tests needlessly complicated.
Diffstat:
3 files changed, 660 insertions(+), 3 deletions(-)
diff --git a/sicp/solutions/chapter-4/exercise-6.scm b/sicp/solutions/chapter-4/exercise-6.scm
@@ -0,0 +1,618 @@
+(define-library (sicp solutions chapter-4 exercise-6)
+ (export
+ eval
+ main
+
+ run-internal-tests
+
+ make-environment
+ setup-environment
+ extend-environment
+ )
+ (import
+ (rename (scheme base) (apply scheme:base:apply))
+ (scheme cxr)
+ (scheme read)
+ (scheme write)
+
+ (srfi srfi-1)
+ (srfi srfi-9)
+ (srfi srfi-64)
+
+ (system vm trace)
+
+ (ice-9 match)
+ (ice-9 pretty-print)
+
+ (sicp utils)
+ )
+
+ (begin
+ ;; XXX: In 4.1.3 we see that the procedure `true?` is defined
+ ;; using the host-variable `false` whose value is 'false, but we
+ ;; don't see it defined anywhere in the good book, so we need to
+ ;; define the host-variable false ourselves.
+ ;;
+ ;; In MIT Scheme, the one the SICP people seem to love to use for
+ ;; SICP, the values of `false` and `true` are #f and #t, #f being
+ ;; the only value that is falsituous and #t there for having a
+ ;; truthious value that has no other meaning other than being
+ ;; truthitiousic.
+ ;;
+ ;; ```
+ ;; # `scheme` is the MIT Scheme executable:
+ ;; $ guix shell mit-scheme -- scheme
+ ;; MIT/GNU Scheme running under GNU/Linux
+ ;; Type `^C' (control-C) followed by `H' to obtain information about interrupts.
+ ;;
+ ;; Copyright (C) 2020 Massachusetts Institute of Technology
+ ;; This is free software; see the source for copying conditions. There is NO warranty; not even for
+ ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+ ;;
+ ;; Image saved on Sunday March 7, 2021 at 3:24:56 PM
+ ;; Release 11.2 || SF || LIAR/x86-64
+ ;;
+ ;; 1 ]=> false
+ ;;
+ ;; ;Value: #f
+ ;;
+ ;; 1 ]=> true
+ ;;
+ ;; ;Value: #t
+ ;;
+ ;; 1 ]=>
+ ;; ```
+ (define false #f)
+ (define true #t)
+
+ (define (make-environment vars vals)
+ "A comfort procedure because calling extend on the-empty-environment is a PITA."
+ (extend-environment vars
+ vals
+ the-empty-environment))
+
+ ;; XXX: As described in chapter 4.1.4 note 2, we need to name the
+ ;; host `apply`, and the guest `apply` differently. I define the
+ ;; host's `apply` to be the name used in the book.
+ (define apply-in-underlying-scheme scheme:base:apply)
+
+;;; Start:
+
+;;; 4.1.1
+
+ (define *form-table* '())
+
+ (define (add-form-handler! form? handler)
+ (set! *form-table*
+ (cons (cons form?
+ handler)
+ *form-table*)))
+
+ (define (get-form-handler exp)
+ (let loop ((table *form-table*))
+ (match table
+ ('()
+ (error "Unknown form" exp))
+ (`((,form? . ,handler) . ,rest)
+ (if (form? exp)
+ handler
+ (loop rest))))))
+
+ (define (eval exp env)
+ (cond ((self-evaluating? exp)
+ exp)
+ ((variable? exp)
+ (lookup-variable-value exp env))
+ ((pair? exp)
+ ((get-form-handler exp) exp env))
+ (else
+ (error "Unknown expression type -- EVAL" exp))))
+
+ (define (apply procedure arguments)
+ (cond ((primitive-procedure? procedure)
+ (apply-primitive-procedure
+ procedure
+ arguments))
+ ((compound-procedure? procedure)
+ (eval-sequence
+ (procedure-body procedure)
+ (extend-environment
+ (procedure-parameters
+ procedure)
+ arguments
+ (procedure-environment
+ procedure))))
+ (else
+ (error "Unknown procedure type -- APPLY"
+ procedure))))
+
+;;; Procedure arguments:
+
+ (define (list-of-values exps env)
+ (if (no-operands? exps)
+ '()
+ (cons (eval (first-operand exps) env)
+ (list-of-values (rest-operands exps) env))))
+
+;;; Conditionals:
+
+ (define (eval-if exp env)
+ (if (true? (eval (if-predicate exp) env))
+ (eval (if-consequent exp) env)
+ (eval (if-alternative exp) env)))
+
+;;; Sequences:
+
+ (define (eval-sequence exps env)
+ (cond ((last-exp? exps)
+ (eval (first-exp exps) env))
+ (else
+ (eval (first-exp exps) env)
+ (eval-sequence (rest-exps exps)
+ env))))
+
+;;; Assignments and definitions
+
+ (define (eval-assignment exp env)
+ (set-variable-value!
+ (assignment-variable exp)
+ (eval (assignment-value exp) env)
+ env)
+ 'ok)
+
+ (define (eval-definition exp env)
+ (define-variable!
+ (definition-variable exp)
+ (eval (definition-value exp) env)
+ env)
+ 'ok)
+
+;;; end 4.1.1
+
+;;; 4.1.2
+
+
+ (define (self-evaluating? exp)
+ (cond ((number? exp) true)
+ ((string? exp) true)
+ (else false)))
+
+ (define (variable? exp) (symbol? exp))
+
+ (define (quoted? exp)
+ (tagged-list? exp 'quote))
+
+ (define (text-of-quotation exp)
+ (cadr exp))
+
+ (define (tagged-list? exp tag)
+ (if (pair? exp)
+ (eq? (car exp) tag)
+ false))
+
+ (define (assignment? exp)
+ (tagged-list? exp 'set!))
+
+ (define (assignment-variable exp)
+ (cadr exp))
+
+ (define (assignment-value exp) (caddr exp))
+
+ (define (definition? exp)
+ (tagged-list? exp 'define))
+
+ (define (definition-variable exp)
+ (if (symbol? (cadr exp))
+ (cadr exp)
+ (caadr exp)))
+
+ (define (definition-value exp)
+ (if (symbol? (cadr exp))
+ (caddr exp)
+ (make-lambda
+ (cdadr exp) ; formal-parameters
+ (cddr exp)))) ; body
+
+ (define (lambda? exp)
+ (tagged-list? exp 'lambda))
+ (define (lambda-parameters exp) (cadr exp))
+ (define (lambda-body exp) (cddr exp))
+
+ (define (make-lambda parameters body)
+ (cons 'lambda (cons parameters body)))
+
+ (define (if? exp) (tagged-list? exp 'if))
+ (define (if-predicate exp) (cadr exp))
+ (define (if-consequent exp) (caddr exp))
+ (define (if-alternative exp)
+ (if (not (null? (cdddr exp)))
+ (cadddr exp)
+ 'false))
+
+ (define (make-if predicate
+ consequent
+ alternative)
+ (list 'if
+ predicate
+ consequent
+ alternative))
+
+ (define (begin? exp)
+ (tagged-list? exp 'begin))
+ (define (begin-actions exp) (cdr exp))
+ (define (last-exp? seq) (null? (cdr seq)))
+ (define (first-exp seq) (car seq))
+ (define (rest-exps seq) (cdr seq))
+
+ (define (sequence->exp seq)
+ (cond ((null? seq) seq)
+ ((last-exp? seq) (first-exp seq))
+ (else (make-begin seq))))
+
+ (define (make-begin seq) (cons 'begin seq))
+
+ (define (application? exp) (pair? exp))
+ (define (operator exp) (car exp))
+ (define (operands exp) (cdr exp))
+ (define (no-operands? ops) (null? ops))
+ (define (first-operand ops) (car ops))
+ (define (rest-operands ops) (cdr ops))
+
+ (define (cond? exp)
+ (tagged-list? exp 'cond))
+ (define (cond-clauses exp) (cdr exp))
+ (define (cond-else-clause? clause)
+ (eq? (cond-predicate clause) 'else))
+ (define (cond-predicate clause)
+ (car clause))
+ (define (cond-actions clause)
+ (cdr clause))
+ (define (cond->if exp)
+ (expand-clauses (cond-clauses exp)))
+ (define (expand-clauses clauses)
+ (match clauses
+ ('() 'false)
+ ((('else actions ...))
+ (sequence->exp actions))
+ ((('else actions ...) rest ...)
+ (error "ELSE clause isn't last: COND->IF"
+ clauses))
+ (((predicate '=> recipient) rest ...)
+ `((lambda (value)
+ (if value
+ (,recipient value)
+ ,(expand-clauses rest)))
+ ,predicate))
+ (((predicate actions ...) rest ...)
+ (make-if predicate
+ (sequence->exp actions)
+ (expand-clauses rest)))
+ (otherwise
+ (error "-- EXPAND-CLAUSES" clauses))))
+
+;;; end 4.1.2
+
+;;; 4.1.3
+
+ ;; XXX: By default, false's value is #f, which is the only true
+ ;; false. All others are fake and would have the truthitousness
+ ;; property. Consult `info r7rs-small` or `C-h
+ (define (true? x)
+ (not (eq? x false)))
+
+ (define (false? x)
+ (eq? x false))
+
+ (define (make-procedure parameters body env)
+ (list 'procedure parameters body env))
+ (define (compound-procedure? p)
+ (tagged-list? p 'procedure))
+ (define (procedure-parameters p) (cadr p))
+ (define (procedure-body p) (caddr p))
+ (define (procedure-environment p) (cadddr p))
+
+ (define (enclosing-environment env) (cdr env))
+ (define (first-frame env) (car env))
+ (define the-empty-environment '())
+
+ (define (make-frame variables values)
+ (cons variables values))
+ (define (frame-variables frame) (car frame))
+ (define (frame-values frame) (cdr frame))
+ (define (add-binding-to-frame! var val frame)
+ (set-car! frame (cons var (car frame)))
+ (set-cdr! frame (cons val (cdr frame))))
+
+ (define (extend-environment vars vals base-env)
+ (if (= (length vars) (length vals))
+ (cons (make-frame vars vals) base-env)
+ (if (< (length vars) (length vals))
+ (error "Too many arguments supplied"
+ vars
+ vals)
+ (error "Too few arguments supplied"
+ vars
+ vals))))
+
+ (define (lookup-variable-value var env)
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop
+ (enclosing-environment env)))
+ ((eq? var (car vars))
+ (car vals))
+ (else (scan (cdr vars)
+ (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- LOOKUP-VARIABLE-VALUE" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+
+ (define (set-variable-value! var val env)
+ ;; XXX: Just trying to see what it would look like if I just used named lets.
+ ;;
+ ;; (let loop-over-environments ((env env))
+ ;; (cond
+ ;; ((eq? env the-empty-enviornment)
+ ;; (error "Unbound variable: SET!" var))
+ ;; (else
+ ;; (let ((frame (first-frame env)))
+ ;; (let loop-over-frame ((vars (frame-variables frame))
+ ;; (vals (frame-values frame)))
+ ;; (cond
+ ;; ((null? vars)
+ ;; (loop-over-environments (enclosing-environment env)))
+ ;; ((eq? var (car vars))
+ ;; (set-car! vals val))
+ ;; (else
+ ;; (loop-over-frame ((cdr vars)
+ ;; (cdr vals))))))))))
+
+ (define (env-loop env)
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (env-loop
+ (enclosing-environment env)))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars)
+ (cdr vals)))))
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable: SET!" var)
+ (let ((frame (first-frame env)))
+ (scan (frame-variables frame)
+ (frame-values frame)))))
+ (env-loop env))
+
+ (define (define-variable! var val env)
+ "Add a new variable VAR with value VAL in the top frame of environment ENV.
+
+If variable VAR already exists in the top frame, set VAR in the top
+frame to VAL."
+
+ ;; We will CHANGE (why did I all uppercase "CHANGE" here? I
+ ;; don't remember. Maybe it is some sort of a joke?) only
+ ;; the first frame.
+ (let ((frame (first-frame env)))
+ (define (scan vars vals)
+ (cond ((null? vars)
+ (add-binding-to-frame!
+ var val frame))
+ ((eq? var (car vars))
+ (set-car! vals val))
+ (else (scan (cdr vars)
+ (cdr vals)))))
+ (scan (frame-variables frame)
+ (frame-values frame))))
+
+;;; 4.1.4
+
+ (define (setup-environment)
+ (dpp 'moo)
+ (let* (;; XXX: See bug below on the quoted (define
+ ;; primitive-procedures ...)
+ (primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '+ +)
+ (list '- -)
+ (list '* *)
+ (list '/ /)
+ (list '= =)
+ (list 'display display)
+ (list 'write write)
+ (list 'read read)))
+ (initial-env
+ (extend-environment
+ (primitive-procedure-names primitive-procedures)
+ (primitive-procedure-objects primitive-procedures)
+ the-empty-environment)))
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ initial-env))
+
+ (define the-global-environment
+ (begin
+ (dpp 'moo)
+ (setup-environment)))
+
+ (define (primitive-procedure? proc)
+ (tagged-list? proc 'primitive))
+
+ (define (primitive-implementation proc)
+ (cadr proc))
+
+ ;; XXX: There is a bug here in SICP or GNU Guile or both.
+ ;; primitive-procedures is `#<unspecified>` when this library is
+ ;; being loaded.
+ '(define primitive-procedures
+ (list (list 'car car)
+ (list 'cdr cdr)
+ (list 'cons cons)
+ (list 'null? null?)
+ (list '+ +)
+ (list '- -)
+ (list '* *)
+ (list '/ /)
+ (list 'display display)
+ (list 'write write)
+ (list 'read read)))
+
+ (define (primitive-procedure-names primitive-procedures)
+ (map car
+ primitive-procedures))
+
+ (define (primitive-procedure-objects primitive-procedures)
+ (map (lambda (proc)
+ (list 'primitive (cadr proc)))
+ primitive-procedures))
+
+ (define (apply-primitive-procedure proc args)
+ (apply-in-underlying-scheme
+ (primitive-implementation proc) args))
+
+ (define input-prompt ";;; M-Eval input:")
+ (define output-prompt ";;; M-Eval value:")
+
+ (define (driver-loop)
+ (prompt-for-input input-prompt)
+ (let ((input (read)))
+ (let ((output
+ (eval input
+ the-global-environment)))
+ (announce-output output-prompt)
+ (user-print output)))
+ (driver-loop))
+
+ (define (prompt-for-input string)
+ (newline) (newline)
+ (display string) (newline))
+
+ (define (announce-output string)
+ (newline) (display string) (newline))
+
+ (define (user-print object)
+ (if (compound-procedure? object)
+ (display
+ (list 'compound-procedure
+ (procedure-parameters object)
+ (procedure-body object)
+ '<procedure-env>))
+ (display object)))
+
+ ;; XXX: Already defined above:
+ ;; (define the-global-environment
+ ;; (setup-environment))
+
+ (define (main args)
+ (match args
+ ('()
+ (error "Arguments should have something rather than nothing."))
+ (`(,arg0)
+ (display arg0)
+ (newline))
+ (`(,arg0 "--debug")
+ (display "DEBUG TURN ON!\n")
+ (set! *debug* #t))
+ (args (error "Unknown arguments:" args)))
+
+ (driver-loop))
+
+ (define (run-internal-tests)
+ (test-eq 1
+ (lookup-variable-value 'a
+ (extend-environment '(a +)
+ `(1 ,+)
+ the-empty-environment)))
+ (test-eq 1
+ (lookup-variable-value 'a
+ (extend-environment '(+ a)
+ `(,+ 1)
+ the-empty-environment)))
+ (test-eq +
+ (lookup-variable-value '+
+ (extend-environment '(a +)
+ `(1 ,+)
+ the-empty-environment))))
+
+ (add-form-handler! application?
+ (lambda (exp env)
+ (apply (eval (operator exp) env)
+ (list-of-values
+ (operands exp)
+ env))))
+ (add-form-handler! (lambda (exp)
+ (tagged-list? exp 'or))
+ (lambda (exp env)
+ (eval (let loop ((seq (cdr exp)))
+ (match seq
+ ('() 'false)
+ ((expression . rest)
+ (list (list 'lambda (list 'value)
+ (list 'if
+ 'value
+ 'value
+ (loop rest)))
+ expression))
+ (otherwise
+ (error "Weird expression -- AND"
+ otherwise))))
+ env)))
+ (add-form-handler! (lambda (exp)
+ (tagged-list? exp 'and))
+ (lambda (exp env)
+ (eval (let loop ((seq (cdr exp)))
+ (match seq
+ ('() 'false)
+ ((expression)
+ `((lambda (value)
+ (if value
+ value
+ false))
+ ,expression)
+ )
+ ((expression . rest)
+ `((lambda (value)
+ (if value
+ ,(loop rest)
+ false))
+ ,expression))
+ (otherwise
+ (error "Weird expression -- AND"
+ otherwise))))
+ env)))
+ (add-form-handler! cond?
+ (lambda (exp env)
+ (eval (cond->if exp) env)))
+ (add-form-handler! begin?
+ (lambda (exp env)
+ (eval-sequence
+ (begin-actions exp)
+ env)))
+ (add-form-handler! lambda?
+ (lambda (exp env)
+ (make-procedure (lambda-parameters exp)
+ (lambda-body exp)
+ env)))
+ (add-form-handler! if? eval-if)
+ (add-form-handler! definition? eval-definition)
+ (add-form-handler! assignment? eval-assignment)
+ (add-form-handler! quoted? (lambda (exp env) (text-of-quotation exp)))
+ (add-form-handler! (lambda (exp) (tagged-list? exp 'let))
+ (lambda (exp env)
+ (match exp
+ (('let (var-exps ...)
+ body ...)
+ (let ((vars (map car var-exps))
+ (exps (map cadr var-exps)))
+ (eval `((lambda ,vars
+ ,@body)
+ ,@exps)
+ env))))))
+
+ ))
diff --git a/sicp/tests/chapter-4/exercise-5.scm b/sicp/tests/chapter-4/exercise-5.scm
@@ -20,9 +20,10 @@
(setup-environment)))
(test-equal 2
- (eval '(cond
- (false 1)
- (else 2))
+ (eval '(+ (cond
+ (false 1)
+ (else (+ -4 6)))
+ 0)
(setup-environment)))
(test-equal 5
diff --git a/sicp/tests/chapter-4/exercise-6.scm b/sicp/tests/chapter-4/exercise-6.scm
@@ -0,0 +1,38 @@
+(define-library (sicp tests chapter-4 exercise-6)
+ (import (scheme base)
+
+ (srfi :64)
+
+ (sicp solutions chapter-4 exercise-6))
+
+ (begin
+ (test-begin "chapter-4-exercise-6")
+
+ (test-equal 1
+ (eval '(cond
+ (else 1))
+ (setup-environment)))
+
+ (test-equal 1
+ (eval '(cond
+ (true 1)
+ (else 2))
+ (setup-environment)))
+
+ (test-equal 2
+ (eval '(cond
+ (false 1)
+ (else 2))
+ (setup-environment)))
+
+ (test-equal 5
+ (eval '(cond
+ (false 1)
+ ((+ 2 3) => (lambda (x)
+ (let ((y -6)
+ (z 6))
+ (+ x y z))))
+ (else 2))
+ (setup-environment)))
+
+ (test-end "chapter-4-exercise-6")))
