Ticket #2833: Main.hs

File Main.hs, 5.5 KB (added by lilac, 5 years ago)

Program exhibiting problem

Line 
1module Main where
2
3import Control.Applicative (pure, (<$>))
4import Control.Concurrent (forkIO)
5import Control.Concurrent.MVar
6import Control.Monad (unless, when, msum)
7
8import Data.Char (ord)
9import Data.Int (Int8, Int16)
10import Data.IORef
11import Data.Maybe (fromMaybe)
12import Data.Monoid
13
14import Foreign.Marshal (mallocArray, free)
15import Foreign.Ptr
16import Foreign.Storable
17
18import FRP.Reactive
19import FRP.Reactive.LegacyAdapters
20import FRP.Reactive.Internal.Reactive (runE)
21
22import Sound.OpenAL (
23  -- Nice AL types
24  Gain, Frequency, Format, SourceRelative(..),
25  -- Nasty AL types
26  ALfloat, BufferData(..), MemoryRegion(..),
27  -- Nice GL types
28  Vertex3(..), Vector3(..),
29  -- GL internal bits
30  ($=), get)
31import qualified Sound.OpenAL as AL
32import Sound.ALUT.Sleep (sleep)
33
34import System.IO
35
36-- | Buffer size in samples. This will normally be about 0.1s, which seems to
37--   be a reasonable tradeoff between stable audio and low latency.
38bufferSize :: Int
39bufferSize = 40960
40
41data PosVel = PosVel {
42  posVelRel :: SourceRelative,
43  posVelPos :: Vertex3 ALfloat,
44  posVelVel :: Vertex3 ALfloat
45}
46
47-- | A sound source somewhere in 3D space.
48data Source = Source {
49  source                  :: Behaviour Double,
50  sourcePosVel            :: Behaviour PosVel,
51  sourceGain              :: Behaviour Gain,
52  sourceDirection         :: Behaviour (Vector3 ALfloat),
53  sourceGainBounds        :: Behaviour (Gain, Gain),
54  sourceReferenceDistance :: Behaviour ALfloat,
55  sourceRolloffFactor     :: Behaviour ALfloat,
56  sourceMaxDistance       :: Behaviour ALfloat,
57  sourceConeAngles        :: Behaviour (ALfloat, ALfloat),
58  sourceConeOuterGain     :: Behaviour Gain
59}
60
61maxFloat = f 1 :: Float where
62  f x | 2*x == 4*x = x
63      | otherwise  = f (2*x)
64
65-- | A default, silent Source, positioned over the listener.
66defaultSource = Source {
67  source                  = pure 0,
68  sourcePosVel            = pure $ PosVel World (Vertex3 0 0 0) (Vertex3 0 0 0),
69  sourceGain              = pure 1,
70  sourceDirection         = pure (Vector3 0 0 0),
71  sourceGainBounds        = pure (0, 1),
72  sourceReferenceDistance = pure 1,
73  sourceRolloffFactor     = pure 1,
74  sourceMaxDistance       = pure maxFloat,
75  sourceConeAngles        = pure (360, 360),
76  sourceConeOuterGain     = pure 1
77}
78
79
80class (Num a, Storable a) => Sample a where
81  -- | Compute the format for the sample. The value of the argument is not used.
82  sampleFormat :: a -> Format
83
84instance Sample Int8 where sampleFormat _ = AL.Mono8
85instance Sample Int16 where sampleFormat _ = AL.Mono16
86--instance Sample (Int8, Int8) where sampleFormat _ = AL.Stereo8
87--instance Sample (Int16, Int16) where sampleFormat _ = AL.Stereo16
88
89
90behaviourType :: Behaviour a -> a
91behaviourType = undefined
92
93freqAttr :: AL.ContextAttribute -> Maybe Frequency
94freqAttr (AL.Frequency f) = Just f
95freqAttr _ = Nothing
96
97playSamples :: Sample a => Behaviour a -> IO ()
98playSamples a = do
99  Just device <- AL.openDevice Nothing -- FIXME accept device name
100  Just context <- AL.createContext device []
101  AL.currentContext $= Just context
102  contextAttrs <- get (AL.allAttributes device)
103  [source] <- AL.genObjectNames 1
104  bufNames <- AL.genObjectNames 2
105  contents <- mallocArray bufferSize
106  bufs <- newIORef (cycle bufNames)
107
108  let frequency :: Frequency
109      frequency = realToFrac . fromMaybe 44100 . msum $ map freqAttr contextAttrs
110      bufferInterval :: TimeT
111      bufferInterval = fromIntegral bufferSize / realToFrac frequency
112      sampleType = behaviourType a
113      bufferSizeBytes = fromIntegral (bufferSize * sizeOf sampleType)
114
115  let fillBuffer t = do
116        buf:rest <- readIORef bufs
117        state <- get (AL.sourceState source)
118        unless (state == AL.Playing) $ do
119          putStrLn "Start playing!"
120          AL.play [source]
121        let sampler = atTimes (take bufferSize [t-bufferInterval,t-bufferInterval+1/realToFrac frequency..])
122            samples = snapshot (countE_ sampler) a
123            fillE = ((\(n,v) -> when (n `mod` 1000 == 0) (print n) >> pokeElemOff contents (n - 1) v) <$> samples)
124        putStrLn "Buffer"
125        --adaptE fillE
126        runE mempty fillE
127        putStrLn "Filled"
128        b <- get (AL.buffer source)
129        state <- get (AL.sourceState source)
130        when (b == Just buf && state == AL.Playing) $ do
131          -- Trying to replace the currently-playing buffer. We've got out of sync with
132          -- the audio playback. Try again.
133          AL.stop [source]
134        AL.unqueueBuffers source [buf]
135        AL.bufferData buf $= BufferData (MemoryRegion contents bufferSizeBytes) (sampleFormat sampleType) frequency
136        AL.queueBuffers source [buf]
137        writeIORef bufs rest
138
139  adaptE (fillBuffer <$> withTimeE_ (atTimes [bufferInterval, 2*bufferInterval..]))
140
141  -- adaptE does not finish; this will never happen...
142  free contents
143  AL.deleteObjectNames [source]
144  AL.deleteObjectNames bufNames
145  AL.currentContext $= Nothing
146  AL.destroyContext context
147  AL.closeDevice device
148  return ()
149
150playSource :: Source -> IO ()
151playSource s = playSamples (floor <$> 32767 * source s :: Behaviour Int16)
152
153-- Final interface:
154-- play :: Event [Source] -> Event ListenerState -> IO ()
155
156mkKeys :: IO (Event Char)
157mkKeys = do
158  (a, b) <- makeEvent =<< makeClock
159  hSetBuffering stdin NoBuffering
160  forkIO $ mapM_ b =<< getContents
161  return a
162
163main = do
164  keys <- mkKeys
165  let tone = stepper 0 (fromIntegral . ord <$> keys)
166  --forkIO $ adaptE (print <$> snapshot_ (atTimes [0,0.1..]) tone)
167  playSource defaultSource { source = sin ( 10 * tone * time) }
168  --playSource defaultSource { source = sin (1000 * time) / 2 + sin ( 100 * time) / 2 }