module Sound.SC3.Lang.Pattern.List where

import qualified Control.Applicative as A
import qualified Control.Monad as M
import qualified Data.Array as A
import qualified Data.Foldable as F
import qualified Data.HashTable as H
import qualified Data.List as L
import qualified Data.Monoid as M
import qualified Data.Traversable as T
import qualified Sound.SC3.Lang.Collection.Collection as S
import qualified Sound.SC3.Lang.Collection.SequenceableCollection as S
import qualified Sound.SC3.Lang.Math.Pitch as S
import qualified System.Random as R

data P a = P { unP :: [a] }

-- * Instances

instance A.Alternative P where
    empty = pempty
    (<|>) = pappend

instance A.Applicative P where
    pure = M.return
    (<*>) = M.ap

instance F.Foldable P where
    foldr = pfoldr

instance (Fractional a) => Fractional (P a) where
    (/) = pzipWith (/)
    recip = fmap recip
    fromRational = return . fromRational

instance Functor P where
    fmap f = P . fmap f . unP

instance (Eq a) => Eq (P a) where
    (P p) == (P q) = p == q

instance Monad P where
    m >>= f = pconcatMap f m
    return x = P [x]

instance M.MonadPlus P where
    mzero = pempty
    mplus = pappend

instance M.Monoid (P a) where
    mempty = pempty
    mappend = pappend

instance (Num a) => Num (P a) where
    (+) = pzipWith (+)
    (-) = pzipWith (-)
    (*) = pzipWith (*)
    abs = fmap abs
    signum = fmap signum
    fromInteger = return . fromInteger
    negate = fmap negate

instance (Show a) => Show (P a) where
    show = show . unP

instance T.Traversable P where
    traverse f = let cons_f x ys = pcons A.<$> f x A.<*> ys
                 in pfoldr cons_f (A.pure pempty)

-- * Basic constructors

pinf :: P Int
pinf = return 83886028 -- 2 ^^ 23

-- * List functions

bool :: (Functor f, Ord a, Num a) => f a -> f Bool
bool = fmap (> 0)

clutch :: [a] -> [Bool] -> [a]
clutch p q =
    let r = fmap (+ 1) (countpost q)
    in stutter r p

-- | Count false values following each true value.
countpost :: [Bool] -> [Int]
countpost =
    let f i [] = [i]
        f i (x:xs) = if not x
                     then f (i + 1) xs
                     else i : f 0 xs
    in tail . f 0

-- | Count false values preceding each true value.
countpre :: [Bool] -> [Int]
countpre =
    let f i [] = if i == 0 then [] else [i]
        f i (x:xs) = if x 
                     then i : f 0 xs
                     else f (i + 1) xs
    in f 0

interleave :: [a] -> [a] -> [a]
interleave p [] = p
interleave [] q = q
interleave (p:ps) (q:qs) = p : q : interleave ps qs

-- | Remove successive duplicates.
rsd :: (Eq a) => [a] -> [a]
rsd =
    let f _ [] = []
        f Nothing (x:xs) = x : f (Just x) xs
        f (Just y) (x:xs) = if x == y
                            then f (Just x) xs
                            else x : f (Just x) xs
    in f Nothing

stutter :: [Int] -> [a] -> [a]
stutter [] _ = []
stutter _ [] = []
stutter (n:ns) (p:ps) = replicate n p ++ stutter ns ps

trigger :: [Bool] -> [a] -> [Maybe a]
trigger p q =
    let r = countpre p
        f i x = replicate i Nothing ++ [Just x]
    in concat (zipWith f r q)

-- * Pattern functions

pappend :: P a -> P a -> P a
pappend p q = P (unP p ++ unP q)

papply :: P (a -> b) -> P a -> P b
papply (P f) (P x) = P (f A.<*> x)

pbool :: (Ord a, Num a) => P a -> P Bool
pbool = bool

pclutch :: P a -> P Bool -> P a
pclutch (P x) (P c) = P (clutch x c)

pcollect :: (a -> b) -> P a -> P b
pcollect = fmap

pcountpost :: P Bool -> P Int
pcountpost = P . countpost . unP

pcountpre :: P Bool -> P Int
pcountpre = P . countpre . unP

pconcat :: P (P a) -> P a
pconcat p =
    if pnull p
    then pempty
    else case phead p of
           Nothing -> pempty
           Just x -> x `pappend` (pconcat (ptail p))

pconcatMap :: (b -> P a) -> P b -> P a
pconcatMap f = pconcat . fmap f

pcons :: a -> P a -> P a
pcons x = P . (x:) . unP

pcycle :: P a -> P a
pcycle = P . L.cycle . unP

pdegreeToKey :: (RealFrac a) => P a -> P [a] -> P a -> P a
pdegreeToKey = pzipWith3 S.degree_to_key

pdrop :: P Int -> P a -> P a
pdrop n =
    case phead n of
      Nothing -> error "pdrop"
      Just n' -> P . L.drop n' . unP

pempty :: P a
pempty = P []

pfilter :: (a -> Bool) -> P a -> P a
pfilter f = P . L.filter f . unP

pfin :: P Int -> P a -> P a
pfin = ptake

pfoldr :: (a -> b -> b) -> b -> P a -> b
pfoldr f x = L.foldr f x . unP

pgeom :: (Num a) => a -> a -> Int -> P a
pgeom i s n = P (S.geom n i s)

phead :: P a -> Maybe a
phead (P []) = Nothing
phead (P (x:_)) = Just x

pinterleave :: P a -> P a -> P a
pinterleave (P p) (P q) = P (interleave p q)

pn :: P a -> P Int -> P a
pn (P p) n =
    let f 0 _ = []
        f i xs = xs ++ f (i - 1) xs
    in case phead n of
         Nothing -> error "preplicate"
         Just x -> P (f x p)

pnull :: P a -> Bool
pnull = L.null . unP

prepeat :: a -> P a
prepeat = P . L.repeat

preject :: (a -> Bool) -> P a -> P a
preject f =
    let g i _ = f i
    in P . S.reject g . unP

prsd :: (Eq a) => P a -> P a
prsd = P . rsd . unP

pseq :: [P a] -> P Int -> P a
pseq ps n =
    case phead n of
      Nothing -> error "pseq: empty repeat pattern"
      Just n' -> let ps' = concat (replicate n' ps)
                 in L.foldr pappend pempty ps'

pser :: [P a] -> P Int -> P a
pser ps n = ptake n (pseq ps pinf)

pseries :: (Num a) => a -> a -> Int -> P a
pseries i s n = P (S.series n i s)

pstutter :: P Int -> P a -> P a
pstutter (P n) (P p) = P (stutter n p)

pswitch :: [P a] -> P Int -> P a
pswitch l i = i >>= (l !!)

pswitch1 :: [P a] -> P Int -> P a
pswitch1 ps i =
    case phead i of
      Nothing -> pempty
      Just i' -> let (l, r) = splitAt i' ps
                     (p:_) = r
                     x = phead p
                     j = ptail i
                 in case x of
                      Nothing -> pswitch1 ps j
                      Just x' -> let ps' = l ++ [ptail p] ++ tail r
                                 in x' `pcons` pswitch1 ps' j

ptail :: P a -> P a
ptail =
    let f [] = []
        f (_:xs) = xs
    in P . f . unP

ptake :: P Int -> P a -> P a
ptake n =
    case phead n of
      Nothing -> error "ptake: empty length pattern"
      Just n' -> P . L.take n' . unP

ptrigger :: P Bool -> P a -> P (Maybe a)
ptrigger (P p) (P q) = P (trigger p q)

pzip :: P a -> P b -> P (a, b)
pzip (P p) (P q) = P (zip p q)

pzip3 :: P a -> P b -> P c -> P (a, b, c)
pzip3 (P p) (P q) (P r) = P (zip3 p q r)

pzipWith :: (a -> b -> c) -> P a -> P b -> P c
pzipWith f (P p) (P q) = P (L.zipWith f p q)

pzipWith3 :: (a -> b -> c -> d) -> P a -> P b -> P c -> P d
pzipWith3 f (P p) (P q) (P r) = P (L.zipWith3 f p q r)

-- * Random patterns

choosea :: R.StdGen -> A.Array Int a -> [a]
choosea g r = 
    let (i, g') = R.randomR (A.bounds r) g
        x = r A.! i
    in x : choosea g' r

pchoose :: String -> P a -> P a
pchoose s (P p) = 
    let g = R.mkStdGen (fromIntegral (H.hashString s))
    in P (choosea g (A.listArray (0, length p - 1) p))

pnoise :: (R.Random a) => String -> P a
pnoise s =
    let g = R.mkStdGen (fromIntegral (H.hashString s))
    in P (R.randoms g)

prand :: String -> [P a] -> P Int -> P a
prand s ps n = 
    case phead n of
      Nothing -> error "prand"
      Just n' -> let g = R.mkStdGen (fromIntegral (H.hashString s))
                     qs = choosea g (A.listArray (0, length ps - 1) ps)
                 in L.foldr pappend pempty (take n' qs)

prand_b :: (R.Random a) => R.StdGen -> P (a,a) -> P a
prand_b g b =
    case phead b of
      Nothing -> pempty
      Just b' -> let (x, g') = R.randomR b' g
                 in pcons x (prand_b g' (ptail b))

pwhite :: (R.Random a) => String -> P a -> P  a -> P a
pwhite s l r =
    let b = pzip (pcycle l) (pcycle r)
        g = R.mkStdGen (fromIntegral (H.hashString s))
    in prand_b g b

-- * Extension

pzipWith_c :: (a -> b -> c) -> P a -> P b -> P c
pzipWith_c f p = pzipWith f p . pcycle

(+.) :: Num a => P a -> P a -> P a
(+.) = pzipWith_c (+)

(*.) :: Num a => P a -> P a -> P a
(*.) = pzipWith_c (*)

(/.) :: Fractional a => P a -> P a -> P a
(/.) = pzipWith_c (/)

(-.) :: Num a => P a -> P a -> P a
(-.) = pzipWith_c (-)