D.scm

(define (D y x)
  (cond ((constant? y x) 0)
        ((identity? y x) 1)
        ((sum? y)
         (let ((f (augend y)) (g (addend y)))
           (make-sum (D f x) (D g x))))
        ((product? y)
         (let ((f (multiplier y)) (g (multiplicand y)))
           (make-sum
             (make-product (D f x) g)
             (make-product f (D g x)))))))

(define (constant? expression variable)
  (or (number? expression)
      (and (symbol? expression)
           (not (equal? expression variable)))))

(define (identity? expression variable)
  (equal? expression variable))

; sum

(define (sum? expression)
  (and (list? expression)
       (equal? (car expression) '+)))

(define (augend expression)
  (apply make-sum (drop-right (cdr expression) 1)))

(define (addend expression) (last expression))

(define (make-sum . terms)
  (let ((simplified-terms
          (combine-like-terms
            (delete
              0
              (rewrite
                number?
                (lambda (numbers) (apply + numbers))
                (rewrite
                  sum?
                  (lambda (sums) (append-map cdr sums))
                  (map make-expression terms)))))))
    (cond ((null? simplified-terms) 0)
          ((null? (cdr simplified-terms))
           (car simplified-terms))
          (else `(+ ,@simplified-terms)))))

(define (combine-like-terms terms)
  (if (< (length terms) 2)
    terms
    (rewrite
      (lambda (term)
        (or (equal? term 'x)
            (and (product? term) (member 'x term))))
      (lambda (variable-terms)
        (hash-table-map
          (fold-left
            (lambda (coefficient-table term)
              (receive
                (constants variables)
                (constants-variables term)
                (hash-table-update!/default
                  coefficient-table
                  variables
                  (lambda (value) `(,@value ,@constants))
                  '())
                coefficient-table))
            (make-hash-table)
            variable-terms)
          (lambda (variables constants)
            (apply make-product
                   (apply make-sum constants)
                   variables))))
      terms)))

(define (constants-variables term)
  (receive
    (variables constants)
    (partition
      (lambda (factor) (equal? factor 'x))
      (if (product? term) (cdr term) `(,term)))
    (values
      (if (null? constants) '(1) constants)
      variables)))

(define (hash-table-map hash-table procedure)
  (map (lambda (entry)
         (procedure (car entry) (cdr entry)))
       (hash-table->alist hash-table)))

; product

(define (product? expression)
  (and (list? expression)
       (equal? (car expression) '*)))

(define (multiplier expression)
  (apply make-product
         (drop-right (cdr expression) 1)))

(define (multiplicand expression)
  (last expression))

(define (make-product . factors)
  (let ((simplified-factors
          (delete
            1
            (rewrite
              number?
              (lambda (numbers) (apply * numbers))
              (rewrite
                product?
                (lambda (products) (append-map cdr products))
                (map make-expression factors))))))
    (cond ((null? simplified-factors) 1)
          ((null? (cdr simplified-factors))
           (car simplified-factors))
          ((member 0 simplified-factors) 0)
          (else `(* ,@simplified-factors)))))

; auxiliaries

(define (make-expression expression)
  (cond ((sum? expression)
         (apply make-sum (cdr expression)))
        ((product? expression)
         (apply make-product (cdr expression)))
        (else expression)))

(define (rewrite pattern substitution terms)
  (receive
    (matches nonmatches)
    (partition pattern terms)
    (if (null? matches)
      nonmatches
      (let ((result (substitution matches)))
        `(,@nonmatches
          ,@(if (list? result) result `(,result)))))))

(display (D '(* x x) 'x))

(newline)