
<<<<< Preliminary Answers to Homework 9 >>>>>

;; Exercise 5.6, p.198
;; The OOP Language of chapter 5 had several implementations, but we only
;; examined the simple implementation.  Test this implementation by running
;; the test program in figure 5.15.  It should result in a list with
;; the following attributes:  15 appears twice, 35 appears 5 times,
;; 50 appears once, 100 appears twice, 200 appears twice, 300 appears once,
;; and there are 6 sets of parentheses.
;; Explain how this answer is derived by briefly explaining the flow and
;; execution of the program.

;; ANSWER

;; Answers will vary, but the list answer should be the same.


;; Exercise 4.2, p.133
;; The Scheme procedure equal? is more powerful than needed here.
;; Rewrite check-equal-type! to do an explicit recursive traversal
;; of the types.

(load "fig4.3-8.scm")

;; ANSWER

(define check-equal-type!
  (lambda (t1 t2 exp)
    (cases type t1
      (atomic-type (name1)
        (cases type t2
          (atomic-type (name2) (eqv? name1 name2))
          (else (bad t1 t2 exp))))
      (proc-type (arg-types1 result-type1)
        (cases type t2
          (proc-type (arg-types2 result-type2)
            (and (= (length arg-types1) (length arg-types2))
                 (andmap check-equal-type!
                         arg-types1
                         arg-types2
                         (dupl exp (length arg-types1)))))
          (else (bad t1 t2 exp)))))))

(define dupl
  (lambda (item n)
    (if (zero? n)
        '()
        (cons item (dupl item (- n 1))))))

(define bad
  (lambda (t1 t2 exp)
    (eopl:error 'check-equal-type!
      "Types didn't match: ~s != ~s in~%~s"
      (type-to-external-form t1)
      (type-to-external-form t2)
      exp)))


;; Test cases:

; (int -> int)
(define test1 '(type-check "

proc (int x) add1(x)

"))

; (int -> int)
(define test2 '(type-check "

letrec
  int fact (int x) =
        if zero?(x) then 1 else *(x,(fact sub1(x)))
in fact

"))

; int
(define test3 '(type-check "

letrec
  int fact (int x) =
        if zero?(x) then 1 else *(x,(fact sub1(x)))
in (fact 3)

"))

; error
(define test4 '(type-check "

letrec
  int fact (int x) =
        if zero?(x) then 1 else *(x,(fact sub1(x)))
in (fact fact)

"))


;; Exercise 4.6, p.141
;; Extend the checker to handle varassign-exp from section 3.7.

(load "fig4.3-8.scm")

;; ANSWER

;;;;;;;;;;;;;;;; grammatical specification ;;;;;;;;;;;;;;;;

(define the-lexical-spec
  '((whitespace (whitespace) skip)
    (comment ("%" (arbno (not #\newline))) skip)
    (identifier
      (letter (arbno (or letter digit "_" "-" "?")))
      symbol)
    (number (digit (arbno digit)) number)))

(define the-grammar
  '((program (expression) a-program)
    (expression (number) lit-exp)
    (expression ("true") true-exp)
    (expression ("false") false-exp)
    (expression (identifier) var-exp)   
    (expression
      (primitive "(" (separated-list expression ",") ")")
      primapp-exp)
    (expression
      ("if" expression "then" expression "else" expression)
      if-exp)
   (expression
      ("let" (arbno  identifier "=" expression) "in" expression)
      let-exp)
    (expression                         ; typed-parameter is new for 4-2
      ("proc" "(" (separated-list type-exp identifier ",") ")" expression)
      proc-exp)
    (expression
      ("(" expression (arbno expression) ")")
      app-exp)
    (expression
      ("letrec"
        (arbno type-exp identifier
          "(" (separated-list type-exp identifier ",") ")"
          "=" expression) "in" expression) 
      letrec-exp)
    (expression
      ("set" identifier "=" expression)
      varassign-exp)

    (primitive ("+")     add-prim)
    (primitive ("-")     subtract-prim)
    (primitive ("*")     mult-prim)
    (primitive ("add1")  incr-prim)
    (primitive ("sub1")  decr-prim)
    (primitive ("zero?") zero-test-prim)
    (type-exp ("int") int-type-exp)             ; 4-2
    (type-exp ("bool") bool-type-exp)           ; 4-2
    (type-exp                                   ; 4-2
      ("(" (separated-list type-exp "*") "->" type-exp ")")
      proc-type-exp)
    ))

(sllgen:make-define-datatypes the-lexical-spec the-grammar)

(define show-the-datatype
  (lambda () (sllgen:list-define-datatypes the-lexical-spec the-grammar)))

(define scan&parse
  (sllgen:make-string-parser the-lexical-spec the-grammar))

(define just-scan
  (sllgen:make-string-scanner the-lexical-spec the-grammar))


(define type-of-expression
  (lambda (exp tenv)
    (cases expression exp
      (lit-exp (number) int-type)
      (true-exp () bool-type)
      (false-exp () bool-type)
      (var-exp (id) (apply-tenv tenv id))
      (if-exp (test-exp true-exp false-exp)
        (let ((test-type (type-of-expression test-exp tenv))
              (false-type (type-of-expression false-exp tenv))
              (true-type (type-of-expression true-exp tenv)))
          (check-equal-type! test-type bool-type test-exp)
       ;^ these tests either succeed or raise an error
          (check-equal-type! true-type false-type exp)
          true-type))
      (proc-exp (texps ids body)
        (type-of-proc-exp texps ids body tenv))
      (primapp-exp (prim rands)
        (type-of-application
          (type-of-primitive prim)
          (types-of-expressions rands tenv)
          prim rands exp))
      (app-exp (rator rands) 
        (type-of-application
          (type-of-expression rator tenv)
          (types-of-expressions rands tenv)
          rator rands exp))
      (let-exp (ids rands body)
        (type-of-let-exp ids rands body tenv))
      (letrec-exp (result-texps proc-names texpss idss bodies
                    letrec-body)
        (type-of-letrec-exp
          result-texps proc-names texpss idss bodies
          letrec-body tenv))

      (varassign-exp (id rhs-exp)                 ;;;;
	(begin                                    ;;;;
	  (check-equal-type!                      ;;;;
	    (apply-tenv tenv id)                  ;;;;
	    (type-of-expression rhs-exp tenv)     ;;;;
	    exp)                                  ;;;;
	  int-type))                              ;;;;

      ))) 


;; Test cases:

; (int -> int)
(define test1 '(type-check "

proc (int x) add1(x)

"))

; (int -> int)
(define test2 '(type-check "

letrec
  int fact (int x) =
        if zero?(x) then 1 else *(x,(fact sub1(x)))
in fact

"))

; int
(define test3 '(type-check "

letrec
  int fact (int x) =
        if zero?(x) then 1 else *(x,(fact sub1(x)))
in (fact 3)

"))

; error
(define test4 '(type-check "

letrec
  int fact (int x) =
        if zero?(x) then 1 else *(x,(fact sub1(x)))
in (fact fact)

"))

; int
(define test5 '(type-check "

let
  n = 5
in let
     d = set n = 7
   in +(n,d)

"))


Rewrite these procedures in CPS and then test them using:

  (define final-valcont
    (lambda  (v)
      (display "The answer is: ")
      (write v)
      (newline)))


;; ANSWER

;; Exercise 8.5.3, p. 279
;; a.

;; original
(define remove*
  (lambda (a alst)
    (cond
      ((null? alst) '())
      ((pair? (car alst))
	(cons (remove* a (car alst)) (remove* a (cdr alst))))
      ((eq? (car alst) a) (remove* a (cdr alst)))
      (else (cons (car alst) (remove* a (cdr alst)))))))


(define test3
  '(remove* 'a
	    '( (a b a c a d a e)
               (a b a c a d a e)
               ( (a b a c a d a e) (a b a c a d a e) )
               (a b a c a d a e)
               (a b a c a d a e)
               (a b a c a d a e))))

(define remove*
  (lambda (a alst)
    (remove*-cps a alst (lambda (v) v))))

(define remove*-cps
  (lambda (a alst k)
    (cond
      ((null? alst) (k '()))
      ((pair? (car alst))
	(remove*-cps a (car alst)
	  (lambda (v)
	    (remove*-cps a (cdr alst)  
	      (lambda (v1) (k (cons v v1)))))))
      ((eq? (car alst) a) (remove*-cps a (cdr alst) k))
      (else
        (remove*-cps a (cdr alst)
	  (lambda (v) (k (cons (car alst) v))))))))


;
;; Exercise 8.5.3, p. 279
;; b.

;; original
(define member*
  (lambda (a alst)
    (cond
      ((null? alst) #f)
      ((pair? (car alst))
	(or (member* a (car alst)) (member* a (cdr alst))))
      ((eq? (car alst) a) alst)
      (else (member* a (cdr alst))))))

(define test4
  '(member* 'x
	    '( (a b a c a d a e)
               (a b a c a d a e)
               ( (a b a c a d a e) (a b a x a d a e) )
               (a b a c a d a e)
               (a b a c a d a e)
               (a b a c a d a e))))

(define member*
  (lambda (a alst)
    (member*-cps a alst (lambda (v) v))))

(define member*-cps
  (lambda (a alst k)
    (cond
      ((null? alst) (k #f))
      ((pair? (car alst))
	(member*-cps a (car alst)
	  (lambda (v)
	    (member*-cps a (cdr alst)
	      (lambda (v1) (k (or v v1))))))) ;; I am suspicious of "or"
      ((eq? (car alst) a) (k alst))
      (else (member*-cps a (cdr alst) k)))))

(define member*-cps
  (lambda (a alst k)
    (cond
      ((null? alst) (k #f))
      ((pair? (car alst))
	(member*-cps a (car alst)
	  (lambda (v)
	    (or v
	        (member*-cps a (cdr alst)
	          (lambda (v1) (k v1)))))))
      ((eq? (car alst) a) (k alst))
      (else (member*-cps a (cdr alst) k)))))


;
;; Exercise 8.5.3, p. 280
;; c.

;; original
(define remfirst*
  (lambda (a alst)
    (letrec
      ((loop (lambda (alst)
	       (cond
		 ((null? alst) '())
		 ((not (pair? (car alst)))
		   (if (eq? (car alst) a)
		       (cdr alst)
		       (cons (car alst) (loop (cdr alst)))))
		 ((equal? (loop (car alst)) (car alst))
		   (cons (car alst) (loop (cdr alst))))
		 (else (cons (loop (car alst)) (cdr alst)))))))
        (loop alst))))

(define test5
  '(remfirst* 'x
	    '( (a b a c a d a e)
               (a b a c a d a e)
               ( (a b a c a d a e) (a b a x a d a e) )
               (a b a c a d a e)
               (a b a c a d a e)
               (a b a c a d a e))))

(define remfirst*
  (lambda (a alst)
    (remfirst*-cps a alst (lambda (v) v))))

(define remfirst*-cps
  (lambda (a alst k)
    (letrec
      ((loop (lambda (alst k)
	       (cond
		 ((null? alst) (k '()))
		 ((not (pair? (car alst)))
		   (if (eq? (car alst) a)
		       (k (cdr alst))
		       (loop (cdr alst)
			 (lambda (v) (k (cons (car alst) v))))))
		 (else
		   (loop (car alst)
		      (lambda (v)
			(if (equal? v (car alst))
			    (loop (cdr alst)
				  (lambda (v1) (k (cons (car alst) v1))))
		            (loop (car alst)
				  (lambda (v1) (k (cons v1 (cdr alst)))))))))))))
        (loop alst k))))

;
;; Exercise 8.5.3, p. 280
;; d.

;; original
(define depth
  (lambda (alst)
    (cond
      ((null? alst) 1)
      ((not (pair? (car alst))) (depth (cdr alst)))
      ((< (+ (depth (car alst)) 1) (depth (cdr alst)))
	(depth (cdr alst)))
      (else (+ (depth (car alst)) 1)))))

(define test6
  '(depth
	    '( (a b a c a d a e)
               (a b a c a d a e)
               ( (a b a c a d a e) (a b a x a d a e) )
               (a b a c a d a e)
               (a b a c a d a e)
               (a b a c a d a e))))

(define depth
  (lambda (alst)
    (depth-cps alst (lambda (v) v))))

(define depth-cps
  (lambda (alst k)
    (cond
      ((null? alst) (k 1))
      ((not (pair? (car alst)))
	(depth-cps (cdr alst) k))
      (else
	(depth-cps (car alst)
	  (lambda (v)
	    (depth-cps (cdr alst)
	      (lambda (v1)
		(if (< (+ v 1) v1)
		    (k v1)
		    (k (+ v 1)))))))))))

;
;; Exercise 8.5.3, p. 280
;; e.

;; original
(define depth-with-let
  (lambda (alst)
    (if (null? alst)
	1
	(let ((drest (depth-with-let (cdr alst))))
	  (if (pair? (car alst))
	      (let ((dfirst (+ (depth-with-let (car alst)) 1)))
		(if (< dfirst drest) drest dfirst))
	      drest)))))


(define test7
  '(depth-with-let
	    '( (a b a c a d a e)
               (a b a c a d a e)
               ( (a b a c a d a e) (a b a x a d a e) )
               (a b a c a d a e)
               (a b a c a d a e)
               (a b a c a d a e))))


(define depth-with-let
  (lambda (alst)
    (depth-with-let-cps alst (lambda (v) v))))

(define depth-with-let-cps
  (lambda (alst k)
    (if (null? alst)
	(k 1)
	(depth-with-let-cps (cdr alst)
	  (lambda (drest) 
	    (if (pair? (car alst))
		(depth-with-let-cps (car alst)
		  (lambda (d)
		    (let ((dfirst (+ d 1)))
		      (if (< dfirst drest)
			  (k drest)
			  (k dfirst)))))
		(k drest)))))))