module Sound.SC3.Lang.Pattern.Control where
import Control.Applicative
import Control.Monad
import Data.List
import Data.Maybe
import Data.Monoid
import Sound.SC3.Lang.Math.Pitch
import Sound.SC3.Lang.Pattern.Pattern
pfilter :: (a -> Bool) -> P a -> P a
pfilter f p = pcontinue p (\x p' -> if f x
then mappend (return x) (pfilter f p')
else pfilter f p')
plist :: [P a] -> P a
plist = foldr mappend mempty
pcons :: a -> P a -> P a
pcons = mappend . return
preplicate_ :: Int -> P a -> P a
preplicate_ n p | n > 0 = mappend p (preplicate_ (n 1) p)
| otherwise = mempty
preplicate :: P Int -> P a -> P a
preplicate n p = n >>= (\x -> preplicate_ x p)
pn :: P a -> P Int -> P a
pn = flip preplicate
pn_ :: P a -> Int -> P a
pn_ = flip preplicate_
ptake_ :: Int -> P a -> P a
ptake_ n p = pzipWith const p (preplicate_ n (return undefined))
ptake :: P Int -> P a -> P a
ptake n p = pzipWith const p (preplicate n (return undefined))
prestrict_ :: Int -> P a -> P a
prestrict_ n = ptake_ n . pcycle
prestrict :: P Int -> P a -> P a
prestrict n = ptake n . pcycle
pmapMaybe :: (a -> Maybe b) -> P a -> P b
pmapMaybe f = fmap fromJust . pfilter isJust . fmap f
preject :: (a -> Bool) -> P a -> P a
preject f = pfilter (not . f)
pzipWith3 :: (a -> b -> c -> d) -> P a -> P b -> P c -> P d
pzipWith3 f p q = (<*>) (pure f <*> p <*> q)
pzip :: P a -> P b -> P (a,b)
pzip = pzipWith (,)
pseries :: (Num a) => a -> a -> Int -> P a
pseries i s n = plist (unfoldr f (i, n))
where f (_, 0) = Nothing
f (j, m) = Just (return j, (j + s, m 1))
pgeom :: (Num a) => a -> a -> Int -> P a
pgeom i s n = plist (unfoldr f (i, n))
where f (_, 0) = Nothing
f (j, m) = Just (return j, (j * s, m 1))
pstutter' :: P Int -> P a -> P a
pstutter' n p =
let f :: Int -> a -> P a
f i e = preplicate (return i) (return e)
in psequence (pzipWith f n p)
pstutter :: P Int -> P a -> P a
pstutter = pstutter' . pcycle
pcountpre :: P Bool -> P Int
pcountpre p = pmapMaybe id (pscan f Nothing 0 p)
where f x e = if e then (0, Just x) else (x + 1, Nothing)
pcountpost :: P Bool -> P Int
pcountpost p = ptail (pmapMaybe id (pscan f (Just Just) 0 p))
where f x e = if e then (0, Just x) else (x + 1, Nothing)
pclutch' :: P a -> P Bool -> P a
pclutch' p q = pstutter' r p
where r = fmap (+ 1) (pcountpost q)
pbool :: (Ord a, Num a) => P a -> P Bool
pbool = fmap (> 0)
pclutch :: (Num b, Ord b) => P a -> P b -> P a
pclutch p = pclutch' p . pbool
pcollect :: (a -> b) -> P a -> P b
pcollect = fmap
pdegreeToKey :: (RealFrac a) => P a -> P [a] -> P a -> P a
pdegreeToKey = pzipWith3 degree_to_key
pfin :: P Int -> P a -> P a
pfin = ptake
pfin_ :: Int -> P a -> P a
pfin_ = ptake_
wrap :: (Ord a, Num a) => a -> a -> a -> a
wrap l r x = if x > r
then wrap l r (x (r l))
else if x < l
then wrap l r (x + (r l))
else x
pwrap :: (Ord a, Num a) => P a -> P a -> P a -> P a
pwrap x l r = pzipWith3 f x (pcycle l) (pcycle r)
where f x' l' r' = wrap l' r' x'
prsd :: (Eq a) => P a -> P a
prsd p = pmapMaybe id (pscan f Nothing Nothing p)
where f Nothing a = (Just a, Just a)
f (Just x) a = (Just a, if a == x then Nothing else Just a)
psequence :: P (P a) -> P a
psequence = join
pduple :: (a, a) -> P a
pduple (x, y) = return x `mappend` return y
pinterleave :: P a -> P a -> P a
pinterleave p = psequence . fmap pduple . pzip p
ptrigger :: P Bool -> P a -> P (Maybe a)
ptrigger p q = join (pzipWith f r q)
where r = pcountpre p
f i = mappend (preplicate_ i (return Nothing)) . return . Just
pif :: Int -> P Bool -> P a -> P a -> P a
pif s b p q = pzipWith f p' q'
where b' = pfix s b
p' = ptrigger b' p
q' = ptrigger (fmap not b') q
f (Just x) Nothing = x
f Nothing (Just x) = x
f _ _ = undefined
pif' :: P Bool -> P a -> P a -> P a
pif' = pif 0
phead :: P a -> P a
phead p = pcontinue p (\x _ -> return x)
ptail :: P a -> P a
ptail p = pcontinue p (\_ p' -> p')
pdrop :: P Int -> P a -> P a
pdrop n p = n >>= (\x -> if x > 0
then pdrop (return (x1)) (ptail p)
else p)
pscanl :: (a -> y -> a) -> a -> P y -> P a
pscanl f i p = pcons i (pscan g Nothing i p)
where g x y = let r = f x y in (r, r)