#lang sicp

(define (variable? x) (symbol? x))

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

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

(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 (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))))

(define (sum? x)
  (and (pair? x) (eq? (cadr x) '+)))

(define (addend s) (car s))

;; Special case of multiplication distributing across addition.  It
;; should be possible to rewrite augend and/or multiplicand to deal
;; with this case

(define (augend s)
  (if (product? (cddr s))
      (cddr s)
      (caddr s)))

(define (product? x)
  (and (pair? x) (eq? (cadr x) '*)))

(define (multiplier p) (car p))

(define (multiplicand p) (caddr p))

;; 2.73: (a) The logic to decide how to derive expressions was moved from the derive
;; procedure into the table.  It isn't possible to use number and variable in the data
;; dispatch because they don't have a tag that could be used to distinguish them.

;; (b)

;;;-----------
;;;from section 3.3.3 for section 2.4.3
;;; to support operation/type table for data-directed dispatch

(define (assoc key records)
  (cond ((null? records) false)
        ((equal? key (caar records)) (car records))
        (else (assoc key (cdr records)))))

(define (make-table)
  (let ((local-table (list '*table*)))
    (define (lookup key-1 key-2)
      (let ((subtable (assoc key-1 (cdr local-table))))
        (if subtable
            (let ((record (assoc key-2 (cdr subtable))))
              (if record
                  (cdr record)
                  false))
            false)))
    (define (insert! key-1 key-2 value)
      (let ((subtable (assoc key-1 (cdr local-table))))
        (if subtable
            (let ((record (assoc key-2 (cdr subtable))))
              (if record
                  (set-cdr! record value)
                  (set-cdr! subtable
                            (cons (cons key-2 value)
                                  (cdr subtable)))))
            (set-cdr! local-table
                      (cons (list key-1
                                  (cons key-2 value))
                            (cdr local-table)))))
      'ok)    
    (define (dispatch m)
      (cond ((eq? m 'lookup-proc) lookup)
            ((eq? m 'insert-proc!) insert!)
            (else (error "Unknown operation -- TABLE" m))))
    dispatch))

(define operation-table (make-table))
(define get (operation-table 'lookup-proc))
(define put (operation-table 'insert-proc!))

;;;-----------

(define (deriv exp var)
   (cond ((number? exp) 0)
         ((variable? exp) (if (same-variable? exp var) 1 0))
         (else ((get 'deriv (operator exp)) (operands exp)
                                            var))))

(define (operator exp) (car exp))

(define (operands exp) (cdr exp))


(define (deriv-sum operands var)
  (cond ((null? operands) 0)
        ((null? (cdr operands)) (deriv (car operands) var))
        (else (make-sum (deriv (car operands) var)
                        (deriv (cadr operands) var)))))

(define (deriv-prod operands var)
  (cond ((null? operands) 1)
        ((null? (cdr operands)) (deriv (car operands) var))
        (else
         (let ((op1 (car operands))
               (op2 (cadr operands)))
           (make-sum (make-product op1 (deriv op2 var))
                     (make-product (deriv op1 var) op2))))))

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

(define (base e) (cadr e))
(define (exponent e) (caddr e))

(define (exponentiation? x) (and (pair? x) (eq? (car x) '**)))

(define (deriv-exp operands var)
  (let ((base (car operands))
        (exponent (cadr operands)))
    (make-product exponent
                  (make-product
                   (make-exponentiation base (- exponent 1))
                   (deriv base var)))))

(put 'deriv '+ deriv-sum)
(put 'deriv '* deriv-prod)
(put 'deriv '** deriv-exp)