module FolPP where

import Text.PrettyPrint.HughesPJ
import Fol
--import Cl.Print(printTree)


-- The debugging pretty printer
--debugPrinter :: ProofObl -> Doc
debugPrinter (_n,cs,p) = complete_doc
    where complete_doc = header $+$ transd $+$ 
                         middle $+$ transp $+$ 
                         footer
          header = text "-- Start of program: " -- <> text (opId n)
          middle = text "-- Properties"
          footer = text "-- End of file"
          transd = vcat (map (\ c -> (opClause c) <> (char '.')) cs)
          transp = vcat (map (\ c -> (opClause c) <> (char '.')) p)


instance Show Clause where
  show     = render . opClause
  showList = (++) . render . vcat . map (\c-> opClause c <> char '.')

-- The Otter pretty printer
otterPrinter :: ProofObl -> Doc
otterPrinter (n,cs,p) = complete_doc
    where complete_doc = header $+$ transd $+$ 
                         middle $+$ transp $+$ footer
          transd = vcat (map (\ c -> (opClause c) <> (char '.')) cs)
          transp = vcat (map (\ c -> (opClause c) <> (char '.')) p)
          header = vcat (map text [ "set(prolog_style_variables).",
                                    "set(auto).",
                                    "",
                                    "list(usable).",
                                    "",
                                    "equal(X,X).",
                                    "" ])
          middle = vcat (map text [ "",
                                    "end_of_list.",
                                    "",
                                    "list(sos).",
                                    "" ])
          footer = vcat (map text [ "",
                                    "end_of_list." ])

opClause :: Clause -> Doc
opClause cl = case cl of
    Cl cl                 -> opYes <> (opClBody cl)
    ClNot cl              -> opNot <> (opClBody cl)
    ClOr cs               -> hsep (punctuate (text "| ") (map opClause cs))
    ClInline id           -> error "Inlining not done"
    ClNinline (Qname m n) -> error ("Ninlining not done - "++m++"."++n)

opClBody :: ClBody -> Doc 
opClBody (ClEqual t1 t2) = opEqual <> 
                           (parens ((opTerm t1) <> comma <+> (opTerm t2)))

opTerm :: Term -> Doc
opTerm t = case t of
    Fvar s     -> text ("V_" ++ opId s)
    Ffun s     -> text ("f_" ++ opId s)
    Fcon s     -> text ("c_" ++ opId s)
    Fapp t1 t2 -> opApp <> (parens ((opTerm t1) <> comma <+> (opTerm t2)))

opId :: Id -> String
opId (Qname m v) = m ++ "_" ++ v

opApp :: Doc 
opApp = text "app"

opEqual :: Doc
opEqual = text "equal"

opNot :: Doc
opNot = text "-"

opYes :: Doc
opYes = empty

-- The TPTP pretty printer
tptpPrinter :: ProofObl -> Doc
tptpPrinter (n,cs,ps) = complete_doc -- Not implemented!
    where complete_doc = header $+$ footer
          header       = vcat (map text [ "" ])
          footer       = vcat (map text [ "" ])

tpTopLevelClause :: Clause -> Doc
tpTopLevelClause cl = intro <> transl <> (text " ]") $+$ outro
    where intro  = (text "input_clause(x,axiom,") $+$ (text " [ ")
          outro  = (text ").") $+$ (text "")
          transl = tpClause cl
 
tpClause :: Clause -> Doc
tpClause cl = case cl of
    Cl cl    -> tpYes <> (tpClBody cl)
    ClNot cl -> tpNot <> (tpClBody cl)
    ClOr cs  -> hsep (punctuate comma (map tpClause cs))

tpClBody :: ClBody -> Doc 
tpClBody (ClEqual t1 t2) = tpEqual <> 
                           (parens ((tpTerm t1) <> comma <+> (tpTerm t2)))

tpTerm :: Term -> Doc
tpTerm t = case t of
    Fvar s     -> text ("V_" ++ tpId s)
    Ffun s     -> text ("f_" ++ tpId s)
    Fcon s     -> text ("c_" ++ tpId s)
    Fapp t1 t2 -> redApp [tpTerm t2] t1
        where redApp ds (Fapp t1' t2') = redApp ((tpTerm t2'):ds) t1'
              redApp ds t = (tpTerm t) <> (parens(hcat (punctuate comma ds)))

tpId :: Id -> String
tpId (Qname m v) = m ++ "_" ++ v

tpApp :: Doc 
tpApp = empty

tpEqual :: Doc
tpEqual = text "equal"

tpNot :: Doc
tpNot = text "--"

tpYes :: Doc
tpYes = text "++"