{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
module Musicology.Core.Slicing
  ( onOffGroups
  , groupsToSlices
  , slicePiece
  , Slicer(..)
  , timed
  , cleanSlicer
  , tiedSlicer
  )
where

import           Musicology.Core

import qualified Data.List                     as L
import           Lens.Micro.Extras              ( view )

onOffGroups :: (Foldable f, HasTime n) => f n -> [[OnOff n (TimeOf n)]]
onOffGroups :: forall (f :: * -> *) n.
(Foldable f, HasTime n) =>
f n -> [[OnOff n (TimeOf n)]]
onOffGroups f n
notes = forall a. (a -> a -> Bool) -> [a] -> [[a]]
L.groupBy forall {a} {a}.
(TimeOf a ~ TimeOf a, HasTime a, HasTime a) =>
a -> a -> Bool
eq forall a b. (a -> b) -> a -> b
$ forall b a. Ord b => (a -> b) -> [a] -> [a]
L.sortOn forall a. HasTime a => a -> TimeOf a
onset forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall {a}.
HasTime a =>
[OnOff a (TimeOf a)] -> a -> [OnOff a (TimeOf a)]
convert forall a. Monoid a => a
mempty f n
notes
 where
  convert :: [OnOff a (TimeOf a)] -> a -> [OnOff a (TimeOf a)]
convert [OnOff a (TimeOf a)]
onoffs a
note =
    forall c t. c -> t -> OnOff c t
Onset a
note (forall a. HasTime a => a -> TimeOf a
onset a
note) forall a. a -> [a] -> [a]
: forall c t. c -> t -> OnOff c t
Offset a
note (forall a. HasTime a => a -> TimeOf a
offset a
note) forall a. a -> [a] -> [a]
: [OnOff a (TimeOf a)]
onoffs
  eq :: a -> a -> Bool
eq a
a a
b = forall a. HasTime a => a -> TimeOf a
onset a
a forall a. Eq a => a -> a -> Bool
== forall a. HasTime a => a -> TimeOf a
onset a
b

data Slicer a t st s = Slicer
  { forall a t st s. Slicer a t st s -> [OnOff a t] -> st
slInit :: [OnOff a t] -> st
  , forall a t st s. Slicer a t st s -> st -> [OnOff a t] -> (st, s)
slNext :: st -> [OnOff a t] -> (st, s)
  , forall a t st s. Slicer a t st s -> st -> Maybe s
slFinal :: st -> Maybe s
  }

-- newPitches
--   :: (Eq p, HasPitch a, IntervalOf a ~ p)
--   => [Pitch p]
--   -> [OnOff a (TimeOf a)]
--   -> [Pitch p]

groupsToSlices :: Foldable f => Slicer a t st s -> f [OnOff a t] -> [s]
groupsToSlices :: forall (f :: * -> *) a t st s.
Foldable f =>
Slicer a t st s -> f [OnOff a t] -> [s]
groupsToSlices (Slicer [OnOff a t] -> st
init st -> [OnOff a t] -> (st, s)
next st -> Maybe s
cleanUp) f [OnOff a t]
groups =
  forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ case forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Maybe (st, [s]) -> [OnOff a t] -> Maybe (st, [s])
nextSlice forall a. Maybe a
Nothing f [OnOff a t]
groups of
    Maybe (st, [s])
Nothing        -> []
    Just (st
st, [s]
acc) -> case st -> Maybe s
cleanUp st
st of
      Just s
rest -> s
rest forall a. a -> [a] -> [a]
: [s]
acc
      Maybe s
Nothing   -> [s]
acc
 where
  nextSlice :: Maybe (st, [s]) -> [OnOff a t] -> Maybe (st, [s])
nextSlice Maybe (st, [s])
Nothing          [OnOff a t]
grp = forall a. a -> Maybe a
Just ([OnOff a t] -> st
init [OnOff a t]
grp, [])
  nextSlice (Just (st
st, [s]
acc)) [OnOff a t]
grp = forall a. a -> Maybe a
Just (st
st', s
slice' forall a. a -> [a] -> [a]
: [s]
acc)
    where (st
st', s
slice') = st -> [OnOff a t] -> (st, s)
next st
st [OnOff a t]
grp

slicePiece :: (Foldable f, HasTime n) => Slicer n (TimeOf n) st s -> f n -> [s]
slicePiece :: forall (f :: * -> *) n st s.
(Foldable f, HasTime n) =>
Slicer n (TimeOf n) st s -> f n -> [s]
slicePiece Slicer n (TimeOf n) st s
slicer f n
notes = forall (f :: * -> *) a t st s.
Foldable f =>
Slicer a t st s -> f [OnOff a t] -> [s]
groupsToSlices Slicer n (TimeOf n) st s
slicer forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) n.
(Foldable f, HasTime n) =>
f n -> [[OnOff n (TimeOf n)]]
onOffGroups f n
notes

timed :: Slicer a a c c -> Slicer a a (a, c) (TimedEvent c a)
timed (Slicer [OnOff a a] -> c
init c -> [OnOff a a] -> (c, c)
next c -> Maybe c
cleanUp) = forall a t st s.
([OnOff a t] -> st)
-> (st -> [OnOff a t] -> (st, s))
-> (st -> Maybe s)
-> Slicer a t st s
Slicer [OnOff a a] -> (a, c)
init' (a, c) -> [OnOff a a] -> ((a, c), TimedEvent c a)
next' (a, c) -> Maybe (TimedEvent c a)
cleanUp'
 where
  time :: [OnOff a a] -> TimeOf (OnOff a a)
time = forall a. HasTime a => a -> TimeOf a
onset forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head
  init' :: [OnOff a a] -> (a, c)
init' [OnOff a a]
grp = ([OnOff a a] -> TimeOf (OnOff a a)
time [OnOff a a]
grp, [OnOff a a] -> c
init [OnOff a a]
grp)
  next' :: (a, c) -> [OnOff a a] -> ((a, c), TimedEvent c a)
next' (a
on, c
st) [OnOff a a]
grp = ((forall a. HasTime a => a -> TimeOf a
onset forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [OnOff a a]
grp, c
st'), TimedEvent c a
timedSlice)
   where
    (c
slice, c
st') = c -> [OnOff a a] -> (c, c)
next c
st [OnOff a a]
grp
    timedSlice :: TimedEvent c a
timedSlice   = forall c t. c -> t -> t -> TimedEvent c t
TimedEvent c
slice a
on ([OnOff a a] -> TimeOf (OnOff a a)
time [OnOff a a]
grp)
  cleanUp' :: (a, c) -> Maybe (TimedEvent c a)
cleanUp' (a
on, c
st) = case c -> Maybe c
cleanUp c
st of
    Maybe c
Nothing    -> forall a. Maybe a
Nothing
    Just c
slice -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall c t. c -> t -> t -> TimedEvent c t
TimedEvent c
slice a
on a
on

cleanSlicer :: (Eq a) => Slicer a t [a] [a]
cleanSlicer :: forall a t. Eq a => Slicer a t [a] [a]
cleanSlicer = forall a t st s.
([OnOff a t] -> st)
-> (st -> [OnOff a t] -> (st, s))
-> (st -> Maybe s)
-> Slicer a t st s
Slicer forall {b} {t}. [OnOff b t] -> [b]
init forall {a} {t}. Eq a => [a] -> [OnOff a t] -> ([a], [a])
next forall {a}. [a] -> Maybe [a]
cleanUp
 where
  contents :: f (OnOff b t) -> f b
contents f (OnOff b t)
onoff = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a s. Getting a s a -> s -> a
view forall c t c2. Lens (OnOff c t) (OnOff c2 t) c c2
onOffContent) f (OnOff b t)
onoff
  newPitches :: [a] -> [OnOff a t] -> [a]
newPitches [a]
curr [OnOff a t]
grp = ([a]
curr forall a. Eq a => [a] -> [a] -> [a]
L.\\ forall {f :: * -> *} {b} {t}. Functor f => f (OnOff b t) -> f b
contents [OnOff a t]
offs) forall a. Eq a => [a] -> [a] -> [a]
`L.union` forall {f :: * -> *} {b} {t}. Functor f => f (OnOff b t) -> f b
contents [OnOff a t]
ons
    where ([OnOff a t]
ons, [OnOff a t]
offs) = forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition forall {c} {t}. OnOff c t -> Bool
isOn [OnOff a t]
grp
  init :: [OnOff b t] -> [b]
init = forall {f :: * -> *} {b} {t}. Functor f => f (OnOff b t) -> f b
contents forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter forall {c} {t}. OnOff c t -> Bool
isOn
  next :: [a] -> [OnOff a t] -> ([a], [a])
next [a]
curr [OnOff a t]
grp = (forall {a} {t}. Eq a => [a] -> [OnOff a t] -> [a]
newPitches [a]
curr [OnOff a t]
grp, [a]
curr)
  cleanUp :: [a] -> Maybe [a]
cleanUp []   = forall a. Maybe a
Nothing
  cleanUp [a]
last = forall a. a -> Maybe a
Just [a]
last

-- groupsToPitches
--   :: (Foldable f, HasPitch a, Eq (IntervalOf a))
--   => f [OnOff a t]
--   -> [[Pitch (IntervalOf a)]]
-- groupsToPitches = groupsToAny pitchSlicer

tiedSlicer :: (Eq a) => Slicer a t ([a], [a]) [(a, Tied)]
tiedSlicer :: forall a t. Eq a => Slicer a t ([a], [a]) [(a, Tied)]
tiedSlicer = forall a t st s.
([OnOff a t] -> st)
-> (st -> [OnOff a t] -> (st, s))
-> (st -> Maybe s)
-> Slicer a t st s
Slicer forall {b} {t} {a}. [OnOff b t] -> ([b], [a])
init forall {a} {t}.
Eq a =>
([a], [a]) -> [OnOff a t] -> (([a], [a]), [(a, Tied)])
next forall {a}. ([a], [a]) -> Maybe [(a, Tied)]
cleanUp
 where
  content :: OnOff a t -> a
content = forall a s. Getting a s a -> s -> a
view forall c t c2. Lens (OnOff c t) (OnOff c2 t) c c2
onOffContent
  init :: [OnOff b t] -> ([b], [a])
init [OnOff b t]
grp = (forall {a} {t}. OnOff a t -> a
content forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (a -> Bool) -> [a] -> [a]
filter forall {c} {t}. OnOff c t -> Bool
isOn [OnOff b t]
grp, [])
  next :: ([a], [a]) -> [OnOff a t] -> (([a], [a]), [(a, Tied)])
next ([a]
currNew, [a]
currOld) [OnOff a t]
grp = (([a]
currNew', [a]
currOld'), [(a, Tied)]
notes)
   where
    ([OnOff a t]
onEvs, [OnOff a t]
offEvs) = forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition forall {c} {t}. OnOff c t -> Bool
isOn [OnOff a t]
grp
    ons :: [a]
ons             = forall {a} {t}. OnOff a t -> a
content forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [OnOff a t]
onEvs
    offs :: [a]
offs            = forall {a} {t}. OnOff a t -> a
content forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [OnOff a t]
offEvs
    singles :: [(a, Tied)]
singles         = (, Tied
Single) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
currNew forall a. Eq a => [a] -> [a] -> [a]
`L.intersect` [a]
offs
    starts :: [(a, Tied)]
starts          = (, Tied
Starts) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
currNew forall a. Eq a => [a] -> [a] -> [a]
L.\\ [a]
offs
    continues :: [(a, Tied)]
continues       = (, Tied
Continues) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
currOld forall a. Eq a => [a] -> [a] -> [a]
L.\\ [a]
offs
    stops :: [(a, Tied)]
stops           = (, Tied
Stops) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
currOld forall a. Eq a => [a] -> [a] -> [a]
`L.intersect` [a]
offs
    notes :: [(a, Tied)]
notes           = [(a, Tied)]
singles forall a. Semigroup a => a -> a -> a
<> [(a, Tied)]
starts forall a. Semigroup a => a -> a -> a
<> [(a, Tied)]
continues forall a. Semigroup a => a -> a -> a
<> [(a, Tied)]
stops
    currOld' :: [a]
currOld'        = ([a]
currNew forall a. Semigroup a => a -> a -> a
<> [a]
currOld) forall a. Eq a => [a] -> [a] -> [a]
L.\\ [a]
offs
    currNew' :: [a]
currNew'        = [a]
ons forall a. Eq a => [a] -> [a] -> [a]
L.\\ [a]
currOld'
  cleanUp :: ([a], [a]) -> Maybe [(a, Tied)]
cleanUp ([] , [] ) = forall a. Maybe a
Nothing
  cleanUp ([a]
new, [a]
old) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (, Tied
Single) [a]
new forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (, Tied
Stops) [a]
old

-- -- groupsToTied
-- --   :: (Foldable t, HasTime n, Eq n) => t [OnOff n (TimeOf n)] -> [[(n, Tied)]]
-- groupsToTied :: (Foldable f, Eq a) => f [OnOff a t] -> [[(a, Tied)]]
-- groupsToTied = groupsToAny tiedSlicer