learning-sicp

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

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:
Asicp/solutions/chapter-4/exercise-16.scm | 701+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Asicp/tests/chapter-4/exercise-16.scm | 115+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
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") + ))