Ticket #5018: zad4.hs

File zad4.hs, 11.2 KB (added by tener, 3 years ago)

program triggering the bug

Line 
1{-# LANGUAGE ScopedTypeVariables, TemplateHaskell, ViewPatterns #-}
2
3{-
4
5Executable synteza-lista1-zad4
6  Main-is:             zad4.hs
7  Build-depends:       base > 4, mersenne-random-pure64, monad-mersenne-random, array, HCodecs, containers, utility-ht, data-accessor, data-accessor-template, alsa-pcm, random, data-default, split, gtk
8
9-}
10
11module Main where
12
13import Control.Monad
14import Control.Applicative
15import Graphics.UI.Gtk
16import Text.Printf
17import Data.List.Split (splitEvery)
18import Data.Default
19
20import Codec.Wav
21import Data.Audio
22import Data.Array.Unboxed
23
24import Data.Int
25import Control.Monad.Mersenne.Random
26import System.Random.Mersenne.Pure64
27
28import Control.Concurrent
29import Control.Concurrent.MVar
30
31--import Data.UUID
32import System.Random
33import qualified Data.Map as Map
34import Data.Map (Map)
35
36import qualified Data.List
37
38--import System.IO.MMap
39
40import Data.Accessor
41import Data.Accessor.Template
42
43import Sound.ALSA.PCM
44
45import Text.Read.HT
46
47import Foreign
48
49data SoundGen = Sine { freq :: Double }
50              | Rect { freq, factor :: Double }
51              | Trian { freq, factor :: Double }
52              | WhiteNoise
53              deriving (Eq,Read,Show)
54
55data SoundEntry = SoundEntry { enabled_ :: Bool
56                             , volume_ :: Double
57                             , generatorParams_ :: SoundGen
58                             , adsr_ :: Bool
59                             }
60              deriving (Eq,Read,Show)
61
62instance Default SoundEntry where
63    def = SoundEntry False 0.5 WhiteNoise False
64
65$(deriveAccessors ''SoundEntry)
66
67data Config = Config { globalADSR :: Bool
68                     , playback :: Bool
69                     }
70
71instance Default Config where
72    def = Config False False
73
74sampleRate_ :: Int
75sampleRate_ = 44100
76duration :: Double
77duration = 3.0
78sampleCount :: Int
79sampleCount = round $ duration * fromIntegral sampleRate_
80
81average xs = sum xs / (fromIntegral $ length xs)
82
83mixSounds :: Bool -> [SoundEntry] -> IO [Double]
84mixSounds globalADSR sounds = do
85  mix <- (map average . Data.List.transpose) `fmap` mapM generateSound sounds
86  return (if globalADSR then adsrEnvelope mix else mix)
87
88adsrEnvelope :: [Double] -> [Double]
89adsrEnvelope xs = let attack  = 0.1
90                      decay   = 0.25
91                      release = 0.2
92                      sustain = duration - attack - decay - release
93
94                      attack_samples  = round $ (fromIntegral sampleRate_) * attack
95                      decay_samples   = round $ (fromIntegral sampleRate_) * decay 
96                      sustain_samples = round $ (fromIntegral sampleRate_) * sustain
97                      release_samples = round $ (fromIntegral sampleRate_) * release
98
99                      envelope = linear 0 1      attack_samples ++ 
100                                 linear 1 0.75   decay_samples ++ 
101                                 linear 0.75 0.5 sustain_samples ++ 
102                                 linear 0.5 0    release_samples
103                  in
104                      zipWith (*) xs envelope
105
106
107linear :: Double -> Double -> Int -> [Double]
108linear low high samples = let step = (high-low) / (fromIntegral $ samples-1) in
109                          [ low + (fromIntegral i) * step | i <- [0 .. samples-1] ]
110
111
112generateSound :: SoundEntry -> IO [Double]
113generateSound (SoundEntry False _ _ _) = return []
114generateSound (SoundEntry _ vol param envelope) = 
115    let f = map (vol*) . (if envelope then adsrEnvelope else id) 
116        r = sampleRate_
117     in
118    f <$> 
119    case param of
120      Sine fr -> let pulse = (fromIntegral r) / fr
121                     sine = [ (sin (2 * pi * (fromIntegral i) / pulse)) | i <- [0 .. sampleCount-1]] -- XXX: fixme
122                 in return sine
123      Rect fr fac ->   let pulse = (fromIntegral r) / fr
124                           lowCount = round $ pulse * fac
125                           hiCount = (round pulse) - lowCount
126                           period = (replicate lowCount 0) ++ (replicate hiCount 1)
127                           rect = take sampleCount (cycle period)
128                       in return rect
129      Trian fr fac -> let pulse = (fromIntegral r) / fr -- number of samples in single period
130                          downCount = round $ pulse * fac
131                          upCount = (round pulse) - downCount
132                          slopeDown = tail $ linear 1 0 downCount
133                          slopeUp = tail $ linear 0 1 upCount
134                          period = slopeDown ++ slopeUp
135                          trian = take sampleCount (cycle period)
136                      in return trian
137      WhiteNoise -> (evalRandom (replicateM sampleCount getDouble)) `fmap` newPureMT
138
139
140addOneBox table = do
141  nrow <- get table tableNRows
142  let nrow' = nrow+1
143  tableResize table nrow' 2
144  button <- volumeButtonNew
145
146  tableAttach table button 0 1 nrow (nrow+1) [] [] 3 3
147  widgetShowAll button
148
149enableButton callback = do
150  enable <- toggleButtonNew
151  toggleButtonSetActive enable True
152  image <- imageNewFromFile "gtk-apply.png"
153  containerAdd enable image
154  on enable toggled $ get enable toggleButtonActive >>= callback
155  return enable
156
157adsrButton callback = do
158  b <- checkButtonNewWithLabel "ADSR"
159  on b toggled $ get b toggleButtonActive >>= callback
160  return b
161
162getDefaultSound "sine" = Sine 3000
163getDefaultSound "white noise" = WhiteNoise
164getDefaultSound "triangle" = Trian 1000 0.5
165getDefaultSound "square" = Rect 3000 0.3
166getDefaultSound _ = error "no such sound"
167
168--uuid :: IO UUID
169--uuid = randomIO
170
171getIdent :: IO Int
172getIdent = randomIO
173
174addSound table soundList = do
175  ident <- getIdent
176
177  let update field value = modifyMVar_ soundList (return . (Map.adjust (field ^= value) ident))
178
179  nrow <- get table tableNRows
180  let nrow' = nrow+1
181  tableResize table nrow' 7
182
183  volB <- volumeButtonNew
184  set volB [ scaleButtonValue := 0.5 ]
185  on volB scaleButtonValueChanged (update volume)
186
187  enable <- enableButton (update enabled)
188  adsrB <- adsrButton (update adsr)
189  parseOkIcon <- imageNewFromStock stockYes IconSizeSmallToolbar
190
191  soundType <- comboBoxNewText
192  mapM_ (comboBoxPrependText soundType) (reverse ["sine","white noise","triangle","square"])
193  soundParams <- hBoxNew False 1
194  soundType `on` changed $ do
195                   (Just text) <- comboBoxGetActiveText soundType
196
197                   entry <- entryNew
198                   let basicSound = getDefaultSound text
199                   update generatorParams basicSound
200                   entrySetText entry (show basicSound)
201                   entrySetWidthChars entry 40
202                   imageSetFromStock parseOkIcon stockYes IconSizeSmallToolbar
203
204                   on entry editableChanged (do
205                                              txt <- entryGetText entry
206                                              case maybeRead txt of
207                                                Just sound -> imageSetFromStock parseOkIcon stockYes IconSizeSmallToolbar >> update generatorParams sound
208                                                Nothing -> imageSetFromStock parseOkIcon stockNo IconSizeSmallToolbar
209                                            )
210
211                   containerForall soundParams (containerRemove soundParams)
212                   containerAdd soundParams entry
213                   widgetShowAll table
214
215  comboBoxSetActive soundType 0
216
217  tableAttach table enable      0 1 nrow nrow' [] [] 3 3
218  tableAttach table volB        1 2 nrow nrow' [] [] 3 3
219  tableAttach table adsrB       2 3 nrow nrow' [] [] 3 3
220  tableAttach table soundType   3 4 nrow nrow' [] [] 3 3
221  tableAttach table soundParams 4 5 nrow nrow' [] [] 3 3
222  tableAttach table parseOkIcon 5 6 nrow nrow' [] [] 3 3
223 
224  widgetShowAll table
225  reorder table
226               
227  let sound = enabled ^= True $
228              volume ^= 0.5 $
229              generatorParams ^= getDefaultSound "sine" $
230              adsr ^= False $
231              def
232
233  modifyMVar_ soundList (return . (Map.insert ident sound))
234
235newActionTool label img callback = do
236  image <- imageNewFromPixbuf =<< pixbufNewFromFileAtSize img 30 30
237  button <- toolButtonNew (Just image) (Just label)
238  onToolButtonClicked button callback
239  return button
240
241newToggleTool label img callback = do
242  image <- imageNewFromPixbuf =<< pixbufNewFromFileAtSize img 30 30
243  button <- toggleToolButtonNew
244  toolButtonSetLabel button (Just label)
245  toolButtonSetIconWidget button (Just image)
246  onToolButtonClicked button $ do
247    state <- get button toggleToolButtonActive
248    print (label,state)
249    callback state
250  return button
251
252-- set right focus order in table
253reorder table = do
254  children <- containerGetChildren table
255  containerSetFocusChain table (reverse children)
256
257main :: IO ()
258main = do
259  initGUI
260
261  globalADSR <- newMVar False
262  soundList <- newMVar Map.empty
263  soundSink <- (newChan :: IO (Chan [Double]))
264
265--  forkIO testAudio
266  forkIO (channelSound soundSink)
267
268  window <- windowNew
269  mainCell <- vBoxNew False 1
270
271  table <- tableNew 10 1 False
272
273  tools <- toolbarNew
274  toolbarSetStyle tools ToolbarBoth
275  (\t -> toolbarInsert tools t (-1)) =<< newActionTool "dodaj dźwięk" "gtk-add-blue.svg" (addSound table soundList)
276  (\t -> toolbarInsert tools t (-1)) =<< newToggleTool "globalny ADSR" "adsr.svg" (\st -> tryTakeMVar globalADSR >> putMVar globalADSR st)
277  (\t -> toolbarInsert tools t (-1)) =<< (newActionTool "odtwórz dźwięk" "play.svg" $
278    do
279      print "Play!"
280      soundMap <- takeMVar soundList
281      adsr <- takeMVar globalADSR
282
283      let sounds = Map.elems soundMap
284
285      putMVar soundList soundMap
286      putMVar globalADSR adsr
287
288      mapM_ print sounds
289
290      writeChan soundSink =<< mixSounds adsr sounds)
291
292  mapM_ (containerAdd mainCell) [toWidget tools, toWidget table]
293
294  set window [ containerBorderWidth := 20,
295               containerChild := mainCell,
296               windowAllowGrow := False ]
297  onDestroy window mainQuit
298  widgetShowAll window
299
300  replicateM 5 (addSound table soundList)
301
302
303  mainGUI
304
305
306channelSound :: SampleFmt y =>
307                Chan [y]
308             -> IO ()
309channelSound chan =
310    let soundFormat = SoundFmt { sampleFreq = sampleRate_ }
311        sink = alsaSoundSink "plughw:0,1" soundFormat
312    in
313    withSoundSink sink $ \to ->
314    forever            $
315      do
316        sample <- readChan chan
317        withArray sample (\buf -> soundSinkWrite sink to buf (length sample))
318
319
320testAudio :: IO ()
321testAudio = do
322  let soundFormat :: SoundFmt Int32
323      soundFormat = SoundFmt { sampleFreq = sampleRate_ }
324      source = fileSoundSource "test.wav" soundFormat
325      sink = alsaSoundSink "plughw:0,1" soundFormat
326
327  samples <- (evalRandom (replicateM sampleCount getDouble)) `fmap` newPureMT
328 
329  let audio :: Audio Int32
330      audio = Audio { sampleRate = sampleRate_, 
331                      channelNumber = 1,
332                      sampleData = convert (listArray (0, length samples) samples)
333                    }
334
335  exportFile "test.wav" audio
336 
337  foreverSound source sink 512
338
339foreverSound :: SampleFmt y =>
340                SoundSource y h1
341             -> SoundSink y h2
342             -> Int -- ^ Buffer size (in sample frames) to use
343             -> IO ()
344foreverSound source sink bufSize =
345    allocaArray     bufSize $ \buf ->
346    withSoundSink   sink    $ \to ->
347    forever                 $
348    withSoundSource source  $ \from ->
349       let loop = do n <- soundSourceRead source from buf bufSize
350                     when (n > 0) $ do soundSinkWrite sink to buf n
351                                       loop
352        in loop