learning-sicp

My embarrassing half assed SICP run.
git clone https://kaka.farm/~git/learning-sicp
Log | Files | Refs

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:
Asicp/solutions/chapter-4/exercise-6.scm | 618+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Msicp/tests/chapter-4/exercise-5.scm | 7++++---
Asicp/tests/chapter-4/exercise-6.scm | 38++++++++++++++++++++++++++++++++++++++
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")))