153 lines
4.5 KiB
Common Lisp
153 lines
4.5 KiB
Common Lisp
|
|
(defun permgr-elements (l)
|
|
(declare (type 'list l))
|
|
(let* ((n (length (first l)))
|
|
(end nil)
|
|
(rslt (list (<a-b> 1 n))))
|
|
|
|
(while (not end)
|
|
(progn
|
|
(setf end t)
|
|
(mapcar #'(lambda (p)
|
|
(progn
|
|
(mapcar #'(lambda (p2)
|
|
(let ((p*p2 (permgr-mult p p2))
|
|
(pos -1))
|
|
(do ((j 0 (1+ j)))
|
|
((or (not (equal pos -1)) (>= j (length rslt))))
|
|
(if (equal (l-cmpr p*p2 (nth j rslt)) :less)
|
|
(setf pos j)
|
|
(if (equal (l-cmpr p*p2 (nth j rslt)) :equal)
|
|
(setf pos -2)
|
|
(if (and (equal j (1- (length rslt))) (equal pos -1))
|
|
(setf pos (length rslt))))))
|
|
(if (> pos -1)
|
|
(progn
|
|
(setf rslt (append (subseq rslt 0 pos) (list p*p2) (subseq rslt pos (length rslt))))
|
|
(setf end nil))))
|
|
|
|
(let ((p2*p (permgr-mult p2 p))
|
|
(pos -1))
|
|
(do ((j 0 (1+ j)))
|
|
((or (not (equal pos -1)) (>= j (length rslt))))
|
|
(if (equal (l-cmpr p2*p (nth j rslt)) :less)
|
|
(setf pos j)
|
|
(if (equal (l-cmpr p2*p (nth j rslt)) :equal)
|
|
(setf pos -2)
|
|
(if (and (equal j (1- (length rslt))) (equal pos -1))
|
|
(setf pos (length rslt))))))
|
|
(if (> pos -1)
|
|
(progn
|
|
(setf rslt (append (subseq rslt 0 pos) (list p2*p) (subseq rslt pos (length rslt))))
|
|
(setf end nil)))
|
|
|
|
|
|
))
|
|
rslt)
|
|
))
|
|
l)))
|
|
rslt))
|
|
|
|
|
|
|
|
#|
|
|
(permgr-elements (list '(2 3 1) '(2 1 3)))
|
|
(permgr-elements (list '(2 3 4 1) '(2 1 3 4)))
|
|
(permgr-elements (list '(2 3 4 5 1) '(2 1 3 4 5)))
|
|
|
|
|#
|
|
|
|
|
|
|
|
|
|
|
|
|
|
(defun permgr-mult (p1 p2)
|
|
(declare (type 'list p1 p2))
|
|
(mapcar #'(lambda (i)
|
|
(nth (1- i) p2))
|
|
p1))
|
|
|
|
#|
|
|
(permgr-mult '(1 3 2) '(1 2 3))
|
|
(permgr-mult '(1 5 4 3 2) '(1 2 3 5 4))
|
|
|#
|
|
|
|
(defun permgr-inv (p1)
|
|
(declare (type 'list p1))
|
|
(mapcar #'(lambda (i)
|
|
(1+ (position i p1)))
|
|
(<a-b> 1 (length p1))))
|
|
|
|
#|
|
|
(permgr-inv '(1 3 2 5 4))
|
|
(permgr-mult '(1 3 2 5 4) '(1 3 2 5 4))
|
|
(permgr-mult '(1 5 2 3 4) (permgr-inv '(1 5 2 3 4)))
|
|
(permgr-mult '(5 4 3 1 2) (permgr-inv '(5 4 3 1 2)))
|
|
|#
|
|
|
|
|
|
|
|
(defun permutationgroup (l)
|
|
(declare (type 'list l))
|
|
(build-group :elements (permgr-elements l)
|
|
:cmpr #'l-cmpr
|
|
:mult #'permgr-mult
|
|
:inv #'permgr-inv
|
|
:nullel (<a-b> 1 (length (first l))) :orgn `(Permutation group generated by ,l)
|
|
))
|
|
|
|
|
|
#|
|
|
(setf s3 (permutationgroup (list '(2 3 1) '(2 1 3))))
|
|
|#
|
|
|
|
|
|
|
|
(defun symmetricgroup (n)
|
|
(let* ((l (list (append (<a-b> 2 n) (list 1)) (append (list 2 1) (<a-b> 3 n))))
|
|
(rslt (permutationgroup l)))
|
|
(setf (slot-value rslt 'orgn) `(Symmetric group ,n))
|
|
rslt))
|
|
|
|
#|
|
|
(cat-init)
|
|
(setf s3 (symmetricgroup 3))
|
|
(elements s3)
|
|
|
|
(setf s4 (symmetricgroup 4))
|
|
(elements s4)
|
|
|
|
|
|
|
|
|
|
|#
|
|
|
|
|
|
|
|
(defun alternatinggroup (n)
|
|
(let* ((l (list
|
|
(if (or (eq n 1) (eq n 2)) nil
|
|
(if (eq n 3) (list '(2 3 1))
|
|
(if (oddp n) (list (append (<a-b> 2 n) (list 1)) (append (<a-b> 1 (- n 3)) (list (1- n) n (- n 2))))
|
|
(list (append (<a-b> 2 (1- n)) (list 1 n)) (append (<a-b> 1 (- n 3)) (list (1- n) n (- n 2)))))))))
|
|
(rslt (permutationgroup l)))
|
|
(setf (slot-value rslt 'orgn) `(Alternating group ,n))
|
|
rslt))
|
|
|
|
|
|
#|
|
|
(cat-init)
|
|
(setf a3 (alternatinggroup 3))
|
|
(elements a3)
|
|
|
|
(setf a4 (alternatinggroup 4))
|
|
(elements a4)
|
|
|
|
|
|
|
|
|#
|
|
|
|
|
|
|
|
|