(define primal cadr)

(define tangent caddr)

(define tag cadddr)

(define (bundle tag primal tangent) (list 'bundle primal tangent tag))

(define bundle?
 (let ((pair? pair?)) (lambda (x) (and (pair? x) (eq? (car x) 'bundle)))))

(define pair?
 (let ((pair? pair?)) (lambda (x) (and (pair? x) (not (bundle? x))))))

(define make-tag (let ((tag 0)) (lambda () (set! tag (+ tag 1)) tag)))

(define (e-t t x)
 (if (bundle? x) (if (= (tag x) t) (tangent x) (e-t t (primal x))) 0))

(define (remove-tag t x)
 (if (bundle? x)
     (if (= (tag x) t)
	 (primal x)
	 (bundle (tag x) (remove-tag t (primal x)) (remove-tag t (tangent x))))
     x))

(define (bring-tag-to-top t x) (bundle t (remove-tag t x) (e-t t x)))

(define (lift-real t x) (bundle t x 0))

(define (in? t x) (and (bundle? x) (or (= (tag x) t) (in? t (primal x)))))

(define (lift-real->real f df/dx)
 (letrec ((self (lambda (x)
		 (if (bundle? x)
		     (bundle (tag x)
			     (self (primal x))
			     (* (df/dx (primal x)) (tangent x)))
		     (f x)))))
  self))

(define (lift-real*real->real f df/dx1 df/dx2)
 (letrec ((self
	   (lambda (x1 x2)
	    (if (bundle? x1)
		(if (bundle? x2)
		    (if (= (tag x1) (tag x2))
			(bundle
			 (tag x1)
			 (self (primal x1) (primal x2))
			 (+ (* (df/dx1 (primal x1) (primal x2)) (tangent x1))
			    (* (df/dx2 (primal x1) (primal x2)) (tangent x2))))
			(cond ((in? (tag x1) x2)
			       (self x1 (bring-tag-to-top (tag x1) x2)))
			      ((in? (tag x2) x1)
			       (self (bring-tag-to-top (tag x2) x1) x2))
			      (else (self x1 (lift-real (tag x1) x2)))))
		    (self x1 (lift-real (tag x1) x2)))
		(if (bundle? x2)
		    (self (lift-real (tag x2) x1) x2)
		    (f x1 x2))))))
  self))

(define (lift-real->boolean f)
 (letrec ((self (lambda (x) (if (bundle? x) (self (primal x)) (f x)))))
  self))

(define (lift-real*real->boolean f)
 (letrec ((self (lambda (x1 x2)
		 (if (bundle? x1)
		     (if (bundle? x2)
			 (self (primal x1) (primal x2))
			 (self (primal x1) x2))
		     (if (bundle? x2) (self x1 (primal x2)) (f x1 x2))))))
  self))

(define + (lift-real*real->real + (lambda (x1 x2) 1) (lambda (x1 x2) 1)))

(define - (lift-real*real->real - (lambda (x1 x2) 1) (lambda (x1 x2) -1)))

(define * (lift-real*real->real * (lambda (x1 x2) x2) (lambda (x1 x2) x1)))

(define /
 (lift-real*real->real
  / (lambda (x1 x2) (/ 1 x2)) (lambda (x1 x2) (- 0 (/ x1 (* x2 x2))))))

(define sqrt (lift-real->real sqrt (lambda (x) (/ 1 (* 2 (sqrt x))))))

(define exp (lift-real->real exp (lambda (x) (exp x))))

(define log (lift-real->real log (lambda (x) (/ 1 x))))

(define sin (lift-real->real sin (lambda (x) (cos x))))

(define cos (lift-real->real cos (lambda (x) (- 0 (sin x)))))

(define atan (lift-real*real->real
	      atan
	      (lambda (x1 x2) (/ (- 0 x2) (+ (* x1 x1) (* x2 x2))))
	      (lambda (x1 x2) (/ x1 (+ (* x1 x1) (* x2 x2))))))

(define = (lift-real*real->boolean =))

(define < (lift-real*real->boolean <))

(define > (lift-real*real->boolean >))

(define <= (lift-real*real->boolean <=))

(define >= (lift-real*real->boolean >=))

(define zero? (lift-real->boolean zero?))

(define positive? (lift-real->boolean positive?))

(define negative? (lift-real->boolean negative?))

(define real? (lift-real->boolean real?))

(define (derivative f)
 (lambda (x) (let ((t (make-tag))) (e-t t (f (bundle t x 1))))))

((derivative (lambda (x) (* x ((derivative (lambda (y) (+ x y))) 1)))) 1)