{-# LANGUAGE GADTs #-}

module Main where

import Infinitive
import PGF
import Data.List

data Fact = Fact {
  content  :: [Fact],
  tense    :: Maybe GTemp,
  polarity :: Maybe GPol,
  agent    :: Maybe GNP,
  action   :: Either GVS GVP
  }

initFact = Fact [] Nothing Nothing Nothing (Left undefined)

factTree fact = GUseCl mtense mpolarity (GPredVP magent mvp)
  where
    mvp = case action fact of
      Left vs -> GComplVS vs (factTree (head (content fact))) ---- head -> ambiguity 
      Right vp -> vp
    mtense = maybe presentTense id (tense fact)
    mpolarity = maybe positivePol id (polarity fact)
    magent = maybe GX_NP id (agent fact)

presentTense = GTTAnt GTPres GASimul
pastTense = GTTAnt GTPast GASimul
perfectTense = GTTAnt GTPres GAAnter
pluperfectTense = GTTAnt GTPast GAAnter
positivePol = GPPos
negativePol = GPNeg


facts :: Infinitive.Tree a -> [Fact]
facts t = case t of
  GUseCl temp pol s ->
    [f{
              tense = Just temp,
	      polarity = Just pol
	      } | f <- facts s]
  GAdjCN (GAgentPartAP np vpslash) cn ->
    [initFact{
              tense = Just perfectTense,
              agent = Just np,
	      action = Right (GComplSlash vpslash (GMassNP cn))}]
  GPredVP ag (GUseComp (GCompAP (GAgentPartAP np vpslash))) ->
    [initFact{
              tense = Just perfectTense,
              agent = Just np,
	      action = Right (GComplSlash vpslash ag)}]
  GPredVP np (GComplPresPartActReflVS vs vp) -> 
    [initFact{
              agent = Just np,
	      action = Left vs,
	      content = [
	        initFact{
		  agent = Just np,
		  action = Right vp
		  }]}]
  GPredVP np (GComplPastPartActReflVS vs vp) ->
      [initFact{
              agent = Just np,
	      action = Left vs,
	      content = [
	        initFact{
		  tense = Just perfectTense,
		  agent = Just np,
		  action = Right vp
		  }]}]
  GPredVP np (GAdvVP vp adv) ->
    [f{agent = Just np} | f <- facts vp ++ facts adv]
----  GPredVP np (GRAdvVP vp (GInf1LongRAdv vpa)) ->
----    [f{agent = Just np, action = } | f <- facts vp ++ facts adv]
  GPredVP np vp ->
    [f{agent = Just np} | f <- facts vp]
  GUseV v ->
    [initFact{
              action = Right t}]
  GUseV2 v ->
    [initFact{
              action = Right (GComplSlash (GSlashV2a v) GY_NP)}]
{-
  GComplPresPartActVS vs np vp ->
    [initFact{
              attitude =
	      Just vs,
	      agent = Just np,
	      action = Just vp}]
  GComplPastPartActVS vs np vp ->
    [initFact{
              tense = Just perfectTense,
	      attitude = Just vs,
              agent = Just np,
	      action = Just vp}]
  GInf3AbessAdv vp ->
    [initFact{
              polarity = Just negativePol,
	      action = Just vp}]
  GComplPresPartPassVS vs np vpslash -> 
    [initFact{
              attitude = Just vs,
	      action = Just (GComplSlash vpslash np)}]
  GComplPastPartPassVS vs np vpslash -> 
    [initFact{
              tense = Just perfectTense,
	      attitude = Just vs,
              action = Just (GComplSlash vpslash np)}]
-}
  _ -> composOpMPlus facts t


shortest = take 1 . sortOn treesize 

treesize t = case unApp t of
  Just (f, xs) -> 1 + sum (map treesize xs)
  _ -> 1


treat gr fin cat s = [
  (showExpr [] t ++ "\t" ++ linearize gr fin t)
     | pt <- shortest (parse gr fin cat s),
       let gt = map (gf . factTree) (facts (fg pt :: GUtt)),
       t <- gt
       ]


main = do
  gr <- readPGF "Infinitive.pgf"
  putStrLn "gr"
  let Just fin = readLanguage "InfinitiveFin"
  let typ = startCat gr
  flip mapM_ [0..] $ \_ -> do
    putStr "> "
    s <- getLine
    let ss = treat gr fin typ s
    putStrLn $ unlines ss