{-# LANGUAGE RebindableSyntax #-}
{- |
Copyright    :   (c) Henning Thielemann 2006
Maintainer   :   numericprelude@henning-thielemann.de
Stability    :   provisional
Portability  :

Permutation represented by an array of the images.
-}

module MathObj.Permutation.Table where

import qualified MathObj.Permutation as Perm

import Data.Set(Set)
import qualified Data.Set as Set

import Data.Array(Array,(!),(//),Ix)
import qualified Data.Array as Array

import Data.List ((\\), nub, unfoldr, )

import Data.Tuple.HT (swap, )
import Data.Maybe.HT (toMaybe, )

import NumericPrelude.Base hiding (cycle)


type T i = Array i i


fromFunction :: (Ix i) =>
   (i, i) -> (i -> i) -> T i
fromFunction :: (i, i) -> (i -> i) -> T i
fromFunction (i, i)
rng i -> i
f =
   (i, i) -> [i] -> T i
forall i e. Ix i => (i, i) -> [e] -> Array i e
Array.listArray (i, i)
rng ((i -> i) -> [i] -> [i]
forall a b. (a -> b) -> [a] -> [b]
map i -> i
f ((i, i) -> [i]
forall a. Ix a => (a, a) -> [a]
Array.range (i, i)
rng))

toFunction :: (Ix i) => T i -> (i -> i)
toFunction :: T i -> i -> i
toFunction = (!)

{-
Create a permutation in table form
from any other permutation representation.
-}
fromPermutation :: (Ix i, Perm.C p) => p i -> T i
fromPermutation :: p i -> T i
fromPermutation p i
x =
   let rng :: (i, i)
rng = p i -> (i, i)
forall (p :: * -> *) i. (C p, Ix i) => p i -> (i, i)
Perm.domain p i
x
   in  (i, i) -> [i] -> T i
forall i e. Ix i => (i, i) -> [e] -> Array i e
Array.listArray (i, i)
rng ((i -> i) -> [i] -> [i]
forall a b. (a -> b) -> [a] -> [b]
map (p i -> i -> i
forall (p :: * -> *) i. (C p, Ix i) => p i -> i -> i
Perm.apply p i
x) ((i, i) -> [i]
forall a. Ix a => (a, a) -> [a]
Array.range (i, i)
rng))

fromCycles :: (Ix i) => (i, i) -> [[i]] -> T i
fromCycles :: (i, i) -> [[i]] -> T i
fromCycles (i, i)
rng = (T i -> [i] -> T i) -> T i -> [[i]] -> T i
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (([i] -> T i -> T i) -> T i -> [i] -> T i
forall a b c. (a -> b -> c) -> b -> a -> c
flip [i] -> T i -> T i
forall i. Ix i => [i] -> T i -> T i
cycle) ((i, i) -> T i
forall i. Ix i => (i, i) -> T i
identity (i, i)
rng)


identity :: (Ix i) => (i, i) -> T i
identity :: (i, i) -> T i
identity (i, i)
rng = (i, i) -> [i] -> T i
forall i e. Ix i => (i, i) -> [e] -> Array i e
Array.listArray (i, i)
rng ((i, i) -> [i]
forall a. Ix a => (a, a) -> [a]
Array.range (i, i)
rng)

cycle :: (Ix i) => [i] -> T i -> T i
cycle :: [i] -> T i -> T i
cycle [i]
cyc T i
p =
   T i
p T i -> [(i, i)] -> T i
forall i e. Ix i => Array i e -> [(i, e)] -> Array i e
// (i -> i -> (i, i)) -> [i] -> [i] -> [(i, i)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\i
i i
j -> (i
j,T i
pT i -> i -> i
forall i e. Ix i => Array i e -> i -> e
!i
i)) [i]
cyc ([i] -> [i]
forall a. [a] -> [a]
tail ([i]
cyc[i] -> [i] -> [i]
forall a. [a] -> [a] -> [a]
++[i]
cyc))

inverse :: (Ix i) => T i -> T i
inverse :: T i -> T i
inverse T i
p =
   let rng :: (i, i)
rng = T i -> (i, i)
forall i e. Array i e -> (i, i)
Array.bounds T i
p
   in  (i, i) -> [(i, i)] -> T i
forall i e. Ix i => (i, i) -> [(i, e)] -> Array i e
Array.array (i, i)
rng (((i, i) -> (i, i)) -> [(i, i)] -> [(i, i)]
forall a b. (a -> b) -> [a] -> [b]
map (i, i) -> (i, i)
forall a b. (a, b) -> (b, a)
swap (T i -> [(i, i)]
forall i e. Ix i => Array i e -> [(i, e)]
Array.assocs T i
p))

compose :: (Ix i) => T i -> T i -> T i
compose :: T i -> T i -> T i
compose T i
p T i
q =
   let pRng :: (i, i)
pRng = T i -> (i, i)
forall i e. Array i e -> (i, i)
Array.bounds T i
p
       qRng :: (i, i)
qRng = T i -> (i, i)
forall i e. Array i e -> (i, i)
Array.bounds T i
q
   in  if (i, i)
pRng(i, i) -> (i, i) -> Bool
forall a. Eq a => a -> a -> Bool
==(i, i)
qRng
         then (i -> i) -> T i -> T i
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (T i
pT i -> i -> i
forall i e. Ix i => Array i e -> i -> e
!) T i
q
         else [Char] -> T i
forall a. HasCallStack => [Char] -> a
error [Char]
"compose: ranges differ"
--                     ++ show pRng ++ " /= " ++ show qRng)


{- |
Extremely naïve algorithm
to generate a list of all elements in a group.
Should be replaced by a Schreier-Sims system
if this code is ever used for anything bigger than .. say ..
groups of order 512 or so.
-}
{-
Alternative to Data.Set.minView in GHC-6.6.
-}
choose :: Set a -> Maybe (a, Set a)
choose :: Set a -> Maybe (a, Set a)
choose Set a
set =
   Bool -> (a, Set a) -> Maybe (a, Set a)
forall a. Bool -> a -> Maybe a
toMaybe (Bool -> Bool
not (Set a -> Bool
forall a. Set a -> Bool
Set.null Set a
set)) (Set a -> (a, Set a)
forall a. Set a -> (a, Set a)
Set.deleteFindMin Set a
set)

closure :: (Ix i) => [T i] -> [T i]
closure :: [T i] -> [T i]
closure [] = []
closure generators :: [T i]
generators@(T i
gen:[T i]
_) =
   let genSet :: Set (T i)
genSet = [T i] -> Set (T i)
forall a. Ord a => [a] -> Set a
Set.fromList [T i]
generators
       idSet :: Set (T i)
idSet  = T i -> Set (T i)
forall a. a -> Set a
Set.singleton ((i, i) -> T i
forall i. Ix i => (i, i) -> T i
identity (T i -> (i, i)
forall i e. Array i e -> (i, i)
Array.bounds T i
gen))
       generate :: (Set (T i), Set (T i)) -> Maybe (T i, (Set (T i), Set (T i)))
generate (Set (T i)
registered, Set (T i)
candidates) =
          do (T i
cand, Set (T i)
remCands) <- Set (T i) -> Maybe (T i, Set (T i))
forall a. Set a -> Maybe (a, Set a)
choose Set (T i)
candidates
             let newCands :: Set (T i)
newCands =
                    (Set (T i) -> Set (T i) -> Set (T i))
-> Set (T i) -> Set (T i) -> Set (T i)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Set (T i) -> Set (T i) -> Set (T i)
forall a. Ord a => Set a -> Set a -> Set a
Set.difference Set (T i)
registered (Set (T i) -> Set (T i)) -> Set (T i) -> Set (T i)
forall a b. (a -> b) -> a -> b
$
                    (T i -> T i) -> Set (T i) -> Set (T i)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (T i -> T i -> T i
forall i. Ix i => T i -> T i -> T i
compose T i
cand) Set (T i)
genSet
             (T i, (Set (T i), Set (T i)))
-> Maybe (T i, (Set (T i), Set (T i)))
forall (m :: * -> *) a. Monad m => a -> m a
return (T i
cand, (Set (T i) -> Set (T i) -> Set (T i)
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set (T i)
registered Set (T i)
newCands,
                            Set (T i) -> Set (T i) -> Set (T i)
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set (T i)
remCands Set (T i)
newCands))
   in  ((Set (T i), Set (T i)) -> Maybe (T i, (Set (T i), Set (T i))))
-> (Set (T i), Set (T i)) -> [T i]
forall b a. (b -> Maybe (a, b)) -> b -> [a]
unfoldr (Set (T i), Set (T i)) -> Maybe (T i, (Set (T i), Set (T i)))
generate (Set (T i)
idSet, Set (T i)
idSet)

closureSlow :: (Ix i) => [T i] -> [T i]
closureSlow :: [T i] -> [T i]
closureSlow [] = []
closureSlow generators :: [T i]
generators@(T i
gen:[T i]
_) =
   let addElts :: [T i] -> [T i] -> [T i]
addElts [T i]
grp [] = [T i]
grp
       addElts [T i]
grp cands :: [T i]
cands@(T i
cand:[T i]
remCands) =
          let group' :: [T i]
group'   = [T i]
grp [T i] -> [T i] -> [T i]
forall a. [a] -> [a] -> [a]
++ [T i
cand]
              newCands :: [T i]
newCands = (T i -> T i) -> [T i] -> [T i]
forall a b. (a -> b) -> [a] -> [b]
map (T i -> T i -> T i
forall i. Ix i => T i -> T i -> T i
compose T i
cand) [T i]
generators
              cands' :: [T i]
cands'   = [T i] -> [T i]
forall a. Eq a => [a] -> [a]
nub ([T i]
remCands [T i] -> [T i] -> [T i]
forall a. [a] -> [a] -> [a]
++ [T i]
newCands) [T i] -> [T i] -> [T i]
forall a. Eq a => [a] -> [a] -> [a]
\\ ([T i]
grp [T i] -> [T i] -> [T i]
forall a. [a] -> [a] -> [a]
++ [T i]
cands)
          in  [T i] -> [T i] -> [T i]
addElts [T i]
group' [T i]
cands'
   in  [T i] -> [T i] -> [T i]
addElts [] [(i, i) -> T i
forall i. Ix i => (i, i) -> T i
identity (T i -> (i, i)
forall i e. Array i e -> (i, i)
Array.bounds T i
gen)]