;;;

(define (and* . args)
  (and-aux args))

(define (and-aux args)
  (cond ((null? args) #t)
	((null? (cdr args)) (car args))
	((car args) (and-aux (cdr args)))
	(else #f)))

;;;

(define (or* . args)
  (or-aux args))

(define (or-aux args)
  (cond ((null? args) #f)
	((car args) (car args))
	(else (or-aux (cdr args)))))

;;;

(define (get-op e)
  (car e))

(define (get-arg1 e)
  (cadr e))

(define (get-arg2 e)
  (caddr e))

(define (op-is? op e)
  (and (pair? e)
       (equal? (get-op e) op)))

(define (make-expr op e1 e2)
  (list op e1 e2))

(define (symbol-before x y)
  (string<? (symbol->string x)
	    (symbol->string y)))

;;; These mark blocks of extra credit transformations:
;;;
;;; vvvvvvvvvvvvvvvv
;;; (extra credit stuff)
;;; ^^^^^^^^^^^^^^^^

(define (sym+ e1 e2)
  (cond ((equal? e1 0)			;0+x -> x
	 e2)
	((equal? e2 0)			;x+0 -> x
	 e1)
	((and (number? e1)		;2+3 -> 5
	      (number? e2))
	 (+ e1 e2))

	;; vvvvvvvvvvvvvvvv
	((and (number? e1)		;1+(2+x) -> 3+x
	      (op-is? '+ e2)
	      (number? (get-arg1 e2)))
	 (sym+ (+ e1 (get-arg1 e2))
	       (get-arg2 e2)))

	((number? e2)			;x+2 -> 2+x
	 (sym+ e2 e1))

	((op-is? '+ e1)			;reorder (x+y)+z -> x+(y+z)
	 (sym+ (get-arg1 e1)
	       (sym+ (get-arg2 e1)
		     e2)))

	((equal? e1 e2)			;x+x -> 2*x
	 (sym* 2 e1))

	((and (op-is? '* e2)		;x+(3*x) -> 4*x
	     (equal? e1 (get-arg2 e2))
	     (number? (get-arg1 e2)))
	 (sym* (sym+ 1 (get-arg1 e2))
	       e1))

	((and (op-is? '* e1)		;(3*x)+x -> 4*x
	     (equal? (get-arg2 e1) e2)
	     (number? (get-arg1 e1)))
	 (sym* (sym+ 1 (get-arg1 e1))
	       e2))

	((and (op-is? '* e1)		;(2*x)+(3*x) -> 5*x
	      (op-is? '* e2)
	      (number? (get-arg1 e1))
	      (number? (get-arg1 e2))
	      (equal? (get-arg2 e1) (get-arg2 e2)))
	 (sym* (sym+ (get-arg1 e1) (get-arg1 e2))
	       (get-arg2 e1)))

	((and (symbol? e1)		;lexographic order b+(a+x) ->  a+(b+x)
	      (op-is? '+ e2)
	      (symbol? (get-arg1 e2))
	      (symbol-before (get-arg1 e2) e1))
	 (sym+ (get-arg1 e2)
	       (sym+ e1 (get-arg2 e2))))

	((and (symbol? e1)		;lexographic reorder b+a -> a+b
	      (symbol? e2)
	      (symbol-before e2 e1))
	 (sym+ e2 e1))
	;; ^^^^^^^^^^^^^^^^

	(else
	 (make-expr '+ e1 e2))))

;;; ELIMINATE THE HATED SUBTRACTION!

(define (sym- e1 e2)
  (sym+ e1 (sym* -1 e2)))

(define (sym* e1 e2)
  (cond ((equal? e1 0)			;0*x -> 0
	 0)
	((equal? e1 1)			;1*x -> x
	 e2)
	((and (number? e1)		;2*3 -> 6
	      (number? e2))
	 (* e1 e2))
	((equal? e2 0)			;x*0 -> x
	 0)
	((equal? e2 1)			;x*1 -> x
	 e1)


	;; vvvvvvvvvvvvvvvv
	((and (number? e1)		;2*(3*x) -> 6*x
	      (op-is? '* e2)
	      (number? (get-arg1 e2)))
	 (sym* (* e1 (get-arg1 e2))
	       (get-arg2 e2)))

	((and (op-is? '* e2)		;x*(3*y) -> 3*(x*y)
	      (number? (get-arg1 e2)))
	 (sym* (get-arg1 e2)
	       (sym* e1 (get-arg2 e2))))

	((number? e2)			;x*6 -> 6*x
	 (sym* e2 e1))

	((op-is? '* e1)			;reorder (x*y)*z -> x*(y*z)
	 (sym* (get-arg1 e1)
	       (sym* (get-arg2 e1)
		     e2)))

	((op-is? '/ e1)			;(x/y)*z -> (x*z)/y
	 (sym/ (sym* (get-arg1 e1) e2)
	       (get-arg2 e1)))

	((op-is? '/ e2)			;x*(y/z) -> (x*y)/z
	 (sym/ (sym* (get-arg1 e2) e1)
	       (get-arg2 e2)))

	((op-is? '+ e2)			;x*(y+z) -> x*y + x*z
	 (sym+ (sym* e1 (get-arg1 e2))	;(this one is debatable)
	       (sym* e1 (get-arg2 e2))))

	((op-is? '+ e1)			;(x+y)*z -> x*z + y*z
	 (sym+ (sym* (get-arg1 e1) e2)
	       (sym* (get-arg2 e1) e2)))

	((and (symbol? e1)		;lexographic order b*(a*x) ->  a*(b*x)
	      (op-is? '* e2)
	      (symbol? (get-arg1 e2))
	      (symbol-before (get-arg1 e2) e1))
	 (sym* (get-arg1 e2)
	       (sym* e1 (get-arg2 e2))))

	((and (symbol? e1)		;lexographic reorder b*a -> a*b
	      (symbol? e2)
	      (symbol-before e2 e1))
	 (sym* e2 e1))
	;; ^^^^^^^^^^^^^^^^

	(else
	 (make-expr '* e1 e2))))

(define (sym/ e1 e2)
  (cond	((equal? e2 1)			;x/1 -> x
	 e1)
	((and (equal? e1 0)		;0/x -> 0
	      (not (equal? e2 0)))
	 0)
	((and (number? e1)		;2/3 -> 0.66666
	      (number? e2)
	      (not (equal? e2 0)))
	 (/ e1 e2))
	((and (equal? e1 e2)		;x/x -> 1
	      (not (equal? e2 0)))
	 1)


	;; vvvvvvvvvvvvvvvv
	((op-is? '/ e1)			;(x/y)/z -> (x*z)/y
	 (sym/ (get-arg1 e1)
	       (sym* (get-arg2 e1) e2)))

	((op-is? '/ e2)			;x*(y/z) -> (x*y)/z
	 (sym/ (sym* e1 (get-arg2 e2))
	       (get-arg1 e2)))

	((and (op-is? '* e1)		;(3*x)/4 -> 0.75*x
	      (number? (get-arg1 e1))
	      (number? e2))
	 (sym* (/ (get-arg1 e1) e2)
	       (get-arg1 e1)))

	((and (op-is? '* e2)		;3/(4*x) -> 0.75/x
	      (number? (get-arg1 e2))
	      (number? e1))
	 (sym/ (/ e1 (get-arg1 e2))
	       (get-arg2 e2)))

	((and (op-is? '* e1)		;(3*x)/(4*y) -> 0.75*(x/y)
	      (op-is? '* e2)
	      (number? (get-arg1 e1))
	      (number? (get-arg1 e2)))
	 (sym* (/ (get-arg1 e1) (get-arg1 e2))
	       (sym/ (get-arg2 e1) (get-arg2 e2))))
	;; ^^^^^^^^^^^^^^^^

	(else (make-expr '/ e1 e2))))


(define (simplify e)
  (if (not (pair? e))
      e
      ((let ((op (get-op e)))
	 (cond ((equal? op '+) sym+)
	       ((equal? op '-) sym-)
	       ((equal? op '*) sym*)
	       ((equal? op '/) sym/)))
	 (simplify (cadr e))
	 (simplify (caddr e)))))

;;; Surprisingly simple:

(define (expr1 e)
  (simplify e))

;;; Alternative definition:

(define (expr1-alternate e)
  (if (number? e)
      e
      (let ((op (get-op e)))
	((cond ((equal? op '+) +)
	       ((equal? op '-) -)
	       ((equal? op '*) *)
	       ((equal? op '/) /))
	 (expr1-alternate (get-arg1 e))
	 (expr1-alternate (get-arg2 e))))))
	


(define (expr2 e env)
  (simplify (substitute e env)))

(define (substitute e env)
  (let ((x (assoc e env)))
    (cond (x (cadr x))
	  ((pair? e)
	   (apply make-expr
		  (get-op e)
		  (map (lambda (x) (substitute x env))
		       (cdr e))))
	  (else e))))