JACK.hs

{-
    JACK bindings for Haskell
    Copyright (C) 2007 Soenke Hahn

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License along
    with this program; if not, write to the Free Software Foundation, Inc.,
    51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
-}

{-|

The Jack module defines types and functions that allows you to
use the JACK Audio Connection Kit.

-}
module Sound.JACK
  (
    CFloat,
    CUInt,

    Client,
    Input,
    Output,
    newClient,
    newClientSimple,
    newInput,
    newOutput,
    activate,
    clientClose,
    getPorts,
    connect,
    setProcessMono,
    setProcessStereo,

    mainMono,
    mainStereo,
 )
    where

import qualified Sound.JACK.FFI as JackFFI
import Sound.JACK.FFI (flagsToWord, wordToFlags)

import Foreign (newForeignPtr_, malloc, peek, peekArray0)
import Foreign.Ptr (Ptr, FunPtr, nullPtr)
import Foreign.C.String (newCString, peekCString)
import Foreign.C.Types (CUInt, CInt, CChar, CFloat, CULong)
import Control.Concurrent (MVar, putMVar, newEmptyMVar, takeMVar, threadDelay)

import System.Posix.Signals (installHandler, keyboardSignal, Handler(Catch))
import System.Environment (getProgName)
import Control.Monad (when)
import System.Random hiding (split)
import Data.Array.Storable
          (StorableArray, Ix(range, index, inRange), readArray, writeArray,
           unsafeForeignPtrToStorableArray)


-- | Handles of Jack clients
newtype Client = Client (Ptr ())
-- | Handles of Jack input ports
newtype Input = Input (Ptr ())
-- | Handles of Jack output ports
newtype Output = Output (Ptr ())

-- | Constructs a new Jack client.
newClient :: String -- ^ name of the JACK server
    -> String -- ^ name of the client
    -> IO Client
newClient server name = do
    cserverS <- newCString server
    cclientS <- newCString name
    status <- malloc
    let opt = flagsToWord [JackFFI.ServerName, JackFFI.NoStartServer]
    client <- JackFFI.client_open cclientS opt status cserverS
    checkStatus client status
    return (Client client)

-- | Creates a new JACK client with the "default" server
newClientSimple :: String -- ^ name of the client
    -> IO Client
newClientSimple name = newClient "default" name

checkStatus :: Ptr a -> Ptr CULong -> IO ()
checkStatus c s = do
    errCode <- peek s
    when (c == nullPtr) (failStatus errCode)
    when (errCode /= 0)
       (putStrLn $ "warning: " ++ show (wordToFlags errCode :: [JackFFI.Status]))

failStatus :: CULong -> IO ()
failStatus errCode =
    fail ("jack_client_open returned a nullPointer. Returned errorcodes: "
            ++ show (wordToFlags errCode :: [JackFFI.Status]))

-- | creates a new input port for the given client
newInput :: Client -- ^ Jack client
    -> String -- ^ name of the input port
    -> IO Input
newInput (Client client) portName = do
    cstring <- newCString portName
    audio_type <- newCString "32 bit float mono audio"
--     putStrLn ("register..." ++ show (client, cstring, audio_type, 1, 0))
    ret <- JackFFI.port_register client cstring audio_type 1 0
--     putStrLn "register..."
    return $ Input ret

-- | creates a new output port
newOutput :: Client -- ^ Jack client
    -> String -- ^ name of the output port
    -> IO Output
newOutput (Client client) portName = do
    cstring <- newCString portName
    audio_type <- newCString "32 bit float mono audio"
    ret <- JackFFI.port_register client cstring audio_type 2 0
    return $ Output ret


-- | activates the given Jack client
activate :: Client -> IO ()
activate client = do
    JackFFI.activate $ getClient client
    return ()

-- | closes the given Jack client without causing any trouble (hopefully)
clientClose :: Client -> [Input] -> [Output] -> IO ()
clientClose client inports outports = do
    mapM (JackFFI.port_unregister (getClient client)) (map getInput inports)
    mapM (JackFFI.port_unregister (getClient client)) (map getOutput outports)
    JackFFI.deactivate (getClient client)
    JackFFI.client_close (getClient client)
    return ()

type Process = CUInt -> Ptr (CChar) -> IO (CInt)
foreign import ccall "wrapper" mkProcess :: Process -> IO (FunPtr Process)


getClient :: Client -> Ptr ()
getClient (Client x) = x

getInput :: Input -> Ptr ()
getInput (Input x) = x

getOutput :: Output -> Ptr ()
getOutput (Output x) = x

-- | returns the names of all existing ports of the given Jack client
getPorts :: Client -- ^ the Jack client
    -> IO [String] -- ^ the names as a list of strings
getPorts client = do
    empty <- newCString ""
    strArray <- JackFFI.get_ports (getClient client) empty empty 0
    peekArray0 nullPtr strArray >>= mapM peekCString


connect :: Client -> String -> String -> IO()
connect client outport inport = do
    outCString <- newCString outport
    inCString <- newCString inport
    JackFFI.connect (getClient client) outCString inCString
    return ()


quit :: MVar () -> Client -> [Input] -> [Output] -> IO ()
quit mvar client ins outs = do
    putStrLn "quitting..."
    clientClose client ins outs
    threadDelay 1000000
    putMVar mvar ()



mainMono :: (CFloat -> IO CFloat) -> IO ()
mainMono fun = do
    name <- getProgName
    client <- newClientSimple name

    input <- newInput client "input"
    output <- newOutput client "output"


    setProcessMono client input fun output

    activate client
    putStrLn $ "started " ++ name ++ "..."

    mvar <- newEmptyMVar
    installHandler keyboardSignal (Catch (quit mvar client [input] [output])) Nothing
    takeMVar mvar

setProcessMono ::
  Client -> Input -> (CFloat -> IO CFloat) -> Output -> IO CInt
setProcessMono client input fun output = do
    procPtr <- mkProcess $ wrapMonoFun input fun output
    JackFFI.set_process_callback (getClient client) procPtr nullPtr

wrapMonoFun :: Input -> (CFloat -> IO CFloat) -> Output
    -> (CUInt -> Ptr CChar -> IO CInt) -- what JACK expects
wrapMonoFun input fun output nframes _args = do
    inArr <- getBufferArray (getInput input) nframes
    outArr <- getBufferArray (getOutput output) nframes
    mapM (applyToArraysMono inArr fun outArr) [0..(nframes - 1)]
    return 0 -- ???

applyToArraysMono :: StorableArray CUInt CFloat -> (CFloat -> IO CFloat)
    -> StorableArray CUInt CFloat
    -> CUInt -> IO ()
applyToArraysMono inArr fun outArr i =
    readArray inArr i >>= fun >>= writeArray outArr i

getBufferArray :: Ptr () -> CUInt -> IO (StorableArray CUInt CFloat)
getBufferArray bptr nframes = do
    ptr <- JackFFI.port_get_buffer bptr nframes
    fptr <- newForeignPtr_ ptr
    unsafeForeignPtrToStorableArray fptr (0, (nframes - 1))

-- Stereo
mainStereo :: ((CFloat, CFloat) -> IO (CFloat, CFloat)) -> IO ()
mainStereo fun = do
    name <- getProgName
    client <- newClientSimple name

    inputLeft <- newInput client "inputLeft"
    inputRight <- newInput client "inputRight"
    outputLeft <- newOutput client "outputLeft"
    outputRight <- newOutput client "outputRight"

    seq (map fun (replicate 100 (0, 0))) (return ())

    setProcessStereo client inputLeft inputRight fun outputLeft outputRight

    activate client
    putStrLn $ "started " ++ name ++ "..."

    mvar <- newEmptyMVar
    installHandler
        keyboardSignal
        (Catch (quit mvar client [inputLeft, inputRight] [outputLeft, outputRight]))
        Nothing
    takeMVar mvar


setProcessStereo ::
   Client -> Input -> Input ->
   ((CFloat, CFloat) -> IO (CFloat, CFloat)) ->
   Output -> Output -> IO CInt
setProcessStereo client inputLeft inputRight fun outputLeft outputRight = do
    procPtr <- mkProcess $ wrapStereoFun inputLeft inputRight fun outputLeft outputRight
    JackFFI.set_process_callback (getClient client) procPtr nullPtr


wrapStereoFun :: Input -> Input
    -> ((CFloat, CFloat) -> IO (CFloat, CFloat))
    -> Output -> Output
    -> (CUInt -> Ptr CChar -> IO CInt) -- what JACK expects
wrapStereoFun iL iR fun oL oR nframes _args = do
    inLArr <- getBufferArray (getInput iL) nframes
    inRArr <- getBufferArray (getInput iR) nframes
    outLArr <- getBufferArray (getOutput oL) nframes
    outRArr <- getBufferArray (getOutput oR) nframes
    mapM (applyToArraysStereo inLArr inRArr fun outLArr outRArr) [0..(nframes - 1)]
    return 0 -- ???

applyToArraysStereo :: StorableArray CUInt CFloat
    -> StorableArray CUInt CFloat
    -> ((CFloat, CFloat) -> IO (CFloat, CFloat))
    -> StorableArray CUInt CFloat
    -> StorableArray CUInt CFloat
    -> CUInt -> IO ()
applyToArraysStereo iL iR fun oL oR i = do
    l <- readArray iL i
    r <- readArray iR i
    (l', r') <- fun (l, r)
    writeArray oL i l'
    writeArray oR i r'



-- Useful instances
instance Ix CUInt where
    range (a, b) = [a..b]
    index (start, _end) i = fromEnum (i - start)
    inRange (start, end) i = start <= i && i <= end


instance Random CFloat where
  random g        = randomIvalDouble (0::Double,1) realToFrac g
  randomR (a,b) g = randomIvalDouble (realToFrac a, realToFrac b) realToFrac g

randomIvalInteger :: (RandomGen g, Num a) => (Integer, Integer) -> g -> (a, g)
randomIvalInteger (l,h) rng =
   if l > h
     then randomIvalInteger (h,l) rng
     else case (f n 1 rng) of (v, rng') -> (fromInteger (l + v `mod` k), rng')
     where
       k = h - l + 1
       b = 2147483561
       n = iLogBase b k

       f 0 acc g = (acc, g)
       f nn acc g = 
          let
	   (x,g')   = next g
	  in
	  f (nn-1) (fromIntegral x + acc * b) g'

randomIvalDouble :: (RandomGen g, Fractional a) =>
   (Double, Double) -> (Double -> a) -> g -> (a, g)
randomIvalDouble (l,h) fromDouble rng =
   if l > h
     then randomIvalDouble (h,l) fromDouble rng
     else
       case (randomIvalInteger (toInteger (minBound::Int), toInteger (maxBound::Int)) rng) of
         (x, rng') -> 
	    let
	     scaled_x = 
		fromDouble ((l+h)/2) + 
                fromDouble ((h-l) / realToFrac intRange) *
		fromIntegral (x::Int)
	    in
	    (scaled_x, rng')

intRange :: Integer
intRange  = toInteger (maxBound::Int) - toInteger (minBound::Int)

iLogBase :: Integer -> Integer -> Integer
iLogBase b i = if i < b then 1 else 1 + iLogBase b (i `div` b)