-- | Ronald C. Read. \"Every one a winner or how to avoid isomorphism
-- search when cataloguing combinatorial configurations.\" /Annals of
-- Discrete Mathematics/ 2:107–20, 1978.
module Music.Theory.Z.Read_1978 where

import Data.Bits {- base -}
import Data.Char {- base -}
import Data.List {- base -}
import Data.Maybe {- base -}
import Data.Word {- base -}

import qualified Music.Theory.List as List {- hmt -}
import qualified Music.Theory.Z as Z {- hmt -}
import qualified Music.Theory.Z.Sro as Sro {- hmt -}

-- | Coding.
type Code = Word64

-- | Number of bits at 'Code'.
code_len :: Num n => n
code_len :: forall n. Num n => n
code_len = n
64

-- | Bit array.
type Bit_Array = [Bool]

-- | Logical complement.
bit_array_complement :: Bit_Array -> Bit_Array
bit_array_complement :: Bit_Array -> Bit_Array
bit_array_complement = forall a b. (a -> b) -> [a] -> [b]
map Bool -> Bool
not

-- | Pretty printer for 'Bit_Array'.
bit_array_pp :: Bit_Array -> String
bit_array_pp :: Bit_Array -> String
bit_array_pp = forall a b. (a -> b) -> [a] -> [b]
map (Int -> Char
intToDigit forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum)

-- | Parse PP of 'Bit_Array'.
--
-- > bit_array_parse "01001" == [False,True,False,False,True]
bit_array_parse :: String -> Bit_Array
bit_array_parse :: String -> Bit_Array
bit_array_parse = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Enum a => Int -> a
toEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
digitToInt)

-- * MSB (BIG-ENDIAN)

-- | Generate 'Code' from 'Bit_Array', the coding is most to least significant.
--
-- > map (bit_array_to_code . bit_array_parse) (words "000 001 010 011 100 101 110 111") == [0..7]
-- > bit_array_to_code (bit_array_parse "1100100011100") == 6428
bit_array_to_code :: Bit_Array -> Code
bit_array_to_code :: Bit_Array -> Code
bit_array_to_code Bit_Array
a =
  let n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length Bit_Array
a
      f :: Bool -> Int -> a
f Bool
e Int
j = if Bool
e then a
2 forall a b. (Num a, Integral b) => a -> b -> a
^ (Int
n forall a. Num a => a -> a -> a
- Int
j forall a. Num a => a -> a -> a
- Int
1) else a
0
  in if Int
n forall a. Ord a => a -> a -> Bool
> forall n. Num n => n
code_len
     then forall a. HasCallStack => String -> a
error String
"bit_array_to_code: > SZ"
     else forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {a}. Num a => Bool -> Int -> a
f Bit_Array
a [Int
0..])

-- | Inverse of 'bit_array_to_code'.
--
-- > code_to_bit_array 13 6428 == bit_array_parse "1100100011100"
code_to_bit_array :: Int -> Code -> Bit_Array
code_to_bit_array :: Int -> Code -> Bit_Array
code_to_bit_array Int
n Code
c =
  if Int
n forall a. Ord a => a -> a -> Bool
> forall n. Num n => n
code_len
  then forall a. HasCallStack => String -> a
error String
"code_to_bit_array: > SZ"
  else forall a b. (a -> b) -> [a] -> [b]
map (forall a. Bits a => a -> Int -> Bool
testBit Code
c) [Int
n forall a. Num a => a -> a -> a
- Int
1, Int
n forall a. Num a => a -> a -> a
- Int
2 .. Int
0]

-- | 'Bit_Array' to set.
--
-- > bit_array_to_set (bit_array_parse "1100100011100") == [0,1,4,8,9,10]
-- > set_to_code 13 [0,1,4,8,9,10] == 6428
bit_array_to_set :: Integral i => Bit_Array -> [i]
bit_array_to_set :: forall i. Integral i => Bit_Array -> [i]
bit_array_to_set =
    let f :: (a, Bool) -> Maybe a
f (a
i,Bool
e) = if Bool
e then forall a. a -> Maybe a
Just a
i else forall a. Maybe a
Nothing
    in forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall {a}. (a, Bool) -> Maybe a
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [i
0..]

-- | Inverse of 'bit_array_to_set', /z/ is the degree of the array.
set_to_bit_array :: Integral i => i -> [i] -> Bit_Array
set_to_bit_array :: forall i. Integral i => i -> [i] -> Bit_Array
set_to_bit_array i
z [i]
p =
  if i
z forall a. Ord a => a -> a -> Bool
> forall n. Num n => n
code_len
  then forall a. HasCallStack => String -> a
error String
"set_to_bit_array: > SZ"
  else forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [i]
p) [i
0 .. i
z forall a. Num a => a -> a -> a
- i
1]

-- | 'bit_array_to_code' of 'set_to_bit_array'.
--
-- > set_to_code 12 [0,2,3,5] == 2880
-- > map (set_to_code 12) (Sro.z_sro_ti_related (flip mod 12) [0,2,3,5])
set_to_code :: Integral i => i -> [i] -> Code
set_to_code :: forall i. Integral i => i -> [i] -> Code
set_to_code i
z = Bit_Array -> Code
bit_array_to_code forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i. Integral i => i -> [i] -> Bit_Array
set_to_bit_array i
z

-- | The /prime/ form is the 'maximum' encoding.
--
-- > bit_array_is_prime (set_to_bit_array 12 [0,2,3,5]) == False
bit_array_is_prime :: Bit_Array -> Bool
bit_array_is_prime :: Bit_Array -> Bool
bit_array_is_prime Bit_Array
a =
    let c :: Code
c = Bit_Array -> Code
bit_array_to_code Bit_Array
a
        p :: [Int]
p = forall i. Integral i => Bit_Array -> [i]
bit_array_to_set Bit_Array
a
        n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length Bit_Array
a
        z :: Z Int
z = forall i. i -> Z i
Z.Z Int
n
        u :: Code
u = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (forall a b. (a -> b) -> [a] -> [b]
map (forall i. Integral i => i -> [i] -> Code
set_to_code Int
n) (forall (f :: * -> *) i.
(Eq (f i), Integral i, Functor f) =>
Z i -> f i -> [f i]
Sro.z_sro_ti_related Z Int
z [Int]
p))
    in Code
c forall a. Eq a => a -> a -> Bool
== Code
u

-- | The augmentation rule adds @1@ in each empty slot at end of array.
--
-- > map bit_array_pp (bit_array_augment (bit_array_parse "01000")) == ["01100","01010","01001"]
bit_array_augment :: Bit_Array -> [Bit_Array]
bit_array_augment :: Bit_Array -> [Bit_Array]
bit_array_augment Bit_Array
a =
    let (Bit_Array
z,Bit_Array
a') = forall a. (a -> Bool) -> [a] -> ([a], [a])
break forall a. a -> a
id (forall a. [a] -> [a]
reverse Bit_Array
a)
        a'' :: Bit_Array
a'' = forall a. [a] -> [a]
reverse Bit_Array
a'
        n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length Bit_Array
z
        f :: Int -> Bit_Array
f Int
k = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Eq a => a -> a -> Bool
== Int
k) [Int
0 .. Int
n forall a. Num a => a -> a -> a
- Int
1]
        x :: [Bit_Array]
x = forall a b. (a -> b) -> [a] -> [b]
map Int -> Bit_Array
f [Int
0 .. Int
n forall a. Num a => a -> a -> a
- Int
1]
    in forall a b. (a -> b) -> [a] -> [b]
map (Bit_Array
a'' forall a. [a] -> [a] -> [a]
++) [Bit_Array]
x

-- | Enumerate first half of the set-classes under given /prime/ function.
--   The second half can be derived as the complement of the first.
--
-- > import Music.Theory.Z.Forte_1973
-- > length scs == 224
-- > map (length . scs_n) [0..12] == [1,1,6,12,29,38,50,38,29,12,6,1,1]
--
-- > let z12 = map (fmap (map bit_array_to_set)) (enumerate_half bit_array_is_prime 12)
-- > map (length . snd) z12 == [1,1,6,12,29,38,50]
--
-- This can become slow, edit /z/ to find out.  It doesn't matter
-- about /n/.  This can be edited so that small /n/ would run quickly
-- even for large /z/.
--
-- > fmap (map bit_array_to_set) (lookup 5 (enumerate_half bit_array_is_prime 16))
enumerate_half :: (Bit_Array -> Bool) -> Int -> [(Int,[Bit_Array])]
enumerate_half :: (Bit_Array -> Bool) -> Int -> [(Int, [Bit_Array])]
enumerate_half Bit_Array -> Bool
pr Int
n =
    let a0 :: Bit_Array
a0 = forall a. Int -> a -> [a]
replicate Int
n Bool
False
        f :: Int -> Bit_Array -> [(Int, [Bit_Array])]
f Int
k Bit_Array
a = if Int
k forall a. Ord a => a -> a -> Bool
>= Int
n forall a. Integral a => a -> a -> a
`div` Int
2
                then []
                else let r :: [Bit_Array]
r = forall a. (a -> Bool) -> [a] -> [a]
filter Bit_Array -> Bool
pr (Bit_Array -> [Bit_Array]
bit_array_augment Bit_Array
a)
                     in (Int
k forall a. Num a => a -> a -> a
+ Int
1,[Bit_Array]
r) forall a. a -> [a] -> [a]
: forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Int -> Bit_Array -> [(Int, [Bit_Array])]
f (Int
k forall a. Num a => a -> a -> a
+ Int
1)) [Bit_Array]
r
        jn :: [(a, [a])] -> (a, [a])
jn [(a, [a])]
l = case [(a, [a])]
l of
                 (a
x,[a]
y):[(a, [a])]
l' -> (a
x,forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([a]
y forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(a, [a])]
l'))
                 [(a, [a])]
_ -> forall a. HasCallStack => String -> a
error String
""
        post_proc :: [(Int, [a])] -> [(Int, [a])]
post_proc = forall a b. (a -> b) -> [a] -> [b]
map forall {a} {a}. [(a, [a])] -> (a, [a])
jn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall x a. Eq x => (a -> x) -> [a] -> [[a]]
List.group_on forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn forall a b. (a, b) -> a
fst
    in forall {a}. [(Int, [a])] -> [(Int, [a])]
post_proc ((Int
0,[Bit_Array
a0]) forall a. a -> [a] -> [a]
: Int -> Bit_Array -> [(Int, [Bit_Array])]
f Int
0 Bit_Array
a0)

-- * LSB - LITTLE-ENDIAN

-- | If the size of the set is '>' 'code_len' then 'error', else 'id'.
set_coding_validate :: [t] -> [t]
set_coding_validate :: forall a. [a] -> [a]
set_coding_validate [t]
l = if forall (t :: * -> *) a. Foldable t => t a -> Int
length [t]
l forall a. Ord a => a -> a -> Bool
<= forall n. Num n => n
code_len then [t]
l else forall a. HasCallStack => String -> a
error String
"set_coding_validate: SIZE"

-- | Encoder for 'encode_prime'.
--
-- > map set_encode [[0,1,3,7,8],[0,1,3,6,8,9]] == [395,843]
--
-- > map (set_to_code 12) [[0,1,3,7,8],[0,1,3,6,8,9]] == [3352,3372]
set_encode :: Integral i => [i] -> Code
set_encode :: forall i. Integral i => [i] -> Code
set_encode = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Code
2 forall a b. (Num a, Integral b) => a -> b -> a
^) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
set_coding_validate

-- | Decoder for 'encode_prime'.
--
-- > map (set_decode 12) [395,843] == [[0,1,3,7,8],[0,1,3,6,8,9]]
set_decode :: Integral i => Int -> Code -> [i]
set_decode :: forall i. Integral i => Int -> Code -> [i]
set_decode Int
z Code
n =
    let f :: Int -> (a, Bool)
f Int
i = (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i,forall a. Bits a => a -> Int -> Bool
testBit Code
n Int
i)
    in forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst (forall a. (a -> Bool) -> [a] -> [a]
filter forall a b. (a, b) -> b
snd (forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Num a => Int -> (a, Bool)
f [Int
0 .. Int
z forall a. Num a => a -> a -> a
- Int
1]))

-- | Binary encoding prime form algorithm, equalivalent to Rahn.
--
-- > set_encode_prime Z.z12 [0,1,3,6,8,9] == [0,2,3,6,7,9]
-- > Music.Theory.Z.Rahn_1980.rahn_prime Z.z12 [0,1,3,6,8,9] == [0,2,3,6,7,9]
set_encode_prime :: Integral i => Z.Z i -> [i] -> [i]
set_encode_prime :: forall i. Integral i => Z i -> [i] -> [i]
set_encode_prime Z i
z [i]
s =
    let t :: [[i]]
t = forall a b. (a -> b) -> [a] -> [b]
map (\i
x -> forall i (f :: * -> *).
(Integral i, Functor f) =>
Z i -> i -> f i -> f i
Sro.z_sro_tn Z i
z i
x [i]
s) (forall i. Integral i => Z i -> [i]
Z.z_univ Z i
z)
        c :: [[i]]
c = [[i]]
t forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (forall i (f :: * -> *).
(Integral i, Functor f) =>
Z i -> i -> f i -> f i
Sro.z_sro_invert Z i
z i
0) [[i]]
t
    in forall i. Integral i => Int -> Code -> [i]
set_decode (forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall i. Z i -> i
Z.z_modulus Z i
z)) (forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (forall a b. (a -> b) -> [a] -> [b]
map forall i. Integral i => [i] -> Code
set_encode [[i]]
c))