module Music.Theory.Contour.Polansky_1992 where
import Data.List
import Data.List.Split
import qualified Data.Map as M
import Data.Maybe
import Data.Ratio
import qualified Music.Theory.List as T
import qualified Music.Theory.Ord as T
import qualified Music.Theory.Permutations.List as T
import qualified Music.Theory.Set.List as T
adjacent_indices :: Integral i => i -> [(i,i)]
adjacent_indices n = zip [0..n2] [1..n1]
all_indices :: Integral i => i -> [(i,i)]
all_indices n =
let n' = n 1
in [(i,j) | i <- [0 .. n'], j <- [i + 1 .. n']]
type Matrix a = [[a]]
matrix_f :: (a -> a -> b) -> [a] -> Matrix b
matrix_f f =
let g (x,xs) = map (f x) xs
h xs = map (\x -> (x,xs)) xs
in map g . h
contour_matrix :: Ord a => [a] -> Matrix Ordering
contour_matrix = matrix_f compare
data Contour_Half_Matrix =
Contour_Half_Matrix {contour_half_matrix_n :: Int
,contour_half_matrix_m :: Matrix Ordering}
deriving (Eq,Ord)
half_matrix_f :: (a -> a -> b) -> [a] -> Matrix b
half_matrix_f f xs =
let drop_last = reverse . drop 1 . reverse
m = drop_last (matrix_f f xs)
in zipWith drop [1..] m
contour_half_matrix :: Ord a => [a] -> Contour_Half_Matrix
contour_half_matrix xs =
let hm = half_matrix_f compare xs
in Contour_Half_Matrix (length xs) hm
contour_half_matrix_str :: Contour_Half_Matrix -> String
contour_half_matrix_str (Contour_Half_Matrix _ hm) =
let hm' = map (concatMap (show . fromEnum)) hm
in unwords hm'
instance Show Contour_Half_Matrix where
show = contour_half_matrix_str
data Contour_Description =
Contour_Description {contour_description_n :: Int
,contour_description_m :: M.Map (Int,Int) Ordering}
deriving (Eq)
contour_description :: Ord a => [a] -> Contour_Description
contour_description x =
let n = length x
ix = all_indices n
o = zip ix (map (\(i,j) -> compare (x !! i) (x !! j)) ix)
in Contour_Description n (M.fromList o)
contour_description_str :: Contour_Description -> String
contour_description_str (Contour_Description n m) =
let xs = concatMap (show . fromEnum . snd) (M.toList m)
in unwords (splitPlaces [n1,n2 .. 0] xs)
instance Show Contour_Description where
show = contour_description_str
half_matrix_to_description :: Contour_Half_Matrix -> Contour_Description
half_matrix_to_description (Contour_Half_Matrix n hm) =
let ix = all_indices n
o = zip ix (concat hm)
in Contour_Description n (M.fromList o)
contour_description_ix :: Contour_Description -> (Int,Int) -> Ordering
contour_description_ix d i = contour_description_m d M.! i
uniform :: Contour_Description -> Bool
uniform (Contour_Description _ m) = T.all_equal (M.elems m)
no_equalities :: Contour_Description -> Bool
no_equalities (Contour_Description _ m) = EQ `notElem` M.elems m
all_contours :: Int -> [Contour_Description]
all_contours n =
let n' = contour_description_lm n
ix = all_indices n
cs = filter (not.null) (T.powerset [LT,EQ,GT])
pf = concatMap T.multiset_permutations . T.expand_set n'
mk p = Contour_Description n (M.fromList (zip ix p))
in map mk (concatMap pf cs)
implication :: (Ordering,Ordering) -> Maybe Ordering
implication (i,j) =
case (min i j,max i j) of
(LT,LT) -> Just LT
(LT,EQ) -> Just LT
(LT,GT) -> Nothing
(EQ,EQ) -> Just EQ
(EQ,GT) -> Just GT
(GT,GT) -> Just GT
_ -> error "implication"
violations :: Contour_Description -> [(Int,Int,Int,Ordering)]
violations d =
let n = contour_description_n d 1
ms = [(i,j,k) | i <- [0..n], j <- [i + 1 .. n], k <- [j + 1 .. n]]
ix = contour_description_ix d
complies (i,j,k) =
let l = ix (i,j)
r = ix (j,k)
b = ix (i,k)
in case implication (l,r) of
Nothing -> Nothing
Just x -> if x == b
then Nothing
else Just (i,j,k,x)
in mapMaybe complies ms
is_possible :: Contour_Description -> Bool
is_possible = null . violations
possible_contours :: Int -> [Contour_Description]
possible_contours = filter is_possible . all_contours
impossible_contours :: Int -> [Contour_Description]
impossible_contours = filter (not.is_possible) . all_contours
contour_description_lm :: Integral a => a -> a
contour_description_lm l = (l * l l) `div` 2
contour_truncate :: Contour_Description -> Int -> Contour_Description
contour_truncate (Contour_Description n m) z =
let n' = min n z
f (i,j) _ = i < n' && j < n'
in Contour_Description n' (M.filterWithKey f m)
contour_is_prefix_of :: Contour_Description -> Contour_Description -> Bool
contour_is_prefix_of p q = p == contour_truncate q (contour_description_n p)
contour_eq_at :: Contour_Description -> Contour_Description -> Int -> Bool
contour_eq_at p q n =
let a = contour_description_m p
b = contour_description_m q
f (_,j) _ = j == n
g = M.toAscList . M.filterWithKey f
in g a == g b
draw_contour :: Integral i => Contour_Description -> [i]
draw_contour d =
let n = contour_description_n d
ix = all_indices n
normalise :: Integral i => [Rational] -> [i]
normalise xs =
let xs' = nub (sort xs)
in map (\i -> fromIntegral (fromJust (elemIndex i xs'))) xs
adjustment x = if x == 0 then 1 else 1 % (denominator x * 2)
step (i,j) ns = let c = contour_description_ix d (i,j)
i' = ns !! i
j' = ns !! j
c' = compare i' j'
in if c == c'
then Nothing
else let j'' = case c of
LT -> i' + adjustment j'
EQ -> i'
GT -> i' adjustment j'
in Just (T.replace_at ns j j'')
refine [] ns = ns
refine (i:is) ns = case step i ns of
Nothing -> refine is ns
Just ns' -> refine ix ns'
in normalise (refine ix (replicate n 0))
contour_description_invert :: Contour_Description -> Contour_Description
contour_description_invert (Contour_Description n m) =
Contour_Description n (M.map T.ord_invert m)
type Build_f st e = st -> Maybe (e,st)
type Conforms_f e = Int -> [e] -> Bool
build_f_n :: Build_f st e -> Build_f (Int,st) e
build_f_n f =
let g g_st =
let (i,f_st) = g_st
in if i == 0
then Nothing
else case f f_st of
Nothing -> Nothing
Just (e,f_st') -> Just (e,(i 1,f_st'))
in g
build_sequence :: Int -> Build_f st e -> Conforms_f e -> Int -> st ->
(Maybe [e],st)
build_sequence n f g z =
let go i j r st =
if i == n
then (Just r,st)
else if j == z
then (Nothing,st)
else case f st of
Nothing -> (Nothing,st)
Just (e,st') ->
let i' = i + 1
j' = j + 1
r' = r ++ [e]
in if g i' r'
then go i' j' r' st'
else go i j' r st'
in go 0 0 []
build_contour :: (Ord e) =>
Build_f st e -> Contour_Description -> Int -> st ->
(Maybe [e],st)
build_contour f c z =
let n = contour_description_n c
g i r = let d = contour_description r
in contour_eq_at c d (i 1)
in build_sequence n f g z
build_contour_retry ::
(Ord e) =>
Build_f st e -> Contour_Description -> Int -> Int -> st ->
(Maybe [e], st)
build_contour_retry f c z n st =
if n == 0
then (Nothing,st)
else case build_contour f c z st of
(Nothing,st') -> build_contour_retry f c z (n 1) st'
r -> r
build_contour_set ::
(Ord e) =>
Build_f st e -> Contour_Description -> Int -> Int -> st -> [[e]]
build_contour_set f c z n st =
case build_contour_retry f c z n st of
(Nothing,_) -> []
(Just r,st') -> r : build_contour_set f c z n st'
build_contour_set_nodup ::
Ord e =>
Build_f st e -> Contour_Description -> Int -> Int -> st -> [[e]]
build_contour_set_nodup f c z n =
let go r st =
case build_contour_retry f c z n st of
(Nothing,_) -> []
(Just r',st') -> if r' `elem` r
then r
else go (r' : r) st'
in go []
ex_1 :: [Rational]
ex_1 = [2,3%2,1%2,1,2]
ex_2 :: [Integer]
ex_2 = [0,5,3]
ex_3 :: [Integer]
ex_3 = [12,7,6,7,8,7]
ex_4 :: Contour_Description
ex_4 =
let ns :: [[Int]]
ns = [[2,2,2,1],[2,2,0],[0,0],[1]]
ns' = map (map T.int_to_ord) ns
in half_matrix_to_description (Contour_Half_Matrix 5 ns')