(define (complex . l)
  (cond
    ((= (length l) 2) (+ (car l) (* 0+i (cadr l))))
    (else (car l))))
(define (quaternion . l)
  (cond
    ((= (length l) 2) `(quaternion ,(car l) ,(cadr l)))
    ((= (length l) 4) `(quaternion ,(complex (car l) (cadr l))
                                   ,(complex (caddr l) (cadddr l))))
    ((only-quaternion? (car l)) (car l))
    ((complex? (car l)) `(quaternion ,(car l) 0))))
(define (only-quaternion? x) (and (list? x) (eq? (car x) 'quaternion)))
(define (quaternion? x) (or (complex? x) (only-quaternion? x)))
(let ((o zero?))
  (eval `(define (zero? x)
           (and (,o (upper-part x)) (,o (lower-part x))))))
(let ((o real-part))
  (eval `(define (upper-part x)
           (if (only-quaternion? x) (cadr x) (,o x))))
  (eval `(define (real-part x)
           (if (only-quaternion? x) (,o (upper-part x)) (,o x))))
  (eval `(define (j-part x) (,o (lower-part x)))))
(let ((o imag-part))
  (eval `(define (lower-part x)
           (if (only-quaternion? x) (caddr x) (,o x))))
  (eval `(define (imag-part x)
           (if (only-quaternion? x) (,o (upper-part x)) (,o x))))
  (eval `(define (k-part x) (,o (lower-part x)))))
(define (quat-lower x)
  (if (and (only-quaternion? x) (zero? (lower-part x))) (upper-part x) x))
(define (conj x)
  (let f ((x x))
    (if (only-quaternion? x)
        (quaternion (f (upper-part x)) (- (lower-part x)))
        (complex (real-part x) (- (imag-part x))))))
(let ((o abs))
  (eval `(define (abs x)
           (cond
             ((and (quaternion? x) (not (real? x)))
              (sqrt (* x (conj x))))
             (else (,o x))))))
(let ((o =))
  (eval `(define (= . a)
           (define (q= a b)
             (and (,o (upper-part a) (upper-part b))
                  (,o (lower-part a) (lower-part b))))
           (cond
             ((null? a) (,o))
             ((null? (cdr a)) (,o (car a)))
             ((and (pair? (cdr a)) (pair? (cddr a)))
              (and (= (car a) (cadr a)) (apply = (car a) (cddr a))))
             ((or (only-quaternion? (car a)) (only-quaternion? (cadr a)))
              (q= (quaternion (car a)) (quaternion (cadr a))))
             (else (,o (car a) (cadr a)))))))
(let ((o +))
  (eval `(define (+ . a)
           (define (q+ a b)
             (quat-lower (quaternion (,o (upper-part a) (upper-part b))
                                     (,o (lower-part a) (lower-part b)))))
           (cond
             ((null? a) (,o))
             ((null? (cdr a)) (car a))
             ((and (pair? (cdr a)) (pair? (cddr a)))
              (apply + (+ (car a) (cadr a)) (cddr a)))
             ((or (only-quaternion? (car a)) (only-quaternion? (cadr a)))
              (q+ (quaternion (car a)) (quaternion (cadr a))))
             (else (,o (car a) (cadr a)))))))
(let ((o -))
  (eval `(define (- . a)
           (define (q- a b)
             (quat-lower (quaternion (,o (upper-part a) (upper-part b))
                                     (,o (lower-part a) (lower-part b)))))
           (cond
             ((null? a) (,o))
             ((null? (cdr a)) (if (only-quaternion? (car a)) (- 0 (car a))
                                  (,o (car a))))
             ((and (pair? (cdr a)) (pair? (cddr a)))
              (apply - (- (car a) (cadr a)) (cddr a)))
             ((or (only-quaternion? (car a)) (only-quaternion? (cadr a)))
              (q- (quaternion (car a)) (quaternion (cadr a))))
             (else (,o (car a) (cadr a)))))))
(let ((o *))
  (eval `(define (* . a)
           (define (q* a b)
             (quat-lower
              (quaternion (- (,o (upper-part a) (upper-part b))
                             (,o (lower-part b) (conj (lower-part a))))
                          (+ (,o (conj (upper-part a)) (lower-part b))
                             (,o (upper-part b) (lower-part a))))))
           (cond
             ((null? a) (,o))
             ((null? (cdr a)) (car a))
             ((and (pair? (cdr a)) (pair? (cddr a)))
              (apply * (* (car a) (cadr a)) (cddr a)))
             ((or (only-quaternion? (car a)) (only-quaternion? (cadr a)))
              (q* (quaternion (car a)) (quaternion (cadr a))))
             (else (,o (car a) (cadr a))))))
  (eval `(define (commutative* . a)
           (define (h* a b)
             (quat-lower (quaternion (- (,o (upper-part a) (upper-part b))
                                        (,o (lower-part a) (lower-part b)))
                                     (+ (,o (upper-part a) (lower-part b))
                                        (,o (lower-part a) (upper-part b))))))
           (cond
             ((null? a) (,o))
             ((null? (cdr a)) (car a))
             ((and (pair? (cdr a)) (pair? (cddr a)))
              (apply commutative* (commutative* (car a) (cadr a)) (cddr a)))
             ((or (only-quaternion? (car a)) (only-quaternion? (cadr a)))
              (h* (quaternion (car a)) (quaternion (cadr a))))
             (else (,o (car a) (cadr a)))))))
(let ((o /))
  (eval `(define (/ . a)
           (define (q/ a b)
             (let ((n (* a (conj b))) (d (* b (conj b))))
               (quat-lower (quaternion (,o (upper-part n) d)
                                       (,o (lower-part n) d)))))
           (cond
             ((null? a) (,o))
             ((null? (cdr a)) (if (only-quaternion? (car a)) (/ 1 (car a))
                                  (,o (car a))))
             ((and (pair? (cdr a)) (pair? (cddr a)))
              (apply / (/ (car a) (cadr a)) (cddr a)))
             ((or (only-quaternion? (car a)) (only-quaternion? (cadr a)))
              (q/ (quaternion (car a)) (quaternion (cadr a))))
             (else (,o (car a) (cadr a)))))))