(define (G f) 
(apply (lambda (conj sg zer zer? one + - * inv) (list
  (lambda (x) (cons (conj (car x)) (- zer (cdr x))))
  (lambda () (cons (sg) (sg)))
  (cons zer zer)
  (lambda (a) (and (zer? (car a)) (zer? (cdr a))))
  (cons one zer)
  (lambda (a b) (cons (+ (car a)(car b))(+ (cdr a)(cdr b))))
  (lambda (a b) (cons (- (car a)(car b))(- (cdr a)(cdr b))))
  (lambda (a b) (cons (- (* (car a)(car b))(* (conj (cdr b))(cdr a)))
                      (+ (* (cdr b)(car a))(* (cdr a)(conj (car b))))))
  (lambda (x) (let ((d (inv
      (+ (* (car x)(conj (car x))) (* (cdr x)(conj (cdr x)))))))
          (cons (* d (conj (car x)))(- zer (* d (cdr x)))))))) f))

(define reals (list
   (lambda (x) x) (lambda () 2)
   0 zero? 1 + - *
   (lambda (x) (/ x))))

(define P (G (G (G reals))))
(define sb (caddr (cddddr P)))
(define m (cadddr (cddddr P)))
(define zer (caddr P))
(define zer? (cadddr P))

(define a0 '((1 . 0) . (0 . 0)))
(define a1 '((0 . 1) . (0 . 0)))
(define a2 '((0 . 0) . (1 . 0)))
(define a3 '((0 . 0) . (0 . 1)))
(define z  '((0 . 0) . (0 . 0)))
(define one (cons a0 z))

(define tq (lambda (x) (let (
   (* m)
   (+ (cadr (cddddr P)))
   (one (car (cddddr P)))
   (zt (cadddr P)))
  (apply (lambda (i j k) (and
    (zt (+ (* i j) (* j i)))
    (zt (+ (* i k) (* k i)))
    (zt (+ (* k j) (* j k)))
    (zt (+ one (* i (* j k))))
    (zt (+ one (* (* i j k))))
    (zt (+ one (* i i)))
    (zt (+ one (* j j)))
    (zt (+ one (* k k)))
    (not (zt one))
   )) x))))

(define (as a b c)(sb (m (m a b) c) (m a (m b c))))
(define (df a b c)(not (or (equal? a b) (equal? a c) (equal? b c))))
; (map (lambda (x) (map (lambda (y) (map (lambda (z)
;   (and (df x y z) (zer? (as x y z)))) ol)) ol)) ol)

(define a0 '((1 . 0) . (0 . 0)))
(define a1 '((0 . 1) . (0 . 0)))
(define a2 '((0 . 0) . (1 . 0)))
(define a3 '((0 . 0) . (0 . 1)))
(define z  '((0 . 0) . (0 . 0)))
; following definitions inspired by bicture at bottom of
; <http://math.ucr.edu/home/baez/octonions/node4.html>.
(define (neg x)(sb zer x))
(define e0 (cons a0 z))
(define e5 (cons a1 z))
(define e6 (cons a2 z))
(define e1 (cons a3 z))
(define e3 (cons z a0))
(define e2 (neg (cons z a1))) ; Really wierd!!
(define e4 (cons z a2))
(define e7 (cons z a3))

(map tq (list (list e1 e2 e4) (list e2 e3 e5) (list e3 e4 e6) (list e4 e5 e7)
(list e5 e6 e1) (list e6 e7 e2) (list e7 e1 e3)))