;;--------------------------------------------------------------------------
;;      Solution for hw2, problem 1.
;;
;;      This solution is suggested by David Christian Lutterkort.
;;--------------------------------------------------------------------------

;;--------------------------------------------------------------------------
;; README written by David Christian Lutterkort
;;
;;   The lexical-address function scans through an expression, exploiting
;; the recursive definition of the syntax for expressions; the real work
;; is done by a function (lex-addr EXP CTXT) which gets the expression 
;; and a variable context as parameters. The context is a list of
;; lists. Every time we run across a lambda - expression, the variable
;; list gets tacked onto the front of the context; if we want to replace
;; a varref by the lex. addr. of that varref, we walk through the CTXT =
;; (c_1 c_2 ... c_n) list, searching the varref in each of its element lists
;; c_i. Then the depth of a symbol is given by the index i of the first
;; c_i that contains the varref, and its position by the list-index of
;; the varref in that c_i.
;;
;;   There's only one problem left: how do we deal with free variables ? We
;; have to make sure that each free variable gets a unique lex. addr.,
;; i.e. we have to assign position numbers to the free variables.
;; My solution to this was to write a function (free-vars EXP) which
;; scans an expression EXP (recursively, following the syntax of the
;; simple language) and records any variable occurences that are not
;; covered by any preceding lambda statement. It returns a list of the
;; free symbols (containing each free symbol once); this list is passed
;; to lex-addr as the initial context. This has the same effect as
;; enclosing the EXP for lex-addr by a (lambda (free_vars) EXP).
;;;  


;;--------------------------------------------------------------------------
;; SOURCE CODE
;;
;;;
;;; IMPORTANT: before you can run these routines, you have to define
;;;    the functions list-index and atom? by loading some appropriate 
;;;    files. list-index was on homework 1, atom? is provided by comlist.scm
;;;
;;; (free-vars EXP)
;;;
;;; scans an EXP of the form
;;; <exp> ::= <varref>
;;;         | (if <exp> <exp> <exp>)
;;;         | (lambda (<var>*) <exp>)
;;;         | (<exp>+) 
;;; and returns a list of the free variables in that expression.
;;; The list won't contain any repetitions of the same symbol.

(define free-vars
  (lambda (exp)
    (letrec ((fv-int
	      (lambda (exp context free)
		(cond
		 ((null? exp) free)
		 ((atom? exp)  ;; EXP must be a varref
		  (if (eq? (list-index exp context) -1) ; EXP is unbound var
		      (if (eq? (list-index exp free) -1)
			  (append free (list exp)) ;; EXP not in free yet
			  free)
		      free))
		 ((eq? (car exp) 'lambda)  ;; EXP is lambda expression
		  (let ((l (cadr exp))
			(e (caddr exp)))
		    (fv-int e (append context l) free)))
		 ((eq? (car exp) 'if)      ;; EXP is if clause
		  (let ((test (cadr exp))
			(then (caddr exp))
			(other (cadddr exp)))
		    (fv-int other context
			    (fv-int then context
				    (fv-int test context free)))))
		 (else              ;; EXP is of the form (<exp>+)
		  (fv-int (cdr exp) context 
			  (fv-int (car exp) context free)))))))
      (fv-int exp '() '()))))

;;;
;;;
;;; (lexical-address EXP)
;;;
;;; replace variable names by their lexical address in expressions
;;; of the above form
;;; uses: list-index, atom?
(define lexical-address
  (lambda (exp)
    (letrec 
	((varref
	 ;;; (varref VARREF CONTEXT) finds the lexical address
	 ;;; in the context list CONTEXT and returns
	 ;;; (v : d p) where d and p are the lexical address of
	 ;;; v
	 ;;; USES: list-index from hw1
	  (lambda (v d context)
	    (if (null? context)
		;;; v is free reference
		;;; that shouldn't happen
		(error "encountered free variable")
		(let ((p (list-index v (car context))))
		  (if (eq? p -1)
		      (varref v (+ d 1) (cdr context))
		      (list v ': d p))))))
	 (lex-addr
	  ;;; (lex-addr EXP CTXT) does all the work for 
	  ;;; lexical-address. EXP is the expression in which lexical 
	  ;;; addresses are to be inserted.
	  ;;; CTXT is a list of all the variable contexts
	  ;;; that were encountered so far.
	  ;;; each (lambda l e) causes CTXT to be replaced by
	  ;;; (cons l CTXT) in the processing of e
	  (lambda (exp ctxt)
	    (cond
	     ((atom? exp) (varref exp 0 ctxt)) ;; EXP is varref
	     ((eq? (car exp) 'lambda)  ;; EXP is lambda expression
	      (let ((l (cadr exp))
		    (e (caddr exp)))
		(list 'lambda l (lex-addr e (cons l ctxt)))))
	     ((eq? (car exp) 'if)      ;; EXP is if clause
	      (let ((test  (lex-addr (cadr exp) ctxt))
		    (then  (lex-addr (caddr exp) ctxt))
		    (other (lex-addr (cadddr exp) ctxt)))
		(list 'if test then other)))
	     (else              ;; EXP must be of the form (<exp>+)
	      (let ((rescar (lex-addr (car exp) ctxt)))
		(if (null? (cdr exp))
		    (list rescar)
		    (cons rescar (lex-addr (cdr exp) ctxt)))))))))
      (lex-addr exp (cons (free-vars exp) '())))))


;;--------------------------------------------------------------------------
;;      Solution for hw2, problem 2.
;;
;;      This solution is suggested by  Lizhen Chen
;;--------------------------------------------------------------------------

;;--------------------------------------------------------------------------
;; SOURCE CODES : translator
;;

(define process
   (lambda (lst)
      (if (null? lst)
         '()
         (let ((item (car lst))
               (next (cdr lst)))
            (if (list? item)
               (append (process item) (process next))
               (case item
                   ((+) (append (process next) '(add)))
                   ((-) (append (process next) '(sub)))
                   ((*) (append (process next) '(mul)))
                   ((/) (append (process next) '(div)))
                   (else
                     (if (number? item)
                        (append (cons 'push (list item)) (process next))
                        (error 'processor "unknown item ~s" item)))))))))
(define translator
   (lambda (lst)
     (append (process lst) '(halt))))


;;--------------------------------------------------------------------------
;; SOURCE CODES : modified stack machine
;;

;;; Grammar for action representation
;;; a ::= (halt) | (incr . a) | (push v . a)
;;;    | (add . a)  | (read . a) | (zero? a1 . a2)

(define apply-action
  (lambda (action stack)
    (let ((instruction (car action)))
      (case instruction
        ((halt)
         (car stack))
        ((incr)
         (let ((next-action (cdr action)))
           (apply-action next-action
             (cons (+ (car stack) 1)
                   (cdr stack)))))
        ((push)
         (let ((v           (cadr action))
               (next-action (cddr action)))
           (apply-action next-action
             (cons v stack))))
        ((add)
         (let ((next-action (cdr action)))
           (apply-action next-action
             (cons (+ (car stack) (cadr stack))
                   (cddr stack)))))
        ((sub)
         (let ((next-action (cdr action)))
           (apply-action next-action
             (cons (- (cadr stack) (car stack))
                   (cddr stack)))))
        ((mul)
         (let ((next-action (cdr action)))
           (apply-action next-action
             (cons (* (car stack) (cadr stack))
                   (cddr stack)))))
        ((div)
         (let ((next-action (cdr action)))
           (apply-action next-action
             (cons (/ (cadr stack) (car stack))
                   (cddr stack)))))
        ((read)
         (let ((v (prompt-read "machine>"))
               (next-action (cdr action)))
           (apply-action next-action
             (cons v stack))))
        ((zero?)
         (let ((true-action (cadr action))
               (false-action (cddr action)))
           (if (zero? (car stack))
             (apply-action true-action stack)
             (apply-action false-action stack))))
        (else
          (error 'apply-action
            "unknown instruction ~s" instruction))))))

(define start
  (lambda (action)
    (apply-action action '())))


(define prompt-read
  (lambda (prompt)
    (display prompt)
    (display " ")
    (read)))


;;--------------------------------------------------------------------------
;;      Solution for hw2, problem 3.
;;
;;	Suggested by 
;;--------------------------------------------------------------------------

;;--------------------------------------------------------------------------
;;  README written by Nitin Garg
;;
;;  Two kind of repetitive loops have been implemented: repeat and while.
;;
;;  repeat has the following format: repeat n <list>
;;  It repeats the stack-machine commands in the list 'n' times. It does 
;;  that by modifying the action stack to add <list> n times.  
;;  Therefore,
;;  	(push 3 repeat 4 (push 4 add) halt)
;;  looks like
;;     	(push 3 push 4 add push 4 add push 4 add push 4 add halt)
;;
;;  while has the following format: while (condition) <list>
;;  The condition is tested against the top of the stack to see if it is 
;;  satisfied. If not the list is repeated until the condition is satisfied.
;;  (condition) is of the form (=? 75) or (>? 10) etc. It is tested against 
;;  the top of the stack using eval command.  while has been implemented using 
;;  letrec and the recursive function called is loop. Both apply-action and loop 
;;  are called recursively to get the desired output.
;;

;;--------------------------------------------------------------------------
;;  SOURCE CODES
;;


(define apply-action
  (lambda (action stack)
    (if (null? action) stack
    (let ((instruction (car action)))
      (case instruction
        ((halt)
         (car stack))
        ((incr)
         (let ((next-action (cdr action)))
           (apply-action next-action
             (cons (+ (car stack) 1)
                   (cdr stack)))))
        ((push)
         (let ((v           (cadr action))
               (next-action (cddr action)))
           (apply-action next-action
             (cons v stack))))
        ((add)
         (let ((next-action (cdr action)))
           (apply-action next-action
             (cons (+ (car stack) (cadr stack))
                   (cddr stack)))))
        ((sub)
         (let ((next-action (cdr action)))
           (apply-action next-action
             (cons (- (cadr stack) (car stack))
                   (cddr stack)))))
        ((mult)
         (let ((next-action (cdr action)))
           (apply-action next-action
             (cons (* (car stack) (cadr stack))
                   (cddr stack)))))
        ((div)
         (let ((next-action (cdr action)))
           (apply-action next-action
             (cons (/ (cadr stack) (car stack))
                   (cddr stack)))))
;;
;;  repeat command
;;
        ((repeat)
         (letrec ((n (cadr action))
                  (rest-action (cdddr action))
                  (repeat-action (caddr action))
                  (loop (lambda (n)
                          (if (eqv? n 0) '()
                              (append repeat-action (loop (- n 1)))))))
            (apply-action (append (loop n) rest-action) stack)))

;;
;;  while command
;;

        ((while)
         (letrec ((condition (cadr action))
                  (repeat-action (caddr action))
                  (rest-action (cdddr action))
                  (loop (lambda (stack)
                          (if (eval (append condition (list (car stack)))) stack
                              (loop (apply-action repeat-action stack))))))
            (apply-action rest-action (loop stack))))
        ((read)
         (let ((v (prompt-read "machine>"))
               (next-action (cdr action)))
           (apply-action next-action
             (cons v stack))))
        ((zero?)
         (let ((true-action (cadr action))
               (false-action (cddr action)))
           (if (zero? (car stack))
             (apply-action true-action stack)
             (apply-action false-action stack))))
        (else
          (error 'apply-action
            "unknown instruction ~s" instruction)))))))

(define start
  (lambda (action)
    (apply-action action '())))

(define prompt-read
  (lambda (prompt)
    (display prompt)
    (display " ")
    (read)))