-- | Place notation (method ringing).
--
-- Morris, R. G. T. "Place Notation"
-- Central Council of Church Bell Ringers (1984).
-- <http://www.cccbr.org.uk/bibliography/>
module Music.Theory.Permutations.Morris_1984 where

import Data.List {- base -}
import Data.List.Split {- split -}
import Data.Maybe {- base -}

import qualified Music.Theory.List as T {- hmt-base -}
import qualified Music.Theory.Permutations as T {- hmt-base -}
import qualified Music.Theory.Tuple as T {- hmt-base -}

-- | A change either swaps all adjacent bells, or holds a subset of bells.
data Change = Swap_All | Hold [Int] deriving (Change -> Change -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Change -> Change -> Bool
$c/= :: Change -> Change -> Bool
== :: Change -> Change -> Bool
$c== :: Change -> Change -> Bool
Eq,Int -> Change -> ShowS
[Change] -> ShowS
Change -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Change] -> ShowS
$cshowList :: [Change] -> ShowS
show :: Change -> String
$cshow :: Change -> String
showsPrec :: Int -> Change -> ShowS
$cshowsPrec :: Int -> Change -> ShowS
Show)

-- | A method is a sequence of changes, if symmetrical only half the
-- changes are given and the lead end.
data Method = Method [Change] (Maybe [Change]) deriving (Method -> Method -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Method -> Method -> Bool
$c/= :: Method -> Method -> Bool
== :: Method -> Method -> Bool
$c== :: Method -> Method -> Bool
Eq,Int -> Method -> ShowS
[Method] -> ShowS
Method -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Method] -> ShowS
$cshowList :: [Method] -> ShowS
show :: Method -> String
$cshow :: Method -> String
showsPrec :: Int -> Method -> ShowS
$cshowsPrec :: Int -> Method -> ShowS
Show)

-- | Maximum hold value at 'Method'
method_limit :: Method -> Int
method_limit :: Method -> Int
method_limit (Method [Change]
p Maybe [Change]
q) =
  let f :: Change -> Int
f Change
c = case Change
c of
              Change
Swap_All -> Int
0
              Hold [Int]
i -> forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [Int]
i
  in forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (forall a b. (a -> b) -> [a] -> [b]
map Change -> Int
f ([Change]
p forall a. [a] -> [a] -> [a]
++ forall a. a -> Maybe a -> a
fromMaybe [] Maybe [Change]
q))

-- | Complete list of 'Change's at 'Method', writing out symmetries.
method_changes :: Method -> [Change]
method_changes :: Method -> [Change]
method_changes (Method [Change]
p Maybe [Change]
q) =
    case Maybe [Change]
q of
      Maybe [Change]
Nothing -> [Change]
p
      Just [Change]
le -> [Change]
p forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [a]
tail (forall a. [a] -> [a]
reverse [Change]
p) forall a. [a] -> [a] -> [a]
++ [Change]
le

-- | Parse a change notation.
--
-- > map parse_change ["-","x","38"] == [Swap_All,Swap_All,Hold [3,8]]
parse_change :: String -> Change
parse_change :: String -> Change
parse_change String
s = if String -> Bool
is_swap_all String
s then Change
Swap_All else [Int] -> Change
Hold (forall a b. (a -> b) -> [a] -> [b]
map Char -> Int
nchar_to_int String
s)

-- | Separate changes.
--
-- > split_changes "-38-14-1258-36-14-58-16-78"
-- > split_changes "345.145.5.1.345" == ["345","145","5","1","345"]
split_changes :: String -> [String]
split_changes :: String -> [String]
split_changes = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= String
".") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Splitter a -> [a] -> [[a]]
split (forall a. Splitter a -> Splitter a
dropInitBlank (forall a. Eq a => [a] -> Splitter a
oneOf String
"-x."))

-- | Place notation, sequence of changes with possible lead end.
type Place = (String,Maybe String)

-- | Parse 'Method' given 'PLACE' notation.
parse_method :: Place -> Method
parse_method :: Place -> Method
parse_method (String
p,Maybe String
q) =
    let f :: String -> [Change]
f = forall a b. (a -> b) -> [a] -> [b]
map String -> Change
parse_change forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
split_changes
    in [Change] -> Maybe [Change] -> Method
Method (String -> [Change]
f String
p) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> [Change]
f Maybe String
q)

-- | Parse string into 'Place'.
--
-- > parse_method (parse_place "-38-14-1258-36-14-58-16-78,12")
parse_place :: String -> Place
parse_place :: String -> Place
parse_place String
txt =
  case forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
"," String
txt of
    [String
p] -> (String
p,forall a. Maybe a
Nothing)
    [String
p,String
q] -> (String
p,forall a. a -> Maybe a
Just String
q)
    [String]
_ -> forall a. HasCallStack => String -> a
error String
"parse_place?"

-- | - or x?
--
-- > map is_swap_all ["-","x","38"] == [True,True,False]
is_swap_all :: String -> Bool
is_swap_all :: String -> Bool
is_swap_all = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [String
"-",String
"x"]

-- | Flatten list of pairs.
--
-- > flatten_pairs [(1,2),(3,4)] == [1..4]
flatten_pairs :: [(a,a)] -> [a]
flatten_pairs :: forall a. [(a, a)] -> [a]
flatten_pairs = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. T2 a -> [a]
T.t2_to_list

-- | Swap all adjacent pairs at list.
--
-- > swap_all [1 .. 8] == [2,1,4,3,6,5,8,7]
swap_all :: [a] -> [a]
swap_all :: forall a. [a] -> [a]
swap_all = forall a. [(a, a)] -> [a]
flatten_pairs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall s t. (s, t) -> (t, s)
T.p2_swap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Int -> [t] -> [(t, t)]
T.adj2 Int
2

numeric_spelling_tbl :: [(Char,Int)]
numeric_spelling_tbl :: [(Char, Int)]
numeric_spelling_tbl = forall a b. [a] -> [b] -> [(a, b)]
zip String
"1234567890ETABCDFGHJKL" [Int
1 .. Int
22]

-- | Parse abbreviated 'Hold' notation, characters are NOT hexadecimal.
--
-- > map nchar_to_int "380ETA" == [3,8,10,11,12,13]
nchar_to_int :: Char -> Int
nchar_to_int :: Char -> Int
nchar_to_int = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"nchar_to_int") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [(Char, Int)]
numeric_spelling_tbl

-- | Inverse of 'nchar_to_int'.
--
-- > map int_to_nchar [3,8,10,11,12,13] == "380ETA"
int_to_nchar :: Int -> Char
int_to_nchar :: Int -> Char
int_to_nchar = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall v k. Eq v => v -> [(k, v)] -> k
T.reverse_lookup_err [(Char, Int)]
numeric_spelling_tbl

-- | Given a 'Hold' notation, generate permutation cycles.
--
-- > let r = [Right (1,2),Left 3,Right (4,5),Right (6,7),Left 8]
-- > gen_swaps 8 [3,8] == r
--
-- > r = [Left 1,Left 2,Right (3,4),Right (5,6),Right (7,8)]
-- > gen_swaps 8 [1,2] == r
gen_swaps :: (Num t, Ord t) => t -> [t] -> [Either t (t,t)]
gen_swaps :: forall t. (Num t, Ord t) => t -> [t] -> [Either t (t, t)]
gen_swaps t
k =
    let close :: t -> [Either a (t, t)]
close t
n = if t
n forall a. Ord a => a -> a -> Bool
< t
k then forall a b. b -> Either a b
Right (t
n,t
n forall a. Num a => a -> a -> a
+ t
1) forall a. a -> [a] -> [a]
: t -> [Either a (t, t)]
close (t
n forall a. Num a => a -> a -> a
+ t
2) else []
        rec :: t -> [t] -> [Either t (t, t)]
rec t
n [t]
l = case [t]
l of
                    [] -> forall {a}. t -> [Either a (t, t)]
close t
n
                    t
m:[t]
l' -> if t
n forall a. Ord a => a -> a -> Bool
< t
m
                            then forall a b. b -> Either a b
Right (t
n,t
nforall a. Num a => a -> a -> a
+t
1) forall a. a -> [a] -> [a]
: t -> [t] -> [Either t (t, t)]
rec (t
n forall a. Num a => a -> a -> a
+ t
2) [t]
l
                            else forall a b. a -> Either a b
Left t
n forall a. a -> [a] -> [a]
: t -> [t] -> [Either t (t, t)]
rec (t
m forall a. Num a => a -> a -> a
+ t
1) [t]
l'
    in t -> [t] -> [Either t (t, t)]
rec t
1

-- | Given two sequences, derive the one-indexed "hold" list.
--
-- > derive_holds ("12345","13254") == [1]
derive_holds :: (Eq a,Enum n,Num n) => ([a],[a]) -> [n]
derive_holds :: forall a n. (Eq a, Enum n, Num n) => ([a], [a]) -> [n]
derive_holds ([a]
p,[a]
q) =
    let f :: a -> (a, a) -> Maybe a
f a
n (a
i,a
j) = if a
i forall a. Eq a => a -> a -> Bool
== a
j then forall a. a -> Maybe a
Just a
n else forall a. Maybe a
Nothing
    in forall a. [Maybe a] -> [a]
catMaybes (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {a} {a}. Eq a => a -> (a, a) -> Maybe a
f [n
1..] (forall a b. [a] -> [b] -> [(a, b)]
zip [a]
p [a]
q))

-- | Two-tuple to two element list.
pair_to_list :: (t,t) -> [t]
pair_to_list :: forall a. T2 a -> [a]
pair_to_list (t
p,t
q) = [t
p,t
q]

-- | Swap notation to plain permutation cycles notation.
--
-- > let n = [Left 1,Left 2,Right (3,4),Right (5,6),Right (7,8)]
-- > in swaps_to_cycles n == [[1],[2],[3,4],[5,6],[7,8]]
swaps_to_cycles :: [Either t (t,t)] -> [[t]]
swaps_to_cycles :: forall t. [Either t (t, t)] -> [[t]]
swaps_to_cycles = forall a b. (a -> b) -> [a] -> [b]
map (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall (m :: * -> *) a. Monad m => a -> m a
return forall a. T2 a -> [a]
pair_to_list)

-- | One-indexed permutation cycles to zero-indexed.
--
-- > let r = [[0],[1],[2,3],[4,5],[6,7]]
-- > to_zero_indexed [[1],[2],[3,4],[5,6],[7,8]] == r
to_zero_indexed :: Enum t => [[t]] -> [[t]]
to_zero_indexed :: forall t. Enum t => [[t]] -> [[t]]
to_zero_indexed = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map forall a. Enum a => a -> a
pred)

-- | Apply abbreviated 'Hold' notation, given cardinality.
--
-- > swap_abbrev 8 [3,8] [2,1,4,3,6,5,8,7] == [1,2,4,6,3,8,5,7]
swap_abbrev :: Int -> [Int] -> [a] -> [a]
swap_abbrev :: forall a. Int -> [Int] -> [a] -> [a]
swap_abbrev Int
k [Int]
a =
    let c :: [[Int]]
c = forall t. Enum t => [[t]] -> [[t]]
to_zero_indexed (forall t. [Either t (t, t)] -> [[t]]
swaps_to_cycles (forall t. (Num t, Ord t) => t -> [t] -> [Either t (t, t)]
gen_swaps Int
k [Int]
a))
        p :: [Int]
p = [[Int]] -> [Int]
T.from_cycles_zero_indexed [[Int]]
c
    in forall t. [Int] -> [t] -> [t]
T.apply_permutation [Int]
p

-- | Apply a 'Change'.
apply_change :: Int -> Change -> [a] -> [a]
apply_change :: forall a. Int -> Change -> [a] -> [a]
apply_change Int
k Change
p [a]
l =
    case Change
p of
      Change
Swap_All -> forall a. [a] -> [a]
swap_all [a]
l
      Hold [Int]
q -> forall a. Int -> [Int] -> [a] -> [a]
swap_abbrev Int
k [Int]
q [a]
l

-- | Apply a 'Method', gives next starting sequence and the course of
-- the method.
--
-- > let r = ([1,2,4,5,3]
-- >         ,[[1,2,3,4,5],[2,1,3,4,5],[2,3,1,4,5],[3,2,4,1,5],[3,4,2,5,1]
-- >          ,[4,3,2,5,1],[4,2,3,1,5],[2,4,1,3,5],[2,1,4,3,5],[1,2,4,3,5]])
-- > apply_method cambridgeshire_slow_course_doubles [1..5] == r
apply_method :: Method -> [a] -> ([a],[[a]])
apply_method :: forall a. Method -> [a] -> ([a], [[a]])
apply_method Method
m [a]
l =
    let k :: Int
k = forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
l
        f :: [a] -> Change -> ([a], [a])
f [a]
z Change
e = (forall a. Int -> Change -> [a] -> [a]
apply_change Int
k Change
e [a]
z,[a]
z)
    in forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL forall {a}. [a] -> Change -> ([a], [a])
f [a]
l (Method -> [Change]
method_changes Method
m)

-- | Iteratively apply a 'Method' until it closes (ie. arrives back at
-- the starting sequence).
--
-- > length (closed_method cambridgeshire_slow_course_doubles [1..5]) == 3
closed_method :: Eq a => Method -> [a] -> [[[a]]]
closed_method :: forall a. Eq a => Method -> [a] -> [[[a]]]
closed_method Method
m [a]
l =
    let rec :: [a] -> [[[a]]] -> [[[a]]]
rec [a]
c [[[a]]]
r =
            let ([a]
e,[[a]]
z) = forall a. Method -> [a] -> ([a], [[a]])
apply_method Method
m [a]
c
            in if [a]
e forall a. Eq a => a -> a -> Bool
== [a]
l
               then forall a. [a] -> [a]
reverse ([[a]]
z forall a. a -> [a] -> [a]
: [[[a]]]
r)
               else [a] -> [[[a]]] -> [[[a]]]
rec [a]
e ([[a]]
z forall a. a -> [a] -> [a]
: [[[a]]]
r)
    in [a] -> [[[a]]] -> [[[a]]]
rec [a]
l []

-- | 'concat' of 'closed_method' with initial sequence appended.
closed_method_lp :: Eq a => Method -> [a] -> [[a]]
closed_method_lp :: forall a. Eq a => Method -> [a] -> [[a]]
closed_method_lp Method
m [a]
l = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a. Eq a => Method -> [a] -> [[[a]]]
closed_method Method
m [a]
l) forall a. [a] -> [a] -> [a]
++ [[a]
l]

-- | 'closed_method' of 'parse_method'
closed_place :: Eq t => Place -> [t] -> [[[t]]]
closed_place :: forall t. Eq t => Place -> [t] -> [[[t]]]
closed_place Place
pl = forall a. Eq a => Method -> [a] -> [[[a]]]
closed_method (Place -> Method
parse_method Place
pl)

-- * Methods

-- | <https://rsw.me.uk/blueline/methods/view/Cambridgeshire_Place_Doubles>
--
-- > length (closed_place cambridgeshire_place_doubles_pl [1..5]) == 3
cambridgeshire_place_doubles_pl :: Place
cambridgeshire_place_doubles_pl :: Place
cambridgeshire_place_doubles_pl = (String
"345.145.5.1.345",forall a. a -> Maybe a
Just String
"123")

-- | 'parse_method' of 'cambridgeshire_place_doubles_pl'
cambridgeshire_slow_course_doubles :: Method
cambridgeshire_slow_course_doubles :: Method
cambridgeshire_slow_course_doubles = Place -> Method
parse_method Place
cambridgeshire_place_doubles_pl

-- | <https://rsw.me.uk/blueline/methods/view/Double_Cambridge_Cyclic_Bob_Minor>
--
-- > length (closed_place double_cambridge_cyclic_bob_minor_pl [1..6]) == 5
double_cambridge_cyclic_bob_minor_pl :: Place
double_cambridge_cyclic_bob_minor_pl :: Place
double_cambridge_cyclic_bob_minor_pl = (String
"-14-16-56-36-16-12",forall a. Maybe a
Nothing)

-- | 'parse_method' of 'double_cambridge_cyclic_bob_minor_pl'
double_cambridge_cyclic_bob_minor :: Method
double_cambridge_cyclic_bob_minor :: Method
double_cambridge_cyclic_bob_minor = Place -> Method
parse_method Place
double_cambridge_cyclic_bob_minor_pl

-- | <https://rsw.me.uk/blueline/methods/view/Hammersmith_Bob_Triples>
--
-- > length (closed_place hammersmith_bob_triples_pl [1..7]) == 6
hammersmith_bob_triples_pl :: Place
hammersmith_bob_triples_pl :: Place
hammersmith_bob_triples_pl = (String
"7.1.5.123.7.345.7",forall a. a -> Maybe a
Just String
"127")

hammersmith_bob_triples :: Method
hammersmith_bob_triples :: Method
hammersmith_bob_triples = Place -> Method
parse_method Place
hammersmith_bob_triples_pl

-- | <https://rsw.me.uk/blueline/methods/view/Cambridge_Surprise_Major>
--
-- > length (closed_place cambridge_surprise_major_pl [1..8]) == 7
cambridge_surprise_major_pl :: Place
cambridge_surprise_major_pl :: Place
cambridge_surprise_major_pl = (String
"-38-14-1258-36-14-58-16-78",forall a. a -> Maybe a
Just String
"12")

cambridge_surprise_major :: Method
cambridge_surprise_major :: Method
cambridge_surprise_major = Place -> Method
parse_method Place
cambridge_surprise_major_pl

-- | <https://rsw.me.uk/blueline/methods/view/Smithsonian_Surprise_Royal>
--
-- > let c = closed_place smithsonian_surprise_royal_pl [1..10]
-- > (length c,nub (map length c),sum (map length c)) == (9,[40],360)
smithsonian_surprise_royal_pl :: Place
smithsonian_surprise_royal_pl :: Place
smithsonian_surprise_royal_pl = (String
"-30-14-50-16-3470-18-1456-50-16-70",forall a. a -> Maybe a
Just String
"12")

smithsonian_surprise_royal :: Method
smithsonian_surprise_royal :: Method
smithsonian_surprise_royal = Place -> Method
parse_method Place
smithsonian_surprise_royal_pl

-- | <https://rsw.me.uk/blueline/methods/view/Ecumenical_Surprise_Maximus>
--
-- > c = closed_place ecumenical_surprise_maximus_pl [1..12]
-- > (length c,nub (map length c),sum (map length c)) == (11,[48],528)
ecumenical_surprise_maximus_pl :: Place
ecumenical_surprise_maximus_pl :: Place
ecumenical_surprise_maximus_pl = (String
"x3Tx14x5Tx16x7Tx1238x149Tx50x16x7Tx18.90.ET",forall a. a -> Maybe a
Just String
"12")

ecumenical_surprise_maximus :: Method
ecumenical_surprise_maximus :: Method
ecumenical_surprise_maximus = Place -> Method
parse_method Place
ecumenical_surprise_maximus_pl