\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           Data.Tuple.HT (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)]
> -- (True,p) - p relative pitch to the previous note in the chord
> -- (False,p) - p absolute pitch
> 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
>
> -- copy of GHC-6.4's ReadP.many function
> 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"]),  -- "maj7" collides with "maj"++"7"
>   (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}