sicp-4-2-2-optionally-lazy-repl-program

#lang racket
(require racket/mpair)
(provide (all-defined-out))

;; This is the repl program for exercise 4.31 from section 4.2.2.  It is the same as
;; the repl program from section 4.1.4, only modified to allow for three different
;; evaluation strategies for procedure arguments:  eager evaluation by default, lazy
;; evaluation without memoization using the lazy keyword, or lazy evaluation with
;; memoization using the lazy-memo keyword.  There are tests at the end of the file.

;; PROGRAM SECTIONS

;; 1. my-eval and my-apply
;; 2. eval procedures
;; 3. self-evaluating expressions, variables, and quotations
;; 4. definition and assignment
;; 5. thunks, lambdas, procedures and applications
;; 6. sequences and begin expressions
;; 7. boolean expressions
;; 8. if and cond expressions
;; 9. let, let*, and named-let
;; 10. environment and frames
;; 11. primitive procedures and the global environment
;; 12. repl operations
;; 13. tests

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 1. MY-EVAL AND MY-APPLY  ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (my-eval expr env)
  (cond [(self-evaluating? expr) expr]
        [(variable? expr) (lookup-variable-value expr env)]
        [(quoted? expr) (text-of-quotation expr)]
        [(definition? expr) (eval-definition expr env)]
        [(assignment? expr) (eval-assignment expr env)]
        [(if? expr) (eval-if expr env)]
        [(cond? expr) (my-eval (cond->if expr) env)]
        [(begin? expr) (eval-sequence (begin-actions expr) env)]
        [(and? expr) (eval-and expr env)]
        [(or? expr) (eval-or expr env)]
        [(let? expr) (my-eval (let->combination expr) env)]
        [(let*? expr) (my-eval (let*->nested-lets expr) env)]
        [(named-let? expr) (my-eval (named-let->sequence expr) env)]
        [(lambda? expr)
         (make-procedure (lambda-parameters expr)
                         (lambda-body expr)
                         env)]
        [(application? expr)
         (my-apply (actual-value (operator expr) env)
                   (operands expr)
                   env)]
        [else (error "Unknown expression type -- MY-EVAL" expr)]))

(define (my-apply procedure arguments env)
  (cond [(primitive-procedure? procedure)
         (apply-primitive-procedure
           procedure
           (list-of-arg-values arguments env))]
        [(compound-procedure? procedure)
         (eval-sequence
           (procedure-body procedure)
           (extend-environment
             (procedure-parameters procedure)
             (list-of-args arguments
                           (procedure-types procedure)
                           env)
             (procedure-environment procedure)))]
        [else (error "Unknown procedure type -- APPLY" procedure)]))

;;;;;;;;;;;;;;;;;;;;;;;;;
;; 2. EVAL PROCEDURES  ;;
;;;;;;;;;;;;;;;;;;;;;;;;;

(define (eval-definition expr env)
  (define-variable! (definition-variable expr)
                    (my-eval (definition-value expr) env)
                    env)
  'ok)
(define (eval-assignment expr env)
  (set-variable-value! (assignment-variable expr)
                       (my-eval (assignment-value expr) env)
                       env)
  'ok)
(define (list-of-values exprs env)
  (if (no-operands? exprs)
    empty
    (cons (my-eval (first-operand exprs) env)
          (list-of-values (rest-operands exprs) env))))
(define (eval-sequence exprs env)
  (cond [(last-exp? exprs) (my-eval (first-exp exprs) env)]
        [else (my-eval (first-exp exprs) env)
              (eval-sequence (rest-exps exprs) env)]))
(define (eval-if expr env)
  (if (true? (actual-value (if-predicate expr) env))
    (my-eval (if-consequent expr) env)
    (my-eval (if-alternative expr) env)))
(define (eval-and expr env)
  (define ops (and-operands expr))
  (cond [(empty? ops) 'true] ; (and) should be true
        [else
          (define val (my-eval (first ops) env))
          (define rest-ops (rest ops))
          (cond [(empty? rest-ops) val] ; (and x) should be x
                [(false? val) false]
                [else
                  (eval-and (make-and rest-ops) env)])]))
(define (eval-or expr env)
  (define ops (or-operands expr))
  (cond [(empty? ops) 'false] ; (or) should be false
        [else
          (define val (my-eval (first ops) env))
          (define rest-ops (rest ops))
          (cond [(empty? rest-ops) val] ; (or x) should be x
                [(not (false? val)) val]
                [else
                  (eval-or (make-or rest-ops) env)])]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 3. SELF-EVALUATING EXPRESSIONS, VARIABLES, AND QUOTATIONS  ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (tagged-list? expr tag)
  (or (and (pair? expr) (eq? (first expr) tag))
      (and (mpair? expr) (eq? (mcar expr) tag))))
;; Only numbers and strings are self-evaluating.
(define (self-evaluating? expr)
  (cond [(number? expr) true]
        [(string? expr) true]
        [else false]))
(define (variable? expr)
  (symbol? expr))
;; Quotations have the form:  (quote <text-of-quotation>)
(define (quoted? expr)
  (tagged-list? expr 'quote))
(define (text-of-quotation expr)
  (second expr))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 4. DEFINITION AND ASSIGNMENT  ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Variable definitions have the form:  (define <var> <value>)

;; Procedure definitions have the form:
;; (define (<var> <parameter-1> ... <parameter-n>) <body>)
;; which is equivalent to:
;; (define <var> (lambda (<parameter-1> ... <parameter-n>) <body>))

(define (definition? expr)
  (tagged-list? expr 'define))
(define (procedure-definition? expr)
  (and (definition? expr)
       (pair? (second expr))))
(define (definition-variable expr)
  (if (procedure-definition? expr)
    (first (second expr))
    (second expr)))
(define (definition-parameters expr)
  (rest (second expr)))
(define (definition-value expr)
  (if (procedure-definition? expr)
    (make-lambda (definition-parameters expr)
                 (drop expr 2))
    (third expr)))

;; All lambda parameters are a two-element list now: the first element is the
;; parameter name, and the second element is the parameter type, either 'eager,
;; 'lazy, or 'lazy-memo.
(define (make-all-typed params)
  (map (lambda (p)
         (if (symbol? p)
           (list p 'eager)
           p))
       params))

;; Assignments have the form:  (set! <var> <value>)
(define (assignment? expr)
  (tagged-list? expr 'set!))
(define (assignment-variable expr) (second expr))
(define (assignment-value expr) (third expr))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 5. THUNKS, LAMBDAS, PROCEDURES AND APPLICATIONS  ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (thunk-memo? obj) (tagged-list? obj 'thunk-memo))
(define (thunk-no-memo? obj) (tagged-list? obj 'thunk-no-memo))
(define (thunk-exp my-thunk) (mcar (mcdr my-thunk)))
(define (thunk-env my-thunk) (mcar (mcdr (mcdr my-thunk))))
(define (delay-it-memo expr env)
  (mlist 'thunk-memo expr env))
(define (delay-it-no-memo expr env)
  (mlist 'thunk-no-memo expr env))
(define (evaluated-thunk? obj) (tagged-list? obj 'evaluated-thunk))
(define (thunk-value evaluated-thunk) (mcar (mcdr evaluated-thunk)))
(define (force-it obj) ; changed
  (cond [(thunk-memo? obj)
         (define result (actual-value (thunk-exp obj) (thunk-env obj)))
         (set-mcar! obj 'evaluated-thunk)
         (set-mcar! (mcdr obj) result)
         (set-mcdr! (mcdr obj) empty)
         result]
        [(evaluated-thunk? obj) (thunk-value obj)]
        [(thunk-no-memo? obj)
         (actual-value (thunk-exp obj) (thunk-env obj))]
        [else obj]))

;; Lambda expressions have the form:
;; (lambda ((<var> <type>) ... ) <body>)
(define (lambda? expr) (tagged-list? expr 'lambda))
(define (lambda-parameters expr) (second expr))
(define (lambda-body expr) (drop expr 2))
(define (make-lambda parameters body)
  (cons 'lambda (cons (make-all-typed parameters) body))) ; changed

;; Procedures:
(define (make-procedure parameters body env)
  (list 'procedure parameters body env))
(define (compound-procedure? p)
  (tagged-list? p 'procedure))
(define (procedure-parameters p) (map first (second p)))
(define (procedure-types p) (map second (second p)))
(define (procedure-body p) (third p))
(define (procedure-environment p) (fourth p))

;; Procedure applications have the from:
;; (<var> <parameter> ...)
(define (application? expr) (pair? expr))
(define (operator expr) (first expr))
(define (operands expr) (rest expr))
(define (no-operands? ops) (empty? ops))
(define (first-operand ops) (first ops))
(define (rest-operands ops) (rest ops))
(define (actual-value expr env)
  (force-it (my-eval expr env)))
(define (list-of-arg-values exprs env)
  (if (no-operands? exprs)
    empty
    (cons (actual-value (first-operand exprs) env)
          (list-of-arg-values (rest-operands exprs)
                              env))))
(define (list-of-args exprs types env)
  (cond [(no-operands? exprs)
         empty]
        [else
          (define e (first-operand exprs))
          (define t (first types))
          (define arg (cond [(eq? t 'eager) (actual-value e env)]
                            [(eq? t 'lazy) (delay-it-no-memo e env)]
                            [(eq? t 'lazy-memo) (delay-it-memo e env)]
                            [else (error "Unknown type -- LIST-OF-ARGS" t)]))
          (cons arg (list-of-args (rest-operands exprs)
                                  (rest types)
                                  env))]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 6. SEQUENCES AND BEGIN EXPRESSIONS  ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Begin has the form:  (begin <actions>)
(define (begin? expr) (tagged-list? expr 'begin))
(define (begin-actions expr) (rest expr))
(define (last-exp? seq) (empty? (rest seq)))
(define (first-exp seq) (first seq))
(define (rest-exps seq) (rest seq))
(define (sequence->exp seq)
  (cond [(empty? seq) seq]
        [(last-exp? seq) (first-exp seq)]
        [else (make-begin seq)]))
;; begin constructor used by cond->if
(define (make-begin seq) (cons 'begin seq))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 7. BOOLEAN EXPRESSIONS  ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (true? x) (not (false? x)))
(define (and? expr) (tagged-list? expr 'and))
(define (and-operands expr) (rest expr))
(define (make-and sequence) (cons 'and sequence))
(define (or? expr) (tagged-list? expr 'or))
(define (or-operands expr) (rest expr))
(define (make-or sequence) (cons 'or sequence))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 8. IF AND COND EXPRESSIONS  ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Conditionals have the form:  (if <predicate> <consequent> <alternative>)
;; If no alternative, use false.
(define (if? expr) (tagged-list? expr 'if))
(define (if-predicate expr) (second expr))
(define (if-consequent expr) (third expr))
(define (if-alternative expr)
  (if (not (empty? (drop expr 3)))
    (fourth expr)
    'false))
(define (make-if predicate consequent alternative)
  (list 'if predicate consequent alternative))

;; Cond has the form:
;; (cond ((<predicate> <actions>)
       ;; (else <actions>))) ; if no else, assume (else false) clause
(define (cond? expr) (tagged-list? expr 'cond))
(define (cond-clauses expr) (rest expr))
;; regular cond clause
(define (cond-predicate clause) (first clause))
(define (cond-actions clause) (rest clause))
;; alternate test clause
(define (cond-alternate-clause? clause)
  (eq? (second clause) '=>))
(define (cond-test clause) (first clause))
(define (cond-recipient clause) (third clause))
;; else clause
(define (cond-else-clause? clause)
  (eq? (cond-predicate clause) 'else))
;; derive cond from if
(define (cond->if expr)
  (expand-clauses (cond-clauses expr)))
(define (expand-clauses clauses)
  (cond [(empty? clauses) 'false] ; no else clause
        [else
          (define first-clause (first clauses))
          (define rest-clauses (rest clauses))
          (cond [(cond-else-clause? first-clause)
                 (if (empty? rest-clauses)
                   (sequence->exp (cond-actions first-clause))
                   (error "ELSE clause isn't last -- COND->IF" clauses))]
                [(cond-alternate-clause? first-clause)
                 (define test (cond-test first-clause)) ; gets evaluated twice
                 (make-if test
                          (list (cond-recipient first-clause)
                                test)
                          (expand-clauses rest-clauses))]
                [else
                  (make-if (cond-predicate first-clause)
                           (sequence->exp (cond-actions first-clause))
                           (expand-clauses rest-clauses))])]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 9. LET, LET*, AND NAMED-LET  ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Let has the form:  (let (<bindings>) <body>)
(define (let? expr)
  (and (tagged-list? expr 'let)
       (list? (second expr))))
(define (let-bindings expr) (second expr))
(define (let-parameters expr) (map first (let-bindings expr)))
(define (let-expressions expr) (map second (let-bindings expr)))
(define (let-body expr) (drop expr 2))
(define (let->combination expr)
  (cond [(empty? (let-bindings expr)) ; do not unnecessarily lambda wrap
         (sequence->exp (let-body expr))]
        [else
          (cons (make-lambda (let-parameters expr)
                             (let-body expr))
                (let-expressions expr))]))
(define (make-let bindings body)
  (cons 'let (cons bindings body)))

;; Let* has the same form as let, but bindings are sequential.
(define (let*? expr) (tagged-list? expr 'let*))
(define (let*-bindings expr) (second expr))
(define (let*-body expr) (drop expr 2))
(define (make-let* bindings body)
  (cons 'let* (cons bindings body)))
(define (let*->nested-lets expr)
  (define bindings (let*-bindings expr))
  (cond [(empty? bindings)
         (sequence->exp (let-body expr))]
        [else
          (list 'let
                (list (first bindings))
                (let*->nested-lets
                  (make-let* (rest bindings)
                             (let-body expr))))]))

;; Named-let has the form:  (let <name> (<bindings>) <body>)
(define (named-let? expr)
  (and (tagged-list? expr 'let)
       (not (list? (second expr)))))
(define (named-let-name expr) (second expr))
(define (named-let-bindings expr) (third expr))
(define (named-let-parameters expr) (map first (named-let-bindings expr)))
(define (named-let-expressions expr) (map second (named-let-bindings expr)))
(define (named-let-body expr) (drop expr 3))
(define (named-let->sequence expr)
  (define bindings (named-let-bindings expr))
  (cond [(empty? bindings)
         (sequence->exp (named-let-body expr))]
        [else
          (list 'begin
                (cons 'define ; first define the named function
                      (cons (cons (named-let-name expr)
                                  (named-let-parameters expr))
                            (named-let-body expr)))
                (cons (named-let-name expr) ; then apply it to the expressions
                      (named-let-expressions expr)))]))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 10. ENVIRONMENT AND FRAMES  ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; An environment is a mutable list of frames.  The enclosing environment is the mcdr
;; of the list.  A frame is a mutable list of bindings with a 'frame header.  A
;; binding is a var-val pair ie (mcons var val).

;; Environments support four procedures:
    ;; lookup-variable-value
    ;; extend-environment
    ;; define-variable
    ;; set-variable-value

;; Two helper functions support the environment procedures:
    ;; find-binding-in-frame
    ;; find-binding-in-environment

(define (enclosing-environment env) (mcdr env))
(define (first-frame env) (mcar env))
(define the-empty-environment empty)
(define the-empty-frame (mlist 'frame))
(define (empty-frame? frame)
  (empty? (frame-bindings frame)))
(define (make-frame vars vals)
  (mcons 'frame
         (mmap mcons
               (list->mlist vars)
               (list->mlist vals))))
(define (frame-bindings frame) (mcdr frame))
(define (frame-variables frame) (mmap mcar (frame-bindings frame)))
(define (frame-values frame) (mmap mcdr (frame-bindings frame)))

(define (binding-variable binding) (mcar binding))
(define (binding-value binding) (mcdr binding))
(define (set-value! binding val) (set-mcdr! binding val))
(define (add-binding-to-frame! var val frame)
  (mappend! frame (mlist (mcons var val))))
(define (find-binding-in-frame var frame)
  ; Return the var-val pair if present else false.
  (define (loop bindings)
    (cond [(empty? bindings) false]
          [else
            (define b (mcar bindings))
            (if (eq? var (binding-variable b))
              b
              (loop (mcdr bindings)))]))
  (loop (frame-bindings frame)))
(define (find-binding-in-env var env)
  ; Return the closest binding for var if present else false.
  (cond [(eq? env the-empty-environment) false]
        [else
          (define b (find-binding-in-frame var (first-frame env)))
          (or b (find-binding-in-env var (enclosing-environment env)))]))

(define (lookup-variable-value var env)
  (define b (find-binding-in-env var env))
  (if b
    (binding-value b)
    (error "Unbound variable" var)))
(define (extend-environment vars vals base-env)
  (cond [(= (length vars) (length vals))
         (mcons (make-frame vars vals) base-env)]
        [else
          (if (< (length vars) (length vals))
            (error "Too many arguments supplied" vars vals)
            (error "Too few arguments supplied" vars vals))]))
(define (define-variable! var val env)
  (define frame (first-frame env))
  (define b (find-binding-in-frame var frame))
  (if b
    (set-value! b val)
    (add-binding-to-frame! var val frame)))
(define (set-variable-value! var val env)
  (define b (find-binding-in-env var env))
  (if b
    (set-value! b val)
    (error "Unbound variable -- SET!" var)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 11. PRIMITIVE PROCEDURES AND THE GLOBAL ENVIRONMENT  ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define primitive-procedures
  (list
    (list 'cons cons)
    (list 'car car)
    (list 'cdr cdr)
    (list '+ +)
    (list '* *)
    (list '- -)
    (list '< <)
    (list '> >)
    (list '<= <=)
    (list '>= >=)
    (list '= =)
    (list 'not not)
    (list 'false? false?)
    (list 'true? (lambda (x) (not (false? x))))
    (list 'empty? empty?)
    (list 'displayln displayln)
    (list 'list list)
    ))
(define (primitive-procedure? proc)
  (tagged-list? proc 'primitive))
(define (primitive-implementation proc)
  (second proc))
(define (primitive-procedure-names)
  (map first primitive-procedures))
(define (primitive-procedure-objects)
  (map (lambda (proc) (list 'primitive (second proc)))
       primitive-procedures))
(define apply-in-underlying-scheme apply)
;; The metacircular evaluator's apply is my-apply.
(define (apply-primitive-procedure proc args)
  (apply-in-underlying-scheme
    (primitive-implementation proc) args))

(define (setup-environment)
  (define initial-env
    (extend-environment (primitive-procedure-names)
                        (primitive-procedure-objects)
                        the-empty-environment))
  (define-variable! 'true true initial-env)
  (define-variable! 'false false initial-env)
  initial-env)
(define the-global-environment (setup-environment))

;;;;;;;;;;;;;;;;;;;;;;;;;;
;; 12. REPL OPERATIONS  ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;

(define input-prompt ";;; M-Eval input:")
(define output-prompt ";;; M-Eval value:")
(define (driver-loop)
  (prompt-for-input input-prompt)
  (let* ([input (read)]
         [output (actual-value input the-global-environment)])
    (announce-output output-prompt)
    (user-print output))
  (driver-loop))
(define prompt-for-input displayln)
(define announce-output displayln)
(define (user-print object)
  (if (compound-procedure? object)
    (displayln (list 'compound-procedure
                   (procedure-parameters object)
                   (procedure-body object)
                   '<procedure-env>))
    (displayln object)))

;;;;;;;;;;;;;;;
;; 13. TESTS ;;
;;;;;;;;;;;;;;;

;; (my-eval '(define (try a (b lazy)) (if (= a 0) 1 b)) the-global-environment)
;; ;; 'ok
;; (my-eval '(try 0 (/ 1 0)) the-global-environment)
;; ;; 1

;; ;; the book example with count and (id (id 10)) with lazy-memo:

;; (my-eval '(define count 0) the-global-environment)
;; ;; 'ok
;; (my-eval '(define (id (x lazy-memo)) (set! count (+ count 1)) x)
            ;; the-global-environment)
;; ;; 'ok
;; (my-eval 'count the-global-environment) ; should be 0
;; ;; 0
;; (my-eval '(define w (id (id 10))) the-global-environment)
;; ;; 'ok
;; (my-eval 'count the-global-environment) ; should be 1
;; ;; 1
;; (actual-value 'w the-global-environment) ; should be 10
;; ;; 10
;; (my-eval 'count the-global-environment) ; should be 2
;; ;; 2
;; (actual-value 'w the-global-environment)
;; ;; 10
;; (my-eval 'count the-global-environment) ; should still be 2
;; ;; 2

;; ;; the book example with count and (id (id 10)) with lazy, no memo:

;; (my-eval '(define count2 0) the-global-environment)
;; ;; 'ok
;; (my-eval '(define (id2 (x lazy)) (set! count2 (+ count2 1)) x) ; no memo
            ;; the-global-environment)
;; ;; 'ok
;; (my-eval 'count2 the-global-environment) ; should be 0
;; ;; 0
;; (my-eval '(define w (id2 (id2 10))) the-global-environment)
;; ;; 'ok
;; (my-eval 'count2 the-global-environment) ; should be 1
;; ;; 1
;; (actual-value 'w the-global-environment) ; should be 10
;; ;; 10
;; (my-eval 'count2 the-global-environment) ; should be 2
;; ;; 2
;; (actual-value 'w the-global-environment)
;; ;; 10
;; (my-eval 'count2 the-global-environment) ; should be 3
;; ;; 3