htune 0.1 → 0.2
raw patch · 2 files changed
+50/−12 lines, 2 files
Files
- htune.cabal +1/−1
- main.hs +49/−11
htune.cabal view
@@ -1,5 +1,5 @@ name: htune-version: 0.1+version: 0.2 synopsis: harmonic analyser and tuner for musical instruments description: A real-time, graphical analyser of frequency spectrums. Reads audio data from ALSA and draws a spectrogram with
main.hs view
@@ -7,8 +7,8 @@ import Data.Array.CArray import GHC.Float ( double2Float ) import Foreign.ForeignPtr-import Data.Char ( toUpper )-import Data.List ( sortBy )+import Data.Char ( toUpper, toLower )+import Data.List ( sortBy, findIndex ) import Sound.ALSA.PCM ( SoundFmt(SoundFmt), sampleFreq, soundSourceRead,@@ -128,35 +128,73 @@ drawfft bits = Line $ [ (centscale $ fromIntegral x, double2Float $ y) | (x, y) <- assocs bits ] -drawpeaks spd fft = Pictures $- [ draw (centscale x) (round . cents $ hz x) i- | (x, y) <- take 10 $ takeWhile ((> 150) . snd) $ peaks spd fft | i <- [10,9..1] ]+centcolor c = case snd $ fancy c of+ x | x <= -20 -> makeColor 1 0 1+ | x <= -10 -> makeColor 0 1 1+ | x > -10 && x < 10 -> makeColor 0 1 0+ | x >= 10 -> makeColor 1 1 0+ | x >= 20 -> makeColor 1 0 0++drawpeaks peaks = Pictures $+ [ draw (centscale x) (round . cents $ hz x) i | ((x, _), i) <- zip peaks [10,9..] ] where draw x c i = color c [ color' c (1 - fromIntegral (abs $ offset c) / 50) $ [ Polygon [ (x, 0), (x, 500), (snap c, 500), (snap c, 0) ] ] , color' c 0.9 $ [ Line [ (snap c, 0), (snap c, 500) ] ] , Translate (maximum [snap c + 5, x + 5]) (200 + 25 * i) $- Scale 0.2 0.2 $ Text $ name c ++ showsign (offset c)+ Scale 0.3 0.3 $ Text $ name c ++ showsign (offset c) ] snap = shift . fst . fst . fancy name = snd . fst . fancy offset = snd . fancy color c = color' c 1- color' c t = case abs $ snd $ fancy c of- x | x < 10 -> Color (makeColor 0 1 0 t) . Pictures- | x < 20 -> Color (makeColor 1 1 0 t) . Pictures- | otherwise -> Color (makeColor 1 0 0 t) . Pictures+ color' c t = Color (centcolor c t) . Pictures +drawpiano peaks = Pictures $ [ whitekey (c, unoctave n) white | (c, n) <- notecents, unoctave n `elem` whitekeys ] +++ [ whitekey (snap p, name p) (color p) | p <- peaks', name p `elem` whitekeys ] +++ [ blackkey (c, unoctave n) black | (c, n) <- notecents, unoctave n `elem` blackkeys ] +++ [ blackkey (snap p, name p) (color p) | p <- peaks', name p `elem` blackkeys ]+ where key c | snd c `elem` ["cis", "es", "fis", "gis", "b" ] = blackkey c+ | otherwise = whitekey c+ unoctave = map toLower . takeWhile (`notElem` ",'+")+ color = uncurry centcolor+ name = unoctave . snd . fst . fancy . fst+ snap = fromIntegral . round . fst . fst . fancy . fst+ peaks' = map (\(x, y) -> (round . cents $ hz x, double2Float y / 500)) peaks+ poly c1 c2 p = Pictures [ Color c1 $ Polygon p, Color c2 $ Line p ]++ octave = 600+ width = octave / 7+ whitekeys = ["a", "h", "c", "d", "e", "f", "g"]+ blackkeys = ["b", "cis", "es", "fis", "gis", "b"]++ keyat (top, bottom, w, fill, outline) c =+ poly fill outline $ [(c - w, top), (c + w, top), (c + w, bottom), (c - w, bottom), (c - w, top)]++ whitecenter (pos, x) = case findIndex (==x) whitekeys of+ Just idx -> octave * fromIntegral ((round $ pos - a55) `div` 1200) + width * (fromIntegral idx)+ whitekey (pos, x) c = keyat (-50, -350, width / 2, c, black) $ whitecenter (pos, x)++ blackkey (pos, x) c = case x of+ "b" -> key ( 7) "a"+ "cis" -> key (-7) "c"+ "es" -> key ( 7) "d"+ "fis" -> key (-7) "f"+ "gis" -> key ( 0) "g"+ where key off rightof = keyat (-50, -250, width / 4, c, black) $ whitecenter (pos, rightof) + width / 2 + off+ analyze bits = draw $ Pictures [ guides , dbguides , Color white $ drawfft bufSPD- , drawpeaks bufSPD bufFFT+ , drawpeaks peakl+ , drawpiano peakl ] where bufFloat = mapArray (\i v -> hamming winSize i $ normalize $ fromIntegral v) bits bufFFT = array (start, end) $ drop start $ take end $ assocs $ dft bufFloat bufSPD :: CArray Int Double = liftArray (\(a :+ b) -> spl $ spd a b) $ bufFFT start = fst fftLimits end = snd fftLimits+ peakl = take 10 $ takeWhile ((> 150) . snd) $ peaks bufSPD bufFFT -- ALSA inputFormat :: SoundFmt Int16