module PermutationGroups where

import Array
import List

-- GROUP

class Group a where
  identity :: Int -> a
  isIdentity :: a -> Bool
  (*>) :: a -> a -> a     -- right multiplication
  inverse :: a -> a

conjugate g h = inverse h *> g *> h

prod gs = foldl1 (*>) gs


-- PERMUTATION

newtype Permutation = PL [Int] deriving (Eq, Ord, Read, Show)

x .^ (PL g) = g !! (x-1)

--instance Show Permutation where
--  show g = show (toCycles' g)
--  show g = "(" ++ (foldl1 (++) (map show g)) ++ ")"

instance Group Permutation where
  identity n = PL [1..n]
  isIdentity (PL xs) = all (\(i,j) -> i==j) (zip [1..] xs)
  (PL g) *> h = PL (map (.^ h) g)
  inverse (PL g) = PL (map snd (sort (zip g [1..])))

fromCycles cs = PL (map snd (sort pointActions))
  where
    pointActions = concat (map fromCycle cs)

fromCycle is = zip is (rotateL is)

fromCycles' n cs = PL (elems (array (1,n) [(i,i) | i <- [1..n]] // (concat (map fromCycle cs))))

findOrbit (PL permutation) elt =
  let buildOrbit os ps e = 
        if (elem e os) 
          then os
          else let ei = elemIndex e ps in 
                 case ei of
                   Nothing -> os
                   Just e' -> buildOrbit ([e] ++ os) ps (e'+1)
  in buildOrbit [] permutation elt

toCycles (PL permutation) =
  let getOrbits out [] per = out
      getOrbits out els per =
        let orbit = findOrbit per (head els)
            els' = els \\ orbit
        in getOrbits (out ++ [orbit]) els' per
  in getOrbits [] permutation (PL permutation)

rotateL (x:xs) = xs ++ [x]

saturateCycles :: [[Int]] -> Int -> [[Int]]
saturateCycles cs n = cs ++ ( group ( [1..n] \\ foldl1 (++) cs ) )

desaturateCycles cs = filter (\x -> length x > 1) cs

-- CGT ALGORITHMS

generateGroup generators = 
  let g0 = head generators
      i = g0 *> inverse g0
      addElts group [] gens = group
      addElts group cands gens = 
        let cand = take 1 cands
            group' = group ++ cand
            newcands = map (*> (head cand)) gens
            cands' = (tail cands) ++ (newcands \\ (group' ++ cands))
        in 
            addElts group' cands' gens
  in addElts [] [i] generators