{-# LANGUAGE TemplateHaskell #-}

module NLP.GenI.Tags(
   -- Main Datatypes
   Tags, TagElem(..), TagItem(..), TagSite(..),
   TagDerivation, DerivationStep(..), emptyTE,
   ts_synIncomplete, ts_semIncomplete, ts_tbUnificationFailure,
   ts_rootFeatureMismatch,

   -- Functions from Tags
   addToTags, tagLeaves,

   -- Functions from TagElem
   setTidnums, 

   -- General functions
   mapBySem, subsumedBy, showTagSites,
   collect, detectSites
) where

import Control.Applicative ( (<$>), (<*>) )
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
import Data.List (intersperse)
import Data.Tree

import Data.Generics (Data)
import Data.Generics.PlateDirect
import Data.Typeable (Typeable)
import Text.JSON

import NLP.GenI.Btypes (Ptype(Initial, Auxiliar), SemPols,
               GeniVal(GConst), AvPair(..),
               GNode(gup, glexeme, gnname, gaconstr, gdown, gtype, gorigin),
               GType(Subs), Flist,
               DescendGeniVal(..),
               Collectable(..), Idable(..),
               Sem, Pred, emptyPred, 
               emptyGNode,
               showFlist, showPairs, showSem, lexemeAttributes,
               )
import NLP.GenI.General (groupByFM, preTerminals)
import NLP.GenI.PolarityTypes (PolarityKey(..))

-- | An anchored grammar.
--   The grammar associates a set of semantic predicates to a list of trees each.
type Tags = Map.Map String [TagElem]                            

-- | 'addTags' @tags key elem@ adds @elem@ to the the list of elements associated
--   to the key
addToTags :: Tags -> String -> TagElem -> Tags
addToTags t k e = Map.insertWith (++) k [e] t

data TagSite = TagSite { tsName :: String
                       , tsUp   :: Flist
                       , tsDown :: Flist
                       , tsOrigin :: String
                       }
  deriving (Show, Eq, Ord, Data, Typeable)

instance Biplate TagSite GeniVal where
  biplate (TagSite x1 zu zd x2) = plate TagSite |- x1 ||+ zu ||+ zd |- x2

instance Biplate (Maybe TagSite) GeniVal where
  biplate (Just x1) = plate Just |+ x1
  biplate Nothing   = plate Nothing

data TagElem = TE {
                   idname       :: String,
                   ttreename    :: String,
                   tidnum       :: Integer,
                   ttype        :: Ptype,
                   ttree        :: Tree GNode,
                   tsemantics   :: Sem,
                   -- optimisation stuff
                   -- (polarity key to charge interval)
                   tpolarities  :: Map.Map PolarityKey (Int,Int),
                   tinterface   :: Flist,  -- for idxconstraints (pol)
                   ttrace       :: [String],
                   tsempols     :: [SemPols]
                }
             deriving (Show, Eq, Data, Typeable)

instance Biplate TagElem GeniVal where
  biplate (TE x1 x2 x3 x4 zt zsem x5 zint x6 x7) =
     plate TE |- x1 |- x2 |- x3 |- x4
              |+ zt
              ||+ zsem |- x5
              ||+ zint |- x6 |- x7

type TagDerivation = [ DerivationStep ]

data DerivationStep = DerivationStep
 { dsOp         :: Char
 , dsChild      :: String
 , dsParent     :: String
 , dsParentSite :: String
 } deriving (Show, Ord, Eq)

instance JSON DerivationStep where
 readJSON j =
    do jo <- fromJSObject `fmap` readJSON j
       let field x = maybe (fail $ "Could not find: " ++ x) readJSON
                   $ lookup x jo
       DerivationStep <$> field "op"
                      <*> field "child"
                      <*> field "parent"
                      <*> field "parent-node"
 showJSON x =
     JSObject . toJSObject $ [ ("op",     showJSON  $ dsOp x)
                             , ("child",  showJSON  $ dsChild x)
                             , ("parent", showJSON  $ dsParent x)
                             , ("parent-node", showJSON $ dsParentSite x)
                             ]

instance Ord TagElem where
  compare t1 t2 = 
    case (ttype t1, ttype t2) of
         (Initial, Initial)   -> compareId 
         (Initial, Auxiliar)  -> LT
         (Auxiliar, Initial)  -> GT
         (Auxiliar, Auxiliar) -> compareId 
         _                    -> error "TagElem compare not exhaustively defined"
    where compareId  = compare (tidnum t1) (tidnum t2)

instance DescendGeniVal TagElem where
  descendGeniVal s te =
    te { tinterface = descendGeniVal s (tinterface te)
       , ttree      = descendGeniVal s (ttree te)
       , tsemantics = descendGeniVal s (tsemantics te) }

instance DescendGeniVal TagSite where
  descendGeniVal s (TagSite n fu fd o) = TagSite n (descendGeniVal s fu) (descendGeniVal s fd) o

instance Collectable TagElem where
  collect t = (collect $ tinterface t) . (collect $ ttree t) 
            . (collect $ tsemantics t)

instance Idable TagElem where
  idOf = tidnum

emptyTE :: TagElem
emptyTE = TE { idname = "",
               ttreename = "",
               tidnum = -1,
               ttype  = Initial,
               ttree  = Node emptyGNode [],
               tsemantics = [], 
               tpolarities = Map.empty,
               tsempols    = [],
               tinterface  = [],
               ttrace = []
             }

-- | Given a tree(GNode) returns a list of substitution or adjunction
--   nodes, as well as remaining nodes with a null adjunction constraint.
detectSites :: Tree GNode -> ([TagSite], [TagSite], [TagSite])
detectSites t =
  ( sites isSub           -- for substitution
  , sites (not.gaconstr)  -- for adjunction
  , sites constrButNotSub -- for neither
  )
 where
 ns = flatten t
 sites match = [ TagSite (gnname n) (gup n) (gdown n) (gorigin n) | n <- ns, match n ]
 isSub n = gtype n == Subs
 constrButNotSub n = gaconstr n && (not $ isSub n)

-- | Assigns a unique id to each element of this list, that is, an integer
--   between 1 and the size of the list.
setTidnums :: [TagElem] -> [TagElem]
setTidnums xs = zipWith (\c i -> setOrigin $ c {tidnum = i}) xs [1..]

setOrigin :: TagElem -> TagElem
setOrigin te = te { ttree = fmap setLabel . ttree $ te }
 where setLabel g = g { gorigin = idname te ++ ":" ++ (show.tidnum) te }

-- | 'TagItem' is a generalisation of 'TagElem'.
class TagItem t where 
  tgIdName    :: t -> String
  tgIdNum     :: t -> Integer
  tgSemantics :: t -> Sem

instance TagItem TagElem where
  tgIdName = idname
  tgIdNum  = tidnum
  tgSemantics = tsemantics

-- | Sorts trees into a Map.Map organised by the first literal of their
--   semantics.  This is useful in at least three places: the polarity
--   optimisation, the gui display code, and code for measuring the efficiency
--   of GenI.  Note: trees with a null semantics are filed under an empty
--   predicate, if any.
mapBySem :: (TagItem t) => [t] -> Map.Map Pred [t]
mapBySem ts = 
  let gfn t = case tgSemantics t of
              []    -> emptyPred
              (x:_) -> x
  in groupByFM gfn ts

-- | 'subsumedBy' @cs ts@ determines if the candidate semantics @cs@ is
--   subsumed by the proposition semantics @ts@.  Notice how the proposition
--   semantics is only a single item where as the candidate semantics is a
--   list.
--
--  We assume
--
--  * most importantly that @cs@ has already its semantics instatiated
--    (all variables assigned)
--
--  * @cs@ and @ts@ are sorted
--
--  * the list in each element of cs and ts is itself sorted 
subsumedBy :: Sem -> Pred -> Bool 
subsumedBy [] _ = False 
subsumedBy ((ch, cp, cla):cl) (th, tp,tla)
    | (ch == th) && (cp == tp) && (cla == tla) = True 
    -- if we haven't yet overshot, try for the next one
    | cp  < tp                   = subsumedBy cl (th, tp, tla)
    | otherwise                  = False

type UninflectedDisjunction = ([String], Flist)

tagLeaves :: TagElem -> [ (String, UninflectedDisjunction) ]
tagLeaves te = [ (gnname pt, (getLexeme t, gup pt)) | (pt,t) <- preTerminals . ttree $ te ]

-- | Try in order: lexeme, lexeme attributes, node name
getLexeme :: GNode -> [String]
getLexeme node =
  case glexeme node of
    []   -> fromMaybe [gnname node] $ firstMaybe grab lexemeAttributes
    lexs -> lexs
  where
   grab la =
     let match (AvPair a (GConst v)) | a == la = Just v
         match _ = Nothing
     in firstMaybe match guppy
   guppy      = gup node

firstMaybe :: (a -> Maybe b) -> [a] -> Maybe b
firstMaybe fn = listToMaybe . mapMaybe fn

-- Useful for debugging adjunction and substitution nodes
showTagSites :: [TagSite] -> String
showTagSites sites = concat $ intersperse "\n  " $ map fn sites
  where
   fn (TagSite n t b o) =
    concat . intersperse "/" $ [ n, showPairs t, showPairs b, o ]

ts_synIncomplete, ts_tbUnificationFailure :: String
ts_synIncomplete = "syntactically incomplete"
ts_tbUnificationFailure = "top/bot unification failure"

ts_rootFeatureMismatch :: Flist -> String
ts_rootFeatureMismatch good = "root feature does not unify with " ++ showFlist good

ts_semIncomplete :: [Pred] -> String
ts_semIncomplete sem = "semantically incomplete - missing:  " ++ showSem sem