module Main
    where

import IO
import System
import Data.Array
import Control.Monad
import IOExts

printUsage = putStrLn "ScoreAlignments human-alignment system-alignment"

main = do
  args <- getArgs
  if "-?" `elem` args || "-h" `elem` args || "--help" `elem` args ||
     (length args /= 2 && length args /= 3)
    then printUsage
    else doCalculation args

doCalculation (human:system:flipSystem) = do
  humanF   <- readFile human
  systemF  <- readFile system
  let humanAl   = readAlignment $ lines humanF
      systemAl' = readAlignment $ lines systemF
      systemAl  = if take 1 flipSystem == ["flip"] 
                    then flipAlignment systemAl'
                    else systemAl'
      p = precision humanAl systemAl
      r = recall    humanAl systemAl
  putStrLn ("Precision " ++ show p)
  putStrLn ("Recall    " ++ show r)
  putStrLn ("F-Score   " ++ show ((2 * p * r) / (p + r)))

(/.) :: Int -> Int -> Double
i /. j = (fromInteger $ toInteger i) / (fromInteger $ toInteger j)

type Al = Array (Int,Int) Int

flipAlignment arr = array ((0,0),(w,h)) [((j,i),arr!(i,j)) | i <- [0..h], j <- [0..w]]
    where (_,(h,w)) = bounds arr

precision,recall :: Al -> Al -> Double
precision hum a = alSize (possible a `alIntersect` sure hum) /. alSize (sure hum)
recall hum a = alSize (possible a `alIntersect` possible hum) /. alSize (possible a)

possible arr = array (bounds arr) [(idx, arr ! idx > 0) | idx <- indices arr]
sure     arr = array (bounds arr) [(idx, arr ! idx > 1) | idx <- indices arr]
alSize = length . filter id . elems

alIntersect a1 a2 = array (bounds a1 `max` bounds a2) 
                    [((i,j), a1 ! (i,j) && a2 ! (i,j)) 
                       | i <- [(min l1a l2a)..(max h1a h2a)], 
                         j <- [(min l1b l2b)..(max h1b h2b)]]
    where ((l1a,l1b),(h1a,h1b)) = bounds a1
          ((l2a,l2b),(h2a,h2b)) = bounds a2

readAlignment :: [String] -> Al
readAlignment (('#':dims):txt) = arr3
    where arr  = array ((0,0),(height-1,width-1)) $
                       concat $ map readAl (zip [0..] (map words $ take height txt))
          arr2 = arr  // readRest (take 1 $ drop height txt)
          arr3 = arr2 // concatMap (readPhrase . map read . words) (drop (height+1) txt)
          [height,width] = map read $ words dims

          readAl (ln,[])     = [((ln,i),0)  | i <- [0..width-1]]
          readAl (ln,["-1"]) = [((ln,i),1)  | i <- [0..width-1]]  -- mark as unsure
          readAl (ln,xs)     = 
              let xs' = map (\ (a,b) -> ((ln,read a),read b)) (mkPairs xs)
              in  [((ln,i), case lookup (ln,i) xs' of { Nothing -> 0 ; Just j -> j})
                      | i <- [0..width-1]]
          
          readRest [] = []
          readRest (botAl:_) = [((i,read bw),max 1 (arr!(i,read bw))) 
                                  | i <- [0..height-1], bw <- words botAl]

          readPhrase [an,ax,dn,dx,v] = [((i,j),max v (arr2!(i,j)))
                                           | i <- [an..ax], j <- [dn..dx]]

mkPairs [] = []
mkPairs [x] = []
mkPairs (x:y:xs) = (x,y) : mkPairs xs