module Fadno.Xml
(
xmlScore,xmlPart,xmlPartClef
,xmlMeasure
,xmlPrependMeasureData,xmlPrependMeasureDatas
,xmlAppendMeasureData,xmlAppendMeasureDatas
,xmlClef,xmlClef'
,xmlRepeats,xmlRepeats'
,xmlBarline,xmlTimeSig,xmlRehearsalMark,xmlDirection
,xmlNote,xmlChord
,xmlTie
,renderFile,renderString,renderElement,Element
) where
import Fadno.MusicXml.MusicXml20
import Fadno.Xml.EmitXml
import qualified Data.Map.Strict as M
import qualified Fadno.Note as N
import qualified Fadno.Notation as N
import Data.List (mapAccumL)
import Data.Maybe
import Data.Ratio
import Control.Arrow
import Text.XML.Light
import Data.String
import Control.Lens hiding (Empty)
import Data.Foldable
import Data.Monoid
makeClassy_ ''ChxMusicData
makeClassy_ ''Note
makeClassy_ ''ChxNote
makeClassy_ ''GrpFullNote
makeClassy_ ''MusicData
makeClassy_ ''Measure
makeClassy_ ''ScorePartwise
makeClassy_ ''ScoreHeader
makeClassy_ ''Identification
makeClassy_ ''PartList
makeClassy_ ''CmpPart
_testFile :: IO ()
_testFile = renderFile "output/newtest.xml" $
xmlScore "Test" "Stoobie"
[xmlPartClef "Hurdy Gurdy" "HGy" N.TrebleClef
[xmlMeasure "1" $ xmlChord _testNote]]
xmlDivisions :: PositiveDivisions
xmlDivisions = 768
type MeasureList f = (Traversable f, Cons (f Measure) (f Measure) Measure Measure,
Snoc (f Measure) (f Measure) Measure Measure)
xmlScore :: String -> String -> [(CmpPart,ScorePart)] -> ScorePartwise
xmlScore title composer xmlParts =
(mkScorePartwise
((mkScoreHeader doPartList)
{ scoreHeaderMovementTitle = Just title
, scoreHeaderIdentification =
Just (mkIdentification
{ identificationCreator =
[TypedText composer (Just "composer") ]}) })
) { scorePartwisePart = toListOf (traverse._1) xmlParts }
where
doPartList =
PartList []
(xmlParts ^?! _head._2)
(map PartListScorePart (toListOf (_tail.traverse._2) xmlParts))
xmlPart :: MeasureList f => String -> String -> f Measure -> (CmpPart,ScorePart)
xmlPart longName shortName measures =
(CmpPart (fromString shortName) (toList $ addDivs measures),
ScorePart
(mkCmpScorePart (fromString shortName)
(mkPartName (fromString longName)))
{ scorePartPartAbbreviation =
Just (mkPartName (fromString shortName)) })
where addDivs = xmlPrependMeasureData
(MusicDataAttributes
((mkAttributes mkEditorial)
{ attributesDivisions = Just xmlDivisions }))
xmlPartClef :: MeasureList f => String -> String -> N.Clef -> f Measure -> (CmpPart,ScorePart)
xmlPartClef l s c ms = xmlPart l s (xmlPrependMeasureData (xmlClef' c) ms)
type ApplyMonoid c t = (Applicative c,Monoid (c t))
xmlMeasure :: Traversable t => String -> t ChxMusicData -> Measure
xmlMeasure mNumber = mkMeasure (fromString mNumber) . MusicData . toList
xmlPrependMeasureData :: (MeasureList f) => ChxMusicData -> f Measure -> f Measure
xmlPrependMeasureData = xmlPrependMeasureDatas . pure
xmlPrependMeasureDatas :: (MeasureList f) => [ChxMusicData] -> f Measure -> f Measure
xmlPrependMeasureDatas d = over (_head._measureMusicData._musicDataMusicData) (d <>)
xmlAppendMeasureData :: (MeasureList f) => ChxMusicData -> f Measure -> f Measure
xmlAppendMeasureData = xmlAppendMeasureDatas . pure
xmlAppendMeasureDatas :: (MeasureList f) => [ChxMusicData] -> f Measure -> f Measure
xmlAppendMeasureDatas d = over (_last._measureMusicData._musicDataMusicData) (d <>)
maybeMusicDatas :: (ApplyMonoid c t) => Getting (Maybe a) s (Maybe a) -> (a -> c t) -> s -> c t
maybeMusicDatas l f = maybe mempty f . view l
maybeMusicData :: (ApplyMonoid c t) => Getting (Maybe a) s (Maybe a) -> (a -> t) -> s -> c t
maybeMusicData l f = maybeMusicDatas l (pure.f)
xmlClef :: (ApplyMonoid c ChxMusicData, N.HasClef a) => a -> c ChxMusicData
xmlClef = maybeMusicData N.clef xmlClef'
xmlClef' :: N.Clef -> ChxMusicData
xmlClef' c =
case c of
N.TrebleClef -> mkC ClefSignG 2
N.BassClef -> mkC ClefSignF 4
N.AltoClef -> mkC ClefSignC 3
N.PercClef -> mkC ClefSignPercussion 3
where mkC cs cl =
MusicDataAttributes
((mkAttributes mkEditorial)
{ attributesClef = [(mkClef cs)
{ clefLine = Just cl }]})
xmlBarline :: (ApplyMonoid c ChxMusicData) => N.HasBarline a => a -> c ChxMusicData
xmlBarline = maybeMusicData N.barline $ \b ->
case b of
N.Double -> mdBarline RightLeftMiddleLeft
BarStyleLightLight Nothing
N.Final -> mdBarline RightLeftMiddleRight
BarStyleLightHeavy Nothing
xmlRepeats :: (ApplyMonoid t ChxMusicData) => N.HasRepeats a => a -> t ChxMusicData
xmlRepeats = maybeMusicDatas N.repeats $ \r ->
case r of
N.RStart -> pure startRepeat
N.REnd -> pure endRepeat
N.RBoth -> pure startRepeat <> pure endRepeat
where
startRepeat :: ChxMusicData
startRepeat = mdBarline RightLeftMiddleLeft
BarStyleHeavyLight (Just BackwardForwardForward)
endRepeat :: ChxMusicData
endRepeat = mdBarline RightLeftMiddleRight
BarStyleLightHeavy (Just BackwardForwardBackward)
xmlRepeats' :: (N.HasRepeats a, MeasureList f) => a -> f Measure -> f Measure
xmlRepeats' s measures =
case view N.repeats s of
Nothing -> measures
Just N.RStart -> doStart measures
Just N.REnd -> doEnd measures
Just N.RBoth -> doStart . doEnd $ measures
where doStart = xmlPrependMeasureData startRepeat
doEnd = xmlAppendMeasureData endRepeat
mdBarline :: RightLeftMiddle -> BarStyle ->
Maybe BackwardForward -> ChxMusicData
mdBarline rml bs bf =
MusicDataBarline
((mkBarline mkEditorial)
{ barlineLocation = Just rml
, barlineBarStyle = Just (mkBarStyleColor bs)
, barlineRepeat = fmap mkRepeat bf })
xmlTimeSig :: (ApplyMonoid t ChxMusicData, N.HasTimeSignature a) => a -> t ChxMusicData
xmlTimeSig = maybeMusicData N.timeSignature $ \(N.TimeSignature n q) ->
MusicDataAttributes $
(mkAttributes mkEditorial)
{ attributesTime =
[mkTime (TimeTime [SeqTime (fromString $ show n)
(fromString $ show $ N.qToInt q)])]}
xmlRehearsalMark :: (ApplyMonoid t ChxMusicData,N.HasRehearsalMark a) => a -> t ChxMusicData
xmlRehearsalMark = maybeMusicData N.rehearsalMark
(makeDirection . DirectionTypeRehearsal . return .
mkRehearsal . view N.rehearsalText)
xmlDirection :: (ApplyMonoid t ChxMusicData,N.HasDirection a) => a -> t ChxMusicData
xmlDirection = maybeMusicData N.direction
(makeDirection . DirectionTypeWords . return .
mkFormattedText . view N.directionText)
makeDirection :: ChxDirectionType -> ChxMusicData
makeDirection dt = MusicDataDirection
((mkDirection mkEditorialVoiceDirection)
{ directionDirectionType = [DirectionType dt] })
xmlNote :: (N.HasNote a (N.Mono N.PitchRep) Rational) => a -> ChxMusicData
xmlNote n = MusicDataNote
(mkNote (NoteFullNote
(GrpFullNote Nothing
(fullNote (view N.notePitch n)))
(Duration durDivs) [])
mkEditorialVoice)
{ noteType = Just (mkNoteType durNoteType)
, noteDot = nds }
where (durDivs,durNoteType,durDots) = convertDurR xmlDivisions $ view N.noteDur n
nds = replicate durDots mkEmptyPlacement
fullNote (N.M p) = FullNotePitch (convertPitchRep p)
fullNote N.Rest = FullNoteRest mkDisplayStepOctave
xmlChord :: (N.HasNote a [N.PitchRep] Rational) =>
a -> [ChxMusicData]
xmlChord ch =
case view N.notePitch ch of
[] -> [doNote N.Rest]
ps -> zipWith doChord [(0 :: Int)..] $ map (doNote.N.M) ps
where doNote p = xmlNote (N.Note p (view N.noteDur ch))
doChord i | i == 0 = id
| otherwise =
set (_musicDataNote._noteNote._noteFullNote2._fullNoteChord)
(Just Empty)
_testNote :: N.Note' [N.PitchRep] Rational
_testNote = over N.nNote (view (bimapping (mapping N.pitchRep) (N.ratioPPQ N.PQ4))) N.testNote
xmlTie :: (N.HasTie a) => a -> ChxMusicData -> ChxMusicData
xmlTie a = over (_musicDataNote._noteNotations) (++adapt mkTNot) .
over (_musicDataNote._noteNote._noteTie1) (++adapt Tie)
where adapt fc = maybe [] (fmap fc . conv) $ view N.tie a
conv N.TStart = [StartStopStart]
conv N.TStop = [StartStopStop]
conv N.TBoth = [StartStopStop,StartStopStart]
mkTNot s = (mkNotations mkEditorial)
{notationsNotations = [NotationsTied (mkTied s)]}
steps :: [(Step,Maybe Semitones)]
steps = [(StepC,Nothing),
(StepC,sharp),
(StepD,Nothing),
(StepE,flat),
(StepE,Nothing),
(StepF,Nothing),
(StepF,sharp),
(StepG,Nothing),
(StepA,flat),
(StepA,Nothing),
(StepB,flat),
(StepB,Nothing)]
where sharp = Just 1
flat = Just (1)
noteTypeValues :: M.Map Int NoteTypeValue
noteTypeValues = M.fromList $ snd $ mapAccumL acc (256*4) [minBound .. maxBound]
where acc v nt = (v `div` 2,(v,nt))
convertPitch :: Int -> Pitch
convertPitch i = Pitch step semi oct where
oct = fromIntegral $ (i `div` 12) 1
(step, semi) = steps !! (i `mod` 12)
convertPitchRep :: N.PitchRep -> Pitch
convertPitchRep (N.PitchRep s o) = Pitch step semi (fromIntegral o)
where (step,semi) = ss s
sharp = Just 1
flat = Just (1)
ss N.C = (StepC,Nothing)
ss N.Cs = (StepC,sharp)
ss N.Db = (StepD,flat)
ss N.D = (StepD,Nothing)
ss N.Ds = (StepD,sharp)
ss N.Eb = (StepE,flat)
ss N.E = (StepE,Nothing)
ss N.F = (StepF,Nothing)
ss N.Fs = (StepF,sharp)
ss N.Gb = (StepG,flat)
ss N.G = (StepG,Nothing)
ss N.Gs = (StepG,sharp)
ss N.Ab = (StepA,flat)
ss N.A = (StepA,Nothing)
ss N.As = (StepA,sharp)
ss N.Bb = (StepB,flat)
ss N.B = (StepB,Nothing)
convertDur :: N.PPQ -> Int -> PositiveDivisions -> (PositiveDivisions,NoteTypeValue,Int)
convertDur ppq dur xdivs = (fromIntegral divs,findValue,dots)
where
ppqd = N.ppqDiv ppq
divs = floor xdivs * dur `div` ppqd
(num,denom) = numerator &&& denominator $ (dur % (ppqd * 16))
dots = fromMaybe 0 $ M.lookup num dotValues
findValue = fromMaybe NoteTypeValue256th $
M.lookup (denom `div` (2 ^ dots)) noteTypeValues
convertDurR :: PositiveDivisions -> Rational -> (PositiveDivisions,NoteTypeValue,Int)
convertDurR xdivs r = (fromIntegral divs,findValue,dots)
where
divs :: Int
divs = floor $ toRational xdivs * (r * 4)
(num,denom) = numerator &&& denominator $ (r / 4)
dots = fromMaybe 0 $ M.lookup (fromIntegral num) dotValues
findValue = fromMaybe NoteTypeValue256th $
M.lookup (fromIntegral denom `div` (2 ^ dots)) noteTypeValues
dotValues :: M.Map Int Int
dotValues = M.fromList $ takeWhile (<= 1024) (dot 3 4) `zip` [1..]
where dot v i = v:dot (v + i) (i * 2)