;;; logo-meta.scm      Part of programming project #4

;;; Differences between the book and this version:  Eval and apply have
;;; been changed to logo-eval and logo-apply so as not to overwrite the Scheme
;;; versions of these routines. An extra procedure initialize-logo has been
;;; added. This routine resets the global environment and then executes the
;;; driver loop. This procedure should be invoked to start the Logo
;;; evaluator executing.  Note: It will reset your global environment and all
;;; definitions to the Logo interpreter will be lost. To restart the Logo
;;; interpreter without resetting the global environment, just invoke
;;; driver-loop.  Don't forget that typing control-C will get you out of
;;; the Logo evaluator back into Scheme.

;;; Problems A1, B1, and 4 require you to find and change existing procedures.

;;;  Procedures that you must write from scratch:

(define (eval-line line-obj env)
  (if (ask line-obj 'empty?)
      '=no-value=
      (let ((value (logo-eval line-obj env)))
        (if (eq? value '=no-value=)
            (eval-line line-obj env)
            value))))



;;; Problem B1    variables  (other procedures must be modified, too)
;;; data abstraction procedures

(define (variable? exp)
  (equal? ":" (first exp)))
  
(define (variable-name exp)
  (bf exp))


;;; Problem A2   handle-infix

(define (de-infix token)
  (cdr (assoc token '((+ . sum)
		      (- . difference)
		      (* . product)
		      (/ . quotient)
		      (= . equalp)
		      (< . lessp)
		      (> . greaterp)))))

(define (handle-infix value line-obj env)
  (if (and (number? value) (not (ask line-obj 'empty?)))
      (let ((b (ask line-obj 'next)))
	(if (member? b '(+ - * / = < >))
		   (let ((proc (text (lookup-procedure (de-infix b)))))
		     (handle-infix (proc value (eval-prefix line-obj env))
				   line-obj
				   env))
	    (begin (ask line-obj 'put-back b)
		   value)))
      value))


;;; Problem B2    eval-definition



(define (make-body line-obj)
  (prompt "-> ")
  (let ((one (logo-read)))
    (if (equal? one '(end))
	'()
	(cons one (make-body line-obj)))))


(define-class (get-args line-obj)
  (instance-vars (par '())
		 (counter 0))
  (method (get-formals)
	  (set! par (cons (variable-name (ask line-obj 'next))
			  par))
	  (set! counter (+ counter 1))))


(define (do-statics obj)
  (let ((frame (make-frame '() '())))
    (define (stat-h line-obj)
      (if (ask line-obj 'empty?)
	  frame
	  (let ((var (variable-name (ask line-obj 'next)))
		(val (logo-eval line-obj the-global-environment)))
	    (begin (add-binding-to-frame! var val frame)
		   (stat-h line-obj)))))
    (stat-h obj)))
    
    
	  
(define (eval-definition line-obj)
  (let ((name (ask line-obj 'next))
	(forms (instantiate get-args line-obj)))
    (define (forms-h)
      (if (and (not (ask line-obj 'empty?))
	       (let ((test (ask line-obj 'next)))
		 (if (not (equal? test 'static))
		     (ask line-obj 'put-back test)
		     #f)))
	  (begin (ask forms 'get-formals)
		 (forms-h))))
    (begin (forms-h)
	   (let ((statics (do-statics line-obj)))
	     (set! the-procedures
		   (cons (list name 'compound (ask forms 'counter)
			       (cons (ask forms 'par) (make-body line-obj)) statics)
			 the-procedures)))))
  '=no-value=)
    




;;; Problem 5    eval-sequence

(define (eval-sequence exps env)
  (let ((obj-list (exps->obj exps)))
    (define (inner obj env)
      (cond ((last-obj? obj)
	     '=no-value=)
	    (else (let ((result (logo-eval (first-obj obj) env)))
		    (cond ((eq? result '=stop=) '=no-value=)
			  ((and (pair? result) (eq? (car result) '=output=))
			    (cdr result))
			  ((not (eq? result '=no-value=))
			   (error "you don't say what to do with " result))
			  (else
			   (inner (rest-obj obj) env)))))))
    (inner obj-list env)))

(define (exps->obj exps)
  (if (null? exps)
      '()
      (cons (make-line-obj (car exps))
	    (exps->obj (cdr exps)))))

(define (first-obj obj)
  (car obj))

(define (rest-obj obj)
  (cdr obj))

(define (last-obj? obj)
  (null? obj))

;;; SETTING UP THE ENVIRONMENT

(define the-primitive-procedures '())
 
(define (add-prim name count proc)
  (set! the-primitive-procedures
	(cons (list name 'primitive count proc)
	      the-primitive-procedures)))

(add-prim 'first 1 first)
(add-prim 'butfirst 1 bf)
(add-prim 'bf 1 bf)
(add-prim 'last 1 last)
(add-prim 'butlast 1 bl)
(add-prim 'bl 1 bl)
(add-prim 'word -2 word)                               ;changed
(add-prim 'sentence -2 se)                             ;changed
(add-prim 'se 2 se)     
(add-prim 'list -2 list)                               ;changed
(add-prim 'fput 2 cons)

(add-prim 'sum -2 (make-logo-arith +))                 ;changed
(add-prim 'difference 2 (make-logo-arith -))
(add-prim '=unary-minus= 1 (make-logo-arith -))
(add-prim '- 1 (make-logo-arith -))
(add-prim 'product -2 (make-logo-arith *))             ;changed
(add-prim 'quotient 2 (make-logo-arith /))
(add-prim 'remainder 2 (make-logo-arith remainder))

(add-prim 'print 1 logo-print)
(add-prim 'pr 1 logo-print)
(add-prim 'show 1 logo-show)
(add-prim 'type 1 logo-type)
(add-prim 'make '(2) make)

(add-prim 'run '(1) run)
(add-prim 'if '(2) logo-if)
(add-prim 'ifelse '(3) ifelse)
(add-prim 'equalp 2 (logo-pred (make-logo-arith equalp)))
(add-prim 'lessp 2 (logo-pred (make-logo-arith <)))
(add-prim 'greaterp 2 (logo-pred (make-logo-arith >)))
(add-prim 'emptyp 1 (logo-pred empty?))
(add-prim 'numberp 1 (logo-pred (make-logo-arith number?)))
(add-prim 'listp 1 (logo-pred list?))
(add-prim 'wordp 1 (logo-pred (lambda (x) (not (list? x)))))

(add-prim 'stop 0 (lambda () '=stop=))
(add-prim 'output 1 (lambda (x) (cons '=output= x)))
(add-prim 'op 1 (lambda (x) (cons '=output= x)))

(add-prim 'load 1 meta-load)

(define the-global-environment '())
(define the-procedures the-primitive-procedures)

;;; INITIALIZATION AND DRIVER LOOP

;;; The following code initializes the machine and starts the Logo
;;; system.  You should not call it very often, because it will clobber
;;; the global environment, and you will lose any definitions you have
;;; accumulated.

(define (initialize-logo)
  (set! the-global-environment (extend-environment '() '() '()))
  (set! the-procedures the-primitive-procedures)
  (driver-loop))

(define (driver-loop)
  (define (helper)
    (prompt "? ")
    (let ((line (logo-read)))
      (if (and (not (null? line)) (not (equal? line '(bye))))
  	  (let ((result (eval-line (make-line-obj line)
				   the-global-environment)))
	    (if (not (eq? result '=no-value=))
		(logo-print (list "You don't say what to do with" result))))
	  (if (equal? line '(bye))
	      (set! helper (lambda ()
			     (newline)
			     (display "BH Sayz: Thank you for using Logo.")
			     (newline)
			     (display "Have a nice day.")
			     (newline))))))
    (helper))
  (logo-read)
  (helper))

;;; APPLYING PRIMITIVE PROCEDURES

;;; To apply a primitive procedure, we ask the underlying Scheme system
;;; to perform the application.  (Of course, an implementation on a
;;; low-level machine would perform the application in some other way.)

(define (apply-primitive-procedure p args)
  (apply (text p) args))


;;; Now for the code that's based on the book!!!


;;; Section 4.1.1

;; Given an expression like (proc :a :b :c)+5
;; logo-eval calls eval-prefix for the part in parentheses, and then
;; handle-infix to check for and process the infix arithmetic.
;; Eval-prefix is comparable to Scheme's eval.

(define (logo-eval line-obj env)
	(handle-infix (eval-prefix line-obj env) line-obj env))

(define (eval-prefix line-obj env)
  (define (eval-helper paren-flag)
    (let ((token (ask line-obj 'next)))
      (cond ((self-evaluating? token) token)
            ((variable? token)
	     (lookup-variable-value (variable-name token) env))
            ((quoted? token) (text-of-quotation token))
            ((definition? token) (eval-definition line-obj))
	    ((left-paren? token)
	     (let ((result (handle-infix (eval-helper #t)
				       	 line-obj
				       	 env)))
	       (let ((token (ask line-obj 'next)))
	       	 (if (right-paren? token)
		     result
		     (error "Too much inside parens")))))
	    ((right-paren? token)
	     (error "Unexpected ')'"))
            (else
	     (let ((proc (lookup-procedure token)))
	       (if (not proc) (error "I don't know how to" token))
	       (logo-apply proc
			   (collect-n-args (arg-count proc)           ;changed
					   line-obj
					   env
					   paren-flag)
			   env)))) ))
  (eval-helper #f))

(define (logo-apply procedure arguments env)                          ;changed
  (cond ((primitive-procedure? procedure)
         (apply-primitive-procedure procedure arguments))
        ((compound-procedure? procedure)
         (eval-sequence (procedure-body procedure)
                        (extend-environment (parameters procedure)
					     arguments
					     (cons (get-local-frame procedure) env))))
        (else
         (error "Unknown procedure type -- LOGO-APPLY" procedure))))

(define (collect-n-args n line-obj env flag)                          ;changed
  (cond ((pair? n)
	 (cons env (collect-n-args (car n) line-obj env flag)))
	((= n 0) ;(print 'zero)
	 '())
	
	((and (< n 0) (not (ask line-obj 'empty?)))
	   (if (not flag)
	       (collect-n-args (* n -1) line-obj env flag)
	       (let ((token (ask line-obj 'next)))
		 (ask line-obj 'put-back token)
		 (if (right-paren? token)
		     '()
		     (let ((next (logo-eval line-obj env)))
		       (cons next
			     (collect-n-args n line-obj env flag))) ))))
	 
	(else
      	 (let ((next (logo-eval line-obj env)))
	   (cons next
	      	 (collect-n-args (-1+ n) line-obj env flag) )))))
	 

;;; Section 4.1.2 -- Representing expressions

;;; numbers

(define (self-evaluating? exp) (number? exp))

;;; quote

(define (quoted? exp)
  (or (list? exp)
      (eq? (string-ref (word->string (first exp)) 0) #\")))

(define (text-of-quotation exp)
  (if (list? exp)
      exp
      (bf exp)))

;;; parens

(define (left-paren? exp) (eq? exp left-paren-symbol))

(define (right-paren? exp) (eq? exp right-paren-symbol))

;;; definitions

(define (definition? exp)
  (eq? exp 'to))

;;; procedures

(define (lookup-procedure name)
  (assoc name the-procedures))

(define (primitive-procedure? p)
  (eq? (cadr p) 'primitive))

(define (compound-procedure? p)
  (eq? (cadr p) 'compound))

(define (arg-count proc)
  (caddr proc))

(define (text proc)
  (cadddr proc))

(define (get-local-frame proc)
  (nth 4 proc))

(define (parameters proc) (car (text proc)))

(define (procedure-body proc) (cdr (text proc)))

;;; Section 4.1.3

;;; Operations on environments

(define (enclosing-environment env) (cdr env))

(define (first-frame env) (car env))

(define the-empty-environment '())

(define (make-frame variables values)
  (cons variables values))

(define (frame-variables frame) (car frame))
(define (frame-values frame) (cdr frame))

(define (add-binding-to-frame! var val frame)
  (set-car! frame (cons var (car frame)))
  (set-cdr! frame (cons val (cdr frame))))

(define (extend-environment vars vals base-env)
  (if (= (length vars) (length vals))
      (cons (make-frame vars vals) base-env)
      (if (< (length vars) (length vals))
          (error "Too many arguments supplied" vars vals)
          (error "Too few arguments supplied" vars vals))))

(define (lookup-variable-value var env)
  (define (env-loop env)
    (define (scan vars vals)
      (cond ((null? vars)
             (env-loop (enclosing-environment env)))
            ((eq? var (car vars))
             (car vals))
            (else (scan (cdr vars) (cdr vals)))))
    (if (eq? env the-empty-environment)
        (error "Unbound variable" var)
        (let ((frame (first-frame env)))
          (scan (frame-variables frame)
                (frame-values frame)))))
  (env-loop env))

(define (set-variable-value! var val env)
  (let ((env2 env))
    (define (env-loop env)
      (define (scan vars vals)
	(cond ((null? vars)
	       (env-loop (enclosing-environment env)))
	      ((eq? var (car vars))
	       (set-car! vals val))
	      (else (scan (cdr vars) (cdr vals)))))
      (if (eq? env the-empty-environment)
	  (define-variable! var val env2)                 ;changed
	  (let ((frame (first-frame env)))
	    (scan (frame-variables frame)
                (frame-values frame)))))
    (env-loop env)))

(define (define-variable! var val env)
  (let ((frame (first-frame env)))
    (define (scan vars vals)
      (cond ((null? vars)
             (add-binding-to-frame! var val frame))
            ((eq? var (car vars))
             (set-car! vals val))
            (else (scan (cdr vars) (cdr vals)))))
    (scan (frame-variables frame)
          (frame-values frame))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;add a new primitive procedure for testing #A1

(define (xyz env x y)
  (print x)
  (print y))

(add-prim 'xyz '(2) xyz)