{-# LANGUAGE NoMonomorphismRestriction #-}
module Sound.Tidal.Dirt where

import Sound.OSC.FD (Datum)
import qualified Data.Map as Map
import Control.Applicative
import Control.Concurrent.MVar
--import Visual
import Data.Colour.SRGB
import Data.Colour.Names
import Data.Hashable
import Data.Bits
import Data.Maybe
import Data.Fixed
import Data.Ratio
import Data.List (elemIndex, sort)

import Sound.Tidal.Stream
import Sound.Tidal.OscStream
import Sound.Tidal.Pattern
import Sound.Tidal.Parse
import Sound.Tidal.Params
import Sound.Tidal.Time
import Sound.Tidal.Tempo
import Sound.Tidal.Transition (transition, wash)
import Sound.Tidal.Utils (enumerate, fst')

dirt :: Shape
dirt = Shape {   params = [ s_p,
                            offset_p,
                            begin_p,
                            end_p,
                            speed_p,
                            pan_p,
                            velocity_p,
                            vowel_p,
                            cutoff_p,
                            resonance_p,
                            accelerate_p,
                            shape_p,
                            kriole_p,
                            gain_p,
                            cut_p,
                            delay_p,
                            delaytime_p,
                            delayfeedback_p,
                            crush_p,
                            coarse_p,
                            hcutoff_p,
                            hresonance_p,
                            bandf_p,
                            bandq_p,
                            unit_p,
                            loop_p,
                            n_p,
                            attack_p,
                            hold_p,
                            release_p
                          ],
                 cpsStamp = True,
                 latency = 0.3
                }

dirtSlang = OscSlang {
  path = "/play",
  timestamp = MessageStamp,
  namedParams = False,
  preamble = []
  }

superDirtSlang = dirtSlang { timestamp = BundleStamp, path = "/play2", namedParams = True }

superDirtBackend port = do
  s <- makeConnection "127.0.0.1" port superDirtSlang
  return $ Backend s (\_ _ _ -> return ())

superDirtState port = do
  backend <- superDirtBackend port
  Sound.Tidal.Stream.state backend dirt

dirtBackend = do
  s <- makeConnection "127.0.0.1" 7771 dirtSlang
  return $ Backend s (\_ _ _ -> return ())

-- dirtstart name = start "127.0.0.1" 7771 dirt

dirtStream = do
  backend <- dirtBackend
  stream backend dirt

dirtState = do
  backend <- dirtBackend
  Sound.Tidal.Stream.state backend dirt

dirtSetters :: IO Time -> IO (ParamPattern -> IO (), (Time -> [ParamPattern] -> ParamPattern) -> ParamPattern -> IO ())
dirtSetters getNow = do ds <- dirtState
                        return (setter ds, transition getNow ds)

superDirtSetters :: IO Time -> IO (ParamPattern -> IO (), (Time -> [ParamPattern] -> ParamPattern) -> ParamPattern -> IO ())
superDirtSetters getNow = do ds <- superDirtState 57120
                             return (setter ds, transition getNow ds)


superDirts :: [Int]  -> IO [(ParamPattern -> IO (), (Time -> [ParamPattern] -> ParamPattern) -> ParamPattern -> IO ())]
superDirts ports = do (_, getNow) <- cpsUtils
                      states <- mapM (superDirtState) ports
                      return $ map (\state -> (setter state, transition getNow state)) states

-- -- disused parameter..
dirtstream _ = dirtStream

-- doubledirt = do remote <- stream "178.77.72.138" 7777 dirt
--                 local <- stream "192.168.0.102" 7771 dirt
--                 return $ \p -> do remote p
--                                   local p
--                                   return ()


dirtToColour :: ParamPattern -> Pattern ColourD
--dirtToColour p = s
--  where s = fmap (\x -> maybe black (datumToColour) (Map.lookup (param dirt "s") x)) p
dirtToColour = fmap (stringToColour . show)

showToColour :: Show a => a -> ColourD
showToColour = stringToColour . show

datumToColour :: Value -> ColourD
datumToColour = showToColour

stringToColour :: String -> ColourD
stringToColour s = sRGB (r/256) (g/256) (b/256)
  where i = (hash s) `mod` 16777216
        r = fromIntegral $ (i .&. 0xFF0000) `shiftR` 16;
        g = fromIntegral $ (i .&. 0x00FF00) `shiftR` 8;
        b = fromIntegral $ (i .&. 0x0000FF);

{-
visualcallback :: IO (ParamPattern -> IO ())
visualcallback = do t <- ticker
                    mv <- startVis t
                    let f p = do let p' = dirtToColour p
                                 swapMVar mv p'
                                 return ()
                    return f
-}

--dirtyvisualstream name = do cb <- visualcallback
--                            streamcallback cb "127.0.0.1" "127.0.0.1" name "127.0.0.1" 7771 dirt

pick :: String -> Int -> String
pick name n = name ++ ":" ++ (show n)

{- | Striate is a kind of granulator, for example:

@
d1 $ striate 3 $ sound "ho ho:2 ho:3 hc"
@

This plays the loop the given number of times, but triggering
progressive portions of each sample. So in this case it plays the loop
three times, the first time playing the first third of each sample,
then the second time playing the second third of each sample, etc..
With the highhat samples in the above example it sounds a bit like
reverb, but it isn't really.

You can also use striate with very long samples, to cut it into short
chunks and pattern those chunks. This is where things get towards
granular synthesis. The following cuts a sample into 128 parts, plays
it over 8 cycles and manipulates those parts by reversing and rotating
the loops.

@
d1 $  slow 8 $ striate 128 $ sound "bev"
@
-}

striate :: Pattern Int -> ParamPattern -> ParamPattern
striate = temporalParam _striate

_striate :: Int -> ParamPattern -> ParamPattern
_striate n p = fastcat $ map (\x -> off (fromIntegral x) p) [0 .. n-1]
  where off i p = p
                  # begin (atom (fromIntegral i / fromIntegral n))
                  # end (atom (fromIntegral (i+1) / fromIntegral n))

{-|
The `striate'` function is a variant of `striate` with an extra
parameter, which specifies the length of each part. The `striate'`
function still scans across the sample over a single cycle, but if
each bit is longer, it creates a sort of stuttering effect. For
example the following will cut the bev sample into 32 parts, but each
will be 1/16th of a sample long:

@
d1 $ slow 32 $ striate' 32 (1/16) $ sound "bev"
@

Note that `striate` uses the `begin` and `end` parameters
internally. This means that if you're using `striate` (or `striate'`)
you probably shouldn't also specify `begin` or `end`. -}
striate' :: Pattern Int -> Pattern Double -> ParamPattern -> ParamPattern
striate' = temporalParam2 _striate'

_striate' :: Int -> Double -> ParamPattern -> ParamPattern
_striate' n f p = fastcat $ map (\x -> off (fromIntegral x) p) [0 .. n-1]
  where off i p = p # begin (atom (slot * i) :: Pattern Double) # end (atom ((slot * i) + f) :: Pattern Double)
        slot = (1 - f) / (fromIntegral n)

{- | like `striate`, but with an offset to the begin and end values -}
striateO :: Pattern Int -> Pattern Double -> ParamPattern -> ParamPattern
striateO = temporalParam2 _striateO

_striateO :: Int -> Double -> ParamPattern -> ParamPattern
_striateO n o p = _striate n p |+| begin (atom o :: Pattern Double) |+| end (atom o :: Pattern Double)

{- | Just like `striate`, but also loops each sample chunk a number of times specified in the second argument.
The primed version is just like `striate'`, where the loop count is the third argument. For example:

@
d1 $ striateL' 3 0.125 4 $ sound "feel sn:2"
@

Like `striate`, these use the `begin` and `end` parameters internally, as well as the `loop` parameter for these versions.
-}
striateL :: Pattern Int -> Pattern Int -> ParamPattern -> ParamPattern
striateL = temporalParam2 _striateL

striateL' :: Pattern Int -> Pattern Double -> Pattern Int -> ParamPattern -> ParamPattern
striateL' = temporalParam3 _striateL'

_striateL :: Int -> Int -> ParamPattern -> ParamPattern
_striateL n l p = _striate n p # loop (atom $ fromIntegral l)
_striateL' n f l p = _striate' n f p # loop (atom $ fromIntegral l)

metronome = _slow 2 $ sound (p "[odx, [hh]*8]")

{-|
Also degrades the current pattern and undegrades the next.
To change the number of cycles the transition takes, you can use @clutchIn@ like so:

@
d1 $ sound "bd(5,8)"

t1 (clutchIn 8) $ sound "[hh*4, odx(3,8)]"
@

will take 8 cycles for the transition.
-}
clutchIn :: Time -> Time -> [Pattern a] -> Pattern a
clutchIn _ _ [] = silence
clutchIn _ _ (p:[]) = p
clutchIn t now (p:p':_) = overlay (fadeOut' now t p') (fadeIn' now t p)

{-|
Degrades the current pattern while undegrading the next.

This is like @xfade@ but not by gain of samples but by randomly removing events from the current pattern and slowly adding back in missing events from the next one.

@
d1 $ sound "bd(3,8)"

t1 clutch $ sound "[hh*4, odx(3,8)]"
@

@clutch@ takes two cycles for the transition, essentially this is @clutchIn 2@.
-}
clutch :: Time -> [Pattern a] -> Pattern a
clutch = clutchIn 2

{- | crossfades between old and new pattern over given number of cycles, e.g.:

@
d1 $ sound "bd sn"

t1 (xfadeIn 16) $ sound "jvbass*3"
@

Will fade over 16 cycles from "bd sn" to "jvbass*3"
-}
xfadeIn :: Time -> Time -> [ParamPattern] -> ParamPattern
xfadeIn _ _ [] = silence
xfadeIn _ _ (p:[]) = p
xfadeIn t now (p:p':_) = overlay (p |*| gain (now `rotR` (_slow t envEqR))) (p' |*| gain (now `rotR` (_slow t (envEq))))

{- |
Crossfade between old and new pattern over the next two cycles.

@
d1 $ sound "bd sn"

t1 xfade $ sound "can*3"
@

`xfade` is built with `xfadeIn` in this case taking two cycles for the fade.
-}
xfade :: Time -> [ParamPattern] -> ParamPattern
xfade = xfadeIn 2

{- | Stut applies a type of delay to a pattern. It has three parameters,
which could be called depth, feedback and time. Depth is an integer
and the others floating point. This adds a bit of echo:

@
d1 $ stut 4 0.5 0.2 $ sound "bd sn"
@

The above results in 4 echos, each one 50% quieter than the last,
with 1/5th of a cycle between them. It is possible to reverse the echo:

@
d1 $ stut 4 0.5 (-0.2) $ sound "bd sn"
@
-}

stut :: Pattern Integer -> Pattern Double -> Pattern Rational -> ParamPattern -> ParamPattern
stut = temporalParam3 _stut

_stut :: Integer -> Double -> Rational -> ParamPattern -> ParamPattern
_stut steps feedback time p = stack (p:(map (\x -> (((x%steps)*time) `rotR` (p |*| gain (pure $ scale (fromIntegral x))))) [1..(steps-1)]))
  where scale x
          = ((+feedback) . (*(1-feedback)) . (/(fromIntegral steps)) . ((fromIntegral steps)-)) x

{- | Instead of just decreasing volume to produce echoes, @stut'@ allows to apply a function for each step and overlays the result delayed by the given time.

@
d1 $ stut' 2 (1%3) (# vowel "{a e i o u}%2") $ sound "bd sn"
@

In this case there are two _overlays_ delayed by 1/3 of a cycle, where each has the @vowel@ filter applied.
-}
stut' :: Pattern Int -> Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
stut' n t f p = unwrap $ (\a b -> _stut' a b f p) <$> n <*> t

_stut' :: (Num n, Ord n) => n -> Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
_stut' steps steptime f p | steps <= 0 = p
                         | otherwise = overlay (f (steptime `rotR` _stut' (steps-1) steptime f p)) p

{- | @durPattern@ takes a pattern and returns the length of events in that
pattern as a new pattern.  For example the result of `durPattern "[a ~] b"`
would be `"[0.25 ~] 0.5"`.
-}

durPattern :: Pattern a -> Pattern Time
durPattern p = Pattern $ \a -> map eventLengthEvent $ arc p a
  where eventLengthEvent (a1@(s1,e1), a2, x) = (a1, a2, e1-s1)

{- | @durPattern'@ is similar to @durPattern@, but does some lookahead to try
to find the length of time to the *next* event. For example, the result of
`durPattern' "[a ~] b"` would be `"[0.5 ~] 0.5"`.
-}

durPattern' :: Pattern a -> Pattern Time
durPattern' p = Pattern $ \a@(s,e) -> map (eventDurToNext (arc p (s,e+1))) (arc p a)
      where eventDurToNext evs ev@(a1,a2,x) = (a1, a2, (nextNum (t ev) (mt evs)) - (t ev))
            t = fst . fst'
            mt = (map fst) . (map fst')
            nextNum a = head . sort . filter (\x -> x >a)

{- | @stutx@ is like @stut'@ but will limit the number of repeats using the 
duration of the original sound.  This usually prevents overlapping "stutters"
from subsequent sounds.
-}

stutx :: Pattern Int -> Pattern Time -> (Pattern a -> Pattern a) -> Pattern a -> Pattern a
stutx n t f p = stut' (liftA2 min n (fmap floor $ durPattern' p / (t+0.001))) t f p

{-| same as `anticipate` though it allows you to specify the number of cycles until dropping to the new pattern, e.g.:

@
d1 $ sound "jvbass(3,8)"

t1 (anticipateIn 4) $ sound "jvbass(5,8)"
@-}
anticipateIn :: Time -> Time -> [ParamPattern] -> ParamPattern
anticipateIn t now = wash (spread' (_stut 8 0.2) (now `rotR` (_slow t $ (toRational . (1-)) <$> envL))) t now

{- | `anticipate` is an increasing comb filter.

Build up some tension, culminating in a _drop_ to the new pattern after 8 cycles.
-}
anticipate :: Time -> [ParamPattern] -> ParamPattern
anticipate = anticipateIn 8

{- | Copies the @n@ parameter to the @orbit@ parameter, so different sound variants or notes go to different orbits in SuperDirt. -}
nToOrbit = copyParam n_p orbit_p

{- | Maps the sample or synth names to different @orbit@s, using indexes from the given list. E.g. @soundToOrbit ["bd", "sn", "cp"] $ sound "bd [cp sn]"@ would cause the bd, sn and cp smamples to be sent to orbit 0, 1, 2 respectively.-}
soundToOrbit :: [String] -> ParamPattern -> ParamPattern
soundToOrbit sounds p = follow s_p orbit_p ((\s -> fromMaybe 0 $ elemIndex s sounds) <$>) p