GEMini Atari/GEMini_Atari_CD-ROM_Walnut_Creek_December_1993.iso/zip/language/examples.zoo/misc/gruppen.lsp

Lisp/Scheme | 1991-10-22 | 50KB | 1,233 lines

; Behandlung von Gruppentheorie
; insbesondere Schreier-Sims-Algorithmus und Rubik's Cube-Gruppe
; außerdem Reduktion der Erzeugenden-Wort-Längen
; Bruno Haible, November-Dezember 1987

#+VAX
(setq f "gruppen.lsp")
#+VAX
(defun c ()
  (compile-file "gruppen.lsp" :output-file "gruppen.fas" :listing t)
)


(defvar *gruppen-trace* t)
; gibt an, ob kurze Meldungen auf dem Bildschirm erscheinen


; (intlist a b) ergibt (a a+1 ... b-1 b), wenn a und b integers sind.
(proclaim '(function intlist (integer integer) list))
(defun intlist (a b)
  (do ((l nil (cons i l))
       (i b (1- i)))
      ((< i a) l)
) )

; (list-rotate '(a1 a2 ... an)) ergibt '(a2 ... an a1)
(proclaim '(function list-rotate (list) list))
(defun list-rotate (l)
  (append (rest l) (list (first l)))
)

; (search-min sequence predicate &key :key :default :from-end) sucht in einer
; Folge nach einem minimalen Element. (predicate x y) gibt an, wann x<y sein
; soll. :key ist eine Funktion, die aus jedem Element der Folge die zu
; vegleichende Größe bildet. :default ist der Wert, der sich bei der leeren
; Folge ergibt. Die Suche geschieht von links nach rechts und liefert das am
; weitesten links gelegene Minimum, bei :from-end t umgekehrt.
; Der erste Wert ist der Minimalwert, der zweite das fragliche Folgenelement.
(defun search-min (seq pr &key (key #'identity) (default nil) (from-end nil)
  &aux mel)
  (if from-end (setq seq (reverse seq)))
  (if (zerop (length seq))
      default
      (values (reduce #'(lambda (bisher-min el &aux (k (funcall key el)))
                          (cond ((funcall pr k bisher-min)
                                 (setq mel el) k)
                                (t bisher-min)
                        ) )
                      seq
                      :start 1
                      :initial-value (funcall key (setq mel (elt seq 0)))
              )
              mel
) )   )


;-------------------------------------------------------------------------------
; Die gerade aktuelle Gruppe (Defaultwert)
(defvar *pgruppe*)

;-------------------------------------------------------------------------------
; Datentyp der Permutation:

; (injektiv a) stellt fest, ob eine Abbildung a (ein Array) injektiv ist
; und eine Permutation der Zahlen ab 1 aufwärts ist.
(proclaim '(function injektiv (vector) atom))
(defun injektiv (a)
  (equal (sort (coerce a 'list) #'<) (intlist 1 (length a)))
)

(deftype Mn (&optional n)
  "Mn ist die Menge {1,...,n}"
  ; `(integer (1) (,n)) gemeint
  (declare (ignore n))
  'integer
)

(deftype perm (&optional n)
  "PERM ist eine Permutation, als Abbildung dargestellt."
  ; `(and (array (Mn ,n) (,n)) (satisfies injektiv)) gemeint
  (declare (ignore n))
  `(and (array t (*)) (satisfies injektiv))
)


; Operationen auf Permutationen:

; Anwendung einer Permutation auf eine Zahl
(defmacro apply-perm (s i)
  `(aref ,s (1- ,i))
)

; Aufbauen einer Permutation aus einer Liste l mit n Elementen
(proclaim '(function make-perm (list) perm))
(defun make-perm (l)
  (let* ((n (length l))
         (u (make-array `(,n) :element-type `(Mn ,n) )))
    (do ((i 1 (1+ i))
         (l l (cdr l)))
        ((null l))
      (setf (apply-perm u i) (car l))
    )
    (if (not (injektiv u)) (error "~S ist keine Permutation." u))
    u
) )

; Multiplikation zweier Permutationen: s nach t
(proclaim '(function perm* (perm perm) perm))
(defun perm* (s1 t1)
   (let* ((n (length t1))
          (u (make-array `(,n) :element-type `(Mn ,n) )))
      (do ((i 1 (+ i 1)))
          ((> i n))
        (setf (apply-perm u i) (apply-perm s1 (apply-perm t1 i)))
      )
      u
)  )

; Invertieren einer Permutation
(proclaim '(function perm/ (perm) perm))
(defun perm/ (s)
  (let* ((n (length s))
         (u (make-array `(,n) :element-type `(Mn ,n))))
    (do ((i 1 (1+ i)))
        ((> i n))
      (setf (apply-perm u (apply-perm s i)) i)
    )
    u
) )

; neutrales Element (identische Abbildung)
(proclaim '(function perm-id (&optional integer) perm))
(defun perm-id (&optional (n (pgruppe-grad *pgruppe*)))
  (let ((u (make-array `(,n) :element-type `(Mn ,n))))
    (do ((i 1 (1+ i)))
        ((> i n))
      (setf (apply-perm u i) i)
    )
    u
) )

; Test auf neutrales Element
(proclaim '(function perm-id-p (perm &optional integer) atom))
(defun perm-id-p (p &optional (n (length p)))
  (do ((i 1 (1+ i)))
      ((> i n) t)
    (unless (= (apply-perm p i) i) (return-from perm-id-p nil))
) )

; erzeugt eine Permutation aus ihrer Zyklendarstellung
; Permutation auf {1,...,n}, gegeben als Liste elementfremder Zyklen
(proclaim '(function zykl-perm (list integer) perm))
(defun zykl-perm (zl n)
  (let ((u (perm-id n)))
    (dolist (z zl)
      (setf (apply-perm u (car (last z))) (first z))
      (do ((l z (cdr l)))
          ((endp (cdr l)))
        (setf (apply-perm u (first l)) (second l))
    ) )
    (the perm u)
) )

; erzeugt die Zyklendarstellung einer Permutation
(proclaim '(function perm-zykl (perm) list))
(defun perm-zykl (p)
  (let ((n (length p)))
    (do ((i 1 (1+ i))
         (zl nil) ; Zyklenliste
         (p1 (copy-seq p))) ; verändertes p
        ((> i n) (nreverse zl))
      ; Suche, ob bei i ein Zyklus anfängt
      (unless (= (apply-perm p1 i) i)
        (push (do ((j i)
                   (z nil) ; Zyklus
                   (flag nil t))
                  ((and flag (= j i)) (nreverse z))
                (push j z)
                (rotatef (apply-perm p1 j) j)
                ; neues (apply-perm p1 j) := j,
                ; neues j := altes (apply-perm p1 j)
              )
              zl
      ) )
) ) )


;-------------------------------------------------------------------------------

; Datentyp des benannten Erzeugendensystems

; Ein benanntes Erzeugendensystem ist eine Ansammlung von Permutationen, von
; denen jede einen Namem hat. Auf sie wird mit (aref1 ezs i) verwiesen.
(deftype named-erz-sys (&optional n)
  "ERZ-SYS ist eine Erzeugendensystem aus der Sn."
  ; `(array (cons (perm ,n) string) (*)) gemeint
  (declare (ignore n))
  'vector
)

; (aref1 s i) ergibt allgemein das i-te Element (i=1,2,...) eines Arrays s.
(defmacro aref1 (s i)
  `(aref ,s (1- ,i))
)

; Aufbauen eines Erzeugendensystems aus einer Liste l von Permutationen
(defun make-erz-sys (l)
  (coerce (mapcar #'(lambda (p) (cons p "")) l) 'vector))


;-------------------------------------------------------------------------------

; Datentyp des Erzeugendenprodukts:

; In Bezug auf ein festes Erzeugendensystem ezs mit m Elementen:
; Die Erzeugenden werden durchnumeriert: 1,...,m für die angegebenen,
; -1,...,-m für ihre Inversen.
; Nun bedeutet ein Erzeugendenprodukt ezp = (t1 ... tk) das Produkt
; Et1 * .... * Etk.

(deftype ezp () 'list)

; Multiplikation zweier Erzeugendendarstellungen: s nach t
; An der Nahtstelle werden Inverse bereits zusammengefaßt.
(proclaim '(function ezp* (ezp ezp) ezp))
(defun ezp* (s1 t1)
  (do ((l1 (reverse s1) (cdr l1))
       (l2 t1 (cdr l2)))
      ((or (null l1) (null l2) (not (zerop (+ (car l1) (car l2)))))
       (nreconc l1 l2))
) )

; Invertieren einer Erzeugendendarstellung
(proclaim '(function ezp/ (ezp) ezp))
(defun ezp/ (s)
  (nreverse (mapcar #'- s)))

; Ausgeben eines Erzeugendenprodukts mit Hilfe eines benannten Erzeugenden-
; systems.
(defun ezp-print (s nezs &optional (stream *standard-output*))
  (if (null s)
      (princ '"Id" stream)
      (do ((l s))
          ((endp l))
        (let ((i (pop l)))
          (princ (cdr (aref1 nezs (abs i))) stream)
          (if (minusp i) (princ '"^-1" stream))
        )
        (unless (endp l) (princ '" * " stream))
) )   )


(defconstant uses-ezprt nil "Wird eine Erzeugendenprodukttabelle verwendet?")

; Um Erzeugendendarstellungen weiter vereinfachen zu können, brauchen wir
; eine Tabelle, die uns z.B. sagt, daß wir (5 -3 -4) zu (6) und somit auch
; (7 5 -3 -4 -6) zu (7 6 -6) und dann zu (7) vereinfachen können.

; Datentyp einer Erzeugendenprodukt-Reduktionstabelle
(deftype ezprt ()
  '(or list vector (member t)))

(when uses-ezprt

; Die Reduktionstabelle ist so aufgebaut, daß ein Matchvorgang erheblich
; beschleunigt wird. Rekursiver Aufbau über die Länge des matchenden Wortes:
; Soll (l1 ... lk) zu (r1 ... rj) reduziert werden, so ist im Teilbaum zu l1
; nach dem Ergebnis von (l2 ... lk) zu suchen, also in dessen Teilbaum zu l2
; nach dem Ergebnis von (l3 ... lk), usw. Ist so ein Baum ein Array, so
; ist der i-te Teilbaum die (m+i)-te Komponente; ist der Baum eine Liste, so
; ist der i-te Teilbaum das ASSOC zu i im Baum, der eine A-Liste ist.
; Schließlich ist das Ergebnis (der l1,...,lk-te Teilbaum) die Liste
; (r1 ... rj). (Beachte: Ergebnis NIL bedeutet j=0, der leere Teilbaum wird
; durch t abgekürzt.)
; Damit es sich auch wirklich um eine Vereinfachung handelt, sollte k>j sein.

; leere Reduktionstabelle, enthält nur die trivialen Reduktionen (j -j) -> ()
(proclaim '(function empty-ezprt (integer) ezprt))
(defun empty-ezprt (m)
  (let ((rt (make-array `(,(+ m 1 m)) :element-type 'ezprt :initial-element t)))
    (dolist (j (mapcan #'(lambda (i) (list i (- i))) (intlist 1 m)))
      (setf (aref rt (+ m j)) (list (cons (- j) '())))
    )
    rt
) )

; (ezprt-to-list rt) ergibt eine Liste der Zuordnungen (l r) =
; ((l1 ... lk) (r1 ... rj)) , die in der Tabelle stehen.
(proclaim '(function ezprt-to-list (ezprt) list))
(defun ezprt-to-list (rt)
  (cond ((eq rt t) nil)
        ((or (null rt) (and (consp rt) (integerp (car rt))))
         (list (list nil rt)))
        ((consp rt) ; muß eine A-Liste sein
         (mapcan #'(lambda (a-soc)
                     (mapcar #'(lambda (lr)
                                 (list (cons (car a-soc) (first lr))
                                       (second lr)))
                             (ezprt-to-list (cdr a-soc))
                   ) )
                 rt))
        ((typep rt 'array)
         (let ((m (floor (length rt) 2)))
           (mapcan #'(lambda (i)
                       (mapcar #'(lambda (lr)
                                   (list (cons i (first lr)) (second lr)))
                               (ezprt-to-list (aref rt (+ m i)))
                     ) )
                   (intlist (- m) m)
        )) )
        (t (error "EZP-Reduktionstabelle falsch aufgebaut!"))
) )


; Vereinfachung eines Wortes w mit Hilfe einer Tabelle rt
(proclaim '(function simpezp (ezp ezprt integer) ezp))
(defun simpezp (w rt m)
  ; gehe von hinten durch den String durch und suche nach einem Teilwort,
  ; das auch in der Tabelle vorkommt.
  (let ((wl (reverse w))
        (wr nil))
    ; Es bleibt stets (append (reverse wl) wr) == w.
    (loop
       (if (null wl) (return wr))
       (push (pop wl) wr) ; ein Zeichen weiterrücken
       (do ((trt rt) ; Teilbaum der Reduktionstabelle
            (twr wr)) ; Teilwort der rechten Wortes
           ((or (null trt)
                (and (consp trt) (integerp (car trt))))
            ; Teilbaum zu Ende, ersetze wr durch trt twr
            (setq wl (revappend trt wl))
            (setq wr twr)
           )
         ; Ende von (l1 ... lk) in rt noch nicht erreicht -> muß eine Stufe
         ; weiter hinabsteigen.
         (if (null twr) (return)) ; ergebnisloses Ende der do-Schleife,
                                  ; weil wr zu kurz war
         (if (eq trt t) (return)) ; Ende der do-Schleife, weil Teilbaum leer
         (if (typep trt 'array)
             (setq trt (aref trt (+ m (pop twr))))
             (let ((x (assoc (pop twr) trt)))
               (if x
                   (setq trt (cdr x))
                   (return)       ; Ende der do-Schleife, weil kein Teilbaum
         )   ) )
         (if (eq trt t) (return)) ; Ende der do-Schleife, weil Teilbaum leer
) ) )  )


; (insert-ezprt l r rt m) fügt in die Tabelle rt zusätzlich ein, daß
; l zu r reduziert werden kann. Im Zweifelsfall hat das kürzere l den
; Vortritt (weil es öfter auftreten wird).
; Das Ergebnis ist das veränderte rt.
(proclaim '(function insert-ezprt (ezp ezp ezprt integer) ezprt))
(defun insert-ezprt (l r rt m)
  (if (null l) (error "Wollte ein leeres Wort reduzieren."))
  (labels ((ins-ezprt (l rt) ; rekursive Version, auf Teilwort und Teilbaum
             (cond ((null l) r) ; Reduktion zu r
                   ((null rt) rt) ; nichts verändern
                   ((eq rt t) (acons (first l) (ins-ezprt (rest l) t) nil))
                   ((and (consp rt) (integerp (car rt)))
                    ; kürzeres der beiden Ergebnisse gelte
                    (if (< (length r) (length rt)) r rt))
                   ((consp rt) ; A-Liste rt
                    (let ((a-soc (assoc (first l) rt)))
                      (if a-soc
                          (setf (cdr a-soc) (ins-ezprt (rest l) (cdr a-soc)))
                          (progn
                            (setq rt (acons (first l)
                                            (ins-ezprt (rest l) t)
                                            rt
                            )        )
                            ; rt von A-Liste in Array umwandeln, falls groß
                            (if (> (length rt) m)
                                (setq rt
                                  (do ((u (make-array `(,(+ m 1 m))
                                                      :element-type 'ezprt
                                                      :initial-element t))
                                       (rt rt (cdr rt)))
                                      ((null rt) u)
                                    (setf (aref u (+ m (caar rt))) (cdar rt))
                      )   ) )   ) )
                      rt
                   ))
                   ((typep rt 'array)
                    (setf (aref rt (+ m (car l)))
                          (ins-ezprt (cdr l) (aref rt (+ m (car l)))))
                    rt
                   )
                   (t (error "EZP-Reduktionstabelle falsch aufgebaut!"))
          )) )
          (ins-ezprt l rt)
) )

(defparameter *setid-limit* 19)

; (setid-ezprt w rt m) teilt der Tabelle rt zusätzlich mit, daß das Wort w
; die Identität darstellt, und liefert das neue rt (das eq zum alten rt ist).
(proclaim '(function setid-ezprt (ezp ezprt integer) ezprt))
(defun setid-ezprt (w rt m)
  (setq w (simpezp w rt m))
  (format *gruppen-trace* "~%Wort der Länge ~D =id." (length w))
  (if (or (null w) (> (length w) *setid-limit*)) (return-from setid-ezprt rt))
  ; w=() sofort abfangen, zu große Wörter bringen nichts. (??)
  (dolist (l (list w (ezp/ w))) ; w=id und w^-1=id merken
    ; Sei l = (t1 ... tk). Merke t1...tk=id, t2...tkt1=1, ...
    (let* ((ll (length l))
           (hll (1+ (floor ll 2)))) ; stets hll > l-hll
      (dotimes (i ll)
        (insert-ezprt (subseq l 0 hll) (ezp/ (subseq l hll)) rt m)
        (setq l (list-rotate l)) ; l rotieren
  ) ) )
  rt
)

)

;-------------------------------------------------------------------------------

; Datentyp des Gruppenelementes

(defstruct pgruppel
  "PGRUPPEL ist ein Element einer Untergruppe der Sn, sowohl als
  Permutation als auch als Erzeugendenprodukt dargestellt."
  (perm nil :type perm) ; als Permutation
  (ezp nil :type ezp) ; als Erzeugendenprodukt
)

; Operationen mit Gruppenelementen:

; Multiplikation zweier Gruppenelemente: s nach t
(proclaim '(function pgruppel* (pgruppel pgruppel &optional pgruppe) pgruppel))
(if uses-ezprt
(defun pgruppel* (s1 t1 &optional (G *pgruppe*))
  (make-pgruppel :perm (the perm (perm* (pgruppel-perm s1) (pgruppel-perm t1)))
                 :ezp (simpezp (ezp* (pgruppel-ezp s1) (pgruppel-ezp t1))
                               (pgruppe-ezprt G)
                               (pgruppe-nezs-l G))
) )
(defun pgruppel* (s1 t1 &optional (G *pgruppe*))
  (declare (ignore G))
  (make-pgruppel :perm (perm* (pgruppel-perm s1) (pgruppel-perm t1))
                 :ezp (ezp* (pgruppel-ezp s1) (pgruppel-ezp t1))
) )
)

; Invertieren eines Gruppenelementes
(proclaim '(function pgruppel/ (pgruppel) pgruppel))
(defun pgruppel/ (s)
  (make-pgruppel :perm (perm/ (pgruppel-perm s))
                 :ezp (ezp/ (pgruppel-ezp s))
) )

; neutrales Element (identische Abbildung) als Gruppenelement
(proclaim '(function pgruppe-id (&optional integer) pgruppel))
(defun pgruppe-id (&optional (n (pgruppe-grad *pgruppe*)))
  (make-pgruppel :perm (perm-id n)
                 :ezp nil
) )

; Test auf neutrales Element als Gruppenelement
(proclaim '(function pgruppe-id-p (pgruppel &optional integer) atom))
(defun pgruppe-id-p (g &optional (n (pgruppe-grad *pgruppe*)))
  (or (null (pgruppel-ezp g)) ; das ist am einfachsten zu erkennen
      (perm-id-p (pgruppel-perm g) n)
) )

; Länge des Erzeugendenprodukts eines Gruppenelements, ein Komplexitätsmaß:
(proclaim '(function pgruppel-ezpl (pgruppel) integer))
(defun pgruppel-ezpl (g)
  (length (pgruppel-ezp g))
)

; nettes Ausgeben eines Gruppenelementes
(defun pgruppel-print (p &optional (G *pgruppe*)
                         &key (stream *standard-output*))
  (princ '"Perm. = " stream)
  (write (perm-zykl (pgruppel-perm p)) :stream stream)
  (princ '" = " stream)
  (ezp-print (pgruppel-ezp p) (pgruppe-nezs G) stream)
  (values)
)


;-------------------------------------------------------------------------------
; Datentyp einer Gruppe

(defstruct pgruppe
  "PGRUPPE ist eine Untergruppe einer Sn."
  (grad 0 :type (integer 0 *)) ; das n
  (nezs nil :type (named-erz-sys *)) ; das Permutationensystem,
     ; auf das sich alle Erzeugendenprodukte beziehen.
  (nezs-l 0 :type (integer 0 *)) ; Länge des Erzeugendensystems, das m
  (ezprt nil :type ezprt) ; Erzeugendenprodukt-Reduktionstabelle
  (ezs nil :type list) ; Ein Erzeugendensystem der Gruppe,
     ; das ist eine Liste von Gruppenelementen
  (sgs nil :type (or null vector) ) ; ein
     ; strong generating set (R1,...Rn), so daß mit
     ; Gj=Schnitt der Fixgruppen von 1,...,j (j=0,...,n)
     ; Rj ein Vertretersystem von Gj-1/Gj ist (j=1,...,n),
     ; d.h. jedes s aus der Gj-1 ist eindeutig als s = r t mit t aus Gj
     ; und r aus Rj schreibbar (sogar r(j)=s(j)).
  (ordnung nil :type (or integer null)) ; die Elementanzahl der Gruppe
)


; Benutzerfreundliche Konstruktion einer Gruppe:
; Grad und Erzeugendenliste ezsn = (Name1 Erz1 ... Namek Erzk) eingeben.
(proclaim '(function mache-gruppe (integer list) pgruppe))
(defun mache-gruppe (n ezsn)
  (do ((l ezsn (cddr l))
       (nezs nil)
       (ezlist nil)
       (m 0))
    ((or (endp l) (endp (cdr l)))
     (make-pgruppe :grad n
                   :nezs (coerce (nreverse nezs) 'vector)
                   :ezs (nreverse ezlist)
                   :nezs-l m
                   :ezprt (if uses-ezprt (empty-ezprt m))
    ))
    (let ((p (zykl-perm (second l) n))
          (s (first l)))
      (push (cons p s) nezs)
      (incf m)
      (push (make-pgruppel :perm p :ezp (list m)) ezlist)
) ) )


;-------------------------------------------------------------------------------
; Datentyp des Vertretersystems:

(deftype vert-sys (&optional n)
  "VERT-SYS ist ein Vertretersystem einer Gruppe Gj-1/Gj.
   Das ist eine partielle Abbildung von {1,...,n} in die Gruppe Gj-1."
  (declare (ignore n))
  'list ; eine A-Liste von (k . rk)-Paaren
)

; Datentyp einer Untergruppe einer festen Gruppe G:
; Liste von Gruppenelementen, die die Untergruppe erzeugen.


;-------------------------------------------------------------------------------
; Gruppentheoretische Algorithmen, ausgeführt mit Permutationen:

; Bestimmung der Bahn eines Punktes p unter der Aktion einer Untergruppe
; H von G. H sei gegeben durch eine Liste HEZS von Erzeugenden, so daß
; H= <HEZS> . Die Erzeugenden sind nur die Permutationen.
; Das Ergebnis ist ein Array, der zu jedem i eine Permutation s aus H mit s(p)=i
; enthält (falls eine solche existiert).
(proclaim '(function perm-bahn (integer list &optional pgruppe) vector))
(defun perm-bahn (p HEZS &optional (G *pgruppe*))
  (let* ((n (pgruppe-grad G))
         (B (make-array `(,n) :initial-element nil))
            ; B[j] enthält NIL oder eine Permutation.
         (HEZS2 (append HEZS (mapcar #'perm/ HEZS)))
            ; HEZS2 enthält die Erzeugenden und ihre Inversen
         B1)
    (setf (aref1 B p) (make-perm (intlist 1 n)))
    (loop
       (setq B1 (copy-seq B))
       (dolist (S HEZS2)
          (do ((i 1 (1+ i)))
              ((> i n))
            (let ((j (apply-perm S i)) ; Sei j=S(i)
                  (TT (aref1 B1 i)))
              (if TT                          ; Wenn T(p)=i
                (if (null (aref1 B j))        ; und j noch nicht erreicht,
                    (setf (aref1 B j)
                          (perm* S TT))       ; ist j=S(T(p)).
            ) ) )
       )  )
       (if (equalp B1 B) (return B))
    )
) )

; Vereinfachung eines Erzeugendensystems.
; Einfachste Methode wäre, Doppelte und Identität zu streichen.
; Wir machen mehr: Wir verändern das Erzeugendensystem so weit, daß wir so
; viele Identitäten streichen können, daß nur noch höchstens n*(n-1)/2
; Erzeugende übrigbleiben.
(proclaim '(function perm-simpEZS (list &optional pgruppe) list))
(defun perm-simpEZS (HEZS &optional (G *pgruppe*) &aux (n (pgruppe-grad G)))
  (format *gruppen-trace* "~%Reduziere ~D Erzeugende." (length HEZS))
  (do ((m 1 (1+ m))
       (l HEZS) ; Erzeugendenliste
       (lk nil)) ; kürzere Erzeugendenliste
    ((null l)
     (format *gruppen-trace* "~%Reduzierte von ~D auf ~D Erzeugende."
             (length HEZS) (length lk))
     lk)
    ; Invariante: <HEZS> = <l,lk>,
    ; Zu jedem i aus {1,...,m-1} und zu jedem j aus {i+1,...,n} gibt es in lk
    ; höchstens ein Element s von lk mit s(1)=1,...,s(i-1)=i-1, s(i)=j.
    ; Für jedes Element s von l gilt s(1)=1,...,s(m-1)=m-1.
    ; Spätestens bei m=n ist l leer, also <HEZS> = <lk>.
    (format *gruppen-trace*
         "~%PERM-SIMPEZS, ~D. Durchlauf, habe ~D Erzeugende in l und ~D in lk."
         m (length l) (length lk))
    (let ((ar (make-array `(,n) :initial-element nil)))
      ; ar sammelt in der i-ten Zelle alle s aus l mit s(m)=i.
      (dolist (s l)
        (let ((i (apply-perm s m)))
          (push s (aref1 ar i))
      ) )
      ; alles von l steckt jetzt im Array ar.
      ; Die Zellen 1,...,m-1 sind leer.
      (setq l (aref1 ar m)) ; s mit s(m)=m kann man unverändert übernehmen.
      ; Suche unter allen s in der i-ten Zelle von ar (i>m) dasjenige mit der
      ; kleinsten Erzeugendenproduktlänge, nenne es s0, stecke s0 nach lk,
      ; stecke s0^-1 s statt s nach l, stecke s0^-1 in die i-te Zelle von ar.
      (do ((i (1+ m) (1+ i)))
          ((> i n))
        (let ((slist (aref1 ar i))
              s0 s01)
          (when slist ; wenn die i-te Zelle von ar nicht leer war:
            (setq s0 (first slist)) ; ein beliebiges Element von slist
            (setq s01 (perm/ s0))
            (dolist (s slist)
              (push (perm* s01 s) l))
            (setf (aref1 ar i) s01)
      ) ) )
      (format *gruppen-trace* "~%Jetzt hat l ~D Elemente." (length l))
      ; Beinahe-Inverse werden ebenfalls nach l gesteckt:
      (do ((i (1+ m) (1+ i))
           (s1) (s2) (j))
          ((> i n))
        (setq s1 (aref1 ar i))
        (when s1
              ; s1 ist eine Permutation im Fach i, also s1(i)=m
              (setq j (apply-perm s1 m)) ; j:=s1(m)
              (setq s2 (aref1 ar j))
              (when (and (/= i j) s2)
                    ; s2 ist eine Permutation im Fach j, also s2(j)=m
                    ; Dann ist s = s2 s1 eine Permutation mit s(1)=1,...,
                    ; s(m-1)=m-1, s(m)=s2(j)=m.
                    (setf (aref1 ar i) nil) ; streiche s1 als Erzeugendes
                    (push (perm* s2 s1) l) ; und ersetze es durch s in l
      ) )     )
      ; Entferne alle Identitäten aus l
      (setq l (remove-if #'perm-id-p l))
      ; Sammle alle s0^-1, die noch in ar stehen, und stecke sie nach lk:
      (do ((i (1+ m) (1+ i)))
          ((> i n))
        (let ((s01 (aref1 ar i)))
          (if s01 (push s01 lk))
      ) )
  ) ) ; Bei m=n enthält l nur Identitäten, ist also leer => <HEZS> = <lk>.
)


; Bestimmung der Fixgruppe Hp einer Untergruppe H einer Permutationsgruppe
; G. H ist gegeben als Erzeugendensystem HEZS, also H = <HEZS>.
; Das Ergebnis ist ein ebensolches Erzeugendensystem HpEZS
; für die Fixgruppe Hp. Der zweite Wert ist eine
; AListe, die jedem j aus der Bahn von p unter H genau ein Element rj von H
; mit rj(p)=j zuordnet (wobei zusätzlich rp=id), also ein Vertretersystem
; von H/Hj.
; Gerechnet wird mit Permutationen.
(proclaim
  '(function perm-fixpgruppe (perm list &optional pgruppe) (values list list)))
(defun perm-fixpgruppe (p HEZS &optional (G *pgruppe*))
  (format *gruppen-trace* "~%~%Bestimme die Fixgruppe von ~D" p)
  (format *gruppen-trace* "~%Bestimme die Bahn der ~D." p)
  (let ((n (pgruppe-grad G))
        (B (perm-bahn p HEZS G))
        (R nil)
        HpEZS)
    (do ((i n (- i 1))) ; erst die Bahnelemente zu R zusammenfassen
        ((zerop i))
      (let ((S (aref1 B i)))
        (when S
          (push (cons i S) R)
          (setf (aref1 B i) (cons S (perm/ S)))
    ) ) )
    (format *gruppen-trace* "~%Bahn der ~D hat ~D Elemente." p (length R))
    (format *gruppen-trace* "~%Erwarte ~D Erzeugende."
            (* (length R) (length HEZS)) )
    (setq HpEZS
      (mapcan
        #'(lambda (k &aux (S-S/ (aref1 B k)))
            (if S-S/
               (mapcar
                  #'(lambda (S)
                      (perm* (cdr (aref1 B (apply-perm S k)))
                             (perm* S (car S-S/))
                    ) )
                  HEZS
          ) )  )
        (intlist 1 n)
    ) )
    (values (perm-simpEZS HpEZS G) R)
) )

; Bestimmung eines STRONG GENERATING SET einer Gruppe G.
; Zugleich auch Bestimmung der Ordnung der Gruppe.
; Gerechnet wird mit Permutationen.
(proclaim '(function perm-sgs (pgruppe) vector))
(defun perm-sgs (G)
  (or (pgruppe-sgs G)
      (let* ((n (pgruppe-grad G))
             (e (mapcar #'pgruppel-perm (pgruppe-ezs G))) ; Erzeugendensystem
             (S (make-array `(,n) :element-type 'vert-sys))
             (Card 1)
             R)
        (dotimes (j n) ; j=0,...,n-1, <e> = G(j)
          (multiple-value-setq (e R) (perm-fixpgruppe (1+ j) e G))
          ; <e> = G(j+1), R Vertretersystem von G(j)/G(j+1)
          (setf (aref S j) R)
          (format *gruppen-trace* "~%Vertretersystem mit ~D Elementen."
                  (length R))
          (setq Card (* Card (length R)))
        )
        (setf (pgruppe-sgs G) S)
        (setf (pgruppe-ordnung G) Card)
        (format *gruppen-trace* "~%Gruppe hat ~D Elemente." Card)
        S
) )   )


;-------------------------------------------------------------------------------
; Gruppentheoretische Algorithmen, ausgeführt mit PGruppenelementen:

; Bestimmung der Bahn eines Punktes p unter der Aktion einer Untergruppe
; H von G. H sei gegeben durch eine Liste HEZS von Erzeugenden, so daß
; H= <HEZS> .
; Das Ergebnis ist ein Array, der zu jedem i ein s aus H mit s(p)=i enthält
; (falls ein solches s existiert), und zwar mit einem relativ kurzen
; Erzeugendenprodukt.
(proclaim '(function bahn (integer list &optional pgruppe) vector))
(defun bahn (p HEZS &optional (G *pgruppe*))
  (let* ((n (pgruppe-grad G))
         (B (make-array `(,n) :initial-element nil))
            ; B[j] enthält NIL oder ein Gruppenelement.
         (HEZS2 (append HEZS (mapcar #'pgruppel/ HEZS)))
            ; HEZS2 enthält die Erzeugenden und ihre Inversen
         B1)
    (setf (aref1 B p) (pgruppe-id n))
    (loop
       (setq B1 (copy-seq B))
       (dolist (S HEZS2)
          (do ((i 1 (1+ i)))
              ((> i n))
            (let ((j (apply-perm (pgruppel-perm S) i)) ; Sei j=S(i)
                  (TT (aref1 B1 i)))
              (if TT                          ; Wenn T(p)=i
                (if (or (null (aref1 B j))    ; und j noch nicht erreicht
                        (< (+ (pgruppel-ezpl S) (pgruppel-ezpl TT)) ; oder j
                           (pgruppel-ezpl (aref1 B j)) ; durch ein
                    )   ) ; längeres Gruppenelement bereits erreicht ist,
                    (setf (aref1 B j)
                          (pgruppel* S TT G)) ; ist j=S(T(p)).
            ) ) )
       )  )
       (if (equalp B1 B) (return B))
    )
) )

; Vereinfachung eines Erzeugendensystems.
; Sei eine Untergruppe H = <HEZS> von G durch ein Erzeugendensystem
; HEZS = <e1,...,er> gegeben. Wir suchen: Welche Erzeugenden können wir
; streichen?
; Dazu wird mit Permutationen  <s1,...,sr> gearbeitet, so daß für alle
; l=0,...,r gilt: <e1,...,el> = <s1,...,sl>.
; Erlaubte Operationen sind: ersetze sl durch sl^-1; oder erzetze sl durch
; si^-1*sl oder si^-1*sl^-1 oder ..., wobei 1 <= i < l <= r ist.
; Falls sich dabei sl=id ergibt, ist el in HEZS überflüssig.
; Gerechnet wird mit den si als Permutationen, an denen noch die Nummer i-1
; anhaftet (Nummern gehen hier ab 0):
(defstruct (numperm (:type list)) perm num)
(proclaim '(function simpEZS (list &optional pgruppe) list))
(defun simpEZS (HEZS &optional (G *pgruppe*) &aux (n (pgruppe-grad G)))
  ; sortiere HEZS nach aufsteigender Länge der Erzeugendenprodukte
  (setq HEZS (coerce
               (sort HEZS #'< :key #'pgruppel-ezpl)
               'array))
  (format *gruppen-trace* "~%Reduziere ~D Erzeugende." (length HEZS))
  (do ((m 1 (1+ m))
       (l (mapcar #'(lambda (i)
                      (make-numperm :perm (pgruppel-perm (aref HEZS i)) :num i))
                  (intlist 0 (1- (length HEZS)))
      ))  )      ; Erzeugendenliste, am Anfang alle Elemente von HEZS
    ((null l))
    (format *gruppen-trace* "~%~D. Durchlauf." m)
    ; Sei r=(length HEZS).
    ; Sei M1 die Menge aller Nummern {1,...,r}.
    ; HEZS enthält die ursprünglichen Erzeugenden ei.
    ; Sei M2 die Menge aller Nummern i mit (aref1 HEZS i) = NIL,
    ;    das bedeutet: si=id überflüssig, ei bereits gestrichen.
    ; Sei M3 die Menge der Nummern der Elemente von l.
    ; Sei M4 = M1 \ M3 die Menge der Nummern i der Erzeugenden, von denen
    ;    bereits erkannt wurde, ob sie notwendig sind (i in M5 :=  M4 \ M2)
    ;    oder ob sie überflüssig sind (i in M6 := M4 n M2).
    ; 1. Invariante:
    ; Die in l auftretenden Permutationen haben paarweise verschiedene Nummern.
    ; Für alle j=0,...,r bleibt <s1,...,sj>=<e1,...,ej> invariant.
    ; 2. Invariante:
    ; Für jedes Element s von l gilt s(1)=1,...,s(m-1)=m-1.
    ; Daher: spätestens bei m=n ist l leer.
    ; 3. Invariante: M5 hat höchstens (n-1) + ... + (n-m+1) Elemente.
    (let ((ar (make-array `(,n) :initial-element nil)))
      ; ar sammelt in der i-ten Zelle alle s aus l mit s(m)=i.
      (dolist (s l)
        (let ((i (apply-perm (numperm-perm s) m)))
          (push s (aref1 ar i))
      ) )
      ; alles von l steckt jetzt im Array ar.
      ; Die Zellen 1,...,m-1 sind leer.
      (setq l (aref1 ar m)) ; s mit s(m)=m kann man unverändert übernehmen.
      ; Suche unter allen s in der i-ten Zelle von ar (i>m) dasjenige mit der
      ; kleinsten Nummer, nenne es s0,
      ; stecke s0^-1 s statt s nach l, stecke s0^-1 in die i-te Zelle von ar.
      (do ((i (1+ m) (1+ i)))
          ((> i n))
        (let ((slist (aref1 ar i))
              s0 s01)
          (when slist ; wenn die i-te Zelle von ar nicht leer war:
            (multiple-value-setq (s01 s0)
              (search-min slist #'<
                :key #'(lambda (s) (numperm-num s))))
            (setq s01 (perm/ (numperm-perm s0)))
            (dolist (s slist)
              (unless (eq s s0)
                ; s hat eine größere Nummer als s0.
                ; Ersetze s durch s0^-1 * s
                (push (make-numperm :perm (perm* s01 (numperm-perm s))
                                    :num (numperm-num s))
                      l)))
            ; Stecke s0^-1 in die i-te Zelle.
            (setf (aref1 ar i)
                  (make-numperm :perm s01 :num (numperm-num s0)))
      ) ) )
      ; Beinahe-Inverse werden ebenfalls nach l gesteckt:
      (do ()
       ((do ((i (1+ m) (1+ i))
             (s1) (s2) (j) (modified nil))
            ((> i n) (not modified))
          (setq s1 (aref1 ar i))
          (when s1
                ; s1 ist eine Permutation im Fach i, also s1(i)=m, i > m
                (setq j (apply-perm (numperm-perm s1) m)) ; j:=s1(m) > m
                (setq s2 (aref1 ar j))
                (when (and (/= i j) s2)
                      ; s2 ist eine Permutation im Fach j, also s2(j)=m
                      ; Dann ist s = s2 s1 eine Permutation mit s(1)=1,...,
                      ; s(m-1)=m-1, s(m)=s2(j)=m.
                      ; Streiche das Erzeugende mit der größeren Nummer
                      (ecase (signum (- (numperm-num s1) (numperm-num s2)))
                        ((-1) ; s1 hat die kleinere Nummer
                              (setf (aref1 ar j) nil) ) ; s2 streichen
                        ((1)  ; s1 hat die größere Nummer
                              (setf (aref1 ar i) nil) ) ; s1 streichen
                      )
                      ; und ersetze es durch s in l:
                      (push (make-numperm
                              :perm (perm* (numperm-perm s2) (numperm-perm s1))
                              :num (max (numperm-num s1) (numperm-num s2)))
                            l)
                      (setq modified t)
       )) )     ) ; solange wiederholen, bis nichts mehr verändert wurde.
      )
      (format *gruppen-trace* "~%Jetzt hat l ~D Elemente." (length l))
      ; Bis jetzt gingen keine Nummern verloren, d.h. M2 blieb unverändert,
      ; M3 wurde verkleinert, M4 wurde vergrößert. Die noch in ar steckenden
      ; Permutationen sind notwendig: worum M3 verkleinert wurde, darum wird
      ; M5 vergrößert. M6 blieb unverändert, weil mit Elementen aus M2 gar
      ; nicht mehr gearbeitet wurde, also M4 nicht um Elemente von M2
      ; vergrößert wurde.
      ; M5 wurde um höchstens (n-m) Elemente vergrößert, weil diese aus
      ; (aref1 ar (1+ m)) ... (aref1 ar n) kamen.
      ; Entferne alle si=id aus l und entsprechende ei aus HEZS:
      (setq l (do ((l1 l (cdr l1))
                   (l2 nil))
                  ((endp l1) l2)
                (if (perm-id-p (numperm-perm (car l1)) n)
                    (setf (aref HEZS (numperm-num (car l1))) nil)
                    (push (car l1) l2)
      )       ) )
      (format *gruppen-trace* "~%Jetzt hat l ~D Elemente." (length l))
      ; Um die jetzt gestrichenen Nummern wurde M2 vergrößert, M3 verkleinert,
      ; M4 vergrößert, M6 vergrößert, während M5 gleich blieb.
    ); Die Schleifeninvariante bleibt erhalten.
  ); Spätestens bei m=n enthält l nur Identitäten, ist also leer.
  ; Wenn l leer ist, ist M3 leer, M4=M1, und die nichtleeren Felder von HEZS
  ; entsprechen den notwendigen Erzeugenden (i aus M5 = M1 \ M2).
  ; Sammle die noch in HEZS steckenden, notwendigen, Erzeugenden:
  (setq HEZS (coerce (remove nil HEZS) 'list))
  (format *gruppen-trace* "~%Reduzierte auf ~D Erzeugende." (length HEZS))
  HEZS
)


; Bestimmung der Fixgruppe Hp einer Untergruppe H einer Permutationsgruppe
; G. H ist gegeben als Erzeugendensystem HEZS, also H = <HEZS>.
; Das Ergebnis ist ein ebensolches Erzeugendensystem HpEZS
; für die Fixgruppe Hp. Der zweite Wert ist eine
; AListe, die jedem j aus der Bahn von p unter H genau ein Element rj von H
; mit rj(p)=j zuordnet (wobei zusätzlich rp=id), also ein Vertretersystem
; von H/Hj.
(proclaim '(function fixpgruppe (integer list &optional pgruppe) list))
(defun fixpgruppe (p HEZS &optional (G *pgruppe*))
  (format *gruppen-trace* "~%~%Bestimme die Fixgruppe von ~D" p)
  (format *gruppen-trace* "~%Bestimme die Bahn der ~D." p)
  (let ((n (pgruppe-grad G))
        (B (bahn p HEZS G))
        (R nil)
        HpEZS)
    (do ((i n (- i 1))) ; erst die Bahnelemente zu R zusammenfassen
        ((zerop i))
      (let ((S (aref1 B i)))
        (when S
          (push (cons i S) R)
          (setf (aref1 B i) (cons S (pgruppel/ S)))
    ) ) )
    (format *gruppen-trace* "~%Bahn der ~D hat ~D Elemente." p (length R))
    (format *gruppen-trace* "~%Erwarte ~D Erzeugende."
            (* (length R) (length HEZS)) )
    (setq HpEZS
      (mapcan
        #'(lambda (k &aux (S-S/ (aref1 B k)))
            (if S-S/
               (mapcar
                  #'(lambda (S)
                      (pgruppel* (cdr (aref1 B (apply-perm (pgruppel-perm S) k)
                                 )    )
                                 (pgruppel* S (car S-S/) G)
                                 G
                    ) )
                  HEZS
          ) )  )
        (intlist 1 n)
    ) )
    (values (simpEZS HpEZS G) R)
) )

; Bestimmung eines STRONG GENERATING SET einer Gruppe G.
; Zugleich auch Bestimmung der Ordnung der Gruppe.
(proclaim '(function sgs (pgruppe) vector))
(defun sgs (G)
  (or (pgruppe-sgs G)
      (let* ((n (pgruppe-grad G))
             (e (pgruppe-ezs G)) ; anfängliches Erzeugendensystem
             (S (make-array `(,n) :element-type 'vert-sys))
             (Card 1)
             R)
        (dotimes (j n) ; j=0,...,n-1, <e> = G(j)
          (multiple-value-setq (e R) (fixpgruppe (1+ j) e G))
          ; <e> = G(j+1), R Vertretersystem von G(j)/G(j+1)
          (setf (aref S j) R)
          (format *gruppen-trace* "~%Vertretersystem mit ~D Elementen."
                  (length R))
          (setq Card (* Card (length R)))
        )
        (setf (pgruppe-sgs G) S)
        (setf (pgruppe-ordnung G) Card)
        (format *gruppen-trace* "~%Gruppe hat ~D Elemente." Card)
        S
) )   )


; Bestimmung der Ordnung einer Gruppe G.
(proclaim '(function ordnung (pgruppe) integer))
(defun ordnung (G)
  (or (pgruppe-ordnung G)
      (progn
        (sgs G)
        (or (pgruppe-ordnung G)
            (let ((n (pgruppe-grad G))
                  (S (pgruppe-sgs G))
                  (Card 1))
              (dotimes (j n) (setq Card (* Card (length (aref S j)))))
              (setf (pgruppe-ordnung G) Card)
) )   ) )   )


; Bestimmung des Schnittes verschiedener Fixgruppen einer Gruppe G.
(proclaim '(function sfixgruppe (list &optional pgruppe) pgruppe))
(defun sfixgruppe (ellist &optional (G *pgruppe*))
  (let ((HEZS (pgruppe-ezs G))
        (Card (pgruppe-ordnung G)))
    (dolist (p ellist)
      (multiple-value-bind (H R) (fixpgruppe p HEZS G)
        (if Card (setq Card (/ Card (length R))))
        (setq HEZS H)
    ) )
    (make-pgruppe :grad (pgruppe-grad G)
                  :nezs (pgruppe-nezs G)
                  :nezs-l (pgruppe-nezs-l G)
                  :ezprt (pgruppe-ezprt G)
                  :ezs HEZS
                  :ordnung Card
) ) )


; nimmt eine Permutation und eine Gruppe G entgegen und liefert NIL,
; falls p kein Element der Gruppe G ist. Bei p in G liefert es die Darstellung
; von p als Gruppenelement, in der auch die Darstellung von p aus Erzeugenden
; inbegriffen ist.
(proclaim
  '(function perm-to-pgruppel (perm &optional pgruppe) (or null pgruppel)))
(defun perm-to-pgruppel (p &optional (Gr *pgruppe*)
                           &aux (n (pgruppe-grad Gr)))
 (and (= (length p) n)
  (let ((S (sgs Gr)))
   (flet
     ((p-t-p-1 (p) ; Darstellung von p aus "g p1 = p"
        (do ((i 1 (1+ i))
             (p1 p)
             (g (pgruppe-id n)))
            ((> i n) g)
          ; invariant: g p1 = p und p1(1)=1,...,p1(i-1)=i-1 und g in Gr.
          ; (assert (equalp (perm* (pgruppel-perm g) p1) p))
          (let* ((R (aref1 S i)) ; Vertretersystem von G(i-1)/G(i)
                 (j (apply-perm p1 i)) ; j=p1(i)
                 (Rj (assoc j R))) ; nil oder (j . r) mit r(i)=j, r aus G(i-1)
            (if (null Rj)
                (return-from perm-to-pgruppel nil)
                (progn
                  (setq Rj (cdr Rj))
                  ; p1 = r p1' und also p = g p1 = g r p1' = g' p1'
                  (setq g (pgruppel* g Rj Gr)) ; g' = g r
                  (setq p1 (perm* (perm/ (pgruppel-perm Rj)) p1))
                  ; p1' = r^-1 p1, hat p1'(1)=1,...,p1'(i-1)=i-1 und
                  ; p1'(i) = r^-1 (j) = i.
      ) ) ) )   )
      (p-t-p-2 (p) ; Darstellung von p aus "g p1 h^-1 = p"
        (do ((i 1 (1+ i))
             (p1 p)
             (g (pgruppe-id n))
             (h (pgruppe-id n)))
            ((> i n) (pgruppel* g (pgruppel/ h) Gr))
          ; Invariant: g p1 h^-1 = p und p1(1)=1,...,p1(i-1)=i-1 und g,h in Gr.
          ; (assert (equalp (perm* (perm* (pgruppel-perm g) p1)
          ;                        (perm/ (pgruppel-perm h))) p))
          (let ((R (aref1 S i))
                (j (apply-perm p1 i))
                (k (apply-perm (perm/ p1) i)))
            (unless (= i j) ; Bei j=p1(i) = i ist nichts zu tun.
              (let ((Rj (assoc j R))  ; NIL oder (j . rij) mit rij(i)=j
                    (Rk (assoc k R))) ; NIL oder (k . rik) mit rik(i)=k
                (if (or (null Rj) (null Rk))
                  (return-from perm-to-pgruppel nil)
                  ; Bei p in Gr wäre auch p1 in Gr.
                  ; Bei (null Rj) wegen p1 (i) = j ein Widerspruch.
                  ; Bei (null Rk) wegen p1^-1 (i) = k ebenso.
                  (progn
                    (setq Rj (cdr Rj))
                    (setq Rk (cdr Rk))
                    (if (<= (pgruppel-ezpl Rj) (pgruppel-ezpl Rk))
                      (progn
                        ; Ziehe Rj vor:
                        ; p1 = rij p1' und also p = g rij p1' h^-1 = g' p1' h^-1
                        (setq g (pgruppel* g Rj Gr)) ; g' = g r, p1' = rij^-1 p1
                        (setq p1 (perm* (perm/ (pgruppel-perm Rj)) p1))
                        ; p1'(1)=1,...,p1'(i-1)=i-1, p1'(i)=rij^-1(j)=i.
                      )
                      (progn
                        ; Ziehe Rk vor: p1 = p1' rik^-1 und
                        ; p = g p1' rik^-1 h^-1 = g p1' h'^-1
                        (setq h (pgruppel* h Rk Gr)) ; h' = h rik, p1' = p1 rik
                        (setq p1 (perm* p1 (pgruppel-perm Rk)))
                        ; p1'(1)=1,...,p1'(i-1)=i-1, p1'(i)=p1(k)=i.
     )) ) ) ) ) ) ) ) )
     (multiple-value-bind (gl g)
       (search-min
         (list ; drei mögliche Erzeugendenprodukte
             (p-t-p-1 p)
             (pgruppel/ (p-t-p-1 (perm/ p)))
             (p-t-p-2 p)
         )
         #'<
         :key #'pgruppel-ezpl
       )
       (declare (ignore gl))
       (format *gruppen-trace* "~%")
       (if *gruppen-trace* (pgruppel-print g Gr))
       g ; das Ergebnis
     )
))))

; (maxezpl G) liefert zu einer Gruppe mit fertigem SGS, mit maximal
; wievielen (benannten) Erzeugenden sich ein beliebiges Gruppenelement
; darstellen läßt.
(proclaim '(function maxezpl (&optional pgruppe) integer))
(defun maxezpl (&optional (G *pgruppe*))
  ; Das ist = Summe (über alle Ri von S) der Länge des längsten
  ;           - bzw. falls beim längsten p aus Ri  p(i) /= p^-1(i) gilt - des
  ;           zweitlängsten p aus Ri.
  (let ((S (sgs G))
        (sum 0))
    (dolist (i (intlist 1 (length S)))
      (incf sum (let ((lmax 0)  ; Länge der längsten Permutation
                      (l2max 0) ; Länge der zweitlängsten Permutation
                      (maxinv t)) ; Flag, das angibt, ob bei der längsten
                                  ; Permutation p p1(i) = p1^-1(i) war.
                  (dolist (P (aref1 S i))
                    (let ((l (pgruppel-ezpl (cdr P)))
                          (p1 (pgruppel-perm (cdr P))))
                      (cond ((<= l l2max)) ; nichts
                            ((<= l lmax) ; neues zweitlängstes
                             (setq l2max l))
                            (t ; neues Maximum
                               (setq l2max lmax)
                               (setq lmax l)
                               (setq maxinv
                                 (= i (apply-perm p1 (apply-perm p1 i)))
                    ) )     )  )
                  )
                  (if maxinv lmax l2max)
    ) )         )
    sum
) )


;-------------------------------------------------------------------------------
; Beispiele:
(defvar w2)
(defvar rubik2)
(defvar rubik3)
(defvar rubikw)
(defvar dodeka)

(defun mache-gruppen () ; konstruiert alle Gruppen, "roh" (leer)

; Drehgruppe des Würfels, auf den Flächen operierend
(setq w2 (mache-gruppe 6
           '("Dreh16" ((2 3 5 4))
             "Dreh25" ((1 3 6 4))
             "Dreh34" ((1 2 6 5))
)        )  )

; Drehgruppe des 2 x 2 x 2 - Rubik-Würfels
(setq rubik2
  (mache-gruppe 24
    '("U" ((1 2 3 4) (5 7 9 11) (6 8 10 12))
      "D" ((13 14 15 16) (17 19 21 23) (18 20 22 24))
      "F" ((5 17 18 6) (1 24 14 7) (2 12 13 19))
      "B" ((10 9 21 22) (4 8 15 23) (3 20 16 11))
      "L" ((8 7 19 20) (3 6 14 21) (2 18 15 9))
      "R" ((12 11 23 24) (1 10 16 17) (4 22 13 5))
) )  )

; Drehgruppe des 3 x 3 x 3 - Rubik-Würfels bei festen Flächenmitten
(setq rubik3
  (mache-gruppe 48
  '("U" ((1 3 8 6) (2 5 7 4) (9 48 15 12) (10 47 16 13) (11 46 17 14))
    "L" ((9 11 26 24) (10 19 25 18) (1 12 33 41) (4 20 36 44) (6 27 38 46))
    "F" ((12 14 29 27) (13 21 28 20) (6 15 35 26) (7 22 34 19) (8 30 33 11))
    "R" ((15 17 32 30) (16 23 31 22) (3 43 35 14) (5 45 37 21) (8 48 40 29))
    "D" ((33 35 40 38) (34 37 39 36) (24 27 30 43) (25 28 31 42) (26 29 32 41))
    "B" ((41 43 48 46) (42 45 47 44) (1 24 40 17) (2 18 39 23) (3 9 38 32))
) ))

; Drehgruppe des 3 x 3 x 3 - Rubik-Würfels bei festen Flächenmitten
; Jede Drehung ist nach der Farbe ihres Mittelfeldes benannt.
(setq rubikw
  (mache-gruppe 48
  '("Weiß"   ((1 3 8 6) (2 5 7 4) (9 48 15 12) (10 47 16 13) (11 46 17 14))
    "Blau"   ((9 11 26 24) (10 19 25 18) (1 12 33 41) (4 20 36 44) (6 27 38 46))
    "Rot"    ((12 14 29 27) (13 21 28 20) (6 15 35 26) (7 22 34 19) (8 30 33 11))
    "Grün"   ((15 17 32 30) (16 23 31 22) (3 43 35 14) (5 45 37 21) (8 48 40 29))
    "Gelb"   ((33 35 40 38) (34 37 39 36) (24 27 30 43) (25 28 31 42) (26 29 32 41))
    "Orange" ((41 43 48 46) (42 45 47 44) (1 24 40 17) (2 18 39 23) (3 9 38 32))
) ))

; Drehgruppe von Rubik's Dodekaeder bei festen Flächenmitten
(setq dodeka
  (mache-gruppe 120
    '("Weiß"       ((1 9 7 5 3) (2 10 8 6 4) (11 51 41 31 21)
                    (19 59 49 39 29) (20 60 50 40 30))
      "Rot"        ((1 21 61 109 57) (2 22 62 110 58) (3 23 63 101 59)
                    (11 19 17 15 13) (12 20 18 16 14))
      "Blau"       ((3 31 71 69 17) (4 32 72 70 18) (5 33 73 61 19)
                    (21 29 27 25 23) (22 30 28 26 24))
      "Schwarz"    ((5 41 81 79 27) (6 42 82 80 28) (7 43 83 71 29)
                    (31 39 37 35 33) (32 40 38 36 34))
      "Gold"       ((7 51 91 89 37) (8 52 92 90 38) (9 53 93 81 39)
                    (41 49 47 45 43) (42 50 48 46 44))
      "Dunkelgrün" ((1 13 103 91 49) (9 11 101 99 47) (10 12 102 100 48)
                    (51 59 57 55 53) (52 60 58 56 54))
      "Silber"     ((15 23 73 119 107) (16 24 74 120 108) (17 25 75 111 109)
                    (61 69 67 65 63) (62 70 68 66 64))
      "Hellgrün"   ((25 33 83 117 67) (26 34 84 118 68) (27 35 85 119 69)
                    (71 79 77 75 73) (72 80 78 76 74))
      "Orange"     ((35 43 93 115 77) (36 44 94 116 78) (37 45 95 117 79)
                    (81 89 87 85 83) (82 90 88 86 84))
      "Grau"       ((45 53 103 113 87) (46 54 104 114 88) (47 55 105 115 89)
                    (91 99 97 95 93) (92 100 98 96 94))
      "Braun"      ((13 63 111 97 55) (14 64 112 98 56) (15 65 113 99 57)
                    (101 109 107 105 103) (102 110 108 106 104))
      "Gelb"       ((65 75 85 95 105) (66 76 86 96 106) (67 77 87 97 107)
                    (111 119 117 115 113) (112 120 118 116 114))
) )  )

)

#|
; Um von den Gruppen das SGS auszurechnen:
; (sgs w2) (sgs rubik2) (sgs rubik3) (sgs rubikw) (sgs dodeka)

; Um von die Gruppen abzuspeichern:
(with-open-file (s "Gruppen.dat" :direction :output)
  (pprint w2 s) (pprint rubik2 s) (pprint rubik3 s) )
; [Vorher in VAX-LISP eventuell (setq *print-right-margin* 130) ]

; Um die Gruppen wieder einzuladen:
(defun lade-gruppen ()
  (with-open-file (s "Gruppen.dat" :direction :input)
    (setq w2 (read s))
    (setq rubik2 (read s))
    (setq rubik3 (read s))
    t
) )
|#

; Um eine spezielle Gruppe abzuspeichern, z.B. (save-gruppe rubik3)
(defmacro save-gruppe (grp-name)
  `(with-open-file (s ,(concatenate 'string (string grp-name) '".SGS")
                    :direction :output :if-exists :new-version)
     #+VAX (let ((*print-right-margin* 132)) (pprint ,grp-name s))
     #-VAX (pprint ,grp-name s)
)  )

; Um eine spezielle Gruppe einzuladen, z.B. (lade-gruppe rubik3)
(defmacro lade-gruppe (grp-name)
  `(with-open-file (s ,(concatenate 'string (string grp-name) '".SGS")
                    :direction :input)
     (setf ,grp-name (read s))
     t
)  )