├── .gitignore ├── ACKNOWLEDGEMENTS ├── examples ├── symmetric.lisp ├── sporadic.lisp ├── package.lisp ├── misc.lisp └── rubik-like.lisp ├── tests ├── package.lisp ├── suite.lisp ├── straight-line-program.lisp ├── free-group.lisp ├── orbit.lisp ├── homomorphism.lisp ├── do-group-elements.lisp ├── permutation.lisp ├── block.lisp └── permutation-group.lisp ├── REFERENCES ├── cl-permutation-examples.asd ├── cl-permutation-tests.asd ├── src ├── group.lisp ├── extra-functions.lisp ├── bruhat.lisp ├── find-subgroups.lisp ├── straight-line-program.lisp ├── right-transversal.lisp ├── do-group-elements.lisp ├── god.lisp ├── permutation-generation.lisp ├── homomorphism.lisp ├── orbit.lisp ├── package.lisp ├── utilities.lisp ├── block-subsystem-solver.lisp ├── free-group.lisp ├── combinatorial-ranking.lisp ├── block.lisp ├── permutation-group.lisp └── 4-list-algorithm.lisp ├── cl-permutation.asd ├── LICENSE └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | *.64xfasl 2 | -------------------------------------------------------------------------------- /ACKNOWLEDGEMENTS: -------------------------------------------------------------------------------- 1 | * Thanks to Brendan Pawlowski for the help with Schreier-Sims and its 2 | codification. -------------------------------------------------------------------------------- /examples/symmetric.lisp: -------------------------------------------------------------------------------- 1 | ;;;; examples/symmetric.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2014 Robert Smith 4 | 5 | (in-package #:cl-permutation-examples) 6 | 7 | ;;; Order: 120 8 | (defun make-S5 () 9 | (group-from 10 | '((2 1 3 4 5) 11 | (1 3 2 4 5) 12 | (1 2 4 3 5) 13 | (1 2 3 5 4)))) 14 | -------------------------------------------------------------------------------- /tests/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; tests/package.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2014-2016 Robert Smith 4 | 5 | (fiasco:define-test-package #:cl-permutation-tests 6 | (:use #:cl) 7 | (:nicknames #:perm-tests) 8 | (:use #:fiasco 9 | #:cl-permutation 10 | #:cl-permutation-examples) 11 | 12 | ;; suite.lisp 13 | (:export 14 | #:run-tests)) 15 | -------------------------------------------------------------------------------- /examples/sporadic.lisp: -------------------------------------------------------------------------------- 1 | ;;;; examples/sporadic.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2014 Robert Smith 4 | 5 | (in-package #:cl-permutation-examples) 6 | 7 | ;;; 244823040 8 | (defun make-mathieu-m25 () 9 | (group-from 10 | '((16 7 4 17 1 6 11 23 22 10 19 2 14 5 3 8 9 18 20 24 15 21 13 12) 11 | (24 21 10 22 9 23 8 7 5 3 18 20 14 13 19 17 16 11 15 12 2 4 6 1)))) 12 | -------------------------------------------------------------------------------- /REFERENCES: -------------------------------------------------------------------------------- 1 | [1] Efficient Representation of Perm Groups. Donald Knuth. 1990. 2 | 3 | [2] Efficient Finite Permutation Groups and Homomesy Computation in Common Lisp. Robert Smith and Brendan Pawlowski. 2014. 4 | 5 | [3] An Algorithm for Solving the Factorization Problemin Permutation Groups. Torsten Minkwitz. https://www.sciencedirect.com/science/article/pii/S0747717198902024 6 | 7 | [4] Info on Minkwitz https://mathstrek.blog/2018/06/21/solving-permutation-based-puzzles/ 8 | 9 | [5] Permutation group library in Nim https://github.com/remigijusj/perms-nim 10 | -------------------------------------------------------------------------------- /tests/suite.lisp: -------------------------------------------------------------------------------- 1 | ;;;; tests/suite.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2014-2018 Robert Smith 4 | 5 | (in-package #:cl-permutation-tests) 6 | 7 | (defun run-the-tests () 8 | (fiasco:run-package-tests :package '#:cl-permutation-tests)) 9 | 10 | ;; Create some groups that will be used immutably in the tests. 11 | 12 | (defvar *2x2* (perm-examples:make-rubik-2x2)) 13 | (defvar *3x3* (perm-examples:make-rubik-3x3)) 14 | (defvar *mm* (progn 15 | (when *compile-verbose* 16 | (format t "~&; Computing Megaminx group. This takes a few seconds...~%")) 17 | (perm-examples:make-megaminx))) 18 | -------------------------------------------------------------------------------- /cl-permutation-examples.asd: -------------------------------------------------------------------------------- 1 | ;;;; cl-permutation-examples.asd 2 | ;;;; 3 | ;;;; Copyright (c) 2014-2018 Robert Smith 4 | 5 | (asdf:defsystem #:cl-permutation-examples 6 | :description "Examples of permutation-groups." 7 | :author "Robert Smith " 8 | :license "BSD 3-clause (See LICENSE)" 9 | :depends-on (#:cl-permutation #:alexandria) 10 | :serial t 11 | :components ((:module examples 12 | :serial t 13 | :components 14 | ((:file "package") 15 | (:file "symmetric") 16 | (:file "sporadic") 17 | (:file "rubik-like") 18 | (:file "misc"))))) 19 | -------------------------------------------------------------------------------- /examples/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; examples/package.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2014 Robert Smith 4 | 5 | (defpackage #:cl-permutation-examples 6 | (:use #:cl #:perm) 7 | (:nicknames #:perm-examples) 8 | 9 | ;; symmetric.lisp 10 | (:export 11 | #:make-S5 ; FUNCTION 12 | ) 13 | 14 | ;; sporadic.lisp 15 | (:export 16 | #:make-mathieu-m25 ; FUNCTION 17 | ) 18 | 19 | ;; rubik-like.lisp 20 | (:export 21 | #:make-rubik-2x2 ; FUNCTION 22 | #:make-rubik-3x3 ; FUNCTION 23 | #:make-rubik-MU-group ; FUNCTION 24 | #:make-rubik-4x4 ; FUNCTION 25 | #:make-skewb ; FUNCTION 26 | #:make-megaminx ; FUNCTION 27 | ) 28 | 29 | (:export 30 | #:make-bicycle ; FUNCTION 31 | #:make-bicycle* ; FUNCTION 32 | #:make-bicycle-with-fixed-wheel ; FUNCTION 33 | ) 34 | ) 35 | -------------------------------------------------------------------------------- /tests/straight-line-program.lisp: -------------------------------------------------------------------------------- 1 | ;;;; tests/straight-line-program.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2015 Robert Smith 4 | 5 | (in-package #:cl-permutation-tests) 6 | 7 | (deftest test-slp () 8 | "Test some example SLPs using all possible constructors." 9 | (let ((f (make-free-group 5)) 10 | (ctx (make-instance 'slp-context))) 11 | (flet ((assign (a b) 12 | (setf (symbol-assignment ctx a) b))) 13 | ;; x1 = 4 14 | (assign :x1 (slp-element 4)) 15 | 16 | ;; x2 = 5 17 | (assign :x2 (slp-element 5)) 18 | 19 | ;; x3 = x1 x2 20 | (assign :x3 (compose-slp (slp-symbol :x1) 21 | (slp-symbol :x2))) 22 | 23 | ;; x4 = x3^-1 * 2 * x2 24 | (assign :x4 (compose-slp (invert-slp (slp-symbol :x3)) 25 | (compose-slp (slp-element 2) 26 | (slp-symbol :x2)))) 27 | 28 | (is (equal (make-free-group-element f -5 -4 2 5) 29 | (evaluate-slp f ctx (slp-symbol :x4))))))) 30 | -------------------------------------------------------------------------------- /cl-permutation-tests.asd: -------------------------------------------------------------------------------- 1 | ;;;; cl-permutation-tests.asd 2 | ;;;; 3 | ;;;; Copyright (c) 2014-2019 Robert Smith 4 | 5 | (asdf:defsystem #:cl-permutation-tests 6 | :description "Regression tests for the library CL-PERMUTATION." 7 | :author "Robert Smith " 8 | :license "BSD 3-clause (See LICENSE)" 9 | :depends-on (#:cl-permutation 10 | #:cl-permutation-examples 11 | #:fiasco) 12 | :perform (asdf:test-op (o s) 13 | (uiop:symbol-call :cl-permutation-tests 14 | '#:run-the-tests)) 15 | :pathname "tests/" 16 | :serial t 17 | :components ((:file "package") 18 | (:file "suite") 19 | (:file "permutation") 20 | (:file "straight-line-program") 21 | (:file "permutation-group") 22 | (:file "do-group-elements") 23 | (:file "homomorphism") 24 | (:file "orbit") 25 | (:file "block") 26 | (:file "free-group"))) 27 | -------------------------------------------------------------------------------- /tests/free-group.lisp: -------------------------------------------------------------------------------- 1 | ;;;; free-group.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2019 Robert Smith 4 | 5 | (in-package #:cl-permutation-tests) 6 | 7 | (deftest test-word-simplification () 8 | "Test that words simplify OK." 9 | (let* ((orders (vector nil 4 2 4 4 4 4)) 10 | (comms (vector nil '(2) '(1) '(4) '(3) '(6) '(5))) 11 | (f (cl-permutation::word-simplifier orders comms))) 12 | (flet ((test (candidate expected) 13 | (is (equalp expected (funcall f candidate))))) 14 | (test '0 'NIL) 15 | (test 'NIL 'NIL) 16 | (test '(0) 'NIL) 17 | (test '(1) '(1)) 18 | (test '(1 1) '(1 1)) 19 | (test '(1 1 1) '(-1)) 20 | (test '(1 1 1 1) 'NIL) 21 | (test '(1 1 1 1 1) '(1)) 22 | (test '(-1) '(-1)) 23 | (test '(-1 -1) '(1 1)) 24 | (test '(-1 -1 -1) '(1)) 25 | (test '(-1 -1 -1 -1) 'NIL) 26 | (test '(-1 -1 -1 -1 -1) '(-1)) 27 | (test '(1 2) '(1 2)) 28 | (test '(1 2 1 2) '(1 1)) 29 | (test '(1 2 1 2 1 2) '(-1 2)) 30 | (test '(1 2 1 2 1 2 1 2) 'NIL) 31 | (test '(1 2 1 2 1 2 1 2 1 2) '(1 2))))) 32 | -------------------------------------------------------------------------------- /tests/orbit.lisp: -------------------------------------------------------------------------------- 1 | ;;;; tests/orbit.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2015-2016 Robert Smith 4 | 5 | (in-package #:cl-permutation-tests) 6 | 7 | (deftest test-group-orbits () 8 | "Test that GROUP-ORBITS counts the right number of orbits." 9 | (is (= 1 (length (perm:group-orbits *2x2*)))) 10 | (is (= 2 (length (perm:group-orbits *3x3*)))) 11 | (is (= 2 (length (perm:group-orbits *mm*)))) 12 | (is (= 3 (length (perm:group-orbits (perm:generate-perm-group 13 | (list 14 | (perm:make-perm 2 1 3 4 5 6) 15 | (perm:make-perm 1 2 4 3 5 6) 16 | (perm:make-perm 1 2 3 4 6 5))))))) 17 | (is (= 1 (length (perm:group-orbits (perm-examples:make-bicycle 3))))) 18 | (is (= 1 (length (perm:group-orbits (perm-examples:make-bicycle-with-fixed-wheel 3)))))) 19 | 20 | (deftest test-rubik-subdirect-factor-count () 21 | "Check that there are exactly two subdirect factors of the cube group." 22 | (let ((subdirect-factors (subdirect-factors *3x3*))) 23 | (is (= 2 (length subdirect-factors))))) 24 | -------------------------------------------------------------------------------- /tests/homomorphism.lisp: -------------------------------------------------------------------------------- 1 | ;;;; tests/homomorphism.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2016 Robert Smith 4 | 5 | (in-package #:cl-permutation-tests) 6 | 7 | (defun convert-homomorphism (func-hom) 8 | (let ((preimage (homomorphism-preimage func-hom)) 9 | (image (homomorphism-image func-hom))) 10 | (make-instance 'generator-homomorphism 11 | :from-group preimage 12 | :to-group image 13 | :generator-map func-hom))) 14 | 15 | (deftest randomly-test-generator-homomorphism-correctness-for-group (group count) 16 | (multiple-value-bind (groups homs) 17 | (subdirect-factors group) 18 | (declare (ignore groups)) 19 | (let* ((func-hom (first homs)) 20 | (gen-hom (convert-homomorphism func-hom))) 21 | (loop :repeat count 22 | :for r := (random-group-element group) 23 | :do (is (perm= (funcall func-hom r) 24 | (funcall gen-hom r))))))) 25 | 26 | (deftest test-generator-homomorphism-correctness () 27 | (randomly-test-generator-homomorphism-correctness-for-group *3x3* 25) 28 | (randomly-test-generator-homomorphism-correctness-for-group *mm* 25)) 29 | -------------------------------------------------------------------------------- /tests/do-group-elements.lisp: -------------------------------------------------------------------------------- 1 | ;;;; tests/permutation-group.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2016 Robert Smith 4 | 5 | (in-package #:cl-permutation-tests) 6 | 7 | (defun test-rank-unrank (group &optional (limit (group-order group))) 8 | (let ((i 0) 9 | (failures nil)) 10 | (multiple-value-bind (rank-el unrank-el) 11 | (group-element-rank-functions group) 12 | (do-group-elements (el group failures) 13 | (when (= i limit) 14 | (return-from test-rank-unrank failures)) 15 | (let ((ranked (funcall rank-el el)) 16 | (unranked (funcall unrank-el i))) 17 | (unless (= i ranked) 18 | (push (list ':RANK i el ranked) failures)) 19 | (unless (perm= el unranked) 20 | (push (list ':UNRANK i el unranked) failures)) 21 | ;; Check that identity is 0. 22 | (when (perm-identity-p el) 23 | (is (zerop i)))) 24 | (incf i))))) 25 | 26 | (deftest test-rank-unrank-s5 () 27 | (is (null (test-rank-unrank (make-s5))))) 28 | 29 | (deftest test-rank-unrank-2x2 () 30 | (is (null (test-rank-unrank *2x2* 10000)))) 31 | 32 | (deftest test-rank-unrank-3x3 () 33 | (is (null (test-rank-unrank *3x3* 1000)))) 34 | -------------------------------------------------------------------------------- /src/group.lisp: -------------------------------------------------------------------------------- 1 | ;;;; group.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2015 Robert Smith 4 | 5 | (in-package #:cl-permutation) 6 | 7 | ;;; Definition of the group protocol. 8 | 9 | ;;; Refresher: 10 | ;;; 11 | ;;; A group G is a set along with a binary operation @ such that: 12 | ;;; 13 | ;;; * G is closed under @ 14 | ;;; 15 | ;;; * There's an identity element e in G such that for an element g 16 | ;;; in G, e@g = g@e = g 17 | ;;; 18 | ;;; * All elements in g in G have an inverse g' such that g'@g = 19 | ;;; g@g' = e 20 | ;;; 21 | ;;; * The binary operation is associative: (a@b)@c = a@(b@c) 22 | 23 | (defgeneric identity-element (G) 24 | (:documentation "Return the identity element of the group G.")) 25 | 26 | (defgeneric compose (G a b) 27 | (:documentation "Compose two elements A and B within the group G.")) 28 | 29 | (defgeneric inverse (G a) 30 | (:documentation "Compute the inverse of A within the group G.")) 31 | 32 | ;;; If a group is generated by a list of generators, then it may 33 | ;;; satisfy the following protocol. We call these groups "generated 34 | ;;; groups". 35 | 36 | (defgeneric generators (G) 37 | (:documentation "Return a list of the generators of G.")) 38 | 39 | (defgeneric num-generators (G) 40 | (:documentation "Return the number of generators of the group G.")) 41 | -------------------------------------------------------------------------------- /src/extra-functions.lisp: -------------------------------------------------------------------------------- 1 | ;;;; extra-functions.lisp 2 | ;;;; Copyright (c) 2012 Robert Smith 3 | 4 | ;;; This file contains extra or experimental functions which are not 5 | ;;; officially a part of the API. 6 | 7 | (in-package #:cl-permutation) 8 | 9 | (defun perm-extend (perm &optional (n 1)) 10 | "Extend a permutation PERM" 11 | (assert (plusp n)) 12 | (perm-compose (perm-identity (+ (perm-size perm) n)) 13 | perm)) 14 | 15 | (defun last-to-position (size new-pos) 16 | "Create a permutation that will permute the last element of a 17 | permutation of size SIZE to the position NEW-POS." 18 | (loop :for i :from size :downto new-pos 19 | :collect i :into cycle 20 | :finally (return (from-cycles (list cycle) size)))) 21 | 22 | (defun perm-inject (perm inject-to) 23 | "For a permutation PERM of size N, inject N+1 to the position 24 | INJECT-TO." 25 | (perm-compose (perm-extend perm) 26 | (last-to-position (1+ (perm-size perm)) 27 | inject-to))) 28 | 29 | (defun perm-eject (perm) 30 | "Remove the largest element of a permutation." 31 | ;; Here, we are going to do it the ugly way. 32 | ;; 33 | ;; TODO FIXME: make better 34 | (let* ((size (perm-size perm)) 35 | (new-spec (remove size (perm.rep perm)))) 36 | (%make-perm new-spec))) 37 | -------------------------------------------------------------------------------- /examples/misc.lisp: -------------------------------------------------------------------------------- 1 | ;;;; examples/misc.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2018 Robert Smith 4 | 5 | (in-package #:cl-permutation-examples) 6 | 7 | ;;; Is there a name for this group? 8 | ;;; 9 | ;;; 1 4 10 | ;;; <=> 11 | ;;; 2 3 5 6 12 | ;;; 13 | (defun make-bicycle (n) 14 | (let ((left-wheel (alexandria:iota n :start 1)) 15 | (right-wheel (alexandria:iota n :start (1+ n)))) 16 | (group-from-cycles 17 | (list 18 | (list (apply #'make-cycle left-wheel)) 19 | (list (apply #'make-cycle right-wheel)) 20 | (mapcar #'make-cycle left-wheel right-wheel)) 21 | (* 2 n)))) 22 | 23 | ;;; == (12) Bc(n) (12)^-1 24 | (defun make-bicycle* (n) 25 | (let ((left-wheel (alexandria:iota n :start 1)) 26 | (right-wheel (alexandria:iota n :start (1+ n)))) 27 | ;; Conjugate by the cycle (12) 28 | (rotatef (nth 0 left-wheel) 29 | (nth 1 left-wheel)) 30 | (group-from-cycles 31 | (list 32 | (list (apply #'make-cycle left-wheel)) 33 | (list (apply #'make-cycle right-wheel)) 34 | (mapcar #'make-cycle left-wheel right-wheel)) 35 | (* 2 n)))) 36 | 37 | (defun make-bicycle-with-fixed-wheel (n) 38 | (let ((left-wheel (alexandria:iota n :start 1)) 39 | (right-wheel (alexandria:iota n :start (1+ n)))) 40 | (group-from-cycles 41 | (list 42 | (list (apply #'make-cycle right-wheel)) 43 | (mapcar #'make-cycle left-wheel right-wheel)) 44 | (* 2 n)))) 45 | -------------------------------------------------------------------------------- /cl-permutation.asd: -------------------------------------------------------------------------------- 1 | ;;;; cl-permutation.asd 2 | ;;;; 3 | ;;;; Copyright (c) 2012-2023 Robert Smith 4 | 5 | (asdf:defsystem #:cl-permutation 6 | :description "A library for operating on permutations and permutation groups." 7 | :author "Robert Smith " 8 | :license "BSD 3-clause (See LICENSE)" 9 | :depends-on (#:alexandria 10 | #:iterate 11 | #:cl-algebraic-data-type 12 | #:closer-mop 13 | #:uiop 14 | #:bordeaux-fft 15 | #:priority-queue 16 | #:cl-cont 17 | ) 18 | :in-order-to ((asdf:test-op (asdf:test-op #:cl-permutation-tests))) 19 | :pathname "src/" 20 | :serial t 21 | :components ((:file "package") 22 | (:file "utilities") 23 | (:file "permutation") 24 | (:file "bruhat") 25 | (:file "permutation-generation") 26 | (:file "group") 27 | (:file "free-group") 28 | (:file "straight-line-program") 29 | (:file "permutation-group") 30 | (:file "minkwitz") 31 | (:file "4-list-algorithm") 32 | (:file "homomorphism") 33 | (:file "orbit") 34 | (:file "do-group-elements") 35 | (:file "block") 36 | (:file "combinatorial-ranking") 37 | (:file "find-subgroups") 38 | (:file "god") 39 | (:file "block-subsystem-solver") 40 | (:file "extra-functions"))) 41 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2012-2016, Robert Smith 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without 5 | modification, are permitted provided that the following conditions are 6 | met: 7 | 8 | 1. Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | 2. Redistributions in binary form must reproduce the above copyright 12 | notice, this list of conditions and the following disclaimer in the 13 | documentation and/or other materials provided with the distribution. 14 | 15 | 3. Neither the name of the copyright holder nor the names of its 16 | contributors may be used to endorse or promote products derived from 17 | this software without specific prior written permission. 18 | 19 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 20 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 21 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 22 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 23 | HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 24 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 25 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 26 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 27 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 28 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 29 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 30 | -------------------------------------------------------------------------------- /src/bruhat.lisp: -------------------------------------------------------------------------------- 1 | ;;;; bruhat.lisp 2 | ;;;; Copyright (c) 2014 Robert Smith 3 | 4 | (in-package #:cl-permutation) 5 | 6 | ;;; This file contains an implementation of Bruhat ordering of 7 | ;;; permutations. 8 | 9 | ;;; This function could be computed more efficiently with a better 10 | ;;; data structure for merging elements. It would also cons less. It 11 | ;;; could be reduced to O(N*log N) where N is the size of the 12 | ;;; permutations W and V. 13 | (defun bruhat<= (w v) 14 | "Does W precede V in the Bruhat sense, or are they equal?" 15 | (assert (= (perm-size w) 16 | (perm-size v)) 17 | (w v) 18 | "The sizes of the perms W and V must be equal.") 19 | (let ((collected-w nil) 20 | (collected-v nil)) 21 | (labels ((lex<= (a b) 22 | (loop :for ai :in a 23 | :for bi :in b 24 | :do 25 | (cond 26 | ((< ai bi) (return t)) 27 | ((> ai bi) (return nil))) 28 | :finally (return t)))) 29 | (loop :for i :from 1 :to (perm-size w) :do 30 | (setf collected-w (merge 'list collected-w 31 | (list (perm-eval w i)) 32 | #'<) 33 | collected-v (merge 'list collected-v 34 | (list (perm-eval v i)) 35 | #'<)) 36 | (unless (lex<= collected-w collected-v) 37 | (return-from bruhat<= nil))) 38 | 39 | ;; Every section is satisfied. 40 | t))) 41 | 42 | (defun bruhat< (w v) 43 | "Does W precede V in the Bruhat sense? 44 | 45 | We say that W precedes V in the Bruhat sense if there's a transposition S with V = WS and the length of V is one less the length of W." 46 | (assert (= (perm-size w) 47 | (perm-size v)) 48 | (w v) 49 | "The sizes of the perms W and V must be equal.") 50 | (and (not (perm= w v)) 51 | (bruhat<= w v))) 52 | -------------------------------------------------------------------------------- /tests/permutation.lisp: -------------------------------------------------------------------------------- 1 | ;;;; tests/permutation.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2014 Robert Smith 4 | 5 | (in-package #:cl-permutation-tests) 6 | 7 | (deftest test-perm-identity () 8 | "Test that PERM-IDENTITY is consistent with PERM-IDENTITY-P." 9 | (dotimes (i 5) 10 | (is (perm:perm-identity-p (perm:perm-identity i))))) 11 | 12 | (deftest test-from-cycles () 13 | (is (perm= (from-cycles (list (make-cycle 1 2))) 14 | (make-perm 2 1))) 15 | (is (perm= (from-cycles (list (make-cycle 1 2 3))) 16 | (make-perm 2 3 1))) 17 | (is (perm= (from-cycles (list (make-cycle 1 2 3) 18 | (make-cycle 4 5))) 19 | (make-perm 2 3 1 5 4)))) 20 | 21 | (deftest test-perm-compose () 22 | (let ((a (make-perm 2 1)) 23 | (b (make-perm 2 1 4 3)) 24 | (c (make-perm 1 3 2))) 25 | (is (perm= (make-perm 1 2 4 3) (perm-compose a b))) 26 | (is (perm= (make-perm 2 3 1) (perm-compose a c))) 27 | (is (perm= (make-perm 2 4 1 3) (perm-compose b c))) 28 | (is (perm= (make-perm 1 2 4 3) (perm-compose b a))) 29 | (is (perm= (make-perm 3 1 2) (perm-compose c a))) 30 | (is (perm= (make-perm 3 1 4 2) (perm-compose c b))))) 31 | 32 | (defun naive-from-cycles (cycles size) 33 | (reduce #'perm-compose cycles 34 | :initial-value (perm-identity size) 35 | :key (lambda (c) (from-cycles (list c) size)))) 36 | 37 | (deftest test-from-cycles-overlapping () 38 | (let ((cycles (list (make-cycle 6 7) 39 | (make-cycle 2 4 5) 40 | (make-cycle 1 9 4 8)))) 41 | (is (perm= (from-cycles cycles) 42 | (naive-from-cycles cycles 9))))) 43 | 44 | (deftest test-conjugator () 45 | "Test that we can find conjugators by checking everything in S_5." 46 | (perm:doperms (x 5) 47 | (perm:doperms (c 5) 48 | (let* ((y (perm:perm-conjugate x c)) 49 | (found-c (perm:find-conjugator x y))) 50 | (is (not (null found-c))) 51 | (is (perm:perm= y (perm:perm-conjugate x found-c))))))) 52 | -------------------------------------------------------------------------------- /src/find-subgroups.lisp: -------------------------------------------------------------------------------- 1 | ;;;; find-subgroups.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2015 Robert Smith 4 | 5 | ;;; This file contains a very simple heuristic for generating 6 | ;;; subgroups, specifically for the purpose of computing generator 7 | ;;; factorizations. The basic premise is that different powers of the 8 | ;;; generators are tried in different combinations to find a group 9 | ;;; that's significantly smaller than the group the generators are 10 | ;;; from. 11 | 12 | (in-package #:cl-permutation) 13 | 14 | ;;; An "exponent subgroup" of a group 15 | ;;; 16 | ;;; G = is a 17 | ;;; 18 | ;;; subgroup generated by where 19 | ;;; 20 | ;;; 0 <= k_i < order(g_i) - 1. 21 | ;;; 22 | ;;; The n-tuple (k_1, ..., k_n) is called the "exponent vector". 23 | 24 | (defun generator-orders (g) 25 | "Return the orders of each generator of the group G." 26 | (check-type g perm-group) 27 | (map 'vector 28 | #'perm:perm-order 29 | (perm-group.generators g))) 30 | 31 | (defun generator-exponent-set (g) 32 | "Return a combinatorial specification suitable for searching for subgroups of the group G. 33 | 34 | The specification specifies vectors of exponents to the group's generators, which may be used to generate some subgroups of the group." 35 | (check-type g perm-group) 36 | ;; We subtract 1 from the orders so we do not search subgroups of G 37 | ;; generated by a set of inverse permutations, because of the 38 | ;; following fact: 39 | ;; 40 | ;; G = 41 | ;; = <..., g_i^-1, ...> 42 | (let ((orders (map 'vector #'1- (generator-orders g)))) 43 | (vector-to-mixed-radix-spec orders))) 44 | 45 | (defun subgroup-from-exponent-vector (g v) 46 | "Generate a subgroup of the group G given the exponent vector V (which was possibly generated by some combinatorial spec, perhaps via #'GENERATOR-EXPONENT-SET)." 47 | (let* ((gens (perm-group.generators g)) 48 | ;; Compute the list of generators of the subgroup, possibly 49 | ;; containing identity perms. 50 | (sub-gens (map 'list #'perm-expt gens v))) 51 | (generate-perm-group (remove-if #'perm-identity-p sub-gens)))) 52 | 53 | (defun map-exponent-subgroups (f group) 54 | "Map the unary function F across all exponent subgroups of the group GROUP." 55 | (flet ((process-vector (ignore exponent-vector) 56 | (declare (ignore ignore)) 57 | (funcall f (subgroup-from-exponent-vector group 58 | exponent-vector)))) 59 | (map-spec #'process-vector (generator-exponent-set group)))) 60 | 61 | (defun suitable-subgroup-p (g) 62 | "Is the group G (which is presumably a subgroup of some other group) suitable for further computation?" 63 | (typep (group-order g) 'fixnum)) 64 | 65 | (defun map-suitable-subgroups (f group) 66 | "Map the unary function F across all suitable subgroups of the group GROUP." 67 | (flet ((process-subgroup (subgroup) 68 | (when (suitable-subgroup-p subgroup) 69 | (funcall f subgroup)))) 70 | (map-exponent-subgroups #'process-subgroup group))) 71 | -------------------------------------------------------------------------------- /tests/block.lisp: -------------------------------------------------------------------------------- 1 | ;;;; tests/block.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2015-2018 Robert Smith 4 | 5 | (in-package #:cl-permutation-tests) 6 | 7 | (deftest test-simple-block-system () 8 | "Compute the block system for a simple group." 9 | (let ((g (group-from-cycles (list (list (make-cycle 1 2 3 4 5 6)) 10 | (list (make-cycle 2 6) 11 | (make-cycle 3 5))) 12 | 6))) 13 | (let ((blocks (find-minimal-block-system-containing g '(1 3)))) 14 | (is (find '(1 3 5) blocks :test 'equalp)) 15 | (is (find '(2 4 6) blocks :test 'equalp))))) 16 | 17 | (deftest test-bike-blocks () 18 | "Test that blocks are computed correctly for the bicycle groups." 19 | (let* ((bike (perm-examples:make-bicycle 3)) 20 | (bike-blocks (perm::raw-block-subsystems bike)) 21 | (broke-bike (perm-examples:make-bicycle-with-fixed-wheel 3)) 22 | (broke-bike-blocks (perm::raw-block-subsystems broke-bike))) 23 | (is (= 1 (length bike-blocks))) 24 | (is (= 1 (length broke-bike-blocks))) 25 | (is (equal bike-blocks broke-bike-blocks)))) 26 | 27 | (deftest test-rubik-block-system () 28 | "Compute the block system of subdirect factors, and ensure they look right." 29 | (let ((bss (perm::raw-block-subsystems *3x3*))) 30 | (destructuring-bind (edges corners) bss 31 | (values 32 | (is (every (lambda (b) (= 2 (length b))) edges)) 33 | (is (every (lambda (b) (= 3 (length b))) corners)))))) 34 | 35 | (deftest test-rubik-intrablock-groups () 36 | "Test that the intrablock groups of the Rubik's cube are calculated correctly." 37 | (let* ((subsystems (perm::group-block-subsystems *3x3*)) 38 | (corners (find 3 subsystems :test #'= :key #'perm::block-subsystem-block-size)) 39 | (edges (find 2 subsystems :test #'= :key #'perm::block-subsystem-block-size)) 40 | (corner-gens (perm::block-subsystem-intrablock-group-generators corners)) 41 | (edge-gens (perm::block-subsystem-intrablock-group-generators edges)) 42 | (corner-intra (perm:generate-perm-group corner-gens)) 43 | (edge-intra (perm:generate-perm-group edge-gens))) 44 | (is (= 3 (perm:group-degree corner-intra :true t))) 45 | (is (= 3 (perm:group-order corner-intra))) 46 | (is (perm:group-element-p (perm:make-perm 2 3 1) corner-intra)) 47 | 48 | (is (= 2 (perm:group-degree edge-intra :true t))) 49 | (is (= 2 (perm:group-order edge-intra))) 50 | (is (perm:group-element-p (perm:make-perm 2 1) edge-intra)))) 51 | 52 | (deftest test-orientation-of-identity-and-superflip () 53 | (let* ((edge-subsys (first (perm::group-block-subsystems *3x3*))) 54 | (coord (perm::intrablock-coordinate-function edge-subsys)) 55 | (identity (group-identity *3x3*)) 56 | (superflip (from-cycles (mapcar (lambda (x) (apply #'make-cycle x)) 57 | (perm::block-subsystem-orbit edge-subsys)) 58 | 48))) 59 | (let ((c1 (funcall coord identity)) 60 | (c2 (funcall coord superflip))) 61 | (is (every #'zerop c1)) 62 | (is (every (lambda (x) (= 1 x)) c2))))) 63 | -------------------------------------------------------------------------------- /src/straight-line-program.lisp: -------------------------------------------------------------------------------- 1 | ;;;; src/straight-line-program.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2015 Robert Smith 4 | 5 | (in-package #:cl-permutation) 6 | 7 | ;;; "Straight Line Programs" (SLPs) are used to construct or record 8 | ;;; group elements and operations. They can, in a sense, be seen as 9 | ;;; "lazy group computations" with symbolic naming. 10 | ;;; 11 | ;;; SLPs are discriminated by four constructors, as shown in the 12 | ;;; following DEFDATA. 13 | 14 | (adt:defdata slp 15 | ;; A concrete group element. 16 | (slp-element t) 17 | ;; A symbol representing an assigned variable. 18 | (slp-symbol symbol) 19 | ;; The composition between two SLPs. 20 | (slp-composition slp slp) 21 | ;; The inverse of an SLP. 22 | (slp-inversion slp)) 23 | 24 | (defclass slp-context () 25 | ((symbol-table :initform (make-hash-table :test 'eq) 26 | :accessor symbol-table 27 | :documentation "A mapping between symbols and their representation as SLPs.")) 28 | (:documentation "Represents a context (e.g., symbol assignments) in which an SLP can be evaluated.")) 29 | 30 | (defun symbol-assignment (ctx symbol) 31 | "Within the context CTX and the symbol SYMBOL, look up its representation. Return NIL if it does not exist." 32 | (values (gethash symbol (symbol-table ctx)))) 33 | 34 | (defun (setf symbol-assignment) (representation ctx symbol) 35 | "Assign to the symbol SYMBOL the representation REPRESENTATION within the context CTX." 36 | (check-type representation slp) 37 | (let ((current-assignment (symbol-assignment ctx symbol))) 38 | ;; Check that the symbol is not already assigned to. 39 | (unless (null current-assignment) 40 | (cerror "Assign to it anyway." 41 | "The symbol ~S is already assigned to." 42 | symbol)) 43 | 44 | (values (setf (gethash symbol (symbol-table ctx)) 45 | representation)))) 46 | 47 | (defun compose-slp (slp1 slp2) 48 | "Compose two SLPs SLP1 and SLP2." 49 | (slp-composition slp1 slp2)) 50 | 51 | (defun invert-slp (slp) 52 | "Invert the SLP SLP." 53 | (slp-inversion slp)) 54 | 55 | ;;; "Evaluation" is a map from an SLP to an element of a group. 56 | 57 | (defun evaluate-slp (group ctx slp &key homomorphism) 58 | "Within a group GROUP, and given the context CTX and the straight line program SLP, compute its evaluation (the value of the SLP in the target group). 59 | 60 | If HOMOMORPHISM is provided, then the image of each SLP-ELEMENT will be computed. The image of the homomorphism should be GROUP." 61 | (let ((phi (if (null homomorphism) 62 | (lambda (x) x) 63 | homomorphism))) 64 | (labels ((ev (slp) 65 | (adt:match slp slp 66 | ((slp-element x) (funcall phi x)) 67 | ((slp-symbol s) 68 | (let ((assignment (symbol-assignment ctx s))) 69 | (assert (not (null assignment)) 70 | () 71 | "Encountered a symbol ~S which has no assignment ~ 72 | when evaluating an SLP." 73 | s) 74 | (ev assignment))) 75 | ((slp-composition a b) 76 | (compose group (ev a) (ev b))) 77 | ((slp-inversion x) 78 | (inverse group (ev x)))))) 79 | (ev slp)))) 80 | -------------------------------------------------------------------------------- /src/right-transversal.lisp: -------------------------------------------------------------------------------- 1 | ;;;; src/right-transversal.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2018 Robert Smith 4 | 5 | (in-package #:cl-permutation) 6 | 7 | (defclass right-cosets () 8 | ((subgroup :initarg :subgroup 9 | :reader coset-subgroup) 10 | (group :initarg :group 11 | :reader coset-group))) 12 | 13 | (defun make-right-cosets (H G) 14 | (assert (subgroup-p G H)) 15 | (make-instance 'right-cosets :subgroup H :group G)) 16 | 17 | (defun same-coset-p (x y cosets) 18 | (group-element-p (perm-compose (perm-inverse x) y) 19 | (coset-subgroup cosets))) 20 | 21 | (defun num-cosets (cosets) 22 | (/ (group-order (coset-group cosets)) 23 | (group-order (coset-subgroup cosets)))) 24 | 25 | (defun right-transversal (cosets) 26 | (let* ((n (num-cosets cosets)) 27 | (G (coset-group cosets)) 28 | (H (coset-subgroup cosets)) 29 | (representatives (list (group-identity G)))) 30 | (format t "Computing ~D transversals of ~A~%" n cosets) 31 | (labels ((random-G () 32 | (let ((e (random-group-element G))) 33 | (if (group-element-p e H) 34 | (random-G) 35 | e))) 36 | (already-seen? (x) 37 | (dolist (rep representatives nil) 38 | (when (group-element-p (perm-compose rep x) H) 39 | (return t))) 40 | #+ig 41 | (member x representatives :test (lambda (x y) 42 | (same-coset-p x y cosets))))) 43 | (loop :with last-time := (get-internal-real-time) 44 | :with found := 1 45 | :for tried :from 0 46 | :while (< found n) 47 | :for r := (random-G) 48 | :do (when (zerop (mod tried 1000)) 49 | (format t "Tried ~D, found ~D (~2,2F%), dt=~D ms~%" 50 | tried 51 | found 52 | (* 100.0 (/ found n)) 53 | (round (* 1000 (- (get-internal-real-time) last-time)) 54 | internal-time-units-per-second)) 55 | (setf last-time (get-internal-real-time)) 56 | (finish-output)) 57 | :unless (already-seen? r) 58 | :do (progn 59 | (push (perm-inverse r) representatives) 60 | (incf found)) 61 | :finally (return (mapcar #'perm-inverse representatives)))))) 62 | 63 | (defun thistlethwaite () 64 | (let ((3x3 (perm-examples:make-rubik-3x3))) 65 | (destructuring-bind (F R U B L D) 66 | (generators 3x3) 67 | (destructuring-bind (F2 R2 U2 B2 L2 D2) 68 | (mapcar (lambda (g) (perm-expt g 2)) (generators 3x3)) 69 | (let ((thistle-0 (generate-perm-group (list F R U B L D))) 70 | (thistle-1 (generate-perm-group (list F R U2 B L D2))) 71 | (thistle-2 (generate-perm-group (list F2 R U2 B2 L D2))) 72 | (thistle-3 (generate-perm-group (list F2 R2 U2 B2 L2 D2))) 73 | (thistle-4 (generate-perm-group (list (group-identity 3x3))))) 74 | (let ((coset1/0 (make-right-cosets thistle-1 thistle-0)) 75 | (coset2/1 (make-right-cosets thistle-2 thistle-1)) 76 | (coset3/2 (make-right-cosets thistle-3 thistle-2)) 77 | (coset4/3 (make-right-cosets thistle-4 thistle-3))) 78 | (list :G1/G0 (length (right-transversal coset1/0)) 79 | :G2/G1 (length (right-transversal coset2/1)) 80 | :G3/G2 (length (right-transversal coset3/2)) 81 | :G4/G3 (length (right-transversal coset4/3))))))))) 82 | -------------------------------------------------------------------------------- /src/do-group-elements.lisp: -------------------------------------------------------------------------------- 1 | ;;;; do-group-elements.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2014 Robert Smith 4 | 5 | (in-package #:cl-permutation) 6 | 7 | ;;;; Here we define a macro to iterate over all elements of a group in 8 | ;;;; some order. See reference [2] for details. 9 | 10 | (defun group-radix (group) 11 | "Compute the radix of the group GROUP." 12 | (map 'simple-vector #'length (perm-group.transversal-system group))) 13 | 14 | ;;; Note, in the below ranking/unranking functions, everything is 15 | ;;; based on the transversal decomposition, and the *position* of the 16 | ;;; sigma_kj in the sigma_k list. This is almost surely not at 17 | ;;; position j! 18 | 19 | (defun group-element-from-signature (group signature) 20 | ;; SIGNATURE is the output of ranking a MIXED-RADIX-SPEC, and has 21 | ;; elements between 0 and the position's radix. Since zero 22 | ;; corresponds to identity, we can skip them. When it is non-zero, 23 | ;; we subtract one, since the identity element is guaranteed to be 24 | ;; sigma_kk, which we don't want. 25 | (loop :with result := (group-identity group) 26 | :for sigma_k :across (perm-group.transversal-system group) 27 | :for n :across signature 28 | :unless (zerop n) 29 | :do (setf result (perm-compose (cdr (nth (1- n) sigma_k)) 30 | result)) 31 | :finally (return result))) 32 | 33 | (defun group-element-rank-functions (group) 34 | "Generate two functions as values: 35 | 36 | 1. A function to map elements of the permutation group GROUP to integers [0, 2^|GROUP| - 1]. 37 | 38 | 2. The inverse of the above function." 39 | ;; FIXME: We need to make sure this fails when we attempt to rank 40 | ;; something not in the group. 41 | (let ((spec (vector-to-mixed-radix-spec (group-radix group)))) 42 | (flet ((rank-element (el) 43 | (let* ((trans (perm-group.transversal-system group)) 44 | (set (make-array (size spec)))) 45 | ;; Get the SET data structure filled. 46 | (reduce-over-trans-decomposition 47 | (lambda (decomp k j) 48 | (declare (ignore decomp)) 49 | ;; Identity is 0, everything else is 1 + position as 50 | ;; found in the built-up transversal system. 51 | (setf (svref set (1- k)) 52 | (if (= j k) 53 | 0 54 | (1+ (position j (svref trans (1- k)) :key #'car)))) 55 | nil) 56 | nil 57 | el 58 | trans) 59 | 60 | ;; Finally, rank it. 61 | (rank spec set))) 62 | (unrank-element (idx) 63 | (group-element-from-signature group (unrank spec idx)))) 64 | (values #'rank-element #'unrank-element)))) 65 | 66 | (defmacro do-group-elements ((var group &optional return) &body body) 67 | "Iterate through all of the elements of the group GROUP, binding each element to VAR and executing BODY. Optionally return a value specified by RETURN." 68 | (let ((ggroup (gensym "GROUP-")) 69 | (spec (gensym "SPEC-")) 70 | (signature (gensym "SIGNATURE-")) 71 | (rank (gensym "RANK-"))) 72 | `(let* ((,ggroup ,group) 73 | (,spec (vector-to-mixed-radix-spec (group-radix ,ggroup)))) 74 | ;; Map across all elements of the group. 75 | (map-spec 76 | (lambda (,rank ,signature) 77 | (declare (ignore ,rank)) 78 | (let ((,var (group-element-from-signature ,ggroup ,signature))) 79 | (tagbody 80 | ,@body))) 81 | ,spec) 82 | ;; Return the return value. 83 | ,return))) 84 | -------------------------------------------------------------------------------- /src/god.lisp: -------------------------------------------------------------------------------- 1 | ;;;; god.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2016 Robert Smith 4 | 5 | (in-package #:cl-permutation) 6 | 7 | (defclass god-table () 8 | ((group :initarg :group 9 | :reader god-table-group) 10 | (table :initarg :table 11 | :reader god-table-vector) 12 | (target :initarg :target 13 | :reader god-table-target) 14 | (generators :initarg :generators 15 | :reader god-table-generators))) 16 | 17 | (defstruct god-table-entry 18 | move 19 | came-from 20 | depth 21 | transition) 22 | 23 | (defun compute-god-table (group &key (target (group-identity group)) 24 | (generators (generators group)) 25 | (rank-cardinality (group-order group)) 26 | (rank-element (group-element-rank-functions group)) 27 | (verbose t)) 28 | ;; RANK-CARDINALITY is max_rank + 1. It is not necessarily the group 29 | ;; order. 30 | (check-type target perm) 31 | (check-type rank-cardinality (integer 0)) 32 | 33 | (let ((generators (loop :for i :from 0 34 | :for g :in generators 35 | :collect (cons i g))) 36 | ;; Table of (list MOVE CAME-FROM DEPTH) 37 | (table (make-array rank-cardinality :initial-element nil)) 38 | (positions-left (make-queue)) 39 | (make-trans (lambda () (make-array (length generators))))) 40 | ;; Record TARGET as starting position. 41 | (enqueue positions-left target) 42 | (let ((target-rank (funcall rank-element target))) 43 | (setf (svref table target-rank) (make-god-table-entry :move -1 44 | :came-from target-rank 45 | :depth 0 46 | :transition (funcall make-trans)))) 47 | 48 | ;; Start iterating. 49 | (loop :for num-elements-explored :from 1 50 | :for next := (dequeue positions-left) 51 | :for next-rank := (funcall rank-element next) 52 | :for next-entry := (svref table next-rank) 53 | :do 54 | (when (and verbose (zerop (mod num-elements-explored 50000))) 55 | (format t "~D~%" (length (queue-elements positions-left)))) 56 | (loop :for (i . g) :in generators 57 | :for p := (perm-compose g next) 58 | :for r := (funcall rank-element p) 59 | ;; Record the coordinate transition. 60 | :do (setf (svref (god-table-entry-transition next-entry) i) r) 61 | ;; Traverse BFS style. 62 | :when (null (svref table r)) 63 | :do (let ((came-from (funcall rank-element next))) 64 | (enqueue positions-left p) 65 | (setf (svref table r) 66 | (make-god-table-entry 67 | :move i 68 | :came-from came-from 69 | :depth (1+ (god-table-entry-depth (svref table came-from))) 70 | :transition (funcall make-trans))))) 71 | :until (queue-empty-p positions-left)) 72 | 73 | ;; Return a GOD-TABLE object. 74 | (make-instance 'god-table :group group 75 | :table table 76 | :target target 77 | :generators generators))) 78 | 79 | (defgeneric reconstruct-perm (god-table perm) 80 | (:method ((table god-table) perm) 81 | (declare (optimize speed)) 82 | (multiple-value-bind (rank-element unrank-element) 83 | (group-element-rank-functions (god-table-group table)) 84 | (declare (ignore unrank-element) 85 | (type function rank-element)) 86 | (labels ((chase (current collected) 87 | (with-slots (move came-from) (svref (god-table-vector table) current) 88 | (declare (type integer move)) 89 | (if (= -1 move) 90 | (nreverse collected) 91 | (chase came-from (cons move collected)))))) 92 | (chase (funcall rank-element perm) nil))))) 93 | 94 | ;;; Example: 95 | ;;; (defvar *god (compute-god-table (perm-examples:make-rubik-2x2))) 96 | ;;; (reconstruct-perm *god (random-group-element (god-table-group *god))) 97 | -------------------------------------------------------------------------------- /src/permutation-generation.lisp: -------------------------------------------------------------------------------- 1 | ;;;; permutation-generation.lisp 2 | ;;;; Copyright (c) 2012-2014 Robert Smith 3 | 4 | (in-package #:cl-permutation) 5 | 6 | ;;;; This file implements the Steinhaus-Johnson-Trotter algorithm for 7 | ;;;; generating permutations. 8 | 9 | ;;;; XXX FIXME: We cons way too much here. Can we clean it up? 10 | 11 | (defun map-into-perm (function perm-spec) 12 | (let* ((n (length perm-spec)) 13 | (spec (allocate-perm-vector (1- (length perm-spec))))) 14 | (dotimes (i n spec) 15 | (setf (aref spec i) 16 | (funcall function (aref perm-spec i)))))) 17 | 18 | (defun abs> (x y) 19 | (> (abs x) 20 | (abs y))) 21 | 22 | (defun mobilep (idx perm &optional (len (length perm))) 23 | (let ((val (aref perm idx))) 24 | (if (plusp val) ; Is the value a "left" 25 | ; directed value? 26 | 27 | ;; Left directed. 28 | (and (> idx 1) ; Check that the index 29 | ; is non-zero. 30 | (abs> val (aref perm (1- idx)))) ; Check the neighbor. 31 | 32 | ;; Right directed. 33 | (and (not (= len idx)) ; Check that the index 34 | ; is not maximal. 35 | (abs> val (aref perm (1+ idx))))))) ; Check the neighbor. 36 | 37 | (defun reverse-direction (idx perm) 38 | (setf (aref perm idx) (- (aref perm idx)))) 39 | 40 | (defun exists-mobile-p (perm len) 41 | (loop :for i :from 1 :to len 42 | :thereis (mobilep i perm len))) 43 | 44 | (defun next-perm (perm len) 45 | (let ((idx -1) 46 | (max-mob -1)) 47 | (when (exists-mobile-p perm len) 48 | ;; Find the largest mobile 49 | (loop :for i :from 1 :to len 50 | :for x := (aref perm i) 51 | :if (and (mobilep i perm len) 52 | (abs> x max-mob)) 53 | :do (setf idx i 54 | max-mob x) 55 | :finally (let ((adj-idx (- idx (sign max-mob)))) 56 | ;; Swap the largest mobile element with its 57 | ;; adjacent partner 58 | (rotatef (aref perm idx) 59 | (aref perm adj-idx)) 60 | 61 | ;; Reverse the direction of all larger 62 | ;; elements. 63 | (loop :for i :from 1 :to len 64 | :for x := (aref perm i) 65 | :when (abs> x max-mob) 66 | :do (reverse-direction i perm)))) 67 | perm))) 68 | 69 | (defun make-perm-generator (n) 70 | "Create a generator that generates permutations of size N." 71 | (assert (plusp n) 72 | (n) 73 | "Must provide a positive size for permutation generation. Given ~D." 74 | n) 75 | (let ((perm t)) 76 | (lambda () 77 | ;; Check if PERM is NIL (if the generator was exhausted). 78 | (when perm 79 | ;; We do this hackery to be able to emit the initial 80 | ;; (identity) perm. Initially PERM is just T -- not a vector. 81 | (if (not (vectorp perm)) 82 | (progn 83 | (setf perm (make-array (1+ n) :initial-contents (iota (1+ n)))) 84 | (%make-perm (map-into-perm #'abs perm))) 85 | (let ((next (next-perm perm n))) 86 | ;; If we are at the end, then set PERM to NIL. 87 | (if next 88 | (%make-perm (map-into-perm #'abs next)) 89 | (setf perm nil)))))))) 90 | 91 | (defmacro doperms ((x n &optional result) &body body) 92 | "Iterate over all permutations of size N, optionally returning 93 | RESULT." 94 | (let ((perm (gensym "PERM-")) 95 | (len (gensym "LEN-"))) 96 | `(let ((,len ,n)) 97 | (assert (plusp ,len) 98 | (,len) 99 | "Must provide a positive size for permutation generation. Given ~D." 100 | ,len) 101 | (loop :for ,perm := (make-array (1+ ,len) 102 | :initial-contents (iota (1+ ,len))) 103 | :then (next-perm ,perm ,len) 104 | :while ,perm 105 | :do (let ((,x (%make-perm (map-into-perm #'abs ,perm)))) 106 | ,@body) 107 | :finally (return ,result))))) 108 | -------------------------------------------------------------------------------- /src/homomorphism.lisp: -------------------------------------------------------------------------------- 1 | ;;;; homomorphism.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2016 Robert Smith 4 | 5 | (in-package #:cl-permutation) 6 | 7 | (defgeneric homomorphism-preimage (hom) 8 | (:documentation "Preimage group of the homomorphism HOM.")) 9 | 10 | (defgeneric homomorphism-image (hom) 11 | (:documentation "Image group of the homomorphism HOM.")) 12 | 13 | (defgeneric image (homomorphism object) 14 | (:documentation "Compute the image of object OBJECT with respect to the homomorphism HOMOMORPHISM.") 15 | ;; By default, we allow functions to look like homomorphisms. It's 16 | ;; up to the user to determine whether the given function is 17 | ;; actually a homomorphism. 18 | (:method ((hom function) object) 19 | (funcall hom object))) 20 | 21 | ;; We provide an abstract class HOMOMORPHISM so that subclasses get 22 | ;; default FUNCALLABLE-INSTANCE-FUNCTIONs. 23 | (defclass homomorphism () 24 | () 25 | (:metaclass c2mop:funcallable-standard-class)) 26 | 27 | (defmethod initialize-instance :after ((hom homomorphism) &key) 28 | (c2mop:set-funcallable-instance-function 29 | hom 30 | (lambda (elt) (image hom elt)))) 31 | 32 | (defclass function-homomorphism (homomorphism) 33 | ((from-group 34 | :initarg :from-group 35 | :reader homomorphism-preimage 36 | :documentation "Preimage of the homomorphism.") 37 | (to-group 38 | :initarg :to-group 39 | :reader homomorphism-image 40 | :documentation "Image of the homomorphism.") 41 | (function :initarg :function 42 | :reader homomorphism-function 43 | :documentation "Homomorphism function.")) 44 | (:metaclass c2mop:funcallable-standard-class) 45 | (:documentation "Simple class which wraps homomorphic functions, associating them with the preimage and image of the function.")) 46 | 47 | (defmethod image ((hom function-homomorphism) obj) 48 | (funcall (homomorphism-function hom) obj)) 49 | 50 | (defclass generator-homomorphism (homomorphism) 51 | ((from-group 52 | :initarg :from-group 53 | :reader homomorphism-preimage 54 | :documentation "Preimage of the homomorphism.") 55 | (to-group 56 | :initarg :to-group 57 | :reader homomorphism-image 58 | :documentation "Image of the homomorphism.") 59 | (generator-map 60 | :initarg :generator-map 61 | :reader homomorphism-generator-map 62 | :documentation "A unary function mapping generators of FROM-GROUP to objects of the resulting group TO-GROUP.")) 63 | (:metaclass c2mop:funcallable-standard-class) 64 | (:documentation "A perm group homomorphism constructed from images of its genertators. 65 | 66 | This class is FUNCALLable.")) 67 | 68 | ;;; XXX FIXME: This is a pretty hairy function. Lots of stuff can also 69 | ;;; be precomputed. This should be cleaned up and made a bit more 70 | ;;; efficient. 71 | (defmethod image ((hom generator-homomorphism) (elt perm)) 72 | "Given a homomorphism HOM, compute the image of ELT." 73 | (let ((gen-map (homomorphism-generator-map hom)) 74 | (preimage (homomorphism-preimage hom)) 75 | (image (homomorphism-image hom))) 76 | (alexandria:if-let 77 | ((x (funcall gen-map elt))) 78 | x 79 | (labels ((core (x) 80 | ;; Perm -> Image 81 | (funcall gen-map 82 | ;; Free -> Perm 83 | (free-group-generator-to-perm-group-generator 84 | preimage 85 | x))) 86 | (ev (slp) 87 | (evaluate-slp 88 | image 89 | (perm-group.slp-context preimage) 90 | slp 91 | :homomorphism #'core))) 92 | (let* ((d (transversal-decomposition elt preimage :remove-identities t)) 93 | (ctx (perm-group.slp-context preimage))) 94 | (labels ((to-sigma-symbol (tt) 95 | (sigma-symbol (car tt) (cdr tt))) 96 | (find-slp (tt) 97 | (symbol-assignment ctx (to-sigma-symbol tt)))) 98 | (reduce (lambda (acc x) 99 | (compose image acc x)) 100 | d 101 | :initial-value (identity-element image) 102 | :key (lambda (sigma) 103 | (ev (find-slp sigma)))))))))) 104 | 105 | (defun homomorphism-induced-perm-group (group hom) 106 | "Given a group GROUP, and a homomorphism HOM mapping elements of that group to permutations,compute the homomorphism-induced group." 107 | (generate-perm-group 108 | (remove-if #'perm-identity-p (mapcar hom (generators group))))) 109 | -------------------------------------------------------------------------------- /src/orbit.lisp: -------------------------------------------------------------------------------- 1 | ;;;; orbit.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2015-2016 Robert Smith 4 | 5 | (in-package #:cl-permutation) 6 | 7 | (defun group-orbits (group) 8 | "Compute the orbits of the group GROUP. This will be a list of arrays of points." 9 | (let* ((d (group-degree group)) 10 | (orbit-membership (make-membership-set d)) 11 | (orbit-memberships nil)) 12 | (flet ((orbit-completed-for-element (x) 13 | (some (lambda (orbit) 14 | (= 1 (sbit orbit x))) 15 | orbit-memberships)) 16 | (membership-set-to-orbit (set) 17 | (let ((orbit (make-array (membership-set-count set))) 18 | (j 0)) 19 | (loop :for i :from 1 :to d 20 | :when (= 1 (sbit set i)) 21 | :do (setf (aref orbit j) i) 22 | (incf j) 23 | :finally (return orbit))))) 24 | ;; We compute the orbit of each point for each generator, 25 | ;; intersecting each time. 26 | (loop :for i :from 1 :to d :do 27 | ;; Even if we have seen I in an orbit before, we still have to 28 | ;; see how *all* the generators act on I. So we can't skip it. 29 | (clear-membership-set orbit-membership) 30 | ;; Compute the orbit of the element across all generators. 31 | (dolist (g (generators group)) 32 | (map-orbit (lambda (k) (setf (sbit orbit-membership k) 1)) 33 | i 34 | g)) 35 | ;; Incorporate that orbit anywhere it has intersected. 36 | (multiple-value-bind (intersecting non-intersecting) 37 | (partition-if (lambda (set) 38 | (membership-sets-intersect-p 39 | orbit-membership 40 | set)) 41 | orbit-memberships) 42 | (cond 43 | ((endp intersecting) 44 | ;; Add the newly found orbit. 45 | (push (copy-seq orbit-membership) orbit-memberships)) 46 | ((endp (rest intersecting)) ; 1 element 47 | ;; Modify the single orbit this intersects with. 48 | (membership-set-nunion (first intersecting) orbit-membership)) 49 | (t 50 | ;; Multiple orbits intersect, so we need to coalesce 51 | ;; them all. First, we nunion into our fresh orbit. (I 52 | ;; promise I am not a shill for Orbit® Gum.) 53 | (dolist (orb intersecting) 54 | (membership-set-nunion orbit-membership orb)) 55 | ;; Now tack this on to our set of non-intersecting 56 | ;; orbits, and save them. We are wasting space by 57 | ;; copying, but oh well. Who's counting anyway? 58 | (setf orbit-memberships (cons 59 | (copy-seq orbit-membership) 60 | non-intersecting)))))) 61 | ;; Return the orbits. 62 | (mapcar #'membership-set-to-orbit orbit-memberships)))) 63 | 64 | (defun orbit-group-homomorphism (original-group orbit) 65 | "Compute a homomorphism between elements of the permutation group ORIGINAL-GROUP to the naturally induced group of an orbit ORBIT of ORIGINAL-GROUP." 66 | (let* ((len (length orbit)) 67 | (element-map (make-array (1+ (group-degree original-group))))) 68 | ;; Compute a map between points in the original group and points 69 | ;; in the resulting orbit group. This is used to construct the 70 | ;; homomorphism. 71 | (loop :for i :from 1 72 | :for x :across orbit 73 | :do (setf (aref element-map x) i)) 74 | ;; Create an actual homomorphism function. 75 | (labels ((homomorphism (g) 76 | (let ((result (allocate-perm-vector len))) 77 | (loop :for i :from 1 :to len 78 | :for x :across orbit 79 | :do (setf (aref result i) 80 | (aref element-map (perm-eval g x))) 81 | :finally (return (%make-perm result)))))) 82 | #'homomorphism))) 83 | 84 | ;;; XXX: We may want to store the group was derived from and the 85 | ;;; function from the factor group to the original group. 86 | (defun group-from-orbit (original-group orbit) 87 | "Produce a group by having the group ORIGINAL-GROUP act on the orbit ORBIT of that group. 88 | 89 | As a second value, the homomorphism will be returned." 90 | (let* ((hom (orbit-group-homomorphism original-group orbit)) 91 | (induced-group (homomorphism-induced-perm-group original-group hom))) 92 | (values 93 | induced-group 94 | (make-instance 'function-homomorphism :from-group original-group 95 | :to-group induced-group 96 | :function hom)))) 97 | 98 | (defun subdirect-factors (group) 99 | "Compute \"subdirect factors\" of the group GROUP. 100 | 101 | These are groups whose direct product has GROUP as a subgroup. 102 | 103 | As a second value, return the corresponding list of homomorphisms between GROUP and the subdirect factors." 104 | (iter:iter 105 | (iter:for o :in (group-orbits group)) 106 | (iter:for (values g hom) := (group-from-orbit group o)) 107 | (iter:collect g :into groups) 108 | (iter:collect hom :into homs) 109 | (iter:finally (return (values groups homs))))) 110 | -------------------------------------------------------------------------------- /src/package.lisp: -------------------------------------------------------------------------------- 1 | ;;;; src/package.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2012-2015 Robert Smith 4 | 5 | (defpackage #:cl-permutation 6 | (:use #:cl) 7 | (:nicknames #:perm) 8 | (:local-nicknames 9 | (#:pq #:priority-queue)) 10 | 11 | ;; permutation.lisp 12 | (:export 13 | #:perm-element 14 | #:perm ; Type, Structure 15 | #:enable-perm-reader 16 | #:list-to-perm 17 | #:perm-to-list 18 | #:vector-to-perm 19 | #:perm-to-vector 20 | #:make-perm 21 | #:perm-identity 22 | #:perm-identity-p 23 | #:random-perm 24 | #:perm-ref 25 | #:perm-eval 26 | #:perm-evaluator 27 | #:perm-eval* 28 | #:perm-evaluator* 29 | #:perm-inverse-eval 30 | #:perm-inverse-eval* 31 | #:perm= 32 | #:perm=* 33 | #:perm-size 34 | #:perm-length 35 | #:perm-even-p 36 | #:perm-odd-p 37 | #:perm-sign 38 | #:perm-compose 39 | #:perm-compose-flipped 40 | #:perm-conjugate 41 | #:perm-expt 42 | #:perm-order 43 | #:perm-transpose-indexes 44 | #:perm-transpose-entries 45 | #:perm-inverse 46 | #:perm-point-fixed-p 47 | #:perm-last-non-fixpoint 48 | #:perm-fixpoints 49 | #:permute 50 | #:commutesp 51 | #:perm< 52 | 53 | #:cycle-element 54 | #:cycle 55 | #:make-cycle 56 | #:*canonicalize-cycle-on-creation* 57 | #:cycle-length 58 | #:cycle-identity-p 59 | #:cycle-ref 60 | #:orbit-length 61 | #:orbit-of 62 | #:rotate-cycle 63 | #:canonicalize-cycle 64 | #:canonicalize-cycles 65 | #:to-cycles 66 | #:from-cycles 67 | #:cycle-type 68 | #:cycles-to-one-line 69 | #:find-conjugator 70 | ) 71 | 72 | ;; bruhat.lisp 73 | (:export 74 | #:bruhat<= 75 | #:bruhat< 76 | ) 77 | 78 | ;; permutation-generation.lisp 79 | (:export 80 | #:make-perm-generator 81 | #:doperms 82 | ) 83 | 84 | ;; group.lisp 85 | (:export 86 | #:identity-element ; GENERIC 87 | #:compose ; GENERIC 88 | #:inverse ; GENERIC 89 | #:generators ; GENERIC 90 | #:num-generators ; GENERIC 91 | ) 92 | 93 | ;; free-group.lisp 94 | (:export 95 | #:free-group ; CLASS 96 | #:make-free-group ; FUNCTION 97 | #:make-free-group-element ; FUNCTION 98 | #:free-group-identity-p ; FUNCTION 99 | ) 100 | 101 | ;; straight-line-program.lisp 102 | (:export 103 | #:slp ; TYPE 104 | #:slp-element ; TYPE, CONSTRUCTOR 105 | #:slp-symbol ; TYPE, CONSTRUCTOR 106 | #:slp-composition ; TYPE, CONSTRUCTOR 107 | #:slp-inversion ; TYPE, CONSTRUCTOR 108 | #:slp-context ; CLASS 109 | #:symbol-assignment ; ACCESSOR 110 | #:compose-slp ; FUNCTION 111 | #:invert-slp ; FUNCTION 112 | #:evaluate-slp ; FUNCTION 113 | ) 114 | 115 | ;; permutation-group.lisp 116 | (:export 117 | #:perm-group ; CLASS 118 | #:group-degree ; FUNCTION 119 | #:group-identity ; FUNCTION 120 | #:generate-perm-group ; FUNCTION 121 | #:group-from ; FUNCTION 122 | #:group-from-cycles ; FUNCTION 123 | #:group-order ; FUNCTION 124 | #:group-element-p ; FUNCTION 125 | #:subgroup-p ; FUNCTION 126 | #:same-group-p ; FUNCTION 127 | #:normal-subgroup-p ; FUNCTION 128 | #:random-group-element ; FUNCTION 129 | #:transversal-decomposition ; FUNCTION 130 | #:group-orbits ; FUNCTION 131 | #:orbit-group-homomorphism ; FUNCTION 132 | #:group-from-orbit ; FUNCTION 133 | #:subdirect-factors ; FUNCTION 134 | #:naive-generator-decomposition ; FUNCTION 135 | #:generator-decomposition ; FUNCTION 136 | ) 137 | 138 | ;; homomorphism.lisp 139 | (:export 140 | #:image ; GENERIC, METHOD 141 | #:homomorphism-preimage ; GENERIC, METHOD 142 | #:homomorphism-image ; GENERIC, METHOD 143 | #:generator-homomorphism ; CLASS 144 | #:function-homomorphism ; CLASS 145 | #:homomorphism-induced-perm-group ; FUNCTION 146 | ) 147 | 148 | ;; block.lisp 149 | (:export 150 | #:find-minimal-block-system-containing 151 | ; FUNCTION 152 | #:find-non-trivial-block-system ; FUNCTION 153 | #:block-systems ; FUNCTION 154 | #:primitive-group-p ; FUNCTION 155 | ) 156 | 157 | ;; combinatorial-ranking.lisp 158 | (:export 159 | #:combinatorial-spec ; CLASS 160 | #:size ; READER 161 | #:radix-spec ; CLASS 162 | #:radix ; READER 163 | #:mixed-radix-spec ; CLASS 164 | #:perm-spec ; CLASS 165 | #:combination-spec ; ClASS 166 | #:word-spec ; CLASS 167 | 168 | #:cardinality ; GENERIC, METHOD 169 | 170 | #:make-perm-spec ; FUNCTION 171 | #:make-combination-spec ; FUNCTION 172 | #:make-radix-spec ; FUNCTION 173 | #:vector-to-mixed-radix-spec ; FUNCTION 174 | #:vector-to-word-spec ; FUNCTION 175 | 176 | #:rank ; GENERIC, METHOD 177 | #:unrank ; GENERIC, METHOD 178 | 179 | #:map-spec ; FUNCTION 180 | #:print-objects-of-spec ; FUNCTION 181 | ) 182 | 183 | ;; do-group-elements.lisp 184 | (:export 185 | #:group-element-rank-functions ; FUNCTION 186 | #:do-group-elements ; FUNCTION 187 | ) 188 | ) 189 | -------------------------------------------------------------------------------- /src/utilities.lisp: -------------------------------------------------------------------------------- 1 | ;;;; utilities.lisp 2 | ;;;; Copyright (c) 2011-2014 Robert Smith 3 | 4 | ;;;; Various portable utilities used in CL-PERMUTATION. 5 | 6 | (in-package #:cl-permutation) 7 | 8 | (deftype vector-size (&key (down-by 0)) 9 | "Possible sizes of a vector." 10 | (check-type down-by (integer 0 #.array-total-size-limit)) 11 | `(integer 0 ,(- array-total-size-limit down-by))) 12 | 13 | (deftype vector-index () 14 | "Possible indexes to a vector." 15 | `(integer 0 #.(1- array-total-size-limit))) 16 | 17 | (defun iota (n) 18 | "Generate a list of numbers between 0 and N-1." 19 | (loop :for i :below n :collect i)) 20 | 21 | (declaim (inline iota-vector)) 22 | (defun iota-vector (n &key (element-type t)) 23 | "Generate the equivalent of (COERCE (IOTA N) 'VECTOR)." 24 | (loop :with a := (make-array n :element-type element-type 25 | :initial-element 0) 26 | :for i :below n 27 | :do (setf (aref a i) i) 28 | :finally (return a))) 29 | (declaim (notinline iota-vector)) 30 | 31 | (defun iota+1 (n) 32 | "Generate a list of numbers between 1 and N." 33 | (loop :for i :from 1 :to n :collect i)) 34 | 35 | (defun random-between (a b) 36 | "Generate a random integer between A and B, inclusive." 37 | (assert (>= b a)) 38 | (if (= a b) 39 | a 40 | (+ a (random (- (1+ b) a))))) 41 | 42 | (defun nshuffle (vector &key (parity :any) 43 | (start 0)) 44 | "Shuffle the permutation vector VECTOR with specified parity PARITY. PARITY may be 45 | 46 | * :ANY for any permutation 47 | * :EVEN for only even permutations 48 | * :ODD for only odd permutations 49 | 50 | START specifies the starting index where elements should be shuffled." 51 | 52 | (assert (member parity '(:any :even :odd))) 53 | 54 | (let ((n (length vector)) 55 | (any? (eql parity :any))) 56 | (loop :for i :from start :below (if any? n (1- n)) 57 | :for r := (random-between i (1- n)) 58 | :when (/= i r) 59 | :do (progn 60 | (rotatef (aref vector i) 61 | (aref vector r)) 62 | (unless any? 63 | (rotatef (aref vector (- n 1)) 64 | (aref vector (- n 2))))) 65 | :finally (progn 66 | (when (and (eql parity :odd) 67 | (< (1+ start) n)) 68 | (rotatef (aref vector start) 69 | (aref vector (1+ start)))) 70 | (return vector))))) 71 | 72 | (defun maximum (list &key (key 'identity)) 73 | "Compute the maximum of LIST, optionally via the function KEY." 74 | (loop :for x :in list 75 | :maximizing (funcall key x))) 76 | 77 | (defun product (seq &key (key 'identity)) 78 | "Compute the product of the items in SEQ, optionally via the 79 | function KEY." 80 | (reduce '* seq :key key :initial-value 1)) 81 | 82 | (defun sign (x) 83 | "Return the sign of X." 84 | (cond 85 | ((plusp x) 1) 86 | ((zerop x) 0) 87 | (t -1))) 88 | 89 | (defun random-element (seq) 90 | "Select a random element from the sequence SEQ." 91 | (elt seq (random (length seq)))) 92 | 93 | (defun singletonp (x) 94 | "Does X contain one element?" 95 | (typecase x 96 | (sequence (= 1 (length x))) 97 | (t nil))) 98 | 99 | (defun list-minimum (list) 100 | "Find the minimum element of the list via CL:MIN." 101 | (if (endp list) 102 | (error "Can't find minimum of empty list.") 103 | (reduce #'min list))) 104 | 105 | ;;; Queue Implementation 106 | ;;; from tarballs_are_good/lisp-random/stack-queue.lisp 107 | 108 | (defstruct (queue (:constructor %make-queue) 109 | (:predicate queuep)) 110 | (elements nil :type list) 111 | (last nil :type (or null (cons t null)))) 112 | 113 | (defun make-queue () 114 | "Create a new empty queue." 115 | (%make-queue)) 116 | 117 | (defun queue-empty-p (queue) 118 | "Is the queue QUEUE empty?" 119 | (null (queue-elements queue))) 120 | 121 | (defun list-to-queue (list) 122 | "Convert the list LIST into a queue. Note: LIST may be modified." 123 | (%make-queue :elements list 124 | :last (last list))) 125 | 126 | (defun enqueue (queue obj) 127 | "Add an element OBJ to the end of the queue QUEUE." 128 | (let ((last (list obj))) 129 | (if (queue-empty-p queue) 130 | ;; Set up the queue with the first element. Note that the same 131 | ;; reference to the singleton list is shared by both 132 | ;; QUEUE-ELEMENTS and QUEUE-LAST. 133 | (setf (queue-elements queue) last 134 | (queue-last queue) last) 135 | 136 | ;; We can now append elements to QUEUE-ELEMENTS simply by 137 | ;; modifying QUEUE-LAST, whose reference is shared by 138 | ;; QUEUE-ELEMENTS, 139 | ;; 140 | ;; We do this instead of a single SETF for type safety of 141 | ;; QUEUE-LAST. 142 | (let ((old (queue-last queue))) 143 | (setf (queue-last queue) last 144 | (cdr old) last)))) 145 | queue) 146 | 147 | (defun dequeue (queue) 148 | "Remove and return an element from the queue QUEUE." 149 | (pop (queue-elements queue))) 150 | 151 | ;;; Membership Sets 152 | 153 | (defun make-membership-set (size) 154 | ;; 1+ to account for 1-based indexing 155 | (make-array (1+ size) :element-type 'bit :initial-element 0)) 156 | 157 | (defun membership-sets-intersect-p (set-a set-b) 158 | (some (lambda (a b) (= 1 a b)) set-a set-b)) 159 | 160 | (defun membership-set-nunion (set-a set-b) 161 | (map-into set-a #'logior set-a set-b)) 162 | 163 | (defun membership-set-count (set) 164 | (count 1 set)) 165 | 166 | (defun clear-membership-set (set) 167 | (map-into set (constantly 0))) 168 | 169 | ;;; Partitioning 170 | 171 | ;;; Taken from Quickutil: http://quickutil.org/list?q=partition%2Dif 172 | (defun partition-if (f seq) 173 | "Given a predicate F, partition SEQ into two sublists, the first 174 | of which has elements that satisfy F, the second which do not." 175 | (let ((yes nil) 176 | (no nil)) 177 | (map nil 178 | #'(lambda (x) 179 | (if (funcall f x) 180 | (push x yes) 181 | (push x no))) 182 | seq) 183 | (values yes no))) 184 | -------------------------------------------------------------------------------- /tests/permutation-group.lisp: -------------------------------------------------------------------------------- 1 | ;;;; tests/permutation-group.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2015-2018 Robert Smith 4 | 5 | (in-package #:cl-permutation-tests) 6 | 7 | (deftest test-random-group-element-randomly () 8 | "Test the generation of random group elements actually produces elements of the group." 9 | (loop :repeat 10 10 | :do (is (group-element-p (random-group-element *3x3*) *3x3*)))) 11 | 12 | (deftest test-group-orders () 13 | "Test that the group order is being computed correctly for a few known examples." 14 | (is (= 120 (group-order (make-s5)))) 15 | (is (= 3674160 (group-order *2x2*))) 16 | (is (= 43252003274489856000 (group-order *3x3*))) 17 | (is (= 100669616553523347122516032313645505168688116411019768627200000000000 18 | (group-order *mm*)))) 19 | 20 | (deftest test-subgroup-test () 21 | "Test that SUBGROUP-P works." 22 | (let ((G (group-from-cycles (list 23 | (list (make-cycle 1 2)) 24 | (list (make-cycle 2 3))) 25 | 4)) 26 | (H (group-from-cycles (list 27 | (list (make-cycle 1 3))) 28 | 4)) 29 | (J (group-from-cycles (list 30 | (list (make-cycle 1 4))) 31 | 4))) 32 | (is (subgroup-p G H)) 33 | (is (not (subgroup-p G J))))) 34 | 35 | (deftest test-normal-subgroup-test () 36 | "Test that NORMAL-SUBGROUP-P works." 37 | (destructuring-bind (F R U B L D) (generators *3x3*) 38 | ;; trivial normal subgroups 39 | (is (normal-subgroup-p *3x3* *3x3*)) 40 | (is (normal-subgroup-p *3x3* (generate-perm-group (list (group-identity *3x3*))))) 41 | ;; other tests 42 | ;; 43 | ;; TODO: FIXME 44 | #+fails 45 | (is (normal-subgroup-p *3x3* (generate-perm-group (list (perm-expt F 2) R U (perm-expt B 2) L D)))) 46 | (is (not (normal-subgroup-p *3x3* (generate-perm-group (list F))))))) 47 | 48 | (deftest test-transversal-decomposition (group p) 49 | "Test that the transversal decomposition of the perm P can reconstruct the perm." 50 | (is (perm=* 51 | p 52 | (reduce #'perm-compose 53 | (transversal-decomposition p group :remove-identities t) 54 | :initial-value (group-identity group) 55 | :key (lambda (kj) 56 | (perm::sigma 57 | (perm::perm-group.transversal-system group) 58 | (car kj) 59 | (cdr kj))))))) 60 | 61 | (deftest test-transversal-decomposition-randomly () 62 | "Randomly test transversal decompositions." 63 | (loop :repeat 10 :do 64 | (test-transversal-decomposition *2x2* (random-group-element *2x2*)) 65 | (test-transversal-decomposition *3x3* (random-group-element *3x3*)))) 66 | 67 | (defun parse-sigma-symbol (s) 68 | "Given a sigma symbol like |SIGMA_(k,j)|, return two values, K and J. Error it's invalid." 69 | (let ((name (symbol-name s))) 70 | (when (null (search "SIGMA" name :test 'char=)) 71 | (error "Invalid sigma symbol ~S" s)) 72 | (values (parse-integer name 73 | :start (1+ (position #\( name)) 74 | :end (position #\, name)) 75 | (parse-integer name 76 | :start (1+ (position #\, name)) 77 | :end (position #\) name))))) 78 | 79 | (deftest test-sigma-slps (group) 80 | "Test that the sigma SLPs match the transversal system" 81 | (loop :with free-group := (perm::perm-group.free-group group) 82 | :with hom := (perm::free-group->perm-group-homomorphism 83 | free-group 84 | group) 85 | :with wrong := 0 86 | :with ctx := (perm::perm-group.slp-context group) 87 | :for count :from 0 88 | :for slp :being :the :hash-values :of (perm::symbol-table ctx) 89 | :using (hash-key sym) 90 | :when (keywordp sym) :do 91 | (multiple-value-bind (k j) 92 | (parse-sigma-symbol sym) 93 | (let ((found (perm::sigma (perm::perm-group.transversal-system group) k j)) 94 | (val (funcall hom (evaluate-slp free-group ctx slp)))) 95 | (unless (perm=* val found) 96 | (incf wrong)))) 97 | :finally (is (zerop wrong) "There were ~D wrong sigma SLPs." wrong))) 98 | 99 | (deftest test-sigma-slps-for-rubik () 100 | "Test that the sigma SLPs are sensible for the 2x2x2 and 3x3x3 Rubik's cubes." 101 | (test-sigma-slps (make-S5)) 102 | (test-sigma-slps *2x2*) 103 | #+#:skip-test 104 | (test-sigma-slps *3x3*)) 105 | 106 | (deftest test-naive-generator-decomposition (group p) 107 | "Check that the perm P decomposes into generators within the perm group GROUP which reconstruct the perm. (Naive method.)" 108 | (let ((gens (naive-generator-decomposition p group :return-original-generators t))) 109 | (is (perm= p 110 | (reduce #'perm-compose 111 | gens 112 | :initial-value (group-identity group)))))) 113 | 114 | (deftest test-naive-generator-decomposition-randomly () 115 | "Check veracity of generator decomposition of random elements of the 2x2 cube group. (Naive method.)" 116 | (loop :repeat 100 :do 117 | (test-naive-generator-decomposition *2x2* (random-group-element *2x2*)))) 118 | 119 | (deftest test-factorization-using-free-group (group p) 120 | "Test that P correctly factorizes as free group generators." 121 | (let* ((f (generator-decomposition p group :return-original-generators nil)) 122 | (ϕ (perm::free-group->perm-group-homomorphism 123 | (perm::perm-group.free-group group) group))) 124 | (is (perm= p (funcall ϕ f))))) 125 | 126 | (deftest test-generator-decomposition (group p) 127 | "Check that the perm P decomposes into generators within the perm group GROUP which reconstruct the perm." 128 | (let ((gens (generator-decomposition p group :return-original-generators t))) 129 | (is (perm= p 130 | (reduce #'perm-compose 131 | gens 132 | :initial-value (group-identity group)))))) 133 | 134 | (deftest test-generator-decomposition-randomly () 135 | "Check veracity of generator decomposition of random elements of the 2x2 cube group." 136 | (loop :repeat 10 137 | :for r := (random-group-element *2x2*) 138 | :do (test-generator-decomposition *2x2* r) 139 | (test-factorization-using-free-group *2x2* r))) 140 | 141 | 142 | -------------------------------------------------------------------------------- /src/block-subsystem-solver.lisp: -------------------------------------------------------------------------------- 1 | ;;;; block-subsystem-solver.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2015-2023 Robert Smith 4 | 5 | (in-package #:cl-permutation) 6 | 7 | ;;;; This file implements a "solver" using block subsystems as 8 | ;;;; heuristics. 9 | 10 | (defun verbose () 11 | (let ((last-time nil)) 12 | (lambda (control &rest args) 13 | (let* ((current-time (get-internal-real-time)) 14 | (elapsed-time-ms (if (null last-time) 15 | 0 16 | (round (* 1000 (- current-time last-time)) 17 | internal-time-units-per-second)))) 18 | (format t "[~6D ms] " elapsed-time-ms) 19 | (apply #'format t control args) 20 | (terpri) 21 | (finish-output) 22 | (setf last-time (get-internal-real-time)) 23 | nil)))) 24 | 25 | (defun subsystem-solver (group &key (verbose (verbose))) 26 | (let (subsystems xforms tables (num-gens (length (generators group)))) 27 | (when verbose (funcall verbose "Computing subsystems")) 28 | (setf subsystems (group-block-subsystems group)) 29 | 30 | (when verbose (funcall verbose "Computing coordinate transforms")) 31 | (setf xforms (loop :for subsys :in subsystems 32 | :append (multiple-value-list (make-subsystem-transformations subsys)))) 33 | (setf xforms (remove-if (lambda (x) (= 1 (coord.order x))) xforms)) 34 | 35 | (when verbose (funcall verbose "Computing ~D God tables" (length xforms))) 36 | (loop :for i :from 1 37 | :for xform :in xforms 38 | :for order := (coord.order xform) 39 | :do 40 | (when (and verbose (> order 10000000)) 41 | (unless (y-or-n-p "Attempting to compute table over ~ 42 | 10M (~D exactly). Continue?" 43 | order) 44 | (return-from subsystem-solver nil))) 45 | (when verbose (funcall verbose "Computing ~:R God table of size ~D" i order)) 46 | (push (compute-god-table group :rank-cardinality order :rank-element (coord.rank xform)) tables) 47 | (when verbose (funcall verbose "Done!"))) 48 | (setf tables (reverse tables)) 49 | 50 | (when verbose (funcall verbose "Computing IDDFS closure")) 51 | 52 | (labels ((coord (g) 53 | (loop :with c := (make-array (length tables) :element-type 'fixnum :initial-element 0) 54 | :for i :from 0 55 | :for xform :in xforms 56 | :do (setf (aref c i) (funcall (coord.rank xform) g)) 57 | :finally (return c))) 58 | (transition-coord (coord gen-idx) 59 | (map 'simple-vector 60 | (lambda (c tbl) 61 | (aref (god-table-entry-transition 62 | (aref (god-table-vector tbl) c)) 63 | gen-idx)) 64 | coord 65 | tables)) 66 | (dfs (coord depth moves) 67 | (cond 68 | ;; Solved. 69 | ((every #'zerop coord) 70 | (values t moves)) 71 | ;; The solution must be of at least the depths specified by each 72 | ;; pruning table. 73 | ((or (zerop depth) 74 | (loop :for tbl :in tables 75 | :for idx :from 0 76 | :for c :across coord 77 | :for entry := (aref (god-table-vector tbl) c) 78 | :do (when (null entry) 79 | (error "Couldn't compute depth for coord[~d]=~d. ~ 80 | Coord xform is ~S" 81 | idx 82 | c 83 | (nth idx xforms))) 84 | :thereis (< depth (god-table-entry-depth entry)))) 85 | (values nil nil)) 86 | ;; Descend. We use transition tables here to actually 87 | ;; compute the map. 88 | (t 89 | (dotimes (i num-gens nil) 90 | (let ((next-coord (transition-coord coord i))) 91 | ;; coordᵢ ← (aref transᵢ coordᵢ mv) 92 | (multiple-value-bind (found? solution) 93 | (dfs next-coord (1- depth) (cons i moves)) 94 | (when found? 95 | (return-from dfs (values t solution)))))))))) 96 | (lambda (g) 97 | (block nil 98 | (format t "Searching: ") 99 | (loop :with coord := (coord g) 100 | :for depth :from 0 101 | :do (multiple-value-bind (found? solution) 102 | (dfs coord depth nil) 103 | (cond 104 | (found? (format t "*") (return (reverse solution))) 105 | (t (format t "~D-" depth) (finish-output)))))))))) 106 | 107 | (defun solve-and-verify (group solver element &key (move-printer #'princ)) 108 | (format t "~&Position: ~A~%" element) 109 | (let* ((start-time (get-internal-real-time)) 110 | (solution (funcall solver element))) 111 | (format t "~&Solution found in ~D ms!~%" 112 | (round (* 1000 (- (get-internal-real-time) start-time)) 113 | internal-time-units-per-second)) 114 | (let ((*print-pretty* nil)) 115 | (format t "Solution (apply left-to-right): ") 116 | (dolist (mv solution) 117 | (funcall move-printer mv) 118 | (write-char #\Space)) 119 | (terpri)) 120 | (let ((solution*element (reduce #'perm-compose (reverse solution) 121 | :initial-value element 122 | :key (lambda (n) (nth n (generators group)))))) 123 | 124 | 125 | (format t "Verification: ~:[Failed! solution*element=~A~;Success!~]" 126 | (perm-identity-p solution*element) 127 | solution*element) 128 | solution))) 129 | 130 | ;;; Solving second phase of Kociemba: 131 | ;;; 132 | ;;; (defparameter *g2 (perm-examples::make-kociemba-g2)) 133 | ;;; 134 | ;;; (defparameter *solver (subsystem-solver *g2)) 135 | ;;; 136 | ;;; (let ((r (random-group-element *g2)) 137 | ;;; (printer (lambda (i) (format t "~[U~;U2~;U'~;D~;D2~;D'~;R2~;L2~;F2~;B2~]" i)))) 138 | ;;; (solve-and-verify *g2 *solver r :move-printer printer)) 139 | -------------------------------------------------------------------------------- /src/free-group.lisp: -------------------------------------------------------------------------------- 1 | ;;;; free-group.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2015 Robert Smith 4 | 5 | (in-package #:cl-permutation) 6 | 7 | (defclass free-group () 8 | ((num-generators :initarg :num-generators 9 | :reader free-group-num-generators)) 10 | (:documentation "Representation of a free group whose symbols are: 11 | 12 | * identity element: 0 13 | * generators: 1 .. N 14 | * inverse generators: -N .. -1 15 | 16 | Elements of the group are either individual integers or lists thereof. The lists represent compositions of generators. The BNF grammar looks something like: 17 | 18 | := 1 | 2 | ... | N 19 | := 20 | | 0 21 | | - 22 | := 23 | | ( * ) 24 | 25 | An empty list corresponds to an empty composition, which is identity (0).")) 26 | 27 | (defun make-free-group (num-generators) 28 | "Make a free group that contains NUM-GENERATORS generators." 29 | (check-type num-generators (integer 0)) 30 | (make-instance 'free-group :num-generators num-generators)) 31 | 32 | (defun free-group-element-valid-p (g element) 33 | "Given the free group G and some purported element ELEMENT, return a boolean indicating whether it is a valid element of G." 34 | (check-type g free-group) 35 | (let ((num-generators (free-group-num-generators g))) 36 | (typecase element 37 | (integer (<= (- num-generators) element num-generators)) 38 | (list (every (lambda (e) 39 | (free-group-element-valid-p g e)) 40 | element)) 41 | (t nil)))) 42 | 43 | (defun make-free-group-element (g &rest elements) 44 | "Make an element of the free group G where ELEMENTS are either integer generators of G, or other elements created by this function." 45 | (declare (dynamic-extent elements)) 46 | (check-type g free-group) 47 | (let ((word nil)) 48 | (dolist (el elements (nreverse word)) 49 | (assert (free-group-element-valid-p g el)) 50 | (etypecase el 51 | (integer 52 | (unless (zerop el) 53 | (push el word))) 54 | (list (dolist (x el) 55 | (unless (zerop x) 56 | (push x word)))))))) 57 | 58 | (defun free-group-identity-p (x) 59 | "Is X an identity element of a free group?" 60 | (cond 61 | ((integerp x) (zerop x)) 62 | ((listp x) (every #'zerop x)) 63 | (t nil))) 64 | 65 | (defmethod identity-element ((g free-group)) 66 | nil) 67 | 68 | (defmethod compose ((g free-group) (a null) b) b) 69 | (defmethod compose ((g free-group) (a (eql 0)) b) b) 70 | (defmethod compose ((g free-group) a (b null)) a) 71 | (defmethod compose ((g free-group) a (b (eql 0))) a) 72 | 73 | (defmethod compose ((g free-group) a b) 74 | (assert (free-group-element-valid-p g a) 75 | (a) 76 | "The value A is not a valid element of the provided free group.") 77 | (assert (free-group-element-valid-p g b) 78 | (b) 79 | "The value A is not a valid element of the provided free group.") 80 | (make-free-group-element g a b)) 81 | 82 | (defmethod inverse ((g free-group) a) 83 | (etypecase a 84 | ;; a^-1 = -a 85 | (integer (- a)) 86 | ;; (a b c)^-1 = (c^-1 b^-1 a^-1) 87 | (list 88 | (let ((word nil)) 89 | (dolist (x a word) 90 | (unless (zerop x) 91 | (push (- x) word))))))) 92 | 93 | (defmethod generators ((G free-group)) 94 | (loop :for i :from 1 :to (num-generators G) 95 | :collect i)) 96 | 97 | (defmethod num-generators ((G free-group)) 98 | (free-group-num-generators G)) 99 | 100 | ;;; Word generation & simplification 101 | 102 | (deftype word () 103 | '(or fixnum list)) 104 | 105 | (declaim (ftype (function (t) (and fixnum unsigned-byte)) word-length)) 106 | (defun word-length (w) 107 | "What is the length of the word W?" 108 | (etypecase w 109 | (fixnum 1) 110 | (list (max 1 (length w))))) 111 | 112 | (defun word-generator (group) 113 | "Return a lambda function taking a non-negative integer N and returning the Nth word in a sequence which enumerates all words of the free group GROUP." 114 | (check-type group free-group) 115 | (%word-generator (free-group-num-generators group))) 116 | 117 | (defun %word-generator (num-generators) 118 | "Return a lambda function taking a non-negative integer N and returning the Nth word in a sequence which enumerates all words of NUM-GENERATORS generators." 119 | (let* ((b/2 num-generators) 120 | (b (* 2 b/2))) 121 | (labels ((process (x) 122 | (if (<= x b/2) 123 | x 124 | (- b/2 x))) 125 | (words-in-level (l) 126 | (expt b l)) 127 | (words-below-level (l) 128 | (loop :for i :below l :sum (words-in-level i))) 129 | (find-level (n) 130 | (if (zerop n) 131 | 0 132 | (loop :for l :from 0 133 | :when (<= (words-below-level l) 134 | n 135 | (1- (words-below-level (1+ l)))) 136 | :do (return l)))) 137 | (generate (n l) 138 | (let ((n (- n (words-below-level l)))) 139 | (loop :repeat l 140 | :collect (multiple-value-bind (quo rem) (floor n b) 141 | (setf n quo) 142 | (process (1+ rem))))))) 143 | (lambda (n) 144 | (generate n (find-level n)))))) 145 | 146 | (defun random-word-generator (n) 147 | (lambda (length) 148 | (loop :repeat (1+ (random length)) 149 | :for sign := (expt -1 (random 2)) 150 | :collect (* sign (1+ (random n)))))) 151 | 152 | (defun word-simplifier (orders commuting) 153 | "Let: 154 | 155 | ORDERS: A vector of orders of each generator, or NIL if unknown/infinite. 156 | 157 | COMMUTING: a vector of length N+1 where the Jth element is a list of all commuting generators of J 158 | 159 | Then return a unary function which takes elements of G and returns simplified versions of them." 160 | (check-type orders vector) 161 | (check-type commuting vector) 162 | (assert (= (length orders) (length commuting))) 163 | (assert (plusp (length orders))) 164 | (assert (null (aref orders 0))) 165 | (assert (null (aref commuting 0))) 166 | (lambda (w) 167 | (etypecase w 168 | (integer (if (zerop w) '() w)) 169 | (list 170 | ;; Remove identities from W and make a copy. 171 | (let ((w (loop :for x :in w :unless (zerop x) :collect x))) 172 | (cond 173 | ;; Identity or singleton: return it. 174 | ((or (endp w) (endp (rest w))) w) 175 | ;; Arbitrary word. 176 | (t 177 | ;; Get rid of identities. 178 | (let ((simplified-word nil)) 179 | (labels ((simplify-power (pt count) 180 | ;; Simplify PT^COUNT for PT > 0. 181 | ;; 182 | ;; Return either: 183 | ;; 184 | ;; - NIL; it simplifies to identity. 185 | ;; 186 | ;; - N; the simplest representation is PT^N for 1 <= N < ORDER. 187 | (let ((order (aref orders pt))) 188 | (if (null order) 189 | (values pt count) 190 | (let ((count (mod count order))) 191 | (if (zerop count) 192 | nil 193 | count))))) 194 | (push-point (point count) 195 | ;; Push the POINT onto SIMPLIFIED-WORD a 196 | ;; total of COUNT times. Take into account 197 | ;; the known order to push inverses if 198 | ;; necessary. 199 | (let ((final (simplify-power point count)) 200 | (order (aref orders point))) 201 | (when final 202 | ;; Having a FINAL implies an ORDER. 203 | (cond 204 | ((<= final (/ order 2)) 205 | (loop :repeat final :do (push point simplified-word))) 206 | (t 207 | (loop :repeat (- order final) :do (push (- point) simplified-word))))))) 208 | (sift-commuting (point w) 209 | ;; Sift through the commuting elements at the 210 | ;; head of W to POINT. Return two values: 211 | ;; 212 | ;; 1. The number of POINT's found (i.e., 213 | ;; POINT^N) through the commuting 214 | ;; elements. Note that N can be negative. 215 | ;; 216 | ;; 2. The remaining W with the commuting 217 | ;; elements at the head. 218 | (let* ((count (if (plusp point) 1 -1)) 219 | (point (abs point)) 220 | (comms (aref commuting point)) 221 | (commuters-found nil)) 222 | (loop :for wi :on w 223 | :for r := (abs (car wi)) 224 | :while (or (= r point) 225 | (find r comms)) 226 | :do (cond 227 | ;; We ran into an identical-ish point. 228 | ((= r point) 229 | (cond 230 | ((plusp (car wi)) (incf count)) 231 | ((minusp (car wi)) (decf count)))) 232 | ;; We ran into a commuter. 233 | (t 234 | (push (car wi) commuters-found))) 235 | :finally (return (values point count (nreconc commuters-found wi)))))) 236 | (simp (w) 237 | ;; W is guaranteed to have no identities. 238 | (cond 239 | ;; Reached the end of the word. Return our answer. 240 | ((endp w) 241 | (nreverse simplified-word)) 242 | ;; Sift through commuting elements and do a 243 | ;; run-length-encoding sort of thing. 244 | (t 245 | (multiple-value-bind (point count w-remaining) 246 | (sift-commuting (first w) (rest w)) 247 | (push-point point count) 248 | (simp w-remaining)))))) 249 | ;; Remove identities, and simplify. 250 | (simp w)))))))))) 251 | -------------------------------------------------------------------------------- /src/combinatorial-ranking.lisp: -------------------------------------------------------------------------------- 1 | ;;;; combinatorial-ranking.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2011-2015 Robert Smith 4 | 5 | (in-package #:cl-permutation) 6 | 7 | ;;; This code was originally written in Fortran 95 (in 2008), and was 8 | ;;; subsequently converted into Lisp as a part of the QSolve project 9 | ;;; (https://bitbucket.org/tarballs_are_good/qsolve). It has been 10 | ;;; merged into CL-PERMUTATION due to its mathematical generality. Its 11 | ;;; main structure remains the same, except CLOS is used instead of 12 | ;;; structures. 13 | 14 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Utilities ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 15 | 16 | (defun binomial-coefficient-or-zero (n k) 17 | "If N < K, return 0, otherwise return the binomial coefficient." 18 | (if (< n k) 19 | 0 20 | (alexandria:binomial-coefficient n k))) 21 | 22 | (defun zero-array (length) 23 | "Make an array of zeroes of length LENGTH." 24 | (make-array length :element-type 'unsigned-byte 25 | :initial-element 0)) 26 | 27 | 28 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Structures ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 29 | 30 | (defclass combinatorial-spec () 31 | ((cardinality-cache :initform nil 32 | :accessor cardinality-cache 33 | :type (or null unsigned-byte)) 34 | (size :initarg :size 35 | :reader size)) 36 | (:documentation "Abstract class representing linear sequences of objects of size SIZE.")) 37 | 38 | (defclass radix-spec (combinatorial-spec) 39 | ((radix :initarg :radix 40 | :reader radix)) 41 | (:documentation "Representation of a sequence of numbers of length SIZE whose elements are between 0 and RADIX - 1.")) 42 | 43 | (defclass mixed-radix-spec (combinatorial-spec) 44 | ((radix :initarg :radix 45 | :reader radix)) 46 | (:documentation "Representation of a mixed-radix number of size SIZE with mixed radix RADIX.")) 47 | 48 | (defclass perm-spec (combinatorial-spec) 49 | () 50 | (:documentation "Representation of a perm of size SIZE. Canonically this is a permutation of the set {1, ..., SIZE}. (Though it's possible to rank the permutation of any subset of numbers.)")) 51 | 52 | (defclass combination-spec (combinatorial-spec) 53 | ((zero-count :initarg :zero-count 54 | :reader comb.zero-count)) 55 | (:documentation "Representation of a sequence ")) 56 | 57 | (defclass word-spec (combinatorial-spec) 58 | ((types :initarg :types 59 | :reader word.types 60 | :documentation "Non-negative integer representing the number of distinct elements within the word. Note that this will include the additional zero type, even though there are never any zero elements.") 61 | (type-counts :initarg :type-counts 62 | :reader word.type-counts 63 | :documentation "Vector of non-negative integers representing the count of each individual element type. (The sum of this vector should equal TYPES.)")) 64 | (:documentation "Representation of a word of elements 1 to TYPES.")) 65 | 66 | 67 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Cardinality ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 68 | 69 | (defgeneric cardinality (spec) 70 | (:documentation "Compute the cardinality of SPEC. This represents the total number of elements described by the spec.")) 71 | 72 | ;;; Cache the computed cardinality. These objects are intended to be 73 | ;;; immutable at the API boundary. 74 | (defmethod cardinality :around ((spec combinatorial-spec)) 75 | (or (cardinality-cache spec) 76 | (setf (cardinality-cache spec) 77 | (call-next-method)))) 78 | 79 | (defmethod cardinality ((spec radix-spec)) 80 | ;; RADIX^SIZE 81 | (expt (radix spec) (size spec))) 82 | 83 | (defmethod cardinality ((spec mixed-radix-spec)) 84 | ;; RADIX1 * RADIX2 * ... * RADIXn 85 | (reduce (lambda (a b) (* a b)) 86 | (radix spec) 87 | :initial-value 1)) 88 | 89 | (defmethod cardinality ((spec perm-spec)) 90 | ;; (SIZE)! 91 | (alexandria:factorial (size spec))) 92 | 93 | (defmethod cardinality ((spec combination-spec)) 94 | ;; C(SIZE, ZEROES) 95 | (alexandria:binomial-coefficient (size spec) (comb.zero-count spec))) 96 | 97 | (defmethod cardinality ((spec word-spec)) 98 | ;; (SIZE)! 99 | ;; -------------------------- 100 | ;; (C_1)! (C_2)! ... (C_N)! 101 | (reduce (lambda (p type-count) 102 | ;; This will always divide evenly. 103 | (floor p (alexandria:factorial type-count))) 104 | (word.type-counts spec) 105 | :initial-value (alexandria:factorial (size spec)))) 106 | 107 | 108 | ;;;;;;;;;;;;;;;;;;;;;;;;;;; Initialization ;;;;;;;;;;;;;;;;;;;;;;;;;;; 109 | 110 | (defun array-for-spec (spec &key (initial-element 0)) 111 | (make-array (size spec) :initial-element initial-element)) 112 | 113 | (defun make-perm-spec (n) 114 | "Make a PERM-SPEC representing the set of permutations S_n." 115 | (check-type n unsigned-byte) 116 | (make-instance 'perm-spec :size n)) 117 | 118 | (defun make-combination-spec (n m) 119 | "Make a COMBINATION-SPEC representing the space of objects representing M items being chosen out of N total." 120 | (check-type n unsigned-byte) 121 | (check-type m unsigned-byte) 122 | (assert (<= m n) (m n) "M must be less than N.") 123 | (make-instance 'combination-spec :size n :zero-count m)) 124 | 125 | (defun make-radix-spec (radix size) 126 | "Make a RADIX-SPEC representing all numbers between 0 and RADIX^SIZE - 1." 127 | (check-type radix (integer 2)) 128 | (check-type size unsigned-byte) 129 | (make-instance 'radix-spec :size size :radix radix)) 130 | 131 | (defun vector-to-mixed-radix-spec (radix) 132 | "Make a MIXED-RADIX-SPEC representing all mixed-radix numbers specified by the vector RADIX." 133 | (check-type radix vector) 134 | (assert (every (alexandria:conjoin #'integerp #'plusp) radix) 135 | (radix) 136 | "The radix must be a vector of positive integers.") 137 | (make-instance 'mixed-radix-spec :radix radix 138 | :size (length radix))) 139 | 140 | (defun vector-to-word-spec (word) 141 | "WORD should be a vector containing 1, 2, ..., N, possibly with repeated elements." 142 | (let* ((size (length word)) 143 | (sorted (sort (copy-seq word) #'<)) 144 | ;; We have a type for '0', even though its count should be 0, 145 | ;; hence the "1+". 146 | (types (1+ (aref sorted (1- size)))) 147 | (type-counts (zero-array types))) 148 | 149 | (loop :for x :across sorted 150 | :do (incf (aref type-counts x))) 151 | 152 | (make-instance 'word-spec :size size 153 | :types types 154 | :type-counts type-counts))) 155 | 156 | 157 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Ranking ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 158 | 159 | (defgeneric rank (spec set) 160 | (:documentation "Rank the set SET to an integer according to the spec SPEC.")) 161 | 162 | (defmethod rank ((spec radix-spec) set) 163 | (let ((radix (radix spec))) 164 | ;; Horner's method. 165 | (reduce (lambda (next sum) 166 | (+ next (* sum radix))) 167 | set 168 | :initial-value 0 169 | :from-end t))) 170 | 171 | (defmethod rank ((spec mixed-radix-spec) set) 172 | (let ((radix (radix spec)) 173 | (i (size spec))) 174 | ;; Horner's method, generalized for mixed radix numerals. 175 | (reduce (lambda (next sum) 176 | (+ next (* sum (aref radix (decf i))))) 177 | set 178 | :initial-value 0 179 | :from-end t))) 180 | 181 | (defmethod rank ((spec perm-spec) set) 182 | (loop :with size := (size spec) 183 | :with rank := 0 184 | :for i :from 0 :below (1- size) 185 | :for elt :across set 186 | :do (let ((inversions (count-if (lambda (elt-after) 187 | (> elt elt-after)) 188 | set 189 | :start (1+ i)))) 190 | (setf rank (+ inversions (* rank (- size i))))) 191 | :finally (return rank))) 192 | 193 | (defmethod rank ((spec combination-spec) set) 194 | (loop :with z := (comb.zero-count spec) 195 | :with rank := 0 196 | :for i :from (1- (size spec)) :downto 0 197 | :when (zerop (aref set i)) 198 | :do (progn 199 | (incf rank (binomial-coefficient-or-zero i z)) 200 | (decf z)) 201 | :finally (return rank))) 202 | 203 | (defmethod rank ((spec word-spec) set) 204 | (let ((size (size spec)) 205 | (current-cardinality (cardinality spec)) 206 | (unprocessed-type-counts (copy-seq (word.type-counts spec))) 207 | (rank 0)) 208 | (loop :for current-position :below (1- size) 209 | :while (< 1 current-cardinality) 210 | :do (let ((current-offset 0) 211 | (current-type (aref set current-position)) 212 | (length-remaining (- size current-position))) 213 | 214 | ;; Compute the offset 215 | ;; 216 | ;; XXX: This can be maintained in an auxiliary data 217 | ;; structure and updated incrementally. 218 | (dotimes (i current-type) 219 | (incf current-offset (aref unprocessed-type-counts i))) 220 | 221 | ;; Update the rank 222 | (incf rank (floor (* current-cardinality current-offset) 223 | length-remaining)) 224 | 225 | ;; This is guaranteeed to decrease in size, because 226 | ;; the count of the current type <= LENGTH-REMAINING. 227 | (setf current-cardinality 228 | (floor (* current-cardinality 229 | (aref unprocessed-type-counts current-type)) 230 | length-remaining)) 231 | 232 | ;; Account for the type which we've processed. 233 | (decf (aref unprocessed-type-counts current-type)))) 234 | 235 | ;; Return the rank 236 | rank)) 237 | 238 | 239 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Unranking ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 240 | 241 | (defgeneric unrank (spec idx &key set) 242 | (:documentation "Unrank the integer rank IDX according to SPEC. If SET is provided, such a vector will be filled. Otherwise, one will be allocated. (Beware: SET must be a vector of an appropriate size.)")) 243 | 244 | (defmethod unrank ((spec radix-spec) (idx integer) &key set) 245 | (let ((radix (radix spec)) 246 | (set (or set (array-for-spec spec)))) 247 | (dotimes (i (size spec) set) 248 | (multiple-value-bind (quo rem) (floor idx radix) 249 | (setf (aref set i) rem 250 | idx quo))))) 251 | 252 | (defmethod unrank ((spec mixed-radix-spec) (idx integer) &key set) 253 | (let ((radix (radix spec)) 254 | (set (or set (array-for-spec spec)))) 255 | (dotimes (i (size spec) set) 256 | (multiple-value-bind (quo rem) (floor idx (svref radix i)) 257 | (setf (aref set i) rem 258 | idx quo))))) 259 | 260 | (defmethod unrank ((spec perm-spec) (idx integer) &key set) 261 | (let ((size (size spec)) 262 | (set (if (null set) 263 | (array-for-spec spec) 264 | (map-into set (constantly 0))))) 265 | (loop 266 | :for i :from (- size 2) :downto 0 267 | :do (progn 268 | (setf (aref set i) (mod idx (- size i))) 269 | (setf idx (floor idx (- size i))) 270 | (loop :for j :from (1+ i) :to (1- (size spec)) 271 | :when (>= (aref set j) 272 | (aref set i)) 273 | :do (incf (aref set j)))) 274 | :finally (return set)))) 275 | 276 | (defmethod unrank ((spec combination-spec) (idx integer) &key set) 277 | (let ((z (comb.zero-count spec)) 278 | (set (if (null set) 279 | (array-for-spec spec :initial-element 1) 280 | (map-into set (constantly 1))))) 281 | (loop :for i :from (1- (size spec)) :downto 0 282 | :do (let ((tmp (binomial-coefficient-or-zero i z))) 283 | (when (>= idx tmp) 284 | (decf idx tmp) 285 | (setf (aref set i) 0) 286 | (decf z))) 287 | :finally (return set)))) 288 | 289 | (defmethod unrank ((spec word-spec) (idx integer) &key set) 290 | (let* ((set (or set (array-for-spec spec))) 291 | (size (size spec)) 292 | (unprocessed-type-counts (copy-seq (word.type-counts spec))) 293 | (current-cardinality (cardinality spec))) 294 | (dotimes (current-position size set) 295 | (let ((length-remaining (- size current-position)) 296 | (current-offset 0) 297 | (current-type 0)) 298 | ;; Compute the next type, as well as the offset to adjust the 299 | ;; index. 300 | (loop 301 | ;; SELECTOR could be a standard division, resulting in a 302 | ;; rational number. However, since we are using it to 303 | ;; check an inequality (namely >=), we can floor it to 304 | ;; keep in the domain of integers. 305 | :with selector := (floor (* idx length-remaining) current-cardinality) 306 | :while (>= selector (+ current-offset 307 | (aref unprocessed-type-counts current-type))) 308 | :do (incf current-offset (aref unprocessed-type-counts current-type)) 309 | (incf current-type)) 310 | 311 | ;; This will divide evenly. 312 | (decf idx (/ (* current-cardinality current-offset) length-remaining)) 313 | 314 | (assert (integerp idx)) 315 | 316 | ;; This will divide evenly. 317 | (setf current-cardinality 318 | (/ (* current-cardinality (aref unprocessed-type-counts current-type)) 319 | length-remaining)) 320 | 321 | (assert (integerp current-cardinality)) 322 | 323 | (decf (aref unprocessed-type-counts current-type)) 324 | 325 | (setf (aref set current-position) current-type))))) 326 | 327 | 328 | ;;; Enumeration of all sets 329 | ;;; 330 | ;;; This function is mostly for testing purposes. 331 | 332 | (defun map-spec (f spec) 333 | "Call the function F across all elements described by SPEC. 334 | 335 | F should be a binary function whose first argument represents the rank of object passed as the second argument." 336 | (let ((set (array-for-spec spec))) 337 | (dotimes (i (cardinality spec)) 338 | (funcall f i (unrank spec i :set set))))) 339 | 340 | (defun print-objects-of-spec (spec &optional (stream *standard-output*)) 341 | "Given the combinatorial specification SPEC, enumerate all possible objects represented by that specification, printing them to the stream STREAM." 342 | (map-spec (lambda (rank obj) 343 | (let ((calculated-rank (rank spec obj))) 344 | (assert (= rank calculated-rank) nil "Mismatch in ranking/unranking ~A" rank) 345 | (format stream 346 | "~D ==> ~A ==> ~D~%" 347 | rank 348 | obj 349 | calculated-rank))) 350 | spec)) 351 | -------------------------------------------------------------------------------- /examples/rubik-like.lisp: -------------------------------------------------------------------------------- 1 | ;;;; examples/rubik-like.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2014 Robert Smith 4 | 5 | (in-package #:cl-permutation-examples) 6 | 7 | ;;; Order: 3674160 8 | ;; +--+--+ 9 | ;; |5 |6 | 10 | ;; +--+--+ 11 | ;; |7 |8 | 12 | ;; +--+--+--+--+--+--+--+--+ 13 | ;; |19|20|1 |2 |9 |10|13|14| 14 | ;; +--+--+--+--+--+--+--+--+ 15 | ;; |xx|21|3 |4 |11|12|15|xx| 16 | ;; +--+--+--+--+--+--+--+--+ 17 | ;; |16|17| 18 | ;; +--+--+ 19 | ;; |xx|18| 20 | ;; +--+--+ 21 | 22 | (defun make-rubik-2x2 () 23 | (group-from-cycles 24 | (list (list (make-cycle 1 2 4 3) ; F 25 | (make-cycle 7 9 17 21) 26 | (make-cycle 8 11 16 20)) 27 | 28 | (list (make-cycle 9 10 12 11) ; R 29 | (make-cycle 2 6 15 17) 30 | (make-cycle 4 8 13 18)) 31 | 32 | (list (make-cycle 5 6 8 7) ; U 33 | (make-cycle 2 20 14 10) 34 | (make-cycle 1 19 13 9))) 35 | 21)) 36 | 37 | ;; +--------------+ 38 | ;; | | 39 | ;; | 1 2 3 | 40 | ;; | | 41 | ;; | 4 up 5 | 42 | ;; | | 43 | ;; | 6 7 8 | 44 | ;; | | 45 | ;; +--------------+--------------+--------------+--------------+ 46 | ;; | | | | | 47 | ;; | 9 10 11 | 17 18 19 | 25 26 27 | 33 34 35 | 48 | ;; | | | | | 49 | ;; | 12 left 13 | 20 front 21 | 28 right 29 | 36 back 37 | 50 | ;; | | | | | 51 | ;; | 14 15 16 | 22 23 24 | 30 31 32 | 38 39 40 | 52 | ;; | | | | | 53 | ;; +--------------+--------------+--------------+--------------+ 54 | ;; | | 55 | ;; | 41 42 43 | 56 | ;; | | 57 | ;; | 44 down 45 | 58 | ;; | | 59 | ;; | 46 47 48 | 60 | ;; | | 61 | ;; +--------------+ 62 | 63 | ;; 43252003274489856000 64 | (defun make-rubik-3x3 () 65 | (group-from-cycles 66 | (list (list (make-cycle 18 21 23 20) ; F 67 | (make-cycle 17 19 24 22) 68 | (make-cycle 8 30 41 11) 69 | (make-cycle 7 28 42 13) 70 | (make-cycle 6 25 43 16)) 71 | 72 | (list (make-cycle 26 29 31 28) ; R 73 | (make-cycle 25 27 32 30) 74 | (make-cycle 8 33 48 24) 75 | (make-cycle 5 36 45 21) 76 | (make-cycle 3 38 43 19)) 77 | 78 | (list (make-cycle 11 35 27 19) ; U 79 | (make-cycle 10 34 26 18) 80 | (make-cycle 9 33 25 17) 81 | (make-cycle 2 5 7 4) 82 | (make-cycle 1 3 8 6)) 83 | 84 | (list (make-cycle 34 37 39 36) ; B 85 | (make-cycle 33 35 40 38) 86 | (make-cycle 3 9 46 32) 87 | (make-cycle 2 12 47 29) 88 | (make-cycle 1 14 48 27)) 89 | 90 | (list (make-cycle 10 13 15 12) ; L 91 | (make-cycle 9 11 16 14) 92 | (make-cycle 6 22 46 35) 93 | (make-cycle 4 20 44 37) 94 | (make-cycle 1 17 41 40)) 95 | 96 | (list (make-cycle 42 45 47 44) ; D 97 | (make-cycle 41 43 48 46) 98 | (make-cycle 16 24 32 40) 99 | (make-cycle 15 23 31 39) 100 | (make-cycle 14 22 30 38))) 101 | 48)) ; size 102 | 103 | (defun make-kociemba-g2 () 104 | ;; 105 | (flet ((mkperm (&rest cycle-lists) 106 | (from-cycles (mapcar (lambda (x) (apply #'make-cycle x)) cycle-lists) 48))) 107 | (let ((U (mkperm '(11 35 27 19) 108 | '(10 34 26 18) 109 | '(9 33 25 17) 110 | '(2 5 7 4) 111 | '(1 3 8 6))) 112 | (D (mkperm '(42 45 47 44) 113 | '(41 43 48 46) 114 | '(16 24 32 40) 115 | '(15 23 31 39) 116 | '(14 22 30 38))) 117 | (R2 (mkperm '(28 29) '(27 30) '(26 31) '(25 32) 118 | '(24 33) '(21 36) '(19 38) '(8 48) 119 | '(5 45) '(3 43))) 120 | (L2 (mkperm '(22 35) '(20 37) '(17 40) '(12 13) 121 | '(11 14) '(10 15) '(9 16) '(6 46) 122 | '(4 44) '(1 41))) 123 | (F2 (mkperm '(20 21) '(19 22) '(18 23) '(17 24) 124 | '(16 25) '(13 28) '(11 30) '(8 41) 125 | '(7 42) '(6 43))) 126 | (B2 (mkperm '(36 37) '(35 38) '(34 39) '(33 40) 127 | '(14 27) '(12 29) '(9 32) '(3 46) 128 | '(2 47) '(1 48)))) 129 | (generate-perm-group 130 | (list U (perm-expt U 2) (perm-inverse U) 131 | D (perm-expt D 2) (perm-inverse D) 132 | R2 L2 F2 B2))))) 133 | 134 | ;; +--------------+ 135 | ;; | | 136 | ;; | 1 2 3 | 137 | ;; | | 138 | ;; | 4 5 6 | 139 | ;; | | 140 | ;; | 7 8 9 | 141 | ;; | | 142 | ;; +--------------+--------------+--------------+--------------+ 143 | ;; | | | | | 144 | ;; | 19 20 21 | 10 11 12 | 13 14 15 | 16 17 18 | 145 | ;; | | | | | 146 | ;; | ** left ** | ** 22 ** | ** right ** | ** 28 ** | 147 | ;; | | | | | 148 | ;; | ** ** ** | ** 23 ** | ** ** ** | ** 27 ** | 149 | ;; | | | | | 150 | ;; +--------------+--------------+--------------+--------------+ 151 | ;; | | 152 | ;; | ** 24 ** | 153 | ;; | | 154 | ;; | ** 25 ** | 155 | ;; | | 156 | ;; | ** 26 ** | 157 | ;; | | 158 | ;; +--------------+ 159 | 160 | 161 | (defun make-rubik-MU-group () 162 | "Create the group of the 3x3 cube." 163 | (group-from-cycles 164 | (list 165 | ;; U 166 | (list (make-cycle 1 3 9 7) 167 | (make-cycle 2 6 8 4) 168 | (make-cycle 11 20 17 14) 169 | (make-cycle 12 21 18 15) 170 | (make-cycle 10 19 16 13)) 171 | ;; M' 172 | (list (make-cycle 24 11 2 27) 173 | (make-cycle 25 22 5 28) 174 | (make-cycle 26 23 8 17))) 175 | 28)) 176 | 177 | ;;; This doesn't work in the way we might expect, because it 178 | ;;; distingushes between otherwise equivalent positions (e.g., cycling 179 | ;;; centers of the same color). 180 | (defun make-rubik-4x4 () 181 | (group-from-cycles 182 | (list 183 | (list (make-cycle 20 68 52 36) 184 | (make-cycle 19 67 51 35) 185 | (make-cycle 18 66 50 34) 186 | (make-cycle 17 65 49 33) 187 | (make-cycle 6 7 11 10) 188 | (make-cycle 3 12 14 5) 189 | (make-cycle 2 8 15 9) 190 | (make-cycle 1 4 16 13)) 191 | (list (make-cycle 38 39 43 42) 192 | (make-cycle 35 44 46 37) 193 | (make-cycle 34 40 47 41) 194 | (make-cycle 33 36 48 45) 195 | (make-cycle 16 61 81 20) 196 | (make-cycle 15 57 82 24) 197 | (make-cycle 14 53 83 28) 198 | (make-cycle 13 49 84 32)) 199 | (list (make-cycle 54 55 59 58) 200 | (make-cycle 51 60 62 53) 201 | (make-cycle 50 56 63 57) 202 | (make-cycle 49 52 64 61) 203 | (make-cycle 16 65 96 48) 204 | (make-cycle 12 69 92 44) 205 | (make-cycle 8 73 88 40) 206 | (make-cycle 4 77 84 36)) 207 | (list (make-cycle 22 23 27 26) 208 | (make-cycle 19 28 30 21) 209 | (make-cycle 18 24 31 25) 210 | (make-cycle 17 20 32 29) 211 | (make-cycle 13 45 93 68) 212 | (make-cycle 9 41 89 72) 213 | (make-cycle 5 37 85 76) 214 | (make-cycle 1 33 81 80)) 215 | (list (make-cycle 70 71 75 74) 216 | (make-cycle 67 76 78 69) 217 | (make-cycle 66 72 79 73) 218 | (make-cycle 65 68 80 77) 219 | (make-cycle 16 29 84 64) 220 | (make-cycle 12 25 88 60) 221 | (make-cycle 8 21 92 56) 222 | (make-cycle 4 17 96 52)) 223 | (list (make-cycle 86 87 91 90) 224 | (make-cycle 83 92 94 85) 225 | (make-cycle 82 88 95 89) 226 | (make-cycle 81 84 96 93) 227 | (make-cycle 32 48 64 80) 228 | (make-cycle 31 47 63 79) 229 | (make-cycle 30 46 62 78) 230 | (make-cycle 29 45 61 77)) 231 | (list (make-cycle 24 72 56 40) 232 | (make-cycle 23 71 55 39) 233 | (make-cycle 22 70 54 38) 234 | (make-cycle 21 69 53 37)) 235 | (list (make-cycle 12 62 85 19) 236 | (make-cycle 11 58 86 23) 237 | (make-cycle 10 54 87 27) 238 | (make-cycle 9 50 88 31)) 239 | (list (make-cycle 15 66 95 47) 240 | (make-cycle 11 70 91 43) 241 | (make-cycle 7 74 87 39) 242 | (make-cycle 3 78 83 35)) 243 | (list (make-cycle 14 46 94 67) 244 | (make-cycle 10 44 90 71) 245 | (make-cycle 6 38 86 75) 246 | (make-cycle 2 34 82 79)) 247 | (list (make-cycle 8 18 89 63) 248 | (make-cycle 7 22 90 58) 249 | (make-cycle 6 26 91 55) 250 | (make-cycle 5 30 92 51)) 251 | (list (make-cycle 28 44 60 76) 252 | (make-cycle 27 43 59 75) 253 | (make-cycle 26 42 58 74) 254 | (make-cycle 25 41 57 73))) 255 | (* 6 4 4))) 256 | 257 | ;; +--+--+--+--+ 258 | ;; |49|50|51|52| 259 | ;; +--+--+--+--+ 260 | ;; |53|**|**|54| 261 | ;; +--+--+--+--+ 262 | ;; |55|**|**|56| 263 | ;; +--+--+--+--+ 264 | ;; |57|58|59|60| 265 | ;; +--+--+--+--+ 266 | ;; +--+--+--+--+ +--+--+--+--+ +--+--+--+--+ +--+--+--+--+ 267 | ;; |37|38|39|40| | 1| 2| 3| 4| |13|14|15|16| |25|26|27|28| 268 | ;; +--+--+--+--+ +--+--+--+--+ +--+--+--+--+ +--+--+--+--+ 269 | ;; |41|**|**|42| | 5|**|**| 6| |17|**|**|18| |29|**|**|30| 270 | ;; +--+--+--+--+ +--+--+--+--+ +--+--+--+--+ +--+--+--+--+ 271 | ;; |43|**|**|44| | 7|**|**| 8| |19|**|**|20| |31|**|**|32| 272 | ;; +--+--+--+--+ +--+--+--+--+ +--+--+--+--+ +--+--+--+--+ 273 | ;; |45|46|47|48| | 9|10|11|12| |21|22|23|24| |33|34|35|36| 274 | ;; +--+--+--+--+ +--+--+--+--+ +--+--+--+--+ +--+--+--+--+ 275 | ;; +--+--+--+--+ 276 | ;; |61|62|63|64| 277 | ;; +--+--+--+--+ 278 | ;; |65|**|**|66| 279 | ;; +--+--+--+--+ 280 | ;; |67|**|**|68| 281 | ;; +--+--+--+--+ 282 | ;; |69|70|71|72| 283 | ;; +--+--+--+--+ 284 | 285 | (defun make-rubik-4x4-no-centers () 286 | (flet ((mkperm (&rest cycle-lists) 287 | (from-cycles (mapcar (lambda (x) (apply #'make-cycle x)) cycle-lists) (* 6 3 4)))) 288 | (let ((\U (mkperm '(49 52 60 57) '(50 54 59 55) '(51 56 58 53) '(1 37 25 13) '(2 38 26 14) '(3 39 27 15) '(4 40 28 16))) 289 | (\u (mkperm '(5 41 29 17) '(6 42 30 18))) 290 | (\d (mkperm '(7 19 31 43) '(8 20 32 44))) 291 | (\D (mkperm '(61 64 72 69) '(62 66 71 67) '(63 68 70 65) '(9 21 33 45) '(10 22 34 46) '(11 23 35 47) '(12 24 36 48))) 292 | (\L (mkperm '(37 40 48 45) '(38 42 47 43) '(39 44 46 41) '(1 61 36 49) '(5 65 32 53) '(7 67 30 55) '(9 69 28 57))) 293 | (\l (mkperm '(2 62 35 50) '(10 70 27 58))) 294 | (\r (mkperm '(3 51 34 63) '(11 59 26 71))) 295 | (\R (mkperm '(13 16 24 21) '(14 18 23 19) '(15 20 22 17) '(4 52 33 64) '(6 54 31 66) '(8 56 29 68) '(12 60 25 72))) 296 | (\F (mkperm '(1 4 12 9) '(2 6 11 7) '(3 8 10 5) '(57 13 64 48) '(58 17 63 44) '(59 19 62 42) '(60 21 61 40))) 297 | (\f (mkperm '(55 14 66 47) '(56 22 65 39))) 298 | (\b (mkperm '(53 46 68 15) '(54 38 67 23))) 299 | (\B (mkperm '(25 28 36 33) '(26 30 35 31) '(27 32 34 29) '(16 49 45 72) '(18 50 43 71) '(20 51 41 70) '(24 52 37 69)))) 300 | (declare (ignore \D \B \L)) 301 | ;; We fix the DBL corner. 302 | (generate-perm-group 303 | (list 304 | \U (perm-expt \U 2) (perm-inverse \U) 305 | \u (perm-expt \u 2) (perm-inverse \u) 306 | \d (perm-expt \d 2) (perm-inverse \d) 307 | ;; \D (perm-expt \D 2) (perm-inverse \D) 308 | ;; \L (perm-expt \L 2) (perm-inverse \L) 309 | \l (perm-expt \l 2) (perm-inverse \l) 310 | \r (perm-expt \r 2) (perm-inverse \r) 311 | \R (perm-expt \R 2) (perm-inverse \R) 312 | \F (perm-expt \F 2) (perm-inverse \F) 313 | \f (perm-expt \f 2) (perm-inverse \f) 314 | \b (perm-expt \b 2) (perm-inverse \b) 315 | ;; \B (perm-expt \B 2) (perm-inverse \B) 316 | ))))) 317 | 318 | (defun make-skewb () 319 | (group-from-cycles 320 | (list 321 | (list (make-cycle 1 11 17) 322 | (make-cycle 2 12 20) 323 | (make-cycle 4 10 18) 324 | (make-cycle 22 6 14) 325 | (make-cycle 25 27 29)) 326 | (list (make-cycle 2 10 22) 327 | (make-cycle 1 9 23) 328 | (make-cycle 3 11 21) 329 | (make-cycle 17 5 15) 330 | (make-cycle 25 27 30)) 331 | (list (make-cycle 4 14 20) 332 | (make-cycle 1 15 19) 333 | (make-cycle 3 13 17) 334 | (make-cycle 7 11 23) 335 | (make-cycle 25 28 29)) 336 | (list (make-cycle 6 12 18) 337 | (make-cycle 5 11 19) 338 | (make-cycle 7 9 17) 339 | (make-cycle 21 1 13) 340 | (make-cycle 26 27 29))) 341 | 30)) 342 | 343 | ;;; 100669616553523347122516032313645505168688116411019768627200000000000 344 | (defun make-megaminx () 345 | (group-from-cycles 346 | (list 347 | (list (make-cycle 1 9 7 5 3) 348 | (make-cycle 50 40 30 120 11) 349 | (make-cycle 52 42 32 22 13) 350 | (make-cycle 2 10 8 6 4) 351 | (make-cycle 51 41 31 21 12)) 352 | 353 | (list (make-cycle 11 13 15 17 19) 354 | (make-cycle 3 120 72 62 54) 355 | (make-cycle 5 28 70 60 52) 356 | (make-cycle 12 14 16 18 20) 357 | (make-cycle 4 29 71 61 53)) 358 | 359 | (list (make-cycle 120 22 24 26 28) 360 | (make-cycle 5 30 82 74 15) 361 | (make-cycle 7 38 80 72 13) 362 | (make-cycle 21 23 25 27 29) 363 | (make-cycle 6 39 81 73 14)) 364 | 365 | (list (make-cycle 30 32 34 36 38) 366 | (make-cycle 7 40 92 84 24) 367 | (make-cycle 9 48 90 82 22) 368 | (make-cycle 31 33 35 37 39) 369 | (make-cycle 8 49 91 83 23)) 370 | 371 | (list (make-cycle 40 42 44 46 48) 372 | (make-cycle 9 50 114 94 34) 373 | (make-cycle 1 58 112 92 32) 374 | (make-cycle 41 43 45 47 49) 375 | (make-cycle 10 59 113 93 33)) 376 | 377 | (list (make-cycle 50 52 54 56 58) 378 | (make-cycle 1 11 60 116 44) 379 | (make-cycle 3 19 68 114 42) 380 | (make-cycle 51 53 55 57 59) 381 | (make-cycle 2 20 69 115 43)) 382 | 383 | (list (make-cycle 60 62 64 66 68) 384 | (make-cycle 19 70 106 118 56) 385 | (make-cycle 17 78 104 116 54) 386 | (make-cycle 61 63 65 67 69) 387 | (make-cycle 18 79 105 117 55)) 388 | 389 | (list (make-cycle 70 72 74 76 78) 390 | (make-cycle 17 28 80 108 64) 391 | (make-cycle 15 26 88 106 62) 392 | (make-cycle 71 73 75 77 79) 393 | (make-cycle 16 27 89 107 63)) 394 | 395 | (list (make-cycle 80 82 84 86 88) 396 | (make-cycle 26 38 90 100 76) 397 | (make-cycle 24 36 98 108 74) 398 | (make-cycle 81 83 85 87 89) 399 | (make-cycle 25 37 99 109 75)) 400 | 401 | (list (make-cycle 90 92 94 96 98) 402 | (make-cycle 36 48 112 102 86) 403 | (make-cycle 34 46 110 100 84) 404 | (make-cycle 91 93 95 97 99) 405 | (make-cycle 35 47 111 101 85)) 406 | 407 | (list (make-cycle 100 102 104 106 108) 408 | (make-cycle 98 110 66 78 88) 409 | (make-cycle 96 118 64 76 86) 410 | (make-cycle 101 103 105 107 109) 411 | (make-cycle 97 119 65 77 87)) 412 | 413 | (list (make-cycle 110 112 114 116 118) 414 | (make-cycle 96 46 58 68 104) 415 | (make-cycle 94 44 56 66 102) 416 | (make-cycle 111 113 115 117 119) 417 | (make-cycle 95 45 57 67 103))) 418 | (* 12 ; faces 419 | 10 ; stickers per face 420 | ))) 421 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # CL-PERMUTATION 2 | 3 | A library for operating on permutations and permutation groups. 4 | 5 | 6 | ## Creating Permutations 7 | 8 | Permutations are represented by the structure `PERM`, which is 9 | read-only/immutable at the API boundary. A permutation of size `N` is essentially a sequence 10 | of numbers from `1` to `N`. One-based permutations were chosen because that 11 | is the dominating convention in mathematics. All we lose, essentially, 12 | is direct compatibility with array indexing, and one fixnum worth of 13 | space. (Internally, the permutations are stored in an array of size 14 | `N+1`, where the zeroth element is always zero). 15 | 16 | A permutation can be created via `MAKE-PERM`: 17 | 18 | ``` 19 | PERM> (make-perm 1 2 3) 20 | # 21 | ``` 22 | 23 | The permutation will be checked for validity. 24 | 25 | ``` 26 | PERM> (make-perm 1 2 5) 27 | Given permutation must contain the numbers 1 to 3 28 | [Condition of type SIMPLE-ERROR] 29 | ``` 30 | 31 | One can also create permutations with `LIST-TO-PERM`, which converts a 32 | list to a permutation. The companion function `PERM-TO-LIST` does the 33 | opposite operation, but it's not recommended to use list 34 | representations of permutations. 35 | 36 | One can also create permutations with `VECTOR-TO-PERM`, which is 37 | analogous to `LIST-TO-PERM`, except it works for vectors. The reverse is 38 | `PERM-TO-VECTOR`. 39 | 40 | Lastly, there is an experimental reader macro for permutations, which 41 | are created at read time. To enable the syntax, use 42 | 43 | ``` 44 | (enable-perm-reader) 45 | ``` 46 | 47 | and then one may type 48 | 49 | ``` 50 | #[3 1 2 4 5] 51 | ``` 52 | 53 | for permutations instead. 54 | 55 | 56 | ## Permutation Operations 57 | 58 | There is a slew of permutation operations: 59 | 60 | * `perm-identity`: construct an identity perm 61 | * `perm-identity-p`: check if a perm is an identity perm 62 | * `random-perm`: construct a random perm with specified parity 63 | * `perm-ref`: zero-based reference 64 | * `perm-eval`: one-based (standard) reference 65 | * `perm-eval*`: one-based (standard) reference with out-of-bounds handling 66 | * `perm-inverse-eval`: one-based (standard) reference of inverse 67 | * `perm-inverse-eval*`: one-based (standard) reference of inverse with out-of-bounds handling 68 | * `perm=`: check for equality 69 | * `perm=*`: check for equality of different sized perms 70 | * `perm-size`: the size of the permutation (number of mapped elements) 71 | * `perm-length`: number of inversions 72 | * `perm-even-p`: check for evenness/oddness 73 | * `perm-odd-p`: '' 74 | * `perm-sign`: '' 75 | * `perm-compose`: compose two permutations 76 | * `perm-expt`: compose a perm with itself a number of times 77 | * `perm-order`: order of a permutation 78 | * `perm-transpose-indexes`: swap two indexes, keeping the entries fixed 79 | * `perm-transpose-entries`: swap two entries, keeping the indexes fixed 80 | * `perm-inverse`: invert a permutation 81 | * `perm-fixpoints`: compute the fixed points of a permutation 82 | * `permute`: permute an array according to a permutation 83 | * `commutesp`: check if two permutations commute 84 | * `perm<`: check lexicographic order 85 | 86 | 87 | ## Permutation Generation 88 | 89 | There are ways of efficiently generating all permutations of a given 90 | length incrementally. Instead of generating all permutations at once 91 | in memory -- which takes `O(n*n!)` space -- we generate permutations on 92 | the fly. 93 | 94 | The first way is to iterate over the permutations using a `DOLIST`-style 95 | macro called `DOPERMS`. 96 | 97 | ``` 98 | PERM> (let ((i 1)) 99 | (doperms (p 3) 100 | (format t "~D: ~A~%" i p) 101 | (incf i))) 102 | 1: # 103 | 2: # 104 | 3: # 105 | 4: # 106 | 5: # 107 | 6: # 108 | ``` 109 | 110 | The other way is to produce a generator object (a closure, in fact) 111 | which generates the permutations. Simply `FUNCALL` the object to receive 112 | the next permutation. When they're all exhausted, the closure will 113 | return `NIL`. 114 | 115 | ``` 116 | PERM> (defparameter S3 (make-perm-generator 3)) 117 | S3 118 | PERM> (defparameter S2 (make-perm-generator 2)) 119 | S2 120 | PERM> (list (funcall S2) (funcall S3)) 121 | (# #) 122 | PERM> (list (funcall S2) (funcall S3)) 123 | (# #) 124 | PERM> (list (funcall S2) (funcall S3)) 125 | (NIL #) 126 | PERM> (list (funcall S2) (funcall S3)) 127 | (NIL #) 128 | PERM> (list (funcall S2) (funcall S3)) 129 | (NIL #) 130 | ``` 131 | 132 | 133 | ## Cycle Operations 134 | 135 | There's also a number of operations for cycles. Cycles are represented 136 | by the `CYCLE` structure. We can convert to and from cycle 137 | representation using `TO-CYCLES` and `FROM-CYCLES`. Cycles created by 138 | `TO-CYCLES` are automatically canonicalized with 139 | `CANONICALIZE-CYCLES`. Canonicalization is defined as: 140 | 141 | * Cycles contain their least element positionally first. 142 | * Cycles are listed in descending order of their first element. 143 | * No null cycles exist. 144 | * The sum of the cycle lengths of a decomposition of a permutation 145 | of size `N` is `N`. 146 | 147 | Cycles that have not been canonicalized are printed with an 148 | asterisk '`*`'. We can observe this by explicitly disabling cycle 149 | canonicalization: 150 | 151 | ``` 152 | PERM> (make-cycle 3 1) 153 | # ; no asterisk 154 | PERM> (let ((*canonicalize-cycle-on-creation* nil)) 155 | (make-cycle 3 1)) 156 | # ; asterisk 157 | ``` 158 | 159 | An example use of `TO-CYCLES` is as follows: 160 | 161 | ``` 162 | PERM> (let ((r (random-perm 10))) 163 | (values r (to-cycles r))) 164 | # 165 | (# # #) 166 | ``` 167 | 168 | `FROM-CYCLES` allows the specification of the permutation's length. For example: 169 | 170 | ``` 171 | PERM> (from-cycles (list (make-cycle 1 3 2))) 172 | # 173 | PERM> (from-cycles (list (make-cycle 1 3 2)) 5) 174 | # 175 | ``` 176 | 177 | Lastly, there is a (mostly useless) function `CYCLES-TO-ONE-LINE` which 178 | converts cycles to one-line notation. That is, the cycles 179 | 180 | ``` 181 | (1 2 3)(4 5) 182 | ``` 183 | 184 | gets converted to the permutation 185 | 186 | ``` 187 | 12345. 188 | ``` 189 | 190 | For example, 191 | 192 | ``` 193 | PERM> (cycles-to-one-line (list (make-cycle 1 2 3) 194 | (make-cycle 4 5))) 195 | # 196 | ``` 197 | 198 | If one takes a permutation which has been canonically decomposed into 199 | cycles, then interestingly, there exists a bijection between one-line 200 | notation and the cycle decomposition. 201 | 202 | 203 | ## Combinatorial Specifications 204 | 205 | A "combinatorial specification" describes a space of combinatorial 206 | objects. They have a nice property that they all can be mapped to and 207 | from integers sharply. See the section "Ranking and Unranking 208 | Combinatorial Specifications". 209 | 210 | 211 | Currently, only objects of linear structure exist. All of them are 212 | represented as subclasses of `COMBINATORIAL-SPEC`. They are as follows. 213 | 214 | 215 | ### `RADIX-SPEC`: Base-`B` Non-Negative Integers 216 | 217 | These are a representation of a base-`B` non-negative integer, for a 218 | base `B > 1`. They are handled by the `RADIX-SPEC` class. Within 219 | `CL-PERMUTATION`, the digits are written left-to-right to correspond 220 | with natural vector index ordering. A `RADIX-SPEC` can be made with 221 | `MAKE-RADIX-SPEC`. Here is the enumeration of all two-digit trinary 222 | numbers: 223 | 224 | ``` 225 | PERM> (print-objects-of-spec (make-radix-spec 3 2)) 226 | 0 ==> #(0 0) ==> 0 227 | 1 ==> #(1 0) ==> 1 228 | 2 ==> #(2 0) ==> 2 229 | 3 ==> #(0 1) ==> 3 230 | 4 ==> #(1 1) ==> 4 231 | 5 ==> #(2 1) ==> 5 232 | 6 ==> #(0 2) ==> 6 233 | 7 ==> #(1 2) ==> 7 234 | 8 ==> #(2 2) ==> 8 235 | ``` 236 | 237 | ### `MIXED-RADIX-SPEC`: Non-Negative Mixed-Radix Integers 238 | 239 | A mixed-radix integer is a generalization of a base-`B` integer. The 240 | digits in a mixed-radix numeral correspond to different 241 | bases. Mixed-radix specifications can be made with 242 | `VECTOR-TO-MIXED-RADIX-SPEC`. For example, the following are all 243 | numerals of radix `(2, 3, 1)`: 244 | 245 | ``` 246 | PERM> (print-objects-of-spec (vector-to-mixed-radix-spec #(2 3 1))) 247 | 0 ==> #(0 0 0) ==> 0 248 | 1 ==> #(1 0 0) ==> 1 249 | 2 ==> #(0 1 0) ==> 2 250 | 3 ==> #(1 1 0) ==> 3 251 | 4 ==> #(0 2 0) ==> 4 252 | 5 ==> #(1 2 0) ==> 5 253 | ``` 254 | Notice again we use vector index ordering. 255 | 256 | 257 | ### `PERM-SPEC`: Permutations 258 | 259 | The space of permutations of length `N` (also known as `S_N`) can be 260 | represented. These are represented by the `PERM-SPEC` class. 261 | 262 | ``` 263 | PERM> (print-objects-of-spec (make-perm-spec 3)) 264 | 0 ==> #(0 1 2) ==> 0 265 | 1 ==> #(0 2 1) ==> 1 266 | 2 ==> #(1 0 2) ==> 2 267 | 3 ==> #(1 2 0) ==> 3 268 | 4 ==> #(2 0 1) ==> 4 269 | 5 ==> #(2 1 0) ==> 5 270 | ``` 271 | 272 | Currently, actual `PERM` objects are *not* generated (see below about 273 | ranking/unranking). However, one can easily convert between the two. 274 | 275 | 276 | ### `COMBINATION-SPEC`: Combinations 277 | 278 | Combinations represent the selection of `M` objects from a collection of 279 | `N` objects. These are represented by a vector containing `M` `1`'s and `N` 280 | `0`'s. The class that manages this is a `COMBINATION-SPEC`. For example, 281 | all combinations of 2 objects of a total of 4 can be listed by the 282 | following: 283 | 284 | ``` 285 | PERM> (print-objects-of-spec (make-combination-spec 4 2)) 286 | 0 ==> #(0 0 1 1) ==> 0 287 | 1 ==> #(0 1 0 1) ==> 1 288 | 2 ==> #(1 0 0 1) ==> 2 289 | 3 ==> #(0 1 1 0) ==> 3 290 | 4 ==> #(1 0 1 0) ==> 4 291 | 5 ==> #(1 1 0 0) ==> 5 292 | ``` 293 | 294 | ### `WORD-SPEC`: Words 295 | 296 | A word is similar to a permutation except that it may have repeated, 297 | indistinct elements. These are represented by a `WORD-SPEC`. It can be 298 | created by supplying a sample word to the function 299 | `VECTOR-TO-WORD-SPEC`. For example, all words of the form `1123` can be 300 | listed as follows: 301 | 302 | ``` 303 | PERM> (print-objects-of-spec (vector-to-word-spec #(1 1 2 3))) 304 | 0 ==> #(1 1 2 3) ==> 0 305 | 1 ==> #(1 1 3 2) ==> 1 306 | 2 ==> #(1 2 1 3) ==> 2 307 | 3 ==> #(1 2 3 1) ==> 3 308 | 4 ==> #(1 3 1 2) ==> 4 309 | 5 ==> #(1 3 2 1) ==> 5 310 | 6 ==> #(2 1 1 3) ==> 6 311 | 7 ==> #(2 1 3 1) ==> 7 312 | 8 ==> #(2 3 1 1) ==> 8 313 | 9 ==> #(3 1 1 2) ==> 9 314 | 10 ==> #(3 1 2 1) ==> 10 315 | 11 ==> #(3 2 1 1) ==> 11 316 | ``` 317 | 318 | 319 | ## Ranking and Unranking Combinatorial Specifications 320 | 321 | Each combinatorial specification represents a finite space of `N > 0` 322 | objects. `N` is called the "cardinality" of the specification and can be 323 | computed with the `CARDINALITY` method. 324 | 325 | ``` 326 | > (cardinality (make-perm-spec 3)) 327 | 6 328 | > (cardinality (vector-to-word-spec #(1 1 2 3))) 329 | 12 330 | ``` 331 | 332 | The cardinality is computed only once for a combinatorial 333 | specification and is then cached for fast access. 334 | 335 | Obviously, every object in a particular finite combinatorial space can 336 | be bijected to and from integers below the cardinality of that 337 | space. `CL-PERMUTATION` provides fast and efficient mechanisms for 338 | computing one such bijection for each combinatorial 339 | specification. Mapping from an object to an integer is called 340 | "ranking" and mapping from an integer back to an object is called 341 | "unranking". 342 | 343 | When a lexicographic ordering makes sense, there will be 1-to-1 344 | correspondence with the ordering on integers. In other words for 345 | objects `X1` and `X2` and their ranks `R1` and `R2`, `X1 lex< X2` iff `R1 < R2`. 346 | 347 | The method `UNRANK` takes a combinatorial specification and an integer, 348 | and maps it to the corresponding object representation (usually a 349 | vector). It takes an optional keyword argument `:SET` which acts as a 350 | destination of the unranked object (for efficiency purposes). 351 | 352 | The method `RANK` takes a combinatorial specification and an object 353 | produced by `UNRANK` (again, usually a sensible vector) and returns the 354 | integer (the "rank") of that object. `PRINT-OBJECTS-OF-SPEC`, as used 355 | above, prints the rank of every object in a combinatorial space. 356 | 357 | One can map over all objects and ranks by using `MAP-SPEC`, which takes 358 | a binary function (rank and object) as well as a combinatorial 359 | specification, and applies that function to each object and their 360 | rank. 361 | 362 | 363 | ## Permutation Groups 364 | 365 | There is initial support for permutation groups at the 366 | moment. Permutation groups are represented by the structure 367 | `PERM-GROUP`. 368 | 369 | We can create a permutation group from its generators via 370 | `GENERATE-PERM-GROUP`. A shorthand syntax is provided which, instead of 371 | taking a list of `PERM` objects, takes a list of lists representing 372 | perms. This shorthand is `GROUP-FROM`. For example, the following two 373 | are the same group: 374 | 375 | ``` 376 | PERM> (generate-perm-group (list (make-perm 1 3 2 4) 377 | (make-perm 3 2 4 1))) 378 | # 379 | PERM> (group-from '((1 3 2 4) 380 | (3 2 4 1))) 381 | # 382 | ``` 383 | 384 | We can generate a permutation group from a list of cycles as well. The 385 | above is equivalent to 386 | 387 | ``` 388 | PERM> (group-from-cycles (list (list (make-cycle 2 3)) 389 | (list (make-cycle 1 3 4))) 390 | 4) 391 | # 392 | ``` 393 | 394 | Once we have generated a group, we can do some operations on it. 395 | 396 | For example, let's define the group for 3x3 Rubik's cubes. A cube has 397 | six moves: we can turn the front, back, left, right, top, and 398 | bottom. Label each sticker with a number like so: 399 | 400 | ``` 401 | +--------------+ 402 | | | 403 | | 1 2 3 | 404 | | | 405 | | 4 up 5 | 406 | | | 407 | | 6 7 8 | 408 | | | 409 | +--------------+--------------+--------------+--------------+ 410 | | | | | | 411 | | 9 10 11 | 17 18 19 | 25 26 27 | 33 34 35 | 412 | | | | | | 413 | | 12 left 13 | 20 front 21 | 28 right 29 | 36 back 37 | 414 | | | | | | 415 | | 14 15 16 | 22 23 24 | 30 31 32 | 38 39 40 | 416 | | | | | | 417 | +--------------+--------------+--------------+--------------+ 418 | | | 419 | | 41 42 43 | 420 | | | 421 | | 44 down 45 | 422 | | | 423 | | 46 47 48 | 424 | | | 425 | +--------------+ 426 | ``` 427 | 428 | Each turn corresponds to a permutation of stickers. I'll do the hard 429 | work of specifying them: 430 | 431 | ``` 432 | (defparameter rubik-3x3 433 | (group-from 434 | '((3 5 8 2 7 1 4 6 33 34 35 12 13 14 15 16 9 10 11 20 21 22 23 24 17 435 | 18 19 28 29 30 31 32 25 26 27 36 37 38 39 40 41 42 43 44 45 46 47 48) 436 | (17 2 3 20 5 22 7 8 11 13 16 10 15 9 12 14 41 18 19 44 21 46 23 24 437 | 25 26 27 28 29 30 31 32 33 34 6 36 4 38 39 1 40 42 43 37 45 35 47 48) 438 | (1 2 3 4 5 25 28 30 9 10 8 12 7 14 15 6 19 21 24 18 23 17 20 22 43 439 | 26 27 42 29 41 31 32 33 34 35 36 37 38 39 40 11 13 16 44 45 46 47 48) 440 | (1 2 38 4 36 6 7 33 9 10 11 12 13 14 15 16 17 18 3 20 5 22 23 8 27 441 | 29 32 26 31 25 28 30 48 34 35 45 37 43 39 40 41 42 19 44 21 46 47 24) 442 | (14 12 9 4 5 6 7 8 46 10 11 47 13 48 15 16 17 18 19 20 21 22 23 24 443 | 25 26 1 28 2 30 31 3 35 37 40 34 39 33 36 38 41 42 43 44 45 32 29 27) 444 | (1 2 3 4 5 6 7 8 9 10 11 12 13 22 23 24 17 18 19 20 21 30 31 32 25 445 | 26 27 28 29 38 39 40 33 34 35 36 37 14 15 16 43 45 48 42 47 41 44 46)))) 446 | ``` 447 | 448 | Now we have our group: 449 | 450 | ``` 451 | PERM> rubik-3x3 452 | # 453 | ``` 454 | 455 | Let's query the group's order: 456 | 457 | ``` 458 | PERM> (group-order rubik-3x3) 459 | 43252003274489856000 460 | ``` 461 | 462 | A lot of positions! Let's generate a random cube: 463 | 464 | ``` 465 | PERM> (random-group-element rubik-3x3) 466 | # 468 | ``` 469 | 470 | And as cycles... 471 | 472 | ``` 473 | PERM> (to-cycles *) 474 | (# 475 | # 476 | # 477 | # 478 | # 479 | # 480 | # 481 | # 482 | # 483 | #) 484 | ``` 485 | 486 | Let's check if flipping an edge piece is valid: 487 | 488 | ``` 489 | PERM> (group-element-p (from-cycles (list (make-cycle 7 18)) 48) rubik-3x3) 490 | NIL 491 | ``` 492 | 493 | No it's not. How about four edge pieces? 494 | 495 | ``` 496 | PERM> (group-element-p (from-cycles (list (make-cycle 7 18) 497 | (make-cycle 2 34) 498 | (make-cycle 4 10) 499 | (make-cycle 5 26)) 500 | 48) 501 | rubik-3x3) 502 | T 503 | ``` 504 | 505 | As can be seen, the few operations we have are powerful in studying 506 | finite groups. 507 | 508 | -------------------------------------------------------------------------------- /src/block.lisp: -------------------------------------------------------------------------------- 1 | ;;;; block.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2015-2018 Robert Smith 4 | 5 | (in-package #:cl-permutation) 6 | 7 | ;;; This file has to do with the computation of "block systems". A 8 | ;;; "block" is roughly a set of points that always "move together". I 9 | ;;; am not sure where its name comes from, but blocks on a Rubik's 10 | ;;; cube-like puzzle would be the actual physical cubelets. (Sometimes 11 | ;;; cubelets don't make *minimal* blocks, however. An example of where 12 | ;;; this is the case is the subgroup of the cube.) 13 | 14 | 15 | ;;; Disjoint-Set (DJS) Data Structure 16 | ;;; 17 | ;;; Below we implement the well known union-find algorithms. We don't 18 | ;;; implement the common optimization of balancing-by-rank, because we 19 | ;;; have an additional constraint: We need to arbitrarily be able to 20 | ;;; change the canonical element of each DJS. 21 | ;;; 22 | ;;; We implement this by endowing DJS's with a "DJS-REP" data 23 | ;;; structure, which adds a level of indirection. This data structure 24 | ;;; just contains a single pointer to DJS node. There is an invariant 25 | ;;; that if one DJS-REP points to a node N, then no other DJS-REP node 26 | ;;; points to N as well. 27 | ;;; 28 | ;;; DJS nodes point to their representative DJS-REP, which changes 29 | ;;; when a DJS-UNION operation occurs. When DJS-UNION occurs, we may 30 | ;;; mess up the invariant above. This invariant is later repaired 31 | ;;; "on-demand" within DJS-FIND. 32 | 33 | (defun %djs-and-rep-printer (s stream depth) 34 | (declare (ignore depth)) 35 | (let ((*print-circle* t)) 36 | (princ s stream))) 37 | 38 | (defstruct (djs (:constructor %make-djs) 39 | (:print-function %djs-and-rep-printer)) 40 | "Representation of a disjoint-set data structure. Each node has a representative element denoted by REPRESENTATIVE, which points to a DJS-REP node representing the canonical element of that disjoint-set." 41 | ;; FIXME: This type produces a warning because the compiler 42 | ;; presumably doesn't know about DJS-REP yet. 43 | (representative nil :type (or null djs-rep)) 44 | value) 45 | 46 | ;;; TODO: I think we can eliminate DJS-REP. We can just use a cons 47 | ;;; cell. 48 | (defstruct (djs-rep (:constructor %make-djs-rep) 49 | (:print-function %djs-and-rep-printer)) 50 | "Pointer to the representative element of a DJS." 51 | (djs nil :type djs)) 52 | 53 | (defun djs (value) 54 | "Construct a fresh DJS node." 55 | (let* ((node (%make-djs :value value)) 56 | (rep (%make-djs-rep :djs node))) 57 | (setf (djs-representative node) rep) 58 | ;; Return the DJS node. 59 | node)) 60 | 61 | (defun djs-change-representative (djs) 62 | "Change the representative of DJS to point to itself." 63 | (setf (djs-rep-djs (djs-representative djs)) djs)) 64 | 65 | (defun djs-find (d) 66 | "Find the canonical DJS node of which the DJS node D is a part." 67 | (loop :with rep := (djs-representative d) 68 | :with rep-node := (djs-rep-djs rep) 69 | :with rep-node-rep := (djs-representative rep-node) 70 | ;; Fix-up out-of-date rep nodes. Once updated, this loop will 71 | ;; not execute in future invocations. 72 | :until (eq rep rep-node-rep) :do 73 | (setf (djs-representative d) rep-node-rep 74 | rep rep-node-rep 75 | rep-node (djs-rep-djs rep) 76 | rep-node-rep (djs-representative rep-node)) 77 | :finally (return (djs-rep-djs rep-node-rep)))) 78 | 79 | (defun djs-union (a b) 80 | "Link together the DJS nodes A and B. 81 | 82 | The representative of the union will be that of B." 83 | (let ((a-rep (djs-representative a)) 84 | (b-rep (djs-representative b))) 85 | (unless (eq a-rep b-rep) 86 | ;; Set representative of A to be B-REP. Now A won't point to 87 | ;; it's old representative. 88 | (setf (djs-representative a) b-rep) 89 | ;; Change the old A representative to point to B. 90 | (setf (djs-rep-djs a-rep) 91 | (djs-rep-djs b-rep)))) 92 | nil) 93 | 94 | 95 | ;;; Internal driver algorithms for block system computation. 96 | 97 | (defun find-minimal-block-system-containing (perm-group alphas) 98 | "Find the minimal blocks of the permutation group PERM-GROUP which contain the list of points ALPHAS. 99 | 100 | Returns a list of lists. Each sub-list represents a block. Each block is an image of one another under the generators of the group." 101 | ;; This is an implementation of Atkinson's algorithm, along with 102 | ;; additional features I've added. 103 | (check-type perm-group perm-group) 104 | (assert (not (null alphas)) (alphas) "ALPHAS must contain at least 1 point.") 105 | (assert (listp alphas) (alphas) "ALPHAS must be a list.") 106 | (let* ((degree (group-degree perm-group)) 107 | ;; CLASSES is a map from point to DJS. We can reverse this 108 | ;; map by inspecting the value of DJS via DJS-VALUE. See the 109 | ;; functions CLASS and REP below. 110 | (classes (make-array (1+ degree) :initial-element nil)) 111 | ;; PROCESSED-ELEMENTS tells us which elements we've 112 | ;; processed, so we can return only the elements that are a 113 | ;; part of the block system. 114 | (processed-elements (make-membership-set degree))) 115 | (assert (every (lambda (alpha) (<= 1 alpha degree)) alphas) 116 | () 117 | "ALPHAS contains invalid points. They must be between 1 and ~ 118 | the degree of the group, which is ~D." 119 | degree) 120 | ;; Set up our equivalence classes as DJS's. 121 | ;; 122 | ;; First, initialize all classes.. 123 | (loop :for i :from 1 :to degree :do 124 | (setf (aref classes i) (djs i))) 125 | 126 | ;; Next, put all ALPHA_I in the same equivalence class. 127 | (let ((alpha_1-class (aref classes (first alphas)))) 128 | (loop :for i :in (rest alphas) :do 129 | (let ((alpha_i-class (aref classes i))) 130 | ;; Ensure that alpha_1-class is the representative of this 131 | ;; union. Currently, this is implicit in the DJS-UNION call. 132 | (djs-union alpha_i-class alpha_1-class)))) 133 | ;; Note that we have processed all ALPHA elements. 134 | (dolist (alpha alphas) 135 | (setf (sbit processed-elements alpha) 1)) 136 | ;; Now for the main algorithm... 137 | (labels ((class (point) 138 | "Find the class of the point POINT." 139 | (aref classes point)) 140 | (rep (point) 141 | "Find the class representative of the point POINT." 142 | (djs-value (djs-find (class point))))) 143 | (let ((q (make-queue))) 144 | ;; Initialize the queue with ALPHA_I for I > 1. 145 | (dolist (alpha (rest alphas)) 146 | (enqueue q alpha)) 147 | ;; Iterate until queue is empty. 148 | (loop :until (queue-empty-p q) :do 149 | (let ((gamma (dequeue q))) 150 | (dolist (g (generators perm-group)) 151 | (let* ((delta (rep gamma)) 152 | (kappa (rep (perm-eval g gamma))) 153 | (lam (rep (perm-eval g delta)))) 154 | (unless (= kappa lam) 155 | (let ((kappa-class (class kappa)) 156 | (lam-class (class lam))) 157 | (setf (sbit processed-elements lam) 1) 158 | (setf (sbit processed-elements kappa) 1) 159 | (setf (sbit processed-elements delta) 1) 160 | ;; Merge the kappa and lambda classes. 161 | (djs-union lam-class kappa-class) 162 | ;; Make kappa the representative of merged class. 163 | (djs-change-representative kappa-class) 164 | ;; Add LAM for processing. 165 | (enqueue q lam)))))))) 166 | ;; Return equivalence classes. 167 | (let ((table (make-hash-table :test 'eql))) 168 | (loop :for j :from 1 :to degree 169 | :when (= 1 (sbit processed-elements j)) 170 | :do (push j (gethash (rep j) table nil)) 171 | :finally (let ((equiv-classes nil)) 172 | (maphash (lambda (k v) 173 | (declare (ignore k)) 174 | (push (nreverse v) equiv-classes)) 175 | table) 176 | (return (values (nreverse equiv-classes) 177 | processed-elements)))))))) 178 | 179 | (defun atkinson (ω gs) 180 | "M. D. Atkinson's original algorithm as specified in his original paper \"An Algorithm for Finding Blocks of a Permutation Group\", with very light modifications. 181 | 182 | Given a point ω and a list of generators GS, return an array F whose size is max deg(gs), and whose elements are specified as follows: 183 | 184 | If a point p appears in F, then the minimal block containing p is the list of all positions of p in F." 185 | ;; Step 1: Initialize 186 | (let* ((C nil) 187 | (n (loop :for g :in gs :maximize (perm-size g))) 188 | (f (coerce (iota+1 n) 'vector))) 189 | (prog (α β γ δ gs-left g) 190 | STEP-2 191 | (push ω C) 192 | (setf (aref f (1- ω)) 1) 193 | 194 | STEP-3 195 | (setf β (pop C)) 196 | (setf α (aref f (1- β))) 197 | 198 | STEP-4 199 | ;; Atkinson instead sets an index j = 0 here to iterate through 200 | ;; GS. We just iterate directly. 201 | (setf gs-left gs) 202 | 203 | STEP-5 204 | ;; Atkinson would have done j += 1 here and accessed GS 205 | ;; directly. 206 | (setf g (pop gs-left)) 207 | (setf γ (perm-eval g α)) 208 | (setf δ (perm-eval g β)) 209 | 210 | STEP-6 211 | (when (= (aref f (1- γ)) 212 | (aref f (1- δ))) 213 | (go STEP-9)) 214 | 215 | STEP-7 216 | (unless (< (aref f (1- δ)) 217 | (aref f (1- γ))) 218 | (rotatef δ γ)) 219 | 220 | STEP-8 221 | (let ((fγ (aref f (1- γ))) 222 | (fδ (aref f (1- δ)))) 223 | (setf f (nsubstitute fδ fγ f)) 224 | (push fγ C)) 225 | 226 | STEP-9 227 | (unless (null gs-left) 228 | (go STEP-5)) 229 | 230 | STEP-10 231 | (unless (null C) 232 | (go STEP-3)) 233 | 234 | STEP-11 235 | (return f)))) 236 | 237 | (defun trivial-block-system-p (bs) 238 | "Is the block system BS a trivial block system?" 239 | (or (= 1 (length bs)) 240 | (every (lambda (b) (= 1 (length b))) bs))) 241 | 242 | (defun find-non-trivial-block-system (group) 243 | "Find a non-trivial block system of the permutation group GROUP. 244 | 245 | GROUP must be transitive in order for this to produce truly non-trivial block systems." 246 | (loop :for i :from 2 :to (group-degree group) 247 | :for bs := (find-minimal-block-system-containing group (list 1 i)) 248 | :unless (trivial-block-system-p bs) 249 | :do (return bs))) 250 | 251 | (defun canonicalize-raw-block-subsystems (bss) 252 | "Take a raw list of block systems BSS and canonicalize them." 253 | (labels ((canonicalize-block (blk) 254 | (sort (copy-list blk) #'<)) 255 | (canonicalize-system (bs) 256 | (sort (mapcar #'canonicalize-block bs) #'< :key #'first))) 257 | (mapcar #'canonicalize-system bss))) 258 | 259 | (defun raw-block-subsystems (group &key (canonicalize t)) 260 | "Compute all minimal, disjoint block subsystems of the group GROUP. 261 | 262 | Returns a list of block systems." 263 | (labels ((find-block-system (orbit) 264 | (loop :with first := (aref orbit 0) 265 | :for i :from 1 :below (length orbit) 266 | :for p := (aref orbit i) 267 | :for bs := (find-minimal-block-system-containing 268 | group 269 | (list first p)) 270 | :unless (trivial-block-system-p bs) 271 | :do (return bs) 272 | :finally (return (list (coerce orbit 'list)))))) 273 | (let* ((orbits (group-orbits group)) 274 | (bss (mapcar #'find-block-system orbits))) 275 | (if canonicalize 276 | (canonicalize-raw-block-subsystems bss) 277 | bss)))) 278 | 279 | (defun primitive-group-p (group) 280 | "Is the perm group GROUP primitive?" 281 | (trivial-block-system-p (raw-block-subsystems group))) 282 | 283 | 284 | ;;; Now we start wrapping this up into better packaging. 285 | 286 | (defstruct block-subsystem 287 | "Representation of a block subsystem of a group. A \"block subsystem\" is a G-orbit of a block." 288 | ;; The group it came from. 289 | group 290 | ;; The block in the lowest slot. 291 | base-block 292 | ;; Number of blocks in the subsystem. 293 | size 294 | ;; Block size (number of points per block). 295 | block-size 296 | ;; The block subsystem itself, in sorted order. This is the G-orbit 297 | ;; of BASE-BLOCK. 298 | orbit) 299 | 300 | (defun block-slot (subsys blk) 301 | "In which slot is BLK found in the block subsystem BLOCK-SUBSYSTEM?" 302 | ;; Ergh, we assume BLK is of the right size and is a valid block of 303 | ;; SUBSYS. 304 | (1+ (position (list-minimum blk) (block-subsystem-orbit subsys) :test #'= :key #'first))) 305 | 306 | (defun group-block-subsystems (group) 307 | "Return a list of block subsystems of the group GROUP." 308 | (flet ((process-raw-block-subsystem (bs) 309 | (assert (not (null bs))) 310 | (let* ((sorted-blocks (sort (copy-list bs) #'< :key #'list-minimum)) 311 | (base-block (first sorted-blocks))) 312 | (make-block-subsystem 313 | :group group 314 | :base-block base-block 315 | :size (length sorted-blocks) 316 | :block-size (length base-block) 317 | :orbit sorted-blocks)))) 318 | (mapcar #'process-raw-block-subsystem (raw-block-subsystems group :canonicalize t)))) 319 | 320 | 321 | ;;; Interblock Group & Permutations 322 | 323 | (defun block-subsystem-interblock-group-homomorphism (subsys) 324 | "Given a block subsystem SUBSYS, compute a homomorphism to its interblock group." 325 | (lambda (gen) 326 | (list-to-perm 327 | (loop :with gen. := (perm-evaluator gen) 328 | :for blk :in (block-subsystem-orbit subsys) 329 | :collect (block-slot subsys (mapcar gen. blk)))))) 330 | 331 | (defun block-subsystem-interblock-group (subsys) 332 | "Compute the interblock group of a block subsystem SUBSYS." 333 | (let ((hom (block-subsystem-interblock-group-homomorphism subsys))) 334 | (generate-perm-group (mapcar hom (generators (block-subsystem-group subsys)))))) 335 | 336 | 337 | ;;; Intrablock Group & Orientations 338 | 339 | (defun block-subsystem-intrablock-group-generators (subsys) 340 | "Compute (possibly redundant) generators of the intrablock group, along with the computed reference frames." 341 | (check-type subsys block-subsystem) 342 | (let* ((num-slots (block-subsystem-size subsys)) 343 | (G-generators (perm-group.generators (block-subsystem-group subsys))) 344 | (blocks (block-subsystem-orbit subsys)) 345 | (reference-frames (make-array num-slots :initial-element nil)) 346 | (intra-gens '())) 347 | (flet ((block-slot (blk) 348 | "What's the slot of this block?" 349 | (position (list-minimum blk) blocks :key #'first))) 350 | ;; Arbitrarily choose a reference frame for an arbitrary 351 | ;; block. We choose ρ = identity for the first (i.e., base) block. 352 | (setf (aref reference-frames 0) (block-subsystem-base-block subsys)) 353 | ;; Now we seek to choose reference frames for each of the other 354 | ;; slots in such a way that we don't depend upon our of 355 | ;; coordinates (i.e., how we map from G to Aut n, or how we 356 | ;; decide to order blocks themselves). To do this, we start with 357 | ;; a reference frame we know ρᵢ for slot i, and compute γ.ρᵢ and 358 | ;; check if we landed in a new slot j. If we did, then ρⱼ := 359 | ;; γ.ρᵢ is the reference frame for that slot j. We queue up ρⱼ 360 | ;; as a slot to explore later. 361 | ;; 362 | ;; We keep going until we've established reference frames for 363 | ;; all of the slots. 364 | (loop :with unexplored-frames := (list-to-queue (list (aref reference-frames 0))) 365 | :until (zerop (count nil reference-frames)) 366 | :for ρ := (dequeue unexplored-frames) 367 | :do (dolist (γ G-generators) 368 | (let* ((γ.ρ (mapcar (perm-evaluator γ) ρ)) 369 | (j (block-slot γ.ρ)) 370 | (ρⱼ (aref reference-frames j))) 371 | (when (null ρⱼ) 372 | (setf (aref reference-frames j) γ.ρ) 373 | (enqueue unexplored-frames γ.ρ))))) 374 | 375 | ;; Now that we have all of the frames, we want to find 376 | ;; generators for the intrablock group. To do this, we look at 377 | ;; the action of each γ on each frame ρ. If the action isn't 378 | ;; identity, then we've found a generator of the intrablock 379 | ;; group. 380 | (loop :for ρ :across reference-frames :do 381 | (dolist (γ G-generators) 382 | (let* ((γ.ρ (mapcar (perm-evaluator γ) ρ)) 383 | (j (block-slot γ.ρ)) 384 | (ρⱼ (aref reference-frames j))) 385 | (assert (not (null ρⱼ)) () "Inconsistent state. Somehow we missed a reference frame.") 386 | ;; Check whether this action isn't identity, and do it 387 | ;; cheaply. 388 | (unless (every #'= ρⱼ γ.ρ) 389 | (pushnew (permuter ρⱼ γ.ρ) intra-gens :test #'perm=))))) 390 | 391 | ;; TODO: Verify this ensures the identity element in the group 392 | ;; corresponds to the identity elements in the intrablock 393 | ;; groups. It seems to be the case for some tests. 394 | ;; 395 | ;; All done. Return the values. 396 | (values intra-gens reference-frames)))) 397 | 398 | (defun block-subsystem-intrablock-group (subsys) 399 | (generate-perm-group (block-subsystem-intrablock-group-generators subsys))) 400 | 401 | (defun intrablock-coordinate-function (subsys) 402 | ;; Interpretation of g → #(X Y Z ...) 403 | ;; 404 | ;; The block in slot 0 will undergo a change in orientation by X. 405 | ;; The block in slot 1 will undergo a change in orientation by Y. 406 | ;; etc. 407 | (multiple-value-bind (gens frame) (block-subsystem-intrablock-group-generators subsys) 408 | (let ((group (generate-perm-group gens))) 409 | (multiple-value-bind (rank unrank) (group-element-rank-functions group) 410 | (declare (ignore unrank)) 411 | (lambda (g) 412 | (let ((γ (perm-evaluator g))) 413 | ;; N.B.: We can't iterate through the orbit. We must 414 | ;; iterate through the frame! Otherwise we will have 415 | ;; incorrect computations of π. 416 | (loop :with coord := (make-array (block-subsystem-size subsys) :initial-element nil) 417 | :for i :from 0 418 | :for b :across frame 419 | :for γ.b := (mapcar γ b) 420 | :for slot := (position-if (lambda (r) (find (list-minimum γ.b) r)) frame) 421 | :for ρ := (elt frame slot) 422 | :for π := (permuter ρ γ.b) 423 | :do (assert (group-element-p π group)) 424 | (setf (aref coord i) (funcall rank π)) 425 | :finally (return coord)))))))) 426 | 427 | ;;; Coordinates 428 | 429 | (defstruct (block-coordinate-transformation (:conc-name coord.) 430 | (:constructor %make-coord)) 431 | order 432 | rank ; GROUP -> INDEX 433 | ) 434 | 435 | (defun make-subsystem-transformations (subsys) 436 | (let* ((size (block-subsystem-size subsys)) 437 | (interblock-group (block-subsystem-interblock-group subsys)) 438 | (interblock-hom (block-subsystem-interblock-group-homomorphism subsys)) 439 | (intrablock-group (block-subsystem-intrablock-group subsys)) 440 | (intrablock-base (group-order intrablock-group)) 441 | (intrablock-spec (if (= 1 intrablock-base) nil (make-radix-spec intrablock-base size))) 442 | (intrablock-coord (if (null intrablock-spec) nil (intrablock-coordinate-function subsys)))) 443 | (multiple-value-bind (inter-rank inter-unrank) 444 | (group-element-rank-functions interblock-group) 445 | (declare (ignore inter-unrank)) 446 | (values 447 | ;; Interblock xform 448 | (%make-coord 449 | :order (group-order interblock-group) 450 | :rank (lambda (g) (funcall inter-rank (funcall interblock-hom g)))) 451 | ;; Intrablock xform 452 | (if (null intrablock-coord) 453 | (%make-coord 454 | :order 1 455 | :rank (lambda (g) 456 | (declare (ignore g)) 457 | 0)) 458 | (%make-coord 459 | :order (cardinality intrablock-spec) 460 | :rank (lambda (g) 461 | ;; We want to interpret this coordinate not as "the 462 | ;; block in position X undergoes a change in 463 | ;; orientation by Y", but rather "the block X 464 | ;; undergoes a change in orientation by Y". We do this 465 | ;; by putting all of the block orientation changes 466 | ;; back into place, using knowledge of the interblock 467 | ;; group we computed above. 468 | (let ((coord (funcall intrablock-coord g)) 469 | (block-perm (funcall interblock-hom g))) 470 | (rank intrablock-spec (permute (perm-inverse block-perm) coord)))) 471 | ;; :unrank (lambda (r) (unrank intrablock-spec r)) 472 | )))))) 473 | 474 | ;;; Examples? See block-subsystem-solver.lisp 475 | -------------------------------------------------------------------------------- /src/permutation-group.lisp: -------------------------------------------------------------------------------- 1 | ;;;; permutation-group.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2012-2018 Robert Smith 4 | 5 | (in-package #:cl-permutation) 6 | 7 | (defvar *perm-group-verbose* nil) 8 | 9 | ;;; A TRANSVERSAL SYSTEM (trans) is represented as an alist, which 10 | ;;; takes a K and returns a table which takes a J and returns 11 | ;;; sigma_kj. That is 12 | ;;; 13 | ;;; K -> (J -> sigma_kj) 14 | 15 | (defclass perm-group () 16 | ((element-size :initarg :element-size 17 | :accessor perm-group.element-size 18 | :documentation "The size of the elements of the group. This is a non-negative integer and may be larger than the true degree of the group.") 19 | (generators :initarg :generators 20 | :accessor perm-group.generators 21 | :documentation "A list of generators of the group.") 22 | (strong-generators :initarg :strong-generators 23 | :accessor perm-group.strong-generators 24 | :documentation "The strong generating set of the group. This is a vector mapping integers to lists of generators which generate the i'th stabilizer.") 25 | (transversal-system :initarg :transversal-system 26 | :accessor perm-group.transversal-system 27 | :documentation "The transversal system of the group. This is a vector mapping integers K to a table of sigmas SIGMA_K. Every permutation in the group can be represented by a product of permutations SIGMA_K * ... * SIGMA_2 * SIGMA_1.") 28 | (free-group :initarg :free-group 29 | :accessor perm-group.free-group 30 | :documentation "A free group corresponding to the given permutation group.") 31 | (factorization-generators :initarg :factorization-generators 32 | :accessor perm-group.factorization-generators 33 | :documentation "A vector whose length is the same length as the base of the group, whose values are vectors of free-group elements that are coset representatives of the stabilizer G^(i+1)/G^(i). This collection of generators is *also* a strong generating set. This is optionally computed with #'COMPUTE-FACTORIZATION-GENERATORS." 34 | :initform nil) 35 | (slp-context :initarg :slp-context 36 | :accessor perm-group.slp-context 37 | :documentation "SLPs corresponding to all sigmas and strong generators.")) 38 | (:documentation "Representation of a permutation group generated by a finite number of generators.")) 39 | 40 | (defun group-degree (group &key true) 41 | "What is the degree of the group GROUP? 42 | 43 | If TRUE is a true-value, then the true degree will be returned (i.e., the maximum non-fixed point index). For example, consider 44 | 45 | G = <(1 3 2 4 5)> 46 | 47 | then 48 | 49 | (group-degree G :true nil) ==> 5 [default] 50 | (group-degree G :true t) ==> 3." 51 | (if true 52 | (maximum (perm-group.generators group) :key #'perm-last-non-fixpoint) 53 | (perm-group.element-size group))) 54 | 55 | (defun group-identity (group) 56 | "Return the identity element of the group GROUP." 57 | (perm-identity (group-degree group :true nil))) 58 | 59 | ;;; Implementation of the group protocol. 60 | 61 | (defmethod identity-element ((g perm-group)) 62 | (group-identity g)) 63 | 64 | (defmethod compose ((g perm-group) a b) 65 | (perm-compose a b)) 66 | 67 | (defmethod inverse ((g perm-group) a) 68 | (perm-inverse a)) 69 | 70 | (defmethod generators ((g perm-group)) 71 | (copy-list (perm-group.generators g))) 72 | 73 | (defmethod num-generators ((g perm-group)) 74 | (length (perm-group.generators g))) 75 | 76 | (defmethod print-object ((group perm-group) stream) 77 | (print-unreadable-object (group stream :type t :identity nil) 78 | (format stream "of ~D generator~:p" (num-generators group)))) 79 | 80 | 81 | ;;;;;;;;;;;;;;; Transversal Systems and Schreier-Sims ;;;;;;;;;;;;;;;; 82 | 83 | (deftype transversal () 84 | ;; It could actually be (simple-array list (*)), but 85 | ;; we will want to use SVREF. While such a type would collapse into 86 | ;; SIMPLE-VECTOR in most implementations, we don't want to assume 87 | ;; such. 88 | ;; 89 | ;; Elements of the transversal are constructed by MAKE-SIGMA-TABLE. 90 | `simple-vector) 91 | 92 | (deftype sgs () 93 | ;; vector of lists of perms 94 | `simple-vector) 95 | 96 | (declaim (inline make-transversal)) 97 | (defun make-transversal (n) 98 | "Make a transversal of size N." 99 | (make-array n :initial-element nil)) 100 | 101 | (declaim (inline transversal-ref)) 102 | (defun transversal-ref (trans k) 103 | "Get the Kth element of the transversal TRANS. This is representative of all sigma_k." 104 | (declare (type transversal trans)) 105 | (svref trans (1- k))) 106 | 107 | (defun (setf transversal-ref) (new-value trans k) 108 | (declare (type transversal trans)) 109 | (setf (svref trans (1- k)) new-value)) 110 | 111 | (declaim (inline make-sgs)) 112 | (defun make-sgs (n) 113 | "Make a strong generating set of size N." 114 | (make-array n :initial-element nil)) 115 | 116 | (declaim (inline sgs-ref)) 117 | (defun sgs-ref (sgs k) 118 | (svref sgs (1- k))) 119 | 120 | (defun (setf sgs-ref) (new-value sgs k) 121 | (setf (svref sgs (1- k)) new-value)) 122 | 123 | (defun make-sigma-table (k &optional (identity (perm-identity k))) 124 | "Make a representation of sigma_K, initialized witk sigma_KK = identity. 125 | 126 | The optional argument IDENTITY allows the caller to provide the identity permutation for sigma_kk. 127 | 128 | This is represented as an alist mapping J to permutations sigma_KJ." 129 | (acons k identity nil)) 130 | 131 | ;;; SIGMAs are elements of the transversal system. A SIGMA is either 132 | ;;; NIL or some permutation that maps K to J. 133 | (defun sigma (trans k j) 134 | "Retrieve sigma_kj for the transversal system TRANS, or NIL if it doesn't exist." 135 | (let ((sigma_k (transversal-ref trans k))) 136 | (cdr (assoc j sigma_k)))) 137 | 138 | (defun (setf sigma) (new-value trans k j) 139 | (let* ((sigma_k (transversal-ref trans k)) 140 | (sigma_kj (assoc j sigma_k))) 141 | (if (null sigma_kj) 142 | (setf (transversal-ref trans k) (acons j new-value sigma_k)) 143 | (rplacd sigma_kj new-value))) 144 | new-value) 145 | 146 | (defun sigma-symbol (k j) 147 | "Return a symbol representing sigma_kj. This is used for perms that are added to the transversal system during group construction." 148 | (alexandria:format-symbol ':keyword "SIGMA_(~D,~D)" k j)) 149 | 150 | (defun tau-symbol () 151 | "Return a freshly made symbol for tau." 152 | (gensym "TAU-")) 153 | 154 | (defun reduce-over-trans-decomposition (f initial-value perm trans &optional (k (perm-size perm))) 155 | "Reduce F over the transversal decomposition of PERM within the transversal system TRANS. Return two values: 156 | 157 | 1. The result of folding over, or NIL if no decomposition exists. 158 | 2. NIL iff no decomposition exists. 159 | 160 | F is a function of three arguments: 161 | 162 | ACCUM: The \"accumulator\" argument. INITIAL-VALUE is the initial value of this argument. 163 | K, J : Two arguments representing the sigma. 164 | 165 | N.B.! The sigma_kj are visited in \"right-to-left\" compositional order. That is, if S1, S2, ..., Sk are visited sequentially, then PERM is the composition Sk * ... * S2 * S1." 166 | (labels ((next (perm k acc) 167 | (if (zerop k) 168 | (values acc t) 169 | (let* ((j (perm-eval perm k)) 170 | (sigma_kj (sigma trans k j))) 171 | (if (null sigma_kj) 172 | (values nil nil) 173 | (next (if (= j k) 174 | perm 175 | (perm-compose (perm-inverse sigma_kj) perm)) 176 | (1- k) 177 | (funcall f acc k j))))))) 178 | (declare (dynamic-extent #'next)) 179 | (next perm k initial-value))) 180 | 181 | (defun trans-decomposition (perm trans &optional (k (perm-size perm))) 182 | "Decompose PERM into a list of sigmas within the transversal system TRANS. The composition of the sigmas equals the original perm up to K. 183 | 184 | The sigma (SIGMA K J) is represented by the cons cell (K . J)." 185 | ;; XXX: Could avoid NREVERSE by collecting more cleverly. 186 | (flet ((collector (decomp k j) 187 | (acons k j decomp))) 188 | (declare (dynamic-extent #'collector)) 189 | (nreverse (reduce-over-trans-decomposition #'collector nil perm trans k)))) 190 | 191 | (defun trans-element-p (perm trans &optional (k (perm-size perm))) 192 | #+#:equivalent (not (null (trans-decomposition perm trans k))) 193 | (values 194 | (reduce-over-trans-decomposition 195 | (load-time-value (constantly t)) 196 | t 197 | perm 198 | trans 199 | k))) 200 | 201 | (defvar *context*) 202 | (setf (documentation '*context* 'variable) 203 | "Special variable used to hold the context being built up for a group.") 204 | 205 | (defvar *taus*) 206 | (setf (documentation '*taus* 'variable) 207 | "Special variable used to hold a mapping between permutation objects (by EQ) to a symbol (one generated by #'TAU-SYMBOL) which is referred to by the SLP context.") 208 | 209 | ;;; For #'ADD-GENERATOR and #'UPDATE-TRANSVERSAL: 210 | ;;; 211 | ;;; * PERM: the perm to introduce to the SGS and transversal system. 212 | ;;; 213 | ;;; * SGS: the strong generating set 214 | ;;; 215 | ;;; * TRANS: the transversal system 216 | ;;; 217 | ;;; * K: All points above K should be fixpoints. K is what is 218 | ;;; recursed on. 219 | ;;; 220 | ;;; * SLP: An SLP to construct PERM. Used for recording purposes. 221 | ;;; 222 | ;;; Both return an updated SGS and transversal system as two values. 223 | ;;; 224 | ;;; Both also use *CONTEXT* to record SLPs, which is expected to be 225 | ;;; bound to. This is indeed the case by the main entry point 226 | ;;; #'GENERATE-PERM-GROUP. 227 | 228 | ;;; Algorithm B from Knuth, with my own modifications. 229 | (defun add-generator (perm sgs trans k slp) 230 | ;; Add the perm to the SGS. 231 | (pushnew perm (sgs-ref sgs k)) 232 | 233 | ;; Generate a new tau for the perm, and remember it. 234 | (let ((t-sym (tau-symbol))) 235 | (setf (gethash perm *taus*) t-sym) 236 | (setf (symbol-assignment *context* t-sym) slp)) 237 | 238 | ;; Process the perm, adding it to the group structure. 239 | (let ((redo nil)) 240 | (loop 241 | (loop :for (j . s) :in (transversal-ref trans k) 242 | :for s-sym := (sigma-symbol k j) :do 243 | (dolist (tau (sgs-ref sgs k)) 244 | (let ((prod (perm-compose tau s))) 245 | (unless (trans-element-p prod trans) 246 | (let* ((t-sym (gethash tau *taus*)) 247 | (prod-slp (compose-slp (slp-symbol t-sym) 248 | (slp-symbol s-sym)))) 249 | (multiple-value-setq (sgs trans) 250 | (update-transversal prod sgs trans k prod-slp))) 251 | 252 | (setf redo t))))) 253 | 254 | ;; Break out? 255 | (unless redo 256 | (return-from add-generator (values sgs trans))) 257 | 258 | ;; Reset the REDO flag. 259 | (setf redo nil)))) 260 | 261 | ;;; Algorithm B from Knuth, with my own modifications. 262 | (defun update-transversal (perm sgs trans k slp) 263 | (let* ((j (perm-eval perm k)) 264 | (sigma (sigma trans k j))) 265 | (cond 266 | ((not (null sigma)) 267 | (let ((new-perm (%perm-compose-upto 268 | (perm-inverse sigma) 269 | perm 270 | (1- k)))) 271 | (if (trans-element-p new-perm trans (1- k)) 272 | (values sgs trans) 273 | (let ((new-perm-slp (compose-slp 274 | (invert-slp 275 | (slp-symbol (sigma-symbol k j))) 276 | slp))) 277 | (add-generator new-perm sgs trans (1- k) new-perm-slp))))) 278 | (t 279 | (setf (sigma trans k j) perm) 280 | (setf (symbol-assignment *context* (sigma-symbol k j)) 281 | slp) 282 | (values sgs trans))))) 283 | 284 | (defun generate-perm-group (generators) 285 | "Generate a permutation group generated by the list of permutations GENERATORS." 286 | (let* ((n (maximum generators :key 'perm-size)) 287 | (sgs (make-sgs n)) 288 | (trans (make-transversal n)) 289 | (fg (make-free-group (length generators))) 290 | (*context* (make-instance 'slp-context)) 291 | (*taus* (make-hash-table :test 'eq))) 292 | ;; Initialize TRANS to map sigma_KK: K -> (K -> Identity(K)). 293 | ;; 294 | ;; Also record their SLPs as (SLP-ELEMENT ). 295 | (loop :for k :from 1 :to n :do 296 | (setf (transversal-ref trans k) (make-sigma-table k)) 297 | (setf (symbol-assignment *context* (sigma-symbol k k)) 298 | (slp-element (identity-element fg)))) 299 | 300 | ;; Add the generators. 301 | ;; 302 | ;; We iterate through the generators of the induced free group 303 | ;; as well purely to record SLPs. We can then construct a 304 | ;; homomorphism from the free group to the perm group to 305 | ;; construct elements from their generators. 306 | (loop :for generator :in generators 307 | :for fg-generator :in (generators fg) 308 | :do (multiple-value-setq (sgs trans) 309 | (add-generator generator 310 | sgs 311 | trans 312 | n 313 | (slp-element fg-generator)))) 314 | 315 | ;; Return the group. 316 | (make-instance 'perm-group 317 | :element-size (maximum generators :key #'perm-size) 318 | :generators (copy-list generators) 319 | :strong-generators sgs 320 | :transversal-system trans 321 | :slp-context *context* 322 | :free-group fg))) 323 | 324 | (defun group-bsgs (perm-group) 325 | "Retrieve a base and associated strong generating set (BSGS) as two values respectively for the permutation group PERM-GROUP." 326 | (loop :with base := nil 327 | :with sgs := nil 328 | :for k :from 1 329 | :for k-generators :across (perm-group.strong-generators perm-group) 330 | :when k-generators :do 331 | (push k base) 332 | (push k-generators sgs) 333 | :finally (return (values base sgs)))) 334 | 335 | (defun group-from (generators-as-lists) 336 | "Generate a permutation group from a list of generators, which are represented as lists." 337 | (generate-perm-group (mapcar #'list-to-perm generators-as-lists))) 338 | 339 | ;;; TODO: Automatically try calculating size. 340 | (defun group-from-cycles (generators-as-cycles size) 341 | "Generate a permutation group from a list of generators, which are represented as cycles." 342 | (generate-perm-group (mapcar (lambda (c) 343 | (from-cycles c size)) 344 | generators-as-cycles))) 345 | 346 | (defun group-order (group) 347 | "Compute the order of the permutation group GROUP." 348 | (let ((transversals (perm-group.transversal-system group))) 349 | (product transversals :key #'length))) 350 | 351 | (defun group-element-p (perm group) 352 | "Decide if the permutation PERM is an element of the group GROUP." 353 | (trans-element-p perm (perm-group.transversal-system group))) 354 | 355 | (defun subgroup-p (group subgroup) 356 | "Is the group SUBGROUP a subgroup of GROUP?" 357 | (every (lambda (g) (group-element-p g group)) 358 | (generators subgroup))) 359 | 360 | (defun same-group-p (group1 group2) 361 | "Are the groups GROUP1 and GROUP2 the same (i.e., have the same permutation elements)?" 362 | (and (subgroup-p group1 group2) 363 | (subgroup-p group2 group1))) 364 | 365 | (defun normal-subgroup-p (group subgroup) 366 | "Is the group SUBGROUP a normal subgroup of GROUP?" 367 | (labels ((in-subgroup-p (x) 368 | (group-element-p x subgroup)) 369 | (normality-criterion (x y) 370 | ;; x in GROUP 371 | ;; y in SUBGROUP 372 | (let ((x-inv (perm-inverse x))) 373 | (and (in-subgroup-p (perm-compose x (perm-compose y x-inv))) 374 | (in-subgroup-p (perm-compose x-inv (perm-compose y x))))))) 375 | (and (subgroup-p group subgroup) 376 | (loop :for x :in (generators group) 377 | :always (loop :for y :in (generators subgroup) 378 | :always (normality-criterion x y)))))) 379 | 380 | ;;; XXX FIXME: Avoid consing here. 381 | (defun random-group-element (group) 382 | "Generate a random element of the group GROUP." 383 | (reduce #'perm-compose-flipped 384 | (perm-group.transversal-system group) 385 | :initial-value (group-identity group) 386 | :key (lambda (sigma_k) (cdr (random-element sigma_k))))) 387 | 388 | ;;; XXX: This can be made more efficient by directly reducing over, 389 | ;;; removing identities within the fold function. 390 | (defun transversal-decomposition (perm group &key remove-identities) 391 | "Decompose the permutation PERM into transversal sigmas of the group GROUP." 392 | (let ((decomp 393 | (trans-decomposition perm (perm-group.transversal-system group)))) 394 | (if (not remove-identities) 395 | decomp 396 | (delete-if (lambda (sigma) 397 | (= (car sigma) 398 | (cdr sigma))) 399 | decomp)))) 400 | 401 | 402 | ;;;;;;;;;;;;;;;;; Generator Decomposition Using SLPs ;;;;;;;;;;;;;;;;; 403 | 404 | ;;; These functions are for pedagogy. 405 | 406 | (defun free-group-generator-to-perm-group-generator (perm-group free-group-generator) 407 | "Convert the free group generator FREE-GROUP-GENERATOR to a generator within the perm group PERM-GROUP." 408 | (let ((i free-group-generator)) 409 | (cond 410 | ((zerop i) (group-identity perm-group)) 411 | ((plusp i) (elt (generators perm-group) (1- i))) 412 | ((minusp i) (perm-inverse 413 | (free-group-generator-to-perm-group-generator 414 | perm-group 415 | (- i))))))) 416 | 417 | ;; FIXME: We should improve this to use the stuff from 418 | ;; homomorphism.lisp, maybe. 419 | (defun free-group->perm-group-homomorphism (free-group perm-group) 420 | "Construct a homomorphism from the perm group PERM-GROUP's free group to elements of the perm group itself." 421 | (assert (= (num-generators free-group) 422 | (num-generators perm-group)) 423 | (free-group perm-group) 424 | "The free group and the perm group must have the ~ 425 | same number of generators.") 426 | ;; The perm group contains the free group. 427 | (let* ((n (num-generators perm-group)) 428 | (lookup-table (make-array (1+ (* 2 n)))) 429 | (degree (group-degree perm-group))) 430 | ;; Fill the lookup table. 431 | (setf (aref lookup-table n) (group-identity perm-group)) 432 | (loop :for i :from 1 :to n 433 | :for g :in (generators perm-group) 434 | :do (setf (aref lookup-table (- n i)) g 435 | (aref lookup-table (+ n i)) (perm-inverse g))) 436 | (assert (every (lambda (x) (= degree (perm-size x))) lookup-table)) 437 | ;; Produce an optimized lambda. 438 | (lambda (elts) 439 | (etypecase elts 440 | (integer (aref lookup-table (- n elts))) 441 | (list (cond 442 | ;; Do this case because it's identity. 443 | ((null elts) (aref lookup-table (- n 0))) 444 | ;; Do this case because it's no work. 445 | ((null (cdr elts)) (aref lookup-table (- n (first elts)))) 446 | ;; Do this case because it costs less to allocate. 447 | ((null (cddr elts)) (perm-compose (aref lookup-table (- n (first elts))) 448 | (aref lookup-table (- n (second elts))))) 449 | ;; Otherwise, we'll do this the best we can. 450 | (t 451 | (loop :with result-storage := (allocate-identity-vector degree) 452 | :with temp-storage := (allocate-perm-vector degree) 453 | :for i :in elts 454 | :for p := (perm.rep (aref lookup-table (- n i))) 455 | :do (%perm-compose-into/equal result-storage p temp-storage) 456 | (rotatef temp-storage result-storage) 457 | :finally (return (%make-perm result-storage)))))))))) 458 | 459 | (defun word-simplifier-for-perm-group (g) 460 | "Construct a simplifier for the permutation group G according to its free group." 461 | (check-type g perm-group) 462 | (let* ((n (num-generators g)) 463 | (phi (free-group->perm-group-homomorphism (perm-group.free-group g) g)) 464 | (orders (make-array (1+ n) :initial-element nil)) 465 | (comms (make-array (1+ n) :initial-element nil))) 466 | ;; Calculate the orders of the generators. 467 | (loop :for i :from 1 :to n 468 | :for g := (funcall phi i) 469 | :do (setf (aref orders i) (perm-order g))) 470 | ;; Calculate the commuting ones. 471 | (loop :for i :from 1 :to n 472 | :for g1 := (funcall phi i) 473 | :do (loop :for j :from (1+ i) :to n 474 | :for g2 := (funcall phi j) 475 | :when (commutesp g1 g2) 476 | :do (push j (aref comms i)) 477 | (push i (aref comms j)))) 478 | ;; Construct the simplifier. 479 | (word-simplifier orders comms))) 480 | 481 | (defun naive-generator-decomposition (perm group &key return-original-generators) 482 | "Compute the generator decomposition of the permutation PERM of the group GROUP. By default, return a sequence of free generators. 483 | 484 | If RETURN-ORIGINAL-GENERATORS is true, return the group's original generators as permutations. 485 | 486 | Note: The result is likely very long and inefficient." 487 | (let* ((d (transversal-decomposition perm group :remove-identities t)) 488 | (ctx (perm-group.slp-context group)) 489 | (fg (perm-group.free-group group)) 490 | (hom (free-group->perm-group-homomorphism fg group))) 491 | (labels ((to-sigma-symbol (tt) 492 | (sigma-symbol (car tt) (cdr tt))) 493 | (find-slp (tt) 494 | (symbol-assignment ctx (to-sigma-symbol tt))) 495 | (eval-slp (slp) 496 | (evaluate-slp fg ctx slp))) 497 | (mapcar (if return-original-generators hom #'identity) ; Free -> Perm 498 | (remove-if #'free-group-identity-p 499 | (loop :for di :in d 500 | :append (alexandria:ensure-list (eval-slp (find-slp di))))))))) 501 | -------------------------------------------------------------------------------- /src/4-list-algorithm.lisp: -------------------------------------------------------------------------------- 1 | ;;;; 4-list-algorithm.lisp 2 | ;;;; 3 | ;;;; Copyright (c) 2023 Robert Smith 4 | 5 | (in-package #:cl-permutation) 6 | 7 | (declaim (optimize speed (safety 1))) 8 | 9 | ;;;; This file implements the planning algorithm from the paper 10 | ;;;; "Planning and Learning in Permutation Groups" by Fiat, Moses, 11 | ;;;; Shamir, Shimshoni, and Tardos. In the paper, they call it a 12 | ;;;; "t-list algorithm", and their main example specialized to t=4. 13 | 14 | ;;; Sparse Array 15 | ;;; 16 | ;;; We use sparse arrays to implement the permutation trie 17 | ;;; (PERM-TRIE), since occupancy is generally very, very small. We 18 | ;;; save a lot of memory this way. 19 | 20 | (declaim (inline sparse-array-bitmap sparse-array-elements %make-sparse-array)) 21 | (defstruct (sparse-array (:constructor %make-sparse-array ())) 22 | ;;(bitmap 0 :type (and unsigned-byte fixnum)) 23 | (elements nil :type list)) 24 | #+sbcl (declaim (sb-ext:freeze-type sparse-array)) 25 | 26 | (declaim (inline sparse-array-count)) 27 | (defun sparse-array-count (sa) 28 | (length (sparse-array-elements sa)) 29 | ;;(logcount (sparse-array-bitmap sa)) 30 | ) 31 | 32 | (defun make-sparse-array (size) 33 | (declare (ignore size)) 34 | (%make-sparse-array) 35 | #+ig 36 | (%make-sparse-array (make-array (1+ size) :element-type 'bit :initial-element 0))) 37 | 38 | (declaim (inline sparse-array-singleton-p)) 39 | (defun sparse-array-singleton-p (sa) 40 | (null (cdr (sparse-array-elements sa)))) 41 | 42 | (declaim (inline assoc*)) 43 | (defun assoc* (i list) 44 | (declare (optimize speed (safety 0)) 45 | (type perm-element i) 46 | (type list list)) 47 | (loop :until (null list) :do 48 | (let ((x (pop list))) 49 | (declare (type (cons perm-element t) x)) 50 | (when (= i (car x)) 51 | (return-from assoc* x)))) 52 | nil) 53 | 54 | (declaim (inline raw-saref)) 55 | (defun raw-saref (sa n) 56 | (assoc* n (sparse-array-elements sa))) 57 | 58 | (defun saref (sa n) 59 | (declare (type sparse-array sa) 60 | (type perm-element n) 61 | (optimize speed (safety 0)) 62 | ) 63 | (cdr (raw-saref sa n)) 64 | #+ig 65 | (if (logbitp n (sparse-array-bitmap sa)) 66 | (cdr (raw-saref sa n)) 67 | nil)) 68 | 69 | (defun (setf saref) (new-value sa n) 70 | (let ((existing (raw-saref sa n))) 71 | (cond 72 | ((consp existing) 73 | (rplacd existing new-value)) 74 | (t 75 | (push (cons n new-value) (sparse-array-elements sa)) 76 | ;; (incf (sparse-array-count sa)) 77 | #+ig 78 | (setf (sparse-array-bitmap sa) 79 | (dpb 1 (byte 1 n) (sparse-array-bitmap sa))) 80 | new-value)))) 81 | 82 | ;;; Permutation Trie 83 | ;;; 84 | ;;; This is a data structure that associates a permutation with 85 | ;;; arbitrary data. It has the benefit that permutations can be 86 | ;;; visited in lexicographic order, and permutations overlap in 87 | ;;; memory. 88 | 89 | (defstruct (perm-trie (:constructor %make-perm-trie)) 90 | "A trie-like data structure to store permutations." 91 | (num-elements 0 :type (and fixnum unsigned-byte)) 92 | (perm-size 0 :type vector-size) 93 | root) 94 | 95 | (defmethod print-object ((object perm-trie) stream) 96 | (print-unreadable-object (object stream :type t :identity t) 97 | (format stream "~D perm~:P" (perm-trie-num-elements object)))) 98 | 99 | (defun occupancy (trie) 100 | (let ((histogram (make-array (1+ (perm-trie-perm-size trie)) :initial-element 0))) 101 | (labels ((tally (x) 102 | (typecase x 103 | (sparse-array 104 | (let ((present (sparse-array-count x))) 105 | (incf (aref histogram present)) 106 | (loop :for (i . y) :in (sparse-array-elements x) 107 | :do (tally y) 108 | ))) 109 | (otherwise 110 | nil)))) 111 | (tally (perm-trie-root trie)) 112 | (values histogram)))) 113 | 114 | (defun make-perm-trie (perm-size) 115 | (%make-perm-trie :num-elements 0 116 | :perm-size perm-size 117 | :root (make-sparse-array perm-size))) 118 | 119 | (defun perm-trie-ref (trie perm) 120 | (let ((size (perm-trie-perm-size trie))) 121 | (labels ((check (i node) 122 | (let ((point (perm-eval perm i))) 123 | (cond 124 | ((= i size) 125 | (let ((result (saref node point))) 126 | (and (not (null result)) 127 | (cdr result)))) 128 | (t 129 | (let ((next-node (saref node point))) 130 | (etypecase next-node 131 | (null nil) 132 | (sparse-array (check (1+ i) next-node)) 133 | (cons (if (perm= perm (car next-node)) 134 | (cdr next-node) 135 | nil))))))))) 136 | (check 1 (perm-trie-root trie))))) 137 | 138 | (defun ingest-perm (trie perm &key (value t) force ignore) 139 | (let ((size (perm-trie-perm-size trie))) 140 | (labels ((record (point node perm value) 141 | (incf (perm-trie-num-elements trie)) 142 | (setf (saref node point) (cons perm value))) 143 | (ingest (i node perm value) 144 | (let ((point (perm-eval perm i))) 145 | (cond 146 | ;; special case at the leaf 147 | ((= i size) 148 | (let ((old-value (saref node point))) 149 | (cond 150 | ((null old-value) 151 | (record point node perm value) 152 | value) 153 | (force 154 | (record point node perm value) 155 | value) 156 | (ignore 157 | nil) 158 | (t 159 | (error "Trying to overwrite existing value."))))) 160 | (t 161 | (let ((object-at-location (saref node point))) 162 | (etypecase object-at-location 163 | (null 164 | (record point node perm value) 165 | value) 166 | (sparse-array 167 | (ingest (1+ i) object-at-location perm value)) 168 | (cons 169 | (let ((old-perm (car object-at-location)) 170 | (old-value (cdr object-at-location))) 171 | (cond 172 | ((perm= perm old-perm) 173 | (cond 174 | (ignore 175 | nil) 176 | (force 177 | (rplacd object-at-location value)) 178 | (t 179 | (error "Trying to overwrite existing value.")))) 180 | (t 181 | (let ((next-node (make-sparse-array size))) 182 | (setf (saref node point) next-node) 183 | ;; don't double count 184 | (decf (perm-trie-num-elements trie)) 185 | (ingest (1+ i) next-node old-perm old-value) 186 | (ingest (1+ i) next-node perm value))))))))))))) 187 | (ingest 1 (perm-trie-root trie) perm value)))) 188 | 189 | (defun map-perm-trie (f trie &key re-order) 190 | ;; TODO: modify so that we can visit all elements *after* a particular one? 191 | "Visit the permutations of TRIE in lexicographic order. F should be a function taking two arguments: 192 | 193 | 1. The perm 194 | 195 | 2. The value associated with the perm. 196 | 197 | RE-ORDER is an optional argument, either a function or a perm that re-orders the children. 198 | 199 | For example, if SIZE = 10, then #[10 9 8 7 6 5 4 3 2 1] would traverse in reverse lexicographic order." 200 | 201 | (declare (optimize speed) 202 | (type function f)) 203 | (let* ((size (perm-trie-perm-size trie)) 204 | (max-depth size) 205 | (relabel (etypecase re-order 206 | (null #'identity) 207 | (perm (lambda (i) 208 | (unsafe/perm-eval re-order i))) 209 | (function re-order)))) 210 | (declare (type fixnum size)) 211 | (labels ((dfs (depth node) 212 | (declare (type fixnum depth)) 213 | (etypecase node 214 | (cons 215 | (funcall f (car node) (cdr node))) 216 | (sparse-array 217 | (cond 218 | ((= depth max-depth) 219 | (loop :for i :from 1 :to size 220 | :for x := (saref node (funcall relabel i)) 221 | :unless (null x) 222 | :do (funcall f (car x) (cdr x)))) 223 | (t 224 | (loop :for i :from 1 :to size 225 | :for x := (saref node (funcall relabel i)) 226 | :unless (null x) 227 | :do (dfs (1+ depth) x)))))))) 228 | (dfs 1 (perm-trie-root trie))))) 229 | 230 | (defun perm-trie-next-perm (trie perm &key (re-order 231 | (perm-identity (perm-trie-perm-size trie)))) 232 | "Find the lexicographic successor to a perm." 233 | (declare (optimize speed)) 234 | (assert (= (perm-size perm) (perm-trie-perm-size trie))) 235 | 236 | (let* ((size (perm-size perm)) 237 | (max-depth size)) 238 | (flet ((relabel (i) 239 | (unsafe/perm-eval re-order i))) 240 | (declare (inline relabel)) 241 | (labels ((search-at-depth (current-depth to-depth node path) 242 | (declare (type fixnum current-depth to-depth) 243 | (type sparse-array node)) 244 | (cond 245 | ((< current-depth to-depth) 246 | (let* ((next-index (unsafe/perm-eval perm current-depth)) 247 | (next (saref node next-index))) 248 | (etypecase next 249 | ;; We didn't actually find our target 250 | ;; perm. That's OK, we can still find the 251 | ;; successor to it. 252 | (null 253 | (bottom-up-dfs perm current-depth path)) 254 | ;; We found something... search above it 255 | ;; 256 | ;; XXX: check??????????????????????????????/ 257 | (cons 258 | (bottom-up-dfs perm current-depth path)) 259 | ;; We found the next node, keep descending. 260 | (sparse-array 261 | (search-at-depth 262 | (1+ current-depth) 263 | to-depth 264 | next 265 | (cons next path)))))) 266 | ;; We reached the node just above the leaf, start 267 | ;; searching here. 268 | (t 269 | (bottom-up-dfs perm current-depth path)))) 270 | 271 | (bottom-up-dfs (perm current-depth path) 272 | (loop :for node :in path 273 | :for depth :of-type fixnum := current-depth :then (1- depth) 274 | :do 275 | (loop :with skip := t 276 | :with point :of-type perm-element := (unsafe/perm-eval perm depth) 277 | :for i :of-type perm-element :from 1 :to size 278 | :for i* :of-type perm-element := (relabel i) 279 | :do (cond 280 | (skip 281 | ;; When we've reached our 282 | ;; point---which is 283 | ;; skipped---we can now stop 284 | ;; skipping. 285 | (when (= i* point) 286 | (setf skip nil))) 287 | (t 288 | (let ((next (saref node i*))) 289 | (dfs (1+ depth) next))))))) 290 | (dfs (depth node) 291 | (declare (type fixnum depth)) 292 | (etypecase node 293 | (null nil) 294 | (cons 295 | (return-from perm-trie-next-perm (car node))) 296 | (sparse-array 297 | (cond 298 | ((= depth max-depth) 299 | (if (sparse-array-singleton-p node) ;(= 1 (sparse-array-count node)) 300 | (return-from perm-trie-next-perm 301 | (cadar (sparse-array-elements node))) 302 | (loop :for i :of-type perm-element :from 1 :to size 303 | :for x := (saref node (relabel i)) 304 | :unless (null x) 305 | :do (return-from perm-trie-next-perm (car x))))) 306 | (t 307 | ;; TODO count optimization? 308 | (if nil ;(sparse-array-singleton-p node) ; (= 1 count) 309 | (dfs (1+ depth) (cdar (sparse-array-elements node))) 310 | (loop :for i :of-type perm-element :from 1 :to size 311 | :for x := (saref node (relabel i)) 312 | :unless (null x) 313 | :do (dfs (1+ depth) x))))))))) 314 | (search-at-depth 1 (1- size) (perm-trie-root trie) (list (perm-trie-root trie))) 315 | ;; If we reached here, we found nothing... 316 | nil)))) 317 | 318 | (defmacro do-perm-trie ((p v trie &key re-order) &body body) 319 | (let ((iter-trie (gensym "ITER-TRIE")) 320 | (trie-once (gensym "TRIE-ONCE"))) 321 | `(let ((,trie-once ,trie)) 322 | (flet ((,iter-trie (,p ,v) 323 | ,@body)) 324 | (declare (dynamic-extent #',iter-trie)) 325 | (map-perm-trie #',iter-trie ,trie-once :re-order ,re-order) 326 | nil)))) 327 | 328 | (defun collect-perm-trie (trie) 329 | (let ((elements nil)) 330 | (do-perm-trie (p v trie) 331 | (declare (ignore v)) 332 | (push p elements)) 333 | (nreverse elements))) 334 | 335 | ;;; should be equal to perm trie 336 | ;;; TODO make a test 337 | (defun collect-perm-trie2 (trie &key re-order) 338 | (loop :with node := (perm-trie-least trie :re-order re-order) 339 | :until (null node) 340 | :collect (prog1 node 341 | (setf node (perm-trie-next-perm trie node :re-order re-order))))) 342 | 343 | (defun perm-trie-least (trie &key re-order) 344 | (do-perm-trie (p v trie :re-order re-order) 345 | (return-from perm-trie-least (values p v)))) 346 | 347 | (defun schroeppel-shamir2 (l2-trie l1-trie) 348 | (let ((q (pq:make-pqueue #'perm<))) 349 | ;; Initialize the queue with minimums. 350 | (do-perm-trie (y wy l2-trie) 351 | (declare (ignore wy)) 352 | (let ((y-inv (perm-inverse y))) 353 | (let ((x (perm-trie-least l1-trie :re-order y-inv))) 354 | (pq:pqueue-push 355 | (list x y y-inv) 356 | (perm-compose y x) 357 | q)))) 358 | 359 | ;; Create an iterator over products of L1 and L2 360 | (labels ((iterator () 361 | (declare (optimize speed)) 362 | (when (pq:pqueue-empty-p q) 363 | (return-from iterator (values nil nil nil))) 364 | (multiple-value-bind (components yx) 365 | (pq:pqueue-pop q) 366 | (destructuring-bind (x y y-inv) components 367 | ;; update queue 368 | (let ((next-x (perm-trie-next-perm l1-trie x :re-order y-inv))) 369 | (when next-x 370 | (rplaca components next-x) ; save memory 371 | (pq:pqueue-push 372 | components 373 | (perm-compose y next-x) 374 | q))) 375 | ;; return our element 376 | (values yx y x))))) 377 | #'iterator))) 378 | 379 | (defun in-common?* (&rest args) 380 | (write-line "; profiling") 381 | (time ;sb-sprof:with-profiling (:reset t :mode :cpu :report :graph) 382 | (apply #'in-common? args))) 383 | 384 | (defun in-common? (a b &key (test '=) 385 | (compare '<) 386 | (join 'list) 387 | (return-immediately nil) 388 | (report-interval 100000) 389 | num-elements-1 390 | num-elements-2 391 | verbose 392 | (limit nil ;500000 393 | )) 394 | (let ((common nil) 395 | (lap (get-internal-real-time)) 396 | (count 2)) 397 | (multiple-value-bind (ax f2 f1) (funcall a) 398 | (multiple-value-bind (bx f4 f3) (funcall b) 399 | (loop 400 | (when (or (null ax) (null bx)) 401 | (return-from in-common? common)) 402 | (cond 403 | ((funcall test ax bx) 404 | (let ((result (funcall join f4 f3 f2 f1))) 405 | (when return-immediately 406 | (return-from in-common? result)) 407 | (push result common)) 408 | (setf (values ax f2 f1) (funcall a) 409 | (values bx f4 f3) (funcall b))) 410 | ((funcall compare ax bx) 411 | (setf (values ax f2 f1) (funcall a))) 412 | (t ; equiv. (funcall compare bx ax) 413 | (setf (values bx f4 f3) (funcall b)))) 414 | ;; Report some info. 415 | (incf count) 416 | (when (and verbose 417 | (plusp count) 418 | (zerop (mod count report-interval))) 419 | (let* ((elapsed-time (/ (- (get-internal-real-time) lap) internal-time-units-per-second)) 420 | (perms-per-sec (/ report-interval elapsed-time)) 421 | (total (+ num-elements-1 num-elements-2)) 422 | (remaining (- total count)) 423 | (hours-left (/ remaining perms-per-sec 60 60))) 424 | (multiple-value-bind (hours hour-fraction) (truncate hours-left 1) 425 | (format t "~&~:D: ~D sec @ ~:D perms/sec; ~3,4F% complete, eta ~D hour~:P ~D minute~:P~%" 426 | count 427 | (round elapsed-time) 428 | (round perms-per-sec) 429 | (* 100.0 (/ count total)) 430 | hours 431 | (round (* 60 hour-fraction)))) 432 | (setf lap (get-internal-real-time)))) 433 | (when (and limit (>= count limit)) 434 | (return-from in-common? common))))))) 435 | 436 | (defun transform-trie (f trie) 437 | (let ((new-trie (make-perm-trie (perm-trie-perm-size trie)))) 438 | (do-perm-trie (p v trie) 439 | (multiple-value-bind (new-p new-v) (funcall f p v) 440 | (ingest-perm new-trie new-p :value new-v))) 441 | new-trie)) 442 | 443 | ;;;; 2x2 444 | 445 | (defun generate-words-of-bounded-length (gens word-length) 446 | (let* ((size (loop :for g :in gens :maximize (perm-size g))) 447 | (trie (make-perm-trie size)) 448 | (id (perm-identity size))) 449 | (ingest-perm trie id :value nil) 450 | (labels ((f (max cur perm word) 451 | (loop :for i :from 1 452 | :for g :in gens 453 | :for p := (perm-compose g perm) 454 | :for w := (cons i word) 455 | :do (ingest-perm trie p :value w :ignore t) 456 | (when (< cur max) 457 | (f max (1+ cur) p w))))) 458 | (loop :for max :from 1 :to word-length :do (f max 1 id nil)) 459 | trie))) 460 | 461 | #+d 462 | (progn 463 | (defun 3x3-htm () 464 | (let* ((original (perm-group.generators (cl-permutation-examples:make-rubik-3x3))) 465 | (new (loop :for g :in original 466 | :collect (perm-expt g 1) 467 | :collect (perm-expt g 2) 468 | :collect (perm-expt g 3)))) 469 | (generate-perm-group new))) 470 | (defun scramble (group num-moves) 471 | (let ((s (group-identity group))) 472 | (loop :repeat num-moves :do 473 | (setf s (perm-compose (alexandria:random-elt (perm-group.generators group)) 474 | s))) 475 | s)) 476 | (defvar *3x3 (3x3-htm))) 477 | 478 | (defun test-ss (g &key group (wordlen 5)) 479 | (check-type group perm-group) 480 | (labels ((logout (string) 481 | (write-line string) 482 | (finish-output))) 483 | (let* ((gens (perm-group.generators group)) 484 | (free (perm-group.free-group group)) 485 | (free->2x2 (free-group->perm-group-homomorphism free group)) 486 | 487 | (L1 (progn 488 | (logout "; generating words") 489 | (generate-words-of-bounded-length gens wordlen))) 490 | (L2 L1) 491 | (L4 (progn 492 | (logout "; xform tries") 493 | (transform-trie (lambda (p v) 494 | (values (perm-inverse p) 495 | (reverse (mapcar #'- v)))) 496 | L1))) 497 | (L3 (transform-trie (lambda (p v) 498 | (values (perm-compose p g) v)) 499 | L4)) 500 | (L1L2 (progn 501 | (logout "; SS 1") 502 | (schroeppel-shamir2 L2 L1))) 503 | (L3L4 (progn 504 | (logout "; SS 2") 505 | (schroeppel-shamir2 L4 L3)))) 506 | (format t "~&|L_i| = ~:D~%" (perm-trie-num-elements L1)) 507 | (format t "~&2|L_i|^2 = ~:D~%" (* 2 (expt (perm-trie-num-elements L1) 2))) 508 | (format t "tally: ~A~%" (let* ((o (occupancy L1)) 509 | (s (reduce #'+ o))) 510 | (map 'vector (lambda (x) 511 | (* 100.0 (/ x s))) 512 | o))) 513 | 514 | (let ((solution (in-common?* L1L2 L3L4 :test #'perm= 515 | :compare #'perm< 516 | :join (lambda (f4 f3 f2 f1) 517 | ;; we can save 518 | ;; memory here if 519 | ;; L{1,2,3,4} are 520 | ;; essentially 521 | ;; equal up to 522 | ;; transformation. 523 | (revappend 524 | (mapcar #'- 525 | (append 526 | (perm-trie-ref L4 f4) 527 | '(0) 528 | (perm-trie-ref L3 f3))) 529 | (append 530 | '(0) 531 | (perm-trie-ref L2 f2) 532 | '(0) 533 | (perm-trie-ref L1 f1)))) 534 | 535 | ;:limit 5000000 536 | :report-interval 10000000 537 | :return-immediately t 538 | :num-elements-1 (* (perm-trie-num-elements L1) 539 | (perm-trie-num-elements L2)) 540 | :num-elements-2 (* (perm-trie-num-elements L3) 541 | (perm-trie-num-elements L4)) 542 | ))) 543 | (when solution 544 | (fresh-line) 545 | (format t "input : ~A~%" g) 546 | (let ((*print-pretty* nil)) 547 | (format t "* * * reconstruction: ~A~%" solution)) 548 | (values solution 549 | (perm-compose (perm-inverse (funcall free->2x2 solution)) 550 | g))))))) 551 | --------------------------------------------------------------------------------