DouKaku?beta

challenge Tiny MML

文字列の入力をとり、音を鳴らすプログラムを作ってください。

入力はcがド、dがレ、eがミ、fがファ、gがソ、aがラ、bがシ、rが休符とします。この8文字以外の文字は入力に含まれていないと仮定して構いません。おのおのの音符・休符は八分音符・八分休符とします。

オクターブや音の長さの変更、同時発音などの機能は不要です。

サンプル入力(カエルの歌) 

cdefedcrefgagfercrcrcrcrcdefedcr
post comment

Posted feedbacks - Haskell

OpenAL使用。カエルの歌はあんまり好きじゃないので、曲は自分で作った。

拡張仕様:
* 0-9 でオクターブ変更、デフォルト5。
* C, D, F, G, A でそれぞれ元の音から半音上げる。
  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
import Control.Concurrent
import Data.Char
import Data.Map (Map)
import qualified Data.Map as M
import Foreign.Marshal.Alloc
import Foreign.Marshal.Array
import Foreign.Ptr
import Foreign.Storable
import Sound.OpenAL

freqForNote :: Char -> Double
freqForNote 'c' = 261.626
freqForNote 'C' = 277.183 -- C# (拡張仕様、互換性有)
freqForNote 'd' = 293.628
freqForNote 'D' = 311.127 -- D# (以下同様)
freqForNote 'e' = 329.628
freqForNote 'f' = 349.228
freqForNote 'F' = 369.994 -- F#
freqForNote 'g' = 391.995
freqForNote 'G' = 415.305 -- G#
freqForNote 'a' = 440
freqForNote 'A' = 466.164 -- A#
freqForNote 'b' = 493.883
freqForNote 'r' = 0

scoreToFreqs :: String -> [Double]
scoreToFreqs = scoreToFreqs' 5 -- 5 が中心
    where
      scoreToFreqs' :: Int -> String -> [Double]
      scoreToFreqs' _      []     = []
      scoreToFreqs' octave (x:xs)
          | isDigit x
              -- オクターブ変更 (拡張仕様、互換性有)
              = scoreToFreqs' (fromEnum x - fromEnum '0') xs
          | otherwise
              = (freqForNote x) * (2 ^^ (octave - 5))
                : scoreToFreqs' octave xs

mkNote :: Int -> Double -> Double -> IO Buffer
mkNote samplFreq sec noteFreq
    = let nSamples = round $ (realToFrac samplFreq) * sec
          bufSize  = nSamples
      in 
        allocaBytes bufSize $ \ mem ->
        do renderToMemBuf mem bufSize
           let memRegion = MemoryRegion mem (fromIntegral bufSize)
               bufData   = BufferData memRegion Mono8 (realToFrac samplFreq)
           [buf] <- genObjectNames 1
           bufferData buf $= bufData
           return buf
    where
      renderToArray :: Int -> [ALubyte]
      renderToArray len = map calcFrame [0 .. len - 1]

      calcFrame :: Int -> ALubyte
      calcFrame n = let frame = sin $
                                2
                                * pi
                                * noteFreq
                                * (realToFrac n / realToFrac samplFreq)
                    in
                      -- -1.0 <= frame <= 1.0
                      floor $ 127 * frame + 128

      renderToMemBuf :: Ptr ALubyte -> Int -> IO ()
      renderToMemBuf mem len = pokeArray mem (renderToArray len)

mkEachBuffers :: Int -> Double -> [Double] -> IO (Map Double Buffer)
mkEachBuffers sampleFreq sec = updateMap M.empty
    where
      updateMap m []     = return m
      updateMap m (x:xs)
          | M.member x m
              = updateMap m xs
          | otherwise
              = do buf <- mkNote sampleFreq sec x
                   updateMap (M.insert x buf m) xs

main = do deviceM <- openDevice Nothing
          case deviceM of
            Nothing
                -> fail "failed to open audio device"
            Just dev
                -> do ctxM <- createContext dev []
                      case ctxM of
                        Nothing
                            -> fail "failed to create context"
                        Just ctx
                            -> do currentContext $= Just ctx
                                  putStrLn "creating buffers..."

                                  let freqs = scoreToFreqs score
                                  buffers <- mkEachBuffers 8000 0.2 freqs
                                  notes   <- mapM (flip M.lookup buffers) freqs

                                  putStrLn "ok. playing..."

                                  [src] <- genObjectNames 1
                                  -- 手抜き。全部の音符を一気にキューに
                                  -- 入れるのは本当は良くない。
                                  queueBuffers src notes
                                  play [src]
                        
                                  waitTillDone src
                                  putStrLn "done."
    where
      waitTillDone :: Source -> IO ()
      waitTillDone src
          = do state <- get (sourceState src)
               case state of
                 Playing -> threadDelay (50 * 1000) >> waitTillDone src
                 _       -> return ()

score :: String
-- score = "cdefedcrefgagfercrcrcrcrcdefedcr"
score = "5daagabaFed4ba" ++ "5daagabaFeFer"   ++
        "5daagabaFedeF"  ++ "5gabFede4b5eFer" ++
        "5daagabaFed4ba" ++ "5daagabaFeFer"   ++
        "5daagabaFedeF"  ++ "5gabFede4b5eFer" ++

        "5babaFabaFeFr"  ++ "5eFaFed4bab5CdF" ++
        "5babaFabaFeFr"  ++ "5eFedFabbbr6dC"  ++
        "5babaFabaFeFr"  ++ "5eFaFed4bab5CdF" ++
        "5babaFabaFeFr"  ++ "5eFedFabbbrFF"   ++

        "5ebeFgFeged4b5d" ++ "5ebeFgebagbar"  ++
        "5ebeFgFeded4br"  ++ "5cdebagFFered"  ++
        "5ebeFgFeged4b5d" ++ "5ebeFgebagbar"  ++
        "5ebeFgFeded4br"  ++ "5cdebagFFerer"  ++

        "5daagabaFed4ba" ++ "5daagabaFeFer"   ++
        "5daagabaFedeF"  ++ "5gabFede4b5eFer" ++
        "5daagabaFed4ba" ++ "5daagabaFeFer"   ++
        "5daagabaFedeF"  ++ "5gabFedeFed4b5d" ++
        "5eee"

Index

Feed

Other

Link

Pathtraq

loading...
Creative Commons License このサイトの内容は、 クリエイティブ・コモンズ・ライセンスの下でライセンスされています。 [詳細]