(load "quaternion.scm")
(define (octonion . l)
  (cond
    ((= (length l) 2) `(octonion ,(car l) ,(cadr l)))
    ((= (length l) 4) `(octonion ,(quaternion (car l) (cadr l))
                                 ,(quaternion (caddr l) (cadddr l))))
    ((= (length l) 8) `(octonion ,(quaternion (car l) (cadr l)
                                              (caddr l) (cadddr l))
                                 ,(apply quaternion (cddddr l))))
    ((only-octonion? (car l)) (car l))
    ((quaternion? (car l)) `(octonion ,(car l) 0))))
(define (only-octonion? x) (and (list? x) (eq? (car x) 'octonion)))
(define (octonion? x) (or (quaternion? x) (only-octonion? x)))
(let ((o zero?))
  (eval `(define (zero? x)
           (and (,o (upper-part x)) (,o (lower-part x))))))
(let ((o upper-part))
  (eval `(define (upper-part x)
           (if (only-octonion? x) (cadr x) (,o x)))))
(let ((o lower-part))
  (eval `(define (lower-part x)
           (if (only-octonion? x) (caddr x) (,o x)))))
(let ((o real-part))
  (eval `(define (real-part x)
           (if (only-octonion? x) (,o (upper-part x)) (,o x))))
  (eval `(define (e1-part x) (,o (lower-part x)))))
(let ((o imag-part))
  (eval `(define (imag-part x)
           (if (only-octonion? x) (,o (upper-part x)) (,o x))))
  (eval `(define (i1-part x) (,o (lower-part x)))))
(let ((o j-part))
  (eval `(define (j-part x)
           (if (only-octonion? x) (,o (upper-part x)) (,o x))))
  (eval `(define (j1-part x) (,o (lower-part x)))))
(let ((o k-part))
  (eval `(define (k-part x)
           (if (only-octonion? x) (,o (upper-part x)) (,o x))))
  (eval `(define (k1-part x) (,o (lower-part x)))))
(define (oct-lower x)
  (quat-lower (if (and (only-octonion? x) (zero? (lower-part x)))
                  (upper-part x) x)))
(let ((o conj))
  (eval `(define (conj x)
           (if (only-octonion? x)
               (octonion (,o (upper-part x)) (- (lower-part x)))
               (,o x)))))
(let ((o abs))
  (eval `(define (abs x) (if (only-octonion? x) (sqrt (* x (conj x)))
                             (,o x)))))
(let ((o =))
  (eval `(define (= . a)
           (define (o= 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-octonion? (car a)) (only-octonion? (cadr a)))
              (o= (octonion (car a)) (octonion (cadr a))))
             (else (,o (car a) (cadr a)))))))
(let ((o +))
  (eval `(define (+ . a)
           (define (o+ a b)
             (oct-lower
              (octonion (,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-octonion? (car a)) (only-octonion? (cadr a)))
              (o+ (octonion (car a)) (octonion (cadr a))))
             (else (,o (car a) (cadr a)))))))
(let ((o -))
  (eval `(define (- . a)
           (define (o- a b)
             (oct-lower
              (octonion (,o (upper-part a) (upper-part b))
                        (,o (lower-part a) (lower-part b)))))
           (cond
             ((null? a) (,o))
             ((null? (cdr a)) (if (only-octonion? (car a)) (- 0 (car a))
                                  (,o (car a))))
             ((and (pair? (cdr a)) (pair? (cddr a)))
              (apply - (- (car a) (cadr a)) (cddr a)))
             ((or (only-octonion? (car a)) (only-octonion? (cadr a)))
              (o- (octonion (car a)) (octonion (cadr a))))
             (else (,o (car a) (cadr a)))))))
(let ((o *))
  (eval `(define (* . a)
           (define (o* a b)
             (oct-lower
              (octonion (- (,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-octonion? (car a)) (only-octonion? (cadr a)))
              (o* (octonion (car a)) (octonion (cadr a))))
             (else (,o (car a) (cadr a)))))))
(let ((o commutative*))
  (eval `(define (commutative* . a)
           (define (h* a b)
             (oct-lower
              (octonion (- (,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-octonion? (car a)) (only-octonion? (cadr a)))
              (h* (octonion (car a)) (octonion (cadr a))))
             (else (,o (car a) (cadr a)))))))
(let ((o /))
  (eval `(define (/ . a)
           (define (o/ a b)
             (let ((n (* a (conj b))) (d (* b (conj b))))
               (oct-lower (octonion (,o (upper-part n) d)
                                    (,o (lower-part n) d)))))
           (cond
             ((null? a) (,o))
             ((null? (cdr a)) (if (only-octonion? (car a)) (/ 1 (car a))
                                  (,o (car a))))
             ((and (pair? (cdr a)) (pair? (cddr a)))
              (apply / (/ (car a) (cadr a)) (cddr a)))
             ((or (only-octonion? (car a)) (only-octonion? (cadr a)))
              (o/ (octonion (car a)) (octonion (cadr a))))
             (else (,o (car a) (cadr a)))))))