diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -0,0 +1,26 @@ + +Copyright (c) 2013, Hans Höglund +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * 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 + 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 +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 +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/music-score.cabal b/music-score.cabal new file mode 100644 --- /dev/null +++ b/music-score.cabal @@ -0,0 +1,56 @@ + +name: music-score +version: 1.2 +cabal-version: >= 1.2 +author: Hans Hoglund +maintainer: Hans Hoglund +license: BSD3 +license-file: COPYING +synopsis: Musical score and part representation. +category: Music +tested-with: GHC +build-type: Simple + +description: + Musical score and part representation. + + This library is part of the Haskell Music Suite, see . + +library + build-depends: + base >= 4 && < 5, + unix, + time, + random, + containers, + parsec, + transformers, + HCodecs, + musicxml2, + semigroups, + semigroupoids, + vector-space, + music-pitch-literal, + music-dynamics-literal, + reenact + + hs-source-dirs: src + exposed-modules: + Music.Score + Music.Score.Time + Music.Score.Duration + Music.Score.Track + Music.Score.Part + Music.Score.Score + Music.Score.Rhythm + Music.Score.Combinators + Music.Score.Pitch + Music.Score.Voice + Music.Score.Ties + Music.Score.Articulation + Music.Score.Dynamics + Music.Score.Ornaments + +executable "music-score-tests" + hs-source-dirs: src test + main-is: Main.hs diff --git a/src/Music/Score.hs b/src/Music/Score.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score.hs @@ -0,0 +1,1204 @@ + +{-# LANGUAGE + CPP, + TypeFamilies, + DeriveFunctor, + DeriveFoldable, + GeneralizedNewtypeDeriving, + FlexibleInstances, + TypeOperators, + OverloadedStrings, + FlexibleContexts, -- for IsPitch stuff + NoMonomorphismRestriction #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +-- Provides a musical score represenation. +-- +------------------------------------------------------------------------------------- + +module Music.Score ( + + module Music.Score.Time, + module Music.Score.Duration, + + module Music.Score.Track, + module Music.Score.Part, + module Music.Score.Score, + + module Music.Score.Pitch, + module Music.Score.Voice, + module Music.Score.Ties, + + module Music.Score.Articulation, + module Music.Score.Dynamics, + module Music.Score.Ornaments, + + -- ** Constructors +#ifdef __HADDOCK__ + rest, + note, + chord, + melody, +#endif + + -- ** Composing + (|>), + (<|), + scat, + -- pcat, + -- sustain, + -- overlap, + -- anticipate, + + -- ** Transforming + move, + moveBack, + startAt, + stopAt, + stretch, + compress, + stretchTo, + + -- ** Conversions + scoreToTrack, + scoreToPart, + scoreToParts, + partToScore, + trackToScore, + + -- * Export + -- ** MIDI + HasMidi(..), + toMidi, + writeMidi, + playMidi, + playMidiIO, + + -- ** MusicXML + XmlScore, + XmlMusic, + HasMusicXml(..), + toXml, + writeXml, + openXml, + toXmlPart, + writeXmlPart, + openXmlPart, +) +where + +{- + TODO + Split and reverse + Zipper applicative (for appying dynamic and articulation transformations etc) +-} + +import Prelude hiding (foldr, concat, foldl, mapM, concatMap, maximum, sum, minimum) + +import Data.Semigroup +import Data.Ratio +import Data.String +import Control.Applicative +import Control.Monad (ap, mfilter, join, liftM, MonadPlus(..)) +import Data.Maybe +import Data.Either +import Data.Foldable +import Data.Traversable +import Data.Function (on) +import Data.Ord (comparing) +import Data.VectorSpace +import Data.AffineSpace +import Data.Basis + +import Control.Reactive +import Control.Reactive.Midi + +import Music.Score.Time +import Music.Score.Duration +import Music.Score.Rhythm +import Music.Score.Track +import Music.Score.Part +import Music.Score.Score +import Music.Score.Combinators +import Music.Score.Pitch +import Music.Score.Ties +import Music.Score.Voice +import Music.Score.Articulation +import Music.Score.Dynamics +import Music.Score.Ornaments + +import qualified Codec.Midi as Midi +import qualified Music.MusicXml.Simple as Xml +import qualified Data.Map as Map +import qualified Data.List as List + +import System.Posix +import System.IO.Unsafe +import Music.Pitch.Literal +import Music.Dynamics.Literal + + +------------------------------------------------------------------------------------- + +-- | +-- Class of types that can be converted to MIDI. +-- +-- Numeric types are interpreted as notes with a default velocity, pairs are +-- interpreted as @(pitch, velocity)@ pairs. +-- +-- Minimal definition: 'getMidi'. Given 'getMidiScore', 'getMidi' can be implemented +-- as @getMidiScore . return@. +-- +class HasMidi a where + + -- | Convert a value to a MIDI score. + -- Typically, generates an /on/ event using 'note' followed by an optional /off/ event. + getMidi :: a -> Score Midi.Message + + -- | Convert a score to a MIDI score. + -- The default definition can be overriden for efficiency. + getMidiScore :: Score a -> Score Midi.Message + getMidiScore = (>>= getMidi) + + +instance HasMidi Double where getMidi = getMidi . toInteger . round +instance HasMidi Float where getMidi = getMidi . toInteger . round +instance HasMidi Int where getMidi = getMidi . toInteger +instance Integral a => HasMidi (Ratio a) where getMidi = getMidi . toInteger . round +instance HasMidi Midi.Message where getMidi = return +instance HasMidi Integer where getMidi = \x -> getMidi (x,100::Integer) + +instance HasMidi (Integer, Integer) where + getMidi (p,v) = mempty + |> note (Midi.NoteOn 0 (fromIntegral p) (fromIntegral v)) + |> note (Midi.NoteOff 0 (fromIntegral p) (fromIntegral v)) + + +-- | +-- Convert a score to a MIDI file representaiton. +-- +toMidi :: HasMidi a => Score a -> Midi.Midi +toMidi score = Midi.Midi fileType divisions' [controlTrack, eventTrack] + where + endPos = 10000 + fileType = Midi.MultiTrack + divisions = 1024 + divisions' = Midi.TicksPerBeat divisions + controlTrack = [(0, Midi.TempoChange 1000000), (endPos, Midi.TrackEnd)] + eventTrack = events <> [(endPos, Midi.TrackEnd)] + + events :: [(Midi.Ticks, Midi.Message)] + events = (\(t,_,x) -> (round (t * divisions), x)) <$> performance + + performance :: [(Time, Duration, Midi.Message)] + performance = performRelative (getMidiScore score) + + -- FIXME arbitrary endTime (files won't work without this...) + -- TODO handle voice + +-- | +-- Convert a score MIDI and write to a file. +-- +writeMidi :: HasMidi a => FilePath -> Score a -> IO () +writeMidi path sc = Midi.exportFile path (toMidi sc) + +-- | +-- Convert a score to a MIDI event. +-- +playMidi :: HasMidi a => Score a -> Event MidiMessage +playMidi x = midiOut midiDest $ playback trig (pure $ toTrack $ rest^*0.2 |> x) + where + trig = accumR 0 ((+ 0.005) <$ pulse 0.005) + toTrack = fmap (\(t,_,m) -> (t,m)) . perform . getMidiScore + midiDest = fromJust $ unsafeGetReactive (findDestination $ pure "Graphic MIDI") + -- FIXME hardcoded output... + +-- | +-- Convert a score to a MIDI event and run it. +-- +playMidiIO :: HasMidi a => Score a -> IO () +playMidiIO = runLoop . playMidi + + + + +------------------------------------------------------------------------------------- + +type XmlScore = Xml.Score +type XmlMusic = Xml.Music + +-- | +-- Class of types that can be converted to MusicXML. +-- +class Tiable a => HasMusicXml a where + -- | + -- Convert a value to MusicXML. + -- + -- Typically, generates a 'XmlMusic' value using 'Xml.note' or 'Xml.chord', and transforms it + -- to add beams, slurs, dynamics, articulation etc. + -- + getMusicXml :: Duration -> a -> XmlMusic + +instance HasMusicXml Double where getMusicXml d = getMusicXml d . (toInteger . round) +instance HasMusicXml Float where getMusicXml d = getMusicXml d . (toInteger . round) +instance HasMusicXml Int where getMusicXml d = getMusicXml d . toInteger +instance Integral a => HasMusicXml (Ratio a) where getMusicXml d = getMusicXml d . (toInteger . round) + +-- FIXME arbitrary spelling, please modularize... +instance HasMusicXml Integer where + getMusicXml d p = Xml.note (spell (fromIntegral p)) d' + where + d' = (fromRational . toRational $ d) + + step xs p = xs !! (p `mod` length xs) + fromStep xs p = fromMaybe (length xs - 1) $ List.findIndex (>= p) xs + scaleFromSteps = snd . List.mapAccumL add 0 + where + add a x = (a + x, a + x) + major = scaleFromSteps [0,2,2,1,2,2,2,1] + + spell :: Int -> Xml.Pitch + spell p = (toEnum pitchClass, if (alteration == 0) then Nothing else Just (fromIntegral alteration), fromIntegral octave) + where + octave = (p `div` 12) - 1 + semitone = p `mod` 12 + pitchClass = fromStep major semitone + alteration = semitone - step major pitchClass + + +-- | +-- Convert a score to MusicXML and write to a file. +-- +writeXml :: (HasMusicXml a, HasVoice a, v ~ Voice a, Ord v, Show v) => FilePath -> Score a -> IO () +writeXml path sc = writeFile path (Xml.showXml $ toXml sc) + +-- | +-- Convert a score to MusicXML and open it. +-- +openXml :: (HasMusicXml a, HasVoice a, v ~ Voice a, Ord v, Show v) => Score a -> IO () +openXml sc = do + writeXml "test.xml" sc + execute "open" ["-a", "/Applications/Sibelius 6.app/Contents/MacOS/Sibelius 6", "test.xml"] + -- FIXME hardcode + +-- | +-- Convert a score to MusicXML and write to a file. +-- +writeXmlPart :: HasMusicXml a => FilePath -> Score a -> IO () +writeXmlPart path sc = writeFile path (Xml.showXml $ toXmlPart sc) + +-- | +-- Convert a score to MusicXML and open it. +-- +openXmlPart :: HasMusicXml a => Score a -> IO () +openXmlPart sc = do + writeXmlPart "test.xml" sc + execute "open" ["-a", "/Applications/Sibelius 6.app/Contents/MacOS/Sibelius 6", "test.xml"] + -- FIXME hardcode + + +-- | +-- Convert a score to a MusicXML representaiton. +-- +toXml :: (HasMusicXml a, HasVoice a, v ~ Voice a, Ord v, Show v) => Score a -> XmlScore +toXml sc = Xml.fromParts "Title" "Composer" pl . fmap toXmlPart' . voices $ sc + where + pl = Xml.partList (fmap show $ getVoices sc) + +-- | +-- Convert a single-part score to a MusicXML representaiton. +-- +toXmlPart :: HasMusicXml a => Score a -> XmlScore +toXmlPart = Xml.fromPart "Title" "Composer" "Part" . toXmlPart' + + +toXmlPart' :: HasMusicXml a => Score a -> [XmlMusic] +toXmlPart' = id + . prelims + . fmap barToXml + . separateBars + . splitTiesSingle + . addRests + . perform + where + prelims [] = [] + prelims (bar1 : rest) = (pre <> bar1) : rest + pre = mempty + <> Xml.defaultKey + <> Xml.defaultDivisions + <> Xml.metronome (1/4) 60 + <> Xml.commonTime + +-- | +-- Given a rest-free single-part score (such as those produced by perform), add explicit rests. +-- The result will have no empty space. +-- +addRests :: [(Time, Duration, a)] -> Score a +addRests = Score . concat . snd . mapAccumL g 0 + where + g prevTime (t, d, x) + | prevTime == t = (t .+^ d, [(t, d, Just x)]) + | prevTime < t = (t .+^ d, [(prevTime, t .-. prevTime, Nothing), (t, d, Just x)]) + | otherwise = error "addRests: Strange prevTime" + +addRests' :: [(Time, Duration, a)] -> [(Time, Duration, Maybe a)] +addRests' = concat . snd . mapAccumL g 0 + where + g prevTime (t, d, x) + | prevTime == t = (t .+^ d, [(t, d, Just x)]) + | prevTime < t = (t .+^ d, [(prevTime, t .-. prevTime, Nothing), (t, d, Just x)]) + | otherwise = error "addRests: Strange prevTime" + +-- | +-- Given a set of absolute-time occurences, separate at each zero-time occurence. +-- Note that this require every bar to start with a zero-time occurence. +-- +separateBars :: HasMusicXml a => Score a -> [[(Duration, Maybe a)]] +separateBars = fmap removeTime . fmap (fmap discardBarNumber) . splitAtTimeZero . fmap separateTime . getScore + where + separateTime (t,d,x) = ((bn,bt),d,x) where (bn,bt) = properFraction (toRational t) + splitAtTimeZero = splitWhile ((== 0) . getBarTime) where getBarTime ((bn,bt),_,_) = bt + discardBarNumber ((bn,bt),d,x) = (fromRational bt, d, x) + removeTime = fmap g where g (t,d,x) = (d,x) + + +barToXml :: HasMusicXml a => [(Duration, Maybe a)] -> Xml.Music +barToXml bar = case quantize bar of + Left e -> error $ "barToXml: Could not quantize this bar: " ++ show e + Right rh -> rhythmToXml rh + +-- FIXME dotted rests does not work... +rhythmToXml :: HasMusicXml a => Rhythm (Maybe a) -> Xml.Music +rhythmToXml (Beat d x) = noteRestToXml (d, x) +rhythmToXml (Dotted n (Beat d x)) = noteRestToXml (dotMod n * d, x) +rhythmToXml (Tuplet m r) = Xml.tuplet (fromIntegral $ denominator $ getDuration $ m) (fromIntegral $ numerator $ getDuration m) (rhythmToXml r) +rhythmToXml (Bound d r) = noteRestToXml (fromRational $ getDuration d, x) <> rhythmToXml r2 + where + (x,r2) = toTiedRhythm r +rhythmToXml (Rhythms rs) = mconcat $ map rhythmToXml rs + +toTiedRhythm :: HasMusicXml a => Rhythm (Maybe a) -> (Maybe a, Rhythm (Maybe a)) +toTiedRhythm (Beat d a) = (b, Beat d c) where (b,c) = toTied a +toTiedRhythm (Dotted n a) = (b, Dotted n c) where (b,c) = toTiedRhythm a +toTiedRhythm (Tuplet m a) = (b, Tuplet m c) where (b,c) = toTiedRhythm a +toTiedRhythm (Bound d r) = error "toXml: Nested bounded rhytms" +toTiedRhythm (Rhythms []) = error "toXml: Bound empty rhythm" +toTiedRhythm (Rhythms (a:as)) = (b, Rhythms (c:as)) where (b,c) = toTiedRhythm a + +noteRestToXml :: HasMusicXml a => (Duration, Maybe a) -> Xml.Music +noteRestToXml (d, Nothing) = Xml.rest d' where d' = (fromRational . toRational $ d) +noteRestToXml (d, Just p) = getMusicXml d p + +------------------------------------------------------------------------------------- +-- Transformer instances (TODO move) +------------------------------------------------------------------------------------- + +-- PitchT + +-- instance HasMidi a => HasMidi (PitchT p a) where +-- getMidi (PitchT (_,x)) = getMidi x +-- instance HasMusicXml a => HasMusicXml (PitchT p a) where +-- getMusicXml d (PitchT (_,x)) = getMusicXml d x +-- instance (IsPitch a, IsString n) => IsPitch (PitchT p a) where +-- fromPitch l = PitchT ("", fromPitch l) +-- instance (IsDynamics a, IsString n) => IsDynamics (PitchT p a) where +-- fromDynamics l = PitchT ("", fromDynamics l) +-- instance HasDynamic a => HasDynamic (PitchT p a) where +-- setBeginCresc n (PitchT (v,x)) = PitchT (v, setBeginCresc n x) +-- setEndCresc n (PitchT (v,x)) = PitchT (v, setEndCresc n x) +-- setBeginDim n (PitchT (v,x)) = PitchT (v, setBeginDim n x) +-- setEndDim n (PitchT (v,x)) = PitchT (v, setEndDim n x) +-- setLevel n (PitchT (v,x)) = PitchT (v, setLevel n x) +-- instance HasArticulation a => HasArticulation (PitchT p a) where +-- setEndSlur n (PitchT (v,x)) = PitchT (v, setEndSlur n x) +-- setContSlur n (PitchT (v,x)) = PitchT (v, setContSlur n x) +-- setBeginSlur n (PitchT (v,x)) = PitchT (v, setBeginSlur n x) +-- setAccLevel n (PitchT (v,x)) = PitchT (v, setAccLevel n x) +-- setStaccLevel n (PitchT (v,x)) = PitchT (v, setStaccLevel n x) +-- instance HasTremolo a => HasTremolo (PitchT p a) where +-- setTrem n (PitchT (v,x)) = PitchT (v, setTrem n x) +-- + +-- VoiceT + + +instance HasMidi a => HasMidi (VoiceT n a) where + getMidi (VoiceT (_,x)) = getMidi x +instance HasMusicXml a => HasMusicXml (VoiceT n a) where + getMusicXml d (VoiceT (_,x)) = getMusicXml d x +instance HasVoice (VoiceT n a) where + type Voice (VoiceT n a) = n + getVoice (VoiceT (v,_)) = v + modifyVoice f (VoiceT (v,x)) = VoiceT (f v, x) +instance HasPitch a => HasPitch (VoiceT n a) where + type Pitch (VoiceT n a) = Pitch a + getPitch (VoiceT (v,a)) = getPitch a + modifyPitch f (VoiceT (v,x)) = VoiceT (v, modifyPitch f x) +-- TODO IsPitch/IsDynamic with mempty/def as default as well? +instance (IsPitch a, Enum n) => IsPitch (VoiceT n a) where + fromPitch l = VoiceT (toEnum 0, fromPitch l) +instance (IsDynamics a, Enum n) => IsDynamics (VoiceT n a) where + fromDynamics l = VoiceT (toEnum 0, fromDynamics l) +instance Tiable a => Tiable (VoiceT n a) where + toTied (VoiceT (v,a)) = (VoiceT (v,b), VoiceT (v,c)) where (b,c) = toTied a +instance HasDynamic a => HasDynamic (VoiceT n a) where + setBeginCresc n (VoiceT (v,x)) = VoiceT (v, setBeginCresc n x) + setEndCresc n (VoiceT (v,x)) = VoiceT (v, setEndCresc n x) + setBeginDim n (VoiceT (v,x)) = VoiceT (v, setBeginDim n x) + setEndDim n (VoiceT (v,x)) = VoiceT (v, setEndDim n x) + setLevel n (VoiceT (v,x)) = VoiceT (v, setLevel n x) +instance HasArticulation a => HasArticulation (VoiceT n a) where + setEndSlur n (VoiceT (v,x)) = VoiceT (v, setEndSlur n x) + setContSlur n (VoiceT (v,x)) = VoiceT (v, setContSlur n x) + setBeginSlur n (VoiceT (v,x)) = VoiceT (v, setBeginSlur n x) + setAccLevel n (VoiceT (v,x)) = VoiceT (v, setAccLevel n x) + setStaccLevel n (VoiceT (v,x)) = VoiceT (v, setStaccLevel n x) +instance HasTremolo a => HasTremolo (VoiceT n a) where + setTrem n (VoiceT (v,x)) = VoiceT (v, setTrem n x) +instance HasHarmonic a => HasHarmonic (VoiceT n a) where + setHarmonic n (VoiceT (v,x)) = VoiceT (v, setHarmonic n x) +instance HasSlide a => HasSlide (VoiceT n a) where + setBeginGliss n (VoiceT (v,x)) = VoiceT (v, setBeginGliss n x) + setBeginSlide n (VoiceT (v,x)) = VoiceT (v, setBeginSlide n x) + setEndGliss n (VoiceT (v,x)) = VoiceT (v, setEndGliss n x) + setEndSlide n (VoiceT (v,x)) = VoiceT (v, setEndSlide n x) +instance HasText a => HasText (VoiceT n a) where + addText s (VoiceT (v,x)) = VoiceT (v, addText s x) + + +-- TieT + +instance HasMidi a => HasMidi (TieT a) where + getMidi (TieT (_,x,_)) = getMidi x +instance HasMusicXml a => HasMusicXml (TieT a) where + getMusicXml d (TieT (ta,x,tb)) = addTies $ getMusicXml d x + where + addTies | ta && tb = Xml.endTie . Xml.beginTie + | tb = Xml.beginTie + | ta = Xml.endTie + | otherwise = id +instance HasVoice a => HasVoice (TieT a) where + type Voice (TieT a) = Voice a + getVoice (TieT (_,x,_)) = getVoice x + modifyVoice f (TieT (b,x,e)) = TieT (b,modifyVoice f x,e) +instance HasPitch a => HasPitch (TieT a) where + type Pitch (TieT a) = Pitch a + getPitch (TieT (_,x,_)) = getPitch x + modifyPitch f (TieT (b,x,e)) = TieT (b,modifyPitch f x,e) +instance IsPitch a => IsPitch (TieT a) where + fromPitch l = TieT (False, fromPitch l, False) +instance IsDynamics a => IsDynamics (TieT a) where + fromDynamics l = TieT (False, fromDynamics l, False) +instance HasDynamic a => HasDynamic (TieT a) where + setBeginCresc n (TieT (b,x,e)) = TieT (b,setBeginCresc n x,e) + setEndCresc n (TieT (b,x,e)) = TieT (b,setEndCresc n x,e) + setBeginDim n (TieT (b,x,e)) = TieT (b,setBeginDim n x,e) + setEndDim n (TieT (b,x,e)) = TieT (b,setEndDim n x,e) + setLevel n (TieT (b,x,e)) = TieT (b,setLevel n x,e) +instance HasArticulation a => HasArticulation (TieT a) where + setEndSlur n (TieT (b,x,e)) = TieT (b,setEndSlur n x,e) + setContSlur n (TieT (b,x,e)) = TieT (b,setContSlur n x,e) + setBeginSlur n (TieT (b,x,e)) = TieT (b,setBeginSlur n x,e) + setAccLevel n (TieT (b,x,e)) = TieT (b,setAccLevel n x,e) + setStaccLevel n (TieT (b,x,e)) = TieT (b,setStaccLevel n x,e) +instance HasTremolo a => HasTremolo (TieT a) where + setTrem n (TieT (b,x,e)) = TieT (b,setTrem n x,e) +instance HasHarmonic a => HasHarmonic (TieT a) where + setHarmonic n (TieT (b,x,e)) = TieT (b,setHarmonic n x,e) +instance HasSlide a => HasSlide (TieT a) where + setBeginGliss n (TieT (b,x,e)) = TieT (b,setBeginGliss n x,e) + setBeginSlide n (TieT (b,x,e)) = TieT (b,setBeginSlide n x,e) + setEndGliss n (TieT (b,x,e)) = TieT (b,setEndGliss n x,e) + setEndSlide n (TieT (b,x,e)) = TieT (b,setEndSlide n x,e) +instance HasText a => HasText (TieT a) where + addText s (TieT (b,x,e)) = TieT (b, addText s x, e) + + +-- DynamicT + +-- end cresc/dim, level, begin cresc/dim +-- newtype DynamicT a = DynamicT { getDynamicT :: (Bool, Bool, Maybe Double, a, Bool, Bool) } + +instance HasMidi a => HasMidi (DynamicT a) where + getMidi (DynamicT (ec,ed,l,a,bc,bd)) = getMidi a + +instance HasMusicXml a => HasMusicXml (DynamicT a) where + getMusicXml d (DynamicT (ec,ed,l,a,bc,bd)) = notate $ getMusicXml d a + where + notate x = nec <> ned <> nl <> nbc <> nbd <> x + nec = if ec then Xml.endCresc else mempty + ned = if ed then Xml.endDim else mempty + nbc = if bc then Xml.beginCresc else mempty + nbd = if bd then Xml.beginDim else mempty + nl = case l of + Nothing -> mempty + Just lvl -> Xml.dynamic (fromDynamics (DynamicsL (Just lvl, Nothing))) + +instance Tiable a => Tiable (DynamicT a) where + toTied (DynamicT (ec,ed,l,a,bc,bd)) = (DynamicT (ec,ed,l,b,bc,bd), + DynamicT (False,False,Nothing,c,False,False)) where (b,c) = toTied a +instance HasVoice a => HasVoice (DynamicT a) where + type Voice (DynamicT a) = Voice a + getVoice (DynamicT (ec,ed,l,a,bc,bd)) = getVoice a + modifyVoice f (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,modifyVoice f a,bc,bd) +instance HasPitch a => HasPitch (DynamicT a) where + type Pitch (DynamicT a) = Pitch a + getPitch (DynamicT (ec,ed,l,a,bc,bd)) = getPitch a + modifyPitch f (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,modifyPitch f a,bc,bd) +instance IsPitch a => IsPitch (DynamicT a) where + fromPitch l = DynamicT (False,False,Nothing,fromPitch l,False,False) +instance IsDynamics a => IsDynamics (DynamicT a) where + fromDynamics l = DynamicT (False,False,Nothing,fromDynamics l,False,False) +instance HasDynamic (DynamicT a) where + setBeginCresc bc (DynamicT (ec,ed,l,a,_ ,bd)) = DynamicT (ec,ed,l,a,bc,bd) + setEndCresc ec (DynamicT (_ ,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,a,bc,bd) + setBeginDim bd (DynamicT (ec,ed,l,a,bc,_ )) = DynamicT (ec,ed,l,a,bc,bd) + setEndDim ed (DynamicT (ec,_ ,l,a,bc,bd)) = DynamicT (ec,ed,l,a,bc,bd) + setLevel l (DynamicT (ec,ed,_,a,bc,bd)) = DynamicT (ec,ed,Just l,a,bc,bd) +instance HasArticulation a => HasArticulation (DynamicT a) where + setEndSlur n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setEndSlur n a,bc,bd) + setContSlur n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setContSlur n a,bc,bd) + setBeginSlur n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setBeginSlur n a,bc,bd) + setAccLevel n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setAccLevel n a,bc,bd) + setStaccLevel n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setStaccLevel n a,bc,bd) +instance HasTremolo a => HasTremolo (DynamicT a) where + setTrem n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setTrem n a,bc,bd) +instance HasHarmonic a => HasHarmonic (DynamicT a) where + setHarmonic n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setHarmonic n a,bc,bd) +instance HasSlide a => HasSlide (DynamicT a) where + setBeginGliss n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setBeginGliss n a,bc,bd) + setBeginSlide n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setBeginSlide n a,bc,bd) + setEndGliss n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setEndGliss n a,bc,bd) + setEndSlide n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setEndSlide n a,bc,bd) +instance HasText a => HasText (DynamicT a) where + addText s (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,addText s a,bc,bd) + + +-- ArticulationT + +-- end slur, cont slur, acc level, stacc level, begin slur +-- newtype ArticulationT a = ArticulationT { getArticulationT :: (Bool, Bool, Int, Int, a, Bool) } + +instance HasMidi a => HasMidi (ArticulationT a) where + getMidi (ArticulationT (es,us,al,sl,a,bs)) = getMidi a +instance HasMusicXml a => HasMusicXml (ArticulationT a) where + getMusicXml d (ArticulationT (es,us,al,sl,a,bs)) = notate $ getMusicXml d a + where + notate = nes . nal . nsl . nbs + nes = if es then Xml.endSlur else id + nal = case al of + 0 -> id + 1 -> Xml.accent + 2 -> Xml.strongAccent + nsl = case sl of + (-2) -> Xml.tenuto + (-1) -> Xml.tenuto . Xml.staccato + 0 -> id + 1 -> Xml.staccato + 2 -> Xml.staccatissimo + nbs = if bs then Xml.beginSlur else id + +instance Tiable a => Tiable (ArticulationT a) where + toTied (ArticulationT (es,us,al,sl,a,bs)) = (ArticulationT (False,us,al,sl,b,bs), + ArticulationT (es, us,0,0,c,False)) where (b,c) = toTied a +instance HasVoice a => HasVoice (ArticulationT a) where + type Voice (ArticulationT a) = Voice a + getVoice (ArticulationT (es,us,al,sl,a,bs)) = getVoice a + modifyVoice f (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,modifyVoice f a,bs) +instance HasPitch a => HasPitch (ArticulationT a) where + type Pitch (ArticulationT a) = Pitch a + getPitch (ArticulationT (es,us,al,sl,a,bs)) = getPitch a + modifyPitch f (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,modifyPitch f a,bs) +instance IsPitch a => IsPitch (ArticulationT a) where + fromPitch l = ArticulationT (False,False,0,0,fromPitch l,False) +instance IsDynamics a => IsDynamics (ArticulationT a) where + fromDynamics l = ArticulationT (False,False,0,0,fromDynamics l,False) +instance HasDynamic a => HasDynamic (ArticulationT a) where + setBeginCresc n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setBeginCresc n a,bs) + setEndCresc n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setEndCresc n a,bs) + setBeginDim n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setBeginDim n a,bs) + setEndDim n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setEndDim n a,bs) + setLevel n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setLevel n a,bs) +instance HasArticulation (ArticulationT a) where + setEndSlur es (ArticulationT (_ ,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,a,bs) + setContSlur us (ArticulationT (es,_ ,al,sl,a,bs)) = ArticulationT (es,us,al,sl,a,bs) + setBeginSlur bs (ArticulationT (es,us,al,sl,a,_ )) = ArticulationT (es,us,al,sl,a,bs) + setAccLevel al (ArticulationT (es,us,_ ,sl,a,bs)) = ArticulationT (es,us,al,sl,a,bs) + setStaccLevel sl (ArticulationT (es,us,al,_ ,a,bs)) = ArticulationT (es,us,al,sl,a,bs) +instance HasTremolo a => HasTremolo (ArticulationT a) where + setTrem n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setTrem n a,bs) +instance HasHarmonic a => HasHarmonic (ArticulationT a) where + setHarmonic n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setHarmonic n a,bs) +instance HasSlide a => HasSlide (ArticulationT a) where + setBeginGliss n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setBeginGliss n a,bs) + setBeginSlide n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setBeginSlide n a,bs) + setEndGliss n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setEndGliss n a,bs) + setEndSlide n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setEndSlide n a,bs) +instance HasText a => HasText (ArticulationT a) where + addText s (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,addText s a,bs) + + +-- TremoloT + +-- newtype TremoloT a = TremoloT { getTremoloT :: (Int, a) } + +instance HasMidi a => HasMidi (TremoloT a) where + getMidi (TremoloT (_,x)) = getMidi x +instance HasMusicXml a => HasMusicXml (TremoloT a) where + getMusicXml d (TremoloT (n,x)) = notate $ getMusicXml d x + where + notate = Xml.tremolo n + +instance Tiable a => Tiable (TremoloT a) where + toTied (TremoloT (n,a)) = (TremoloT (n,b), TremoloT (n,c)) where (b,c) = toTied a +instance HasVoice a => HasVoice (TremoloT a) where + type Voice (TremoloT a) = Voice a + getVoice (TremoloT (_,a)) = getVoice a + modifyVoice f (TremoloT (n,x)) = TremoloT (n, modifyVoice f x) +instance HasPitch a => HasPitch (TremoloT a) where + type Pitch (TremoloT a) = Pitch a + getPitch (TremoloT (_,a)) = getPitch a + modifyPitch f (TremoloT (n,x)) = TremoloT (n, modifyPitch f x) +instance IsPitch a => IsPitch (TremoloT a) where + fromPitch l = TremoloT (0, fromPitch l) +instance IsDynamics a => IsDynamics (TremoloT a) where + fromDynamics l = TremoloT (0, fromDynamics l) +instance HasDynamic a => HasDynamic (TremoloT a) where + setBeginCresc n (TremoloT (v,x)) = TremoloT (v, setBeginCresc n x) + setEndCresc n (TremoloT (v,x)) = TremoloT (v, setEndCresc n x) + setBeginDim n (TremoloT (v,x)) = TremoloT (v, setBeginDim n x) + setEndDim n (TremoloT (v,x)) = TremoloT (v, setEndDim n x) + setLevel n (TremoloT (v,x)) = TremoloT (v, setLevel n x) +instance HasArticulation a => HasArticulation (TremoloT a) where + setEndSlur n (TremoloT (v,x)) = TremoloT (v, setEndSlur n x) + setContSlur n (TremoloT (v,x)) = TremoloT (v, setContSlur n x) + setBeginSlur n (TremoloT (v,x)) = TremoloT (v, setBeginSlur n x) + setAccLevel n (TremoloT (v,x)) = TremoloT (v, setAccLevel n x) + setStaccLevel n (TremoloT (v,x)) = TremoloT (v, setStaccLevel n x) +instance HasTremolo (TremoloT a) where + setTrem n (TremoloT (_,x)) = TremoloT (n,x) +instance HasHarmonic a => HasHarmonic (TremoloT a) where + setHarmonic n (TremoloT (v,x)) = TremoloT (v, setHarmonic n x) +instance HasSlide a => HasSlide (TremoloT a) where + setBeginGliss n (TremoloT (v,x)) = TremoloT (v, setBeginGliss n x) + setBeginSlide n (TremoloT (v,x)) = TremoloT (v, setBeginSlide n x) + setEndGliss n (TremoloT (v,x)) = TremoloT (v, setEndGliss n x) + setEndSlide n (TremoloT (v,x)) = TremoloT (v, setEndSlide n x) +instance HasText a => HasText (TremoloT a) where + addText s (TremoloT (n,x)) = TremoloT (n,addText s x) + + +-- TextT + +-- newtype TextT a = TextT { getTextT :: (Int, a) } + +instance HasMidi a => HasMidi (TextT a) where + getMidi (TextT (_,x)) = getMidi x +instance HasMusicXml a => HasMusicXml (TextT a) where + getMusicXml d (TextT (s,x)) = notate s $ getMusicXml d x + where + notate ts a = (mconcat $ fmap Xml.text ts) <> a + +instance Tiable a => Tiable (TextT a) where + toTied (TextT (n,a)) = (TextT (n,b), TextT (mempty,c)) where (b,c) = toTied a +instance HasVoice a => HasVoice (TextT a) where + type Voice (TextT a) = Voice a + getVoice (TextT (_,a)) = getVoice a + modifyVoice f (TextT (n,x)) = TextT (n, modifyVoice f x) +instance HasPitch a => HasPitch (TextT a) where + type Pitch (TextT a) = Pitch a + getPitch (TextT (_,a)) = getPitch a + modifyPitch f (TextT (n,x)) = TextT (n, modifyPitch f x) +instance IsPitch a => IsPitch (TextT a) where + fromPitch l = TextT (mempty, fromPitch l) +instance IsDynamics a => IsDynamics (TextT a) where + fromDynamics l = TextT (mempty, fromDynamics l) +instance HasDynamic a => HasDynamic (TextT a) where + setBeginCresc n (TextT (v,x)) = TextT (v, setBeginCresc n x) + setEndCresc n (TextT (v,x)) = TextT (v, setEndCresc n x) + setBeginDim n (TextT (v,x)) = TextT (v, setBeginDim n x) + setEndDim n (TextT (v,x)) = TextT (v, setEndDim n x) + setLevel n (TextT (v,x)) = TextT (v, setLevel n x) +instance HasArticulation a => HasArticulation (TextT a) where + setEndSlur n (TextT (v,x)) = TextT (v, setEndSlur n x) + setContSlur n (TextT (v,x)) = TextT (v, setContSlur n x) + setBeginSlur n (TextT (v,x)) = TextT (v, setBeginSlur n x) + setAccLevel n (TextT (v,x)) = TextT (v, setAccLevel n x) + setStaccLevel n (TextT (v,x)) = TextT (v, setStaccLevel n x) +instance HasTremolo a => HasTremolo (TextT a) where + setTrem n (TextT (s,x)) = TextT (s,setTrem n x) +instance HasHarmonic a => HasHarmonic (TextT a) where + setHarmonic n (TextT (v,x)) = TextT (v, setHarmonic n x) +instance HasSlide a => HasSlide (TextT a) where + setBeginGliss n (TextT (v,x)) = TextT (v, setBeginGliss n x) + setBeginSlide n (TextT (v,x)) = TextT (v, setBeginSlide n x) + setEndGliss n (TextT (v,x)) = TextT (v, setEndGliss n x) + setEndSlide n (TextT (v,x)) = TextT (v, setEndSlide n x) +instance HasText (TextT a) where + addText s (TextT (t,x)) = TextT (t ++ [s],x) + + +-- HarmonicT + +instance HasMidi a => HasMidi (HarmonicT a) where + getMidi (HarmonicT (_,x)) = getMidi x +instance HasMusicXml a => HasMusicXml (HarmonicT a) where + getMusicXml d (HarmonicT (n,x)) = notate $ getMusicXml d x + where + notate | n /= 0 = Xml.setNoteHead Xml.DiamondNoteHead + | otherwise = id + -- TODO adjust pitch etc + +instance Tiable a => Tiable (HarmonicT a) where + toTied (HarmonicT (n,a)) = (HarmonicT (n,b), HarmonicT (n,c)) where (b,c) = toTied a +instance HasVoice a => HasVoice (HarmonicT a) where + type Voice (HarmonicT a) = Voice a + getVoice (HarmonicT (_,a)) = getVoice a + modifyVoice f (HarmonicT (n,x)) = HarmonicT (n, modifyVoice f x) +instance HasPitch a => HasPitch (HarmonicT a) where + type Pitch (HarmonicT a) = Pitch a + getPitch (HarmonicT (_,a)) = getPitch a + modifyPitch f (HarmonicT (n,x)) = HarmonicT (n, modifyPitch f x) +instance IsPitch a => IsPitch (HarmonicT a) where + fromPitch l = HarmonicT (0, fromPitch l) +instance IsDynamics a => IsDynamics (HarmonicT a) where + fromDynamics l = HarmonicT (0, fromDynamics l) +instance HasDynamic a => HasDynamic (HarmonicT a) where + setBeginCresc n (HarmonicT (v,x)) = HarmonicT (v, setBeginCresc n x) + setEndCresc n (HarmonicT (v,x)) = HarmonicT (v, setEndCresc n x) + setBeginDim n (HarmonicT (v,x)) = HarmonicT (v, setBeginDim n x) + setEndDim n (HarmonicT (v,x)) = HarmonicT (v, setEndDim n x) + setLevel n (HarmonicT (v,x)) = HarmonicT (v, setLevel n x) +instance HasArticulation a => HasArticulation (HarmonicT a) where + setEndSlur n (HarmonicT (v,x)) = HarmonicT (v, setEndSlur n x) + setContSlur n (HarmonicT (v,x)) = HarmonicT (v, setContSlur n x) + setBeginSlur n (HarmonicT (v,x)) = HarmonicT (v, setBeginSlur n x) + setAccLevel n (HarmonicT (v,x)) = HarmonicT (v, setAccLevel n x) + setStaccLevel n (HarmonicT (v,x)) = HarmonicT (v, setStaccLevel n x) +instance HasTremolo a => HasTremolo (HarmonicT a) where + setTrem n (HarmonicT (s,x)) = HarmonicT (s,setTrem n x) +instance HasHarmonic (HarmonicT a) where + setHarmonic n (HarmonicT (_,x)) = HarmonicT (n,x) +instance HasSlide a => HasSlide (HarmonicT a) where + setBeginGliss n (HarmonicT (s,x)) = HarmonicT (s,setBeginGliss n x) + setBeginSlide n (HarmonicT (s,x)) = HarmonicT (s,setBeginSlide n x) + setEndGliss n (HarmonicT (s,x)) = HarmonicT (s,setEndGliss n x) + setEndSlide n (HarmonicT (s,x)) = HarmonicT (s,setEndSlide n x) +instance HasText a => HasText (HarmonicT a) where + addText s (HarmonicT (n,x)) = HarmonicT (n,addText s x) + + +-- SlideT + +instance HasMidi a => HasMidi (SlideT a) where + getMidi (SlideT (_,_,a,_,_)) = getMidi a +instance HasMusicXml a => HasMusicXml (SlideT a) where + getMusicXml d (SlideT (eg,es,a,bg,bs)) = notate $ getMusicXml d a + where + notate = neg . nes . nbg . nbs + neg = if es then Xml.endGliss else id + nes = if es then Xml.endSlide else id + nbg = if es then Xml.beginGliss else id + nbs = if es then Xml.beginSlide else id + + +instance Tiable a => Tiable (SlideT a) where + toTied (SlideT (eg,es,a,bg,bs)) = (SlideT (eg, es, b,False,False), + SlideT (False,False,c,bg, bs)) where (b,c) = toTied a +instance HasVoice a => HasVoice (SlideT a) where + type Voice (SlideT a) = Voice a + getVoice (SlideT (eg,es,a,bg,bs)) = getVoice a + modifyVoice f (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,modifyVoice f a,bg,bs) +instance HasPitch a => HasPitch (SlideT a) where + type Pitch (SlideT a) = Pitch a + getPitch (SlideT (eg,es,a,bg,bs)) = getPitch a + modifyPitch f (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,modifyPitch f a,bg,bs) +instance IsPitch a => IsPitch (SlideT a) where + fromPitch l = SlideT (False,False,fromPitch l,False,False) +instance IsDynamics a => IsDynamics (SlideT a) where + fromDynamics l = SlideT (False,False,fromDynamics l,False,False) +instance HasDynamic a => HasDynamic (SlideT a) where + setBeginCresc n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setBeginCresc n a,bg,bs) + setEndCresc n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setEndCresc n a,bg,bs) + setBeginDim n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setBeginDim n a,bg,bs) + setEndDim n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setEndDim n a,bg,bs) + setLevel n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setLevel n a,bg,bs) +instance HasArticulation a => HasArticulation (SlideT a) where + setEndSlur n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setEndSlur n a,bg,bs) + setContSlur n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setContSlur n a,bg,bs) + setBeginSlur n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setBeginSlur n a,bg,bs) + setAccLevel n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setAccLevel n a,bg,bs) + setStaccLevel n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setStaccLevel n a,bg,bs) +instance HasTremolo a => HasTremolo (SlideT a) where + setTrem n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setTrem n a,bg,bs) +instance HasHarmonic a => HasHarmonic (SlideT a) where + setHarmonic n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setHarmonic n a,bg,bs) +instance HasSlide (SlideT a) where + setBeginGliss bg (SlideT (eg,es,a,_,bs)) = SlideT (eg,es,a,bg,bs) + setBeginSlide bs (SlideT (eg,es,a,bg,_)) = SlideT (eg,es,a,bg,bs) + setEndGliss eg (SlideT (_,es,a,bg,bs)) = SlideT (eg,es,a,bg,bs) + setEndSlide es (SlideT (eg,_,a,bg,bs)) = SlideT (eg,es,a,bg,bs) +instance HasText a => HasText (SlideT a) where + addText s (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,addText s a,bg,bs) + + +------------------------------------------------------------------------------------- +-- Num, Integral, Enum and Bounded +------------------------------------------------------------------------------------- + +-- VoiceT + +instance (Enum v, Eq v, Num a) => Num (VoiceT v a) where + VoiceT (v,a) + VoiceT (_,b) = VoiceT (v,a+b) + VoiceT (v,a) * VoiceT (_,b) = VoiceT (v,a*b) + VoiceT (v,a) - VoiceT (_,b) = VoiceT (v,a-b) + abs (VoiceT (v,a)) = VoiceT (v,abs a) + signum (VoiceT (v,a)) = VoiceT (v,signum a) + fromInteger a = VoiceT (toEnum 0,fromInteger a) + +instance (Enum v, Enum a) => Enum (VoiceT v a) where + toEnum a = VoiceT (toEnum 0, toEnum a) -- TODO use def, mempty or minBound? + fromEnum (VoiceT (v,a)) = fromEnum a + +instance (Enum v, Bounded a) => Bounded (VoiceT v a) where + minBound = VoiceT (toEnum 0, minBound) + maxBound = VoiceT (toEnum 0, maxBound) + +instance (Enum v, Ord v, Num a, Ord a, Real a) => Real (VoiceT v a) where + toRational (VoiceT (v,a)) = toRational a + +instance (Enum v, Ord v, Real a, Enum a, Integral a) => Integral (VoiceT v a) where + VoiceT (v,a) `quotRem` VoiceT (_,b) = (VoiceT (v,q), VoiceT (v,r)) where (q,r) = a `quotRem` b + toInteger (VoiceT (v,a)) = toInteger a + + +-- TieT + +instance Num a => Num (TieT a) where + TieT (et,a,bt) + TieT (_,b,_) = TieT (et,a+b,bt) + TieT (et,a,bt) * TieT (_,b,_) = TieT (et,a*b,bt) + TieT (et,a,bt) - TieT (_,b,_) = TieT (et,a-b,bt) + abs (TieT (et,a,bt)) = TieT (et,abs a,bt) + signum (TieT (et,a,bt)) = TieT (et,signum a,bt) + fromInteger a = TieT (False,fromInteger a,False) + +instance Enum a => Enum (TieT a) where + toEnum a = TieT (False,toEnum a,False) + fromEnum (TieT (_,a,_)) = fromEnum a + +instance Bounded a => Bounded (TieT a) where + minBound = TieT (False,minBound,False) + maxBound = TieT (False,maxBound,False) + +instance (Num a, Ord a, Real a) => Real (TieT a) where + toRational (TieT (_,a,_)) = toRational a + +instance (Real a, Enum a, Integral a) => Integral (TieT a) where + TieT (et,a,bt) `quotRem` TieT (_,b,_) = (TieT (et,q,bt), TieT (et,r,bt)) where (q,r) = a `quotRem` b + toInteger (TieT (_,a,_)) = toInteger a + + +-- DynamicT + +instance Num a => Num (DynamicT a) where + DynamicT (p,q,r,a,s,t) + DynamicT (_,_,_,b,_,_) = DynamicT (p,q,r,a+b,s,t) + DynamicT (p,q,r,a,s,t) * DynamicT (_,_,_,b,_,_) = DynamicT (p,q,r,a*b,s,t) + DynamicT (p,q,r,a,s,t) - DynamicT (_,_,_,b,_,_) = DynamicT (p,q,r,a-b,s,t) + abs (DynamicT (p,q,r,a,s,t)) = DynamicT (p,q,r,abs a,s,t) + signum (DynamicT (p,q,r,a,s,t)) = DynamicT (p,q,r,signum a,s,t) + fromInteger a = DynamicT (False,False,Nothing,fromInteger a,False,False) + +instance Enum a => Enum (DynamicT a) where + toEnum a = DynamicT (False,False,Nothing,toEnum a,False,False) + fromEnum (DynamicT (_,_,_,a,_,_)) = fromEnum a + +instance Bounded a => Bounded (DynamicT a) where + minBound = DynamicT (False,False,Nothing,minBound,False,False) + maxBound = DynamicT (False,False,Nothing,maxBound,False,False) + +instance (Num a, Ord a, Real a) => Real (DynamicT a) where + toRational (DynamicT (_,_,_,a,_,_)) = toRational a + +instance (Real a, Enum a, Integral a) => Integral (DynamicT a) where + DynamicT (p,q,r,a,s,t) `quotRem` DynamicT (_,_,_,b,_,_) = (DynamicT (p,q,r,q',s,t), DynamicT (p,q,r,r',s,t)) where (q',r') = a `quotRem` b + toInteger (DynamicT (_,_,_,a,_,_)) = toInteger a + + +-- ArticulationT + +instance Num a => Num (ArticulationT a) where + ArticulationT (p,q,r,s,a,t) + ArticulationT (_,_,_,_,b,_) = ArticulationT (p,q,r,s,a+b,t) + ArticulationT (p,q,r,s,a,t) * ArticulationT (_,_,_,_,b,_) = ArticulationT (p,q,r,s,a*b,t) + ArticulationT (p,q,r,s,a,t) - ArticulationT (_,_,_,_,b,_) = ArticulationT (p,q,r,s,a-b,t) + abs (ArticulationT (p,q,r,s,a,t)) = ArticulationT (p,q,r,s,abs a,t) + signum (ArticulationT (p,q,r,s,a,t)) = ArticulationT (p,q,r,s,signum a,t) + fromInteger a = ArticulationT (False,False,0,0,fromInteger a,False) + +instance Enum a => Enum (ArticulationT a) where + toEnum a = ArticulationT (False,False,0,0,toEnum a,False) + fromEnum (ArticulationT (_,_,_,_,a,_)) = fromEnum a + +instance Bounded a => Bounded (ArticulationT a) where + minBound = ArticulationT (False,False,0,0,minBound,False) + maxBound = ArticulationT (False,False,0,0,maxBound,False) + +instance (Num a, Ord a, Real a) => Real (ArticulationT a) where + toRational (ArticulationT (_,_,_,_,a,_)) = toRational a + +instance (Real a, Enum a, Integral a) => Integral (ArticulationT a) where + ArticulationT (p,q,r,s,a,t) `quotRem` ArticulationT (_,_,_,_,b,_) = (ArticulationT (p,q,r,s,q',t), ArticulationT (p,q,r,s,r',t)) where (q',r') = a `quotRem` b + toInteger (ArticulationT (_,_,_,_,a,_)) = toInteger a + + +-- TremoloT + +instance Num a => Num (TremoloT a) where + TremoloT (v,a) + TremoloT (_,b) = TremoloT (v,a+b) + TremoloT (v,a) * TremoloT (_,b) = TremoloT (v,a*b) + TremoloT (v,a) - TremoloT (_,b) = TremoloT (v,a-b) + abs (TremoloT (v,a)) = TremoloT (v,abs a) + signum (TremoloT (v,a)) = TremoloT (v,signum a) + fromInteger a = TremoloT (toEnum 0,fromInteger a) + +instance Enum a => Enum (TremoloT a) where + toEnum a = TremoloT (0, toEnum a) -- TODO use def, mempty or minBound? + fromEnum (TremoloT (v,a)) = fromEnum a + +instance Bounded a => Bounded (TremoloT a) where + minBound = TremoloT (0, minBound) + maxBound = TremoloT (0, maxBound) + +instance (Num a, Real a) => Real (TremoloT a) where + toRational (TremoloT (_,a)) = toRational a + +instance (Real a, Enum a, Integral a) => Integral (TremoloT a) where + TremoloT (v,a) `quotRem` TremoloT (_,b) = (TremoloT (v,q), TremoloT (v,r)) where (q,r) = a `quotRem` b + toInteger (TremoloT (_,a)) = toInteger a + + +-- TextT + +instance Num a => Num (TextT a) where + TextT (v,a) + TextT (_,b) = TextT (v,a+b) + TextT (v,a) * TextT (_,b) = TextT (v,a*b) + TextT (v,a) - TextT (_,b) = TextT (v,a-b) + abs (TextT (v,a)) = TextT (v,abs a) + signum (TextT (v,a)) = TextT (v,signum a) + fromInteger a = TextT (mempty,fromInteger a) + +instance Enum a => Enum (TextT a) where + toEnum a = TextT (mempty, toEnum a) -- TODO use def, mempty or minBound? + fromEnum (TextT (v,a)) = fromEnum a + +instance Bounded a => Bounded (TextT a) where + minBound = TextT (mempty, minBound) + maxBound = TextT (mempty, maxBound) + +instance (Num a, Ord a, Real a) => Real (TextT a) where + toRational (TextT (v,a)) = toRational a + +instance (Real a, Enum a, Integral a) => Integral (TextT a) where + TextT (v,a) `quotRem` TextT (_,b) = (TextT (v,q), TextT (v,r)) where (q,r) = a `quotRem` b + toInteger (TextT (v,a)) = toInteger a + + +-- HarmonicT + +instance Num a => Num (HarmonicT a) where + HarmonicT (v,a) + HarmonicT (_,b) = HarmonicT (v,a+b) + HarmonicT (v,a) * HarmonicT (_,b) = HarmonicT (v,a*b) + HarmonicT (v,a) - HarmonicT (_,b) = HarmonicT (v,a-b) + abs (HarmonicT (v,a)) = HarmonicT (v,abs a) + signum (HarmonicT (v,a)) = HarmonicT (v,signum a) + fromInteger a = HarmonicT (toEnum 0,fromInteger a) + +instance Enum a => Enum (HarmonicT a) where + toEnum a = HarmonicT (0, toEnum a) -- TODO use def, mempty or minBound? + fromEnum (HarmonicT (v,a)) = fromEnum a + +instance Bounded a => Bounded (HarmonicT a) where + minBound = HarmonicT (0, minBound) + maxBound = HarmonicT (0, maxBound) + +instance (Num a, Ord a, Real a) => Real (HarmonicT a) where + toRational (HarmonicT (v,a)) = toRational a + +instance (Real a, Enum a, Integral a) => Integral (HarmonicT a) where + HarmonicT (v,a) `quotRem` HarmonicT (_,b) = (HarmonicT (v,q), HarmonicT (v,r)) where (q,r) = a `quotRem` b + toInteger (HarmonicT (v,a)) = toInteger a + + +-- SlideT + +instance Num a => Num (SlideT a) where + SlideT (eg,es,a,bg,bs) + SlideT (_,_,b,_,_) = SlideT (eg,es,a+b,bg,bs) + SlideT (eg,es,a,bg,bs) * SlideT (_,_,b,_,_) = SlideT (eg,es,a*b,bg,bs) + SlideT (eg,es,a,bg,bs) - SlideT (_,_,b,_,_) = SlideT (eg,es,a-b,bg,bs) + abs (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,abs a,bg,bs) + signum (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,signum a,bg,bs) + fromInteger a = SlideT (False,False,fromInteger a,False,False) + +instance Enum a => Enum (SlideT a) where + toEnum a = SlideT (False,False,toEnum a,False,False) + fromEnum (SlideT (_,_,a,_,_)) = fromEnum a + +instance Bounded a => Bounded (SlideT a) where + minBound = SlideT (False,False,minBound,False,False) + maxBound = SlideT (False,False,maxBound,False,False) + +instance (Num a, Ord a, Real a) => Real (SlideT a) where + toRational (SlideT (_,_,a,_,_)) = toRational a + +instance (Real a, Enum a, Integral a) => Integral (SlideT a) where + SlideT (eg,es,a,bg,bs) `quotRem` SlideT (_,_,b,_,_) = (SlideT (eg,es,q',bg,bs), SlideT (eg,es,r',bg,bs)) where (q',r') = a `quotRem` b + toInteger (SlideT (_,_,a,_,_)) = toInteger a + + +------------------------------------------------------------------------------------- +-- Literals +------------------------------------------------------------------------------------- + +instance IsPitch Double where + fromPitch (PitchL (pc, sem, oct)) = fromIntegral $ semitones sem + diatonic pc + (oct+1) * 12 + where + semitones = maybe 0 round + diatonic pc = case pc of + 0 -> 0 + 1 -> 2 + 2 -> 4 + 3 -> 5 + 4 -> 7 + 5 -> 9 + 6 -> 11 + +instance IsPitch Integer where + fromPitch (PitchL (pc, sem, oct)) = fromIntegral $ semitones sem + diatonic pc + (oct+1) * 12 + where + semitones = maybe 0 round + diatonic pc = case pc of + 0 -> 0 + 1 -> 2 + 2 -> 4 + 3 -> 5 + 4 -> 7 + 5 -> 9 + 6 -> 11 + +instance IsDynamics Double where + fromDynamics (DynamicsL (Just x, _)) = x + fromDynamics (DynamicsL (Nothing, _)) = error "IsDynamics Double: No dynamics" + + +data Alteration = Sh | Fl +sharp = Sh +flat = Fl +instance IsPitch (Alteration -> Double) where + fromPitch l Sh = fromPitch l + 1 + fromPitch l Fl = fromPitch l - 1 +instance IsPitch (Alteration -> Integer) where + fromPitch l Sh = fromPitch l + 1 + fromPitch l Fl = fromPitch l - 1 +instance IsPitch (Alteration -> a) => IsPitch (Alteration -> Score a) where + fromPitch l a = (pure . fromPitch l) a + + +------------------------------------------------------------------------------------- +-- Test stuff +------------------------------------------------------------------------------------- + + +type Fun a = a -> a +type Sc a = Score (VoiceT Int (TieT (TremoloT (DynamicT (ArticulationT a))))) + +score :: Fun (Sc Double) +score = id + +open = openXml . score + +------------------------------------------------------------------------------------- + +list z f [] = z +list z f xs = f xs + +first f (x,y) = (f x, y) +second f (x,y) = (x, f y) + +sep :: a -> [a] -> [a] +sep = List.intersperse + +concatSep :: [a] -> [[a]] -> [a] +concatSep x = List.concat . sep x + +-- Score filtering generalized to MonadPlus (TODO move!) + +-- | +-- Generalizes the 'remove' function. +-- +mremove :: MonadPlus m => (a -> Bool) -> m a -> m a +mremove p = mfilter (not . p) + +-- | +-- Generalizes the 'partition' function. +-- +mpartition :: MonadPlus m => (a -> Bool) -> m a -> (m a, m a) +mpartition p a = (mfilter p a, mremove p a) + +-- | +-- Pass through @Just@ occurrences. +-- Generalizes the 'catMaybes' function. +-- +mcatMaybes :: MonadPlus m => m (Maybe a) -> m a +mcatMaybes = (>>= maybe mzero return) + +-- | +-- Modify or discard a value. +-- Generalizes the 'mapMaybe' function. +-- +mmapMaybe :: MonadPlus m => (a -> Maybe b) -> m a -> m b +mmapMaybe f = mcatMaybes . liftM f + +-- | +-- Group a list into sublists whereever a predicate holds. The matched element +-- is the first in the sublist. +-- +-- > splitWhile isSpace "foo bar baz" +-- > ===> ["foo"," bar"," baz"] +-- > +-- > splitWhile (> 3) [1,5,4,7,0,1,2] +-- > ===> [[1],[5],[4],[7,0,1,2]] +-- +splitWhile :: (a -> Bool) -> [a] -> [[a]] +splitWhile p xs = case splitWhile' p xs of + []:xss -> xss + xss -> xss + where + splitWhile' p [] = [[]] + splitWhile' p (x:xs) = case splitWhile' p xs of + (xs:xss) -> if p x then []:(x:xs):xss else (x:xs):xss + +execute :: FilePath -> [String] -> IO () +execute program args = do + forkProcess $ executeFile program True args Nothing + return () + +single x = [x] +fmap2 = fmap . fmap +fmap3 = fmap . fmap . fmap + +dump = mapM putStrLn . fmap show + +left f (Left x) = Left (f x) +left f (Right y) = Right y + +mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a] +mergeBy f as bs = List.sortBy f $ as <> bs + diff --git a/src/Music/Score/Articulation.hs b/src/Music/Score/Articulation.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Articulation.hs @@ -0,0 +1,149 @@ + +{-# LANGUAGE + TypeFamilies, + DeriveFunctor, + DeriveFoldable, + FlexibleInstances, + GeneralizedNewtypeDeriving #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +-- Provides a musical score represenation. +-- +------------------------------------------------------------------------------------- + + +module Music.Score.Articulation ( + HasArticulation(..), + ArticulationT(..), + + -- ** Accents + accent, + marcato, + accentLast, + marcatoLast, + accentAll, + marcatoAll, + + -- ** Phrasing + tenuto, + separated, + staccato, + portato, + legato, + spiccato, + + -- ** Miscellaneous + resetArticulation, + + ) where + +import Data.Ratio +import Data.Foldable +import Data.Semigroup +import qualified Data.List as List +import Data.VectorSpace +import Data.AffineSpace + +import Music.Score.Part +import Music.Score.Score +import Music.Score.Duration +import Music.Score.Time +import Music.Score.Voice +import Music.Score.Combinators + +class HasArticulation a where + setBeginSlur :: Bool -> a -> a + setContSlur :: Bool -> a -> a + setEndSlur :: Bool -> a -> a + setAccLevel :: Int -> a -> a + setStaccLevel :: Int -> a -> a + +newtype ArticulationT a = ArticulationT { getArticulationT :: (Bool, Bool, Int, Int, a, Bool) } + deriving (Eq, Show, Ord, Functor, Foldable) + +-------------------------------------------------------------------------------- +-- Articulation +-------------------------------------------------------------------------------- + +-- Accents + +accent :: (HasArticulation a, HasVoice a, Ord v, v ~ Voice a) => Score a -> Score a +accent = mapSep (setAccLevel 1) id id + +marcato :: (HasArticulation a, HasVoice a, Ord v, v ~ Voice a) => Score a -> Score a +marcato = mapSep (setAccLevel 2) id id + +accentAll :: (HasArticulation a, HasVoice a, Ord v, v ~ Voice a) => Score a -> Score a +accentAll = mapSep (setAccLevel 1) (setAccLevel 1) (setAccLevel 1) + +marcatoAll :: (HasArticulation a, HasVoice a, Ord v, v ~ Voice a) => Score a -> Score a +marcatoAll = mapSep (setAccLevel 2) (setAccLevel 2) (setAccLevel 2) + +accentLast :: (HasArticulation a, HasVoice a, Ord v, v ~ Voice a) => Score a -> Score a +accentLast = mapSep id id (setAccLevel 1) + +marcatoLast :: (HasArticulation a, HasVoice a, Ord v, v ~ Voice a) => Score a -> Score a +marcatoLast = mapSep id id (setAccLevel 2) + +-- Phrasing + +tenuto :: (HasArticulation a, HasVoice a, Ord v, v ~ Voice a) => Score a -> Score a +tenuto = mapSep (setStaccLevel (-2)) (setStaccLevel (-2)) (setStaccLevel (-2)) + +separated :: (HasArticulation a, HasVoice a, Ord v, v ~ Voice a) => Score a -> Score a +separated = mapSep (setStaccLevel (-1)) (setStaccLevel (-1)) (setStaccLevel (-1)) + +staccato :: (HasArticulation a, HasVoice a, Ord v, v ~ Voice a) => Score a -> Score a +staccato = mapSep (setStaccLevel 1) (setStaccLevel 1) (setStaccLevel 1) + +portato :: (HasArticulation a, HasVoice a, Ord v, v ~ Voice a) => Score a -> Score a +portato = staccato . legato + +legato :: (HasArticulation a, HasVoice a, Ord v, v ~ Voice a) => Score a -> Score a +legato = mapSep (setBeginSlur True) id (setEndSlur True) + +spiccato :: (HasArticulation a, HasVoice a, Ord v, v ~ Voice a) => Score a -> Score a +spiccato = mapSep (setStaccLevel 2) (setStaccLevel 2) (setStaccLevel 2) + +resetArticulation :: HasArticulation c => c -> c +resetArticulation = setBeginSlur False . setContSlur False . setEndSlur False . setAccLevel 0 . setStaccLevel 0 + + + +-- FIXME consolidate + +-- | +-- Map over first, middle and last elements of list. +-- Biased on first, then on first and last for short lists. +-- +mapSepL :: (a -> b) -> (a -> b) -> (a -> b) -> [a] -> [b] +mapSepL f g h [] = [] +mapSepL f g h [a] = [f a] +mapSepL f g h [a,b] = [f a, h b] +mapSepL f g h xs = [f $ head xs] ++ (map g $ tail $ init xs) ++ [h $ last xs] + +mapSep :: (HasVoice a, Ord v, v ~ Voice a) => (a -> b) -> (a -> b) -> (a -> b) -> Score a -> Score b +mapSep f g h sc = fixDur . mapVoices (fmap $ mapSepPart f g h) $ sc + where + fixDur a = padAfter (duration sc - duration a) a + +mapSepPart :: (a -> b) -> (a -> b) -> (a -> b) -> Score a -> Score b +mapSepPart f g h sc = mconcat . mapSepL (fmap f) (fmap g) (fmap h) . fmap toSc . perform $ sc + where + fixDur a = padAfter (duration sc - duration a) a + toSc (t,d,x) = delay (t .-. 0) . stretch d $ note x + third f (a,b,c) = (a,b,f c) + +padAfter :: Duration -> Score a -> Score a +padAfter d a = a |> (rest^*d) + + diff --git a/src/Music/Score/Combinators.hs b/src/Music/Score/Combinators.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Combinators.hs @@ -0,0 +1,523 @@ + +{-# LANGUAGE + TypeFamilies, + DeriveFunctor, + DeriveFoldable, + FlexibleInstances, + OverloadedStrings, + GeneralizedNewtypeDeriving #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +-- Provides a musical score represenation. +-- +------------------------------------------------------------------------------------- + + +module Music.Score.Combinators ( + -- ** Constructing scores + rest, + note, + chord, + melody, + + -- ** Composing scores + (|>), + (<|), + scat, + pcat, + + -- *** Special composition + sustain, + overlap, + anticipate, + + -- ** Transforming scores + -- *** Moving in time + move, + moveBack, + startAt, + stopAt, + + -- *** Stretching in time + stretch, + compress, + stretchTo, + + -- ** Zipper + apply, + sample, + trig, + applySingle, + sampleSingle, + + -- *** Structure + + repTimes, + repWith, + repWithIndex, + repWithTime, + group, + groupWith, + scatMap, + rev, + before, + first, + butFirst, + + + -- ** Conversion + scoreToTrack, + scoreToPart, + scoreToParts, + partToScore, + trackToScore, + ) where + +import Prelude hiding (foldr, concat, foldl, mapM, concatMap, maximum, sum, minimum) + +import Control.Monad (ap, mfilter, join, liftM, MonadPlus(..)) +import Data.Semigroup +import Data.String +import Data.Foldable +import Data.Traversable +import qualified Data.List as List +import Data.VectorSpace +import Data.AffineSpace +import Data.Ratio +import Data.Ord + +import Music.Score.Track +import Music.Score.Part +import Music.Score.Score +import Music.Score.Duration +import Music.Score.Time +import Music.Score.Ties +import Music.Score.Voice + + +------------------------------------------------------------------------------------- +-- Constructors +------------------------------------------------------------------------------------- + +-- | Creates a score containing the given elements, composed in sequence. +melody :: [a] -> Score a +melody = scat . map note + +-- | Creates a score containing the given elements, composed in parallel. +chord :: [a] -> Score a +chord = pcat . map note + +-- | Creates a score from a the given melodies, composed in parallel. +melodies :: [[a]] -> Score a +melodies = pcat . map melody + +-- | Creates a score from a the given chords, composed in sequence. +chords :: [[a]] -> Score a +chords = scat . map chord + +-- | Like 'melody', but stretching each note by the given factors. +melodyStretch :: [(Duration, a)] -> Score a +melodyStretch = scat . map ( \(d, x) -> stretch d $ note x ) + +-- | Like 'chord', but delays each note the given amounts. +chordDelay :: [(Duration, a)] -> Score a +chordDelay = pcat . map ( \(t, x) -> delay t $ note x ) + +-- | Like 'chord', but delays and stretches each note the given amounts. +chordDelayStretch :: [(Duration, Duration, a)] -> Score a +chordDelayStretch = pcat . map ( \(t, d, x) -> delay t . stretch d $ note x ) + +-- -- | Like chord, but delaying each note the given amount. +-- arpeggio :: t -> [a] -> Score a +-- arpeggio t xs = chordDelay (zip [0, t ..] xs) + + +------------------------------------------------------------------------------------- +-- Transformations +------------------------------------------------------------------------------------- + +-- | +-- Move a score move in time. Equivalent to 'delay'. +-- +-- > Duration -> Score a -> Score a +-- +move :: Delayable a => Duration -> a -> a +move = delay + +-- | +-- Move a score moveBack in time. Negated verison of 'delay' +-- +-- > Duration -> Score a -> Score a +-- +moveBack :: Delayable a => Duration -> a -> a +moveBack t = delay (negate t) + +-- | +-- Stretch a score. Equivalent to '*^'. +-- +-- > Duration -> Score a -> Score a +-- +stretch :: VectorSpace v => Scalar v -> v -> v +stretch = (*^) + +-- | +-- Move a score to start at a specific time. +-- +-- > Duration -> Score a -> Score a +-- +startAt :: (Delayable a, HasOnset a) => Time -> a -> a +t `startAt` x = delay d x where d = t .-. onset x + +-- | +-- Move a score to stop at a specific time. +-- +-- > Duration -> Score a -> Score a +-- +stopAt :: (Delayable a, HasOnset a) => Time -> a -> a +t `stopAt` x = delay d x where d = t .-. offset x + +-- | +-- Compress a score. Flipped version of '^/'. +-- +-- > Duration -> Score a -> Score a +-- +compress :: (VectorSpace v, s ~ Scalar v, Fractional s) => s -> v -> v +compress = flip (^/) + +-- | +-- Stretch to the given duration. +-- +-- > Duration -> Score a -> Score a +-- +stretchTo :: (VectorSpace a, HasDuration a, Scalar a ~ Duration) => Duration -> a -> a +t `stretchTo` x = (t / duration x) `stretch` x + + +------------------------------------------------------------------------------------- +-- Composition +------------------------------------------------------------------------------------- + +infixr 6 |> +infixr 6 <| + +-- | +-- Compose in sequence. +-- +-- To compose in parallel, use '<>'. +-- +-- > Score a -> Score a -> Score a +(|>) :: (Semigroup a, Delayable a, HasOnset a) => a -> a -> a +a |> b = a <> startAt (offset a) b +-- a |< b = a <> stopAt (onset a) b + + +-- | +-- Compose in reverse sequence. +-- +-- To compose in parallel, use '<>'. +-- +-- > Score a -> Score a -> Score a +(<|) :: (Semigroup a, Delayable a, HasOnset a) => a -> a -> a +a <| b = b |> a + +-- | +-- Sequential concatentation. +-- +-- > [Score t] -> Score t +scat :: (Monoid a, Delayable a, HasOnset a) => [a] -> a +scat = unwrapMonoid . foldr (|>) mempty . fmap WrapMonoid + +-- | +-- Parallel concatentation. A synonym for 'mconcat'. +-- +-- > [Score t] -> Score t +pcat :: Monoid a => [a] -> a +pcat = mconcat + +-- infixr 7 <<| +-- infixr 7 |>> +-- infixr 7 <|| +-- infixr 7 ||> + +-- (<||) = sustain +-- (||>) = flip sustain +-- (|>>) = overlap +-- (<<|) = flip overlap + +-- | +-- Like '<>', but scaling the second agument to the duration of the first. +-- +-- > Score a -> Score a -> Score a +-- +sustain :: (Semigroup a, VectorSpace a, HasDuration a, Scalar a ~ Duration) => a -> a -> a +x `sustain` y = x <> (duration x) `stretchTo` y + +-- Like '<>', but truncating the second agument to the duration of the first. +-- prolong x y = x <> before (duration x) y + +-- | +-- Like '|>', but moving second argument halfway to the offset of the first. +-- +-- > Score a -> Score a -> Score a +-- +overlap :: (Semigroup a, Delayable a, HasDuration a) => a -> a -> a +x `overlap` y = x <> delay t y where t = duration x / 2 + +-- | +-- Like '|>' but with a negative delay on the second element. +-- +-- > Duration -> Score a -> Score a -> Score a +-- +anticipate :: (Semigroup a, Delayable a, HasDuration a, HasOnset a) => Duration -> a -> a -> a +anticipate t x y = x |> delay t' y where t' = (duration x - t) `max` 0 + + +------------------------------------------------------------------------------------- +-- Analysis + +apply :: (Ord v, v ~ Voice a, HasVoice a) => Part (Score a -> Score b) -> Score a -> Score b +apply x = mapVoices (fmap $ applySingle x) + +sample :: (Ord v, v ~ Voice a, HasVoice a) => Score b -> Score a -> Score (b, Score a) +sample x = mapVoices (fmap $ sampleSingle x) + +trig :: Score a -> Score b -> Score b +trig p as = mconcat $ toList $ fmap snd $ sampleSingle p as + +applySingle :: Part (Score a -> Score b) -> Score a -> Score b +applySingle fs as = notJoin $ fmap (\(f,s) -> f s) $ sampled + where + -- This is not join; we simply concatenate all inner scores in parallel + notJoin = mconcat . toList + sampled = sampleSingle (partToScore fs) as + +-- | +-- Get all notes that start during a given note. +-- +sampleSingle :: Score a -> Score b -> Score (a, Score b) +sampleSingle as bs = Score . fmap (\(t,d,a) -> (t,d,g a (onsetIn t d bs))) . getScore $ as + where + g Nothing z = Nothing + g (Just a) z = Just (a,z) + + +-- | Filter out events that has its onset in the given time interval (inclusive start). +-- For example, onset in 1 2 filters events such that (1 <= onset x < 3) +onsetIn :: Time -> Duration -> Score a -> Score a +onsetIn a b = Score . filt (\(t,d,x) -> a <= t && t < a .+^ b) . getScore + where + -- filt = mfilter + filt = takeUntil + -- more lazy than mfilter + +-- Take until predicate goes from True to False. +takeUntil :: (a -> Bool) -> [a] -> [a] +takeUntil p as = List.takeWhile p (List.dropWhile (not . p) as) + + +------------------------------------------------------------------------------------- +-- Conversion + +-- | +-- Convert a score to a track by throwing away durations. +-- +scoreToTrack :: Score a -> Track a +scoreToTrack = Track . fmap g . perform + where + g (t,d,x) = (t,x) + +-- | +-- Convert a single-part score to a part. +-- +scoreToPart :: Score a -> Part (Maybe a) +scoreToPart = Part . fmap g . addRests' . perform + where + g (t,d,x) = (d,x) + +-- | +-- Convert a score to a list of parts. +-- +scoreToParts :: (HasVoice a, Voice a ~ v, Ord v) => Score a -> [Part (Maybe a)] +scoreToParts = fmap scoreToPart . voices + +-- | +-- Convert a part to a score. +-- +partToScore :: Part a -> Score a +partToScore = scat . fmap g . getPart + where + g (d,x) = stretch d (note x) + +-- | +-- Convert a track to a score. Each note gets an arbitrary duration of one. +-- +trackToScore :: Track a -> Score a +trackToScore = pcat . fmap g . getTrack + where + g (t,x) = delay (t .-. 0) (note x) + + +-------------------------------------------------------------------------------- +-- Structure +-------------------------------------------------------------------------------- + +-- | +-- Repeat exact amount of times. +-- +-- > Duration -> Score Note -> Score Note +-- +repTimes :: (Enum a, Monoid c, HasOnset c, Delayable c) => a -> c -> c +repTimes n a = replicate (0 `max` fromEnum n) () `repWith` (const a) + +-- | +-- Repeat once for each element in the list. +-- +-- > [a] -> (a -> Score Note) -> Score Note +-- +-- Example: +-- +-- > repWith [1,2,1] (c^*) +-- +repWith :: (Monoid c, HasOnset c, Delayable c) => [a] -> (a -> c) -> c +repWith = flip (\f -> scat . fmap f) + +-- | +-- Combination of 'scat' and 'fmap'. Note that +-- +-- > scatMap = flip repWith +-- +scatMap f = scat . fmap f + +-- | +-- Repeat exact amount of times with an index. +-- +-- > Duration -> (Duration -> Score Note) -> Score Note +-- +repWithIndex :: (Enum a, Num a, Monoid c, HasOnset c, Delayable c) => a -> (a -> c) -> c +repWithIndex n = repWith [0..n-1] + +-- | +-- Repeat exact amount of times with relative time. +-- +-- > Duration -> (Time -> Score Note) -> Score Note +-- +repWithTime :: (Enum a, Fractional a, Monoid c, HasOnset c, Delayable c) => a -> (a -> c) -> c +repWithTime n = repWith $ fmap (/ n') [0..(n' - 1)] + where + n' = n + +-- | +-- Repeat a number of times and scale down by the same amount. +-- +-- > Duration -> Score a -> Score a +-- +group :: (Enum a, Fractional a, a ~ Scalar c, Monoid c, Semigroup c, VectorSpace c, HasOnset c, Delayable c) => a -> c -> c +group n a = repTimes n (a^/n) + +-- | +-- Repeat a number of times and scale down by the same amount. +-- +-- > [Duration] -> Score a -> Score a +-- +groupWith :: (Enum a, Fractional a, a ~ Scalar c, Monoid c, Semigroup c, VectorSpace c, HasOnset c, Delayable c) => [a] -> c -> c +groupWith = flip $ \p -> scat . fmap (flip group $ p) + +-- | +-- Reverse a score around its middle point. +-- +-- > onset a = onset (rev a) +-- > duration a = duration (rev a) +-- > offset a = offset (rev a) +-- +rev :: Score a -> Score a +rev = startAt 0 . rev' + where + rev' = Score . List.sortBy (comparing getT) . fmap g . getScore + g (t,d,x) = (-(t.+^d),d,x) + getT (t,d,x) = t + +-- | +-- Repeat indefinately, like repeat for lists. +-- +-- > Score Note -> Score Note +-- +rep :: Score a -> Score a +rep a = a `plus` delay (duration a) (rep a) + where + Score as `plus` Score bs = Score (as <> bs) + + +infixl 6 ||> +a ||> b = padToBar a |> b +bar = rest^*4 + +padToBar a = a |> (rest ^* (d' * 4)) + where + d = snd $ properFraction $ duration a / 4 + d' = if (d == 0) then 0 else (1-d) + + +rotl [] = [] +rotl (x:xs) = xs ++ [x] + +rotr [] = [] +rotr xs = (last xs:init xs) + +rotated n as | n >= 0 = iterate rotr as !! n + | n < 0 = iterate rotl as !! (abs n) + + + +before :: Duration -> Score a -> Score a +before d = trig (on^*d) + +first :: Score a -> a +first = get3 . head . perform + where get3 (a,b,c) = c + +butFirst :: Score a -> Score a +butFirst = Score . tail . getScore + +on :: Score () +on = note () + +off :: Score () +off = rest + + +tau = pi*2 + +splitWhile :: (a -> Bool) -> [a] -> [[a]] +splitWhile p xs = case splitWhile' p xs of + []:xss -> xss + xss -> xss + where + splitWhile' p [] = [[]] + splitWhile' p (x:xs) = case splitWhile' p xs of + (xs:xss) -> if p x then []:(x:xs):xss else (x:xs):xss + + + + + + + + + +-- FIXME consolidate +addRests' :: [(Time, Duration, a)] -> [(Time, Duration, Maybe a)] +addRests' = concat . snd . mapAccumL g 0 + where + g prevTime (t, d, x) + | prevTime == t = (t .+^ d, [(t, d, Just x)]) + | prevTime < t = (t .+^ d, [(prevTime, t .-. prevTime, Nothing), (t, d, Just x)]) + | otherwise = error "addRests: Strange prevTime" diff --git a/src/Music/Score/Duration.hs b/src/Music/Score/Duration.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Duration.hs @@ -0,0 +1,85 @@ + +{-# LANGUAGE + TypeFamilies, + DeriveFunctor, + DeriveFoldable, + GeneralizedNewtypeDeriving #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +-- Provides a musical score represenation. +-- +------------------------------------------------------------------------------------- + +module Music.Score.Duration where + +import Prelude hiding (foldr, concat, foldl, mapM, concatMap, maximum, sum, minimum) + +import Data.Semigroup +import Control.Applicative +import Data.Traversable +import Data.Maybe +import Data.Either +import Data.Function (on) +import Data.Ord (comparing) +import Data.Ratio +import Data.VectorSpace +import Data.AffineSpace + + +------------------------------------------------------------------------------------- +-- Duration type +------------------------------------------------------------------------------------- + +-- | +-- This type represents relative time in seconds. +-- +newtype Duration = Duration { getDuration::Rational } + deriving (Eq, Ord, Num, Enum, Real, Fractional, RealFrac) + -- Note: no Floating as we want to be able to switch to rational + +instance Show Duration where + show = show . getDuration + +instance AdditiveGroup Duration where + zeroV = 0 + (^+^) = (+) + negateV = negate + +instance VectorSpace Duration where + type Scalar Duration = Duration + (*^) = (*) + +instance InnerSpace Duration where (<.>) = (*) + + +class HasDuration a where + duration :: a -> Duration + + +------------------------------------------------------------------------------------- +-- Delayable class +------------------------------------------------------------------------------------- + +-- | +-- Delayable values. This is really similar to 'AffineSpace', except that there +-- is no '.-.'. +-- +class Delayable a where + + -- | + -- Delay a score. + -- > Duration -> Score a -> Score a + -- + delay :: Duration -> a -> a + +instance Delayable a => Delayable (WrappedMonoid a) where + delay t = WrapMonoid . delay t . unwrapMonoid diff --git a/src/Music/Score/Dynamics.hs b/src/Music/Score/Dynamics.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Dynamics.hs @@ -0,0 +1,204 @@ + +{-# LANGUAGE + TypeFamilies, + DeriveFunctor, + DeriveFoldable, + FlexibleInstances, + GeneralizedNewtypeDeriving #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +-- Provides a musical score represenation. +-- +------------------------------------------------------------------------------------- + + +module Music.Score.Dynamics ( + HasDynamic(..), + DynamicT(..), + + -- ** Dynamics over time + Levels(..), + cresc, + dim, + + -- ** Application + dynamicSingle, + dynamics, + + -- ** Miscellaneous + resetDynamics, + ) where + +import Control.Monad +import Data.Semigroup +import Data.Ratio +import Data.Foldable +import qualified Data.List as List +import Data.VectorSpace +import Data.AffineSpace + +import Music.Score.Part +import Music.Score.Score +import Music.Score.Duration +import Music.Score.Time +import Music.Score.Voice +import Music.Score.Combinators + +import Music.Dynamics.Literal + +class HasDynamic a where + setBeginCresc :: Bool -> a -> a + setEndCresc :: Bool -> a -> a + setBeginDim :: Bool -> a -> a + setEndDim :: Bool -> a -> a + setLevel :: Double -> a -> a + +-- end cresc/dim, level, begin cresc/dim +newtype DynamicT a = DynamicT { getDynamicT :: (Bool, Bool, Maybe Double, a, Bool, Bool) } + deriving (Eq, Show, Ord, Functor, Foldable) + + + +-------------------------------------------------------------------------------- +-- Dynamics +-------------------------------------------------------------------------------- + +-- Apply a constant level over the whole score. +-- dynamic :: (HasDynamic a, HasVoice a, Ord v, v ~ Voice a) => Double -> Score a -> Score a +-- dynamic n = mapSep (setLevel n) id id + + +-- | Apply a dynamic level over the score. +-- The dynamic score is assumed to have duration one. +-- +dynamics :: (HasDynamic a, HasVoice a, Ord v, v ~ Voice a) => Score (Levels Double) -> Score a -> Score a +dynamics d a = (duration a `stretchTo` d) `dyns` a + +-- | Apply a dynamic level over a single-part score. +-- Equivalent to `dynamics` for single part scores but more efficient. +-- +dynamicSingle :: HasDynamic a => Score (Levels Double) -> Score a -> Score a +dynamicSingle d a = (duration a `stretchTo` d) `dyn` a + + + +-- | Apply a variable level over the score. +dyns :: (HasDynamic a, HasVoice a, Ord v, v ~ Voice a) => Score (Levels Double) -> Score a -> Score a +dyns ds = mapVoices (fmap $ applyDynSingle (fmap fromJust $ scoreToPart ds)) + +-- | Apply a variable level over a single-part score. +dyn :: HasDynamic a => Score (Levels Double) -> Score a -> Score a +dyn ds = applyDynSingle (fmap fromJust . scoreToPart $ ds) + +resetDynamics :: HasDynamic c => c -> c +resetDynamics = setBeginCresc False . setEndCresc False . setBeginDim False . setEndDim False + + +-- | +-- Represents dynamics over a duration. +-- +data Levels a + = Level a + | Change a a + deriving (Eq, Show) + +instance Fractional a => IsDynamics (Levels a) where + fromDynamics (DynamicsL (Just a, Nothing)) = Level (toFrac a) + fromDynamics (DynamicsL (Just a, Just b)) = Change (toFrac a) (toFrac b) + fromDynamics x = error $ "fromDynamics: Invalid dynamics literal " {- ++ show x-} + +cresc :: IsDynamics a => Double -> Double -> a +cresc a b = fromDynamics $ DynamicsL ((Just a), (Just b)) + +dim :: IsDynamics a => Double -> Double -> a +dim a b = fromDynamics $ DynamicsL ((Just a), (Just b)) + + +-- end cresc, end dim, level, begin cresc, begin dim +type Levels2 a = (Bool, Bool, Maybe a, Bool, Bool) + +dyn2 :: Ord a => [Levels a] -> [Levels2 a] +dyn2 = snd . List.mapAccumL g (Nothing, False, False) -- level, cresc, dim + where + g (Nothing, False, False) (Level b) = ((Just b, False, False), (False, False, Just b, False, False)) + g (Nothing, False, False) (Change b c) = ((Just b, b < c, b > c), (False, False, Just b, b < c, b > c)) + + g (Just a , cr, dm) (Level b) + | a == b = ((Just b, False, False), (cr, dm, Nothing, False, False)) + | a /= b = ((Just b, False, False), (cr, dm, Just b, False, False)) + g (Just a , cr, dm) (Change b c) + | a == b = ((Just b, b < c, b > c), (cr, dm, Nothing, b < c, b > c)) + | a /= b = ((Just b, b < c, b > c), (cr, dm, Just b, b < c, b > c)) + + + +transf :: ([a] -> [b]) -> Part a -> Part b +transf f = Part . uncurry zip . second f . unzip . getPart + +applyDynSingle :: HasDynamic a => Part (Levels Double) -> Score a -> Score a +applyDynSingle ds as = applySingle ds3 as + where + -- ds2 :: Part (Dyn2 Double) + ds2 = transf dyn2 ds + -- ds3 :: Part (Score a -> Score a) + ds3 = (flip fmap) ds2 g + + g (ec,ed,l,bc,bd) = id + . (if ec then map1 (setEndCresc True) else id) + . (if ed then map1 (setEndDim True) else id) + . (if bc then map1 (setBeginCresc True) else id) + . (if bd then map1 (setBeginDim True) else id) + . (maybe id (\x -> map1 (setLevel x)) $ l) + map1 f = mapSepPart f id id + + + + + + +-- FIXME consolidate + +-- | +-- Map over first, middle and last elements of list. +-- Biased on first, then on first and last for short lists. +-- +mapSepL :: (a -> b) -> (a -> b) -> (a -> b) -> [a] -> [b] +mapSepL f g h [] = [] +mapSepL f g h [a] = [f a] +mapSepL f g h [a,b] = [f a, h b] +mapSepL f g h xs = [f $ head xs] ++ (map g $ tail $ init xs) ++ [h $ last xs] + +mapSep :: (HasVoice a, Ord v, v ~ Voice a) => (a -> b) -> (a -> b) -> (a -> b) -> Score a -> Score b +mapSep f g h sc = fixDur . mapVoices (fmap $ mapSepPart f g h) $ sc + where + fixDur a = padAfter (duration sc - duration a) a + +mapSepPart :: (a -> b) -> (a -> b) -> (a -> b) -> Score a -> Score b +mapSepPart f g h sc = mconcat . mapSepL (fmap f) (fmap g) (fmap h) . fmap toSc . perform $ sc + where + fixDur a = padAfter (duration sc - duration a) a + toSc (t,d,x) = delay (t .-. 0) . stretch d $ note x + third f (a,b,c) = (a,b,f c) + +padAfter :: Duration -> Score a -> Score a +padAfter d a = a |> (rest^*d) + + + + +second :: (a -> b) -> (c,a) -> (c,b) +second f (a,b) = (a,f b) + +toFrac :: (Real a, Fractional b) => a -> b +toFrac = fromRational . toRational + +fromJust (Just x) = x diff --git a/src/Music/Score/Ornaments.hs b/src/Music/Score/Ornaments.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Ornaments.hs @@ -0,0 +1,145 @@ + +{-# LANGUAGE + TypeFamilies, + DeriveFunctor, + DeriveFoldable, + FlexibleInstances, + GeneralizedNewtypeDeriving #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +-- Provides a musical score represenation. +-- +------------------------------------------------------------------------------------- + + +module Music.Score.Ornaments ( + HasTremolo(..), + TremoloT(..), + HasText(..), + TextT(..), + HasHarmonic(..), + HarmonicT(..), + HasSlide(..), + SlideT(..), + + tremolo, + text, + harmonic, + artificial, + slide, + ) where + +import Data.Ratio +import Data.Foldable +import Data.Monoid +import qualified Data.List as List +import Data.VectorSpace +import Data.AffineSpace + +import Music.Score.Part +import Music.Score.Score +import Music.Score.Duration +import Music.Score.Time +import Music.Score.Voice +import Music.Score.Combinators + +class HasTremolo a where + setTrem :: Int -> a -> a + +newtype TremoloT a = TremoloT { getTremoloT :: (Int, a) } + deriving (Eq, Show, Ord, Functor{-, Foldable-}) + +class HasText a where + addText :: String -> a -> a + +newtype TextT a = TextT { getTextT :: ([String], a) } + deriving (Eq, Show, Ord, Functor{-, Foldable-}) + + +-- 0 for none, positive for natural, negative for artificial +class HasHarmonic a where + setHarmonic :: Int -> a -> a + +newtype HarmonicT a = HarmonicT { getHarmonicT :: (Int, a) } + deriving (Eq, Show, Ord, Functor{-, Foldable-}) + +-- end gliss/slide, level, begin gliss/slide +class HasSlide a where + setBeginGliss :: Bool -> a -> a + setBeginSlide :: Bool -> a -> a + setEndGliss :: Bool -> a -> a + setEndSlide :: Bool -> a -> a + +newtype SlideT a = SlideT { getSlideT :: (Bool, Bool, a, Bool, Bool) } + deriving (Eq, Show, Ord, Functor{-, Foldable-}) + + +-- | +-- Add tremolo cross-beams to all notes in the score. +-- +tremolo :: (Functor f, HasTremolo b) => Int -> f b -> f b +tremolo n = fmap (setTrem n) + +-- | +-- Add text to the first note in the score. +-- +text :: (Ord v, v ~ Voice b, HasVoice b, HasText b) => String -> Score b -> Score b +text s = mapSep (addText s) id id + +-- | +-- Slide between the first and the last note. +-- +slide :: (Ord v, v ~ Voice b, HasVoice b, HasSlide b) => Score b -> Score b +slide = mapSep (setBeginSlide True) id (setEndSlide True) + +-- | +-- Make all notes natural harmonics on the given overtone (1 for octave, 2 for fifth etc). +-- Sounding pitch is unaffected, but notated output is transposed automatically. +-- +harmonic :: (Ord v, v ~ Voice b, HasVoice b, HasHarmonic b) => Int -> Score b -> Score b +harmonic n = mapSep f f f where f = setHarmonic n + +-- | +-- Make all notes natural harmonics on the given overtone (1 for octave, 2 for fifth etc). +-- Sounding pitch is unaffected, but notated output is transposed automatically. +-- +artificial :: (Ord v, v ~ Voice b, HasVoice b, HasHarmonic b) => Score b -> Score b +artificial = mapSep f f f where f = setHarmonic (-4) + +-- FIXME consolidate + +-- | +-- Map over first, middle and last elements of list. +-- Biased on first, then on first and last for short lists. +-- +mapSepL :: (a -> b) -> (a -> b) -> (a -> b) -> [a] -> [b] +mapSepL f g h [] = [] +mapSepL f g h [a] = [f a] +mapSepL f g h [a,b] = [f a, h b] +mapSepL f g h xs = [f $ head xs] ++ (map g $ tail $ init xs) ++ [h $ last xs] + +mapSep :: (HasVoice a, Ord v, v ~ Voice a) => (a -> b) -> (a -> b) -> (a -> b) -> Score a -> Score b +mapSep f g h sc = fixDur . mapVoices (fmap $ mapSepPart f g h) $ sc + where + fixDur a = padAfter (duration sc - duration a) a + +mapSepPart :: (a -> b) -> (a -> b) -> (a -> b) -> Score a -> Score b +mapSepPart f g h sc = mconcat . mapSepL (fmap f) (fmap g) (fmap h) . fmap toSc . perform $ sc + where + fixDur a = padAfter (duration sc - duration a) a + toSc (t,d,x) = delay (t .-. 0) . stretch d $ note x + third f (a,b,c) = (a,b,f c) + +padAfter :: Duration -> Score a -> Score a +padAfter d a = a |> (rest^*d) + + diff --git a/src/Music/Score/Part.hs b/src/Music/Score/Part.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Part.hs @@ -0,0 +1,113 @@ + +{-# LANGUAGE + TypeFamilies, + DeriveFunctor, + DeriveFoldable, + GeneralizedNewtypeDeriving #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +-- Provides a musical score represenation. +-- +------------------------------------------------------------------------------------- + +module Music.Score.Part ( + Part(..) + ) where + +import Prelude hiding (foldr, concat, foldl, mapM, concatMap, maximum, sum, minimum) + +import Data.Semigroup +import Control.Applicative +import Control.Monad (ap, join, MonadPlus(..)) +import Data.Foldable +import Data.Traversable +import Data.Maybe +import Data.Either +import Data.Function (on) +import Data.Ord (comparing) +import Data.Ratio +import Data.VectorSpace +import Data.AffineSpace + +import Music.Score.Time +import Music.Score.Duration + +------------------------------------------------------------------------------------- +-- Part type +------------------------------------------------------------------------------------- + +-- | +-- A part is a sorted list of relative-time notes and rests. +-- +-- Part is a 'Monoid' under sequential composition. 'mempty' is the empty part and 'mappend' +-- appends parts. +-- +-- Part has an 'Applicative' instance derived from the 'Monad' instance. +-- +-- Part is a 'Monad'. 'return' creates a part containing a single value of duration +-- one, and '>>=' transforms the values of a part, allowing the addition and +-- removal of values under relative duration. Perhaps more intuitively, 'join' scales +-- each inner part to the duration of the outer part, then removes the +-- intermediate structure. +-- +-- > let p = Part [(1, Just 0), (2, Just 1)] :: Part Int +-- > +-- > p >>= \x -> Part [ (1, Just $ toEnum $ x+65), +-- > (3, Just $ toEnum $ x+97) ] :: Part Char +-- > +-- > ===> Part {getPart = [ (1 % 1,Just 'A'), +-- > (3 % 1,Just 'a'), +-- > (2 % 1,Just 'B'), +-- > (6 % 1,Just 'b') ]} +-- +-- Part is a 'VectorSpace' using sequential composition as addition, and time scaling +-- as scalar multiplication. +-- +newtype Part a = Part { getPart :: [(Duration, a)] } + deriving (Eq, Ord, Show, Functor, Foldable, Monoid) + +instance Semigroup (Part a) where + (<>) = mappend + +instance Applicative Part where + pure = return + (<*>) = ap + +instance Monad Part where + return a = Part [(1, a)] + a >>= k = join' $ fmap k a + where + join' (Part ps) = foldMap (uncurry (*^)) ps + +instance AdditiveGroup (Part a) where + zeroV = mempty + (^+^) = mappend + negateV = id + +instance VectorSpace (Part a) where + type Scalar (Part a) = Duration + n *^ Part as = Part (fmap (first (n*^)) as) + +instance HasDuration (Part a) where + duration (Part []) = 0 + duration (Part as) = sum (fmap fst as) + + + + + + +list z f [] = z +list z f xs = f xs + +first f (x,y) = (f x, y) +second f (x,y) = (x, f y) diff --git a/src/Music/Score/Pitch.hs b/src/Music/Score/Pitch.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Pitch.hs @@ -0,0 +1,109 @@ + +{-# LANGUAGE + TypeFamilies, + DeriveFunctor, + DeriveFoldable, + FlexibleInstances, + GeneralizedNewtypeDeriving #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +-- Provides a musical score represenation. +-- +------------------------------------------------------------------------------------- + + +module Music.Score.Pitch ( + HasPitch(..), + PitchT(..), + getPitches, + setPitches, + modifyPitches, + ) where + +import Control.Monad (ap, mfilter, join, liftM, MonadPlus(..)) +import Data.String +import Data.Foldable +import Data.Traversable +import qualified Data.List as List +import Data.VectorSpace +import Data.AffineSpace +import Data.Ratio + +import Music.Score.Part +import Music.Score.Score +import Music.Score.Duration +import Music.Score.Time +import Music.Score.Ties + +class HasPitch a where + -- | + -- Associated pitch type. Should implement 'Eq' and 'Show' to be usable. + -- + type Pitch a :: * + + -- | + -- Get the pitch of the given note. + -- + getPitch :: a -> Pitch a + + -- | + -- Set the pitch of the given note. + -- + setPitch :: Pitch a -> a -> a + + -- | + -- Modify the pitch of the given note. + -- + modifyPitch :: (Pitch a -> Pitch a) -> a -> a + + setPitch n = modifyPitch (const n) + modifyPitch f x = x + + +newtype PitchT p a = PitchT { getPitchT :: (p, a) } + deriving (Eq, Ord, Show, Functor) + +instance HasPitch (PitchT p a) where + type Pitch (PitchT p a) = p + getPitch (PitchT (v,_)) = v + modifyPitch f (PitchT (v,x)) = PitchT (f v, x) + +instance HasPitch () where { type Pitch () = () ; getPitch = id; modifyPitch = id } +instance HasPitch Double where { type Pitch Double = Double ; getPitch = id; modifyPitch = id } +instance HasPitch Float where { type Pitch Float = Float ; getPitch = id; modifyPitch = id } +instance HasPitch Int where { type Pitch Int = Int ; getPitch = id; modifyPitch = id } +instance HasPitch Integer where { type Pitch Integer = Integer ; getPitch = id; modifyPitch = id } +instance Integral a => HasPitch (Ratio a) where { type Pitch (Ratio a) = (Ratio a) ; getPitch = id; modifyPitch = id } + +-- | +-- Get all pitches in the given score. Returns a list of pitches. +-- +-- > Score a -> [Pitch] +-- +getPitches :: (HasPitch a, Eq v, v ~ Pitch a, Foldable s) => s a -> [Pitch a] +getPitches = List.nub . fmap getPitch . toList + +-- | +-- Set all pitches in the given score. +-- +-- > Pitch -> Score a -> Score a +-- +setPitches :: (HasPitch a, Functor s) => Pitch a -> s a -> s a +setPitches n = fmap (setPitch n) + +-- | +-- Modify all pitches in the given score. +-- +-- > (Pitch -> Pitch) -> Score a -> Score a +-- +modifyPitches :: (HasPitch a, Functor s) => (Pitch a -> Pitch a) -> s a -> s a +modifyPitches n = fmap (modifyPitch n) diff --git a/src/Music/Score/Rhythm.hs b/src/Music/Score/Rhythm.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Rhythm.hs @@ -0,0 +1,245 @@ + +{-# LANGUAGE + TypeFamilies, + DeriveFunctor, + DeriveFoldable, + GeneralizedNewtypeDeriving, + ScopedTypeVariables #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +-- Provides a musical score represenation. +-- +------------------------------------------------------------------------------------- + +module Music.Score.Rhythm ( + -- * Rhythm type + Rhythm(..), + + -- * Quantization + quantize, + dotMod, + ) where + +import Prelude hiding (foldr, concat, foldl, mapM, concatMap, maximum, sum, minimum) + +import Data.Semigroup +import Control.Applicative +import Control.Monad (ap, join, MonadPlus(..)) +import Data.Maybe +import Data.Either +import Data.Foldable +import Data.Traversable +import Data.Function (on) +import Data.Ord (comparing) +import Data.Ratio +import Data.VectorSpace + +import Text.Parsec hiding ((<|>)) +import Text.Parsec.Pos + +import Music.Score.Time +import Music.Score.Duration +import Music.Score.Ties + + +data Rhythm a + = Beat Duration a -- d is divisible by 2 + | Dotted Int (Rhythm a) -- n > 0. + | Tuplet Duration (Rhythm a) -- d is an emelent of 'tupletMods'. + | Bound Duration (Rhythm a) -- tied from duration + | Rhythms [Rhythm a] -- normal note sequence + deriving (Eq, Show, Functor, Foldable) + -- RInvTuplet Duration (Rhythm a) + +instance Semigroup (Rhythm a) where + (<>) = mappend + +-- Catenates using 'Rhythms' +instance Monoid (Rhythm a) where + mempty = Rhythms [] + Rhythms as `mappend` Rhythms bs = Rhythms (as <> bs) + r `mappend` Rhythms bs = Rhythms ([r] <> bs) + Rhythms as `mappend` r = Rhythms (as <> [r]) + +instance AdditiveGroup (Rhythm a) where + zeroV = error "No zeroV for (Rhythm a)" + (^+^) = error "No ^+^ for (Rhythm a)" + negateV = error "No negateV for (Rhythm a)" + +instance VectorSpace (Rhythm a) where + type Scalar (Rhythm a) = Duration + a *^ Beat d x = Beat (a*d) x + +Beat d x `subDur` d' = Beat (d-d') x + +instance HasDuration (Rhythm a) where + duration (Beat d _) = d + duration (Dotted n a) = duration a * dotMod n + duration (Tuplet c a) = duration a * c + duration (Bound d a) = duration a + d + duration (Rhythms as) = sum (fmap duration as) + +quantize :: [(Duration, a)] -> Either String (Rhythm a) +quantize = quantize' (atEnd rhythm) + + +-- Internal... + +testQuantize :: [Duration] -> Either String (Rhythm ()) +testQuantize = quantize' (atEnd rhythm) . fmap (\x->(x,())) + +dotMod :: Int -> Duration +dotMod n = dotMods !! (n-1) + +-- [3/2, 7/4, 15/8, 31/16 ..] +dotMods :: [Duration] +dotMods = zipWith (/) (fmap pred $ drop 2 times2) (drop 1 times2) + where + times2 = iterate (*2) 1 + +tupletMods :: [Duration] +tupletMods = [2/3, 4/5, {-4/6,-} 4/7, 8/9] + + +-- 3/2 for dots +-- 2/3, 4/5, 4/6, 4/7, 8/9, 8/10, 8/11 for ordinary tuplets +-- 3/2, 6/4 for inverted tuplets + +data RState = RState { + timeMod :: Duration, -- time modification; notatedDur * timeMod = actualDur + timeSub :: Duration, -- time subtraction (in bound note) + tupleDepth :: Int + } + +instance Monoid RState where + mempty = RState { timeMod = 1, timeSub = 0, tupleDepth = 0 } + a `mappend` _ = a + +modifyTimeMod :: (Duration -> Duration) -> RState -> RState +modifyTimeMod f (RState tm ts td) = RState (f tm) ts td + +modifyTimeSub :: (Duration -> Duration) -> RState -> RState +modifyTimeSub f (RState tm ts td) = RState tm (f ts) td + +modifyTupleDepth :: (Int -> Int) -> RState -> RState +modifyTupleDepth f (RState tm ts td) = RState tm ts (f td) + +-- | +-- A @RhytmParser a b@ converts (Part a) to b. +type RhythmParser a b = Parsec [(Duration, a)] RState b + +quantize' :: RhythmParser a b -> [(Duration, a)] -> Either String b +quantize' p = left show . runParser p mempty "" + +-- Matches a (duration, value) pair iff the predicate matches, returns beat +match :: (Duration -> a -> Bool) -> RhythmParser a (Rhythm a) +match p = tokenPrim show next test + where + show x = "" + next pos _ _ = updatePosChar pos 'x' + test (d,x) = if p d x then Just (Beat d x) else Nothing + +-- Matches any rhythm +rhythm :: RhythmParser a (Rhythm a) +rhythm = Rhythms <$> Text.Parsec.many1 (rhythm' <|> bound) + +rhythmNoBound :: RhythmParser a (Rhythm a) +rhythmNoBound = Rhythms <$> Text.Parsec.many1 rhythm' + +rhythm' :: RhythmParser a (Rhythm a) +rhythm' = mzero + <|> beat + <|> dotted + <|> tuplet + +-- Matches a beat divisible by 2 (notated) +beat :: RhythmParser a (Rhythm a) +beat = do + RState tm ts _ <- getState + (\d -> (d^/tm) `subDur` ts) <$> match (\d _ -> + d - ts > 0 + && + isDivisibleBy 2 (d / tm - ts)) -- TODO or is it (d - ts) / tm + +-- | Matches a dotted rhythm +dotted :: RhythmParser a (Rhythm a) +dotted = msum . fmap dotted' $ [1..2] -- max 2 dots + +dotted' :: Int -> RhythmParser a (Rhythm a) +dotted' n = do + modifyState $ modifyTimeMod (* dotMod n) + a <- beat + modifyState $ modifyTimeMod (/ dotMod n) + return (Dotted n a) + + +-- | Matches a bound rhythm +bound :: RhythmParser a (Rhythm a) +bound = bound' (1/2) + + +bound' :: Duration -> RhythmParser a (Rhythm a) +bound' d = do + modifyState $ modifyTimeSub (+ d) + a <- rhythm' + modifyState $ modifyTimeSub (subtract d) + return $ Bound d a + +-- | Matches a tuplet +tuplet :: RhythmParser a (Rhythm a) +tuplet = msum . fmap tuplet' $ tupletMods + +-- tuplet' 2/3 for triplet, 4/5 for quintuplet etc +tuplet' :: Duration -> RhythmParser a (Rhythm a) +tuplet' d = do + RState _ _ depth <- getState + onlyIf (depth < 1) $ do -- max 1 nested tuplets + modifyState $ modifyTimeMod (* d) + . modifyTupleDepth succ + a <- rhythmNoBound + modifyState $ modifyTimeMod (/ d) + . modifyTupleDepth pred + return (Tuplet d a) + + + +-- | +-- Succeed only if the entire input is consumed. +-- +atEnd :: RhythmParser a b -> RhythmParser a b +atEnd p = do + x <- p + notFollowedBy' anyToken' "end of input" + return x + where + notFollowedBy' p = try $ (try p >> unexpected "") <|> return () + anyToken' = tokenPrim (const "") (\pos _ _ -> pos) Just + +onlyIf :: MonadPlus m => Bool -> m b -> m b +onlyIf b p = if b then p else mzero + +logBaseR :: forall a . (RealFloat a, Floating a) => Rational -> Rational -> a +logBaseR k n + | isInfinite (fromRational n :: a) = logBaseR k (n/k) + 1 +logBaseR k n + | isDenormalized (fromRational n :: a) = logBaseR k (n*k) - 1 +logBaseR k n = logBase (fromRational k) (fromRational n) + +-- As it sounds +isDivisibleBy :: Duration -> Duration -> Bool +isDivisibleBy n = (== 0.0) . snd . properFraction . logBaseR (toRational n) . toRational + + +single x = [x] + +left f (Left x) = Left (f x) +left f (Right y) = Right y diff --git a/src/Music/Score/Score.hs b/src/Music/Score/Score.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Score.hs @@ -0,0 +1,228 @@ + +{-# LANGUAGE + TypeFamilies, + DeriveFunctor, + DeriveFoldable, + GeneralizedNewtypeDeriving #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +-- Provides a musical score represenation. +-- +------------------------------------------------------------------------------------- + +module Music.Score.Score ( + Score(..), + rest, + note, + -- filterS, + perform, + performRelative + ) where + +import Prelude hiding (foldr, concat, foldl, mapM, concatMap, maximum, sum, minimum) + +import Data.Semigroup +import Control.Applicative +import Control.Monad (ap, join, MonadPlus(..)) +import Data.Foldable +import Data.Traversable +import Data.Maybe +import Data.Either +import Data.Function (on) +import Data.Ord (comparing) +import Data.Ratio +import Data.VectorSpace +import Data.AffineSpace +import qualified Data.Map as Map +import qualified Data.List as List + +import Music.Pitch.Literal +import Music.Dynamics.Literal + +import Music.Score.Time +import Music.Score.Duration + +------------------------------------------------------------------------------------- +-- Score type +------------------------------------------------------------------------------------- + +-- | +-- A score is a sorted list of absolute time notes and rests. A rest is a duration and +-- a note is a value and a duration. +-- +-- Score is a 'Monoid' under parallel composition. 'mempty' is a score of no parts. +-- For sequential composition of scores, use '|>'. +-- +-- Score has an 'Applicative' instance derived from the 'Monad' instance. Not sure it is useful. +-- +-- Score is a 'Monad'. 'return' creates a score containing a single note of +-- duration one, and '>>=' transforms the values of a score, while allowing +-- transformations of time and duration. More intuitively, 'join' scales and +-- offsets each inner score to fit into an outer score, then removes the intermediate +-- structure. +-- +-- > let s = Score [(0, 1, Just 0), (1, 2, Just 1)] :: Score Int +-- > +-- > s >>= \x -> Score [ (0, 1, Just $ toEnum $ x+65), +-- > (1, 3, Just $ toEnum $ x+97) ] :: Score Char +-- > +-- > ===> Score {getScore = [ (0 % 1, 1 % 1, Just 'A'), +-- > (1 % 1, 3 % 1, Just 'a'), +-- > (1 % 1, 2 % 1, Just 'B'), +-- > (3 % 1, 6 % 1, Just 'b') ]} +-- +-- Score is an instance of 'VectorSpace' using sequential composition as addition, +-- and time scaling as scalar multiplication. +-- +newtype Score a = Score { getScore :: [(Time, Duration, Maybe a)] } + deriving ({-Eq, Ord, -}Show, Functor, Foldable) + +-- TODO invariant that the list is sorted + + +-- Performance equality needeed because of rests... + +instance Eq a => Eq (Score a) where + a == b = perform a == perform b + +instance Ord a => Ord (Score a) where + a `compare` b = perform a `compare` perform b + +instance Semigroup (Score a) where + (<>) = mappend + +-- Equivalent to the derived Monoid, except for the sorted invariant. +instance Monoid (Score a) where + mempty = Score [] + Score as `mappend` Score bs = Score (as `m` bs) + where + m = mergeBy (comparing fst3) + fst3 (a,b,c) = a + +instance Applicative Score where + pure = return + (<*>) = ap + +instance Alternative Score where + empty = mempty + (<|>) = mappend + +-- Satisfies left distribution +instance MonadPlus Score where + mzero = mempty + mplus = mappend + +instance Monad Score where + return = note + a >>= k = join' $ fmap k a + where + join' sc = mconcat $ toList $ mapWithTimeDur (\t d -> fmap (delay t . (d*^) )) $ sc + +mapWithTimeDur :: (Duration -> Duration -> Maybe a -> Maybe b) -> Score a -> Score b +mapWithTimeDur f = Score . fmap (liftTimeDur f) . getScore + +liftTimeDur :: (Duration -> Duration -> Maybe a -> Maybe b) -> (Time, Duration, Maybe a) -> (Time, Duration, Maybe b) +liftTimeDur f (t,d,x) = case f (t2d t) d x of + Nothing -> (t,d,Nothing) + Just y -> (t,d,Just y) + where + t2d = Duration . getTime + +instance AdditiveGroup (Score a) where + zeroV = mempty + (^+^) = mappend + negateV = id + +instance VectorSpace (Score a) where + type Scalar (Score a) = Duration + d *^ Score sc = Score . fmap (first3 (^* d2t d) . second3 (^* d)) $ sc + where + first3 f (a,b,c) = (f a,b,c) + second3 f (a,b,c) = (a,f b,c) + d2t = Time . getDuration + +instance Delayable (Score a) where + d `delay` Score sc = Score . fmap (first3 (.+^ d)) $ sc + where + first3 f (a,b,c) = (f a,b,c) + +instance HasOnset (Score a) where + onset (Score []) = 0 + -- onset (Score xs) = minimum (fmap on xs) where on (t,d,x) = t + onset (Score xs) = on (head xs) where on (t,d,x) = t + offset (Score []) = 0 + offset (Score xs) = maximum (fmap off xs) where off (t,d,x) = t + (Time . getDuration $ d) + -- Note: this version of onset is lazier, but depends on the invariant above + +instance HasDuration (Score a) where + duration x = offset x .-. onset x + +instance IsPitch a => IsPitch (Score a) where + fromPitch = pure . fromPitch + +instance IsDynamics a => IsDynamics (Score a) where + fromDynamics = pure . fromDynamics + + +-- | +-- Create a score of duration one with no values. +-- +rest :: Score a +rest = Score [(0,1,Nothing)] + +-- | +-- Create a score of duration one with the given value. Equivalent to 'pure' and 'return'. +-- +note :: a -> Score a +note x = Score [(0,1,Just x)] + +{- +-- Use mfilter instead of this + +filterS :: (a -> Bool) -> Score a -> Score a +filterS f = Score . filter g . getScore + where + g (t,d,Nothing) = True + g (t,d,(Just x)) = f x +-} + +perform :: Score a -> [(Time, Duration, a)] +perform = removeRests . getScore + where + removeRests = catMaybes . fmap propagateRest + propagateRest (t, d, Just x) = Just (t, d, x) + propagateRest (t, d, Nothing) = Nothing + +performRelative :: Score a -> [(Time, Duration, a)] +performRelative = toRel . perform + where + toRel = snd . mapAccumL g 0 + g now (t,d,x) = (t, (t-now,d,x)) + + + + + + + + + +list z f [] = z +list z f xs = f xs + +first f (x,y) = (f x, y) +second f (x,y) = (x, f y) + + +mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a] +mergeBy f as bs = List.sortBy f $ as <> bs + diff --git a/src/Music/Score/Ties.hs b/src/Music/Score/Ties.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Ties.hs @@ -0,0 +1,139 @@ + +{-# LANGUAGE + TypeFamilies, + DeriveFunctor, + DeriveFoldable, + FlexibleInstances, + GeneralizedNewtypeDeriving #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +-- Provides a musical score represenation. +-- +------------------------------------------------------------------------------------- + + +module Music.Score.Ties ( + Tiable(..), + TieT(..), + splitTies, + splitTiesSingle, + splitTiesPart, + ) where + +import Data.Ratio +import qualified Data.List as List +import Data.VectorSpace +import Data.AffineSpace + + +import Music.Score.Part +import Music.Score.Score +import Music.Score.Duration +import Music.Score.Time + + + +-- | +-- Class of types that can be tied. +-- +class Tiable a where + -- | Split elements into beginning and end and add tie. + -- Begin properties goes to the first tied note, and end properties to the latter. + + -- The first returned element will have the original onset. + -- + toTied :: a -> (a, a) + +newtype TieT a = TieT { getTieT :: (Bool, a, Bool) } + deriving (Eq, Ord, Show, Functor) + +-- These are note really tiable..., but Tiable a => (Bool,a,Bool) would be +instance Tiable Double where toTied x = (x,x) +instance Tiable Float where toTied x = (x,x) +instance Tiable Int where toTied x = (x,x) +instance Tiable Integer where toTied x = (x,x) +instance Tiable () where toTied x = (x,x) +instance Tiable (Ratio a) where toTied x = (x,x) + +instance Tiable a => Tiable (Maybe a) where + toTied Nothing = (Nothing, Nothing) + toTied (Just a) = (Just b, Just c) where (b,c) = toTied a + +instance Tiable a => Tiable (TieT a) where + toTied (TieT (prevTie, a, _)) = (TieT (prevTie, b, True), TieT (True, c, False)) + where (b,c) = toTied a + +-- | +-- /Not implemented/ +-- Split all notes that cross a barlines into a pair of tied notes. +-- +splitTies :: Tiable a => Score a -> Score a +splitTies = error "splitTies: Not implemented" + +-- | +-- Split all notes that cross a barlines into a pair of tied notes. +-- Note: only works for single-part scores (with no overlapping events). +-- +splitTiesSingle :: Tiable a => Score a -> Score a +splitTiesSingle = partToSingleScore . splitTiesPart . singleScoreToPart + +partToSingleScore :: Part (Maybe a) -> Score a +partToSingleScore = Score . accumTime . getPart + where + accumTime = snd . List.mapAccumL g 0 + where + g t (d, x) = (t .+^ d, (t, d, x)) + +singleScoreToPart :: Score a -> Part (Maybe a) +singleScoreToPart sc = Part . movePart . throwTime . getScore $ sc + where + throwTime = fmap g where g (t,d,x) = (d,x) + d = onset sc .-. 0 + movePart = if (d == 0) then id else ([(d, Nothing)] ++) + +-- | +-- Split all notes that cross a barlines into a pair of tied notes. +-- +splitTiesPart :: Tiable a => Part a -> Part a +splitTiesPart = Part . concat . snd . List.mapAccumL g 0 . getPart + where + g t (d, x) = (t + d, occs) + where + (_, barTime) = properFraction t + remBarTime = 1 - barTime + occs = splitDur remBarTime (d,x) + +-- | +-- Split an event into a part the given duration, and parts shorter than or equal to one. +-- The returned list is always non-empty. +-- +-- > sum $ fmap fst $ splitDur s (x,a) = x +-- +splitDur :: Tiable a => Duration -> (Duration, a) -> [(Duration, a)] +splitDur s x = case splitDur' s x of + (a, Nothing) -> a : [] + (a, Just b) -> a : splitDur 1 b + +-- FIXME completely assumes bar dur 1, see #36 + +-- | +-- Extract the the first part of a given duration. If the note is shorter than the given duration, +-- return it and @Nothing@. Otherwise return the extracted part, and the rest. +-- +-- > splitDur s (d,a) +-- +splitDur' :: Tiable a => Duration -> (Duration, a) -> ((Duration, a), Maybe (Duration, a)) +splitDur' s (d,a) | d <= s = ((d,a), Nothing) + | otherwise = ((s,b), Just (d-s, c)) where (b,c) = toTied a + + + diff --git a/src/Music/Score/Time.hs b/src/Music/Score/Time.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Time.hs @@ -0,0 +1,120 @@ + +{-# LANGUAGE + TypeFamilies, + DeriveFunctor, + DeriveFoldable, + GeneralizedNewtypeDeriving #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +-- Provides a musical score represenation. +-- +------------------------------------------------------------------------------------- + +module Music.Score.Time where + +import Prelude hiding (foldr, concat, foldl, mapM, concatMap, maximum, sum, minimum) + +import Data.Semigroup +import Control.Applicative +import Data.Traversable +import Data.Maybe +import Data.Either +import Data.Function (on) +import Data.Ord (comparing) +import Data.Ratio +import Data.VectorSpace +import Data.AffineSpace + +import Music.Score.Duration + +------------------------------------------------------------------------------------- +-- Time type +------------------------------------------------------------------------------------- + +-- | +-- This type represents absolute time in seconds a known reference time. +-- The reference time can be any time, but is usually the the beginning of the +-- musical performance. +-- +-- Times forms an affine space with durations as the underlying vector space, +-- that is, we can add a time to a duration to get a new time using '.+^', +-- take the difference of two times to get a duration using '.-.'. +-- +newtype Time = Time { getTime::Rational } + deriving (Eq, Ord, Num, Enum, Real, Fractional, RealFrac) + -- Note: no Floating as we want to be able to switch to rational + +instance Show Time where + show = show . getTime + +instance AdditiveGroup Time where + zeroV = 0 + (^+^) = (+) + negateV = negate + +instance VectorSpace Time where + type Scalar Time = Time + (*^) = (*) + +instance InnerSpace Time where (<.>) = (*) + +instance AffineSpace Time where + type Diff Time = Duration + a .-. b = t2d $ a - b where t2d = Duration . getTime + a .+^ b = a + d2t b where d2t = Time . getDuration + +-- | +-- Class of types with a position in time. +-- +-- Onset and offset are logical start and stop time, rather than actual sounding time, +-- or to put it differently, the time of the attack and damp actions on an instrument, +-- rather than the actual beginning or end of the sound. +-- +-- If a type has an instance for both 'HasOnset' and 'HasDuration', the following laws +-- should hold: +-- +-- > duration a = offset a - onset a +-- > offset a >= onset a +-- +-- implying +-- +-- > duration a >= 0 +-- +-- +class HasOnset a where + -- |  + -- Get the onset of the given value. + -- + onset :: a -> Time + + -- |  + -- Get the offset of the given value. + -- + offset :: a -> Time + +instance HasOnset a => HasOnset (WrappedMonoid a) where + onset = onset . unwrapMonoid + offset = offset . unwrapMonoid + + +class HasPreOnset a where + preOnset :: a -> Time + +class HasPostOnset a where + postOnset :: a -> Time + +class HasPostOffset a where + postOffset :: a -> Time + + + + diff --git a/src/Music/Score/Track.hs b/src/Music/Score/Track.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Track.hs @@ -0,0 +1,143 @@ + +{-# LANGUAGE + TypeFamilies, + DeriveFunctor, + DeriveFoldable, + GeneralizedNewtypeDeriving #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +-- Provides a musical score represenation. +-- +------------------------------------------------------------------------------------- + +module Music.Score.Track ( + Track(..) + ) where + +import Prelude hiding (foldr, concat, foldl, mapM, concatMap, maximum, sum, minimum) + +import Data.Semigroup +import Control.Applicative +import Control.Monad (ap, join, MonadPlus(..)) +import Data.Foldable +import Data.Traversable +import Data.Maybe +import Data.Either +import Data.Function (on) +import Data.Ord (comparing) +import Data.Ratio +import Data.VectorSpace +import Data.AffineSpace +import qualified Data.Map as Map +import qualified Data.List as List + +import Music.Score.Time +import Music.Score.Duration + +------------------------------------------------------------------------------------- +-- Track type +------------------------------------------------------------------------------------- + +-- | +-- A track is a sorted list of absolute-time occurences. +-- +-- Track is a 'Monoid' under parallel composition. 'mempty' is the empty track and 'mappend' +-- interleaves values. +-- +-- Track has an 'Applicative' instance derived from the 'Monad' instance. +-- +-- Track is a 'Monad'. 'return' creates a track containing a single value at time +-- zero, and '>>=' transforms the values of a track, allowing the addition and +-- removal of values relative to the time of the value. Perhaps more intuitively, +-- 'join' delays each inner track to start at the offset of an outer track, then +-- removes the intermediate structure. +-- +-- > let t = Track [(0, 65),(1, 66)] +-- > +-- > t >>= \x -> Track [(0, 'a'), (10, toEnum x)] +-- > +-- > ==> Track {getTrack = [ (0.0, 'a'), +-- > (1.0, 'a'), +-- > (10.0, 'A'), +-- > (11.0, 'B') ]} +-- +-- Track is an instance of 'VectorSpace' using parallel composition as addition, +-- and time scaling as scalar multiplication. +-- +newtype Track a = Track { getTrack :: [(Time, a)] } + deriving (Eq, Ord, Show, Functor, Foldable) + +instance Semigroup (Track a) where + (<>) = mappend + +-- Equivalent to the derived Monoid, except for the sorted invariant. +instance Monoid (Track a) where + mempty = Track [] + Track as `mappend` Track bs = Track (as `m` bs) + where + m = mergeBy (comparing fst) + +instance Applicative Track where + pure = return + (<*>) = ap + +instance Monad Track where + return a = Track [(0, a)] + a >>= k = join' . fmap k $ a + where + join' (Track ts) = foldMap (uncurry delay') $ ts + delay' t = delay (Duration . getTime $ t) + +instance Alternative Track where + empty = mempty + (<|>) = mappend + +-- Satisfies left distribution +instance MonadPlus Track where + mzero = mempty + mplus = mappend + +instance AdditiveGroup (Track a) where + zeroV = mempty + (^+^) = mappend + negateV = id + +instance VectorSpace (Track a) where + type Scalar (Track a) = Time + n *^ Track tr = Track . (fmap (first (n*^))) $ tr + +instance Delayable (Track a) where + d `delay` Track tr = Track . fmap (first (.+^ d)) $ tr + +instance HasOnset (Track a) where + onset (Track []) = 0 + onset (Track xs) = minimum (fmap on xs) where on (t,x) = t + offset (Track []) = 0 + offset (Track xs) = maximum (fmap off xs) where off (t,x) = t + +instance HasDuration (Track a) where + duration x = offset x .-. onset x + +-- offset x = maximum (fmap off x) where off (t,x) = t + + + +list z f [] = z +list z f xs = f xs + +first f (x,y) = (f x, y) +second f (x,y) = (x, f y) + + +mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a] +mergeBy f as bs = List.sortBy f $ as <> bs + diff --git a/src/Music/Score/Voice.hs b/src/Music/Score/Voice.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Voice.hs @@ -0,0 +1,199 @@ + +{-# LANGUAGE + TypeFamilies, + DeriveFunctor, + DeriveFoldable, + FlexibleInstances, + OverloadedStrings, + GeneralizedNewtypeDeriving #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +-- Provides a musical score represenation. +-- +------------------------------------------------------------------------------------- + + +module Music.Score.Voice ( + HasVoice(..), + -- VoiceName(..), + VoiceT(..), + voices, + mapVoice, + mapVoices, + getVoices, + setVoices, + modifyVoices, + + -- ** Voice composition + (), + moveParts, + moveToPart, + ) where + +import Control.Monad (ap, mfilter, join, liftM, MonadPlus(..)) +import Data.Semigroup +import Data.String +import Data.Foldable +import Data.Ord (comparing) +import Data.Traversable +import qualified Data.List as List +import Data.VectorSpace +import Data.AffineSpace +import Data.Ratio + +import Music.Score.Part +import Music.Score.Score +import Music.Score.Duration +import Music.Score.Time +import Music.Score.Ties + + +class HasVoice a where + -- | + -- Associated voice type. Should implement 'Ord' and 'Show' to be usable. + -- + type Voice a :: * + + -- | + -- Get the voice of the given note. + -- + getVoice :: a -> Voice a + + -- | + -- Set the voice of the given note. + -- + setVoice :: Voice a -> a -> a + + -- | + -- Modify the voice of the given note. + -- + modifyVoice :: (Voice a -> Voice a) -> a -> a + + setVoice n = modifyVoice (const n) + modifyVoice f x = x + +-- newtype VoiceName = VoiceName { getVoiceName :: String } + -- deriving (Eq, Ord, IsString) +-- instance Show VoiceName where show = getVoiceName + +newtype VoiceT n a = VoiceT { getVoiceT :: (n, a) } + deriving (Eq, Ord, Show, Functor) + +instance HasVoice () where { type Voice () = Integer ; getVoice _ = 0 } +instance HasVoice Double where { type Voice Double = Integer ; getVoice _ = 0 } +instance HasVoice Float where { type Voice Float = Integer ; getVoice _ = 0 } +instance HasVoice Int where { type Voice Int = Integer ; getVoice _ = 0 } +instance HasVoice Integer where { type Voice Integer = Integer ; getVoice _ = 0 } +instance Integral a => HasVoice (Ratio a) where { type Voice (Ratio a) = Integer ; getVoice _ = 0 } + + + +-- | +-- Extract parts from the given score. Returns a list of single-part score. A dual of @pcat@. +-- +-- > Score a -> [Score a] +-- +voices :: (HasVoice a, Ord v, v ~ Voice a, MonadPlus s, Foldable s) => s a -> [s a] +voices sc = fmap (flip extract $ sc) (getVoices sc) + where + extract v = mfilter ((== v) . getVoice) + +-- | +-- Map over a single voice in the given score. +-- +-- > Voice -> (Score a -> Score a) -> Score a -> Score a +-- +mapVoice :: (Ord v, v ~ Voice a, HasVoice a, MonadPlus s, Foldable s, Enum b) => b -> (s a -> s a) -> s a -> s a +mapVoice n f = mapVoices (zipWith ($) (replicate (fromEnum n) id ++ [f] ++ repeat id)) + +-- | +-- Map over all voices in the given score. +-- +-- > ([Score a] -> [Score a]) -> Score a -> Score a +-- +mapVoices :: (HasVoice a, Ord v, v ~ Voice a, MonadPlus s, Foldable s) => ([s a] -> [s b]) -> s a -> s b +mapVoices f = msum . f . voices + +-- | +-- Get all voices in the given score. Returns a list of voices. +-- +-- > Score a -> [Voice] +-- +getVoices :: (HasVoice a, Ord v, v ~ Voice a, Foldable s) => s a -> [Voice a] +getVoices = List.sort . List.nub . fmap getVoice . toList + +-- | +-- Set all voices in the given score. +-- +-- > Voice -> Score a -> Score a +-- +setVoices :: (HasVoice a, Functor s) => Voice a -> s a -> s a +setVoices n = fmap (setVoice n) + +-- | +-- Modify all voices in the given score. +-- +-- > (Voice -> Voice) -> Score a -> Score a +-- +modifyVoices :: (HasVoice a, Functor s) => (Voice a -> Voice a) -> s a -> s a +modifyVoices n = fmap (modifyVoice n) + + + +-------------------------------------------------------------------------------- +-- Voice composition +-------------------------------------------------------------------------------- + +infixr 6 + +-- TODO use Alternative instead of (Functor + MonadPlus) ? + +-- | +-- Similar to '<>', but increases voices in the second part to prevent voice collision. +-- +() :: (Enum v, Ord v, v ~ Voice a, Functor s, MonadPlus s, Foldable s, HasVoice a) => s a -> s a -> s a +a b = a `mplus` moveParts offset b + where + -- max voice in a + 1 + offset = succ $ maximum' 0 $ fmap fromEnum $ getVoices a + + +-- | +-- Move down one voice (all parts). +-- +moveParts :: (Enum v, v ~ Voice a, Integral b, Functor s, HasVoice a) => b -> s a -> s a +moveParts x = modifyVoices (successor x) + +-- | +-- Move top-part to the specific voice (other parts follow). +-- +moveToPart :: (Enum v, v ~ Voice a, Functor s, HasVoice a) => v -> s a -> s a +moveToPart v = moveParts (fromEnum v) + + + + + + + + + +successor :: (Integral b, Enum a) => b -> a -> a +successor n | n < 0 = (!! fromIntegral (abs n)) . iterate pred + | n >= 0 = (!! fromIntegral n) . iterate succ + + +maximum' :: (Ord a, Foldable t) => a -> t a -> a +maximum' z = option z getMax . foldMap (Option . Just . Max) + +minimum' :: (Ord a, Foldable t) => a -> t a -> a +minimum' z = option z getMin . foldMap (Option . Just . Min) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,67 @@ + +module Main where + +import Music.Score + +{- +fj1 = sc $ melody [c,d] |> melody [eb,d]^/2 |> c +fj2 = sc $ melody [eb,f] |> g^*2 +fj3 = sc $ g^*(3/4) |> ab^*(1/4) |> melody [g,f,eb,d] ^/2 |> c +fj4 = c |> g_ |> c^*2 + +fj = rep 2 fj1 |> rep 2 fj2 |> rep 2 fj3 |> rep 2 fj4 + +fj' = mempty + <> setVoices "Violin I" (rep 10 fj) + <> setVoices "Violin II" (delay 8 $ (rep 10 fj)^*(2/3)) + <> setVoices "Viola" (delay 16 $ (rep 10 fj)^*(4/5)) + <> setVoices "Violoncello" (delay 24 $ (rep 10 fj)^*(4/7)) + +-- classic version... +fj'' = mempty + <> setVoices "Violin I" (rep 10 fj) + <> setVoices "Violin II" (delay 8 $ (rep 10 fj)) + <> setVoices "Viola" (delay 16 $ (rep 10 fj)) + <> setVoices "Violoncello" (delay 24 $ (rep 10 fj)) + +-- rep 0 x = mempty +-- rep n x = x |> rep (n-1) x +grp n p = rep n p^/n + +-- open$ (rep 3 $ grp 2 c |> grp 4 db |> grp 4 c |> (rest^*3)) + +testArtDyn = mempty + <> v (0+1) (rep 80 t^*(3*1)) + <> v (0+2) (rep 80 t^*(4*1)) + <> v (0+3) (rep 80 t^*(5*1)) + <> v (0+4) (rep 80 t^*(7*1)) + <> v (4+1) (rep 20 s^*(3*2)) + <> v (4+2) (rep 20 s^*(4*2)) + <> v (4+3) (rep 20 s^*(5*2)) + <> v (4+4) (rep 20 s^*(7*2)) + where + v x = setVoices (VoiceName $ "Violin I." ++ show x) + s, t :: Sc Double + s = mempty + |> (fmap (setLevel (-2.5) . setBeginSlur True . setBeginCresc True) c) + |> d + |> f + |> (fmap (setEndSlur True . setLevel (0.5) . setEndCresc True ) e) + t = mempty + |> (fmap (setLevel (-2.5) . setBeginSlur True . setBeginCresc True) g) + |> a + |> bb + |> (fmap (setEndSlur True . setLevel (0.5) . setEndCresc True ) a) + +showScore :: Score Double -> String +showScore = show + +play = playMidiIO . (^* (60/100)) . sc +open = openXml . (^* (1/4)) . sc + +rep 0 x = mempty +rep n x = x |> rep (n-1) x + -} + +main = do + putStrLn "Testing Music.Score"