{-# 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 = (OnOff n (TimeOf n) -> OnOff n (TimeOf n) -> Bool)
-> [OnOff n (TimeOf n)] -> [[OnOff n (TimeOf n)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
L.groupBy OnOff n (TimeOf n) -> OnOff n (TimeOf n) -> Bool
forall {a} {a}.
(TimeOf a ~ TimeOf a, HasTime a, HasTime a) =>
a -> a -> Bool
eq ([OnOff n (TimeOf n)] -> [[OnOff n (TimeOf n)]])
-> [OnOff n (TimeOf n)] -> [[OnOff n (TimeOf n)]]
forall a b. (a -> b) -> a -> b
$ (OnOff n (TimeOf n) -> TimeOf n)
-> [OnOff n (TimeOf n)] -> [OnOff n (TimeOf n)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
L.sortOn OnOff n (TimeOf n) -> TimeOf n
OnOff n (TimeOf n) -> TimeOf (OnOff n (TimeOf n))
forall a. HasTime a => a -> TimeOf a
onset ([OnOff n (TimeOf n)] -> [OnOff n (TimeOf n)])
-> [OnOff n (TimeOf n)] -> [OnOff n (TimeOf n)]
forall a b. (a -> b) -> a -> b
$ ([OnOff n (TimeOf n)] -> n -> [OnOff n (TimeOf n)])
-> [OnOff n (TimeOf n)] -> f n -> [OnOff n (TimeOf n)]
forall b a. (b -> a -> b) -> b -> f a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [OnOff n (TimeOf n)] -> n -> [OnOff n (TimeOf n)]
forall {a}.
HasTime a =>
[OnOff a (TimeOf a)] -> a -> [OnOff a (TimeOf a)]
convert [OnOff n (TimeOf n)]
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 =
    a -> TimeOf a -> OnOff a (TimeOf a)
forall c t. c -> t -> OnOff c t
Onset a
note (a -> TimeOf a
forall a. HasTime a => a -> TimeOf a
onset a
note) OnOff a (TimeOf a) -> [OnOff a (TimeOf a)] -> [OnOff a (TimeOf a)]
forall a. a -> [a] -> [a]
: a -> TimeOf a -> OnOff a (TimeOf a)
forall c t. c -> t -> OnOff c t
Offset a
note (a -> TimeOf a
forall a. HasTime a => a -> TimeOf a
offset a
note) OnOff a (TimeOf a) -> [OnOff a (TimeOf a)] -> [OnOff a (TimeOf a)]
forall a. a -> [a] -> [a]
: [OnOff a (TimeOf a)]
onoffs
  eq :: a -> a -> Bool
eq a
a a
b = a -> TimeOf a
forall a. HasTime a => a -> TimeOf a
onset a
a TimeOf a -> TimeOf a -> Bool
forall a. Eq a => a -> a -> Bool
== a -> TimeOf a
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 =
  [s] -> [s]
forall a. [a] -> [a]
reverse ([s] -> [s]) -> [s] -> [s]
forall a b. (a -> b) -> a -> b
$ case (Maybe (st, [s]) -> [OnOff a t] -> Maybe (st, [s]))
-> Maybe (st, [s]) -> f [OnOff a t] -> Maybe (st, [s])
forall b a. (b -> a -> b) -> b -> f a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Maybe (st, [s]) -> [OnOff a t] -> Maybe (st, [s])
nextSlice Maybe (st, [s])
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 s -> [s] -> [s]
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 = (st, [s]) -> Maybe (st, [s])
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 = (st, [s]) -> Maybe (st, [s])
forall a. a -> Maybe a
Just (st
st', s
slice' s -> [s] -> [s]
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 = Slicer n (TimeOf n) st s -> [[OnOff n (TimeOf n)]] -> [s]
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 ([[OnOff n (TimeOf n)]] -> [s]) -> [[OnOff n (TimeOf n)]] -> [s]
forall a b. (a -> b) -> a -> b
$ f n -> [[OnOff n (TimeOf n)]]
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) = ([OnOff a a] -> (a, c))
-> ((a, c) -> [OnOff a a] -> ((a, c), TimedEvent c a))
-> ((a, c) -> Maybe (TimedEvent c a))
-> Slicer a a (a, c) (TimedEvent c a)
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 = OnOff a a -> TimeOf (OnOff a a)
forall a. HasTime a => a -> TimeOf a
onset (OnOff a a -> TimeOf (OnOff a a))
-> ([OnOff a a] -> OnOff a a) -> [OnOff a a] -> TimeOf (OnOff a a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [OnOff a a] -> OnOff a a
forall a. HasCallStack => [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 = ((OnOff a a -> TimeOf (OnOff a a)
forall a. HasTime a => a -> TimeOf a
onset (OnOff a a -> TimeOf (OnOff a a))
-> OnOff a a -> TimeOf (OnOff a a)
forall a b. (a -> b) -> a -> b
$ [OnOff a a] -> OnOff a a
forall a. HasCallStack => [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   = c -> a -> a -> TimedEvent c a
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    -> Maybe (TimedEvent c a)
forall a. Maybe a
Nothing
    Just c
slice -> TimedEvent c a -> Maybe (TimedEvent c a)
forall a. a -> Maybe a
Just (TimedEvent c a -> Maybe (TimedEvent c a))
-> TimedEvent c a -> Maybe (TimedEvent c a)
forall a b. (a -> b) -> a -> b
$ c -> a -> a -> TimedEvent c a
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 = ([OnOff a t] -> [a])
-> ([a] -> [OnOff a t] -> ([a], [a]))
-> ([a] -> Maybe [a])
-> Slicer a t [a] [a]
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 t] -> [a]
forall {b} {t}. [OnOff b t] -> [b]
init [a] -> [OnOff a t] -> ([a], [a])
forall {a} {t}. Eq a => [a] -> [OnOff a t] -> ([a], [a])
next [a] -> Maybe [a]
forall {a}. [a] -> Maybe [a]
cleanUp
 where
  contents :: f (OnOff b t) -> f b
contents f (OnOff b t)
onoff = (OnOff b t -> b) -> f (OnOff b t) -> f b
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Getting b (OnOff b t) b -> OnOff b t -> b
forall a s. Getting a s a -> s -> a
view Getting b (OnOff b t) b
forall c t c2 (f :: * -> *).
Functor f =>
(c -> f c2) -> OnOff c t -> f (OnOff c2 t)
onOffContent) f (OnOff b t)
onoff
  newPitches :: [a] -> [OnOff a t] -> [a]
newPitches [a]
curr [OnOff a t]
grp = ([a]
curr [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [OnOff a t] -> [a]
forall {f :: * -> *} {b} {t}. Functor f => f (OnOff b t) -> f b
contents [OnOff a t]
offs) [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a]
`L.union` [OnOff a t] -> [a]
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) = (OnOff a t -> Bool) -> [OnOff a t] -> ([OnOff a t], [OnOff a t])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition OnOff a t -> Bool
forall {c} {t}. OnOff c t -> Bool
isOn [OnOff a t]
grp
  init :: [OnOff b t] -> [b]
init = [OnOff b t] -> [b]
forall {f :: * -> *} {b} {t}. Functor f => f (OnOff b t) -> f b
contents ([OnOff b t] -> [b])
-> ([OnOff b t] -> [OnOff b t]) -> [OnOff b t] -> [b]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (OnOff b t -> Bool) -> [OnOff b t] -> [OnOff b t]
forall a. (a -> Bool) -> [a] -> [a]
filter OnOff b t -> Bool
forall {c} {t}. OnOff c t -> Bool
isOn
  next :: [a] -> [OnOff a t] -> ([a], [a])
next [a]
curr [OnOff a t]
grp = ([a] -> [OnOff a t] -> [a]
forall {a} {t}. Eq a => [a] -> [OnOff a t] -> [a]
newPitches [a]
curr [OnOff a t]
grp, [a]
curr)
  cleanUp :: [a] -> Maybe [a]
cleanUp []   = Maybe [a]
forall a. Maybe a
Nothing
  cleanUp [a]
last = [a] -> Maybe [a]
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 = ([OnOff a t] -> ([a], [a]))
-> (([a], [a]) -> [OnOff a t] -> (([a], [a]), [(a, Tied)]))
-> (([a], [a]) -> Maybe [(a, Tied)])
-> Slicer a t ([a], [a]) [(a, Tied)]
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 t] -> ([a], [a])
forall {b} {t} {a}. [OnOff b t] -> ([b], [a])
init ([a], [a]) -> [OnOff a t] -> (([a], [a]), [(a, Tied)])
forall {a} {t}.
Eq a =>
([a], [a]) -> [OnOff a t] -> (([a], [a]), [(a, Tied)])
next ([a], [a]) -> Maybe [(a, Tied)]
forall {a}. ([a], [a]) -> Maybe [(a, Tied)]
cleanUp
 where
  content :: OnOff a t -> a
content = Getting a (OnOff a t) a -> OnOff a t -> a
forall a s. Getting a s a -> s -> a
view Getting a (OnOff a t) a
forall c t c2 (f :: * -> *).
Functor f =>
(c -> f c2) -> OnOff c t -> f (OnOff c2 t)
onOffContent
  init :: [OnOff b t] -> ([b], [a])
init [OnOff b t]
grp = (OnOff b t -> b
forall {a} {t}. OnOff a t -> a
content (OnOff b t -> b) -> [OnOff b t] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (OnOff b t -> Bool) -> [OnOff b t] -> [OnOff b t]
forall a. (a -> Bool) -> [a] -> [a]
filter OnOff b t -> Bool
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) = (OnOff a t -> Bool) -> [OnOff a t] -> ([OnOff a t], [OnOff a t])
forall a. (a -> Bool) -> [a] -> ([a], [a])
L.partition OnOff a t -> Bool
forall {c} {t}. OnOff c t -> Bool
isOn [OnOff a t]
grp
    ons :: [a]
ons             = OnOff a t -> a
forall {a} {t}. OnOff a t -> a
content (OnOff a t -> a) -> [OnOff a t] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [OnOff a t]
onEvs
    offs :: [a]
offs            = OnOff a t -> a
forall {a} {t}. OnOff a t -> a
content (OnOff a t -> a) -> [OnOff a t] -> [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [OnOff a t]
offEvs
    singles :: [(a, Tied)]
singles         = (, Tied
Single) (a -> (a, Tied)) -> [a] -> [(a, Tied)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
currNew [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a]
`L.intersect` [a]
offs
    starts :: [(a, Tied)]
starts          = (, Tied
Starts) (a -> (a, Tied)) -> [a] -> [(a, Tied)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
currNew [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [a]
offs
    continues :: [(a, Tied)]
continues       = (, Tied
Continues) (a -> (a, Tied)) -> [a] -> [(a, Tied)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
currOld [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [a]
offs
    stops :: [(a, Tied)]
stops           = (, Tied
Stops) (a -> (a, Tied)) -> [a] -> [(a, Tied)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
currOld [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a]
`L.intersect` [a]
offs
    notes :: [(a, Tied)]
notes           = [(a, Tied)]
singles [(a, Tied)] -> [(a, Tied)] -> [(a, Tied)]
forall a. Semigroup a => a -> a -> a
<> [(a, Tied)]
starts [(a, Tied)] -> [(a, Tied)] -> [(a, Tied)]
forall a. Semigroup a => a -> a -> a
<> [(a, Tied)]
continues [(a, Tied)] -> [(a, Tied)] -> [(a, Tied)]
forall a. Semigroup a => a -> a -> a
<> [(a, Tied)]
stops
    currOld' :: [a]
currOld'        = ([a]
currNew [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> [a]
currOld) [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [a]
offs
    currNew' :: [a]
currNew'        = [a]
ons [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [a]
currOld'
  cleanUp :: ([a], [a]) -> Maybe [(a, Tied)]
cleanUp ([] , [] ) = Maybe [(a, Tied)]
forall a. Maybe a
Nothing
  cleanUp ([a]
new, [a]
old) = [(a, Tied)] -> Maybe [(a, Tied)]
forall a. a -> Maybe a
Just ([(a, Tied)] -> Maybe [(a, Tied)])
-> [(a, Tied)] -> Maybe [(a, Tied)]
forall a b. (a -> b) -> a -> b
$ (a -> (a, Tied)) -> [a] -> [(a, Tied)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (, Tied
Single) [a]
new [(a, Tied)] -> [(a, Tied)] -> [(a, Tied)]
forall a. Semigroup a => a -> a -> a
<> (a -> (a, Tied)) -> [a] -> [(a, Tied)]
forall a b. (a -> b) -> [a] -> [b]
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