-- | Permutation functions.
module Music.Theory.Permutations where

import Data.List {- base -}
import qualified Numeric {- base -}

import qualified Music.Theory.List as L {- hmt-base -}

-- | Factorial function.
--
-- > (factorial 20,maxBound::Int)
factorial :: Integral n => n -> n
factorial :: forall n. Integral n => n -> n
factorial n
n = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
product [n
1..n
n]

-- | Number of /k/ element permutations of a set of /n/ elements.
--
-- > let f = nk_permutations in (f 3 2,f 3 3,f 4 3,f 4 4,f 13 3,f 12 12) == (6,6,24,24,1716,479001600)
nk_permutations :: Integral a => a -> a -> a
nk_permutations :: forall a. Integral a => a -> a -> a
nk_permutations a
n a
k = forall n. Integral n => n -> n
factorial a
n  forall a. Integral a => a -> a -> a
`div` forall n. Integral n => n -> n
factorial (a
n forall a. Num a => a -> a -> a
- a
k)

-- | Number of /nk/ permutations where /n/ '==' /k/.
--
-- > map n_permutations [1..8] == [1,2,6,24,120,720,5040,40320]
-- > n_permutations 12 == 479001600
-- > n_permutations 16 `div` 1000000 == 20922789
n_permutations :: (Integral a) => a -> a
n_permutations :: forall n. Integral n => n -> n
n_permutations a
n = forall a. Integral a => a -> a -> a
nk_permutations a
n a
n

-- | Permutation given as a zero-indexed list of destination indices.
type Permutation = [Int]

{- | Generate the permutation from /p/ to /q/, ie. the permutation
     that, when applied to /p/, gives /q/.

> p = permutation "abc" "bac"
> p == [1,0,2]
> apply_permutation p "abc" == "bac"
-}
permutation :: Eq t => [t] -> [t] -> Permutation
permutation :: forall t. Eq t => [t] -> [t] -> Permutation
permutation [t]
p [t]
q =
    let f :: t -> Int
f t
x = forall a. Eq a => a -> [a] -> Int
L.elem_index_unique t
x [t]
p
    in forall a b. (a -> b) -> [a] -> [b]
map t -> Int
f [t]
q

-- | Permutation to list of swaps, ie. 'zip' [0..]
--
-- > permutation_to_swaps [0,2,1,3] == [(0,0),(1,2),(2,1),(3,3)]
permutation_to_swaps :: Permutation -> [(Int,Int)]
permutation_to_swaps :: Permutation -> [(Int, Int)]
permutation_to_swaps = forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..]

-- | Inverse of 'permutation_to_swaps', ie. 'map' 'snd' '.' 'sort'
swaps_to_permutation :: [(Int,Int)] -> Permutation
swaps_to_permutation :: [(Int, Int)] -> Permutation
swaps_to_permutation = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
sort

-- | List of cycles to list of swaps.
--
-- > cycles_to_swaps [[0,2],[1],[3,4]] == [(0,2),(1,1),(2,0),(3,4),(4,3)]
cycles_to_swaps :: [[Int]] -> [(Int,Int)]
cycles_to_swaps :: [Permutation] -> [(Int, Int)]
cycles_to_swaps = forall a. Ord a => [a] -> [a]
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall t. Int -> [t] -> [(t, t)]
L.adj2_cyclic Int
1)

-- > swaps_to_cycles [(0,2),(1,1),(2,0),(3,4),(4,3)] == [[0,2],[1],[3,4]]
swaps_to_cycles :: [(Int, Int)] -> [[Int]]
swaps_to_cycles :: [(Int, Int)] -> [Permutation]
swaps_to_cycles [(Int, Int)]
s =
  let z :: Int
z = forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, Int)]
s
      next :: Int -> Int
next Int
k = forall k v. Eq k => k -> [(k, v)] -> v
L.lookup_err Int
k [(Int, Int)]
s
      trace :: Int -> Permutation
trace Int
k =
        let f :: Permutation -> Int -> Permutation
f Permutation
r Int
i = let j :: Int
j = Int -> Int
next Int
i in if Int
j forall a. Eq a => a -> a -> Bool
== Int
k then forall a. [a] -> [a]
reverse Permutation
r else Permutation -> Int -> Permutation
f (Int
j forall a. a -> [a] -> [a]
: Permutation
r) Int
j
        in Permutation -> Int -> Permutation
f [Int
k] Int
k
      step :: [Permutation] -> Int -> [Permutation]
step [Permutation]
r Int
k =
        if Int
k forall a. Eq a => a -> a -> Bool
== Int
z
        then forall a. [a] -> [a]
reverse [Permutation]
r
        else if Int
k forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [Permutation]
r then [Permutation] -> Int -> [Permutation]
step [Permutation]
r (Int
k forall a. Num a => a -> a -> a
+ Int
1) else [Permutation] -> Int -> [Permutation]
step (Int -> Permutation
trace Int
k forall a. a -> [a] -> [a]
: [Permutation]
r) (Int
k forall a. Num a => a -> a -> a
+ Int
1)
  in [Permutation] -> Int -> [Permutation]
step [] Int
0

{- | Apply permutation /f/ to /p/.

> let p = permutation [1..4] [4,3,2,1]
> p == [3,2,1,0]
> apply_permutation p [1..4] == [4,3,2,1]
-}
apply_permutation :: Permutation -> [t] -> [t]
apply_permutation :: forall t. Permutation -> [t] -> [t]
apply_permutation Permutation
f [t]
p = forall a b. (a -> b) -> [a] -> [b]
map ([t]
p forall a. [a] -> Int -> a
!!) Permutation
f

-- | Composition of 'apply_permutation' and 'from_cycles_zero_indexed'.
--
-- > apply_permutation_c_zero_indexed [[0,3],[1,2]] [1..4] == [4,3,2,1]
-- > apply_permutation_c_zero_indexed [[0,2],[1],[3,4]] [1..5] == [3,2,1,5,4]
-- > apply_permutation_c_zero_indexed [[0,1,4],[2,3]] [1..5] == [2,5,4,3,1]
-- > apply_permutation_c_zero_indexed [[0,1,3],[2,4]] [1..5] == [2,4,5,1,3]
apply_permutation_c_zero_indexed :: [[Int]] -> [a] -> [a]
apply_permutation_c_zero_indexed :: forall a. [Permutation] -> [a] -> [a]
apply_permutation_c_zero_indexed = forall t. Permutation -> [t] -> [t]
apply_permutation forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Permutation] -> Permutation
from_cycles_zero_indexed

-- > p_inverse [2,7,4,9,8,3,5,0,6,1] == [7,9,0,5,2,6,8,1,4,3]
p_inverse :: Permutation -> Permutation
p_inverse :: Permutation -> Permutation
p_inverse = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..]

p_cycles :: Permutation -> [[Int]]
p_cycles :: Permutation -> [Permutation]
p_cycles = [(Int, Int)] -> [Permutation]
swaps_to_cycles forall b c a. (b -> c) -> (a -> b) -> a -> c
. Permutation -> [(Int, Int)]
permutation_to_swaps

{- | True if the inverse of /p/ is /p/.

> non_invertible [1,0,2] == True
> non_invertible [2,7,4,9,8,3,5,0,6,1] == False

> let p = permutation [1..4] [4,3,2,1]
> non_invertible p == True && p_cycles p == [[0,3],[1,2]]
-}
non_invertible :: Permutation -> Bool
non_invertible :: Permutation -> Bool
non_invertible Permutation
p = Permutation
p forall a. Eq a => a -> a -> Bool
== Permutation -> Permutation
p_inverse Permutation
p

-- | Generate a permutation from the cycles /c/ (zero-indexed)
--
-- > apply_permutation (from_cycles_zero_indexed [[0,1,2,3]]) [1..4] == [2,3,4,1]
from_cycles_zero_indexed :: [[Int]] -> Permutation
from_cycles_zero_indexed :: [Permutation] -> Permutation
from_cycles_zero_indexed = [(Int, Int)] -> Permutation
swaps_to_permutation forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Permutation] -> [(Int, Int)]
cycles_to_swaps

from_cycles_one_indexed :: [[Int]] -> Permutation
from_cycles_one_indexed :: [Permutation] -> Permutation
from_cycles_one_indexed = [Permutation] -> Permutation
from_cycles_zero_indexed forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Num a => a -> a -> a
subtract Int
1))

-- | Generate all permutations of size /n/ (naive)
--
-- > let r = [[1,2,3],[1,3,2],[2,1,3],[2,3,1],[3,1,2],[3,2,1]]
-- > map one_line (permutations_n 3) == r
permutations_n :: Int -> [Permutation]
permutations_n :: Int -> [Permutation]
permutations_n Int
n =
  let minus :: [t] -> t -> [t]
minus [] t
_ = []
      minus (t
x:[t]
xs) t
i = if t
x forall a. Ord a => a -> a -> Bool
< t
i then t
x forall a. a -> [a] -> [a]
: [t] -> t -> [t]
minus [t]
xs t
i else [t]
xs
      f :: [a] -> [[a]]
f [] = [[]]
      f [a]
xs = [a
i forall a. a -> [a] -> [a]
: [a]
ys | a
i <- [a]
xs , [a]
ys <- [a] -> [[a]]
f ([a]
xs forall {t}. Ord t => [t] -> t -> [t]
`minus` a
i)]
  in case Int
n of
       Int
0 -> []
       Int
1 -> [[Int
0]]
       Int
_ -> forall {a}. Ord a => [a] -> [[a]]
f [Int
0 .. Int
n forall a. Num a => a -> a -> a
- Int
1]

p_size :: Permutation -> Int
p_size :: Permutation -> Int
p_size = forall (t :: * -> *) a. Foldable t => t a -> Int
length

{- | Composition of /q/ then /p/.

> let p = from_cycles_zero_indexed [[0,2],[1],[3,4]]
> let q = from_cycles_zero_indexed [[0,1,4],[2,3]]
> let r = p `compose` q
> apply_permutation r [1,2,3,4,5] == [2,4,5,1,3]
-}
compose :: Permutation -> Permutation -> Permutation
compose :: Permutation -> Permutation -> Permutation
compose Permutation
p Permutation
q =
    let n :: Int
n = Permutation -> Int
p_size Permutation
q
        i :: Permutation
i = [Int
1 .. Int
n]
        j :: Permutation
j = forall t. Permutation -> [t] -> [t]
apply_permutation Permutation
p Permutation
i
        k :: Permutation
k = forall t. Permutation -> [t] -> [t]
apply_permutation Permutation
q Permutation
j
    in forall t. Eq t => [t] -> [t] -> Permutation
permutation Permutation
i Permutation
k

-- | One-indexed 'p_cycles'
cycles_one_indexed :: Permutation -> [[Int]]
cycles_one_indexed :: Permutation -> [Permutation]
cycles_one_indexed = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map (forall a. Num a => a -> a -> a
+ Int
1)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Permutation -> [Permutation]
p_cycles

{- | 'flip' of 'compose'

> cycles_one_indexed (from_cycles_one_indexed [[1,5],[2,3,6],[4]] `permutation_mul` from_cycles_one_indexed [[1,6,4],[2],[3,5]])
-}
permutation_mul :: Permutation -> Permutation -> Permutation
permutation_mul :: Permutation -> Permutation -> Permutation
permutation_mul Permutation
p Permutation
q = Permutation -> Permutation -> Permutation
compose Permutation
q Permutation
p

-- | Two line notation of /p/.
--
-- > two_line (permutation [0,1,3] [1,0,3]) == ([1,2,3],[2,1,3])
two_line :: Permutation -> ([Int],[Int])
two_line :: Permutation -> (Permutation, Permutation)
two_line Permutation
p =
    let n :: Int
n = Permutation -> Int
p_size Permutation
p
        i :: Permutation
i = [Int
1..Int
n]
    in (Permutation
i,forall t. Permutation -> [t] -> [t]
apply_permutation Permutation
p Permutation
i)

-- | One line notation of /p/.
--
-- > one_line (permutation [0,1,3] [1,0,3]) == [2,1,3]
--
-- > let r = [[1,2,3],[1,3,2],[2,1,3],[2,3,1],[3,1,2],[3,2,1]]
-- > map one_line (permutations_n 3) == r
one_line :: Permutation -> [Int]
one_line :: Permutation -> Permutation
one_line = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. Permutation -> (Permutation, Permutation)
two_line

-- | Variant of 'one_line' that produces a compact string.
--
-- > one_line_compact (permutation [0,1,3] [1,0,3]) == "213"
--
-- > let p = permutations_n 3
-- > unwords (map one_line_compact p) == "123 132 213 231 312 321"
one_line_compact :: Permutation -> String
one_line_compact :: Permutation -> String
one_line_compact =
    let f :: a -> String
f a
n = if a
n forall a. Ord a => a -> a -> Bool
>= a
0 Bool -> Bool -> Bool
&& a
n forall a. Ord a => a -> a -> Bool
<= a
15
              then forall a. (Integral a, Show a) => a -> ShowS
Numeric.showHex a
n String
""
              else forall a. HasCallStack => String -> a
error String
"one_line_compact:not(0-15)"
    in forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a}. (Integral a, Show a) => a -> String
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Permutation -> Permutation
one_line

-- | Multiplication table of symmetric group /n/.
--
-- > unlines (map (unwords . map one_line_compact) (multiplication_table 3))
--
-- @
-- ==> 123 132 213 231 312 321
--     132 123 312 321 213 231
--     213 231 123 132 321 312
--     231 213 321 312 123 132
--     312 321 132 123 231 213
--     321 312 231 213 132 123
-- @
multiplication_table :: Int -> [[Permutation]]
multiplication_table :: Int -> [[Permutation]]
multiplication_table Int
n =
    let ps :: [Permutation]
ps = Int -> [Permutation]
permutations_n Int
n
        f :: Permutation -> [Permutation]
f Permutation
p = forall a b. (a -> b) -> [a] -> [b]
map (Permutation -> Permutation -> Permutation
compose Permutation
p) [Permutation]
ps
    in forall a b. (a -> b) -> [a] -> [b]
map Permutation -> [Permutation]
f [Permutation]
ps

{-

let q = permutation [1..4] [2,3,4,1] -- [[0,1,2,3]]
(q,non_invertible q,p_cycles q,apply_permutation q [1..4])

let p = permutation [1..5] [3,2,1,5,4] -- [[0,2],[1],[3,4]]
let q = permutation [1..5] [2,5,4,3,1] -- [[0,1,4],[2,3]]
let r = permutation [1..5] [2,4,5,1,3] -- [[0,1,3],[2,4]]
(non_invertible p,p_cycles p,apply_permutation p [1..5])
(non_invertible q,p_cycles q,apply_permutation q [1..5])
(non_invertible r,p_cycles r,apply_permutation r [1..5])

map p_cycles (permutations_n 3)
map p_cycles (permutations_n 4)

import Data.List {- base -}
partition not (map non_invertible (permutations_n 4))
putStrLn $ unlines $ map unwords $ permutations ["A0","A1","B0"]

-}