ikarus/benchmarks/new/r6rs-benchmarks/dderiv.ss

;;; DDERIV -- Table-driven symbolic derivation.

;;; Returns the wrong answer for quotients.
;;; Fortunately these aren't used in the benchmark.

(library (r6rs-benchmarks dderiv)
  (export main)
  (import (r6rs) (r6rs mutable-pairs) (r6rs-benchmarks))
    
  (define (lookup key table)
    (let loop ((x table))
      (if (null? x)
        #f
        (let ((pair (car x)))
          (if (eq? (car pair) key)
            pair
            (loop (cdr x)))))))
  
  (define properties '())
  
  (define (get key1 key2)
    (let ((x (lookup key1 properties)))
      (if x
        (let ((y (lookup key2 (cdr x))))
          (if y
            (cdr y)
            #f))
        #f)))
  
  (define (put key1 key2 val)
    (let ((x (lookup key1 properties)))
      (if x
        (let ((y (lookup key2 (cdr x))))
          (if y
            (set-cdr! y val)
            (set-cdr! x (cons (cons key2 val) (cdr x)))))
        (set! properties
          (cons (list key1 (cons key2 val)) properties)))))
  
  (define (my+dderiv a)
    (cons '+
          (map dderiv (cdr a))))
  
  (define (my-dderiv a)
    (cons '-
          (map dderiv (cdr a))))
  
  (define (*dderiv a)
    (list '*
           a
           (cons '+
                 (map (lambda (a) (list '/ (dderiv a) a)) (cdr a)))))
  
  (define (/dderiv a)
    (list '-
          (list '/
                (dderiv (cadr a))
                (caddr a))
          (list '/
                (cadr a)
                (list '*
                      (caddr a)
                      (caddr a)
                      (dderiv (caddr a))))))
  
  
  (define (dderiv a)
    (if (not (pair? a))
      (if (eq? a 'x) 1 0)
      (let ((f (get (car a) 'dderiv)))
        (if f
          (f a)
          (fatal-error "No derivation method available")))))
  
  (define (main . args)
    (run-benchmark
      "dderiv"
      dderiv-iters
      (lambda (result)
        (equal? result
                '(+ (* (* 3 x x) (+ (/ 0 3) (/ 1 x) (/ 1 x)))
                    (* (* a x x) (+ (/ 0 a) (/ 1 x) (/ 1 x)))
                    (* (* b x) (+ (/ 0 b) (/ 1 x)))
                    0)))
      (lambda (a) (lambda () (dderiv a)))
      '(+ (* 3 x x) (* a x x) (* b x) 5)))
  
  
  (put '+ 'dderiv my+dderiv)
  (put '- 'dderiv my-dderiv)
  (put '* 'dderiv *dderiv)
  (put '/ 'dderiv /dderiv))