Charlie Harvey

Morse code again — translating audio back to morse

Written by Charlie on

↙

Today is the final installment in my Haskell morse code odyssey, in which I translate some audio of morse code back into dots and dahs and even strings on the screen. The idea of translating audio back into something more human-friendly was suggested by @russellbanned when I put up my Let’s make morse code with Haskell blog post. Thanks for the suggestion.

Fortunately, I finally found something that worked for doing screencasts. Sorry screenr.com, but you just wouldn't upload my file! Plus because I am putting it on yt, I can be as long-winded as I like talking through the code and save myself editing time. And writing time come to that. Incidentaly vokoscreen is a pretty nice bit of screencasting software for GNU/Linux. My microphone is a bit crap though, so the sound is far from great. Will try and get a better set up for the next screencast!

I’ve had great fun this week making my computer beep and I have learned a fair amount from making morse.hs. If you want the code, please take and improve. Consider it public domain. And finally:

.... .- .--. .--. -.-- _ -- --- .-. ... . _ .... .- -.-. -.- .. -. --. _ --- -. . _ .- -. -.. _ .- .-.. .-.. !

Here is the final code

The final morse.hs code

module Main where import qualified Data.Map as M (Map, toList, fromList, lookup) import System.Console.GetOpt import System.Process import Data.Maybe (fromMaybe) import Data.Char (toLower) import System.Environment import Data.WAVE import Data.List (intersperse, groupBy, group) import Data.Int (Int32) type MorseString = String data Options = Options { optUnmorse :: Bool , optAudio :: Bool , optPlayAudio :: Bool , optUnAudio :: Bool , optStringFromAudio :: Bool , optVerbose :: Bool } deriving Show defaultOptions :: Options defaultOptions = Options { optUnmorse = False , optAudio = False , optPlayAudio = False , optUnAudio = False , optStringFromAudio = False , optVerbose = False } options :: [OptDescr (Options -> Options)] options = [ Option ['u'] ["unmorse"] (NoArg (\ opts -> opts { optUnmorse = True })) "Translate from morse back to string" , Option ['a'] ["audio"] (NoArg (\ opts -> opts { optAudio = True })) "Translate from string to audio. Output file to morse-out.wav and play using aplay" , Option ['p'] ["playaudio"] (NoArg (\ opts -> opts { optPlayAudio = True })) "Play morse-out.wav using aplay" , Option ['r'] ["readaudio"] (NoArg (\ opts -> opts { optUnAudio = True })) "Read morse-in.wav and attempt to parse" , Option [ ] ["stringaudio"] (NoArg (\ opts -> opts { optStringFromAudio = True })) "Print result of reading morse-in.wav as a string, not a morse code string" , Option ['v'] ["verbose"] (NoArg (\ opts -> opts { optVerbose = True })) "Go on about it at great length" ] myOpts :: [String] -> IO (Options, [String]) myOpts argv = case getOpt Permute options argv of (o,n,[] ) -> return (foldl (flip id) defaultOptions o, n) (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options)) where header = "Usage: morse [uavp] < file" letters :: (M.Map Char MorseString) letters = M.fromList [ ('a', ".-") , ('b', "-...") , ('c', "-.-.") , ('d', "-..") , ('e', ".") , ('f', "..-.") , ('g', "--.") , ('h', "....") , ('i', "..") , ('j', ".---") , ('k', "-.-") , ('l', ".-..") , ('m', "--") , ('n', "-.") , ('o', "---") , ('p', ".--.") , ('q', "--.-") , ('r', ".-.") , ('s', "...") , ('t', "-") , ('u', "..-") , ('v', "...-") , ('w', ".--") , ('x', "-..-") , ('y', "-.--") , ('z', "--..") , ('1', ".----") , ('2', "..---") , ('3', "...--") , ('4', "....-") , ('5', ".....") , ('6', "-....") , ('7', "--...") , ('8', "---..") , ('9', "----.") , ('0', "-----") , (' ', "_") , ('.', " ") ] invertLetters = M.fromList $ map (\(x,y) -> (y,x)) $ M.toList letters charToMorse :: Char -> MorseString charToMorse x = case M.lookup (toLower x) letters of Just x' -> x' ++ " " Nothing -> "" stringToMorse :: String -> MorseString stringToMorse xs = m ++ "\n" where m = concatMap charToMorse xs morseToChar :: MorseString -> Char morseToChar x = case M.lookup x invertLetters of Just x' -> x' Nothing -> '?' morseToString :: MorseString -> String morseToString xs = s ++ "\n" where s = map morseToChar $ words xs -- Sound implementation samplesPS = 16000 -- samples per second bitrate = 16 -- or 32 bit if you need beepFreq = 800 -- dits and dahs come out at this frequency operatorSpeedFactor = 3 -- higher is slower, could make this into a commandline option morseSpeed = operatorSpeedFactor/10 -- Used in the file header header :: WAVEHeader header = WAVEHeader 1 samplesPS bitrate Nothing -- From an answer by David Milani at: -- https://stackoverflow.com/questions/5658391/generating-wav-sound-data-in-haskell sound :: Double -- | Frequency -> Int -- | Samples per second -> Double -- | Length of sound in seconds -> Int32 -- | Volume, (maxBound :: Int32) for highest, 0 for lowest -> [Int32] sound freq samples len volume = take (round $ len * (fromIntegral samples)) $ map (round . (* fromIntegral volume)) $ map sin [0.0, (freq * 2 * pi / (fromIntegral samples))..] -- space between dots and dahs space :: [Int32] space = sound 0 samplesPS (morseSpeed * 0.25) 0 -- gap between words longSpace :: [Int32] longSpace = sound 0 samplesPS (morseSpeed * 1.25) 0 medSpace :: [Int32] medSpace = sound 0 samplesPS (morseSpeed * 0.5) 0 dit :: [Int32] dit = sound beepFreq samplesPS (morseSpeed * 0.25) (maxBound `div` 2) dah :: [Int32] dah = sound beepFreq samplesPS (morseSpeed * 0.75) (maxBound `div` 2) stringToMorseWavFile :: String -> IO () stringToMorseWavFile xs = makeWavFile $ concatMap (map (:[])) $ stringToMorseSounds xs stringToMorseSounds :: String -> WAVESamples stringToMorseSounds xs = map charToMorseSound $ stringToMorse xs charToMorseSound :: Char -> [Int32] charToMorseSound x = case x of '.' -> concat [dit,space] '-' -> concat [dah,space] '_' -> longSpace ' ' -> medSpace otherwise -> space makeWavFile :: WAVESamples -> IO () makeWavFile xs = putWAVEFile "morse-out.wav" (WAVE header xs) -- Listening to audio and translating to morse or strings data Sample a = Space a | Beep a deriving Show -- Is an x a space? isSp x' = abs x' <= zeroish -- Sometimes we get small spaces within a beep, skip up to -- this number of spaces in a beep skippableSpace = 10 -- If the WAVESample is <= this, then we think of it as a space -- Otherwise, we think oof it as a Beep zeroish = 2 -- We divide sound lengths by this factor, and remultiply up to -- get a reasonable range of sound lengths for a dit length space -- i.e. means that dit spaces between 1600 and 1699 are treated as -- the same when searching for mostFrequent sound lengths when this -- is 100. -- Unfortunate if you hit a 1599 length space of course. -- -- We also use this as a factor in checking beep/space length variance -- in audioToMorse dampingFactor = 100 -- Turn samples into a list of Spaces and Beeps groupZ :: Bool -> Int -> [WAVESample] -> [Sample Int] groupZ space _ [] = [] groupZ space count xs = if space && spaces > skippableSpace then (Space (spaces+1)) : (groupZ False 0 (drop (spaces+1) xs)) else if space then (groupZ False 1 (drop (spaces+1) xs)) else (Beep (beeps+1+count)) : (groupZ True 0 (drop (beeps+1) xs)) where spaces = length $ takeWhile (isSp) xs beeps = length $ takeWhile (not . isSp) xs -- Squish together adjacent beeps tidyZ :: [Sample Int] -> [Sample Int] tidyZ [] = [] tidyZ [x] = [x] tidyZ (x:y:xs) = case (x, y) of (Beep i, Beep j) -> tidyZ ((Beep (i+j)):xs) otherwise -> x : tidyZ (y:xs) -- Given a list of Beeps and Spaces, return a list of the durations of the spaces getSpaceLengths :: [Sample Int] -> [Int] getSpaceLengths [] = [] getSpaceLengths (x:xs) = case x of (Space n) -> n : getSpaceLengths xs otherwise -> getSpaceLengths xs -- Utility function, find the most frequently occuring thing in a list -- We use this by taking a list of lengths of spaces (from getSpaceLengths) -- and assuming that the most frequently occuring of these will be the gap -- between dits and dahs in a letter, which ought to work for automatically generated -- morse, but will probably break on morse by human beings. mostFrequent :: [Int] -> Int mostFrequent = snd . foldl1 max . map mark . group . map (\x -> (x`div`dampingFactor)*dampingFactor) where mark (a:as) = (1 + length as, a) mark [] = error "cannot happen" -- Map audio into Sample datatypes audioToSamples :: WAVESamples -> [Sample Int] audioToSamples ws = tidyZ $ groupZ False 0 $ concat ws -- Take audio into morse code and print it audioToMorse :: String -> IO MorseString audioToMorse f = do (WAVE _ ws) <- getWAVEFile f let q = audioToSamples ws d = rDit q s = 3*d c = sampleToMorse d s q return $ concat c where rDit ms = mostFrequent $ getSpaceLengths $ ms sampleToMorse _ _ [] = [] sampleToMorse d s (m:ms') = case m of (Space x) -> if abs (x - d) < dampingFactor -- dit length space (between symbols in a char) then "" : sampleToMorse d s ms' else if abs (x - s) < dampingFactor -- med length space (between chars in a word) then " " : sampleToMorse d s ms' else " _ " : sampleToMorse d s ms' -- long space, between words (Beep x) -> if abs (x - d) < dampingFactor then "." : sampleToMorse d s ms' -- dit else "-" : sampleToMorse d s ms' -- dah putAudioToMorse :: String -> IO () putAudioToMorse f = audioToMorse f >>= putStrLn audioToString :: String -> IO String audioToString f = do ms <- audioToMorse f return $ morseToString ms putAudioToString :: String -> IO () putAudioToString f = audioToString f >>= putStrLn main :: IO () main = do (os, _) <- getArgs >>= myOpts if optUnmorse os then interact morseToString else if optAudio os then do xs <- getContents putStr $ verboseWav os xs stringToMorseWavFile xs if optPlayAudio os then do putStr $ verbosePlay os xs pid <- runCommand "aplay -q morse-out.wav" waitForProcess pid return () else return () else if optUnAudio os then if optStringFromAudio os then putAudioToString "morse-in.wav" else putAudioToMorse "morse-in.wav" else interact stringToMorse where verboseWav os xs = if optVerbose os then stringToMorse xs ++ "Writing to morse-out.wav\n" else "" verbosePlay os xs = if optVerbose os then "Playing morse-out.wav\n" else ""


Comments

  • Be respectful. You may want to read the comment guidelines before posting.
  • You can use Markdown syntax to format your comments. You can only use level 5 and 6 headings.
  • You can add class="your language" to code blocks to help highlight.js highlight them correctly.

Privacy note: This form will forward your IP address, user agent and referrer to the Akismet, StopForumSpam and Botscout spam filtering services. I don’t log these details. Those services will. I do log everything you type into the form. Full privacy statement.