Α Try αt Hαskeλλ in Λinguistics

import qualified Data.Map as M
import qualified Data.List as L
import Data.List.Zipper as Z
import Data.Maybe as DM
import System.Environment (getArgs)
import System.IO
 
{-----------
DATA TYPES
-----------}
type Token = String
type Tag = String
type TokenTag = (Token, Tag)
 
{----------------
IO: dealing with the outside world
-----------------}
main = do
   (command:args) <- getArgs
   case command of
      "tag" -> tag args
      _ -> putStrLn "Error: command does not exist\nPossible commands are:\n-tag filename\n"
 
tag :: [String] -> IO()
tag [trainName, testName, evalName] = do
   -- open files and retrieve contents
   trainFile <- openFile trainName ReadMode
   trainContents <- hGetContents trainFile
   testFile <- openFile testName ReadMode
   testContents <- hGetContents testFile
   evalFile <- openFile evalName ReadMode
   evalContents <- hGetContents evalFile
   let model = tokenMostFreqTag $ tokenTagFreqs $ map (toTokenTag '/') $ words trainContents
   -- test frequency tagging and print results
   putStrLn "***Frequency tagging***"
   let freqTags = freqTest model $ words testContents
   let evalTokenTag = map (toTokenTag '/') $  words evalContents
   let statFreqTags = compareMaybe evalTokenTag freqTags [0,0,0]
   prettyPrint statFreqTags
   -- test frequency tagging + base tagging and print results
   putStrLn "***Base tagging***"
   let baseTags = baseTest freqTags "NN"
   let statBaseTags = compareTag evalTokenTag baseTags [0,0]
   prettyPrint statBaseTags
   hClose testFile
   hClose evalFile
test _ = do
   putStrLn "Error: the tag command requires three arguments: tag trainName testName evalName"
 
{-------------------
MODEL TRAINER
-------------------}
-- split the tokens and the tags
toTokenTag :: Char -> String -> TokenTag
toTokenTag separator string =
   let (token, tag, _) = rsplit_ separator string
   in (token, tag)
 
rsplit_ :: (Eq a) => a -> [a] -> ([a], [a], Bool)
rsplit_ separator = foldr (splitBool separator) ([],[],False)
   where
      splitBool separator letter (token, tag, True) = (letter:token, tag, True)
      splitBool separator letter (token, tag, False) | letter == separator = (token, tag, True)
                                                     | otherwise = (token, letter:tag, False)
-- Step 1: Frequency
--  Calculate the frequency of tags for a token
tokenTagFreqs :: [TokenTag] -> M.Map Token (M.Map Tag Int)
tokenTagFreqs = L.foldl' countWord M.empty
   where
      countWord map1 (token, tag) = M.insertWith (countTag tag) token (M.singleton tag 1) map1
      countTag tag _ map2 = M.insertWith (\ newFreq oldFreq -> oldFreq + newFreq) tag 1 map2
 
-- Find the most frequent tag for a token
tokenMostFreqTag :: M.Map Token (M.Map Tag Int) -> M.Map Token Tag
tokenMostFreqTag = M.map (fst . M.foldlWithKey findMax ("NIL", 0))
   where findMax acc@(_, maxFreq) tag freq
           | freq > maxFreq = (tag, freq)
           | otherwise = acc
 
-- Step 2: add default tag
-- add default tag to all tokens without a tag (probably"NN")
defaultTag :: Tag -> (Token, Maybe Tag) -> (Token, Tag)
defaultTag baseTag (token, Nothing) = (token, baseTag)
defaultTag baseTag (token, Just tag) = (token, tag)
 
{-------------
MODEL TESTER
--------------}
lookupToken :: M.Map Token Tag -> Token -> Maybe Tag
lookupToken myMap token = M.lookup token myMap
 
freqTest :: M.Map Token Tag -> [Token] -> [(Token, Maybe Tag)]
freqTest freqModel wordList = L.zip wordList tagList
   where tagList = map (lookupToken freqModel) wordList
 
baseTest :: [(Token, Maybe Tag)] -> Tag -> [(Token, Tag)]
baseTest tokenTag baseTag = map (defaultTag baseTag) tokenTag
 
{-------------
MODEL EVALUATOR
---------------}
compareTag :: [(Token, Tag)] -> [(Token, Tag)] -> [Int] -> [Int]
compareTag [] [] [number, correct] = [number, correct]
compareTag _ [] [number, correct] = [number, correct]
compareTag [] _ [number, correct] = [number, correct]
compareTag (x:xs) (y:ys) [number, correct] = compareTag xs ys [(number + 1), (correct + (eval x y))]
                                             where eval tagOriginal tagComputed | tagOriginal == tagComputed = 1
                                                                                | otherwise  = 0
 
compareMaybe :: [(Token, Tag)] -> [(Token, Maybe Tag)] -> [Int] -> [Int]
compareMaybe [] [] [number, correct, empty] = [number, correct, empty]
compareMaybe _ [] [number, correct, empty] = [number, correct, empty]
compareMaybe [] _ [number, correct, empty] = [number, correct, empty]
compareMaybe (x:xs) (y:ys) [number, correct, empty] =
            compareMaybe xs ys [(number + 1), (correct + (evalJust x y)), (empty + (evalNothing x y))]
                 where
                   evalJust (_,tagOriginal) (_,tagComputed) | tagOriginal == (DM.fromMaybe "NIHIL" tagComputed) = 1
                                                            | otherwise = 0
                   evalNothing (_, tagOriginal) (_,tagComputed) | tagComputed == Nothing = 1
                                                                | otherwise = 0
 
prettyPrint :: [Int] -> IO()
prettyPrint [number, correct, empty] = do
   putStrLn ("Total tagged: " ++ (show $ (((number - empty) `myDiv` number) * 100)) ++ " %")
   putStrLn ("Total tagged correctly: " ++ (show $ ((correct `myDiv` number) * 100)) ++ " %")
   putStrLn ("Total empty: " ++ (show $ ((empty `myDiv` number) * 100)) ++ " %")
   putStrLn ("Total tagged known: " ++ (show $ ((correct `myDiv` (number-empty)) * 100)) ++ " %")
prettyPrint [number, correct] = do
   putStrLn ("Total tagged correctly: " ++ (show $ ((correct `myDiv` number) * 100)) ++ " %")
 
myDiv :: Int -> Int -> Float
myDiv n1 n2 = (fromIntegral n1) / (fromIntegral n2)