\begin{haskelllisting}
> module Haskore.Composition.ChordType
> (T, toChord, parse, fromString, toString) where
>
> import qualified Haskore.Composition.Chord as Chord
> import qualified Haskore.Basic.Pitch as Pitch
> import qualified Text.ParserCombinators.ReadP as ReadP
> import Text.ParserCombinators.ReadP (ReadP)
> import qualified Data.Array as Array
> import Data.Array(Array,Ix,(!))
> import Haskore.General.Utility(mapSnd)
> import Control.Monad(liftM2,liftM3)
\end{haskelllisting}
% http://www.geocities.com/melatefet/chordsr.htm
\begin{haskelllisting}
> data T = Cons Third Fourth [Fifth]
> deriving (Show, Eq)
>
> toChord :: T -> Chord.T
> toChord (Cons third fourth fifth) =
> scanl (\p (rel,rp) -> if rel then p+rp else rp) 0
> (foldl (flip fifthToSteps)
> (fourthToSteps third fourth
> (thirdToSteps third)) fifth)
> thirdToSteps :: Third -> [Pitch.Relative]
> thirdToSteps third =
> case third of
> ThirdMajor -> [4,3]
> ThirdAugmentedFifth -> [4,4]
> ThirdDiminishedFifth -> [4,2]
> ThirdMinor -> [3,4]
> ThirdMinorAugmentedFifth -> [3,5]
> ThirdMinorDiminishedFifth -> [3,3]
> ThirdDiminished -> [3,3]
> ThirdSustained2 -> [2,5]
> ThirdSustained4 -> [5,2]
> ThirdDiminishedAugmented -> [3,3,3]
> absP, relP :: Pitch.Relative -> (Bool,Pitch.Relative)
> absP = (,) False
> relP = (,) True
> fourthToSteps ::
> Third -> Fourth -> [Pitch.Relative] -> [(Bool,Pitch.Relative)]
>
>
> fourthToSteps third fourth ps =
> let bps = map relP ps
> in case fourth of
> FourthNone -> bps
> FourthSecond -> bps++[absP 2]
> FourthSixth -> bps++[absP 9]
> FourthSixthNineth -> bps++[absP 9, relP 5]
> FourthSeventh ->
> if third==ThirdDiminished
> then bps++[relP 3]
> else bps++[absP 10]
> FourthMajorSeventh -> bps++[absP 11]
> FourthNineth -> bps++[relP 10, absP 2]
> FourthMajorNineth -> bps++[absP 11, relP 3]
> FourthEleventh -> [absP 7, relP 3, relP 4, absP 5]
> FourthThirteenth -> [absP (head ps), relP 5, absP 2, absP 10]
> updateNode :: Int -> a -> (a -> a) -> [a] -> [a]
> updateNode n deflt f xs =
> let (x0,x1) = splitAt n xs
> in x0 ++ case x1 of
> [] -> [f deflt]
> (y:ys) -> f y : ys
> incPitch :: Int -> Pitch.Relative -> Pitch.Relative ->
> [(Bool,Pitch.Relative)] -> [(Bool,Pitch.Relative)]
> incPitch n deflt inc =
> updateNode n (False,deflt) (mapSnd (inc+))
> fifthToSteps :: Fifth -> [(Bool,Pitch.Relative)] -> [(Bool,Pitch.Relative)]
> fifthToSteps fifth =
> case fifth of
> FifthAugmentedThird -> incPitch 0 undefined 1 .
> incPitch 1 undefined (1)
> FifthDiminishedFifth -> incPitch 1 undefined (1)
> FifthAugmentedFifth -> incPitch 1 undefined 1
> FifthMajorSeventh -> incPitch 2 10 1
> FifthMinorNineth -> incPitch 3 14 (1)
> FifthMajorNineth -> incPitch 3 14 1
> FifthAugmentedEleventh -> incPitch 3 17 1
\end{haskelllisting}
\begin{haskelllisting}
> data Third =
> ThirdMajor
> | ThirdAugmentedFifth
> | ThirdDiminishedFifth
> | ThirdMinor
> | ThirdMinorAugmentedFifth
> | ThirdMinorDiminishedFifth
> | ThirdDiminished
> | ThirdSustained2
> | ThirdSustained4
> | ThirdDiminishedAugmented
> deriving (Show, Eq, Ord, Ix)
>
> data Fourth =
> FourthNone
> | FourthSecond
> | FourthSixth
> | FourthSixthNineth
> | FourthSeventh
> | FourthMajorSeventh
> | FourthNineth
> | FourthMajorNineth
> | FourthEleventh
> | FourthThirteenth
> deriving (Show, Eq, Ord, Ix)
>
> data Fifth =
> FifthAugmentedThird
> | FifthDiminishedFifth
> | FifthAugmentedFifth
> | FifthMajorSeventh
> | FifthMinorNineth
> | FifthMajorNineth
> | FifthAugmentedEleventh
> deriving (Show, Eq, Ord, Ix)
>
> toString :: T -> String
> toString (Cons third fourth fifthList) =
> thirdsArray!third ++
> fourthsArray!fourth ++
> concatMap (fifthsArray!) fifthList
>
> intervalToArray :: (Ix a) => [(a,[String])] -> Array a String
> intervalToArray xs =
> Array.array (fst (head xs), fst (last xs))
> (map (mapSnd head) xs)
>
> thirdsArray :: Array Third String
> thirdsArray = intervalToArray thirds
>
> fourthsArray :: Array Fourth String
> fourthsArray = intervalToArray fourths
>
> fifthsArray :: Array Fifth String
> fifthsArray = intervalToArray fifths
>
> fromString :: String -> T
> fromString =
> fst . head . filter (null . snd) . ReadP.readP_to_S parse
>
>
> readPmany :: ReadP a -> ReadP [a]
> readPmany p = return [] ReadP.+++ liftM2 (:) p (readPmany p)
>
> parse :: ReadP T
> parse =
> liftM3 Cons
> (parseInterval thirds)
> (parseInterval fourths)
> (readPmany (parseInterval fifths))
>
> parseInterval :: [(a,[String])] -> ReadP a
> parseInterval =
> ReadP.choice . map (uncurry parseIntervalAlternatives)
>
> parseIntervalAlternatives :: a -> [String] -> ReadP a
> parseIntervalAlternatives x sym =
> ReadP.choice (map ReadP.string sym) >> return x
>
> thirds :: [(Third,[String])]
> thirds = [
> (ThirdMajor, ["", "maj"]),
> (ThirdAugmentedFifth, ["+", "aug"]),
> (ThirdDiminishedFifth, ["-"]),
> (ThirdMinor, ["m"]),
> (ThirdMinorAugmentedFifth, ["m+"]),
> (ThirdMinorDiminishedFifth, ["m-"]),
> (ThirdDiminished, ["0", "dim"]),
> (ThirdSustained2, ["sus2"]),
> (ThirdSustained4, ["sus4", "4"]),
> (ThirdDiminishedAugmented, ["0+"])
> ]
> fourths :: [(Fourth,[String])]
> fourths = [
> (FourthNone, [""]),
> (FourthSecond, ["2"]),
> (FourthSixth, ["6"]),
> (FourthSixthNineth, ["6/9"]),
> (FourthSeventh, ["7"]),
> (FourthMajorSeventh, ["M7", "Ma7"]),
> (FourthNineth, ["9"]),
> (FourthMajorNineth, ["M9"]),
> (FourthEleventh, ["11"]),
> (FourthThirteenth, ["13"])
> ]
> fifths :: [(Fifth,[String])]
> fifths = [
> (FifthAugmentedThird, ["3+"]),
> (FifthDiminishedFifth, ["-5", "5-"]),
> (FifthAugmentedFifth, ["+5", "5+", "-6", "6-"]),
> (FifthMajorSeventh, ["7+"]),
> (FifthMinorNineth, ["-9"]),
> (FifthMajorNineth, ["+9"]),
> (FifthAugmentedEleventh, ["+11"])
> ]
\end{haskelllisting}