commit 676d9c5dea12e28491a59bc70ed5f0cc85fc6dc0
parent de7c5637fe29f4e518258215546adc1a9f8bd83a
Author: Yuval Langer <yuval.langer@gmail.com>
Date: Wed, 7 Aug 2024 15:43:21 +0300
Copy solution of exercise 4.14 as template for solution of exercise 4.16.
Diffstat:
2 files changed, 816 insertions(+), 0 deletions(-)
diff --git a/sicp/solutions/chapter-4/exercise-16.scm b/sicp/solutions/chapter-4/exercise-16.scm
@@ -0,0 +1,701 @@
+(define-library (sicp solutions chapter-4 exercise-14)
+ (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)
+ (dp exp)
+ (dp env)
+ (let ((value (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)))))
+ (dp `(eval value: ,value))
+ value))
+
+ (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))))
+
+ (define (let->combination exp)
+ (match exp
+ (('let (var-exps ...)
+ body ...)
+ (let ((vars (map car var-exps))
+ (exps (map cadr var-exps)))
+ `((lambda ,vars
+ ,@body)
+ ,@exps)))
+ (('let name (var-exps ...)
+ body ...)
+ (let ((vars (map car var-exps))
+ (exps (map cadr var-exps)))
+ `(let ((,name '()))
+ (set! ,name
+ (lambda ,vars
+ ,@body))
+ (,name ,@exps))))))
+
+ (define (let*->nested-lets exp)
+ (match exp
+ (('let* ()
+ body ...)
+ (make-begin body))
+ (`(let* ((,var ,exp) . ,rest-of-var-exps)
+ . ,body)
+ `(let ((,var ,exp))
+ ,(let*->nested-lets
+ `(let* ,rest-of-var-exps
+ ,@body))))))
+
+;;; 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)
+ (let loop ((variables variables)
+ (values values)
+ (frame '(frame)))
+ (match (list variables values)
+ ('(() ()) (reverse frame))
+ (((variable rest-of-variables ...) (value rest-of-values ...))
+ (loop rest-of-variables
+ rest-of-values
+ (alist-cons variable
+ value
+ frame))))))
+ (define (frame-variables frame) (map car (cdr frame)))
+ (define (frame-values frame) (map cdr (cdr frame)))
+ (define (add-binding-to-frame! var val frame)
+ (set-cdr! frame (alist-cons var
+ val
+ (cdr frame))))
+ (define (get-frame-variable-value var frame)
+ (assoc var (cdr frame) eq?))
+ (define (set-frame-variable-value! var val frame)
+ (match (get-frame-variable-value var frame)
+ (#f
+ (set-cdr! frame
+ (alist-cons var
+ val
+ (cdr frame))))
+ (pair
+ (set-cdr! pair
+ val))))
+
+ (define (extend-environment vars vals base-env)
+ (dp vars)
+ (dp vals)
+ (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)
+ (dp `(,var ,env))
+ (define (env-loop env)
+ (if (eq? env the-empty-environment)
+ (error "Unbound variable -- LOOKUP-VARIABLE-VALUE" var)
+ (let ((frame (first-frame env)))
+ (match (get-frame-variable-value var
+ frame)
+ (#f
+ (env-loop (enclosing-environment env)))
+ ((existing-var . existing-val)
+ existing-val)))))
+ (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))))))))))
+
+ (dp `(before set-variable-value! ,var ,val ,env))
+ (let env-loop ((env env))
+ (cond
+ ((eq? env the-empty-environment)
+ (error "Unbound variable: SET!" var))
+ (else
+ (let ((frame (first-frame env)))
+ (match (get-frame-variable-value var frame)
+ (#f
+ (env-loop (enclosing-environment env)))
+ (pair
+ (set-cdr! pair val)))))))
+ (dp `(after set-variable-value! ,var ,val ,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)))
+ (match (get-frame-variable-value var frame)
+ (#f
+ (add-binding-to-frame! var
+ val
+ frame))
+ (pair
+ (set-cdr! pair
+ val)))))
+
+ (define (make-unbound! var env)
+ (cond
+ ((eq? env
+ the-empty-environment)
+ #f)
+ (else
+ (let ((frame (first-frame env)))
+ (let loop ((frame-alist (cdr frame))
+ (new-frame '(frame))
+ (hit #f))
+ (cond
+ ((null? frame-alist)
+ (cond
+ (hit hit)
+ (else (make-unbound! var
+ (enclosing-environment env)))))
+ ((eq? (car frame-alist)
+ var)
+ (loop (cdr frame-alist)
+ new-frame
+ #t))
+ (else
+ (loop (cdr frame-alist)
+ (cons (car frame-alist)
+ new-frame)
+ hit))))))))
+
+;;; 4.1.4
+
+ (define (setup-environment)
+ (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)
+ (list 'list list)))
+ (initial-env
+ (extend-environment
+ (primitive-procedure-names primitive-procedures)
+ (primitive-procedure-objects primitive-procedures)
+ the-empty-environment)))
+ (dp initial-env)
+ (define-variable! 'true true initial-env)
+ (define-variable! 'false false initial-env)
+ (dp initial-env)
+ initial-env))
+
+ (define the-global-environment
+ (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)
+ (list '*debug* *debug* )))
+
+ (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)
+ (eval (let->combination exp) env)))
+ (add-form-handler! (lambda (exp) (tagged-list? exp 'let*))
+ (lambda (exp env)
+ (eval (let*->nested-lets exp) env)))
+ (add-form-handler! (lambda (exp) (tagged-list? exp 'map-form))
+ (lambda (exp env)
+ (let* ((f (eval (cadr exp) env))
+ (our-list (eval (caddr exp) env))
+ (_ (dp our-list))
+ (result (map (lambda (x)
+ (apply f (list x)))
+ our-list)))
+ result)))))
diff --git a/sicp/tests/chapter-4/exercise-16.scm b/sicp/tests/chapter-4/exercise-16.scm
@@ -0,0 +1,115 @@
+(define-library (sicp tests chapter-4 exercise-14)
+ (import (scheme base)
+
+ (srfi :64)
+
+ (sicp solutions chapter-4 exercise-14)
+
+ (sicp utils))
+
+ (begin
+ ;; (debug! #t)
+
+ ;; TODO: Not sure if this is the real solution.
+
+ (test-begin "chapter-4-exercise-14")
+
+ (test-equal 1
+ (eval '(begin
+ (define (map f l)
+ (cond
+ ((null? l)
+ '())
+ (else
+ (cons (f (car l))
+ (map f (cdr l))))))
+ (car (map (lambda (x) (+ x 1))
+ '(0 1 2))))
+ (setup-environment)))
+
+ (test-equal -1
+ (eval '(begin
+ (define (map f l)
+ (cond
+ ((null? l)
+ '())
+ (else
+ (cons (f (car l))
+ (map f (cdr l))))))
+ (car (map (lambda (x) (- x 1))
+ '(0 1 2))))
+ (setup-environment)))
+
+ (test-equal '(2 3)
+ (eval '(begin
+ (define (map f l)
+ (cond
+ ((null? l)
+ '())
+ (else
+ (cons (f (car l))
+ (map f (cdr l))))))
+ (cdr (map (lambda (x) (+ x 1))
+ '(0 1 2))))
+ (setup-environment)))
+
+ (test-equal '()
+ (eval '(map-form (lambda (x) (+ x 2)) '())
+ (setup-environment)))
+
+ (test-equal '(3 4 5)
+ (eval '(map-form (lambda (x) (+ x 2)) (list 1 2 3))
+ (setup-environment)))
+
+ (test-equal '(3 4 5)
+ (eval '(let ((l (list 1 2 3)))
+ (map-form (lambda (x) (+ x 2)) l))
+ (setup-environment)))
+
+ (test-equal 1
+ (eval '1
+ (setup-environment)))
+
+ (test-equal 1
+ (eval '(begin
+ (define a 1)
+ 1)
+ (setup-environment)))
+
+ (test-equal 1
+ (eval '(begin
+ (define a 1)
+ (let ((b 1))
+ b))
+ (setup-environment)))
+
+ (test-equal 1
+ (eval '(begin
+ (define a 1)
+ (let* ((b 1))
+ b))
+ (setup-environment)))
+
+ (test-equal 2
+ (eval '(begin
+ (define a 1)
+ (+ a 1))
+ (setup-environment)))
+
+ (test-equal 3
+ (eval '(begin
+ (define a 1)
+ (let ((b (+ a 1)))
+ (+ a b)))
+ (setup-environment)))
+
+ (test-equal 5
+ (eval '(begin
+ (define a 1) ;; a = 1
+ (let ((b (+ a 1))) ;; b = 1 + 1 = 2
+ (set! b (+ b b)) ;; b = b + b = 2 + 2 = 4
+ (+ a b))) ;; a = a + b = 1 + 4 = 5
+ (setup-environment)))
+
+ (test-end "chapter-4-exercise-14")
+ ))
