sicp-2-3-2-symbolic-differentiation

#lang racket

(define (deriv expr var)
  (cond [(number? expr) 0]
        [(variable? expr)
         (if (same-variable? expr var) 1 0)]
        [(sum? expr)
         (make-sum (deriv (addend expr) var)
                   (deriv (augend expr) var))]
        [(product? expr)
         (make-sum (make-product (multiplier expr)
                                 (deriv (multiplicand expr) var))
                   (make-product (deriv (multiplier expr) var)
                                 (multiplicand expr)))]
        [(exponentiation? expr)
         (make-product (exponent expr)
                       (make-product (make-exponentiation (base expr)
                                                          (sub1 (exponent expr)))
                                     (deriv (base expr) var)))]
        [else (error "unknown expression type -- DERIV" expr)]))

(define (variable? x) (symbol? x))
(define (same-variable? v1 v2)
  (and (variable? v1) (variable? v2) (eq? v1 v2)))

(define (=number? expr num)
  (and (number? expr) (= expr num)))

;; This file contains four different representations for sums and products.  The
;; original one below, another in 2.57, and two more in 2.58.  Only one can be
;; commented out at a time in order for the file to load and for deriv to work.

;; (define (sum? x) (and (list? x) (eq? (first x) '+)))
;; (define (addend s) (second s))
;; (define (augend s) (third s))

;; (define (make-sum a1 a2)
  ;; (cond [(=number? a1 0) a2]
        ;; [(=number? a2 0) a1]
        ;; [(and (number? a1) (number? a2)) (+ a1 a2)]
        ;; [else (list '+ a1 a2)]))

;; (define (product? x) (and (list? x) (eq? (first x) '*)))
;; (define (multiplier p) (second p))
;; (define (multiplicand p) (third p))

;; (define (make-product m1 m2)
  ;; (cond [(or (=number? m1 0) (=number? m2 0)) 0]
        ;; [(=number? m1 1) m2]
        ;; [(=number? m2 1) m1]
        ;; [(and (number? m1) (number? m2)) (* m1 m2)]
        ;; [else (list '* m1 m2)]))

;;;;;;;;;;
;; 2.56 ;;
;;;;;;;;;;

;; Define a constructor and selectors for exponentiation and add an exponentiation
;; rule to the deriv procedure above.

(define (exponentiation? x) (and (list? x) (eq? (first x) '**)))
(define (base e) (second e))
(define (exponent e) (third e))

(define (make-exponentiation b p)
  (cond [(=number? p 0) 1]
        [(=number? p 1) b]
        [else (list '** b p)]))

(deriv (make-exponentiation (list '* 'x 'y) 2) 'x)
;; '(* 2 (* (* x y) y))

;;;;;;;;;;
;; 2.57 ;;
;;;;;;;;;;

;; Define new constructors and selectors for sums and products that can take more
;; than one term.

(define (sum? x) (and (list? x) (eq? (first x) '+)))
(define (addend s) (second s))
(define (augend s)
  (define rst (rest (rest s)))
  (if (= (length  rst) 1)
    (first rst)
    (apply make-sum rst)))

(define (make-sum a1 a2 . more)
  (define summands (append (list a1 a2) more))
  (define numbers (filter number? summands))
  (define not-numbers (filter-not number? summands))
  (define sum-numbers (apply + numbers))
  (cond [(empty? not-numbers) sum-numbers]
        [(= (length not-numbers) 1)
         (define not-number (first not-numbers))
         (if (zero? sum-numbers)
           not-number
           (list '+ sum-numbers not-number))]
        [else
          (if (zero? sum-numbers)
            (cons '+ not-numbers)
            (append (list '+ sum-numbers) not-numbers))]))

(define (product? x) (and (list? x) (eq? (first x) '*)))
(define (multiplier p) (second p))
(define (multiplicand p)
  (define rst (rest (rest p)))
  (if (= (length rst) 1)
    (first rst)
    (apply make-product rst)))

(define (make-product m1 m2 . more)
  (define factors (append (list m1 m2) more))
  (define numbers (filter number? factors))
  (define not-numbers (filter-not number? factors))
  (define product-numbers (apply * numbers))
  (cond [(empty? not-numbers) product-numbers]
        [(zero? product-numbers) 0]
        [(= (length not-numbers) 1)
         (define not-number (first not-numbers))
         (if (= product-numbers 1)
           not-number
           (list '* product-numbers not-number))]
        [else
          (if (= product-numbers 1)
            (cons '* not-numbers)
            (append (list '* product-numbers) not-numbers))]))

(deriv '(* x y (+ x 3)) 'x)
;; '(+ (* x y) (* y (+ x 3)))

(deriv '(+ x y (** z 2)) 'z)
;; '(* 2 z)

(deriv '(** (+ x y 3) 2) 'y)
;; '(* 2 (+ x y 3))

(deriv '(* (+ x y 3) 2) 'y)
;; 2

;;;;;;;;;;
;; 2.58 ;;
;;;;;;;;;;

;; a.  Define new constructors and selectors for sums and products that use infix
;; notation, take exactly two terms, and are fully parenthesized.

;; (define (sum? x)
  ;; (and (list? x)
       ;; (= (length x) 3)
       ;; (eq? (second x) '+)))
;; (define (addend s) (first s))
;; (define (augend s) (third s))

;; (define (make-sum a1 a2)
  ;; (cond [(=number? a1 0) a2]
        ;; [(=number? a2 0) a1]
        ;; [(and (number? a1) (number? a2)) (+ a1 a2)]
        ;; [else (list a1 '+ a2)]))

;; (define (product? x)
  ;; (and (list? x)
       ;; (= (length x) 3)
       ;; (eq? (second x) '*)))
;; (define (multiplier p) (first p))
;; (define (multiplicand p) (third p))

;; (define (make-product m1 m2)
  ;; (cond [(or (=number? m1 0) (=number? m2 0)) 0]
        ;; [(=number? m1 1) m2]
        ;; [(=number? m2 1) m1]
        ;; [(and (number? m1) (number? m2)) (* m1 m2)]
        ;; [else (list m1 '* m2)]))

;; (deriv '(x + (3 * (x + (y + 2)))) 'y)
;; ;; 3

;; (deriv '(x * (y + (2 * z))) 'x)
;; ;; '(y + (2 * z))

;; (deriv '(x * (y + (2 * z))) 'y)
;; ;; 'x

;; (deriv '(x * (y + (2 * z))) 'z)
;; ;; '(x * 2)

;; b.  Define new constructors and selectors for sums and products that use infix
;; notation, can take more than two terms, and may not be fully parenthesized.

;; (define (not-plus? x)
  ;; (not (equal? x '+)))
;; (define (sum? x)
  ;; (and (list? x) (member '+ x) (not-plus? (last x))))
;; (define (addend s)
  ;; (define a1 (takef s not-plus?))
  ;; (if (= (length a1) 1) (first a1) a1))
;; (define (augend s)
  ;; (define a2 (rest (dropf s not-plus?)))
  ;; (if (= (length a2) 1) (first a2) a2))

;; (define (make-sum a1 a2)
  ;; (cond [(=number? a1 0) a2]
        ;; [(=number? a2 0) a1]
        ;; [(and (number? a1) (number? a2)) (+ a1 a2)]
        ;; [else (list a1 '+ a2)]))

;; (define (not-times? x)
  ;; (not (equal? x '*)))
;; (define (product? x)
  ;; (and (list? x)
       ;; (not (member '+ x)) ; multiplication binds tighter than addition
       ;; (member '* x)
       ;; (not-times? (last x))))
;; (define (multiplier p)
  ;; (define m1 (takef p not-times?))
  ;; (if (= (length m1) 1) (first m1) m1))
;; (define (multiplicand p)
  ;; (define m2 (rest (dropf p not-times?)))
  ;; (if (= (length m2) 1) (first m2) m2))

;; (define (make-product m1 m2)
  ;; (cond [(or (=number? m1 0) (=number? m2 0)) 0]
        ;; [(=number? m1 1) m2]
        ;; [(=number? m2 1) m1]
        ;; [(and (number? m1) (number? m2)) (* m1 m2)]
        ;; [else (list m1 '* m2)]))

;; (deriv '(x + 3 * (x + y + 2)) 'x)
;; ;; 4

;; (deriv '(x + 3 * (x + y + 2)) 'y)
;; ;; 3

;; (deriv '(x * (y + 2 * z)) 'x)
;; ;; '(y + 2 * z)

;; (deriv '(x * (y + 2 * z)) 'y)
;; ;; 'x

;; (deriv '(x * (y + 2 * z)) 'z)
;; ;; '(x * 2)