diff --git a/COPYING b/COPYING --- a/COPYING +++ b/COPYING @@ -9,14 +9,14 @@ * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of the nor the + * Neither the name of the Music Suite nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,14 @@ +#! /usr/bin/env runhaskell + +import Distribution.Simple +main = defaultMain + +-- import Data.Monoid +-- import System.Process +-- import Distribution.Simple +-- +-- main = defaultMainWithHooks simpleUserHooks { preBuild = preBuild' } +-- +-- preBuild' _ _ = do +-- runCommand "hackette cp Music.Score.Util src/Music/Score/Util.hs" +-- return mempty diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,4 +0,0 @@ -#! /usr/bin/env runhaskell - -> import Distribution.Simple -> main = defaultMain diff --git a/music-score.cabal b/music-score.cabal --- a/music-score.cabal +++ b/music-score.cabal @@ -1,6 +1,6 @@ name: music-score -version: 1.3.1 +version: 1.6 cabal-version: >= 1.10 author: Hans Hoglund maintainer: Hans Hoglund @@ -9,79 +9,113 @@ synopsis: Musical score and part representation. category: Music tested-with: GHC -build-type: Simple +build-type: Custom description: - Musical score and part representation. + Musical time struture, voices, tracks and scores. - This library is part of the Music Suite, see . + This library is part of the Music Suite, see . source-repository head type: git - location: git://github.com/hanshoglund/music-score.git + location: git://github.com/music-suite/music-score.git library build-depends: - base >= 4 && < 5, - QuickCheck >= 1.2 && < 1.3, - unix, - time, - random, + base >= 4 && < 5, + QuickCheck >= 1.2 && < 1.3, + + lens >= 4.0 && < 4.1, + -- time, + -- random, process, data-default, containers, - parsec, + comonad, + NumInstances, + + profunctors, transformers, monadplus, - prettify, - HCodecs, - musicxml2, - lilypond, + void, semigroups, + monoid-extras, nats, - pointed, semigroupoids, + musicxml2 == 1.6, + lilypond == 1.6, + HCodecs, vector-space, - music-pitch-literal, - music-dynamics-literal, - reenact + vector-space-points == 0.1.3, + music-pitch-literal == 1.6, + music-dynamics-literal == 1.6, + prettify, + parsec + -- reenact hs-source-dirs: src default-language: Haskell2010 exposed-modules: + Data.PairMonad + Control.Monad.Compose + Music.Time - Music.Time.Time - Music.Time.Duration Music.Time.Delayable Music.Time.Stretchable - Music.Time.Performable Music.Time.Onset - Music.Time.Pos + Music.Time.Juxtapose + Music.Time.Reverse + Music.Time.Time + Music.Time.Span + Music.Time.Reactive + Music.Time.Behavior Music.Score.Rhythm Music.Score + Music.Score.Note Music.Score.Track Music.Score.Voice Music.Score.Score Music.Score.Combinators + Music.Score.Convert Music.Score.Ties - Music.Score.Zip Music.Score.Part Music.Score.Chord + + Music.Score.Meta + Music.Score.Meta.Annotations + Music.Score.Meta.Attribution + Music.Score.Meta.Barline + Music.Score.Meta.Clef + Music.Score.Meta.Fermata + Music.Score.Meta.Key + Music.Score.Meta.RehearsalMark + Music.Score.Meta.Tempo + Music.Score.Meta.Time + Music.Score.Meta.Title + + Music.Score.Clef Music.Score.Pitch Music.Score.Articulation Music.Score.Dynamics Music.Score.Ornaments - Music.Score.Export.Midi + Music.Score.Export.Abc Music.Score.Export.Lilypond Music.Score.Export.MusicXml + Music.Score.Export.Midi + Music.Score.Import.Abc + Music.Score.Import.Lilypond + Music.Score.Import.Midi + + -- Need to expose these to allow GHCI development + Music.Score.Util + Music.Score.Export.Common other-modules: Music.Score.Instances - Music.Score.Export.Util -- executable "music-score-tests" -- hs-source-dirs: src test diff --git a/src/Control/Monad/Compose.hs b/src/Control/Monad/Compose.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Compose.hs @@ -0,0 +1,40 @@ + +-- | +-- Monadic composition. +-- +-- Based on an operator found in /Composing Monads/ by Jones and Duponcheel (1993). +-- +-- Should be moved to a separate package `control-monad-compose`. +-- +module Control.Monad.Compose ( + mjoin, + mbind + ) where + +import Control.Monad + +import Data.Set (Set) +import Data.Map (Map) +import Data.Typeable +import Data.Foldable (Foldable) +import Data.Traversable (Traversable) +import qualified Data.Foldable as F +import qualified Data.Traversable as T +import qualified Data.Set as Set +import qualified Data.Map as Map +import qualified Data.List as List + +-- Intution: +-- +-- Starts off with m (n (m (n a))) +-- Sequences inner structure to get m (m (n (n a))) +-- Folds outer level to get m (n (n a)) +-- Folds inner level to get m (n a) + +mjoin :: (Monad m, Monad n, Functor m, Traversable n) => m (n (m (n a))) -> m (n a) +mjoin = fmap join . join . fmap T.sequence + +mbind :: (Monad m, Monad n, Functor m, Traversable n) => (a -> m (n b)) -> m (n a) -> m (n b) +mbind = (join .) . fmap . (fmap join .) . T.mapM + + diff --git a/src/Data/PairMonad.hs b/src/Data/PairMonad.hs new file mode 100644 --- /dev/null +++ b/src/Data/PairMonad.hs @@ -0,0 +1,28 @@ + +{-# LANGUAGE + CPP, + StandaloneDeriving, + DeriveFoldable, + DeriveTraversable #-} + +module Data.PairMonad where + +import Control.Applicative + +-- #ifdef __HAS_LENS__ +import Control.Lens() +-- #endif __HAS_LENS__ + +import Data.Monoid +import Data.Foldable +import Data.Traversable + +-- Equivalent to the Monad Writer instance. +instance Monoid o => Monad ((,) o) where + return = pure + (o,a) >>= f = (o `mappend` o', a') where (o',a') = f a + +-- #ifndef __HAS_LENS__ +-- deriving instance Foldable ((,) o) +-- deriving instance Traversable ((,) o) +-- #endif __HAS_LENS__ diff --git a/src/Music/Score.hs b/src/Music/Score.hs --- a/src/Music/Score.hs +++ b/src/Music/Score.hs @@ -1,17 +1,4 @@ -{-# LANGUAGE - TypeFamilies, - DeriveFunctor, - DeriveFoldable, - DeriveDataTypeable, - GeneralizedNewtypeDeriving, - FlexibleInstances, - FlexibleContexts, - ConstraintKinds, - TypeOperators, - OverloadedStrings, - NoMonomorphismRestriction #-} - ------------------------------------------------------------------------------------- -- | -- Copyright : (c) Hans Hoglund 2012 @@ -33,67 +20,108 @@ module Data.Semigroup, module Data.VectorSpace, module Data.AffineSpace, + module Data.AffineSpace.Point, -- * Basic types - module Music.Pitch.Literal, - module Music.Dynamics.Literal, module Music.Time, -- * Musical container types + module Music.Score.Note, module Music.Score.Track, module Music.Score.Voice, module Music.Score.Score, + module Music.Score.Convert, -- * Manipulation + -- ** Combinators module Music.Score.Combinators, - module Music.Score.Zip, - module Music.Score.Part, + + -- ** Structure module Music.Score.Ties, + module Music.Score.Chord, + + -- ** Meta-information + module Music.Score.Meta, + module Music.Score.Meta.Title, + module Music.Score.Meta.Attribution, + module Music.Score.Meta.RehearsalMark, + module Music.Score.Meta.Barline, + module Music.Score.Meta.Clef, + module Music.Score.Meta.Fermata, + module Music.Score.Meta.Key, + module Music.Score.Meta.Time, + module Music.Score.Meta.Tempo, + module Music.Score.Meta.Annotations, + module Music.Score.Clef, + + -- ** Musical elements + module Music.Score.Part, module Music.Score.Pitch, module Music.Score.Dynamics, module Music.Score.Articulation, module Music.Score.Ornaments, - -- * Export + -- * Import and export + module Music.Score.Import.Abc, + module Music.Score.Import.Lilypond, + module Music.Score.Import.Midi, + + module Music.Score.Export.Abc, module Music.Score.Export.Midi, module Music.Score.Export.Lilypond, module Music.Score.Export.MusicXml, ) where -import Prelude hiding (foldr, concat, foldl, mapM, concatMap, maximum, sum, minimum) +import Control.Applicative +import Control.Monad hiding (mapM) +import Control.Monad.Plus +import Data.AffineSpace +import Data.AffineSpace.Point +import Data.Basis +import Data.Either +import Data.Foldable +import Data.Maybe +import Data.Ratio +import Data.Semigroup +import Data.Traversable +import Data.Typeable +import Data.VectorSpace hiding (Sum, getSum) -import Data.Semigroup -import Data.Ratio -import Control.Applicative -import Control.Monad hiding (mapM) -import Control.Monad.Plus -import Data.Maybe -import Data.Either -import Data.Foldable -import Data.Typeable -import Data.Traversable -import Data.VectorSpace hiding (Sum, getSum) -import Data.AffineSpace -import Data.Basis +import Music.Time -import Music.Time -import Music.Pitch.Literal -import Music.Dynamics.Literal +import Music.Score.Articulation +import Music.Score.Chord +import Music.Score.Clef +import Music.Score.Combinators +import Music.Score.Convert +import Music.Score.Dynamics +import Music.Score.Export.Abc +import Music.Score.Export.Lilypond +import Music.Score.Export.Midi +import Music.Score.Export.MusicXml +import Music.Score.Import.Abc +import Music.Score.Import.Lilypond +import Music.Score.Import.Midi +import Music.Score.Instances () +import Music.Score.Meta +import Music.Score.Meta.Annotations +import Music.Score.Meta.Attribution +import Music.Score.Meta.Barline +import Music.Score.Meta.Clef +import Music.Score.Meta.Fermata +import Music.Score.Meta.Key +import Music.Score.Meta.RehearsalMark +import Music.Score.Meta.Tempo +import Music.Score.Meta.Time +import Music.Score.Meta.Title +import Music.Score.Note +import Music.Score.Ornaments +import Music.Score.Part +import Music.Score.Pitch +import Music.Score.Rhythm +import Music.Score.Score +import Music.Score.Ties +import Music.Score.Track +import Music.Score.Voice -import Music.Score.Rhythm -import Music.Score.Track -import Music.Score.Voice -import Music.Score.Score -import Music.Score.Combinators -import Music.Score.Zip -import Music.Score.Pitch -import Music.Score.Ties -import Music.Score.Part -import Music.Score.Articulation -import Music.Score.Dynamics -import Music.Score.Ornaments -import Music.Score.Instances -import Music.Score.Export.Midi -import Music.Score.Export.Lilypond -import Music.Score.Export.MusicXml diff --git a/src/Music/Score/Articulation.hs b/src/Music/Score/Articulation.hs --- a/src/Music/Score/Articulation.hs +++ b/src/Music/Score/Articulation.hs @@ -1,14 +1,15 @@ -{-# LANGUAGE - TypeFamilies, - DeriveFunctor, - DeriveFoldable, - DeriveDataTypeable, - FlexibleInstances, - FlexibleContexts, - ConstraintKinds, - GeneralizedNewtypeDeriving, - NoMonomorphismRestriction #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} ------------------------------------------------------------------------------------- -- | @@ -20,15 +21,17 @@ -- Stability : experimental -- Portability : non-portable (TF,GNTD) -- --- Provides articulation. +-- Provides functions for manipulating articulation. -- ------------------------------------------------------------------------------------- module Music.Score.Articulation ( + -- * Representation HasArticulation(..), ArticulationT(..), + -- * Transformations -- ** Accents accent, marcato, @@ -50,19 +53,16 @@ ) where -import Data.Ratio -import Data.Foldable -import Data.Typeable -import Data.Semigroup -import qualified Data.List as List -import Data.VectorSpace -import Data.AffineSpace +import Control.Applicative +import Data.Foldable +import Data.Semigroup +import Data.Typeable -import Music.Score.Voice -import Music.Score.Score -import Music.Time -import Music.Score.Part -import Music.Score.Combinators +import Music.Dynamics.Literal +import Music.Pitch.Literal +import Music.Score.Combinators +import Music.Score.Part +import Music.Score.Score class HasArticulation a where setBeginSlur :: Bool -> a -> a @@ -71,44 +71,102 @@ 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, Typeable) +newtype ArticulationT a = ArticulationT { getArticulationT :: (((Any, Any, Any), (Sum Int, Sum Int)), a) } + deriving (Eq, Show, Ord, Functor, Foldable, Typeable, Applicative, Monad) +-- instance Monad ArticulationT where + -- return = undefined + -- return x = ArticulationT (Any False,Any False,0,0,x,False) + -- (>>=) = error "No ArticulationT.(>>=)" + +instance Semigroup a => Semigroup (ArticulationT a) where + ArticulationT (((es,us,bs),(al,sl)),a) <> ArticulationT (_,b) = ArticulationT (((es,us,bs),(al,sl)), a <> b) + +instance (Semigroup a, Monoid a) => Monoid (ArticulationT a) where + mempty = return mempty + mappend = (<>) + +instance IsPitch a => IsPitch (ArticulationT a) where + fromPitch l = return (fromPitch l) + +instance IsDynamics a => IsDynamics (ArticulationT a) where + fromDynamics l = return (fromDynamics l) + +instance HasArticulation (ArticulationT a) where + setEndSlur (Any -> es) (ArticulationT (((_ ,us,bs),(al,sl)),a)) = ArticulationT (((es,us,bs),(al,sl)),a) + setContSlur (Any -> us) (ArticulationT (((es,_ ,bs),(al,sl)),a)) = ArticulationT (((es,us,bs),(al,sl)),a) + setBeginSlur (Any -> bs) (ArticulationT (((es,us,_ ),(al,sl)),a)) = ArticulationT (((es,us,bs),(al,sl)),a) + setAccLevel (Sum -> al) (ArticulationT (((es,us,bs),(_ ,sl)),a)) = ArticulationT (((es,us,bs),(al,sl)),a) + setStaccLevel (Sum -> sl) (ArticulationT (((es,us,bs),(al,_ )),a)) = ArticulationT (((es,us,bs),(al,sl)),a) + +instance HasArticulation b => HasArticulation (a,b) where + setEndSlur n = fmap (setEndSlur n) + setContSlur n = fmap (setContSlur n) + setBeginSlur n = fmap (setBeginSlur n) + setAccLevel n = fmap (setAccLevel n) + setStaccLevel n = fmap (setStaccLevel n) + -------------------------------------------------------------------------------- -- Articulation -------------------------------------------------------------------------------- -- Accents -accent :: (HasEvents s, HasPart' a, HasArticulation a) => s a -> s a -marcato :: (HasEvents s, HasPart' a, HasArticulation a) => s a -> s a -accentAll :: (HasEvents s, HasPart' a, HasArticulation a) => s a -> s a -marcatoAll :: (HasEvents s, HasPart' a, HasArticulation a) => s a -> s a -accentLast :: (HasEvents s, HasPart' a, HasArticulation a) => s a -> s a -marcatoLast :: (HasEvents s, HasPart' a, HasArticulation a) => s a -> s a +-- | Add a normal accent at the beginning of each phrase in each part in the given score. +accent :: (HasPart' a, HasArticulation a) => Score a -> Score a accent = mapPhrase (setAccLevel 1) id id + +-- | Add a marcato accent at the beginning of each phrase in each part in the given score. +marcato :: (HasPart' a, HasArticulation a) => Score a -> Score a marcato = mapPhrase (setAccLevel 2) id id + +-- | Add a normal accent to all notes in the given score. +accentAll :: (HasPart' a, HasArticulation a) => Score a -> Score a accentAll = mapPhrase (setAccLevel 1) (setAccLevel 1) (setAccLevel 1) + +-- | Add a marcato accent to all notes in the given score. +marcatoAll :: (HasPart' a, HasArticulation a) => Score a -> Score a marcatoAll = mapPhrase (setAccLevel 2) (setAccLevel 2) (setAccLevel 2) + +-- | Add a normal accent at the end of each phrase in each part in the given score. +accentLast :: (HasPart' a, HasArticulation a) => Score a -> Score a accentLast = mapPhrase id id (setAccLevel 1) + +-- | Add a marcato accent at the end of each phrase in each part in the given score. +marcatoLast :: (HasPart' a, HasArticulation a) => Score a -> Score a marcatoLast = mapPhrase id id (setAccLevel 2) + -- Phrasing -tenuto :: (HasEvents s, HasPart' a, HasArticulation a) => s a -> s a -separated :: (HasEvents s, HasPart' a, HasArticulation a) => s a -> s a -staccato :: (HasEvents s, HasPart' a, HasArticulation a) => s a -> s a -portato :: (HasEvents s, HasPart' a, HasArticulation a) => s a -> s a -legato :: (HasEvents s, HasPart' a, HasArticulation a) => s a -> s a -spiccato :: (HasEvents s, HasPart' a, HasArticulation a) => s a -> s a +-- | Add tenuto marks to each phrase in each part in the given score. +tenuto :: (HasPart' a, HasArticulation a) => Score a -> Score a tenuto = mapPhrase (setStaccLevel (-2)) (setStaccLevel (-2)) (setStaccLevel (-2)) + +-- | Add combined staccato and tenuto marks to each phrase in each part in the given score. +separated :: (HasPart' a, HasArticulation a) => Score a -> Score a separated = mapPhrase (setStaccLevel (-1)) (setStaccLevel (-1)) (setStaccLevel (-1)) + +-- | Add staccato marks to each phrase in each part in the given score. +staccato :: (HasPart' a, HasArticulation a) => Score a -> Score a staccato = mapPhrase (setStaccLevel 1) (setStaccLevel 1) (setStaccLevel 1) + +-- | Add portato marks to each phrase in each part in the given score. +portato :: (HasPart' a, HasArticulation a) => Score a -> Score a portato = staccato . legato + +-- | Add legato marks to each phrase in each part in the given score. +legato :: (HasPart' a, HasArticulation a) => Score a -> Score a legato = mapPhrase (setBeginSlur True) id (setEndSlur True) + +-- | Add spiccatto marks to the given score. +spiccato :: (HasPart' a, HasArticulation a) => Score a -> Score a spiccato = mapPhrase (setStaccLevel 2) (setStaccLevel 2) (setStaccLevel 2) +-- | Remove all articulation from the given note or notes. resetArticulation :: HasArticulation c => c -> c resetArticulation = setBeginSlur False . setContSlur False . setEndSlur False . setAccLevel 0 . setStaccLevel 0 +-- Safe for tuple-like types +get1 = head . toList diff --git a/src/Music/Score/Chord.hs b/src/Music/Score/Chord.hs --- a/src/Music/Score/Chord.hs +++ b/src/Music/Score/Chord.hs @@ -1,14 +1,15 @@ -{-# LANGUAGE - TypeFamilies, - DeriveFunctor, - DeriveFoldable, - DeriveDataTypeable, - FlexibleInstances, - FlexibleContexts, - ConstraintKinds, - GeneralizedNewtypeDeriving, - NoMonomorphismRestriction #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} ------------------------------------------------------------------------------------- -- | @@ -20,53 +21,220 @@ -- Stability : experimental -- Portability : non-portable (TF,GNTD) -- --- Provides articulation. +-- Provides a representation for chords. -- ------------------------------------------------------------------------------------- module Music.Score.Chord ( + -- * Chord representation HasChord(..), ChordT(..), - flatten, + + -- * Voice separation + separateVoices, + mergePossible, + + -- * Chord transformations + takeNoteInChord, + dropNoteInChord, + takeNotesInChord, + dropNotesInChord, + mapSimultaneous, + simultaneous, + simultaneous', ) where -import Data.Ratio -import Data.Foldable -import Data.Typeable -import Data.Semigroup -import Data.VectorSpace -import Data.AffineSpace -import Control.Monad.Plus +import Prelude hiding (any, mapM_) -import Music.Score.Voice -import Music.Score.Score -import Music.Time -import Music.Score.Part -import Music.Score.Pitch -import Music.Score.Combinators +import Control.Lens hiding (perform) +import Control.Monad.Plus hiding (mapM_) +import Data.Foldable +import qualified Data.List as List +import qualified Data.List.NonEmpty as NonEmpty +import Data.Ord +import Data.Semigroup +import Data.Typeable +import Music.Score.Combinators +import Music.Score.Convert +import Music.Score.Note +import Music.Score.Part +import Music.Score.Score +import Music.Score.Voice +import Music.Score.Meta +import Music.Time + class HasChord a where type ChordNote a :: * + -- TODO use NonEmpty getChord :: a -> [ChordNote a] --- Actually we should use NonEmpty here --- Empty chords will cause error with HasPitch, among others +instance HasChord [a] where + type ChordNote [a] = a + getChord = id + +instance HasChord (ChordT a) where + type ChordNote (ChordT a) = a + getChord (ChordT as) = as + +-- TODO Use NonEmpty newtype ChordT a = ChordT { getChordT :: [a] } - deriving (Eq, Show, Ord, Functor, Foldable, Typeable) + deriving (Eq, Show, Ord, Monad, Functor, Monoid, Semigroup, Foldable, Typeable) --- instance HasChord +overlaps :: (HasOnset a, HasOffset a, HasOnset b, HasOffset b) => a -> b -> Bool +overlaps t u = not $ offset t <= onset u || offset u <= onset t --- Score a -> Score (ChordT a) +overlapsAny :: (Foldable t, HasOnset a, HasOffset a, HasOnset b, HasOffset b) => a -> t b -> Bool +overlapsAny x = any (overlaps x) --- Note: +notOverlaps :: (HasOnset a, HasOnset b, HasOffset a, HasOffset b) => a -> b -> Bool +x `notOverlaps` y = not (x `overlaps` y) + +hasOverlapping :: Score a -> Bool +hasOverlapping x = let ns = (^. notes) x in not $ null [(x,y) | x <- ns, y <- ns, x `overlaps` y, era x /= era y] + +-- | Heuristically merge voices if possible +mergePossible :: [Score a] -> [Score a] +mergePossible [] = [] +mergePossible (x:xs) = let + pick = x + (res, rest) = List.foldr mergeMaybe' (x, []) xs + in res : mergePossible rest + +mergeMaybe' x (y,rest) = if hasOverlapping (x <> y) then (x, y:rest) else (x <> y, rest) + +mergeMaybe x y = if hasOverlapping (x <> y) then (x, Just y) else (x <> y, Nothing) + + + +notOverlapsHead :: (HasOnset a, HasOnset b, HasOffset a, HasOffset b) => a -> [b] -> Bool +x `notOverlapsHead` [] = True +x `notOverlapsHead` xs = x `notOverlaps` head xs + +class Null a where + isNull :: a -> Bool +-- > isNull mempty +instance Null [a] where + isNull = null +nonNull = not . isNull +class Divisible a where + divide :: a -> (a, a) + + + +data Tower a = Tower [a] a [a] + deriving (Functor, Eq, Show) + +tower x = Tower (repeat mempty) x (repeat mempty) +moveUp (Tower (a:as) x (b:bs)) = Tower (x:a:as) b bs +moveDown (Tower (a:as) x (b:bs)) = Tower as a (x:b:bs) + +top :: (Monoid a, Null a) => Tower a -> [a] +top (Tower as x sa) = List.takeWhile nonNull sa + +middle :: Tower a -> a +middle (Tower as x sa) = x + +bottom :: (Monoid a, Null a) => Tower a -> [a] +bottom (Tower as x sa) = reverse (List.takeWhile nonNull as) + +-- semantic function +floors :: (Monoid a, Null a) => Tower a -> ([a], a, [a]) +floors t = (bottom t, middle t, top t) + + +compareHead x [] = EQ +compareHead x (y:_) = x `compare` y +comparingHead p x y = compareHead (p x) (fmap p y) +compareHeadVal = comparingHead getNoteValue + +pushNote :: Ord a => Note a -> Tower [Note a] -> Tower [Note a] +pushNote n t = if n `notOverlapsHead` middle t then pushMiddle n t else + case n `compareHeadVal` middle t of + GT -> moveUp $ pushNote n (moveDown t) + _ -> moveDown $ pushNote n (moveUp t) + +pushMiddle :: a -> Tower [a] -> Tower [a] +pushMiddle x (Tower as a sa) = Tower as (x:a) sa + +separateVoices :: Ord a => Score a -> [Score ( a)] +separateVoices = fmap (^. from notes) . f . (^. notes) + where + f = (\(as,x,bs) -> as++[x]++bs) . floors . List.foldr pushNote (tower []) . List.sortBy (comparing getNoteSpan) + +-- Note: -- --- The HasChord instance (for various types) takes care to transform strucuture *above* the chord representation --- In particular, getChord will extract the chord from below and transform each note (or only the first etc) --- as appropriate for the given type. --- The ChordT instances transforms structure *below* the chord representation +-- The HasChord instance (for other transformer types) takes care to transform strucuture *above* the chord representation +-- In particular, getChord will extract the chord from below and transform each note (or only the first etc) +-- as appropriate for the given type. +-- The ChordT instances (of other transformer classes) transforms structure *below* the chord representation +-- For example, it allow us to use functions such as up, down, legato etc on chords. -flatten :: (MonadPlus m, HasChord a) => m a -> m (ChordNote a) -flatten = mscatter . liftM getChord +-- TODO rewrite, generalize? + +takeNotesInChord n = mapSimultaneous (fmap $ take n) +dropNotesInChord n = mapSimultaneous (fmap $ drop n) + +takeNoteInChord n = mapSimultaneous $ (fmap $ take 1) . (fmap $ drop (n - 1)) +dropNoteInChord n = mapSimultaneous $ (fmap $ drop1 n) + +drop1 n xs = take (n - 1) xs <> drop n xs + + +-- | +-- Process all simultaneous events. +-- +-- Two events /a/ and /b/ are considered simultaneous if and only if they have the same +-- era, that is if @`era` a == `era` b@ +-- +mapSimultaneous :: (Score [a] -> Score [b]) -> Score a -> Score b +mapSimultaneous f = mscatter . f . simultaneous' + +-- | +-- Merge all simultaneous events using their 'Semigroup' instance. +-- +-- Two events /a/ and /b/ are considered simultaneous if and only if they have the same +-- era, that is if @`era` a == `era` b@ +-- +simultaneous :: Semigroup a => Score a -> Score a +simultaneous = fmap (sconcat . NonEmpty.fromList) . simultaneous' + +-- | +-- Group simultaneous events as lists. +-- +-- Two events /a/ and /b/ are considered simultaneous if and only if they have the same +-- era, that is if @`era` a == `era` b@ +-- +-- Note that 'simultaneous' is identical to 'simultaneous' @.@ 'fmap' 'return' +-- +simultaneous' :: Score a -> Score [a] +simultaneous' sc = (meta .~) m $ (^. from events) vs + where + m = (view meta) sc + -- es :: [Era] + -- evs :: [[a]] + -- vs :: [(Time, Duration, [a])] + es = List.nub $ eras sc + evs = fmap (`chordEvents` sc) es + vs = zipWith (\(view delta -> (t,d)) a -> (t,d,a)) es evs + + +-- TODO (re)move these + +eras :: Score a -> [Span] +eras sc = fmap getSpan . (^. events) $ sc + +chordEvents :: Span -> Score a -> [a] +chordEvents era sc = fmap getValue . filter (\ev -> getSpan ev == era) . (^. events) $ sc + +getValue :: (Time, Duration, a) -> a +getValue (t,d,a) = a + +getSpan :: (Time, Duration, a) -> Span +getSpan (t,d,a) = t >-> d + + + diff --git a/src/Music/Score/Clef.hs b/src/Music/Score/Clef.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Clef.hs @@ -0,0 +1,95 @@ + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +-- Provides clefs. +-- +------------------------------------------------------------------------------------- + + +module Music.Score.Clef ( + ClefT(..), + HasClef(..), + ) where + +import Control.Arrow +import Control.Monad.Plus +import Data.Foldable (Foldable) +import qualified Data.Foldable as F +import qualified Data.List as List +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe +import Data.Semigroup +import Data.Set (Set) +import qualified Data.Set as Set +import Data.String +import Data.Traversable (Traversable) +import qualified Data.Traversable as T +import Data.Typeable +import Data.Void + +import Music.Score.Combinators (mapFirst) +import Music.Score.Meta +import Music.Score.Meta.Clef +import Music.Score.Note +import Music.Score.Ornaments (HasText, text) +import Music.Score.Part +import Music.Score.Score +import Music.Score.Ties +import Music.Score.Util +import Music.Time +import Music.Time.Reactive + + +-- Put the given clef in front of the note +newtype ClefT a = ClefT { getClefT :: (Option (Last Clef), a) } + deriving (Functor, Semigroup, Monoid) + +type instance Part (ClefT a) = Part a +instance HasPart a => HasPart (ClefT a) where + getPart (ClefT (_,a)) = getPart a + modifyPart f (ClefT (a,b)) = ClefT (a, modifyPart f b) + +instance Monad ClefT where + return x = ClefT (mempty, x) + (>>=) = error "No ClefT.(>>=)" + + +instance Tiable a => Tiable (ClefT a) where + toTied (ClefT (clef,a)) = (ClefT (clef,b), ClefT (mempty,c)) where (b,c) = toTied a + +class HasClef a where + applyClef :: Clef -> a -> a + +instance HasClef (ClefT a) where + applyClef c (ClefT (_,a)) = ClefT (Option $ Just $ Last c,a) + +instance HasClef a => HasClef (b,a) where + applyClef c = fmap (applyClef c) + +instance (HasPart' a, HasClef a) => HasClef (Score a) where + applyClef c = mapFirst (applyClef c) id + diff --git a/src/Music/Score/Combinators.hs b/src/Music/Score/Combinators.hs --- a/src/Music/Score/Combinators.hs +++ b/src/Music/Score/Combinators.hs @@ -1,16 +1,16 @@ -{-# LANGUAGE - CPP, - TypeFamilies, - DeriveFunctor, - DeriveFoldable, - FlexibleInstances, - FlexibleContexts, - ConstraintKinds, - OverloadedStrings, - MultiParamTypeClasses, - NoMonomorphismRestriction, - GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} ------------------------------------------------------------------------------------- -- | @@ -22,677 +22,436 @@ -- Stability : experimental -- Portability : non-portable (TF,GNTD) -- --- Combinators for manipulating scores. +-- Combinators for manipulating scores and related structures. -- ------------------------------------------------------------------------------------- - module Music.Score.Combinators ( - -- ** Preliminaries - Monoid', - Transformable1, - Transformable, - Composable, - HasEvents, + -- * Basic + note, + rest, + noteRest, + removeRests, - -- ** Composing scores - (|>), - (<|), - scat, - pcat, + -- * Mapping over events + mapEvents, - -- *** Special composition - sustain, - anticipate, + -- * Filtering events - -- ** Transforming scores - -- *** Moving in time - move, - moveBack, - startAt, - stopAt, + -- ** Editing + filterEvents, + mapFilterEvents, - -- *** Stretching in time - stretch, - compress, - stretchTo, + -- * Editing + before, + after, + split, + slice, + splice, - -- *** Rests - rest, - removeRests, + -- * Meta-events + metaAt, + metaAtStart, + withMeta, + withGlobalMeta, + withMetaAtStart, + withGlobalMetaAtStart, - -- *** Repetition - times, - repeated, - group, - -- triplet, - -- quadruplet, - -- quintuplet, - -- *** Transformations - perform, - compose, - retrograde, - mapEvents, - filterEvents, - mapFilterEvents, - mapAllEvents, - mapEventsSingle, + + + -- ** Map over phrases mapFirst, mapLast, mapPhrase, mapPhraseSingle, - -- ** Conversion - scoreToVoice, - voiceToScore, - voiceToScore', - eventToScore, - ) where + -- * Parts + -- ** Extracting parts + filterPart, + extractParts, + extractParts', -import Control.Monad -import Control.Monad.Plus -import Data.Semigroup -import Data.String -import Data.Foldable (Foldable) -import Data.Traversable -import Data.VectorSpace -import Data.AffineSpace -import Data.Ratio -import Data.Pointed -import Data.Ord + -- ** Map over parts + -- mapPart, + mapParts, + mapAllParts, + -- modifyParts, -import Music.Score.Track -import Music.Score.Voice -import Music.Score.Score -import Music.Score.Part -import Music.Time + -- ** Part composition + (), + rcat, + -- moveParts, + -- moveToPart, -import qualified Data.List as List + -- * Zippers + -- apply, + -- snapshot, + -- snapshotWith, --- | --- This pseudo-class can be used in place of 'Monoid' whenever an additional 'Semigroup' --- constraint is needed. --- --- Ideally, 'Monoid' should be changed to extend 'Semigroup' instead. --- -type Monoid' a = (Monoid a, Semigroup a) + -- ** Single-part versions + applySingle, + -- snapshotSingle, + -- snapshotWithSingle, + ) where --- TODO names? -type Scalable t d a = ( - Stretchable a, Delayable a, - AdditiveGroup t, - AffineSpace t, - Diff t ~ d, - Time a ~ t, - Duration a ~ d - ) +import Control.Applicative +import Control.Arrow +import Control.Lens hiding (perform) +import Control.Monad +import Control.Monad.Plus +import Data.AffineSpace +import Data.AffineSpace.Point +import Data.Foldable (Foldable (..)) +import Data.Ord +import Data.Ratio +import Data.Semigroup +import Data.String +import Data.Traversable +import Data.VectorSpace --- | --- This class includes time-based structures that can be scaled and moved in time. --- -class ( - Stretchable s, Delayable s, - AdditiveGroup (Time s), AffineSpace (Time s) - ) => Transformable1 s where +import Music.Score.Convert +import Music.Score.Meta +import Music.Score.Note +import Music.Score.Part +import Music.Score.Score +import Music.Score.Track +import Music.Score.Util +import Music.Score.Voice +import Music.Time +import Music.Time.Reactive -instance Transformable1 Score -instance Transformable1 Track -instance (Transformable1 a, t ~ Time a) => Transformable1 (AddOffset t a) +import qualified Data.Foldable as Foldable +import qualified Data.List as List +-- | Create a score containing a note at time zero and duration one. This is an alias for 'return'. +note :: Monad m => a -> m a +note = return +-- | Create a score containing a rest at time zero and duration one. This is an alias for @'return' 'Nothing'@. +rest :: MonadPlus m => m (Maybe a) +rest = return Nothing --- | --- This class includes time-based structures with a known position in time. --- -class ( - HasOnset s, HasOffset s, - Transformable1 s - ) => Transformable s where +-- | Create a note or a rest at time zero and duration one. This is an alias for 'mfromMaybe'. +noteRest :: MonadPlus m => Maybe a -> m a +noteRest = mfromMaybe -{- -type Transformable t d a = ( - Stretchable a, Delayable a, - AdditiveGroup t, - AffineSpace t, - HasOnset a, HasOffset a, - Time a ~ t, - Duration a ~ d - ) --} +-- | Remove all rests from a score. This is an alias for 'mcatMaybes'. +removeRests :: MonadPlus m => m (Maybe a) -> m a +removeRests = mcatMaybes -instance Transformable Score -instance (Transformable a, t ~ Time a) => Transformable (AddOffset t a) +-- | Retain only the notes whose /offset/ does not fall after the given time. +before :: Time -> Score a -> Score a +before u = filterEvents (\t d _ -> t .+^ d <= u) --- | --- This class includes time-based structures that can be transcribed. --- -class ( - MonadPlus s, - Transformable s - ) => Composable s where +-- | Retain only the notes whose /onset/ does not fall before the given time. +after :: Time -> Score a -> Score a +after u = filterEvents (\t d _ -> u <= t) -instance Composable Score --- instance Composable Track +-- | Returns notes whose /onset/ and /offset/ fall between the given times. +slice :: Time -> Time -> Score a -> Score a +slice u v = filterEvents (\t d _ -> u <= t && t .+^ d <= v) --- | --- This class includes time-based structures that can be perfomed /and/ transcribed. --- --- The combined power of 'perform' and 'compose' give us the power to traverse and --- the entire event structure, as per 'mapEvents'. --- -class ( - Performable s, - Composable s - ) => HasEvents s where +-- | Split a score into events whose onsets +split :: Time -> Score a -> (Score a, Score a) +split t a = (before t a, after t a) -{- -type HasEvents t d s a = ( - Performable s, - MonadPlus s, - Transformable t d (s a) - ) --} +-- | Split a score into three parts +splice :: Time -> Duration -> Score a -> (Score a, Score a, Score a) +splice t d a = tripr (before t a, split (t .+^ d) a) -instance HasEvents Score -------------------------------------------------------------------------------------- --- Constructors -------------------------------------------------------------------------------------- + -- | --- Create a score containing a single event. --- --- This function uses the unit position (0, 1). +-- Map over the first, and remaining notes in each part. -- --- > a -> Score a +-- If a part has only one notes, the first function is applied. +-- If a part has no notes, it is returned unchanged. -- -note :: Monad s => a -> s a -note = return +mapFirst :: HasPart' a => (a -> b) -> (a -> b) -> Score a -> Score b +mapFirst f g = mapPhrase f g g -- | --- Create a score containing a rest at time zero of duration one. --- --- This function uses the unit position (0, 1). +-- Map over the last, and preceding notes in each part. -- --- > Score (Maybe a) +-- If a part has only one notes, the first function is applied. +-- If a part has no notes, it is returned unchanged. -- -rest :: MonadPlus s => s (Maybe a) -rest = note Nothing +mapLast :: HasPart' a => (a -> b) -> (a -> b) -> Score a -> Score b +mapLast f g = mapPhrase g g f -- | --- Create a note or a rest. This is an alias for 'mfromMaybe' with a nicer reading. --- --- This function uses the unit position (0, 1). +-- Map over the first, middle and last note in each part. -- --- > a -> Score a +-- If a part has fewer than three notes the first takes precedence over the last, +-- and last takes precedence over the middle. -- -noteRest :: MonadPlus s => Maybe a -> s a -noteRest = mfromMaybe +mapPhrase :: HasPart' a => (a -> b) -> (a -> b) -> (a -> b) -> Score a -> Score b +mapPhrase f g h = mapAllParts (fmap $ mapPhraseSingle f g h) --- | Creates a score containing a chord. +-- | +-- Equivalent to 'mapPhrase' for single-part scores. -- --- This function uses the unit position (0, 1). +-- Fails if the score contains overlapping events. -- --- > [a] -> Score a +-- > (a -> b) -> (a -> b) -> (a -> b) -> Score a -> Score b -- --- chord :: (Pointed s, Monoid (s a)) => [a] -> s a -chord :: (MonadPlus s, Monoid' (s a)) => [a] -> s a -chord = pcat . map note +mapPhraseSingle :: (a -> b) -> (a -> b) -> (a -> b) -> Score a -> Score b +mapPhraseSingle f g h = mapAll (mapFTL (_3 %~ f) (_3 %~ g) (_3 %~ h)) --- | Creates a score containing the given elements, composed in sequence. --- --- > [a] -> Score a --- -melody :: (MonadPlus s, Monoid' (s a), Transformable s) => [a] -> s a -melody = scat . map note --- | Like 'melody', but stretching each note by the given factors. --- --- > [(Duration, a)] -> Score a --- -melodyStretch :: (MonadPlus s, Monoid' (s a), Transformable s, d ~ Duration s) => [(d, a)] -> s a -melodyStretch = scat . map ( \(d, x) -> stretch d $ note x ) --- | Like 'chord', but delays each note the given amounts. --- --- > [(Time, a)] -> Score a +-- | +-- Map over all events in a score. -- -chordDelay :: (MonadPlus s, Monoid (s a), Transformable s, t ~ Time s) => [(t, a)] -> s a -chordDelay = pcat . map (\(t, x) -> delay' t $ note x) +mapAll :: ([(Time, Duration, a)] -> [(Time, Duration, b)]) -> Score a -> Score b +mapAll f = saveMeta $ over events f + where + saveMeta f x = (meta .~) ((view meta) x) $ f x --- | Like 'chord', but delays and stretches each note the given amounts. --- --- > [(Time, Duration, a)] -> Score a --- -chordDelayStretch :: (MonadPlus s, Monoid (s a), Transformable s, d ~ Duration s, t ~ Time s) => [(t, d, a)] -> s a -chordDelayStretch = pcat . map (\(t, d, x) -> delay' t . stretch d $ note x) -------------------------------------------------------------------------------------- --- Transformations -------------------------------------------------------------------------------------- --- | --- Move a score forward in time. Equivalent to 'delay'. --- --- > Duration -> Score a -> Score a --- -move :: (Delayable s, d ~ Duration s) => d -> s a -> s a -move = delay - --- | --- Move a score backward in time. Negated verison of 'delay' --- --- > Duration -> Score a -> Score a --- -moveBack :: (Delayable s, AdditiveGroup d, d ~ Duration s) => d -> s a -> s a -moveBack t = delay (negateV t) +-------------------------------------------------------------------------------- +-- Parts +-------------------------------------------------------------------------------- -- | --- Move a score so that its onset is at the specific time. --- --- > Duration -> Score a -> Score a +-- Filter a score to include only those events whose parts match a given predicate. -- -startAt :: (HasOnset s, Delayable s, AffineSpace t, t ~ Time s) => t -> s a -> s a -t `startAt` x = (t .-. onset x) `delay` x +filterPart :: HasPart' a => (Part a -> Bool) -> Score a -> Score a +filterPart p = mfilter (p . getPart) --- | --- Move a score so that its offset is at the specific time. --- --- > Duration -> Score a -> Score a --- -stopAt :: (HasOffset s, Delayable s, AffineSpace t, t ~ Time s) => t -> s a -> s a -t `stopAt` x = (t .-. offset x) `delay` x +filterPartIs :: HasPart' a => Part a -> Score a -> Score a +filterPartIs = filterPart <$> (==) -- | --- Compress (diminish) a score. Flipped version of '^/'. +-- Extract parts from the a score. -- --- > Duration -> Score a -> Score a +-- The parts are returned in the order defined the associated 'Ord' instance part type. -- -compress :: (Stretchable s, Fractional d, d ~ Duration s) => d -> s a -> s a -compress x = stretch (recip x) +extractParts :: HasPart' a => Score a -> [Score a] +extractParts x = filterPartIs <$> getParts x <*> return x -- | --- Stretch a score to fit into the given duration. +-- Extract parts from the a score and include the part name. -- --- > Duration -> Score a -> Score a +-- The parts are returned in the order defined the associated 'Ord' instance part type. -- -stretchTo :: (Stretchable s, HasDuration s, Fractional d, d ~ Duration s) => d -> s a -> s a -t `stretchTo` x = (t / duration x) `stretch` x +extractParts' :: HasPart' a => Score a -> [(Part a, Score a)] +extractParts' x = getParts x `zip` extractParts x -------------------------------------------------------------------------------------- --- Composition -------------------------------------------------------------------------------------- - -infixr 6 |> -infixr 6 <| - -- | --- Compose in sequence. --- --- To compose in parallel, use '<>'. +-- Map over a specific part in the given score. -- --- > Score a -> Score a -> Score a -(|>) :: (Semigroup (s a), AffineSpace (Time s), HasOnset s, HasOffset s, Delayable s) => s a -> s a -> s a -a |> b = a <> startAt (offset a) b - +mapPart :: (Enum (Part a), HasPart' a) => Part a -> (Score a -> Score a) -> Score a -> Score a -- | --- Compose in reverse sequence. +-- Map over all parts in the given score. -- --- To compose in parallel, use '<>'. +-- > (Score a -> Score a) -> Score a -> Score a -- --- > Score a -> Score a -> Score a -(<|) :: (Semigroup (s a), AffineSpace (Time s), HasOnset s, HasOffset s, Delayable s) => s a -> s a -> s a -a <| b = b |> a +mapParts :: HasPart' a => (Score a -> Score b) -> Score a -> Score b -- | --- Sequential concatentation. +-- Map over all parts in the given score. -- --- > [Score t] -> Score t -scat :: (Monoid' (s a), AffineSpace (Time s), HasOnset s, HasOffset s, Delayable s) => [s a] -> s a -scat = foldr (|>) mempty - --- | --- Parallel concatentation. A synonym for 'mconcat'. +-- > ([Score a] -> [Score a]) -> Score a -> Score a -- --- > [Score t] -> Score t -pcat :: Monoid a => [a] -> a -pcat = mconcat +mapAllParts :: HasPart' a => ([Score a] -> [Score b]) -> Score a -> Score b +{-# DEPRECATED mapParts "" #-} +{-# DEPRECATED mapAllParts "" #-} +{-# DEPRECATED filterPart "" #-} +{-# DEPRECATED extractParts "" #-} +{-# DEPRECATED extractParts' "" #-} --- | --- Like '<>', but scaling the second agument to the duration of the first. --- --- > Score a -> Score a -> Score a --- -sustain :: (Fractional (Duration s), Semigroup (s a), Stretchable s, HasDuration s) => s a -> s a -> s 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 +mapPart n f = mapAllParts (zipWith ($) (replicate (fromEnum n) id ++ [f] ++ repeat id)) +mapParts f = mapAllParts (fmap f) +mapAllParts f = mconcat . f . extractParts -- | --- Like '|>' but with a negative delay on the second element. +-- Modify all parts in the given score. -- --- > Duration -> Score a -> Score a -> Score a +-- > (Part -> Part) -> Score a -> Score a -- -anticipate :: (Semigroup (s a), Transformable s, d ~ Duration s, Ord d) => d -> s a -> s a -> s a -anticipate t a b = a <> startAt (offset a .-^ t) b +modifyParts :: HasPart' a => (Part a -> Part a) -> Score a -> Score a +modifyParts n = fmap (modifyPart n) -------------------------------------------------------------------------------- --- Structure +-- Part composition -------------------------------------------------------------------------------- --- | --- Repeat exact amount of times. --- --- > Duration -> Score Note -> Score Note --- -times :: (Monoid' (s a), Transformable s) => Int -> s a -> s a -times n a = replicate (0 `max` n) () `repeated` const a +infixr 6 -- | --- Repeat once for each element in the list. --- --- Example: --- --- > repeated [1,2,1] (c^*) --- --- Simple type: --- --- > [a] -> (a -> Score Note) -> Score Note +-- Similar to '<>', but increases parts in the second part to prevent collision. -- -repeated :: (Monoid' (s b), Transformable s) => [a] -> (a -> s b) -> s b -repeated = flip (\f -> scat . fmap f) - - -{- -repeatedIndex n = repeated [0..n-1] -repeatedTime n = repeated $ fmap (/ n) [0..(n - 1)] --} - +() :: (HasPart' a, Enum (Part a)) => Score a -> Score a -> Score a +a b = a <> moveParts offset b + where + -- max voice in a + 1 + offset = succ $ maximum' 0 $ fmap fromEnum $ getParts a -- | --- Remove rests from a score. --- --- This is just an alias for 'mcatMaybes' which reads better in certain contexts. --- --- > Score (Maybe a) -> Score a +-- Concatenate parts. -- -removeRests :: MonadPlus m => m (Maybe a) -> m a -removeRests = mcatMaybes - --- -- | --- -- Repeat three times and scale down by three. --- -- --- -- > Score a -> Score a --- -- --- triplet :: (Monoid' (s a), Transformable t d s, Time s ~ TimeT) => s a -> s a --- triplet = group 3 --- --- -- | --- -- Repeat three times and scale down by three. --- -- --- -- > Score a -> Score a --- -- --- quadruplet :: (Monoid' (s a), Transformable t d s, Time s ~ TimeT) => s a -> s a --- quadruplet = group 4 --- --- -- | --- -- Repeat three times and scale down by three. --- -- --- -- > Score a -> Score a --- -- --- quintuplet :: (Monoid' (s a), Transformable t d s, Time s ~ TimeT) => s a -> s a --- quintuplet = group 5 +rcat :: (HasPart' a, Enum (Part a)) => [Score a] -> Score a +rcat = List.foldr () mempty -- | --- Repeat a number of times and scale down by the same amount. --- --- > Duration -> Score a -> Score a +-- Move down one voice (all parts). -- -group :: (Monoid' (s a), Transformable s, Time s ~ TimeT) => Int -> s a -> s a -group n a = times n (toDurationT n `compress` a) +moveParts :: (Integral b, HasPart' a, Enum (Part a)) => b -> Score a -> Score a +moveParts x = modifyParts (successor x) -- | --- Reverse a score around its middle point (TODO not correct documentation w.r.t to start). --- --- > onset a = onset (retrograde a) --- > duration a = duration (retrograde a) --- > offset a = offset (retrograde a) +-- Move top-part to the specific voice (other parts follow). -- --- > Score a -> Score a +moveToPart :: (Enum b, HasPart' a, Enum (Part a)) => b -> Score a -> Score a +moveToPart v = moveParts (fromEnum v) -retrograde :: (HasEvents s, t ~ Time s, Num t, Ord t) => s a -> s a -retrograde = startAt 0 . (mapAllEvents $ List.sortBy (comparing fst3) . fmap g) - where - g (t,d,x) = (-(t.+^d),d,x) --------------------------------------------------------------------------------- --- Mapping and recomposition --------------------------------------------------------------------------------- -#define MAP_CONSTRAINT \ - HasPart' a, \ - HasEvents s - --- | Recompose a score. --- --- This is the inverse of 'perform' --- --- > [(Time, Duration, a)] -> Score a --- -compose :: (Composable s, d ~ Duration s, t ~ Time s) => [(t, d, a)] -> s a -compose = msum . liftM eventToScore - --- retrograde :: (HasEvents s, t ~ Time s, Num t, Ord t) => s a -> s a -mapAllEvents :: (HasEvents s, d ~ Duration s, t ~ Time s) => ([(t, d, a)] -> [(t, d, b)]) -> s a -> s b -mapAllEvents f = compose . f . perform - -{- -mapFilterAllEvents :: (HasEvents s, d ~ Duration s, t ~ Time s) => ([(t, d, a)] -> [(t, d, Maybe b)]) -> s a -> s b -mapFilterAllEvents f = mcatMaybes . mapAllEvents f --} +------------------------------------------------------------------------------------- +-- Zippers -- | --- Map over the events in a score. --- --- > (Time -> Duration -> a -> b) -> Score a -> Score b +-- Apply a time-varying function to all events in score. -- -filterEvents :: (MAP_CONSTRAINT, t ~ Time s, d ~ Duration s) => (t -> d -> a -> Bool) -> s a -> s a -filterEvents f = mapFilterEvents (partial3 f) --- TODO Maybe this could be optimized by using mapEventsSingle? +apply :: HasPart' a => Voice (Score a -> Score b) -> Score a -> Score b +apply x = mapAllParts (fmap $ applySingle x) -- | --- Map over the events in a score. --- --- > (Time -> Duration -> a -> b) -> Score a -> Score b +-- Apply a time-varying function to all events in score. -- -mapFilterEvents :: (MAP_CONSTRAINT, t ~ Time s, d ~ Duration s) => (t -> d -> a -> Maybe b) -> s a -> s b -mapFilterEvents f = mcatMaybes . mapAllParts (liftM $ mapEventsSingle f) +applySingle :: Voice (Score a -> Score b) -> Score a -> Score b +applySingle fs = notJoin . fmap (uncurry ($)) . sample fs + where + notJoin = mconcat . Foldable.toList + sample fs = snapshotSingle (voiceToScore fs) +{-# DEPRECATED applySingle "" #-} -- | --- Map over the events in a score. --- --- > (Time -> Duration -> a -> b) -> Score a -> Score b +-- Get all notes that start during a given note. -- -mapEvents :: (MAP_CONSTRAINT, t ~ Time s, d ~ Duration s) => (t -> d -> a -> b) -> s a -> s b -mapEvents f = mapAllParts (liftM $ mapEventsSingle f) +snapshot :: HasPart' b => Score a -> Score b -> Score (a, Score b) +snapshot x = mapAllParts (fmap $ snapshotSingle x) +snapshotWith :: HasPart' b => (a -> Score b -> c) -> Score a -> Score b -> Score c +snapshotWith f x = mapAllParts (fmap $ snapshotWithSingle f x) + -- | --- Equivalent to 'mapEvents' for single-voice scores. --- Fails if the score contains overlapping events. --- --- > (Time -> Duration -> a -> b) -> Score a -> Score b +-- Get all notes that start during a given note. -- -mapEventsSingle :: (HasEvents s, t ~ Time s, d ~ Duration s) => (t -> d -> a -> b) -> s a -> s b -mapEventsSingle f sc = compose . fmap (third' f) . perform $ sc +snapshotSingle :: Score a -> Score b -> Score (a, Score b) +snapshotSingle = snapshotWithSingle (,) +snapshotWithSingle :: (a -> Score b -> c) -> Score a -> Score b -> Score c +snapshotWithSingle g as bs = mapEvents ( \t d a -> g a (onsetIn t d bs) ) as + -- | --- Equivalent to 'mapEvents' for single-voice scores. --- Fails if the score contains overlapping events. --- --- > ([(Time,Duration,a)] -> [b]) -> Score a -> Score b +-- 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) -- --- mapAllEventsSingle :: (HasEvents s, t ~ Time s, d ~ Duration s) => ([(t,d,a)] -> b) -> s a -> s b --- mapAllEventsSingle f sc = compose . fmap trd3 . f . perform $ sc --- mapAllEventsSingle' :: (HasEvents s, t ~ Time s, d ~ Duration s) => ([(t,d,a)] -> [b]) -> s a -> s b --- mapAllEventsSingle' f = compose . fmap trd3 . f . perform +onsetIn :: Time -> Duration -> Score a -> Score a +onsetIn a b = mapAll $ filterOnce (\(t,d,x) -> a <= t && t < a .+^ b) +-- We could also have used mfilter. filterOnce is more lazy, +-- but depends on the events being sorted -trd3 (a,b,c) = c -mapAllEventsSingle' :: (HasEvents s, t ~ Time s, d ~ Duration s) => ([(t,d,a)] -> [(t,d,b)]) -> s a -> s b -mapAllEventsSingle' f = compose . f . perform --- | --- Map over the first, and remaining notes in each part. --- --- If a part has only one notes, the first function is applied. --- If a part has no notes, the given score is returned unchanged. --- --- > (a -> b) -> (a -> b) -> Score a -> Score b --- -mapFirst :: (MAP_CONSTRAINT) => (a -> b) -> (a -> b) -> s a -> s b -mapFirst f g = mapPhrase f g g --- | --- Map over the last, and preceding notes in each part. --- --- If a part has only one notes, the first function is applied. --- If a part has no notes, the given score is returned unchanged. --- --- > (a -> b) -> (a -> b) -> Score a -> Score b --- -mapLast :: (MAP_CONSTRAINT) => (a -> b) -> (a -> b) -> s a -> s b -mapLast f g = mapPhrase g g f --- | --- Map over the first, middle and last note in each part. --- --- If a part has fewer than three notes the first takes precedence over the last, --- and last takes precedence over the middle. --- --- > (a -> b) -> (a -> b) -> (a -> b) -> Score a -> Score b --- -mapPhrase :: (MAP_CONSTRAINT) => (a -> b) -> (a -> b) -> (a -> b) -> s a -> s b -mapPhrase f g h = mapAllParts (liftM $ mapPhraseSingle f g h) --- | --- Equivalent to 'mapPhrase' for single-voice scores. --- Fails if the score contains overlapping events. --- --- > (a -> b) -> (a -> b) -> (a -> b) -> Score a -> Score b --- -mapPhraseSingle :: HasEvents s => (a -> b) -> (a -> b) -> (a -> b) -> s a -> s b -mapPhraseSingle f g h sc = compose . mapFirstMiddleLast (third f) (third g) (third h) . perform $ sc --- eventToScore :: Scalable t d a => (t, d, a) -> m a +withSpan :: Score a -> Score (Span, a) +withSpan = mapEvents (\t d x -> (t >-> d,x)) +withTime = mapEvents (\t d x -> (t, x)) -eventToScore - :: (Monad s, - Transformable1 s, - Time s ~ t, Duration s ~ d - ) => (t, d, a) -> s a +inSpan t' (view range -> (t,u)) = t <= t' && t' < u -eventToScore (t,d,x) = delay' t . stretch d $ return x +-- TODO clean +mapBefore :: Time -> (Score a -> Score a) -> Score a -> Score a +mapDuring :: Span -> (Score a -> Score a) -> Score a -> Score a +mapAfter :: Time -> (Score a -> Score a) -> Score a -> Score a +mapBefore t f x = let (y,n) = (fmap snd *** fmap snd) $ mpartition (\(t2,x) -> t2 < t) (withTime x) in (f y <> n) +mapDuring s f x = let (y,n) = (fmap snd *** fmap snd) $ mpartition (\(t,x) -> t `inSpan` s) (withTime x) in (f y <> n) +mapAfter t f x = let (y,n) = (fmap snd *** fmap snd) $ mpartition (\(t2,x) -> t2 >= t) (withTime x) in (f y <> n) --------------------------------------------------------------------------------- --- Conversion --------------------------------------------------------------------------------- --- | --- Convert a score into a voice. --- --- This function fails if the score contain overlapping events. --- -scoreToVoice :: Score a -> Voice (Maybe a) -scoreToVoice = Voice . fmap throwTime . addRests' . perform - where - throwTime (t,d,x) = (d,x) +-- Transform the score with the current value of some meta-information +-- Each "update chunk" of the meta-info is processed separately --- | --- Convert a voice into a score. --- -voiceToScore :: Voice a -> Score a -voiceToScore = scat . fmap g . getVoice - where - g (d,x) = stretch d (note x) +runScoreMeta :: forall a b . (HasPart' a, IsAttribute b) => Score a -> Reactive b +runScoreMeta = runMeta (Nothing :: Maybe a) . (view meta) --- | --- Convert a voice which may contain rests into a score. --- -voiceToScore' :: Voice (Maybe a) -> Score a -voiceToScore' = mcatMaybes . voiceToScore +metaAt :: (HasPart' a, IsAttribute b) => Time -> Score a -> b +metaAt x = (? x) . runScoreMeta --- TODO move this instance -instance Performable Voice where - perform = perform . voiceToScore +metaAtStart :: (HasPart' a, IsAttribute b) => Score a -> b +metaAtStart x = onset x `metaAt` x +withGlobalMeta :: IsAttribute a => (a -> Score b -> Score b) -> Score b -> Score b +withGlobalMeta = withMeta' (Nothing :: Maybe Int) --------------------------------------------------------------------------------- +withMeta :: (IsAttribute a, HasPart' b) => (a -> Score b -> Score b) -> Score b -> Score b +withMeta f x = withMeta' (Just x) f x -addRests' :: [(TimeT, DurationT, a)] -> [(TimeT, DurationT, Maybe a)] -addRests' = concat . snd . mapAccumL g 0 - where - g u (t, d, x) - | u == t = (t .+^ d, [(t, d, Just x)]) - | u < t = (t .+^ d, [(u, t .-. u, Nothing), (t, d, Just x)]) - | otherwise = error "addRests: Strange prevTime" +withMeta' :: (HasPart' c, IsAttribute a) => Maybe c -> (a -> Score b -> Score b) -> Score b -> Score b +withMeta' part f x = let + m = (view meta) x + r = runMeta part m + in case splitReactive r of + Left a -> f a x + Right ((a, t), bs, (u, c)) -> + (meta .~) m + $ mapBefore t (f a) + $ (composed $ fmap (\(getNote -> (s, a)) -> mapDuring s $ f a) $ bs) + $ mapAfter u (f c) + $ x --- | --- Map over first, middle and last elements of list. --- Biased on first, then on first and last for short lists. --- -mapFirstMiddleLast :: (a -> b) -> (a -> b) -> (a -> b) -> [a] -> [b] -mapFirstMiddleLast f g h = go - where - go [] = [] - go [a] = [f a] - go [a,b] = [f a, h b] - go xs = [f $ head xs] ++ - map g (tail $ init xs) ++ - [h $ last xs] +withGlobalMetaAtStart :: IsAttribute a => (a -> Score b -> Score b) -> Score b -> Score b +withGlobalMetaAtStart = withMetaAtStart' (Nothing :: Maybe Int) -delay' t = delay (t .-. zeroV) +withMetaAtStart :: (IsAttribute a, HasPart' b) => (a -> Score b -> Score b) -> Score b -> Score b +withMetaAtStart f x = withMetaAtStart' (Just x) f x -fst3 (t, d, x) = t +withMetaAtStart' :: (IsAttribute b, HasPart' p) => + Maybe p -> (b -> Score a -> Score a) -> Score a -> Score a +withMetaAtStart' part f x = let + m = (view meta) x + in f (runMeta part m ? onset x) x -third f (a,b,c) = (a,b,f c) -third' f (a,b,c) = (a,b,f a b c) -rotl [] = [] -rotl (x:xs) = xs ++ [x] -rotr [] = [] -rotr xs = last xs : init xs -curry3 :: ((a, b, c) -> d) -> a -> b -> c -> d -curry3 = curry . curry . (. trip) +------------------------------------------------------------------------------------- -uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d -uncurry3 = (. untrip) . uncurry . uncurry -untrip (a,b,c) = ((a,b),c) -trip ((a,b),c) = (a,b,c) +-- partial2 :: (a -> b -> Bool) -> a -> b -> Maybe b +-- partial3 :: (a -> b -> c -> Bool) -> a -> b -> c -> Maybe c +-- partial2 f = curry (fmap snd . partial (uncurry f)) +-- partial3 f = curry3 (fmap (^. _3) . partial (uncurry3 f)) -{- -partial :: (a -> Bool) -> a -> Maybe a --} -partial2 :: (a -> b -> Bool) -> a -> b -> Maybe b -partial3 :: (a -> b -> c -> Bool) -> a -> b -> c -> Maybe c -partial2 f = curry (fmap snd . partial (uncurry f)) -partial3 f = curry3 (fmap trd3 . partial (uncurry3 f)) +iterating :: (a -> a) -> (a -> a) -> Int -> a -> a +iterating f g n + | n < 0 = f . iterating f g (n + 1) + | n == 0 = id + | n > 0 = g . iterating f g (n - 1) -rotated :: Int -> [a] -> [a] -rotated = go - where - go n as - | n >= 0 = iterate rotr as !! n - | n < 0 = iterate rotl as !! abs n +successor :: (Integral b, Enum a) => b -> a -> a +successor n = iterating pred succ (fromIntegral n) + +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/src/Music/Score/Convert.hs b/src/Music/Score/Convert.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Convert.hs @@ -0,0 +1,201 @@ + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +-- Provides conversion betwen temporal container types. +-- +------------------------------------------------------------------------------------- + + +module Music.Score.Convert ( + -- * Conversion + noteToVoice, + noteToScore, + -- scoreToNotes, + -- notesToScore, + voiceToScore, + voicesToScore, + trackToScore, + trackToScore', + scoreToVoice, + reactiveToVoice, + reactiveToVoice', + noteToReactive, + splitReactive, + activate, + ) where + +import Control.Applicative +import Control.Lens +import Control.Monad +import Control.Monad.Plus +import Data.AffineSpace +import Data.AffineSpace.Point +import Data.Foldable (Foldable (..)) +import Data.Ord +import Data.Ratio +import Data.Semigroup +import Data.String +import Data.Traversable +import Data.VectorSpace + +import Music.Score.Note +import Music.Score.Part +import Music.Score.Score +import Music.Score.Track +import Music.Score.Voice +import Music.Time +import Music.Time.Reactive + +import qualified Data.Foldable as Foldable +import qualified Data.List as List + + +-- | Convert a note to an onset and a voice. +noteToVoice :: Note a -> (Time, Voice a) +noteToVoice (getNote -> (s,x)) = (onset s, stretchTo (duration s) $ return x) + +-- | Convert a note to a score. +noteToScore :: Note a -> Score a +noteToScore (getNote -> (s,x)) = s `sapp` return x + +-- scoreToNotes :: Score a -> [Note a] +-- scoreToNotes = Foldable.toList . reifyScore + +-- notesToScore :: [Note a] -> Score a +-- notesToScore = pcat . fmap noteToScore + +reactiveToVoice :: Duration -> Reactive a -> Voice a +reactiveToVoice d r = (^. voice) $ durs `zip` (fmap (r ?) times) + where + times = origin : filter (\t -> origin < t && t < origin .+^ d) (occs r) + durs = toRelN' (origin .+^ d) times + +reactiveToVoice' :: Span -> Reactive a -> Voice a +reactiveToVoice' (view range -> (u,v)) r = (^. voice) $ durs `zip` (fmap (r ?) times) + where + times = origin : filter (\t -> u < t && t < v) (occs r) + durs = toRelN' v times + +-- | +-- Convert a score to a voice. Fails if the score contain overlapping events. +-- +scoreToVoice :: Score a -> Voice (Maybe a) +scoreToVoice = (^. voice) . fmap throwTime . addRests . (^. events) + where + throwTime (t,d,x) = (d,x) + addRests = concat . snd . mapAccumL g origin + where + g u (t, d, x) + | u == t = (t .+^ d, [(t, d, Just x)]) + | u < t = (t .+^ d, [(u, t .-. u, Nothing), (t, d, Just x)]) + | otherwise = error "addRests: Strange prevTime" + + +-- | +-- Convert a voice to a score. +-- +voiceToScore :: Voice a -> Score a +voiceToScore = scat . fmap g . (^. from voice) + where + g (d,x) = stretch d (return x) + +-- | Join voices in a given part into a score. +voicesToScore :: HasPart a => [(Part a, Voice a)] -> Score a +voicesToScore = pcat . fmap (voiceToScore . uncurry (\n -> fmap (setPart n))) + +-- | +-- Convert a voice which may contain rests to a score. +-- +voiceToScore' :: Voice (Maybe a) -> Score a +voiceToScore' = mcatMaybes . voiceToScore + +-- | +-- Convert a track to a score where each event is given a fixed duration. +-- +trackToScore :: Duration -> Track a -> Score a +trackToScore x = trackToScore' (const x) + +-- | +-- Convert a track to a score, using durations determined by the values. +-- +trackToScore' :: (a -> Duration) -> Track a -> Score a +trackToScore' f = (^. from events) . fmap (\(t,x) -> (t,f x,x)) . (^. from track) + + +-- Convert to delta (time to wait before this note) +toRel :: [Time] -> [Duration] +toRel = snd . mapAccumL g origin where g prev t = (t, t .-. prev) + +-- Convert to delta (time to wait before next note) +toRelN :: [Time] -> [Duration] +toRelN [] = [] +toRelN xs = snd $ mapAccumR g (last xs) xs where g prev t = (t, prev .-. t) + +-- Convert to delta (time to wait before next note) +toRelN' :: Time -> [Time] -> [Duration] +toRelN' end xs = snd $ mapAccumR g end xs where g prev t = (t, prev .-. t) + +-- 0 x,1 x,1 x,1 x + -- x 1,x 1,x 1,x 0 + +-- Convert from delta (time to wait before this note) +toAbs :: [Duration] -> [Time] +toAbs = snd . mapAccumL g origin where g now d = (now .+^ d, now .+^ d) + + +-- TODO rename during +noteToReactive :: Monoid a => Note a -> Reactive a +noteToReactive n = (pure <$> n) `activate` pure mempty + +-- | Split a reactive into notes, as well as the values before and after the first/last update +splitReactive :: Reactive a -> Either a ((a, Time), [Note a], (Time, a)) +splitReactive r = case updates r of + [] -> Left (initial r) + (t,x):[] -> Right ((initial r, t), [], (t, x)) + (t,x):xs -> Right ((initial r, t), fmap note $ mrights (res $ (t,x):xs), head $ mlefts (res $ (t,x):xs)) + + where + + note (t,u,x) = t <-> u =: x + + -- Always returns a 0 or more Right followed by one left + res :: [(Time, a)] -> [Either (Time, a) (Time, Time, a)] + res rs = let (ts,xs) = unzip rs in + flip fmap (withNext ts `zip` xs) $ + \ ((t, mu), x) -> case mu of + Nothing -> Left (t, x) + Just u -> Right (t, u, x) + + -- lenght xs == length (withNext xs) + withNext :: [a] -> [(a, Maybe a)] + withNext = go + where + go [] = [] + go [x] = [(x, Nothing)] + go (x:y:rs) = (x, Just y) : withNext (y : rs) + +activate :: Note (Reactive a) -> Reactive a -> Reactive a +activate (getNote -> (view range -> (start,stop), x)) y = y `turnOn` (x `turnOff` y) + where + turnOn = switch start + turnOff = switch stop + diff --git a/src/Music/Score/Dynamics.hs b/src/Music/Score/Dynamics.hs --- a/src/Music/Score/Dynamics.hs +++ b/src/Music/Score/Dynamics.hs @@ -1,13 +1,14 @@ -{-# LANGUAGE - TypeFamilies, - DeriveFunctor, - DeriveFoldable, - DeriveDataTypeable, - FlexibleInstances, - FlexibleContexts, - ConstraintKinds, - GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} ------------------------------------------------------------------------------------- -- | @@ -25,40 +26,44 @@ module Music.Score.Dynamics ( + -- * Dynamics representation HasDynamic(..), DynamicT(..), - - -- ** Dynamics over time - Levels(..), - cresc, - dim, - - -- ** Application dynamics, dynamicVoice, dynamicSingle, + -- * Dynamic transformations + -- ** Crescendo and diminuendo + Level(..), + cresc, + dim, + -- ** Miscellaneous resetDynamics, ) where -import Control.Monad -import Data.Semigroup -import Data.Ratio -import Data.Foldable -import Data.Typeable -import qualified Data.List as List -import Data.VectorSpace -import Data.AffineSpace +import Control.Applicative +import Control.Arrow +import Control.Lens hiding (Level) +import Control.Monad +import Data.AffineSpace +import Data.Foldable +import qualified Data.List as List +import Data.Maybe +import Data.Ratio +import Data.Semigroup +import Data.Typeable +import Data.VectorSpace hiding (Sum) -import Music.Score.Voice -import Music.Score.Score -import Music.Time -import Music.Score.Part -import Music.Score.Combinators -import Music.Score.Zip +import Music.Score.Combinators +import Music.Score.Convert +import Music.Score.Part +import Music.Score.Score +import Music.Score.Voice +import Music.Time -import Music.Dynamics.Literal +import Music.Dynamics.Literal class HasDynamic a where setBeginCresc :: Bool -> a -> a @@ -68,118 +73,113 @@ 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, Typeable) +newtype DynamicT a = DynamicT { getDynamicT :: (((Any, Any), Option (First Double), (Any, Any)), a) } + deriving (Eq, Show, Ord, Functor, Foldable, Typeable, Applicative, Monad) +instance HasDynamic (DynamicT a) where + setBeginCresc (Any -> bc) (DynamicT (((ec,ed),l,(_ ,bd)),a)) = DynamicT (((ec,ed),l,(bc,bd)),a) + setEndCresc (Any -> ec) (DynamicT (((_ ,ed),l,(bc,bd)),a)) = DynamicT (((ec,ed),l,(bc,bd)),a) + setBeginDim (Any -> bd) (DynamicT (((ec,ed),l,(bc,_ )),a)) = DynamicT (((ec,ed),l,(bc,bd)),a) + setEndDim (Any -> ed) (DynamicT (((ec,_ ),l,(bc,bd)),a)) = DynamicT (((ec,ed),l,(bc,bd)),a) + setLevel ((Option . Just . First) -> l ) (DynamicT (((ec,ed),_,(bc,bd)),a)) = DynamicT (((ec,ed),l,(bc,bd)),a) +instance HasDynamic b => HasDynamic (a, b) where + setBeginCresc n = fmap (setBeginCresc n) + setEndCresc n = fmap (setEndCresc n) + setBeginDim n = fmap (setBeginDim n) + setEndDim n = fmap (setEndDim n) + setLevel n = fmap (setLevel n) + + -------------------------------------------------------------------------------- -- Dynamics -------------------------------------------------------------------------------- --- Apply a constant level over the whole score. --- dynamic :: (HasDynamic a, HasPart a, Ord v, v ~ Part a) => Double -> Score a -> Score a --- dynamic n = mapPhrase (setLevel n) id id +-- | +-- Represents dynamics over a duration. +-- +data Level a + = Level a + | Change a a + deriving (Eq, Show) +instance Fractional a => IsDynamics (Level a) where + fromDynamics (DynamicsL (Just a, Nothing)) = Level (realToFrac a) + fromDynamics (DynamicsL (Just a, Just b)) = Change (realToFrac a) (realToFrac b) + fromDynamics x = error $ "fromDynamics: Invalid dynamics literal " ++ show x + -- | -- Apply a dynamic level over the score. --- The dynamic score is assumed to have duration one. -- -dynamics :: (HasDynamic a, HasPart' a) => Score (Levels Double) -> Score a -> Score a -dynamics d a = (duration a `stretchTo` d) `dyns` a +dynamics :: (HasDynamic a, HasPart' a) => Score (Level Double) -> Score a -> Score a +dynamics d a = (duration a `stretchTo` d) `dynamics'` a --- | --- Equivalent to `splitTies` for single-voice scores. --- Fails if the score contains overlapping events. --- -dynamicSingle :: HasDynamic a => Score (Levels Double) -> Score a -> Score a -dynamicSingle d a = (duration a `stretchTo` d) `dyn` a +dynamicSingle :: HasDynamic a => Score (Level Double) -> Score a -> Score a +dynamicSingle d a = (duration a `stretchTo` d) `dynamicsSingle'` a -- | -- Apply a dynamic level over a voice. -- -dynamicVoice :: HasDynamic a => Score (Levels Double) -> Voice (Maybe a) -> Voice (Maybe a) -dynamicVoice d = scoreToVoice . dynamicSingle d . voiceToScore' +dynamicVoice :: HasDynamic a => Score (Level Double) -> Voice (Maybe a) -> Voice (Maybe a) +dynamicVoice d = scoreToVoice . dynamicSingle d . removeRests . voiceToScore -dyns :: (HasDynamic a, HasPart a, Ord v, v ~ Part a) => Score (Levels Double) -> Score a -> Score a -dyns ds = mapAllParts (fmap $ applyDynSingle (fmap fromJust $ scoreToVoice ds)) - -dyn :: HasDynamic a => Score (Levels Double) -> Score a -> Score a -dyn ds = applyDynSingle (fmap fromJust . scoreToVoice $ ds) +dynamics' :: (HasDynamic a, HasPart' a) => Score (Level Double) -> Score a -> Score a +dynamics' ds = mapAllParts (fmap $ dynamicsSingle' ds) -resetDynamics :: HasDynamic c => c -> c -resetDynamics = setBeginCresc False . setEndCresc False . setBeginDim False . setEndDim False +dynamicsSingle' :: HasDynamic a => Score (Level Double) -> Score a -> Score a +dynamicsSingle' ds = applyDynSingle (fmap fromJust $ scoreToVoice ds) --- | --- 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) +applyDynSingle :: HasDynamic a => Voice (Level Double) -> Score a -> Score a +applyDynSingle ds = applySingle ds3 + where + -- ds2 :: Voice (Dyn2 Double) + ds2 = mapValuesVoice dyn2 ds + -- ds3 :: Voice (Score a -> Score a) + ds3 = fmap g ds2 + g (ec,ed,l,bc,bd) = id + . (if ec then mapFirstSingle (setEndCresc True) else id) + . (if ed then mapFirstSingle (setEndDim True) else id) + . (if bc then mapFirstSingle (setBeginCresc True) else id) + . (if bd then mapFirstSingle (setBeginDim True) else id) + . maybe id (mapFirstSingle . setLevel) l + mapFirstSingle f = mapPhraseSingle f id id -- end cresc, end dim, level, begin cresc, begin dim -type Levels2 a = (Bool, Bool, Maybe a, Bool, Bool) +type LevelDiff a = (Bool, Bool, Maybe a, Bool, Bool) -dyn2 :: Ord a => [Levels a] -> [Levels2 a] +dyn2 :: Ord a => [Level a] -> [LevelDiff 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)) + | 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)) + | 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]) -> Voice a -> Voice b -transf f = Voice . uncurry zip . second f . unzip . getVoice +mapValuesVoice :: ([a] -> [b]) -> Voice a -> Voice b +mapValuesVoice f = (^. voice) . uncurry zip . second f . unzip . (^. from voice) -applyDynSingle :: HasDynamic a => Voice (Levels Double) -> Score a -> Score a -applyDynSingle ds = applySingle ds3 - where - -- ds2 :: Voice (Dyn2 Double) - ds2 = transf dyn2 ds - -- ds3 :: Voice (Score a -> Score a) - ds3 = fmap g ds2 - 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 (map1 . setLevel) l - map1 f = mapPhraseSingle f id id +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) -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 - +resetDynamics :: HasDynamic c => c -> c +resetDynamics = setBeginCresc False . setEndCresc False . setBeginDim False . setEndDim False diff --git a/src/Music/Score/Export/Abc.hs b/src/Music/Score/Export/Abc.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Export/Abc.hs @@ -0,0 +1,2 @@ + +module Music.Score.Export.Abc where diff --git a/src/Music/Score/Export/Common.hs b/src/Music/Score/Export/Common.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Export/Common.hs @@ -0,0 +1,105 @@ + +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +------------------------------------------------------------------------------------- + +module Music.Score.Export.Common ( + voiceToBars', + -- separateBars, + spellPitch, + toRelative, + ) where + +import Prelude hiding (concat, concatMap, foldl, + foldr, mapM, maximum, minimum, sum) + +import Control.Applicative +import Control.Lens +import Control.Monad hiding (mapM) +import Control.Monad.Plus +import Data.AffineSpace +import Data.AffineSpace.Point +import Data.Basis +import Data.Either +import Data.Foldable +import Data.Function (on) +import Data.Maybe +import Data.Ord (comparing) +import Data.Ratio +import Data.Semigroup +import Data.String +import Data.Traversable +import Data.Typeable +import Data.VectorSpace + +import Music.Score.Articulation +import Music.Score.Combinators +import Music.Score.Convert +import Music.Score.Dynamics +import Music.Score.Ornaments +import Music.Score.Part +import Music.Score.Pitch +import Music.Score.Rhythm +import Music.Score.Score +import Music.Score.Ties +import Music.Score.Track +import Music.Score.Voice +import Music.Time + +import qualified Codec.Midi as Midi +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Music.Lilypond as Lilypond +import qualified Music.MusicXml.Simple as Xml +import qualified Text.Pretty as Pretty + +import Music.Dynamics.Literal +import Music.Pitch.Literal +import Music.Score.Util +import System.IO.Unsafe +import System.Process + +-- | Convert a voice to a list of bars using the given bar durations. +voiceToBars' :: Tiable a => [Duration] -> Voice (Maybe a) -> [[(Duration, Maybe a)]] +voiceToBars' barDurs = fmap (^. from voice) . splitTiesVoiceAt barDurs +-- TODO remove prime from name + +-- | Convert absolute to relative durations. +toRelative :: [(Time, Duration, b)] -> [(Time, Duration, b)] +toRelative = snd . mapAccumL g origin + where + g now (t,d,x) = (t, (origin .+^ (t .-. now),d,x)) + +-- | Basic spelling for integral types. +spellPitch :: Integral a => a -> (a, a, a) +spellPitch p = ( + pitchClass, + alteration, + octave + ) + where + octave = (p `div` 12) - 1 + semitone = p `mod` 12 + pitchClass = fromStep major semitone + alteration = semitone - step major pitchClass + + step xs p = xs !! (fromIntegral p `mod` length xs) + fromStep xs p = fromIntegral $ 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] + diff --git a/src/Music/Score/Export/Lilypond.hs b/src/Music/Score/Export/Lilypond.hs --- a/src/Music/Score/Export/Lilypond.hs +++ b/src/Music/Score/Export/Lilypond.hs @@ -1,15 +1,15 @@ -{-# LANGUAGE - TypeFamilies, - DeriveFunctor, - DeriveFoldable, - DeriveDataTypeable, - GeneralizedNewtypeDeriving, - FlexibleContexts, - ConstraintKinds, - TypeOperators, - OverloadedStrings, - NoMonomorphismRestriction #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} ------------------------------------------------------------------------------------- -- | @@ -26,58 +26,75 @@ module Music.Score.Export.Lilypond ( Lilypond, HasLilypond(..), - toLy, - writeLy, - openLy, - -- toLySingle, - -- writeLySingle, - -- openLySingle, + + toLilypond, + toLilypondString, + + showLilypond, + openLilypond, + writeLilypond, + + -- * Options + LilypondOptions(..), + writeLilypond', + openLilypond', ) where -import Prelude hiding (foldr, concat, foldl, mapM, concatMap, maximum, sum, minimum) +import Prelude hiding (concat, concatMap, foldl, + foldr, mapM, maximum, minimum, + sum) -import Data.Semigroup -import Data.Ratio -import Data.String -import Control.Applicative -import Control.Monad hiding (mapM) -import Control.Monad.Plus -import Data.Maybe -import Data.Either -import Data.Foldable -import Data.Typeable -import Data.Traversable -import Data.Function (on) -import Data.Ord (comparing) -import Data.VectorSpace -import Data.AffineSpace -import Data.Basis -import System.Process +import Control.Applicative +import Control.Arrow +import Control.Lens hiding (rewrite) +import Control.Monad hiding (mapM) +import Data.AffineSpace +import Data.Default +import Data.Foldable +import Data.Function (on) +import Data.Maybe (fromMaybe) +import Data.Ord (comparing) +import Data.Ratio +import Data.Semigroup +import Data.String +import Data.Traversable +import Data.Typeable +import Data.VectorSpace hiding (Sum) +import System.Process -import Music.Time -import Music.Pitch.Literal -import Music.Dynamics.Literal -import Music.Score.Rhythm -import Music.Score.Track -import Music.Score.Voice -import Music.Score.Score -import Music.Score.Combinators -import Music.Score.Zip -import Music.Score.Pitch -import Music.Score.Ties -import Music.Score.Part -import Music.Score.Articulation -import Music.Score.Dynamics -import Music.Score.Ornaments -import Music.Score.Instances -import Music.Score.Export.Util +import Music.Dynamics.Literal +import Music.Pitch.Literal +import Music.Score.Articulation +import Music.Score.Chord +import Music.Score.Clef +import Music.Score.Combinators +import Music.Score.Convert +import Music.Score.Dynamics +import Music.Score.Export.Common +import Music.Score.Instances +import Music.Score.Meta +import Music.Score.Meta.Attribution +import Music.Score.Meta.Clef +import Music.Score.Meta.Time +import Music.Score.Meta.Title +import Music.Score.Ornaments +import Music.Score.Part +import Music.Score.Pitch +import Music.Score.Rhythm +import Music.Score.Score +import Music.Score.Ties +import Music.Score.Track +import Music.Score.Util +import Music.Score.Voice +import Music.Time +import Music.Time.Reactive (initial) -import qualified Codec.Midi as Midi -import qualified Music.MusicXml.Simple as Xml -import qualified Music.Lilypond as Lilypond -import qualified Text.Pretty as Pretty -import qualified Data.Map as Map -import qualified Data.List as List +import qualified Codec.Midi as Midi +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Music.Lilypond as Lilypond +import qualified Music.MusicXml.Simple as Xml +import qualified Text.Pretty as Pretty type Lilypond = Lilypond.Music @@ -86,24 +103,38 @@ -- Class of types that can be converted to Lilypond. -- class Tiable a => HasLilypond a where + -- | -- Convert a value to a Lilypond music expression. -- - getLilypond :: DurationT -> a -> Lilypond + getLilypond :: Duration -> a -> Lilypond + getLilypondChord :: Duration -> [a] -> Lilypond + getLilypondChord d = pcatLilypond . fmap (getLilypond d) + + getLilypondWithPrefix :: Duration -> a -> (Lilypond -> Lilypond,Lilypond) + getLilypondWithPrefix d x = (id, getLilypond d x) + + getLilypondChordWithPrefix :: Duration -> [a] -> (Lilypond -> Lilypond,Lilypond) + getLilypondChordWithPrefix d x = (id, getLilypondChord d x) + instance HasLilypond Int where getLilypond d = getLilypond d . toInteger instance HasLilypond Float where getLilypond d = getLilypond d . toInteger . round instance HasLilypond Double where getLilypond d = getLilypond d . toInteger . round instance Integral a => HasLilypond (Ratio a) where getLilypond d = getLilypond d . toInteger . round instance HasLilypond Integer where - getLilypond d p = Lilypond.note (spellLy $ p+12) ^*(fromDurationT $ d*4) + getLilypond d = (^*realToFrac (d*4)) . Lilypond.note . spellLilypond . (+ 12) + getLilypondChord d = (^*realToFrac (d*4)) . Lilypond.chord . fmap (spellLilypond . (+ 12)) +instance HasLilypond a => HasLilypond (ChordT a) where + getLilypond d = getLilypondChord d . getChordT + instance HasLilypond a => HasLilypond (PartT n a) where getLilypond d (PartT (_,x)) = getLilypond d x instance HasLilypond a => HasLilypond (TieT a) where - getLilypond d (TieT (ta,x,tb)) = addTies $ getLilypond d x + getLilypond d (TieT ((Any ta, Any tb),x)) = addTies $ getLilypond d x where addTies | ta && tb = id . Lilypond.beginTie | tb = Lilypond.beginTie @@ -111,7 +142,7 @@ | otherwise = id instance HasLilypond a => HasLilypond (DynamicT a) where - getLilypond d (DynamicT (ec,ed,l,a,bc,bd)) = notate $ getLilypond d a + getLilypond d (DynamicT (((Any ec,Any ed),Option l,(Any bc,Any bd)), a)) = notate $ getLilypond d a where notate x = nec . ned . nl . nbc . nbd $ x nec = if ec then Lilypond.endCresc else id @@ -119,11 +150,11 @@ nbc = if bc then Lilypond.beginCresc else id nbd = if bd then Lilypond.beginDim else id nl = case l of - Nothing -> id - Just lvl -> Lilypond.addDynamics (fromDynamics (DynamicsL (Just lvl, Nothing))) + Nothing -> id + Just (First lvl) -> Lilypond.addDynamics (fromDynamics (DynamicsL (Just lvl, Nothing))) instance HasLilypond a => HasLilypond (ArticulationT a) where - getLilypond d (ArticulationT (es,us,al,sl,a,bs)) = notate $ getLilypond d a + getLilypond d (ArticulationT (((Any es, Any us, Any bs), (Sum al, Sum sl)), a)) = notate $ getLilypond d a where notate = nes . nal . nsl . nbs nes = if es then Lilypond.endSlur else id @@ -140,12 +171,13 @@ nbs = if bs then Lilypond.beginSlur else id instance HasLilypond a => HasLilypond (TremoloT a) where - getLilypond d (TremoloT (n,x)) = notate $ getLilypond d x + getLilypond d (TremoloT (Sum 0, x)) = getLilypond d x + getLilypond d (TremoloT (Sum n, x)) = notate $ getLilypond newDur x where - notate = case n of - 0 -> id - _ -> Lilypond.Tremolo n - -- FIXME wrong number? + scale = 2^n + newDur = (d `min` (1/4)) / scale + repeats = d / newDur + notate = Lilypond.Tremolo (round repeats) instance HasLilypond a => HasLilypond (TextT a) where getLilypond d (TextT (s,x)) = notate s $ getLilypond d x @@ -153,35 +185,90 @@ notate ts = foldr (.) id (fmap Lilypond.addText ts) instance HasLilypond a => HasLilypond (HarmonicT a) where - getLilypond d (HarmonicT (n,x)) = notate $ getLilypond d x + getLilypond d (HarmonicT ((view _Wrapped' -> isNat, view _Wrapped' -> n),x)) = notate isNat n $ getLilypond d x where - notate = id - -- FIXME + notate _ 0 = id + notate True n = notateNatural n + notate False n = notateArtificial n + notateNatural n = Lilypond.addFlageolet -- addOpen? + + notateArtificial n = id -- TODO + instance HasLilypond a => HasLilypond (SlideT a) where - getLilypond d (SlideT (eg,es,a,bg,bs)) = notate $ getLilypond d a + getLilypond d (SlideT (((eg,es),(bg,bs)),a)) = notate $ getLilypond d a where - notate = id - -- FIXME + notate = if view _Wrapped' bg || view _Wrapped' bs then Lilypond.beginGlissando else id +instance HasLilypond a => HasLilypond (ClefT a) where + -- TODO consolidate + getLilypondWithPrefix d (ClefT (c, a)) = (notate c, getLilypond d a) + where + notate c = case fmap getLast $ getOption c of + Nothing -> id + Just c -> \x -> Lilypond.Sequential [addClef c, x] + getLilypond d (ClefT (c, a)) = notate c $ getLilypond d a + where + notate c = case fmap getLast $ getOption c of + Nothing -> id + Just c -> \x -> Lilypond.Sequential [addClef c, x] +instance HasLilypond a => HasLilypond (Behavior a) where + getLilypond d = getLilypond d . (? 0) --- TODO rename -pcatLy :: [Lilypond] -> Lilypond -pcatLy = foldr Lilypond.pcat (Lilypond.Simultaneous False []) +-- TODO +addClef GClef = Lilypond.Clef Lilypond.Treble +addClef CClef = Lilypond.Clef Lilypond.Alto +addClef FClef = Lilypond.Clef Lilypond.Bass -scatLy :: [Lilypond] -> Lilypond -scatLy = foldr Lilypond.scat (Lilypond.Sequential []) +pcatLilypond :: [Lilypond] -> Lilypond +pcatLilypond = pcatLilypond' False +pcatLilypond' :: Bool -> [Lilypond] -> Lilypond +pcatLilypond' p = foldr Lilypond.simultaneous e + where + e = Lilypond.Simultaneous p [] + +scatLilypond :: [Lilypond] -> Lilypond +scatLilypond = foldr Lilypond.sequential e + where + e = Lilypond.Sequential [] + + -- | +-- Convert a score to a Lilypond representaiton and print it on the standard output. +-- +showLilypond :: (HasLilypond a, HasPart' a, Semigroup a) => Score a -> IO () +showLilypond = putStrLn . toLilypondString + +-- | -- Convert a score to a Lilypond representation and write to a file. -- -writeLy :: (HasLilypond a, HasPart' a, Show (Part a)) => FilePath -> Score a -> IO () -writeLy path sc = writeFile path ((header ++) $ show $ Pretty.pretty $ toLy sc) +writeLilypond :: (HasLilypond a, HasPart' a, Semigroup a) => FilePath -> Score a -> IO () +writeLilypond = writeLilypond' def + +data LilypondOptions + = Inline + | Score +instance Default LilypondOptions where + def = Inline + +-- | +-- Convert a score to a Lilypond representation and write to a file. +-- +writeLilypond' :: (HasLilypond a, HasPart' a, Semigroup a) => LilypondOptions -> FilePath -> Score a -> IO () +writeLilypond' options path sc = writeFile path $ (lyFilePrefix ++) $ toLilypondString sc where - header = mempty ++ + title = fromMaybe "" $ flip getTitleAt 0 $ metaAtStart sc + composer = fromMaybe "" $ flip getAttribution "composer" $ metaAtStart sc + + lyFilePrefix = case options of + Inline -> lyInlinePrefix + Score -> lyScorePrefix + + lyInlinePrefix = mempty ++ "\\include \"lilypond-book-preamble.ly\"\n" ++ "\\paper {\n" ++ " #(define dump-extents #t)\n" ++ @@ -192,60 +279,156 @@ " force-assignment = #\"\"\n" ++ " line-width = #(- line-width (* mm 3.000000))\n" ++ "}\n" ++ + "\\header {\n" ++ + " title = \"" ++ title ++ "\"\n" ++ + " composer = \"" ++ composer ++ "\"\n" ++ + "}\n" ++ "\\layout {\n" ++ - "}\n" + "}" ++ + "\n\n" + lyScorePrefix = mempty ++ + "\\paper {" ++ + " indent = 0\\mm" ++ + " line-width = 210\\mm - 2.0 * 0.4\\in" ++ + "}" ++ + "\\header {\n" ++ + " title = \"" ++ title ++ "\"\n" ++ + " composer = \"" ++ composer ++ "\"\n" ++ + "}\n" ++ + "\\layout {" ++ + "}" ++ + "\n\n" + + -- | -- Typeset a score using Lilypond and open it. -- -openLy :: (HasLilypond a, HasPart' a, Show (Part a)) => Score a -> IO () -openLy sc = do - writeLy "test.ly" sc - runLy - cleanLy - openLy' +openLilypond :: (HasLilypond a, HasPart' a, Semigroup a) => Score a -> IO () +openLilypond = openLilypond' def -runLy = runCommand "lilypond -f pdf test.ly" >>= waitForProcess >> return () -cleanLy = runCommand "rm -f test-*.tex test-*.texi test-*.count test-*.eps test-*.pdf test.eps" -openLy' = runCommand "open test.pdf" >> return () - -- FIXME hardcoded +openLilypond' :: (HasLilypond a, HasPart' a, Semigroup a) => LilypondOptions -> Score a -> IO () +openLilypond' options sc = do + writeLilypond' options "test.ly" sc + runLilypond + cleanLilypond + openLilypond'' +runLilypond = void $ runCommand "lilypond -f pdf test.ly" >>= waitForProcess +cleanLilypond = void $ runCommand "rm -f test-*.tex test-*.texi test-*.count test-*.eps test-*.pdf test.eps" +openLilypond'' = void $ runCommand "open test.pdf" + -- | +-- Convert a score to a Lilypond string. +-- +toLilypondString :: (HasLilypond a, HasPart' a, Semigroup a) => Score a -> String +toLilypondString = show . Pretty.pretty . toLilypond + +-- | -- Convert a score to a Lilypond representation. -- -toLy :: (HasLilypond a, HasPart' a, Show (Part a)) => Score a -> Lilypond -toLy sc = pcatLy . fmap (addStaff . scatLy . prependName . second toLyVoice' . second scoreToVoice) . extractParts $ sc +toLilypond :: (HasLilypond a, HasPart' a, Semigroup a) => Score a -> Lilypond +toLilypond sc = + -- Score structure + pcatLilypond . fmap ( + addStaff . scatLilypond . uncurry addPartName + + -- Main notation pipeline + . second (voiceToLilypond barTimeSigs barDurations . scoreToVoice . simultaneous) + + -- Meta-event expansion + . uncurry addClefs + ) + + . extractParts' $ sc + where - addStaff x = Lilypond.New "Staff" Nothing x - prependName (v,x) = [Lilypond.Set "Staff.instrumentName" (Lilypond.toValue $ show v)] ++ x + addClefT :: a -> ClefT a + addClefT = return + addClefs p = (,) p . setClef . fmap addClefT + setClef = withClef def $ \c x -> applyClef c x where def = GClef -- TODO use part default + + timeSigs = getTimeSignatures (time 4 4) sc -- 4/4 is default + timeSigsV = fmap swap $ (^. from voice) $ mergeEqual $ reactiveToVoice' (start <-> offset sc) timeSigs + + -- Despite mergeEqual above we need retainUpdates here to prevent redundant repetition of time signatures + barTimeSigs = retainUpdates $ getBarTimeSignatures $ timeSigsV + barDurations = getBarDurations $ timeSigsV + + + -- getTimeSignatures def = fmap (fromMaybe def . unOptionFirst) . runMeta (Nothing::Maybe Int) . getScoreMeta + -- getTimeSignatureChanges def = updates . fmap (fromMaybe def . unOptionFirst) . runMeta (Nothing::Maybe Int) . getScoreMeta + + addStaff = Lilypond.New "Staff" Nothing + addPartName partName x = Lilypond.Set "Staff.instrumentName" (Lilypond.toValue $ show partName) + : Lilypond.Set "Staff.shortInstrumentName" (Lilypond.toValue $ show partName) + : x + +mergeBars :: [Lilypond] -> Lilypond +mergeBars [x] = x +mergeBars _ = error "mergeBars: Not supported" + -- | -- Convert a voice score to a list of bars. -- -toLyVoice' :: HasLilypond a => Voice (Maybe a) -> [Lilypond] -toLyVoice' = fmap barToLy . voiceToBars +voiceToLilypond :: HasLilypond a => [Maybe TimeSignature] -> [Duration] -> Voice (Maybe a) -> [Lilypond] +voiceToLilypond barTimeSigs barDurations = zipWith setBarTimeSig barTimeSigs . fmap barToLilypond . voiceToBars' barDurations +-- +-- This is where notation of a single voice takes place +-- * voiceToBars is generic for most notations outputs: it handles bar splitting and ties +-- * barToLilypond is specific: it handles quantization and notation +-- + where + -- FIXME compounds + setBarTimeSig Nothing x = x + setBarTimeSig (Just (getTimeSignature -> (m:_, n))) x = scatLilypond [Lilypond.Time m n, x] -barToLy :: HasLilypond a => [(DurationT, Maybe a)] -> Lilypond -barToLy bar = case quantize bar of - Left e -> error $ "barToLy: Could not quantize this bar: " ++ show e - Right rh -> rhythmToLy rh -rhythmToLy :: HasLilypond a => Rhythm (Maybe a) -> Lilypond -rhythmToLy (Beat d x) = noteRestToLy d x -rhythmToLy (Group rs) = foldr Lilypond.scat (Lilypond.Sequential []) $ map rhythmToLy rs -rhythmToLy (Dotted n (Beat d x)) = noteRestToLy (dotMod n * d) x -rhythmToLy (Tuplet m r) = Lilypond.Times (fromDurationT m) (rhythmToLy r) - where (a,b) = both fromIntegral fromIntegral $ unRatio $ fromDurationT m +barToLilypond :: HasLilypond a => [(Duration, Maybe a)] -> Lilypond +barToLilypond bar = case (fmap rewrite . quantize) bar of + Left e -> error $ "barToLilypond: Could not quantize this bar: " ++ show e + Right rh -> rhythmToLilypond rh -noteRestToLy :: HasLilypond a => DurationT -> Maybe a -> Lilypond -noteRestToLy d Nothing = Lilypond.rest^*(fromDurationT $ d*4) -noteRestToLy d (Just p) = getLilypond d p +rhythmToLilypond = uncurry ($) . rhythmToLilypond2 -spellLy :: Integer -> Lilypond.Note -spellLy a = Lilypond.NotePitch (spellLy' a) Nothing +-- rhythmToLilypond :: HasLilypond a => Rhythm (Maybe a) -> Lilypond +-- rhythmToLilypond (Beat d x) = noteRestToLilypond d x +-- rhythmToLilypond (Dotted n (Beat d x)) = noteRestToLilypond (dotMod n * d) x +-- rhythmToLilypond (Group rs) = scatLilypond $ map rhythmToLilypond rs +-- rhythmToLilypond (Tuplet m r) = Lilypond.Times (realToFrac m) (rhythmToLilypond r) +-- where (a,b) = fromIntegral *** fromIntegral $ unRatio $ realToFrac m +-- +-- noteRestToLilypond :: HasLilypond a => Duration -> Maybe a -> Lilypond +-- noteRestToLilypond d Nothing = Lilypond.rest^*(realToFrac d*4) +-- noteRestToLilypond d (Just p) = Lilypond.removeSingleChords $ getLilypond d p -spellLy' :: Integer -> Lilypond.Pitch -spellLy' p = Lilypond.Pitch ( + + +rhythmToLilypond2 :: HasLilypond a => Rhythm (Maybe a) -> (Lilypond -> Lilypond, Lilypond) +rhythmToLilypond2 (Beat d x) = noteRestToLilypond2 d x +rhythmToLilypond2 (Dotted n (Beat d x)) = noteRestToLilypond2 (dotMod n * d) x + +-- TODO propagate +rhythmToLilypond2 (Group rs) = first (maybe id id) $ second scatLilypond $ extract1 $ map rhythmToLilypond2 $ rs + +rhythmToLilypond2 (Tuplet m r) = second (Lilypond.Times (realToFrac m)) $ (rhythmToLilypond2 r) + where (a,b) = fromIntegral *** fromIntegral $ unRatio $ realToFrac m + +noteRestToLilypond2 :: HasLilypond a => Duration -> Maybe a -> (Lilypond -> Lilypond, Lilypond) +noteRestToLilypond2 d Nothing = ( id, Lilypond.rest^*(realToFrac d*4) ) +noteRestToLilypond2 d (Just p) = second Lilypond.removeSingleChords $ getLilypondWithPrefix d p + +-- extract first value of type b +extract1 :: [(b, a)] -> (Maybe b, [a]) +extract1 [] = (Nothing, []) +extract1 ((p,x):xs) = (Just p, x : fmap snd xs) + +spellLilypond :: Integer -> Lilypond.Note +spellLilypond a = Lilypond.NotePitch (spellLilypond' a) Nothing + +spellLilypond' :: Integer -> Lilypond.Pitch +spellLilypond' p = Lilypond.Pitch ( toEnum $ fromIntegral pc, fromIntegral alt, fromIntegral oct diff --git a/src/Music/Score/Export/Midi.hs b/src/Music/Score/Export/Midi.hs --- a/src/Music/Score/Export/Midi.hs +++ b/src/Music/Score/Export/Midi.hs @@ -1,16 +1,16 @@ -{-# LANGUAGE - TypeFamilies, - DeriveFunctor, - DeriveFoldable, - DeriveDataTypeable, - GeneralizedNewtypeDeriving, - FlexibleInstances, - FlexibleContexts, - ConstraintKinds, - TypeOperators, - OverloadedStrings, - NoMonomorphismRestriction #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} ------------------------------------------------------------------------------------- -- | @@ -26,60 +26,90 @@ module Music.Score.Export.Midi ( HasMidi(..), + HasMidiPart, + HasMidiProgram(..), toMidi, toMidiTrack, writeMidi, - playMidi, + -- playMidi, playMidiIO, ) where -import Prelude hiding (foldr, concat, foldl, mapM, concatMap, maximum, sum, minimum) +import Prelude hiding (concat, concatMap, foldl, + foldr, mapM, maximum, minimum, sum) -import Data.Semigroup -import Data.Ratio -import Data.String -import Control.Applicative -import Control.Monad hiding (mapM) -import Control.Monad.Plus -import Data.Maybe -import Data.Either -import Data.Foldable -import Data.Typeable -import Data.Traversable -import Data.Function (on) -import Data.Ord (comparing) -import Data.VectorSpace -import Data.AffineSpace -import Data.Basis +import Control.Applicative +import Control.Arrow +import Control.Lens hiding ((|>)) +import Control.Monad hiding (mapM) +import Control.Monad.Plus +import Data.AffineSpace +import Data.AffineSpace.Point +import Data.Basis +import Data.Either +import Data.Foldable +import Data.Function (on) +import Data.Maybe +import Data.Ord (comparing) +import Data.Ratio +import Data.Semigroup +import Data.String +import Data.Traversable +import Data.Typeable +import Data.VectorSpace -import Control.Reactive -import Control.Reactive.Midi +import Codec.Midi hiding (Track) +-- import Control.Reactive hiding (Event) +-- import qualified Control.Reactive as R +-- import Control.Reactive.Midi -import Music.Time -import Music.Pitch.Literal -import Music.Dynamics.Literal -import Music.Score.Rhythm -import Music.Score.Track -import Music.Score.Voice -import Music.Score.Score -import Music.Score.Combinators -import Music.Score.Zip -import Music.Score.Pitch -import Music.Score.Ties -import Music.Score.Part -import Music.Score.Articulation -import Music.Score.Dynamics -import Music.Score.Ornaments -import Music.Score.Export.Util +import Music.Dynamics.Literal +import Music.Pitch.Literal +import Music.Score.Articulation +import Music.Score.Chord +import Music.Score.Combinators +import Music.Score.Dynamics +import Music.Score.Export.Common +import Music.Score.Ornaments +import Music.Score.Part +import Music.Score.Pitch +import Music.Score.Rhythm +import Music.Score.Score +import Music.Score.Ties +import Music.Score.Track +import Music.Score.Voice +import Music.Time -import qualified Codec.Midi as Midi -import qualified Music.MusicXml.Simple as Xml -import qualified Music.Lilypond as Lilypond -import qualified Text.Pretty as Pretty -import qualified Data.Map as Map -import qualified Data.List as List +import qualified Codec.Midi as Midi +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Music.Lilypond as Lilypond +import qualified Music.MusicXml.Simple as Xml +import qualified Text.Pretty as Pretty +-- | Class of types with MIDI-compatible parts. +type HasMidiPart a = (HasPart' a, HasMidiProgram (Part a)) + +-- | Class of part types with an associated MIDI program number. +class HasMidiProgram a where + getMidiChannel :: a -> Midi.Channel + getMidiProgram :: a -> Midi.Preset + getMidiChannel _ = 0 + +instance HasMidiProgram () where + getMidiProgram _ = 0 +instance HasMidiProgram Double where + getMidiProgram = fromIntegral . floor +instance HasMidiProgram Float where + getMidiProgram = fromIntegral . floor +instance HasMidiProgram Int where + getMidiProgram = id +instance HasMidiProgram Integer where + getMidiProgram = fromIntegral +instance (Integral a, HasMidiProgram a) => HasMidiProgram (Ratio a) where + getMidiProgram = fromIntegral . floor + -- | -- Class of types that can be converted to MIDI. -- @@ -108,20 +138,22 @@ instance HasMidi Midi.Message where getMidi = return instance HasMidi Int where getMidi = getMidi . toInteger -instance HasMidi Integer where getMidi = \x -> getMidi (x,100::Integer) instance HasMidi Float where getMidi = getMidi . toInteger . round instance HasMidi Double where getMidi = getMidi . toInteger . round instance Integral a => HasMidi (Ratio a) where getMidi = getMidi . toInteger . round instance HasMidi a => HasMidi (Maybe a) where getMidi = getMidiScore . mfromMaybe +instance HasMidi Integer where getMidi x = getMidi (x,100::Integer) instance HasMidi a => HasMidi (PartT n a) where getMidi (PartT (_,a)) = getMidi a +instance HasMidi a => HasMidi (ChordT a) where + getMidi = pcat . fmap getMidi . getChordT instance HasMidi a => HasMidi (TieT a) where - getMidi (TieT (_,a,_)) = getMidi a + getMidi (TieT (_,a)) = getMidi a instance HasMidi a => HasMidi (DynamicT a) where - getMidi (DynamicT (ec,ed,l,a,bc,bd)) = getMidi a + getMidi (DynamicT (_,a)) = getMidi a instance HasMidi a => HasMidi (ArticulationT a) where - getMidi (ArticulationT (es,us,al,sl,a,bs)) = getMidi a + getMidi (ArticulationT (_,a)) = getMidi a instance HasMidi a => HasMidi (TremoloT a) where getMidi (TremoloT (_,a)) = getMidi a instance HasMidi a => HasMidi (TextT a) where @@ -129,53 +161,64 @@ instance HasMidi a => HasMidi (HarmonicT a) where getMidi (HarmonicT (_,a)) = getMidi a instance HasMidi a => HasMidi (SlideT a) where - getMidi (SlideT (_,_,a,_,_)) = getMidi a + getMidi (SlideT (_,a)) = getMidi a +instance HasMidi a => HasMidi (Behavior a) where + getMidi = getMidi . (? 0) -- | -- Convert a score to a MIDI file representation. -- -toMidi :: HasMidi a => Score a -> Midi.Midi -toMidi score = Midi.Midi fileType divisions' [controlTrack, eventTrack] +toMidi :: forall a . (HasMidiPart a, HasMidi a) => Score a -> Midi.Midi +toMidi score = Midi.Midi fileType divisions' (controlTrack : eventTracks) where - endPos = 10000 + -- Each track needs TrackEnd + -- We place it long after last event just in case (necessary?) + endDelta = 10000 fileType = Midi.MultiTrack divisions = 1024 divisions' = Midi.TicksPerBeat divisions - controlTrack = [(0, Midi.TempoChange 1000000), (endPos, Midi.TrackEnd)] - eventTrack = events <> [(endPos, Midi.TrackEnd)] + controlTrack = [(0, Midi.TempoChange 1000000), (endDelta, Midi.TrackEnd)] + eventTracks = fmap ((<> [(endDelta, Midi.TrackEnd)]) . uncurry setProgramChannel . second scoreToMTrack) + $ extractParts' score - events :: [(Midi.Ticks, Midi.Message)] - events = (\(t,_,x) -> (round (t * divisions), x)) <$> performance + setProgramChannel :: Part a -> Midi.Track Midi.Ticks -> Midi.Track Midi.Ticks + setProgramChannel p = ([(0, Midi.ProgramChange ch prg)] <>) . fmap (fmap (setChannel ch)) + where + ch = getMidiChannel p + prg = getMidiProgram p - performance :: [(TimeT, DurationT, Midi.Message)] - performance = (toRelative . perform) (getMidiScore score) + scoreToMTrack :: Score a -> Midi.Track Midi.Ticks + scoreToMTrack = fmap (\(t,_,x) -> (round ((t.-. origin) ^* divisions), x)) . toRelative . (^. events) . getMidiScore - -- FIXME arbitrary endTimeT (files won't work without this...) -- TODO render voices separately -- | -- Convert a score to a track of MIDI messages. -- toMidiTrack :: HasMidi a => Score a -> Track Message -toMidiTrack = Track . fmap (\(t,_,m) -> (t,m)) . perform . getMidiScore +toMidiTrack = (^. track) . fmap (\(t,_,m) -> (t, m)) . (^. events) . getMidiScore -- | -- Convert a score MIDI and write to a file. -- -writeMidi :: HasMidi a => FilePath -> Score a -> IO () +writeMidi :: (HasMidiPart a, HasMidi a) => FilePath -> Score a -> IO () writeMidi path sc = Midi.exportFile path (toMidi sc) +playMidiIO :: HasMidi a => String -> Score a -> IO () +playMidiIO = error "playMidiIO: Not implemented" + +{- -- | -- Convert a score to a MIDI event. -- -playMidi :: HasMidi a => String -> Score a -> Event MidiMessage -playMidi dest x = midiOut midiDest $ playback trig (pure $ toTrack $ delay 0.2 x) +playMidi :: HasMidi a => String -> Score a -> R.Event MidiMessage +playMidi dest x = midiOut midiDest $ playback trig (pure $ toTrack $ startAt 0.2 x) where -- trig = accumR 0 ((+ 0.005) <$ pulse 0.005) trig = time - toTrack = fmap (\(t,_,m) -> (t,m)) . perform . getMidiScore + toTrack = fmap (\(t,_,m) -> (t .-. origin, m)) . (^. events) . getMidiScore midiDest = fromJust $ unsafeGetReactive (findDestination $ pure dest) -- | @@ -183,4 +226,20 @@ -- playMidiIO :: HasMidi a => String -> Score a -> IO () playMidiIO dest = runLoop . playMidi dest +-} + + + +setChannel :: Midi.Channel -> Midi.Message -> Midi.Message +setChannel c = go + where + go (NoteOff _ k v) = NoteOff c k v + go (NoteOn _ k v) = NoteOn c k v + go (KeyPressure _ k v) = KeyPressure c k v + go (ControlChange _ n v) = ControlChange c n v + go (ProgramChange _ p) = ProgramChange c p + go (ChannelPressure _ p) = ChannelPressure c p + go (PitchWheel _ w) = PitchWheel c w + go (ChannelPrefix _) = ChannelPrefix c + diff --git a/src/Music/Score/Export/MusicXml.hs b/src/Music/Score/Export/MusicXml.hs --- a/src/Music/Score/Export/MusicXml.hs +++ b/src/Music/Score/Export/MusicXml.hs @@ -1,15 +1,15 @@ -{-# LANGUAGE - TypeFamilies, - DeriveFunctor, - DeriveFoldable, - DeriveDataTypeable, - GeneralizedNewtypeDeriving, - FlexibleContexts, - ConstraintKinds, - TypeOperators, - OverloadedStrings, - NoMonomorphismRestriction #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} ------------------------------------------------------------------------------------- -- | @@ -27,58 +27,66 @@ XmlScore, XmlMusic, HasMusicXml(..), - toXml, - writeXml, - openXml, - toXmlVoice, - toXmlSingle, - writeXmlSingle, - openXmlSingle, + + toMusicXml, + toMusicXmlString, + + showMusicXml, + openMusicXml, + writeMusicXml, ) where -import Prelude hiding (foldr, concat, foldl, mapM, concatMap, maximum, sum, minimum) +import Prelude hiding (concat, concatMap, foldl, + foldr, mapM, maximum, minimum, + sum) -import Data.Semigroup -import Data.Ratio -import Data.String -import Control.Applicative -import Control.Monad hiding (mapM) -import Control.Monad.Plus -import Data.Maybe -import Data.Either -import Data.Foldable -import Data.Typeable -import Data.Traversable -import Data.Function (on) -import Data.Ord (comparing) -import Data.VectorSpace -import Data.AffineSpace -import Data.Basis +import Control.Applicative +import Control.Arrow +import Control.Lens hiding (rewrite) +import Control.Monad hiding (mapM) +import Data.Function (on) +import Data.Maybe +import Data.Monoid.WithSemigroup +import Data.Ord (comparing) +import Data.Ratio +import Data.Semigroup +import Data.String +import System.Process -import Music.Time -import Music.Pitch.Literal -import Music.Dynamics.Literal -import Music.Score.Rhythm -import Music.Score.Track -import Music.Score.Voice -import Music.Score.Score -import Music.Score.Combinators -import Music.Score.Zip -import Music.Score.Pitch -import Music.Score.Ties -import Music.Score.Part -import Music.Score.Articulation -import Music.Score.Dynamics -import Music.Score.Ornaments -import Music.Score.Instances -import Music.Score.Export.Util +import Music.Dynamics.Literal +import Music.Pitch.Literal +import Music.Score.Articulation +import Music.Score.Chord +import Music.Score.Clef +import Music.Score.Combinators +import Music.Score.Convert +import Music.Score.Convert +import Music.Score.Dynamics +import Music.Score.Export.Common +import Music.Score.Instances +import Music.Score.Meta +import Music.Score.Meta.Attribution +import Music.Score.Meta.Clef +import Music.Score.Meta.Time +import Music.Score.Meta.Title +import Music.Score.Ornaments +import Music.Score.Part +import Music.Score.Pitch +import Music.Score.Rhythm +import Music.Score.Score +import Music.Score.Ties +import Music.Score.Track +import Music.Score.Util +import Music.Score.Voice +import Music.Time +import Music.Time.Reactive (Reactive, initial) -import qualified Codec.Midi as Midi -import qualified Music.MusicXml.Simple as Xml -import qualified Music.Lilypond as Lilypond -import qualified Text.Pretty as Pretty -import qualified Data.Map as Map -import qualified Data.List as List +import qualified Codec.Midi as Midi +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Music.Lilypond as Lilypond +import qualified Music.MusicXml.Simple as Xml +import qualified Text.Pretty as Pretty type XmlScore = Xml.Score @@ -94,22 +102,28 @@ -- Typically, generates a 'XmlMusic' value using 'Xml.note' or 'Xml.chord', and transforms it -- to add beams, slurs, dynamics, articulation etc. -- - getMusicXml :: DurationT -> a -> XmlMusic + getMusicXml :: Duration -> a -> XmlMusic + getMusicXmlChord :: Duration -> [a] -> XmlMusic + getMusicXmlChord d = error "getMusicXmlChord: Not implemented" + instance HasMusicXml Int where getMusicXml d = getMusicXml d . toInteger instance HasMusicXml Float where getMusicXml d = getMusicXml d . toInteger . round instance HasMusicXml Double where getMusicXml d = getMusicXml d . toInteger . round instance Integral a => HasMusicXml (Ratio a) where getMusicXml d = getMusicXml d . toInteger . round --- instance HasMusicXml a => HasMusicXml (Maybe a) where getMusicXml d = ? instance HasMusicXml Integer where - getMusicXml d p = Xml.note (spellXml (fromIntegral p)) . fromDurationT $ d + getMusicXml d = (`Xml.note` realToFrac d) . spellMusicXml . fromIntegral + getMusicXmlChord d = (`Xml.chord` realToFrac d) . fmap (spellMusicXml . fromIntegral) +instance HasMusicXml a => HasMusicXml (ChordT a) where + getMusicXml d = getMusicXmlChord d . getChordT + instance HasMusicXml a => HasMusicXml (PartT n a) where getMusicXml d (PartT (_,x)) = getMusicXml d x instance HasMusicXml a => HasMusicXml (TieT a) where - getMusicXml d (TieT (ta,x,tb)) = addTies $ getMusicXml d x + getMusicXml d (TieT ((Any ta,Any tb),x)) = addTies $ getMusicXml d x where addTies | ta && tb = Xml.endTie . Xml.beginTie | tb = Xml.beginTie @@ -117,7 +131,7 @@ | otherwise = id instance HasMusicXml a => HasMusicXml (DynamicT a) where - getMusicXml d (DynamicT (ec,ed,l,a,bc,bd)) = notate $ getMusicXml d a + getMusicXml d (DynamicT (((Any ec,Any ed),Option l,(Any bc,Any bd)), a)) = notate $ getMusicXml d a where notate x = nec <> ned <> nl <> nbc <> nbd <> x nec = if ec then Xml.endCresc else mempty @@ -125,11 +139,11 @@ 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))) + Nothing -> mempty + Just (First lvl) -> Xml.dynamic (fromDynamics (DynamicsL (Just lvl, Nothing))) instance HasMusicXml a => HasMusicXml (ArticulationT a) where - getMusicXml d (ArticulationT (es,us,al,sl,a,bs)) = notate $ getMusicXml d a + getMusicXml d (ArticulationT (((Any es, Any us, Any bs), (Sum al, Sum sl)), a)) = notate $ getMusicXml d a where notate = nes . nal . nsl . nbs nes = if es then Xml.endSlur else id @@ -146,7 +160,7 @@ nbs = if bs then Xml.beginSlur else id instance HasMusicXml a => HasMusicXml (TremoloT a) where - getMusicXml d (TremoloT (n,x)) = notate $ getMusicXml d x + getMusicXml d (TremoloT (Sum n,x)) = notate $ getMusicXml d x where notate = case n of 0 -> id @@ -158,120 +172,177 @@ notate ts a = mconcat (fmap Xml.text ts) <> a instance HasMusicXml a => HasMusicXml (HarmonicT a) where - getMusicXml d (HarmonicT (n,x)) = notate $ getMusicXml d x + getMusicXml d (HarmonicT ((view _Wrapped' -> isNat, view _Wrapped' -> n),x)) = notate isNat n $ getMusicXml d x where - notate | n /= 0 = Xml.setNoteHead Xml.DiamondNoteHead - | otherwise = id + notate _ 0 = id + notate True n = notateNatural n + notate False n = notateArtificial n + + -- notateNatural n = Xml.harmonic -- openString? + notateNatural n = Xml.setNoteHead Xml.DiamondNoteHead + -- Most programs do not recognize the harmonic tag + -- We set a single diamond notehead instead, which can be manually replaced + + notateArtificial n = id -- TODO + + + -- notate | n /= 0 = Xml.setNoteHead Xml.DiamondNoteHead -- TODO adjust pitch etc instance HasMusicXml a => HasMusicXml (SlideT a) where - getMusicXml d (SlideT (eg,es,a,bg,bs)) = notate $ getMusicXml d a + getMusicXml d (SlideT (((eg,es),(bg,bs)),a)) = 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 + neg = if view _Wrapped' eg then Xml.endGliss else id + nes = if view _Wrapped' es then Xml.endSlide else id + nbg = if view _Wrapped' bg then Xml.beginGliss else id + nbs = if view _Wrapped' bs then Xml.beginSlide else id +instance HasMusicXml a => HasMusicXml (ClefT a) where + getMusicXml d (ClefT (c, a)) = notate $ getMusicXml d a + where + notate = case fmap getLast $ getOption c of + Nothing -> id + Just GClef -> (Xml.trebleClef <>) + Just CClef -> (Xml.altoClef <>) + Just FClef -> (Xml.bassClef <>) +instance HasMusicXml a => HasMusicXml (Behavior a) where + getMusicXml d = getMusicXml d . (? 0) + + -- | -- Convert a score to MusicXML and write to a file. -- -writeXml :: (HasMusicXml a, HasPart' a, Show (Part a)) => FilePath -> Score a -> IO () -writeXml path sc = writeFile path (Xml.showXml $ toXml sc) +writeMusicXml :: (HasMusicXml a, HasPart' a, Semigroup a) => FilePath -> Score a -> IO () +writeMusicXml path sc = writeFile path (Xml.showXml $ toMusicXml sc) -- | -- Convert a score to MusicXML and open it. -- -openXml :: (HasMusicXml a, HasPart' a, Show (Part a)) => Score a -> IO () -openXml sc = do - writeXml "test.xml" sc - execute "open" ["-a", "/Applications/Sibelius 6.app/Contents/MacOS/Sibelius 6", "test.xml"] - -- FIXME hardcoded +openMusicXml :: (HasMusicXml a, HasPart' a, Semigroup a) => Score a -> IO () +openMusicXml sc = do + writeMusicXml "test.xml" sc + -- FIXME find out which program to use... + void $ rawSystem "open" ["-a", "Sibelius 7", "test.xml"] +-- -- | +-- -- Convert a score to MusicXML and write to a file. +-- -- +-- writeXmlSingle :: HasMusicXml a => FilePath -> Score a -> IO () +-- writeXmlSingle path sc = writeFile path (Xml.showXml $ toXmlSingle sc) + +-- -- | +-- -- Convert a score to MusicXML and open it. +-- -- +-- openXmlSingle :: HasMusicXml a => Score a -> IO () +-- openXmlSingle sc = do +-- writeXmlSingle "test.xml" sc +-- void $ rawSystem "open" ["-a", "/Applications/Sibelius 6.app/Contents/MacOS/Sibelius 6", "test.xml"] + -- | --- Convert a score to MusicXML and write to a file. +-- Convert a score to MusicXML and print it on the standard output. -- -writeXmlSingle :: HasMusicXml a => FilePath -> Score a -> IO () -writeXmlSingle path sc = writeFile path (Xml.showXml $ toXmlSingle sc) +showMusicXml :: (HasMusicXml a, HasPart' a, Semigroup a) => Score a -> IO () +showMusicXml = putStrLn . toMusicXmlString -- | --- Convert a score to MusicXML and open it. +-- Convert a score to a MusicXML string. -- -openXmlSingle :: HasMusicXml a => Score a -> IO () -openXmlSingle sc = do - writeXmlSingle "test.xml" sc - execute "open" ["-a", "/Applications/Sibelius 6.app/Contents/MacOS/Sibelius 6", "test.xml"] - -- FIXME hardcoded - +toMusicXmlString :: (HasMusicXml a, HasPart' a, Semigroup a) => Score a -> String +toMusicXmlString = Xml.showXml . toMusicXml -- | -- Convert a score to a MusicXML representation. -- -toXml :: (HasMusicXml a, HasPart' a, Show (Part a)) => Score a -> XmlScore -toXml sc = Xml.fromParts "Title" "Composer" pl . fmap (toXmlVoice' . scoreToVoice) . extract $ sc +toMusicXml :: (HasMusicXml a, HasPart' a, Semigroup a) => Score a -> XmlScore +toMusicXml sc = + -- Score structure + Xml.fromParts title composer pl + + -- Main notation pipeline + . fmap (voiceToMusicXml' barTimeSigs barDurations . scoreToVoice . simultaneous + + -- Meta-event expansion + . addClefs + ) + + . extractParts $ sc + where + addClefT :: a -> ClefT a + addClefT = return + + addClefs = setClef . fmap addClefT + setClef = withClef def $ \c x -> applyClef c x where def = GClef -- TODO use part default + + timeSigs = getTimeSignatures (time 4 4) sc -- 4/4 is default + timeSigsV = fmap swap $ (^. from voice) $ mergeEqual $ reactiveToVoice' (start <-> offset sc) timeSigs + + -- Despite mergeEqual above we need retainUpdates here to prevent redundant repetition of time signatures + barTimeSigs = retainUpdates $ getBarTimeSignatures $ timeSigsV + barDurations = getBarDurations $ timeSigsV + + title = fromMaybe "" $ flip getTitleAt 0 $ metaAtStart sc + composer = fromMaybe "" $ flip getAttribution "composer" $ metaAtStart sc + pl = Xml.partList (fmap show $ getParts sc) --- | --- Convert a single-voice score to a MusicXML representation. --- -toXmlSingle :: HasMusicXml a => Score a -> XmlScore -toXmlSingle = toXmlVoice . scoreToVoice +mergeBars :: [XmlMusic] -> XmlMusic +mergeBars [x] = x +mergeBars _ = error "mergeBars: Not supported" -- | --- Convert a single-voice score to a MusicXML representation. +-- Convert a voice score to a list of bars. -- -toXmlVoice :: HasMusicXml a => Voice (Maybe a) -> XmlScore -toXmlVoice = Xml.fromPart "Title" "Composer" "Voice" . toXmlVoice' +voiceToMusicXml' :: HasMusicXml a => [Maybe TimeSignature] -> [Duration] -> Voice (Maybe a) -> [XmlMusic] +voiceToMusicXml' barTimeSigs barDurations = addStartInfo . zipWith setBarTimeSig barTimeSigs . fmap barToMusicXml . voiceToBars' barDurations +-- TODO attach key signatures in each bar (basically zip) --- | --- Convert a voice score to a list of bars. -- -toXmlVoice' :: HasMusicXml a => Voice (Maybe a) -> [XmlMusic] -toXmlVoice' = - addDefaultSignatures . fmap barToXml . voiceToBars +-- This is where notation of a single voice takes place +-- * voiceToBars is generic for most notations outputs: it handles bar splitting and ties +-- * barToMusicXml is specific: it handles quantization and notation +-- where - addDefaultSignatures [] = [] - addDefaultSignatures (x:xs) = (defaultSignatures <> x):xs - defaultSignatures = mempty + -- FIXME compounds + setBarTimeSig Nothing x = x + setBarTimeSig (Just (getTimeSignature -> (m:_, n))) x = Xml.time (fromInteger m) (fromInteger n) <> x + + addStartInfo [] = [] + addStartInfo (x:xs) = (startInfo <> x):xs + startInfo = mempty <> Xml.defaultKey <> Xml.defaultDivisions <> Xml.metronome (1/4) 60 - <> Xml.commonTime + -- <> Xml.commonTime + -- TODO explicit time sig -barToXml :: HasMusicXml a => [(DurationT, 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 +barToMusicXml :: HasMusicXml a => [(Duration, Maybe a)] -> XmlMusic +barToMusicXml bar = case (fmap rewrite . quantize) bar of + Left e -> error $ "barToMusicXml: Could not quantize this bar: " ++ show e + Right rh -> rhythmToMusicXml rh -rhythmToXml :: HasMusicXml a => Rhythm (Maybe a) -> Xml.Music -rhythmToXml (Beat d x) = noteRestToXml d x -rhythmToXml (Group rs) = mconcat $ map rhythmToXml rs -rhythmToXml (Dotted n (Beat d x)) = noteRestToXml (dotMod n * d) x -rhythmToXml (Tuplet m r) = Xml.tuplet b a (rhythmToXml r) - where (a,b) = both fromIntegral fromIntegral $ unRatio $ fromDurationT m +rhythmToMusicXml :: HasMusicXml a => Rhythm (Maybe a) -> XmlMusic +rhythmToMusicXml (Beat d x) = noteRestToMusicXml d x +rhythmToMusicXml (Group rs) = mconcat $ map rhythmToMusicXml rs +rhythmToMusicXml (Dotted n (Beat d x)) = noteRestToMusicXml (dotMod n * d) x +rhythmToMusicXml (Tuplet m r) = Xml.tuplet b a (rhythmToMusicXml r) + where (a,b) = fromIntegral *** fromIntegral $ unRatio $ realToFrac m -noteRestToXml :: HasMusicXml a => DurationT -> Maybe a -> Xml.Music -noteRestToXml d Nothing = setDefaultVoice $ Xml.rest $ fromDurationT d -noteRestToXml d (Just p) = setDefaultVoice $ getMusicXml d p +noteRestToMusicXml :: HasMusicXml a => Duration -> Maybe a -> XmlMusic +noteRestToMusicXml d Nothing = setDefaultVoice $ Xml.rest $ realToFrac d +noteRestToMusicXml d (Just p) = setDefaultVoice $ getMusicXml d p --- FIXME only works for single-voice parts -setDefaultVoice :: Xml.Music -> Xml.Music +setDefaultVoice :: XmlMusic -> XmlMusic setDefaultVoice = Xml.setVoice 1 --- FIXME arbitrary spelling, please modularize... -spellXml :: Integer -> Xml.Pitch -spellXml p = ( +spellMusicXml :: Integer -> Xml.Pitch +spellMusicXml p = ( toEnum $ fromIntegral pc, if alt == 0 then Nothing else Just (fromIntegral alt), fromIntegral oct ) where (pc,alt,oct) = spellPitch p - - - - - diff --git a/src/Music/Score/Export/Util.hs b/src/Music/Score/Export/Util.hs deleted file mode 100644 --- a/src/Music/Score/Export/Util.hs +++ /dev/null @@ -1,145 +0,0 @@ -{-# LANGUAGE - TypeFamilies, - DeriveFunctor, - DeriveFoldable, - GeneralizedNewtypeDeriving #-} - -------------------------------------------------------------------------------------- --- | --- Copyright : (c) Hans Hoglund 2012 --- --- License : BSD-style --- --- Maintainer : hans@hanshoglund.se --- Stability : experimental --- Portability : non-portable (TF,GNTD) --- -------------------------------------------------------------------------------------- - -module Music.Score.Export.Util -- ( --- ) -where - -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 hiding (mapM) -import Control.Monad.Plus -import Data.Maybe -import Data.Either -import Data.Foldable -import Data.Typeable -import Data.Traversable -import Data.Function (on) -import Data.Ord (comparing) -import Data.VectorSpace -import Data.AffineSpace -import Data.Basis - -import Music.Time -import Music.Score.Rhythm -import Music.Score.Track -import Music.Score.Voice -import Music.Score.Score -import Music.Score.Combinators -import Music.Score.Zip -import Music.Score.Pitch -import Music.Score.Ties -import Music.Score.Part -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 Music.Lilypond as Lilypond -import qualified Text.Pretty as Pretty -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 - --- | --- Convert a single-voice score to a list of bars. --- -voiceToBars :: Tiable a => Voice (Maybe a) -> [[(DurationT, Maybe a)]] -voiceToBars = separateBars . splitTiesVoice - --- | --- 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 :: Voice (Maybe a) -> [[(DurationT, Maybe a)]] -separateBars = - fmap (removeTime . fmap discardBarNumber) . - splitAtTimeZero . fmap separateTime . perform - where - separateTime (t,d,x) = ((bn,bt),d,x) where (bn,bt) = properFraction (toRational t * 1) - splitAtTimeZero = splitWhile ((== 0) . getBarTime) where getBarTime ((bn,bt),_,_) = bt - discardBarNumber ((bn,bt),d,x) = (fromRational bt / 1, d, x) - removeTime = fmap g where g (t,d,x) = (d,x) - --- | --- Convert absolute to relative durations. --- -toRelative :: [(TimeT, DurationT, b)] -> [(TimeT, DurationT, b)] -toRelative = snd . mapAccumL g 0 - where - g now (t,d,x) = (t, (t-now,d,x)) - - --- FIXME arbitrary spelling, please modularize... -spellPitch :: Integral a => a -> (a, a, a) -spellPitch p = ( - pitchClass, - alteration, - octave - ) - where - octave = (p `div` 12) - 1 - semitone = p `mod` 12 - pitchClass = fromStep major semitone - alteration = semitone - step major pitchClass - - step xs p = xs !! ((fromIntegral p) `mod` length xs) - fromStep xs p = fromIntegral $ 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] - - --- | --- 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 () - -unRatio x = (numerator x, denominator x) -first f (x, y) = (f x, y) -second f (x, y) = (x, f y) -both f g = first f . second g diff --git a/src/Music/Score/Import/Abc.hs b/src/Music/Score/Import/Abc.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Import/Abc.hs @@ -0,0 +1,3 @@ + +module Music.Score.Import.Abc where + diff --git a/src/Music/Score/Import/Lilypond.hs b/src/Music/Score/Import/Lilypond.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Import/Lilypond.hs @@ -0,0 +1,2 @@ + +module Music.Score.Import.Lilypond where diff --git a/src/Music/Score/Import/Midi.hs b/src/Music/Score/Import/Midi.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Import/Midi.hs @@ -0,0 +1,109 @@ + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE OverloadedStrings #-} + +module Music.Score.Import.Midi ( + IsMidi(..), + fromMidi, + readMidi, + readMidiMaybe, + readMidiEither + ) where + +import Music.Pitch.Literal (IsPitch) +import Music.Score.Score + +import Control.Applicative +import Control.Lens +import Codec.Midi hiding (Track) +-- import Control.Reactive hiding (Event) +-- import qualified Control.Reactive as R +-- import Control.Reactive.Midi + +import Music.Dynamics.Literal +import Music.Pitch.Literal +import Music.Score.Articulation +import Music.Score.Chord +import Music.Score.Combinators +import Music.Score.Dynamics +import Music.Score.Export.Common +import Music.Score.Ornaments +import Music.Score.Part +import Music.Score.Pitch +import Music.Score.Rhythm +import Music.Score.Score +import Music.Score.Ties +import Music.Score.Track +import Music.Score.Voice +import Music.Time + +import qualified Codec.Midi as Midi +import qualified Data.List as List +import qualified Data.Map as Map +import qualified Music.Lilypond as Lilypond +import qualified Music.MusicXml.Simple as Xml +import qualified Text.Pretty as Pretty + +import qualified Music.Pitch.Literal as Pitch +-- import qualified Data.ByteString.Lazy as ByteString + +-- | +-- This constraint includes all note types that can be constructed from a Midi representation. +-- +type IsMidi a = ( + -- TODO + IsPitch a, + HasPart' a, + Enum (Part a), + -- HasPitch a, + Num (Pitch a), + HasTremolo a, + HasArticulation a, + Tiable a + ) + + +-- | +-- Convert a score from a Midi representation. +-- +fromMidi :: IsMidi a => Midi -> Score a +fromMidi = undefined + -- Map each track to a part (scanning for ProgramChange, name etc) + -- Subdivide parts based on channels + -- Set channel 10 tracks to "percussion" + + -- Remove all non-used messages (KeyPressure, ChannelPressure, ProgramChange) + -- Create reactives from variable values + -- Create notes + -- Superimpose variable values + + -- Compose + -- Add meta-information + +-- TODO + +-- | +-- Read a Midi score from a file. Fails if the file could not be read or if a parsing +-- error occurs. +-- +readMidi :: IsMidi a => FilePath -> IO (Score a) +readMidi path = fmap (either (\x -> error $ "Could not read MIDI file" ++ x) id) $ readMidiEither path + +-- | +-- Read a Midi score from a file. Fails if the file could not be read, and returns +-- @Nothing@ if a parsing error occurs. +-- +readMidiMaybe :: IsMidi a => FilePath -> IO (Maybe (Score a)) +readMidiMaybe path = fmap (either (const Nothing) Just) $ readMidiEither path + +-- | +-- Read a Midi score from a file. Fails if the file could not be read, and returns +-- @Left m@ if a parsing error occurs. +-- +readMidiEither :: IsMidi a => FilePath -> IO (Either String (Score a)) +readMidiEither path = fmap (fmap fromMidi) $ importFile path + + diff --git a/src/Music/Score/Instances.hs b/src/Music/Score/Instances.hs --- a/src/Music/Score/Instances.hs +++ b/src/Music/Score/Instances.hs @@ -1,750 +1,860 @@ -{-# LANGUAGE - TypeFamilies, - DeriveFunctor, - DeriveFoldable, - DeriveDataTypeable, - FlexibleInstances, - FlexibleContexts, - ConstraintKinds, - GeneralizedNewtypeDeriving #-} - -------------------------------------------------------------------------------------- --- | --- Copyright : (c) Hans Hoglund 2012 --- --- License : BSD-style --- --- Maintainer : hans@hanshoglund.se --- Stability : experimental --- Portability : non-portable (TF,GNTD) --- --- To be written. --- -------------------------------------------------------------------------------------- - -module Music.Score.Instances ( - ) where - -import Control.Monad -import Data.Semigroup -import Data.Ratio -import Data.Maybe -import Data.Foldable -import Data.Typeable -import qualified Data.List as List -import Data.VectorSpace -import Data.AffineSpace - -import Music.Time -import Music.Pitch.Literal -import Music.Dynamics.Literal - -import Music.Score.Rhythm -import Music.Score.Track -import Music.Score.Voice -import Music.Score.Score -import Music.Score.Combinators -import Music.Score.Zip -import Music.Score.Pitch -import Music.Score.Ties -import Music.Score.Part -import Music.Score.Chord -import Music.Score.Articulation -import Music.Score.Dynamics -import Music.Score.Ornaments - -------------------------------------------------------------------------------------- - - -instance (IsPitch a, Enum n) => IsPitch (PartT n a) where - fromPitch l = PartT (toEnum 0, fromPitch l) -instance (IsDynamics a, Enum n) => IsDynamics (PartT n a) where - fromDynamics l = PartT (toEnum 0, fromDynamics l) - -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 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 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 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 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 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 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) - - -------------------------------------------------------------------------------------- -------------------------------------------------------------------------------------- - --- Maybe - --- TODO this instance may be problematic with mapPhrase -instance HasArticulation a => HasArticulation (Maybe a) where - setEndSlur n (Just x) = Just (setEndSlur n x) - setEndSlur n Nothing = Nothing - setContSlur n (Just x) = Just (setContSlur n x) - setContSlur n Nothing = Nothing - setBeginSlur n (Just x) = Just (setBeginSlur n x) - setBeginSlur n Nothing = Nothing - setAccLevel n (Just x) = Just (setAccLevel n x) - setAccLevel n Nothing = Nothing - setStaccLevel n (Just x) = Just (setStaccLevel n x) - setStaccLevel n Nothing = Nothing -instance HasPart a => HasPart (Maybe a) where - type Part (Maybe a) = Maybe (Part a) -- ! - getPart Nothing = Nothing - getPart (Just a) = Just (getPart a) - modifyPart f (Nothing) = Nothing - modifyPart f (Just a) = Just (modifyPart (fromJust . f . Just) a) -- TODO use cofunctor -instance HasPitch a => HasPitch (Maybe a) where - type Pitch (Maybe a) = Maybe (Pitch a) -- ! - getPitch Nothing = Nothing - getPitch (Just a) = Just (getPitch a) - modifyPitch f (Nothing) = Nothing - modifyPitch f (Just a) = Just (modifyPitch (fromJust . f . Just) a) - - --- PitchT - - --- PartT - - -instance HasPart (PartT n a) where - type Part (PartT n a) = n - getPart (PartT (v,_)) = v - modifyPart f (PartT (v,x)) = PartT (f v, x) -instance HasChord a => HasChord (PartT n a) where - type ChordNote (PartT n a) = PartT n (ChordNote a) - getChord (PartT (v,x)) = fmap (\x -> PartT (v,x)) (getChord x) -instance HasPitch a => HasPitch (PartT n a) where - type Pitch (PartT n a) = Pitch a - getPitch (PartT (v,a)) = getPitch a - modifyPitch f (PartT (v,x)) = PartT (v, modifyPitch f x) -instance Tiable a => Tiable (PartT n a) where - beginTie = fmap beginTie - endTie = fmap endTie - toTied (PartT (v,a)) = (PartT (v,b), PartT (v,c)) where (b,c) = toTied a -instance HasDynamic a => HasDynamic (PartT n a) where - setBeginCresc n (PartT (v,x)) = PartT (v, setBeginCresc n x) - setEndCresc n (PartT (v,x)) = PartT (v, setEndCresc n x) - setBeginDim n (PartT (v,x)) = PartT (v, setBeginDim n x) - setEndDim n (PartT (v,x)) = PartT (v, setEndDim n x) - setLevel n (PartT (v,x)) = PartT (v, setLevel n x) -instance HasArticulation a => HasArticulation (PartT n a) where - setEndSlur n (PartT (v,x)) = PartT (v, setEndSlur n x) - setContSlur n (PartT (v,x)) = PartT (v, setContSlur n x) - setBeginSlur n (PartT (v,x)) = PartT (v, setBeginSlur n x) - setAccLevel n (PartT (v,x)) = PartT (v, setAccLevel n x) - setStaccLevel n (PartT (v,x)) = PartT (v, setStaccLevel n x) -instance HasTremolo a => HasTremolo (PartT n a) where - setTrem n (PartT (v,x)) = PartT (v, setTrem n x) -instance HasHarmonic a => HasHarmonic (PartT n a) where - setHarmonic n (PartT (v,x)) = PartT (v, setHarmonic n x) -instance HasSlide a => HasSlide (PartT n a) where - setBeginGliss n (PartT (v,x)) = PartT (v, setBeginGliss n x) - setBeginSlide n (PartT (v,x)) = PartT (v, setBeginSlide n x) - setEndGliss n (PartT (v,x)) = PartT (v, setEndGliss n x) - setEndSlide n (PartT (v,x)) = PartT (v, setEndSlide n x) -instance HasText a => HasText (PartT n a) where - addText s (PartT (v,x)) = PartT (v, addText s x) - - --- ChordT - -instance Tiable a => Tiable (ChordT a) where - beginTie = fmap beginTie - endTie = fmap endTie - toTied (ChordT as) = (ChordT bs, ChordT cs) where (bs,cs) = (unzip . fmap toTied) as --- No HasPart instance, PartT must be outside ChordT --- This restriction assures all chord notes are in the same part -instance HasChord (ChordT a) where - type ChordNote (ChordT a) = a - getChord (ChordT as) = as --- Derived form the [a] instance -instance HasPitch a => HasPitch (ChordT a) where - type Pitch (ChordT a) = Pitch a - getPitch (ChordT as) = getPitch as - modifyPitch f (ChordT as) = ChordT (modifyPitch f as) -instance HasDynamic a => HasDynamic (ChordT a) where - setBeginCresc n (ChordT as) = ChordT (fmap (setBeginCresc n) as) - setEndCresc n (ChordT as) = ChordT (fmap (setEndCresc n) as) - setBeginDim n (ChordT as) = ChordT (fmap (setBeginDim n) as) - setEndDim n (ChordT as) = ChordT (fmap (setEndDim n) as) - setLevel n (ChordT as) = ChordT (fmap (setLevel n) as) -instance HasArticulation a => HasArticulation (ChordT a) where - setEndSlur n (ChordT as) = ChordT (fmap (setEndSlur n) as) - setContSlur n (ChordT as) = ChordT (fmap (setContSlur n) as) - setBeginSlur n (ChordT as) = ChordT (fmap (setBeginSlur n) as) - setAccLevel n (ChordT as) = ChordT (fmap (setAccLevel n) as) - setStaccLevel n (ChordT as) = ChordT (fmap (setStaccLevel n) as) -instance HasTremolo a => HasTremolo (ChordT a) where - setTrem n (ChordT as) = ChordT (fmap (setTrem n) as) -instance HasHarmonic a => HasHarmonic (ChordT a) where - setHarmonic n (ChordT as) = ChordT (fmap (setHarmonic n) as) -instance HasSlide a => HasSlide (ChordT a) where - setBeginGliss n (ChordT as) = ChordT (fmap (setBeginGliss n) as) - setBeginSlide n (ChordT as) = ChordT (fmap (setBeginSlide n) as) - setEndGliss n (ChordT as) = ChordT (fmap (setEndGliss n) as) - setEndSlide n (ChordT as) = ChordT (fmap (setEndSlide n) as) -instance HasText a => HasText (ChordT a) where - addText s (ChordT as) = ChordT (mapFirstL (addText s) as) - - --- TieT - -instance HasPart a => HasPart (TieT a) where - type Part (TieT a) = Part a - getPart (TieT (_,x,_)) = getPart x - modifyPart f (TieT (b,x,e)) = TieT (b,modifyPart f x,e) -instance HasChord a => HasChord (TieT a) where - type ChordNote (TieT a ) = TieT (ChordNote a) - getChord (TieT (b,x,e)) = fmap (\x -> TieT (b,x,e)) (getChord x) -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 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 Tiable a => Tiable (DynamicT a) where - beginTie = fmap beginTie - endTie = fmap endTie - 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 HasPart a => HasPart (DynamicT a) where - type Part (DynamicT a) = Part a - getPart (DynamicT (ec,ed,l,a,bc,bd)) = getPart a - modifyPart f (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,modifyPart f a,bc,bd) -instance HasChord a => HasChord (DynamicT a) where - type ChordNote (DynamicT a) = DynamicT (ChordNote a) - getChord (DynamicT (ec,ed,l,a,bc,bd)) = fmap (\x -> DynamicT (ec,ed,l,x,bc,bd)) (getChord a) -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 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 Tiable a => Tiable (ArticulationT a) where - beginTie = fmap beginTie - endTie = fmap endTie - 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 HasPart a => HasPart (ArticulationT a) where - type Part (ArticulationT a) = Part a - getPart (ArticulationT (es,us,al,sl,a,bs)) = getPart a - modifyPart f (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,modifyPart f a,bs) -instance HasChord a => HasChord (ArticulationT a) where - type ChordNote (ArticulationT a) = ArticulationT (ChordNote a) - getChord (ArticulationT (es,us,al,sl,a,bs)) = fmap (\x -> ArticulationT (es,us,al,sl,x,bs)) (getChord a) -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 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 Tiable a => Tiable (TremoloT a) where - beginTie = fmap beginTie - endTie = fmap endTie - toTied (TremoloT (n,a)) = (TremoloT (n,b), TremoloT (n,c)) where (b,c) = toTied a -instance HasPart a => HasPart (TremoloT a) where - type Part (TremoloT a) = Part a - getPart (TremoloT (_,a)) = getPart a - modifyPart f (TremoloT (n,x)) = TremoloT (n, modifyPart f x) -instance HasChord a => HasChord (TremoloT a) where - type ChordNote (TremoloT a) = TremoloT (ChordNote a) - getChord (TremoloT (n,x)) = fmap (\x -> TremoloT (n,x)) (getChord 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 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 Tiable a => Tiable (TextT a) where - beginTie = fmap beginTie - endTie = fmap endTie - toTied (TextT (n,a)) = (TextT (n,b), TextT (mempty,c)) where (b,c) = toTied a -instance HasPart a => HasPart (TextT a) where - type Part (TextT a) = Part a - getPart (TextT (_,a)) = getPart a - modifyPart f (TextT (n,x)) = TextT (n, modifyPart f x) -instance HasChord a => HasChord (TextT a) where - type ChordNote (TextT a) = TextT (ChordNote a) - getChord (TextT (n,x)) = fmap (\x -> TextT (n,x)) (getChord 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 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 Tiable a => Tiable (HarmonicT a) where - beginTie = fmap beginTie - endTie = fmap endTie - toTied (HarmonicT (n,a)) = (HarmonicT (n,b), HarmonicT (n,c)) where (b,c) = toTied a -instance HasPart a => HasPart (HarmonicT a) where - type Part (HarmonicT a) = Part a - getPart (HarmonicT (_,a)) = getPart a - modifyPart f (HarmonicT (n,x)) = HarmonicT (n, modifyPart f x) -instance HasChord a => HasChord (HarmonicT a) where - type ChordNote (HarmonicT a) = HarmonicT (ChordNote a) - getChord (HarmonicT (n,x)) = fmap (\x -> HarmonicT (n,x)) (getChord 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 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 Tiable a => Tiable (SlideT a) where - beginTie = fmap beginTie - endTie = fmap endTie - 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 HasPart a => HasPart (SlideT a) where - type Part (SlideT a) = Part a - getPart (SlideT (eg,es,a,bg,bs)) = getPart a - modifyPart f (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,modifyPart f a,bg,bs) -instance HasChord a => HasChord (SlideT a) where - type ChordNote (SlideT a) = SlideT (ChordNote a) - getChord (SlideT (eg,es,a,bg,bs)) = fmap (\x -> SlideT (eg,es,x,bg,bs)) (getChord a) -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 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 -------------------------------------------------------------------------------------- - --- PartT - -instance (Enum v, Eq v, Num a) => Num (PartT v a) where - PartT (v,a) + PartT (_,b) = PartT (v,a+b) - PartT (v,a) * PartT (_,b) = PartT (v,a*b) - PartT (v,a) - PartT (_,b) = PartT (v,a-b) - abs (PartT (v,a)) = PartT (v,abs a) - signum (PartT (v,a)) = PartT (v,signum a) - fromInteger a = PartT (toEnum 0,fromInteger a) - -instance (Enum v, Enum a) => Enum (PartT v a) where - toEnum a = PartT (toEnum 0, toEnum a) -- TODO use def, mempty or minBound? - fromEnum (PartT (v,a)) = fromEnum a - -instance (Enum v, Bounded a) => Bounded (PartT v a) where - minBound = PartT (toEnum 0, minBound) - maxBound = PartT (toEnum 0, maxBound) - -instance (Enum v, Ord v, Num a, Ord a, Real a) => Real (PartT v a) where - toRational (PartT (v,a)) = toRational a - -instance (Enum v, Ord v, Real a, Enum a, Integral a) => Integral (PartT v a) where - PartT (v,a) `quotRem` PartT (_,b) = (PartT (v,q), PartT (v,r)) where (q,r) = a `quotRem` b - toInteger (PartT (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 - - - - - -mapFirstL f = mapFirstMiddleLast f id id - -mapFirstMiddleLast :: (a -> b) -> (a -> b) -> (a -> b) -> [a] -> [b] -mapFirstMiddleLast f g h = go - where - go [] = [] - go [a] = [f a] - go [a,b] = [f a, h b] - go xs = [f $ head xs] ++ - map g (tail $ init xs) ++ - [h $ last xs] +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +-- Instances for note transformers. This module should be imported as part +-- of "Music.Score". +-- +------------------------------------------------------------------------------------- + +module Music.Score.Instances () where + +import Control.Applicative +import Control.Comonad +import Control.Monad +import Data.AffineSpace +import Data.Default +import Data.Foldable +import qualified Data.List as List +import Data.Maybe +import Data.Ratio +import Data.Semigroup +import Data.Typeable +import Data.VectorSpace + +import Music.Dynamics.Literal +import Music.Pitch.Literal +import Music.Score.Articulation +import Music.Score.Chord +import Music.Score.Combinators +import Music.Score.Dynamics +import Music.Score.Ornaments +import Music.Score.Part +import Music.Score.Pitch +import Music.Score.Rhythm +import Music.Score.Score +import Music.Score.Ties +import Music.Score.Track +import Music.Score.Util +import Music.Score.Voice +import Music.Time + +------------------------------------------------------------------------------------- + +{- + Rewrite pairs: + + CANNOT DO + ChordT + TODO + PartT + + DONE + DynamicT + TieT + ArticulationT + TremoloT + HarmonicT + TextT + SlideT + + +-} + + +instance (IsPitch a, Enum n) => IsPitch (PartT n a) where + fromPitch l = PartT (toEnum 0, fromPitch l) +instance (IsDynamics a, Enum n) => IsDynamics (PartT n a) where + fromDynamics l = PartT (toEnum 0, fromDynamics l) + +instance IsPitch a => IsPitch (ChordT a) where + fromPitch = return . fromPitch +instance IsDynamics a => IsDynamics (ChordT a) where + fromDynamics = return . fromDynamics + +instance IsPitch a => IsPitch (TieT a) where + fromPitch = pure . fromPitch +instance IsDynamics a => IsDynamics (TieT a) where + fromDynamics = return . fromDynamics + +instance IsPitch a => IsPitch (DynamicT a) where + fromPitch = pure . fromPitch +instance IsDynamics a => IsDynamics (DynamicT a) where + fromDynamics = return . fromDynamics + +instance IsPitch a => IsPitch (TremoloT a) where + fromPitch = pure . fromPitch +instance IsDynamics a => IsDynamics (TremoloT a) where + fromDynamics = pure . fromDynamics + +instance IsPitch a => IsPitch (TextT a) where + fromPitch = pure . fromPitch +instance IsDynamics a => IsDynamics (TextT a) where + fromDynamics = pure . fromDynamics + +instance IsPitch a => IsPitch (HarmonicT a) where + fromPitch = pure . fromPitch +instance IsDynamics a => IsDynamics (HarmonicT a) where + fromDynamics = pure . fromDynamics + +instance IsPitch a => IsPitch (SlideT a) where + fromPitch = pure . fromPitch +instance IsDynamics a => IsDynamics (SlideT a) where + fromDynamics = pure . fromDynamics + +------------------------------------------------------------------------------------- + +instance Reversible (ChordT a) where + rev = id +instance Reversible a => Reversible (DynamicT a) where + rev = fmap rev +instance Reversible a => Reversible (SlideT a) where + rev = fmap rev +instance Reversible a => Reversible (TieT a) where + rev = fmap rev +instance Reversible a => Reversible (HarmonicT a) where + rev = fmap rev +instance Reversible a => Reversible (ArticulationT a) where + rev = fmap rev +instance Reversible a => Reversible (TextT a) where + rev = fmap rev +instance Reversible a => Reversible (TremoloT a) where + rev = fmap rev +instance Reversible a => Reversible (PartT p a) where + rev = fmap rev + + +------------------------------------------------------------------------------------- + +instance Semigroup a => Semigroup (DynamicT a) where + DynamicT (d1, x1) <> DynamicT (d2, x2) = DynamicT (d1 <> d2, x1 <> x2) +instance Semigroup a => Semigroup (SlideT a) where + (<>) = liftA2 (<>) +instance Semigroup a => Semigroup (TieT a) where + TieT (t1, x1) <> TieT (t2, x2) = TieT (t1 <> t2, x1 <> x2) + -- This instance is suspect: in general chord notes are not required to share ties, + -- so this instance may be removed (provided that TieT is moved inside ChordT for + -- all Preludes). See #134 +instance Semigroup a => Semigroup (HarmonicT a) where + (<>) = liftA2 (<>) +instance Semigroup a => Semigroup (TextT a) where + (<>) = liftA2 (<>) +instance Semigroup a => Semigroup (TremoloT a) where + (<>) = liftA2 (<>) +instance Semigroup a => Semigroup (PartT n a) where + PartT (v1,x1) <> PartT (v2,x2) = PartT (v1, x1 <> x2) + + +------------------------------------------------------------------------------------- + +-- Maybe + +-- TODO this instance may be problematic with mapPhrase +instance HasArticulation a => HasArticulation (Maybe a) where + setEndSlur n = fmap (setEndSlur n) + setContSlur n = fmap (setContSlur n) + setBeginSlur n = fmap (setBeginSlur n) + setAccLevel n = fmap (setAccLevel n) + setStaccLevel n = fmap (setStaccLevel n) +type instance Part (Maybe a) = Part a +instance HasPart a => HasPart (Maybe a) where + getPart Nothing = error "Nothing: no part" + getPart (Just a) = getPart a + modifyPart f = fmap (modifyPart f) +type instance Pitch (Maybe a) = Pitch a +instance HasSetPitch a b => HasSetPitch (Maybe a) (Maybe b) where + type SetPitch g (Maybe a) = Maybe (SetPitch g a) + __mapPitch f (Nothing) = Nothing + __mapPitch f (Just a) = Just (__mapPitch f a) + + +-- PartT + +instance HasChord a => HasChord (PartT n a) where + type ChordNote (PartT n a) = PartT n (ChordNote a) + getChord (PartT (v,x)) = fmap (\x -> PartT (v,x)) (getChord x) + +type instance Pitch (PartT n a) = Pitch a +instance HasGetPitch a => HasGetPitch (PartT n a) where + __getPitch = __getPitch . extract +instance HasSetPitch a b => HasSetPitch (PartT n a) (PartT n b) where + type SetPitch g (PartT n a) = PartT n (SetPitch g a) + __mapPitch f = fmap (__mapPitch f) + +instance Tiable a => Tiable (PartT n a) where + toTied (PartT (v,a)) = (PartT (v,b), PartT (v,c)) where (b,c) = toTied a +deriving instance HasDynamic a => HasDynamic (PartT n a) +deriving instance HasArticulation a => HasArticulation (PartT n a) +deriving instance HasTremolo a => HasTremolo (PartT n a) +deriving instance HasHarmonic a => HasHarmonic (PartT n a) +deriving instance HasSlide a => HasSlide (PartT n a) +deriving instance HasText a => HasText (PartT n a) + + +-- ChordT + +instance Tiable a => Tiable (ChordT a) where + toTied (ChordT as) = (ChordT bs, ChordT cs) where (bs,cs) = (unzip . fmap toTied) as +-- There is no (HasPart ChordT) instance, so PartT must be outside ChordT in the stack +-- This restriction assures all chord notes are in the same part + +type instance Pitch (ChordT a) = Pitch a + +instance HasSetPitch a b => HasSetPitch (ChordT a) (ChordT b) where + type SetPitch g (ChordT a) = ChordT (SetPitch g a) + __mapPitch f = fmap (__mapPitch f) + +instance HasDynamic a => HasDynamic (ChordT a) where + setEndDim n = fmap (setEndDim n) + setLevel n = fmap (setLevel n) +instance HasArticulation a => HasArticulation (ChordT a) where + setEndSlur n = fmap (setEndSlur n) + setContSlur n = fmap (setContSlur n) + setBeginSlur n = fmap (setBeginSlur n) + setAccLevel n = fmap (setAccLevel n) + setStaccLevel n = fmap (setStaccLevel n) +instance HasTremolo a => HasTremolo (ChordT a) where + setTrem n = fmap (setTrem n) +instance HasHarmonic a => HasHarmonic (ChordT a) where + setNatural n = fmap (setNatural n) + setHarmonic n = fmap (setHarmonic n) +instance HasSlide a => HasSlide (ChordT a) where + setBeginGliss n = fmap (setBeginGliss n) + setBeginSlide n = fmap (setBeginSlide n) + setEndGliss n = fmap (setEndGliss n) + setEndSlide n = fmap (setEndSlide n) +instance HasText a => HasText (ChordT a) where + addText s (ChordT as) = ChordT (mapF (addText s) as) + + +-- TieT + +type instance Part (TieT a) = Part a +instance HasPart a => HasPart (TieT a) where + getPart (TieT (_,x)) = getPart x + modifyPart f = fmap (modifyPart f) +instance HasChord a => HasChord (TieT a) where + type ChordNote (TieT a) = TieT (ChordNote a) + getChord (TieT (t,x)) = fmap (\x -> TieT (t,x)) (getChord x) + +type instance Pitch (TieT a) = Pitch a +instance HasGetPitch a => HasGetPitch (TieT a) where + __getPitch = __getPitch . get1 +instance HasSetPitch a b => HasSetPitch (TieT a) (TieT b) where + type SetPitch g (TieT a) = TieT (SetPitch g a) + __mapPitch f = fmap (__mapPitch f) + + +deriving instance HasDynamic a => HasDynamic (TieT a) +deriving instance HasArticulation a => HasArticulation (TieT a) +deriving instance HasTremolo a => HasTremolo (TieT a) +deriving instance HasHarmonic a => HasHarmonic (TieT a) +deriving instance HasSlide a => HasSlide (TieT a) +deriving instance HasText a => HasText (TieT a) + + +-- DynamicT + +-- end cresc/dim, level, begin cresc/dim +-- newtype DynamicT a = DynamicT { getDynamicT :: (Bool, Bool, Maybe Double, a, Bool, Bool) } + +instance Tiable a => Tiable (DynamicT a) where + toTied (DynamicT (l, a)) = (DynamicT (l, b), DynamicT (mempty, c)) where (b,c) = toTied a + +type instance Part (DynamicT a) = Part a +instance HasPart a => HasPart (DynamicT a) where + getPart (DynamicT (_,x)) = getPart x + modifyPart f = fmap (modifyPart f) +instance HasChord a => HasChord (DynamicT a) where + type ChordNote (DynamicT a) = DynamicT (ChordNote a) + getChord (DynamicT (d,as)) = fmap (\x -> DynamicT (d,x)) (getChord as) + +type instance Pitch (DynamicT a) = Pitch a +instance HasGetPitch a => HasGetPitch (DynamicT a) where + __getPitch (DynamicT (_,x)) = __getPitch x +instance HasSetPitch a b => HasSetPitch (DynamicT a) (DynamicT b) where + type SetPitch g (DynamicT a) = DynamicT (SetPitch g a) + __mapPitch f = fmap (__mapPitch f) + + +deriving instance HasArticulation a => HasArticulation (DynamicT a) +deriving instance HasTremolo a => HasTremolo (DynamicT a) +deriving instance HasHarmonic a => HasHarmonic (DynamicT a) +deriving instance HasSlide a => HasSlide (DynamicT a) +deriving instance HasText a => HasText (DynamicT a) + + +-- ArticulationT + +-- end slur, cont slur, acc level, stacc level, begin slur +-- newtype ArticulationT a = ArticulationT { getArticulationT :: (Bool, Bool, Int, Int, a, Bool) } + + +instance Tiable a => Tiable (ArticulationT a) where + toTied (ArticulationT (v,a)) = (ArticulationT (v,b), ArticulationT (v,c)) where (b,c) = toTied a + +type instance Part (ArticulationT a) = Part a +instance HasPart a => HasPart (ArticulationT a) where + getPart = getPart . get1 + modifyPart f = fmap (modifyPart f) +instance HasChord a => HasChord (ArticulationT a) where + type ChordNote (ArticulationT a) = ArticulationT (ChordNote a) + getChord (ArticulationT (v,x)) = fmap (\x -> ArticulationT (v,x)) (getChord x) + +type instance Pitch (ArticulationT a) = Pitch a +instance HasGetPitch a => HasGetPitch (ArticulationT a) where + __getPitch (ArticulationT (_,a)) = __getPitch a +instance HasSetPitch a b => HasSetPitch (ArticulationT a) (ArticulationT b) where + type SetPitch g (ArticulationT a) = ArticulationT (SetPitch g a) + __mapPitch f (ArticulationT (v,x)) = (ArticulationT (v,__mapPitch f x)) + +deriving instance HasDynamic a => HasDynamic (ArticulationT a) +deriving instance HasTremolo a => HasTremolo (ArticulationT a) +deriving instance HasHarmonic a => HasHarmonic (ArticulationT a) +deriving instance HasSlide a => HasSlide (ArticulationT a) +deriving instance HasText a => HasText (ArticulationT a) + +-- TremoloT + +instance Tiable a => Tiable (TremoloT a) where + toTied (TremoloT (n,a)) = (TremoloT (n,b), TremoloT (n,c)) where (b,c) = toTied a +type instance Part (TremoloT a) = Part a +instance HasPart a => HasPart (TremoloT a) where + getPart (TremoloT (_,a)) = getPart a + modifyPart f (TremoloT (n,x)) = TremoloT (n, modifyPart f x) +instance HasChord a => HasChord (TremoloT a) where + type ChordNote (TremoloT a) = TremoloT (ChordNote a) + getChord (TremoloT (n,x)) = fmap (\x -> TremoloT (n,x)) (getChord x) + +type instance Pitch (TremoloT a) = Pitch a +instance HasGetPitch a => HasGetPitch (TremoloT a) where + __getPitch = __getPitch . get1 +instance HasSetPitch a b => HasSetPitch (TremoloT a) (TremoloT b) where + type SetPitch g (TremoloT a) = TremoloT (SetPitch g a) + __mapPitch f = fmap (__mapPitch f) + +deriving instance HasDynamic a => HasDynamic (TremoloT a) +deriving instance HasArticulation a => HasArticulation (TremoloT a) +deriving instance HasHarmonic a => HasHarmonic (TremoloT a) +deriving instance HasSlide a => HasSlide (TremoloT a) +deriving instance HasText a => HasText (TremoloT a) + + +-- TextT + +instance Tiable a => Tiable (TextT a) where + toTied (TextT (n,a)) = (TextT (n,b), TextT (mempty,c)) where (b,c) = toTied a +type instance Part (TextT a) = Part a +instance HasPart a => HasPart (TextT a) where + getPart (TextT (_,a)) = getPart a + modifyPart f = fmap (modifyPart f) +instance HasChord a => HasChord (TextT a) where + type ChordNote (TextT a) = TextT (ChordNote a) + getChord (TextT (n,x)) = fmap (\x -> TextT (n,x)) (getChord x) + +type instance Pitch (TextT a) = Pitch a +instance HasGetPitch a => HasGetPitch (TextT a) where + __getPitch = __getPitch . get1 +instance HasSetPitch a b => HasSetPitch (TextT a) (TextT b) where + type SetPitch g (TextT a) = TextT (SetPitch g a) + __mapPitch f = fmap (__mapPitch f) + +deriving instance HasDynamic a => HasDynamic (TextT a) +deriving instance HasArticulation a => HasArticulation (TextT a) +deriving instance HasTremolo a => HasTremolo (TextT a) +deriving instance HasHarmonic a => HasHarmonic (TextT a) +deriving instance HasSlide a => HasSlide (TextT a) + + +-- HarmonicT + +instance Tiable a => Tiable (HarmonicT a) where + toTied (HarmonicT (n,a)) = (HarmonicT (n,b), HarmonicT (n,c)) where (b,c) = toTied a +type instance Part (HarmonicT a) = Part a +instance HasPart a => HasPart (HarmonicT a) where + getPart (HarmonicT (_,a)) = getPart a + modifyPart f (HarmonicT (n,x)) = HarmonicT (n, modifyPart f x) +instance HasChord a => HasChord (HarmonicT a) where + type ChordNote (HarmonicT a) = HarmonicT (ChordNote a) + getChord (HarmonicT (n,x)) = fmap (\x -> HarmonicT (n,x)) (getChord x) + +type instance Pitch (HarmonicT a) = Pitch a +instance HasGetPitch a => HasGetPitch (HarmonicT a) where + __getPitch = __getPitch . get1 +instance HasSetPitch a b => HasSetPitch (HarmonicT a) (HarmonicT b) where + type SetPitch g (HarmonicT a) = HarmonicT (SetPitch g a) + __mapPitch f = fmap (__mapPitch f) + +deriving instance HasDynamic a => HasDynamic (HarmonicT a) +deriving instance HasArticulation a => HasArticulation (HarmonicT a) +deriving instance HasTremolo a => HasTremolo (HarmonicT a) +deriving instance HasSlide a => HasSlide (HarmonicT a) +deriving instance HasText a => HasText (HarmonicT a) + + +-- SlideT + + +instance Tiable a => Tiable (SlideT a) where + toTied (SlideT (v,x)) = (SlideT (v,a), SlideT (v,b)) where (a,b) = toTied x + +type instance Part (SlideT a) = Part a +instance HasPart a => HasPart (SlideT a) where + getPart = getPart . get1 + modifyPart f = fmap (modifyPart f) +instance HasChord a => HasChord (SlideT a) where + type ChordNote (SlideT a) = SlideT (ChordNote a) + getChord (SlideT (x,as)) = fmap (\a -> SlideT (x,a)) (getChord as) + +type instance Pitch (SlideT a) = Pitch a +instance HasGetPitch a => HasGetPitch (SlideT a) where + __getPitch = __getPitch . get1 +instance HasSetPitch a b => HasSetPitch (SlideT a) (SlideT b) where + type SetPitch g (SlideT a) = SlideT (SetPitch g a) + __mapPitch f = fmap (__mapPitch f) + +deriving instance HasDynamic a => HasDynamic (SlideT a) +deriving instance HasArticulation a => HasArticulation (SlideT a) +deriving instance HasTremolo a => HasTremolo (SlideT a) +deriving instance HasHarmonic a => HasHarmonic (SlideT a) +deriving instance HasText a => HasText (SlideT a) + + + + + + + + + + + + + + + + + + + +------------------------------------------------------------------------------------- +-- Num, Integral, Enum and Bounded +------------------------------------------------------------------------------------- + +-- PartT + +instance (Enum v, Eq v, Num a) => Num (PartT v a) where + PartT (v,a) + PartT (_,b) = PartT (v,a+b) + PartT (v,a) * PartT (_,b) = PartT (v,a*b) + PartT (v,a) - PartT (_,b) = PartT (v,a-b) + abs (PartT (v,a)) = PartT (v,abs a) + signum (PartT (v,a)) = PartT (v,signum a) + fromInteger a = PartT (toEnum 0,fromInteger a) + +instance (Enum v, Enum a) => Enum (PartT v a) where + toEnum a = PartT (toEnum 0, toEnum a) -- TODO use def, mempty or minBound? + fromEnum (PartT (v,a)) = fromEnum a + +instance (Enum v, Bounded a) => Bounded (PartT v a) where + minBound = PartT (toEnum 0, minBound) + maxBound = PartT (toEnum 0, maxBound) + +instance (Enum v, Ord v, Num a, Ord a, Real a) => Real (PartT v a) where + toRational (PartT (v,a)) = toRational a + +instance (Enum v, Ord v, Real a, Enum a, Integral a) => Integral (PartT v a) where + PartT (v,a) `quotRem` PartT (_,b) = (PartT (v,q), PartT (v,r)) where (q,r) = a `quotRem` b + toInteger (PartT (v,a)) = toInteger a + + +-- ChordT + +-- instance Num a => Num (ChordT a) where +-- ChordT [a] + ChordT [b] = ChordT [a+b] +-- ChordT [a] * ChordT [b] = ChordT [a*b] +-- ChordT [a] - ChordT [b] = ChordT [a-b] +-- abs (ChordT [a]) = ChordT [abs a] +-- signum (ChordT [a]) = ChordT [signum a] +-- fromInteger a = ChordT [fromInteger a] + +instance Enum a => Enum (ChordT a) where + toEnum a = ChordT [toEnum a] + fromEnum (ChordT [a]) = fromEnum a + +instance Bounded a => Bounded (ChordT a) where + minBound = ChordT [minBound] + maxBound = ChordT [maxBound] + +-- instance (Num a, Ord a, Real a) => Real (ChordT a) where +-- toRational (ChordT [a]) = toRational a + +-- instance (Real a, Enum a, Integral a) => Integral (ChordT a) where +-- ChordT [a] `quotRem` ChordT [b] = (ChordT [q], ChordT [r]) where (q,r) = a `quotRem` b +-- toInteger (ChordT [a]) = toInteger a + + +-- TieT + +instance Num a => Num (TieT a) where + (+) = liftA2 (+) + (*) = liftA2 (*) + (-) = liftA2 (-) + abs = fmap abs + signum = fmap signum + fromInteger = pure . fromInteger + +instance Fractional a => Fractional (TieT a) where + recip = fmap recip + fromRational = pure . fromRational + +instance Floating a => Floating (TieT a) where + pi = pure pi + sqrt = fmap sqrt + exp = fmap exp + log = fmap log + sin = fmap sin + cos = fmap cos + asin = fmap asin + atan = fmap atan + acos = fmap acos + sinh = fmap sinh + cosh = fmap cosh + asinh = fmap asinh + atanh = fmap atanh + acosh = fmap acos + +instance Enum a => Enum (TieT a) where + toEnum = pure . toEnum + fromEnum = fromEnum . get1 + +instance Bounded a => Bounded (TieT a) where + minBound = pure minBound + maxBound = pure maxBound + +instance (Num a, Ord a, Real a) => Real (TieT a) where + toRational = toRational . get1 + +instance (Real a, Enum a, Integral a) => Integral (TieT a) where + quot = liftA2 quot + rem = liftA2 rem + toInteger = toInteger . get1 + + +-- DynamicT + +instance Num a => Num (DynamicT a) where + (+) = liftA2 (+) + (*) = liftA2 (*) + (-) = liftA2 (-) + abs = fmap abs + signum = fmap signum + fromInteger = pure . fromInteger + +instance Fractional a => Fractional (DynamicT a) where + recip = fmap recip + fromRational = pure . fromRational + +instance Floating a => Floating (DynamicT a) where + pi = pure pi + sqrt = fmap sqrt + exp = fmap exp + log = fmap log + sin = fmap sin + cos = fmap cos + asin = fmap asin + atan = fmap atan + acos = fmap acos + sinh = fmap sinh + cosh = fmap cosh + asinh = fmap asinh + atanh = fmap atanh + acosh = fmap acos + +instance Enum a => Enum (DynamicT a) where + toEnum = pure . toEnum + fromEnum = fromEnum . get1 + +instance Bounded a => Bounded (DynamicT a) where + minBound = pure minBound + maxBound = pure maxBound + +instance (Num a, Ord a, Real a) => Real (DynamicT a) where + toRational = toRational . get1 + +instance (Real a, Enum a, Integral a) => Integral (DynamicT a) where + quot = liftA2 quot + rem = liftA2 rem + toInteger = toInteger . get1 + + +-- ArticulationT + +instance Num a => Num (ArticulationT a) where + (+) = liftA2 (+) + (*) = liftA2 (*) + (-) = liftA2 (-) + abs = fmap abs + signum = fmap signum + fromInteger = pure . fromInteger + +instance Fractional a => Fractional (ArticulationT a) where + recip = fmap recip + fromRational = pure . fromRational + +instance Floating a => Floating (ArticulationT a) where + pi = pure pi + sqrt = fmap sqrt + exp = fmap exp + log = fmap log + sin = fmap sin + cos = fmap cos + asin = fmap asin + atan = fmap atan + acos = fmap acos + sinh = fmap sinh + cosh = fmap cosh + asinh = fmap asinh + atanh = fmap atanh + acosh = fmap acos + +instance Enum a => Enum (ArticulationT a) where + toEnum = pure . toEnum + fromEnum = fromEnum . get1 + +instance Bounded a => Bounded (ArticulationT a) where + minBound = pure minBound + maxBound = pure maxBound + +instance (Num a, Ord a, Real a) => Real (ArticulationT a) where + toRational = toRational . get1 + +instance (Real a, Enum a, Integral a) => Integral (ArticulationT a) where + quot = liftA2 quot + rem = liftA2 rem + toInteger = toInteger . get1 + +-- TremoloT + +instance Num a => Num (TremoloT a) where + (+) = liftA2 (+) + (*) = liftA2 (*) + (-) = liftA2 (-) + abs = fmap abs + signum = fmap signum + fromInteger = pure . fromInteger + +instance Fractional a => Fractional (TremoloT a) where + recip = fmap recip + fromRational = pure . fromRational + +instance Floating a => Floating (TremoloT a) where + pi = pure pi + sqrt = fmap sqrt + exp = fmap exp + log = fmap log + sin = fmap sin + cos = fmap cos + asin = fmap asin + atan = fmap atan + acos = fmap acos + sinh = fmap sinh + cosh = fmap cosh + asinh = fmap asinh + atanh = fmap atanh + acosh = fmap acos + +instance Enum a => Enum (TremoloT a) where + toEnum = pure . toEnum + fromEnum = fromEnum . get1 + +instance Bounded a => Bounded (TremoloT a) where + minBound = pure minBound + maxBound = pure maxBound + +instance (Num a, Ord a, Real a) => Real (TremoloT a) where + toRational = toRational . get1 + +instance (Real a, Enum a, Integral a) => Integral (TremoloT a) where + quot = liftA2 quot + rem = liftA2 rem + toInteger = toInteger . get1 + +-- TextT + +instance Num a => Num (TextT a) where + (+) = liftA2 (+) + (*) = liftA2 (*) + (-) = liftA2 (-) + abs = fmap abs + signum = fmap signum + fromInteger = pure . fromInteger + +instance Fractional a => Fractional (TextT a) where + recip = fmap recip + fromRational = pure . fromRational + +instance Floating a => Floating (TextT a) where + pi = pure pi + sqrt = fmap sqrt + exp = fmap exp + log = fmap log + sin = fmap sin + cos = fmap cos + asin = fmap asin + atan = fmap atan + acos = fmap acos + sinh = fmap sinh + cosh = fmap cosh + asinh = fmap asinh + atanh = fmap atanh + acosh = fmap acos + +instance Enum a => Enum (TextT a) where + toEnum = pure . toEnum + fromEnum = fromEnum . get1 + +instance Bounded a => Bounded (TextT a) where + minBound = pure minBound + maxBound = pure maxBound + +instance (Num a, Ord a, Real a) => Real (TextT a) where + toRational = toRational . get1 + +instance (Real a, Enum a, Integral a) => Integral (TextT a) where + quot = liftA2 quot + rem = liftA2 rem + toInteger = toInteger . get1 + + +-- HarmonicT + +instance Num a => Num (HarmonicT a) where + (+) = liftA2 (+) + (*) = liftA2 (*) + (-) = liftA2 (-) + abs = fmap abs + signum = fmap signum + fromInteger = pure . fromInteger + +instance Fractional a => Fractional (HarmonicT a) where + recip = fmap recip + fromRational = pure . fromRational + +instance Floating a => Floating (HarmonicT a) where + pi = pure pi + sqrt = fmap sqrt + exp = fmap exp + log = fmap log + sin = fmap sin + cos = fmap cos + asin = fmap asin + atan = fmap atan + acos = fmap acos + sinh = fmap sinh + cosh = fmap cosh + asinh = fmap asinh + atanh = fmap atanh + acosh = fmap acos + +instance Enum a => Enum (HarmonicT a) where + toEnum = pure . toEnum + fromEnum = fromEnum . get1 + +instance Bounded a => Bounded (HarmonicT a) where + minBound = pure minBound + maxBound = pure maxBound + +instance (Num a, Ord a, Real a) => Real (HarmonicT a) where + toRational = toRational . get1 + +instance (Real a, Enum a, Integral a) => Integral (HarmonicT a) where + quot = liftA2 quot + rem = liftA2 rem + toInteger = toInteger . get1 + +-- SlideT + +instance Num a => Num (SlideT a) where + (+) = liftA2 (+) + (*) = liftA2 (*) + (-) = liftA2 (-) + abs = fmap abs + signum = fmap signum + fromInteger = pure . fromInteger + +instance Fractional a => Fractional (SlideT a) where + recip = fmap recip + fromRational = pure . fromRational + +instance Floating a => Floating (SlideT a) where + pi = pure pi + sqrt = fmap sqrt + exp = fmap exp + log = fmap log + sin = fmap sin + cos = fmap cos + asin = fmap asin + atan = fmap atan + acos = fmap acos + sinh = fmap sinh + cosh = fmap cosh + asinh = fmap asinh + atanh = fmap atanh + acosh = fmap acos + +instance Enum a => Enum (SlideT a) where + toEnum = pure . toEnum + fromEnum = fromEnum . get1 + +instance Bounded a => Bounded (SlideT a) where + minBound = pure minBound + maxBound = pure maxBound + +instance (Num a, Ord a, Real a) => Real (SlideT a) where + toRational = toRational . get1 + +instance (Real a, Enum a, Integral a) => Integral (SlideT a) where + quot = liftA2 quot + rem = liftA2 rem + toInteger = toInteger . get1 + + +type instance Pitch (Behavior a) = Behavior (Pitch a) + +-- TODO undecidable +instance (HasGetPitch a, HasSetPitch a b) => HasSetPitch (Behavior a) (Behavior b) where + type SetPitch (Behavior p) (Behavior a) = Behavior (SetPitch p a) + __mapPitch f a = liftA2 (__setPitch) (f $ (__getPitch) <$> a) a + +instance Tiable a => Tiable (Behavior a) where toTied x = (x,x) + + + +-- Safe for tuple-like types +get1 = head . toList +-- TODO replace with extract + +fmaps :: Functor f => (a -> (b, c)) -> f a -> (f b, f c) +fmaps f x = ((fst . f) <$> x, (snd . f) <$> x) + +liftsA2 :: Applicative f => (a -> b -> (c, d)) -> f a -> f b -> (f a, f b) +liftsA2 f x y = (fst <$> ((,) <$> x <*> y), snd <$> ((,) <$> x <*> y)) diff --git a/src/Music/Score/Meta.hs b/src/Music/Score/Meta.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Meta.hs @@ -0,0 +1,243 @@ + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +-- Provides meta-information. +-- +-- Each score supports an unlimited number of 'Reactive' meta-values. +-- +-- This is more or less based on Diagrams styles, which is in turn based +-- on XMonad. +-- +------------------------------------------------------------------------------------- + +module Music.Score.Meta ( + -- * Attributes + IsAttribute, + Attribute, + wrapAttr, + unwrapAttr, + + -- * Meta-values + Meta, + -- addMeta, + addMetaNote, + addGlobalMetaNote, + runMeta, + HasMeta(..), + ) where + +import Control.Applicative +import Control.Arrow +import Control.Lens +import Control.Monad.Plus +import Data.Foldable (Foldable) +import qualified Data.Foldable as F +import qualified Data.List as List +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe +import Data.Monoid.WithSemigroup +import Data.Semigroup +import Data.Set (Set) +import qualified Data.Set as Set +import Data.String +import Data.Traversable (Traversable) +import qualified Data.Traversable as T +import Data.Typeable +import Data.Void + +import Music.Pitch.Literal +import Music.Score.Note +import Music.Score.Part +import Music.Score.Pitch +import Music.Score.Util +import Music.Score.Voice +import Music.Time + + +type IsAttribute a = (Typeable a, Monoid' a) + +-- | An existential wrapper type to hold attributes. +data Attribute :: * where + Attribute :: IsAttribute a => a -> Attribute + -- TAttribute :: (Transformable a, IsAttribute a) => a -> Attribute + +-- | Wrap up an attribute. +wrapAttr :: IsAttribute a => a -> Attribute +wrapAttr = Attribute + +unwrapAttr :: IsAttribute a => Attribute -> Maybe a +unwrapAttr (Attribute a) = cast a + +instance Semigroup Attribute where + (Attribute a1) <> a2 = case unwrapAttr a2 of + Nothing -> a2 + Just a2' -> Attribute (a1 <> a2') + +instance Delayable Attribute where + delay _ (Attribute a) = Attribute a +instance Stretchable Attribute where + stretch _ (Attribute a) = Attribute a + + +-- TODO is Transformable right w.r.t. join? +newtype Meta = Meta (Map String (Reactive Attribute)) + deriving (Delayable, Stretchable) + +-- instance HasPart Meta where + +inMeta :: (Map String (Reactive Attribute) -> Map String (Reactive Attribute)) -> Meta -> Meta +inMeta f (Meta s) = Meta (f s) + + +addGlobalMetaNote :: forall a b . (IsAttribute a, HasMeta b) => Note a -> b -> b +addGlobalMetaNote x = applyMeta $ addMeta' (Nothing::Maybe Int) $ noteToReactive x + +-- XXX +addMetaNote :: forall a b . (IsAttribute a, HasMeta b, HasPart' b) => Note a -> b -> b +addMetaNote x y = (applyMeta $ addMeta' (Just y) $ noteToReactive x) y + +-- Switch at time t to the given value (switch is valid until the end of the music). +-- TODO might not work as we think +addMetaChange :: forall a b . (IsAttribute a, HasMeta b, HasPart' b) => Time -> a -> b -> b +addMetaChange t x y = (applyMeta $ addMeta' (Just y) $ switch t mempty (pure x)) y + + +runMeta :: forall a b . (HasPart' a, IsAttribute b) => Maybe a -> Meta -> Reactive b +runMeta part = fromMaybe mempty . runMeta' part + +addMeta' :: forall a b . (HasPart' a, IsAttribute b) => Maybe a -> Reactive b -> Meta +addMeta' part a = Meta $ Map.singleton key $ fmap wrapAttr a + where + key = ty ++ pt + pt = show $ fmap getPart part + ty = show $ typeOf (undefined :: b) + +-- runMeta' :: forall a . IsAttribute a => Meta -> Maybe (Reactive a) +runMeta' :: forall a b . (HasPart' a, IsAttribute b) => Maybe a -> Meta -> Maybe (Reactive b) +runMeta' part (Meta s) = fmap (fmap (fromMaybe (error "runMeta'") . unwrapAttr)) $ Map.lookup key s +-- Note: unwrapAttr should never fail + where + key = ty ++ pt + pt = show $ fmap getPart part + ty = show . typeOf $ (undefined :: b) + +instance Semigroup Meta where + Meta s1 <> Meta s2 = Meta $ Map.unionWith (<>) s1 s2 + +-- | The empty meta contains no attributes; composition of metas is +-- a union of attributes; if the two metas have attributes of the +-- same type they are combined according to their semigroup +-- structure. +instance Monoid Meta where + mempty = Meta Map.empty + mappend = (<>) + +-- | Type class for things which have meta-information. +class HasMeta a where + -- | Apply meta-information by combining it (on the left) with the + -- existing meta-information. + meta :: Lens' a Meta + +instance HasMeta Meta where + meta = ($) + +applyMeta :: HasMeta a => Meta -> a -> a +applyMeta m = (meta <>~ m) + +-- instance (HasMeta a, HasMeta b) => HasMeta (a,b) where +-- applyMeta s = applyMeta s *** applyMeta s +-- +-- instance HasMeta a => HasMeta [a] where +-- applyMeta = fmap . applyMeta +-- +-- instance HasMeta b => HasMeta (a -> b) where +-- applyMeta = fmap . applyMeta +-- +-- instance HasMeta a => HasMeta (Map k a) where +-- applyMeta = fmap . applyMeta +-- +-- instance (HasMeta a, Ord a) => HasMeta (Set a) where +-- applyMeta = Set.map . applyMeta +-- + + + + + + + + + +newtype RehearsalMark = RehearsalMark () + deriving (Typeable, Monoid, Semigroup) + + + + + + + + + + + +-- TODO rename during +noteToReactive :: Monoid a => Note a -> Reactive a +noteToReactive n = (pure <$> n) `activate` pure mempty + +-- | Split a reactive into notes, as well as the values before and after the first/last update +splitReactive :: Reactive a -> Either a ((a, Time), [Note a], (Time, a)) +splitReactive r = case updates r of + [] -> Left (initial r) + (t,x):[] -> Right ((initial r, t), [], (t, x)) + (t,x):xs -> Right ((initial r, t), fmap note $ mrights (res $ (t,x):xs), head $ mlefts (res $ (t,x):xs)) + + where + + note (t,u,x) = t <-> u =: x + + -- Always returns a 0 or more Right followed by one left + res :: [(Time, a)] -> [Either (Time, a) (Time, Time, a)] + res rs = let (ts,xs) = unzip rs in + flip fmap (withNext ts `zip` xs) $ + \ ((t, mu), x) -> case mu of + Nothing -> Left (t, x) + Just u -> Right (t, u, x) + + -- lenght xs == length (withNext xs) + withNext :: [a] -> [(a, Maybe a)] + withNext = go + where + go [] = [] + go [x] = [(x, Nothing)] + go (x:y:rs) = (x, Just y) : withNext (y : rs) + +activate :: Note (Reactive a) -> Reactive a -> Reactive a +activate (getNote -> (view range -> (start,stop), x)) y = y `turnOn` (x `turnOff` y) + where + turnOn = switch start + turnOff = switch stop + diff --git a/src/Music/Score/Meta/Annotations.hs b/src/Music/Score/Meta/Annotations.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Meta/Annotations.hs @@ -0,0 +1,86 @@ + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +-- Provides annotations +-- +------------------------------------------------------------------------------------- + + +module Music.Score.Meta.Annotations ( + Annotation, + annotate, + annotateSpan, + showAnnotations, + showAnnotations', + withAnnotations, + ) where + +import Control.Arrow +import Control.Monad.Plus +import qualified Data.List +import Data.Semigroup +import Data.String +import Data.Typeable +import Data.Void + +import Music.Score.Combinators (withGlobalMeta) +import Music.Score.Meta +import Music.Score.Note +import Music.Score.Ornaments (HasText, text) +import Music.Score.Part +import Music.Score.Score +import Music.Time +import Music.Time.Reactive + +-- | +-- An annotation is a unique textual value attached to parts of a score. +-- They are ignored by default, but can be collected with 'withAnnotations'. +-- +newtype Annotation = Annotation { getAnnotation_ :: [String] } + deriving (Semigroup, Monoid, Typeable) +instance IsString Annotation where fromString = Annotation . return + +getAnnotation :: Annotation -> [String] +getAnnotation = Data.List.nub . getAnnotation_ + +-- | Annotate the whole score. +annotate :: String -> Score a -> Score a +annotate str x = annotateSpan (start >-> duration x) str x + +-- | Annotate a part of the score. +annotateSpan :: Span -> String -> Score a -> Score a +annotateSpan span str x = addGlobalMetaNote (sapp span $ return $ Annotation [str]) x + +-- | Show all annotations in the score. +showAnnotations :: (HasPart' a, HasText a) => Score a -> Score a +showAnnotations = showAnnotations' ":" + +-- | Show all annotations in the score using the given prefix. +showAnnotations' :: (HasPart' a, HasText a) => String -> Score a -> Score a +showAnnotations' prefix = withAnnotations (flip $ \s -> foldr (text . (prefix ++ )) s) + +-- | Handle the annotations in a score. +withAnnotations :: (HasPart' a, HasText a) => ([String] -> Score a -> Score a) -> Score a -> Score a +withAnnotations f = withGlobalMeta (f . getAnnotation) + diff --git a/src/Music/Score/Meta/Attribution.hs b/src/Music/Score/Meta/Attribution.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Meta/Attribution.hs @@ -0,0 +1,161 @@ + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +------------------------------------------------------------------------------------- + +module Music.Score.Meta.Attribution ( + + -- * Attribution type + Attribution, + attribution, + attributions, + getAttribution, + + -- ** Adding attribution to scores + attribute, + attributeDuring, + composer, + composerDuring, + lyricist, + lyricistDuring, + arranger, + arrangerDuring, + + -- ** Extracting attribution + withAttribution, + withAttribution', + ) where + +import Control.Arrow +import Control.Monad.Plus +import Data.Foldable (Foldable) +import qualified Data.Foldable as F +import qualified Data.List as List +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe +import Data.Monoid.WithSemigroup +import Data.Semigroup +import Data.Set (Set) +import qualified Data.Set as Set +import Data.String +import Data.Traversable (Traversable) +import qualified Data.Traversable as T +import Data.Typeable +import Data.Void + +import Music.Pitch.Literal +import Music.Score.Combinators +import Music.Score.Meta +import Music.Score.Note +import Music.Score.Part +import Music.Score.Pitch +import Music.Score.Score +import Music.Score.Util +import Music.Score.Voice +import Music.Time +import Music.Time.Reactive + + +-- | +-- An attributions is a simple map from keys to values used to gather information such as +-- composer, lyricist, orchestrator, performer, etc. +-- +-- Attribution is a 'Semigroup', and compose by choosing the leftmost value in each +-- category. For example +-- +-- > attribution "composer" "H" <> attribution "composer" "S" <> attribution "lyricist" "S" +-- > ===> attributions [("composer","H"),("lyricist","S")] +-- +-- Any kind of attribution can be added, and backends may recognize or ignore categories as they +-- see fit. The following categories are normally recognized: +-- +-- > composer +-- > lyricist +-- > arranger +-- > performer +-- > dedication +-- > year +-- > copyright +-- > information +-- +newtype Attribution = Attribution (Map String (Option (Last String))) + deriving (Typeable, Monoid, Semigroup) + +instance Show Attribution where + show (Attribution a) = "attributions " ++ show (Map.toList (fmap (fromJust . fmap getLast . getOption) $ a)) + +-- | Make an 'Attribution' from keys and values. +attributions :: [(String, String)] -> Attribution +attributions = Attribution . fmap (Option . Just . Last) . Map.fromList + +-- | Make an 'Attribution' a single key and value. +attribution :: String -> String -> Attribution +attribution k v = Attribution . fmap (Option . Just . Last) $ Map.singleton k v + +-- | Extract an the given attributions value. Semantic function. +getAttribution :: Attribution -> String -> Maybe String +getAttribution (Attribution a) k = join $ k `Map.lookup` (fmap (fmap getLast . getOption) $ a) + + +-- | Set the given attribution in the given score. +attribute :: (HasMeta a, HasPart' a, HasOnset a, HasOffset a) => Attribution -> a -> a +attribute a x = attributeDuring (era x) a x + +-- | Set the given attribution in the given part of a score. +attributeDuring :: (HasMeta a, HasPart' a) => Span -> Attribution -> a -> a +attributeDuring s a = addGlobalMetaNote (s =: a) + +-- | Set composer of the given score. +composer :: (HasMeta a, HasPart' a, HasOnset a, HasOffset a) => String -> a -> a +composer t x = composerDuring (era x) t x + +-- | Set composer of the given part of a score. +composerDuring :: (HasMeta a, HasPart' a) => Span -> String -> a -> a +composerDuring s x = attributeDuring s ("composer" `attribution` x) + +-- | Set lyricist of the given score. +lyricist :: (HasMeta a, HasPart' a, HasOnset a, HasOffset a) => String -> a -> a +lyricist t x = lyricistDuring (era x) t x + +-- | Set lyricist of the given part of a score. +lyricistDuring :: (HasMeta a, HasPart' a) => Span -> String -> a -> a +lyricistDuring s x = attributeDuring s ("lyricist" `attribution` x) + +-- | Set arranger of the given score. +arranger :: (HasMeta a, HasPart' a, HasOnset a, HasOffset a) => String -> a -> a +arranger t x = arrangerDuring (era x) t x + +-- | Set arranger of the given part of a score. +arrangerDuring :: (HasMeta a, HasPart' a) => Span -> String -> a -> a +arrangerDuring s x = attributeDuring s ("arranger" `attribution` x) + +-- | Extract attribution values of the given category from a score. +withAttribution :: String -> (String -> Score a -> Score a) -> Score a -> Score a +withAttribution name f = withAttribution' (fromMaybe id . fmap f . flip getAttribution name) + +-- | Extract all attribution values from a score. +withAttribution' :: (Attribution -> Score a -> Score a) -> Score a -> Score a +withAttribution' = withGlobalMetaAtStart + diff --git a/src/Music/Score/Meta/Barline.hs b/src/Music/Score/Meta/Barline.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Meta/Barline.hs @@ -0,0 +1,101 @@ + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +------------------------------------------------------------------------------------- + +module Music.Score.Meta.Barline ( + -- * Barline type + BarlineType(..), + Barline, + + -- ** Adding barlines to scores + barline, + doubleBarline, + finalBarline, + barlineDuring, + + -- ** Extracting barlines + withBarline, + ) where + + +import Control.Arrow +import Control.Monad.Plus +import Data.Default +import Data.Foldable (Foldable) +import qualified Data.Foldable as F +import qualified Data.List as List +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe +import Data.Monoid.WithSemigroup +import Data.Semigroup +import Data.Set (Set) +import qualified Data.Set as Set +import Data.String +import Data.Traversable (Traversable) +import qualified Data.Traversable as T +import Data.Typeable +import Data.Void + +import Music.Pitch.Literal +import Music.Score.Combinators +import Music.Score.Meta +import Music.Score.Note +import Music.Score.Part +import Music.Score.Pitch +import Music.Score.Score +import Music.Score.Util +import Music.Score.Voice +import Music.Time +import Music.Time.Reactive + +-- | Represents a barline. +-- +-- TODO repeats +data Barline = Barline BarlineType + deriving (Eq, Ord, Show, Typeable) + +data BarlineType = StandardBarline | DoubleBarline | FinalBarline + deriving (Eq, Ord, Show, Typeable) + +-- | Add a barline over the whole score. +barline :: (HasMeta a, HasPart' a, HasOnset a, HasOffset a) => Barline -> a -> a +barline c x = barlineDuring (era x) c x + +-- | Add a barline over the whole score. +doubleBarline :: (HasMeta a, HasPart' a, HasOnset a, HasOffset a) => Barline -> a -> a +doubleBarline = undefined + +-- | Add a barline over the whole score. +finalBarline :: (HasMeta a, HasPart' a, HasOnset a, HasOffset a) => Barline -> a -> a +finalBarline = undefined + +-- | Add a barline to the given score. +barlineDuring :: (HasMeta a, HasPart' a) => Span -> Barline -> a -> a +barlineDuring s c = addMetaNote (s =: (Option $ Just $ Last c)) + +-- | Extract barlines in from the given score, using the given default barline. +withBarline :: (Barline -> Score a -> Score a) -> Score a -> Score a +withBarline f = withGlobalMeta (maybe id f . fmap getLast . getOption) diff --git a/src/Music/Score/Meta/Clef.hs b/src/Music/Score/Meta/Clef.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Meta/Clef.hs @@ -0,0 +1,82 @@ + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +------------------------------------------------------------------------------------- + +module Music.Score.Meta.Clef ( + -- * Clef type + Clef(..), + + -- ** Adding clefs to scores + clef, + clefDuring, + + -- ** Extracting clefs + withClef, + ) where + +import Control.Arrow +import Control.Monad.Plus +import Data.Foldable (Foldable) +import qualified Data.Foldable as F +import qualified Data.List as List +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe +import Data.Monoid.WithSemigroup +import Data.Semigroup +import Data.Set (Set) +import qualified Data.Set as Set +import Data.String +import Data.Traversable (Traversable) +import qualified Data.Traversable as T +import Data.Typeable +import Data.Void + +import Music.Pitch.Literal +import Music.Score.Combinators +import Music.Score.Meta +import Music.Score.Note +import Music.Score.Part +import Music.Score.Pitch +import Music.Score.Score +import Music.Score.Util +import Music.Score.Voice +import Music.Time +import Music.Time.Reactive + +data Clef = GClef | CClef | FClef + deriving (Eq, Ord, Show, Typeable) + +-- | Set clef of the given score. +clef :: (HasMeta a, HasPart' a, HasOnset a, HasOffset a) => Clef -> a -> a +clef c x = clefDuring (era x) c x + +-- | Set clef of the given part of a score. +clefDuring :: (HasMeta a, HasPart' a) => Span -> Clef -> a -> a +clefDuring s c = addMetaNote (s =: (Option $ Just $ Last c)) + +-- | Extract the clef in from the given score, using the given default clef. +withClef :: HasPart' a => Clef -> (Clef -> Score a -> Score a) -> Score a -> Score a +withClef def f = withMeta (f . fromMaybe def . fmap getLast . getOption) diff --git a/src/Music/Score/Meta/Fermata.hs b/src/Music/Score/Meta/Fermata.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Meta/Fermata.hs @@ -0,0 +1,91 @@ + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +------------------------------------------------------------------------------------- + +module Music.Score.Meta.Fermata ( + -- * Fermata type + FermataType(..), + Fermata, + + -- ** Adding fermatas to scores + fermata, + fermataDuring, + + -- ** Extracting fermatas + withFermata, + ) where + + +import Control.Arrow +import Control.Monad.Plus +import Data.Default +import Data.Foldable (Foldable) +import qualified Data.Foldable as F +import qualified Data.List as List +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe +import Data.Monoid.WithSemigroup +import Data.Semigroup +import Data.Set (Set) +import qualified Data.Set as Set +import Data.String +import Data.Traversable (Traversable) +import qualified Data.Traversable as T +import Data.Typeable +import Data.Void + +import Music.Pitch.Literal +import Music.Score.Combinators +import Music.Score.Meta +import Music.Score.Note +import Music.Score.Part +import Music.Score.Pitch +import Music.Score.Score +import Music.Score.Util +import Music.Score.Voice +import Music.Time +import Music.Time.Reactive + +-- | Represents a fermata. +-- +-- TODO where is the fermata added if the score contains multiple notes. Always the last? +data Fermata = Fermata FermataType + deriving (Eq, Ord, Show, Typeable) + +data FermataType = StandardFermata | LongFermata | VeryLongFermata + deriving (Eq, Ord, Show, Typeable) + +-- | Add a fermata over the whole score. +fermata :: (HasMeta a, HasPart' a, HasOnset a, HasOffset a) => Fermata -> a -> a +fermata c x = fermataDuring (era x) c x + +-- | Add a fermata to the given score. +fermataDuring :: (HasMeta a, HasPart' a) => Span -> Fermata -> a -> a +fermataDuring s c = addMetaNote (s =: (Option $ Just $ Last c)) + +-- | Extract fermatas in from the given score, using the given default fermata. +withFermata :: (Fermata -> Score a -> Score a) -> Score a -> Score a +withFermata f = withGlobalMeta (maybe id f . fmap getLast . getOption) diff --git a/src/Music/Score/Meta/Key.hs b/src/Music/Score/Meta/Key.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Meta/Key.hs @@ -0,0 +1,134 @@ + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +------------------------------------------------------------------------------------- + +module Music.Score.Meta.Key ( + -- * Key signature type + Fifths, + KeySignature, + key, + isMajorKey, + isMinorKey, + + -- * Adding key signatures to scores + keySignature, + keySignatureDuring, + + -- * Extracting key signatures + withKeySignature, + ) where + +import Control.Arrow +import Control.Monad.Plus +import Data.Foldable (Foldable) +import qualified Data.Foldable as F +import qualified Data.List as List +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe +import Data.Monoid.WithSemigroup +import Data.Semigroup +import Data.Set (Set) +import qualified Data.Set as Set +import Data.String +import Data.Traversable (Traversable) +import qualified Data.Traversable as T +import Data.Typeable +import Data.Void + +import Music.Pitch.Literal +import Music.Score.Combinators +import Music.Score.Meta +import Music.Score.Note +import Music.Score.Part +import Music.Score.Pitch +import Music.Score.Score +import Music.Score.Util +import Music.Score.Voice +import Music.Time +import Music.Time.Reactive + +newtype Fifths = Fifths Integer + deriving (Eq, Ord, Num, Enum, Integral, Real) + +instance IsPitch Fifths where + fromPitch (PitchL (d, fromMaybe 0 -> c, _)) = case (d,c) of + (0,-1) -> (-7) + (0, 0) -> 0 + (0, 1) -> 7 + + (1,-1) -> (-5) + (1, 0) -> 2 + (1, 1) -> 9 + + (2,-1) -> (-3) + (2, 0) -> 4 + (2, 1) -> 11 + + (3,-1) -> (-8) + (3, 0) -> (-1) + (3, 1) -> 6 + + (4,-1) -> (-6) + (4, 0) -> 1 + (4, 1) -> 8 + + (5,-1) -> (-4) + (5, 0) -> 3 + (5, 1) -> 10 + + (6,-1) -> (-2) + (6, 0) -> 5 + (6, 1) -> 12 + + _ -> error "Strange number of Fifths" + +-- | A key signature, represented by number of fifths from C and mode. +newtype KeySignature = KeySignature (Fifths, Bool) + deriving (Eq, Ord, Typeable) + +-- | Create a major or minor signature. +key :: Fifths -> Bool -> KeySignature +key fifths mode = KeySignature (fifths, mode) + +isMajorKey :: KeySignature -> Bool +isMajorKey (KeySignature (_,x)) = x + +isMinorKey :: KeySignature -> Bool +isMinorKey = not . isMajorKey + +-- | Set the key signature of the given score. +keySignature :: (HasMeta a, HasPart' a, HasOnset a, HasOffset a) => KeySignature -> a -> a +keySignature c x = keySignatureDuring (era x) c x + +-- | Set the key signature of the given part of a score. +keySignatureDuring :: (HasMeta a, HasPart' a) => Span -> KeySignature -> a -> a +keySignatureDuring s c = addGlobalMetaNote (s =: (Option $ Just $ Last c)) + +-- | Extract all key signatures from the given score, using the given default key signature. +withKeySignature :: KeySignature -> (KeySignature -> Score a -> Score a) -> Score a -> Score a +withKeySignature def f = withGlobalMeta (f . fromMaybe def . fmap getLast . getOption) + diff --git a/src/Music/Score/Meta/RehearsalMark.hs b/src/Music/Score/Meta/RehearsalMark.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Meta/RehearsalMark.hs @@ -0,0 +1,103 @@ + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +------------------------------------------------------------------------------------- + +module Music.Score.Meta.RehearsalMark ( + -- * Rehearsal mark type + RehearsalMark, + + -- * Adding rehearsal marks to scores + rehearsalMark, + rehearsalMarkDuring, + + -- * Extracting rehearsal marks + withRehearsalMark, + ) where + + +import Control.Arrow +import Control.Monad.Plus +import Data.Default +import Data.Foldable (Foldable) +import qualified Data.Foldable as F +import qualified Data.List as List +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe +import Data.Monoid.WithSemigroup +import Data.Semigroup +import Data.Set (Set) +import qualified Data.Set as Set +import Data.String +import Data.Traversable (Traversable) +import qualified Data.Traversable as T +import Data.Typeable +import Data.Void + +import Music.Pitch.Literal +import Music.Score.Combinators +import Music.Score.Meta +import Music.Score.Note +import Music.Score.Part +import Music.Score.Pitch +import Music.Score.Score +import Music.Score.Util +import Music.Score.Voice +import Music.Time +import Music.Time.Reactive + +-- | Represents a rehearsal mark. +-- +-- TODO this needs zero-duration spans to work properly. +data RehearsalMark = RehearsalMark (Maybe String) Int + deriving (Eq, Ord, Typeable) +-- name level(0=standard) + +instance Default RehearsalMark where + def = RehearsalMark Nothing 0 + +instance Semigroup RehearsalMark where + RehearsalMark n1 l1 <> RehearsalMark n2 l2 = RehearsalMark (n1 <> n2) (l1 `max` l2) + +instance Monoid RehearsalMark where + mempty = def + mappend = (<>) + +instance Show RehearsalMark where + show (RehearsalMark name level) = "A" -- TODo + + +-- metronome :: Duration -> Bpm -> Tempo +-- metronome noteVal bpm = Tempo Nothing (Just noteVal) $ 60 / (bpm * noteVal) + +rehearsalMark :: (HasMeta a, HasPart' a, HasOnset a, HasOffset a) => RehearsalMark -> a -> a +rehearsalMark c x = rehearsalMarkDuring (era x) c x + +rehearsalMarkDuring :: (HasMeta a, HasPart' a) => Span -> RehearsalMark -> a -> a +rehearsalMarkDuring s x = addGlobalMetaNote (s =: x) + +withRehearsalMark :: (RehearsalMark -> Score a -> Score a) -> Score a -> Score a +withRehearsalMark = withGlobalMeta + diff --git a/src/Music/Score/Meta/Tempo.hs b/src/Music/Score/Meta/Tempo.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Meta/Tempo.hs @@ -0,0 +1,315 @@ + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +------------------------------------------------------------------------------------- + +module Music.Score.Meta.Tempo ( + -- * Tempo type + Bpm, + NoteValue, + Tempo, + metronome, + tempoNoteValue, + tempoBeatsPerMinute, + getTempo, + tempoToDuration, + + -- * Adding tempo to scores + tempo, + tempoDuring, + + -- * Extracting tempo + renderTempo, + ) where + + +import Control.Arrow +import Control.Lens +import Control.Monad.Plus +import Data.AffineSpace +import Data.Default +import Data.Foldable (Foldable) +import qualified Data.Foldable as F +import qualified Data.List as List +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe +import Data.Monoid.WithSemigroup +import Data.Semigroup +import Data.Set (Set) +import qualified Data.Set as Set +import Data.String +import Data.Traversable (Traversable) +import qualified Data.Traversable as T +import Data.Typeable +import Data.VectorSpace +import Data.Void + +import Music.Pitch.Literal +import Music.Score.Combinators +import Music.Score.Convert +import Music.Score.Meta +import Music.Score.Note +import Music.Score.Part +import Music.Score.Pitch +import Music.Score.Score +import Music.Score.Util +import Music.Score.Voice +import Music.Time +import Music.Time.Reactive + +type Bpm = Duration +type NoteValue = Duration + +-- | Represents musical tempo as a scaling factor with an optional name and/or beat duration. +-- +-- 'tempoToDuration' provides a scaling factor such that +-- +-- > stretch (tempoToDuration t) notation = sounding +-- > compress (tempoToDuration t) sounding = notation +-- +-- You can construct a tempo in various ways +-- +-- > tempoToDuration (metronome (1/4) 120) == tempoToDuration (metronome (1/2) 60) +-- > metronome (1/4) 120 /= metronome (1/2) 60 + +data Tempo = Tempo (Maybe String) (Maybe Duration) Duration + deriving (Eq, Ord, Typeable) +-- The internal representation is actually: maybeName maybeDisplayNoteValue scalingFactor + +-- TODO +instance Num Tempo where + fromInteger = Tempo Nothing Nothing . fromInteger + +instance Show Tempo where + show (getTempo -> (nv, bpm)) = "metronome " ++ showR nv ++ " " ++ showR bpm + where + showR (realToFrac -> (unRatio -> (x, 1))) = show x + showR (realToFrac -> (unRatio -> (x, y))) = "(" ++ show x ++ "/" ++ show y ++ ")" + +instance Default Tempo where + def = metronome (1/1) 60 + +-- | Create a tempo from a duration and a number of beats per minute. +-- +-- For example @metronome (1/2) 48@ means 48 half notes per minute. +metronome :: Duration -> Bpm -> Tempo +metronome noteVal bpm = Tempo Nothing (Just noteVal) $ 60 / (bpm * noteVal) + + +-- TODO use lenses +-- +-- noteValue :: Lens' Tempo (Maybe NoteValue) +-- noteValue = lens g s +-- where +-- g (Tempo n nv d) = nv +-- s (Tempo n _ d) nv = Tempo n nv d +-- +-- bpm :: Lens' Tempo Bpm +-- bpm = lens g s +-- where +-- g (Tempo n nv d) = nv +-- s (Tempo n _ d) nv = Tempo n nv d + + +-- | Get the note value indicated by a tempo. +tempoNoteValue :: Tempo -> Maybe NoteValue +tempoNoteValue (Tempo n nv d) = nv + +-- | Get the number of beats per minute indicated by a tempo. +tempoBeatsPerMinute :: Tempo -> Bpm +tempoBeatsPerMinute = snd . getTempo + +-- | Get the note value and number of beats per minute indicated by a tempo. +-- +-- Typically used with the @ViewPatterns@ extension, as in +-- +-- > foo (getTempo -> (nv, bpm)) = ... +-- +getTempo :: Tempo -> (NoteValue, Bpm) +getTempo (Tempo _ Nothing x) = (1, (60 * recip x) / 1) -- assume whole note +getTempo (Tempo _ (Just nv) x) = (nv, (60 * recip x) / nv) + +-- | Convert a tempo to a duration suitable for converting written to sounding durations. +-- +-- > stretch (tempoToDuration t) notation = sounding +-- > compress (tempoToDuration t) sounding = notation +-- +tempoToDuration :: Tempo -> Duration +tempoToDuration (Tempo _ _ x) = x + +-- | Set the tempo of the given score. +tempo :: (HasMeta a, HasPart' a, HasOnset a, HasOffset a) => Tempo -> a -> a +tempo c x = tempoDuring (era x) c x + +-- | Set the tempo of the given part of a score. +tempoDuring :: (HasMeta a, HasPart' a) => Span -> Tempo -> a -> a +tempoDuring s c = addGlobalMetaNote (s =: (optionFirst c)) + + +-- TODO move +inSpan :: Span -> Time -> Bool +inSpan (view range -> (t,u)) x = t <= x && x <= u + +inSpan' (view range -> (t,u)) x = t <= x && x < u + +-- | Split a reactive into notes, as well as the values before and after the first/last update +-- TODO fails if not positive +-- TODO same as reactiveToVoice +reactiveIn :: Span -> Reactive a -> [Note a] +reactiveIn s r + | duration s <= 0 = error "reactiveIn: Needs positive duration" + | otherwise = let r2 = trim s (fmap optionFirst r) + in fmap (fmap $ fromJust . unOptionFirst) $ case updates r2 of + -- We have at least 2 value because of trim + (frl -> ((t,x),[],(u,_))) -> [t <-> u =: x] -- one note + (frl -> ((t0,x0), unzip -> (tn,xn), (tl,_))) -> let + times = [t0] ++ tn + spans = mapWithNext (\t mu -> t <-> fromMaybe tl mu) times + values = [x0] ++ xn + in zipWith (=:) spans values + + + + +-- | Extract all tempi from the given score, using the given default tempo. +-- withTempo :: (Tempo -> Score a -> Score a) -> Score a -> Score a +-- withTempo f = withGlobalMeta (f . fromMaybe def . fmap getFirst . getOption) + +renderTempo :: Score a -> Score a +renderTempo sc = + flip composed sc $ fmap renderTempoScore + $ tempoRegions (era sc) + $ tempoRegions0 (era sc) + $ getTempoChanges defTempo sc + +renderTempoTest :: Score a -> [TempoRegion] +renderTempoTest sc = id + $ tempoRegions (era sc) + $ tempoRegions0 (era sc) + $ getTempoChanges defTempo sc + + +-- | Standard tempo +-- +-- > tempoToDuration defTempo == 1 +defTempo :: Tempo +defTempo = metronome (1/1) 60 + +getTempoChanges :: Tempo -> Score a -> Reactive Tempo +getTempoChanges def = fmap (fromMaybe def . unOptionFirst) . runMeta (Nothing::Maybe Int) . (view meta) + + +-- | Get all tempo regions for the given span. +tempoRegions0 :: Span -> Reactive Tempo -> [TempoRegion0] +tempoRegions0 s r = fmap f $ s `reactiveIn` r + where + f (getNote -> (view delta -> (t,u),x)) = TempoRegion0 t u (tempoToDuration x) + +tempoRegions :: Span -> [TempoRegion0] -> [TempoRegion] +tempoRegions s = snd . List.mapAccumL f (onset s, onset s) -- XXX offset? + where + f (nt,st) (TempoRegion0 _ d x) = ((nt .+^ d, st .+^ (d*x)), + TempoRegion nt (nt .+^ d) st x + ) + + + + + +-- | Return the sounding position of the given notated position, given its tempo region. +-- Does nothing if the given point is outside the given region. +renderTempoTime :: TempoRegion -> Time -> Time +renderTempoTime (TempoRegion notRegOn notRegOff soRegOn str) t + | notRegOn <= t && t < notRegOff = soRegOn .+^ (t .-. notRegOn) ^* str + | otherwise = t + +renderTempoTime' (TempoRegion notRegOn notRegOff soRegOn str) t = soRegOn .+^ ((t .-. notRegOn) ^* str) + +renderTempoSpan :: TempoRegion -> Span -> Span +renderTempoSpan tr = over range $ \(t,u) -> + if inSpan' (tempoRegionNotated tr) t + then (renderTempoTime' tr t, renderTempoTime' tr u) + else (t, u) + +-- TODO use lens +renderTempoScore :: TempoRegion -> Score a -> Score a +renderTempoScore tr = over notes $ fmap $ over (note_ . _1) $ renderTempoSpan tr + + +data TempoRegion0 = + TempoRegion0 { + notatedOnset0 :: Time, + notatedDuration0 :: Duration, + stretching0 :: Duration + } + deriving (Eq, Ord, Show) + +data TempoRegion = + TempoRegion { + notatedOnset :: Time, -- same + notatedOffset :: Time, -- notOns + notDur + soundingOnset :: Time, -- sum of previous sounding durations + stretching :: Duration -- same + } + deriving (Eq, Ord, Show) + +tempoRegionNotated (TempoRegion t u _ _) = t <-> u + +-- TODO add to Music.Score.Note +note_ :: Iso (Note a) (Note b) (Span, a) (Span, b) +note_ = iso getNote (uncurry (=:)) + +-- span :: Iso (Note a) (Note b) Span Span + +{- + A "tempo region" is a consecutive span in which the tempo is constant (obtained by @renderR tempo@) + + Tempo region: + - Its offset is the sum of the duration of all the previous regions + - Its scaling is simply (tempoToDuration tempo) + - Its duration is (scaling `stretch` notatedDuration) + + To "render tempo" for a time point: + - Its position is the offset in its tempo region + the offset of the tempo region + + To "render tempo" for a span: + - Its onset and offset are rendered separately + - Its duration is (offset - onset) as per the duration law + + + + +-} + + +-- TODO consolidate +optionFirst = Option . Just . First +unOptionFirst = fmap getFirst . getOption + +-- TODO move +frl [] = error "frl: No value" +frl [x] = error "frl: Just one value" +frl xs = (head xs, (tail.init) xs, last xs) diff --git a/src/Music/Score/Meta/Time.hs b/src/Music/Score/Meta/Time.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Meta/Time.hs @@ -0,0 +1,250 @@ + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +------------------------------------------------------------------------------------- + +module Music.Score.Meta.Time ( + + -- * Time signature type + TimeSignature, + time, + compoundTime, + isSimpleTime, + isCompoundTime, + toSimpleTime, + getTimeSignature, + + -- * Adding time signature to scores + timeSignature, + timeSignatureDuring, + + -- * Extracting time signatures + withTimeSignature, + getTimeSignatures, + getTimeSignatureChanges, + + -- * Utility + getBarDurations, + getBarTimeSignatures, + standardTimeSignature, + ) where + +import Control.Arrow +import Control.Monad.Plus +import Control.Lens (view) +import Data.Foldable (Foldable) +import qualified Data.Foldable as F +import qualified Data.List as List +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe +import Data.Monoid.WithSemigroup +import Data.Ratio ((%)) +import Data.Semigroup +import Data.Set (Set) +import qualified Data.Set as Set +import Data.String +import Data.Traversable (Traversable) +import qualified Data.Traversable as T +import Data.Typeable +import Data.Void + +import Music.Pitch.Literal +import Music.Score.Combinators +import Music.Score.Meta +import Music.Score.Note +import Music.Score.Part +import Music.Score.Pitch +import Music.Score.Score +import Music.Score.Util +import Music.Score.Voice +import Music.Time +import Music.Time.Reactive + +-- | +-- A time signature is a sequence of beat numbers and a note value (i.e. an expression on the +-- form @(a1+a2...)/b@). For simple time signatures just one beat number is used. +-- +-- TimeSignature is an instance of 'Fractional' and can be used as +-- follows: +-- +-- > timeSignature (4/4) +-- > timeSignature (6/8) +-- > timeSignature ((3+2)/4) +-- +newtype TimeSignature = TimeSignature ([Integer], Integer) + deriving (Eq, Ord, Typeable) + +mapNums f (TimeSignature (m,n)) = TimeSignature (f m, n) +mapDenom f (TimeSignature (m,n)) = TimeSignature (m, f n) +isSimple (TimeSignature ([_],_)) = True +isSimple _ = False +getSimple (TimeSignature ([m],n)) = m `div` n + +-- TODO move +liftRational f = fromRational . f . toRational +liftRational2 f x y = fromRational $ toRational x `f` toRational y + +instance Num TimeSignature where + x + y | x `haveSameDenominator` y = concatFrac x y + | otherwise = liftRational2 (+) x y + where + TimeSignature (_,n1) `haveSameDenominator` TimeSignature (_,n2) = n1 == n2 + TimeSignature (m1,n) `concatFrac` TimeSignature (m2,_) = TimeSignature (m1 <> m2, n) + + x * y | isSimple y = mapNums (fmap (* (getSimple y))) x + | otherwise = liftRational2 (*) x y + + negate = liftRational negate + abs = liftRational abs + signum = liftRational signum + fromInteger x = TimeSignature ([x], 1) + +instance Fractional TimeSignature where + fromRational (unRatio -> (m, n)) = TimeSignature ([m], n) + + x / y | isSimple y = mapDenom (* (getSimple y)) x + | otherwise = liftRational2 (/) x y + +instance Real TimeSignature where + toRational (TimeSignature (xs, x)) = sum xs % x + +instance Show TimeSignature where + show (TimeSignature ([m], n)) = show m ++ "/" ++ show n + show (TimeSignature (xs, n)) = "(" ++ List.intercalate "+" (fmap show xs) ++ ")/" ++ show n + +-- | Create a simple time signature. +time :: Integer -> Integer -> TimeSignature +time x y = TimeSignature ([x], y) + +-- | Create a compound time signature. +compoundTime :: [Integer] -> Integer -> TimeSignature +compoundTime = curry TimeSignature + +-- | Whether this is a simple time signature. +isSimpleTime :: TimeSignature -> Bool +isSimpleTime (TimeSignature ([_],_)) = True +isSimpleTime _ = False + +-- | Whether this is a compound time signature. +isCompoundTime :: TimeSignature -> Bool +isCompoundTime = not . isSimpleTime + +-- | Convert to a simple time signature by adding all numerators. +-- If given a simple time signature, returns it. +toSimpleTime :: TimeSignature -> TimeSignature +toSimpleTime = fromRational . toRational + +-- | Extract the components of a time signature. Semantic function. +-- +-- Typically used with the @ViewPatterns@ extension, as in +-- +-- > foo (getTimeSignature -> (beats, noteValue)) = ... +-- +getTimeSignature :: TimeSignature -> ([Integer], Integer) +getTimeSignature (TimeSignature x) = x + +-- | Set the time signature of the given score. +timeSignature :: (HasMeta a, HasPart' a, HasOnset a, HasOffset a) => TimeSignature -> a -> a +timeSignature c x = timeSignatureDuring (start <-> offset x) c x + +-- use (onset x <-> offset x) instead of (start <-> offset x) +-- timeSignature' c x = timeSignatureDuring (era x) c x + +-- | Set the time signature of the given part of a score. +timeSignatureDuring :: (HasMeta a, HasPart' a) => Span -> TimeSignature -> a -> a +timeSignatureDuring s c = addGlobalMetaNote (s =: optionFirst c) + +getTimeSignatures :: TimeSignature -> Score a -> Reactive TimeSignature +getTimeSignatures def = fmap (fromMaybe def . unOptionFirst) . runMeta (Nothing::Maybe Int) . (view meta) + +getTimeSignatureChanges :: TimeSignature -> Score a -> [(Time, TimeSignature)] +getTimeSignatureChanges def = updates . getTimeSignatures def + +-- | Extract the time signature from the given score, using the given default time signature. +withTimeSignature :: TimeSignature -> (TimeSignature -> Score a -> Score a) -> Score a -> Score a +withTimeSignature def f = withGlobalMeta (f . fromMaybe def . unOptionFirst) + +-- | Given a list of time signatures and the duration between them (TODO use voice), return a list of appropriate +-- bar durations. +getBarDurations :: [(TimeSignature, Duration)] -> [Duration] +getBarDurations = fmap realToFrac . getBarTimeSignatures + +-- | Given a list of time signatures and the duration between them (TODO use voice), return a list of appropriate +-- time signatures for each bar. +getBarTimeSignatures :: [(TimeSignature, Duration)] -> [TimeSignature] +getBarTimeSignatures = concatMap $ uncurry getBarTimeSignatures1 + +getBarTimeSignatures1 :: TimeSignature -> Duration -> [TimeSignature] +getBarTimeSignatures1 ts d = let + (n,r) = numWholeBars ts d + -- Repeat the chosen time signature as long as possible + -- If there is a rest duration, add a bar of that duration choosing an appropriate time signature + in replic n ts ++ if r > 0 then [standardTimeSignature r] else [] + + +-- | Return the number of whole bars needed to notate the given duration, as well as the remainder duration. +numWholeBars :: TimeSignature -> Duration -> (Integer, Duration) +numWholeBars ts dur = second (* barDur) $ properFraction (dur / barDur) where barDur = realToFrac ts + + + +-- | Time signature typically used for the given duration. +standardTimeSignature :: Duration -> TimeSignature +standardTimeSignature x = case unRatio (toRational x) of + -- (1,2) -> time 1 2 + (2,2) -> time 2 2 + (3,2) -> time 3 2 + (2,1) -> time 4 2 + (5,2) -> time 5 2 + (3,1) -> time 6 2 + (7,2) -> time 7 2 + + (1,4) -> time 1 4 + (1,2) -> time 2 4 + (3,4) -> time 3 4 + (1,1) -> time 4 4 + (5,4) -> time 5 4 + -- (3,2) -> time 6 4 + (7,4) -> time 7 4 + + (1,8) -> time 1 8 + -- (1,4) -> time 2 8 + (3,8) -> time 3 8 + -- (1,2) -> time 4 8 + (5,8) -> time 5 8 + -- (3,4) -> time 6 8 + (7,8) -> time 7 8 + + -- TODO check divisible by 8 etc + _ -> time 4 4 + -- _ -> error "standardTimeSignature: Stange value" + +-- TODO consolidate +optionFirst = Option . Just . First +unOptionFirst = fmap getFirst . getOption + + + diff --git a/src/Music/Score/Meta/Title.hs b/src/Music/Score/Meta/Title.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Meta/Title.hs @@ -0,0 +1,151 @@ + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +------------------------------------------------------------------------------------- + +module Music.Score.Meta.Title ( + + -- * Title type + Title, + + -- ** Creating and modifying + -- titleFromString, + denoteTitle, + getTitle, + getTitleAt, + + -- * Adding titles to scores + title, + titleDuring, + subtitle, + subtitleDuring, + subsubtitle, + subsubtitleDuring, + + -- * Extracting titles + withTitle, + ) where + +import Control.Arrow +import Control.Monad.Plus +import Data.Foldable (Foldable) +import qualified Data.Foldable as F +import qualified Data.List as List +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe +import Data.Monoid.WithSemigroup +import Data.Semigroup +import Data.Set (Set) +import qualified Data.Set as Set +import Data.String +import Data.Traversable (Traversable) +import qualified Data.Traversable as T +import Data.Typeable +import Data.Void + +import Music.Pitch.Literal +import Music.Score.Combinators +import Music.Score.Meta +import Music.Score.Note +import Music.Score.Part +import Music.Score.Pitch +import Music.Score.Score +import Music.Score.Util +import Music.Score.Voice +import Music.Time +import Music.Time.Reactive + +-- | +-- A title is a sequence of 'String' values, representing the name of a work or part of a work. +-- An arbitrary depth of title sections can be used. +-- +-- Title is an instance of 'IsString' and can be used with the 'OverloadedStrings' extension as +-- follows: +-- +-- > title "Le Nozze di Figaro" +-- > +-- > subtitle "Atto primo" +-- > subsubtitle "Scena I" +-- > subsubtitle "Scena II" +-- > ... +-- > +-- > subtitle "Atto secundo" +-- > ... +-- +newtype Title = Title (Int -> Option (Last String)) + deriving (Typeable, Monoid, Semigroup) + +instance IsString Title where + fromString x = Title $ \n -> if n == 0 then Option (Just (Last x)) else Option Nothing + +instance Show Title where + show = List.intercalate " " . getTitle + +-- | Create a title from a string. See also 'fromString'. +titleFromString :: String -> Title +titleFromString = fromString + +-- | Denote a title to a lower level, i.e title becomes subtitle, subtitle becomes subsubtitle etc. +denoteTitle :: Title -> Title +denoteTitle (Title t) = Title (t . subtract 1) + +-- | Extract the title as a descending list of title levels (i.e. title, subtitle, subsubtitle...). +getTitle :: Title -> [String] +getTitle t = untilFail . fmap (getTitleAt t) $ [0..] + where + untilFail = fmap fromJust . takeWhile isJust + +-- | Extract the title of the given level. Semantic function. +getTitleAt :: Title -> Int -> Maybe String +getTitleAt (Title t) n = fmap getLast . getOption . t $ n + +-- | Set title of the given score. +title :: (HasMeta a, HasPart' a, HasOnset a, HasOffset a) => Title -> a -> a +title t x = titleDuring (era x) t x + +-- | Set title of the given part of a score. +titleDuring :: (HasMeta a, HasPart' a) => Span -> Title -> a -> a +titleDuring s t = addGlobalMetaNote (s =: t) + +-- | Set subtitle of the given score. +subtitle :: (HasMeta a, HasPart' a, HasOnset a, HasOffset a) => Title -> a -> a +subtitle t x = subtitleDuring (era x) t x + +-- | Set subtitle of the given part of a score. +subtitleDuring :: (HasMeta a, HasPart' a) => Span -> Title -> a -> a +subtitleDuring s t = addGlobalMetaNote (s =: denoteTitle t) + +-- | Set subsubtitle of the given score. +subsubtitle :: (HasMeta a, HasPart' a, HasOnset a, HasOffset a) => Title -> a -> a +subsubtitle t x = subsubtitleDuring (era x) t x + +-- | Set subsubtitle of the given part of a score. +subsubtitleDuring :: (HasMeta a, HasPart' a) => Span -> Title -> a -> a +subsubtitleDuring s t = addGlobalMetaNote (s =: denoteTitle (denoteTitle t)) + +-- | Extract the title in from the given score. +withTitle :: (Title -> Score a -> Score a) -> Score a -> Score a +withTitle = withGlobalMetaAtStart + diff --git a/src/Music/Score/Note.hs b/src/Music/Score/Note.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Note.hs @@ -0,0 +1,99 @@ + +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} + +module Music.Score.Note ( + Note, + getNote, + getNoteSpan, + getNoteValue, + (=:), + ) where + +import Control.Applicative +import Control.Comonad +import Control.Comonad.Env +import Control.Monad + +import Data.Foldable (Foldable) +import qualified Data.Foldable as F +import Data.PairMonad () +import Data.Traversable (Traversable) +import qualified Data.Traversable as T + +import Music.Dynamics.Literal +import Music.Pitch.Literal +import Music.Score.Pitch +import Music.Time + +newtype Note a = Note { getNote_ :: (Span, a) } + deriving (Eq, Ord, Show, {-Read, -}Functor, Applicative, Monad, Comonad, Foldable, Traversable) + +-- | +-- Deconstruct a note. +-- +-- Typically used with the @ViewPatterns@ extension, as in +-- +-- > foo (getNote -> (s,x)) = ... +-- +getNote :: Note a -> (Span, a) +getNote (Note x) = x + +-- | Get the span of the note. Same as 'era' and 'ask'. +getNoteSpan :: Note a -> Span +getNoteSpan = fst . getNote + +-- | Get the value of the note. Same as 'extract'. +getNoteValue :: Note a -> a +getNoteValue = snd . getNote + +-- Note that +-- extract = getNoteValue +-- ask = getNoteSpan + +instance ComonadEnv Span Note where + ask = getNoteSpan + +instance Delayable (Note a) where + delay n (Note (s,x)) = Note (delay n s, x) + +instance Stretchable (Note a) where + stretch n (Note (s,x)) = Note (stretch n s, x) + +instance HasOnset (Note a) where + onset (Note (s,x)) = onset s + +instance HasOffset (Note a) where + offset (Note (s,x)) = offset s + +instance IsPitch a => IsPitch (Note a) where + fromPitch = pure . fromPitch + +instance IsDynamics a => IsDynamics (Note a) where + fromDynamics = pure . fromDynamics + +instance IsInterval a => IsInterval (Note a) where + fromInterval = pure . fromInterval + +type instance Pitch (Note a) = Pitch a +instance HasGetPitch a => HasGetPitch (Note a) where + __getPitch = __getPitch . getNoteValue +instance HasSetPitch a b => HasSetPitch (Note a) (Note b) where + type SetPitch g (Note a) = Note (SetPitch g a) + __mapPitch f = fmap (__mapPitch f) + + +-- | Construct a note from a span and value. +-- +-- Typically used with the span constructors as in: +-- +-- > 0 <-> 2 =: c +-- > 0 >-> 1 =: d +-- +(=:) :: Span -> a -> Note a +s =: x = Note (s,x) diff --git a/src/Music/Score/Ornaments.hs b/src/Music/Score/Ornaments.hs --- a/src/Music/Score/Ornaments.hs +++ b/src/Music/Score/Ornaments.hs @@ -1,13 +1,14 @@ -{-# LANGUAGE - TypeFamilies, - DeriveFunctor, - DeriveFoldable, - DeriveDataTypeable, - FlexibleInstances, - FlexibleContexts, - ConstraintKinds, - GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} ------------------------------------------------------------------------------------- -- | @@ -19,104 +20,184 @@ -- Stability : experimental -- Portability : non-portable (TF,GNTD) -- --- Provides functions for manipulating ornaments (and some other things...). +-- Provides functions for manipulating ornaments (and miscellaneous stuff to be +-- given its own module soon...). -- ------------------------------------------------------------------------------------- module Music.Score.Ornaments ( + -- * Tremolo HasTremolo(..), TremoloT(..), + tremolo, + + -- * Text HasText(..), TextT(..), + text, + + -- * Harmonics HasHarmonic(..), HarmonicT(..), - HasSlide(..), - SlideT(..), - - tremolo, - text, harmonic, artificial, + + -- * Slides and glissando + HasSlide(..), + SlideT(..), slide, + glissando, ) where -import Data.Ratio -import Data.Foldable -import Data.Monoid -import Data.Typeable -import qualified Data.List as List -import Data.VectorSpace -import Data.AffineSpace +import Control.Applicative +import Control.Lens +import Data.Foldable +import Data.Foldable +import Data.Ratio +import Data.Semigroup +import Data.Typeable -import Music.Score.Voice -import Music.Score.Score -import Music.Time -import Music.Score.Part -import Music.Score.Combinators +import Music.Score.Combinators +import Music.Score.Part +import Music.Score.Score +import Music.Score.Voice +import Music.Time class HasTremolo a where setTrem :: Int -> a -> a -newtype TremoloT a = TremoloT { getTremoloT :: (Int, a) } - deriving (Eq, Show, Ord, Functor{-, Foldable-}, Typeable) +newtype TremoloT a = TremoloT { getTremoloT :: (Sum Int, a) } + deriving (Eq, Show, Ord, Functor, Foldable, Typeable, Applicative, Monad) +instance HasTremolo (TremoloT a) where + setTrem n (TremoloT (_,x)) = TremoloT (Sum n,x) + +instance HasTremolo b => HasTremolo (a, b) where + setTrem n = fmap (setTrem n) + +instance HasTremolo a => HasTremolo (Score a) where + setTrem n = fmap (setTrem n) + + + + + class HasText a where addText :: String -> a -> a newtype TextT a = TextT { getTextT :: ([String], a) } - deriving (Eq, Show, Ord, Functor{-, Foldable-}, Typeable) + deriving (Eq, Show, Ord, Functor, Foldable, Typeable, Applicative, Monad) +instance HasText (TextT a) where + addText s (TextT (t,x)) = TextT (t ++ [s],x) +instance HasText a => HasText (b, a) where + addText s = fmap (addText s) + +instance HasText a => HasText (Score a) where + addText s = fmap (addText s) + + + + -- 0 for none, positive for natural, negative for artificial class HasHarmonic a where + setNatural :: Bool -> a -> a setHarmonic :: Int -> a -> a -newtype HarmonicT a = HarmonicT { getHarmonicT :: (Int, a) } - deriving (Eq, Show, Ord, Functor{-, Foldable-}, Typeable) +-- (isNatural, overtone series index where 0 is fundamental) +newtype HarmonicT a = HarmonicT { getHarmonicT :: ((Any, Sum Int), a) } + deriving (Eq, Show, Ord, Functor, Foldable, Typeable, Applicative, Monad) --- end gliss/slide, level, begin gliss/slide +instance HasHarmonic (HarmonicT a) where + setNatural b (HarmonicT ((_,n),x)) = HarmonicT ((Any b,n),x) + setHarmonic n (HarmonicT ((nat,_),x)) = HarmonicT ((nat,Sum n),x) + +instance HasHarmonic a => HasHarmonic (b, a) where + setNatural b = fmap (setNatural b) + setHarmonic n = fmap (setHarmonic n) + +instance HasHarmonic a => HasHarmonic (Score a) where + setNatural b = fmap (setNatural b) + setHarmonic n = fmap (setHarmonic n) + + + 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-}, Typeable) +-- (eg,es,a,bg,bs) +newtype SlideT a = SlideT { getSlideT :: (((Any, Any), (Any, Any)), a) } + deriving (Eq, Show, Ord, Functor, Foldable, Typeable, Applicative, Monad) +instance Wrapped (SlideT a) where + type Unwrapped (SlideT a) = (((Any, Any), (Any, Any)), a) + _Wrapped' = iso getSlideT SlideT +bg, bs, eg, es :: Lens' (SlideT a) Any +bg = _Wrapped' . _1 . _2 . _1 +bs = _Wrapped' . _1 . _2 . _2 +eg = _Wrapped' . _1 . _1 . _1 +es = _Wrapped' . _1 . _1 . _2 + +instance HasSlide (SlideT a) where + setBeginGliss x = bg .~ Any x + setBeginSlide x = bs .~ Any x + setEndGliss x = eg .~ Any x + setEndSlide x = es .~ Any x + +instance HasSlide a => HasSlide (b, a) where + setBeginGliss n = fmap (setBeginGliss n) + setBeginSlide n = fmap (setBeginSlide n) + setEndGliss n = fmap (setEndGliss n) + setEndSlide n = fmap (setEndSlide n) + +instance HasSlide a => HasSlide (Score a) where + setBeginGliss n = fmap (setBeginGliss n) + setBeginSlide n = fmap (setBeginSlide n) + setEndGliss n = fmap (setEndGliss n) + setEndSlide n = fmap (setEndSlide n) + -- | -- Set the number of tremolo divisions for all notes in the score. -- -tremolo :: (Functor s, HasTremolo b) => Int -> s b -> s b -tremolo n = fmap (setTrem n) +tremolo :: HasTremolo a => Int -> a -> a +tremolo = setTrem -- | -- Attach the given text to the first note in the score. -- -text :: (HasEvents s, HasPart' a, HasText a) => String -> s a -> s a +text :: (HasPart' a, HasText a) => String -> Score a -> Score a text s = mapPhrase (addText s) id id -- | --- Slide between the first and the last note. +-- Add a slide between the first and the last note. -- -slide :: (HasEvents s, HasPart' a, HasSlide a) => s a -> s a +slide :: (HasPart' a, HasSlide a) => Score a -> Score a slide = mapPhrase (setBeginSlide True) id (setEndSlide True) -glissando :: (HasEvents s, HasPart' a, HasSlide a) => s a -> s a +-- | +-- Add a glissando between the first and the last note. +-- +glissando :: (HasPart' a, HasSlide a) => Score a -> Score a glissando = mapPhrase (setBeginGliss True) id (setEndGliss 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 :: (Functor s, HasHarmonic a) => Int -> s a -> s a -harmonic n = fmap (setHarmonic n) +harmonic :: HasHarmonic a => Int -> a -> a +harmonic n = setNatural True . setHarmonic n +-- TODO verify this can actually be played -- | -- 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 :: (Functor s, HasHarmonic a) => s a -> s a -artificial = fmap f where f = setHarmonic (-4) +artificial :: HasHarmonic a => a -> a +artificial = setNatural False . setHarmonic 3 diff --git a/src/Music/Score/Part.hs b/src/Music/Score/Part.hs --- a/src/Music/Score/Part.hs +++ b/src/Music/Score/Part.hs @@ -1,14 +1,14 @@ -{-# LANGUAGE - TypeFamilies, - DeriveFunctor, - DeriveFoldable, - DeriveDataTypeable, - FlexibleInstances, - FlexibleContexts, - ConstraintKinds, - OverloadedStrings, - GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} ------------------------------------------------------------------------------------- -- | @@ -20,54 +20,46 @@ -- Stability : experimental -- Portability : non-portable (TF,GNTD) -- --- Provides partwise traversal, part composition and extraction. +-- Provides functions for manipulating parts. -- ------------------------------------------------------------------------------------- module Music.Score.Part ( + -- * Part representation + Part, HasPart(..), HasPart', - -- PartName(..), PartT(..), - extract, - extractParts, - mapPart, - mapAllParts, - mapParts, getParts, - setParts, - modifyParts, - - -- ** Part composition - (), - moveParts, - moveToPart, ) where -import Control.Monad (ap, mfilter, join, liftM, MonadPlus(..)) -import Data.Semigroup -import Data.String -import Data.Foldable -import Data.Typeable -import Data.Ord (comparing) -import Data.Traversable -import qualified Data.List as List -import Data.VectorSpace -import Data.AffineSpace -import Data.Ratio +import Control.Applicative +import Control.Comonad +import Control.Monad.Plus +import Data.Default +import Data.Foldable +import qualified Data.List as List +import Data.Ord (comparing) +import Data.PairMonad +import Data.Ratio +import Data.Semigroup +import Data.Traversable +import Data.Typeable -import Music.Time +import Music.Time +-- | Associated part type. Should normally implement 'Ord' and 'Show'. +type family Part a :: * + + -- | -- Class of types with an associated part. -- --- The part type can be any type that is orddered. +-- The part type can be any ordered type. A 'Show' instance is also +-- required from printing the name of the part in output. -- class HasPart a where - -- | Associated part type. Should implement 'Ord' and 'Show'. - type Part a :: * - -- | Get the voice of the given note. getPart :: a -> Part a @@ -77,146 +69,49 @@ -- | Modify the voice of the given note. modifyPart :: (Part a -> Part a) -> a -> a - setPart n = modifyPart (const n) + setPart n = modifyPart (const n) modifyPart f x = x newtype PartT n a = PartT { getPartT :: (n, a) } - deriving (Eq, Ord, Show, Functor, Typeable) - -instance HasPart () where { type Part () = Integer ; getPart _ = 0 } -instance HasPart Double where { type Part Double = Integer ; getPart _ = 0 } -instance HasPart Float where { type Part Float = Integer ; getPart _ = 0 } -instance HasPart Int where { type Part Int = Integer ; getPart _ = 0 } -instance HasPart Integer where { type Part Integer = Integer ; getPart _ = 0 } -instance Integral a => HasPart (Ratio a) where { type Part (Ratio a) = Integer ; getPart _ = 0 } - --- | --- Like 'HasPart', but enforces the part to be ordered. --- This is usually required for part separation and traversal. --- -type HasPart' a = (Ord (Part a), HasPart a) + deriving (Eq, Ord, Show, Functor, Applicative, Comonad, Monad, Typeable) --- | --- Extract parts from the a score. --- --- The parts are returned in the order defined the associated 'Ord' instance part type. --- You can recompose the score with 'mconcat', i.e. --- --- > mconcat . extract = id --- --- Simple type --- --- > Score a -> [Score a] --- -extract :: (HasPart' a, MonadPlus s, Performable s) => s a -> [s a] -extract sc = fmap (`extract'` sc) (getParts sc) - where - extract' v = mfilter ((== v) . getPart) +type instance Part () = Integer +type instance Part Double = Integer +type instance Part Float = Integer +type instance Part Int = Integer +type instance Part Integer = Integer +type instance Part (Ratio a) = Integer --- | --- Extract parts from the a score. --- --- The parts are returned in the order defined the associated 'Ord' instance part type. --- --- Simple type --- --- > Score a -> [(Part a, Score a)] --- -extractParts :: (HasPart' a, MonadPlus s, Performable s) => s a -> [(Part a, s a)] -extractParts sc = fmap (`extractParts2` sc) (getParts sc) - where - extractParts2 v = (\x -> (v,x)) . mfilter ((== v) . getPart) +instance HasPart () where { getPart _ = def } +instance HasPart Double where { getPart _ = def } +instance HasPart Float where { getPart _ = def } +instance HasPart Int where { getPart _ = def } +instance HasPart Integer where { getPart _ = def } +instance Integral a => HasPart (Ratio a) where { getPart _ = def } +type instance Part (PartT n a) = n +instance HasPart (PartT n a) where + getPart (PartT (v,_)) = v + modifyPart f (PartT (v,x)) = PartT (f v, x) --- | --- Map over a single voice in the given score. --- --- > Part -> (Score a -> Score a) -> Score a -> Score a --- -mapPart :: (Ord v, v ~ Part a, HasPart a, MonadPlus s, Performable s, Enum b) => b -> (s a -> s a) -> s a -> s a -mapPart n f = mapAllParts (zipWith ($) (replicate (fromEnum n) id ++ [f] ++ repeat id)) +type instance Part (a,b) = Part b +instance HasPart b => HasPart (a,b) where + getPart (a,b) = getPart b + modifyPart f (a,b) = (a, modifyPart f b) -- | --- Map over all parts in the given score. --- --- > ([Score a] -> [Score a]) -> Score a -> Score a +-- Like 'HasPart', but enforces the part to be ordered. +-- This is usually required for part separation and traversal. -- -mapAllParts :: (HasPart' a, MonadPlus s, Performable s) => ([s a] -> [s b]) -> s a -> s b -mapAllParts f = msum . f . extract +type HasPart' a = (Show (Part a), Ord (Part a), Default (Part a), HasPart a) --- | --- Map over all parts in the given score. --- --- > ([Score a] -> [Score a]) -> Score a -> Score a --- -mapParts :: (HasPart' a, MonadPlus s, Performable s) => (s a -> s b) -> s a -> s b -mapParts f = mapAllParts (fmap f) +-- TODO unify with class above as in Pitch? -- | -- Get all parts in the given score. Returns a list of parts. -- -- > Score a -> [Part] -- -getParts :: (HasPart' a, Performable s) => s a -> [Part a] -getParts = List.sort . List.nub . fmap getPart . toList' - --- | --- Set all parts in the given score. --- --- > Part -> Score a -> Score a --- -setParts :: (HasPart a, Functor s) => Part a -> s a -> s a -setParts n = fmap (setPart n) - --- | --- Modify all parts in the given score. --- --- > (Part -> Part) -> Score a -> Score a --- -modifyParts :: (HasPart a, Functor s) => (Part a -> Part a) -> s a -> s a -modifyParts n = fmap (modifyPart n) - - - --------------------------------------------------------------------------------- --- Part composition --------------------------------------------------------------------------------- - -infixr 6 - --- | --- Similar to '<>', but increases parts in the second part to prevent collision. --- -() :: (HasPart' a, Enum (Part a), Functor s, MonadPlus s, Performable s) => 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 $ getParts a - --- | --- Move down one voice (all parts). --- -moveParts :: (HasPart' a, Enum (Part a), Integral b, Functor s) => b -> s a -> s a -moveParts x = modifyParts (successor x) - --- | --- Move top-part to the specific voice (other parts follow). --- -moveToPart :: (HasPart' a, Enum (Part a), Functor s) => Part a -> 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) +getParts :: (Foldable t, HasPart' a) => t a -> [Part a] +getParts = List.sort . List.nub . fmap getPart . toList diff --git a/src/Music/Score/Pitch.hs b/src/Music/Score/Pitch.hs --- a/src/Music/Score/Pitch.hs +++ b/src/Music/Score/Pitch.hs @@ -1,10 +1,20 @@ {-# LANGUAGE - TypeFamilies, + CPP, DeriveFunctor, + DefaultSignatures, DeriveFoldable, DeriveDataTypeable, FlexibleInstances, + FlexibleContexts, + ConstraintKinds, + TypeFamilies, + TypeOperators, + MultiParamTypeClasses, + NoMonomorphismRestriction, + UndecidableInstances, + RankNTypes, + ScopedTypeVariables, GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------------- @@ -17,105 +27,299 @@ -- Stability : experimental -- Portability : non-portable (TF,GNTD) -- --- Provides pitch manipulation. +-- Provides functions for manipulating pitch. -- ------------------------------------------------------------------------------------- -module Music.Score.Pitch ( - HasPitch(..), - PitchT(..), - getPitches, - setPitches, - modifyPitches, +module Music.Score.Pitch ( + -- * Accessors + pitch', + pitch, + -- pitch_, + -- pitches', + -- pitches, + + -- * Transformations + -- ** Transformations + inv, + + -- ** Transformations up, down, + fifthsUp, + fifthsDown, + octavesUp, + octavesDown, + + -- ** Transformations + -- above, + -- below, + fifthsAbove, + fifthsBelow, + octavesAbove, + octavesBelow, + + -- * Pitch representation + Pitch, + Interval, + HasGetPitch(..), + HasSetPitch(..), + HasPitch'(..), + HasPitch(..), + HasSetPitch'(..), + Transposable, + Transposable1, + ) where import Control.Monad (ap, mfilter, join, liftM, MonadPlus(..)) +import Control.Applicative +import Control.Lens +import Data.Semigroup import Data.String -import Data.Foldable import Data.Typeable -import Data.Traversable -import qualified Data.List as List +import Data.Foldable (Foldable) +import Data.Traversable (Traversable) +import Data.Ratio import Data.VectorSpace import Data.AffineSpace -import Data.Ratio +import Data.AffineSpace.Point +import qualified Data.List as List -class HasPitch a where - -- | - -- Associated pitch type. Should implement 'Eq' and 'Show' to be usable. - -- - type Pitch a :: * +import Music.Time +import Music.Pitch.Literal - -- | - -- Get the pitch of the given note. - -- - getPitch :: a -> Pitch a +-- This is outside HasGetPitch etc because HasSetPitch needs it +-- (and it allow us to derive more instances, see #95) +type family Pitch a - -- | - -- Set the pitch of the given note. - -- - setPitch :: Pitch a -> a -> a +type Interval a = Diff (Pitch a) - -- | - -- Modify the pitch of the given note. - -- - modifyPitch :: (Pitch a -> Pitch a) -> a -> a +-- | +-- Class of types with readable pitch. +-- +class HasGetPitch s where + __getPitch :: (a ~ Pitch s) => s -> a - setPitch n = modifyPitch (const n) - modifyPitch f x = x +-- | +-- Class of types with mutable pitch. +-- +-- Either 'setPitch' or 'mapPitch' can be implemented. If both are implemented, +-- the following laws should be satisfied: +-- +-- > setPitch x = mapPitch (const x) +-- > mapPitch f x = setPitch p x where p = f (__getPitch x) +-- +-- For types that are 'Functors', the following instance can be used +-- +-- > type instance Pitch (T a) = Pitch a +-- > instance HasSetPitch a b => HasSetPitch (T a) (T b) where +-- > type SetPitch g (T a) = T (SetPitch g a) +-- > mapPitch = fmap . mapPitch +-- +class (SetPitch (Pitch t) s ~ t) => HasSetPitch (s :: *) (t :: *) where + type SetPitch (b :: *) (s :: *) :: * + __setPitch :: Pitch t -> s -> t + __setPitch x = __mapPitch (const x) + + __mapPitch :: (Pitch s -> Pitch t) -> s -> t + default __mapPitch :: HasGetPitch s => (Pitch s -> Pitch t) -> s -> t + __mapPitch f x = __setPitch p x where p = f (__getPitch x) + +type HasPitch s t = (HasGetPitch s, HasSetPitch s t) -newtype PitchT p a = PitchT { getPitchT :: (p, a) } - deriving (Eq, Ord, Show, Functor) +type HasPitch' a = HasPitch a a +type HasSetPitch' a = HasSetPitch a a -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) +-- | A lens to the pitch in a note, score or other structure. +-- +pitch' :: HasPitch' a => Lens' a (Pitch a) +pitch' = pitch -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 } +-- | A lens to the pitch in a note, score or other structure. +-- +pitch :: HasPitch a b => Lens a b (Pitch a) (Pitch b) +pitch = lens __getPitch (flip __setPitch) -instance HasPitch a => HasPitch [a] where - type Pitch [a] = Pitch a - getPitch [] = error "getPitch: Empty list" - getPitch as = getPitch (head as) - modifyPitch f as = fmap (modifyPitch f) as +-- | A setter to the pitch in a note, score or other structure. +-- +pitch_ :: HasSetPitch a b => Setter a b (Pitch a) (Pitch b) +pitch_ = sets __mapPitch +-- | Traverses all pitches in structure. +-- +pitches' :: (Traversable t, HasPitch' a) => Traversal' (t a) (Pitch a) +pitches' = traverse . pitch' + +-- | Traverses all pitches in structure. +-- +pitches :: (Traversable t, HasPitch a b) => Traversal (t a) (t b) (Pitch a) (Pitch b) +pitches = traverse . pitch + + +type HasPitchConstr a = ( + HasPitch' a, + VectorSpace (Interval a), Integer ~ Scalar (Interval a), + AffineSpace (Pitch a) + ) + +newtype PitchT p a = PitchT { __getPitchT :: (p, a) } + deriving (Eq, Ord, Show, Functor, Foldable, Traversable) + +instance (Semigroup p, Monoid p) => Applicative (PitchT p) where + pure x = PitchT (mempty,x) + PitchT (pf,vf) <*> PitchT (px,vx) = PitchT (pf <> px, vf $ vx) + +-- TODO move these +instance Stretchable () +instance Stretchable Double +instance Stretchable Float +instance Stretchable Int +instance Stretchable Integer +instance Integral a => Stretchable (Ratio a) + +instance Delayable () +instance Delayable Double +instance Delayable Float +instance Delayable Int +instance Delayable Integer +instance Integral a => Delayable (Ratio a) + +type instance Pitch (c,a) = Pitch a +instance HasGetPitch a => HasGetPitch (c,a) where + __getPitch (c,a) = __getPitch a + +-- Undecidable ?? +instance (HasGetPitch a, HasSetPitch a b) => HasSetPitch (c,a) (c,b) where + type SetPitch b (c,a) = (c,SetPitch b a) + __setPitch b = fmap (__setPitch b) + +#define HAS_PITCH_PRIM(T) \ +type instance Pitch T = T; \ +instance HasGetPitch T where { \ + __getPitch = id } + +#define HAS_SET_PITCH_PRIM(T) \ +instance (a ~ Pitch a) => HasSetPitch T a where { \ + type SetPitch a T = a; \ + __mapPitch = id } + +HAS_PITCH_PRIM(()) +HAS_PITCH_PRIM(Bool) +HAS_PITCH_PRIM(Double) +HAS_PITCH_PRIM(Float) +HAS_PITCH_PRIM(Int) +HAS_PITCH_PRIM(Integer) + +HAS_SET_PITCH_PRIM(()) +HAS_SET_PITCH_PRIM(Bool) +HAS_SET_PITCH_PRIM(Double) +HAS_SET_PITCH_PRIM(Float) +HAS_SET_PITCH_PRIM(Int) +HAS_SET_PITCH_PRIM(Integer) + +-- type Transposable p i = (Diff p ~ i, AffineSpace p, VectorSpace i, IsPitch p, IsInterval i) +type Transposable a = + ( + HasSetPitch' a, + Transposable1 a + ) +type Transposable1 a = + ( + Diff (Pitch a) ~ Interval a, + AffineSpace (Pitch a), + VectorSpace (Interval a), + IsPitch (Pitch a), + IsInterval (Interval a) + ) + + -- | --- Get all pitches in the given score. Returns a list of pitches. +-- Transpose up. -- --- > Score a -> [Pitch] +up :: Transposable a => Interval a -> a -> a +up a = pitch_ %~ (.+^ a) + +-- | +-- Transpose down. -- -getPitches :: (HasPitch a, Eq v, v ~ Pitch a, Foldable s, p ~ Pitch a) => s a -> [p] -getPitches = List.nub . fmap getPitch . toList +down :: Transposable a => Interval a -> a -> a +down a = pitch_ %~ (.-^ a) -- | --- Set all pitches in the given score. +-- Add the given interval above. -- --- > Pitch -> Score a -> Score a +above :: (Semigroup a, Transposable a) => Interval a -> a -> a +above a x = x <> up a x + +-- | +-- Add the given interval below. -- -setPitches :: (HasPitch a, Functor s, p ~ Pitch a) => p -> s a -> s a -setPitches n = fmap (setPitch n) +below :: (Semigroup a, Transposable a) => Interval a -> a -> a +below a x = x <> down a x -- | --- Modify all pitches in the given score. +-- Invert pitches. -- --- > (Pitch -> Pitch) -> Score a -> Score a +inv :: Transposable a => Pitch a -> a -> a +inv p = pitch_ %~ (reflectThrough p) + +-- | +-- Transpose up by the given number of octaves. -- -modifyPitches :: (HasPitch a, Functor s, p ~ Pitch a) => (p -> p) -> s a -> s a -modifyPitches f = fmap (modifyPitch f) +octavesUp :: Transposable a => Scalar (Interval a) -> a -> a +octavesUp a = up (_P8^*a) -up :: (HasPitch a, Functor s, AffineSpace p, p ~ Pitch a) => Diff p -> s a -> s a -up a = modifyPitches (.+^ a) +-- | +-- Transpose down by the given number of octaves. +-- +octavesDown :: Transposable a => Scalar (Interval a) -> a -> a +octavesDown a = down (_P8^*a) -down :: (HasPitch a, Functor s, AffineSpace p, p ~ Pitch a) => Diff p -> s a -> s a -down a = modifyPitches (.-^ a) +-- | +-- Add the given interval below. +-- +fifthsUp :: Transposable a => Scalar (Interval a) -> a -> a +fifthsUp a = up (_P8^*a) +-- | +-- Add the given interval below. +-- +fifthsDown :: Transposable a => Scalar (Interval a) -> a -> a +fifthsDown a = down (_P8^*a) + +-- | +-- Add the given interval below. +-- +octavesAbove :: (Semigroup a, Transposable a) => Scalar (Interval a) -> a -> a +octavesAbove n x = x <> octavesUp n x + +-- | +-- Add the given interval below. +-- +octavesBelow :: (Semigroup a, Transposable a) => Scalar (Interval a) -> a -> a +octavesBelow n x = x <> octavesUp n x + +-- | +-- Add the given interval below. +-- +fifthsAbove :: (Semigroup a, Transposable a) => Scalar (Interval a) -> a -> a +fifthsAbove n x = x <> fifthsUp n x + +-- | +-- Add the given interval below. +-- +fifthsBelow :: (Semigroup a, Transposable a) => Scalar (Interval a) -> a -> a +fifthsBelow n x = x <> fifthsUp n x + +{- + +highestPitch = maximum . __getPitches +lowestPitch = maximum . __getPitches +meanPitch = mean . __getPitches +mean x = fst $ foldl (\(m, n) x -> (m+(x-m)/(n+1),n+1)) (0,0) x + +-} diff --git a/src/Music/Score/Rhythm.hs b/src/Music/Score/Rhythm.hs --- a/src/Music/Score/Rhythm.hs +++ b/src/Music/Score/Rhythm.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE - TypeFamilies, - DeriveFunctor, - DeriveFoldable, - GeneralizedNewtypeDeriving, - ScopedTypeVariables #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} ------------------------------------------------------------------------------------- -- | @@ -24,35 +24,41 @@ -- * Quantization quantize, + rewrite, 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 Prelude hiding (concat, concatMap, foldl, foldr, + mapM, maximum, minimum, sum) -import Text.Parsec hiding ((<|>)) -import Text.Parsec.Pos +import Control.Applicative +import Control.Arrow hiding (left) +import Control.Monad (MonadPlus (..), ap, join) +import Data.Either +import Data.Foldable +import Data.Function (on) +import qualified Data.List as List +import Data.Maybe +import Data.Ord (comparing) +import Data.Ratio +import Data.Semigroup +import Data.Traversable +import Data.Tree +import Data.VectorSpace -import Music.Time -import Music.Score.Ties +import Text.Parsec hiding ((<|>)) +import Text.Parsec.Pos +import Music.Score.Ties +import Music.Score.Util +import Music.Score.Voice +import Music.Time data Rhythm a - = Beat DurationT a -- d is divisible by 2 - | Group [Rhythm a] -- normal note sequence + = Beat Duration a -- d is divisible by 2 + | Group [Rhythm a] -- | Dotted Int (Rhythm a) -- n > 0. - | Tuplet DurationT (Rhythm a) -- d is an emelent of 'tupletMods'. + | Tuplet Duration (Rhythm a) -- d is an emelent of 'konstTuplets'. deriving (Eq, Show, Functor, Foldable) -- RInvTuplet Duration (Rhythm a) @@ -60,11 +66,40 @@ getBeatValue (Beat d a) = a getBeatValue _ = error "getBeatValue: Not a beat" -getBeatDuration :: Rhythm a -> DurationT +getBeatDuration :: Rhythm a -> Duration getBeatDuration (Beat d a) = d getBeatDuration _ = error "getBeatValue: Not a beat" +realize :: Rhythm a -> [(Duration, a)] +realize (Beat d a) = [(d, a)] +realize (Group rs) = rs >>= realize +realize (Dotted n r) = dotMod n `stretch` realize r +realize (Tuplet n r) = n `stretch` realize r +-- rhythmToTree :: Rhythm a -> Tree (String, Maybe a) +-- rhythmToTree = go +-- where +-- go (Beat d a) = Node ("beat " ++ showD d, Just a) [] +-- go (Group rs) = Node ("group", Nothing) (fmap rhythmToTree rs) +-- go (Dotted n r) = Node ("dotted " ++ show n, Nothing) [rhythmToTree r] +-- go (Tuplet n r) = Node ("tuplet " ++ showD n, Nothing) [rhythmToTree r] +-- showD = show . toRational +-- +-- drawRhythm :: Show a => Rhythm a -> String +-- drawRhythm = drawTree . fmap (uncurry (++) <<< (++ " ") *** show) . rhythmToTree + +rhythmToTree :: Rhythm a -> Tree String +rhythmToTree = go + where + go (Beat d a) = Node ("" ++ showD d) [] + go (Group rs) = Node ("") (fmap rhythmToTree rs) + go (Dotted n r) = Node (replicate n '.') [rhythmToTree r] + go (Tuplet n r) = Node ("*^ " ++ showD n) [rhythmToTree r] + showD = (\x -> show (numerator x) ++ "/" ++ show (denominator x)) . toRational + +drawRhythm :: Show a => Rhythm a -> String +drawRhythm = drawTree . rhythmToTree + instance Semigroup (Rhythm a) where (<>) = mappend @@ -74,87 +109,152 @@ Group as `mappend` Group bs = Group (as <> bs) r `mappend` Group bs = Group ([r] <> bs) Group as `mappend` r = Group (as <> [r]) + a `mappend` b = Group [a, b] +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 (Group as) = sum (fmap duration as) + 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) = DurationT + type Scalar (Rhythm a) = Duration a *^ Beat d x = Beat (a*d) x + -- FIXME how does this preserve the invariant? 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 (Group as) = sum (fmap duration as) + Rhythm rewrite laws (all up to realization equality) + + Note: Just sketching, needs more formal treatment. + + + Group [Group xs ...] = Group [xs ...] + [JoinGroup] + + Tuplet m (Tuplet n x) = Tuplet (m * n) x + [NestTuplet] + + Tuplet m (Group [a,b ...]) = Group [Tuplet m a, Tuplet m b ...] + [DistributeTuplet] + This is only OK in certain contexts! Which? + -} -quantize :: Tiable a => [(DurationT, a)] -> Either String (Rhythm a) -quantize = quantize' (atEnd rhythm) +rewrite :: Rhythm a -> Rhythm a +rewrite = rewriteR . rewrite1 --- Internal... +rewriteR = go where + go (Beat d a) = Beat d a + go (Group rs) = Group (fmap (rewriteR . rewrite1) rs) + go (Dotted n r) = Dotted n ((rewriteR . rewrite1) r) + go (Tuplet n r) = Tuplet n ((rewriteR . rewrite1) r) -testQuantize :: [DurationT] -> Either String (Rhythm ()) -testQuantize = quantize' (atEnd rhythm) . fmap (\x->(x,())) +rewrite1 = splitTuplet . tupletDot . singleGroup -dotMod :: Int -> DurationT -dotMod n = dotMods !! (n-1) --- [3/2, 7/4, 15/8, 31/16 ..] -dotMods :: [DurationT] -dotMods = zipWith (/) (fmap pred $ drop 2 times2) (drop 1 times2) +singleGroup :: Rhythm a -> Rhythm a +singleGroup orig@(Group [x]) = x +singleGroup orig = orig + +-- | Removes dotted notes in 2/3 tuplets. +tupletDot :: Rhythm a -> Rhythm a +tupletDot orig@(Tuplet ((unRatio.realToFrac) -> (2,3)) (Dotted 1 x)) = x +tupletDot orig = orig + +-- | Splits a tuplet iff it contans a group which can be split into two halves of exactly the same size. +splitTuplet :: Rhythm a -> Rhythm a +splitTuplet orig@(Tuplet n (Group xs)) = case trySplit xs of + Nothing -> orig + Just (as, bs) -> Tuplet n (Group as) <> Tuplet n (Group bs) +splitTuplet orig = orig + +-- TODO bad instance +instance HasDuration a => HasDuration [a] where + duration = sum . fmap duration + +trySplit :: [Rhythm a] -> Maybe ([Rhythm a], [Rhythm a]) +trySplit = firstJust . fmap g . splits where - times2 = iterate (*2) 1 + g (part1, part2) + | duration part1 == duration part2 = Just (part1, part2) + | otherwise = Nothing + splits xs = List.inits xs `zip` List.tails xs + firstJust = listToMaybe . fmap fromJust . List.dropWhile isNothing -tupletMods :: [DurationT] -tupletMods = [2/3, 4/5, {-4/6,-} 4/7, 8/9] +quantize :: Tiable a => [(Duration, a)] -> Either String (Rhythm a) +quantize = quantize' (atEnd rhythm) --- 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 +testQuantize :: [Duration] -> IO () +testQuantize x = case fmap rewrite $ quantize' (atEnd rhythm) $ fmap (\x -> (x,())) $ x of + Left e -> error e + Right x -> putStrLn $ drawRhythm x -data RState = RState { - timeMod :: DurationT, -- time modification; notatedDur * timeMod = actualDur - timeSub :: DurationT, -- time subtraction (in bound note) + +konstNumDotsAllowed :: [Int] +konstNumDotsAllowed = [1..2] + +konstBounds :: [Duration] +konstBounds = [ 1/2, 1/4, 1/8 ] + +konstTuplets :: [Duration] +konstTuplets = [ 2/3, 4/5, 4/7, 8/9, 8/11, 8/13, 8/15, 16/17, 16/18, 16/19, 16/21, 16/23 ] + +konstMaxTupletNest :: Int +konstMaxTupletNest = 1 + + +data RhythmContext = RhythmContext { + + -- Time scaling of the current note (from dots and tuplets). + timeMod :: Duration, + + -- Time subtracted from the current rhythm (from ties). + timeSub :: Duration, + + -- Number of tuplets above the current note (default 0). tupleDepth :: Int } -instance Monoid RState where - mempty = RState { timeMod = 1, timeSub = 0, tupleDepth = 0 } +instance Monoid RhythmContext where + mempty = RhythmContext { timeMod = 1, timeSub = 0, tupleDepth = 0 } a `mappend` _ = a -modifyTimeMod :: (DurationT -> DurationT) -> RState -> RState -modifyTimeMod f (RState tm ts td) = RState (f tm) ts td +modifyTimeMod :: (Duration -> Duration) -> RhythmContext -> RhythmContext +modifyTimeMod f (RhythmContext tm ts td) = RhythmContext (f tm) ts td -modifyTimeSub :: (DurationT -> DurationT) -> RState -> RState -modifyTimeSub f (RState tm ts td) = RState tm (f ts) td +modifyTimeSub :: (Duration -> Duration) -> RhythmContext -> RhythmContext +modifyTimeSub f (RhythmContext tm ts td) = RhythmContext tm (f ts) td -modifyTupleDepth :: (Int -> Int) -> RState -> RState -modifyTupleDepth f (RState tm ts td) = RState tm ts (f td) +modifyTupleDepth :: (Int -> Int) -> RhythmContext -> RhythmContext +modifyTupleDepth f (RhythmContext tm ts td) = RhythmContext tm ts (f td) + + + + + -- | -- A @RhytmParser a b@ converts (Voice a) to b. -type RhythmParser a b = Parsec [(DurationT, a)] RState b +type RhythmParser a b = Parsec [(Duration, a)] RhythmContext b -quantize' :: Tiable a => RhythmParser a b -> [(DurationT, a)] -> Either String b +quantize' :: Tiable a => 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 :: Tiable a => (DurationT -> 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 :: Tiable a => RhythmParser a (Rhythm a) rhythm = Group <$> many1 (rhythm' <|> bound) @@ -168,18 +268,36 @@ <|> tuplet -- Matches a beat divisible by 2 (notated) +-- beat :: Tiable a => RhythmParser a (Rhythm a) +-- beat = do +-- RhythmContext tm ts _ <- getState +-- (\d -> (d^/tm) `subDur` ts) <$> match (\d _ -> +-- d - ts > 0 && isDivisibleBy 2 (d / tm - ts)) + beat :: Tiable a => 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)) -- Or is it ((d - ts) / tm)? + RhythmContext tm ts _ <- getState + match' $ \d x -> + let d2 = d / tm - ts + in (d2, x) `assuming` (d - ts > 0 && isDivisibleBy 2 d2) + -- | Matches a dotted rhythm dotted :: Tiable a => RhythmParser a (Rhythm a) -dotted = msum . fmap dotted' $ [1..2] -- max 2 dots +dotted = msum . fmap dotted' $ konstNumDotsAllowed +-- | Matches a bound rhythm +bound :: Tiable a => RhythmParser a (Rhythm a) +bound = msum . fmap bound' $ konstBounds + +-- | Matches a tuplet +tuplet :: Tiable a => RhythmParser a (Rhythm a) +tuplet = msum . fmap tuplet' $ konstTuplets + + + + + dotted' :: Tiable a => Int -> RhythmParser a (Rhythm a) dotted' n = do modifyState $ modifyTimeMod (* dotMod n) @@ -187,30 +305,31 @@ modifyState $ modifyTimeMod (/ dotMod n) return (Dotted n a) - --- | Matches a bound rhythm -bound :: Tiable a => RhythmParser a (Rhythm a) -bound = bound' (1/2) +-- | Return the scaling applied to a note with the given number of dots (i.e. 3/2, 7/4 etc). +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 -bound' :: Tiable a => DurationT -> RhythmParser a (Rhythm a) +bound' :: Tiable a => Duration -> RhythmParser a (Rhythm a) bound' d = do modifyState $ modifyTimeSub (+ d) a <- beat modifyState $ modifyTimeSub (subtract d) let (b,c) = toTied $ getBeatValue a - return $ Group [Beat (getBeatDuration a) $ b, Beat (1/2) $ c] - -- FIXME doesn't know order --- | Matches a tuplet -tuplet :: Tiable a => RhythmParser a (Rhythm a) -tuplet = msum . fmap tuplet' $ tupletMods + -- FIXME doesn't know order + return $ Group [Beat (getBeatDuration a) b, Beat d c] -- tuplet' 2/3 for triplet, 4/5 for quintuplet etc -tuplet' :: Tiable a => DurationT -> RhythmParser a (Rhythm a) +tuplet' :: Tiable a => Duration -> RhythmParser a (Rhythm a) tuplet' d = do - RState _ _ depth <- getState - onlyIf (depth < 1) $ do -- max 1 nested tuplets + RhythmContext _ _ depth <- getState + onlyIf (depth < konstMaxTupletNest) $ do modifyState $ modifyTimeMod (* d) . modifyTupleDepth succ a <- rhythmNoBound @@ -222,13 +341,31 @@ ------------------------------------------------------------------------------------- -- | Similar to 'many1', but tries longer sequences before trying one. -many1long :: Stream s m t => ParsecT s u m a -> ParsecT s u m [a] -many1long p = try (many2 p) <|> fmap return p +-- many1long :: Stream s m t => ParsecT s u m a -> ParsecT s u m [a] +-- many1long p = try (many2 p) <|> fmap return p -- | Similar to 'many1', but applies the parser 2 or more times. -many2 :: Stream s m t => ParsecT s u m a -> ParsecT s u m [a] -many2 p = do { x <- p; xs <- many1 p; return (x : xs) } +-- many2 :: Stream s m t => ParsecT s u m a -> ParsecT s u m [a] +-- many2 p = do { x <- p; xs <- many1 p; return (x : xs) } +-- Matches a (duration, value) pair iff the predicate matches, returns beat +match :: Tiable a => (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 a (duration, value) pair iff the predicate matches, returns beat +match' :: Tiable a => (Duration -> a -> Maybe (Duration, b)) -> RhythmParser a (Rhythm b) +match' f = tokenPrim show next test + where + show x = "" + next pos _ _ = updatePosChar pos 'x' + test (d,x) = case f d x of + Nothing -> Nothing + Just (d,x) -> Just $ Beat d x + -- | -- Succeed only if the entire input is consumed. -- @@ -244,6 +381,10 @@ onlyIf :: MonadPlus m => Bool -> m b -> m b onlyIf b p = if b then p else mzero +-- | Just x or Nothing +assuming :: a -> Bool -> Maybe a +assuming x b = if b then Just x else Nothing + logBaseR :: forall a . (RealFloat a, Floating a) => Rational -> Rational -> a logBaseR k n | isInfinite (fromRational n :: a) = logBaseR k (n/k) + 1 @@ -251,8 +392,13 @@ | isDenormalized (fromRational n :: a) = logBaseR k (n*k) - 1 logBaseR k n = logBase (fromRational k) (fromRational n) --- As it sounds -isDivisibleBy :: DurationT -> DurationT -> Bool + +divides = isDivisibleBy +divisibleBy = flip isDivisibleBy + +-- As it sounds, do NOT use infix +-- Only works for simple n such as 2 or 3, TODO determine +isDivisibleBy :: Duration -> Duration -> Bool isDivisibleBy n = (== 0.0) . snd . properFraction . logBaseR (toRational n) . toRational diff --git a/src/Music/Score/Score.hs b/src/Music/Score/Score.hs --- a/src/Music/Score/Score.hs +++ b/src/Music/Score/Score.hs @@ -1,11 +1,19 @@ -{-# LANGUAGE - TypeFamilies, - DeriveFunctor, - DeriveFoldable, - DeriveDataTypeable, - DeriveTraversable, - GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} ------------------------------------------------------------------------------------- -- | @@ -22,213 +30,267 @@ ------------------------------------------------------------------------------------- module Music.Score.Score ( + -- * Score type Score, - -- mapTime, + notes, + events, + -- mkScore, + -- getScore, + mapScore, + reifyScore, + + mapWithSpan, + filterWithSpan, + mapFilterWithSpan, + mapEvents, + filterEvents, + mapFilterEvents, + ) where -import Prelude hiding (null, length, repeat, foldr, concat, foldl, mapM, concatMap, maximum, sum, minimum) +import Control.Applicative +import Control.Arrow +import Control.Comonad +import Control.Lens +import Control.Monad +import Control.Monad.Compose +import Control.Monad.Plus +import Data.Dynamic +import Data.Foldable (foldMap) +import Data.Maybe +import Data.Ord +import Data.Semigroup -import Data.Semigroup -import Control.Applicative -import Control.Monad (ap, join, MonadPlus(..)) -import Data.Foldable -import Data.Traversable -import Data.Typeable -import Data.Maybe -import Data.Either -import Data.Pointed -import Data.Function (on) -import Data.Ord (comparing) -import Data.Ratio -import Data.VectorSpace -import Data.AffineSpace -import Test.QuickCheck (Arbitrary(..),Gen(..)) -import qualified Data.Map as Map -import qualified Data.List as List +import Data.AffineSpace +import Data.AffineSpace.Point +import Data.VectorSpace +import Test.QuickCheck (Arbitrary (..), Gen (..)) -import Music.Pitch.Literal -import Music.Dynamics.Literal +import Data.Default +import Data.Foldable (Foldable) +import qualified Data.Foldable as F +import qualified Data.List as List +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Traversable (Traversable) +import qualified Data.Traversable as T +import Data.Typeable -import Music.Time -import Music.Score.Voice -import Music.Score.Track +import Music.Dynamics.Literal +import Music.Pitch.Literal +import Music.Score.Meta +import Music.Score.Note +import Music.Score.Part +import Music.Score.Pitch +import Music.Score.Util +import Music.Time +import Music.Time.Reactive -------------------------------------------------------------------------------------- --- Score type -------------------------------------------------------------------------------------- +newtype Score a = Score { getScore' :: (Meta, NScore a) } + deriving (Functor, Semigroup, Monoid, Foldable, Traversable, Typeable) --- | --- A score is a list of events, i.e. time-duration-value triplets. Semantically --- --- > type Score a = [(Time, Duration, a)] +-- | TODO not a real iso, must be lens (meta) +notes :: Iso (Score a) (Score b) [Note a] [Note b] +notes = iso (getNScore . snd . getScore') (Score . return . NScore) + +-- | TODO not a real iso, must be lens (meta) +events :: Iso (Score a) (Score b) [(Time, Duration, a)] [(Time, Duration, b)] +events = iso getScore mkScore + +inScore f = Score . f . getScore' + +mkScore :: [(Time, Duration, a)] -> Score a +mkScore = mconcat . fmap (uncurry3 event) + where + event t d x = (delay (t .-. origin) . stretch d) (return x) + +getScore :: Score a -> [(Time, Duration, a)] +getScore = + fmap (\(view delta -> (t,d),x) -> (t,d,x)) . + List.sortBy (comparing fst) . + F.toList . + fmap getNote . + reifyScore + +-- | Map with the associated time span. +mapScore :: (Note a -> b) -> Score a -> Score b +mapScore f = over _Wrapped (second $ mapNScore f) + +-- | Group each occurence with its associated time span. -- --- There is no explicit representation for rests. However you can use `Score (Maybe a)` to --- represent a score with rests. Such rests are only useful when composing scores. They --- may be removed with 'removeRests'. +-- Note: This may or may not be what you expect. Each note is /not/ repositioned +-- to start at 'sunit', so this holds -- --- Score is a 'Monoid' under parallel composition. 'mempty' is a score of no parts. --- For sequential composition of scores, use '|>'. +-- > fmap extract . reifyScore = id -- --- Score has an 'Applicative' instance derived from the 'Monad' instance. Not sure it is useful. +-- while -- --- Score is an instance of 'VectorSpace' using sequential composition as addition, --- and time scaling as scalar multiplication. +-- > join . fmap (noteToScore) . reifyScore /= id -- -newtype Score a = Score { getScore :: [(TimeT, DurationT, a)] } - deriving (Eq, Ord, Show, Functor, Foldable, Typeable, Traversable) +reifyScore :: Score a -> Score (Note a) +reifyScore = over _Wrapped (second reifyNScore) -type instance Time Score = TimeT +-- | Map over the events in a score. +mapWithSpan :: (Span -> a -> b) -> Score a -> Score b +mapWithSpan f = mapScore (uncurry f . getNote) -instance Semigroup (Score a) where - (<>) = mappend +-- | Filter the events in a score. +filterWithSpan :: (Span -> a -> Bool) -> Score a -> Score a +filterWithSpan f = mapFilterWithSpan (partial2 f) --- 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) +-- | Efficient combination of 'mapEvents' and 'filterEvents'. +mapFilterWithSpan :: (Span -> a -> Maybe b) -> Score a -> Score b +mapFilterWithSpan f = mcatMaybes . mapWithSpan f --- | --- This instance is somewhat similar to the list instance. --- --- * 'return' creates a score containing a single note at /(0, 1)/. --- --- * @s@ '>>=' @k@ maps each note to a new score, which is then scaled and delayed by the onset and --- duration of the original note. That is, @k@ returns a score @t@ such that /0 < onset t < offset t < 1/, --- the resulting events will not cross the boundaries of the original note. --- --- * 'join' scales and offsets each inner score to fit into the note containing it, then --- removes the intermediate structure. --- --- > let s = compose [(0,1,0), (1,2,1)] --- > --- > s >>= \x -> compose [ (0,1,toEnum $ x+65), --- > (1,3,toEnum $ x+97) ] :: Score Char --- > --- > ===> compose [ (1, 1, 'A'), --- > (1, 3, 'a'), --- > (1, 2, 'B'), --- > (3, 6, 'b') ]} --- -instance Monad Score where - return x = Score [(0, 1, x)] - a >>= k = join' $ fmap k a - where - join' sc = {-mconcat $ toList-}fold $ mapTime (\t d -> delay' t . stretch d) sc +-- | Map over the events in a score. +mapEvents :: (Time -> Duration -> a -> b) -> Score a -> Score b +mapEvents f = mapWithSpan (uncurry f . view delta) -instance Pointed Score where - point = return +-- | Filter the events in a score. +filterEvents :: (Time -> Duration -> a -> Bool) -> Score a -> Score a +filterEvents f = mapFilterEvents (partial3 f) +-- | Efficient combination of 'mapEvents' and 'filterEvents'. +mapFilterEvents :: (Time -> Duration -> a -> Maybe b) -> Score a -> Score b +mapFilterEvents f = mcatMaybes . mapEvents f + +instance Wrapped (Score a) where + type Unwrapped (Score a) = (Meta, NScore a) + _Wrapped' = iso getScore' Score +instance Rewrapped (Score a) (Score b) where + instance Applicative Score where - pure = return + pure = return (<*>) = ap +instance Monad Score where + return = (^. _Unwrapped') . return . return + xs >>= f = (^. _Unwrapped') $ mbind ((^. _Wrapped') . f) ((^. _Wrapped') xs) + instance Alternative Score where empty = mempty (<|>) = mappend --- Satisfies left distribution instance MonadPlus Score where mzero = mempty mplus = mappend -instance Performable Score where - perform = getScore +instance HasOnset (Score a) where + onset (Score (m,x)) = onset x -instance Stretchable (Score) where - d `stretch` Score sc = Score $ fmap (first3 (^* fromDurationT d) . second3 (^* d)) $ sc +instance HasOffset (Score a) where + offset (Score (m,x)) = offset x -instance Delayable (Score) where - d `delay` Score sc = Score . fmap (first3 (.+^ d)) $ sc +instance Delayable (Score a) where + delay n (Score (m,x)) = Score (delay n m, delay n x) -instance HasOnset (Score) where - -- onset (Score []) = 0 - -- onset (Score xs) = minimum (fmap on xs) where on (t,d,x) = t +instance Stretchable (Score a) where + stretch n (Score (m,x)) = Score (stretch n m, stretch n x) - -- Note: this version of onset is lazier, but depends on the invariant that the list is sorted - onset (Score []) = 0 - onset (Score xs) = on (head xs) where on (t,d,x) = t +instance HasDuration (Score a) where + duration = durationDefault -instance HasOffset (Score) where - offset (Score []) = 0 - offset (Score xs) = maximum (fmap off xs) where off (t,d,x) = t + (fromDurationT $ d) +instance Reversible a => Reversible (Score a) where + rev = fmap rev . withSameOnset (stretch (-1)) -instance HasDuration (Score) where - duration x = offset x .-. onset x +instance HasMeta (Score a) where + meta = _Wrapped' . _1 -instance IsPitch a => IsPitch (Score a) where - fromPitch = pure . fromPitch -instance IsDynamics a => IsDynamics (Score a) where - fromDynamics = pure . fromDynamics --- Utility -instance AdditiveGroup (Score a) where - zeroV = error "Not impl" - (^+^) = error "Not impl" - negateV = error "Not impl" -instance VectorSpace (Score a) where - type Scalar (Score a) = DurationT - d *^ s = d `stretch` s - -instance Arbitrary a => Arbitrary (Score a) where - arbitrary = do - x <- arbitrary - t <- fmap toDurationT $ (arbitrary::Gen Double) - d <- fmap toDurationT $ (arbitrary::Gen Double) - return $ delay t $ stretch d $ (note x) - -- | --- Create a score of duration one with the given value (same as 'return'). +-- Score without meta-events. -- -note :: a -> Score a -note = return - --- | --- Create a score of duration one with no values. +-- Semantics: a list of 'Note'. The semantics of each instances follow the instances of +-- the semantics. -- -rest :: Score (Maybe a) -rest = return Nothing +newtype NScore a = NScore { getNScore :: [Note a] } -- sorted + deriving (Functor, Foldable, Semigroup, Monoid, Traversable, Delayable, Stretchable, HasOnset, HasOffset) --- | --- Repeat a score indefinately. --- -repeat :: Score a -> Score a -repeat a = a `plus` delay (duration a) (repeat a) - where - Score as `plus` Score bs = Score (as <> bs) +inNScore f = NScore . f . getNScore --- | --- Map over all events in a score. --- -mapTime :: (TimeT -> DurationT -> a -> b) -> Score a -> Score b -mapTime f = Score . fmap (mapEvent f) . getScore +-- | Map with the associated span. +mapNScore :: (Note a -> b) -> NScore a -> NScore b +mapNScore f = inNScore (fmap $ extend f) -mapEvent :: (TimeT -> DurationT -> a -> b) -> (TimeT, DurationT, a) -> (TimeT, DurationT, b) -mapEvent f (t, d, x) = (t, d, f t d x) +-- | Reify the associated span. Use with 'Traversable' to get a fold. +reifyNScore :: NScore a -> NScore (Note a) +reifyNScore = inNScore $ fmap duplicate +instance Wrapped (NScore a) where + type Unwrapped (NScore a) = [Note a] + _Wrapped' = iso getNScore NScore -------------------------------------------------------------------------------------- +instance Applicative NScore where + pure = return + (<*>) = ap -delay' t = delay (fromTimeT t) +instance Monad NScore where + return = (^. _Unwrapped') . return . return + xs >>= f = (^. _Unwrapped') $ mbind ((^. _Wrapped') . f) ((^. _Wrapped') xs) -fst3 (a,b,c) = a +instance MonadPlus NScore where + mzero = mempty + mplus = mappend -list z f [] = z -list z f xs = f xs +instance HasDuration (Note a) where + duration = durationDefault -first f (x,y) = (f x, y) -second f (x,y) = (x, f y) +-- The following instances allow us to write expressions like [c..g] -first3 f (a,b,c) = (f a,b,c) -second3 f (a,b,c) = (a,f b,c) +instance IsPitch a => IsPitch (Score a) where + fromPitch = pure . fromPitch -mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a] -mergeBy f [] ys = ys -mergeBy f xs [] = xs -mergeBy f xs'@(x:xs) ys'@(y:ys) - | x `f` y == LT = x : mergeBy f xs ys' - | x `f` y /= LT = y : mergeBy f xs' ys +instance IsDynamics a => IsDynamics (Score a) where + fromDynamics = pure . fromDynamics +instance IsInterval a => IsInterval (Score a) where + fromInterval = pure . fromInterval + +instance Enum a => Enum (Score a) where + toEnum = return . toEnum + fromEnum = list 0 (fromEnum . head) . F.toList + +-- TODO +instance Num a => Num (Score a) where + fromInteger = return . fromInteger + + + +-- Bogus VectorSpace instance, so we can use c^*2 etc. +-- If you hate this instance, please open an issue. + +instance AdditiveGroup (Score a) where + zeroV = error "Not impl" + (^+^) = error "Not impl" + negateV = error "Not impl" + +instance VectorSpace (Score a) where + type Scalar (Score a) = Duration + d *^ s = d `stretch` s + +type instance Pitch (Score a) = Pitch a +instance (HasSetPitch a b, + Transformable (Pitch a), + Transformable (Pitch b)) => + HasSetPitch (Score a) (Score b) where + type SetPitch g (Score a) = Score (SetPitch g a) + -- TODO really similar to indexed maps + -- compare lens, category-extras + __mapPitch f = mapWithSpan (__mapPitch . (`sunder` f)) + + +type instance Part (Score a) = Part a +instance HasPart a => HasPart (Score a) where + getPart = error "No Score.getPart" + modifyPart f = fmap (modifyPart f) + + +-- TODO mo +partial2 :: (a -> b -> Bool) -> a -> b -> Maybe b +partial3 :: (a -> b -> c -> Bool) -> a -> b -> c -> Maybe c +partial2 f = curry (fmap snd . partial (uncurry f)) +partial3 f = curry3 (fmap (view _3) . partial (uncurry3 f)) diff --git a/src/Music/Score/Ties.hs b/src/Music/Score/Ties.hs --- a/src/Music/Score/Ties.hs +++ b/src/Music/Score/Ties.hs @@ -1,13 +1,13 @@ -{-# LANGUAGE - TypeFamilies, - DeriveFunctor, - DeriveFoldable, - DeriveDataTypeable, - FlexibleInstances, - FlexibleContexts, - ConstraintKinds, - GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} ------------------------------------------------------------------------------------- -- | @@ -19,55 +19,78 @@ -- Stability : experimental -- Portability : non-portable (TF,GNTD) -- --- Provides tie representation and splitting. +-- Provides a representation for tied notes, and a way to split a single note +-- into a pair of tied notes. -- ------------------------------------------------------------------------------------- - module Music.Score.Ties ( + -- * Tiable class Tiable(..), TieT(..), - splitTies, - splitTiesSingle, + + -- * Splitting tied notes in scores splitTiesVoice, + splitTiesVoiceAt, ) where -import Control.Monad -import Control.Monad.Plus -import Data.Default -import Data.Maybe -import Data.Ratio -import Data.Foldable hiding (concat) -import Data.Typeable -import qualified Data.List as List -import Data.VectorSpace -import Data.AffineSpace +import Control.Applicative +import Control.Arrow +import Control.Lens +import Control.Monad +import Control.Monad.Plus +import Data.AffineSpace +import Data.Default +import Data.Foldable hiding (concat) +import qualified Data.List as List +import Data.Maybe +import Data.Ratio +import Data.Semigroup +import Data.Typeable +import Data.VectorSpace -import Music.Score.Voice -import Music.Score.Score -import Music.Score.Combinators -import Music.Score.Part -import Music.Time +import Music.Score.Combinators +import Music.Score.Convert +import Music.Score.Part +import Music.Score.Score +import Music.Score.Voice +import Music.Time -- | --- Class of types that can be tied. +-- Class of types that can be tied. Ties are added to a score by splitting a single note +-- into two and annotating them with a /begin tie/ and /end tie/ mark respectively. -- +-- +-- Minimal definition: 'toTied', or both 'beginTie' and 'endTie'. +-- class Tiable a where + -- | + -- Modify a note to be the first note in a tied note pair. + -- beginTie :: a -> a - endTie :: a -> a + beginTie = fst . toTied - -- | Split elements into beginning and end and add tie. - -- Begin properties goes to the first tied note, and end properties to the latter. + -- | + -- Modify a note to be the second note in a tied note pair. + -- + endTie :: a -> a + endTie = snd . toTied - -- The first returned element will have the original onset. + -- | + -- Split a single note into a pair of tied notes. -- + -- The first returned element should have the original 'onset' and the second + -- element should have the original 'offset'. Formally + -- + -- > (onset . fst . toTied) a = onset a + -- > (offset . snd . toTied) a = offset a + -- toTied :: a -> (a, a) toTied a = (beginTie a, endTie a) -newtype TieT a = TieT { getTieT :: (Bool, a, Bool) } - deriving (Eq, Ord, Show, Functor, Foldable, Typeable) +newtype TieT a = TieT { getTieT :: ((Any, Any), a) } + deriving (Eq, Ord, Show, Functor, Foldable, Typeable, Applicative, Monad) --- These are note really tiable..., but Tiable a => (Bool,a,Bool) would be instance Tiable Double where { beginTie = id ; endTie = id } instance Tiable Float where { beginTie = id ; endTie = id } instance Tiable Int where { beginTie = id ; endTie = id } @@ -77,62 +100,94 @@ instance Tiable a => Tiable (Maybe a) where beginTie = fmap beginTie - endTie = fmap endTie - toTied Nothing = (Nothing, Nothing) - toTied (Just a) = (Just b, Just c) where (b,c) = toTied a + endTie = fmap endTie instance Tiable a => Tiable (TieT a) where - beginTie (TieT (prevTie, a, nextTie)) = TieT (prevTie, a, True) - endTie (TieT (prevTie, a, nextTie)) = TieT (True, a, nextTie) - toTied (TieT (prevTie, a, nextTie)) = (TieT (prevTie, b, True), TieT (True, c, nextTie)) + toTied (TieT ((prevTie, nextTie), a)) = (TieT ((prevTie, Any True), b), TieT ((Any True, nextTie), c)) where (b,c) = toTied a -- | -- Split all notes that cross a barlines into a pair of tied notes. -- -splitTies :: (HasPart' a, Tiable a) => Score a -> Score a -splitTies = mapParts splitTiesSingle - --- | --- Equivalent to `splitTies` for single-voice scores. --- Fails if the score contains overlapping events. --- -splitTiesSingle :: Tiable a => Score a -> Score a -splitTiesSingle = voiceToScore' . splitTiesVoice . scoreToVoice - --- | --- Split all notes that cross a barlines into a pair of tied notes. --- splitTiesVoice :: Tiable a => Voice a -> Voice a -splitTiesVoice = Voice . concat . snd . List.mapAccumL g 0 . getVoice +splitTiesVoice = (^. voice) . concat . snd . List.mapAccumL g 0 . (^. from voice) where g t (d, x) = (t + d, occs) where (_, barTime) = properFraction t remBarTime = 1 - barTime - occs = splitDur remBarTime 1 (d,x) + occs = splitDurThen remBarTime 1 (d,x) -- | +-- Split all voice into bars, using the given bar durations. Music that does not +-- fit into the given durations is discarded. +-- +-- Notes that cross a barlines are split into tied notes. +-- +splitTiesVoiceAt :: Tiable a => [Duration] -> Voice a -> [Voice a] +splitTiesVoiceAt barDurs x = fmap (^. voice) $ splitTiesVoiceAt' barDurs ((^. from voice) x) + +splitTiesVoiceAt' :: Tiable a => [Duration] -> [(Duration, a)] -> [[(Duration, a)]] +splitTiesVoiceAt' [] _ = [] +splitTiesVoiceAt' _ [] = [] +splitTiesVoiceAt' (barDur : rbarDur) occs = case splitDurFor barDur occs of + (barOccs, []) -> barOccs : [] + (barOccs, restOccs) -> barOccs : splitTiesVoiceAt' rbarDur restOccs + +tsplitTiesVoiceAt :: [Duration] -> [Duration] -> [[(Duration, Char)]] +tsplitTiesVoiceAt barDurs = fmap (^. from voice) . splitTiesVoiceAt barDurs . (^. voice) . fmap (\x -> (x,'_')) + +-- | -- Split an event into one chunk of the duration @s@, followed parts shorter than duration @t@. -- -- The returned list is always non-empty. All elements but the first and the last must have duration @t@. -- -- > sum $ fmap fst $ splitDur s (x,a) = x -- -splitDur :: Tiable a => DurationT -> DurationT -> (DurationT, a) -> [(DurationT, a)] -splitDur s t x = case splitDur' s x of +splitDurThen :: Tiable a => Duration -> Duration -> (Duration, a) -> [(Duration, a)] +splitDurThen s t x = case splitDur s x of (a, Nothing) -> [a] - (a, Just b) -> a : splitDur t t b + (a, Just b) -> a : splitDurThen t t b + -- | --- 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. +-- Extract as many notes or parts of notes as possible in the given positive duration, and +-- return it with remaining notes. -- --- > splitDur s (d,a) +-- The extracted notes always fit into the given duration, i.e. -- -splitDur' :: Tiable a => DurationT -> (DurationT, a) -> ((DurationT, a), Maybe (DurationT, a)) -splitDur' s (d,a) | d <= s = ((d,a), Nothing) - | otherwise = ((s,b), Just (d-s, c)) where (b,c) = toTied a +-- > sum $ fmap duration $ fst $ splitDurFor maxDur xs <= maxDur +-- +-- If there are remaining notes, they always fit exactly, i.e. +-- +-- > sum $ fmap duration $ fst $ splitDurFor maxDur xs == maxDur iff (not $ null $ snd $ splitDurFor maxDur xs) +-- +splitDurFor :: Tiable a => Duration -> [(Duration, a)] -> ([(Duration, a)], [(Duration, a)]) +splitDurFor remDur [] = ([], []) +splitDurFor remDur (x : xs) = case splitDur remDur x of + (x@(d,_), Nothing) -> + if d < remDur then + first (x:) $ splitDurFor (remDur - d) xs + else -- d == remDur + ([x], xs) + (x@(d,_), Just rest) -> ([x], rest : xs) + +tsplitDurFor :: Duration -> [Duration] -> ([(Duration,Char)], [(Duration,Char)]) +tsplitDurFor maxDur xs = splitDurFor maxDur $ fmap (\x -> (x,'_')) xs +instance Tiable Char where + toTied _ = ('(',')') + +-- | +-- Split a note if it is longer than the given duration. Returns the first part of the +-- note (which always <= s) and the rest. +-- +-- > splitDur maxDur (d,a) +-- +splitDur :: Tiable a => Duration -> (Duration, a) -> ((Duration, a), Maybe (Duration, a)) +splitDur maxDur (d,a) + | maxDur <= 0 = error "splitDur: maxDur must be > 0" + | d <= maxDur = ((d, a), Nothing) + | d > maxDur = ((maxDur, b), Just (d - maxDur, c)) where (b,c) = toTied a diff --git a/src/Music/Score/Track.hs b/src/Music/Score/Track.hs --- a/src/Music/Score/Track.hs +++ b/src/Music/Score/Track.hs @@ -1,10 +1,16 @@ -{-# LANGUAGE - TypeFamilies, - DeriveFunctor, - DeriveFoldable, - FlexibleInstances, - GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} ------------------------------------------------------------------------------------- -- | @@ -21,40 +27,42 @@ ------------------------------------------------------------------------------------- module Music.Score.Track ( - Track(..), + -- * Track type + Track, + track', + track, + -- mkTrack, + -- getTrack, ) 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 Test.QuickCheck (Arbitrary(..),Gen(..)) -import qualified Data.Map as Map -import qualified Data.List as List - -import Music.Time +import Control.Applicative +import Control.Arrow +import Control.Lens +import Control.Monad +import Control.Monad.Compose +import Data.AffineSpace.Point +import Data.Foldable (Foldable (..), foldMap) +import qualified Data.Foldable as F +import qualified Data.List as List +import Data.PairMonad () +import Data.Semigroup +import Data.Traversable (Traversable (..)) +import qualified Data.Traversable as T +import Data.Typeable +import Data.VectorSpace hiding (Sum) +import Test.QuickCheck (Arbitrary (..), Gen (..)) -------------------------------------------------------------------------------------- --- Track type -------------------------------------------------------------------------------------- +import Music.Dynamics.Literal +import Music.Pitch.Literal +import Music.Score.Pitch +import Music.Score.Util +import Music.Time -- | --- A track is a list of events with explicit onset. Events can not overlap. --- --- Track is a 'Monoid' under parallel composition. 'mempty' is the empty track and 'mappend' --- interleaves values. +-- A track is a list of events with explicit onset. -- --- Track has an 'Applicative' instance derived from the 'Monad' instance. +-- Track is a 'Monoid' under parallel composition. 'mempty' is the empty track +-- and 'mappend' interleaves values. -- -- 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 @@ -74,11 +82,10 @@ -- Track is an instance of 'VectorSpace' using parallel composition as addition, -- and time scaling as scalar multiplication. -- -newtype Track a = Track { getTrack :: [(TimeT, a)] } - deriving (Eq, Ord, Show, Functor, Foldable) - -type instance Time Track = TimeT +newtype Track a = Track { getTrack' :: [Occ a] } + deriving (Eq, Ord, Show, Functor, Foldable, Typeable, Traversable, Monoid, Semigroup, Delayable, Stretchable) +{- instance Semigroup (Track a) where (<>) = mappend @@ -88,69 +95,74 @@ Track as `mappend` Track bs = Track (as `m` bs) where m = mergeBy (comparing fst) +-} -instance Monad Track where - return a = Track [(0, a)] - a >>= k = join' . fmap k $ a - where - join' (Track ts) = foldMap (uncurry delay') ts +instance Wrapped (Track a) where + type Unwrapped (Track a) = [Occ a] + _Wrapped' = iso getTrack' Track instance Applicative Track where pure = return (<*>) = ap +instance Monad Track where + return = (^. _Unwrapped') . return . return + xs >>= f = (^. _Unwrapped') $ mbind ((^. _Wrapped') . f) ((^. _Wrapped') xs) + instance Alternative Track where empty = mempty (<|>) = mappend --- Satisfies left distribution instance MonadPlus Track where mzero = mempty mplus = mappend -instance Stretchable (Track) where - n `stretch` Track tr = Track $ fmap (first (^* fromDurationT n)) tr +instance HasOnset (Track a) where + onset (Track a) = list origin (onset . head) a -instance Delayable (Track) where - d `delay` Track tr = Track $ fmap (first (.+^ d)) tr +instance IsPitch a => IsPitch (Track a) where + fromPitch = pure . fromPitch -instance HasOnset (Track) where - onset (Track []) = 0 - onset (Track xs) = minimum (fmap on xs) where on (t,x) = t +instance IsDynamics a => IsDynamics (Track a) where + fromDynamics = pure . fromDynamics -{- -instance HasOffset (Track) where - offset (Track []) = 0 - offset (Track xs) = maximum (fmap off xs) where off (t,x) = t --} +instance IsInterval a => IsInterval (Track a) where + fromInterval = pure . fromInterval --- offset x = maximum (fmap off x) where off (t,x) = t +type instance Pitch (Track a) = Pitch a +instance (HasSetPitch a b, Transformable (Pitch (Track a)), Transformable (Pitch (Track b))) => HasSetPitch (Track a) (Track b) where + type SetPitch g (Track a) = Track (SetPitch g a) + -- FIXME this is wrong, need to behave like __mapPitch' + __mapPitch f = fmap (__mapPitch f) -{- -instance HasDuration (Track) where - duration x = offset x .-. onset x --} -instance Arbitrary a => Arbitrary (Track a) where - arbitrary = do - x <- arbitrary - t <- fmap toDurationT $ (arbitrary::Gen Double) - d <- fmap toDurationT $ (arbitrary::Gen Double) - return $ delay t $ stretch d $ (return x) +-- | +-- Create a voice from a list of occurences. +-- +track' :: Iso' [(Time, a)] (Track a) +track' = track +-- | +-- Create a voice from a list of occurences. +-- +track :: Iso [(Time, a)] [(Time, b)] (Track a) (Track b) +track = iso mkTrack getTrack + where + mkTrack = Track . fmap (uncurry occ . first (fmap realToFrac)) + getTrack = fmap (first (fmap realToFrac) . getOcc) . getTrack' -------------------------------------------------------------------------------------- -delay' t = delay (fromTimeT 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) +newtype Occ a = Occ (Sum Time, a) + deriving (Eq, Ord, Show, {-Read, -}Functor, Applicative, Monad, Foldable, Traversable) +occ t x = Occ (Sum t, x) +getOcc (Occ (Sum t, x)) = (t, x) -mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a] -mergeBy f as bs = List.sortBy f $ as <> bs +instance Delayable (Occ a) where + delay n (Occ (s,x)) = Occ (delay n s, x) +instance Stretchable (Occ a) where + stretch n (Occ (s,x)) = Occ (stretch n s, x) +instance HasOnset (Occ a) where + onset (Occ (s,x)) = onset s diff --git a/src/Music/Score/Util.hs b/src/Music/Score/Util.hs new file mode 100644 --- /dev/null +++ b/src/Music/Score/Util.hs @@ -0,0 +1,384 @@ + + +{-# LANGUAGE ViewPatterns #-} + +module Music.Score.Util where + +---------------------------------------------------------------------- +-- +-- File generated by hackette. Do not edit! +-- +-- Fetched by hans on Sön 9 Mar 2014 14:52:14 CET +-- +---------------------------------------------------------------------- + + + +{-# LANGUAGE ViewPatterns #-} + +{- + Rules: + + * Functions may depend on any module in the lastest Haskell Platform release + * All functions but those in Prelude must be referred to with their full, + qualified names (i.e. Data.List.unfoldr). + * Each function must have a unique name (so the whole file is a loadable module). + * Each function should have a synopisis, like: + + -- | Ordinary Haddock commentary ... + -- > category: Categories (please use the common Hackage names) + -- > depends : base (all packages in HP that the function depends on) + +-} + +import qualified Data.Char +import qualified Data.Monoid +import qualified Data.List +import qualified Data.Ratio + +-- | Synonym for 'Data.Char.toUpper' +-- > category : String +-- > depends : base +toUpperChar :: Char -> Char +toUpperChar = Data.Char.toUpper + +-- | Synonym for 'Data.Char.toLower' +-- > category : String +-- > depends : base +toLowerChar :: Char -> Char +toLowerChar = Data.Char.toLower + +-- | Synonym for 'fmap Data.Char.toUpper' +-- > category : String +-- > depends : base +toUpperString :: String -> String +toUpperString = fmap Data.Char.toUpper + +-- | Synonym for 'fmap Data.Char.toLower' +-- > category : String +-- > depends : base +toLowerString :: String -> String +toLowerString = fmap Data.Char.toLower + +-- | Convert a string to use upper case for the leading letter and lower case for remaining letters. +-- > category : String +-- > depends : base +toCapitalString :: String -> String +toCapitalString [] = [] +toCapitalString (x:xs) = toUpperChar x : toLowerString xs + +-- | Synonym for '(++)' +-- > category : List +-- > depends : base +withPrefix :: [a] -> [a] -> [a] +withPrefix x = (x ++) + +-- | Synonym for 'flip (++)' +-- > category : List +-- > depends : base +withSuffix :: [a] -> [a] -> [a] +withSuffix x = (++ x) + +-- | Separate a list by the given element. Equivalent to 'Data.List.intersperse'. +-- > category : List +-- > depends : base +sep :: a -> [a] -> [a] +sep = Data.List.intersperse + +-- | Initiate and separate a list by the given element. +-- > category : List +-- > depends : base +pre :: a -> [a] -> [a] +pre x = (x :) . sep x + +-- | Separate and terminate a list by the given element. +-- > category : List +-- > depends : base +post :: a -> [a] -> [a] +post x = withSuffix [x] . sep x + +-- | Separate and terminate a list by the given element. +-- > category : List +-- > depends : base +wrap :: a -> a -> [a] -> [a] +wrap x y = (x :) . withSuffix [y] . sep x + +-- | Combination of 'concat' and 'sep'. Equivalent to 'Data.List.intercalate'. +-- > category : List +-- > depends : base +concatSep :: [a] -> [[a]] -> [a] +concatSep x = concat . sep x + +-- | Combination of 'concat' and 'pre'. +-- > category : List +-- > depends : base +concatPre :: [a] -> [[a]] -> [a] +concatPre x = concat . pre x + +-- | Combination of 'concat' and 'post'. +-- > category : List +-- > depends : base +concatPost :: [a] -> [[a]] -> [a] +concatPost x = concat . post x + +-- | Combination of 'concat' and 'wrap'. +-- > category : List +-- > depends : base +concatWrap :: [a] -> [a] -> [[a]] -> [a] +concatWrap x y = concat . wrap x y + +-- | Divide a list into parts of maximum length n. +-- > category : List +-- > depends : base +divideList :: Int -> [a] -> [[a]] +divideList n xs + | length xs <= n = [xs] + | otherwise = [take n xs] ++ (divideList n $ drop n xs) + +-- | 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]] +-- +-- > category : List +-- > depends : base +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 + + +-- | Break up a list into parts of maximum length n, inserting the given list as separator. +-- Useful for breaking up strings, as in @breakList 80 "\n" str@. +-- +-- > category : List +-- > depends : base +breakList :: Int -> [a] -> [a] -> [a] +breakList n z = Data.Monoid.mconcat . Data.List.intersperse z . divideList n + +-- | Map over the indices and elements of list. +-- > category : List +-- > depends : base +mapIndexed :: (Int -> a -> b) -> [a] -> [b] +mapIndexed f as = map (uncurry f) (zip is as) + where + n = length as - 1 + is = [0..n] + +-- test + +-- | Duplicate an element. +-- > category: Combinator, Tuple +-- > depends: base +dup :: a -> (a,a) +dup x = (x,x) + +-- | Unfold a partial function. This is a simpler version of 'Data.List.unfoldr'. +-- > category: Function, List +-- > depends: base +unf :: (a -> Maybe a) -> a -> [a] +unf f = Data.List.unfoldr (fmap dup . f) + +-- | +-- Map over first elements of a list. +-- Biased on first element for shorter lists. +-- > category: List +-- > depends: base +mapF f = mapFTL f id id + +-- | +-- Map over all but the first and last elements of a list. +-- Biased on middle elements for shorter lists. +-- > category: List +-- > depends: base +mapT f = mapFTL id f id + +-- | +-- Map over last elements of a list. +-- Biased on last element for shorter lists. +-- > category: List +-- > depends: base +mapL f = mapFTL id id f + +-- | +-- Map over first, middle and last elements of list. +-- Biased on first, then on first and last for short lists. +-- +-- > category: List +-- > depends: base +mapFTL :: (a -> b) -> (a -> b) -> (a -> b) -> [a] -> [b] +mapFTL f g h = go + where + go [] = [] + go [a] = [f a] + go [a,b] = [f a, h b] + go xs = [f $ head xs] ++ + map g (tail $ init xs) ++ + [h $ last xs] + +-- | +-- Extract the first consecutive sublist for which the predicate returns true, or +-- the empty list if no such sublist exists. +-- > category: List +-- > depends: base +filterOnce :: (a -> Bool) -> [a] -> [a] +filterOnce p = Data.List.takeWhile p . Data.List.dropWhile (not . p) + + +-- | Returns all rotations of the given list. Given an infinite list, returns an infinite +-- list of rotated infinite lists. +-- > category: List +-- > depends: base +rots :: [a] -> [[a]] +rots xs = init (zipWith (++) (Data.List.tails xs) (Data.List.inits xs)) + +-- | +-- > category: List +-- > depends: base +rotl :: [a] -> [a] +rotl [] = [] +rotl (x:xs) = xs ++ [x] + +-- | +-- > category: List +-- > depends: base +rotr :: [a] -> [a] +rotr [] = [] +rotr xs = last xs : init xs + +-- | +-- > category: List +-- > depends: base +rotated :: Int -> [a] -> [a] +rotated = go + where + go n as + | n >= 0 = iterate rotr as !! n + | n < 0 = iterate rotl as !! abs n + + +curry3 :: ((a, b, c) -> d) -> a -> b -> c -> d +curry3 = curry . curry . (. tripl) + +uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d +uncurry3 = (. untripl) . uncurry . uncurry + +untripl :: (a,b,c) -> ((a,b),c) +untripl (a,b,c) = ((a,b),c) + +tripl :: ((a,b),c) -> (a,b,c) +tripl ((a,b),c) = (a,b,c) + +tripr :: (a,(b,c)) -> (a,b,c) +tripr (a,(b,c)) = (a,b,c) + +-- | Case matching on lists. +-- > category: List +-- > depends: base +list :: r -> ([a] -> r) -> [a] -> r +list z f [] = z +list z f xs = f xs + +-- | Merge lists. +-- > category: List +-- > depends: base +merge :: Ord a => [a] -> [a] -> [a] +merge = mergeBy compare + +-- | Merge lists. +-- > category: List +-- > depends: base +mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a] +mergeBy f = mergeBy' $ (fmap.fmap) orderingToBool f + where + orderingToBool LT = True + orderingToBool EQ = True + orderingToBool GT = False + +mergeBy' :: (a -> a -> Bool) -> [a] -> [a] -> [a] +mergeBy' pred xs [] = xs +mergeBy' pred [] ys = ys +mergeBy' pred (x:xs) (y:ys) = + case pred x y of + True -> x: mergeBy' pred xs (y:ys) + False -> y: mergeBy' pred (x:xs) ys + +-- | Compose all functions. +-- > category: Function +-- > depends: base +composed :: [b -> b] -> b -> b +composed = Prelude.foldr (.) id + +-- | Separate a ratio. +-- > category: Math +-- > depends: base +unRatio :: Integral a => Data.Ratio.Ratio a -> (a, a) +unRatio x = (Data.Ratio.numerator x, Data.Ratio.denominator x) + +-- | Nicer printing of ratio as ordinary fractions. +-- > category: Math +-- > depends: base +showRatio :: (Integral a, Show a) => Data.Ratio.Ratio a -> String +showRatio (realToFrac -> (unRatio -> (x, 1))) = show x +showRatio (realToFrac -> (unRatio -> (x, y))) = "(" ++ show x ++ "/" ++ show y ++ ")" + + +-- Replace all contigous ranges of equal values with [Just x, Nothing, Nothing ...] +-- > category: List +-- > depends: base +retainUpdates :: Eq a => [a] -> [Maybe a] +retainUpdates = snd . Data.List.mapAccumL g Nothing where + g Nothing x = (Just x, Just x) + g (Just p) x = (Just x, if p == x then Nothing else Just x) + + +-- Generic version of 'replicate'. +-- > category: List +-- > depends: base +replic :: Integral a => a -> b -> [b] +replic n = replicate (fromIntegral n) + +-- Swap components. +-- > category: Tuple +-- > depends: base +swap :: (a, b) -> (b, a) +swap (x, y) = (y, x) + +-- Interleave a list with the next consecutive element. +-- +-- For any xs +-- +-- > lenght xs == length (withNext xs) +-- +-- If @xs@ is a finite list +-- +-- > isNothing $ snd $ last $ withNext xs == True +-- > all isJust $ snd $ init $ withNext xs == True +-- +-- If @xs@ is an infinite list +-- +-- > all isJust $ snd $ withNext xs == True +-- +-- > category: List +-- > depends: base +withNext :: [a] -> [(a, Maybe a)] +withNext = go + where + go [] = [] + go [x] = [(x, Nothing)] + go (x:y:rs) = (x, Just y) : withNext (y : rs) + +-- Map over a list with the next consecutive element. +-- +-- > category: List +-- > depends: base +mapWithNext :: (a -> Maybe a -> b) -> [a] -> [b] +mapWithNext f = fmap (uncurry f) . withNext diff --git a/src/Music/Score/Voice.hs b/src/Music/Score/Voice.hs --- a/src/Music/Score/Voice.hs +++ b/src/Music/Score/Voice.hs @@ -1,9 +1,16 @@ -{-# LANGUAGE - TypeFamilies, - DeriveFunctor, - DeriveFoldable, - GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} ------------------------------------------------------------------------------------- -- | @@ -20,42 +27,46 @@ ------------------------------------------------------------------------------------- module Music.Score.Voice ( - Voice(..), + -- * Voice type + Voice, + voice', + voice, + + zipVoice, + zipVoiceWith, + dzipVoiceWith, + mergeEqual, ) where -import Prelude hiding (foldr, concat, foldl, mapM, concatMap, maximum, sum, minimum) +import Control.Applicative +import Control.Arrow +import Control.Lens +import Control.Monad +import Control.Monad.Compose +import Data.Semigroup -import Data.Semigroup -import Control.Applicative -import Control.Monad (ap, join, MonadPlus(..)) -import Data.Foldable -import Data.Traversable -import Data.Maybe -import Data.Pointed -import Data.Either -import Data.Function (on) -import Data.Ord (comparing) -import Data.Ratio -import Data.VectorSpace -import Data.AffineSpace +import Data.Foldable (Foldable (..), foldMap) +import qualified Data.Foldable as F +import qualified Data.List as List +import Data.PairMonad () +import Data.Traversable (Traversable (..)) +import qualified Data.Traversable as T +import Data.Typeable +import Data.VectorSpace hiding (Sum) -import Music.Time +import Music.Dynamics.Literal +import Music.Pitch.Literal +import Music.Score.Pitch +import Music.Score.Util +import Music.Time -import Music.Pitch.Literal -import Music.Dynamics.Literal -------------------------------------------------------------------------------------- --- Voice type -------------------------------------------------------------------------------------- - -- | -- A voice is a list of events with explicit duration. Events can not overlap. -- -- Voice is a 'Monoid' under sequential composition. 'mempty' is the empty part and 'mappend' -- appends parts. -- --- Voice has an 'Applicative' instance derived from the 'Monad' instance. --- -- Voice 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 @@ -64,7 +75,7 @@ -- -- > let p = Voice [(1, Just 0), (2, Just 1)] :: Voice Int -- > --- > p >>= \x -> Voice [ (1, Just $ toEnum $ x+65), +-- > p >>= \x -> Voice [ (1, Just $ toEnum $ x+65), -- > (3, Just $ toEnum $ x+97) ] :: Voice Char -- > -- > ===> Voice {getVoice = [ (1 % 1,Just 'A'), @@ -75,32 +86,24 @@ -- Voice is a 'VectorSpace' using sequential composition as addition, and time scaling -- as scalar multiplication. -- -newtype Voice a = Voice { getVoice :: [(DurationT, a)] } - deriving (Eq, Ord, Show, Functor, Foldable, Monoid) +newtype Voice a = Voice { getVoice' :: [Ev a] } + deriving (Eq, Ord, Show, Functor, Foldable, Monoid, Semigroup, Typeable, Traversable, Stretchable) -type instance Time Voice = TimeT -instance Semigroup (Voice a) where - (<>) = mappend - -instance Monad Voice where - return a = Voice [(1, a)] - a >>= k = join' $ fmap k a - where - join' (Voice ps) = foldMap (uncurry stretch) ps - -instance Pointed Voice where - point = return +instance Wrapped (Voice a) where + type Unwrapped (Voice a) = [Ev a] + _Wrapped' = iso getVoice' Voice instance Applicative Voice where pure = return (<*>) = ap -instance Stretchable (Voice) where - n `stretch` Voice as = Voice (fmap (first (n*^)) as) +instance Monad Voice where + return = (^. _Unwrapped') . return . return + xs >>= f = (^. _Unwrapped') $ ((^. _Wrapped') . f) `mbind` ((^. _Wrapped') xs) -instance HasDuration (Voice) where - duration (Voice as) = sum (fmap fst as) +instance HasDuration (Voice a) where + duration = sum . fmap duration . getVoice' instance IsPitch a => IsPitch (Voice a) where fromPitch = pure . fromPitch @@ -108,12 +111,73 @@ instance IsDynamics a => IsDynamics (Voice a) where fromDynamics = pure . fromDynamics +instance IsInterval a => IsInterval (Voice a) where + fromInterval = pure . fromInterval -------------------------------------------------------------------------------------- +-- TODO +instance Num a => Num (Voice a) where + fromInteger = pure . fromInteger -list z f [] = z -list z f xs = f xs +type instance Pitch (Voice a) = Pitch a +instance (HasSetPitch a b, Transformable (Pitch a), Transformable (Pitch b)) => HasSetPitch (Voice a) (Voice b) where + type SetPitch g (Voice a) = Voice (SetPitch g a) + -- FIXME this is wrong, need to behave like __mapPitch' + __mapPitch f = fmap (__mapPitch f) -first f (x,y) = (f x, y) -second f (x,y) = (x, f y) +-- | +-- Create a voice from a list of events. +-- +voice' :: Iso' [(Duration, a)] (Voice a) +voice' = voice + +-- | +-- Create a voice from a list of events. +-- +voice :: Iso [(Duration, a)] [(Duration, b)] (Voice a) (Voice b) +voice = iso mkVoice getVoice + where + mkVoice = Voice . fmap (uncurry ev . first realToFrac) + getVoice = fmap (first realToFrac . getEv) . getVoice' + +-- | +-- Join the given voices by multiplying durations and pairing values. +-- +zipVoice :: Voice a -> Voice b -> Voice (a, b) +zipVoice = zipVoiceWith (,) + +-- | +-- Join the given voices by multiplying durations and combining values using the given function. +-- +zipVoiceWith :: (a -> b -> c) -> Voice a -> Voice b -> Voice c +zipVoiceWith f (Voice a) (Voice b) = Voice $ zipWith (\(Ev (dx,vx)) (Ev (dy,vy)) -> Ev (dx <> dy, f vx vy)) a b + +-- | +-- Join the given voices by combining durations and values using the given function. +-- +dzipVoiceWith :: (Duration -> Duration -> a -> b -> (Duration, c)) -> Voice a -> Voice b -> Voice c +dzipVoiceWith f (Voice a) (Voice b) = Voice $ zipWith (\(Ev (Product dx,vx)) (Ev (Product dy,vy)) -> Ev (first Product $ f dx dy vx vy)) a b + +-- | +-- Merge consecutive equal note. +-- +mergeEqual :: Eq a => Voice a -> Voice a +mergeEqual = over (from voice) $ fmap f . List.groupBy (inspecting snd) + where + f dsAs = let (ds,as) = unzip dsAs in (sum ds, head as) + +inspecting :: Eq a => (b -> a) -> b -> b -> Bool +inspecting p x y = p x == p y + +newtype Ev a = Ev (Product Duration, a) + deriving (Eq, Ord, Show, {-Read, -}Functor, Applicative, Monad, Foldable, Traversable) + +ev t x = Ev (Product t, x) +getEv (Ev (Product t, x)) = (t, x) + +instance Stretchable (Ev a) where + stretch n (Ev (s,x)) = Ev (stretch n s, x) + +instance HasDuration (Ev a) where + duration (Ev (s,x)) = duration s + diff --git a/src/Music/Score/Zip.hs b/src/Music/Score/Zip.hs deleted file mode 100644 --- a/src/Music/Score/Zip.hs +++ /dev/null @@ -1,119 +0,0 @@ - -{-# LANGUAGE - TypeFamilies, - DeriveFunctor, - DeriveFoldable, - FlexibleInstances, - FlexibleContexts, - ConstraintKinds, - OverloadedStrings, - GeneralizedNewtypeDeriving #-} - -------------------------------------------------------------------------------------- --- | --- Copyright : (c) Hans Hoglund 2012 --- --- License : BSD-style --- --- Maintainer : hans@hanshoglund.se --- Stability : experimental --- Portability : non-portable (TF,GNTD) --- --- Provides zippers over scores. --- -------------------------------------------------------------------------------------- - - -module Music.Score.Zip ( - -- ** Zipper - apply, - snapshot, - -- trig, - applySingle, - snapshotSingle, - -- before, - -- first, - ) where - -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.Voice -import Music.Score.Score -import Music.Time -import Music.Score.Part -import Music.Score.Combinators - -------------------------------------------------------------------------------------- --- Analysis - --- | --- Apply a time-varying function to all events in score. --- -apply :: HasPart' a => Voice (Score a -> Score b) -> Score a -> Score b -apply x = mapAllParts (fmap $ applySingle x) - --- | --- Get all notes that start during a given note. --- -snapshot :: HasPart' a => Score b -> Score a -> Score (b, Score a) -snapshot x = mapAllParts (fmap $ snapshotSingle x) - -trig :: Score a -> Score b -> Score b -trig p as = mconcat $ toList $ fmap snd $ snapshotSingle p as - --- | --- Apply a time-varying function to all events in score. --- -applySingle :: Voice (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 = snapshotSingle (voiceToScore fs) as - --- | --- Get all notes that start during a given note. --- -snapshotSingle :: Score a -> Score b -> Score (a, Score b) -snapshotSingle as bs = mapEventsSingle ( \t d a -> g a (onsetIn t d bs) ) as - where - -- g Nothing z = Nothing - g = (,) - - --- | --- 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 :: TimeT -> DurationT -> Score a -> Score a -onsetIn a b = compose . filter' (\(t,d,x) -> a <= t && t < a .+^ b) . perform - where - filter' = filterOnce - -- more lazy than mfilter - --- | --- Extract the first consecutive sublist for which the predicate returns true, or --- the empty list if no such sublist exists. -filterOnce :: (a -> Bool) -> [a] -> [a] -filterOnce p = List.takeWhile p . List.dropWhile (not . p) - - -before :: DurationT -> Score a -> Score a -before d = trig (return () `stretchedBy` d) - -first :: Score a -> a -first = value . head . perform - where - value (a,b,c) = c - - -stretchedBy = flip stretch diff --git a/src/Music/Time.hs b/src/Music/Time.hs --- a/src/Music/Time.hs +++ b/src/Music/Time.hs @@ -1,17 +1,4 @@ -{-# LANGUAGE - TypeFamilies, - DeriveFunctor, - DeriveFoldable, - DeriveDataTypeable, - GeneralizedNewtypeDeriving, - FlexibleInstances, - FlexibleContexts, - ConstraintKinds, - TypeOperators, - OverloadedStrings, - NoMonomorphismRestriction #-} - ------------------------------------------------------------------------------------- -- | -- Copyright : (c) Hans Hoglund 2012 @@ -22,26 +9,32 @@ -- Stability : experimental -- Portability : non-portable (TF,GNTD) -- --- Provides time representations for use with scores, events etc. +-- Provides generic functions for manipulating time-based structures. -- ------------------------------------------------------------------------------------- module Music.Time ( - module Music.Time.Pos, module Music.Time.Time, - module Music.Time.Duration, - -- module Music.Time.Era, + module Music.Time.Span, + module Music.Time.Delayable, module Music.Time.Stretchable, - module Music.Time.Performable, module Music.Time.Onset, + + module Music.Time.Juxtapose, + module Music.Time.Reverse, + module Music.Time.Reactive, + module Music.Time.Behavior ) where -import Music.Time.Time -import Music.Time.Duration -import Music.Time.Delayable -import Music.Time.Stretchable --- import Music.Time.Era -import Music.Time.Performable -import Music.Time.Pos -import Music.Time.Onset +import Music.Time.Span +import Music.Time.Time + +import Music.Time.Delayable +import Music.Time.Onset +import Music.Time.Stretchable + +import Music.Time.Behavior +import Music.Time.Juxtapose +import Music.Time.Reactive +import Music.Time.Reverse diff --git a/src/Music/Time/Behavior.hs b/src/Music/Time/Behavior.hs new file mode 100644 --- /dev/null +++ b/src/Music/Time/Behavior.hs @@ -0,0 +1,160 @@ + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +-- Behaviors, or time-varying values. +-- +-- TODO integrate better in the library +-- +------------------------------------------------------------------------------------- + +module Music.Time.Behavior ( + Behavior, + constant, + behavior, + varying, + varyingIn, + -- time, + switchB, + trimBeforeB, + ) where + +import Prelude hiding (trimAfter) + +import Control.Applicative +import Control.Arrow +import Control.Lens +import Control.Monad +import Control.Monad.Compose +import Control.Monad.Plus +import Data.AffineSpace +import Data.AffineSpace.Point +import Data.Foldable (Foldable) +import qualified Data.Foldable as F +import qualified Data.List as List +import Data.Map (Map) +import qualified Data.Map as Map +import Data.NumInstances () +import Data.Profunctor +import Data.Semigroup +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Traversable (Traversable) +import qualified Data.Traversable as T +import Data.Typeable +import Data.VectorSpace + +import Music.Dynamics.Literal +import Music.Pitch.Literal +import Music.Time.Delayable +import Music.Time.Reactive +import Music.Time.Span +import Music.Time.Stretchable +import Music.Time.Time +import Music.Time.Time + +-- Inner TFun focuses on [0..1] +newtype Behavior a = Behavior { getBehavior :: Reactive (Time -> a) } + deriving (Functor, Semigroup, Monoid) + +instance Delayable (Behavior a) where + delay n (Behavior x) = Behavior (fmap (delay n) $ delay n x) + +instance Stretchable (Behavior a) where + stretch n (Behavior x) = Behavior (fmap (stretch n) $ stretch n x) + +instance Wrapped (Behavior a) where + type Unwrapped (Behavior a) = (Reactive (Time -> a)) + _Wrapped' = iso getBehavior Behavior + +instance Applicative Behavior where + pure = (^. _Unwrapped') . pure . pure + ((^. _Wrapped') -> f) <*> ((^. _Wrapped') -> x) = (^. _Unwrapped') $ liftA2 (<*>) f x + +instance HasBehavior Behavior where + (?) = behAt + +deriving instance Num a => Num (Behavior a) +deriving instance Fractional a => Fractional (Behavior a) +deriving instance Floating a => Floating (Behavior a) + +instance IsPitch a => IsPitch (Behavior a) where + fromPitch = pure . fromPitch +instance IsInterval a => IsInterval (Behavior a) where + fromInterval = pure . fromInterval +instance IsDynamics a => IsDynamics (Behavior a) where + fromDynamics = pure . fromDynamics +instance AdditiveGroup a => AdditiveGroup (Behavior a) where + zeroV = pure zeroV + negateV = fmap negateV + (^+^) = liftA2 (^+^) +instance AffineSpace a => AffineSpace (Behavior a) where + type Diff (Behavior a) = Behavior (Diff a) + (.+^) = liftA2 (.+^) + (.-.) = liftA2 (.-.) + + + + +-- | A constant (non-varying) behavior. +-- +-- Identical to @behavior . const@ but creates more efficient behaviors. +constant :: a -> Behavior a +constant = (^. _Unwrapped') . pure . pure + +-- | Create a behavior from function of (absolute) time. +-- +-- You should pass a function defined for the whole range, including negative time. +behavior :: (Time -> a) -> Behavior a +behavior = (^. _Unwrapped') . pure + +-- | Create a behaviour from a function of (relative) duration focused on 'sunit'. +-- +-- You should pass a function defined for the whole range, including negative durations. +varying :: (Duration -> a) -> Behavior a +varying = varyingIn sunit + +-- | Create a behaviour from a function of (relative) duration focused on the given span. +-- +-- You should pass a function defined for the whole range, including negative durations. +varyingIn :: Span -> (Duration -> a) -> Behavior a +varyingIn s f = behavior $ sapp (sinvert s) (lmap (.-. start) f) + +-- | @b ?? t@ returns the value of the behavior at time @t@. +-- Semantic function. +behAt :: Behavior a -> Time -> a +b `behAt` t = ((^. _Wrapped') b ? t) t + +time :: Behavior Time +time = behavior id + +trimBeforeB :: Monoid a => Time -> Behavior a -> Behavior a +trimBeforeB t = _Wrapping' Behavior %~ trimBefore t + +switchB :: Time -> Behavior a -> Behavior a -> Behavior a +switchB t ((^. _Wrapped') -> x) ((^. _Wrapped') -> y) = (^. _Unwrapped') $ switch t x y + + + + diff --git a/src/Music/Time/Delayable.hs b/src/Music/Time/Delayable.hs --- a/src/Music/Time/Delayable.hs +++ b/src/Music/Time/Delayable.hs @@ -1,11 +1,11 @@ -{-# LANGUAGE - TypeFamilies, - DeriveFunctor, - DeriveFoldable, - FlexibleContexts, - ConstraintKinds, - GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} ------------------------------------------------------------------------------------- -- | @@ -17,28 +17,105 @@ -- Stability : experimental -- Portability : non-portable (TF,GNTD) -- +-- Provides delayable values. +-- ------------------------------------------------------------------------------------- module Music.Time.Delayable ( + -- * Delayable class Delayable(..), - ) where + undelay, + delaying, + move, + moveBack, -import Data.Semigroup -import Data.VectorSpace -import Data.AffineSpace + -- ** Utility + delayTime, + NoDelay(..), + ) where -import Music.Time.Time -import Music.Time.Duration -import Music.Time.Pos +import Data.AffineSpace +import Data.AffineSpace.Point +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Semigroup +import Data.Set (Set) +import qualified Data.Set as Set +import Data.VectorSpace hiding (Sum) +import Music.Time.Time -- | --- Delayable values. --- -class Delayable s where +-- Delayable values. +-- +class Delayable a where -- | -- Delay a value. - -- > Duration -> Score a -> Score a - -- - delay :: Duration s -> s a -> s a + -- + delay :: Duration -> a -> a + delay _ = id + +instance Delayable Time where + delay n = (.+^ n) + +instance Delayable (Time -> a) where + delay n = (. delay (negateV n)) + +instance Delayable a => Delayable [a] where + delay n = fmap (delay n) + +instance (Ord a, Delayable a) => Delayable (Set a) where + delay n = Set.map (delay n) + +instance Delayable a => Delayable (Map k a) where + delay n = fmap (delay n) + +instance Delayable (Time, a) where + delay n (t, a) = (n `delay` t, a) + +instance Delayable (Time, Duration, a) where + delay n (t, d, a) = (n `delay` t, d, a) + +instance Delayable a => Delayable (Sum a) where + delay n (Sum x) = Sum (delay n x) + +instance Delayable a => Delayable (Product a) where + delay n (Product x) = Product (delay n x) + + + +-- | +-- Move a score forward in time. Equivalent to 'delay'. +-- +move :: Delayable a => Duration -> a -> a + +-- | +-- Move a score backward in time. Negated verison of 'delay'. +-- +moveBack :: Delayable a => Duration -> a -> a + +-- | +-- Delay relative to 'origin'. Provided for situations when you have a value that +-- should forward based on the distance between some time @t@ and the origin, but +-- it does not necessarily have a start time. +-- +delayTime :: Delayable a => Time -> a -> a + +undelay t = delay (negateV t) +move = delay +moveBack t = delay (negateV t) +delayTime t = delay (t .-. origin) + + +-- | Apply a function under delay. +-- See also 'sunder'. +delaying :: (Delayable a, Delayable b) => Duration -> (a -> b) -> a -> b +delaying t f = undelay t . f . delay t + +newtype NoDelay a = NoDelay { getNoDelay :: a } + deriving (Eq, Ord, Enum, Show, Semigroup, Monoid + {-Delayable, HasOnset, HasOffset, HasDuration-}) + +instance Delayable (NoDelay a) where + delay _ = id diff --git a/src/Music/Time/Duration.hs b/src/Music/Time/Duration.hs deleted file mode 100644 --- a/src/Music/Time/Duration.hs +++ /dev/null @@ -1,62 +0,0 @@ - -{-# LANGUAGE - TypeFamilies, - DeriveFunctor, - DeriveFoldable, - FlexibleContexts, - ConstraintKinds, - GeneralizedNewtypeDeriving #-} - -------------------------------------------------------------------------------------- --- | --- Copyright : (c) Hans Hoglund 2012 --- --- License : BSD-style --- --- Maintainer : hans@hanshoglund.se --- Stability : experimental --- Portability : non-portable (TF,GNTD) --- -------------------------------------------------------------------------------------- - -module Music.Time.Duration ( - DurationT, - fromDurationT, - toDurationT, - ) where - -import Data.Semigroup -import Data.VectorSpace -import Data.AffineSpace - - -------------------------------------------------------------------------------------- --- Duration type -------------------------------------------------------------------------------------- - --- | --- This type represents relative time in seconds. --- -newtype DurationT = DurationT { getDurationT::Rational } - deriving (Eq, Ord, Num, Enum, Real, Fractional, RealFrac) - -instance Show DurationT where - show = show . getDurationT - -instance AdditiveGroup DurationT where - zeroV = 0 - (^+^) = (+) - negateV = negate - -instance VectorSpace DurationT where - type Scalar DurationT = DurationT - (*^) = (*) - -instance InnerSpace DurationT where (<.>) = (*) - -fromDurationT :: Fractional a => DurationT -> a -fromDurationT = fromRational . getDurationT - -toDurationT :: Real a => a -> DurationT -toDurationT = DurationT . toRational - diff --git a/src/Music/Time/Juxtapose.hs b/src/Music/Time/Juxtapose.hs new file mode 100644 --- /dev/null +++ b/src/Music/Time/Juxtapose.hs @@ -0,0 +1,208 @@ + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +------------------------------------------------------------------------------------- + +module Music.Time.Juxtapose ( + -- * Prerequisites + Transformable(..), + + -- ** Juxtaposing values + following, + preceding, + during, + + -- * Composing values + (|>), + (>|), + (<|), + scat, + pcat, + + -- ** Special composition + sustain, + anticipate, + + -- ** Repetition + times, + repeated, + group, + ) where + + +import Data.AffineSpace +import Data.AffineSpace.Point +import Data.Monoid.WithSemigroup +import Data.Semigroup +import Data.VectorSpace + +import Music.Time.Delayable +import Music.Time.Onset +import Music.Time.Stretchable +import Music.Time.Time + +-- | +-- This pseudo-class gathers the restrictions needed to implement position a value at +-- any point and duration in time. +-- +type Transformable a = (Stretchable a, Delayable a) + + +------------------------------------------------------------------------------------- +-- Juxtaposition +------------------------------------------------------------------------------------- + +-- | +-- @a \`following\` b@ moves score /b/ so that its onset is at the offset of score +-- /a/ and returns the moved score. +-- +following :: (HasOffset a, Delayable b, HasOnset b) => a -> b -> b +a `following` b = startAt (offset a) b + +-- | +-- @a \`preceding\` b@ moves score /a/ so that its offset is at the onset of score +-- /b/ and returns the moved score. +-- +preceding :: (Delayable a, HasOffset a, HasOnset b) => a -> b -> a +a `preceding` b = stopAt (onset b) a + +-- | @a \`during\` b@ places /a/ at the same era as /b/ and returns the moved score. +during :: (Delayable a, Stretchable a, HasOnset a, HasDuration a, HasOnset b, HasDuration b) => a -> b -> a +a `during` b = startAt (onset b) $ stretchTo (duration b) a + +------------------------------------------------------------------------------------- +-- Composition +------------------------------------------------------------------------------------- + +infixr 6 |> +infixr 6 >| +infixr 6 <| + +-- | +-- Compose in sequence. +-- +-- @a |> b@ moves score /b/ as per 'following' and then composes the resulting scores with '<>'. +-- +-- > Score a -> Score a -> Score a +-- +(|>) :: (Semigroup a, HasOnset a, HasOffset a, Delayable a) => + a -> a -> a +-- | +-- Compose in sequence. +-- +-- @a >| b@ moves score /a/ as per 'preceding' and then composes the resulting scores with '<>'. +-- +-- > Score a -> Score a -> Score a +-- +(>|) :: (Semigroup a, HasOnset a, HasOffset a, Delayable a) => + a -> a -> a + +-- | +-- Compose in reverse sequence. +-- +-- To compose in parallel, use '<>'. +-- +-- > Score a -> Score a -> Score a +-- +(<|) :: (Semigroup a, HasOnset a, HasOffset a, Delayable a) => + a -> a -> a + +a |> b = a <> (a `following` b) +a >| b = (a `preceding` b) <> b +a <| b = b |> a + +-- | +-- Sequential catenation. +-- +-- > [Score a] -> Score a +-- +scat :: (Monoid' a, HasOnset a, HasOffset a, Delayable a) => + [a] -> a +-- | +-- Parallel catenation. +-- +-- > [Score a] -> Score a +-- +pcat :: Monoid' a => + [a] -> a + +scat = Prelude.foldr (|>) mempty +pcat = Prelude.foldr (<>) mempty + + +-- | +-- Like '<>', but scaling the second agument to the duration of the first. +-- +-- > Score a -> Score a -> Score a +-- +sustain :: (Semigroup a, Stretchable a, HasDuration a, Fractional d, d ~ Duration) => + a -> a -> a + +-- | +-- Like '|>' but with a negative delay on the second element. +-- +-- > Duration -> Score a -> Score a -> Score a +-- +anticipate :: (Semigroup a, Transformable a, HasOnset a, HasOffset a, Ord d, d ~ Duration) => + d -> a -> a -> a + +x `sustain` y = x <> duration x `stretchTo` y +anticipate t a b = a <> startAt (offset a .-^ t) b + +-- Like '<>', but truncating the second agument to the duration of the first. +-- prolong x y = x <> before (duration x) y + + +-- -------------------------------------------------------------------------------- +-- -- Structure +-- -------------------------------------------------------------------------------- + +-- | +-- Repeat exact amount of times. +-- +-- > Duration -> Score Note -> Score Note +-- +times :: (Monoid' a, Transformable a, HasOnset a, HasOffset a) => + Int -> a -> a + +-- | +-- Repeat once for each element in the list. +-- +-- Example: +-- +-- > repeated [1,2,1] (c^*) +-- +-- Simple type: +-- +-- > [a] -> (a -> Score Note) -> Score Note +-- +repeated :: (Monoid' b, Transformable b, HasOnset b, HasOffset b) => + [a] -> (a -> b) -> b + +-- | +-- Repeat a number of times and scale down by the same amount. +-- +-- > Duration -> Score a -> Score a +-- +group :: (Monoid' a, Transformable a, Fractional d, d ~ Duration, HasOnset a, HasOffset a) => + Int -> a -> a + +times n = scat . replicate n +repeated = flip (\f -> scat . fmap f) +group n = times n . (fromIntegral n `compress`) + diff --git a/src/Music/Time/Onset.hs b/src/Music/Time/Onset.hs --- a/src/Music/Time/Onset.hs +++ b/src/Music/Time/Onset.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE - TypeFamilies, - DeriveFunctor, - DeriveFoldable, - FlexibleContexts, - GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} ------------------------------------------------------------------------------------- -- | @@ -16,37 +16,81 @@ -- Stability : experimental -- Portability : non-portable (TF,GNTD) -- +-- This misleadingly named module provide a way to query a value for its +-- 'duration', 'onset' and 'offset'. +-- ------------------------------------------------------------------------------------- module Music.Time.Onset ( + -- * Duration class HasDuration(..), + stretchTo, + + -- * Onset and offset class HasOnset(..), HasOffset(..), - HasPreOnset(..), - HasPostOnset(..), - HasPostOffset(..), - -- ** Defaults + startAt, + stopAt, + withSameOnset, + withSameOffset, + + -- * Utility + -- ** Default implementations durationDefault, onsetDefault, offsetDefault, - -- ** Wrappers - AddOffset(..), ) where -import Data.Semigroup -import Data.VectorSpace -import Data.AffineSpace -import Music.Time.Pos -import Music.Time.Time -import Music.Time.Duration -import Music.Time.Delayable -import Music.Time.Stretchable +import Data.AffineSpace +import Data.AffineSpace.Point +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Semigroup +import Data.Set (Set) +import qualified Data.Set as Set +import Data.VectorSpace hiding (Sum) -class HasDuration s where - duration :: s a -> Duration s +import Music.Score.Util +import Music.Time.Delayable +import Music.Time.Stretchable +import Music.Time.Time -- | +-- Class of types with a duration. +-- +-- If a type has an instance for both 'HasOnset' and 'HasDuration', the following laws +-- should hold: +-- +-- > duration a = offset a .-. onset a +-- +class HasDuration a where + duration :: a -> Duration + +instance HasDuration Duration where + duration = id + +instance HasDuration (Duration, a) where + duration = fst + +instance HasDuration (Time, Duration, a) where + duration (t,d,x) = d + +instance HasDuration a => HasDuration (Product a) where + duration (Product x) = duration x + +-- Works for monophonic containers but not in general +-- instance HasDuration a => HasDuration [a] where + -- duration = getSum . F.foldMap (Sum . duration) + +-- | +-- Stretch a score to fit into the given duration. +-- +-- > Duration -> Score a -> Score a +-- +stretchTo :: (Stretchable a, HasDuration a) => Duration -> a -> a + +-- | -- Class of types with a position in time. -- -- Onset and offset are logical start and stop time, i.e. the preferred beginning and end @@ -54,60 +98,98 @@ -- -- 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 +-- > duration a = offset a .-- onset a -- -class HasOnset s where - -- |  +class HasOnset a where + -- | -- Get the onset of the given value. -- - onset :: s a -> Time s + onset :: a -> Time -class HasOffset s where - -- |  +class HasOffset a where + -- | -- Get the offset of the given value. -- - offset :: s a -> Time s - -class HasPreOnset s where - preOnset :: s a -> Time s + offset :: a -> Time -class HasPostOnset s where - postOnset :: s a -> Time s +instance HasOnset Time where + onset = id -class HasPostOffset s where - postOffset :: s a -> Time s +instance HasOnset (Time, a) where + onset = fst +instance HasOnset (Time, Duration, a) where + onset (t,d,x) = t + +instance HasOffset (Time, Duration, a) where + offset (t,d,x) = t .+^ d + +instance HasOnset a => HasOnset [a] where + onset = list origin (minimum . fmap onset) + +instance HasOffset a => HasOffset [a] where + offset = list origin (maximum . fmap offset) + +instance HasOnset a => HasOnset (Set a) where + onset = list origin (onset . head) . Set.toAscList + +instance HasOffset a => HasOffset (Set a) where + offset = list origin (offset . last) . Set.toAscList + +instance HasOnset k => HasOnset (Map k a) where + onset = list origin (onset . head) . Map.keys + +instance HasOffset k => HasOffset (Map k a) where + offset = list origin (offset . last) . Map.keys + +instance HasOnset a => HasOnset (Sum a) where + onset (Sum x) = onset x + +-- | +-- Move a score so that its onset is at the specific time. +-- +-- > Time -> Score a -> Score a +-- +startAt :: (HasOnset a, Delayable a) => Time -> a -> a + +-- | +-- Move a score so that its offset is at the specific time. +-- +-- > Time -> Score a -> Score a +-- +stopAt :: (HasOffset a, Delayable a) => Time -> a -> a + +t `stretchTo` x = (t / duration x) `stretch` x +t `startAt` x = (t .-. onset x) `delay` x +t `stopAt` x = (t .-. offset x) `delay` x + +-- | +-- Transform a score without affecting its onset. +-- +-- > Time -> Score a -> Score a +-- +withSameOnset :: (Delayable a, HasOnset a, HasOnset b) => (b -> a) -> b -> a + +-- | +-- Transform a score without affecting its offset. +-- +-- > Time -> Score a -> Score a +-- +withSameOffset :: (Delayable a, HasOffset a, HasOffset b) => (b -> a) -> b -> a + +withSameOnset f a = startAt (onset a) $ f a +withSameOffset f a = stopAt (offset a) $ f a + -- | Given 'HasOnset' and 'HasOffset' instances, this function implements 'duration'. -durationDefault :: (AffineSpace (Time s), HasOffset s, HasOnset s) => s a -> Duration s +durationDefault :: (HasOffset a, HasOnset a) => a -> Duration durationDefault x = offset x .-. onset x -- | Given 'HasDuration' and 'HasOffset' instances, this function implements 'onset'. -onsetDefault :: (AffineSpace (Time s), HasOffset s, HasDuration s) => s a -> Time s +onsetDefault :: (HasOffset a, HasDuration a) => a -> Time onsetDefault x = offset x .-^ duration x -- | Given 'HasOnset' and 'HasOnset' instances, this function implements 'offset'. -offsetDefault :: (AffineSpace (Time s), HasOnset s, HasDuration s) => s a -> Time s +offsetDefault :: (HasOnset a, HasDuration a) => a -> Time offsetDefault x = onset x .+^ duration x - -newtype AddOffset t s a = AddOffset (t, s a) - -type instance Time (AddOffset t s) = t - -instance (Delayable a, t ~ Time a) => Delayable (AddOffset t a) where - delay d (AddOffset (t,a)) = AddOffset (t, delay d a) - -instance (Stretchable a, t ~ Time a) => Stretchable (AddOffset t a) where - stretch d (AddOffset (t,a)) = AddOffset (t, stretch d a) - -instance (HasOnset a, t ~ Time a) => HasOnset (AddOffset t a) where - onset (AddOffset (t,a)) = onset a - -instance HasOffset (AddOffset t s) where - offset (AddOffset (t,_)) = t diff --git a/src/Music/Time/Performable.hs b/src/Music/Time/Performable.hs deleted file mode 100644 --- a/src/Music/Time/Performable.hs +++ /dev/null @@ -1,59 +0,0 @@ - -{-# LANGUAGE - TypeFamilies, - DeriveFunctor, - DeriveFoldable, - RankNTypes, - GeneralizedNewtypeDeriving #-} - -------------------------------------------------------------------------------------- --- | --- Copyright : (c) Hans Hoglund 2012 --- --- License : BSD-style --- --- Maintainer : hans@hanshoglund.se --- Stability : experimental --- Portability : non-portable (TF,GNTD) --- -------------------------------------------------------------------------------------- - -module Music.Time.Performable ( - Performable(..), - foldMapDefault, - ) where - -import Data.Foldable (Foldable(..)) - -import Data.Semigroup -import Music.Time.Pos -import Music.Time.Time -import Music.Time.Duration -import Music.Time.Delayable -import Music.Time.Stretchable - --- | --- Performable values. --- --- Minimal complete definition: 'perform'. --- -class Foldable s => Performable s where - - -- | Perform a score. - -- - -- This is the inverse of 'compose' - -- - perform :: (t ~ Time s, d ~ Duration s) => s a -> [(t, d, a)] - - -- | Perform a score, yielding an ordered list of values. - -- - -- Equivalent to 'Foldable.toList', but may be more efficient. - -- - toList' :: s a -> [a] - toList' = map trd3 . perform - where - trd3 (a,b,c) = c - --- | This function may be used as a value for 'foldMap' in a 'Foldable' instance. -foldMapDefault :: (Performable s, Monoid m) => (a -> m) -> s a -> m -foldMapDefault f = foldMap f . toList' diff --git a/src/Music/Time/Pos.hs b/src/Music/Time/Pos.hs deleted file mode 100644 --- a/src/Music/Time/Pos.hs +++ /dev/null @@ -1,70 +0,0 @@ - -{-# LANGUAGE - TypeFamilies, - DeriveFunctor, - DeriveFoldable, - GeneralizedNewtypeDeriving #-} - -------------------------------------------------------------------------------------- --- | --- Copyright : (c) Hans Hoglund 2012 --- --- License : BSD-style --- --- Maintainer : hans@hanshoglund.se --- Stability : experimental --- Portability : non-portable (TF,GNTD) --- -------------------------------------------------------------------------------------- - -module Music.Time.Pos ( - Time(..), - Duration(..), - ) where - -import Data.AffineSpace -import Music.Time.Time -import Music.Time.Duration - --- | --- This type function returns the time type for a given type. --- --- It has kind --- --- > (* -> *) -> * --- --- meaning that an instance should be written on the form: --- --- > type instance Time a = b --- --- where /a/ and /b/ are type-level expression of kind @* -> *@ and @*@ respectively. --- -type family Time (s :: * -> *) :: * - --- | --- This type function returns the duration type for a given type. --- -type Duration a = Diff (Time a) - -{- - -type instance Time Double = Double -type instance Time Rational = Rational -type instance Time (a -> b) = Time b -type instance Time [a] = Time a -type instance Time (Maybe a) = Time a - --- TODO move -type instance Time TimeT = TimeT -type instance Time DurationT = DurationT --} - - --- type instance Pos (Option a) = Pos a --- type instance Pos (Set a) = Pos a --- type instance Pos (Map k a) = Pos a - - - - - diff --git a/src/Music/Time/Reactive.hs b/src/Music/Time/Reactive.hs new file mode 100644 --- /dev/null +++ b/src/Music/Time/Reactive.hs @@ -0,0 +1,272 @@ + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ViewPatterns #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +-- Reactive values, or piecewise functions of time. +-- +-- Similar to Conal's definition in , +-- but defined in negative time as well. Its semantics function is either 'occs' @&&&@ '?' +-- /or/ 'initial' @&&&@ 'updates', where 'intial' is the value from negative infinity +-- to the first update. +-- +-- TODO integrate better in the library +-- +------------------------------------------------------------------------------------- + +module Music.Time.Reactive ( + Reactive, + + -- * Create, isos etc (TODO) + initial, + final, + Future, + Past, + updates, + resets, + occs, + + -- * Predicates + isConstant, + isVariable, + + -- * Combinators + step, + switch, + trim, + trimBefore, + trimAfter, + + -- * Semantics + -- renderR, + -- renderR', + -- printR, + ) where + +import Control.Applicative +import Control.Arrow +import Control.Lens +import Control.Monad +import Control.Monad.Compose +import Control.Monad.Plus +import Data.AffineSpace +import Data.AffineSpace.Point +import Data.Foldable (Foldable) +import qualified Data.Foldable as F +import qualified Data.List as List +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Semigroup +import Data.Set (Set) +import qualified Data.Set as Set +import Data.String +import Data.Traversable (Traversable) +import qualified Data.Traversable as T +import Data.Typeable +import Data.VectorSpace + +import Music.Time.Delayable +import Music.Time.Span +import Music.Time.Stretchable +import Music.Time.Time +import Music.Time.Time +-- import Music.Score.Note +-- import Music.Score.Track +-- import Music.Score.Pitch +-- import Music.Score.Util +-- import Music.Pitch.Literal +-- import Music.Dynamics.Literal + +newtype Reactive a = Reactive { getReactive :: ([Time], Time -> a) } + deriving (Functor, Semigroup, Monoid) + +instance Delayable (Reactive a) where + delay n (Reactive (t,r)) = Reactive (delay n t, delay n r) + +instance Stretchable (Reactive a) where + stretch n (Reactive (t,r)) = Reactive (stretch n t, stretch n r) + +instance Wrapped (Reactive a) where + type Unwrapped (Reactive a) = ([Time], Time -> a) + _Wrapped' = iso getReactive Reactive + +instance Applicative Reactive where + pure = (^. _Unwrapped') . pure . pure + ((^. _Wrapped') -> (tf, rf)) <*> ((^. _Wrapped') -> (tx, rx)) = (^. _Unwrapped') (tf <> tx, rf <*> rx) + +instance HasBehavior Reactive where + (?) = atTime + +instance IsString a => IsString (Reactive a) where + fromString = pure . fromString + +instance Eq (Reactive b) where + (==) = error "(==)" + (/=) = error "(/=)" + +instance Ord b => Ord (Reactive b) where + min = liftA2 min + max = liftA2 max + +instance Enum a => Enum (Reactive a) where + succ = fmap succ + pred = fmap pred + toEnum = pure . toEnum + fromEnum = error "fromEnum" + enumFrom = error "enumFrom" + enumFromThen = error "enumFromThen" + enumFromTo = error "enumFromTo" + enumFromThenTo = error "enumFromThenTo" + +instance Num a => Num (Reactive a) where + (+) = liftA2 (+) + (*) = liftA2 (*) + (-) = liftA2 (-) + abs = fmap abs + signum = fmap signum + fromInteger = pure . fromInteger + +instance (Num a, Ord a) => Real (Reactive a) where + toRational = error "toRational" + +instance Integral a => Integral (Reactive a) where + quot = liftA2 quot + rem = liftA2 rem + div = liftA2 div + mod = liftA2 mod + quotRem = (fmap.fmap) unzip' (liftA2 quotRem) + divMod = (fmap.fmap) unzip' (liftA2 divMod) + toInteger = error "toInteger" + +instance Fractional b => Fractional (Reactive b) where + recip = fmap recip + fromRational = pure . fromRational + +instance Floating b => Floating (Reactive b) where + pi = pure pi + sqrt = fmap sqrt + exp = fmap exp + log = fmap log + sin = fmap sin + cos = fmap cos + asin = fmap asin + atan = fmap atan + acos = fmap acos + sinh = fmap sinh + cosh = fmap cosh + asinh = fmap asinh + atanh = fmap atanh + acosh = fmap acosh + +instance AdditiveGroup v => AdditiveGroup (Reactive v) where + zeroV = pure zeroV + (^+^) = liftA2 (^+^) + negateV = liftA negateV + +instance VectorSpace v => VectorSpace (Reactive v) where + type Scalar (Reactive v) = Scalar v + (*^) s = fmap (s *^) + + +-- | Get the time of all updatese. +occs :: Reactive a -> [Time] +occs = fst . (^. _Wrapped') + +-- | @b ?? t@ returns the value of the reactive at time @t@. +-- Semantic function. +atTime :: Reactive a -> Time -> a +atTime = snd . (^. _Wrapped') + +-- | Get the initial value. +initial :: Reactive a -> a +initial r = r ? minB (occs r) + where + -- If there are no updates, just use value at time 0 + -- Otherwise pick an arbitrary time /before/ the first value + -- It looks strange but it works + minB [] = 0 + minB (x:_) = x - 1 + +-- | Get the time of all updates and the value switched to at this point. +updates :: Reactive a -> [Future a] +updates r = (\t -> (t, r ? t)) <$> (List.sort . List.nub) (occs r) + +-- | Get the final value. +final :: Reactive a -> a +final (renderR -> (i,[])) = i +final (renderR -> (i,xs)) = snd $ last xs + +-- | @switch t a b@ behaves as @a@ before time @t@, then as @b@. +switch :: Time -> Reactive a -> Reactive a -> Reactive a +switch t (Reactive (tx, rx)) (Reactive (ty, ry)) = Reactive $ (,) + (filter (< t) tx <> [t] <> filter (> t) ty) + (\u -> if u < t then rx u else ry u) + + + +-- TODO separate these with newtype +type Future a = (Time, a) +type Past a = (Time, a) + +isConstant :: Reactive a -> Bool +isConstant = null . occs + +isVariable :: Reactive a -> Bool +isVariable = not . isConstant + +resets :: Reactive a -> [Past a] +resets = error "resets: Not impl" + +-- | The unit step function, which goes from 0 to 1 at 'start'. +step :: (AdditiveGroup a, Fractional a) => Reactive a +step = switch start zeroV 1.0 -- TODO some overloaded unit + +-- | Replace everthing outside the given span by `mempty`. +trim :: Monoid a => Span -> Reactive a -> Reactive a +trim (view range -> (t,u)) = trimBefore t . trimAfter u + +-- | Replace everthing before the given time by `mempty`. +trimBefore :: Monoid a => Time -> Reactive a -> Reactive a +trimBefore start x = switch start mempty x + +-- | Replace everthing after the given time by `mempty`. +trimAfter :: Monoid a => Time -> Reactive a -> Reactive a +trimAfter stop x = switch stop x mempty + +-- | Semantic function. +renderR :: Reactive a -> (a, [(Time, a)]) +renderR = initial &&& updates + +-- | Semantic function. +renderR' :: Reactive a -> ([Time], Time -> a) +renderR' = occs &&& (?) + + +printR :: Show a => Reactive a -> IO () +printR r = let (x, xs) = renderR r in do + print x + mapM_ print xs + +unzip' :: Functor f => f (a, b) -> (f a, f b) +unzip' r = (fst <$> r, snd <$> r) diff --git a/src/Music/Time/Reverse.hs b/src/Music/Time/Reverse.hs new file mode 100644 --- /dev/null +++ b/src/Music/Time/Reverse.hs @@ -0,0 +1,119 @@ + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +-- Provides reversible values. +-- +------------------------------------------------------------------------------------- + +module Music.Time.Reverse ( + -- * Reversible class + Reversible(..), + + -- ** Utility + NoRev(..), + WithRev(..), + withRev, + fromWithRev, + ) where + +import Data.AffineSpace +import Data.AffineSpace.Point +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Ratio +import Data.Semigroup +import Data.Set (Set) +import qualified Data.Set as Set +import Data.VectorSpace + +import Music.Time.Delayable +import Music.Time.Juxtapose +import Music.Time.Onset +import Music.Time.Stretchable +import Music.Time.Time + +-- | +-- Reversible values. +-- +-- For instances of 'Reversible' and 'HasOnset', the following laws should hold: +-- +-- > onset a = onset (rev a) +-- > duration a = duration (rev a) +-- +-- For structural types, 'rev' is applied recursively, hence the constraint on +-- the 'Score' instance. 'rev' is id by default, so for a trivial type @T@ it +-- suffices to write +-- +-- > instance Reversible T +-- +-- For instances 'U' of 'HasOnset' and 'Transformable', a suitable instance +-- is +-- +-- > instance Reversible T where +-- > rev = withSameOnset (stretch (-1)) +-- +-- +class Reversible a where + + -- | + -- Reverse a value. + -- + -- Reverse is an involution, meaning that: + -- + -- > rev (rev a) = a + -- + rev :: a -> a + rev = id + +-- instance Reversible Time where + -- rev t = mirror t + +instance Reversible Double +instance Reversible Float +instance Reversible Int +instance Reversible Integer +instance Reversible () +instance Reversible (Ratio a) + +instance Reversible a => Reversible [a] where + rev = fmap rev + +instance (Ord a, Reversible a) => Reversible (Set a) where + rev = Set.map rev + +instance Reversible a => Reversible (Map k a) where + rev = fmap rev + +newtype NoRev a = NoRev { getNoRev :: a } + deriving (Eq, Ord, Enum, Show, Semigroup, Monoid, + Delayable, Stretchable, HasOnset, HasOffset, HasDuration) + +instance Reversible (NoRev a) where + rev = id + + + +newtype WithRev a = WithRev (a,a) + deriving (Eq, Ord, Semigroup, Monoid) + +withRev :: Reversible a => a -> WithRev a +withRev x = WithRev (rev x, x) + +fromWithRev :: Reversible a => WithRev a -> a +fromWithRev (WithRev (_,x)) = x + +instance Reversible a => Reversible (WithRev a) where + rev (WithRev (r,x)) = WithRev (x,r) + + + diff --git a/src/Music/Time/Span.hs b/src/Music/Time/Span.hs new file mode 100644 --- /dev/null +++ b/src/Music/Time/Span.hs @@ -0,0 +1,198 @@ + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +-- Provides time spans. +-- +------------------------------------------------------------------------------------- + +module Music.Time.Span ( + Span, + -- inSpan, + + -- ** Constructing spans + (<->), + (>->), + era, + + -- ** Deconstructing spans + -- _range, + -- _delta, + range, + delta, + -- mapRange, + -- mapDelta, + + -- ** Span as transformation + sunit, + sapp, + sunder, + sinvert, + ) where + +import Control.Arrow +import Control.Lens +import Data.AffineSpace +import Data.AffineSpace.Point +import Data.Semigroup +import Data.VectorSpace + +import Music.Time.Delayable +import Music.Time.Onset +import Music.Time.Reverse +import Music.Time.Stretchable +import Music.Time.Time + +-- | +-- A 'Span' represents two points in time @u@ and @v@ where @t <= u@ or, equivalently, +-- a time @t@ and a duration @d@ where @d >= 0@. +-- +-- A third way of looking at 'Span' is that it represents a time transformation where +-- onset is translation and duration is scaling. +-- +newtype Span = Span (Time, Duration) + deriving (Eq, Ord, Show) + +-- normalizeSpan :: Span -> Span +-- normalizeSpan (Span (t,d)) + -- | d >= 0 = t <-> (t .+^ d) + -- | d < 0 = (t .+^ d) <-> t + +{- + "Applying a transformation t to a Located a results in the transformation being + applied to the location, and the linear portion of t being applied to the value of + type a (i.e. it is not translated)." + + -- Diagrams Haddocks +-} +instance Delayable Span where + delay n = delta %~ first (delay n) + +instance Stretchable Span where + stretch n = delta %~ (stretch n *** stretch n) + + +instance HasOnset Span where + onset = fst . _range + +instance HasOffset Span where + offset = snd . _range + +instance HasDuration Span where + duration = snd . _delta + +instance Semigroup Span where + -- Span (t1, d1) <> Span (t2, d2) = Span (t1 `delayTime` (d1 `stretch` t2), d1 `stretch` d2) + (<>) = sapp + + +instance Monoid Span where + mempty = start <-> stop + mappend = (<>) + +inSpan f = Span . f . _delta + +-- | +-- The default span, i.e. 'start' '<->' 'stop'. +-- +sunit :: Span +sunit = mempty + +-- | @t \<-\> u@ represents the span between @t@ and @u@. +(<->) :: Time -> Time -> Span +(<->) t u = t >-> (u .-. t) + +-- | @t >-> d@ represents the span between @t@ and @t .+^ d@. +(>->) :: Time -> Duration -> Span +t >-> d = Span (t,d) + -- | d > 0 = Span (t,d) + -- | otherwise = error "Invalid span" + +-- | Get the era (onset to offset) of a given value. +era :: (HasOnset a, HasOffset a) => a -> Span +era x = onset x <-> offset x + +_delta :: Span -> (Time, Duration) +_delta (Span x) = x + +_range :: Span -> (Time, Time) +_range x = let (t, d) = _delta x + in (t, t .+^ d) + +-- | Map over the span as onset and duration. +mapDelta :: (Time -> Duration -> (Time, Duration)) -> Span -> Span +mapDelta f = delta %~ uncurry f + +-- | Map over the span as a time pair. +mapRange :: (Time -> Time -> (Time, Time)) -> Span -> Span +mapRange f = range %~ uncurry f + +-- | +-- View a span as onset and offset. +-- +-- Typically used with the @ViewPatterns@ extension, as in +-- +-- > foo (view range -> (u,v)) = ... +-- +range :: Iso' Span (Time, Time) +range = iso _range $ uncurry (<->) + +-- | +-- View a span as a time and duration. +-- +-- Typically used with the @ViewPatterns@ extension, as in +-- +-- > foo (view delta -> (t,d)) = ... +-- +delta :: Iso' Span (Time, Duration) +delta = iso _delta $ uncurry (>->) + +-- | Apply a span transformation. +sapp :: (Delayable a, Stretchable a) => Span -> a -> a +sapp (view delta -> (t,d)) = delayTime t . stretch d + +-- | Apply a function under a span transformation. +sunder :: (Delayable a, Stretchable a, Delayable b, Stretchable b) => Span -> (a -> b) -> a -> b +-- sunder s f = sapp (sinvert s) . f . sapp s + +sunder s f = sappInv s . f . sapp s +sappInv (view delta -> (t,d)) = stretch (recip d) . delayTime (mirror t) + +-- | The inversion of a span. +-- +-- > sinvert (sinvert s) = s +-- > sapp (sinvert s) . sapp s = id +-- +sinvert :: Span -> Span +sinvert (Span (t,d)) = Span (mirror t, recip d) + +-- TODO add "individual scaling" component, i.e. scale just duration not both time and duration +-- Useful for implementing separation in articulation etc + +deriving instance Delayable a => Delayable (NoStretch a) +deriving instance HasOnset a => HasOnset (NoStretch a) +deriving instance HasOffset a => HasOffset (NoStretch a) +deriving instance HasDuration a => HasDuration (NoStretch a) + +deriving instance Stretchable a => Stretchable (NoDelay a) +deriving instance HasOnset a => HasOnset (NoDelay a) +deriving instance HasOffset a => HasOffset (NoDelay a) +deriving instance HasDuration a => HasDuration (NoDelay a) + + diff --git a/src/Music/Time/Stretchable.hs b/src/Music/Time/Stretchable.hs --- a/src/Music/Time/Stretchable.hs +++ b/src/Music/Time/Stretchable.hs @@ -1,11 +1,12 @@ -{-# LANGUAGE - TypeFamilies, - DeriveFunctor, - DeriveFoldable, - FlexibleContexts, - ConstraintKinds, - GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} ------------------------------------------------------------------------------------- -- | @@ -17,34 +18,93 @@ -- Stability : experimental -- Portability : non-portable (TF,GNTD) -- +-- Provides stretchable values. +-- ------------------------------------------------------------------------------------- module Music.Time.Stretchable ( + -- * Stretchable class Stretchable(..), - ) where + compress, + stretching, -import Data.Semigroup -import Data.VectorSpace -import Data.AffineSpace + -- ** Utility + NoStretch(..), + ) where -import Music.Time.Time -import Music.Time.Duration -import Music.Time.Pos +import Control.Arrow --- -- | --- -- Stretchable values. --- -- --- type Stretchable a = (VectorSpace a, Scalar a ~ Duration) +import Data.AffineSpace +import Data.AffineSpace.Point +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Semigroup +import Data.Set (Set) +import qualified Data.Set as Set +import Data.VectorSpace hiding (Sum) +import Music.Time.Time -- | --- Stretchable values. --- -class Stretchable s where +-- Stretchable values. +-- +class Stretchable a where -- | -- Stretch (augment) a value by the given factor. - -- - -- > Duration -> Score a -> Score a - -- - stretch :: Duration s -> s a -> s a + -- + stretch :: Duration -> a -> a + stretch _ = id + +instance Stretchable Time where + stretch n = (n*.) + +instance Stretchable Duration where + stretch n = (n*^) + +instance Stretchable (Time, a) where + stretch n (t, a) = (n `stretch` t, a) + +instance Stretchable (Duration, a) where + stretch n (d, a) = (n `stretch` d, a) + +instance Stretchable (Time, Duration, a) where + stretch n (t, d, a) = (n `stretch` t, n `stretch` d, a) + +instance Stretchable (Time -> a) where + stretch n = (. relative origin (^/ n)) + +instance Stretchable (Duration -> a) where + stretch n = (. (^/ n)) + +instance Stretchable a => Stretchable [a] where + stretch n = fmap (stretch n) + +instance Stretchable a => Stretchable (Map k a) where + stretch n = fmap (stretch n) + +instance Stretchable a => Stretchable (Product a) where + stretch n (Product x) = Product (stretch n x) + +instance Stretchable a => Stretchable (Sum a) where + stretch n (Sum x) = Sum (stretch n x) + + +-- | +-- Compress (diminish) a score. Flipped version of 'stretch'. +-- +compress :: Stretchable a => Duration -> a -> a +compress x = stretch (recip x) + +-- | Apply a function under stretch. +-- See also 'sunder'. +stretching :: (Stretchable a, Stretchable b) => Duration -> (a -> b) -> a -> b +stretching t f = compress t . f . stretch t + + +newtype NoStretch a = NoStretch { getNoStretch :: a } + deriving (Eq, Ord, Enum, Show, Semigroup, Monoid + {-Delayable, HasOnset, HasOffset, HasDuration-}) + +instance Stretchable (NoStretch a) where + stretch _ = id diff --git a/src/Music/Time/Time.hs b/src/Music/Time/Time.hs --- a/src/Music/Time/Time.hs +++ b/src/Music/Time/Time.hs @@ -1,9 +1,7 @@ -{-# LANGUAGE - TypeFamilies, - DeriveFunctor, - DeriveFoldable, - GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeFamilies #-} ------------------------------------------------------------------------------------- -- | @@ -18,56 +16,98 @@ ------------------------------------------------------------------------------------- module Music.Time.Time ( - TimeT, - fromTimeT, - toTimeT + -- $convert + + -- * Time type + Time(..), + + -- * Duration type + Duration, + + -- * Behavior class + HasBehavior(..), + + -- ** Identities + start, + stop, + unit, + + -- ** Combinators + -- TODO ) where -import Data.Semigroup -import Data.VectorSpace -import Data.AffineSpace +import Data.AffineSpace +import Data.AffineSpace.Point +import Data.Semigroup +import Data.VectorSpace -import Music.Time.Duration +import Music.Score.Util (showRatio) -------------------------------------------------------------------------------------- --- Time type -------------------------------------------------------------------------------------- +-- $convert +-- +-- Note that you should use '.-.' and '.+^' to convert between time and +-- duration. To refer to time zero (the beginning of the music), use +-- 'origin'. +-- -- | --- This type represents absolute time in seconds since the start time. Note --- that time can be negative, representing events occuring before the start time. --- The start time is usually the the beginning of the musical performance. +-- This type represents relative time in seconds. -- +newtype Duration = Duration { getDuration :: Rational } + deriving (Eq, Ord, Num, Enum, Fractional, Real, RealFrac, AdditiveGroup) + +instance Show Duration where + show = showRatio . getDuration + +instance VectorSpace Duration where + type Scalar Duration = Duration + (Duration x) *^ (Duration y) = Duration (x *^ y) + +-- | +-- The unit duration. +-- +unit :: Duration +unit = 1 -- TODO some overloaded unit value + +-- | +-- This type represents absolute time in seconds since 'start'. Note that time can be +-- negative, representing events occuring before the start time. +-- -- Time 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 '.+^', +-- 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 TimeT = TimeT { getTimeT :: Rational } - deriving (Eq, Ord, Num, Enum, Real, Fractional, RealFrac) +type Time = Point Duration -instance Show TimeT where - show = show . getTimeT +instance Num Time where + (+) = relative2 origin (+) + (*) = relative2 origin (*) + negate = mirror + abs = relative origin abs + signum = relative origin signum + fromInteger = (origin .+^) . fromInteger +instance Fractional Time where + recip = relative origin recip + fromRational = (origin .+^) . fromRational -instance AdditiveGroup TimeT where - zeroV = 0 - (^+^) = (+) - negateV = negate +-- | +-- The global start time, which usually means the the beginning of the musical performance. +-- +-- This is a synonym for 'origin'. +-- +start :: Time +start = origin -instance VectorSpace TimeT where - type Scalar TimeT = TimeT - (*^) = (*) +-- | +-- The global end time, defined as @start .+^ unit@. +-- +stop :: Time +stop = origin .+^ unit -instance InnerSpace TimeT where - (<.>) = (*) -instance AffineSpace TimeT where - type Diff TimeT = DurationT - a .-. b = fromTimeT $ a - b - a .+^ b = a + fromDurationT b - -fromTimeT :: Fractional a => TimeT -> a -fromTimeT = fromRational . getTimeT +class HasBehavior f where + (?) :: f a -> Time -> a -toTimeT :: Real a => a -> TimeT -toTimeT = TimeT . toRational +instance HasBehavior ((->) Time) where + (?) = id