the *lisp* program which calculates conjugacy classes of symmetric groups and alternating groups

group.lisp

;; '((1 . 2) (2 . 3) (3 . 1))
;; '((1 . 4) (2 . 3) (4 . 1) (3 . 2))
;; '((5 . 1) (4 . 2) (2 . 5) (3 . 4) (1 . 3))

(defun mapping (item g)
  (cdr (assoc item g)))

(defun normalize (g)
  (sort g #'(lambda (x y) (< (car x) (car y)))))

(defun gequal (g h)
  (equal (normalize g) (normalize h)))

(defun multiply (&rest args)
  (reduce #'(lambda (g h)
              (mapcar #'(lambda (x) (cons (car x) (mapping (cdr x) g)))
                      h))
          args))
  
(defun unit (n)
  (loop for x from 1 to n collect (cons x x)))

(defun power (g n)
  (if (= n 0)
      (unit (length g))
      (if (oddp n)
          (multiply g (power g (1- n)))
          (let ((g2 (power g (/ n 2))))
            (multiply g2 g2)))))

(defun inverse (g)
  (mapcar #'(lambda (x) (cons (cdr x) (car x))) g))

(defun cycle (g)
  (let (ret seen)
    (dolist (x g)
      (unless (member (car x) seen)
        (let ((l (list (cdr x) (car x))))
          (setf seen (append l seen))
          (when (/= (car x) (cdr x))
            (do ((y (cdr x) z)
                 (z (mapping (cdr x) g) (mapping z g)))
                ((= (car x) z))
              (push z seen)
              (push z l))
            (push (reverse l) ret)))))
    (normalize ret)))

(defun sign (g)
  (reduce #'*
          (mapcar #'(lambda (l) (if (oddp (length l)) 1 -1))
                  (cycle g))))

;; http://rosettacode.org/wiki/Permutations
(defun permute (list)
  (if list
      (mapcan #'(lambda (x)
                  (mapcar #'(lambda (y) (cons x y))
                          (permute (remove x list))))
              list)
      '(())))

(defun symmetric-group (n)
  (let ((l (loop for x from 1 to n collect x)))
    (loop for p in (permute l)
       collect (mapcar #'(lambda (x y) (cons x y)) l p))))

(defun alternating-group (n)
  (remove-if #'(lambda (g) (= (sign g) -1)) (symmetric-group n)))

(defun conjugacy-class (groups)
  (loop for g in groups
     with seen = nil
     unless (member g seen :test #'gequal)
     collect
       (loop for x in groups
          for y = (normalize (multiply x g (inverse x))) ;; nanka okasii
          unless (member y seen :test #'gequal)
          do (push y seen) and
          collect y)))

(defun ccycle (class)
  (mapcar #'(lambda (groups) (mapcar #'cycle groups)) class))

;; (ccycle (conjugacy-class (alternating-group 4)))
;; => ((NIL)                                                                                                                                              
;;     (((2 3 4)) ((1 4 3)) ((1 2 4)) ((1 3 2)))                                                                                                          
;;     (((2 4 3)) ((1 3 4)) ((1 4 2)) ((1 2 3)))                                                                                                          
;;     (((1 2) (3 4)) ((1 3) (2 4)) ((1 4) (2 3))))