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

module MathObj.Permutation.CycleList.Check where

import qualified MathObj.Permutation.CycleList as PermCycle
import qualified MathObj.Permutation.Table     as PermTable
import qualified MathObj.Permutation           as Perm

import qualified Algebra.Monoid as Monoid
import Algebra.Monoid((<*>))

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

import NumericPrelude.Base hiding (cycle)

{- |
We shall make a little bit of a hack here, enabling us to use additive
or multiplicative syntax for groups as we wish by simply instantiating
Num with both operations corresponding to the group operation of the
permutation group we're studying
-}

{- |
There are quite a few way we could represent elements of permutation
groups: the images in a row, a list of the cycles, et.c. All of these
differ highly in how complex various operations end up being.
-}

newtype Cycle i = Cycle { Cycle i -> [i]
cycle :: [i] } deriving (ReadPrec [Cycle i]
ReadPrec (Cycle i)
Int -> ReadS (Cycle i)
ReadS [Cycle i]
(Int -> ReadS (Cycle i))
-> ReadS [Cycle i]
-> ReadPrec (Cycle i)
-> ReadPrec [Cycle i]
-> Read (Cycle i)
forall i. Read i => ReadPrec [Cycle i]
forall i. Read i => ReadPrec (Cycle i)
forall i. Read i => Int -> ReadS (Cycle i)
forall i. Read i => ReadS [Cycle i]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Cycle i]
$creadListPrec :: forall i. Read i => ReadPrec [Cycle i]
readPrec :: ReadPrec (Cycle i)
$creadPrec :: forall i. Read i => ReadPrec (Cycle i)
readList :: ReadS [Cycle i]
$creadList :: forall i. Read i => ReadS [Cycle i]
readsPrec :: Int -> ReadS (Cycle i)
$creadsPrec :: forall i. Read i => Int -> ReadS (Cycle i)
Read,Cycle i -> Cycle i -> Bool
(Cycle i -> Cycle i -> Bool)
-> (Cycle i -> Cycle i -> Bool) -> Eq (Cycle i)
forall i. Eq i => Cycle i -> Cycle i -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Cycle i -> Cycle i -> Bool
$c/= :: forall i. Eq i => Cycle i -> Cycle i -> Bool
== :: Cycle i -> Cycle i -> Bool
$c== :: forall i. Eq i => Cycle i -> Cycle i -> Bool
Eq)
data T i = Cons { T i -> (i, i)
range :: (i, i), T i -> [Cycle i]
cycles :: [Cycle i] }

{- |
Does not check whether the input values are in range.
-}
fromCycles :: (i, i) -> [[i]] -> T i
fromCycles :: (i, i) -> [[i]] -> T i
fromCycles (i, i)
rng = (i, i) -> [Cycle i] -> T i
forall i. (i, i) -> [Cycle i] -> T i
Cons (i, i)
rng ([Cycle i] -> T i) -> ([[i]] -> [Cycle i]) -> [[i]] -> T i
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([i] -> Cycle i) -> [[i]] -> [Cycle i]
forall a b. (a -> b) -> [a] -> [b]
map [i] -> Cycle i
forall i. [i] -> Cycle i
Cycle

toCycles :: T i -> [[i]]
toCycles :: T i -> [[i]]
toCycles = (Cycle i -> [i]) -> [Cycle i] -> [[i]]
forall a b. (a -> b) -> [a] -> [b]
map Cycle i -> [i]
forall i. Cycle i -> [i]
cycle ([Cycle i] -> [[i]]) -> (T i -> [Cycle i]) -> T i -> [[i]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T i -> [Cycle i]
forall i. T i -> [Cycle i]
cycles

toTable :: (Ix i) => T i -> PermTable.T i
toTable :: T i -> T i
toTable T i
x = (i, i) -> [[i]] -> T i
forall i. Ix i => (i, i) -> [[i]] -> T i
PermTable.fromCycles (T i -> (i, i)
forall i. T i -> (i, i)
range T i
x) (T i -> [[i]]
forall i. T i -> [[i]]
toCycles T i
x)

fromTable :: (Ix i) => PermTable.T i -> T i
fromTable :: T i -> T i
fromTable T i
x =
   let rng :: (i, i)
rng = T i -> (i, i)
forall i e. Array i e -> (i, i)
Array.bounds T i
x
   in  (i, i) -> [[i]] -> T i
forall i. (i, i) -> [[i]] -> T i
fromCycles (i, i)
rng ((i, i) -> (i -> i) -> [[i]]
forall i. Ix i => (i, i) -> (i -> i) -> T i
PermCycle.fromFunction (i, i)
rng (T i
xT i -> i -> i
forall i e. Ix i => Array i e -> i -> e
!))


errIncompat :: a
errIncompat :: a
errIncompat = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"Permutation.CycleList: Incompatible domains"

liftCmpTable2 :: (Ix i) =>
   (PermTable.T i -> PermTable.T i -> a) -> T i -> T i -> a
liftCmpTable2 :: (T i -> T i -> a) -> T i -> T i -> a
liftCmpTable2 T i -> T i -> a
f T i
x T i
y =
   if T i -> (i, i)
forall i. T i -> (i, i)
range T i
x (i, i) -> (i, i) -> Bool
forall a. Eq a => a -> a -> Bool
== T i -> (i, i)
forall i. T i -> (i, i)
range T i
y
     then T i -> T i -> a
f (T i -> T i
forall i. Ix i => T i -> T i
toTable T i
x) (T i -> T i
forall i. Ix i => T i -> T i
toTable T i
y)
     else a
forall a. a
errIncompat

liftTable2 :: (Ix i) =>
   (PermTable.T i -> PermTable.T i -> PermTable.T i) -> T i -> T i -> T i
liftTable2 :: (T i -> T i -> T i) -> T i -> T i -> T i
liftTable2 T i -> T i -> T i
f T i
x T i
y = T i -> T i
forall i. Ix i => T i -> T i
fromTable ((T i -> T i -> T i) -> T i -> T i -> T i
forall i a. Ix i => (T i -> T i -> a) -> T i -> T i -> a
liftCmpTable2 T i -> T i -> T i
f T i
x T i
y)


closure :: (Ix i) => [T i] -> [T i]
closure :: [T i] -> [T i]
closure = (T i -> T i) -> [T i] -> [T i]
forall a b. (a -> b) -> [a] -> [b]
map T i -> T i
forall i. Ix i => T i -> T i
fromTable ([T i] -> [T i]) -> ([T i] -> [T i]) -> [T i] -> [T i]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [T i] -> [T i]
forall i. Ix i => [T i] -> [T i]
PermTable.closure ([T i] -> [T i]) -> ([T i] -> [T i]) -> [T i] -> [T i]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (T i -> T i) -> [T i] -> [T i]
forall a b. (a -> b) -> [a] -> [b]
map T i -> T i
forall i. Ix i => T i -> T i
toTable


instance Perm.C T where
   domain :: T i -> (i, i)
domain    = T i -> (i, i)
forall i. T i -> (i, i)
range
   apply :: T i -> i -> i
apply   T i
p = ((T i -> [[i]]
forall i. T i -> [[i]]
toCycles T i
p) [[i]] -> i -> i
forall i. Eq i => T i -> i -> i
PermCycle.*>)
   inverse :: T i -> T i
inverse T i
p = (i, i) -> [[i]] -> T i
forall i. (i, i) -> [[i]] -> T i
fromCycles (T i -> (i, i)
forall i. T i -> (i, i)
range T i
p) ([[i]] -> [[i]]
forall i. T i -> T i
PermCycle.inverse (T i -> [[i]]
forall i. T i -> [[i]]
toCycles T i
p))

instance Show i => Show (Cycle i) where
   show :: Cycle i -> [Char]
show Cycle i
c = [Char]
"(" [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++
           ([[Char]] -> [Char]
unwords ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$
            (i -> [Char]) -> [i] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map i -> [Char]
forall a. Show a => a -> [Char]
show ([i] -> [[Char]]) -> [i] -> [[Char]]
forall a b. (a -> b) -> a -> b
$
            Cycle i -> [i]
forall i. Cycle i -> [i]
cycle Cycle i
c) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
")"

instance Show i => Show (T i) where
   show :: T i -> [Char]
show T i
p =
      case T i -> [Cycle i]
forall i. T i -> [Cycle i]
cycles T i
p of
         []  -> [Char]
"Id"
         [Cycle i]
cyc -> (Cycle i -> [Char]) -> [Cycle i] -> [Char]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Cycle i -> [Char]
forall a. Show a => a -> [Char]
show [Cycle i]
cyc


{- |
These instances may need more work
They involve converting a permutation to a table.
-}
instance Ix i => Eq (T i) where
   == :: T i -> T i -> Bool
(==)  =  (T i -> T i -> Bool) -> T i -> T i -> Bool
forall i a. Ix i => (T i -> T i -> a) -> T i -> T i -> a
liftCmpTable2 T i -> T i -> Bool
forall a. Eq a => a -> a -> Bool
(==)

instance Ix i => Ord (T i) where
   compare :: T i -> T i -> Ordering
compare  =  (T i -> T i -> Ordering) -> T i -> T i -> Ordering
forall i a. Ix i => (T i -> T i -> a) -> T i -> T i -> a
liftCmpTable2 T i -> T i -> Ordering
forall a. Ord a => a -> a -> Ordering
compare

{- Better: Group class and instances
instance Additive.C (T i) where
   p + q = p * q
   negate = inverse
   zero = one

instance Ring.C (T i) where
   (Cons op cp) * (Cons oq cq) = reduceCycles $
           Cons (max op oq) (cp ++ cq)
   one = Cons 1 []
-}

instance Ix i => Monoid.C (T i) where
   <*> :: T i -> T i -> T i
(<*>) = (T i -> T i -> T i) -> T i -> T i -> T i
forall i. Ix i => (T i -> T i -> T i) -> T i -> T i -> T i
liftTable2 T i -> T i -> T i
forall i. Ix i => T i -> T i -> T i
PermTable.compose
   idt :: T i
idt   = [Char] -> T i
forall a. HasCallStack => [Char] -> a
error [Char]
"There is no generic unit element"