Morse decoder.hs

module Main where

data Trie a =
    Leaf
  | Node (Trie a) a (Trie a)

data Code   = Dot | Dash
type Word   = [ Code ]
type Phrase = [ Word ]
type Dict   = Trie (Maybe Char)

mkNode :: Trie (Maybe a) -> Trie (Maybe a) -> Trie (Maybe a)
mkNode l r = Node l Nothing r

insert :: Char -> Word -> Dict -> Dict
insert a []          Leaf         = Node Leaf (Just a) Leaf
insert a []          (Node l _ r) = Node l (Just a) r
insert a (Dot  : cs) Leaf         = mkNode (insert a cs Leaf) Leaf
insert a (Dash : cs) Leaf         = mkNode Leaf (insert a cs Leaf)
insert a (Dot  : cs) (Node l b r) = Node (insert a cs l) b r
insert a (Dash : cs) (Node l b r) = Node l b (insert a cs r)

decodeWord :: Dict -> Word -> Maybe Char
decodeWord Leaf         _           = Nothing
decodeWord (Node _ a _) []          = a
decodeWord (Node l _ _) (Dot  : cs) = decodeWord l cs
decodeWord (Node _ _ r) (Dash : cs) = decodeWord r cs

parseCode :: Char -> Code
parseCode '.' = Dot
parseCode '-' = Dash

parseWord :: String -> Word
parseWord = map parseCode

parsePhrase :: String -> Phrase
parsePhrase = map parseWord . words

decodePhrase :: Dict -> Phrase -> Maybe String
decodePhrase dict = sequence . fmap (decodeWord dict)

dictionary :: Dict
dictionary = foldl (\ d (c, w) -> insert c (parseWord w) d) Leaf
  [ ('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', "--.."),
  ('0', "-----"),
  ('1', ".----"),
  ('2', "..---"),
  ('3', "...--"),
  ('4', "....-"),
  ('5', "....."),
  ('6', "-...."),
  ('7', "--..."),
  ('8', "---.."),
  ('9', "----."),
  ('.', ".-.-.-"),
  ('\'', "--..--"),
  (',', "---..."),
  ('?', "..--.."),
  ('\'', ".----."),
  ('-', "-....-"),
  ('/', "-..-.") ]

msg :: Phrase
msg = parsePhrase ".... . .-.. .-.. ---"

main :: IO ()
main = print $ decodePhrase dictionary msg