-- | Polansky, Larry and Bassein, Richard
-- \"Possible and Impossible Melody: Some Formal Aspects of Contour\"
-- /Journal of Music Theory/ 36/2, 1992 (pp.259-284)
-- (<http://www.jstor.org/pss/843933>)
module Music.Theory.Contour.Polansky_1992 where

import Data.List {- base -}
import Data.List.Split {- split -}
import qualified Data.Map as M {- containers -}
import Data.Maybe {- base -}
import Data.Ratio {- base -}

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

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

-- * Indices

-- | Construct set of /n/ '-' @1@ adjacent indices, left right order.
--
-- > adjacent_indices 5 == [(0,1),(1,2),(2,3),(3,4)]
adjacent_indices :: Integral i => i -> [(i,i)]
adjacent_indices :: forall i. Integral i => i -> [(i, i)]
adjacent_indices i
n = forall a b. [a] -> [b] -> [(a, b)]
zip [i
0..i
nforall a. Num a => a -> a -> a
-i
2] [i
1..i
nforall a. Num a => a -> a -> a
-i
1]

-- | All /(i,j)/ indices, in half matrix order.
--
-- > all_indices 4 == [(0,1),(0,2),(0,3),(1,2),(1,3),(2,3)]
all_indices :: Integral i => i -> [(i,i)]
all_indices :: forall i. Integral i => i -> [(i, i)]
all_indices i
n =
    let n' :: i
n' = i
n forall a. Num a => a -> a -> a
- i
1
    in [(i
i,i
j) | i
i <- [i
0 .. i
n'], i
j <- [i
i forall a. Num a => a -> a -> a
+ i
1 .. i
n']]

-- * Matrix

-- | A list notation for matrices.
type Matrix a = [[a]]

-- | Apply /f/ to construct 'Matrix' from sequence.
--
-- > matrix_f (,) [1..3] == [[(1,1),(1,2),(1,3)]
-- >                        ,[(2,1),(2,2),(2,3)]
-- >                        ,[(3,1),(3,2),(3,3)]]
matrix_f :: (a -> a -> b) -> [a] -> Matrix b
matrix_f :: forall a b. (a -> a -> b) -> [a] -> Matrix b
matrix_f a -> a -> b
f =
    let g :: (a, [a]) -> [b]
g (a
x,[a]
xs) = forall a b. (a -> b) -> [a] -> [b]
map (a -> a -> b
f a
x) [a]
xs
        h :: [a] -> [(a, [a])]
h [a]
xs = forall a b. (a -> b) -> [a] -> [b]
map (\a
x -> (a
x,[a]
xs)) [a]
xs
    in forall a b. (a -> b) -> [a] -> [b]
map (a, [a]) -> [b]
g forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. [a] -> [(a, [a])]
h

-- | Construct 'matrix_f' with 'compare' (p.263).
--
-- > contour_matrix [1..3] == [[EQ,LT,LT],[GT,EQ,LT],[GT,GT,EQ]]
contour_matrix :: Ord a => [a] -> Matrix Ordering
contour_matrix :: forall a. Ord a => [a] -> Matrix Ordering
contour_matrix = forall a b. (a -> a -> b) -> [a] -> Matrix b
matrix_f forall a. Ord a => a -> a -> Ordering
compare

-- * Half matrix

-- | Half matrix notation for contour.
data Contour_Half_Matrix =
    Contour_Half_Matrix {Contour_Half_Matrix -> Int
contour_half_matrix_n :: Int
                        ,Contour_Half_Matrix -> Matrix Ordering
contour_half_matrix_m :: Matrix Ordering}
    deriving (Contour_Half_Matrix -> Contour_Half_Matrix -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Contour_Half_Matrix -> Contour_Half_Matrix -> Bool
$c/= :: Contour_Half_Matrix -> Contour_Half_Matrix -> Bool
== :: Contour_Half_Matrix -> Contour_Half_Matrix -> Bool
$c== :: Contour_Half_Matrix -> Contour_Half_Matrix -> Bool
Eq,Eq Contour_Half_Matrix
Contour_Half_Matrix -> Contour_Half_Matrix -> Bool
Contour_Half_Matrix -> Contour_Half_Matrix -> Ordering
Contour_Half_Matrix -> Contour_Half_Matrix -> Contour_Half_Matrix
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 :: Contour_Half_Matrix -> Contour_Half_Matrix -> Contour_Half_Matrix
$cmin :: Contour_Half_Matrix -> Contour_Half_Matrix -> Contour_Half_Matrix
max :: Contour_Half_Matrix -> Contour_Half_Matrix -> Contour_Half_Matrix
$cmax :: Contour_Half_Matrix -> Contour_Half_Matrix -> Contour_Half_Matrix
>= :: Contour_Half_Matrix -> Contour_Half_Matrix -> Bool
$c>= :: Contour_Half_Matrix -> Contour_Half_Matrix -> Bool
> :: Contour_Half_Matrix -> Contour_Half_Matrix -> Bool
$c> :: Contour_Half_Matrix -> Contour_Half_Matrix -> Bool
<= :: Contour_Half_Matrix -> Contour_Half_Matrix -> Bool
$c<= :: Contour_Half_Matrix -> Contour_Half_Matrix -> Bool
< :: Contour_Half_Matrix -> Contour_Half_Matrix -> Bool
$c< :: Contour_Half_Matrix -> Contour_Half_Matrix -> Bool
compare :: Contour_Half_Matrix -> Contour_Half_Matrix -> Ordering
$ccompare :: Contour_Half_Matrix -> Contour_Half_Matrix -> Ordering
Ord)

-- | Half 'Matrix' of contour given comparison function /f/.
--
-- > half_matrix_f (flip (-)) [2,10,6,7] == [[8,4,5],[-4,-3],[1]]
-- > half_matrix_f (flip (-)) [5,0,3,2] == [[-5,-2,-3],[3,2],[-1]]
-- > half_matrix_f compare [5,0,3,2] == [[GT,GT,GT],[LT,LT],[GT]]
half_matrix_f :: (a -> a -> b) -> [a] -> Matrix b
half_matrix_f :: forall a b. (a -> a -> b) -> [a] -> Matrix b
half_matrix_f a -> a -> b
f [a]
xs =
    let drop_last :: [a] -> [a]
drop_last = forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
drop Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse
        m :: [[b]]
m = forall a. [a] -> [a]
drop_last (forall a b. (a -> a -> b) -> [a] -> Matrix b
matrix_f a -> a -> b
f  [a]
xs)
    in forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. Int -> [a] -> [a]
drop [Int
1..] [[b]]
m

-- | Construct 'Contour_Half_Matrix' (p.264)
contour_half_matrix :: Ord a => [a] -> Contour_Half_Matrix
contour_half_matrix :: forall a. Ord a => [a] -> Contour_Half_Matrix
contour_half_matrix [a]
xs =
    let hm :: Matrix Ordering
hm = forall a b. (a -> a -> b) -> [a] -> Matrix b
half_matrix_f forall a. Ord a => a -> a -> Ordering
compare [a]
xs
    in Int -> Matrix Ordering -> Contour_Half_Matrix
Contour_Half_Matrix (forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
xs) Matrix Ordering
hm

-- | 'Show' function for 'Contour_Half_Matrix'.
contour_half_matrix_str :: Contour_Half_Matrix -> String
contour_half_matrix_str :: Contour_Half_Matrix -> String
contour_half_matrix_str (Contour_Half_Matrix Int
_ Matrix Ordering
hm) =
    let hm' :: [String]
hm' = forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum)) Matrix Ordering
hm
    in [String] -> String
unwords [String]
hm'

instance Show Contour_Half_Matrix where
    show :: Contour_Half_Matrix -> String
show = Contour_Half_Matrix -> String
contour_half_matrix_str

-- * Contour description

-- | /Description/ notation of contour.
data Contour_Description =
    Contour_Description {Contour_Description -> Int
contour_description_n :: Int
                        ,Contour_Description -> Map (Int, Int) Ordering
contour_description_m :: M.Map (Int,Int) Ordering}
    deriving (Contour_Description -> Contour_Description -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Contour_Description -> Contour_Description -> Bool
$c/= :: Contour_Description -> Contour_Description -> Bool
== :: Contour_Description -> Contour_Description -> Bool
$c== :: Contour_Description -> Contour_Description -> Bool
Eq)

-- | Construct 'Contour_Description' of contour (p.264).
--
-- > let c = [[3,2,4,1],[3,2,1,4]]
-- > in map (show.contour_description) c == ["202 02 2","220 20 0"]
contour_description :: Ord a => [a] -> Contour_Description
contour_description :: forall a. Ord a => [a] -> Contour_Description
contour_description [a]
x =
    let n :: Int
n = forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
x
        ix :: [(Int, Int)]
ix = forall i. Integral i => i -> [(i, i)]
all_indices Int
n
        o :: [((Int, Int), Ordering)]
o = forall a b. [a] -> [b] -> [(a, b)]
zip [(Int, Int)]
ix (forall a b. (a -> b) -> [a] -> [b]
map (\(Int
i,Int
j) -> forall a. Ord a => a -> a -> Ordering
compare ([a]
x forall a. [a] -> Int -> a
!! Int
i) ([a]
x forall a. [a] -> Int -> a
!! Int
j)) [(Int, Int)]
ix)
    in Int -> Map (Int, Int) Ordering -> Contour_Description
Contour_Description Int
n (forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [((Int, Int), Ordering)]
o)

-- | 'Show' function for 'Contour_Description' (p.264).
contour_description_str :: Contour_Description -> String
contour_description_str :: Contour_Description -> String
contour_description_str (Contour_Description Int
n Map (Int, Int) Ordering
m) =
    let xs :: String
xs = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Enum a => a -> Int
fromEnum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) (forall k a. Map k a -> [(k, a)]
M.toList Map (Int, Int) Ordering
m)
    in [String] -> String
unwords (forall a e. Integral a => [a] -> [e] -> [[e]]
splitPlaces [Int
nforall a. Num a => a -> a -> a
-Int
1,Int
nforall a. Num a => a -> a -> a
-Int
2 .. Int
0] String
xs)

instance Show Contour_Description where
    show :: Contour_Description -> String
show = Contour_Description -> String
contour_description_str

-- | Convert from 'Contour_Half_Matrix' notation to 'Contour_Description'.
half_matrix_to_description :: Contour_Half_Matrix -> Contour_Description
half_matrix_to_description :: Contour_Half_Matrix -> Contour_Description
half_matrix_to_description (Contour_Half_Matrix Int
n Matrix Ordering
hm) =
    let ix :: [(Int, Int)]
ix = forall i. Integral i => i -> [(i, i)]
all_indices Int
n
        o :: [((Int, Int), Ordering)]
o = forall a b. [a] -> [b] -> [(a, b)]
zip [(Int, Int)]
ix (forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat Matrix Ordering
hm)
    in Int -> Map (Int, Int) Ordering -> Contour_Description
Contour_Description Int
n (forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [((Int, Int), Ordering)]
o)

-- | Ordering from /i/th to /j/th element of sequence described at /d/.
--
-- > contour_description_ix (contour_description "abdc") (0,3) == LT
contour_description_ix :: Contour_Description -> (Int,Int) -> Ordering
contour_description_ix :: Contour_Description -> (Int, Int) -> Ordering
contour_description_ix Contour_Description
d (Int, Int)
i = Contour_Description -> Map (Int, Int) Ordering
contour_description_m Contour_Description
d forall k a. Ord k => Map k a -> k -> a
M.! (Int, Int)
i

-- | 'True' if contour is all descending, equal or ascending.
--
-- > let c = ["abc","bbb","cba"]
-- > in map (uniform.contour_description) c == [True,True,True]
uniform :: Contour_Description -> Bool
uniform :: Contour_Description -> Bool
uniform (Contour_Description Int
_ Map (Int, Int) Ordering
m) = forall a. Eq a => [a] -> Bool
T.all_equal (forall k a. Map k a -> [a]
M.elems Map (Int, Int) Ordering
m)

-- | 'True' if contour does not containt any 'EQ' elements.
--
-- > let c = ["abc","bbb","cba"]
-- > map (no_equalities.contour_description) c == [True,False,True]
no_equalities :: Contour_Description -> Bool
no_equalities :: Contour_Description -> Bool
no_equalities (Contour_Description Int
_ Map (Int, Int) Ordering
m) = Ordering
EQ forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` forall k a. Map k a -> [a]
M.elems Map (Int, Int) Ordering
m

-- | Set of all contour descriptions.
--
-- > map (length.all_contours) [3,4,5] == [27,729,59049]
all_contours :: Int -> [Contour_Description]
all_contours :: Int -> [Contour_Description]
all_contours Int
n =
    let n' :: Int
n' = forall a. Integral a => a -> a
contour_description_lm Int
n
        ix :: [(Int, Int)]
ix = forall i. Integral i => i -> [(i, i)]
all_indices Int
n
        cs :: Matrix Ordering
cs = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
notforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (t :: * -> *) a. Foldable t => t a -> Bool
null) (forall a. [a] -> [[a]]
T.powerset [Ordering
LT,Ordering
EQ,Ordering
GT])
        pf :: [Ordering] -> Matrix Ordering
pf = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall a. Ord a => [a] -> [[a]]
T.multiset_permutations forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => Int -> [a] -> [[a]]
T.expand_set Int
n'
        mk :: [Ordering] -> Contour_Description
mk [Ordering]
p = Int -> Map (Int, Int) Ordering -> Contour_Description
Contour_Description Int
n (forall k a. Ord k => [(k, a)] -> Map k a
M.fromList (forall a b. [a] -> [b] -> [(a, b)]
zip [(Int, Int)]
ix [Ordering]
p))
    in forall a b. (a -> b) -> [a] -> [b]
map [Ordering] -> Contour_Description
mk (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [Ordering] -> Matrix Ordering
pf Matrix Ordering
cs)

-- | A sequence of orderings /(i,j)/ and /(j,k)/ may imply ordering
-- for /(i,k)/.
--
-- > map implication [(LT,EQ),(EQ,EQ),(EQ,GT)] == [Just LT,Just EQ,Just GT]
implication :: (Ordering,Ordering) -> Maybe Ordering
implication :: (Ordering, Ordering) -> Maybe Ordering
implication (Ordering
i,Ordering
j) =
    case (forall a. Ord a => a -> a -> a
min Ordering
i Ordering
j,forall a. Ord a => a -> a -> a
max Ordering
i Ordering
j) of
      (Ordering
LT,Ordering
LT) -> forall a. a -> Maybe a
Just Ordering
LT
      (Ordering
LT,Ordering
EQ) -> forall a. a -> Maybe a
Just Ordering
LT
      (Ordering
LT,Ordering
GT) -> forall a. Maybe a
Nothing
      (Ordering
EQ,Ordering
EQ) -> forall a. a -> Maybe a
Just Ordering
EQ
      (Ordering
EQ,Ordering
GT) -> forall a. a -> Maybe a
Just Ordering
GT
      (Ordering
GT,Ordering
GT) -> forall a. a -> Maybe a
Just Ordering
GT
      (Ordering, Ordering)
_ -> forall a. HasCallStack => String -> a
error String
"implication"

-- | List of all violations at a 'Contour_Description' (p.266).
violations :: Contour_Description -> [(Int,Int,Int,Ordering)]
violations :: Contour_Description -> [(Int, Int, Int, Ordering)]
violations Contour_Description
d =
    let n :: Int
n = Contour_Description -> Int
contour_description_n Contour_Description
d forall a. Num a => a -> a -> a
- Int
1
        ms :: [(Int, Int, Int)]
ms = [(Int
i,Int
j,Int
k) | Int
i <- [Int
0..Int
n], Int
j <- [Int
i forall a. Num a => a -> a -> a
+ Int
1 .. Int
n], Int
k <- [Int
j forall a. Num a => a -> a -> a
+ Int
1 .. Int
n]]
        ix :: (Int, Int) -> Ordering
ix = Contour_Description -> (Int, Int) -> Ordering
contour_description_ix Contour_Description
d
        complies :: (Int, Int, Int) -> Maybe (Int, Int, Int, Ordering)
complies (Int
i,Int
j,Int
k) =
            let l :: Ordering
l = (Int, Int) -> Ordering
ix (Int
i,Int
j)
                r :: Ordering
r = (Int, Int) -> Ordering
ix (Int
j,Int
k)
                b :: Ordering
b = (Int, Int) -> Ordering
ix (Int
i,Int
k)
            in case (Ordering, Ordering) -> Maybe Ordering
implication (Ordering
l,Ordering
r) of
                 Maybe Ordering
Nothing -> forall a. Maybe a
Nothing
                 Just Ordering
x -> if Ordering
x forall a. Eq a => a -> a -> Bool
== Ordering
b
                           then forall a. Maybe a
Nothing
                           else forall a. a -> Maybe a
Just (Int
i,Int
j,Int
k,Ordering
x)
    in forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Int, Int, Int) -> Maybe (Int, Int, Int, Ordering)
complies [(Int, Int, Int)]
ms

-- | Is the number of 'violations' zero.
is_possible :: Contour_Description -> Bool
is_possible :: Contour_Description -> Bool
is_possible = forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. Contour_Description -> [(Int, Int, Int, Ordering)]
violations

-- | All possible contour descriptions
--
-- > map (length.possible_contours) [3,4,5] == [13,75,541]
possible_contours :: Int -> [Contour_Description]
possible_contours :: Int -> [Contour_Description]
possible_contours = forall a. (a -> Bool) -> [a] -> [a]
filter Contour_Description -> Bool
is_possible forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Contour_Description]
all_contours

-- | All impossible contour descriptions
--
-- > map (length.impossible_contours) [3,4,5] == [14,654,58508]
impossible_contours :: Int -> [Contour_Description]
impossible_contours :: Int -> [Contour_Description]
impossible_contours = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
notforall b c a. (b -> c) -> (a -> b) -> a -> c
.Contour_Description -> Bool
is_possible) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Contour_Description]
all_contours

-- | Calculate number of contours of indicated degree (p.263).
--
-- > map contour_description_lm [2..7] == [1,3,6,10,15,21]
--
-- > let r = [3,27,729,59049,14348907]
-- > in map (\n -> 3 ^ n) (map contour_description_lm [2..6]) == r
contour_description_lm :: Integral a => a -> a
contour_description_lm :: forall a. Integral a => a -> a
contour_description_lm a
l = (a
l forall a. Num a => a -> a -> a
* a
l forall a. Num a => a -> a -> a
- a
l) forall a. Integral a => a -> a -> a
`div` a
2

-- | Truncate a 'Contour_Description' to have at most /n/ elements.
--
-- > let c = contour_description [3,2,4,1]
-- > in contour_truncate c 3 == contour_description [3,2,4]
contour_truncate :: Contour_Description -> Int -> Contour_Description
contour_truncate :: Contour_Description -> Int -> Contour_Description
contour_truncate (Contour_Description Int
n Map (Int, Int) Ordering
m) Int
z =
    let n' :: Int
n' = forall a. Ord a => a -> a -> a
min Int
n Int
z
        f :: (Int, Int) -> p -> Bool
f (Int
i,Int
j) p
_ = Int
i forall a. Ord a => a -> a -> Bool
< Int
n' Bool -> Bool -> Bool
&& Int
j forall a. Ord a => a -> a -> Bool
< Int
n'
    in Int -> Map (Int, Int) Ordering -> Contour_Description
Contour_Description Int
n' (forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey forall {p}. (Int, Int) -> p -> Bool
f Map (Int, Int) Ordering
m)

-- | Is 'Contour_Description' /p/ a prefix of /q/.
--
-- > let {c = contour_description [3,2,4,1]
-- >     ;d = contour_description [3,2,4]}
-- > in d `contour_is_prefix_of` c == True
contour_is_prefix_of :: Contour_Description -> Contour_Description -> Bool
contour_is_prefix_of :: Contour_Description -> Contour_Description -> Bool
contour_is_prefix_of Contour_Description
p Contour_Description
q = Contour_Description
p forall a. Eq a => a -> a -> Bool
== Contour_Description -> Int -> Contour_Description
contour_truncate Contour_Description
q (Contour_Description -> Int
contour_description_n Contour_Description
p)

-- | Are 'Contour_Description's /p/ and /q/ equal at column /n/.
--
-- > let {c = contour_description [3,2,4,1,5]
-- >     ;d = contour_description [3,2,4,1]}
-- > in map (contour_eq_at c d) [0..4] == [True,True,True,True,False]
contour_eq_at :: Contour_Description -> Contour_Description -> Int -> Bool
contour_eq_at :: Contour_Description -> Contour_Description -> Int -> Bool
contour_eq_at Contour_Description
p Contour_Description
q Int
n =
    let a :: Map (Int, Int) Ordering
a = Contour_Description -> Map (Int, Int) Ordering
contour_description_m Contour_Description
p
        b :: Map (Int, Int) Ordering
b = Contour_Description -> Map (Int, Int) Ordering
contour_description_m Contour_Description
q
        f :: (a, Int) -> p -> Bool
f (a
_,Int
j) p
_ = Int
j forall a. Eq a => a -> a -> Bool
== Int
n
        g :: Map (a, Int) a -> [((a, Int), a)]
g = forall k a. Map k a -> [(k, a)]
M.toAscList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey forall {a} {p}. (a, Int) -> p -> Bool
f
    in forall {a} {a}. Map (a, Int) a -> [((a, Int), a)]
g Map (Int, Int) Ordering
a forall a. Eq a => a -> a -> Bool
== forall {a} {a}. Map (a, Int) a -> [((a, Int), a)]
g Map (Int, Int) Ordering
b

-- * Contour drawing

-- | Derive an 'Integral' contour that would be described by
-- 'Contour_Description'.  Diverges for impossible contours.
--
-- > draw_contour (contour_description "abdc") == [0,1,3,2]
draw_contour :: Integral i => Contour_Description -> [i]
draw_contour :: forall i. Integral i => Contour_Description -> [i]
draw_contour Contour_Description
d =
    let n :: Int
n = Contour_Description -> Int
contour_description_n Contour_Description
d
        ix :: [(Int, Int)]
ix = forall i. Integral i => i -> [(i, i)]
all_indices Int
n
        normalise :: Integral i => [Rational] -> [i]
        normalise :: forall i. Integral i => [Rational] -> [i]
normalise [Rational]
xs =
            let xs' :: [Rational]
xs' = forall a. Eq a => [a] -> [a]
nub (forall a. Ord a => [a] -> [a]
sort [Rational]
xs)
            in forall a b. (a -> b) -> [a] -> [b]
map (\Rational
i -> forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall a. HasCallStack => Maybe a -> a
fromJust (forall a. Eq a => a -> [a] -> Maybe Int
elemIndex Rational
i [Rational]
xs'))) [Rational]
xs
        adjustment :: Ratio a -> Ratio a
adjustment Ratio a
x = if Ratio a
x forall a. Eq a => a -> a -> Bool
== Ratio a
0 then Ratio a
1 else a
1 forall a. Integral a => a -> a -> Ratio a
% (forall a. Ratio a -> a
denominator Ratio a
x forall a. Num a => a -> a -> a
* a
2)
        step :: (Int, Int) -> [Ratio a] -> Maybe [Ratio a]
step (Int
i,Int
j) [Ratio a]
ns = let c :: Ordering
c = Contour_Description -> (Int, Int) -> Ordering
contour_description_ix Contour_Description
d (Int
i,Int
j)
                            i' :: Ratio a
i' = [Ratio a]
ns forall a. [a] -> Int -> a
!! Int
i
                            j' :: Ratio a
j' = [Ratio a]
ns forall a. [a] -> Int -> a
!! Int
j
                            c' :: Ordering
c' = forall a. Ord a => a -> a -> Ordering
compare Ratio a
i' Ratio a
j' -- traceShow (i,j,ns) $
                        in if Ordering
c forall a. Eq a => a -> a -> Bool
== Ordering
c'
                           then forall a. Maybe a
Nothing
                           else let j'' :: Ratio a
j'' = case Ordering
c of
                                            Ordering
LT -> Ratio a
i' forall a. Num a => a -> a -> a
+ forall {a}. Integral a => Ratio a -> Ratio a
adjustment Ratio a
j'
                                            Ordering
EQ -> Ratio a
i'
                                            Ordering
GT -> Ratio a
i' forall a. Num a => a -> a -> a
- forall {a}. Integral a => Ratio a -> Ratio a
adjustment Ratio a
j'
                                in forall a. a -> Maybe a
Just (forall i a. Integral i => [a] -> i -> a -> [a]
T.replace_at [Ratio a]
ns Int
j Ratio a
j'')
        refine :: [(Int, Int)] -> [Ratio a] -> [Ratio a]
refine [] [Ratio a]
ns = [Ratio a]
ns
        refine ((Int, Int)
i:[(Int, Int)]
is) [Ratio a]
ns = case forall {a}.
Integral a =>
(Int, Int) -> [Ratio a] -> Maybe [Ratio a]
step (Int, Int)
i [Ratio a]
ns of
                             Maybe [Ratio a]
Nothing -> [(Int, Int)] -> [Ratio a] -> [Ratio a]
refine [(Int, Int)]
is [Ratio a]
ns
                             Just [Ratio a]
ns' -> [(Int, Int)] -> [Ratio a] -> [Ratio a]
refine [(Int, Int)]
ix [Ratio a]
ns'
    in forall i. Integral i => [Rational] -> [i]
normalise (forall {a}. Integral a => [(Int, Int)] -> [Ratio a] -> [Ratio a]
refine [(Int, Int)]
ix (forall a. Int -> a -> [a]
replicate Int
n Rational
0))

-- | Invert 'Contour_Description'.
--
-- > let c = contour_description "abdc"
-- > in draw_contour (contour_description_invert c) == [3,2,0,1]
contour_description_invert :: Contour_Description -> Contour_Description
contour_description_invert :: Contour_Description -> Contour_Description
contour_description_invert (Contour_Description Int
n Map (Int, Int) Ordering
m) =
    Int -> Map (Int, Int) Ordering -> Contour_Description
Contour_Description Int
n (forall a b k. (a -> b) -> Map k a -> Map k b
M.map Ordering -> Ordering
T.ord_invert Map (Int, Int) Ordering
m)

-- * Construction

-- | Function to perhaps generate an element and a new state from an
-- initial state.  This is the function provided to 'unfoldr'.
type Build_f st e = st -> Maybe (e,st)

-- | Function to test is a partial sequence conforms to the target
-- sequence.
type Conforms_f e = Int -> [e] -> Bool

-- | Transform a 'Build_f' to produce at most /n/ elements.
--
-- > let f i = Just (i,succ i)
-- > in unfoldr (build_f_n f) (5,'a') == "abcde"
build_f_n :: Build_f st e -> Build_f (Int,st) e
build_f_n :: forall st e. Build_f st e -> Build_f (Int, st) e
build_f_n Build_f st e
f =
    let g :: (a, st) -> Maybe (e, (a, st))
g (a, st)
g_st =
            let (a
i,st
f_st) = (a, st)
g_st
            in if a
i forall a. Eq a => a -> a -> Bool
== a
0
               then forall a. Maybe a
Nothing
               else case Build_f st e
f st
f_st of
                      Maybe (e, st)
Nothing -> forall a. Maybe a
Nothing
                      Just (e
e,st
f_st') -> forall a. a -> Maybe a
Just (e
e,(a
i forall a. Num a => a -> a -> a
- a
1,st
f_st'))
    in forall {a}. (Eq a, Num a) => (a, st) -> Maybe (e, (a, st))
g

-- | Attempt to construct a sequence of /n/ elements given a 'Build_f'
-- to generate possible elements, a 'Conforms_f' that the result
-- sequence must conform to at each step, an 'Int' to specify the
-- maximum number of elements to generate when searching for a
-- solution, and an initial state.
--
-- > let {b_f i = Just (i,i+1)
-- >     ;c_f i x = odd (sum x `div` i)}
-- > in build_sequence 6 b_f c_f 20 0 == (Just [1,2,6,11,15,19],20)
build_sequence :: Int -> Build_f st e -> Conforms_f e -> Int -> st ->
                  (Maybe [e],st)
build_sequence :: forall st e.
Int -> Build_f st e -> Conforms_f e -> Int -> st -> (Maybe [e], st)
build_sequence Int
n Build_f st e
f Conforms_f e
g Int
z =
    let go :: Int -> Int -> [e] -> st -> (Maybe [e], st)
go Int
i Int
j [e]
r st
st =
            if Int
i forall a. Eq a => a -> a -> Bool
== Int
n
            then (forall a. a -> Maybe a
Just [e]
r,st
st)
            else if Int
j forall a. Eq a => a -> a -> Bool
== Int
z
                 then (forall a. Maybe a
Nothing,st
st)
                 else case Build_f st e
f st
st of
                        Maybe (e, st)
Nothing -> (forall a. Maybe a
Nothing,st
st)
                        Just (e
e,st
st') ->
                            let i' :: Int
i' = Int
i forall a. Num a => a -> a -> a
+ Int
1
                                j' :: Int
j' = Int
j forall a. Num a => a -> a -> a
+ Int
1
                                r' :: [e]
r' = [e]
r forall a. [a] -> [a] -> [a]
++ [e
e]
                            in if Conforms_f e
g Int
i' [e]
r'
                               then Int -> Int -> [e] -> st -> (Maybe [e], st)
go Int
i' Int
j' [e]
r' st
st'
                               else Int -> Int -> [e] -> st -> (Maybe [e], st)
go Int
i Int
j' [e]
r st
st'
    in Int -> Int -> [e] -> st -> (Maybe [e], st)
go Int
0 Int
0 []

-- | Attempt to construct a sequence that has a specified contour.
-- The arguments are a 'Build_f' to generate possible elements, a
-- 'Contour_Description' that the result sequence must conform to, an
-- 'Int' to specify the maximum number of elements to generate when
-- searching for a solution, and an initial state.
--
-- > import System.Random
--
-- > let {f = Just . randomR ('a','z')
-- >     ;c = contour_description "atdez"
-- >     ;st = mkStdGen 2347}
-- > in fst (build_contour f c 1024 st) == Just "nvruy"
build_contour :: (Ord e) =>
                 Build_f st e -> Contour_Description -> Int -> st ->
                 (Maybe [e],st)
build_contour :: forall e st.
Ord e =>
Build_f st e -> Contour_Description -> Int -> st -> (Maybe [e], st)
build_contour Build_f st e
f Contour_Description
c Int
z =
    let n :: Int
n = Contour_Description -> Int
contour_description_n Contour_Description
c
        g :: Int -> [a] -> Bool
g Int
i [a]
r = let d :: Contour_Description
d = forall a. Ord a => [a] -> Contour_Description
contour_description [a]
r -- traceShow r
                in Contour_Description -> Contour_Description -> Int -> Bool
contour_eq_at Contour_Description
c Contour_Description
d (Int
i forall a. Num a => a -> a -> a
- Int
1)
    in forall st e.
Int -> Build_f st e -> Conforms_f e -> Int -> st -> (Maybe [e], st)
build_sequence Int
n Build_f st e
f forall {a}. Ord a => Int -> [a] -> Bool
g Int
z

-- | A variant on 'build_contour' that retries a specified number of
-- times using the final state of the failed attempt as the state for
-- the next try.
--
-- > let {f = Just . randomR ('a','z')
-- >     ;c = contour_description "atdezjh"
-- >     ;st = mkStdGen 2347}
-- > in fst (build_contour_retry f c 64 8 st) == Just "nystzvu"
build_contour_retry ::
    (Ord e) =>
    Build_f st e -> Contour_Description -> Int -> Int -> st ->
    (Maybe [e], st)
build_contour_retry :: forall e st.
Ord e =>
Build_f st e
-> Contour_Description -> Int -> Int -> st -> (Maybe [e], st)
build_contour_retry Build_f st e
f Contour_Description
c Int
z Int
n st
st =
   if Int
n forall a. Eq a => a -> a -> Bool
== Int
0
   then (forall a. Maybe a
Nothing,st
st)
   else case forall e st.
Ord e =>
Build_f st e -> Contour_Description -> Int -> st -> (Maybe [e], st)
build_contour Build_f st e
f Contour_Description
c Int
z st
st of
          (Maybe [e]
Nothing,st
st') -> forall e st.
Ord e =>
Build_f st e
-> Contour_Description -> Int -> Int -> st -> (Maybe [e], st)
build_contour_retry Build_f st e
f Contour_Description
c Int
z (Int
n forall a. Num a => a -> a -> a
- Int
1) st
st'
          (Maybe [e], st)
r -> (Maybe [e], st)
r

-- | A variant on 'build_contour_retry' that returns the set of all
-- sequences constructed.
--
-- > let {f = Just . randomR ('a','z')
-- >     ;c = contour_description "atdezjh"
-- >     ;st = mkStdGen 2347}
-- > in length (build_contour_set f c 64 64 st) == 60
build_contour_set ::
    (Ord e) =>
    Build_f st e -> Contour_Description -> Int -> Int -> st -> [[e]]
build_contour_set :: forall e st.
Ord e =>
Build_f st e -> Contour_Description -> Int -> Int -> st -> [[e]]
build_contour_set Build_f st e
f Contour_Description
c Int
z Int
n st
st =
    case forall e st.
Ord e =>
Build_f st e
-> Contour_Description -> Int -> Int -> st -> (Maybe [e], st)
build_contour_retry Build_f st e
f Contour_Description
c Int
z Int
n st
st of
      (Maybe [e]
Nothing,st
_) -> []
      (Just [e]
r,st
st') -> [e]
r forall a. a -> [a] -> [a]
: forall e st.
Ord e =>
Build_f st e -> Contour_Description -> Int -> Int -> st -> [[e]]
build_contour_set Build_f st e
f Contour_Description
c Int
z Int
n st
st'

-- | Variant of 'build_contour_set' that halts when an generated
-- sequence is a duplicate of an already generated sequence.
--
-- > let {f = randomR ('a','f')
-- >     ;c = contour_description "cafe"
-- >     ;st = mkStdGen 2346836
-- >     ;r = build_contour_set_nodup f c 64 64 st}
-- > in filter ("c" `isPrefixOf`) r == ["cafe","cbed","caed"]
build_contour_set_nodup ::
    Ord e =>
    Build_f st e -> Contour_Description -> Int -> Int -> st -> [[e]]
build_contour_set_nodup :: forall e st.
Ord e =>
Build_f st e -> Contour_Description -> Int -> Int -> st -> [[e]]
build_contour_set_nodup Build_f st e
f Contour_Description
c Int
z Int
n =
    let go :: [[e]] -> st -> [[e]]
go [[e]]
r st
st =
            case forall e st.
Ord e =>
Build_f st e
-> Contour_Description -> Int -> Int -> st -> (Maybe [e], st)
build_contour_retry Build_f st e
f Contour_Description
c Int
z Int
n st
st of
              (Maybe [e]
Nothing,st
_) -> []
              (Just [e]
r',st
st') -> if [e]
r' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[e]]
r
                               then [[e]]
r
                               else [[e]] -> st -> [[e]]
go ([e]
r' forall a. a -> [a] -> [a]
: [[e]]
r) st
st'
    in [[e]] -> st -> [[e]]
go []

-- * Examples

-- | Example from p.262 (quarter-note durations)
--
-- > ex_1 == [2,3/2,1/2,1,2]
-- > compare_adjacent ex_1 == [GT,GT,LT,LT]
-- > show (contour_half_matrix ex_1) == "2221 220 00 0"
-- > draw_contour (contour_description ex_1) == [3,2,0,1,3]
--
-- > let d = contour_description_invert (contour_description ex_1)
-- > in (show d,is_possible d) == ("0001 002 22 2",True)
ex_1 :: [Rational]
ex_1 :: [Rational]
ex_1 = [Rational
2,Integer
3forall a. Integral a => a -> a -> Ratio a
%Integer
2,Integer
1forall a. Integral a => a -> a -> Ratio a
%Integer
2,Rational
1,Rational
2]

-- | Example on p.265 (pitch)
--
-- > ex_2 == [0,5,3]
-- > show (contour_description ex_2) == "00 2"
ex_2 :: [Integer]
ex_2 :: [Integer]
ex_2 = [Integer
0,Integer
5,Integer
3]

-- | Example on p.265 (pitch)
--
-- > ex_3 == [12,7,6,7,8,7]
-- > show (contour_description ex_3) == "22222 2101 000 01 2"
-- > contour_description_ix (contour_description ex_3) (0,5) == GT
-- > is_possible (contour_description ex_3) == True
ex_3 :: [Integer]
ex_3 :: [Integer]
ex_3 = [Integer
12,Integer
7,Integer
6,Integer
7,Integer
8,Integer
7]

-- | Example on p.266 (impossible)
--
-- > show ex_4 == "2221 220 00 1"
-- > is_possible ex_4 == False
-- > violations ex_4 == [(0,3,4,GT),(1,3,4,GT)]
ex_4 :: Contour_Description
ex_4 :: Contour_Description
ex_4 =
    let ns :: [[Int]]
        ns :: [[Int]]
ns = [[Int
2,Int
2,Int
2,Int
1],[Int
2,Int
2,Int
0],[Int
0,Int
0],[Int
1]]
        ns' :: Matrix Ordering
ns' = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map Int -> Ordering
T.int_to_ord) [[Int]]
ns
    in Contour_Half_Matrix -> Contour_Description
half_matrix_to_description (Int -> Matrix Ordering -> Contour_Half_Matrix
Contour_Half_Matrix Int
5 Matrix Ordering
ns')