;;;------------------------------------------------------------------------;;;
;;; Advanced Programming Techniques ;;;
;;; Exercise number 3 ;;;
;;; Solution Set ;;;
;;; Michael Elhadad ;;;
;;; Dec 95 ;;;
;;;------------------------------------------------------------------------;;;
(require 'struct)
;;;-------------------------------------------
;;; Utilities
;;;-------------------------------------------
;;; Make sure this is tail-recursive
(define (every pred? list)
(cond ((null? list) #t)
((pred? (car list)) (every pred? (cdr list)))
(else #f)))
(define (some pred? list)
(cond ((null? list) #f)
((pred? (car list)) #t)
(else (some pred? (cdr list)))))
;;;-------------------------------------------
;;; General for streams without memoization
;;;-------------------------------------------
(define (make-stream x thunk)
(cons x thunk))
(define (stream-car st)
(car st))
(define (stream-cdr st)
((cdr st)))
(define the-null-stream '())
(define stream-null? null?)
(define (integers n) (make-stream n (lambda () (integers (+ n 1)))))
(define (filter-stream pred? s)
(cond ((stream-null? s) the-null-stream)
((pred? (stream-car s))
(make-stream (stream-car s)
(lambda () (filter-stream pred? (stream-cdr s)))))
(else (filter-stream pred? (stream-cdr s)))))
(define (display-head s n)
(if (> n 0)
(let ((head (stream-car s)))
(display head) (display " ")
(display-head (stream-cdr s) (- n 1)))))
;;;------------------------------------------------------------
;;; interleave-stream
;;;------------------------------------------------------------
;;; NOTE: Many people gave a longer than necessary definition.
(define (interleave-stream stream1 stream2)
(cond ((stream-null? stream1) stream2)
((stream-null? stream2) stream1)
(else
(make-stream (stream-car stream1)
(lambda () (interleave-stream
stream2
(stream-cdr stream1)))))))
;;;------------------------------------------------------------
;;; merge-stream
;;;------------------------------------------------------------
;;; returns all elements in a stream except n.
(define (all-except n stream)
(filter-stream (lambda (x) (not (= x n))) stream))
;;; merge two ordered streams into one ordered stream eliminating repetition
(define (merge-stream stream1 stream2)
(cond
((stream-null? stream1) stream2)
((stream-null? stream2) stream1)
(else
(let ((x1 (stream-car stream1))
(x2 (stream-car stream2)))
(cond ((= x1 x2)
(make-stream x1
(lambda () (merge-stream
(all-except x1 (stream-cdr stream1))
(all-except x2 (stream-cdr stream2))))))
((< x1 x2)
(make-stream x1
(lambda () (merge-stream
(all-except x1 (stream-cdr stream1)) stream2))))
((> x1 x2)
(make-stream x2
(lambda () (merge-stream stream1
(all-except x2 (stream-cdr stream2)))))))))))
(define (scale-stream n S)
(make-stream (* n (stream-car S))
(lambda () (scale-stream n (stream-cdr S)))))
;; NOTE: ALMOST EVERYBODY GOT IT WRONG
;; Most people returned something like:
;; (define ss2 (scale-stream 2 (integers 1)))
;; (define ss3 (scale-stream 3 (integers 1)))
;; (define ss5 (scale-stream 5 (integers 1)))
;; (define ms (merge-stream ss5 (merge-stream ss2 ss3)))
;;
;; (display-head ms 10)
;; 2 3 4 5 6 8 9 10 12 14
;; BUT 14 = 2 * 7 SHOULD NOT BE INCLUDED! (7 is a prime factor != 2,3,5)
;;
;; S has to be a recursive structure because the definition was recursive.
;; NOTE: you CAN have a recursive data structure that refers to itself
;; with streams because of the delayed evaluation. The definition of S
;; is visible inside the thunk: (lambda () ...).
(define S
(make-stream 1 (lambda ()
(merge-stream
(merge-stream
(scale-stream 2 S)
(scale-stream 3 S))
(scale-stream 5 S)))))
;; (display-head ms 30)
;; 1 2 3 4 5 6 8 9 10 12 15 16 18 20 24 25 27 30 32 36 40 45 48 50 54 60 64
;; 72 75 80 #
;;;----------------------------------------
;;; Define-records for the following BNF
;;;----------------------------------------
;; ::= varref (var)
;; | lit (datum)
;; | (if ) if (test-exp then-exp else-exp)
;; | (proc ({}*) ) proc (formals body)
;; | ( {}*) app (rator rands)
;; | (:= ) varassign (var exp)
;; | (begin {}+) begin (exps)
;; | (let ) let (decls body)
;; | (letrec ) letrec (decls body)
;; | (letmutable ) letmutable (decls body)
;; ::= ({}*)
;; ::= ( ) decl (var exp)
(define-record varref (var))
(define-record lit (datum))
(define-record if-exp (test-exp then-exp else-exp))
(define-record proc (formals body))
(define-record app (rator rands))
(define-record varassign (var exp))
(define-record begin-exp (exps))
(define-record let-exp (decls body))
(define-record letrec-exp (decls body))
(define-record letmutable-exp (decls body))
(define-record decl (var exp))
(define-record closure (formals body env))
(define-record prim-proc (op))
(define-record empty-env ())
(define-record ne-env (symbol value env))
(define-record cell (val))
;;;----------------------------------------
;;; Parser
;;;----------------------------------------
(define first car)
(define second cadr)
(define third caddr)
(define fourth cadddr)
;;; parse expression according to given BNF.
(define (parse exp)
(cond ((number? exp) (make-lit exp))
((symbol? exp) (make-varref exp))
((and (list? exp) (= (length exp) 4) (eq? (first exp) 'if))
(make-if-exp (parse (second exp))
(parse (third exp))
(parse (fourth exp))))
((and (list? exp) (>= (length exp) 3)
(eq? (first exp) 'proc) (list? (second exp)))
(make-proc (second exp) (parse (third exp))))
((and (list? exp) (= (length exp) 3)
(eq? (first exp) ':=))
(make-varassign (parse (second exp)) (parse (third exp))))
((and (list? exp) (> (length exp) 2) (eq? (first exp) 'begin))
(make-begin-exp (map parse (cdr exp))))
((and (list? exp) (>= (length exp) 3) (eq? (first exp) 'let)
(list? (second exp)))
(make-let-exp (parse-decls (second exp)) (parse (third exp))))
((and (list? exp) (>= (length exp) 3) (eq? (first exp) 'letrec)
(list? (second exp)))
(make-letrec-exp (parse-decls (second exp)) (parse (third exp))))
((and (list? exp) (>= (length exp) 3) (eq? (first exp) 'letmutable)
(list? (second exp)))
(make-letmutable-exp (parse-decls (second exp)) (parse (third exp))))
((and (list? exp) (> (length exp) 0))
(make-app (parse (car exp)) (map parse (cdr exp))))
(else (error "Illegal input to parser"))))
(define (parse-decls decls)
(if (null? decls)
()
(let* ((decl (car decls)))
(if (and (list? decl)
(= (length decl) 2)
(symbol? (first decl)))
(cons (make-decl (first decl) (parse (second decl)))
(parse-decls (cdr decls)))
(error "Wrong input to parse-decls" decls)))))
;; NOTE: we also unparse closures and numbers to be able to read the output of
;; the interpreter when it returns a closure.
(define (unparse exp)
(variant-case exp
(varref (var) var)
(lit (datum) datum)
(if-exp (test-exp then-exp else-exp)
(list 'if (unparse test-exp)
(unparse then-exp) (unparse else-exp)))
(proc (formals body) (list 'proc formals (unparse body)))
(app (rator rands) (cons (unparse rator) (map unparse rands)))
(varassign (var exp) (list ':= var (unparse exp)))
(begin-exp
(exps) (cons 'begin (map unparse exps)))
(let-exp (decls body) (list 'let (map unparse decls) (unparse body)))
(letrec-exp
(decls body) (list 'letrec (map unparse decls) (unparse body)))
(letmutable-exp
(decls body) (list 'letmutable (map unparse decls)
(unparse body)))
(decl (var exp) (list var (unparse exp)))
(closure (formals body env)
(list 'closure formals (unparse body)))
(else
(if (number? exp)
exp
(error "unparse: Invalid abstract syntax" exp)))))
;;;------------------------------------------------------------
;;; syntax-expand
;;;------------------------------------------------------------
;;; (syntax-expand syntax-tree) where syntax-tree is a parsed expression.
;;; syntax-expand must return a new syntax tree, with every let and letrec
;;; records are replaced by a semantically equivalent app record.
;;; Create new symbols of the form %Gnnn
;;; we assume these new symbols do not appear free in any expression.
(define gensym
(let ((counter 0))
(lambda ()
(set! counter (1+ counter))
(string->symbol (string-append "%G" (number->string counter))))))
(define (create-vars n)
(if (= n 0)
'()
(cons (gensym) (create-vars (- n 1)))))
(define (syntax-expand syntax-tree)
(variant-case syntax-tree
(varref (var) syntax-tree)
(lit (datum) syntax-tree)
(if-exp (test-exp then-exp else-exp)
(make-if (syntax-expand test-exp)
(syntax-expand then-exp)
(syntax-expand else-exp)))
(proc (formals body) (make-proc formals (syntax-expand body)))
(app (rator rands) (make-app (syntax-expand rator)
(map syntax-expand rands)))
(varassign (var exp) (make-varassign var
(syntax-expand exp)))
(begin-exp (exps) (make-begin-exp (map syntax-expand exps)))
(let-exp (decls body) (make-app (make-proc (map decl->var decls)
(syntax-expand body))
(map syntax-expand
(map decl->exp decls))))
(letrec-exp (decls body)
(let ((new-vars (create-vars (length decls))))
(syntax-expand
(make-let-exp
(map (lambda (var) (make-decl var (make-lit 1)))
(map decl->var decls))
(make-let-exp
(map make-decl new-vars (map decl->exp decls))
(make-begin-exp
(append
(map make-varassign
(map make-varref (map decl->var decls))
(map make-varref new-vars))
(list body))))))))
(decl (var exp) (make-decl var (syntax-expand exp)))
(else (error "Wrong abstract syntax for syntax-expand" syntax-tree))))
;;;------------------------------------------------------------
;;; ENVIRONMENT ADT DEFINITION and initial environment
;;;------------------------------------------------------------
(define (extend-env symb val env)
(if (not (list? symb))
(make-ne-env symb val env)
(if (null? symb)
env
(extend-env (cdr symb) (cdr val)
(make-ne-env (car symb) (car val) env)))))
(define (apply-env env symb)
(variant-case env
(empty-env () (error "Symbol Not found in environment" symb))
(ne-env (symbol value env)
(if (eq? symbol symb) value (apply-env env symb)))
(else (error "Error for apply-env"))))
(define empty-env
(make-empty-env))
(define prim-op-names '(+ - * / add1 sub1 =))
(define init-env
(extend-env prim-op-names
(map make-cell
(map make-prim-proc prim-op-names))
empty-env))
;;;------------------------------------------------------------
;;; VALUE STRUCTURE ADT:
;;; denoted value = Cell(expressed value) + expressed value
;;;------------------------------------------------------------
(define (cell-set! cell val)
(vector-set! cell 1 val))
(define (denoted->expressed e)
(if (cell? e)
(cell->val e)
e))
(define expressed->denoted make-cell)
(define (denoted-value-assign! var val)
(if (cell? var)
(begin (cell-set! var val) '*unspecified-value*)
(error "Assignment to non-mutable variable")))
;;;------------------------------------------------------------
;;; LETMUTABLE INTERPRETER
;;;------------------------------------------------------------
(define (eval-begin exps env)
(cond ((null? exps) '*unspecidfied-value*)
((null? (cdr exps)) (eval-exp (car exps) env))
(else (eval-exp (car exps) env)
(eval-begin (cdr exps) env))))
(define apply-prim-op
(lambda (prim-op args)
(case prim-op
((+) (+ (car args) (cadr args)))
((-) (- (car args) (cadr args)))
((*) (* (car args) (cadr args)))
((/) (/ (car args) (cadr args)))
((add1) (+ (car args) 1))
((sub1) (- (car args) 1))
((=) (= (car args) (cadr args)))
(else (error "Invalid prim-op name:" prim-op)))))
(define (true-value? exp)
(if (eq? exp #f)
#f
#t))
;;; eval-exp with letmutable
;;; All the problems deriving from the existence of immutable variables
;;; are encapsulated in the value structure ADT.
(define (eval-exp exp env)
(variant-case exp
(lit (datum) datum)
(varref (var)
(denoted->expressed (apply-env env var)))
(app (rator rands)
(let ((proc (eval-exp rator env))
(args (eval-rands rands env)))
(apply-proc proc args)))
(if-exp (test-exp then-exp else-exp)
(if (true-value? (eval-exp test-exp env))
(eval-exp then-exp env)
(eval-exp else-exp env)))
(proc (formals body) (make-closure formals body env))
(varassign (var exp)
(denoted-value-assign! (apply-env env (varref->var var))
(eval-exp exp env)))
(decl (var exp) (make-decl var (eval-exp exp env)))
(let-exp (decls body)
(let ((vars (map decl->var decls))
(exps (map decl->exp decls)))
;; ------------------------------------------------------
;; NOTE: here bind variables directly to expressed values
;; without a cell wrapper. Vars are immutable.
;; ------------------------------------------------------
(let ((new-env (extend-env
vars
(eval-rands exps env)
env)))
(eval-exp body new-env))))
(letmutable-exp (decls body)
(let ((vars (map decl->var decls))
(exps (map decl->exp decls)))
;; ------------------------------------------------------
;; NOTE: here bind variables to cells.
;; vars are mutable.
;; ------------------------------------------------------
(let ((new-env (extend-env
vars
(map expressed->denoted
(eval-rands exps env))
env)))
(eval-exp body new-env))))
(begin-exp (exps) (eval-begin exps env))
(else (error "Invalid abstract syntax: " exp))))
;; ------------------------------------------------------
;; NOTE: eval-rands returns expressed values.
;; apply-proc binds formal parameters directly to
;; expressed values. This is like let (immutable).
;; ------------------------------------------------------
(define (eval-rands rands env)
(map (lambda (exp) (eval-exp exp env)) rands))
(define (apply-proc proc args)
(variant-case proc
(prim-proc (op) (apply-prim-op op args))
(closure (formals body env)
(eval-exp body (extend-env formals args env)))
(else (error "Invalid Procedure: " proc))))
;;;------------------------------------------------------------
;;; constant optimization
;;;------------------------------------------------------------
;;; find all assigned variables in the expression
(define (assigned-var? var1 exp)
(variant-case exp
(lit (datum) #f)
(varref (var) #f)
(if-exp (test-exp then-exp else-exp)
(or (assigned-var? var1 test-exp)
(assigned-var? var1 then-exp)
(assigned-var? var1 else-exp)))
(proc (formals body)
(if (member var1 formals)
#f
(assigned-var? var1 body)))
(begin-exp (exps) (some (lambda (e) (assigned-var? var1 e)) exps))
(varassign (var exp)
(if (eq? (varref->var var) var1)
#t
(assigned-var? var1 exp)))
(decl (var exp) (assigned-var? var1 exp))
(let-exp (decls body)
(if (member var1 (map decl->var decls))
(some (lambda (e) (assigned-var? var1 e)) decls)
(or (some (lambda (e) (assigned-var? var1 e)) decls)
(assigned-var? var1 body))))
(app (rator rands)
(or (assigned-var? var1 rator)
(some (lambda (e) (assigned-var? var1 e)) rands)))
(else (error "Wrong expression for assigned-var" exp))))
;; find all variables from the variables in decls that are mutable in body.
(define (get-mutable-vars decls body)
(if (null? decls)
'()
(let ((decl (car decls))
(result (get-mutable-vars (cdr decls) body)))
(if (assigned-var? (decl->var decl) body)
(cons decl result)
result))))
;;; List difference (long - short)
;;; return all elements of long which are not in short
(define (list-difference long short)
(cond ((null? long) '())
((member (car long) short)
(list-difference (cdr long) short))
(else
(cons (car long)
(list-difference (cdr long) short)))))
;;; Modify all let expressions to let or let-mutable according
;;; to the need: if there is an assignment in the scope
;;; convert it to let-mutable.
(define (const-optimize exp)
(variant-case exp
(varref (var) exp)
(lit (datum) exp)
(if-exp (test-exp then-exp else-exp)
(make-if (const-optimize test-exp)
(const-optimize then-exp)
(const-optimize else-exp)))
(proc (formals body) (make-proc formals (const-optimize body)))
(app (rator rands) (make-app (const-optimize rator)
(map const-optimize rands)))
(varassign (var exp) (make-varassign var
(const-optimize exp)))
(begin-exp (exps) (make-begin-exp (map const-optimize exps)))
(let-exp (decls body)
(let* ((mutable-decls (get-mutable-vars decls body))
(others (list-difference decls mutable-decls)))
(cond ((null? mutable-decls)
(make-let-exp (map const-optimize decls)
(const-optimize body)))
((null? others)
(make-letmutable-exp (map const-optimize decls)
(const-optimize body)))
(else
(make-letmutable-exp (map const-optimize mutable-decls)
(make-let-exp (map const-optimize others)
(const-optimize body)))))))
(decl (var exp) (make-decl var (const-optimize exp)))
(else (error "Const-optimize -- unrecognized abstract syntax " exp))))
;;;------------------------------------------------------------
;;; interpreter with explicit store
;;;------------------------------------------------------------
;;; the result of eval-exp now returns a pair of value and store.
(define-record interp-result (value store))
;;; the result of make-cell should return a pair of address and new store
(define-record cell-result (address store))
;;;------------------------------------------------------------
;;; Store ADT
;;;------------------------------------------------------------
;;; Implementaion of store as finite-function
(define init-store (lambda (x) (error "Not Found in store" x)))
(define (extend-store address val store)
(lambda (s)
(if (eq? s address)
val
(apply-store s store))))
(define (apply-store address store)
(store address))
;;;------------------------------------------------------------
;;; Updated cell ADT
;;;------------------------------------------------------------
;; return new address
(define get-new-address
(let ((counter 0))
(lambda ()
(set! counter (1+ counter))
counter)))
(define (make-store-cell val store)
(let ((address (get-new-address)))
(make-cell-result address (extend-store address val store ))))
(define (store-cell-set! address val store)
(extend-store address val store))
(define (make-cells formals args store)
(letrec ((loop (lambda (formals args ans store)
(if (null? formals)
(make-interp-result (reverse ans) store)
(let ((first-result (make-store-cell (car args)
store)))
(loop
(cdr formals)
(cdr args)
(cons (cell-result->address first-result) ans)
(cell-result->store first-result)))))))
(loop formals args '() store)))
;;;------------------------------------------------------------
;;; New interpreter
;;;------------------------------------------------------------
(define init-env-store
(let ((result (make-cells prim-op-names
(map make-prim-proc prim-op-names)
init-store)))
(set! init-store (interp-result->store result))
(extend-env prim-op-names
(interp-result->value result)
empty-env)))
(define (eval-rands-store rands env store)
(letrec ((loop (lambda (rands ans store)
(if (null? rands)
(make-interp-result (reverse ans) store)
(let ((first-result (eval-exp-store (car rands)
env store)))
(loop
(cdr rands)
(cons (interp-result->value first-result) ans)
(interp-result->store first-result)))))))
(loop rands '() store)))
(define (apply-proc-store proc args store)
(variant-case proc
(prim-proc (op) (make-interp-result ;; assuming applying primitive
;; operator can't change the store.
(apply-prim-op op args)
store))
(closure (formals body env)
(let ((result (make-cells formals args store)))
(eval-exp-store body
(extend-env formals
(interp-result->value result)
env)
(interp-result->store result))))
(else (error "Invalid Procedure: " proc))))
(define (eval-begin-store exps env store)
(letrec ((loop (lambda (exps ans store)
(if (null? exps)
(make-interp-result ans store)
(let ((first-result (eval-exp-store (car exps) env store)))
(loop
(cdr exps)
(interp-result->value first-result)
(interp-result->store first-result)))))))
(loop exps '? store)))
;;; The new eval-exp
(define (eval-exp-store exp env store)
(variant-case exp
(lit (datum)
(make-interp-result datum store))
(varref (var)
(make-interp-result (apply-store (apply-env env var) store) store))
(app (rator rands)
(let* ((proc (eval-exp-store rator env store))
(args (eval-rands-store rands env
(interp-result->store proc))))
(apply-proc-store (interp-result->value proc)
(interp-result->value args)
(interp-result->store args))))
(if-exp (test-exp then-exp else-exp)
(let* ((test-result
(eval-exp-store test-exp env store)))
(if (true-value? (interp-result->value test-result))
(eval-exp-store then-exp env
(interp-result->store test-result))
(eval-exp-store else-exp env
(interp-result->store test-result)))))
(proc (formals body)
(make-interp-result
(make-closure formals body env)
store))
(varassign (var exp)
(let* ((result (eval-exp-store exp env store))
(new-st (store-cell-set!
(apply-env env (varref->var var))
(interp-result->value result)
store)))
(make-interp-result '*unspecified* new-st)))
(begin-exp (exps) (eval-begin-store exps env store))
(else (error "Invalid abstract syntax to eval-exp-store: " exp))))