;;; These handle expressions with any number of arguments to +, *, -

(define (diff expr var)
  (cond ((equal? expr var) 1)
	((pair? expr)
	 (let ((f (car expr))
	       (a (cdr expr))
	       (da (map (lambda (x) (diff x var)) (cdr expr))))
	   (cond ((equal? f '+) (apply sym+ da))
		 ((equal? f '-) (apply sym- da))
		 ((equal? f '*) (run* a da))
		 ((equal? f '/) (sym/ (sym- (sym* (car da) (cadr a))
					    (sym* (car a) (cadr da)))
				      (sym* (cadr a) (cadr a))))
		 ((equal? f 'exp) (sym* (car da) expr))
		 ((equal? f 'log) (sym/ (car da) (car a)))
		 ((equal? f 'sin) (sym* (car da) (sym-cos (car a))))
		 ((equal? f 'cos) (sym* (car da) (sym- (sym-sin (car a)))))
		 (else (error "DIFF: unknown function:" f)))))
	(else 0)))


(define (sym-cos expr)
  (cond ((number? expr) (cos expr))
	((and (pair? expr)
	      (equal? (car expr) '*)
	      (number? (cadr expr))
	      (< (cadr expr) 0))
	 (sym-cos (sym* -1 expr)))
	(else (list 'cos expr))))

(define (sym-sin expr)
  (cond ((number? expr) (sin expr))
	((and (pair? expr)
	      (equal? (car expr) '*)
	      (number? (cadr expr))
	      (< (cadr expr) 0))
	 (sym- (sym-sin (sym* -1 expr))))
	(else (list 'sin expr))))

(define (run* lis dlis)
  (if (null? lis)
      0
      (sym+ (apply sym* (car dlis) (cdr lis))
	    (sym* (car lis) (run* (cdr lis) (cdr dlis))))))

(define (sym- x . others)
  (if (null? others)
      (sym* -1 x)
      (apply sym+ x (map sym- others))))

(define (sym+ . args)
  (let ((args (apply append (map (lambda (x)
				   (if (and (pair? x) (equal? (car x) '+))
				       (cdr x)
				       (list x)))
				 args))))
    (let ((args (crunch-terms args)))
      (cond ((null? args) 0)
	    ((null? (cdr args)) (car args))
	    (else (cons '+ args))))))


(define (crunch-terms args)
  (cond ((null? args) '())
	((null? (cdr args)) (if (equal? args '(0)) '() args))
	(else (let ((t (car args)))
		(let ((c (constant-factor t))
		      (a (non-constant-factor t)))
		  (if (= c 0)
		      (crunch-terms (cdr args))
		      (let ((x (honker-term c a (cdr args))))
			(if x
			    (crunch-terms x)
			    (cons (car args) (crunch-terms (cdr args)))))))))))

(define (honker-term c e args)
  (cond ((null? args) #f)
	((equal? e (non-constant-factor (car args)))
	 (cons (sym* (+ c (constant-factor (car args)))
		     e)
	       (cdr args)))
	(else (let ((r (honker-term c e (cdr args))))
		(and r (cons (car args) r))))))


(define (constant-factor expr)
  (cond ((and (pair? expr)
	      (equal? (car expr) '*)
	      (not (null? (cdr expr)))
	      (number? (cadr expr)))
	 (cadr expr))
	((number? expr) expr)
	(else 1)))

(define (non-constant-factor expr)
  (cond ((and (pair? expr)
	      (equal? (car expr) '*)
	      (not (null? (cdr expr)))
	      (number? (cadr expr)))
	 (apply sym* (cddr expr)))
	((number? expr) 1)
	(else expr)))


(define (sym* . args)
  (let ((args (apply append (map (lambda (x)
				   (if (and (pair? x) (equal? (car x) '*))
				       (cdr x)
				       (list x)))
				 args))))
    (let ((args (map (lambda (x) (if (and (pair? x)
					  (equal? (car x) '/))
				     (cadr x)
				     x))
		     args))
	  (denoms (apply append (map (lambda (x) (if (and (pair? x)
							  (equal? (car x) '/))
						     (list (caddr x))
						     '()))
				     args))))
      (let ((num-prod (apply * (map (lambda (x) (if (number? x) x 1)) args)))
	    (non-nums (apply append (map (lambda (x)
					   (if (number? x) '() (list x)))
					 args))))
	(let ((args (cond ((= num-prod 0) '(0))
			  ((= num-prod 1) non-nums)
			  (else (cons num-prod non-nums)))))

	  (let ((top (cond ((null? args) 1)
			   ((null? (cdr args)) (car args))
			   (else (cons '* args)))))
	    (if (null? denoms) top (sym/ top (apply sym* denoms)))))))))

(define (sym/ a b)
  (cond ((and (number? a) (number? b) (not (= b 0)))
	 (/ a b))
	((and (equal? a 0) (not (= b 0)))
	 0)
	((equal? b 1)
	 a)
	((and (pair? a)
	      (equal? (car a) '/))
	 (sym/ (cadr a)
	       (sym* (caddr a) b)))
	((and (pair? b)
	      (equal? (car b) '/))
	 (sym/ (sym* a (caddr b))
	       (cadr b)))
	(else (list '/ a b))))

(define (simplify expr)
  (cond ((not (pair? expr)) expr)
	(else (let ((sub (map simplify (cdr expr)))
		    (op (car expr)))
		(apply (cond ((equal? op '+) sym+)
			     ((equal? op '-) sym-)
			     ((equal? op '*) sym*)
			     ((equal? op '/) sym/)

			     ((equal? op 'sin) sym-sin)
			     ((equal? op 'cos) sym-cos)

			     (else (lambda (. args) (cons op args))))
		       sub)))))