Alternate Score type for csound-expression

Score.hs

{-# Language DeriveFoldable #-}
{-# Language DeriveFunctor #-}
{-# Language DeriveTraversable #-}
{-# Language TypeFamilies #-}

module Score where

import Csound.Base

data Params = Params { duration0 :: !Double, volume0 :: D, sustain0 :: !Double }

params0 :: Params
params0 = Params 0 0 0

-- | A score with statically known duration
data Score a
  = Mel !Double (Score a) (Score a)
  | Har !Double (Score a) (Score a)
  | Sample !Params a
  | Zero deriving (Functor, Foldable, Traversable)

type instance DurOf (Score a) = Double

instance Duration (Score a) where
  dur (Mel d _ _) = d
  dur (Har d _ _) = d
  dur (Sample (Params d _ _) _) = d
  dur Zero = 0

instance Melody (Score a) where
  mel [] = Zero
  mel s = foldr1 h s where
    h s1 s2 = Mel (dur s1 + dur s2) s1 s2

instance Harmony (Score a) where
  har [] = Zero
  har s = foldr1 h s where
    h s1 s2 = Har (dur s1 `max` dur s2) s1 s2

instance Monoid a => Rest (Score a) where
  rest d = Sample (params0 { duration0 = d }) mempty

instance Limit (Score a) where
  lim d s | dur s <= d = s -- we're ok
  lim _ Zero = Zero
  lim d (Sample p f) = Sample (p { duration0 = d }) f
  lim d (Mel _ a b) = if dur a > d then lim d a
                      else mel [a, lim (d - dur a) b]
  lim d (Har _ a b) = har [lim d a, lim d b]

instance Stretch (Score a) where
  str _ Zero = Zero
  str d (Sample p f) = Sample (p { duration0 = duration0 p * d }) f
  str d (Har d0 a b) = Har (d0*d) (str d a) (str d b)
  str d (Mel d0 a b) = Mel (d0*d) (str d a) (str d b)

instance Monoid a => Delay (Score a) where
  del by s = mel [ rest by, s ]

instance Compose (Score a) where

resample :: (Params -> a -> (Params, b)) -> Score a -> Score b
resample f s = case s of
  Zero -> Zero
  Har d a b -> Har d (resample f a) (resample f b)
  Mel d a b -> Mel d (resample f a) (resample f b)
  Sample ps a -> let (ps2,a2) = f ps a in Sample ps2 a2

hold :: Double -> Score a -> Score a
hold d = resample go where
  go (Params dur vol sus) a = (Params dur vol (sus+d), a)

class Playable s where
  playAt :: Params -> s -> SE Sig2

run :: Playable n => Score n -> Sco (Mix Sig2)
run s = case s of
  Zero -> mel []
  Sample params note -> sco (const $ playAt params note) (str (double (dur s)) $ temp (0 :: D))
  Har _ s1 s2 -> run s1 =:= run s2
  Mel _ s1 s2 -> run s1 +:+ run s2

play :: Playable n => Score n -> IO ()
play s = (dac . mix . run) s

data Note = Note D (D -> Params -> SE Sig2)

hz :: Note -> D
hz (Note freq _) = freq

newtype Sound = Sound (Params -> SE Sig2)

patch :: Patch Sig2 -> Score Note -> Score Note
patch f s = resample go s where
  go ps (Note hz _) = (ps, Note hz $ \hz (Params _ vol _) -> ar2 <$> atNote f (vol,hz))

font :: Sf -> Score Note -> Score Note
font f s = resample go s where
  go ps (Note hz _) = (ps, Note hz $ \hz (Params _ vol sus) -> pure (sfCps3 f (double sus) vol hz))

instrument :: (D -> Params -> SE Sig2) -> Score Note -> Score Note
instrument f s = resample go s where
  go ps (Note hz _) = (ps, Note hz f)

timbre :: (D -> Sig) -> Score Note -> Score Note
timbre f = instrument (\hz _ -> pure $ fromMono (f hz))

timbre2 :: (D -> Sig2) -> Score Note -> Score Note
timbre2 f = instrument (\hz _ -> pure $ f hz)

instance Playable Note where
  playAt ps (Note hz f) = f hz ps

instance Playable Sound where
  playAt ps (Sound f) = f ps

instance Monoid Note where
  mempty = Note 0 (\_ _ -> pure (0,0))
  mappend (Note hz1 f1) (Note hz2 f2) = Note (hz1 + hz2) (\hz ps -> (+) <$> f1 hz ps <*> f2 hz ps)

instance Monoid Sound where
  mempty = Sound (\_ -> pure (0,0))
  mappend (Sound f1) (Sound f2) = Sound (\ps -> (+) <$> f1 ps <*> f2 ps)

instance SigSpace Note where
  mapSig f (Note hz g) = Note hz (\hz ps -> mapSig f <$> g hz ps)

instance SigSpace Sound where
  mapSig f (Sound g) = Sound (\ps -> mapSig f <$> g ps)

instance SigSpace a => SigSpace (Score a) where
  mapSig f x = fmap (mapSig f) x

note :: D -> Score Note
note hz = Sample (Params 1 1 0) (Note hz $ \hz (Params _ vol _) -> pure
  (sig vol * osc (sig hz), sig vol * osc (sig hz)))

-- | Transcribe up an octave
up :: Score Note -> Score Note
up = transcribe (2*)

-- | Transcribe down an octave
down :: Score Note -> Score Note
down = transcribe ((1/2) *)

-- | Shift the frequency of notes in this score using the given function
transcribe :: (D -> D) -> Score Note -> Score Note
transcribe freqf = fmap (\(Note hz f) -> Note (freqf hz) f)

-- | Map over the base amplitude of notes in this score
vol :: (D -> D) -> Score a -> Score a
vol f = resample go where
  go (Params d v0 s) a = (Params d (f v0) s, a)

-- e.g. bpm (140/4) is 140 quarter notes per minute
bpm :: Double -> Score a -> Score a
bpm n = str (60 / n)

triplets, wholes, halves, quarters, eighths, sixteenths :: [Score a] -> Score a
triplets = str (1/3*1/4) . mel
wholes = mel
halves = str (1/2) . mel
quarters = str (1/4) . mel
eighths = str (1/8) . mel
sixteenths = str (1/16) . mel

n16, n8, n4, n2, n1 :: [Score a] -> Score a
n16 = sixteenths
n8 = eighths
n4 = quarters
n2 = halves
n1 = wholes

r16, r8, r4, r2, r1 :: Monoid a => Score a
r16 = rest (1/16)
r8 = rest (1/8)
r4 = rest (1/4)
r2 = rest (1/2)
r1 = rest 1

dot :: Score a -> Score a
dot = str (1+1/2)