(define (l) (load "pattern.scm.txt"))

(define (atom? x) (not (pair? x)))

(define (evaluate form dict)
  (if (atom? form)
    (lookup form dict)
    (apply
      (eval 
        (lookup (car form) dict)
        user-initial-environment
      )
      (map
        (lambda (v) (lookup v dict))
        (cdr form)
      )
    )
  )
)


(define (instantiate skeleton dict)
  (define (loop s)
    (cond 
      ((atom? s) s)
      ((skeleton-evaluation? s)
       (evaluate (eval-exp s) dict))
      (else 
        (cons 
          (loop (car s))
          (loop (cdr s))
        )
      )
    )
  )
  (loop skeleton)
)

(define (variable-name pat) (cadr pat))
(define (eval-exp skel-part) (cadr skel-part))

(define (arbitrary-constant? pat)
  (and 
    (pair? pat)
    (eq? (car pat) '?c)
  )
)
(define (arbitrary-variable? pat)
  (and 
    (pair? pat)
    (eq? (car pat) '?v)
  )
)
(define (arbitrary-expression? pat)
  (and 
    (pair? pat)
    (eq? (car pat) '?)
  )
)
(define (skeleton-evaluation? pat)
  (and 
    (pair? pat)
    (eq? (car pat) ':)
  )
)


(define (constant? exp)
  (and (atom? exp) (number? exp))
)
(define (variable? exp)
  (and (atom? exp) (not (number? exp)))
)


(define (dict-is-failure? dict) 
  (if (atom? dict)
    (eq? dict 'failed)
    (eq? (car dict) 'failed)
  )
)

(define (match pat exp dict)
  (cond
    ((dict-is-failure? dict) dict)
    ((atom? pat) 
     (if (and (atom? exp) (eq? pat exp))
       dict
       (list 'failed 'atomic 'pattern pat 'not 'matched 'expr exp)
     )
    )

    ((arbitrary-constant? pat)
     (if (constant? exp)
       (extend-dictionary pat exp dict)
       (list 'failed 'expr exp 'not 'constant)
     )
    )

    ((arbitrary-variable? pat)
     (if (variable? exp)
       (extend-dictionary pat exp dict)
       (list 'failed 'expr exp 'not 'var)
     )
    )

    ((arbitrary-expression? pat)
     (extend-dictionary pat exp dict))
     
    ((atom? exp) (list 'failed 'pattern pat 'not 'atom 'but 'expr exp 'is))

    (else
      (match
        (cdr pat)
        (cdr exp)
        (match
          (car pat)
          (car exp)
          dict
        )
      )
    )
  )
)


(define (empty-dictionary) '())


(define (extend-dictionary pat dat dict)
  (let 
    (
      (name (variable-name pat))
    )
    (let 
      (
        (v (assq name dict))
      )
      (cond
        ((null? v)               (cons (list name dat) dict))
        ((equal? (cadr v) dat)   dict)
        (else                    (list 
                                    'failed 'pattern 'var name 
                                    'had 'old 'value (cadr v) 
                                    'not 'matching dat
                                 )
        )
      )
    )
  )
)

(define (lookup var dict)
  (let
    (
      (v   (assq var dict))
    )
    (if (null? v)
      var
      (cadr v)
    )
  )
)


(define (make-rule pat skel) (list pat skel))
(define (pattern rule) (car rule))
(define (skeleton rule) (cadr rule))

(define (empty-ruleset) '())
(define (first-rule ruleset) (car ruleset))
(define (rest-of-rules ruleset) (cdr ruleset))


(define (compound? expr) (not (atom? expr)))

(define (simplifier the-rules)

  (define (simplify-exp exp)
    (try-rules 
      (if (compound? exp)
        (simplify-parts exp)
        exp
      )
    )
  )

  (define (simplify-parts exp)
    (if (null? exp)
      '()
      (cons
        (simplify-exp (car exp))
        (simplify-parts (cdr exp))
      )
    )
  )

  (define (try-rules exp)

    (define (scan rules)
      (if (null? rules)
        exp
        (let
          (
            (dict 
              (match 
                (pattern (first-rule rules))
                exp
                (empty-dictionary)
              )
            )
          )
          (if (dict-is-failure? dict)
            (scan (rest-of-rules rules))
            (simplify-exp
              (instantiate
                (skeleton (first-rule rules))
                dict
              )
            )
          )
        )
      )
    )
    
    (scan the-rules)
  )

  simplify-exp
)


(define deriv-rules
  '(
     ( (+ (?c x) (?c y))              (: (+ x y) )         )
     ( (- (?c x) (?c y))              (: (- x y) )         )
     ( (* (?c x) (?c y))              (: (* x y) )         )
     ( (/ (?c x) (?c y))              (: (/ x y) )         )

     ( (+ (? x) (?c y))            (+ (: y) (: x))         )
     ( (* (? x) (?c y))            (* (: y) (: x))         )

     ( (* (?c x) (* (?c y) (? z)))   (* (: (* x y)) (: z)) )
     ( (* (?c x) (/ (?c y) (? z)))   (/ (: (* x y)) (: z)) )
     ( (+ (?c x) (+ (?c y) (? z)))   (+ (: (+ x y)) (: z)) )
     ( (+ (?c x) (- (?c y) (? z)))   (- (: (+ x y)) (: z)) )

     ( (** (? x) 0)                         1              )
     ( (** (? x) 1)                       (: x)            )

     ( (+ (? x) (? x))                   (* 2 (: x))       )
     ( (* (? x) (? x))                   (** (: x) 2)      )

     ( (+ 0 (? x))                        (: x)            )
     ( (+ (? x) 0)                        (: x)            )

     ( (* 0 (? x))                         0               )
     ( (* (? x) 0)                         0               )

     ( (* 1 (? x))                        (: x)            )
     ( (* (? x) 1)                        (: x)            )

     ( (dd (?c c) (? v))                   0               )
     ( (dd (?v v) (? v))                   1               )
     ( (dd (?v u) (? v))                   0               )
     
     ( (dd (+ (? x1) (? x2)) (? v))
                                 (+ (dd (: x1) (: v))
                                    (dd (: x2) (: v)))     )
     
     ( (dd (* (? x1) (? x2)) (? v))
                                    (+ (* 
                                         (: x1)
                                         (dd (: x2) (: v))
                                       )
                                       (* 
                                         (dd (: x1) (: v))
                                         (: x2)
                                       )
                                    )
                                                          )
     
     ( (dd (** (? x) (?c n)) (? v))
                             (* (* (: n)
                                   (** (: x) (: (- n 1)))
                                )
                                (dd (: x) (: v))
                             )
     )

     ( (dd (sin (? x)) (? v))      (* (dd (: x) (: v)) (cos (: x)))  )
   )
)

(define qexp
 '(+
    (* a (* x x))
    (+
      (* b x)
      c
    )
  )
)

1