\documentclass{article}
\usepackage{axiom}
\begin{document}
\title{The Andrews-Curtis Conjecture}
\author{Gilbert Baumslag, Timothy Daly}
\maketitle
\begin{abstract}
\end{abstract}
\eject
\tableofcontents
\eject
\section{The Problem}
<<code>>=
(defun element-print (object stream depth)
  "elements are supposed to be single characters that
  are raised to a given power. Thus an elements look like:
  a a^2 a^-3 etc..."
 (let ((power (element-power object)))
  (cond 
   ((= power 0))
   ((= power 1)
     (format stream "~a" (element-char object)))
   (t
     (format stream "~a^~a" (element-char object) power)))))

(defstruct (element (:print-function element-print))
  "elements are structures with a general string field and a numeric power.
   elements are allowed to have null strings or 0 powers. Neither one will
   be printed"
   (char (:type string)) 
   (power (:type number)))

(defun element-nonzero (element)
 "returns the element if it is of a nonzero power otherwise return nil"
  (unless (= (element-power element) 0)
    element))

(defun element-nonzero-test ()
 (format t "~%testing element-nonzero...~%")
 (setq a (make-element :char "a" :power 1))
 (format t "a               = ~a~%" a)
 (format t "(element-nonzero a) = ~a~%" (element-nonzero a))
 (setq b (make-element :char "b" :power 0))
 (format t "b               = ~a~%" a)
 (format t "(element-nonzero b) = ~a~%" (element-nonzero b)))

(defun element-equal (element1 element2)
  "element-equal returns true if the char values are equal else nil"
  (when (string= (element-char element1) (element-char element2)) t))

(defun element-equal-test ()
 (format t "~%testing element-equal...~%")
 (setq a (make-element :char "a" :power 1))
 (format t "a             = ~a~%" a)
 (format t "(element-equal a a) = ~a~%" (element-equal a a))
 (setq b (make-element :char "b" :power 0))
 (format t "b             = ~a~%" a)
 (format t "(element-equal a b) = ~a~%" (element-equal a b)))

(defun element-combine (element1 element2)
 "element-combine returns a new element that combines the exponents
  if element-equal is true else nil"
 (when (element-equal element1 element2)
   (make-element :char (element-char element1)
     :power (+ (element-power element1) (element-power element2)))))

(defun element-combine-test ()
 (format t "~%testing element-combine...~%")
 (setq a (make-element :char "a" :power 2))
 (format t "a               = ~a~%" a)
 (format t "(element-combine a a) = ~a~%" (element-combine a a))
 (setq am (make-element :char "a" :power -2))
 (format t "am              = ~a~%" am)
 (format t "(element-combine a am) = ~a~%" (element-combine a am))
 (setq b (make-element :char "b" :power 2))
 (format t "b               = ~a~%" a)
 (format t "(element-combine a b) = ~a~%" (element-combine a b)))

(defun element-expand (element)
 "element-expand will take an element to some power N and return a list
  of N elements with a power of 1 if N is positive and -1 if N is negative.
  An element with power 0 or power 1 is returned as a singleton list"
 (let ((char (element-char element))
       (power (element-power element)))
  (cond 
   ((< power -1)
     (let ((result))
       (dotimes (i (- power))
         (setq result 
           (cons (make-element :char char :power -1) result)))
       result))
   ((= power -1)
     (list element))
   ((= power 0)
     (list element))
   ((= power 1)
     (list element))
   (t
     (let ((result))
       (dotimes (i power)
         (setq result 
           (cons (make-element :char char :power 1) result)))
       result)))))

(defun element-expand-test ()
 (format t "~%testing element-expand...~%")
 (setq am3 (make-element :char "a" :power -3))
 (format t "a^-2          = ~a~%" am3)
 (format t "element-expand = (")
 (dolist (item (element-expand am3))
   (format t "~a" item))
 (format t ")~%")
 (setq am2 (make-element :char "a" :power -2))
 (format t "a^-2          = ~a~%" am2)
 (format t "element-expand = (")
 (dolist (item (element-expand am2))
   (format t "~a" item))
 (format t ")~%")
 (setq am1 (make-element :char "a" :power -1))
 (format t "a^-1           = ~a~%" am1)
 (format t "element-expand = ~a~%" (element-expand am1))
 (setq a0 (make-element :char "a" :power 0))
 (format t "a^0            = ~a~%" a0)
 (format t "element-expand = ~a~%" (element-expand a0))
 (setq a1 (make-element :char "a" :power 1))
 (format t "a^1            = ~a~%" a1)
 (format t "element-expand = ~a~%" (element-expand a1))
 (setq a2 (make-element :char "a" :power 2))
 (format t "a^2            = ~a~%" a2)
 (format t "element-expand = (")
 (dolist (item (element-expand a2))
   (format t "~a" item))
 (format t ")~%")
 (setq a3 (make-element :char "a" :power 3))
 (format t "a^3            = ~a~%" a3)
 (format t "element-expand = (")
 (dolist (item (element-expand a3))
   (format t "~a" item))
 (format t ")~%")

)
   
(defun element-modified-test ()
 "check to see what functions destructively modify their arguments"
 (format t "~%testing element-modified...~%")
 (setq char "a")
 (setq power 1)
 (setq a (make-element :char char :power power))
 (format t "char eq? = ~a  power eq? = ~a~%" 
   (eq char (element-char a)) (eq power (element-power a)))
 (setq b (element-expand a))
 (format t "char eq? = ~a  power eq? = ~a~%" 
   (eq char (element-char a)) (eq power (element-power a)))
 (setq c (element-combine a a))
 (format t "char eq? = ~a  power eq? = ~a~%" 
   (eq char (element-char a)) (eq power (element-power a)))
 (setq d (element-equal a a))
 (format t "char eq? = ~a  power eq? = ~a~%" 
   (eq char (element-char a)) (eq power (element-power a)))
 (setq d (element-nonzero a))
 (format t "char eq? = ~a  power eq? = ~a~%" 
   (eq char (element-char a)) (eq power (element-power a)))
 (setq e (element-print a t 0))
 (format t "char eq? = ~a  power eq? = ~a~%" 
   (eq char (element-char a)) (eq power (element-power a))))


(defun element-test ()
 (format t "~%=================================================~%")
 (format t "testing element...~%")
 (format t "=================================================~%")
 (setq am2 (make-element :char "a" :power -2))
 (format t "a^-2 = ~a~%" am2)
 (setq am1 (make-element :char "a" :power -1))
 (format t "a^-1 = ~a~%" am1)
 (setq a0 (make-element :char "a" :power 0))
 (format t "a^0  = ~a~%" a0)
 (setq a1 (make-element :char "a" :power 1))
 (format t "a^1  = ~a~%" a1)
 (setq a2 (make-element :char "a" :power 2))
 (format t "a^2  = ~a~%" a2)
 (element-expand-test)
 (element-nonzero-test)
 (element-equal-test)
 (element-combine-test)
 (element-modified-test))

;;; words are lists of elements

(defun word-print (object stream depth)
 "words are lists of elements that are raised to a given power. 
  Thus a words look like a a^2 (ab)^2 (a^2)^-3 etc..."
  (let ((tmplist (word-elements object)) (power (word-power object)))
   (cond 
    ((= power 0))
    ((= power 1)
      (dolist (element tmplist)
        (format stream "~a" element)))
    (t
      (cond
        ((> (length tmplist) 0)
          (format stream "(")
          (dolist (element tmplist)
            (format stream "~a" element))
          (format stream ")^~a" power)))))))

(defstruct (word (:print-function word-print)) 
  (elements (:type list))
  (power (:type number)))

(defun word-removeZeros (word)
 "remove all of the 0 power words and words of length 0"
 (let ((power (word-power word))
       (elements (word-elements word)))
  (if (not (= (word-power word) 0))
    (let (result)
      (dolist (element (reverse elements))
        (when (element-nonzero element) 
          (setq result (cons element result))))
      (when result
       (make-word :elements result :power power))))))

(defun word-removeZeros-test ()
  (format t "~%test word-removeZeros...~%")
  (setq a (make-element :char "a" :power 1))
  (setq b (make-element :char "b" :power 1))
  (setq c (make-element :char "c" :power 1))
  (setq w1 (make-word :elements (list a b c) :power 1))
  (format t "w1               = ~a~%" w1)
  (format t "length           = ~a~%" (length (word-elements w1)))
  (setq w1a (word-removeZeros w1))
  (format t "w1a              = ~a~%" w1a)
  (format t "length           = ~a~%" (length (word-elements w1a)))
  (setq a (make-element :char "a" :power 0))
  (setq b (make-element :char "b" :power 1))
  (setq c (make-element :char "c" :power 1))
  (setq w2 (make-word :elements (list a b c) :power 1))
  (format t "w2               = ~a~%" w2)
  (format t "length           = ~a~%" (length (word-elements w2)))
  (setq w2a (word-removeZeros w2))
  (format t "w2a              = ~a~%" w2a)
  (format t "length           = ~a~%" (length (word-elements w2a)))
  (setq a (make-element :char "a" :power 1))
  (setq b (make-element :char "b" :power 0))
  (setq c (make-element :char "c" :power 1))
  (setq w3 (make-word :elements (list a b c) :power 1))
  (format t "w3               = ~a~%" w3)
  (format t "length           = ~a~%" (length (word-elements w3)))
  (setq w3a (word-removeZeros w3))
  (format t "w3a              = ~a~%" w3a)
  (format t "length           = ~a~%" (length (word-elements w3a)))
  (setq a (make-element :char "a" :power 1))
  (setq b (make-element :char "b" :power 1))
  (setq c (make-element :char "c" :power 0))
  (setq w4 (make-word :elements (list a b c) :power 1))
  (format t "w4               = ~a~%" w4)
  (format t "length           = ~a~%" (length (word-elements w4)))
  (setq w4a (word-removeZeros w4))
  (format t "w4a              = ~a~%" w4a)
  (format t "length           = ~a~%" (length (word-elements w4a)))
  (setq a (make-element :char "a" :power 0))
  (setq b (make-element :char "b" :power 0))
  (setq c (make-element :char "c" :power 0))
  (setq w5 (make-word :elements (list a b c) :power 1))
  (format t "w5               = ~a~%" w5)
  (format t "length           = ~a~%" (length (word-elements w5)))
  (setq w5a (word-removeZeros w5))
  (format t "w5a              = ~a~%" w5a)
  (when w5a
   (format t "length           = ~a~%" (length (word-elements w5a))))
  (setq a (make-element :char "a" :power 1))
  (setq b (make-element :char "b" :power 0))
  (setq c (make-element :char "c" :power 1))
  (setq w6 (make-word :elements (list a b c) :power 0))
  (format t "w6               = ~a~%" w6)
  (format t "length           = ~a~%" (length (word-elements w6)))
  (setq w6a (word-removeZeros w6))
  (format t "w6a              = ~a~%" w6a)
  (when w6a
   (format t "length           = ~a~%" (length (word-elements w6a))))
  (setq w7 (make-word :elements (list ) :power 1))
  (format t "w7               = ~a~%" w7)
  (format t "length           = ~a~%" (length (word-elements w7)))
  (setq w7a (word-removeZeros w7))
  (format t "w7a              = ~a~%" w7a)
  (when w7a
   (format t "length           = ~a~%" (length (word-elements w7a)))))


(defun word-expand (word)
 "word-expand will take a word to some power N and return a word 
  replicated N times with a power 1. A word with power 0 or power 1
  is returned unchanged. This will remove all powers except -1 at
  the word level. Note that elements can still have higher powers.
  The result is a word (not necessarily new)"
 (let ((elements (word-elements word))
       (power (word-power word)))
  (cond 
   ((<= power -1)
     (let ((onecopy) rev)
       (dolist (elem elements)
         (push 
           (make-element 
             :char (element-char elem) :power (- (element-power elem)))
           rev))
       (dotimes (i (- power))
         (setq onecopy (concatenate 'list onecopy rev)))
       (make-word :elements onecopy :power 1)))
   ((= power 0)
     word)
   ((= power 1)
     word)
   (t
     (let ((onecopy))
       (dotimes (i power)
         (setq onecopy (concatenate 'list onecopy elements)))
       (make-word :elements onecopy :power 1))))))
   
(defun word-expand-test ()
 "test that words to various powers are properly expanded"
 (format t "~%test word expansion...~%")
 (setq a (make-element :char "a" :power 1))
 (setq b (make-element :char "b" :power -1))
 (setq c (make-element :char "c" :power 0))
 (setq d (make-element :char "d" :power 1))
 (setq wm2 (make-word :elements (list a b c d) :power -2))
 (format t "w^-2        = ~a~%" wm2)
 (format t "word-expand = ~a~%"  (word-expand wm2))
 (setq wm1 (make-word :elements (list a b c d) :power -1))
 (format t "w^-1        = ~a~%" wm1)
 (format t "word-expand = ~a~%"  (word-expand wm1))
 (setq w0 (make-word :elements (list a b c d) :power 0))
 (format t "w^0         = ~a~%" w0)
 (format t "word-expand = ~a~%"  (word-expand w0))
 (setq w1 (make-word :elements (list a b c d) :power 1))
 (format t "w^1         = ~a~%" w1)
 (format t "word-expand = ~a~%"  (word-expand w1))
 (setq w2 (make-word :elements (list a b c d) :power 2))
 (format t "w^2         = ~a~%" w2)
 (format t "word-expand = ~a~%"  (word-expand w2))
 (setq w3 (make-word :elements (list a b c d) :power 3))
 (format t "w^3         = ~a~%" w3)
 (format t "word-expand = ~a~%"  (word-expand w3))
 (setq wempty (make-word :elements (list) :power 3))
 (format t "wempty      = ~a~%" wempty)
 (format t "word-expand = ~a~%"  (word-expand wempty)))

(defun word-expand-fully (word)
 "word-expand-fully will expand all of the elements in the word and
  then call word-expand on the result. This will remove all powers
  except -1 at all levels. The result is a new word"
 (let ((tmpcopy (copy-word word)))
   (setf (word-elements tmpcopy) 
     (mapcan #'element-expand (word-elements tmpcopy)))
   (word-expand tmpcopy)))

(defun word-expand-fully-test ()
 "test that words to various powers at all levels are properly expanded"
 (format t "~%test word expansion...~%")
 (setq a (make-element :char "a" :power 3))
 (setq b (make-element :char "b" :power -3))
 (setq c (make-element :char "c" :power 0))
 (setq d (make-element :char "d" :power 1))
 (setq wm2 (make-word :elements (list a b c d) :power -2))
 (format t "w^-2              = ~a~%" wm2)
 (format t "word-expand-fully = ~a~%"  (word-expand-fully wm2))
 (setq wm1 (make-word :elements (list a b c d) :power -1))
 (format t "w^-1              = ~a~%" wm1)
 (format t "word-expand-fully = ~a~%"  (word-expand-fully wm1))
 (setq w0 (make-word :elements (list a b c d) :power 0))
 (format t "w^0               = ~a~%" w0)
 (format t "word-expand-fully = ~a~%"  (word-expand-fully w0))
 (setq w1 (make-word :elements (list a b c d) :power 1))
 (format t "w^1               = ~a~%" w1)
 (format t "word-expand-fully = ~a~%"  (word-expand-fully w1))
 (setq w2 (make-word :elements (list a b c d) :power 2))
 (format t "w^2               = ~a~%" w2)
 (format t "word-expand-fully = ~a~%"  (word-expand-fully w2))
 (setq w3 (make-word :elements (list a b c d) :power 3))
 (format t "w^3               = ~a~%" w3)
 (format t "word-expand-fully = ~a~%"  (word-expand-fully w3))
 (setq wempty (make-word :elements (list ) :power 3))
 (format t "wempty            = ~a~%" wempty)
 (format t "word-expand-fully = ~a~%"  (word-expand-fully wempty))
 (format t "NB: the zero exponent elements still exist~%")
 (format t "length=~a~%" (length (word-elements (word-expand-fully w3))))
 (dolist (elem (word-elements (word-expand-fully w3)))
   (element-print elem t 0)
   (terpri))
 (format t "but now we remove the zero exponent elements~%")
 (setq nonzero (word-removeZeros (word-expand-fully w3)))
 (format t "length=~a~%" (length (word-elements nonzero)))
 (dolist (elem (word-elements nonzero))
   (element-print elem t 0)
   (terpri)))

(defun word-freely-reduce (word)
  "The word is fully expanded and all possible cancels are pinched.
   An element will cancel its neighbor if the neighbor is the same
   element-char and opposite power. Note that a fully expanded word
   has only powers of 1, -1 and 0."
  (cond 
    ((<= (length (word-elements word)) 1)
      word)
    (t
     (let* ((flat (word-removeZeros (word-expand word)))
            (elems (word-elements flat))
            (result (list (pop elems)))
            (pinched nil))
       (dolist (elem elems)
         (cond 
          ((element-equal (car result) elem)
            (setq pinched t)
            (push (element-combine (pop result) elem) result))
          (t (push elem result))))
       (cond
         (pinched
          (word-freely-reduce (make-word :elements (reverse result) :power 1)))
         (t
           (make-word :elements (reverse result) :power 1)))))))
   
 (defun word-freely-reduce-test ()
 (format t "~%testing word-freely-reduce...~%")
 (setq a (make-element :char "a" :power 3))
 (setq am (make-element :char "a" :power -3))
 (setq b (make-element :char "b" :power 3))
 (setq bm (make-element :char "b" :power -3))
 (setq c (make-element :char "c" :power 3))
 (setq cm (make-element :char "c" :power -3))
 (setq d (make-element :char "d" :power 3))
 (setq w0 (make-word :elements nil :power 1))
 (format t "w0                 = ~a~%" w0)
 (format t "word-freely-reduce = ~a~%" (word-freely-reduce w0))
 (setq w1 (make-word :elements (list a am b bm c cm d) :power 1))
 (format t "w1                 = ~a~%" w1)
 (format t "word-freely-reduce = ~a~%" (word-freely-reduce w1))
 (setq w2 (make-word :elements (list am a bm b cm c d) :power 1))
 (format t "w2                 = ~a~%" w2)
 (format t "word-freely-reduce = ~a~%" (word-freely-reduce w2))
 (setq w3 (make-word :elements (list a am b bm c cm d) :power 3))
 (format t "w3                 = ~a~%" w3)
 (format t "word-freely-reduce = ~a~%" (word-freely-reduce w3))
 (setq w4 (make-word :elements (list a d am b d bm c d cm d d) :power 1))
 (format t "w4                 = ~a~%" w4)
 (format t "word-freely-reduce = ~a~%" (word-freely-reduce w4)))

(defun word-prefix (word N)
  "word-abbrev will return a word of the first N elements of the
   freely-reduced word. If N is less than 1 returns nil. If N is
   greater than the word length return a copy of the word"
 (let* ((flat (word-freely-reduce word))
        (elems (word-elements flat)))
  (cond
   ((<= N 1)
     nil)
   ((> N (length elems))
     (make-word :elements elems :power 1))
   (t
    (make-word :elements (subseq elems 0 (- N 1)) :power 1)))))

(defun word-prefix-test ()
 (format t "~%testing word-prefix...~%")
 (setq a (make-element :char "a" :power 2))
 (setq b (make-element :char "b" :power -2))
 (setq c (make-element :char "c" :power 1))
 (setq d (make-element :char "d" :power 0))
 (setq wm2 (make-word :elements (list a b c d) :power -2))
 (format t "w^-2 = ~a~%" wm2)
 (format t "word-expand = ~a~%" (word-expand wm2))
 (format t "word-prefix 1 = ~a~%" (word-prefix wm2 1))
 (format t "word-prefix 2 = ~a~%" (word-prefix wm2 2))
 (format t "word-prefix 3 = ~a~%" (word-prefix wm2 3))
 (format t "word-prefix 4 = ~a~%" (word-prefix wm2 4))
 (format t "word-prefix 5 = ~a~%" (word-prefix wm2 5))
 (format t "word-prefix 6 = ~a~%" (word-prefix wm2 6))
 (format t "word-prefix 7 = ~a~%" (word-prefix wm2 7))
 (format t "word-prefix 8 = ~a~%" (word-prefix wm2 8))
 (format t "word-prefix 9 = ~a~%" (word-prefix wm2 9)))

(defun word-inverse (word)
 "word inverse returns the inverse word"
  (make-word :elements (word-elements word) :power (- (word-power word))))

(defun word-inverse-test ()
 (format t "~%testing word-inverse...~%")
 (setq a (make-element :char "a" :power 2))
 (setq b (make-element :char "b" :power -2))
 (setq c (make-element :char "c" :power 1))
 (setq d (make-element :char "d" :power 0))
 (setq w (make-word :elements (list a b c d) :power -2))
 (format t "w = ~a~%" w)
 (setq wi (word-inverse w))
 (format t "wi = w^-1 = ~a~%" wi)
 (setq w2 (make-word :elements (list a b c d) :power 2))
 (format t "w2 = ~a~%" w2)
 (setq wi2 (word-inverse w2))
 (format t "wi2 = w2^-1 = ~a~%" wi2)
 (setq w3 (make-word :elements (list a) :power 1))
 (format t "w3 = ~a~%" w3)
 (setq wi3 (word-inverse w3))
 (format t "wi3 = w3^-1 = ~a~%" wi3)
 (setq w4 (make-word :elements (list ) :power -2))
 (format t "w4 = ~a~%" w4)
 (setq wi4 (word-inverse w4))
 (format t "wi4 = w4^-1 = ~a~%" wi4))

(defun word-equal (word1 word2)
 "word-equal returns word1 if the words are equal (not necessarily eq)
  else it returns nil. Equality means that the powers are equal and
  the sequence of elements are equal. If you want to test if the
  expanded words are equal can multiply the freely-reduced words"
 (cond
  ((eq word1 word2)
    word1)
  ((and 
    (= (word-power word1) (word-power word2))
    (= 
      (length (word-elements (word-removeZeros word1)))
      (length (word-elements (word-removeZeros word2))))
    (every #'element-equal 
      (word-elements (word-removeZeros word1))
      (word-elements (word-removeZeros word2))))
   word1)
  (t nil)))   

(defun word-equal-test ()
 "check that word-equal works correctly"
 (format t "~%testing word-equal...~%")
 (setq a (make-element :char "a" :power 2))
 (setq b (make-element :char "b" :power -2))
 (setq c (make-element :char "c" :power 1))
 (setq d (make-element :char "d" :power 0))
 (setq w1 (make-word :elements (list a b c d) :power 1))
 (format t "w1 = ~a~%" w1)
 (setq w2 (make-word :elements (list a b c) :power 1))
 (format t "w2 = ~a~%" w2)
 (format t "w1 = w2? = ~a~%" (word-equal w1 w2))
 (setq w3 (make-word :elements (list a b c d) :power -2))
 (format t "w3 = ~a~%" w3)
 (format t "w3 = w3? = ~a~%" (word-equal w3 w3))
 (format t "w3 = (freely-reduce w3)? = ~a~%" 
   (word-equal w3 (word-freely-reduce w3))))
 

(defun word-multiply (word1 word2)
 "word-multiply will return the concatenation of the two words as a new word
  if the words are different otherwise it will return a new word that is the
  sum of the powers of the original words"
 (let ((power1 (word-power word1))
       (power2 (word-power word2))
       (elements1 (word-elements word1))
       (elements2 (word-elements word2)))
  (cond
   ((and (= (length elements1) (length elements2))
         (every #'element-equal elements1 elements2))
     (make-word :elements (copy-seq elements1) :power (+ power1 power2)))
   (t
    (let ((new1 (word-expand word1))
          (new2 (word-expand word2)))
     (make-word 
       :elements (append (word-elements new1) (word-elements new2))
       :power 1))))))

(defun word-multiply-test ()
  (format t "~%testing word multiply...~%")
  (setq a (make-element :char "a" :power 2))
  (setq b (make-element :char "b" :power -2))
  (setq c (make-element :char "c" :power 1))
  (setq w1 (make-word :elements (list a b c) :power -2))
  (format t "w1 = ~a~%" w1)
  (format t "w1 * w1 = ~a~%" (word-multiply w1 w1))
  (setq wm1 (word-inverse w1))
  (format t "wm1 = w1^-1 = ~a~%" wm1)
  (format t "w1 * w1^-1 = ~a~%" (word-multiply w1 wm1))
  (setq we1 (word-expand wm1))
  (format t "we1 = w1^-1 (expanded) = ~a~%" we1)
  (setq wme1 (word-multiply w1 we1))
  (format t "wme1 = w1 * w1^-1 (exp) = ~a~%" wme1)
  (setq wfr (word-freely-reduce wme1))
  (format t "wfr = (freely-reduce (w1 * w1^-1 (exp)) = ~a~%" wfr))

(defun word-parse (ws)
 "word-parse takes a word that describes a string and returns the word
  structure that represents that string"
 (let (element elements (power 0) (depth 0) result needNumber negative error
       carrot lastchar accept)
  (setq result (make-word :elements (list) :power 0))
  (dotimes (i (length ws))
   (cond 
    (error)
    ((string= (subseq ws i (+ i 1)) "(") 
      (setq depth (+ depth 1))
      (when (> depth 1)
       (setq error "defining word within a word"))
      (push "(" accept))
    ((string= (subseq ws i (+ i 1)) ")") 
      (setq depth (- depth 1))
      (when needNumber
       (setq error "missing number"))
      (unless lastchar
       (setq error "missing element"))
      (unless (string= lastchar ")")
       (push (word-newParseElement lastchar negative power) elements))
      (push lastchar accept)
      (setq lastchar (subseq ws i (+ i 1)))
      (setq power 0)
      (setq negative nil)
      (setq carrot nil)
      (setq needNumber nil)
      (push ")" accept))
    ((string= (subseq ws i (+ i 1)) "^") 
      (when carrot
        (setq error "duplicate carrot"))
      (setq carrot t)
      (setq needNumber t)
      (push "^" accept))
    ((string= (subseq ws i (+ i 1)) "-") 
      (when negative 
        (setq error "duplicate negative"))
      (unless carrot
        (setq error "missing carrot"))
      (setq negative t)
      (push "-" accept))
    ((string= (subseq ws i (+ i 1)) "0") 
      (setq needNumber nil)
      (setq power (* power 10))
      (push "0" accept))
    ((string= (subseq ws i (+ i 1)) "1") 
      (setq needNumber nil)
      (setq power (+ (* power 10) 1))
      (push "1" accept))
    ((string= (subseq ws i (+ i 1)) "2") 
      (setq needNumber nil)
      (setq power (+ (* power 10) 2))
      (push "2" accept))
    ((string= (subseq ws i (+ i 1)) "3") 
      (setq needNumber nil)
      (setq power (+ (* power 10) 3))
      (push "3" accept))
    ((string= (subseq ws i (+ i 1)) "4") 
      (setq needNumber nil)
      (setq power (+ (* power 10) 4))
      (push "4" accept))
    ((string= (subseq ws i (+ i 1)) "5") 
      (setq needNumber nil)
      (setq power (+ (* power 10) 5))
      (push"5" accept))
    ((string= (subseq ws i (+ i 1)) "6") 
      (setq needNumber nil)
      (setq power (+ (* power 10) 6))
      (push "6" accept))
    ((string= (subseq ws i (+ i 1)) "7") 
      (setq needNumber nil)
      (setq power (+ (* power 10) 7))
      (push "7" accept))
    ((string= (subseq ws i (+ i 1)) "8") 
      (setq needNumber nil)
      (setq power (+ (* power 10) 8))
      (push "8" accept))
    ((string= (subseq ws i (+ i 1)) "9") 
      (setq needNumber nil)
      (setq power (+ (* power 10) 9))
      (push "9" accept))
    ((not lastchar)
     (setq lastchar (subseq ws i (+ i 1)))
     (push lastchar accept))
    (t
      (unless (string= lastchar ")")
       (push (word-newParseElement lastchar negative power) elements))
      (push lastchar accept)
      (setq lastchar (subseq ws i (+ i 1)))
      (setq power 0)
      (setq negative nil)
      (setq carrot nil)
      (setq needNumber nil))))
   (when (and (> (length ws) 0) (not (string= lastchar ")"))) 
     (push (word-newParseElement lastchar negative power) elements)
     (setq power 0)
     (setq negative nil))
   (cond 
    (error
      (word-parseError ws (length accept) error))
    (needNumber 
      (word-parseError ws (length accept) "missing power"))
    ((not (= depth 0)) 
      (word-parseError ws (length accept) "unbalanced paren"))
    ((and (= depth 0)
          (not needNumber))
     (when elements
      (setf (word-elements result) (reverse elements)))
     (cond
      ((= power 0)
        (setf (word-power result) 1))
      (negative
       (setf (word-power result) (- power)))
      (t
       (setf (word-power result) power)))))
   result))

(defun word-parseError (word index msg)
 "word-parseError is a helper function for word-parse.
  It outputs a formatted error message"
 (format t "~a~%" word)
 (dotimes (i (- index 1))
  (format t " "))
 (format t "^ ...~a~%" msg))

(defun word-newParseElement (char negative power)
 "word-newParseElement is a helper function for word-parse.
  It creates a new element"
  (cond
   ((= power 0)
     (make-element :char char :power 1))
   (negative
     (make-element :char char :power (- power)))
   (t
     (make-element :char char :power power))))

(defun word-parse-test ()
 (format t "~%testing word-parse...~%")
 (setq a (word-parse ""))
 (format t "(word-parse \"\") = ~a~%" a)
 (setq b (word-parse "a"))
 (format t "(word-parse \"a\") = ~a~%" b)
 (setq c (word-parse "ab"))
 (format t "(word-parse \"ab\") = ~a~%" c)
 (setq c1 (word-parse "abc"))
 (format t "(word-parse \"abc\") = ~a~%" c1)
 (setq d (word-parse "(ab)"))
 (format t "(word-parse \"(ab)\") = ~a~%" d)
 (setq e (word-parse "(a)b"))
 (format t "(word-parse \"(a)b\") = ~a~%" e)
 (setq f (word-parse "a(b)"))
 (format t "(word-parse \"a(b)\") = ~a~%" f)
 (setq f1 (word-parse "(a)(b)"))
 (format t "(word-parse \"(a)(b)\") = ~a~%" f1)
 (setq g (word-parse "a(b"))
 (format t "(word-parse \"a(b\") = ~a~%" g)
 (setq h (word-parse "a^1"))
 (format t "(word-parse \"a^1\") = ~a~%" h)
 (setq aa (word-parse "a^"))
 (format t "(word-parse \"a^\") = ~a~%" aa)
 (setq ab (word-parse "a^1"))
 (format t "(word-parse \"a^1\") = ~a~%" ab)
 (setq ac (word-parse "a^2"))
 (format t "(word-parse \"a^2\") = ~a~%" ac)
 (setq ad (word-parse "a^--2"))
 (format t "(word-parse \"a^--2\") = ~a~%" ad)
 (setq ae (word-parse "a-2"))
 (format t "(word-parse \"a-2\") = ~a~%" ae)
 (setq ba (word-parse "a^23"))
 (format t "(word-parse \"a^23\") = ~a~%" ba)
 (setq bb (word-parse "(a)^23"))
 (format t "(word-parse \"(a)^23\") = ~a~%" bb)
 (setq bc (word-parse "ab^23"))
 (format t "(word-parse \"ab^23\") = ~a~%" bc)
 (setq bd (word-parse "a^23b"))
 (format t "(word-parse \"a^23b\") = ~a~%" bd)
 (setq be (word-parse "a^23b^3"))
 (format t "(word-parse \"a^23b^3\") = ~a~%" be)
 (setq ca (word-parse "a^-23"))
 (format t "(word-parse \"a^-23\") = ~a~%" ca)
 (setq cb (word-parse "(a)^-23"))
 (format t "(word-parse \"(a)^-23\") = ~a~%" cb)
 (setq cb1 (word-parse "(ab)^-23"))
 (format t "(word-parse \"(ab)^-23\") = ~a~%" cb1)
 (setq cb2 (word-parse "(a)(b)^-23"))
 (format t "(word-parse \"(a)(b)^-23\") = ~a~%" cb1)
 (setq cc (word-parse "ab^-23"))
 (format t "(word-parse \"ab^-23\") = ~a~%" cc)
 (setq cd (word-parse "a^-23b"))
 (format t "(word-parse \"a^-23b\") = ~a~%" cd)
 (setq ce (word-parse "a^-23b^3"))
 (format t "(word-parse \"a^-23b^3\") = ~a~%" ce)
 (setq da (word-parse "()^-2"))
 (format t "(word-parse \"()^-2\") = ~a~%" da)
 (setq db (word-parse "(a)^-2"))
 (format t "(word-parse \"(a)^-2\") = ~a~%" db)
 (setq dc (word-parse "(ab)^-2"))
 (format t "(word-parse \"(ab)^-2\") = ~a~%" dc)
 (setq dc1 (word-parse "(abc)^-2"))
 (format t "(word-parse \"(abc)^-2\") = ~a~%" dc1)
 (setq dd (word-parse "((ab))^-2"))
 (format t "(word-parse \"((ab))^-2\") = ~a~%" dd)
 (setq de (word-parse "((a)b)^-2"))
 (format t "(word-parse \"((a)b)^-2\") = ~a~%" de)
 (setq df (word-parse "(a(b))^-2"))
 (format t "(word-parse \"(a(b))^-2\") = ~a~%" df)
 (setq dg (word-parse "(a(b)^-2"))
 (format t "(word-parse \"(a(b)^-2\") = ~a~%" dg)
 (setq dh (word-parse "(a^1)^-2"))
 (format t "(word-parse \"(a^1)^-2\") = ~a~%" dh)
 (setq dh1 (word-parse "(a^-1)^-2"))
 (format t "(word-parse \"(a^-1)^-2\") = ~a~%" dh1)
 (setq daa (word-parse "(a^)^-2"))
 (format t "(word-parse \"(a^)^-2\") = ~a~%" daa)
 (setq dab (word-parse "(a^1)^-2"))
 (format t "(word-parse \"(a^1)^-2\") = ~a~%" dab)
 (setq dac (word-parse "(a^2)^-2"))
 (format t "(word-parse \"(a^2)^-2\") = ~a~%" dac)
 (setq dad (word-parse "(a^--2)^-2"))
 (format t "(word-parse \"(a^--2)^-2\") = ~a~%" dad)
 (setq dae (word-parse "(a-2)^-2"))
 (format t "(word-parse \"(a-2)^-2\") = ~a~%" dae)
 (setq dba (word-parse "(a^23)^-2"))
 (format t "(word-parse \"(a^23)^-2\") = ~a~%" dba)
 (setq dbb (word-parse "((a)^23)^-2"))
 (format t "(word-parse \"((a)^23)^-2\") = ~a~%" dbb)
 (setq dbc (word-parse "(ab^23)^-2"))
 (format t "(word-parse \"(ab^23)^-2\") = ~a~%" dbc)
 (setq dbd (word-parse "(a^23b)^-2"))
 (format t "(word-parse \"(a^23b)^-2\") = ~a~%" dbd)
 (setq dbe (word-parse "(a^23b^3)^-2"))
 (format t "(word-parse \"(a^23b^3)^-2\") = ~a~%" dbe)
 (setq dca (word-parse "(a^-23)^-2"))
 (format t "(word-parse \"(a^-23)^-2\") = ~a~%" dca)
 (setq dcb (word-parse "((a)^-23)^-2"))
 (format t "(word-parse \"((a)^-23)^-2\") = ~a~%" dcb)
 (setq dcc (word-parse "(ab^-23)^-2"))
 (format t "(word-parse \"(ab^-23)^-2\") = ~a~%" dcc)
 (setq dcd (word-parse "(a^-23b)^-2"))
 (format t "(word-parse \"(a^-23b)^-2\") = ~a~%" dcd)
 (setq dce (word-parse "(a^-23b^3)^-2"))
 (format t "(word-parse \"(a^-23b^3)^-2\") = ~a~%" dce)
 (setq ea (word-parse "((a^-23)(b^3))^-2"))
 (format t "(word-parse \"((a^-23)(b^3))^-2\") = ~a~%" ea)
 (setq eb (word-parse "(a^-23)(b^3)^-2"))
 (format t "(word-parse \"(a^-23)(b^3)^-2\") = ~a~%" eb))


(defun word-commute-elements (word)
 "word-commute-elements rearranges all of the elements in a word
  into alphabetic order. It does not reduce the word"
 (make-word 
   :elements (stable-sort (word-elements word) #'string< :key #'element-char)
   :power (word-power word)))))

(defun word-commute-elements-test ()
  (format t "~%testing word-commute-elements...~%")
  (setq w1 (word-parse "abcd"))
  (format t "w1 = ~a~%" w1)
  (format t "(word-commute elements w1) = ~a~%" (word-commute-elements w1))
  (setq w2 (word-parse "badc"))
  (format t "w1 = ~a~%" w2)
  (format t "(word-commute elements w2) = ~a~%" (word-commute-elements w2))
  (setq w3 (word-parse "b^-1a^-1ba"))
  (format t "w3 = ~a~%" w3)
  (format t "(word-freely-reduce w3) = ~a~%" (word-freely-reduce w3))
  (format t "(word-commute elements w3) = ~a~%" (word-commute-elements w3))
  (format t "(word-freely-reduce (word-commute-elements w3)) = ~a~%"
    (word-freely-reduce (word-commute-elements w3)))
  (setq w4 (word-parse "ab^-1a^-1baa"))
  (format t "w4 = ~a~%" w4)
  (format t "(word-freely-reduce w4) = ~a~%" (word-freely-reduce w4))
  (format t "(word-commute elements w4) = ~a~%" (word-commute-elements w4))
  (format t "(word-freely-reduce (word-commute-elements w4)) = ~a~%"
    (word-freely-reduce (word-commute-elements w4))))
  

(defun word-test ()
 "test that words are handled properly"
 (format t "~%=================================================~%")
 (format t "testing word...~%")
 (format t "=================================================~%")
 (setq a (make-element :char "a" :power 2))
 (setq b (make-element :char "b" :power -2))
 (setq c (make-element :char "c" :power 1))
 (setq d (make-element :char "d" :power 0))
 (setq wm2 (make-word :elements (list a b c d) :power -2))
 (format t "w^-2 = ~a~%" wm2)
 (setq wm1 (make-word :elements (list a b c d) :power -1))
 (format t "w^-1 = ~a~%" wm1)
 (setq w0 (make-word :elements (list a b c d) :power 0))
 (format t "w^0  = ~a~%" w0)
 (setq w1 (make-word :elements (list a b c d) :power 1))
 (format t "w^1  = ~a~%" w1)
 (setq w2 (make-word :elements (list a b c d) :power 2))
 (format t "w^2  = ~a~%" w2)
 (setq wempty (make-word :elements (list) :power 2))
 (format t "wempty  = ~a~%" wempty)
 (format t "w^1  = ~a~%" w1)
 (setq wm0 (word-inverse w1))
 (format t "w1 inverse = ~a~%" wm0)
 (setq wm1 (word-expand w0))
 (format t "w1 inverse expanded = ~a~%" wm1)
 (setq wm2 (word-multiply w1 wm1))
 (format t "w1 * (w1^1 expanded) = ~a~%" wm2)
 (word-expand-test)
 (word-removeZeros-test)
 (word-expand-fully-test)
 (word-freely-reduce-test)
 (word-prefix-test)
 (word-inverse-test)
 (word-multiply-test)
 (word-equal-test)
 (word-parse-test)
 (word-commute-elements-test))

;;; 
(defun SchreierRep (word)
 "SchreierRep reduces the word to the form: a^nb^nx and returns x"
 (let (newword elems)
   (setq newword 
     (word-freely-reduce 
       (word-commute-elements 
         (word-expand-fully word))))
   (setq elems (word-elements newword))
   (when (string= (element-char (car elems)) "a")
     (pop elems))
   (when elems
    (if (string= (element-char (car elems)) "b")
      (pop elems)))
   (if elems 
    (make-word :elements elems :power 1)
    (make-word :elements nil :power 1))))

(defun SchreierRep-test ()
 (format t "~%testing SchreierRep...~%")
 (setq w1 (word-parse "a"))
 (format t "w1 = ~a~%" w1)
 (format t "(SchreierRep w1) = ~a~%" (SchreierRep w1))
 (setq w2 (word-parse "b"))
 (format t "w2 = ~a~%" w2)
 (format t "(SchreierRep w2) = ~a~%" (SchreierRep w2))
 (setq w3 (word-parse "ba"))
 (format t "w3 = ~a~%" w3)
 (format t "(SchreierRep w3) = ~a~%" (SchreierRep w3))
 (setq w4 (word-parse "ac"))
 (format t "w4 = ~a~%" w4)
 (format t "(SchreierRep w4) = ~a~%" (SchreierRep w4))
 (setq w5 (word-parse "ca"))
 (format t "w5 = ~a~%" w5)
 (format t "(SchreierRep w5) = ~a~%" (SchreierRep w5))
 (setq w6 (word-parse "aca^-1"))
 (format t "w6 = ~a~%" w6)
 (format t "(SchreierRep w6) = ~a~%" (SchreierRep w6)))

;;; sigma objects are 

(defun sigma (schreierRep word)
 ())
;;; finite presentations are a two lists, the generators and the relators

(defun finitePresentation-print (object stream depth)
 (format stream "< ")
 (dolist (gen (finitePresentation-generators object))
  (format stream "~a " gen))
 (format stream "; ")
 (dolist (rel (finitePresentation-relators object))
  (format stream "~a " rel))
 (format stream ">"))

(defstruct (finitePresentation (:print-function finitePresentation-print))
  (generators (:type list))
  (relators (:type list)))

(defun finitePresentation-test ()
 "test that a finite presentation is handled properly"
 (format t "~%=================================================~%")
 (format t "testing finitePresentation...~%")
 (format t "=================================================~%")
 (setq a (make-element :char "a" :power 2))
 (setq b (make-element :char "b" :power -2))
 (setq c (make-element :char "c" :power 1))
 (setq d (make-element :char "d" :power 0))
 (setq w (make-word :elements (list a b c d) :power 1))
 (format t "generators=~a~%" w)
 (setq w1 (make-word :elements (list a b c d) :power -2))
 (format t "relators=~a~%" w1)
 (setq fp (make-finitePresentation :generators (list w) :relators (list w1)))
 (format t "finite presentation=~a~%" fp))

(defun RS (FinitePresentationG)
  "Let H be a subgroup of finite index in the finitely presented group G.
   We construct a set of defining relations for H from those of G"
  (ReidemesiterSchreier FinitePresentationG))

(defun ReidemesiterSchreier (FinitePresentationG)
 nil)

(defun make-table (set)
 "make a group table from elements of the given set"
 (let ((maxlen 0) line linelen p (result (reverse set)))
  (dolist (i set)
   (setq maxlen (max (length i) maxlen)))
  (setq maxlen (+ 1 (* 2 maxlen)))
  (setq linelen (* maxlen (+ 1 (length set))))
  (setq line (make-string linelen :initial-element #\ ))
  (dotimes (i (length set))
   (insertInString line (elt set i) (* maxlen (+ i 1))))
  (print line)
  (dolist (row set)
    (setq line (make-string linelen :initial-element #\ ))
    (insertInString line row 0)
    (dotimes (i (length set))
     (setq p (product row (elt set i)))
     (setq result (adjoin p result :test #'string=))
     (insertInString line (product row (elt set i)) (* maxlen (+ i 1))))
    (print line))
 (reverse result)))

(defun insertInString (string word location)
 "given a long string we want to insert a word in the string at location"
 (dotimes (i (length word))
  (setf (elt string (+ location i)) (elt word i))))

(defun make-set ()
 (list 
   (make-word :elements (list (make-element :char "a" :power 1)))
   (make-word :elements (list (make-element :char "b" :power 1)))
   (make-word :elements (list (make-element :char "a" :power -1)))
   (make-word :elements (list (make-element :char "b" :power -1)))))
  
(defun test ()
 (element-test)
 (word-test)
 (finitePresentation-test))

@
<<*>>=
<<code>>
@
\begin{thebibliography}{99}
\bibitem{1} Nothing
\end{thebibliography}
\end{document}