module CPF where

import Data.List
import Term
import Rule
import TRS
import Fork
import Linear
import Matrix
import SN hiding (phi)
import PCP
import Labeling
import qualified TA
import Proof
import Text.XML.Light
import Version

type Attribute = (String, String)

type Certificate = (TRS, Signature, TRS, Proof)



-- XMLs

text :: String -> CData
text s = CData {cdVerbatim = CDataText, cdData = s, cdLine = Nothing}

int :: Int -> CData
int n = text (show n)

qname :: String -> String -> QName
qname prefix name = QName {qPrefix = Just prefix, qName = name, qURI = Nothing}

attr :: QName -> String -> Attr
attr key val = Attr {attrKey = key, attrVal = val}

-- term and rule

tag_term :: Term -> Element
tag_term (V x)    = unode "var" (text x)
tag_term (F f ts) = 
  unode "funapp" 
    (unode "name" (text f) :
     [tag_term t  | t <- ts ])

tag_rule :: Rule -> Element
tag_rule (l, r) = unode "rule" [tag_term l, tag_term r]

-- lookupTables

tag_index :: Int -> Element
tag_index i = unode "index" (int (i + 1))

tag_lookupTable :: TRS -> Element
tag_lookupTable trs =
  unode "lookupTables" 
    (unode "ruleTable" 
       [ unode "indexToRule" [tag_index i, tag_rule rule]
       | (i, rule) <- zip [0..] trs ])

-- input

tag_signature :: Signature -> Element
tag_signature sig =
  unode "signature"
    [ unode "symbol" [unode "name" (text f), unode "arity" (int n)]
    | (f, n) <- sig ]

tag_ruleIndex :: TRS -> Rule -> Element
tag_ruleIndex table rule
  | Just i <- elemIndex rule table = unode "ruleIndex" (int (i + 1))
  | otherwise                      = tag_rule rule

tag_rules :: TRS -> TRS -> Element
tag_rules table rules =
  unode "rules" [ tag_ruleIndex table rule | rule <- rules ]

tag_relativeRules :: TRS -> TRS -> Element
tag_relativeRules table rules =
  unode "relativeRules" [ tag_ruleIndex table rule | rule <- rules ]

tag_input :: TRS -> (Signature, TRS, TRS) -> Element
tag_input table (sig, rs, ss) =
  unode "input"
    (unode "trsWithSignature" 
       ([tag_signature sig, unode "trs" (tag_rules table rs)] ++ relatives))
  where
    relatives
      | ss == []  = []
      | otherwise = [tag_relativeRules table ss]


tag_trs :: TRS -> TRS -> Element
tag_trs table trs = unode "trs" (tag_rules table trs)

-- termination proofs based on linear interpretations

tag_sum :: [Element] -> Element
tag_sum []  = unode "integer" (int 0)
tag_sum [e] = e
tag_sum es  = unode "sum" es

tag_cxi :: (Int, Int) -> Element
tag_cxi (1, i) = unode "variable" (int i)
tag_cxi (c, i) =
  unode "product"
    [unode "integer"  (int c), 
     unode "variable" (int i)]


tag_linear_interpret :: Linear.Interpretation -> Element
tag_linear_interpret (f, c0, cs) =
  unode "interpret"
    [unode "name" (text f),
     unode "arity" (int (length cs)),
     tag_sum 
       ([ tag_cxi (c, i) | (c, i) <- zip cs [1..], c /= 0 ] ++
        if c0 == 0 then [] else [unode "integer" (int c0)] )]

tag_sum_vector :: [Element] -> Element
tag_sum_vector []  = tag_vector (0,0)
tag_sum_vector [e] = e
tag_sum_vector es  = unode "sum" es

tag_vector :: Vector -> Element
tag_vector (a, b) =
  unode "vector" 
    [unode "integer" (int a),
     unode "integer" (int b)]

tag_matrix :: Matrix -> Element
tag_matrix (a, b, c, d) =
  unode "matrix"
    [tag_vector (a, b),
     tag_vector (c, d)]

tag_monomial :: (Int, Matrix) -> Element
tag_monomial (i, (1,0,0,1)) = unode "variable" (int i)
tag_monomial (i, m) =
  unode "product"
    [tag_matrix m, 
     unode "variable" (int i)]

tag_matrix_interpret :: Matrix.Interpretation -> Element
tag_matrix_interpret (f, c0, cs) =
  unode "interpret"
    [unode "name" (text f),
     unode "arity" (int (length cs)),
     tag_sum_vector 
       ([ tag_monomial (i, m) | (i, m) <- zip [1..] cs, m /= (0,0,0,0) ] ++
        if c0 == (0,0) then [] else [tag_vector c0] )]

tag_order :: Order -> Element
tag_order (Linear algebra) =
  unode "interpretation"
    (unode "type" 
        (unode "polynomial" 
           [unode "domain" (unode "naturals" ()),
            unode "degree" (int 1)]) :
     [ tag_linear_interpret interpretation | interpretation <- algebra ])
tag_order (Matrix algebra) =
  unode "interpretation"
    (unode "type" 
        (unode "matrixInterpretation" 
           [unode "domain" (unode "naturals" ()),
            unode "dimension" (int 2),
            unode "strictDimension" (int 1)]) :
     [ tag_matrix_interpret interpretation | interpretation <- algebra ])
tag_order (UpperTriangularMatrix algebra) =
  unode "interpretation"
    (unode "type" 
        (unode "matrixInterpretation" 
           [unode "domain" (unode "naturals" ()),
            unode "dimension" (int 2),
            unode "strictDimension" (int 1)]) :
     [ tag_matrix_interpret interpretation | interpretation <- algebra ])

tag_trsTerminationProof :: TRS -> TRS -> TRS -> SNProof -> Element
tag_trsTerminationProof _ _ _ RIsEmpty =
  unode "trsTerminationProof" (unode "rIsEmpty" ())
tag_trsTerminationProof table trs_R trs_S (MonotoneReductionPair _ _ order) =
  unode "trsTerminationProof"
    (unode "ruleRemoval" 
       [tag_order order,
        unode "trs" (tag_rules table trs_R),
        tag_trsTerminationProof table [] trs_S RIsEmpty])

tag_terminationCertificationProblem :: (TRS, TRS, TRS, SNProof) -> Element
tag_terminationCertificationProblem (table, trs_R, trs_S, sn_proof) = 
  add_attrs 
    [attr (qname "xmlns" "xsi") "http://www.w3.org/2001/XMLSchema-instance", 
     attr (qname "xsi" "noNamespaceSchemaLocation") "cpf3.xsd"]
    (unode "certificationProblem"
       [unode "cpfVersion" (text "3.0"),
        tag_lookupTable table,
        unode "input"
          (unode "trsInput"
             [unode "trs" (tag_rules table trs_R),
              unode "relativeRules" (tag_rules table trs_S)]),
        unode "property" (unode "termination" ()),
        unode "answer" (unode "yes" ()),
        unode "proof" (tag_trsTerminationProof table trs_R trs_S sn_proof),
        unode "metaInformation"
          (unode "toolInfos"
             [unode "toolInfo" (text "Hakusan"),
              unode "toolInfo" (text ("version: " ++ version))])])

show_terminationCertificate :: (TRS, TRS, TRS, SNProof) -> String
show_terminationCertificate certificate =
  -- "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>\n" ++
  "<?xml version=\"1.0\"?>\n" ++
  "<?xml-stylesheet type=\"text/xsl\" href=\"cpf3HTML.xsl\"?>\n" ++
  showElement (tag_terminationCertificationProblem certificate) ++ "\n"

-- rule labeling

tag_positionInTerm :: Position -> Element
tag_positionInTerm p = 
  unode "positionInTerm" 
    [ unode "position" (int (i + 1)) | i <- p ]

tag_labels :: Int -> Int -> Element
tag_labels maxLeft right =
  unode "labels" 
    [unode "maxLeft" (int maxLeft),
     unode "right" (int right)]

tag_intermediateTerms :: [Term] -> Element
tag_intermediateTerms ts =
  unode "intermediateTerms" [ tag_term t | t <- ts ]

tag_critPairInfo :: CritPairInfo -> Element
tag_critPairInfo (t, ps, s, u, labels, vs) = 
  unode "critPairInfo" 
    ([unode "left" (tag_term t), 
      unode "peak" (tag_term s), 
      unode "right" (tag_term u),
      unode "overlapPositions" [ tag_positionInTerm p | p <- ps ]] ++
      f labels ++
      [tag_intermediateTerms vs])
  where
    f Nothing = []
    f (Just (maxLeft, right)) = [tag_labels maxLeft right]

tag_joinSequences :: [CritPairInfo] -> Element
tag_joinSequences joinSequences =
  unode "joinSequences" 
    [ tag_critPairInfo critPairInfo | critPairInfo <- joinSequences ]


tag_ruleLabelingFunction :: TRS -> Labeling Int -> Element
tag_ruleLabelingFunction table phi =
  unode "ruleLabelingFunction"
    [ unode "ruleLabelingFunctionEntry" 
        [tag_ruleIndex table rule, unode "label" (int n)]
    | (rule, n) <- phi ]

index :: TRS -> Rule -> Int
index table rule
  | Just i <- elemIndex rule table = i
  | otherwise                = error "index"

indexes :: TRS -> TRS -> [Int]
indexes table trs = [ index table rule | rule <- trs ]

tag_answer :: Status -> Element
tag_answer Proved    = unode "answer" (unode "yes" ())
tag_answer Disproved = unode "answer" (unode "no" ())
tag_answer _         = error "tag_answer"

tag_rewriteStep :: TRS -> Step -> Element
tag_rewriteStep table (p, rule, t) =
  unode "rewriteStep"
    [tag_positionInTerm p,
     tag_ruleIndex table rule,
     tag_term t]

tag_rewriteSequence :: TRS -> Sequence -> Element
tag_rewriteSequence table (s, steps) =
  unode "rewriteSequence"
    (unode "startTerm" (tag_term s) :
     [ tag_rewriteStep table step | step <- steps])

tag_nonJoinableFork :: TRS -> Fork -> Element -> Element
tag_nonJoinableFork table (left, s, right) e =
  unode "nonJoinableFork" 
    [tag_rewriteSequence table (s, left),
     tag_rewriteSequence table (s, right),
     e]

tag_name :: String -> Element
tag_name s = unode "name" (text s)

tag_state :: Int -> Element
tag_state q = unode "state" (int q)

tag_transition :: ((String, [Int]), Int) -> Element
tag_transition ((f, ps), q) =
  unode "transition"
    [unode "lhs" (tag_name f : [ tag_state p | p <- ps ]),
     unode "rhs" (tag_state q)]

tag_treeAutomaton :: TA.TA Int -> Element
tag_treeAutomaton dta =
  unode "treeAutomaton"
    [unode "finalStates"
       [ tag_state q | q <- TA._Qf dta],
     unode "transitions" 
       [ tag_transition transition | transition <- TA._non_epsilon dta ]]

tag_criterion :: TA.TA Int -> Element
tag_criterion dta =
  unode "criterion"
    (unode "stateCompatibility"
      (unode "relation"
          [ unode "entry" [tag_state p, tag_state q]
          | (p, q) <- TA._relation dta ]))
          
tag_proof_steps :: TRS -> [ProofStep] -> Element
tag_proof_steps _ [Emptiness] = 
  unode "crProof" (unode "orthogonal" ())
tag_proof_steps table [TCAP _ fork] =
  unode "crDisproof"
    (tag_nonJoinableFork table fork (unode "capNotUnif" ()))
tag_proof_steps table [TA _ fork dta1 dta2] =
  unode "crDisproof"
    (tag_nonJoinableFork table fork 
      (unode "emptyTreeAutomataIntersection"
         [unode "firstAutomaton" 
            [tag_treeAutomaton dta1, tag_criterion dta1],
          unode "secondAutomaton" 
            [tag_treeAutomaton dta2, tag_criterion dta2]]))
tag_proof_steps table (r@(RL {}) : proof_steps) =
  unode "crProof"
    (unode "compositionalPcpRuleLabeling"
       [tag_ruleLabelingFunction table (_phi r),
        tag_ruleLabelingFunction table (_psi r),
        unode "joinsRS" (tag_joinSequences (_joinsRS r)),
        unode "joinsSR" (tag_joinSequences (_joinsSR r)),
        unode "trs" (tag_rules table (_trsC r)),
        tag_proof_steps table proof_steps])
tag_proof_steps table (r@(CPS {}) : proof_steps) =
  unode "crProof"
    (unode "compositionalPcps"
      [unode "trsC" (tag_rules table (_trsS r)),
       unode "trsP" (tag_rules table (_trsP r)),
       tag_joinSequences (_joinSequencesForS r),
       tag_joinSequences (_joinSequencesForR r),
       tag_trsTerminationProof table (_trsP r) (_trsR r) (_relativeTerminationProof r),
       tag_proof_steps table proof_steps])
tag_proof_steps _ (Redundancy {} : _) =
  error "CPF3 output for redundant rule elimination is unsupported."
tag_proof_steps _ (KH12 {} : _) =
  error "CPF3 output for Klein and Hirokawa 2012 is unsupported."
tag_proof_steps _ _ = error "MAYBE"


crProof_or_crDisproof :: Status -> String
crProof_or_crDisproof Proved    = "crProof"
crProof_or_crDisproof Disproved = "crDisproof"
crProof_or_crDisproof _         = "crProof_or_crDisproof"

tag_proof :: TRS -> Proof -> Element
tag_proof table (proof_steps, _) =
  unode "proof" (tag_proof_steps table proof_steps)

tag_certificationProblem :: Certificate -> Element
tag_certificationProblem (table, sig, trs, proof@(_, status)) = 
  add_attrs 
    [attr (qname "xmlns" "xsi") "http://www.w3.org/2001/XMLSchema-instance", 
     attr (qname "xsi" "noNamespaceSchemaLocation") "cpf3.xsd"]
    (unode "certificationProblem"
       [unode "cpfVersion" (text "3.0"),
        tag_lookupTable table,
        tag_input table (sig, trs, []),
        unode "property" (unode "confluence" ()),
        tag_answer status,
        tag_proof table proof,
        unode "metaInformation"
          (unode "toolInfos"
             [unode "toolInfo" (text "Hakusan"),
              unode "toolInfo" (text ("version: " ++ version))])])

show_certificate :: Certificate -> String
show_certificate certificate =
  "<?xml version=\"1.0\"?>\n" ++
  "<?xml-stylesheet type=\"text/xsl\" href=\"cpf3HTML.xsl\"?>\n" ++
  showElement (tag_certificationProblem certificate) ++ "\n"

-- for interface to TTT2

relativeTerminationProof :: String -> Maybe Element
relativeTerminationProof s = do
  root <- parseXMLDoc s
  proof <- findChild (unqual "proof") root
  findChild (unqual "trsTerminationProof") proof

tag_relativeTerminationProof :: String -> Element
tag_relativeTerminationProof proof =
  case relativeTerminationProof proof of
    Nothing -> error ("tag_relativeTerminationProof: Failed to parse\n" ++ proof)
    Just e  -> e

tag_wst_rule :: Rule -> Element
tag_wst_rule (l, r) =
  unode "rule" [unode "lhs" (tag_term l),
                unode "rhs" (tag_term r)]

tag_wst_relrules :: TRS -> Element
tag_wst_relrules trs = 
  unode "relrules" [ tag_wst_rule lr | lr <- trs ]

tag_wst_rules :: (TRS, TRS) -> Element
tag_wst_rules (rs, []) = 
  unode "rules" [ tag_wst_rule lr | lr <- rs ]
tag_wst_rules (rs, ss) =
  unode "rules" ([ tag_wst_rule lr | lr <- rs ] ++ [tag_wst_relrules ss])
 
tag_wst_trs :: (TRS, TRS) -> Element
tag_wst_trs (rs, ss) = 
  unode "trs" 
    [tag_wst_rules (rs, ss),
     tag_signature (TRS.signature_of (rs ++ ss))]

tag_problem :: (TRS, TRS) -> Element
tag_problem (rs, ss) = 
  add_attrs
    [attr (qname "xmlns" "xsi") "http://www.w3.org/2001/XMLSchema-instance",
     attr (unqual "type") "termination",
     attr (qname "xsi" "noNamespaceSchemaLocation") "/xtc.xsd"]
  (unode "problem" 
     [tag_wst_trs (rs, ss),
      unode "strategy" (text "FULL")])

show_problem :: (TRS, TRS) -> String
show_problem (rs, ss) = 
  "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"no\"?>\n" ++
  showElement (tag_problem (rs, ss)) ++ "\n"
