music-sibelius 1.8.1 → 1.9.0

raw patch · 4 files changed

+635/−445 lines, 4 filesdep +music-articulationdep +music-dynamicsdep +music-partsdep ~lensdep ~music-pitch-literaldep ~music-preludesPVP ok

version bump matches the API change (PVP)

Dependencies added: music-articulation, music-dynamics, music-parts, music-pitch

Dependency ranges changed: lens, music-pitch-literal, music-preludes, music-score

API changes (from Hackage documentation)

Files

• music-sibelius.cabal +12/−8
• src/Data/Music/Sibelius.hs +326/−0
• src/Music/Score/Import/Sibelius.hs +297/−124
• src/Music/Sibelius.hs +0/−313

@@ -1,6 +1,6 @@  name:                   music-sibelius-version:                1.8.1+version:                1.9.0 author:                 Hans Hoglund maintainer:             Hans Hoglund <hans@hanshoglund.se> license:                BSD3@@ -21,18 +21,22 @@   location:             git://github.com/music-suite/music-sibelius.git    library                    -    build-depends:      base                    >= 4 && < 5,-                        aeson                   >= 0.7.0.6 && < 1,-                        lens                    >= 4.6 && < 4.7,+    build-depends:      base                    >= 4        && < 5,+                        aeson                   >= 0.7.0.6  && < 1,+                        lens                    >= 4.11     && < 5,                         semigroups              >= 0.13.0.1 && < 1,                         monadplus,                         unordered-containers,                         bytestring,-                        music-score             == 1.8.1,-                        music-pitch-literal     == 1.8.1,-                        music-preludes          == 1.8.1,+                        music-score             == 1.9.0,+                        music-pitch             == 1.9.0,+                        music-parts             == 1.9.0,+                        music-dynamics          == 1.9.0,+                        music-articulation      == 1.9.0,+                        music-pitch-literal     == 1.9.0,+                        music-preludes          == 1.9.0,                         aeson-    exposed-modules:    Music.Sibelius+    exposed-modules:    Data.Music.Sibelius                         Music.Score.Import.Sibelius     hs-source-dirs:     src     default-language:   Haskell2010

@@ -0,0 +1,326 @@++{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, NoMonomorphismRestriction, +             ConstraintKinds, FlexibleContexts #-}++module Data.Music.Sibelius (++        -- * Scores and staves+        SibeliusScore(..),+        SibeliusStaff(..),+        SibeliusSystemStaff(..),+        SibeliusBar(..),+        +        -- * Bar objects+        SibeliusBarObject(..),+        isTimeSignature,+        +        -- ** Notes+        SibeliusChord(..),+        SibeliusNote(..),+        +        -- ** Lines+        SibeliusSlur(..),+        SibeliusCrescendoLine(..),+        SibeliusDiminuendoLine(..),+        +        -- ** Tuplets+        SibeliusTuplet(..),+        SibeliusArticulation(..),+        readSibeliusArticulation,+        +        -- ** Miscellaneous+        SibeliusClef(..),+        SibeliusKeySignature(..),+        SibeliusTimeSignature(..),+        SibeliusText(..),++  ) where++import Control.Monad.Plus+import Control.Applicative+import Data.Semigroup+import Data.Aeson++import qualified Data.HashMap.Strict as HashMap+++{-+setTitle :: String -> Score a -> Score a+setTitle = setMeta "title"+setComposer :: String -> Score a -> Score a+setComposer = setMeta "composer"+setInformation :: String -> Score a -> Score a+setInformation = setMeta "information"+setMeta :: String -> String -> Score a -> Score a+setMeta _ _ = id+-}+++data SibeliusScore = SibeliusScore {+            scoreTitle             :: String,+            scoreComposer          :: String,+            scoreInformation       :: String,+            scoreStaffHeight       :: Double,+            scoreTransposing       :: Bool,+            scoreStaves            :: [SibeliusStaff],+            scoreSystemStaff       :: SibeliusSystemStaff+    }+    deriving (Eq, Ord, Show)+instance FromJSON SibeliusScore where+    parseJSON (Object v) = SibeliusScore+        <$> v .: "title" +        <*> v .: "composer"+        <*> v .: "information"+        <*> v .: "staffHeight"+        <*> v .: "transposing"+        <*> v .: "staves"          +        <*> v .: "systemStaff"          ++data SibeliusSystemStaff = SibeliusSystemStaff {+            systemStaffBars                :: [SibeliusBar]+    }+    deriving (Eq, Ord, Show)+instance FromJSON SibeliusSystemStaff where+    parseJSON (Object v) = SibeliusSystemStaff+        <$> v .: "bars"++data SibeliusStaff = SibeliusStaff {+            staffBars                :: [SibeliusBar],+            staffName                :: String,+            staffShortName           :: String+    }+    deriving (Eq, Ord, Show)+instance FromJSON SibeliusStaff where+    parseJSON (Object v) = SibeliusStaff+        <$> v .: "bars"+        <*> v .: "name"+        <*> v .: "shortName"++data SibeliusBar = SibeliusBar {+            barElements            :: [SibeliusBarObject]+    }+    deriving (Eq, Ord, Show)+instance FromJSON SibeliusBar where+    parseJSON (Object v) = SibeliusBar+        <$> v .: "elements"++data SibeliusBarObject +    = SibeliusBarObjectText SibeliusText+    | SibeliusBarObjectClef SibeliusClef+    | SibeliusBarObjectSlur SibeliusSlur+    | SibeliusBarObjectCrescendoLine SibeliusCrescendoLine+    | SibeliusBarObjectDiminuendoLine SibeliusDiminuendoLine+    | SibeliusBarObjectTimeSignature SibeliusTimeSignature+    | SibeliusBarObjectKeySignature SibeliusKeySignature+    | SibeliusBarObjectTuplet SibeliusTuplet+    | SibeliusBarObjectChord SibeliusChord+    | SibeliusBarObjectUnknown String -- type+    deriving (Eq, Ord, Show)+-- TODO highlights, lyric, barlines, comment, other lines and symbols++isTimeSignature (SibeliusBarObjectTimeSignature _) = True+isTimeSignature _ = False++instance FromJSON SibeliusBarObject where+    parseJSON x@(Object v) = case HashMap.lookup "type" v of    +        -- TODO+        Just "text"      -> SibeliusBarObjectText <$> parseJSON x+        Just "clef"      -> SibeliusBarObjectClef <$> parseJSON x+        Just "slur"      -> SibeliusBarObjectSlur <$> parseJSON x+        Just "cresc"     -> SibeliusBarObjectCrescendoLine <$> parseJSON x+        Just "dim"       -> SibeliusBarObjectDiminuendoLine <$> parseJSON x+        Just "time"      -> SibeliusBarObjectTimeSignature <$> parseJSON x+        Just "key"       -> SibeliusBarObjectKeySignature <$> parseJSON x+        Just "tuplet"    -> SibeliusBarObjectTuplet <$> parseJSON x+        Just "chord"     -> SibeliusBarObjectChord <$> parseJSON x+        Just typ         -> SibeliusBarObjectUnknown <$> (return $ show typ)+        _                -> mempty -- failure: no type field++data SibeliusText = SibeliusText {+            textVoice               :: Int,+            textPosition            :: Int,+            textText                :: String,+            textStyle               :: Maybe String+    }+    deriving (Eq, Ord, Show)+instance FromJSON SibeliusText where+    parseJSON (Object v) = SibeliusText+        <$> v .: "voice" +        <*> v .: "position"+        <*> v .: "text"+        <*> v .: "style"+     +data SibeliusClef = SibeliusClef {+            clefVoice               :: Int,+            clefPosition            :: Int,+            clefStyle               :: Maybe String+    }+    deriving (Eq, Ord, Show)+instance FromJSON SibeliusClef where+    parseJSON (Object v) = SibeliusClef+        <$> v .: "voice" +        <*> v .: "position"+        <*> v .: "style"++data SibeliusSlur = SibeliusSlur {+            slurVoice               :: Int,+            slurPosition            :: Int,+            slurDuration            :: Int,+            slurStyle               :: Maybe String+    }+    deriving (Eq, Ord, Show)+instance FromJSON SibeliusSlur where+    parseJSON (Object v) = SibeliusSlur+        <$> v .: "voice" +        <*> v .: "position"+        <*> v .: "duration"+        <*> v .: "style"++data SibeliusCrescendoLine = SibeliusCrescendoLine {  +            crescVoice               :: Int,+            crescPosition            :: Int,+            crescDuration            :: Int,+            crescStyle               :: Maybe String+    }+    deriving (Eq, Ord, Show)+instance FromJSON SibeliusCrescendoLine where+    parseJSON (Object v) = SibeliusCrescendoLine+        <$> v .: "voice" +        <*> v .: "position"+        <*> v .: "duration"+        <*> v .: "style"++data SibeliusDiminuendoLine = SibeliusDiminuendoLine {+            dimVoice               :: Int,+            dimPosition            :: Int,+            dimDuration            :: Int,+            dimStyle               :: Maybe String+    }+    deriving (Eq, Ord, Show)+instance FromJSON SibeliusDiminuendoLine where+    parseJSON (Object v) = SibeliusDiminuendoLine+        <$> v .: "voice" +        <*> v .: "position"+        <*> v .: "duration"+        <*> v .: "style"++data SibeliusTimeSignature = SibeliusTimeSignature {+            timeVoice               :: Int,+            timePosition            :: Int,+            timeValue               :: [Int],+            timeIsCommon            :: Bool,+            timeIsAllaBreve         :: Bool+    }+    deriving (Eq, Ord, Show)+instance FromJSON SibeliusTimeSignature where+    parseJSON (Object v) = SibeliusTimeSignature+        <$> v .: "voice" +        <*> v .: "position"+        <*> v .: "value"+        <*> v .: "common"+        <*> v .: "allaBreve"++data SibeliusKeySignature = SibeliusKeySignature {+            keyVoice               :: Int,+            keyPosition            :: Int,+            keyMajor               :: Bool,+            keySharps              :: Int,+            keyIsOpen              :: Bool+    }+    deriving (Eq, Ord, Show)+instance FromJSON SibeliusKeySignature where+    parseJSON (Object v) = SibeliusKeySignature+        <$> v .: "voice" +        <*> v .: "position"+        <*> v .: "major"+        <*> v .: "sharps"+        <*> v .: "isOpen"++data SibeliusTuplet = SibeliusTuplet {+            tupletVoice               :: Int,+            tupletPosition            :: Int,+            tupletDuration            :: Int,+            tupletPlayedDuration      :: Int,+            tupletValue               :: [Int]+    }+    deriving (Eq, Ord, Show)+instance FromJSON SibeliusTuplet where+    parseJSON (Object v) = SibeliusTuplet +        <$> v .: "voice" +        <*> v .: "position"+        <*> v .: "duration"+        <*> v .: "playedDuration"+        <*> v .: "value"++data SibeliusArticulation+    = UpBow+    | DownBow+    | Plus+    | Harmonic+    | Marcato+    | Accent+    | Tenuto+    | Wedge+    | Staccatissimo+    | Staccato+    deriving (Eq, Ord, Show, Enum)++readSibeliusArticulation :: String -> Maybe SibeliusArticulation+readSibeliusArticulation = go+    where+        go "upbow"          = Just UpBow+        go "downBow"        = Just DownBow+        go "plus"           = Just Plus+        go "harmonic"       = Just Harmonic+        go "marcato"        = Just Marcato+        go "accent"         = Just Accent+        go "tenuto"         = Just Tenuto+        go "wedge"          = Just Wedge+        go "staccatissimo"  = Just Staccatissimo+        go "staccato"       = Just Staccato+        go _                = Nothing+    +data SibeliusChord = SibeliusChord { +            chordPosition            :: Int,+            chordDuration            :: Int,+            chordVoice               :: Int,+            chordArticulations       :: [SibeliusArticulation], -- TODO+            chordSingleTremolos      :: Int,+            chordDoubleTremolos      :: Int,+            chordAcciaccatura        :: Bool,+            chordAppoggiatura        :: Bool,+            chordNotes               :: [SibeliusNote]+    }+    deriving (Eq, Ord, Show)++instance FromJSON SibeliusChord where+    parseJSON (Object v) = SibeliusChord +        <$> v .: "position" +        <*> v .: "duration"+        <*> v .: "voice"+        <*> fmap (mmapMaybe readSibeliusArticulation) (v .: "articulations")+        <*> v .: "singleTremolos"+        <*> v .: "doubleTremolos"+        <*> v .: "acciaccatura"+        <*> v .: "appoggiatura"+        <*> v .: "notes"++data SibeliusNote = SibeliusNote {+            notePitch               :: Int,+            noteDiatonicPitch       :: Int,+            noteAccidental          :: Int,+            noteTied                :: Bool,+            noteStyle               :: Maybe Int -- not String?+    }+    deriving (Eq, Ord, Show)+instance FromJSON SibeliusNote where+    parseJSON (Object v) = SibeliusNote +        <$> v .: "pitch" +        <*> v .: "diatonicPitch"+        <*> v .: "accidental"+        <*> v .: "tied"+        <*> v .: "style"++++    

@@ -1,134 +1,307 @@  {-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, NoMonomorphismRestriction, -             ConstraintKinds, FlexibleContexts #-}+             ConstraintKinds, FlexibleContexts, TypeFamilies, CPP, ViewPatterns #-}  module Music.Score.Import.Sibelius (-        -- IsSibelius(..),-        -- fromSibelius,-        -- readSibelius,-        -- readSibeliusMaybe,-        -- readSibeliusEither+        IsSibelius(..),+        fromSibelius,+        readSibelius,+        readSibeliusMaybe,+        readSibeliusEither   ) where --- import Control.Lens--- import Music.Sibelius--- import Music.Score--- import Data.Aeson--- import Music.Pitch.Literal (IsPitch)--- --- import qualified Music.Pitch.Literal as Pitch--- import qualified Data.ByteString.Lazy as ByteString--- --- -- |--- -- Convert a score from a Sibelius representation.--- ----- fromSibelius :: IsSibelius a => SibeliusScore -> Score a--- fromSibelius (SibeliusScore title composer info staffH transp staves systemStaff) =---     foldr (</>) mempty $ fmap fromSibeliusStaff staves---     -- TODO meta information--- --- fromSibeliusStaff :: IsSibelius a => SibeliusStaff -> Score a--- fromSibeliusStaff (SibeliusStaff bars name shortName) =---     removeRests $ scat $ fmap fromSibeliusBar bars---     -- TODO bar length hardcoded---     -- TODO meta information---     -- NOTE slur pos/dur always "stick" to an adjacent note, regardless of visual position---     --      for other lines (cresc etc) this might not be the case---     -- WARNING key sig changes goes at end of previous bar--- --- fromSibeliusBar :: IsSibelius a => SibeliusBar -> Score (Maybe a)--- fromSibeliusBar (SibeliusBar elems) = ---     fmap Just (pcat $ fmap fromSibeliusChordElem chords) <> return Nothing^*1---     where---         chords   = filter isChord elems---         tuplets  = filter isTuplet elems -- TODO use these---         floating = filter isFloating elems--- --- fromSibeliusChordElem :: IsSibelius a => SibeliusBarObject -> Score a--- fromSibeliusChordElem = go where---     go (SibeliusBarObjectChord chord) = fromSibeliusChord chord---     go _                         = error "fromSibeliusChordElem: Expected chord"--- --- -- handleFloatingElem :: IsSibelius a => SibeliusBarObject -> [Score a] -> [Score a]--- --- isChord (SibeliusBarObjectChord _) = True--- isChord _                     = False--- --- isTuplet (SibeliusBarObjectTuplet _) = True--- isTuplet _                      = False--- --- isFloating x = not (isChord x) && not (isTuplet x) ---     --- --- fromSibeliusChord :: IsSibelius a => SibeliusChord -> Score a--- fromSibeliusChord (SibeliusChord pos dur voice ar strem dtrem acci appo notes) = ---     showVals $ setTime $ setDur $ every setArt ar $ tremolo strem $ pcat $ fmap fromSibeliusNote notes---     where     ---         showVals = text (show pos ++ " " ++ show dur) -- TODO DEBUG---         -- WARNING for tuplets, positions are absolute (sounding), but durations are relative (written)---         -- To retrieve sounding duration we must find floating tuplet objects and use---         -- the duration/playedDuration fields---         setTime = delay (fromIntegral pos / kTicksPerWholeNote)---         setDur  = stretch (fromIntegral dur / kTicksPerWholeNote)---         setArt Marcato         = marcato---         setArt Accent          = accent---         setArt Tenuto          = tenuto---         setArt Staccato        = staccato---         setArt a               = error $ "fromSibeliusChord: Unsupported articulation" ++ show a        ---     -- TODO tremolo and appogiatura/acciaccatura support--- --- fromSibeliusNote :: IsSibelius a => SibeliusNote -> Score a--- fromSibeliusNote (SibeliusNote pitch diatonicPitch acc tied style) =---     (if tied then fmap beginTie else id)---     $ fmap (up' (fromIntegral pitch - 60)) Pitch.c---     -- TODO spell correctly if this is Common.Pitch (how to distinguish)---     where---         up' x = pitch' %~ (+ x)---         -- up' x = mapPitch' (+ x)--- --- -- |--- -- Read a Sibelius score from a file. Fails if the file could not be read or if a parsing--- -- error occurs.--- -- --- readSibelius :: IsSibelius a => FilePath -> IO (Score a)--- readSibelius path = fmap (either (\x -> error $ "Could not read score " ++ x) id) $ readSibeliusEither path--- --- -- |--- -- Read a Sibelius score from a file. Fails if the file could not be read, and returns--- -- @Nothing@ if a parsing error occurs.--- -- --- readSibeliusMaybe :: IsSibelius a => FilePath -> IO (Maybe (Score a))--- readSibeliusMaybe path = fmap (either (const Nothing) Just) $ readSibeliusEither path--- --- -- |--- -- Read a Sibelius score from a file. Fails if the file could not be read, and returns--- -- @Left m@ if a parsing error occurs.--- -- --- readSibeliusEither :: IsSibelius a => FilePath -> IO (Either String (Score a))--- readSibeliusEither path = do---     json <- ByteString.readFile path---     return $ fmap fromSibelius $ eitherDecode' json--- --- -- |--- -- This constraint includes all note types that can be constructed from a Sibelius representation.--- ----- type IsSibelius a = (---     IsPitch a, ---     HasPart' a, ---     Enum (Part a), ---     HasPitch' a, ---     Num (Pitch a), ---     HasTremolo a, ---     HasArticulation a,---     HasText a,---     Tiable a---     )--- +import Control.Lens+import Data.Music.Sibelius+import qualified Data.Maybe+import qualified Music.Score as S+import Data.Aeson+import qualified Music.Prelude+import Music.Pitch.Literal (IsPitch)+import Music.Score hiding (Pitch, Interval, Articulation, Part)+import Music.Pitch+import Music.Articulation+import Music.Dynamics+import Music.Parts+#ifdef GHCI+import qualified System.Process+import Music.Prelude+#endif++import qualified Music.Pitch.Literal as Pitch+import qualified Data.ByteString.Lazy as ByteString++-- |+-- Read a Sibelius score from a file. Fails if the file could not be read or if a parsing+-- error occurs. -- --- -- Util+readSibelius :: IsSibelius a => FilePath -> IO (Score a)+readSibelius path = fmap (either (\x -> error $ "Could not read score: " ++ x) id) $ readSibeliusEither path++-- |+-- Read a Sibelius score from a file. Fails if the file could not be read, and returns+-- @Nothing@ if a parsing error occurs. -- --- every :: (a -> b -> b) -> [a] -> b -> b--- every f = flip (foldr f)+readSibeliusMaybe :: IsSibelius a => FilePath -> IO (Maybe (Score a))+readSibeliusMaybe path = fmap (either (const Nothing) Just) $ readSibeliusEither path++-- |+-- Read a Sibelius score from a file. Fails if the file could not be read, and returns+-- @Left m@ if a parsing error occurs. -- --- kTicksPerWholeNote = 1024 -- Always in Sibelius+readSibeliusEither :: IsSibelius a => FilePath -> IO (Either String (Score a))+readSibeliusEither path = do+    json <- ByteString.readFile path+    return $ fmap fromSibelius $ eitherDecode' json+readSibeliusEither' :: FilePath -> IO (Either String SibeliusScore)+readSibeliusEither' path = do+    json <- ByteString.readFile path+    return $ eitherDecode' json +-- Get the eventual time signature changes in each bar+getSibeliusTimeSignatures :: SibeliusSystemStaff -> [Maybe TimeSignature]+getSibeliusTimeSignatures x = fmap (getTimeSignatureInBar) +  $ systemStaffBars x+  where+    getTimeSignatureInBar = fmap convertTimeSignature . Data.Maybe.listToMaybe . filter isTimeSignature . barElements++convertTimeSignature :: SibeliusBarObject -> TimeSignature+convertTimeSignature (SibeliusBarObjectTimeSignature (SibeliusTimeSignature voice position [m,n] isCommon isAllaBReve)) = +    (fromIntegral m / fromIntegral n)  ++-- |+-- Convert a score from a Sibelius representation.+--+fromSibelius :: IsSibelius a => SibeliusScore -> Score a+fromSibelius (SibeliusScore title composer info staffH transp staves systemStaff) =+    timeSig $ pcat $ fmap (\staff -> set (parts') (partFromSibeliusStaff staff) (fromSibeliusStaff barDur staff)) $ staves+    -- TODO meta information+        where+            -- FIXME only reads TS in first bar+            barDur = case head (getSibeliusTimeSignatures systemStaff) of+              Nothing -> 1+              Just ts -> barDuration ts+            timeSig = case head (getSibeliusTimeSignatures systemStaff) of+              Nothing -> id+              Just ts -> timeSignature ts+          +            partFromSibeliusStaff (SibeliusStaff bars name shortName) = partFromName (name, shortName)++            -- TODO something more robust (in part library...)+            partFromName ("Piccolo",_) = piccoloFlutes+            partFromName ("Piccolo Flute",_) = piccoloFlutes+            partFromName ("Flute",_) = flutes+            partFromName ("Flutes (a)",_) = (!! 0) $ divide 4 $ flutes+            partFromName ("Flutes (b)",_) = (!! 1) $ divide 4 $ flutes+            partFromName ("Flutes (c)",_) = (!! 2) $ divide 4 $ flutes+            partFromName ("Flutes (d)",_) = (!! 3) $ divide 4 $ flutes+            partFromName ("Oboe",_) = oboes+            partFromName ("Oboes (a)",_) = (!! 0) $ divide 4 $ oboes+            partFromName ("Oboes (b)",_) = (!! 1) $ divide 4 $ oboes+            partFromName ("Oboes (c)",_) = (!! 2) $ divide 4 $ oboes+            partFromName ("Oboes (d)",_) = (!! 3) $ divide 4 $ oboes+            partFromName ("Cor Anglais",_) = tutti corAnglais+            partFromName ("Clarinet",_) = clarinets+            partFromName ("Clarinet in Bb",_) = clarinets+            partFromName ("Clarinet in A",_) = clarinets+            partFromName ("Clarinets",_) = clarinets+            partFromName ("Clarinets in Bb",_) = clarinets+            partFromName ("Clarinets in Bb (a)",_) = (!! 0) $ divide 3 clarinets+            partFromName ("Clarinets in Bb (b)",_) = (!! 1) $ divide 3 clarinets+            partFromName ("Clarinets in Bb (c)",_) = (!! 2) $ divide 3 clarinets+            partFromName ("Clarinets in A",_) = clarinets+            partFromName ("Bassoon",_) = bassoons+            partFromName ("Bassoon (a)",_) = (!! 0) $ divide 4 bassoons+            partFromName ("Bassoon (b)",_) = (!! 1) $ divide 4 bassoons+            partFromName ("Bassoon (c)",_) = (!! 2) $ divide 4 bassoons+            partFromName ("Bassoon (d)",_) = (!! 3) $ divide 4 bassoons+            partFromName ("Horn",_) = horns+            partFromName ("Horn (a)",_) = (!! 0) $ divide 4 $ horns+            partFromName ("Horn (b)",_) = (!! 1) $ divide 4 $ horns+            partFromName ("Horn (c)",_) = (!! 2) $ divide 4 $ horns+            partFromName ("Horn (d)",_) = (!! 3) $ divide 4 $ horns++            partFromName ("Horns",_) = horns+            partFromName ("Horns (a)",_) = (!! 0) $ divide 4 $ horns+            partFromName ("Horns (b)",_) = (!! 1) $ divide 4 $ horns+            partFromName ("Horns (c)",_) = (!! 2) $ divide 4 $ horns+            partFromName ("Horns (d)",_) = (!! 3) $ divide 4 $ horns++            partFromName ("Horns in F",_) = horns+            partFromName ("Horns in F (a)",_) = (!! 0) $ divide 4 $ horns+            partFromName ("Horns in F (b)",_) = (!! 1) $ divide 4 $ horns+            partFromName ("Horns in F (c)",_) = (!! 2) $ divide 4 $ horns+            partFromName ("Horns in F (d)",_) = (!! 3) $ divide 4 $ horns+            partFromName ("Horn in F",_) = horns+            partFromName ("Horn in E",_) = horns+            partFromName ("Trumpet (a)",_) = (!! 0) $ divide 4 $ trumpets+            partFromName ("Trumpet (b)",_) = (!! 1) $ divide 4 $ trumpets+            partFromName ("Trumpet (c)",_) = (!! 2) $ divide 4 $ trumpets+            partFromName ("Trumpet (d)",_) = (!! 3) $ divide 4 $ trumpets+            partFromName ('T':'r':'u':'m':'p':'e':'t':_,_) = trumpets+            partFromName ("Trombone",_) = trombones+            partFromName ("Trombones",_) = trombones+            partFromName ("Timpani",_) = tutti timpani++            partFromName ("Harp",_)     = harp+            partFromName ("Harp (a)",_) = (!! 0) $ divide 2 harp+            partFromName ("Harp (b)",_) = (!! 1) $ divide 2 harp++            partFromName ("Strings (a)",_) = (!! 0) $ divide 8 violins+            partFromName ("Strings (b)",_) = (!! 0) $ divide 8 cellos+            partFromName ("Strings (c)",_) = (!! 1) $ divide 8 violins+            partFromName ("Strings (d)",_) = (!! 1) $ divide 8 cellos+            partFromName ("Strings (e)",_) = (!! 2) $ divide 8 violins+            partFromName ("Strings (f)",_) = (!! 2) $ divide 8 cellos+            partFromName ("Strings (g)",_) = (!! 3) $ divide 8 violins+            partFromName ("Strings (h)",_) = (!! 3) $ divide 8 cellos+            partFromName ("Strings (i)",_) = (!! 4) $ divide 8 violins+            partFromName ("Strings (j)",_) = (!! 4) $ divide 8 cellos+            partFromName ("Strings (k)",_) = (!! 5) $ divide 8 violins+            partFromName ("Strings (l)",_) = (!! 5) $ divide 8 cellos+            partFromName ("Strings (m)",_) = (!! 6) $ divide 8 violins+            partFromName ("Strings (n)",_) = (!! 6) $ divide 8 cellos+            partFromName ("Strings (o)",_) = (!! 7) $ divide 8 violins+            partFromName ("Strings (p)",_) = (!! 7) $ divide 8 cellos+            -- partFromName ("Strings (q)",_) = (!! 0) $ divide 2 violins+            +            partFromName ("Violin I",_) = violins1+            partFromName ("Violin II",_) = violins2+            partFromName ("Viola",_) = violas+            partFromName ("Violin",_) = violins+            partFromName ("Violoncello",_) = cellos+            partFromName ("Violoncello (a)",_) = (!! 0) $ divide 2 cellos+            partFromName ("Violoncello (b)",_) = (!! 1) $ divide 2 cellos+            partFromName ("Contrabass",_) = doubleBasses+            partFromName ("Double Bass",_) = doubleBasses+            partFromName ("Piano",_)       = tutti piano+            partFromName ("Piano (a)",_)       = tutti piano+            partFromName ("Piano (b)",_)       = tutti piano++            partFromName ("Soprano",_) = violins1+            partFromName ("Mezzo-Soprano",_) = violins2+            partFromName ("Mezzo-soprano",_) = violins2+            partFromName ("Alto",_) = violas+            partFromName ("Tenor",_) = (!! 0) $ divide 2 cellos+            partFromName ("Baritone",_) = (!! 1) $ divide 2 cellos+            partFromName ("Bass",_) = doubleBasses++            partFromName (n,_) = error $ "Unknown instrument: " ++ n+-- TODO move to Score.Meta.TimeSignature++barDuration :: TimeSignature -> Duration+barDuration (getTimeSignature -> (as,b)) =  realToFrac (sum as) / realToFrac b++fromSibeliusStaff :: IsSibelius a => Duration -> SibeliusStaff -> Score a+fromSibeliusStaff d (SibeliusStaff bars name shortName) =+    removeRests $ scat $ fmap (fromSibeliusBar d) bars+    -- TODO meta information+    -- NOTE slur pos/dur always "stick" to an adjacent note, regardless of visual position+    --      for other lines (cresc etc) this might not be the case+    -- WARNING key sig changes goes at end of previous bar++fromSibeliusBar :: IsSibelius a => Duration -> SibeliusBar -> Score (Maybe a)+fromSibeliusBar d (SibeliusBar elems) = +    fmap Just (pcat $ fmap fromSibeliusChordElem chords) <> stretch d rest+    where+        chords   = filter isChord elems+        tuplets  = filter isTuplet elems -- TODO use these+        floating = filter isFloating elems++fromSibeliusChordElem :: IsSibelius a => SibeliusBarObject -> Score a+fromSibeliusChordElem = go where+    go (SibeliusBarObjectChord chord) = fromSibeliusChord chord+    go _                         = error "fromSibeliusChordElem: Expected chord"++-- handleFloatingElem :: IsSibelius a => SibeliusBarObject -> [Score a] -> [Score a]++++-- In Sibelius, bar objects are either chords, tuplet or a "floating" object (i.e. one that has no duraion)+isChord :: SibeliusBarObject -> Bool+isChord (SibeliusBarObjectChord _) = True+isChord _                     = False++isTuplet :: SibeliusBarObject -> Bool+isTuplet (SibeliusBarObjectTuplet _) = True+isTuplet _                      = False++isFloating :: SibeliusBarObject -> Bool+isFloating x = not (isChord x) && not (isTuplet x) ++    ++fromSibeliusChord :: (+  IsSibelius a+  ) => SibeliusChord -> Score a+fromSibeliusChord (SibeliusChord pos dur voice ar strem dtrem acci appo notes) = +    showVals $ setTime $ setDur $ every setArt ar $ tremolo strem $ pcat $ fmap fromSibeliusNote notes+    where     +        -- showVals = text (show pos ++ " " ++ show dur) -- TODO DEBUG+        showVals = id+        -- WARNING for tuplets, positions are absolute (sounding), but durations are relative (written)+        -- To retrieve sounding duration we must find floating tuplet objects and use+        -- the duration/playedDuration fields+        setTime = delay (fromIntegral pos / kTicksPerWholeNote)+        setDur  = stretch (fromIntegral dur / kTicksPerWholeNote)+        setArt Marcato         = marcato+        setArt Accent          = accent+        setArt Tenuto          = tenuto+        setArt Staccato        = staccato+        setArt a               = error $ "fromSibeliusChord: Unsupported articulation" ++ show a        +    -- TODO tremolo and appogiatura/acciaccatura support+++fromSibeliusNote :: (IsSibelius a, Tiable a) => SibeliusNote -> Score a+fromSibeliusNote (SibeliusNote pitch diatonicPitch acc tied style) =+    (if tied then fmap beginTie else id)+    $ fromPitch'' actualPitch+    -- TODO spell correctly if this is Common.Pitch (how to distinguish)+    where+      actualPitch = midiOrigin .+^ (d2^*fromIntegral diatonicPitch ^+^ _A1^*fromIntegral pitch)+      midiOrigin = octavesDown 5 Pitch.c -- As middle C is (60 = 5*12)+      +fromPitch'' :: IsPitch a => Music.Prelude.Pitch -> a+fromPitch'' x = let i = x .-. c in +  fromPitch $ PitchL ((fromIntegral $ i^._steps) `mod` 7, Just (fromIntegral (i^._alteration)), fromIntegral $ octaves i)++-- |+-- This constraint includes all note types that can be constructed from a Sibelius representation.+--+type IsSibelius a = (+    HasPitches' a, +    IsPitch a, ++    HasPart' a, +    S.Part a ~ Part,++    HasArticulation' a,+    S.Articulation a ~ Articulation,++    HasDynamic' a,+    S.Dynamic a ~ Dynamics,+    +    HasText a, +    HasTremolo a,+    Tiable a+    -- Num (Pitch a), +    -- HasTremolo a, +    -- HasText a,+    -- Tiable a+    )+++-- Util++every :: (a -> b -> b) -> [a] -> b -> b+every f = flip (foldr f)++kTicksPerWholeNote = 1024 -- Always in Sibelius++-- Debug+#ifdef GHCI+openAudacity :: Score StandardNote -> IO ()    +openAudacity x = do+    void $ writeMidi "test.mid" $ x+    void $ System.Process.system "timidity -Ow test.mid"+    void $ System.Process.system "open -a Audacity test.wav"+#endif

@@ -1,313 +0,0 @@--{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, NoMonomorphismRestriction, -             ConstraintKinds, FlexibleContexts #-}--module Music.Sibelius (--        -- -- * Scores and staves-        -- SibeliusScore(..),-        -- SibeliusStaff(..),-        -- SibeliusBar(..),-        -- -        -- -- * Bar objects-        -- SibeliusBarObject(..),-        -- -        -- -- ** Notes-        -- SibeliusChord(..),-        -- SibeliusNote(..),-        -- -        -- -- ** Lines-        -- SibeliusSlur(..),-        -- SibeliusCrescendoLine(..),-        -- SibeliusDiminuendoLine(..),-        -- -        -- -- ** Tuplets-        -- SibeliusTuplet(..),-        -- SibeliusArticulation(..),-        -- readSibeliusArticulation,-        -- -        -- -- ** Miscellaneous-        -- SibeliusClef(..),-        -- SibeliusKeySignature(..),-        -- SibeliusTimeSignature(..),-        -- SibeliusText(..),--  ) where---- import Control.Monad.Plus--- import Control.Applicative--- import Data.Semigroup--- import Data.Aeson--- --- import qualified Data.HashMap.Strict as HashMap--- --- --- {---- setTitle :: String -> Score a -> Score a--- setTitle = setMeta "title"--- setComposer :: String -> Score a -> Score a--- setComposer = setMeta "composer"--- setInformation :: String -> Score a -> Score a--- setInformation = setMeta "information"--- setMeta :: String -> String -> Score a -> Score a--- setMeta _ _ = id--- -}--- --- --- data SibeliusScore = SibeliusScore {---             scoreTitle             :: String,---             scoreComposer          :: String,---             scoreInformation       :: String,---             scoreStaffHeight       :: Double,---             scoreTransposing       :: Bool,---             scoreStaves            :: [SibeliusStaff],---             scoreSystemStaff       :: ()---     }---     deriving (Eq, Ord, Show)--- instance FromJSON SibeliusScore where---     parseJSON (Object v) = SibeliusScore---         <$> v .: "title" ---         <*> v .: "composer"---         <*> v .: "information"---         <*> v .: "staffHeight"---         <*> v .: "transposing"---         <*> v .: "staves"          ---         -- TODO system staff---         <*> return ()--- --- --- data SibeliusStaff = SibeliusStaff {---             staffBars                :: [SibeliusBar],---             staffName                :: String,---             staffShortName           :: String---     }---     deriving (Eq, Ord, Show)--- instance FromJSON SibeliusStaff where---     parseJSON (Object v) = SibeliusStaff---         <$> v .: "bars"---         <*> v .: "name"---         <*> v .: "shortName"--- --- data SibeliusBar = SibeliusBar {---             barElements            :: [SibeliusBarObject]---     }---     deriving (Eq, Ord, Show)--- instance FromJSON SibeliusBar where---     parseJSON (Object v) = SibeliusBar---         <$> v .: "elements"--- --- data SibeliusBarObject ---     = SibeliusBarObjectText SibeliusText---     | SibeliusBarObjectClef SibeliusClef---     | SibeliusBarObjectSlur SibeliusSlur---     | SibeliusBarObjectCrescendoLine SibeliusCrescendoLine---     | SibeliusBarObjectDiminuendoLine SibeliusDiminuendoLine---     | SibeliusBarObjectTimeSignature SibeliusTimeSignature---     | SibeliusBarObjectKeySignature SibeliusKeySignature---     | SibeliusBarObjectTuplet SibeliusTuplet---     | SibeliusBarObjectChord SibeliusChord---     deriving (Eq, Ord, Show)--- -- TODO highlights, lyric, barlines, comment, other lines and symbols--- --- instance FromJSON SibeliusBarObject where---     parseJSON x@(Object v) = case HashMap.lookup "type" v of    ---         -- TODO---         Just "text"      -> SibeliusBarObjectText <$> parseJSON x---         Just "clef"      -> SibeliusBarObjectClef <$> parseJSON x---         Just "slur"      -> SibeliusBarObjectSlur <$> parseJSON x---         Just "cresc"     -> SibeliusBarObjectCrescendoLine <$> parseJSON x---         Just "dim"       -> SibeliusBarObjectDiminuendoLine <$> parseJSON x---         Just "time"      -> SibeliusBarObjectTimeSignature <$> parseJSON x---         Just "key"       -> SibeliusBarObjectKeySignature <$> parseJSON x---         Just "tuplet"    -> SibeliusBarObjectTuplet <$> parseJSON x---         Just "chord"     -> SibeliusBarObjectChord <$> parseJSON x---         _                -> mempty -- failure--- --- data SibeliusText = SibeliusText {---             textVoice               :: Int,---             textPosition            :: Int,---             textText                :: String,---             textStyle               :: String---     }---     deriving (Eq, Ord, Show)--- instance FromJSON SibeliusText where---     parseJSON (Object v) = SibeliusText---         <$> v .: "voice" ---         <*> v .: "position"---         <*> v .: "text"---         <*> v .: "style"---      --- data SibeliusClef = SibeliusClef {---             clefVoice               :: Int,---             clefPosition            :: Int,---             clefStyle               :: String---     }---     deriving (Eq, Ord, Show)--- instance FromJSON SibeliusClef where---     parseJSON (Object v) = SibeliusClef---         <$> v .: "voice" ---         <*> v .: "position"---         <*> v .: "style"--- --- data SibeliusSlur = SibeliusSlur {---             slurVoice               :: Int,---             slurPosition            :: Int,---             slurDuration            :: Int,---             slurStyle               :: String---     }---     deriving (Eq, Ord, Show)--- instance FromJSON SibeliusSlur where---     parseJSON (Object v) = SibeliusSlur---         <$> v .: "voice" ---         <*> v .: "position"---         <*> v .: "duration"---         <*> v .: "style"--- --- data SibeliusCrescendoLine = SibeliusCrescendoLine {  ---             crescVoice               :: Int,---             crescPosition            :: Int,---             crescDuration            :: Int,---             crescStyle               :: String---     }---     deriving (Eq, Ord, Show)--- instance FromJSON SibeliusCrescendoLine where---     parseJSON (Object v) = SibeliusCrescendoLine---         <$> v .: "voice" ---         <*> v .: "position"---         <*> v .: "duration"---         <*> v .: "style"--- --- data SibeliusDiminuendoLine = SibeliusDiminuendoLine {---             dimVoice               :: Int,---             dimPosition            :: Int,---             dimDuration            :: Int,---             dimStyle               :: String---     }---     deriving (Eq, Ord, Show)--- instance FromJSON SibeliusDiminuendoLine where---     parseJSON (Object v) = SibeliusDiminuendoLine---         <$> v .: "voice" ---         <*> v .: "position"---         <*> v .: "duration"---         <*> v .: "style"--- --- data SibeliusTimeSignature = SibeliusTimeSignature {---             timeVoice               :: Int,---             timePosition            :: Int,---             timeValue               :: Rational,---             timeIsCommon            :: Bool,---             timeIsAllaBreve         :: Bool---     }---     deriving (Eq, Ord, Show)--- instance FromJSON SibeliusTimeSignature where---     parseJSON (Object v) = SibeliusTimeSignature---         <$> v .: "voice" ---         <*> v .: "position"---         <*> fmap (\[x,y] -> (x::Rational) / (y::Rational)) (v .: "value")---         <*> v .: "common"---         <*> v .: "allaBreve"--- --- data SibeliusKeySignature = SibeliusKeySignature {---             keyVoice               :: Int,---             keyPosition            :: Int,---             keyMajor               :: Bool,---             keySharps              :: Int,---             keyIsOpen              :: Bool---     }---     deriving (Eq, Ord, Show)--- instance FromJSON SibeliusKeySignature where---     parseJSON (Object v) = SibeliusKeySignature---         <$> v .: "voice" ---         <*> v .: "position"---         <*> v .: "major"---         <*> v .: "sharps"---         <*> v .: "isOpen"--- --- data SibeliusTuplet = SibeliusTuplet {---             tupletVoice               :: Int,---             tupletPosition            :: Int,---             tupletDuration            :: Int,---             tupletPlayedDuration      :: Int,---             tupletValue               :: Rational---     }---     deriving (Eq, Ord, Show)--- instance FromJSON SibeliusTuplet where---     parseJSON (Object v) = SibeliusTuplet ---         <$> v .: "voice" ---         <*> v .: "position"---         <*> v .: "duration"---         <*> v .: "playedDuration"---         <*> (v .: "value" >>= \[x,y] -> return $ x / y) -- TODO unsafe--- --- data SibeliusArticulation---     = UpBow---     | DownBow---     | Plus---     | Harmonic---     | Marcato---     | Accent---     | Tenuto---     | Wedge---     | Staccatissimo---     | Staccato---     deriving (Eq, Ord, Show, Enum)--- --- readSibeliusArticulation :: String -> Maybe SibeliusArticulation--- readSibeliusArticulation = go---     where---         go "upbow"          = Just UpBow---         go "downBow"        = Just DownBow---         go "plus"           = Just Plus---         go "harmonic"       = Just Harmonic---         go "marcato"        = Just Marcato---         go "accent"         = Just Accent---         go "tenuto"         = Just Tenuto---         go "wedge"          = Just Wedge---         go "staccatissimo"  = Just Staccatissimo---         go "staccato"       = Just Staccato---         go _                = Nothing---     --- data SibeliusChord = SibeliusChord { ---             chordPosition            :: Int,---             chordDuration            :: Int,---             chordVoice               :: Int,---             chordArticulations       :: [SibeliusArticulation], -- TODO---             chordSingleTremolos      :: Int,---             chordDoubleTremolos      :: Int,---             chordAcciaccatura        :: Bool,---             chordAppoggiatura        :: Bool,---             chordNotes               :: [SibeliusNote]---     }---     deriving (Eq, Ord, Show)--- --- instance FromJSON SibeliusChord where---     parseJSON (Object v) = SibeliusChord ---         <$> v .: "position" ---         <*> v .: "duration"---         <*> v .: "voice"---         <*> fmap (mmapMaybe readSibeliusArticulation) (v .: "articulations")---         <*> v .: "singleTremolos"---         <*> v .: "doubleTremolos"---         <*> v .: "acciaccatura"---         <*> v .: "appoggiatura"---         <*> v .: "notes"--- --- data SibeliusNote = SibeliusNote {---             notePitch               :: Int,---             noteDiatonicPitch       :: Int,---             noteAccidental          :: Int,---             noteTied                :: Bool,---             noteStyle               :: Int -- not String?---     }---     deriving (Eq, Ord, Show)--- instance FromJSON SibeliusNote where---     parseJSON (Object v) = SibeliusNote ---         <$> v .: "pitch" ---         <*> v .: "diatonicPitch"---         <*> v .: "accidental"---         <*> v .: "tied"---         <*> v .: "style"--- --- --- ---