module Music.Time.Voice (
Voice,
voice,
stretcheds,
eventsV,
singleStretched,
fuse,
fuseBy,
fuseRests,
coverRests,
valuesV,
durationsV,
withValues,
withDurations,
rotateValues,
rotateDurations,
reverseValues,
reverseDurations,
unzipVoice,
zipVoice,
zipVoice3,
zipVoice4,
zipVoiceNoScale,
zipVoiceNoScale3,
zipVoiceNoScale4,
zipVoiceWith,
zipVoiceWith',
zipVoiceWithNoScale,
withContext,
voiceLens,
voiceAsList,
listAsVoice,
unsafeStretcheds,
unsafeEventsV,
) where
import Data.AffineSpace
import Data.AffineSpace.Point
import Data.Functor.Adjunction (unzipR)
import Data.Functor.Context
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
import Data.Ratio
import Data.Semigroup
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Data.String
import Data.VectorSpace
import Music.Time.Reverse
import Music.Time.Split
import Music.Time.Stretched
import Control.Applicative
import Control.Lens hiding (Indexable, Level, above,
below, index, inside, parts,
reversed, transform, (<|), (|>))
import Control.Monad
import Control.Monad.Compose
import Control.Monad.Plus
import Data.Foldable (Foldable)
import qualified Data.Foldable as Foldable
import qualified Data.List
import Data.List.NonEmpty (NonEmpty)
import Data.Traversable (Traversable)
import qualified Data.Traversable as T
import Data.Typeable
import Music.Dynamics.Literal
import Music.Pitch.Literal
import Music.Time.Internal.Util
newtype Voice a = Voice { getVoice :: VoiceList (VoiceEv a) }
deriving (Functor, Foldable, Traversable, Semigroup, Monoid, Typeable, Eq)
instance (Show a, Transformable a) => Show (Voice a) where
show x = show (x^.stretcheds) ++ "^.voice"
type VoiceList = []
type VoiceEv a = Stretched a
voiceEv :: Iso (Stretched a) (Stretched b) (VoiceEv a) (VoiceEv b)
voiceEv = id
instance Applicative Voice where
pure = return
(<*>) = ap
instance Alternative Voice where
(<|>) = (<>)
empty = mempty
instance Monad Voice where
return = view _Unwrapped . return . return
xs >>= f = view _Unwrapped $ (view _Wrapped . f) `mbind` view _Wrapped xs
instance MonadPlus Voice where
mzero = mempty
mplus = mappend
instance Wrapped (Voice a) where
type Unwrapped (Voice a) = (VoiceList (VoiceEv a))
_Wrapped' = iso getVoice Voice
instance Rewrapped (Voice a) (Voice b)
instance Cons (Voice a) (Voice b) (Stretched a) (Stretched b) where
_Cons = prism (\(s,v) -> (view voice.return $ s) <> v) $ \v -> case view stretcheds v of
[] -> Left mempty
(x:xs) -> Right (x, view voice xs)
instance Snoc (Voice a) (Voice b) (Stretched a) (Stretched b) where
_Snoc = prism (\(v,s) -> v <> (view voice.return $ s)) $ \v -> case unsnoc (view stretcheds v) of
Nothing -> Left mempty
Just (xs, x) -> Right (view voice xs, x)
instance Transformable (Voice a) where
transform s = over _Wrapped' (transform s)
instance HasDuration (Voice a) where
_duration = Foldable.sum . fmap _duration . view _Wrapped'
instance Splittable a => Splittable (Voice a) where
split t x
| t <= 0 = (mempty, x)
| t >= _duration x = (x, mempty)
| otherwise = let (a,b) = split' t (x^._Wrapped) in (a^._Unwrapped, b^._Unwrapped)
where
split' = error "TODO"
instance Reversible a => Reversible (Voice a) where
rev = over _Wrapped' (fmap rev)
instance IsString a => IsString (Voice a) where
fromString = pure . fromString
instance IsPitch a => IsPitch (Voice a) where
fromPitch = pure . fromPitch
instance IsInterval a => IsInterval (Voice a) where
fromInterval = pure . fromInterval
instance IsDynamics a => IsDynamics (Voice a) where
fromDynamics = pure . fromDynamics
instance Enum a => Enum (Voice a) where
toEnum = return . toEnum
fromEnum = list 0 (fromEnum . head) . Foldable.toList
instance Num a => Num (Voice a) where
fromInteger = return . fromInteger
abs = fmap abs
signum = fmap signum
(+) = error "Not implemented"
() = error "Not implemented"
(*) = error "Not implemented"
instance AdditiveGroup (Voice a) where
zeroV = error "Not implemented"
(^+^) = error "Not implemented"
negateV = error "Not implemented"
instance VectorSpace (Voice a) where
type Scalar (Voice a) = Duration
d *^ s = d `stretch` s
voice :: Getter [Stretched a] (Voice a)
voice = from unsafeStretcheds
stretcheds :: Lens (Voice a) (Voice b) [Stretched a] [Stretched b]
stretcheds = unsafeStretcheds
eventsV :: Lens (Voice a) (Voice b) [(Duration, a)] [(Duration, b)]
eventsV = unsafeEventsV
unsafeEventsV :: Iso (Voice a) (Voice b) [(Duration, a)] [(Duration, b)]
unsafeEventsV = iso (map (^.from stretched) . (^.stretcheds)) ((^.voice) . map (^.stretched))
unsafeStretcheds :: Iso (Voice a) (Voice b) [Stretched a] [Stretched b]
unsafeStretcheds = _Wrapped
singleStretched :: Prism' (Voice a) (Stretched a)
singleStretched = unsafeStretcheds . single
unzipVoice :: Voice (a, b) -> (Voice a, Voice b)
unzipVoice = unzipR
zipVoice :: Voice a -> Voice b -> Voice (a, b)
zipVoice = zipVoiceWith (,)
zipVoice3 :: Voice a -> Voice b -> Voice c -> Voice (a, (b, c))
zipVoice3 a b c = zipVoice a (zipVoice b c)
zipVoice4 :: Voice a -> Voice b -> Voice c -> Voice d -> Voice (a, (b, (c, d)))
zipVoice4 a b c d = zipVoice a (zipVoice b (zipVoice c d))
zipVoice5 :: Voice a -> Voice b -> Voice c -> Voice d -> Voice e -> Voice (a, (b, (c, (d, e))))
zipVoice5 a b c d e = zipVoice a (zipVoice b (zipVoice c (zipVoice d e)))
zipVoiceNoScale :: Voice a -> Voice b -> Voice (a, b)
zipVoiceNoScale = zipVoiceWithNoScale (,)
zipVoiceNoScale3 :: Voice a -> Voice b -> Voice c -> Voice (a, (b, c))
zipVoiceNoScale3 a b c = zipVoiceNoScale a (zipVoiceNoScale b c)
zipVoiceNoScale4 :: Voice a -> Voice b -> Voice c -> Voice d -> Voice (a, (b, (c, d)))
zipVoiceNoScale4 a b c d = zipVoiceNoScale a (zipVoiceNoScale b (zipVoiceNoScale c d))
zipVoiceNoScale5 :: Voice a -> Voice b -> Voice c -> Voice d -> Voice e -> Voice (a, (b, (c, (d, e))))
zipVoiceNoScale5 a b c d e = zipVoiceNoScale a (zipVoiceNoScale b (zipVoiceNoScale c (zipVoiceNoScale d e)))
zipVoiceWith :: (a -> b -> c) -> Voice a -> Voice b -> Voice c
zipVoiceWith = zipVoiceWith' (*)
zipVoiceWithNoScale :: (a -> b -> c) -> Voice a -> Voice b -> Voice c
zipVoiceWithNoScale = zipVoiceWith' const
zipVoiceWith' :: (Duration -> Duration -> Duration) -> (a -> b -> c) -> Voice a -> Voice b -> Voice c
zipVoiceWith' f g
((unzip.view eventsV) -> (ad, as))
((unzip.view eventsV) -> (bd, bs))
= let cd = zipWith f ad bd
cs = zipWith g as bs
in view (from unsafeEventsV) (zip cd cs)
fuse :: Eq a => Voice a -> Voice a
fuse = fuseBy (==)
fuseBy :: (a -> a -> Bool) -> Voice a -> Voice a
fuseBy p = fuseBy' p head
fuseBy' :: (a -> a -> Bool) -> ([a] -> a) -> Voice a -> Voice a
fuseBy' p g = over unsafeEventsV $ fmap foldNotes . Data.List.groupBy (inspectingBy snd p)
where
foldNotes (unzip -> (ds, as)) = (sum ds, g as)
fuseRests :: Voice (Maybe a) -> Voice (Maybe a)
fuseRests = fuseBy (\x y -> isNothing x && isNothing y)
coverRests :: Voice (Maybe a) -> Maybe (Voice a)
coverRests x = if hasOnlyRests then Nothing else Just (fmap fromJust $fuseBy merge x)
where
norm = fuseRests x
merge Nothing Nothing = error "Voice normalized, so consecutive rests are impossible"
merge (Just x) Nothing = True
merge Nothing (Just x) = True
merge (Just x) (Just y) = False
hasOnlyRests = all isNothing $ toListOf traverse x
withContext :: Voice a -> Voice (Ctxt a)
withContext = over valuesV (fmap Ctxt . withPrevNext)
voiceFromRhythm :: [Duration] -> Voice ()
voiceFromRhythm = mkVoice . fmap (, ())
mkVoice = view voice . fmap (view stretched)
durationsV :: Lens' (Voice a) [Duration]
durationsV = lens getDurs (flip setDurs)
where
getDurs :: Voice a -> [Duration]
getDurs = map fst . view eventsV
setDurs :: [Duration] -> Voice a -> Voice a
setDurs ds as = zipVoiceWith' (\a b -> a) (\a b -> b) (mconcat $ map durToVoice ds) as
durToVoice d = stretch d $ pure ()
valuesV :: Lens (Voice a) (Voice b) [a] [b]
valuesV = lens getValues (flip setValues)
where
getValues :: Voice a -> [a]
getValues = map snd . view eventsV
setValues :: [a] -> Voice b -> Voice a
setValues as bs = zipVoiceWith' (\a b -> b) (\a b -> a) (listToVoice as) bs
listToVoice = mconcat . map pure
withDurations :: ([Duration] -> [Duration]) -> Voice a -> Voice a
withDurations = over durationsV
withValues :: ([a] -> [b]) -> Voice a -> Voice b
withValues = over valuesV
rotateDurations :: Int -> Voice a -> Voice a
rotateDurations n = over durationsV (rotate n)
rotateValues :: Int -> Voice a -> Voice a
rotateValues n = over valuesV (rotate n)
reverseDurations :: Voice a -> Voice a
reverseDurations = over durationsV reverse
reverseValues :: Voice a -> Voice a
reverseValues = over valuesV reverse
voiceLens :: (s -> a) -> (b -> s -> t) -> Lens (Voice s) (Voice t) (Voice a) (Voice b)
voiceLens getter setter = lens (fmap getter) (flip $ zipVoiceWithNoScale setter)
voiceL l = voiceLens (view $ cloneLens l) (set $ cloneLens l)
voiceAsList :: Iso (Voice a) (Voice b) [a] [b]
voiceAsList = iso voiceToList listToVoice
where
voiceToList = map snd . view eventsV
listToVoice = mconcat . fmap pure
listAsVoice :: Iso [a] [b] (Voice a) (Voice b)
listAsVoice = from voiceAsList
headV, lastV :: Voice a -> Maybe (Stretched a)
headV = preview _head
lastV = preview _head
tailV, initV :: Voice a -> Maybe (Voice a)
tailV = preview _tail
initV = preview _init
consV :: Stretched a -> Voice a -> Voice a
unconsV :: Voice a -> Maybe (Stretched a, Voice a)
consV = cons
unconsV = uncons
snocV :: Voice a -> Stretched a -> Voice a
unsnocV :: Voice a -> Maybe (Voice a, Stretched a)
snocV = snoc
unsnocV = unsnoc
nullV :: Voice a -> Bool
nullV = nullOf eventsV
lengthV :: Voice a -> Int
lengthV = lengthOf eventsV
mapV :: (a -> b) -> Voice a -> Voice b
mapV = fmap
sameDurations :: Voice a -> Voice b -> Bool
sameDurations a b = view durationsV a == view durationsV b
mergeIfSameDuration :: Voice a -> Voice b -> Maybe (Voice (a, b))
mergeIfSameDuration = mergeIfSameDurationWith (,)
mergeIfSameDurationWith :: (a -> b -> c) -> Voice a -> Voice b -> Maybe (Voice c)
mergeIfSameDurationWith f a b
| sameDurations a b = Just $ zipVoiceWithNoScale f a b
| otherwise = Nothing
splitLatterToAssureSameDuration :: Voice b -> Voice b -> Voice b
splitLatterToAssureSameDuration = splitLatterToAssureSameDurationWith dup
where
dup x = (x,x)
splitLatterToAssureSameDurationWith :: (b -> (b, b)) -> Voice b -> Voice b -> Voice b
splitLatterToAssureSameDurationWith = undefined
polyToHomophonic :: [Voice a] -> Maybe (Voice [a])
polyToHomophonic = undefined
polyToHomophonicForce :: [Voice a] -> Voice [a]
polyToHomophonicForce = undefined
homoToPolyphonic :: Voice [a] -> [Voice a]
homoToPolyphonic = undefined
changeCrossing :: Ord a => Voice a -> Voice a -> (Voice a, Voice a)
changeCrossing = undefined
changeCrossingBy :: Ord b => (a -> b) -> Voice a -> Voice a -> (Voice a, Voice a)
changeCrossingBy = undefined
processExactOverlaps :: (a -> a -> (a, a)) -> Voice a -> Voice a -> (Voice a, Voice a)
processExactOverlaps = undefined
processExactOverlaps' :: (a -> b -> Either (a,b) (b,a)) -> Voice a -> Voice b -> (Voice (Either b a), Voice (Either a b))
processExactOverlaps' = undefined
onsetsRelative :: Time -> Voice a -> [Time]
onsetsRelative = undefined
offsetsRelative :: Time -> Voice a -> [Time]
offsetsRelative = undefined
midpointsRelative :: Time -> Voice a -> [Time]
midpointsRelative = undefined
erasRelative :: Time -> Voice a -> [Span]
erasRelative = undefined
onsetMap :: Time -> Voice a -> Map Time a
onsetMap = undefined
offsetMap :: Time -> Voice a -> Map Time a
offsetMap = undefined
midpointMap :: Time -> Voice a -> Map Time a
midpointMap = undefined
eraMap :: Time -> Voice a -> Map Span a
eraMap = undefined
durations :: Voice a -> [Duration]
durations = undefined