(define (derivative f)
 (lambda (x)
  (let-struct bundle (primal tangent)
   (define (dual-number x x-prime)
    (if (zero? x-prime) x (make-bundle x x-prime)))

   (define (primal p) (if (bundle? p) (bundle-primal p) p))

   (define (perturbation p) (if (bundle? p) (bundle-tangent p) 0))

   (define (raise-alpha->alpha f df/dx)
    (let ((* *))
     (lambda (p)
      (dual-number
       (f (primal p)) (* (df/dx (primal p)) (perturbation p))))))

   (define (raise-alpha*alpha->alpha f df/dx1 df/dx2)
    (let ((+ +) (* *))
     (lambda (p1 p2)
      (dual-number
       (f (primal p1) (primal p2))
       (+ (* (df/dx1 (primal p1) (primal p2)) (perturbation p1))
	  (* (df/dx2 (primal p1) (primal p2)) (perturbation p2)))))))

   (define (raise-alpha^n->boolean f) (lambda ps (apply f (map primal ps))))

   (fluid-let ((+ (raise-alpha*alpha->alpha
		   + (lambda (x1 x2) 1) (lambda (x1 x2) 1)))
	       (- (raise-alpha*alpha->alpha
		   - (lambda (x1 x2) 1) (lambda (x1 x2) -1)))
	       (* (raise-alpha*alpha->alpha
		   * (lambda (x1 x2) x2) (lambda (x1 x2) x1)))
	       (/ (let ((- -) (* *) (/ /))
		   (raise-alpha*alpha->alpha
		    /
		    (lambda (x1 x2) (/ 1 x2))
		    (lambda (x1 x2) (- 0 (/ x1 (* x2 x2)))))))
	       (sqrt (let ((* *) (/ /) (sqrt sqrt))
		      (raise-alpha->alpha
		       sqrt (lambda (x) (/ 1 (* 2 (sqrt x)))))))
	       (exp (raise-alpha->alpha exp exp))
	       (log (let ((/ /))
		     (raise-alpha->alpha log (lambda (x) (/ 1 x)))))
	       (sin (raise-alpha->alpha sin cos))
	       (cos (let ((- -) (sin sin))
		     (raise-alpha->alpha cos (lambda (x) (- 0 (sin x))))))
	       (atan (let ((+ +) (- -) (* *) (/ /))
		      (raise-alpha*alpha->alpha
		       atan
		       (lambda (x1 x2)
			(/ (- 0 x2) (+ (* x1 x1) (* x2 x2))))
		       (lambda (x1 x2) (/ x1 (+ (* x1 x1) (* x2 x2)))))))
	       (= (raise-alpha^n->boolean =))
	       (< (raise-alpha^n->boolean <))
	       (> (raise-alpha^n->boolean >))
	       (<= (raise-alpha^n->boolean <=))
	       (>= (raise-alpha^n->boolean >=))
	       (zero? (raise-alpha^n->boolean zero?))
	       (positive? (raise-alpha^n->boolean positive?))
	       (negative? (raise-alpha^n->boolean negative?))
	       (real? (raise-alpha^n->boolean real?)))
    (perturbation (f (dual-number x 1)))))))