testAccSynth.hs

{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts, Arrows #-}
module Main where
import Euterpea.IO.Audio.Accelerate.BasicSigFuns
import Control.Monad ( when, unless )
import Data.List ( intersperse )
import System.Exit ( exitFailure )
import System.IO ( hPutStrLn, stderr )
import Euterpea.IO.Audio.Accelerate.Basics
import Euterpea.IO.Audio.Accelerate.IO
import Euterpea.IO.Audio.Accelerate.BasicSigFuns
import qualified Data.Array.Accelerate as A
import Euterpea.IO.Audio.Types hiding (Clock)
import Euterpea.IO.Audio.Types (Backend(..))
import GHC.TypeLits (KnownNat)
import qualified Data.Vector.Storable as DVS
import qualified Sound.MIDI.Message as Msg
import qualified Sound.MIDI.Message.Channel as ChannelMsg
import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg

import qualified Sound.JACK.MIDI as MIDI
import qualified Sound.JACK.Audio as Audio
import qualified Sound.JACK as JACK
import Foreign.C.Types (CFloat(..))
import qualified Data.EventList.Absolute.TimeBody as EventList

import qualified Control.Monad.Exception.Synchronous as Sync
import qualified Control.Monad.Trans.State.Strict as MS
import qualified Control.Monad.Trans.Class as Trans
import qualified Foreign.C.Error as E
import Foreign.Marshal.Array (copyArray)

import System.Environment (getProgName, )

import qualified Data.StorableVector.Base as SVB

import Data.IORef (IORef, newIORef, readIORef, writeIORef, )

import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg
import Sound.MIDI.Message.Channel.Voice (Pitch, )

import qualified Data.StorableVector.ST.Strict as SVST
import qualified Data.StorableVector as SV

import Foreign.Storable (Storable, )
import Control.Monad.ST.Strict as ST

import qualified Control.Monad.Trans.State.Strict as MS

import qualified Data.Map as Map

import Control.Monad (liftM, )

import Debug.Trace (trace, )
import Debug.Hoed.Pure 
import Control.Arrow
import Control.Arrow.Operations
import Control.Arrow.ArrowP

sineWave
    :: forall c i a l.
       (Clock c, KnownNat l)
    => Int -> Signal c (A.Acc (A.Array A.DIM1 a)) (AccSample i l)
sineWave rate =
           let freq = A.constant 440.0 :: A.Exp Float
               nrm = A.unit ( A.lift True)
               sz = A.unit (A.lift rate)
               tbl = funToTable (A.sin) nrm sz
             
           in proc _ -> do  osc tbl (A.constant 0) -< freq

check :: Monad m => Bool -> String -> m () -> m ()
check b msg act =
    if not b
        then trace msg $ return ()
        else act

unsafeAddChunkToBuffer :: 
   SVST.Vector s CFloat -> Int -> DVS.Vector Float -> ST s ()
unsafeAddChunkToBuffer v start xs =
    let go i j =
            if j >= DVS.length xs
                then return ()
                else SVST.unsafeModify v i ( CFloat (xs DVS.! j) +) >>
                     go (i + 1) (j + 1)
    in
       check (start >= 0) ("start negative: " ++ show (start, DVS.length xs)) $
       check
           (start <= SVST.length v)
           ("start too late: " ++ show (start, DVS.length xs)) $
       check
           (start + DVS.length xs <= SVST.length v)
           ("end too late: " ++ show (start, DVS.length xs)) $
       check
           (1 == 1)
           ("Everything is cool") $
       go start 0

type Size = Int
data OscillatorState a = OscillatorState a a Int

type State a = Map.Map Pitch (OscillatorState a)

arrange
 :: Size -> [(Int, DVS.Vector Float)] -> SV.Vector CFloat
arrange size evs =
    SVST.runSTVector
        (do v <- SVST.new (fromIntegral size) 0
            mapM_ (uncurry $ unsafeAddChunkToBuffer v) evs
            return v)

instance Clock AudRate where
    rate _ = 96000

gen sig = runToStorable sig (A.fromList (A.Z A.:. 1) [0])

renderTone
    :: ( Storable a, Floating a, Monad m) =>
     Int -> MS.StateT (State a) m [(Int, DVS.Vector Float)]
renderTone rate =
    let pt = \x -> x
        checkItOut = observe "generated data" pt
        sig =
            sineWave rate :: Signal (AudRate) (A.Acc (A.Array A.DIM1 Int)) (AccSample LLVM 96000)
    in return [( checkItOut 1, gen sig), (2, gen sig)]

run
    :: (Storable a, Floating a, Monad m)
    => Int -> Int -> MS.StateT (State a) m  (SV.Vector CFloat)
run size rate = liftM (arrange size) $ renderTone rate

mainWait client name =
    JACK.withActivation client $
    Trans.lift $
    do putStrLn $ "started " ++ name ++ "..."
       JACK.waitForBreak
        
initialState :: State a
initialState = Map.empty

main :: IO ()
main = runO $
  do
    name <- getProgName
    let name' = observe "name" name
    stateRef <- newIORef initialState
    JACK.handleExceptions $
        JACK.withClientDefault name' $
        \client ->
                  JACK.withPort client "output" $
                  \output ->
                       JACK.withProcess
                           client
                           (process client stateRef output) $
                       mainWait client name

runStateOnIORef :: IORef s -> MS.State s a -> IO a
runStateOnIORef ref m = do
    (a,state) <- fmap (MS.runState m) $ readIORef ref
    writeIORef ref state
    return a

intFromNFrames :: Integral i => JACK.NFrames -> i
intFromNFrames (JACK.NFrames n) = fromIntegral n

process
    :: JACK.Client
    -> IORef (State Audio.Sample)
    -> Audio.Port JACK.Output
    -> JACK.NFrames
    -> Sync.ExceptionalT E.Errno IO ()
process client stateRef output nframes = do
    Trans.lift $
        do rate <- JACK.getSampleRate client
           let rate' = observe "rate" rate
           putStrLn $ "rate " ++  show rate'
           outArr <- Audio.getBufferPtr output nframes
           putStrLn $ "got output buffer" 
           block <-
               runStateOnIORef stateRef $
               run (intFromNFrames nframes) rate' :: IO (SVB.Vector Audio.Sample)
           putStrLn $ "writing to output" 
           SVB.withStartPtr block $
               \src len -> do
                    putStrLn "This won't print.  :("
                    copyArray outArr src len

The SVB.withStartPtr call in process bails with a printf: argument list ended prematurely at runtime.

building with -prof and running with +RTS -xc replaces the above error with Segmentation fault: 11