module Monocle.Tex (
Texified (..),
texObj,
ptex,
pobj,
pdoc
)where
import Monocle.Core
import Monocle.Utils
import Monocle.Markup
import IO
import Control.Monad.State
import qualified Data.Map as Map
class Texified a where
tex :: a -> String
doc :: a -> String
s'join inf [] = ""
s'join inf (x:xs) = foldl (\x y -> x++inf++y) x xs
t'sub x = "_{" ++ x ++ "}"
t'sup x = "^{" ++ x ++ "}"
t'id x = " id" ++ (t'sub x)
t'op op [] = ""
t'op op (z:[]) = z
t'op op (z:zs) = (foldl (\x y -> x++op++" "++y) z zs)
t'rop op [] = ""
t'rop op x = t'op op $ reverse x
t'open x =
if not $ null x then
if head x == '(' && last x == ')'
then init $ tail x
else x
else x
t'close x =
if not $ null x then
if head x /= '(' || last x /= ')'
then "(" ++ x ++ ")"
else x
else x
t'cmd cmd x = " \\" ++ cmd ++ "{" ++ x ++ "}"
t'sf x = t'cmd "textsf" x
t'begin x = t'cmd "begin" x
t'end x = t'cmd "end" x
t'endl = "\n"
t'math f = "$" ++ f ++ "$"
t'docMap mp = map doc $ filter (not.isId) $ fst $ unzip $ Map.toList mp
t'docType_ fobj f = (t'open $ fobj $ dom f)++"\\to "++(t'open $ fobj $ cod f)
t'docHead_ ftex fobj wd f = t'endl ++ (t'sf wd) ++ ( t'math $ (ftex f) ++ ": " ++ (t'docType_ fobj f) ) ++ t'endl
t'itemize [] = ""
t'itemize items = (t'sf " where ") ++ t'endl ++ (t'begin "itemize") ++
(foldl (\x y -> x++"\n\\item "++y) "" items) ++ (t'end "itemize") ++ t'endl
t'doc_ ftex fobj wd f mp = (t'docHead_ ftex fobj wd f) ++ (t'itemize $ t'docMap mp)
t'texF_ ftex nm xs = nm ++ (t'close $ s'join ", " $ map ftex xs)
t'texNaturalTfm_ ftex fobj x xs = (ftex x) ++ (t'sub $ t'op ", " $ map fobj xs)
t'texMor f = case f of
Arrow y _ -> str y
Func nm xs t -> case t of
Function -> t'texF_ t'texMor nm xs
Functor -> t'texF_ t'texMor nm xs
Cofunctor -> t'texF_ t'texMor nm xs
Transform nm x xs -> t'texNaturalTfm_ t'texMor t'objMor x xs
Id y -> t'id $ str y
Tensor [] -> "id_I"
Tensor y -> t'close $ t'op "\\otimes" $ map t'texMor y
Composition y -> t'close $ t'rop "\\circ" $ map t'texMor y
t'objMor f = case f of
Func nm xs t -> case t of
Function -> t'texF_ t'objMor nm xs
Functor -> t'texF_ t'objMor nm xs
Cofunctor -> t'texF_ t'objMor nm xs
Id y -> str y
Tensor [] -> "I"
Tensor y -> t'close $ t'op "\\otimes" $ map t'objMor y
_ -> error "texObj: not an object"
instance (Printable a, Ord a) => Texified (Mor a) where
tex f = t'math $ t'open $ t'texMor f
doc f = if atomary f then
if not $ isId f then t'docHead_ t'texMor t'objMor "morphism " f else ""
else t'doc_ t'texMor t'objMor "morphism " f $ collect f
texObj :: Printable t => Mor t -> String
texObj f = t'open (t'objMor f)
instance (Printable a, Ord a) => Texified (Rule a) where
tex (DefEqual l r) = (t'sf "rule ")++ ( t'math ( (t'texMor l) ++ "\\equiv " ++ (t'texMor r) ) )
doc s@(DefEqual l r) = let dl = doc l; dr = doc r in
(tex s) ++ (t'sf " where ") ++ t'endl ++ (t'begin "itemize") ++
(if not $ null dl then "\\item "++ dl else "") ++
(if not $ null dr then "\\item " ++ dr else "") ++
(t'end "itemize")
t'mblab lab x =
if null lab then x
else (t'close x) ++ (t'sub lab)
t'texLab f = case f of
MFunc nm xs t lab -> t'mblab lab $ case t of
Function -> t'texF_ t'texLab nm xs
Functor -> t'texF_ t'texLab nm xs
Cofunctor -> t'texF_ t'texLab nm xs
MTransform nm x xs lab -> t'mblab lab $ t'texNaturalTfm_ t'texLab t'objMor x xs
MTensor [] lab -> t'mblab lab "id_I"
MTensor xs lab -> t'mblab lab $ t'op "\\otimes" $ map t'texLab xs
MComposition xs lab -> t'mblab lab $ t'op "\\circ" $ map t'texLab xs
_ -> t'mblab (getLabel f) $ t'texMor $ unmark f
t'objLab f = case f of
MFunc nm xs t lab -> t'mblab lab $ case t of
Function -> t'texF_ t'objLab nm xs
Functor -> t'texF_ t'objLab nm xs
Cofunctor -> t'texF_ t'objLab nm xs
MId f lab -> t'mblab lab $ texObj f
MTensor [] lab -> t'mblab lab "I"
MTensor xs lab -> t'mblab lab $ t'op "\\otimes" $ map t'objLab xs
_ -> error "texObjLab: not an object"
texObjLab f = t'open (t'objLab f)
instance (Printable a, Ord a) => Texified (Lab a) where
tex f = t'math $ t'open $ t'texLab f
doc f = if atomary $ unmark f then
if not $ isId f then t'docHead_ t'texLab t'objLab "marked morphism " f else ""
else t'doc_ t'texLab t'objLab "marked morphism " f $ collect $ unmark f
ptex :: (Texified a) => a -> IO ()
ptex f = do putStrLn $ tex f
pobj :: Printable t => Mor t -> IO ()
pobj f = do putStrLn $ texObj f
pdoc :: (Texified a) => a -> IO ()
pdoc f = do putStrLn $ doc f