Diagnose.hs

{-# LANGUAGE FlexibleContexts #-}
-----------------------------------------------------------------------------
-- Copyright 2019, Advise-Me project team. This file is distributed under 
-- the terms of the Apache License 2.0. For more information, see the files
-- "LICENSE.txt" and "NOTICE.txt", which are included in the distribution.
-----------------------------------------------------------------------------
-- |
-- Maintainer  :  bastiaan.heeren@ou.nl
-- Stability   :  provisional
-- Portability :  portable (depends on ghc)
--
-----------------------------------------------------------------------------

module Main.Diagnose where

import Main.ParserCSV
import Data.List
import Data.Time
import Ideas.Common.Id
import Ideas.Text.HTML
import Recognize.Data.MathStoryProblem
import Recognize.Data.Approach
import Recognize.Data.Entry
import Recognize.Data.Solution
import Util.W3CSSHTML

diagnoseSingle :: MathStoryProblem -> String -> IO Entry
diagnoseSingle e _ = timed $ do
    let entry = diagnose e (defaultSolution [error "diagnoseSingle conversion of Solution"])
    print entry
    writePage ("single."++show e) (makePage (show e) (toHTML entry))
    return entry

diagnoseMultiple :: MathStoryProblem -> CSV -> IO ()
diagnoseMultiple e csv = timed $ do
    let answers = map (defaultSolution . map (uncurry Input . fmap ((:[]).Right))) (restrict csv) -- [[Id,String]]
        nrs     =  [1 :: Int ..]
        entries = zipWith (\_ -> diagnose e) nrs answers -- todo add ann and gs to entry
    -- writeFileMsg "output/extracted.txt" (outExtract entries) -- always empty
    writeFileMsg "output/diagnosed.txt" (outDiagnose entries)
    writeFileMsg "output/categories.txt" (outCategories entries)
    writeOutput ("output/out."++show e++".txt") entries
    writePage ("all."++show e) (makePage (show e) (mconcat (map toHTML entries)))
    --writePages ("html/all."++show e++".html") False entries
  --  writeErrors "output/errors.txt" entries
    putStrLn $ "Answers: " ++ show (length entries)
    putStrLn $ categoryStatistics entries

timed :: IO a -> IO a
timed m = do
    t0 <- getCurrentTime
    a  <- m
    t1 <- getCurrentTime
    putStrLn $ "time: " ++ show (diffUTCTime t1 t0)
    return a

writeOutput :: FilePath -> [Entry] -> IO ()
writeOutput file = writeFileMsg file . show

{-}
writeErrors :: FilePath -> [Entry e] -> IO ()
writeErrors file = writeFileMsg file . show . filter p . map f
  where
    f x = x { rawText = [], formulas = filter (isNothing . getExpr) (formulas x) }
    p = not . null . formulas
-}

writeFileMsg :: FilePath -> String -> IO ()
writeFileMsg file s = do
    putStr $ "Generating " ++ file ++ "... "
    writeFile file s
    putStrLn "ok"

-- outExtract :: [Entry e] -> String
-- outExtract = unlines . concatMap f
--   where
--     f entry
--       | null (Recognize.Data.Entry.formulas entry) = [nr ++ "EMPTY"]
--       | otherwise = map g (Recognize.Data.Entry.formulas entry)
--       where
--         nr  = "#" ++ show (entryNr entry) ++ ": "
--         g x = case getExpr x of
--                   Just xs -> nr ++ show xs
--                   Nothing -> nr ++ "ERROR: " ++ getString x

outDiagnose :: [Entry] -> String
outDiagnose = unlines . zipWith f [0 :: Int ..]
  where
    f nr entry = nrStr ++ "\n" ++ concatMap (\d -> show d ++ "\n") (diagnoses entry)
      where
        nrStr = "#" ++ show nr ++ ": "

outCategories :: [Entry] -> String
outCategories = unlines . zipWith f [0 :: Int ..]
  where
  f nr entry = nrStr ++ intercalate ", " (map (show . approach) $ diagnoses entry)
    where
    nrStr = "#" ++ show nr ++ ": "

categoryStatistics :: [Entry] -> String
categoryStatistics xs = unlines $ map f $ count $ map categoryAsString xs
  where
    nrTotal  = length xs
    f (d, n) = d ++ ": " ++ show n ++ percPar n nrTotal

count :: Ord a => [a] -> [(a, Int)]
count = map f . group . sort
  where
    f xs = (head xs, length xs)

percPar :: Integral a => a -> a -> String
percPar x y = " (" ++ perc x y ++ ")"

perc :: Integral a => a -> a -> String
perc x y | y == 0 = "0%"
         | otherwise = show d ++ "." ++ make (show m) ++ "%"
  where
    (d, m) = (round ((10000 * fromIntegral x / fromIntegral y) :: Double) :: Integer) `divMod` 100

    make s = replicate (2 - length s) '0' ++ s

    {-
instance Show Formula where
    show x = "  " ++ ljustify 25 (rawFormula x) ++ ": " ++
      case recognized x of
          Just xs -> showChecked xs
          Nothing -> "???" ++ if balanced (rawFormula x) then "" else " (unbalanced)"
    where
      showChecked a = show a ++ if checkEquation a then "" else " (not equal)"

    showList = (++) . unlines . map show -}

restrict :: [[String]] -> [[(Id,String)]]
restrict xs = map (zip header) content
  where
    ys = map (map normalize) xs
    header = map newId (head ys)
    content = filter (\y -> p y && not (null y)) (tail ys)
    p = all (not . isInfixOf "v0")
{- = map normalize . filter (not . null) . drop 1 . map f
  where
    column x =
    f [_, x] = unlines $ filter (/= "v0") $ lines x
    f _ = error "invalid number of rows"
-}
normalize :: String -> String
normalize [] = []
normalize xs | "\\'" `isPrefixOf` xs = "'" ++ normalize (drop 2 xs)
              | "\\\"" `isPrefixOf` xs = '"' : normalize (drop 2 xs)
              | "&#x" `isPrefixOf` xs =
    case break (== ';') (drop 3 xs) of
      (xs1, ';':xs2) ->
          case lookup xs1 asciiTable of
            Just c  -> c : normalize xs2
            Nothing -> '?' : normalize xs2
      _ -> error "normalize"
normalize (x:xs) = x : normalize xs

asciiTable :: [(String, Char)]
asciiTable =
    [ ("e9", 'e') -- e acute
    , ("e0", 'a') -- a grave
    , ("e8", 'e') -- e grave
    , ("f9", 'u') -- u grave
    , ("ea", 'e') -- e circumflex
    , ("e2", 'a') -- a circumflex
    , ("e7", 'c') -- c cedilla
    , ("c3", 'A') -- A tilde
    , ("f7", '%') -- division
    , ("a0", ' ') -- space
    , ("a9", '?') -- copyright
    , ("b0", '?') -- ?????
    , ("aa", '?') -- ?????
    ]