learning-sicp

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

exercise-14.scm (23021B)


      1 (define-library (sicp solutions chapter-4 exercise-14)
      2   (export
      3    eval
      4    main
      5 
      6    run-internal-tests
      7 
      8    make-environment
      9    setup-environment
     10    extend-environment
     11    )
     12   (import
     13    (rename (scheme base) (apply scheme:base:apply))
     14    (scheme cxr)
     15    (scheme read)
     16    (scheme write)
     17 
     18    (srfi srfi-1)
     19    (srfi srfi-9)
     20    (srfi srfi-64)
     21 
     22    (system vm trace)
     23 
     24    (ice-9 match)
     25    (ice-9 pretty-print)
     26 
     27    (sicp utils)
     28    )
     29 
     30   (begin
     31     ;; XXX: In 4.1.3 we see that the procedure `true?` is defined
     32     ;; using the host-variable `false` whose value is 'false, but we
     33     ;; don't see it defined anywhere in the good book, so we need to
     34     ;; define the host-variable false ourselves.
     35     ;;
     36     ;; In MIT Scheme, the one the SICP people seem to love to use for
     37     ;; SICP, the values of `false` and `true` are #f and #t, #f being
     38     ;; the only value that is falsituous and #t there for having a
     39     ;; truthious value that has no other meaning other than being
     40     ;; truthitiousic.
     41     ;;
     42     ;; ```
     43     ;; # `scheme` is the MIT Scheme executable:
     44     ;; $ guix shell mit-scheme -- scheme
     45     ;; MIT/GNU Scheme running under GNU/Linux
     46     ;; Type `^C' (control-C) followed by `H' to obtain information about interrupts.
     47     ;;
     48     ;; Copyright (C) 2020 Massachusetts Institute of Technology
     49     ;; This is free software; see the source for copying conditions. There is NO warranty; not even for
     50     ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
     51     ;;
     52     ;; Image saved on Sunday March 7, 2021 at 3:24:56 PM
     53     ;;   Release 11.2 || SF || LIAR/x86-64
     54     ;;
     55     ;; 1 ]=> false
     56     ;;
     57     ;; ;Value: #f
     58     ;;
     59     ;; 1 ]=> true
     60     ;;
     61     ;; ;Value: #t
     62     ;;
     63     ;; 1 ]=>
     64     ;; ```
     65     (define false #f)
     66     (define true #t)
     67 
     68     (define (make-environment vars vals)
     69       "A comfort procedure because calling extend on the-empty-environment is a PITA."
     70       (extend-environment vars
     71                           vals
     72                           the-empty-environment))
     73 
     74     ;; XXX: As described in chapter 4.1.4 note 2, we need to name the
     75     ;; host `apply`, and the guest `apply` differently.  I define the
     76     ;; host's `apply` to be the name used in the book.
     77     (define apply-in-underlying-scheme scheme:base:apply)
     78 
     79 ;;; Start:
     80 
     81 ;;; 4.1.1
     82 
     83     (define *form-table* '())
     84 
     85     (define (add-form-handler! form? handler)
     86       (set! *form-table*
     87             (cons (cons form?
     88                         handler)
     89                   *form-table*)))
     90 
     91     (define (get-form-handler exp)
     92       (let loop ((table *form-table*))
     93         (match table
     94           ('()
     95            (error "Unknown form" exp))
     96           (`((,form? . ,handler) . ,rest)
     97            (if (form? exp)
     98                handler
     99                (loop rest))))))
    100 
    101     (define (eval exp env)
    102       (dp exp)
    103       (dp env)
    104       (let ((value (cond ((self-evaluating? exp)
    105                           exp)
    106                          ((variable? exp)
    107                           (lookup-variable-value exp env))
    108                          ((pair? exp)
    109                           ((get-form-handler exp) exp env))
    110                          (else
    111                           (error "Unknown expression type -- EVAL" exp)))))
    112         (dp `(eval value: ,value))
    113         value))
    114 
    115     (define (apply procedure arguments)
    116       (cond ((primitive-procedure? procedure)
    117              (apply-primitive-procedure
    118               procedure
    119               arguments))
    120             ((compound-procedure? procedure)
    121              (eval-sequence
    122               (procedure-body procedure)
    123               (extend-environment
    124                (procedure-parameters
    125                 procedure)
    126                arguments
    127                (procedure-environment
    128                 procedure))))
    129             (else
    130              (error "Unknown procedure type -- APPLY"
    131                     procedure))))
    132 
    133 ;;; Procedure arguments:
    134 
    135     (define (list-of-values exps env)
    136       (if (no-operands? exps)
    137           '()
    138           (cons (eval (first-operand exps) env)
    139                 (list-of-values (rest-operands exps) env))))
    140 
    141 ;;; Conditionals:
    142 
    143     (define (eval-if exp env)
    144       (if (true? (eval (if-predicate exp) env))
    145           (eval (if-consequent exp) env)
    146           (eval (if-alternative exp) env)))
    147 
    148 ;;; Sequences:
    149 
    150     (define (eval-sequence exps env)
    151       (cond ((last-exp? exps)
    152              (eval (first-exp exps) env))
    153             (else
    154              (eval (first-exp exps) env)
    155              (eval-sequence (rest-exps exps)
    156                             env))))
    157 
    158 ;;; Assignments and definitions
    159 
    160     (define (eval-assignment exp env)
    161       (set-variable-value!
    162        (assignment-variable exp)
    163        (eval (assignment-value exp) env)
    164        env)
    165       'ok)
    166 
    167     (define (eval-definition exp env)
    168       (define-variable!
    169         (definition-variable exp)
    170         (eval (definition-value exp) env)
    171         env)
    172       'ok)
    173 
    174 ;;; end 4.1.1
    175 
    176 ;;; 4.1.2
    177 
    178 
    179     (define (self-evaluating? exp)
    180       (cond ((number? exp) true)
    181             ((string? exp) true)
    182             (else false)))
    183 
    184     (define (variable? exp) (symbol? exp))
    185 
    186     (define (quoted? exp)
    187       (tagged-list? exp 'quote))
    188 
    189     (define (text-of-quotation exp)
    190       (cadr exp))
    191 
    192     (define (tagged-list? exp tag)
    193       (if (pair? exp)
    194           (eq? (car exp) tag)
    195           false))
    196 
    197     (define (assignment? exp)
    198       (tagged-list? exp 'set!))
    199 
    200     (define (assignment-variable exp)
    201       (cadr exp))
    202 
    203     (define (assignment-value exp) (caddr exp))
    204 
    205     (define (definition? exp)
    206       (tagged-list? exp 'define))
    207 
    208     (define (definition-variable exp)
    209       (if (symbol? (cadr exp))
    210           (cadr exp)
    211           (caadr exp)))
    212 
    213     (define (definition-value exp)
    214       (if (symbol? (cadr exp))
    215           (caddr exp)
    216           (make-lambda
    217            (cdadr exp)   ; formal-parameters
    218            (cddr exp)))) ; body
    219 
    220     (define (lambda? exp)
    221       (tagged-list? exp 'lambda))
    222     (define (lambda-parameters exp) (cadr exp))
    223     (define (lambda-body exp) (cddr exp))
    224 
    225     (define (make-lambda parameters body)
    226       (cons 'lambda (cons parameters body)))
    227 
    228     (define (if? exp) (tagged-list? exp 'if))
    229     (define (if-predicate exp) (cadr exp))
    230     (define (if-consequent exp) (caddr exp))
    231     (define (if-alternative exp)
    232       (if (not (null? (cdddr exp)))
    233           (cadddr exp)
    234           'false))
    235 
    236     (define (make-if predicate
    237                      consequent
    238                      alternative)
    239       (list 'if
    240             predicate
    241             consequent
    242             alternative))
    243 
    244     (define (begin? exp)
    245       (tagged-list? exp 'begin))
    246     (define (begin-actions exp) (cdr exp))
    247     (define (last-exp? seq) (null? (cdr seq)))
    248     (define (first-exp seq) (car seq))
    249     (define (rest-exps seq) (cdr seq))
    250 
    251     (define (sequence->exp seq)
    252       (cond ((null? seq) seq)
    253             ((last-exp? seq) (first-exp seq))
    254             (else (make-begin seq))))
    255 
    256     (define (make-begin seq) (cons 'begin seq))
    257 
    258     (define (application? exp) (pair? exp))
    259     (define (operator exp) (car exp))
    260     (define (operands exp) (cdr exp))
    261     (define (no-operands? ops) (null? ops))
    262     (define (first-operand ops) (car ops))
    263     (define (rest-operands ops) (cdr ops))
    264 
    265     (define (cond? exp)
    266       (tagged-list? exp 'cond))
    267     (define (cond-clauses exp) (cdr exp))
    268     (define (cond-else-clause? clause)
    269       (eq? (cond-predicate clause) 'else))
    270     (define (cond-predicate clause)
    271       (car clause))
    272     (define (cond-actions clause)
    273       (cdr clause))
    274     (define (cond->if exp)
    275       (expand-clauses (cond-clauses exp)))
    276     (define (expand-clauses clauses)
    277       (match clauses
    278         ('() 'false)
    279         ((('else actions ...))
    280          (sequence->exp actions))
    281         ((('else actions ...) rest ...)
    282          (error "ELSE clause isn't last: COND->IF"
    283                 clauses))
    284         (((predicate '=> recipient) rest ...)
    285          `((lambda (value)
    286              (if value
    287                  (,recipient value)
    288                  ,(expand-clauses rest)))
    289            ,predicate))
    290         (((predicate actions ...) rest ...)
    291          (make-if predicate
    292                   (sequence->exp actions)
    293                   (expand-clauses rest)))
    294         (otherwise
    295          (error "-- EXPAND-CLAUSES" clauses))))
    296 
    297     (define (let->combination exp)
    298       (match exp
    299         (('let (var-exps ...)
    300            body ...)
    301          (let ((vars (map car var-exps))
    302                (exps (map cadr var-exps)))
    303            `((lambda ,vars
    304                ,@body)
    305              ,@exps)))
    306         (('let name (var-exps ...)
    307            body ...)
    308          (let ((vars (map car var-exps))
    309                (exps (map cadr var-exps)))
    310            `(let ((,name '()))
    311               (set! ,name
    312                     (lambda ,vars
    313                       ,@body))
    314               (,name ,@exps))))))
    315 
    316     (define (let*->nested-lets exp)
    317       (match exp
    318         (('let* ()
    319            body ...)
    320          (make-begin body))
    321         (`(let* ((,var ,exp) . ,rest-of-var-exps)
    322             . ,body)
    323          `(let ((,var ,exp))
    324             ,(let*->nested-lets
    325               `(let* ,rest-of-var-exps
    326                  ,@body))))))
    327 
    328 ;;; end 4.1.2
    329 
    330 ;;; 4.1.3
    331 
    332     ;; XXX: By default, false's value is #f, which is the only true
    333     ;; false.  All others are fake and would have the truthitousness
    334     ;; property.  Consult `info r7rs-small` or `C-h
    335     (define (true? x)
    336       (not (eq? x false)))
    337 
    338     (define (false? x)
    339       (eq? x false))
    340 
    341     (define (make-procedure parameters body env)
    342       (list 'procedure parameters body env))
    343     (define (compound-procedure? p)
    344       (tagged-list? p 'procedure))
    345     (define (procedure-parameters p) (cadr p))
    346     (define (procedure-body p) (caddr p))
    347     (define (procedure-environment p) (cadddr p))
    348 
    349     (define (enclosing-environment env) (cdr env))
    350     (define (first-frame env) (car env))
    351     (define the-empty-environment '())
    352 
    353     (define (make-frame variables values)
    354       (let loop ((variables variables)
    355                  (values values)
    356                  (frame '(frame)))
    357         (match (list variables values)
    358           ('(() ()) (reverse frame))
    359           (((variable rest-of-variables ...) (value rest-of-values ...))
    360            (loop rest-of-variables
    361                  rest-of-values
    362                  (alist-cons variable
    363                              value
    364                              frame))))))
    365     (define (frame-variables frame) (map car (cdr frame)))
    366     (define (frame-values frame) (map cdr (cdr frame)))
    367     (define (add-binding-to-frame! var val frame)
    368       (set-cdr! frame (alist-cons var
    369                                   val
    370                                   (cdr frame))))
    371     (define (get-frame-variable-value var frame)
    372       (assoc var (cdr frame) eq?))
    373     (define (set-frame-variable-value! var val frame)
    374       (match (get-frame-variable-value var frame)
    375         (#f
    376          (set-cdr! frame
    377                    (alist-cons var
    378                                val
    379                                (cdr frame))))
    380         (pair
    381          (set-cdr! pair
    382                    val))))
    383 
    384     (define (extend-environment vars vals base-env)
    385       (dp vars)
    386       (dp vals)
    387       (if (= (length vars) (length vals))
    388           (cons (make-frame vars vals) base-env)
    389           (if (< (length vars) (length vals))
    390               (error "Too many arguments supplied"
    391                      vars
    392                      vals)
    393               (error "Too few arguments supplied"
    394                      vars
    395                      vals))))
    396 
    397     (define (lookup-variable-value var env)
    398       (dp `(,var ,env))
    399       (define (env-loop env)
    400         (if (eq? env the-empty-environment)
    401             (error "Unbound variable -- LOOKUP-VARIABLE-VALUE" var)
    402             (let ((frame (first-frame env)))
    403               (match (get-frame-variable-value var
    404                                                frame)
    405                 (#f
    406                  (env-loop (enclosing-environment env)))
    407                 ((existing-var . existing-val)
    408                  existing-val)))))
    409       (env-loop env))
    410 
    411     (define (set-variable-value! var val env)
    412       ;; XXX: Just trying to see what it would look like if I just used named lets.
    413       ;;
    414       ;; (let loop-over-environments ((env env))
    415       ;;   (cond
    416       ;;    ((eq? env the-empty-enviornment)
    417       ;;     (error "Unbound variable: SET!" var))
    418       ;;    (else
    419       ;;     (let ((frame (first-frame env)))
    420       ;;       (let loop-over-frame ((vars (frame-variables frame))
    421       ;;                             (vals (frame-values frame)))
    422       ;;         (cond
    423       ;;          ((null? vars)
    424       ;;           (loop-over-environments (enclosing-environment env)))
    425       ;;          ((eq? var (car vars))
    426       ;;           (set-car! vals val))
    427       ;;          (else
    428       ;;           (loop-over-frame ((cdr vars)
    429       ;;                             (cdr vals))))))))))
    430 
    431       (dp `(before set-variable-value! ,var ,val ,env))
    432       (let env-loop ((env env))
    433         (cond
    434          ((eq? env the-empty-environment)
    435           (error "Unbound variable: SET!" var))
    436          (else
    437           (let ((frame (first-frame env)))
    438             (match (get-frame-variable-value var frame)
    439               (#f
    440                (env-loop (enclosing-environment env)))
    441               (pair
    442                (set-cdr! pair val)))))))
    443       (dp `(after set-variable-value! ,var ,val ,env)))
    444 
    445     (define (define-variable! var val env)
    446       "Add a new variable VAR with value VAL in the top frame of environment ENV.
    447 
    448 If variable VAR already exists in the top frame, set VAR in the top
    449 frame to VAL."
    450 
    451       ;; We will CHANGE (why did I all uppercase "CHANGE" here?  I
    452       ;; don't remember.  Maybe it is some sort of a joke?) only
    453       ;; the first frame.
    454       (let ((frame (first-frame env)))
    455         (match (get-frame-variable-value var frame)
    456           (#f
    457            (add-binding-to-frame! var
    458                                   val
    459                                   frame))
    460           (pair
    461            (set-cdr! pair
    462                      val)))))
    463 
    464     (define (make-unbound! var env)
    465       (cond
    466        ((eq? env
    467              the-empty-environment)
    468         #f)
    469        (else
    470         (let ((frame (first-frame env)))
    471           (let loop ((frame-alist (cdr frame))
    472                      (new-frame '(frame))
    473                      (hit #f))
    474             (cond
    475              ((null? frame-alist)
    476               (cond
    477                (hit hit)
    478                (else (make-unbound! var
    479                                     (enclosing-environment env)))))
    480              ((eq? (car frame-alist)
    481                    var)
    482               (loop (cdr frame-alist)
    483                     new-frame
    484                     #t))
    485              (else
    486               (loop (cdr frame-alist)
    487                     (cons (car frame-alist)
    488                           new-frame)
    489                     hit))))))))
    490 
    491 ;;; 4.1.4
    492 
    493     (define (setup-environment)
    494       (let* ( ;; XXX: See bug below on the quoted (define
    495              ;; primitive-procedures ...)
    496              (primitive-procedures
    497               (list (list 'car car)
    498                     (list 'cdr cdr)
    499                     (list 'cons cons)
    500                     (list 'null? null?)
    501                     (list '+ +)
    502                     (list '- -)
    503                     (list '* *)
    504                     (list '/ /)
    505                     (list '= =)
    506                     (list 'display display)
    507                     (list 'write write)
    508                     (list 'read read)
    509                     (list 'list list)))
    510              (initial-env
    511               (extend-environment
    512                (primitive-procedure-names primitive-procedures)
    513                (primitive-procedure-objects primitive-procedures)
    514                the-empty-environment)))
    515         (dp initial-env)
    516         (define-variable! 'true true initial-env)
    517         (define-variable! 'false false initial-env)
    518         (dp initial-env)
    519         initial-env))
    520 
    521     (define the-global-environment
    522       (setup-environment))
    523 
    524     (define (primitive-procedure? proc)
    525       (tagged-list? proc 'primitive))
    526 
    527     (define (primitive-implementation proc)
    528       (cadr proc))
    529 
    530     ;; XXX: There is a bug here in SICP or GNU Guile or both.
    531     ;; primitive-procedures is `#<unspecified>` when this library is
    532     ;; being loaded.
    533     '(define primitive-procedures
    534        (list (list 'car car)
    535              (list 'cdr cdr)
    536              (list 'cons cons)
    537              (list 'null? null?)
    538              (list '+ +)
    539              (list '- -)
    540              (list '* *)
    541              (list '/ /)
    542              (list 'display display)
    543              (list 'write write)
    544              (list 'read read)
    545              (list '*debug* *debug* )))
    546 
    547     (define (primitive-procedure-names primitive-procedures)
    548       (map car
    549            primitive-procedures))
    550 
    551     (define (primitive-procedure-objects primitive-procedures)
    552       (map (lambda (proc)
    553              (list 'primitive (cadr proc)))
    554            primitive-procedures))
    555 
    556     (define (apply-primitive-procedure proc args)
    557       (apply-in-underlying-scheme
    558        (primitive-implementation proc) args))
    559 
    560     (define input-prompt  ";;; M-Eval input:")
    561     (define output-prompt ";;; M-Eval value:")
    562 
    563     (define (driver-loop)
    564       (prompt-for-input input-prompt)
    565       (let ((input (read)))
    566         (let ((output
    567                (eval input
    568                      the-global-environment)))
    569           (announce-output output-prompt)
    570           (user-print output)))
    571       (driver-loop))
    572 
    573     (define (prompt-for-input string)
    574       (newline) (newline)
    575       (display string) (newline))
    576 
    577     (define (announce-output string)
    578       (newline) (display string) (newline))
    579 
    580     (define (user-print object)
    581       (if (compound-procedure? object)
    582           (display
    583            (list 'compound-procedure
    584                  (procedure-parameters object)
    585                  (procedure-body object)
    586                  '<procedure-env>))
    587           (display object)))
    588 
    589     ;; XXX: Already defined above:
    590     ;; (define the-global-environment
    591     ;;   (setup-environment))
    592 
    593     (define (main args)
    594       (match args
    595         ('()
    596          (error "Arguments should have something rather than nothing."))
    597         (`(,arg0)
    598          (display arg0)
    599          (newline))
    600         (`(,arg0 "--debug")
    601          (display "DEBUG TURN ON!\n")
    602          (set! *debug* #t))
    603         (args (error "Unknown arguments:" args)))
    604 
    605       (driver-loop))
    606 
    607     (define (run-internal-tests)
    608       (test-eq 1
    609         (lookup-variable-value 'a
    610                                (extend-environment '(a +)
    611                                                    `(1 ,+)
    612                                                    the-empty-environment)))
    613       (test-eq 1
    614         (lookup-variable-value 'a
    615                                (extend-environment '(+ a)
    616                                                    `(,+ 1)
    617                                                    the-empty-environment)))
    618       (test-eq +
    619         (lookup-variable-value '+
    620                                (extend-environment '(a +)
    621                                                    `(1 ,+)
    622                                                    the-empty-environment))))
    623 
    624     (add-form-handler! application?
    625                        (lambda (exp env)
    626                          (apply (eval (operator exp) env)
    627                                 (list-of-values
    628                                  (operands exp)
    629                                  env))))
    630     (add-form-handler! (lambda (exp)
    631                          (tagged-list? exp 'or))
    632                        (lambda (exp env)
    633                          (eval (let loop ((seq (cdr exp)))
    634                                  (match seq
    635                                    ('() 'false)
    636                                    ((expression . rest)
    637                                     (list (list 'lambda (list 'value)
    638                                                 (list 'if
    639                                                       'value
    640                                                       'value
    641                                                       (loop rest)))
    642                                           expression))
    643                                    (otherwise
    644                                     (error "Weird expression -- AND"
    645                                            otherwise))))
    646                                env)))
    647     (add-form-handler! (lambda (exp)
    648                          (tagged-list? exp 'and))
    649                        (lambda (exp env)
    650                          (eval (let loop ((seq (cdr exp)))
    651                                  (match seq
    652                                    ('() 'false)
    653                                    ((expression)
    654                                     `((lambda (value)
    655                                         (if value
    656                                             value
    657                                             false))
    658                                       ,expression)
    659                                     )
    660                                    ((expression . rest)
    661                                     `((lambda (value)
    662                                         (if value
    663                                             ,(loop rest)
    664                                             false))
    665                                       ,expression))
    666                                    (otherwise
    667                                     (error "Weird expression -- AND"
    668                                            otherwise))))
    669                                env)))
    670     (add-form-handler! cond?
    671                        (lambda (exp env)
    672                          (eval (cond->if exp) env)))
    673     (add-form-handler! begin?
    674                        (lambda (exp env)
    675                          (eval-sequence
    676                           (begin-actions exp)
    677                           env)))
    678     (add-form-handler! lambda?
    679                        (lambda (exp env)
    680                          (make-procedure (lambda-parameters exp)
    681                                          (lambda-body exp)
    682                                          env)))
    683     (add-form-handler! if? eval-if)
    684     (add-form-handler! definition? eval-definition)
    685     (add-form-handler! assignment? eval-assignment)
    686     (add-form-handler! quoted? (lambda (exp env) (text-of-quotation exp)))
    687     (add-form-handler! (lambda (exp) (tagged-list? exp 'let))
    688                        (lambda (exp env)
    689                          (eval (let->combination exp) env)))
    690     (add-form-handler! (lambda (exp) (tagged-list? exp 'let*))
    691                        (lambda (exp env)
    692                          (eval (let*->nested-lets exp) env)))
    693     (add-form-handler! (lambda (exp) (tagged-list? exp 'map-form))
    694                        (lambda (exp env)
    695                          (let* ((f (eval (cadr exp) env))
    696                                 (our-list (eval (caddr exp) env))
    697                                 (_ (dp our-list))
    698                                 (result (map (lambda (x)
    699                                                (apply f (list x)))
    700                                              our-list)))
    701                            result)))))