home *** CD-ROM | disk | FTP | other *** search
/ GEMini Atari / GEMini_Atari_CD-ROM_Walnut_Creek_December_1993.iso / files / language / examples / gruppen.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1993-10-23  |  48.8 KB  |  1,233 lines
  1. ; Behandlung von Gruppentheorie
  2. ; insbesondere Schreier-Sims-Algorithmus und Rubik's Cube-Gruppe
  3. ; außerdem Reduktion der Erzeugenden-Wort-Längen
  4. ; Bruno Haible, November-Dezember 1987
  5.  
  6. #+VAX
  7. (setq f "gruppen.lsp")
  8. #+VAX
  9. (defun c ()
  10.   (compile-file "gruppen.lsp" :output-file "gruppen.fas" :listing t)
  11. )
  12.  
  13.  
  14. (defvar *gruppen-trace* t)
  15. ; gibt an, ob kurze Meldungen auf dem Bildschirm erscheinen
  16.  
  17.  
  18. ; (intlist a b) ergibt (a a+1 ... b-1 b), wenn a und b integers sind.
  19. (proclaim '(function intlist (integer integer) list))
  20. (defun intlist (a b)
  21.   (do ((l nil (cons i l))
  22.        (i b (1- i)))
  23.       ((< i a) l)
  24. ) )
  25.  
  26. ; (list-rotate '(a1 a2 ... an)) ergibt '(a2 ... an a1)
  27. (proclaim '(function list-rotate (list) list))
  28. (defun list-rotate (l)
  29.   (append (rest l) (list (first l)))
  30. )
  31.  
  32. ; (search-min sequence predicate &key :key :default :from-end) sucht in einer
  33. ; Folge nach einem minimalen Element. (predicate x y) gibt an, wann x<y sein
  34. ; soll. :key ist eine Funktion, die aus jedem Element der Folge die zu
  35. ; vegleichende Größe bildet. :default ist der Wert, der sich bei der leeren
  36. ; Folge ergibt. Die Suche geschieht von links nach rechts und liefert das am
  37. ; weitesten links gelegene Minimum, bei :from-end t umgekehrt.
  38. ; Der erste Wert ist der Minimalwert, der zweite das fragliche Folgenelement.
  39. (defun search-min (seq pr &key (key #'identity) (default nil) (from-end nil)
  40.   &aux mel)
  41.   (if from-end (setq seq (reverse seq)))
  42.   (if (zerop (length seq))
  43.       default
  44.       (values (reduce #'(lambda (bisher-min el &aux (k (funcall key el)))
  45.                           (cond ((funcall pr k bisher-min)
  46.                                  (setq mel el) k)
  47.                                 (t bisher-min)
  48.                         ) )
  49.                       seq
  50.                       :start 1
  51.                       :initial-value (funcall key (setq mel (elt seq 0)))
  52.               )
  53.               mel
  54. ) )   )
  55.  
  56.  
  57. ;-------------------------------------------------------------------------------
  58. ; Die gerade aktuelle Gruppe (Defaultwert)
  59. (defvar *pgruppe*)
  60.  
  61. ;-------------------------------------------------------------------------------
  62. ; Datentyp der Permutation:
  63.  
  64. ; (injektiv a) stellt fest, ob eine Abbildung a (ein Array) injektiv ist
  65. ; und eine Permutation der Zahlen ab 1 aufwärts ist.
  66. (proclaim '(function injektiv (vector) atom))
  67. (defun injektiv (a)
  68.   (equal (sort (coerce a 'list) #'<) (intlist 1 (length a)))
  69. )
  70.  
  71. (deftype Mn (&optional n)
  72.   "Mn ist die Menge {1,...,n}"
  73.   ; `(integer (1) (,n)) gemeint
  74.   (declare (ignore n))
  75.   'integer
  76. )
  77.  
  78. (deftype perm (&optional n)
  79.   "PERM ist eine Permutation, als Abbildung dargestellt."
  80.   ; `(and (array (Mn ,n) (,n)) (satisfies injektiv)) gemeint
  81.   (declare (ignore n))
  82.   `(and (array t (*)) (satisfies injektiv))
  83. )
  84.  
  85.  
  86. ; Operationen auf Permutationen:
  87.  
  88. ; Anwendung einer Permutation auf eine Zahl
  89. (defmacro apply-perm (s i)
  90.   `(aref ,s (1- ,i))
  91. )
  92.  
  93. ; Aufbauen einer Permutation aus einer Liste l mit n Elementen
  94. (proclaim '(function make-perm (list) perm))
  95. (defun make-perm (l)
  96.   (let* ((n (length l))
  97.          (u (make-array `(,n) :element-type `(Mn ,n) )))
  98.     (do ((i 1 (1+ i))
  99.          (l l (cdr l)))
  100.         ((null l))
  101.       (setf (apply-perm u i) (car l))
  102.     )
  103.     (if (not (injektiv u)) (error "~S ist keine Permutation." u))
  104.     u
  105. ) )
  106.  
  107. ; Multiplikation zweier Permutationen: s nach t
  108. (proclaim '(function perm* (perm perm) perm))
  109. (defun perm* (s1 t1)
  110.    (let* ((n (length t1))
  111.           (u (make-array `(,n) :element-type `(Mn ,n) )))
  112.       (do ((i 1 (+ i 1)))
  113.           ((> i n))
  114.         (setf (apply-perm u i) (apply-perm s1 (apply-perm t1 i)))
  115.       )
  116.       u
  117. )  )
  118.  
  119. ; Invertieren einer Permutation
  120. (proclaim '(function perm/ (perm) perm))
  121. (defun perm/ (s)
  122.   (let* ((n (length s))
  123.          (u (make-array `(,n) :element-type `(Mn ,n))))
  124.     (do ((i 1 (1+ i)))
  125.         ((> i n))
  126.       (setf (apply-perm u (apply-perm s i)) i)
  127.     )
  128.     u
  129. ) )
  130.  
  131. ; neutrales Element (identische Abbildung)
  132. (proclaim '(function perm-id (&optional integer) perm))
  133. (defun perm-id (&optional (n (pgruppe-grad *pgruppe*)))
  134.   (let ((u (make-array `(,n) :element-type `(Mn ,n))))
  135.     (do ((i 1 (1+ i)))
  136.         ((> i n))
  137.       (setf (apply-perm u i) i)
  138.     )
  139.     u
  140. ) )
  141.  
  142. ; Test auf neutrales Element
  143. (proclaim '(function perm-id-p (perm &optional integer) atom))
  144. (defun perm-id-p (p &optional (n (length p)))
  145.   (do ((i 1 (1+ i)))
  146.       ((> i n) t)
  147.     (unless (= (apply-perm p i) i) (return-from perm-id-p nil))
  148. ) )
  149.  
  150. ; erzeugt eine Permutation aus ihrer Zyklendarstellung
  151. ; Permutation auf {1,...,n}, gegeben als Liste elementfremder Zyklen
  152. (proclaim '(function zykl-perm (list integer) perm))
  153. (defun zykl-perm (zl n)
  154.   (let ((u (perm-id n)))
  155.     (dolist (z zl)
  156.       (setf (apply-perm u (car (last z))) (first z))
  157.       (do ((l z (cdr l)))
  158.           ((endp (cdr l)))
  159.         (setf (apply-perm u (first l)) (second l))
  160.     ) )
  161.     (the perm u)
  162. ) )
  163.  
  164. ; erzeugt die Zyklendarstellung einer Permutation
  165. (proclaim '(function perm-zykl (perm) list))
  166. (defun perm-zykl (p)
  167.   (let ((n (length p)))
  168.     (do ((i 1 (1+ i))
  169.          (zl nil) ; Zyklenliste
  170.          (p1 (copy-seq p))) ; verändertes p
  171.         ((> i n) (nreverse zl))
  172.       ; Suche, ob bei i ein Zyklus anfängt
  173.       (unless (= (apply-perm p1 i) i)
  174.         (push (do ((j i)
  175.                    (z nil) ; Zyklus
  176.                    (flag nil t))
  177.                   ((and flag (= j i)) (nreverse z))
  178.                 (push j z)
  179.                 (rotatef (apply-perm p1 j) j)
  180.                 ; neues (apply-perm p1 j) := j,
  181.                 ; neues j := altes (apply-perm p1 j)
  182.               )
  183.               zl
  184.       ) )
  185. ) ) )
  186.  
  187.  
  188. ;-------------------------------------------------------------------------------
  189.  
  190. ; Datentyp des benannten Erzeugendensystems
  191.  
  192. ; Ein benanntes Erzeugendensystem ist eine Ansammlung von Permutationen, von
  193. ; denen jede einen Namem hat. Auf sie wird mit (aref1 ezs i) verwiesen.
  194. (deftype named-erz-sys (&optional n)
  195.   "ERZ-SYS ist eine Erzeugendensystem aus der Sn."
  196.   ; `(array (cons (perm ,n) string) (*)) gemeint
  197.   (declare (ignore n))
  198.   'vector
  199. )
  200.  
  201. ; (aref1 s i) ergibt allgemein das i-te Element (i=1,2,...) eines Arrays s.
  202. (defmacro aref1 (s i)
  203.   `(aref ,s (1- ,i))
  204. )
  205.  
  206. ; Aufbauen eines Erzeugendensystems aus einer Liste l von Permutationen
  207. (defun make-erz-sys (l)
  208.   (coerce (mapcar #'(lambda (p) (cons p "")) l) 'vector))
  209.  
  210.  
  211. ;-------------------------------------------------------------------------------
  212.  
  213. ; Datentyp des Erzeugendenprodukts:
  214.  
  215. ; In Bezug auf ein festes Erzeugendensystem ezs mit m Elementen:
  216. ; Die Erzeugenden werden durchnumeriert: 1,...,m für die angegebenen,
  217. ; -1,...,-m für ihre Inversen.
  218. ; Nun bedeutet ein Erzeugendenprodukt ezp = (t1 ... tk) das Produkt
  219. ; Et1 * .... * Etk.
  220.  
  221. (deftype ezp () 'list)
  222.  
  223. ; Multiplikation zweier Erzeugendendarstellungen: s nach t
  224. ; An der Nahtstelle werden Inverse bereits zusammengefaßt.
  225. (proclaim '(function ezp* (ezp ezp) ezp))
  226. (defun ezp* (s1 t1)
  227.   (do ((l1 (reverse s1) (cdr l1))
  228.        (l2 t1 (cdr l2)))
  229.       ((or (null l1) (null l2) (not (zerop (+ (car l1) (car l2)))))
  230.        (nreconc l1 l2))
  231. ) )
  232.  
  233. ; Invertieren einer Erzeugendendarstellung
  234. (proclaim '(function ezp/ (ezp) ezp))
  235. (defun ezp/ (s)
  236.   (nreverse (mapcar #'- s)))
  237.  
  238. ; Ausgeben eines Erzeugendenprodukts mit Hilfe eines benannten Erzeugenden-
  239. ; systems.
  240. (defun ezp-print (s nezs &optional (stream *standard-output*))
  241.   (if (null s)
  242.       (princ '"Id" stream)
  243.       (do ((l s))
  244.           ((endp l))
  245.         (let ((i (pop l)))
  246.           (princ (cdr (aref1 nezs (abs i))) stream)
  247.           (if (minusp i) (princ '"^-1" stream))
  248.         )
  249.         (unless (endp l) (princ '" * " stream))
  250. ) )   )
  251.  
  252.  
  253. (defconstant uses-ezprt nil "Wird eine Erzeugendenprodukttabelle verwendet?")
  254.  
  255. ; Um Erzeugendendarstellungen weiter vereinfachen zu können, brauchen wir
  256. ; eine Tabelle, die uns z.B. sagt, daß wir (5 -3 -4) zu (6) und somit auch
  257. ; (7 5 -3 -4 -6) zu (7 6 -6) und dann zu (7) vereinfachen können.
  258.  
  259. ; Datentyp einer Erzeugendenprodukt-Reduktionstabelle
  260. (deftype ezprt ()
  261.   '(or list vector (member t)))
  262.  
  263. (when uses-ezprt
  264.  
  265. ; Die Reduktionstabelle ist so aufgebaut, daß ein Matchvorgang erheblich
  266. ; beschleunigt wird. Rekursiver Aufbau über die Länge des matchenden Wortes:
  267. ; Soll (l1 ... lk) zu (r1 ... rj) reduziert werden, so ist im Teilbaum zu l1
  268. ; nach dem Ergebnis von (l2 ... lk) zu suchen, also in dessen Teilbaum zu l2
  269. ; nach dem Ergebnis von (l3 ... lk), usw. Ist so ein Baum ein Array, so
  270. ; ist der i-te Teilbaum die (m+i)-te Komponente; ist der Baum eine Liste, so
  271. ; ist der i-te Teilbaum das ASSOC zu i im Baum, der eine A-Liste ist.
  272. ; Schließlich ist das Ergebnis (der l1,...,lk-te Teilbaum) die Liste
  273. ; (r1 ... rj). (Beachte: Ergebnis NIL bedeutet j=0, der leere Teilbaum wird
  274. ; durch t abgekürzt.)
  275. ; Damit es sich auch wirklich um eine Vereinfachung handelt, sollte k>j sein.
  276.  
  277. ; leere Reduktionstabelle, enthält nur die trivialen Reduktionen (j -j) -> ()
  278. (proclaim '(function empty-ezprt (integer) ezprt))
  279. (defun empty-ezprt (m)
  280.   (let ((rt (make-array `(,(+ m 1 m)) :element-type 'ezprt :initial-element t)))
  281.     (dolist (j (mapcan #'(lambda (i) (list i (- i))) (intlist 1 m)))
  282.       (setf (aref rt (+ m j)) (list (cons (- j) '())))
  283.     )
  284.     rt
  285. ) )
  286.  
  287. ; (ezprt-to-list rt) ergibt eine Liste der Zuordnungen (l r) =
  288. ; ((l1 ... lk) (r1 ... rj)) , die in der Tabelle stehen.
  289. (proclaim '(function ezprt-to-list (ezprt) list))
  290. (defun ezprt-to-list (rt)
  291.   (cond ((eq rt t) nil)
  292.         ((or (null rt) (and (consp rt) (integerp (car rt))))
  293.          (list (list nil rt)))
  294.         ((consp rt) ; muß eine A-Liste sein
  295.          (mapcan #'(lambda (a-soc)
  296.                      (mapcar #'(lambda (lr)
  297.                                  (list (cons (car a-soc) (first lr))
  298.                                        (second lr)))
  299.                              (ezprt-to-list (cdr a-soc))
  300.                    ) )
  301.                  rt))
  302.         ((typep rt 'array)
  303.          (let ((m (floor (length rt) 2)))
  304.            (mapcan #'(lambda (i)
  305.                        (mapcar #'(lambda (lr)
  306.                                    (list (cons i (first lr)) (second lr)))
  307.                                (ezprt-to-list (aref rt (+ m i)))
  308.                      ) )
  309.                    (intlist (- m) m)
  310.         )) )
  311.         (t (error "EZP-Reduktionstabelle falsch aufgebaut!"))
  312. ) )
  313.  
  314.  
  315. ; Vereinfachung eines Wortes w mit Hilfe einer Tabelle rt
  316. (proclaim '(function simpezp (ezp ezprt integer) ezp))
  317. (defun simpezp (w rt m)
  318.   ; gehe von hinten durch den String durch und suche nach einem Teilwort,
  319.   ; das auch in der Tabelle vorkommt.
  320.   (let ((wl (reverse w))
  321.         (wr nil))
  322.     ; Es bleibt stets (append (reverse wl) wr) == w.
  323.     (loop
  324.        (if (null wl) (return wr))
  325.        (push (pop wl) wr) ; ein Zeichen weiterrücken
  326.        (do ((trt rt) ; Teilbaum der Reduktionstabelle
  327.             (twr wr)) ; Teilwort der rechten Wortes
  328.            ((or (null trt)
  329.                 (and (consp trt) (integerp (car trt))))
  330.             ; Teilbaum zu Ende, ersetze wr durch trt twr
  331.             (setq wl (revappend trt wl))
  332.             (setq wr twr)
  333.            )
  334.          ; Ende von (l1 ... lk) in rt noch nicht erreicht -> muß eine Stufe
  335.          ; weiter hinabsteigen.
  336.          (if (null twr) (return)) ; ergebnisloses Ende der do-Schleife,
  337.                                   ; weil wr zu kurz war
  338.          (if (eq trt t) (return)) ; Ende der do-Schleife, weil Teilbaum leer
  339.          (if (typep trt 'array)
  340.              (setq trt (aref trt (+ m (pop twr))))
  341.              (let ((x (assoc (pop twr) trt)))
  342.                (if x
  343.                    (setq trt (cdr x))
  344.                    (return)       ; Ende der do-Schleife, weil kein Teilbaum
  345.          )   ) )
  346.          (if (eq trt t) (return)) ; Ende der do-Schleife, weil Teilbaum leer
  347. ) ) )  )
  348.  
  349.  
  350. ; (insert-ezprt l r rt m) fügt in die Tabelle rt zusätzlich ein, daß
  351. ; l zu r reduziert werden kann. Im Zweifelsfall hat das kürzere l den
  352. ; Vortritt (weil es öfter auftreten wird).
  353. ; Das Ergebnis ist das veränderte rt.
  354. (proclaim '(function insert-ezprt (ezp ezp ezprt integer) ezprt))
  355. (defun insert-ezprt (l r rt m)
  356.   (if (null l) (error "Wollte ein leeres Wort reduzieren."))
  357.   (labels ((ins-ezprt (l rt) ; rekursive Version, auf Teilwort und Teilbaum
  358.              (cond ((null l) r) ; Reduktion zu r
  359.                    ((null rt) rt) ; nichts verändern
  360.                    ((eq rt t) (acons (first l) (ins-ezprt (rest l) t) nil))
  361.                    ((and (consp rt) (integerp (car rt)))
  362.                     ; kürzeres der beiden Ergebnisse gelte
  363.                     (if (< (length r) (length rt)) r rt))
  364.                    ((consp rt) ; A-Liste rt
  365.                     (let ((a-soc (assoc (first l) rt)))
  366.                       (if a-soc
  367.                           (setf (cdr a-soc) (ins-ezprt (rest l) (cdr a-soc)))
  368.                           (progn
  369.                             (setq rt (acons (first l)
  370.                                             (ins-ezprt (rest l) t)
  371.                                             rt
  372.                             )        )
  373.                             ; rt von A-Liste in Array umwandeln, falls groß
  374.                             (if (> (length rt) m)
  375.                                 (setq rt
  376.                                   (do ((u (make-array `(,(+ m 1 m))
  377.                                                       :element-type 'ezprt
  378.                                                       :initial-element t))
  379.                                        (rt rt (cdr rt)))
  380.                                       ((null rt) u)
  381.                                     (setf (aref u (+ m (caar rt))) (cdar rt))
  382.                       )   ) )   ) )
  383.                       rt
  384.                    ))
  385.                    ((typep rt 'array)
  386.                     (setf (aref rt (+ m (car l)))
  387.                           (ins-ezprt (cdr l) (aref rt (+ m (car l)))))
  388.                     rt
  389.                    )
  390.                    (t (error "EZP-Reduktionstabelle falsch aufgebaut!"))
  391.           )) )
  392.           (ins-ezprt l rt)
  393. ) )
  394.  
  395. (defparameter *setid-limit* 19)
  396.  
  397. ; (setid-ezprt w rt m) teilt der Tabelle rt zusätzlich mit, daß das Wort w
  398. ; die Identität darstellt, und liefert das neue rt (das eq zum alten rt ist).
  399. (proclaim '(function setid-ezprt (ezp ezprt integer) ezprt))
  400. (defun setid-ezprt (w rt m)
  401.   (setq w (simpezp w rt m))
  402.   (format *gruppen-trace* "~%Wort der Länge ~D =id." (length w))
  403.   (if (or (null w) (> (length w) *setid-limit*)) (return-from setid-ezprt rt))
  404.   ; w=() sofort abfangen, zu große Wörter bringen nichts. (??)
  405.   (dolist (l (list w (ezp/ w))) ; w=id und w^-1=id merken
  406.     ; Sei l = (t1 ... tk). Merke t1...tk=id, t2...tkt1=1, ...
  407.     (let* ((ll (length l))
  408.            (hll (1+ (floor ll 2)))) ; stets hll > l-hll
  409.       (dotimes (i ll)
  410.         (insert-ezprt (subseq l 0 hll) (ezp/ (subseq l hll)) rt m)
  411.         (setq l (list-rotate l)) ; l rotieren
  412.   ) ) )
  413.   rt
  414. )
  415.  
  416. )
  417.  
  418. ;-------------------------------------------------------------------------------
  419.  
  420. ; Datentyp des Gruppenelementes
  421.  
  422. (defstruct pgruppel
  423.   "PGRUPPEL ist ein Element einer Untergruppe der Sn, sowohl als
  424.   Permutation als auch als Erzeugendenprodukt dargestellt."
  425.   (perm nil :type perm) ; als Permutation
  426.   (ezp nil :type ezp) ; als Erzeugendenprodukt
  427. )
  428.  
  429. ; Operationen mit Gruppenelementen:
  430.  
  431. ; Multiplikation zweier Gruppenelemente: s nach t
  432. (proclaim '(function pgruppel* (pgruppel pgruppel &optional pgruppe) pgruppel))
  433. (if uses-ezprt
  434. (defun pgruppel* (s1 t1 &optional (G *pgruppe*))
  435.   (make-pgruppel :perm (the perm (perm* (pgruppel-perm s1) (pgruppel-perm t1)))
  436.                  :ezp (simpezp (ezp* (pgruppel-ezp s1) (pgruppel-ezp t1))
  437.                                (pgruppe-ezprt G)
  438.                                (pgruppe-nezs-l G))
  439. ) )
  440. (defun pgruppel* (s1 t1 &optional (G *pgruppe*))
  441.   (declare (ignore G))
  442.   (make-pgruppel :perm (perm* (pgruppel-perm s1) (pgruppel-perm t1))
  443.                  :ezp (ezp* (pgruppel-ezp s1) (pgruppel-ezp t1))
  444. ) )
  445. )
  446.  
  447. ; Invertieren eines Gruppenelementes
  448. (proclaim '(function pgruppel/ (pgruppel) pgruppel))
  449. (defun pgruppel/ (s)
  450.   (make-pgruppel :perm (perm/ (pgruppel-perm s))
  451.                  :ezp (ezp/ (pgruppel-ezp s))
  452. ) )
  453.  
  454. ; neutrales Element (identische Abbildung) als Gruppenelement
  455. (proclaim '(function pgruppe-id (&optional integer) pgruppel))
  456. (defun pgruppe-id (&optional (n (pgruppe-grad *pgruppe*)))
  457.   (make-pgruppel :perm (perm-id n)
  458.                  :ezp nil
  459. ) )
  460.  
  461. ; Test auf neutrales Element als Gruppenelement
  462. (proclaim '(function pgruppe-id-p (pgruppel &optional integer) atom))
  463. (defun pgruppe-id-p (g &optional (n (pgruppe-grad *pgruppe*)))
  464.   (or (null (pgruppel-ezp g)) ; das ist am einfachsten zu erkennen
  465.       (perm-id-p (pgruppel-perm g) n)
  466. ) )
  467.  
  468. ; Länge des Erzeugendenprodukts eines Gruppenelements, ein Komplexitätsmaß:
  469. (proclaim '(function pgruppel-ezpl (pgruppel) integer))
  470. (defun pgruppel-ezpl (g)
  471.   (length (pgruppel-ezp g))
  472. )
  473.  
  474. ; nettes Ausgeben eines Gruppenelementes
  475. (defun pgruppel-print (p &optional (G *pgruppe*)
  476.                          &key (stream *standard-output*))
  477.   (princ '"Perm. = " stream)
  478.   (write (perm-zykl (pgruppel-perm p)) :stream stream)
  479.   (princ '" = " stream)
  480.   (ezp-print (pgruppel-ezp p) (pgruppe-nezs G) stream)
  481.   (values)
  482. )
  483.  
  484.  
  485. ;-------------------------------------------------------------------------------
  486. ; Datentyp einer Gruppe
  487.  
  488. (defstruct pgruppe
  489.   "PGRUPPE ist eine Untergruppe einer Sn."
  490.   (grad 0 :type (integer 0 *)) ; das n
  491.   (nezs nil :type (named-erz-sys *)) ; das Permutationensystem,
  492.      ; auf das sich alle Erzeugendenprodukte beziehen.
  493.   (nezs-l 0 :type (integer 0 *)) ; Länge des Erzeugendensystems, das m
  494.   (ezprt nil :type ezprt) ; Erzeugendenprodukt-Reduktionstabelle
  495.   (ezs nil :type list) ; Ein Erzeugendensystem der Gruppe,
  496.      ; das ist eine Liste von Gruppenelementen
  497.   (sgs nil :type (or null vector) ) ; ein
  498.      ; strong generating set (R1,...Rn), so daß mit
  499.      ; Gj=Schnitt der Fixgruppen von 1,...,j (j=0,...,n)
  500.      ; Rj ein Vertretersystem von Gj-1/Gj ist (j=1,...,n),
  501.      ; d.h. jedes s aus der Gj-1 ist eindeutig als s = r t mit t aus Gj
  502.      ; und r aus Rj schreibbar (sogar r(j)=s(j)).
  503.   (ordnung nil :type (or integer null)) ; die Elementanzahl der Gruppe
  504. )
  505.  
  506.  
  507. ; Benutzerfreundliche Konstruktion einer Gruppe:
  508. ; Grad und Erzeugendenliste ezsn = (Name1 Erz1 ... Namek Erzk) eingeben.
  509. (proclaim '(function mache-gruppe (integer list) pgruppe))
  510. (defun mache-gruppe (n ezsn)
  511.   (do ((l ezsn (cddr l))
  512.        (nezs nil)
  513.        (ezlist nil)
  514.        (m 0))
  515.     ((or (endp l) (endp (cdr l)))
  516.      (make-pgruppe :grad n
  517.                    :nezs (coerce (nreverse nezs) 'vector)
  518.                    :ezs (nreverse ezlist)
  519.                    :nezs-l m
  520.                    :ezprt (if uses-ezprt (empty-ezprt m))
  521.     ))
  522.     (let ((p (zykl-perm (second l) n))
  523.           (s (first l)))
  524.       (push (cons p s) nezs)
  525.       (incf m)
  526.       (push (make-pgruppel :perm p :ezp (list m)) ezlist)
  527. ) ) )
  528.  
  529.  
  530. ;-------------------------------------------------------------------------------
  531. ; Datentyp des Vertretersystems:
  532.  
  533. (deftype vert-sys (&optional n)
  534.   "VERT-SYS ist ein Vertretersystem einer Gruppe Gj-1/Gj.
  535.    Das ist eine partielle Abbildung von {1,...,n} in die Gruppe Gj-1."
  536.   (declare (ignore n))
  537.   'list ; eine A-Liste von (k . rk)-Paaren
  538. )
  539.  
  540. ; Datentyp einer Untergruppe einer festen Gruppe G:
  541. ; Liste von Gruppenelementen, die die Untergruppe erzeugen.
  542.  
  543.  
  544. ;-------------------------------------------------------------------------------
  545. ; Gruppentheoretische Algorithmen, ausgeführt mit Permutationen:
  546.  
  547. ; Bestimmung der Bahn eines Punktes p unter der Aktion einer Untergruppe
  548. ; H von G. H sei gegeben durch eine Liste HEZS von Erzeugenden, so daß
  549. ; H= <HEZS> . Die Erzeugenden sind nur die Permutationen.
  550. ; Das Ergebnis ist ein Array, der zu jedem i eine Permutation s aus H mit s(p)=i
  551. ; enthält (falls eine solche existiert).
  552. (proclaim '(function perm-bahn (integer list &optional pgruppe) vector))
  553. (defun perm-bahn (p HEZS &optional (G *pgruppe*))
  554.   (let* ((n (pgruppe-grad G))
  555.          (B (make-array `(,n) :initial-element nil))
  556.             ; B[j] enthält NIL oder eine Permutation.
  557.          (HEZS2 (append HEZS (mapcar #'perm/ HEZS)))
  558.             ; HEZS2 enthält die Erzeugenden und ihre Inversen
  559.          B1)
  560.     (setf (aref1 B p) (make-perm (intlist 1 n)))
  561.     (loop
  562.        (setq B1 (copy-seq B))
  563.        (dolist (S HEZS2)
  564.           (do ((i 1 (1+ i)))
  565.               ((> i n))
  566.             (let ((j (apply-perm S i)) ; Sei j=S(i)
  567.                   (TT (aref1 B1 i)))
  568.               (if TT                          ; Wenn T(p)=i
  569.                 (if (null (aref1 B j))        ; und j noch nicht erreicht,
  570.                     (setf (aref1 B j)
  571.                           (perm* S TT))       ; ist j=S(T(p)).
  572.             ) ) )
  573.        )  )
  574.        (if (equalp B1 B) (return B))
  575.     )
  576. ) )
  577.  
  578. ; Vereinfachung eines Erzeugendensystems.
  579. ; Einfachste Methode wäre, Doppelte und Identität zu streichen.
  580. ; Wir machen mehr: Wir verändern das Erzeugendensystem so weit, daß wir so
  581. ; viele Identitäten streichen können, daß nur noch höchstens n*(n-1)/2
  582. ; Erzeugende übrigbleiben.
  583. (proclaim '(function perm-simpEZS (list &optional pgruppe) list))
  584. (defun perm-simpEZS (HEZS &optional (G *pgruppe*) &aux (n (pgruppe-grad G)))
  585.   (format *gruppen-trace* "~%Reduziere ~D Erzeugende." (length HEZS))
  586.   (do ((m 1 (1+ m))
  587.        (l HEZS) ; Erzeugendenliste
  588.        (lk nil)) ; kürzere Erzeugendenliste
  589.     ((null l)
  590.      (format *gruppen-trace* "~%Reduzierte von ~D auf ~D Erzeugende."
  591.              (length HEZS) (length lk))
  592.      lk)
  593.     ; Invariante: <HEZS> = <l,lk>,
  594.     ; Zu jedem i aus {1,...,m-1} und zu jedem j aus {i+1,...,n} gibt es in lk
  595.     ; höchstens ein Element s von lk mit s(1)=1,...,s(i-1)=i-1, s(i)=j.
  596.     ; Für jedes Element s von l gilt s(1)=1,...,s(m-1)=m-1.
  597.     ; Spätestens bei m=n ist l leer, also <HEZS> = <lk>.
  598.     (format *gruppen-trace*
  599.          "~%PERM-SIMPEZS, ~D. Durchlauf, habe ~D Erzeugende in l und ~D in lk."
  600.          m (length l) (length lk))
  601.     (let ((ar (make-array `(,n) :initial-element nil)))
  602.       ; ar sammelt in der i-ten Zelle alle s aus l mit s(m)=i.
  603.       (dolist (s l)
  604.         (let ((i (apply-perm s m)))
  605.           (push s (aref1 ar i))
  606.       ) )
  607.       ; alles von l steckt jetzt im Array ar.
  608.       ; Die Zellen 1,...,m-1 sind leer.
  609.       (setq l (aref1 ar m)) ; s mit s(m)=m kann man unverändert übernehmen.
  610.       ; Suche unter allen s in der i-ten Zelle von ar (i>m) dasjenige mit der
  611.       ; kleinsten Erzeugendenproduktlänge, nenne es s0, stecke s0 nach lk,
  612.       ; stecke s0^-1 s statt s nach l, stecke s0^-1 in die i-te Zelle von ar.
  613.       (do ((i (1+ m) (1+ i)))
  614.           ((> i n))
  615.         (let ((slist (aref1 ar i))
  616.               s0 s01)
  617.           (when slist ; wenn die i-te Zelle von ar nicht leer war:
  618.             (setq s0 (first slist)) ; ein beliebiges Element von slist
  619.             (setq s01 (perm/ s0))
  620.             (dolist (s slist)
  621.               (push (perm* s01 s) l))
  622.             (setf (aref1 ar i) s01)
  623.       ) ) )
  624.       (format *gruppen-trace* "~%Jetzt hat l ~D Elemente." (length l))
  625.       ; Beinahe-Inverse werden ebenfalls nach l gesteckt:
  626.       (do ((i (1+ m) (1+ i))
  627.            (s1) (s2) (j))
  628.           ((> i n))
  629.         (setq s1 (aref1 ar i))
  630.         (when s1
  631.               ; s1 ist eine Permutation im Fach i, also s1(i)=m
  632.               (setq j (apply-perm s1 m)) ; j:=s1(m)
  633.               (setq s2 (aref1 ar j))
  634.               (when (and (/= i j) s2)
  635.                     ; s2 ist eine Permutation im Fach j, also s2(j)=m
  636.                     ; Dann ist s = s2 s1 eine Permutation mit s(1)=1,...,
  637.                     ; s(m-1)=m-1, s(m)=s2(j)=m.
  638.                     (setf (aref1 ar i) nil) ; streiche s1 als Erzeugendes
  639.                     (push (perm* s2 s1) l) ; und ersetze es durch s in l
  640.       ) )     )
  641.       ; Entferne alle Identitäten aus l
  642.       (setq l (remove-if #'perm-id-p l))
  643.       ; Sammle alle s0^-1, die noch in ar stehen, und stecke sie nach lk:
  644.       (do ((i (1+ m) (1+ i)))
  645.           ((> i n))
  646.         (let ((s01 (aref1 ar i)))
  647.           (if s01 (push s01 lk))
  648.       ) )
  649.   ) ) ; Bei m=n enthält l nur Identitäten, ist also leer => <HEZS> = <lk>.
  650. )
  651.  
  652.  
  653. ; Bestimmung der Fixgruppe Hp einer Untergruppe H einer Permutationsgruppe
  654. ; G. H ist gegeben als Erzeugendensystem HEZS, also H = <HEZS>.
  655. ; Das Ergebnis ist ein ebensolches Erzeugendensystem HpEZS
  656. ; für die Fixgruppe Hp. Der zweite Wert ist eine
  657. ; AListe, die jedem j aus der Bahn von p unter H genau ein Element rj von H
  658. ; mit rj(p)=j zuordnet (wobei zusätzlich rp=id), also ein Vertretersystem
  659. ; von H/Hj.
  660. ; Gerechnet wird mit Permutationen.
  661. (proclaim
  662.   '(function perm-fixpgruppe (perm list &optional pgruppe) (values list list)))
  663. (defun perm-fixpgruppe (p HEZS &optional (G *pgruppe*))
  664.   (format *gruppen-trace* "~%~%Bestimme die Fixgruppe von ~D" p)
  665.   (format *gruppen-trace* "~%Bestimme die Bahn der ~D." p)
  666.   (let ((n (pgruppe-grad G))
  667.         (B (perm-bahn p HEZS G))
  668.         (R nil)
  669.         HpEZS)
  670.     (do ((i n (- i 1))) ; erst die Bahnelemente zu R zusammenfassen
  671.         ((zerop i))
  672.       (let ((S (aref1 B i)))
  673.         (when S
  674.           (push (cons i S) R)
  675.           (setf (aref1 B i) (cons S (perm/ S)))
  676.     ) ) )
  677.     (format *gruppen-trace* "~%Bahn der ~D hat ~D Elemente." p (length R))
  678.     (format *gruppen-trace* "~%Erwarte ~D Erzeugende."
  679.             (* (length R) (length HEZS)) )
  680.     (setq HpEZS
  681.       (mapcan
  682.         #'(lambda (k &aux (S-S/ (aref1 B k)))
  683.             (if S-S/
  684.                (mapcar
  685.                   #'(lambda (S)
  686.                       (perm* (cdr (aref1 B (apply-perm S k)))
  687.                              (perm* S (car S-S/))
  688.                     ) )
  689.                   HEZS
  690.           ) )  )
  691.         (intlist 1 n)
  692.     ) )
  693.     (values (perm-simpEZS HpEZS G) R)
  694. ) )
  695.  
  696. ; Bestimmung eines STRONG GENERATING SET einer Gruppe G.
  697. ; Zugleich auch Bestimmung der Ordnung der Gruppe.
  698. ; Gerechnet wird mit Permutationen.
  699. (proclaim '(function perm-sgs (pgruppe) vector))
  700. (defun perm-sgs (G)
  701.   (or (pgruppe-sgs G)
  702.       (let* ((n (pgruppe-grad G))
  703.              (e (mapcar #'pgruppel-perm (pgruppe-ezs G))) ; Erzeugendensystem
  704.              (S (make-array `(,n) :element-type 'vert-sys))
  705.              (Card 1)
  706.              R)
  707.         (dotimes (j n) ; j=0,...,n-1, <e> = G(j)
  708.           (multiple-value-setq (e R) (perm-fixpgruppe (1+ j) e G))
  709.           ; <e> = G(j+1), R Vertretersystem von G(j)/G(j+1)
  710.           (setf (aref S j) R)
  711.           (format *gruppen-trace* "~%Vertretersystem mit ~D Elementen."
  712.                   (length R))
  713.           (setq Card (* Card (length R)))
  714.         )
  715.         (setf (pgruppe-sgs G) S)
  716.         (setf (pgruppe-ordnung G) Card)
  717.         (format *gruppen-trace* "~%Gruppe hat ~D Elemente." Card)
  718.         S
  719. ) )   )
  720.  
  721.  
  722. ;-------------------------------------------------------------------------------
  723. ; Gruppentheoretische Algorithmen, ausgeführt mit PGruppenelementen:
  724.  
  725. ; Bestimmung der Bahn eines Punktes p unter der Aktion einer Untergruppe
  726. ; H von G. H sei gegeben durch eine Liste HEZS von Erzeugenden, so daß
  727. ; H= <HEZS> .
  728. ; Das Ergebnis ist ein Array, der zu jedem i ein s aus H mit s(p)=i enthält
  729. ; (falls ein solches s existiert), und zwar mit einem relativ kurzen
  730. ; Erzeugendenprodukt.
  731. (proclaim '(function bahn (integer list &optional pgruppe) vector))
  732. (defun bahn (p HEZS &optional (G *pgruppe*))
  733.   (let* ((n (pgruppe-grad G))
  734.          (B (make-array `(,n) :initial-element nil))
  735.             ; B[j] enthält NIL oder ein Gruppenelement.
  736.          (HEZS2 (append HEZS (mapcar #'pgruppel/ HEZS)))
  737.             ; HEZS2 enthält die Erzeugenden und ihre Inversen
  738.          B1)
  739.     (setf (aref1 B p) (pgruppe-id n))
  740.     (loop
  741.        (setq B1 (copy-seq B))
  742.        (dolist (S HEZS2)
  743.           (do ((i 1 (1+ i)))
  744.               ((> i n))
  745.             (let ((j (apply-perm (pgruppel-perm S) i)) ; Sei j=S(i)
  746.                   (TT (aref1 B1 i)))
  747.               (if TT                          ; Wenn T(p)=i
  748.                 (if (or (null (aref1 B j))    ; und j noch nicht erreicht
  749.                         (< (+ (pgruppel-ezpl S) (pgruppel-ezpl TT)) ; oder j
  750.                            (pgruppel-ezpl (aref1 B j)) ; durch ein
  751.                     )   ) ; längeres Gruppenelement bereits erreicht ist,
  752.                     (setf (aref1 B j)
  753.                           (pgruppel* S TT G)) ; ist j=S(T(p)).
  754.             ) ) )
  755.        )  )
  756.        (if (equalp B1 B) (return B))
  757.     )
  758. ) )
  759.  
  760. ; Vereinfachung eines Erzeugendensystems.
  761. ; Sei eine Untergruppe H = <HEZS> von G durch ein Erzeugendensystem
  762. ; HEZS = <e1,...,er> gegeben. Wir suchen: Welche Erzeugenden können wir
  763. ; streichen?
  764. ; Dazu wird mit Permutationen  <s1,...,sr> gearbeitet, so daß für alle
  765. ; l=0,...,r gilt: <e1,...,el> = <s1,...,sl>.
  766. ; Erlaubte Operationen sind: ersetze sl durch sl^-1; oder erzetze sl durch
  767. ; si^-1*sl oder si^-1*sl^-1 oder ..., wobei 1 <= i < l <= r ist.
  768. ; Falls sich dabei sl=id ergibt, ist el in HEZS überflüssig.
  769. ; Gerechnet wird mit den si als Permutationen, an denen noch die Nummer i-1
  770. ; anhaftet (Nummern gehen hier ab 0):
  771. (defstruct (numperm (:type list)) perm num)
  772. (proclaim '(function simpEZS (list &optional pgruppe) list))
  773. (defun simpEZS (HEZS &optional (G *pgruppe*) &aux (n (pgruppe-grad G)))
  774.   ; sortiere HEZS nach aufsteigender Länge der Erzeugendenprodukte
  775.   (setq HEZS (coerce
  776.                (sort HEZS #'< :key #'pgruppel-ezpl)
  777.                'array))
  778.   (format *gruppen-trace* "~%Reduziere ~D Erzeugende." (length HEZS))
  779.   (do ((m 1 (1+ m))
  780.        (l (mapcar #'(lambda (i)
  781.                       (make-numperm :perm (pgruppel-perm (aref HEZS i)) :num i))
  782.                   (intlist 0 (1- (length HEZS)))
  783.       ))  )      ; Erzeugendenliste, am Anfang alle Elemente von HEZS
  784.     ((null l))
  785.     (format *gruppen-trace* "~%~D. Durchlauf." m)
  786.     ; Sei r=(length HEZS).
  787.     ; Sei M1 die Menge aller Nummern {1,...,r}.
  788.     ; HEZS enthält die ursprünglichen Erzeugenden ei.
  789.     ; Sei M2 die Menge aller Nummern i mit (aref1 HEZS i) = NIL,
  790.     ;    das bedeutet: si=id überflüssig, ei bereits gestrichen.
  791.     ; Sei M3 die Menge der Nummern der Elemente von l.
  792.     ; Sei M4 = M1 \ M3 die Menge der Nummern i der Erzeugenden, von denen
  793.     ;    bereits erkannt wurde, ob sie notwendig sind (i in M5 :=  M4 \ M2)
  794.     ;    oder ob sie überflüssig sind (i in M6 := M4 n M2).
  795.     ; 1. Invariante:
  796.     ; Die in l auftretenden Permutationen haben paarweise verschiedene Nummern.
  797.     ; Für alle j=0,...,r bleibt <s1,...,sj>=<e1,...,ej> invariant.
  798.     ; 2. Invariante:
  799.     ; Für jedes Element s von l gilt s(1)=1,...,s(m-1)=m-1.
  800.     ; Daher: spätestens bei m=n ist l leer.
  801.     ; 3. Invariante: M5 hat höchstens (n-1) + ... + (n-m+1) Elemente.
  802.     (let ((ar (make-array `(,n) :initial-element nil)))
  803.       ; ar sammelt in der i-ten Zelle alle s aus l mit s(m)=i.
  804.       (dolist (s l)
  805.         (let ((i (apply-perm (numperm-perm s) m)))
  806.           (push s (aref1 ar i))
  807.       ) )
  808.       ; alles von l steckt jetzt im Array ar.
  809.       ; Die Zellen 1,...,m-1 sind leer.
  810.       (setq l (aref1 ar m)) ; s mit s(m)=m kann man unverändert übernehmen.
  811.       ; Suche unter allen s in der i-ten Zelle von ar (i>m) dasjenige mit der
  812.       ; kleinsten Nummer, nenne es s0,
  813.       ; stecke s0^-1 s statt s nach l, stecke s0^-1 in die i-te Zelle von ar.
  814.       (do ((i (1+ m) (1+ i)))
  815.           ((> i n))
  816.         (let ((slist (aref1 ar i))
  817.               s0 s01)
  818.           (when slist ; wenn die i-te Zelle von ar nicht leer war:
  819.             (multiple-value-setq (s01 s0)
  820.               (search-min slist #'< 
  821.                 :key #'(lambda (s) (numperm-num s))))
  822.             (setq s01 (perm/ (numperm-perm s0)))
  823.             (dolist (s slist)
  824.               (unless (eq s s0)
  825.                 ; s hat eine größere Nummer als s0.
  826.                 ; Ersetze s durch s0^-1 * s
  827.                 (push (make-numperm :perm (perm* s01 (numperm-perm s))
  828.                                     :num (numperm-num s))
  829.                       l)))
  830.             ; Stecke s0^-1 in die i-te Zelle.
  831.             (setf (aref1 ar i)
  832.                   (make-numperm :perm s01 :num (numperm-num s0)))
  833.       ) ) )
  834.       ; Beinahe-Inverse werden ebenfalls nach l gesteckt:
  835.       (do ()
  836.        ((do ((i (1+ m) (1+ i))
  837.              (s1) (s2) (j) (modified nil))
  838.             ((> i n) (not modified))
  839.           (setq s1 (aref1 ar i))
  840.           (when s1
  841.                 ; s1 ist eine Permutation im Fach i, also s1(i)=m, i > m
  842.                 (setq j (apply-perm (numperm-perm s1) m)) ; j:=s1(m) > m
  843.                 (setq s2 (aref1 ar j))
  844.                 (when (and (/= i j) s2)
  845.                       ; s2 ist eine Permutation im Fach j, also s2(j)=m
  846.                       ; Dann ist s = s2 s1 eine Permutation mit s(1)=1,...,
  847.                       ; s(m-1)=m-1, s(m)=s2(j)=m.
  848.                       ; Streiche das Erzeugende mit der größeren Nummer
  849.                       (ecase (signum (- (numperm-num s1) (numperm-num s2)))
  850.                         ((-1) ; s1 hat die kleinere Nummer
  851.                               (setf (aref1 ar j) nil) ) ; s2 streichen
  852.                         ((1)  ; s1 hat die größere Nummer
  853.                               (setf (aref1 ar i) nil) ) ; s1 streichen
  854.                       )
  855.                       ; und ersetze es durch s in l:
  856.                       (push (make-numperm
  857.                               :perm (perm* (numperm-perm s2) (numperm-perm s1))
  858.                               :num (max (numperm-num s1) (numperm-num s2)))
  859.                             l)
  860.                       (setq modified t)
  861.        )) )     ) ; solange wiederholen, bis nichts mehr verändert wurde.
  862.       )
  863.       (format *gruppen-trace* "~%Jetzt hat l ~D Elemente." (length l))
  864.       ; Bis jetzt gingen keine Nummern verloren, d.h. M2 blieb unverändert,
  865.       ; M3 wurde verkleinert, M4 wurde vergrößert. Die noch in ar steckenden
  866.       ; Permutationen sind notwendig: worum M3 verkleinert wurde, darum wird
  867.       ; M5 vergrößert. M6 blieb unverändert, weil mit Elementen aus M2 gar
  868.       ; nicht mehr gearbeitet wurde, also M4 nicht um Elemente von M2
  869.       ; vergrößert wurde.
  870.       ; M5 wurde um höchstens (n-m) Elemente vergrößert, weil diese aus
  871.       ; (aref1 ar (1+ m)) ... (aref1 ar n) kamen.
  872.       ; Entferne alle si=id aus l und entsprechende ei aus HEZS:
  873.       (setq l (do ((l1 l (cdr l1))
  874.                    (l2 nil))
  875.                   ((endp l1) l2)
  876.                 (if (perm-id-p (numperm-perm (car l1)) n)
  877.                     (setf (aref HEZS (numperm-num (car l1))) nil)
  878.                     (push (car l1) l2)
  879.       )       ) )
  880.       (format *gruppen-trace* "~%Jetzt hat l ~D Elemente." (length l))
  881.       ; Um die jetzt gestrichenen Nummern wurde M2 vergrößert, M3 verkleinert,
  882.       ; M4 vergrößert, M6 vergrößert, während M5 gleich blieb.
  883.     ); Die Schleifeninvariante bleibt erhalten.
  884.   ); Spätestens bei m=n enthält l nur Identitäten, ist also leer.
  885.   ; Wenn l leer ist, ist M3 leer, M4=M1, und die nichtleeren Felder von HEZS
  886.   ; entsprechen den notwendigen Erzeugenden (i aus M5 = M1 \ M2).
  887.   ; Sammle die noch in HEZS steckenden, notwendigen, Erzeugenden:
  888.   (setq HEZS (coerce (remove nil HEZS) 'list))
  889.   (format *gruppen-trace* "~%Reduzierte auf ~D Erzeugende." (length HEZS))
  890.   HEZS
  891. )
  892.  
  893.  
  894. ; Bestimmung der Fixgruppe Hp einer Untergruppe H einer Permutationsgruppe
  895. ; G. H ist gegeben als Erzeugendensystem HEZS, also H = <HEZS>.
  896. ; Das Ergebnis ist ein ebensolches Erzeugendensystem HpEZS
  897. ; für die Fixgruppe Hp. Der zweite Wert ist eine
  898. ; AListe, die jedem j aus der Bahn von p unter H genau ein Element rj von H
  899. ; mit rj(p)=j zuordnet (wobei zusätzlich rp=id), also ein Vertretersystem
  900. ; von H/Hj.
  901. (proclaim '(function fixpgruppe (integer list &optional pgruppe) list))
  902. (defun fixpgruppe (p HEZS &optional (G *pgruppe*))
  903.   (format *gruppen-trace* "~%~%Bestimme die Fixgruppe von ~D" p)
  904.   (format *gruppen-trace* "~%Bestimme die Bahn der ~D." p)
  905.   (let ((n (pgruppe-grad G))
  906.         (B (bahn p HEZS G))
  907.         (R nil)
  908.         HpEZS)
  909.     (do ((i n (- i 1))) ; erst die Bahnelemente zu R zusammenfassen
  910.         ((zerop i))
  911.       (let ((S (aref1 B i)))
  912.         (when S
  913.           (push (cons i S) R)
  914.           (setf (aref1 B i) (cons S (pgruppel/ S)))
  915.     ) ) )
  916.     (format *gruppen-trace* "~%Bahn der ~D hat ~D Elemente." p (length R))
  917.     (format *gruppen-trace* "~%Erwarte ~D Erzeugende."
  918.             (* (length R) (length HEZS)) )
  919.     (setq HpEZS
  920.       (mapcan
  921.         #'(lambda (k &aux (S-S/ (aref1 B k)))
  922.             (if S-S/
  923.                (mapcar
  924.                   #'(lambda (S)
  925.                       (pgruppel* (cdr (aref1 B (apply-perm (pgruppel-perm S) k)
  926.                                  )    )
  927.                                  (pgruppel* S (car S-S/) G)
  928.                                  G
  929.                     ) )
  930.                   HEZS
  931.           ) )  )
  932.         (intlist 1 n)
  933.     ) )
  934.     (values (simpEZS HpEZS G) R)
  935. ) )
  936.  
  937. ; Bestimmung eines STRONG GENERATING SET einer Gruppe G.
  938. ; Zugleich auch Bestimmung der Ordnung der Gruppe.
  939. (proclaim '(function sgs (pgruppe) vector))
  940. (defun sgs (G)
  941.   (or (pgruppe-sgs G)
  942.       (let* ((n (pgruppe-grad G))
  943.              (e (pgruppe-ezs G)) ; anfängliches Erzeugendensystem
  944.              (S (make-array `(,n) :element-type 'vert-sys))
  945.              (Card 1)
  946.              R)
  947.         (dotimes (j n) ; j=0,...,n-1, <e> = G(j)
  948.           (multiple-value-setq (e R) (fixpgruppe (1+ j) e G))
  949.           ; <e> = G(j+1), R Vertretersystem von G(j)/G(j+1)
  950.           (setf (aref S j) R)
  951.           (format *gruppen-trace* "~%Vertretersystem mit ~D Elementen."
  952.                   (length R))
  953.           (setq Card (* Card (length R)))
  954.         )
  955.         (setf (pgruppe-sgs G) S)
  956.         (setf (pgruppe-ordnung G) Card)
  957.         (format *gruppen-trace* "~%Gruppe hat ~D Elemente." Card)
  958.         S
  959. ) )   )
  960.  
  961.  
  962. ; Bestimmung der Ordnung einer Gruppe G.
  963. (proclaim '(function ordnung (pgruppe) integer))
  964. (defun ordnung (G)
  965.   (or (pgruppe-ordnung G)
  966.       (progn
  967.         (sgs G)
  968.         (or (pgruppe-ordnung G)
  969.             (let ((n (pgruppe-grad G))
  970.                   (S (pgruppe-sgs G))
  971.                   (Card 1))
  972.               (dotimes (j n) (setq Card (* Card (length (aref S j)))))
  973.               (setf (pgruppe-ordnung G) Card)
  974. ) )   ) )   )
  975.  
  976.  
  977. ; Bestimmung des Schnittes verschiedener Fixgruppen einer Gruppe G.
  978. (proclaim '(function sfixgruppe (list &optional pgruppe) pgruppe))
  979. (defun sfixgruppe (ellist &optional (G *pgruppe*))
  980.   (let ((HEZS (pgruppe-ezs G))
  981.         (Card (pgruppe-ordnung G)))
  982.     (dolist (p ellist)
  983.       (multiple-value-bind (H R) (fixpgruppe p HEZS G)
  984.         (if Card (setq Card (/ Card (length R))))
  985.         (setq HEZS H)
  986.     ) )
  987.     (make-pgruppe :grad (pgruppe-grad G)
  988.                   :nezs (pgruppe-nezs G)
  989.                   :nezs-l (pgruppe-nezs-l G)
  990.                   :ezprt (pgruppe-ezprt G)
  991.                   :ezs HEZS
  992.                   :ordnung Card
  993. ) ) )
  994.  
  995.  
  996. ; nimmt eine Permutation und eine Gruppe G entgegen und liefert NIL,
  997. ; falls p kein Element der Gruppe G ist. Bei p in G liefert es die Darstellung
  998. ; von p als Gruppenelement, in der auch die Darstellung von p aus Erzeugenden
  999. ; inbegriffen ist.
  1000. (proclaim
  1001.   '(function perm-to-pgruppel (perm &optional pgruppe) (or null pgruppel)))
  1002. (defun perm-to-pgruppel (p &optional (Gr *pgruppe*)
  1003.                            &aux (n (pgruppe-grad Gr)))
  1004.  (and (= (length p) n)
  1005.   (let ((S (sgs Gr)))
  1006.    (flet
  1007.      ((p-t-p-1 (p) ; Darstellung von p aus "g p1 = p"
  1008.         (do ((i 1 (1+ i))
  1009.              (p1 p)
  1010.              (g (pgruppe-id n)))
  1011.             ((> i n) g)
  1012.           ; invariant: g p1 = p und p1(1)=1,...,p1(i-1)=i-1 und g in Gr.
  1013.           ; (assert (equalp (perm* (pgruppel-perm g) p1) p))
  1014.           (let* ((R (aref1 S i)) ; Vertretersystem von G(i-1)/G(i)
  1015.                  (j (apply-perm p1 i)) ; j=p1(i)
  1016.                  (Rj (assoc j R))) ; nil oder (j . r) mit r(i)=j, r aus G(i-1)
  1017.             (if (null Rj)
  1018.                 (return-from perm-to-pgruppel nil)
  1019.                 (progn
  1020.                   (setq Rj (cdr Rj))
  1021.                   ; p1 = r p1' und also p = g p1 = g r p1' = g' p1'
  1022.                   (setq g (pgruppel* g Rj Gr)) ; g' = g r
  1023.                   (setq p1 (perm* (perm/ (pgruppel-perm Rj)) p1))
  1024.                   ; p1' = r^-1 p1, hat p1'(1)=1,...,p1'(i-1)=i-1 und
  1025.                   ; p1'(i) = r^-1 (j) = i.
  1026.       ) ) ) )   )
  1027.       (p-t-p-2 (p) ; Darstellung von p aus "g p1 h^-1 = p"
  1028.         (do ((i 1 (1+ i))
  1029.              (p1 p)
  1030.              (g (pgruppe-id n))
  1031.              (h (pgruppe-id n)))
  1032.             ((> i n) (pgruppel* g (pgruppel/ h) Gr))
  1033.           ; Invariant: g p1 h^-1 = p und p1(1)=1,...,p1(i-1)=i-1 und g,h in Gr.
  1034.           ; (assert (equalp (perm* (perm* (pgruppel-perm g) p1)
  1035.           ;                        (perm/ (pgruppel-perm h))) p))
  1036.           (let ((R (aref1 S i))
  1037.                 (j (apply-perm p1 i))
  1038.                 (k (apply-perm (perm/ p1) i)))
  1039.             (unless (= i j) ; Bei j=p1(i) = i ist nichts zu tun.
  1040.               (let ((Rj (assoc j R))  ; NIL oder (j . rij) mit rij(i)=j
  1041.                     (Rk (assoc k R))) ; NIL oder (k . rik) mit rik(i)=k
  1042.                 (if (or (null Rj) (null Rk))
  1043.                   (return-from perm-to-pgruppel nil)
  1044.                   ; Bei p in Gr wäre auch p1 in Gr.
  1045.                   ; Bei (null Rj) wegen p1 (i) = j ein Widerspruch.
  1046.                   ; Bei (null Rk) wegen p1^-1 (i) = k ebenso.
  1047.                   (progn
  1048.                     (setq Rj (cdr Rj))
  1049.                     (setq Rk (cdr Rk))
  1050.                     (if (<= (pgruppel-ezpl Rj) (pgruppel-ezpl Rk))
  1051.                       (progn
  1052.                         ; Ziehe Rj vor:
  1053.                         ; p1 = rij p1' und also p = g rij p1' h^-1 = g' p1' h^-1
  1054.                         (setq g (pgruppel* g Rj Gr)) ; g' = g r, p1' = rij^-1 p1
  1055.                         (setq p1 (perm* (perm/ (pgruppel-perm Rj)) p1))
  1056.                         ; p1'(1)=1,...,p1'(i-1)=i-1, p1'(i)=rij^-1(j)=i.
  1057.                       )
  1058.                       (progn
  1059.                         ; Ziehe Rk vor: p1 = p1' rik^-1 und
  1060.                         ; p = g p1' rik^-1 h^-1 = g p1' h'^-1
  1061.                         (setq h (pgruppel* h Rk Gr)) ; h' = h rik, p1' = p1 rik
  1062.                         (setq p1 (perm* p1 (pgruppel-perm Rk)))
  1063.                         ; p1'(1)=1,...,p1'(i-1)=i-1, p1'(i)=p1(k)=i.
  1064.      )) ) ) ) ) ) ) ) )
  1065.      (multiple-value-bind (gl g)
  1066.        (search-min
  1067.          (list ; drei mögliche Erzeugendenprodukte
  1068.              (p-t-p-1 p)
  1069.              (pgruppel/ (p-t-p-1 (perm/ p)))
  1070.              (p-t-p-2 p)
  1071.          )
  1072.          #'<
  1073.          :key #'pgruppel-ezpl
  1074.        )
  1075.        (declare (ignore gl))
  1076.        (format *gruppen-trace* "~%")
  1077.        (if *gruppen-trace* (pgruppel-print g Gr))
  1078.        g ; das Ergebnis
  1079.      )
  1080. ))))
  1081.  
  1082. ; (maxezpl G) liefert zu einer Gruppe mit fertigem SGS, mit maximal
  1083. ; wievielen (benannten) Erzeugenden sich ein beliebiges Gruppenelement
  1084. ; darstellen läßt.
  1085. (proclaim '(function maxezpl (&optional pgruppe) integer))
  1086. (defun maxezpl (&optional (G *pgruppe*))
  1087.   ; Das ist = Summe (über alle Ri von S) der Länge des längsten
  1088.   ;           - bzw. falls beim längsten p aus Ri  p(i) /= p^-1(i) gilt - des
  1089.   ;           zweitlängsten p aus Ri.
  1090.   (let ((S (sgs G))
  1091.         (sum 0))
  1092.     (dolist (i (intlist 1 (length S)))
  1093.       (incf sum (let ((lmax 0)  ; Länge der längsten Permutation
  1094.                       (l2max 0) ; Länge der zweitlängsten Permutation
  1095.                       (maxinv t)) ; Flag, das angibt, ob bei der längsten
  1096.                                   ; Permutation p p1(i) = p1^-1(i) war.
  1097.                   (dolist (P (aref1 S i))
  1098.                     (let ((l (pgruppel-ezpl (cdr P)))
  1099.                           (p1 (pgruppel-perm (cdr P))))
  1100.                       (cond ((<= l l2max)) ; nichts
  1101.                             ((<= l lmax) ; neues zweitlängstes
  1102.                              (setq l2max l))
  1103.                             (t ; neues Maximum
  1104.                                (setq l2max lmax)
  1105.                                (setq lmax l)
  1106.                                (setq maxinv
  1107.                                  (= i (apply-perm p1 (apply-perm p1 i)))
  1108.                     ) )     )  )
  1109.                   )
  1110.                   (if maxinv lmax l2max)
  1111.     ) )         )
  1112.     sum
  1113. ) )
  1114.  
  1115.  
  1116. ;-------------------------------------------------------------------------------
  1117. ; Beispiele:
  1118. (defvar w2)
  1119. (defvar rubik2)
  1120. (defvar rubik3)
  1121. (defvar rubikw)
  1122. (defvar dodeka)
  1123.  
  1124. (defun mache-gruppen () ; konstruiert alle Gruppen, "roh" (leer)
  1125.  
  1126. ; Drehgruppe des Würfels, auf den Flächen operierend
  1127. (setq w2 (mache-gruppe 6
  1128.            '("Dreh16" ((2 3 5 4))
  1129.              "Dreh25" ((1 3 6 4))
  1130.              "Dreh34" ((1 2 6 5))
  1131. )        )  )
  1132.  
  1133. ; Drehgruppe des 2 x 2 x 2 - Rubik-Würfels
  1134. (setq rubik2
  1135.   (mache-gruppe 24
  1136.     '("U" ((1 2 3 4) (5 7 9 11) (6 8 10 12))
  1137.       "D" ((13 14 15 16) (17 19 21 23) (18 20 22 24))
  1138.       "F" ((5 17 18 6) (1 24 14 7) (2 12 13 19))
  1139.       "B" ((10 9 21 22) (4 8 15 23) (3 20 16 11))
  1140.       "L" ((8 7 19 20) (3 6 14 21) (2 18 15 9))
  1141.       "R" ((12 11 23 24) (1 10 16 17) (4 22 13 5))
  1142. ) )  )
  1143.  
  1144. ; Drehgruppe des 3 x 3 x 3 - Rubik-Würfels bei festen Flächenmitten
  1145. (setq rubik3
  1146.   (mache-gruppe 48
  1147.   '("U" ((1 3 8 6) (2 5 7 4) (9 48 15 12) (10 47 16 13) (11 46 17 14))
  1148.     "L" ((9 11 26 24) (10 19 25 18) (1 12 33 41) (4 20 36 44) (6 27 38 46))
  1149.     "F" ((12 14 29 27) (13 21 28 20) (6 15 35 26) (7 22 34 19) (8 30 33 11))
  1150.     "R" ((15 17 32 30) (16 23 31 22) (3 43 35 14) (5 45 37 21) (8 48 40 29))
  1151.     "D" ((33 35 40 38) (34 37 39 36) (24 27 30 43) (25 28 31 42) (26 29 32 41))
  1152.     "B" ((41 43 48 46) (42 45 47 44) (1 24 40 17) (2 18 39 23) (3 9 38 32))
  1153. ) ))
  1154.  
  1155. ; Drehgruppe des 3 x 3 x 3 - Rubik-Würfels bei festen Flächenmitten
  1156. ; Jede Drehung ist nach der Farbe ihres Mittelfeldes benannt.
  1157. (setq rubikw
  1158.   (mache-gruppe 48
  1159.   '("Weiß"   ((1 3 8 6) (2 5 7 4) (9 48 15 12) (10 47 16 13) (11 46 17 14))
  1160.     "Blau"   ((9 11 26 24) (10 19 25 18) (1 12 33 41) (4 20 36 44) (6 27 38 46))
  1161.     "Rot"    ((12 14 29 27) (13 21 28 20) (6 15 35 26) (7 22 34 19) (8 30 33 11))
  1162.     "Grün"   ((15 17 32 30) (16 23 31 22) (3 43 35 14) (5 45 37 21) (8 48 40 29))
  1163.     "Gelb"   ((33 35 40 38) (34 37 39 36) (24 27 30 43) (25 28 31 42) (26 29 32 41))
  1164.     "Orange" ((41 43 48 46) (42 45 47 44) (1 24 40 17) (2 18 39 23) (3 9 38 32))
  1165. ) ))
  1166.  
  1167. ; Drehgruppe von Rubik's Dodekaeder bei festen Flächenmitten
  1168. (setq dodeka
  1169.   (mache-gruppe 120
  1170.     '("Weiß"       ((1 9 7 5 3) (2 10 8 6 4) (11 51 41 31 21)
  1171.                     (19 59 49 39 29) (20 60 50 40 30))
  1172.       "Rot"        ((1 21 61 109 57) (2 22 62 110 58) (3 23 63 101 59)
  1173.                     (11 19 17 15 13) (12 20 18 16 14))
  1174.       "Blau"       ((3 31 71 69 17) (4 32 72 70 18) (5 33 73 61 19)
  1175.                     (21 29 27 25 23) (22 30 28 26 24))
  1176.       "Schwarz"    ((5 41 81 79 27) (6 42 82 80 28) (7 43 83 71 29)
  1177.                     (31 39 37 35 33) (32 40 38 36 34))
  1178.       "Gold"       ((7 51 91 89 37) (8 52 92 90 38) (9 53 93 81 39)
  1179.                     (41 49 47 45 43) (42 50 48 46 44))
  1180.       "Dunkelgrün" ((1 13 103 91 49) (9 11 101 99 47) (10 12 102 100 48)
  1181.                     (51 59 57 55 53) (52 60 58 56 54))
  1182.       "Silber"     ((15 23 73 119 107) (16 24 74 120 108) (17 25 75 111 109)
  1183.                     (61 69 67 65 63) (62 70 68 66 64))
  1184.       "Hellgrün"   ((25 33 83 117 67) (26 34 84 118 68) (27 35 85 119 69)
  1185.                     (71 79 77 75 73) (72 80 78 76 74))
  1186.       "Orange"     ((35 43 93 115 77) (36 44 94 116 78) (37 45 95 117 79)
  1187.                     (81 89 87 85 83) (82 90 88 86 84))
  1188.       "Grau"       ((45 53 103 113 87) (46 54 104 114 88) (47 55 105 115 89)
  1189.                     (91 99 97 95 93) (92 100 98 96 94))
  1190.       "Braun"      ((13 63 111 97 55) (14 64 112 98 56) (15 65 113 99 57)
  1191.                     (101 109 107 105 103) (102 110 108 106 104))
  1192.       "Gelb"       ((65 75 85 95 105) (66 76 86 96 106) (67 77 87 97 107)
  1193.                     (111 119 117 115 113) (112 120 118 116 114))
  1194. ) )  )
  1195.  
  1196. )
  1197.  
  1198. #|
  1199. ; Um von den Gruppen das SGS auszurechnen:
  1200. ; (sgs w2) (sgs rubik2) (sgs rubik3) (sgs rubikw) (sgs dodeka)
  1201.  
  1202. ; Um von die Gruppen abzuspeichern:
  1203. (with-open-file (s "Gruppen.dat" :direction :output)
  1204.   (pprint w2 s) (pprint rubik2 s) (pprint rubik3 s) )
  1205. ; [Vorher in VAX-LISP eventuell (setq *print-right-margin* 130) ]
  1206.  
  1207. ; Um die Gruppen wieder einzuladen:
  1208. (defun lade-gruppen ()
  1209.   (with-open-file (s "Gruppen.dat" :direction :input)
  1210.     (setq w2 (read s))
  1211.     (setq rubik2 (read s))
  1212.     (setq rubik3 (read s))
  1213.     t
  1214. ) )
  1215. |#
  1216.  
  1217. ; Um eine spezielle Gruppe abzuspeichern, z.B. (save-gruppe rubik3)
  1218. (defmacro save-gruppe (grp-name)
  1219.   `(with-open-file (s ,(concatenate 'string (string grp-name) '".SGS")
  1220.                     :direction :output :if-exists :new-version)
  1221.      #+VAX (let ((*print-right-margin* 132)) (pprint ,grp-name s))
  1222.      #-VAX (pprint ,grp-name s)
  1223. )  )
  1224.  
  1225. ; Um eine spezielle Gruppe einzuladen, z.B. (lade-gruppe rubik3)
  1226. (defmacro lade-gruppe (grp-name)
  1227.   `(with-open-file (s ,(concatenate 'string (string grp-name) '".SGS")
  1228.                     :direction :input)
  1229.      (setf ,grp-name (read s))
  1230.      t
  1231. )  )
  1232.  
  1233.