-- |
-- Copyright   : Anders Claesson 2013
-- Maintainer  : Anders Claesson <anders.claesson@gmail.com>
--
-- Permutation diagrams, or permutations as monads.

module Sym.Permgram
    (
    -- * Data types
      Label
    , Permgram

    -- * Accessors
    , perm
    , label
    , size

    -- * Construct permgrams
    , permgram
    , inverse
    ) where

import Data.Ord
import Data.List
import Control.Monad
import Sym.Perm (Perm, unsafeAt)
import qualified Sym.Perm as P
import Data.Vector (Vector, (!))
import qualified Data.Vector as V

-- | The purpose of this data type is to assign labels to the indices of
-- a given permutation.
type Label a = Vector a

-- | A permgram consists of a permutation together with a label for each
-- index of the permutation.
data Permgram a = PGram {
      -- | The underlying permutation.
      forall a. Permgram a -> Perm
perm  :: Perm
      -- | The assignment of labels to indices.
    , forall a. Permgram a -> Label a
label :: Label a
    }

constituents :: Permgram a -> (Perm, [a])
constituents :: forall a. Permgram a -> (Perm, [a])
constituents (PGram Perm
v Label a
f) = (Perm
v, Label a -> [a]
forall a. Vector a -> [a]
V.toList Label a
f)

instance Show a => Show (Permgram a) where
    show :: Permgram a -> String
show Permgram a
w =
        let (Perm
v, [a]
ys) = Permgram a -> (Perm, [a])
forall a. Permgram a -> (Perm, [a])
constituents Permgram a
w
        in [String] -> String
unwords [String
"permgram", String
"(" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Perm -> String
forall a. Show a => a -> String
show Perm
v String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")", [a] -> String
forall a. Show a => a -> String
show [a]
ys]

instance Eq a => Eq (Permgram a) where
    Permgram a
u == :: Permgram a -> Permgram a -> Bool
== Permgram a
v = Permgram a -> (Perm, [a])
forall a. Permgram a -> (Perm, [a])
constituents Permgram a
u (Perm, [a]) -> (Perm, [a]) -> Bool
forall a. Eq a => a -> a -> Bool
== Permgram a -> (Perm, [a])
forall a. Permgram a -> (Perm, [a])
constituents Permgram a
v

instance Ord a => Ord (Permgram a) where
    compare :: Permgram a -> Permgram a -> Ordering
compare Permgram a
u Permgram a
v =
        case (Permgram a -> Int) -> Permgram a -> Permgram a -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Permgram a -> Int
forall a. Permgram a -> Int
size Permgram a
u Permgram a
v of
          Ordering
EQ -> (Permgram a -> (Perm, [a])) -> Permgram a -> Permgram a -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Permgram a -> (Perm, [a])
forall a. Permgram a -> (Perm, [a])
constituents Permgram a
u Permgram a
v
          Ordering
x  -> Ordering
x

-- | Construct a permgram from an underlying permutation and a list of
-- labels.
permgram :: Perm -> [a] -> Permgram a
permgram :: forall a. Perm -> [a] -> Permgram a
permgram Perm
v = Perm -> Label a -> Permgram a
forall a. Perm -> Label a -> Permgram a
PGram Perm
v (Label a -> Permgram a) -> ([a] -> Label a) -> [a] -> Permgram a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [a] -> Label a
forall a. Int -> [a] -> Vector a
V.fromListN (Perm -> Int
forall a. Size a => a -> Int
P.size Perm
v) ([a] -> Label a) -> ([a] -> [a]) -> [a] -> Label a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a]
forall a. HasCallStack => [a] -> [a]
cycle

-- | The inverse permgram. It's obtained by mirroring the permgram in
-- the /x=y/ diagonal.
inverse :: Permgram a -> Permgram a
inverse :: forall a. Permgram a -> Permgram a
inverse (PGram Perm
u Label a
f) = Perm -> Label a -> Permgram a
forall a. Perm -> Label a -> Permgram a
PGram ([Int] -> Perm
P.fromList [Int]
v) (Int -> [a] -> Label a
forall a. Int -> [a] -> Vector a
V.fromListN Int
n ((Int -> a) -> [Int] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (Label a
fLabel a -> Int -> a
forall a. Vector a -> Int -> a
!) [Int]
v))
    where
      v :: [Int]
v = ((Int, Int) -> Int) -> [(Int, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Int) -> Int
forall a b. (a, b) -> b
snd ([(Int, Int)] -> [Int])
-> ([(Int, Int)] -> [(Int, Int)]) -> [(Int, Int)] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, Int)] -> [(Int, Int)]
forall a. Ord a => [a] -> [a]
sort ([(Int, Int)] -> [Int]) -> [(Int, Int)] -> [Int]
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Perm -> [Int]
P.toList Perm
u) [Int
0..] -- v = u^{-1}
      n :: Int
n = Perm -> Int
forall a. Size a => a -> Int
P.size Perm
u

-- | The size of a permgram is the size of the underlying permutation.
size :: Permgram a -> Int
size :: forall a. Permgram a -> Int
size = Perm -> Int
forall a. Size a => a -> Int
P.size (Perm -> Int) -> (Permgram a -> Perm) -> Permgram a -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Permgram a -> Perm
forall a. Permgram a -> Perm
perm

instance Functor Permgram where
    fmap :: forall a b. (a -> b) -> Permgram a -> Permgram b
fmap a -> b
f Permgram a
w = Permgram a
w { label = V.map f (label w) }

instance Applicative Permgram where
    pure :: forall a. a -> Permgram a
pure a
x = Perm -> [a] -> Permgram a
forall a. Perm -> [a] -> Permgram a
permgram ([Int] -> Perm
P.fromList [Int
0]) [a
x]
    <*> :: forall a b. Permgram (a -> b) -> Permgram a -> Permgram b
(<*>) = Permgram (a -> b) -> Permgram a -> Permgram b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad Permgram where
    Permgram a
w >>= :: forall a b. Permgram a -> (a -> Permgram b) -> Permgram b
>>= a -> Permgram b
f  = Permgram (Permgram b) -> Permgram b
forall a. Permgram (Permgram a) -> Permgram a
joinPermgram (Permgram (Permgram b) -> Permgram b)
-> Permgram (Permgram b) -> Permgram b
forall a b. (a -> b) -> a -> b
$ (a -> Permgram b) -> Permgram a -> Permgram (Permgram b)
forall a b. (a -> b) -> Permgram a -> Permgram b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Permgram b
f Permgram a
w

joinPermgram :: Permgram (Permgram a) -> Permgram a
joinPermgram :: forall a. Permgram (Permgram a) -> Permgram a
joinPermgram w :: Permgram (Permgram a)
w@(PGram Perm
u Label (Permgram a)
f) = Perm -> Label a -> Permgram a
forall a. Perm -> Label a -> Permgram a
PGram ([Int] -> Perm
P.fromList [Int]
xs) (Int -> [a] -> Label a
forall a. Int -> [a] -> Vector a
V.fromListN Int
m [a]
ys)
    where
      len :: Vector Int
len = (Permgram a -> Int) -> Label (Permgram a) -> Vector Int
forall a b. (a -> b) -> Vector a -> Vector b
V.map Permgram a -> Int
forall a. Permgram a -> Int
size Label (Permgram a)
f
      m :: Int
m = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ Vector Int -> [Int]
forall a. Vector a -> [a]
V.toList Vector Int
len
      n :: Int
n = Permgram (Permgram a) -> Int
forall a. Permgram a -> Int
size Permgram (Permgram a)
w
      uInverse :: [Int]
uInverse = ((Int, Int) -> Int) -> [(Int, Int)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Int) -> Int
forall a b. (a, b) -> b
snd ([(Int, Int)] -> [Int])
-> ([(Int, Int)] -> [(Int, Int)]) -> [(Int, Int)] -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, Int)] -> [(Int, Int)]
forall a. Ord a => [a] -> [a]
sort ([(Int, Int)] -> [Int]) -> [(Int, Int)] -> [Int]
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Perm -> [Int]
P.toList Perm
u) [Int
0..]
      a :: Vector Int
a = Int -> [Int] -> Vector Int
forall a. Int -> [a] -> Vector a
V.fromListN Int
n ([Int] -> Vector Int) -> ([Int] -> [Int]) -> [Int] -> Vector Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Int -> Int) -> Int -> [Int] -> [Int]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Int
0 ([Int] -> Vector Int) -> [Int] -> Vector Int
forall a b. (a -> b) -> a -> b
$ (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Vector Int
lenVector Int -> Int -> Int
forall a. Vector a -> Int -> a
!) [Int]
uInverse
      ([Int]
xs, [a]
ys) = [(Int, a)] -> ([Int], [a])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Int, a)] -> ([Int], [a])) -> [(Int, a)] -> ([Int], [a])
forall a b. (a -> b) -> a -> b
$ do
        Int
i <- [Int
0..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
        let PGram Perm
v Label a
g = Label (Permgram a)
f Label (Permgram a) -> Int -> Permgram a
forall a. Vector a -> Int -> a
! Int
i
        let d :: Int
d = Vector Int
a Vector Int -> Int -> Int
forall a. Vector a -> Int -> a
! (Perm
u Perm -> Int -> Int
`unsafeAt` Int
i)
        [ (Int
d Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Perm
v Perm -> Int -> Int
`P.unsafeAt` Int
j, Label a
gLabel a -> Int -> a
forall a. Vector a -> Int -> a
!Int
j) | Int
j <- [Int
0 .. Vector Int
lenVector Int -> Int -> Int
forall a. Vector a -> Int -> a
!Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] ]