;;
;; CS 61A               Summer 2003            Midterm 2 solutions
;;

;;
;; Question 1: Deep List Recursion (10 points)
;;


;; Part A: Substitution
;;
;; The way suggested on the midterm says that you should go down the
;; replace list and have another procedure that takes each of the
;; variable value pairs and goes down the target list replacing each
;; instance of that variable with the appropriate value.  So a
;; a correct way of doing this would be:

(define (substitute replace-lst target-lst)
  (if (null? replace-lst) ;; go down the replace-lst
      '()
      (substitute (cdr replace-lst)
		  (replace (car replace-lst) target-lst))))

(define (replace pair target-lst)
  (cond ((null? target-lst) '())
	((pair? (car target-lst))
	 (cons (replace pair (car target-lst))
	       (replace pair (cdr target-lst))))
	((equal? (car pair) (car target-lst))
	 (cons (cadr pair) (replace pair (cdr target-lst))))
	(else
	 (cons (car target-lst) (replace pair (cdr target-lst))))))

;; Most people went with the hint and did some kind of variation of
;; this particular solution.  But with this solution you would get
;; a solution for the third example to be (* (+ 12 z) 17), which
;; wasn't our intent, but since it was too late to restrict it, we
;; accepted this version and a later one.

;; There were also some really interesting solutions to this problem
;; Some are shown here.

;; This version shows how to do substitution with a deep-replace
(define (substitute replace-lst target-lst)
  (if  (null? replace-lst)
       target-lst
       (substitute (cdr replace-lst)
		   (deep-replace (caar replace-lst)
				 (cadar replace-lst)
				 target-lst))))

(define (deep-replace var val lst)
  (cond ((equal? lst var) val)
        ((not (pair? lst)) lst)
        (else (cons (deep-replace var val (car lst))
                    (deep-replace var val (cdr lst))))))

;; Apparently not many people did the 'assoc' way.  Greg and Carolen
;; Both had a solution that uses 'assoc' which didn't need a helper
;; at all.  Remember assoc will return you either a key value pair
;; of false if the key isn't in the association list.

;; Greg's Solution
(define (substitute replace-lst target-lst)
  (cond ((null? target-lst) '())
        ((pair? (car target-lst))
         (cons (substitute replace-lst (car target-lst))
               (substitute replace-lst (cdr target-lst))))
        (else
         (let ((replacement (assoc (car target-lst) replace-lst)))
           (if replacement
               (cons (cadr replacement)
                     (substitute replace-lst (cdr target-lst)))
               (cons (car target-lst)
                     (substitute replace-lst (cdr target-lst))))))))

;; Carolen's solution
(define (substitute replace-lst target-lst)
  (map (lambda (exp)
         (if (not (pair? exp))
             (let ((replacement (assoc exp replace-lst)))
               (if replacement
                   (cadr replacement)
                   exp))
             (subsitute replace-lst exp)))
       target-lst))

;; A minority of people decided to write this problem iteratively,
;; which is much, much harder than the recursive approach (much
;; harder to grade, too). The following is a correct version:

(define (substitute replace-lst target-lst)
  (define (helper replace-lst target-lst so-far)
    (cond ((null? replace-lst) target-lst)
	  ((null? target-lst) (helper (cdr replace-lst) so-far '()))
	  ((list? (car target-lst))
	   (helper replace-lst (cdr target-lst)
		   (append so-far
			   (list (helper replace-lst
					 (car target-lst) '())))))
	  ((equal? (car target-lst) (caar replace-lst))
	   (helper replace-lst (cdr target-lst)
		   (append so-far (list (cadar replace-lst)))))
	  (else
 	   (helper replace-lst (cdr target-lst)
		   (append so-far (list (car target-lst)))))))		  
  (helper replace-lst target-lst '()))


;;Grading:
;; Part A (7 points)
;; 4 points were given to the deep recursion part of the problem
;; 3 points were given to the flat recursion and correct replacement

;; -1: CAR instead of CADR, APPEND instead of CONS, etc.
;; -1: incorrect replacement
;; -4: no deep-recursion
;; -3: no flat-recursion
;; -7: doesn't work
;; 
;; Most people either got close to seven points, or got 1 point
;; for showing some idea of how to do the problem. Some people
;; constructed the list incorrectly and that lost some points.
;; If the solution errored, then points were given on effort.
;;
;; Common Mistakes:
;; 1. Constructing the list incorrectly or inserting multiple
;;    copies of the target-list as it's being replaced
;; 2. Extracting the value of the variable value pair. (using cdr
;;    instead of cadr)


;; Part B: Supersub
;;
;; As for part B, you either got it or didn't get it.  The solution
;; we were looking for recursively called supersub and checked
;; whether or not the substitution of the replace-lst and target-lst
;; was equal to the original target-lst.  Meaning that if we call
;; substitution and get the original lst back it means we can't
;; substitute any further.  But if it isn't, that means we should
;; call supersub again with the same replace-lst but now passing
;; in the substituted-lst

(define (supersub replace-lst target-lst)
  (let ((substituted-lst (substitution replace-lst target-lst)))
    (if (equal? substituted-lst target-lst)
	target-lst
	(supersub replace-lst substituted-lst))))

;; some people were clever enough to see that if we just recursively
;; call substitute with the length of the replace-lst and the
;; target-lst, we would get the correct solution.

(define (supersub replace-lst target-lst)
  ((repeated (lambda (lst) (substitute replace-lst lst))
	     (length replace-lst)) target-lst))

;; Here is another 'repeated' sort of algorithm that doesn't
;; explicitly call repeated.

(define (supersub replace-lst target-lst)
  (if (null? replace-lst)
      target-lst
      (supersub (substitute (list (car replace-lst))
			    (cdr replace-lst))
		(substitute (list (car replace-lst))
			    target-lst))))
;; Grading:
;; Part B (3 points)
;; +1: Correct call to substitute
;; +1: Correct recursive call to supersub
;; +1: Perfect
;;
;; -3: did substitute, ie just substituted once
;;
;; Otherwise, everything was based on how you thought about the
;; algorithm.  1 point was given to those that had some clue of how
;; to get to some close answer, like a 'repeated' failed attempt.
;;
;; Commom Errors:
;; 1. Replacing the replace-lst's variable value pairs.  This was
;;    an incorrect approach to this problem.
;; 2. Only replacing twice, meaning not doing any type of deep
;;    replace.


;;
;; Question 2: Alex and Carolen's Question (aka Environment Diagram)
;;

;; A perfect solution would have been exactly like the included
;; picture. There were seven frames in total: one for the global
;; environment (nothing is bound in it), one for each let, and
;; two calls to each lambda (the first calls the second each time).

;; No points were taken off or rewarded for return values written
;; down, because it wasn't requested.


;;Grading:
;; 5 points went to setting up the proper procedure and let
;; structure, and the other 5 points were awarded for
;; consistency in the body of the first let, (+ (-4 (+ 2 5))),
;; regardless of how first part was done.

;; For the lets, a point was taken off for the several errors,
;; including pointing any of the four procedure to the wrong
;; environment, a frame extending the wrong environment, a
;; procedure not begin created, or a binding pointing to the
;; wrong procedure.

;; For the body, two points were taken off for not calling the
;; new version of - from within +, a point was taken off for
;; messing up a computation, two points were taken off for
;; making up frames (including empty ones) or stopping before
;; the computation had finished. A point was taken off for using
;; the new version of - for the explicit call from within the main
;; let body.


;; The most common error was to bind + to something other than the
;; RETURN value of the second let. People though that it should be
;; bound to - among other things. The rest of the errors are those
;; which are described in the grading.



;;
;; Question 3: OOP Mobile
;;

;; Our solution uses only instance vars, although you could
;; accomplish the same functionality by using the initialize
;; clause or other methods. We accepted any way of creating the
;; total-weight and balanced? properties that computed the
;; right values and didn't break the OOP syntax.
;;
;; The best solutions calculated the total-weight and
;; balanced? properties and stored them in instance vars at
;; construction time rather than recalculating them every
;; time via a method.
;;
;; Grading:
;;  +1: Anything about total-weight in OOP
;;  +2: Attempted deep total-weight recursion
;;  +1: Only small errors in total-weight, NOS
;;  +1: Perfect total-weight
;;  +1: Anything about balanced? in OOP
;;  +1: Balanced? working, excluding torque calculation
;;  +2: Balanced? working, including torque calculation
;;  +1: Balanced? working perfectly.
;;
;; Common Errors:
;;  1. Terrible OOP style (From -1 to -4)
;;  2. Setting branches as always balanced, even if the
;;     corresponding struct is unbalanced. (-2)
;;  3. Defining balanced in terms of total-weight, not
;;     torque. (-3)


(define-class (weight value)
  (instance-vars (total-weight value)
		 (balanced? #t)))

(define-class (branch branch-length branch-struct)
  (instance-vars (total-weight (ask branch-struct 'total-weight))
		 (torque       (* (ask branch-struct 'total-weight)
				  branch-length))
		 (balanced?    (ask branch-struct 'balanced?))))

(define-class (mobile left-branch right-branch)
  (instance-vars (total-weight (+ (ask left-branch 'total-weight)
				  (ask right-branch 'total-weight)))
		 (balanced?    (and (= (ask left-branch 'torque)
				       (ask right-branch 'torque))
				    (ask left-branch 'balanced)
				    (ask right-branch 'balanced)))))

;;
;; Question 4: Hierarchy of Types
;;

;; Part A
;;
;; We accepted any answer that computed the 'add-super-type' and
;; 'isa?' methods correctly in the OOP syntax. Our solution
;; uses an instance variable to keep track of the supertypes
;; of an object.
;;
;; The hardest part of the problem seemed to be calling isa?
;; recursively on the parents. Quite a few people built a list
;; of type-names (not objects), but this won't work because
;; there would be no way to recurse on the supers.

(define-class (Typeobj type-name)
  (instance-vars (supers '()))
  (method (add-super-type obj)
	  (set! supers (cons obj supers)))
  (method (isa? obj)
	  (or (equal? (ask obj 'type-name) type-name)
	      (accumulate or #f (map (lambda (x) (ask x 'isa? obj))
				     supers)))))

;; Grading: 
;;
;; +1: Has a supers-like structure to store the supertypes
;; +1: Working 'add-super' method
;; +1: (x isa? x) works correctly.
;; +1: Asking parents about isa? almost works
;; +1: Perfect
;;
;; Common Errors:
;; 1. Putting self in supers list -- this will cause a
;;    loop if you then call 'isa?' on the supers. (-2)
;; 2. Not asking parents if they satisfy 'isa?' on an obj. (-2)
;; 3. Constructing an expanded supers list that includes the
;;    supers of supers. This will only work if objects are
;;    created in top-down order. (-2)

;; Part B:
;;
;; People tried all sorts of crazy stuff for this problem,
;; but there were really only 3 things that had to be done:
;; 1. Create OOP Typeobjs as necessary,
;; 2. Find some way to get froma type-name to a Typeobj,
;; 3. Pass 'add-super' and 'isa?' calls to the proper Typeobj.
;;
;; Our solution leaves the old tag interface unchanged, but
;; accpeted any solution that did the above 3 things. Our
;; solution is also a bit more robust that what the
;; specification required, in that it does a few extra
;; error checks. We did not take off if you missed the
;; error checks.

(define (register-as-subtype type1 type2)
  (define (type->oop type)
    (let ((obj (get 'types type)))
      (or obj (begin (put 'types type (instantiate Typeobj type))
		     (get 'types type)))))
  (ask (type->oop type1) 'add-super-type (type->oop type2)))

(define (subtype? type1 type2)
  (let ((obj1 (get 'types type1))
	(obj2 (get 'types type2)))
    (and obj1 obj2 (ask obj1 'isa? obj2))))

;; Grading:
;;
;; +1: Perfect instantiation of OOP objects
;; +1: Puts type->oop mapping in table correctly
;; +1: Registers super/sub connections properly
;; +1: Get super/sub connections properly
;; +1: Perfect.
;;
;; Common Errors:
;;
;; 1. Not realizing that 'thing' can be any object, not just
;;    a Typeobj. This showed a serious lack of understanding
;;    about abstraction. (-2)
;; 2. Re-creating the Typeobj that represents a particular
;;    type every time 'attach-tag' is called. This won't work
;;    because it will destroy the list of supers. (-1)
;; 3. Treating type-names like 'square' as if they were
;;    already Typeobjs. (-1)
;; 4. Breaking the old interface (-1)