-- | Permutations. 
--
-- See eg.:
-- Donald E. Knuth: The Art of Computer Programming, vol 4, pre-fascicle 2B.
--
-- WARNING: As of version 0.2.8.0, I changed the convention of how permutations
-- are represented internally. Also now they act on the /right/ by default!
--

{-# LANGUAGE CPP, BangPatterns, ScopedTypeVariables, GeneralizedNewtypeDeriving, FlexibleContexts #-}
module Math.Combinat.Permutations 
  ( -- * The Permutation type
    Permutation (..)
  , fromPermutation
  , lookupPermutation , (!!!)
  , permutationArray
  , permutationUArray
  , uarrayToPermutationUnsafe
  , isPermutation
  , maybePermutation
  , toPermutation
  , toPermutationUnsafe
  , toPermutationUnsafeN
  , permutationSize
    -- * Disjoint cycles
  , DisjointCycles (..)
  , fromDisjointCycles
  , disjointCyclesUnsafe
  , permutationToDisjointCycles
  , disjointCyclesToPermutation
  , numberOfCycles
  , concatPermutations
    -- * Queries
  , isIdentityPermutation
  , isReversePermutation
  , isEvenPermutation
  , isOddPermutation
  , signOfPermutation  
  , signValueOfPermutation  
  , module Math.Combinat.Sign   --  , Sign(..)
  , isCyclicPermutation
    -- * Some concrete permutations
  , transposition
  , transpositions
  , adjacentTransposition
  , adjacentTranspositions
  , cycleLeft
  , cycleRight
  , reversePermutation
    -- * Inversions
  , inversions
  , numberOfInversions
  , numberOfInversionsNaive
  , numberOfInversionsMerge
  , bubbleSort2
  , bubbleSort
    -- * Permutation groups
  , identityPermutation
  , inversePermutation
  , multiplyPermutation
  , productOfPermutations
  , productOfPermutations'
    -- * Action of the permutation group
  , permuteArray 
  , permuteList
  , permuteArrayLeft , permuteArrayRight
  , permuteListLeft  , permuteListRight
    -- * Sorting
  , sortingPermutationAsc 
  , sortingPermutationDesc
    -- * ASCII drawing
  , asciiPermutation
  , asciiDisjointCycles
  , twoLineNotation 
  , inverseTwoLineNotation
  , genericTwoLineNotation
    -- * List of permutations
  , permutations
  , _permutations
  , permutationsNaive
  , _permutationsNaive
  , countPermutations
    -- * Random permutations
  , randomPermutation
  , _randomPermutation
  , randomCyclicPermutation
  , _randomCyclicPermutation
  , randomPermutationDurstenfeld
  , randomCyclicPermutationSattolo
    -- * Multisets
  , permuteMultiset
  , countPermuteMultiset
  , fasc2B_algorithm_L
  ) 
  where

--------------------------------------------------------------------------------

import Control.Monad
import Control.Monad.ST

import Data.List hiding ( permutations )
import Data.Ord ( comparing )

import Data.Array (Array)
import Data.Array.ST
import Data.Array.Unboxed
import Data.Array.IArray
import Data.Array.MArray
import Data.Array.Unsafe

import Data.Vector.Compact.WordVec ( WordVec )
import qualified Data.Vector.Compact.WordVec as V

import Math.Combinat.ASCII
import Math.Combinat.Classes
import Math.Combinat.Helper
import Math.Combinat.Sign
import Math.Combinat.Numbers ( factorial , binomial )

import System.Random

--------------------------------------------------------------------------------
-- WordVec helpers

toUArray :: WordVec -> UArray Int Int
toUArray :: WordVec -> UArray Int Int
toUArray WordVec
vec = (Int, Int) -> [Int] -> UArray Int Int
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (Int
1,Int
n) ((Word -> Int) -> [Word] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Word] -> [Int]) -> [Word] -> [Int]
forall a b. (a -> b) -> a -> b
$ WordVec -> [Word]
V.toList WordVec
vec) where n :: Int
n = WordVec -> Int
V.vecLen WordVec
vec

fromUArray :: UArray Int Int -> WordVec
fromUArray :: UArray Int Int -> WordVec
fromUArray UArray Int Int
arr = Int -> [Int] -> WordVec
fromPermListN Int
n ((Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ UArray Int Int -> [Int]
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
elems UArray Int Int
arr) where
  (Int
1,Int
n) = UArray Int Int -> (Int, Int)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds UArray Int Int
arr

-- | maximum = length
fromPermListN :: Int -> [Int] -> WordVec
fromPermListN :: Int -> [Int] -> WordVec
fromPermListN Int
n [Int]
perm = Shape -> [Word] -> WordVec
V.fromList' Shape
shape ((Int -> Word) -> [Int] -> [Word]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral [Int]
perm) where
  shape :: Shape
shape = Int -> Int -> Shape
V.Shape Int
n Int
bits
  bits :: Int
bits  = Word -> Int
V.bitsNeededFor (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n :: Word)

fromPermList :: [Int] -> WordVec
fromPermList :: [Int] -> WordVec
fromPermList [Int]
perm = [Word] -> WordVec
V.fromList ((Int -> Word) -> [Int] -> [Word]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral [Int]
perm)

(.!) :: WordVec -> Int -> Int
.! :: WordVec -> Int -> Int
(.!) WordVec
vec Int
idx = Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> WordVec -> Word
V.unsafeIndex (Int
idxInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) WordVec
vec)

_elems :: WordVec -> [Int]
_elems :: WordVec -> [Int]
_elems = (Word -> Int) -> [Word] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([Word] -> [Int]) -> (WordVec -> [Word]) -> WordVec -> [Int]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WordVec -> [Word]
V.toList

_assocs :: WordVec -> [(Int,Int)]
_assocs :: WordVec -> [(Int, Int)]
_assocs WordVec
vec = [Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] (WordVec -> [Int]
_elems WordVec
vec)

_bound :: WordVec -> Int
_bound :: WordVec -> Int
_bound = WordVec -> Int
V.vecLen

{- 
-- the old internal representation (UArray Int Int)

_elems :: UArray Int Int -> [Int]
_elems = elems

_assocs :: UArray Int Int -> [(Int,Int)]
_assocs = elems

_bound :: UArray Int Int -> Int
_bound = snd . bounds
-}


toPermN :: Int -> [Int] -> Permutation
toPermN :: Int -> [Int] -> Permutation
toPermN Int
n [Int]
xs = WordVec -> Permutation
Permutation (Int -> [Int] -> WordVec
fromPermListN Int
n [Int]
xs)

--------------------------------------------------------------------------------
-- * Types

-- | A permutation. Internally it is an (compact) vector 
-- of the integers @[1..n]@.
--
-- If this array of integers is @[p1,p2,...,pn]@, then in two-line 
-- notations, that represents the permutation
--
-- > ( 1  2  3  ... n  )
-- > ( p1 p2 p3 ... pn )
--
-- That is, it is the permutation @sigma@ whose (right) action on the set @[1..n]@ is
--
-- > sigma(1) = p1
-- > sigma(2) = p2 
-- > ...
--
-- (NOTE: this changed at version 0.2.8.0!)
--
newtype Permutation = Permutation WordVec deriving (Permutation -> Permutation -> Bool
(Permutation -> Permutation -> Bool)
-> (Permutation -> Permutation -> Bool) -> Eq Permutation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Permutation -> Permutation -> Bool
$c/= :: Permutation -> Permutation -> Bool
== :: Permutation -> Permutation -> Bool
$c== :: Permutation -> Permutation -> Bool
Eq,Eq Permutation
Eq Permutation
-> (Permutation -> Permutation -> Ordering)
-> (Permutation -> Permutation -> Bool)
-> (Permutation -> Permutation -> Bool)
-> (Permutation -> Permutation -> Bool)
-> (Permutation -> Permutation -> Bool)
-> (Permutation -> Permutation -> Permutation)
-> (Permutation -> Permutation -> Permutation)
-> Ord Permutation
Permutation -> Permutation -> Bool
Permutation -> Permutation -> Ordering
Permutation -> Permutation -> Permutation
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Permutation -> Permutation -> Permutation
$cmin :: Permutation -> Permutation -> Permutation
max :: Permutation -> Permutation -> Permutation
$cmax :: Permutation -> Permutation -> Permutation
>= :: Permutation -> Permutation -> Bool
$c>= :: Permutation -> Permutation -> Bool
> :: Permutation -> Permutation -> Bool
$c> :: Permutation -> Permutation -> Bool
<= :: Permutation -> Permutation -> Bool
$c<= :: Permutation -> Permutation -> Bool
< :: Permutation -> Permutation -> Bool
$c< :: Permutation -> Permutation -> Bool
compare :: Permutation -> Permutation -> Ordering
$ccompare :: Permutation -> Permutation -> Ordering
$cp1Ord :: Eq Permutation
Ord) -- ,Show,Read)

instance Show Permutation where
  showsPrec :: Int -> Permutation -> ShowS
showsPrec Int
d (Permutation WordVec
arr) 
    = Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10)  
    (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ String -> ShowS
showString String
"toPermutation " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Int] -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 (WordVec -> [Int]
_elems WordVec
arr)       -- app_prec = 10

instance Read Permutation where
  readsPrec :: Int -> ReadS Permutation
readsPrec Int
d String
r = Bool -> ReadS Permutation -> ReadS Permutation
forall a. Bool -> ReadS a -> ReadS a
readParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) ReadS Permutation
fun String
r where
    fun :: ReadS Permutation
fun String
r = [ ([Int] -> Permutation
toPermutation [Int]
p,String
t) 
            | (String
"toPermutation",String
s) <- ReadS String
lex String
r
            , ([Int]
p,String
t) <- Int -> ReadS [Int]
forall a. Read a => Int -> ReadS a
readsPrec Int
11 String
s                              -- app_prec = 10
            ] 

instance DrawASCII Permutation where
  ascii :: Permutation -> ASCII
ascii = Permutation -> ASCII
asciiPermutation

-- | Disjoint cycle notation for permutations. Internally it is @[[Int]]@.
--
-- The cycles are to be understood as follows: a cycle @[c1,c2,...,ck]@ means
-- the permutation
--
-- > ( c1 c2 c3 ... ck )
-- > ( c2 c3 c4 ... c1 )
--
newtype DisjointCycles = DisjointCycles [[Int]] deriving (DisjointCycles -> DisjointCycles -> Bool
(DisjointCycles -> DisjointCycles -> Bool)
-> (DisjointCycles -> DisjointCycles -> Bool) -> Eq DisjointCycles
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DisjointCycles -> DisjointCycles -> Bool
$c/= :: DisjointCycles -> DisjointCycles -> Bool
== :: DisjointCycles -> DisjointCycles -> Bool
$c== :: DisjointCycles -> DisjointCycles -> Bool
Eq,Eq DisjointCycles
Eq DisjointCycles
-> (DisjointCycles -> DisjointCycles -> Ordering)
-> (DisjointCycles -> DisjointCycles -> Bool)
-> (DisjointCycles -> DisjointCycles -> Bool)
-> (DisjointCycles -> DisjointCycles -> Bool)
-> (DisjointCycles -> DisjointCycles -> Bool)
-> (DisjointCycles -> DisjointCycles -> DisjointCycles)
-> (DisjointCycles -> DisjointCycles -> DisjointCycles)
-> Ord DisjointCycles
DisjointCycles -> DisjointCycles -> Bool
DisjointCycles -> DisjointCycles -> Ordering
DisjointCycles -> DisjointCycles -> DisjointCycles
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: DisjointCycles -> DisjointCycles -> DisjointCycles
$cmin :: DisjointCycles -> DisjointCycles -> DisjointCycles
max :: DisjointCycles -> DisjointCycles -> DisjointCycles
$cmax :: DisjointCycles -> DisjointCycles -> DisjointCycles
>= :: DisjointCycles -> DisjointCycles -> Bool
$c>= :: DisjointCycles -> DisjointCycles -> Bool
> :: DisjointCycles -> DisjointCycles -> Bool
$c> :: DisjointCycles -> DisjointCycles -> Bool
<= :: DisjointCycles -> DisjointCycles -> Bool
$c<= :: DisjointCycles -> DisjointCycles -> Bool
< :: DisjointCycles -> DisjointCycles -> Bool
$c< :: DisjointCycles -> DisjointCycles -> Bool
compare :: DisjointCycles -> DisjointCycles -> Ordering
$ccompare :: DisjointCycles -> DisjointCycles -> Ordering
$cp1Ord :: Eq DisjointCycles
Ord,Int -> DisjointCycles -> ShowS
[DisjointCycles] -> ShowS
DisjointCycles -> String
(Int -> DisjointCycles -> ShowS)
-> (DisjointCycles -> String)
-> ([DisjointCycles] -> ShowS)
-> Show DisjointCycles
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DisjointCycles] -> ShowS
$cshowList :: [DisjointCycles] -> ShowS
show :: DisjointCycles -> String
$cshow :: DisjointCycles -> String
showsPrec :: Int -> DisjointCycles -> ShowS
$cshowsPrec :: Int -> DisjointCycles -> ShowS
Show,ReadPrec [DisjointCycles]
ReadPrec DisjointCycles
Int -> ReadS DisjointCycles
ReadS [DisjointCycles]
(Int -> ReadS DisjointCycles)
-> ReadS [DisjointCycles]
-> ReadPrec DisjointCycles
-> ReadPrec [DisjointCycles]
-> Read DisjointCycles
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [DisjointCycles]
$creadListPrec :: ReadPrec [DisjointCycles]
readPrec :: ReadPrec DisjointCycles
$creadPrec :: ReadPrec DisjointCycles
readList :: ReadS [DisjointCycles]
$creadList :: ReadS [DisjointCycles]
readsPrec :: Int -> ReadS DisjointCycles
$creadsPrec :: Int -> ReadS DisjointCycles
Read)

fromPermutation :: Permutation -> [Int]
fromPermutation :: Permutation -> [Int]
fromPermutation (Permutation WordVec
ar) = WordVec -> [Int]
_elems WordVec
ar

permutationUArray :: Permutation -> UArray Int Int
permutationUArray :: Permutation -> UArray Int Int
permutationUArray (Permutation WordVec
ar) = WordVec -> UArray Int Int
toUArray WordVec
ar

permutationArray :: Permutation -> Array Int Int
permutationArray :: Permutation -> Array Int Int
permutationArray (Permutation WordVec
ar) = (Int, Int) -> [Int] -> Array Int Int
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (Int
1,Int
n) (WordVec -> [Int]
_elems WordVec
ar) where
  n :: Int
n = WordVec -> Int
_bound WordVec
ar

-- | Assumes that the input is a permutation of the numbers @[1..n]@.
toPermutationUnsafe :: [Int] -> Permutation
toPermutationUnsafe :: [Int] -> Permutation
toPermutationUnsafe [Int]
xs = WordVec -> Permutation
Permutation ([Int] -> WordVec
fromPermList [Int]
xs) 

-- | This is faster than 'toPermutationUnsafe', but you need to supply @n@.
toPermutationUnsafeN :: Int -> [Int] -> Permutation
toPermutationUnsafeN :: Int -> [Int] -> Permutation
toPermutationUnsafeN Int
n [Int]
xs = WordVec -> Permutation
Permutation (Int -> [Int] -> WordVec
fromPermListN Int
n [Int]
xs) 

-- | Note: Indexing starts from 1.
uarrayToPermutationUnsafe :: UArray Int Int -> Permutation
uarrayToPermutationUnsafe :: UArray Int Int -> Permutation
uarrayToPermutationUnsafe = WordVec -> Permutation
Permutation (WordVec -> Permutation)
-> (UArray Int Int -> WordVec) -> UArray Int Int -> Permutation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UArray Int Int -> WordVec
fromUArray

-- | Checks whether the input is a permutation of the numbers @[1..n]@.
isPermutation :: [Int] -> Bool
isPermutation :: [Int] -> Bool
isPermutation [Int]
xs = (UArray Int Int
arUArray Int Int -> Int -> Int
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
!Int
0 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [ UArray Int Int
arUArray Int Int -> Int -> Int
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
!Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 | Int
j<-[Int
1..Int
n] ] where
  n :: Int
n = [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
xs
  -- the zero index is an unidiomatic hack
  ar :: UArray Int Int
ar = ((Int -> Int -> Int)
-> Int -> (Int, Int) -> [(Int, Int)] -> UArray Int Int
forall (a :: * -> * -> *) e i e'.
(IArray a e, Ix i) =>
(e -> e' -> e) -> e -> (i, i) -> [(i, e')] -> a i e
accumArray Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Int
0 (Int
0,Int
n) ([(Int, Int)] -> UArray Int Int) -> [(Int, Int)] -> UArray Int Int
forall a b. (a -> b) -> a -> b
$ (Int -> (Int, Int)) -> [Int] -> [(Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map Int -> (Int, Int)
f [Int]
xs) :: UArray Int Int
  f :: Int -> (Int,Int)
  f :: Int -> (Int, Int)
f !Int
j = if Int
jInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
1 Bool -> Bool -> Bool
|| Int
jInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
n then (Int
0,Int
1) else (Int
j,Int
1)

-- | Checks whether the input is a permutation of the numbers @[1..n]@.
maybePermutation :: [Int] -> Maybe Permutation
maybePermutation :: [Int] -> Maybe Permutation
maybePermutation [Int]
input = (forall s. ST s (Maybe Permutation)) -> Maybe Permutation
forall a. (forall s. ST s a) -> a
runST forall s. ST s (Maybe Permutation)
action where
  n :: Int
n = [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
input
  action :: forall s. ST s (Maybe Permutation)
  action :: ST s (Maybe Permutation)
action = do
    STUArray s Int Int
ar <- (Int, Int) -> Int -> ST s (STUArray s Int Int)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Int
1,Int
n) Int
0 :: ST s (STUArray s Int Int)
    let go :: [Int] -> m (Maybe Permutation)
go []     = Maybe Permutation -> m (Maybe Permutation)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Permutation -> m (Maybe Permutation))
-> Maybe Permutation -> m (Maybe Permutation)
forall a b. (a -> b) -> a -> b
$ Permutation -> Maybe Permutation
forall a. a -> Maybe a
Just ([Int] -> Permutation
toPermutationUnsafe [Int]
input)
        go (Int
j:[Int]
js) = if Int
jInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
1 Bool -> Bool -> Bool
|| Int
jInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
n 
          then Maybe Permutation -> m (Maybe Permutation)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Permutation
forall a. Maybe a
Nothing
          else do
            Int
z <- STUArray s Int Int -> Int -> m Int
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Int
ar Int
j
            STUArray s Int Int -> Int -> Int -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int
ar Int
j (Int
zInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
            if Int
zInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0 then [Int] -> m (Maybe Permutation)
go [Int]
js
                    else Maybe Permutation -> m (Maybe Permutation)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Permutation
forall a. Maybe a
Nothing               
    [Int] -> ST s (Maybe Permutation)
forall (m :: * -> *).
MArray (STUArray s) Int m =>
[Int] -> m (Maybe Permutation)
go [Int]
input
    
-- | Checks the input.
toPermutation :: [Int] -> Permutation
toPermutation :: [Int] -> Permutation
toPermutation [Int]
xs = case [Int] -> Maybe Permutation
maybePermutation [Int]
xs of
  Just Permutation
p  -> Permutation
p
  Maybe Permutation
Nothing -> String -> Permutation
forall a. HasCallStack => String -> a
error String
"toPermutation: not a permutation"

-- | Returns @n@, where the input is a permutation of the numbers @[1..n]@
permutationSize :: Permutation -> Int
permutationSize :: Permutation -> Int
permutationSize (Permutation WordVec
ar) = WordVec -> Int
_bound WordVec
ar

-- | Returns the image @sigma(k)@ of @k@ under the permutation @sigma@.
-- 
-- Note: we don't check the bounds! It may even crash if you index out of bounds!
lookupPermutation :: Permutation -> Int -> Int
lookupPermutation :: Permutation -> Int -> Int
lookupPermutation (Permutation WordVec
ar) Int
idx = WordVec
ar WordVec -> Int -> Int
.! Int
idx

-- infix 8 !!!

-- | Infix version of 'lookupPermutation'
(!!!) :: Permutation -> Int -> Int
!!! :: Permutation -> Int -> Int
(!!!) (Permutation WordVec
ar) Int
idx = WordVec
ar WordVec -> Int -> Int
.! Int
idx

instance HasWidth Permutation where
  width :: Permutation -> Int
width = Permutation -> Int
permutationSize

-- | Checks whether the permutation is the identity permutation
isIdentityPermutation :: Permutation -> Bool
isIdentityPermutation :: Permutation -> Bool
isIdentityPermutation (Permutation WordVec
ar) = (WordVec -> [Int]
_elems WordVec
ar [Int] -> [Int] -> Bool
forall a. Eq a => a -> a -> Bool
== [Int
1..Int
n]) where
  n :: Int
n = WordVec -> Int
_bound WordVec
ar

-- | Given a permutation of @n@ and a permutation of @m@, we return
-- a permutation of @n+m@ resulting by putting them next to each other.
-- This should satisfy
--
-- > permuteList p1 xs ++ permuteList p2 ys == permuteList (concatPermutations p1 p2) (xs++ys)
--
concatPermutations :: Permutation -> Permutation -> Permutation 
concatPermutations :: Permutation -> Permutation -> Permutation
concatPermutations Permutation
perm1 Permutation
perm2 = [Int] -> Permutation
toPermutationUnsafe [Int]
list where
  n :: Int
n    = Permutation -> Int
permutationSize Permutation
perm1
  list :: [Int]
list = Permutation -> [Int]
fromPermutation Permutation
perm1 [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
n) (Permutation -> [Int]
fromPermutation Permutation
perm2)

--------------------------------------------------------------------------------
-- * ASCII

-- | Synonym for 'twoLineNotation'
asciiPermutation :: Permutation -> ASCII
asciiPermutation :: Permutation -> ASCII
asciiPermutation = Permutation -> ASCII
twoLineNotation 

asciiDisjointCycles :: DisjointCycles -> ASCII
asciiDisjointCycles :: DisjointCycles -> ASCII
asciiDisjointCycles (DisjointCycles [[Int]]
cycles) = ASCII
final where
  final :: ASCII
final = VAlign -> HSep -> [ASCII] -> ASCII
hCatWith VAlign
VTop (Int -> HSep
HSepSpaces Int
1) [ASCII]
boxes 
  boxes :: [ASCII]
boxes = [ [(Int, Int)] -> ASCII
genericTwoLineNotation ([Int] -> [(Int, Int)]
forall a. [a] -> [(a, a)]
f [Int]
cyc) | [Int]
cyc <- [[Int]]
cycles ]
  f :: [a] -> [(a, a)]
f [a]
cyc = [a] -> [(a, a)]
forall a. [a] -> [(a, a)]
pairs ([a]
cyc [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [[a] -> a
forall a. [a] -> a
head [a]
cyc])

-- | The standard two-line notation, moving the element indexed by the top row into
-- the place indexed by the corresponding element in the bottom row.
twoLineNotation :: Permutation -> ASCII
twoLineNotation :: Permutation -> ASCII
twoLineNotation (Permutation WordVec
arr) = [(Int, Int)] -> ASCII
genericTwoLineNotation ([(Int, Int)] -> ASCII) -> [(Int, Int)] -> ASCII
forall a b. (a -> b) -> a -> b
$ [Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] (WordVec -> [Int]
_elems WordVec
arr)

-- | The inverse two-line notation, where the it\'s the bottom line 
-- which is in standard order. The columns of this are a permutation
-- of the columns 'twoLineNotation'.
--
-- Remark: the top row of @inverseTwoLineNotation perm@ is the same 
-- as the bottom row of @twoLineNotation (inversePermutation perm)@.
--
inverseTwoLineNotation :: Permutation -> ASCII
inverseTwoLineNotation :: Permutation -> ASCII
inverseTwoLineNotation (Permutation WordVec
arr) =
  [(Int, Int)] -> ASCII
genericTwoLineNotation ([(Int, Int)] -> ASCII) -> [(Int, Int)] -> ASCII
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> (Int, Int) -> Ordering)
-> [(Int, Int)] -> [(Int, Int)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Int, Int) -> Int) -> (Int, Int) -> (Int, Int) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Int, Int) -> Int
forall a b. (a, b) -> b
snd) ([(Int, Int)] -> [(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 [Int
1..] (WordVec -> [Int]
_elems WordVec
arr) 

-- | Two-line notation for any set of numbers
genericTwoLineNotation :: [(Int,Int)] -> ASCII
genericTwoLineNotation :: [(Int, Int)] -> ASCII
genericTwoLineNotation [(Int, Int)]
xys = [String] -> ASCII
asciiFromLines [ String
topLine, String
botLine ] where
  topLine :: String
topLine = String
"( " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" " [String]
us String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" )"
  botLine :: String
botLine = String
"( " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" " [String]
vs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" )"
  pairs :: [(String, String)]
pairs   = [ (Int -> String
forall a. Show a => a -> String
show Int
x, Int -> String
forall a. Show a => a -> String
show Int
y) | (Int
x,Int
y) <- [(Int, Int)]
xys ]
  ([String]
us,[String]
vs) = [(String, String)] -> ([String], [String])
forall a b. [(a, b)] -> ([a], [b])
unzip (((String, String) -> (String, String))
-> [(String, String)] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map (String, String) -> (String, String)
f [(String, String)]
pairs) 
  f :: (String, String) -> (String, String)
f (String
s,String
t) = (String
s',String
t') where
    a :: Int
a = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s 
    b :: Int
b = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
t
    c :: Int
c = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
a Int
b
    s' :: String
s' = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
cInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
a) Char
' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s
    t' :: String
t' = Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
cInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
b) Char
' ' String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
t

--------------------------------------------------------------------------------
-- * Disjoint cycles

fromDisjointCycles :: DisjointCycles -> [[Int]]
fromDisjointCycles :: DisjointCycles -> [[Int]]
fromDisjointCycles (DisjointCycles [[Int]]
cycles) = [[Int]]
cycles

disjointCyclesUnsafe :: [[Int]] -> DisjointCycles 
disjointCyclesUnsafe :: [[Int]] -> DisjointCycles
disjointCyclesUnsafe = [[Int]] -> DisjointCycles
DisjointCycles

instance DrawASCII DisjointCycles where
  ascii :: DisjointCycles -> ASCII
ascii = DisjointCycles -> ASCII
asciiDisjointCycles

instance HasNumberOfCycles DisjointCycles where
  numberOfCycles :: DisjointCycles -> Int
numberOfCycles (DisjointCycles [[Int]]
cycles) = [[Int]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Int]]
cycles

instance HasNumberOfCycles Permutation where
  numberOfCycles :: Permutation -> Int
numberOfCycles = DisjointCycles -> Int
forall p. HasNumberOfCycles p => p -> Int
numberOfCycles (DisjointCycles -> Int)
-> (Permutation -> DisjointCycles) -> Permutation -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Permutation -> DisjointCycles
permutationToDisjointCycles
  
disjointCyclesToPermutation :: Int -> DisjointCycles -> Permutation
disjointCyclesToPermutation :: Int -> DisjointCycles -> Permutation
disjointCyclesToPermutation Int
n (DisjointCycles [[Int]]
cycles) = WordVec -> Permutation
Permutation (WordVec -> Permutation) -> WordVec -> Permutation
forall a b. (a -> b) -> a -> b
$ UArray Int Int -> WordVec
fromUArray UArray Int Int
perm where

  pairs :: [Int] -> [(Int,Int)]
  pairs :: [Int] -> [(Int, Int)]
pairs xs :: [Int]
xs@(Int
x:[Int]
_) = [Int] -> [(Int, Int)]
forall a. [a] -> [(a, a)]
worker ([Int]
xs[Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++[Int
x]) where
    worker :: [b] -> [(b, b)]
worker (b
x:xs :: [b]
xs@(b
y:[b]
_)) = (b
x,b
y)(b, b) -> [(b, b)] -> [(b, b)]
forall a. a -> [a] -> [a]
:[b] -> [(b, b)]
worker [b]
xs
    worker [b]
_ = [] 
  pairs [] = String -> [(Int, Int)]
forall a. HasCallStack => String -> a
error String
"disjointCyclesToPermutation: empty cycle"

  perm :: UArray Int Int
perm = (forall s. ST s (STUArray s Int Int)) -> UArray Int Int
forall i e. (forall s. ST s (STUArray s i e)) -> UArray i e
runSTUArray ((forall s. ST s (STUArray s Int Int)) -> UArray Int Int)
-> (forall s. ST s (STUArray s Int Int)) -> UArray Int Int
forall a b. (a -> b) -> a -> b
$ do
    STUArray s Int Int
ar <- (Int, Int) -> ST s (STUArray s Int Int)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ (Int
1,Int
n) :: ST s (STUArray s Int Int)
    [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1..Int
n] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> STUArray s Int Int -> Int -> Int -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int
ar Int
i Int
i 
    [[Int]] -> ([Int] -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[Int]]
cycles (([Int] -> ST s ()) -> ST s ()) -> ([Int] -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \[Int]
cyc -> [(Int, Int)] -> ((Int, Int) -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Int] -> [(Int, Int)]
pairs [Int]
cyc) (((Int, Int) -> ST s ()) -> ST s ())
-> ((Int, Int) -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \(Int
i,Int
j) -> STUArray s Int Int -> Int -> Int -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int
ar Int
i Int
j
    STUArray s Int Int -> ST s (STUArray s Int Int)
forall (m :: * -> *) a. Monad m => a -> m a
return STUArray s Int Int
ar -- freeze ar
  
-- | Convert to disjoint cycle notation.
--
-- This is compatible with Maple's @convert(perm,\'disjcyc\')@ 
-- and also with Mathematica's @PermutationCycles[perm]@
--
-- Note however, that for example Mathematica uses the 
-- /top row/ to represent a permutation, while we use the
-- /bottom row/ - thus even though this function looks
-- identical, the /meaning/ of both the input and output
-- is different!
-- 
permutationToDisjointCycles :: Permutation -> DisjointCycles
permutationToDisjointCycles :: Permutation -> DisjointCycles
permutationToDisjointCycles (Permutation WordVec
perm) = DisjointCycles
res where

  n :: Int
n = WordVec -> Int
_bound WordVec
perm

  -- we don't want trivial cycles
  f :: [Int] -> Bool
  f :: [Int] -> Bool
f [Int
_] = Bool
False
  f [Int]
_ = Bool
True
  
  res :: DisjointCycles
res = (forall s. ST s DisjointCycles) -> DisjointCycles
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s DisjointCycles) -> DisjointCycles)
-> (forall s. ST s DisjointCycles) -> DisjointCycles
forall a b. (a -> b) -> a -> b
$ do
    STUArray s Int Bool
tag <- (Int, Int) -> Bool -> ST s (STUArray s Int Bool)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Int
1,Int
n) Bool
False 
    [[Int]]
cycles <- (Int -> ST s ([Int], Maybe Int)) -> Int -> ST s [[Int]]
forall (m :: * -> *) b a.
Monad m =>
(b -> m (a, Maybe b)) -> b -> m [a]
unfoldM (STUArray s Int Bool -> Int -> ST s ([Int], Maybe Int)
forall s. STUArray s Int Bool -> Int -> ST s ([Int], Maybe Int)
step STUArray s Int Bool
tag) Int
1 
    DisjointCycles -> ST s DisjointCycles
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Int]] -> DisjointCycles
DisjointCycles ([[Int]] -> DisjointCycles) -> [[Int]] -> DisjointCycles
forall a b. (a -> b) -> a -> b
$ ([Int] -> Bool) -> [[Int]] -> [[Int]]
forall a. (a -> Bool) -> [a] -> [a]
filter [Int] -> Bool
f [[Int]]
cycles)
    
  step :: STUArray s Int Bool -> Int -> ST s ([Int],Maybe Int)
  step :: STUArray s Int Bool -> Int -> ST s ([Int], Maybe Int)
step STUArray s Int Bool
tag Int
k = do
    [Int]
cyc <- STUArray s Int Bool -> Int -> Int -> [Int] -> ST s [Int]
forall s. STUArray s Int Bool -> Int -> Int -> [Int] -> ST s [Int]
worker STUArray s Int Bool
tag Int
k Int
k [Int
k] 
    Maybe Int
m <- STUArray s Int Bool -> Int -> ST s (Maybe Int)
forall s. STUArray s Int Bool -> Int -> ST s (Maybe Int)
next STUArray s Int Bool
tag (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
    ([Int], Maybe Int) -> ST s ([Int], Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Int] -> [Int]
forall a. [a] -> [a]
reverse [Int]
cyc, Maybe Int
m) 
    
  next :: STUArray s Int Bool -> Int -> ST s (Maybe Int)
  next :: STUArray s Int Bool -> Int -> ST s (Maybe Int)
next STUArray s Int Bool
tag Int
k = if Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n
    then Maybe Int -> ST s (Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
forall a. Maybe a
Nothing
    else STUArray s Int Bool -> Int -> ST s Bool
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Bool
tag Int
k ST s Bool -> (Bool -> ST s (Maybe Int)) -> ST s (Maybe Int)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b -> if Bool
b 
      then STUArray s Int Bool -> Int -> ST s (Maybe Int)
forall s. STUArray s Int Bool -> Int -> ST s (Maybe Int)
next STUArray s Int Bool
tag (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)  
      else Maybe Int -> ST s (Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
k)
       
  worker :: STUArray s Int Bool -> Int -> Int -> [Int] -> ST s [Int]
  worker :: STUArray s Int Bool -> Int -> Int -> [Int] -> ST s [Int]
worker STUArray s Int Bool
tag Int
k Int
l [Int]
cyc = do
    STUArray s Int Bool -> Int -> Bool -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Bool
tag Int
l Bool
True
    let m :: Int
m = WordVec
perm WordVec -> Int -> Int
.! Int
l
    if Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
k 
      then [Int] -> ST s [Int]
forall (m :: * -> *) a. Monad m => a -> m a
return [Int]
cyc
      else STUArray s Int Bool -> Int -> Int -> [Int] -> ST s [Int]
forall s. STUArray s Int Bool -> Int -> Int -> [Int] -> ST s [Int]
worker STUArray s Int Bool
tag Int
k Int
m (Int
mInt -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
cyc)      

isEvenPermutation :: Permutation -> Bool
isEvenPermutation :: Permutation -> Bool
isEvenPermutation (Permutation WordVec
perm) = Bool
res where

  n :: Int
n = WordVec -> Int
_bound WordVec
perm
  res :: Bool
res = (forall s. ST s Bool) -> Bool
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s Bool) -> Bool) -> (forall s. ST s Bool) -> Bool
forall a b. (a -> b) -> a -> b
$ do
    STUArray s Int Bool
tag <- (Int, Int) -> Bool -> ST s (STUArray s Int Bool)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Int
1,Int
n) Bool
False 
    [Int]
cycles <- (Int -> ST s (Int, Maybe Int)) -> Int -> ST s [Int]
forall (m :: * -> *) b a.
Monad m =>
(b -> m (a, Maybe b)) -> b -> m [a]
unfoldM (STUArray s Int Bool -> Int -> ST s (Int, Maybe Int)
forall s. STUArray s Int Bool -> Int -> ST s (Int, Maybe Int)
step STUArray s Int Bool
tag) Int
1 
    Bool -> ST s Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> ST s Bool) -> Bool -> ST s Bool
forall a b. (a -> b) -> a -> b
$ Int -> Bool
forall a. Integral a => a -> Bool
even ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int]
cycles)
    
  step :: STUArray s Int Bool -> Int -> ST s (Int,Maybe Int)
  step :: STUArray s Int Bool -> Int -> ST s (Int, Maybe Int)
step STUArray s Int Bool
tag Int
k = do
    Int
cyclen <- STUArray s Int Bool -> Int -> Int -> Int -> ST s Int
forall s. STUArray s Int Bool -> Int -> Int -> Int -> ST s Int
worker STUArray s Int Bool
tag Int
k Int
k Int
0
    Maybe Int
m <- STUArray s Int Bool -> Int -> ST s (Maybe Int)
forall s. STUArray s Int Bool -> Int -> ST s (Maybe Int)
next STUArray s Int Bool
tag (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
    (Int, Maybe Int) -> ST s (Int, Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
cyclen,Maybe Int
m)
    
  next :: STUArray s Int Bool -> Int -> ST s (Maybe Int)
  next :: STUArray s Int Bool -> Int -> ST s (Maybe Int)
next STUArray s Int Bool
tag Int
k = if Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n
    then Maybe Int -> ST s (Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Int
forall a. Maybe a
Nothing
    else STUArray s Int Bool -> Int -> ST s Bool
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Bool
tag Int
k ST s Bool -> (Bool -> ST s (Maybe Int)) -> ST s (Maybe Int)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
b -> if Bool
b 
      then STUArray s Int Bool -> Int -> ST s (Maybe Int)
forall s. STUArray s Int Bool -> Int -> ST s (Maybe Int)
next STUArray s Int Bool
tag (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)  
      else Maybe Int -> ST s (Maybe Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
k)
      
  worker :: STUArray s Int Bool -> Int -> Int -> Int -> ST s Int
  worker :: STUArray s Int Bool -> Int -> Int -> Int -> ST s Int
worker STUArray s Int Bool
tag Int
k Int
l Int
cyclen = do
    STUArray s Int Bool -> Int -> Bool -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Bool
tag Int
l Bool
True
    let m :: Int
m = WordVec
perm WordVec -> Int -> Int
.! Int
l
    if Int
m Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
k 
      then Int -> ST s Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
cyclen
      else STUArray s Int Bool -> Int -> Int -> Int -> ST s Int
forall s. STUArray s Int Bool -> Int -> Int -> Int -> ST s Int
worker STUArray s Int Bool
tag Int
k Int
m (Int
1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
cyclen)      

isOddPermutation :: Permutation -> Bool
isOddPermutation :: Permutation -> Bool
isOddPermutation = Bool -> Bool
not (Bool -> Bool) -> (Permutation -> Bool) -> Permutation -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Permutation -> Bool
isEvenPermutation

signOfPermutation :: Permutation -> Sign
signOfPermutation :: Permutation -> Sign
signOfPermutation Permutation
perm = case Permutation -> Bool
isEvenPermutation Permutation
perm of
  Bool
True  -> Sign
Plus
  Bool
False -> Sign
Minus

-- | Plus 1 or minus 1.
{-# SPECIALIZE signValueOfPermutation :: Permutation -> Int     #-}
{-# SPECIALIZE signValueOfPermutation :: Permutation -> Integer #-}
signValueOfPermutation :: Num a => Permutation -> a
signValueOfPermutation :: Permutation -> a
signValueOfPermutation = Sign -> a
forall a. Num a => Sign -> a
signValue (Sign -> a) -> (Permutation -> Sign) -> Permutation -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Permutation -> Sign
signOfPermutation
  
isCyclicPermutation :: Permutation -> Bool
isCyclicPermutation :: Permutation -> Bool
isCyclicPermutation Permutation
perm = 
  case [[Int]]
cycles of
    []    -> Bool
True
    [[Int]
cyc] -> ([Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
cyc Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n)
    [[Int]]
_     -> Bool
False
  where 
    n :: Int
n = Permutation -> Int
permutationSize Permutation
perm
    DisjointCycles [[Int]]
cycles = Permutation -> DisjointCycles
permutationToDisjointCycles Permutation
perm

--------------------------------------------------------------------------------
-- * Inversions

-- | An /inversion/ of a permutation @sigma@ is a pair @(i,j)@ such that
-- @i<j@ and @sigma(i) > sigma(j)@.
--
-- This functions returns the inversion of a permutation.
--
inversions :: Permutation -> [(Int,Int)]
inversions :: Permutation -> [(Int, Int)]
inversions (Permutation WordVec
arr) = [(Int, Int)]
list where
  n :: Int
n =  WordVec -> Int
_bound WordVec
arr
  list :: [(Int, Int)]
list = [ (Int
i,Int
j) | Int
i<-[Int
1..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1], Int
j<-[Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1..Int
n], WordVec
arrWordVec -> Int -> Int
.!Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> WordVec
arrWordVec -> Int -> Int
.!Int
j ]

-- | Returns the number of inversions:
--
-- > numberOfInversions perm = length (inversions perm)
--
-- Synonym for 'numberOfInversionsMerge'
--
numberOfInversions :: Permutation -> Int
numberOfInversions :: Permutation -> Int
numberOfInversions = Permutation -> Int
numberOfInversionsMerge

-- | Returns the number of inversions, using the merge-sort algorithm.
-- This should be @O(n*log(n))@
--
numberOfInversionsMerge :: Permutation -> Int
numberOfInversionsMerge :: Permutation -> Int
numberOfInversionsMerge (Permutation WordVec
arr) = (Int, [Int]) -> Int
forall a b. (a, b) -> a
fst (Int -> [Int] -> (Int, [Int])
sortCnt Int
n ([Int] -> (Int, [Int])) -> [Int] -> (Int, [Int])
forall a b. (a -> b) -> a -> b
$ WordVec -> [Int]
_elems WordVec
arr) where
  n :: Int
n = WordVec -> Int
_bound WordVec
arr
                                        
  -- | First argument is length of the list.
  -- Returns also the inversion count.
  sortCnt :: Int -> [Int] -> (Int,[Int])
  sortCnt :: Int -> [Int] -> (Int, [Int])
sortCnt Int
0 [Int]
_     = (Int
0,[] )
  sortCnt Int
1 [Int
x]   = (Int
0,[Int
x])
  sortCnt Int
2 [Int
x,Int
y] = if Int
xInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
y then (Int
1,[Int
y,Int
x]) else (Int
0,[Int
x,Int
y])
  sortCnt Int
n [Int]
xs    = (Int, [Int]) -> (Int, [Int]) -> (Int, [Int])
mergeCnt (Int -> [Int] -> (Int, [Int])
sortCnt Int
k [Int]
us) (Int -> [Int] -> (Int, [Int])
sortCnt Int
l [Int]
vs) where
    k :: Int
k = Int -> Int -> Int
forall a. Integral a => a -> a -> a
div Int
n Int
2
    l :: Int
l = Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
k 
    ([Int]
us,[Int]
vs) = Int -> [Int] -> ([Int], [Int])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
k [Int]
xs

  mergeCnt :: (Int,[Int]) -> (Int,[Int]) -> (Int,[Int])
  mergeCnt :: (Int, [Int]) -> (Int, [Int]) -> (Int, [Int])
mergeCnt (!Int
c,[Int]
us) (!Int
d,[Int]
vs) = (Int
cInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
dInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
e,[Int]
ws) where

    (Int
e,[Int]
ws) = Int -> [Int] -> [Int] -> (Int, [Int])
forall a. Ord a => Int -> [a] -> [a] -> (Int, [a])
go Int
0 [Int]
us [Int]
vs 

    go :: Int -> [a] -> [a] -> (Int, [a])
go !Int
k [a]
xs [] = ( Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
*[a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs , [a]
xs )
    go Int
_  [] [a]
ys = ( Int
0 , [a]
ys)
    go !Int
k xxs :: [a]
xxs@(a
x:[a]
xs) yys :: [a]
yys@(a
y:[a]
ys) = if a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
y
      then let (Int
a,[a]
zs) = Int -> [a] -> [a] -> (Int, [a])
go  Int
k     [a]
xs [a]
yys in (Int
aInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
k, a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
zs)
      else let (Int
a,[a]
zs) = Int -> [a] -> [a] -> (Int, [a])
go (Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [a]
xxs  [a]
ys in (Int
a  , a
ya -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
zs)

-- | Returns the number of inversions, using the definition, thus it's @O(n^2)@.
--
numberOfInversionsNaive :: Permutation -> Int
numberOfInversionsNaive :: Permutation -> Int
numberOfInversionsNaive (Permutation WordVec
arr) = [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
list where
  n :: Int
n    = WordVec -> Int
_bound WordVec
arr
  list :: [Int]
list = [ (Int
0::Int) | Int
i<-[Int
1..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1], Int
j<-[Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1..Int
n], WordVec
arrWordVec -> Int -> Int
.!Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> WordVec
arrWordVec -> Int -> Int
.!Int
j ]

-- | Bubble sorts breaks a permutation into the product of adjacent transpositions:
--
-- > multiplyMany' n (map (transposition n) $ bubbleSort2 perm) == perm
--
-- Note that while this is not unique, the number of transpositions 
-- equals the number of inversions.
--
bubbleSort2 :: Permutation -> [(Int,Int)]
bubbleSort2 :: Permutation -> [(Int, Int)]
bubbleSort2 = (Int -> (Int, Int)) -> [Int] -> [(Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map Int -> (Int, Int)
forall b. Num b => b -> (b, b)
f ([Int] -> [(Int, Int)])
-> (Permutation -> [Int]) -> Permutation -> [(Int, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Permutation -> [Int]
bubbleSort where f :: b -> (b, b)
f b
i = (b
i,b
ib -> b -> b
forall a. Num a => a -> a -> a
+b
1)

-- | Another version of bubble sort. An entry @i@ in the return sequence means
-- the transposition @(i,i+1)@:
--
-- > multiplyMany' n (map (adjacentTransposition n) $ bubbleSort perm) == perm
--
bubbleSort :: Permutation -> [Int]
bubbleSort :: Permutation -> [Int]
bubbleSort perm :: Permutation
perm@(Permutation WordVec
tgt) = (forall s. ST s [Int]) -> [Int]
forall a. (forall s. ST s a) -> a
runST forall s. ST s [Int]
action where
  n :: Int
n = WordVec -> Int
_bound WordVec
tgt

  action :: forall s. ST s [Int]
  action :: ST s [Int]
action = do
    STUArray s Int Int
fwd <- (Int, Int) -> ST s (STUArray s Int Int)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ (Int
1,Int
n) :: ST s (STUArray s Int Int)
    STUArray s Int Int
inv <- (Int, Int) -> ST s (STUArray s Int Int)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ (Int
1,Int
n) :: ST s (STUArray s Int Int)
    [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1..Int
n] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> STUArray s Int Int -> Int -> Int -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int
fwd Int
i Int
i
    [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1..Int
n] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> STUArray s Int Int -> Int -> Int -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int
inv Int
i Int
i

    [[Int]]
list <- [Int] -> (Int -> ST s [Int]) -> ST s [[Int]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int
1..Int
n] ((Int -> ST s [Int]) -> ST s [[Int]])
-> (Int -> ST s [Int]) -> ST s [[Int]]
forall a b. (a -> b) -> a -> b
$ \Int
x -> do

      let k :: Int
k = WordVec
tgt WordVec -> Int -> Int
.! Int
x       -- we take the number which will be at the @x@-th position at the end
      Int
i <- STUArray s Int Int -> Int -> ST s Int
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Int
inv Int
k   -- number @k@ is at the moment at position @i@
      let j :: Int
j = Int
x              -- but the final place is at @x@      

      let swaps :: [Int]
swaps = Int -> Int -> [Int]
move Int
i Int
j
      [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int]
swaps ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
y -> do

        Int
a <- STUArray s Int Int -> Int -> ST s Int
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Int
fwd  Int
y
        Int
b <- STUArray s Int Int -> Int -> ST s Int
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Int
fwd (Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
        STUArray s Int Int -> Int -> Int -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int
fwd (Int
yInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
a
        STUArray s Int Int -> Int -> Int -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int
fwd  Int
y    Int
b

        Int
u <- STUArray s Int Int -> Int -> ST s Int
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Int
inv Int
a
        Int
v <- STUArray s Int Int -> Int -> ST s Int
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Int
inv Int
b
        STUArray s Int Int -> Int -> Int -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int
inv Int
b Int
u
        STUArray s Int Int -> Int -> Int -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int
inv Int
a Int
v

      [Int] -> ST s [Int]
forall (m :: * -> *) a. Monad m => a -> m a
return [Int]
swaps
  
    [Int] -> ST s [Int]
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Int]] -> [Int]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Int]]
list)

  move :: Int -> Int -> [Int]
  move :: Int -> Int -> [Int]
move !Int
i !Int
j
    | Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i  = []
    | Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>  Int
i  = [Int
i..Int
jInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1]
    | Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<  Int
i  = [Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1,Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
2..Int
j]

--------------------------------------------------------------------------------
-- * Some concrete permutations

-- | The permutation @[n,n-1,n-2,...,2,1]@. Note that it is the inverse of itself.
reversePermutation :: Int -> Permutation
reversePermutation :: Int -> Permutation
reversePermutation Int
n = WordVec -> Permutation
Permutation (WordVec -> Permutation) -> WordVec -> Permutation
forall a b. (a -> b) -> a -> b
$ Int -> [Int] -> WordVec
fromPermListN Int
n [Int
n,Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1..Int
1]

-- | Checks whether the permutation is the reverse permutation @[n,n-1,n-2,...,2,1].
isReversePermutation :: Permutation -> Bool
isReversePermutation :: Permutation -> Bool
isReversePermutation (Permutation WordVec
arr) = WordVec -> [Int]
_elems WordVec
arr [Int] -> [Int] -> Bool
forall a. Eq a => a -> a -> Bool
== [Int
n,Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1..Int
1] where n :: Int
n = WordVec -> Int
_bound WordVec
arr

-- | A transposition (swapping two elements). 
--
-- @transposition n (i,j)@ is the permutation of size @n@ which swaps @i@\'th and @j@'th elements.
--
transposition :: Int -> (Int,Int) -> Permutation
transposition :: Int -> (Int, Int) -> Permutation
transposition Int
n (Int
i,Int
j) = 
  if Int
iInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>=Int
1 Bool -> Bool -> Bool
&& Int
jInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>=Int
1 Bool -> Bool -> Bool
&& Int
iInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<=Int
n Bool -> Bool -> Bool
&& Int
jInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<=Int
n 
    then WordVec -> Permutation
Permutation (WordVec -> Permutation) -> WordVec -> Permutation
forall a b. (a -> b) -> a -> b
$ Int -> [Int] -> WordVec
fromPermListN Int
n [ Int -> Int
f Int
k | Int
k<-[Int
1..Int
n] ]
    else String -> Permutation
forall a. HasCallStack => String -> a
error String
"transposition: index out of range"
  where
    f :: Int -> Int
f Int
k | Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
i    = Int
j
        | Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
j    = Int
i
        | Bool
otherwise = Int
k

-- | Product of transpositions.
--
-- > transpositions n list == multiplyMany [ transposition n pair | pair <- list ]
--
transpositions :: Int -> [(Int,Int)] -> Permutation
transpositions :: Int -> [(Int, Int)] -> Permutation
transpositions Int
n [(Int, Int)]
list = WordVec -> Permutation
Permutation (UArray Int Int -> WordVec
fromUArray (UArray Int Int -> WordVec) -> UArray Int Int -> WordVec
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (STUArray s Int Int)) -> UArray Int Int
forall i e. (forall s. ST s (STUArray s i e)) -> UArray i e
runSTUArray forall s. ST s (STUArray s Int Int)
action) where

  action :: ST s (STUArray s Int Int)
  action :: ST s (STUArray s Int Int)
action = do
    STUArray s Int Int
arr <- (Int, Int) -> ST s (STUArray s Int Int)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ (Int
1,Int
n) 
    [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1..Int
n] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> STUArray s Int Int -> Int -> Int -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int
arr Int
i Int
i    
    let doSwap :: (Int, Int) -> m ()
doSwap (Int
i,Int
j) = do
          Int
u <- STUArray s Int Int -> Int -> m Int
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Int
arr Int
i
          Int
v <- STUArray s Int Int -> Int -> m Int
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Int
arr Int
j
          STUArray s Int Int -> Int -> Int -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int
arr Int
i Int
v
          STUArray s Int Int -> Int -> Int -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int
arr Int
j Int
u          
    ((Int, Int) -> ST s ()) -> [(Int, Int)] -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Int, Int) -> ST s ()
forall (m :: * -> *).
MArray (STUArray s) Int m =>
(Int, Int) -> m ()
doSwap [(Int, Int)]
list
    STUArray s Int Int -> ST s (STUArray s Int Int)
forall (m :: * -> *) a. Monad m => a -> m a
return STUArray s Int Int
arr

-- | @adjacentTransposition n k@ swaps the elements @k@ and @(k+1)@.
adjacentTransposition :: Int -> Int -> Permutation
adjacentTransposition :: Int -> Int -> Permutation
adjacentTransposition Int
n Int
k 
  | Int
kInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>Int
0 Bool -> Bool -> Bool
&& Int
kInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
n  = Int -> (Int, Int) -> Permutation
transposition Int
n (Int
k,Int
kInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
  | Bool
otherwise   = String -> Permutation
forall a. HasCallStack => String -> a
error String
"adjacentTransposition: index out of range"

-- | Product of adjacent transpositions.
--
-- > adjacentTranspositions n list == multiplyMany [ adjacentTransposition n idx | idx <- list ]
--
adjacentTranspositions :: Int -> [Int] -> Permutation
adjacentTranspositions :: Int -> [Int] -> Permutation
adjacentTranspositions Int
n [Int]
list = WordVec -> Permutation
Permutation (UArray Int Int -> WordVec
fromUArray (UArray Int Int -> WordVec) -> UArray Int Int -> WordVec
forall a b. (a -> b) -> a -> b
$ (forall s. ST s (STUArray s Int Int)) -> UArray Int Int
forall i e. (forall s. ST s (STUArray s i e)) -> UArray i e
runSTUArray forall s. ST s (STUArray s Int Int)
action) where

  action :: ST s (STUArray s Int Int)
  action :: ST s (STUArray s Int Int)
action = do
    STUArray s Int Int
arr <- (Int, Int) -> ST s (STUArray s Int Int)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ (Int
1,Int
n) 
    [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1..Int
n] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> STUArray s Int Int -> Int -> Int -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int
arr Int
i Int
i    
    let doSwap :: Int -> m ()
doSwap Int
i
          | Int
iInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<Int
0 Bool -> Bool -> Bool
|| Int
iInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>=Int
n  = String -> m ()
forall a. HasCallStack => String -> a
error String
"adjacentTranspositions: index out of range"
          | Bool
otherwise    = do
              Int
u <- STUArray s Int Int -> Int -> m Int
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Int
arr  Int
i
              Int
v <- STUArray s Int Int -> Int -> m Int
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Int
arr (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
              STUArray s Int Int -> Int -> Int -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int
arr  Int
i    Int
v
              STUArray s Int Int -> Int -> Int -> m ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int
arr (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Int
u          
    (Int -> ST s ()) -> [Int] -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Int -> ST s ()
forall (m :: * -> *). MArray (STUArray s) Int m => Int -> m ()
doSwap [Int]
list
    STUArray s Int Int -> ST s (STUArray s Int Int)
forall (m :: * -> *) a. Monad m => a -> m a
return STUArray s Int Int
arr

-- | The permutation which cycles a list left by one step:
-- 
-- > permuteList (cycleLeft 5) "abcde" == "bcdea"
--
-- Or in two-line notation:
--
-- > ( 1 2 3 4 5 )
-- > ( 2 3 4 5 1 )
-- 
cycleLeft :: Int -> Permutation
cycleLeft :: Int -> Permutation
cycleLeft Int
n = WordVec -> Permutation
Permutation (WordVec -> Permutation) -> WordVec -> Permutation
forall a b. (a -> b) -> a -> b
$ Int -> [Int] -> WordVec
fromPermListN Int
n ([Int
2..Int
n] [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int
1])

-- | The permutation which cycles a list right by one step:
-- 
-- > permuteList (cycleRight 5) "abcde" == "eabcd"
--
-- Or in two-line notation:
--
-- > ( 1 2 3 4 5 )
-- > ( 5 1 2 3 4 )
-- 
cycleRight :: Int -> Permutation
cycleRight :: Int -> Permutation
cycleRight Int
n = WordVec -> Permutation
Permutation (WordVec -> Permutation) -> WordVec -> Permutation
forall a b. (a -> b) -> a -> b
$ Int -> [Int] -> WordVec
fromPermListN Int
n (Int
n Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int
1..Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1])
   
--------------------------------------------------------------------------------
-- * Permutation groups

-- | Multiplies two permutations together: @p `multiplyPermutation` q@
-- means the permutation when we first apply @p@, and then @q@
-- (that is, the natural action is the /right/ action)
--
-- See also 'permuteArray' for our conventions.  
--
multiplyPermutation :: Permutation -> Permutation -> Permutation
multiplyPermutation :: Permutation -> Permutation -> Permutation
multiplyPermutation pi1 :: Permutation
pi1@(Permutation WordVec
perm1) pi2 :: Permutation
pi2@(Permutation WordVec
perm2) = 
  if (Int
nInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
m) 
    then WordVec -> Permutation
Permutation (WordVec -> Permutation) -> WordVec -> Permutation
forall a b. (a -> b) -> a -> b
$ UArray Int Int -> WordVec
fromUArray UArray Int Int
result
    else String -> Permutation
forall a. HasCallStack => String -> a
error String
"multiplyPermutation: permutations of different sets"  
  where
    n :: Int
n = WordVec -> Int
_bound WordVec
perm1
    m :: Int
m = WordVec -> Int
_bound WordVec
perm2    
    result :: UArray Int Int
result = Permutation -> UArray Int Int -> UArray Int Int
forall (arr :: * -> * -> *) b.
IArray arr b =>
Permutation -> arr Int b -> arr Int b
permuteArray Permutation
pi2 (WordVec -> UArray Int Int
toUArray WordVec
perm1)
  
infixr 7 `multiplyPermutation`  

-- | The inverse permutation.
inversePermutation :: Permutation -> Permutation    
inversePermutation :: Permutation -> Permutation
inversePermutation (Permutation WordVec
perm1) = WordVec -> Permutation
Permutation (WordVec -> Permutation) -> WordVec -> Permutation
forall a b. (a -> b) -> a -> b
$ UArray Int Int -> WordVec
fromUArray UArray Int Int
result
  where
    result :: UArray Int Int
result = (Int, Int) -> [(Int, Int)] -> UArray Int Int
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [(i, e)] -> a i e
array (Int
1,Int
n) ([(Int, Int)] -> UArray Int Int) -> [(Int, Int)] -> UArray Int Int
forall a b. (a -> b) -> a -> b
$ ((Int, Int) -> (Int, Int)) -> [(Int, Int)] -> [(Int, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Int) -> (Int, Int)
forall a b. (a, b) -> (b, a)
swap ([(Int, Int)] -> [(Int, Int)]) -> [(Int, Int)] -> [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ WordVec -> [(Int, Int)]
_assocs WordVec
perm1
    n :: Int
n = WordVec -> Int
_bound WordVec
perm1
    
-- | The identity (or trivial) permutation.
identityPermutation :: Int -> Permutation 
identityPermutation :: Int -> Permutation
identityPermutation Int
n = WordVec -> Permutation
Permutation (WordVec -> Permutation) -> WordVec -> Permutation
forall a b. (a -> b) -> a -> b
$ Int -> [Int] -> WordVec
fromPermListN Int
n [Int
1..Int
n]

-- | Multiply together a /non-empty/ list of permutations (the reason for requiring the list to
-- be non-empty is that we don\'t know the size of the result). See also 'multiplyMany''.
productOfPermutations :: [Permutation] -> Permutation 
productOfPermutations :: [Permutation] -> Permutation
productOfPermutations [] = String -> Permutation
forall a. HasCallStack => String -> a
error String
"productOfPermutations: empty list, we don't know size of the result"
productOfPermutations [Permutation]
ps = (Permutation -> Permutation -> Permutation)
-> [Permutation] -> Permutation
forall a. (a -> a -> a) -> [a] -> a
foldl1' Permutation -> Permutation -> Permutation
multiplyPermutation [Permutation]
ps    

-- | Multiply together a (possibly empty) list of permutations, all of which has size @n@
productOfPermutations' :: Int -> [Permutation] -> Permutation 
productOfPermutations' :: Int -> [Permutation] -> Permutation
productOfPermutations' Int
n []       = Int -> Permutation
identityPermutation Int
n
productOfPermutations' Int
n ps :: [Permutation]
ps@(Permutation
p:[Permutation]
_) = if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Permutation -> Int
permutationSize Permutation
p 
  then (Permutation -> Permutation -> Permutation)
-> [Permutation] -> Permutation
forall a. (a -> a -> a) -> [a] -> a
foldl1' Permutation -> Permutation -> Permutation
multiplyPermutation [Permutation]
ps    
  else String -> Permutation
forall a. HasCallStack => String -> a
error String
"productOfPermutations': incompatible permutation size(s)"

--------------------------------------------------------------------------------
-- * Action of the permutation group

-- | /Right/ action of a permutation on a set. If our permutation is 
-- encoded with the sequence @[p1,p2,...,pn]@, then in the
-- two-line notation we have
--
-- > ( 1  2  3  ... n  )
-- > ( p1 p2 p3 ... pn )
--
-- We adopt the convention that permutations act /on the right/ 
-- (as in Knuth):
--
-- > permuteArray pi2 (permuteArray pi1 set) == permuteArray (pi1 `multiplyPermutation` pi2) set
--
-- Synonym to 'permuteArrayRight'
--
{-# SPECIALIZE permuteArray :: Permutation -> Array  Int b   -> Array  Int b   #-}
{-# SPECIALIZE permuteArray :: Permutation -> UArray Int Int -> UArray Int Int #-}
permuteArray :: IArray arr b => Permutation -> arr Int b -> arr Int b    
permuteArray :: Permutation -> arr Int b -> arr Int b
permuteArray = Permutation -> arr Int b -> arr Int b
forall (arr :: * -> * -> *) b.
IArray arr b =>
Permutation -> arr Int b -> arr Int b
permuteArrayRight

-- | Right action on lists. Synonym to 'permuteListRight'
--
permuteList :: Permutation -> [a] -> [a]
permuteList :: Permutation -> [a] -> [a]
permuteList = Permutation -> [a] -> [a]
forall a. Permutation -> [a] -> [a]
permuteListRight
    
-- | The right (standard) action of permutations on sets. 
-- 
-- > permuteArrayRight pi2 (permuteArrayRight pi1 set) == permuteArrayRight (pi1 `multiplyPermutation` pi2) set
--   
-- The second argument should be an array with bounds @(1,n)@.
-- The function checks the array bounds.
--
{-# SPECIALIZE permuteArrayRight :: Permutation -> Array  Int b   -> Array  Int b   #-}
{-# SPECIALIZE permuteArrayRight :: Permutation -> UArray Int Int -> UArray Int Int #-}
permuteArrayRight :: IArray arr b => Permutation -> arr Int b -> arr Int b    
permuteArrayRight :: Permutation -> arr Int b -> arr Int b
permuteArrayRight pi :: Permutation
pi@(Permutation WordVec
perm) arr Int b
ar = 
  if (Int
aInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
1) Bool -> Bool -> Bool
&& (Int
bInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
n) 
    then (Int, Int) -> [b] -> arr Int b
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (Int
1,Int
n) [ arr Int b
ararr Int b -> Int -> b
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
!(WordVec
permWordVec -> Int -> Int
.!Int
i) | Int
i <- [Int
1..Int
n] ] 
    else String -> arr Int b
forall a. HasCallStack => String -> a
error String
"permuteArrayRight: array bounds do not match"
  where
    n :: Int
n     = WordVec -> Int
_bound WordVec
perm
    (Int
a,Int
b) = arr Int b -> (Int, Int)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds arr Int b
ar   

-- | The right (standard) action on a list. The list should be of length @n@.
--
-- > fromPermutation perm == permuteListRight perm [1..n]
-- 
permuteListRight :: forall a . Permutation -> [a] -> [a]    
permuteListRight :: Permutation -> [a] -> [a]
permuteListRight Permutation
perm [a]
xs = Array Int a -> [a]
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
elems (Array Int a -> [a]) -> Array Int a -> [a]
forall a b. (a -> b) -> a -> b
$ Permutation -> Array Int a -> Array Int a
forall (arr :: * -> * -> *) b.
IArray arr b =>
Permutation -> arr Int b -> arr Int b
permuteArrayRight Permutation
perm (Array Int a -> Array Int a) -> Array Int a -> Array Int a
forall a b. (a -> b) -> a -> b
$ Array Int a
arr where
  arr :: Array Int a
arr = (Int, Int) -> [a] -> Array Int a
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (Int
1,Int
n) [a]
xs :: Array Int a
  n :: Int
n   = Permutation -> Int
permutationSize Permutation
perm

-- | The left (opposite) action of the permutation group.
--
-- > permuteArrayLeft pi2 (permuteArrayLeft pi1 set) == permuteArrayLeft (pi2 `multiplyPermutation` pi1) set
--
-- It is related to 'permuteLeftArray' via:
--
-- > permuteArrayLeft  pi arr == permuteArrayRight (inversePermutation pi) arr
-- > permuteArrayRight pi arr == permuteArrayLeft  (inversePermutation pi) arr
--
{-# SPECIALIZE permuteArrayLeft :: Permutation -> Array  Int b   -> Array  Int b   #-}
{-# SPECIALIZE permuteArrayLeft :: Permutation -> UArray Int Int -> UArray Int Int #-}
permuteArrayLeft :: IArray arr b => Permutation -> arr Int b -> arr Int b    
permuteArrayLeft :: Permutation -> arr Int b -> arr Int b
permuteArrayLeft pi :: Permutation
pi@(Permutation WordVec
perm) arr Int b
ar =    
  -- permuteRight (inverse pi) ar
  if (Int
aInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
1) Bool -> Bool -> Bool
&& (Int
bInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
n) 
    then (Int, Int) -> [(Int, b)] -> arr Int b
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [(i, e)] -> a i e
array (Int
1,Int
n) [ ( WordVec
permWordVec -> Int -> Int
.!Int
i , arr Int b
ararr Int b -> Int -> b
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> i -> e
!Int
i ) | Int
i <- [Int
1..Int
n] ] 
    else String -> arr Int b
forall a. HasCallStack => String -> a
error String
"permuteArrayLeft: array bounds do not match"
  where
    n :: Int
n     = WordVec -> Int
_bound WordVec
perm
    (Int
a,Int
b) = arr Int b -> (Int, Int)
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
a i e -> (i, i)
bounds arr Int b
ar   

-- | The left (opposite) action on a list. The list should be of length @n@.
--
-- > permuteListLeft perm set == permuteList (inversePermutation perm) set
-- > fromPermutation (inversePermutation perm) == permuteListLeft perm [1..n]
--
permuteListLeft :: forall a. Permutation -> [a] -> [a]    
permuteListLeft :: Permutation -> [a] -> [a]
permuteListLeft Permutation
perm [a]
xs = Array Int a -> [a]
forall (a :: * -> * -> *) e i. (IArray a e, Ix i) => a i e -> [e]
elems (Array Int a -> [a]) -> Array Int a -> [a]
forall a b. (a -> b) -> a -> b
$ Permutation -> Array Int a -> Array Int a
forall (arr :: * -> * -> *) b.
IArray arr b =>
Permutation -> arr Int b -> arr Int b
permuteArrayLeft Permutation
perm (Array Int a -> Array Int a) -> Array Int a -> Array Int a
forall a b. (a -> b) -> a -> b
$ Array Int a
arr where
  arr :: Array Int a
arr = (Int, Int) -> [a] -> Array Int a
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [e] -> a i e
listArray (Int
1,Int
n) [a]
xs :: Array Int a
  n :: Int
n   = Permutation -> Int
permutationSize Permutation
perm

--------------------------------------------------------------------------------

-- | Given a list of things, we return a permutation which sorts them into
-- ascending order, that is:
--
-- > permuteList (sortingPermutationAsc xs) xs == sort xs
--
-- Note: if the things are not unique, then the sorting permutations is not
-- unique either; we just return one of them.
--
sortingPermutationAsc :: Ord a => [a] -> Permutation
sortingPermutationAsc :: [a] -> Permutation
sortingPermutationAsc [a]
xs = [Int] -> Permutation
toPermutation (((Int, a) -> Int) -> [(Int, a)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, a) -> Int
forall a b. (a, b) -> a
fst [(Int, a)]
sorted) where
  sorted :: [(Int, a)]
sorted = ((Int, a) -> (Int, a) -> Ordering) -> [(Int, a)] -> [(Int, a)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Int, a) -> a) -> (Int, a) -> (Int, a) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Int, a) -> a
forall a b. (a, b) -> b
snd) ([(Int, a)] -> [(Int, a)]) -> [(Int, a)] -> [(Int, a)]
forall a b. (a -> b) -> a -> b
$ [Int] -> [a] -> [(Int, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [a]
xs

-- | Given a list of things, we return a permutation which sorts them into
-- descending order, that is:
--
-- > permuteList (sortingPermutationDesc xs) xs == reverse (sort xs)
--
-- Note: if the things are not unique, then the sorting permutations is not
-- unique either; we just return one of them.
--
sortingPermutationDesc :: Ord a => [a] -> Permutation
sortingPermutationDesc :: [a] -> Permutation
sortingPermutationDesc [a]
xs = [Int] -> Permutation
toPermutation (((Int, a) -> Int) -> [(Int, a)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, a) -> Int
forall a b. (a, b) -> a
fst [(Int, a)]
sorted) where
  sorted :: [(Int, a)]
sorted = ((Int, a) -> (Int, a) -> Ordering) -> [(Int, a)] -> [(Int, a)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Int, a) -> a) -> (Int, a) -> (Int, a) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
reverseComparing (Int, a) -> a
forall a b. (a, b) -> b
snd) ([(Int, a)] -> [(Int, a)]) -> [(Int, a)] -> [(Int, a)]
forall a b. (a -> b) -> a -> b
$ [Int] -> [a] -> [(Int, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1..] [a]
xs

--------------------------------------------------------------------------------
-- * Permutations of distinct elements

-- | A synonym for 'permutationsNaive'
permutations :: Int -> [Permutation]
permutations :: Int -> [Permutation]
permutations = Int -> [Permutation]
permutationsNaive

_permutations :: Int -> [[Int]]
_permutations :: Int -> [[Int]]
_permutations = Int -> [[Int]]
_permutationsNaive

-- | All permutations of @[1..n]@ in lexicographic order, naive algorithm.
permutationsNaive :: Int -> [Permutation]
permutationsNaive :: Int -> [Permutation]
permutationsNaive Int
n = ([Int] -> Permutation) -> [[Int]] -> [Permutation]
forall a b. (a -> b) -> [a] -> [b]
map [Int] -> Permutation
toPermutationUnsafe ([[Int]] -> [Permutation]) -> [[Int]] -> [Permutation]
forall a b. (a -> b) -> a -> b
$ Int -> [[Int]]
_permutations Int
n 

_permutationsNaive :: Int -> [[Int]]  
_permutationsNaive :: Int -> [[Int]]
_permutationsNaive Int
0 = [[]]
_permutationsNaive Int
1 = [[Int
1]]
_permutationsNaive Int
n = [Int] -> [[Int]]
forall a. Ord a => [a] -> [[a]]
helper [Int
1..Int
n] where
  helper :: [a] -> [[a]]
helper [] = [[]]
  helper [a]
xs = [ a
i a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
ys | a
i <- [a]
xs , [a]
ys <- [a] -> [[a]]
helper ([a]
xs [a] -> a -> [a]
forall a. Ord a => [a] -> a -> [a]
`minus` a
i) ]
  minus :: [a] -> a -> [a]
minus [] a
_ = []
  minus (a
x:[a]
xs) a
i = if a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
i then a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> a -> [a]
minus [a]
xs a
i else [a]
xs
          
-- | # = n!
countPermutations :: Int -> Integer
countPermutations :: Int -> Integer
countPermutations = Int -> Integer
forall a. Integral a => a -> Integer
factorial

--------------------------------------------------------------------------------
-- * Random permutations

-- | A synonym for 'randomPermutationDurstenfeld'.
randomPermutation :: RandomGen g => Int -> g -> (Permutation,g)
randomPermutation :: Int -> g -> (Permutation, g)
randomPermutation = Int -> g -> (Permutation, g)
forall g. RandomGen g => Int -> g -> (Permutation, g)
randomPermutationDurstenfeld

_randomPermutation :: RandomGen g => Int -> g -> ([Int],g)
_randomPermutation :: Int -> g -> ([Int], g)
_randomPermutation Int
n g
rndgen = (Permutation -> [Int]
fromPermutation Permutation
perm, g
rndgen') where
  (Permutation
perm, g
rndgen') = Int -> g -> (Permutation, g)
forall g. RandomGen g => Int -> g -> (Permutation, g)
randomPermutationDurstenfeld Int
n g
rndgen 

-- | A synonym for 'randomCyclicPermutationSattolo'.
randomCyclicPermutation :: RandomGen g => Int -> g -> (Permutation,g)
randomCyclicPermutation :: Int -> g -> (Permutation, g)
randomCyclicPermutation = Int -> g -> (Permutation, g)
forall g. RandomGen g => Int -> g -> (Permutation, g)
randomCyclicPermutationSattolo

_randomCyclicPermutation :: RandomGen g => Int -> g -> ([Int],g)
_randomCyclicPermutation :: Int -> g -> ([Int], g)
_randomCyclicPermutation Int
n g
rndgen = (Permutation -> [Int]
fromPermutation Permutation
perm, g
rndgen') where
  (Permutation
perm, g
rndgen') = Int -> g -> (Permutation, g)
forall g. RandomGen g => Int -> g -> (Permutation, g)
randomCyclicPermutationSattolo Int
n g
rndgen 

-- | Generates a uniformly random permutation of @[1..n]@.
-- Durstenfeld's algorithm (see <http://en.wikipedia.org/wiki/Knuth_shuffle>).
randomPermutationDurstenfeld :: RandomGen g => Int -> g -> (Permutation,g)
randomPermutationDurstenfeld :: Int -> g -> (Permutation, g)
randomPermutationDurstenfeld = Bool -> Int -> g -> (Permutation, g)
forall g. RandomGen g => Bool -> Int -> g -> (Permutation, g)
randomPermutationDurstenfeldSattolo Bool
False

-- | Generates a uniformly random /cyclic/ permutation of @[1..n]@.
-- Sattolo's algorithm (see <http://en.wikipedia.org/wiki/Knuth_shuffle>).
randomCyclicPermutationSattolo :: RandomGen g => Int -> g -> (Permutation,g)
randomCyclicPermutationSattolo :: Int -> g -> (Permutation, g)
randomCyclicPermutationSattolo = Bool -> Int -> g -> (Permutation, g)
forall g. RandomGen g => Bool -> Int -> g -> (Permutation, g)
randomPermutationDurstenfeldSattolo Bool
True

randomPermutationDurstenfeldSattolo :: RandomGen g => Bool -> Int -> g -> (Permutation,g)
randomPermutationDurstenfeldSattolo :: Bool -> Int -> g -> (Permutation, g)
randomPermutationDurstenfeldSattolo Bool
isSattolo Int
n g
rnd = (Permutation, g)
res where
  res :: (Permutation, g)
res = (forall s. ST s (Permutation, g)) -> (Permutation, g)
forall a. (forall s. ST s a) -> a
runST ((forall s. ST s (Permutation, g)) -> (Permutation, g))
-> (forall s. ST s (Permutation, g)) -> (Permutation, g)
forall a b. (a -> b) -> a -> b
$ do
    STUArray s Int Int
ar <- (Int, Int) -> ST s (STUArray s Int Int)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> m (a i e)
newArray_ (Int
1,Int
n) 
    [Int] -> (Int -> ST s ()) -> ST s ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1..Int
n] ((Int -> ST s ()) -> ST s ()) -> (Int -> ST s ()) -> ST s ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> STUArray s Int Int -> Int -> Int -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int
ar Int
i Int
i
    g
rnd' <- Int -> Int -> g -> STUArray s Int Int -> ST s g
forall g s.
RandomGen g =>
Int -> Int -> g -> STUArray s Int Int -> ST s g
worker Int
n (if Bool
isSattolo then Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1 else Int
n) g
rnd STUArray s Int Int
ar 
    UArray Int Int
perm <- STUArray s Int Int -> ST s (UArray Int Int)
forall i (a :: * -> * -> *) e (m :: * -> *) (b :: * -> * -> *).
(Ix i, MArray a e m, IArray b e) =>
a i e -> m (b i e)
Data.Array.Unsafe.unsafeFreeze STUArray s Int Int
ar
    (Permutation, g) -> ST s (Permutation, g)
forall (m :: * -> *) a. Monad m => a -> m a
return (WordVec -> Permutation
Permutation (UArray Int Int -> WordVec
fromUArray UArray Int Int
perm), g
rnd')
  worker :: RandomGen g => Int -> Int -> g -> STUArray s Int Int -> ST s g 
  worker :: Int -> Int -> g -> STUArray s Int Int -> ST s g
worker Int
n Int
m g
rnd STUArray s Int Int
ar = 
    if Int
nInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
1 
      then g -> ST s g
forall (m :: * -> *) a. Monad m => a -> m a
return g
rnd 
      else do
        let (Int
k,g
rnd') = (Int, Int) -> g -> (Int, g)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (Int
1,Int
m) g
rnd
        Bool -> ST s () -> ST s ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
n) (ST s () -> ST s ()) -> ST s () -> ST s ()
forall a b. (a -> b) -> a -> b
$ do
          Int
y <- STUArray s Int Int -> Int -> ST s Int
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Int
ar Int
k 
          Int
z <- STUArray s Int Int -> Int -> ST s Int
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray STUArray s Int Int
ar Int
n
          STUArray s Int Int -> Int -> Int -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int
ar Int
n Int
y
          STUArray s Int Int -> Int -> Int -> ST s ()
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> e -> m ()
writeArray STUArray s Int Int
ar Int
k Int
z
        Int -> Int -> g -> STUArray s Int Int -> ST s g
forall g s.
RandomGen g =>
Int -> Int -> g -> STUArray s Int Int -> ST s g
worker (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) (Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) g
rnd' STUArray s Int Int
ar 

--------------------------------------------------------------------------------
-- * Permutations of a multiset

-- | Generates all permutations of a multiset.  
--   The order is lexicographic. A synonym for 'fasc2B_algorithm_L'
permuteMultiset :: (Eq a, Ord a) => [a] -> [[a]] 
permuteMultiset :: [a] -> [[a]]
permuteMultiset = [a] -> [[a]]
forall a. (Eq a, Ord a) => [a] -> [[a]]
fasc2B_algorithm_L

-- | # = \\frac { (\sum_i n_i) ! } { \\prod_i (n_i !) }    
countPermuteMultiset :: (Eq a, Ord a) => [a] -> Integer
countPermuteMultiset :: [a] -> Integer
countPermuteMultiset [a]
xs = Int -> Integer
forall a. Integral a => a -> Integer
factorial Int
n Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` [Integer] -> Integer
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product [ Int -> Integer
forall a. Integral a => a -> Integer
factorial ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
z) | [a]
z <- [a] -> [[a]]
forall a. Eq a => [a] -> [[a]]
group [a]
ys ] 
  where
    ys :: [a]
ys = [a] -> [a]
forall a. Ord a => [a] -> [a]
sort [a]
xs
    n :: Int
n = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs
  
-- | Generates all permutations of a multiset 
--   (based on \"algorithm L\" in Knuth; somewhat less efficient). 
--   The order is lexicographic.  
fasc2B_algorithm_L :: (Eq a, Ord a) => [a] -> [[a]] 
fasc2B_algorithm_L :: [a] -> [[a]]
fasc2B_algorithm_L [a]
xs = ([a] -> Maybe [a]) -> [a] -> [[a]]
forall a. (a -> Maybe a) -> a -> [a]
unfold1 [a] -> Maybe [a]
forall a. Ord a => [a] -> Maybe [a]
next ([a] -> [a]
forall a. Ord a => [a] -> [a]
sort [a]
xs) where

  -- next :: [a] -> Maybe [a]
  next :: [a] -> Maybe [a]
next [a]
xs = case ([a], [a]) -> Maybe ([a], [a])
forall a. Ord a => ([a], [a]) -> Maybe ([a], [a])
findj ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
xs,[]) of 
    Maybe ([a], [a])
Nothing -> Maybe [a]
forall a. Maybe a
Nothing
    Just ( (a
l:[a]
ls) , [a]
rs) -> [a] -> Maybe [a]
forall a. a -> Maybe a
Just ([a] -> Maybe [a]) -> [a] -> Maybe [a]
forall a b. (a -> b) -> a -> b
$ a -> [a] -> ([a], [a]) -> [a]
forall a. Ord a => a -> [a] -> ([a], [a]) -> [a]
inc a
l [a]
ls ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
rs,[]) 
    Just ( [] , [a]
_ ) -> String -> Maybe [a]
forall a. HasCallStack => String -> a
error String
"permute: should not happen"

  -- we use simple list zippers: (left,right)
  -- findj :: ([a],[a]) -> Maybe ([a],[a])   
  findj :: ([a], [a]) -> Maybe ([a], [a])
findj ( xxs :: [a]
xxs@(a
x:[a]
xs) , yys :: [a]
yys@(a
y:[a]
_) ) = if a
x a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
y 
    then ([a], [a]) -> Maybe ([a], [a])
findj ( [a]
xs , a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
yys )
    else ([a], [a]) -> Maybe ([a], [a])
forall a. a -> Maybe a
Just ( [a]
xxs , [a]
yys )
  findj ( a
x:[a]
xs , [] ) = ([a], [a]) -> Maybe ([a], [a])
findj ( [a]
xs , [a
x] )  
  findj ( [] , [a]
_ ) = Maybe ([a], [a])
forall a. Maybe a
Nothing
  
  -- inc :: a -> [a] -> ([a],[a]) -> [a]
  inc :: a -> [a] -> ([a], [a]) -> [a]
inc !a
u [a]
us ( (a
x:[a]
xs) , [a]
yys ) = if a
u a -> a -> Bool
forall a. Ord a => a -> a -> Bool
>= a
x
    then a -> [a] -> ([a], [a]) -> [a]
inc a
u [a]
us ( [a]
xs , a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
yys ) 
    else [a] -> [a]
forall a. [a] -> [a]
reverse (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
us)  [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a] -> [a]
forall a. [a] -> [a]
reverse (a
ua -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
yys) [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
xs
  inc a
_ [a]
_ ( [] , [a]
_ ) = String -> [a]
forall a. HasCallStack => String -> a
error String
"permute: should not happen"
      
--------------------------------------------------------------------------------