Strategies.hs

{-# OPTIONS_GHC -XNoMonomorphismRestriction #-}

module Sound.Tidal.Strategies where

import Data.Ratio
import Control.Applicative
import qualified Data.Map as Map

import Data.Maybe
import Sound.Tidal.Dirt
import Sound.Tidal.Pattern
import Sound.Tidal.Stream
import Sound.Tidal.Time
import Sound.Tidal.Utils
import Sound.Tidal.Params
import qualified Sound.OSC.FD as OSC.FD

stutter n t p = stack $ map (\i -> (t * (fromIntegral i)) ~> p) [0 .. (n-1)]

echo   = stutter 2
triple = stutter 3
quad   = stutter 4
double = echo

jux f p = stack [p # pan (pure 0), f $ p # pan (pure 1)]
juxcut f p = stack [p     # pan (pure 0) # cut (pure (-1)), 
                    f $ p # pan (pure 1) # cut (pure (-2))
                   ]

jux' fs p = stack $ map (\n -> ((fs !! n) p) # pan (pure $ fromIntegral n / fromIntegral l)) [0 .. l-1]
  where l = length fs

-- For multichannel
jux4 f p = stack [p # pan (pure (5/8)), f $ p # pan (pure (1/8))]

juxBy n f p = stack [p # pan (pure $ 0.5 - (n/2)), f $ p # pan (pure $ 0.5 + (n/2))]

-- every 4 (smash 4 [1, 2, 3]) $ sound "[odx sn/2 [~ odx] sn/3, [~ hh]*4]"

smash n xs p = slowcat $ map (\n -> slow n p') xs
  where p' = striate n p

smash' n xs p = slowcat $ map (\n -> slow n p') xs
  where p' = chop n p

-- samples "jvbass [~ latibro] [jvbass [latibro jvbass]]" ((1%2) <~ slow 6 "[1 6 8 7 3]")

samples :: Applicative f => f String -> f Int -> f String
samples p p' = pick <$> p <*> p'

samples' :: Applicative f => f String -> f Int -> f String
samples' p p' = (flip pick) <$> p' <*> p

{-
scrumple :: Time -> Pattern a -> Pattern a -> Pattern a
scrumple o p p' = p'' -- overlay p (o ~> p'')
  where p'' = Pattern $ \a -> concatMap 
                              (\((s,d), vs) -> map (\x -> ((s,d),
                                                           snd x
                                                          )
                                                   )
                                                   (arc p' (s,s))
                              ) (arc p a)
-}

--rev :: Pattern a -> Pattern a
--rev p = Pattern $ \a -> concatMap 
--                        (\a' -> mapFsts mirrorArc $ 
--                                (arc p (mirrorArc a')))
--                        (arcCycles a)

--spreadf :: [Pattern a -> Pattern b] -> Pattern a -> Pattern b
spreadf ts p = spread ($)

spin :: Int -> OscPattern -> OscPattern
spin copies p =
  stack $ map (\n -> let offset = toInteger n % toInteger copies in
                     offset <~ p
                     # pan (pure $ fromRational offset)
              )
          [0 .. (copies - 1)]

{-stripe :: Arc -> Pattern a -> Pattern a
stripe (stripeS, stripeE) p = slow t $ Pattern $ \a -> concatMap f $ arcCycles a
  where f a = mapFsts (stretch . stripe') $ arc p (stripe' a)
        trunc' (s,e) = (min s ((sam s) + t), min e ((sam s) + t))
        stretch (s,e) = (sam s + ((s - sam s) / t), sam s + ((e - sam s) / t))
-}

sawwave4 = ((*4) <$> sawwave1)
sinewave4 = ((*4) <$> sinewave1)
rand4 = ((*4) <$> rand)

stackwith p ps | null ps = silence
               | otherwise = stack $ map (\(i, p') -> p' # (((fromIntegral i) % l) <~ p)) (zip [0 ..] ps)
  where l = fromIntegral $ length ps

{-
cross f p p' = Pattern $ \t -> concat [filter flt $ arc p t,
                                       filter (not . flt) $ arc p' t
                                      ]
]  where flt = f . cyclePos . fst . fst
-}

inside n f p = density n $ f (slow n p)

scale :: (Functor f, Num b) => b -> b -> f b -> f b
scale from to p = ((+ from) . (* (to-from))) <$> p

chop :: Int -> OscPattern -> OscPattern
chop n p = Pattern $ \queryA -> concatMap (f queryA) $ arcCycles queryA
     where f queryA a = concatMap (chopEvent queryA) (arc p a)
           chopEvent (queryS, queryE) (a,a',v) = map (newEvent v) $ filter (\(_, (s,e)) -> not $ or [e < queryS, s >= queryE]) (enumerate $ chopArc a n)
           newEvent :: OscMap -> (Int, Arc) -> Event OscMap
           newEvent v (i, a) = (a,a,Map.insert (param dirt "end") (Just $ OSC.FD.float ((fromIntegral $ i+1)/(fromIntegral n))) $ Map.insert (param dirt "begin") (Just $ OSC.FD.float ((fromIntegral i)/(fromIntegral n))) v)

gap :: Int -> OscPattern -> OscPattern
gap n p = Pattern $ \queryA -> concatMap (f queryA) $ arcCycles queryA
     where f queryA a = concatMap (chopEvent queryA) (arc p a)
           chopEvent (queryS, queryE) (a,a',v) = map (newEvent v) $ filter (\(_, (s,e)) -> not $ or [e < queryS, s >= queryE]) (enumerate $ everyOther $ chopArc a n)
           newEvent :: OscMap -> (Int, Arc) -> Event OscMap
           newEvent v (i, a) = (a,a,Map.insert (param dirt "end") (Just $ OSC.FD.float ((fromIntegral $ i+1)/(fromIntegral n))) $ Map.insert (param dirt "begin") (Just $ OSC.FD.float ((fromIntegral i)/(fromIntegral n))) v)
           everyOther (x:(y:xs)) = x:(everyOther xs)
           everyOther xs = xs

chopArc :: Arc -> Int -> [Arc]
chopArc (s, e) n = map (\i -> ((s + (e-s)*(fromIntegral i/fromIntegral n)), s + (e-s)*((fromIntegral $ i+1)/fromIntegral n))) [0 .. n-1]
{-
normEv :: Event a -> Event a -> Event a
normEv ev@(_, (s,e), _) ev'@(_, (s',e'), _) 
       | not on && not off = [] -- shouldn't happen
       | on && off = splitEv ev'
       | not on && s' > sam s = []
       | not off && e' < nextSam s = [(fst' ev, mapSnd' (mapSnd (min $ nextSam s)) ev, thd' ev)]
  where on = onsetIn (sam s, nextSam s) ev
        off = offsetIn (sam s, nextSam s) ev
        eplitEv
-}
--mapCycleEvents :: Pattern a -> ([Event a] -> [Event a]) -> Pattern a
--mapCycleEvents p f = splitQueries $ Pattern $ \(s,e) -> filter (\ev -> isJust $ subArc (s,e) (eventArc ev)) $ f $ arc p (sam s, nextSam s)

--off :: Time -> Pattern a -> Pattern a
--off t p = mapCycleEvents p (mapArcs (mapSnd wrappedPlus . mapFst wrappedPlus))
--               where wrapAtCycle f t' = sam t' + cyclePos (f t')
--                     wrappedPlus = wrapAtCycle (+t)


en :: [(Int, Int)] -> Pattern String -> Pattern String
en ns p = stack $ map (\(i, (k, n)) -> e k n (samples p (pure i))) $ enumerate ns

weave :: Rational -> OscPattern -> [OscPattern] -> OscPattern
weave t p ps = weave' t p (map (\x -> (x #)) ps)

weave' :: Rational -> Pattern a -> [Pattern a -> Pattern a] -> Pattern a
weave' t p fs | l == 0 = silence
              | otherwise = slow t $ stack $ map (\(i, f) -> (fromIntegral i % l) <~ (density t $ f (slow t p))) (zip [0 ..] fs)
  where l = fromIntegral $ length fs

interlace :: OscPattern -> OscPattern -> OscPattern
interlace a b = weave 16 (shape $ ((* 0.9) <$> sinewave1)) [a, b]

-- Step sequencing
step :: String -> String -> Pattern String
step s steps = cat $ map f steps
    where f c | c == 'x' = atom s
              | c >= '0' && c <= '9' = atom $ s ++ ":" ++ [c]
              | otherwise = silence

steps :: [(String, String)] -> Pattern String
steps = stack . map (\(a,b) -> step a b)

off :: Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
off t f p = superimpose (f . (t ~>)) p

offadd :: Num a => Time -> a -> Pattern a -> Pattern a
offadd t n p = off t ((+n) <$>) p

up :: Pattern Double -> OscPattern
up = speed . ((1.059466**) <$>)