-- | Polansky, Larry and Bassein, Richard -- \"Possible and Impossible Melody: Some Formal Aspects of Contour\" -- /Journal of Music Theory/ 36/2, 1992 (pp.259-284) -- () 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.Set as T import qualified Music.Theory.Permutations as T -- | Compare adjacent elements (p.262). -- -- > compare_adjacent [0,1,3,2] == [LT,LT,GT] compare_adjacent :: Ord a => [a] -> [Ordering] compare_adjacent xs = zipWith compare xs (tail xs) -- | 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 f = let g (x,xs) = map (f x) xs h xs = map (\x -> (x,xs)) xs in map g . 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 = matrix_f compare -- | Half matrix notation for contour. data Contour_Half_Matrix = Contour_Half_Matrix {contour_half_matrix_n :: Int ,contour_half_matrix_m :: Matrix Ordering} deriving (Eq) -- | 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 f xs = let drop_last = reverse . drop 1 . reverse m = drop_last (matrix_f f xs) in zipWith drop [1..] m -- | Construct 'Contour_Half_Matrix' (p.264) 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 -- | 'Show' function for 'Contour_Half_Matrix'. 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 -- | Generic variant of 'fromEnum' (p.263). ord_to_int :: Integral a => Ordering -> a ord_to_int = fromIntegral . fromEnum -- | Generic variant of 'toEnum' (p.263). int_to_ord :: Integral a => a -> Ordering int_to_ord = toEnum . fromIntegral -- | /Description/ notation of contour. data Contour_Description = Contour_Description {contour_description_n :: Int ,contour_description_m :: M.Map (Int,Int) Ordering} deriving (Eq) -- | Construct set of /n/-1 adjacent indices. -- -- > adjacent_indices 5 == [(0,1),(1,2),(2,3),(3,4)] adjacent_indices :: Integral i => i -> [(i,i)] adjacent_indices n = zip [0..n-2] [1..n-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 n = let n' = n - 1 in [(i,j) | i <- [0 .. n'], j <- [i + 1 .. n']] -- | Construct 'Contour_Description' of contour (p.264). -- -- > map (show.contour_description) [[3,2,4,1],[3,2,1,4]] == ["202 02 2","220 20 0"] 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) -- | 'Show' function for 'Contour_Description' (p.264). 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 [n-1,n-2 .. 0] xs) instance Show Contour_Description where show = 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 n hm) = let ix = all_indices n o = zip ix (concat hm) in Contour_Description n (M.fromList 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 d i = contour_description_m d M.! i -- | Are all elements equal. -- -- > all_equal "aaa" == True all_equal :: Eq a => [a] -> Bool all_equal xs = all id (zipWith (==) xs (tail xs)) -- | 'True' if contour is all descending, equal or ascending. -- -- > map (uniform.contour_description) ["abc","bbb","cba"] == [True,True,True] uniform :: Contour_Description -> Bool uniform (Contour_Description _ m) = all_equal (M.elems m) -- | 'True' if contour does not containt any 'EQ' elements. -- -- > map (no_equalities.contour_description) ["abc","bbb","cba"] == [True,False,True] no_equalities :: Contour_Description -> Bool no_equalities (Contour_Description _ m) = EQ `notElem` M.elems m -- | Set of all contour descriptions. -- -- > map (length.all_contours) [3,4,5] == [27,729,59049] 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]) ps = concatMap (concatMap T.multiset_permutations . T.se n') cs mk p = Contour_Description n (M.fromList (zip ix p)) in map mk ps -- | List of all violations at a 'Contour_Description' (p.266). 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 the number of 'violations' zero. is_possible :: Contour_Description -> Bool is_possible = (== 0) . length . violations -- | All possible contour descriptions -- -- > map (length.possible_contours) [3,4,5] == [13,75,541] possible_contours :: Int -> [Contour_Description] possible_contours = filter is_possible . all_contours -- | All impossible contour descriptions -- -- > map (length.impossible_contours) [3,4,5] == [14,654,58508] impossible_contours :: Int -> [Contour_Description] impossible_contours = filter (not.is_possible) . all_contours -- | Calculate number of contours of indicated degree (p.263). -- -- > map contour_description_lm [2..7] == [1,3,6,10,15,21] -- > map (\n -> 3 ^ n) (map contour_description_lm [2..6]) == [3,27,729,59049,14348907] contour_description_lm :: Integral a => a -> a contour_description_lm l = (l * l - l) `div` 2 -- | 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 (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" -- | Replace the /i/th value at /ns/ with /x/. -- -- > replace "test" 2 'n' == "tent" replace :: Integral i => [a] -> i -> a -> [a] replace ns i x = let f j y = if i == j then x else y in zipWith f [0..] ns -- | 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 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 (findIndex (== 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' -- traceShow (i,j,ns) $ in if c == c' then Nothing else let j'' = case c of LT -> i' + adjustment j' EQ -> i' GT -> i' - adjustment j' in Just (replace 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)) -- | Invert 'Ordering'. -- -- > map ord_invert [LT,EQ,GT] == [GT,EQ,LT] ord_invert :: Ordering -> Ordering ord_invert x = case x of LT -> GT EQ -> EQ GT -> LT -- | Invert 'Contour_Description'. -- -- > draw_contour (contour_description_invert (contour_description "abdc")) == [3,2,0,1] contour_description_invert :: Contour_Description -> Contour_Description contour_description_invert (Contour_Description n m) = Contour_Description n (M.map ord_invert m) -- | 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 = [2,3%2,1%2,1,2] -- | Example on p.265 (pitch) -- -- > ex_2 == [0,5,3] -- > show (contour_description ex_2) == "00 2" ex_2 :: [Integer] ex_2 = [0,5,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 = [12,7,6,7,8,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 = let ns :: [[Int]] ns = [[2,2,2,1],[2,2,0],[0,0],[1]] ns' = map (map int_to_ord) ns in half_matrix_to_description (Contour_Half_Matrix 5 ns')