diff --git a/COPYING b/COPYING --- a/COPYING +++ b/COPYING @@ -9,14 +9,14 @@ * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of the nor the + * Neither the name of the Music Suite nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND diff --git a/music-sibelius.cabal b/music-sibelius.cabal --- a/music-sibelius.cabal +++ b/music-sibelius.cabal @@ -1,6 +1,6 @@ name: music-sibelius -version: 1.3.1 +version: 1.6 cabal-version: >= 1.10 author: Hans Hoglund maintainer: Hans Hoglund @@ -12,21 +12,24 @@ build-type: Simple description: - Import music from Sibelius. + Import music from Sibelius (experimental). - This library is part of the Music Suite, see . + This library is part of the Music Suite, see . source-repository head type: git - location: git://github.com/hanshoglund/music-sibelius.git + location: git://github.com/music-suite/music-sibelius.git library build-depends: - base >= 4 && < 5, + base >= 4 && < 5, + semigroups, + monadplus, unordered-containers, bytestring, - music-score, - music-preludes, + music-score == 1.6, + music-pitch-literal == 1.6, + music-preludes == 1.6, aeson hs-source-dirs: src default-language: Haskell2010 diff --git a/src/Music/Score/Import/Sibelius.hs b/src/Music/Score/Import/Sibelius.hs --- a/src/Music/Score/Import/Sibelius.hs +++ b/src/Music/Score/Import/Sibelius.hs @@ -1,10 +1,134 @@ +{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, NoMonomorphismRestriction, + ConstraintKinds, FlexibleContexts #-} + module Music.Score.Import.Sibelius ( IsSibelius(..), - fromSib, - readSib, - readSibMaybe, - readSibEither + 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 + ) + + +-- Util + +every :: (a -> b -> b) -> [a] -> b -> b +every f = flip (foldr f) + +kTicksPerWholeNote = 1024 -- Always in Sibelius + diff --git a/src/Music/Sibelius.hs b/src/Music/Sibelius.hs --- a/src/Music/Sibelius.hs +++ b/src/Music/Sibelius.hs @@ -2,18 +2,47 @@ {-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving, NoMonomorphismRestriction, ConstraintKinds, FlexibleContexts #-} -module Music.Sibelius where +module Music.Sibelius ( -import Data.Aeson + -- * 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.Aeson.Types(parse, Parser) -import Music.Prelude.StringQuartet -import qualified Music.Score as Score +import Data.Semigroup +import Data.Aeson -import Data.ByteString.Lazy(ByteString) -import qualified Data.ByteString.Lazy as B import qualified Data.HashMap.Strict as HashMap + +{- setTitle :: String -> Score a -> Score a setTitle = setMeta "title" setComposer :: String -> Score a -> Score a @@ -22,128 +51,147 @@ setInformation = setMeta "information" setMeta :: String -> String -> Score a -> Score a setMeta _ _ = id - - - +-} -data SibScore = SibScore { +data SibeliusScore = SibeliusScore { scoreTitle :: String, scoreComposer :: String, scoreInformation :: String, scoreStaffHeight :: Double, scoreTransposing :: Bool, - scoreStaves :: [SibStaff], + scoreStaves :: [SibeliusStaff], scoreSystemStaff :: () } deriving (Eq, Ord, Show) -instance FromJSON SibScore where - parseJSON (Object v) = SibScore +instance FromJSON SibeliusScore where + parseJSON (Object v) = SibeliusScore <$> v .: "title" <*> v .: "composer" <*> v .: "information" <*> v .: "staffHeight" <*> v .: "transposing" <*> v .: "staves" - -- TODO + -- TODO system staff <*> return () -data SibStaff = SibStaff { - staffBars :: [SibBar], +data SibeliusStaff = SibeliusStaff { + staffBars :: [SibeliusBar], staffName :: String, staffShortName :: String } deriving (Eq, Ord, Show) -instance FromJSON SibStaff where - parseJSON (Object v) = SibStaff +instance FromJSON SibeliusStaff where + parseJSON (Object v) = SibeliusStaff <$> v .: "bars" <*> v .: "name" <*> v .: "shortName" -data SibBar = SibBar { - barElements :: [SibElement] +data SibeliusBar = SibeliusBar { + barElements :: [SibeliusBarObject] } deriving (Eq, Ord, Show) -instance FromJSON SibBar where - parseJSON (Object v) = SibBar +instance FromJSON SibeliusBar where + parseJSON (Object v) = SibeliusBar <$> v .: "elements" -data SibElement - = SibElementText SibText - | SibElementClef SibClef - | SibElementSlur SibSlur - | SibElementCrescendoLine SibCrescendoLine - | SibElementDiminuendoLine SibDiminuendoLine - | SibElementTimeSignature SibTimeSignature - | SibElementKeySignature SibKeySignature - | SibElementTuplet SibTuplet - | SibElementChord SibChord +data SibeliusBarObject + = SibeliusBarObjectText SibeliusText + | SibeliusBarObjectClef SibeliusClef + | SibeliusBarObjectSlur SibeliusSlur + | SibeliusBarObjectCrescendoLine SibeliusCrescendoLine + | SibeliusBarObjectDiminuendoLine SibeliusDiminuendoLine + | SibeliusBarObjectTimeSignature SibeliusTimeSignature + | SibeliusBarObjectKeySignature SibeliusKeySignature + | SibeliusBarObjectTuplet SibeliusTuplet + | SibeliusBarObjectChord SibeliusChord deriving (Eq, Ord, Show) -instance FromJSON SibElement where +-- 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" -> error "JsElementText" - Just "clef" -> error "SibElementClef" - Just "slur" -> error "SibElementSlur" - Just "cresc" -> error "SibElementCrescendoLine" - Just "dim" -> error "SibElementDiminuendoLine" - Just "time" -> error "SibElementTimeSignature" - Just "key" -> error "SibElementKeySignature" - Just "tuplet" -> error "SibElementTuplet" - Just "chord" -> SibElementChord <$> parseJSON x - _ -> mempty + 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 SibText = SibText { +data SibeliusText = SibeliusText { textVoice :: Int, textPosition :: Int, textText :: String, - textStyle :: Int + textStyle :: String } deriving (Eq, Ord, Show) -instance FromJSON SibText where - parseJSON = error "Not implemented (instance FromJSON SibText)" +instance FromJSON SibeliusText where + parseJSON (Object v) = SibeliusText + <$> v .: "voice" + <*> v .: "position" + <*> v .: "text" + <*> v .: "style" -data SibClef = SibClef { +data SibeliusClef = SibeliusClef { clefVoice :: Int, clefPosition :: Int, - clefStyle :: Int + clefStyle :: String } deriving (Eq, Ord, Show) -instance FromJSON SibClef where - parseJSON = error "Not implemented (instance FromJSON SibClef)" +instance FromJSON SibeliusClef where + parseJSON (Object v) = SibeliusClef + <$> v .: "voice" + <*> v .: "position" + <*> v .: "style" -data SibSlur = SibSlur { +data SibeliusSlur = SibeliusSlur { slurVoice :: Int, slurPosition :: Int, slurDuration :: Int, - slurStyle :: Int + slurStyle :: String } deriving (Eq, Ord, Show) -instance FromJSON SibSlur where - parseJSON = error "Not implemented (instance FromJSON SibSlur)" +instance FromJSON SibeliusSlur where + parseJSON (Object v) = SibeliusSlur + <$> v .: "voice" + <*> v .: "position" + <*> v .: "duration" + <*> v .: "style" -data SibCrescendoLine = SibCrescendoLine { +data SibeliusCrescendoLine = SibeliusCrescendoLine { crescVoice :: Int, crescPosition :: Int, crescDuration :: Int, - crescStyle :: Int + crescStyle :: String } deriving (Eq, Ord, Show) -instance FromJSON SibCrescendoLine where - parseJSON = error "Not implemented (instance FromJSON SibCrescendoLine)" +instance FromJSON SibeliusCrescendoLine where + parseJSON (Object v) = SibeliusCrescendoLine + <$> v .: "voice" + <*> v .: "position" + <*> v .: "duration" + <*> v .: "style" -data SibDiminuendoLine = SibDiminuendoLine { +data SibeliusDiminuendoLine = SibeliusDiminuendoLine { dimVoice :: Int, dimPosition :: Int, dimDuration :: Int, - dimStyle :: Int + dimStyle :: String } deriving (Eq, Ord, Show) -instance FromJSON SibDiminuendoLine where - parseJSON = error "Not implemented (instance FromJSON SibDiminuendoLine)" +instance FromJSON SibeliusDiminuendoLine where + parseJSON (Object v) = SibeliusDiminuendoLine + <$> v .: "voice" + <*> v .: "position" + <*> v .: "duration" + <*> v .: "style" -data SibTimeSignature = SibTimeSignature { +data SibeliusTimeSignature = SibeliusTimeSignature { timeVoice :: Int, timePosition :: Int, timeValue :: Rational, @@ -151,10 +199,15 @@ timeIsAllaBreve :: Bool } deriving (Eq, Ord, Show) -instance FromJSON SibTimeSignature where - parseJSON = error "Not implemented (instance FromJSON SibTimeSignature)" +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 SibKeySignature = SibKeySignature { +data SibeliusKeySignature = SibeliusKeySignature { keyVoice :: Int, keyPosition :: Int, keyMajor :: Bool, @@ -162,10 +215,15 @@ keyIsOpen :: Bool } deriving (Eq, Ord, Show) -instance FromJSON SibKeySignature where - parseJSON = error "Not implemented (instance FromJSON SibKeySignature)" +instance FromJSON SibeliusKeySignature where + parseJSON (Object v) = SibeliusKeySignature + <$> v .: "voice" + <*> v .: "position" + <*> v .: "major" + <*> v .: "sharps" + <*> v .: "isOpen" -data SibTuplet = SibTuplet { +data SibeliusTuplet = SibeliusTuplet { tupletVoice :: Int, tupletPosition :: Int, tupletDuration :: Int, @@ -173,15 +231,15 @@ tupletValue :: Rational } deriving (Eq, Ord, Show) -instance FromJSON SibTuplet where - parseJSON (Object v) = SibTuplet +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 SibArticulation +data SibeliusArticulation = UpBow | DownBow | Plus @@ -194,8 +252,8 @@ | Staccato deriving (Eq, Ord, Show, Enum) -readSibArticulation :: String -> Maybe SibArticulation -readSibArticulation = go +readSibeliusArticulation :: String -> Maybe SibeliusArticulation +readSibeliusArticulation = go where go "upbow" = Just UpBow go "downBow" = Just DownBow @@ -209,44 +267,41 @@ go "staccato" = Just Staccato go _ = Nothing -data SibChord = SibChord { +data SibeliusChord = SibeliusChord { chordPosition :: Int, chordDuration :: Int, chordVoice :: Int, - chordArticulations :: [SibArticulation], -- TODO + chordArticulations :: [SibeliusArticulation], -- TODO chordSingleTremolos :: Int, chordDoubleTremolos :: Int, chordAcciaccatura :: Bool, chordAppoggiatura :: Bool, - chordNotes :: [SibNote] + chordNotes :: [SibeliusNote] } deriving (Eq, Ord, Show) -instance FromJSON SibChord where - parseJSON (Object v) = SibChord +instance FromJSON SibeliusChord where + parseJSON (Object v) = SibeliusChord <$> v .: "position" <*> v .: "duration" <*> v .: "voice" - <*> doThing (v .: "articulations") + <*> fmap (mmapMaybe readSibeliusArticulation) (v .: "articulations") <*> v .: "singleTremolos" <*> v .: "doubleTremolos" <*> v .: "acciaccatura" <*> v .: "appoggiatura" <*> v .: "notes" -doThing = (=<<) (sequence . fmap (returnMaybe readSibArticulation)) - - -data SibNote = SibNote { +data SibeliusNote = SibeliusNote { notePitch :: Int, noteDiatonicPitch :: Int, noteAccidental :: Int, noteTied :: Bool, - noteStyle :: Int + noteStyle :: Int -- not String? } deriving (Eq, Ord, Show) -instance FromJSON SibNote where - parseJSON (Object v) = SibNote +instance FromJSON SibeliusNote where + parseJSON (Object v) = SibeliusNote <$> v .: "pitch" <*> v .: "diatonicPitch" <*> v .: "accidental" @@ -255,91 +310,4 @@ -fromSib :: IsSibelius a => SibScore -> Score a -fromSib (SibScore title composer info staffH transp staves systemStaff) = - foldr () mempty $ fmap fromSibStaff staves - -- TODO meta information - -fromSibStaff :: IsSibelius a => SibStaff -> Score a -fromSibStaff (SibStaff bars name shortName) = - removeRests $ scat $ fmap fromSibBar bars - -- TODO bar length hardcoded - -- TODO meta information - -fromSibBar :: IsSibelius a => SibBar -> Score (Maybe a) -fromSibBar (SibBar elems) = - fmap Just (pcat $ fmap fromSibElem elems) <> return Nothing^*1 - -fromSibElem :: IsSibelius a => SibElement -> Score a -fromSibElem = go where - go (SibElementChord chord) = fromSibChord chord - -- TODO tuplet, key/time signature, line and text support - -fromSibChord :: IsSibelius a => SibChord -> Score a -fromSibChord (SibChord pos dur voice ar strem dtrem acci appo notes) = - setTime $ setDur $ every setArt ar $ tremolo strem $ pcat $ fmap fromSibNote notes - where - setTime = delay (fromIntegral pos / 1024) - setDur = stretch (fromIntegral dur / 1024) - setArt Marcato = marcato - setArt Accent = accent - setArt Tenuto = tenuto - setArt Staccato = staccato - setArt a = error $ "fromSibChord: Unsupported articulation" ++ show a - -- TODO tremolo and appogiatura/acciaccatura support - -fromSibNote :: IsSibelius a => SibNote -> Score a -fromSibNote (SibNote pitch di acc tied style) = - (if tied then fmap beginTie else id) - $ modifyPitches (+ (fromIntegral pitch - 60)) def - where - def = c - -readSib :: IsSibelius a => FilePath -> IO (Score a) -readSib path = fmap (either (\x -> error $ "Could not read score" ++ x) id) $ readSibEither path - -readSibMaybe :: IsSibelius a => FilePath -> IO (Maybe (Score a)) -readSibMaybe path = fmap (either (const Nothing) Just) $ readSibEither path - -readSibEither :: IsSibelius a => FilePath -> IO (Either String (Score a)) -readSibEither path = do - json <- B.readFile path - return $ fmap fromSib $ eitherDecode' json - -type IsSibelius a = ( - IsPitch a, - HasPart' a, - Enum (Part a), - HasPitch a, - Num (Score.Pitch a), - HasTremolo a, - HasArticulation a, - Tiable a - ) - -main = do - result <- readSibEither "test.json" - case result of - Left e -> putStrLn $ "Error: " ++ e - Right x -> do - writeMidi "test.mid" $ asScore $ f x - openXml $ f x - -- openLy $ f x - - -- let score = fromSib $ fromJust $ decode' json - -- openLy score - - where - f = id - -- f = retrograde - -- f x = stretch (1/4) $ times 2 x |> times 2 (stretch 2 x) - -fromJust (Just x) = x - -returnMaybe :: MonadPlus m => (a -> Maybe b) -> a -> m b -returnMaybe f = mmapMaybe f . return - -every :: (a -> b -> b) -> [a] -> b -> b -every f x = foldr (.) id (fmap f x) -