tidalAsLibrary.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RebindableSyntax #-}
import Prelude
import Sound.Tidal.Context
import qualified Foreign.Store as ForeignStore
import Data.Word (Word32)
import Data.String (fromString)
import Control.Arrow ((>>>))

-- Runs computation once. Persists across ghci sessions.
runOnce :: Word32 -> IO a -> IO a
runOnce index computation = do
  result <- ForeignStore.lookupStore index
  case result of
    Nothing -> do
      x <- computation
      ForeignStore.writeStore (ForeignStore.Store index) x
      return x
    Just store -> ForeignStore.readStore (ForeignStore.Store index)

newtype Func a = Func {appFunc :: a -> a }
instance Monoid (Func a) where
  mempty = Func id
  mappend (Func f) (Func g) = Func (g . f)

main :: IO ()
main = do
  (cps, d1,t1) <- runOnce 0 $ do
    (cps, getNow) <- bpsUtils
    (d1, t1) <- superDirtSetters getNow
    return (cps, d1, t1)
  cps (80/60)
  d1 $ prog silence

rotL :: Time -> Pattern a -> Pattern a
rotL t p = withResultTime (subtract t) $ withQueryTime (+ t) p

add x y = stack [x, y]
addMod f x = add (f x) x
appendMod f x = append' (f x) x
catMod mods x = slowcat (fmap ($x) mods)
patMod mods x = tt (recip . fromIntegral $ length mods) (catMod mods) x
tt x f = (slow x) . f. (slow (1/x))

fastcatMod mods x = cat (fmap ($x) mods)

prog :: Pattern ParamMap -> Pattern ParamMap
prog = let (>>) = (>>>) in add $ ($ silence) $ do
  const $ sound $ samples "[[~ bd] ~ feelfx sn]*4" ((+4) <$> run 4)
  slow 4
  addMod $ do
    const $ sound $ samples "gab*2" (run 2)
    patMod
      [ tt 4 $ chop 4
      , tt 2 $ chop 2
      , tt 1 $ chop 2
      , tt 1 $ chop 4
      ]
    (# speed "1 2 4 0.5")
  (# gain "0.8")
  addMod $ do
    const $ sound $ samples "808cy*8" (fmap (+8) $ run 8)
    catMod
      [ slow 1
      , slow 2
      ]
    catMod
      [ slow 1
      , slow 2
      ]
    catMod [id, id]
  (# cut "1")
  tt 4 $ catMod
    [ tt 0.25 $ (|*| speed (fmap ((+1) . (*0.5)) sine))
    , tt 1 $ (|*| speed (fmap ((+1) . (*1)) sine))
    ]
  tt 1.5 $ patMod
    [ tt 16 $ chop 2
    , tt 16 $ chop 16
    ]
  -- tt 3 (|*| speed "1 2 0.5")
  -- tt 2 (|*| speed "1 2 0.5")
  -- tt 0.5 (|*| speed "1 2 0.5")

  appendMod $ tt 1 $ trunc 0.5
  appendMod $ tt 1 $ trunc 0.5