(define op car)
(define args cdr)
(define first-arg cadr)
(define second-arg caddr)
(define other-args cddr)
(define (bisection func array)
(cons (filter func array) (filter (lambda (el) (not (func el))) array)))
(define (has-0 L)
(cond ((null? L) #f)
((and (number? (car L)) (= (car L) 0)) #t)
(else (has-0 (cdr L)))))
(define (constant? exp var)
(and (not (pair? exp))
(not (eq? exp var))))
(define (same-var? exp var)
(and (not (pair? exp))
(eq? exp var)))
(define (sum? exp)
(and (pair? exp)
(eq? (op exp) '+)))
(define (make-sum . a)
(let ((a (filter (lambda (n) (not (and (number? n) (= n 0)))) a)))
(cond ((null? (cdr a)) (car a))
(else
(let ((numbers (bisection number? a)))
(cond ((= 0 (length (cdr numbers)))
(apply + (car numbers)))
(else
(let ((sums (bisection sum? a)))
(cons '+ (append (reduce append '() (map args (car sums))) (cdr sums)))))))))))
(define (diff? exp)
(and (pair? exp)
(eq? (op exp) '-)))
(define (make-diff a1 a2)
(cond ((and (number? a1) (number? a2))
(- a1 a2))
((and (number? a1) (= a1 0))
(make-product -1 a2))
((and (number? a2) (= a2 0))
a1)
(else (list '- a1 a2))))
(define (product? exp)
(and (pair? exp)
(eq? (op exp) '*)))
(define (make-product . m)
(let ((m (filter (lambda (n) (not (and (number? n) (= n 1)))) m)))
(cond ((null? m) 1)
((null? (cdr m)) (car m))
((has-0 m) 0)
(else
(let ((numbers (bisection number? m)))
(cond ((= 0 (length (cdr numbers)))
(apply * (car numbers)))
(else
(let ((products (bisection product? m)))
(cons '* (append (reduce append '() (map args (car products))) (cdr products)))))))))))
(define (division? exp)
(and (pair? exp)
(eq? (car exp) '/)))
(define (make-division d1 d2)
(cond ((and (number? d2) (= d2 1)) d1)
((and (number? d2) (= d1 0)) 0)
(else (list '/ d1 d2))))
(define (func? exp)
(not (or (not (pair? exp))
(eq? (op exp) '+)
(eq? (op exp) '-)
(eq? (op exp) '*)
(eq? (op exp) '/))))
(define (make-func f1 f2 var)
(make-product (derive f2 var)
(cond ((eq? f1 'sin)
(list 'cos f2))
((eq? f1 'cos)
(make-product -1 (list 'sin f2)))
((eq? f1 'ln)
(make-division 1 f2))
((eq? f1 'sqr)
(make-product 2 f2)))))
(define (derive exp var)
(cond ((constant? exp var) 0)
((same-var? exp var) 1)
((sum? exp)
(apply make-sum (map (lambda (exp) (derive exp var)) (args exp))))
((diff? exp)
(make-diff (derive (first-arg exp) var)
(derive (second-arg exp) var)))
((product? exp)
(cond ((not (pair? (cddr exp)))
(make-sum (make-product (first-arg exp) (derive (second-arg exp) var))
(make-product (second-arg exp) (derive (first-arg exp) var))))
(else
(make-sum (make-product (first-arg exp) (derive (apply make-product (other-args exp)) var))
(make-product (apply make-product (other-args exp)) (derive (first-arg exp) var))))))
((division? exp)
(make-division (make-diff (make-product (derive (first-arg exp) var)
(second-arg exp))
(make-product (derive (second-arg exp) var)
(first-arg exp)))
(make-func 'sqr (make-product (first-arg exp) (second-arg exp)) var)))
((func? exp)
(make-func (op exp) (first-arg exp) var))))
; testing
(define foo
'(sin (ln (sqr x))))
(define bar
'(+ x x x x x))
(define baz
'(/ (* x x x) (ln x)))
(derive baz 'x)