marxup 1.0.2 → 3.0.0
raw patch · 24 files changed
+2925/−584 lines, 24 filesdep +configuratordep +containersdep +cubicbezierdep −parsecdep ~basedep ~mtlnew-component:exe:marxup3
Dependencies added: configurator, containers, cubicbezier, directory, dlist, glpk-hs, graphviz, lens, parsek, polynomials-bernstein, process, text, typography-geometry, vector
Dependencies removed: parsec
Dependency ranges changed: base, mtl
Files
- Main.hs +0/−171
- Main3.hs +188/−0
- MarXup.hs +10/−0
- MarXup/Beamer.hs +25/−14
- MarXup/DerivationTrees.hs +150/−148
- MarXup/Diagram.hs +7/−0
- MarXup/Diagram/Graphviz.hs +109/−0
- MarXup/Diagram/Layout.hs +203/−0
- MarXup/Diagram/Object.hs +266/−0
- MarXup/Diagram/Path.hs +156/−0
- MarXup/Diagram/Point.hs +96/−0
- MarXup/Diagram/Tikz.hs +172/−0
- MarXup/Latex.hs +171/−74
- MarXup/Latex/Bib.hs +19/−0
- MarXup/Latex/Math.hs +97/−0
- MarXup/Math.hs +99/−0
- MarXup/MetaPost.hs +0/−27
- MarXup/MultiRef.hs +50/−0
- MarXup/PrettyPrint.hs +442/−0
- MarXup/PrettyPrint/Core.hs +245/−0
- MarXup/Tex.hs +198/−110
- MarXup/Verbatim.hs +22/−0
- examples/LaTeX.hs +152/−28
- marxup.cabal +48/−12
− Main.hs
@@ -1,171 +0,0 @@-import Text.ParserCombinators.Parsec--- import Text.PrettyPrint.HughesPJ hiding (char)--- import qualified Text.PrettyPrint.HughesPJ as O---import Data.Char-import Control.Applicative hiding (many, (<|>))-import Data.List-import System.IO-import System.Environment-import Control.Monad---- todo: parse strings inside haskell code--- todo: output line directives.--instance Applicative (GenParser Char st) where- (<*>) = ap- pure = return------------- -type Doc = String -> String-(<>) = (.)-text s = (s ++)-x <+> y = x <> text " " <> y -oChar c = (c:)-parens s = oChar '(' <> s <> oChar ')'-braces s = oChar '{' <> s <> oChar '}'-brackets s = oChar '[' <> s <> oChar ']'-doubleQuotes s = oChar '"' <> s <> oChar '"'--oEmpty = id-int x = text $ show x-hcat :: [Doc] -> Doc-hcat = foldr (<>) oEmpty-punctuate t = map (<> t)-render x = x ""----------------------------------------------- Output combinators- -oPos :: SourcePos -> Doc-oPos p = text "{-# LINE" <+> int (sourceLine p) <+> text (show (sourceName p)) <+> text "#-}"- -oText :: String -> Doc-oText x = text "textual" <+> text (show x)--oMappend :: [Doc] -> Doc-oMappend [] = text "(return ())"-oMappend [x] = parens x-oMappend l = text "do" <+> braces (text "rec" <+> braces (hcat (punctuate (text ";") binds)) <> text ";" <> ret)- where binds = init l- ret = last l- --oBraces :: Doc -> Doc-oBraces x = oText "{" <> text "*>" <> x <> text "<*" <> oText "}"---------------------------------------------------- Parsing combinators-pChunk :: String -> Parser String-pChunk stops = many1 (noneOf stops)--pWPos :: Parser Doc -pWPos = do - char '\n'- pos <- getPosition- return $ oPos pos <> text "\n"--pTextChunk = (oText <$> pChunk "\n{}@")--pHaskChunk = (text <$> many1 (noneOf "\n\"{}[]()@" <|> try (char '@' <* notFollowedBy (oneOf "[({\""))))--pHaskLn = pWPos -- before each newline, tell GHC where we are.--pTextLn = do- (oText "\n" <>) <$> pWPos - -- add code to output a newline; and insert a newline in the code.- --pQuote = do- try (string "@\"")- d <- pInText (string "@\"")- return $ parens d--box x = [x]--pString = do- char '"'- result <- many (string "\\\"" <|> pChunk ['"'])- char '"'- return $ doubleQuotes . hcat . map text $ result---- | Parse some Haskell code with markup inside. -pHask = hcat <$> many ((brackets <$> pArg "[]") <|> - (braces <$> pArg "{}") <|>- (parens <$> pArg "()") <|> pQuote <|> pString <|> pHaskChunk <|> pHaskLn)---- | Parse a text argument to an element-pTextArg :: Parser Doc-pTextArg = do- char '{' - result <- pInText (char '}')- return result---pInText :: Parser a -> Parser Doc-pInText end = oMappend <$> manyTill (pTextChunk <|> pTextLn <|> pElement <|> (oBraces <$> pTextArg)) (try end)--pArg :: String -> Parser Doc-pArg [open,close] = do - char open- result <- pHask- char close- return result--pArg1 [open,close] = do- r <- pArg [open,close]- return $ oChar open <> r <> oChar close--isIdentChar x = isAlphaNum x || x == '\''---- | Either @fctName or @result<-fctName-pFctName :: Parser (Maybe Doc, Doc)-pFctName = do - x <- try (char '@' >> satisfy isIdentChar) -- this is to clash with @"- xs' <- many1 (satisfy isIdentChar)- let xs = x : xs'- ys <- option Nothing (Just <$> (try (string "<-") >> many1 (satisfy isIdentChar)))- return $ case ys of- Nothing -> (Nothing, text xs)- Just ys -> (Just (text xs), text ys)--pFct = (Nothing,) <$> parens <$> - (try (string "@{") *> pHask <* char '}')--pElement :: Parser Doc-pElement = do- (result,function) <- pFctName <|> pFct- args <- many (pArg "()" <|> pTextArg)- let binder = maybe oEmpty (<+> text "<-") result- return $ binder <> text "element" <+> parens (function <+> (hcat $ fmap parens args))-{--pTop :: Parser Doc-pTop = do- t <- pInText- return (text "import Text" $$- text "main =" <+> t)--}-{--main = do- p <- parseFromFile pTop "Text.ths"- case p of - Left err -> hPutStrLn stderr $ show err- Right res -> putStrLn $ render res- -}--main :: IO ()-main = do- x : y : z : _ <- getArgs- putStrLn x- putStrLn y- putStrLn z- p <- parseFromFile pHask y- case p of - Left err -> do- hPutStrLn stderr $ show err- Right res -> writeFile z $ - render res-
+ Main3.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE TupleSections, FlexibleInstances, TransformListComp #-}+import Text.ParserCombinators.Parsek.Position++import Data.Char+import Data.List+import System.IO+import System.Environment+import Control.Monad+import Data.DList hiding (map,foldr)+import Data.Monoid+import GHC.Exts (the,groupWith)+import Config++-- todo: parse haskell comments++------------------+-- Simple printing combinators, which do not add nor remove line breaks++type Doc = DList Char++text = fromList+x <+> y = x <> text " " <> y+oChar = singleton+parens s = oChar '(' <> s <> oChar ')'+braces s = oChar '{' <> s <> oChar '}'+brackets s = oChar '[' <> s <> oChar ']'+doubleQuotes s = oChar '"' <> s <> oChar '"'++int x = text $ show x+hcat :: [Doc] -> Doc+hcat = foldr (<>) mempty+punctuate t = map (<> t)+render :: Doc -> String+render = toList++------------------------------------------+-- Output combinators++oPos :: SourcePos -> Doc+oPos EOF = mempty+oPos p = text "{-# LINE" <+> int (sourceLine p) <+> text (show (sourceName p)) <+> text "#-}"++oText :: String -> Doc+oText x = text "textual" <+> text (show x)++oMappend :: [Doc] -> Doc+oMappend [] = text "(return ())"+oMappend [x] = parens x+oMappend l = text "do" <+> braces (text "rec" <+> braces (hcat (punctuate (text ";") binds)) <> text ";" <> ret)+ where binds = init l+ ret = last l++----------------------------------------------+-- Parsing helpers++satisfy' :: (String -> Bool) -> Parser Char+satisfy' p = do+ l <- look+ unless (p l) $+ fail "Unexpected leading string"+ anySymbol++munch',munch1' :: (String -> Bool) -> Parser String+munch' p = scan =<< look+ where+ scan (c:cs) | p (c:cs) = (:) <$> anySymbol <*> scan cs+ scan _ = pure []++munch1' p = (:) <$> satisfy' p <*> munch' p++-- | A chunck not containing some strings+pChunk' :: [String] -> Parser String+pChunk' stops = munch1' (\l -> not $ any (`isPrefixOf` l) stops)+++-- | A chunk not containing some chars.+pChunk :: [Char] -> Parser String+pChunk stops = munch1 (not . (`elem` stops))++----------------------------------------------+-- Parsing combinators++anyQuoteStrings :: [String]+anyQuoteStrings = concatMap (\(x,y) -> [x,y]) quoteStrings++pTextChunk = oText <$> pChunk' ("\n" : commentString : antiQuoteStrings ++ anyQuoteStrings) <?> "Text chunk"+pHaskChunk = text <$> pChunk' (map box "\n\"[]()" ++ map fst quoteStrings) <?> "Haskell chunk"+ -- we keep track of balancing++pWPos :: Parser Doc+pWPos = do+ char '\n'+ pos <- getPosition+ return $ oPos pos <> text "\n"++pHaskLn = pWPos -- before each newline, tell GHC where we are.+pTextLn = (oText "\n" <>) <$> pWPos+ -- add code to output a newline; and insert a newline in the code.++box = (:[])++pString :: Parser Doc+pString = do+ char '"'+ result <- many (string "\\\"" <|> pChunk ['"'])+ char '"'+ return $ doubleQuotes . hcat . map text $ result++-- | Parse some Haskell code with markup inside.+pHask :: Parser Doc+pHask =+ (hcat <$> many ((brackets <$> pArg "[]") <|>+ (parens <$> pArg "()") <|>+ (parens <$> pTextArg ) <|> pString <|> pHaskChunk <|> pHaskLn))++-- | Parse a text argument to an element+pTextArg' :: String -> String -> Parser Doc+pTextArg' open close = label "quoted text" $+ string open *>+ (oMappend <$> many (pElement <|> pTextChunk <|> pTextLn <|> pComment))+ <* string close++pTextArg :: Parser Doc+pTextArg = choice $ map (uncurry pTextArg') quoteStrings++pArg :: String -> Parser Doc+pArg [open,close] = char open *> pHask <* char close++isIdentChar :: Char -> Bool+isIdentChar x = isAlphaNum x || (x `elem` "\'_")++pIdent :: Parser Doc+pIdent = text <$> munch1 isIdentChar <?> "identifier"++pArgument :: Parser Doc+pArgument = (pArg "()" <|> (brackets <$> pArg "[]") <|> pTextArg <|> pString) <?> "argument"++pElement :: Parser Doc+pElement = label "Haskell element" $ do+ choice $ map string $ antiQuoteStrings+ var <- ((<+> text "<-") <$> (pIdent <* string "<-")) <<|> pure mempty+ val <- ((:) <$> pIdent <*> manyGreedy pArgument) <|> (box <$> pArg "()")+ return $ var <> text "element" <+> parens (hcat $ fmap parens val)++commentString :: String+commentString = "%%"++pComment :: Parser Doc+pComment = label "Comment" $ do+ string commentString+ munch (/= '\n')+ string "\n"+ return mempty++main :: IO ()+main = do+ x : y : z : _ <- getArgs+ putStrLn x+ putStrLn y+ putStrLn z+ p <- parseFromFile (pHask <* endOfFile) completeResults y+ case p of+ Left e -> handleErr e+ Right [res] -> writeFile z $ render res+ Right _ -> hPutStrLn stderr "Amibiguous input!"++handleErr e =+ sequence_+ [ hPutStrLn stderr (show $ maybePosToPos $ the pos) >>+ hPutStrLn stderr (" Expected:" ++ (intercalate " or " $ nub what))+ | (exps,_why) <- e, (what,pos) <- exps, then group by pos using groupWith, then reverse ]++instance Show (DList Char) where+ show x = show $ render x+++-- Tests+testHask = parse "<interactive>" pHask completeResults "arst « text @z<-fct[x](y) awft"+testHask2 = parse "<interactive>" pHask completeResults "ars(t) « text @z<-fct[x](y) » awft"+testText2 = parse "<interactive>" pTextArg completeResults "« text @fct(x »"+testText3 = parse "<interactive>" pTextArg completeResults "« 1 @x 2 @y 3 @x 4 »"+testElem = parse "<interactive>" pElement completeResults "@x<-fct(x « yop »)[y]"+testChunk = parse "<interactive>" pHaskChunk completeResults "t"+testArg = parse "<interactive>" (pArg "()") completeResults "()"++terr e = case e of+ Left x -> handleErr x+ Right [res] -> putStrLn $ render res
+ MarXup.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE TypeFamilies #-}++module MarXup where++class Element a where+ type Target a+ element :: a -> Target a++class Textual f where+ textual :: String -> f ()
MarXup/Beamer.hs view
@@ -4,26 +4,37 @@ import Control.Applicative import Data.Monoid import MarXup.Tex+import MarXup.Latex (itemize,enumerate,item,color)+import Data.List (intercalate) usetheme = cmd "usetheme" . tex frame tit bod = env "frame" $ do cmd "frametitle" tit bod- -pause :: TeX-pause = cmd "pause"$ mempty +framesubtitle = cmd "framesubtitle"+itemiz xs = itemize $ mconcat $ fmap (item <>) xs+enumerat xs = enumerate $ mconcat $ fmap (item <>) xs+ note = cmd "note" -{--preamble :: Tex ()-preamble = do - usepackage [] "bbm"- usetheme "Malmoe"- - title $ tex "Elements of Parametricity and Computational Irrelevance" - cmd' "author" ["JP Bernardy"] $ tex "Jean-Philippe Bernardy"- cmd "institute" $ tex "Chalmers University of Technology and University of Gothenburg"- cmd "date" $ cmd "today" mempty--}+hide = color "white"++-----------------------------------+-- Discouraged commands+-- (it's usually better to generate the various frames using Haskell code)+pause :: TeX+pause = cmd0 "pause"++frameCmd :: String -> [Int] -> TeX -> TeX+frameCmd cmd frames body = do+ tex $ "\\ " ++ cmd ++ "<"+ tex $ intercalate "," $ map show frames+ tex ">"+ braces body++only :: [Int] -> TeX -> TeX+only = frameCmd "only"+uncover :: [Int] -> TeX -> TeX+uncover = frameCmd "uncover"
MarXup/DerivationTrees.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, RecordWildCards, PostfixOperators, LiberalTypeSynonyms, TypeOperators, OverloadedStrings #-}+{-# LANGUAGE DisambiguateRecordFields, NamedFieldPuns, RecordWildCards, PostfixOperators, LiberalTypeSynonyms, TypeOperators, OverloadedStrings, PackageImports #-} module MarXup.DerivationTrees ( -- * Basics@@ -7,220 +7,222 @@ -- * Derivation' building -- axiom, rule, etc, aborted, -emptyDrv, haltDrv, haltDrv', abortDrv, delayPre, +emptyDrv, haltDrv, haltDrv', delayPre, dummy, rule, Derivation, Premise, Rule(..), -- * Links-Alignment(..), LineStyle(..),defaultLink,Link(..),---- * Figure building-Figure(..),+LineStyle,defaultLink,Link(..), -- * Engine-derivationTree+derivationTree, derivationTreeD ) where -- import DerivationTrees.Basics import Data.List-import Data.Traversable hiding (mapM) import Control.Monad.Writer -import Control.Monad.State import Control.Applicative -import System.IO.Unsafe import Data.LabeledTree--- import Control.Applicative.State-import Data.Monoid hiding ((<>))+import Data.Monoid+import MarXup (element) import MarXup.Tex hiding (label)-import MarXup.MetaPost-+import MarXup.MultiRef+import MarXup.Diagram as D+import qualified Data.Tree as T ------------------ --- Basics -data LineStyle = None | Simple | Double | Dotted | Dashed | Waved | TeXDotted - deriving (Enum,Show)+type LineStyle = PathOptions -> PathOptions -data Link = Link {label :: Tex (), linkStyle :: LineStyle, align :: Alignment, steps :: Int} -- ^ Regular link- | Detached {label :: Tex ()} -- ^ Detach the derivation as another figure- | Delayed {align :: Alignment} -- ^ automatic delaying--- deriving Show+data Link = Link {label :: Tex (), linkStyle :: LineStyle, steps :: Int} -- ^ Regular link+ | Delayed -- ^ automatic delaying defaultLink :: Link-defaultLink = Link mempty Dotted CenterA 0--data Alignment = LeftA | CenterA | RightA-instance Show Alignment where - show LeftA = "l"- show CenterA = "c"- show RightA = "r"+defaultLink = Link mempty (denselyDotted . outline "black") 0 ------------------- -data Rule tag = Rule {tag :: tag, ruleStyle :: LineStyle, delimiter :: Tex (), ruleLabel :: Tex (), conclusion :: Tex ()}+data Rule = Rule {ruleStyle :: LineStyle, delimiter :: Tex (), ruleLabel :: Tex (), conclusion :: Tex ()} -- deriving Show -{--instance Monoid t => Applicative (Writer t) where- pure = return- (<*>) = ap--}--type Premise = Link ::> Derivation' ()-type Derivation' tag = Tree Link (Rule tag) -type Derivation = Derivation' ()--data Figure tag = Figure {figureTag :: Label, contents :: Derivation' tag}----------------------------------------------------------------- Phase 1: Detach--type Detach x = x -> WriterT [Figure ()] Tex x--detachP :: Detach Premise-detachP (Detached{..} ::> d) = do- d'@(Node r ps) <- detachD d- figureTag <- lift $ newLabel - tell [Figure {contents = Node r {delimiter = label} ps,..}]- return $ (defaultLink ::> haltDrv label d)-detachP (l ::> d) = (l ::>) <$> detachD d--detachD :: Detach Derivation-detachD (Node n ps) = Node n <$> for ps detachP--detachF :: Figure () -> WriterT [Figure ()] Tex ()-detachF Figure{..} = do- contents <- detachD contents- tell [Figure{..}]--detachTop :: [Figure ()] -> Tex [Figure ()]-detachTop fs = do - figs <- runWriterT $ for fs detachF- return $ snd $ figs+type Premise = Link ::> Derivation+type Derivation = Tree Link Rule ----------------------------------------------------- Phase 2: Delay--insertAt n x xs = take n xs ++ x : drop n xs--rm idx [] = []-rm 0 (x:xs) = xs-rm n (x:xs) = x : rm (n-1) xs+-- Delay -depth (Detached{} ::> _) = 2 depth (Link{steps} ::> Node _ ps) = 1 + steps + maximum (0 : map depth ps) isDelayed :: Premise -> Bool isDelayed (Delayed{} ::> _) = True isDelayed _ = False -delayPre a s (Link {..} ::> j) = Link {steps = s, align = a, ..} ::> j+delayPre s (Link {..} ::> j) = Link {steps = s, ..} ::> j delayD :: Derivation -> Derivation delayD (Node r ps0) = Node r (map delayP ps) where ps = fmap (fmap delayD) ps0 ps' = filter (not . isDelayed) ps- delayP (Delayed{..} ::> d) = Link{..} ::> d- where steps = 1 + maximum (0 : map depth ps')- label = mempty- linkStyle = Dotted+ delayP (Delayed{..} ::> d) = defaultLink {steps = 1 + maximum (0 : map depth ps')} ::> d delayP p = p -delayF :: Figure () -> Figure ()-delayF (Figure{..}) = Figure{contents = delayD contents,..}+----------------------------------------------------------+-- TeXify+ +-- | Render a derivation tree without using metapost drv package (links will not be rendered properly)+derivationTree :: Derivation -> TeX+derivationTree = stringizeTex -delayTop = map delayF+stringizeTex :: Derivation -> TeX+stringizeTex (Node Rule {..} premises) = braces $ do+ cmd0 "displaystyle" -- so that the text does not get smaller+ cmdn "frac" [mconcat $+ intersperse (cmd0 "quad")+ [ stringizeTex v | _ ::> v <- premises]+ ,conclusion]+ braces $ do cmd0 "small"+ ruleLabel +----------------------------------------------------------+-- Tikzify +derivationTreeD :: Derivation -> Tex ()+derivationTreeD d = element $ derivationTreeDiag $ delayD d ------------------------------------------------------------- Phase 3: Tag+derivationTreeDiag :: Derivation -> Diagram ()+derivationTreeDiag d = do+ [h] <- newVars [ContVar] -- the height of a layer in the tree.+ minimize h+ h >== 1+ tree@(T.Node (_,n,_) _) <- toDiagram h d+ forM_ (T.levels tree) $ \ls ->+ case ls of+ [] -> return ()+ (_:ls') -> forM_ (zip ls ls') $ \((_,_,l),(r,_,_)) ->+ (l + Point 10 0) `westOf` r+ let leftFringe = map head nonNilLevs+ rightFringe = map last nonNilLevs+ nonNilLevs = filter (not . null) $ T.levels tree+ [leftMost,rightMost] <- newVars [ContVar,ContVar]+ forM_ leftFringe $ \(p,_,_) ->+ leftMost <== xpart p+ forM_ rightFringe $ \(_,_,p) ->+ xpart p <== rightMost+ minimize $ 10 *- (rightMost - leftMost)+ n # Center .=. Point 0 0 -type Tag x = x () -> Tex (x Int)+toDiagPart :: Expr -> Premise -> Diagram (T.Tree (Point,Anchorage,Point))+toDiagPart layerHeight (Link{..} ::> rul)+ | steps == 0 = toDiagram layerHeight rul+ | otherwise = do+ above@(T.Node (_,concl,_) _) <- toDiagram layerHeight rul+ ptObj <- vrule+ let pt = ptObj # S+ pt `eastOf` (concl # W)+ pt `westOf` (concl # E)+ xpart pt =~= xpart (concl # Center)+ let top = ypart (concl # S)+ ypart pt + (fromIntegral steps *- layerHeight) === top+ using linkStyle $ path $ polyline [ptObj # Base,Point (xpart pt) top]+ let embedPt 1 x = T.Node (concl # W,ptObj,concl # E) [x]+ embedPt n x = T.Node (pt,ptObj,pt) [embedPt (n-1) x]+ return $ embedPt steps above -tagify :: Tag Rule-tagify (Rule {..}) = do- tag <- newLabel- return $ Rule {..}+-- | @chainBases distance objects@+-- - Ensures that all the objects have the same baseline.+-- - Separates the objects by the given distance+-- - Returns an object encompassing the group, with a the baseline set correctly.+-- - Returns the average distance between the objects+ +chainBases :: Expr -> [Anchorage] -> Diagram (Anchorage,Expr)+chainBases _ [] = do+ o <- box+ return (o,0)+chainBases spacing ls = do+ grp <- box+ forM_ [Base,N,S] $ \ anch -> do+ D.align ypart $ map (# anch) (grp:ls)+ dxs <- forM (zip ls (tail ls)) $ \(x,y) -> do+ let dx = xdiff (x # E) (y # W)+ dx >== spacing+ return dx+ D.align xpart [grp # W,head ls # W]+ D.align xpart [grp # E,last ls # E]+ return (grp,avg dxs) -tagifyFig :: Tag Figure-tagifyFig (Figure {..}) = Figure figureTag <$> traverse tagify contents+-- | Make an horizontally flexible box of glue.+mkHGlue :: Expr -> Expr -> Diagram Anchorage+mkHGlue minimumWidth preferredWidth = do+ g <- box+ width g >== minimumWidth+ width g =~= preferredWidth+ return g -tagifyTop :: [Figure ()] -> Tex [Figure Int]-tagifyTop = mapM tagifyFig+-- | Put object in a box of the same vertical extent, and baseline,+-- but whose height can be bigger.+relaxHeight o = do+ b <- box+ -- using (outline "green")$ traceBounds o+ D.align xpart [b#W,o#W]+ D.align xpart [b#E,o#E]+ D.align ypart [b#Base,o#Base]+ o `fitsVerticallyIn` b+ return b -------------------------------------------------------------- Phase 4: Texify+toDiagram :: Expr -> Derivation -> Diagram (T.Tree (Point,Anchorage,Point))+toDiagram layerHeight (Node Rule{..} premises) = do+ ps <- mapM (toDiagPart layerHeight) premises+ concl <- relaxHeight =<< extend 1.5 <$> texBox conclusion+ -- using (outline "red")$ traceBounds concl+ lab <- texBox ruleLabel -mpQuote :: Tex () -> Tex ()-mpQuote t = Tex "\"" >> t >> Tex "\""+ -- Grouping+ (psGrp,premisesDist) <- chainBases 10 [p | T.Node (_,p,_) _ <- ps]+ -- using (outline "blue" . denselyDotted) $ traceBounds psGrp+ height psGrp === layerHeight -mkTuple :: [Tex ()] -> Tex ()-mkTuple l = Tex " (" >> sequence_ (intersperse "," l) >> Tex ") "+ -- Sepaartion rule+ separ <- hrule+ separ # N .=. psGrp # S+ align ypart [concl # N,separ # S]+ minimize $ width separ+ psGrp `fitsHorizontallyIn` separ+ concl `fitsHorizontallyIn` separ -link (Link {..} ::> Node (Rule{tag}) _) - | steps == 0 = sho tag- | otherwise = Tex "MVD " >> sho tag >> Tex " " >>- mkTuple [sho steps,sho "",mpQuote label,sho align,sho (fromEnum linkStyle)]+ -- rule label+ lab # BaseW .=. separ # E + Point 3 (negate 1) -type Stringize x = x Int -> Tex () -stringize :: Derivation' Label -> Tex ()-stringize (Node Rule {tag = t, ..} premises) = do- traverse (traverse stringize) premises- Tex "jgm " >> reference t >> Tex " " >> mpQuote conclusion >> Tex ";\n"- Tex "Nfr " >> reference t >> mkTuple (map link premises) >> Tex " " >>- mkTuple [mpQuote ruleLabel,mpQuote delimiter,mpQuote (Tex ""),sho (fromEnum ruleStyle)] >> Tex ";\n"--stringizeFig :: Figure Label -> Tex () -stringizeFig (Figure {..}) = metapostFigure figureTag $ do- stringize contents- texLn "draw drv_tree;"- ----------------------------------------------- Pipeline+ -- layout hints (not necessary for "correctness")+ let xd = xdiff (separ # W) (psGrp # W)+ xd === xdiff (psGrp # E) (separ # E) + relax 2 $ (2 *- xd) =~= premisesDist+ -- centering of conclusion+ xd' <- absoluteValue $ xdiff (separ # Center) (concl # Center)+ relax 3 $ minimize xd' -derivationTree :: [String] -> Derivation -> Tex Label-derivationTree opts j = do - f <- newLabel- a <- delayTop <$> detachTop [Figure f j]- bz <- tagifyTop a - Metapost $ mapM stringizeFig bz- cmd' "includegraphics" opts (MPFigure f)- return f+ -- draw the rule.+ localPathOptions ruleStyle $ path $ polyline [separ # W,separ # E]+ return $ T.Node (separ # W, concl, lab # E) ps ----------------------- -rule ruleLabel conclusion = Rule {tag = (), delimiter = mempty, ruleStyle = Simple, ..} -dummy :: Rule ()-dummy = (rule mempty mempty) {ruleStyle = None}+rule ruleLabel conclusion = Rule {delimiter = mempty, ruleStyle = outline "black", ..}++dummy :: Rule+dummy = (rule mempty mempty) {ruleStyle = const defaultPathOptions} emptyDrv = Node dummy [] -abortDrv (Node Rule {..} _) = Node Rule {ruleStyle = Waved, ..} []+-- abortDrv (Node Rule {..} _) = Node Rule {ruleStyle = Waved, ..} [] -- | Used when the rest of the derivation is known. haltDrv' :: Tex () -> Derivation -> Derivation-haltDrv' tex (Node r _) = Node r {ruleStyle = None} - [defaultLink {linkStyle = TeXDotted, steps = 1, label = tex} ::> emptyDrv]+haltDrv' tex (Node r _) = Node r {ruleStyle = noOutline}+ [defaultLink {steps = 1, label = tex} ::> emptyDrv] -- | More compact variant haltDrv :: Tex () -> Derivation -> Derivation-haltDrv t (Node r _) = Node r [defaultLink ::> Node dummy {conclusion = cmd "vdots" nil >> cmd "hspace" (Tex "2pt") >> t} []]---{--------------------------brace :: TeX -> TeX-brace (TeX x) = TeX $ '{' : x ++ ['}']-paren (TeX x) = TeX $ '(' : x ++ [')']-brack (TeX x) = TeX $ "[" ++ x ++ "]"--tex :: String -> [TeX] -> TeX-tex macro args = TeX ('\\' : macro) <> mconcat (map brace args)-text x = tex "text" [TeX x]--f ! x = brace f <> TeX "_" <> brace x-+haltDrv t (Node r _) = Node r [defaultLink ::> Node dummy {conclusion = cmd "vdots" nil >> cmd "hspace" (tex "2pt") >> t} []] --}
+ MarXup/Diagram.hs view
@@ -0,0 +1,7 @@+module MarXup.Diagram (module D) where++import MarXup.Diagram.Layout as D+import MarXup.Diagram.Path as D+import MarXup.Diagram.Point as D+import MarXup.Diagram.Object as D+import MarXup.Diagram.Tikz as D
+ MarXup/Diagram/Graphviz.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE RecordWildCards #-}+module MarXup.Diagram.Graphviz (graph) where++import MarXup.Tex+import MarXup.Diagram.Point as D+import MarXup.Diagram.Object as D+import MarXup.Diagram.Tikz as D+import MarXup.Diagram.Layout+import MarXup.Diagram.Path+import Data.GraphViz as G+import Data.GraphViz.Attributes.Complete as G+import Data.GraphViz.Parsing as G+import qualified Data.GraphViz.Types.Generalised as Gen+import Data.GraphViz.Commands.IO as G+-- import qualified Data.Text.Lazy.Internal as T+import qualified Data.Text.Lazy as T+import System.IO.Unsafe (unsafePerformIO)+-- import Data.Traversable+import Data.Foldable+import Control.Lens (set)++graph :: (PrintDotRepr g n, ParseDot n, PrintDot n) => GraphvizCommand -> g n -> Dia+graph cmd gr = graphToDiagram $ layout cmd gr++layout :: (PrintDotRepr g n, ParseDot n, PrintDot n) => GraphvizCommand -> g n -> Gen.DotGraph n+layout command input = parseIt' $ unsafePerformIO $ graphvizWithHandle command input DotOutput hGetStrict ++pos (Pos p) = Just p+pos _= Nothing++lpos (LPos p) = Just p+lpos _= Nothing++shapeA (Shape s) = Just s+shapeA _ = Nothing++widthA (Width s) = Just s+widthA _ = Nothing++labelA (Label l) = Just l+labelA _ = Nothing++arrowHeadA (ArrowHead a) = Just a+arrowHeadA _ = Nothing++readAttr :: Monad m => (Attribute -> Maybe a) -> [Attribute] -> (a -> m ()) -> m ()+readAttr f as k = readAttr' f as k (return ())++readAttr' :: (Attribute -> Maybe a) -> [Attribute] -> (a -> k) -> k -> k+readAttr' f as k1 k2 = case [x | Just x <- map f as] of+ (x:_) -> k1 x+ _ -> k2+++pt' (G.Point x y _z _forced) = D.Point x y+pt = unfreeze . pt'++diaSpline (w:x:y:z:rest) = curveSegment w x y z:diaSpline (z:rest)+diaSpline _ = []++-- ToTip | CircleTip | NoTip | StealthTip | LatexTip | ReversedTip LineTip | BracketTip | ParensTip+tipTop def (AType [(_,NoArrow)]) = NoTip+tipTop def (AType [(_,Normal)]) = LatexTip+tipTop def (AType [(_,DotArrow)]) = CircleTip+tipTop def (AType [(_,Vee)]) = StealthTip+tipTop def _ = def++renderLab l p = do+ l' <- labelObj $ tex $ T.unpack $ l+ l' # D.Center .=. pt p++graphToDiagram :: Gen.DotGraph n -> Dia+graphToDiagram (Gen.DotGraph _strict _directed _grIdent stmts) = do+ forM_ stmts $ \ stmt -> case stmt of+ (Gen.DE (DotEdge _from _to attrs)) -> do+ diaRaw $ "%Edge: " ++ show attrs ++ "\n"+ let toTip = readAttr' arrowHeadA attrs (tipTop ToTip) ToTip+ readAttr labelA attrs $ \(StrLabel l) ->+ readAttr lpos attrs $ \p -> + renderLab l p+ readAttr pos attrs $ \(SplinePos splines) ->+ forM_ splines $ \Spline{..} -> do+ let mid = diaSpline $ map pt' splinePoints+ let beg = case (startPoint,splinePoints) of+ (Just p,q:_) -> [lineSegment (pt' p) (pt' q)]+ _ -> []+ let end = case (endPoint,reverse splinePoints) of+ (Just p,q:_) -> [lineSegment (pt' q) (pt' p)]+ _ -> []+ using (set endTip toTip) $+ draw $ frozenPath $ fromBeziers (beg ++ mid ++ end)++ (Gen.DN (DotNode _nodeIdent attrs)) -> do+ diaRaw $ "%Node: " ++ show attrs ++ "\n"+ readAttr pos attrs $ \(PointPos p) -> do+ readAttr labelA attrs $ \l -> do+ case l of+ StrLabel l -> renderLab l p+ readAttr widthA attrs $ \w ->+ readAttr shapeA attrs $ \s ->+ case s of+ Circle -> do+ draw $ path $ circle (pt p) (constant $ inch (w/2))+ _ -> return ()+ _ -> return ()++inch x = 72 * x++
+ MarXup/Diagram/Layout.hs view
@@ -0,0 +1,203 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RecursiveDo, TypeFamilies, OverloadedStrings, RecordWildCards,UndecidableInstances, PackageImports, TemplateHaskell #-}++module MarXup.Diagram.Layout (module MarXup.Diagram.Layout) where+import Control.Monad.LPMonad+import Prelude hiding (sum,mapM_,mapM,concatMap)+import Control.Monad.RWS hiding (forM,forM_,mapM_,mapM)+import Data.LinearProgram+import Data.LinearProgram.Common as MarXup.Diagram.Layout (VarKind(..)) +import Data.LinearProgram.LinExpr+import Data.Map (Map)+import qualified Data.Map as M+import Control.Lens hiding (element)+import Data.String+-- import MarXup+import Data.Traversable+import Data.Foldable+import Control.Applicative+import System.IO.Unsafe+import MarXup.MultiRef+import MarXup.Tex++type LPState = LP Var Constant++type Solution = Map Var Double+type Constant = Double++-- | Expressions are linear functions of the variables+type Expr = LinExpr Var Constant++newtype Decoration = Decoration String+data LineTip = ToTip | CircleTip | NoTip | StealthTip | LatexTip | ReversedTip LineTip | BracketTip | ParensTip+type Color = String+data LineCap = ButtCap | RectCap | RoundCap+data LineJoin = MiterJoin | RoundJoin | BevelJoin+type DashPattern = [(Constant,Constant)]+data PathOptions = PathOptions+ {_drawColor :: Maybe Color+ ,_fillColor :: Maybe Color+ ,_lineWidth :: Constant+ ,_startTip :: LineTip+ ,_endTip :: LineTip+ ,_lineCap :: LineCap+ ,_lineJoin :: LineJoin+ ,_dashPattern :: DashPattern+ ,_decoration :: Decoration+ }+$(makeLenses ''PathOptions)++data Env = Env {_diaSolution :: Solution+ ,_diaTightness :: Constant -- ^ Multiplicator to minimize constraints+ ,_diaPathOptions :: PathOptions}++$(makeLenses ''Env)++defaultPathOptions :: PathOptions+defaultPathOptions = PathOptions+ {_drawColor = Nothing+ ,_fillColor = Nothing+ ,_lineWidth = 0.4+ ,_startTip = NoTip+ ,_endTip = NoTip+ ,_lineCap = ButtCap+ ,_lineJoin = MiterJoin+ ,_dashPattern = []+ ,_decoration = Decoration ""+ }++newtype Diagram a = Dia (RWST Env () (Var,LPState) Multi a)+ deriving (Monad, Applicative, Functor, MonadReader Env)++type Dia = Diagram ()++instance MonadState LPState Diagram where+ get = Dia $ snd <$> get+ put y = Dia $ do+ (x,_) <- get+ put (x,y)++-------------+-- Diagrams++runDiagram :: Diagram a -> Multi a+runDiagram (Dia diag) = do+ rec (a,(_,problem),_) <- runRWST diag (Env solution 1 defaultPathOptions)+ (Var 0,LP Min M.empty [] M.empty M.empty)+ let solution = case unsafePerformIO $ glpSolveVars simplexDefaults problem of+ (_retcode,Just (_objFunc,s)) -> s+ (retcode,Nothing) -> error $ "ret code = " ++ show retcode+ -- Raw Normal $ "%problem solved: " ++ show problem ++ "\n"+ return a++diaRawTex :: Tex a -> Diagram a+diaRawTex (Tex t) = Dia $ lift t++diaRaw :: String -> Dia+diaRaw = diaRawTex . tex++relax factor = local (over diaTightness (/ factor)) ++instance Monoid (Diagram ()) where+ mempty = return ()+ mappend = (>>)++instance IsString (Diagram ()) where+ fromString = diaRawTex . tex++--------------+-- Variables+varValue :: Var -> Diagram Double+varValue v = M.findWithDefault 0 v <$> view diaSolution++rawNewVar :: Diagram Var+rawNewVar = Dia $ do+ (Var x,y) <- get+ put $ (Var (x+1),y)+ return $ Var x++newVars :: [VarKind] -> Diagram [Expr]+newVars kinds = newVars' (zip kinds (repeat Free))++newVars' :: [(VarKind,Bounds Constant)] -> Diagram [Expr]+newVars' kinds = forM kinds $ \(k,b) -> do+ v <- rawNewVar+ setVarKind v k+ setVarBounds v b+ return $ variable v++infix 4 <==,===,>==++----------------+-- Expressions+instance Fractional Expr where+ fromRational ratio = constant (fromRational ratio)++instance Num Expr where+ fromInteger x = LinExpr M.empty (fromInteger x)+ negate = neg+ (+) = (^+^)+ (-) = (^-^)++valueOf :: Expr -> Diagram Double+valueOf (LinExpr m c) = do+ vs <- forM (M.assocs m) $ \(v,scale) ->+ (scale *) <$> varValue v+ return $ sum $ c:vs++variable :: Var -> Expr+variable v = LinExpr (var v) 0++constant :: Constant -> Expr+constant c = LinExpr M.empty c++(*-) :: Module Constant a => Constant -> a -> a+(*-) = (*^)+infixr 6 *-++avg :: Module Constant a => [a] -> a+avg xs = (1/fromIntegral (length xs)) *- gsum xs++absoluteValue :: Expr -> Diagram Expr+absoluteValue x = do+ [t1,t2] <- newVars' [(ContVar,LBound 0),(ContVar,LBound 0)]+ t1 - t2 === x+ return $ t1 + t2++satAll :: (Expr -> a -> Diagram b) -> [a] -> Diagram Expr+satAll p xs = do+ [m] <- newVars [ContVar]+ mapM_ (p m) xs+ return m++maximVar, minimVar :: [Expr] -> Diagram Expr+maximVar = satAll (>==)+minimVar = satAll (<==)++--------------+-- Expression constraints+(>==), (<==) :: Expr -> Expr -> Diagram ()+e1 <== e2 = do+ let LinExpr f c = e1 - e2+ leqTo f (negate c)++(>==) = flip (<==)++(===) :: Expr -> Expr -> Diagram ()+e1 === e2 = do+ let LinExpr f c = e1 - e2+ equalTo f (negate c)++-- | minimize the distance between expressions+(=~=) :: Expr -> Expr -> Diagram ()+x =~= y = minimize =<< absoluteValue (x-y)++-------------------------+-- Expression objectives++minimize,maximize :: Expr -> Diagram ()+minimize (LinExpr x _) = do+ tightness <- view diaTightness+ addObjective (tightness *- x)+maximize = minimize . negate++
+ MarXup/Diagram/Object.hs view
@@ -0,0 +1,266 @@+{-# LANGUAGE DataKinds, KindSignatures, OverloadedStrings, EmptyDataDecls, MultiParamTypeClasses, FlexibleContexts, OverlappingInstances, TypeSynonymInstances, FlexibleInstances #-}++module MarXup.Diagram.Object where++-- import MarXup+import MarXup.Tex+import MarXup.Diagram.Tikz+import MarXup.Diagram.Path+import MarXup.Diagram.Point+import MarXup.Diagram.Layout+import MarXup.MultiRef (BoxSpec(..))+import Control.Monad+import Control.Applicative+-- import Data.Algebra+-- import Data.List (intersperse)+import Control.Lens (set)++data Anchor = Center | N | NW | W | SW | S | SE | E | NE | BaseW | Base | BaseE+ deriving Show++-- | Box-shaped object. (a subtype)+type Box = Object++newtype Anchorage = Anchorage {boxAnchors :: Anchor -> Point}+data Object = Object {objectOutline :: Path, objectAnchorage :: Anchorage}++class Anchored a where+ anchors :: a -> Anchor -> Point+infix 8 #++(#) :: Anchored a => a -> Anchor -> Point+(#) = anchors++instance Anchored Anchorage where+ anchors = boxAnchors++instance Anchored Object where+ anchors = anchors . objectAnchorage++instance Anchored Point where+ anchors p _ = p++-- | Horizontal distance between objects+hdist :: Anchored a => a -> a -> Expr+hdist x y = xpart (y # W - x # E)++-- | Vertical distance between objects+vdist :: Anchored a => a -> a -> Expr+vdist x y = ypart (y # S - x # N)++-- | Extend the box boundaries by the given delta+extend :: Expr -> Anchorage -> Anchorage+extend e o = Anchorage $ \a -> o # a + shiftInDir a e++-- | Makes a shift of size 'd' in the given direction.+shiftInDir :: Anchor -> Expr -> Point+shiftInDir N d = 0 `Point` d+shiftInDir S d = 0 `Point` negate d+shiftInDir W d = negate d `Point` 0+shiftInDir E d = d `Point` 0+shiftInDir NW d = negate d `Point` d+shiftInDir SE d = d `Point` negate d+shiftInDir SW d = negate d `Point` negate d+shiftInDir NE d = d `Point` d+shiftInDir _ _ = 0 `Point` 0++-- | Make a label object. This is just some text surrounded by 4+-- points of blank.+mkLabel :: TeX -> Diagram Anchorage+mkLabel texCode = extend 4 <$> texBox texCode++labelObj :: TeX -> Diagram Box+labelObj = rectangleShape <=< mkLabel++-- | Label a point by a given TeX expression, at the given anchor.+labelPt :: TeX -> Anchor -> Point -> Diagram Box+labelPt labell anchor labeled = do+ t <- labelObj labell + t # anchor .=. labeled+ return t++-- | A free point+point :: Diagram Point+point = do+ [x,y] <- newVars (replicate 2 ContVar)+ return $ Point x y++-- | A point anchorage (similar to a box of zero width and height)+pointBox :: Diagram Anchorage+pointBox = do+ p <- point+ return $ Anchorage $ \a -> case a of _ -> p++-- | A box. Anchors are aligned along a grid.+box :: Diagram Anchorage+box = do+ [n,s,e,w,base,midx,midy] <- newVars (replicate 7 ContVar)+ n >== base+ base >== s+ w <== e+ + midx === avg [w,e]+ midy === avg [n,s]+ let pt = flip Point+ return $ Anchorage $ \anch -> case anch of+ NW -> pt n w+ N -> pt n midx+ NE -> pt n e + E -> pt midy e+ SE -> pt s e+ S -> pt s midx+ SW -> pt s w+ W -> pt midy w+ Center -> pt midy midx+ Base -> pt base midx+ BaseE -> pt base e+ BaseW -> pt base w++-- | A box of zero width+vrule :: Diagram Anchorage+vrule = do+ o <- box+ align xpart [o # W, o #Center, o#E]+ return o++-- | A box of zero height+hrule :: Diagram Anchorage+hrule = do+ o <- box+ height o === 0+ return o++height o = ypart (o # N - o # S)+width o = xpart (o # E - o # W)+ascent o = ypart (o # N - o # Base)+descent o = ypart (o # Base - o # S)++-- fitsVerticallyIn :: Anchorage -> Anchorage -> Diagram ()+o `fitsVerticallyIn` o' = do+ let dyN = ypart $ o' # N - o # N+ dyS = ypart $ o # S - o' # S+ minimize dyN+ dyN >== 0+ minimize dyS+ dyS >== 0++-- fitsHorizontallyIn :: Anchorage -> Anchorage -> Diagram ()+o `fitsHorizontallyIn` o' = do+ let dyW = xpart $ o # W - o' # W+ dyE = xpart $ o' # E - o # E+ minimize dyW+ dyW >== 0+ minimize dyE+ dyE >== 0++a `fitsIn` b = do+ a `fitsHorizontallyIn` b+ a `fitsVerticallyIn` b++circleShape :: Diagram Object+circleShape = do+ anch <- box+ width anch === height anch+ let radius = 0.5 *- width anch+ let p = circle (anch # Center) radius+ path p+ return $ Object p anch+-- let k1 :: Constant+-- k1 = sqrt 2 / 2+-- k = k1 *^ r+-- p = circle center r+-- return $ Object p $ Anchorage $ \a -> center + case a of+-- N -> Point 0 r+-- S -> Point 0 (-r)+-- E -> Point r 0+-- W -> Point (-r) 0+-- Center -> Point 0 0+-- NE -> Point k k++rectangleShape :: Anchorage -> Diagram Object+rectangleShape l = do+ let p = polygon (map (l #) [NW,NE,SE,SW])+ path p+ return $ Object p l++traceAnchorage :: Anchored a => Color -> a -> Diagram ()+traceAnchorage c l = do+ stroke c $ path $ polygon (map (l #) [NW,NE,SE,SW])+ -- TODO: draw the baseline, etc.++-- | Typeset a piece of text and return its bounding box.+texBox :: TeX -> Diagram Anchorage+texBox t = do+ l <- box+ -- traceAnchorage "red" l+ BoxSpec wid h desc <- drawText (l # NW) t++ width l === constant wid+ descent l === constant desc+ height l === constant (h + desc)+ return l++data Incidence = Incidence { incidencePoint, incidenceNormal :: Point }+swap :: Incidence -> Incidence+swap (Incidence p v) = Incidence p (negate v)++-- | Traces a straight edge between two objects.+-- The midpoint is returned, as well as a normal vector.+edge :: Object -> Object -> Diagram Incidence+edge source target = do+ let points@[a,b] = [source # Center,target # Center]+ link = polyline points+ targetArea = objectOutline target+ sourceArea = objectOutline source+ l' <- freeze link+ sa' <- freeze sourceArea+ ta' <- freeze targetArea+ frozenPath $ (l' `cutAfter` ta') `cutBefore` sa'+ return $ Incidence (avg points) (rotate90 (b-a))++(.<.) :: Point -> Point -> Diagram ()+Point x1 y1 .<. Point x2 y2 = do+ x1 <== x2+ y1 <== y2++-- | Forces the point to be inside the (bounding box) of the object.+inside :: Point -> Box -> Diagram ()+inside p o = do+ (o # SW) .<. p+ p .<. (o # NE)++-- | @autoLabel label i@ Layouts the label at the given incidence+-- point.+autoLabel :: Box -> Incidence -> Diagram ()+autoLabel lab (Incidence pt norm) = do+ pt `inside` lab+ minimize =<< orthoDist (lab#Center) (pt + norm)++-- | @labeledEdge label source target@+labeledEdge :: Object -> Object -> Box -> Diagram ()+labeledEdge source target lab = autoLabel lab =<< edge source target++++-------------------+-- Even higher-level primitives:+++--example: spread hdist 30 ps++spread f d (x:y:xs) = do+ f x y === d+ spread f d (y:xs)+spread f _ _ = return ()++node lab = do+ l <- extend 4 <$> texBox lab+ c <- draw $ circleShape+ l `fitsIn` c+ l # Center .=. c # Center+ return c++arrow :: Object -> Object -> Diagram Incidence+arrow src trg = using (outline "black" . set endTip LatexTip) $ do+ edge src trg+
+ MarXup/Diagram/Path.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RecursiveDo, TypeFamilies, OverloadedStrings, RecordWildCards,UndecidableInstances, PackageImports, TemplateHaskell #-}++module MarXup.Diagram.Path where++import MarXup.Diagram.Layout+import MarXup.Diagram.Point+import Data.Traversable+import Data.Foldable+import Data.Algebra+-- import Data.Traversable+-- import Data.Foldable+import Graphics.Typography.Geometry.Bezier+import Graphics.Typography.Geometry.Bezier as MarXup.Diagram.Point (Curve) +import Control.Applicative+import Data.List (sort,transpose)+import Data.Maybe (listToMaybe)+import Prelude hiding (sum,mapM_,mapM,concatMap,maximum,minimum)+import qualified Data.Vector.Unboxed as V+import Algebra.Polynomials.Bernstein (restriction,Bernsteinp(..))++type Frozen x = x Constant+type FrozenPoint = Frozen Point'+type FrozenPath = Frozen Path'++freeze :: Traversable t => t Expr -> Diagram (t Constant)+freeze = traverse valueOf++unfreeze :: Functor t => t Constant -> t Expr+unfreeze = fmap constant++toBeziers :: FrozenPath -> [Curve]+toBeziers EmptyPath = []+toBeziers (Path start ss) | not (null ss) &&+ isCycle (last ss) = toBeziers' start (init ss ++ [StraightTo start])+ | otherwise = toBeziers' start ss++curveSegment (Point xa ya) (Point xb yb) (Point xc yc) (Point xd yd) = bezier3 xa ya xb yb xc yc xd yd+lineSegment (Point xa ya) (Point xb yb) = line xa ya xb yb++toBeziers' :: FrozenPoint -> [Frozen Segment] -> [Curve]+toBeziers' _ [] = []+toBeziers' start (StraightTo next:ss) = curveSegment start mid mid next : toBeziers' next ss+ where mid = avg [start, next]+toBeziers' p (CurveTo c d q:ss) = curveSegment p c d q : toBeziers' q ss++fromBeziers :: [Curve] -> FrozenPath+fromBeziers [] = EmptyPath+fromBeziers (Bezier cx cy t0 t1:bs) = case map toPt $ V.foldr (:) [] cxy of+ [p,c,d,q] -> Path p (CurveTo c d q:rest)+ [p,q] -> Path p (StraightTo q:rest)+ where [cx',cy'] = map (\c -> coefs $ restriction c t0 t1) [cx,cy]+ cxy = V.zip cx' cy'+ toPt (x,y) = Point x y+ rest = pathSegments (fromBeziers bs)++pathSegments :: Path' t -> [Segment t]+pathSegments EmptyPath = []+pathSegments (Path _ ss) = ss++isCycle Cycle = True+isCycle _ = False++frozenPointElim (Point x y) f = f x y++splitBezier (Bezier cx cy t0 t1) (u,v,_,_) = (Bezier cx cy t0 u, Bezier cx cy v t1)++clipOne :: Curve -> [Curve] -> Maybe Curve+clipOne b cutter = fmap firstPart $ listToMaybe $ sort $ concatMap (inter b) cutter+ where firstPart t = fst $ splitBezier b t++-- | @cutAfter path area@ cuts the path after its first intersection with the @area@.+cutAfter', cutBefore' :: [Curve] -> [Curve] -> [Curve]+cutAfter' [] _cutter = []+cutAfter' (b:bs) cutter = case clipOne b cutter of+ Nothing -> b:cutAfter' bs cutter+ Just b' -> [b']++revBernstein (Bernsteinp n c) = Bernsteinp n (V.reverse c)+revBeziers :: [Curve] -> [Curve]+revBeziers = reverse . map rev+ where rev (Bezier cx cy t0 t1) = (Bezier (revBernstein cx) (revBernstein cy) (1-t1) (1-t0))++cutBefore' path area = revBeziers $ cutAfter' (revBeziers path) area++onBeziers :: ([Curve] -> [Curve] -> [Curve])+ -> FrozenPath -> FrozenPath -> FrozenPath+onBeziers op p' q' = fromBeziers $ op (toBeziers p') (toBeziers q')+++cutAfter :: FrozenPath -> FrozenPath -> FrozenPath+cutAfter = onBeziers cutAfter'++cutBefore :: FrozenPath -> FrozenPath -> FrozenPath+cutBefore = onBeziers cutBefore'++data Segment v = CurveTo (Point' v) (Point' v) (Point' v)+ | StraightTo (Point' v)+ | Cycle+ -- | Rounded (Maybe Constant)+ -- | HV point | VH point+ deriving (Show,Eq)+instance Functor Segment where+ fmap = fmapDefault+ +instance Foldable Segment where+ foldMap = foldMapDefault+instance Traversable Segment where+ traverse _ Cycle = pure Cycle+ traverse f (StraightTo p) = StraightTo <$> traverse f p+ traverse f (CurveTo c d q) = CurveTo <$> traverse f c <*> traverse f d <*> traverse f q+ ++-----------------+-- Paths++type Path = Path' Expr++data Path' a+ = EmptyPath+ | Path {startingPoint :: Point' a+ ,segments :: [Segment a]}+ deriving Show++-- mapPoints :: (Point' a -> Point' b) -> Path' a -> Path' b+instance Functor Path' where+ fmap = fmapDefault++instance Foldable Path' where+ foldMap = foldMapDefault+instance Traversable Path' where+ traverse _ EmptyPath = pure EmptyPath+ traverse f (Path s ss) = Path <$> traverse f s <*> traverse (traverse f) ss+++polyline :: [Point] -> Path+polyline [] = EmptyPath+polyline (x:xs) = Path x (map StraightTo xs)++polygon :: [Point] -> Path+polygon [] = EmptyPath+polygon (x:xs) = Path x (map StraightTo xs ++ [Cycle])+++-- | Circle approximated with 4 cubic bezier curves+circle :: Point -> Expr -> Path+circle center r = Path (pt r 0)+ [CurveTo (pt r k) (pt k r) (pt 0 r),+ CurveTo (pt (-k) r) (pt (-r) k) (pt (-r) 0),+ CurveTo (pt (-r) (-k)) (pt (-k) (-r)) (pt 0 (-r)),+ CurveTo (pt k (-r)) (pt r (-k)) (pt r 0),+ Cycle]+ where k1 :: Constant+ k1 = 4 * (sqrt 2 - 1) / 3+ k = k1 *^ r+ pt x y = center ^+^ (Point x y)+
+ MarXup/Diagram/Point.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RecursiveDo, TypeFamilies, OverloadedStrings, RecordWildCards,UndecidableInstances, PackageImports, TemplateHaskell #-}++module MarXup.Diagram.Point where++import MarXup.Diagram.Layout+import Data.Traversable+import Data.Foldable+import Data.Algebra+import Control.Applicative+import Data.List (transpose)+import Prelude hiding (sum,mapM_,mapM,concatMap,maximum,minimum)++infix 4 .=.+----------------+-- Points +-- | A point in 2d space+data Point' a = Point {xpart :: a, ypart :: a}+ deriving (Eq,Show)++instance Traversable Point' where+ traverse f (Point x y) = Point <$> f x <*> f y++instance Foldable Point' where+ foldMap = foldMapDefault++instance Functor Point' where+ fmap = fmapDefault++ +type Point = Point' Expr+instance Group a => Num (Point' a) where+ negate = neg+ (+) = (^+^)+ (-) = (^-^)++instance Group v => Group (Point' v) where+ zero = Point zero zero+ Point x1 y1 ^+^ Point x2 y2 = Point (x1 ^+^ x2) (y1 ^+^ y2)+ neg (Point x y) = Point (neg x) (neg y)++instance Module Constant v => Module Constant (Point' v) where+ k *^ Point x y = Point (k *^ x) (k *^ y)++-- | Orthogonal norm of a vector+orthonorm :: Point -> Diagram Expr+orthonorm (Point x y) =+ (+) <$> absoluteValue x <*> absoluteValue y++-- | Orthogonal distance between points.+orthoDist :: Point -> Point -> Diagram Expr+orthoDist p q = orthonorm (q-p)++-- | Rotate a vector 90 degres in the trigonometric direction.+rotate90, rotate180 :: Point -> Point+rotate90 (Point x y) = Point (negate y) x++rotate180 = rotate90 . rotate90++xdiff,ydiff :: Point -> Point -> Expr+xdiff p q = xpart (q - p)+ydiff p q = ypart (q - p)++-----------------+-- Point constraints++(.=.),northOf,southOf,westOf,eastOf :: Point -> Point -> Diagram ()+Point x1 y1 .=. Point x2 y2 = do+ x1 === x2+ y1 === y2++northOf (Point _ y1) (Point _ y2) = y2 <== y1+southOf = flip northOf+westOf (Point x1 _) (Point x2 _) = x1 <== x2+eastOf = flip westOf++alignHoriz,alignVert :: [Point] -> Diagram ()+alignHoriz = align ypart+alignVert = align xpart++align :: (a -> Expr) -> [a] -> Diagram ()+align _ [] = return ()+align f (p:ps) = forM_ ps $ \p' -> f p === f p'++alignMatrix :: [[Point]] -> Dia+alignMatrix ls = do+ forM_ ls alignHoriz+ forM_ (transpose ls) alignVert++---------------------+-- Point objectives++southwards, northwards, westwards, eastwards :: Point -> Diagram ()+southwards (Point _ y) = minimize y+westwards (Point x _) = minimize x+northwards = southwards . negate+eastwards = westwards . negate
+ MarXup/Diagram/Tikz.hs view
@@ -0,0 +1,172 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, RecursiveDo, TypeFamilies, OverloadedStrings, RecordWildCards,UndecidableInstances, PackageImports, TemplateHaskell #-}++module MarXup.Diagram.Tikz where++import MarXup.Diagram.Layout+import MarXup.Diagram.Point+import MarXup.Diagram.Path+import Control.Lens hiding (element)+import Prelude hiding (sum,mapM_,mapM,concatMap)+import Control.Applicative+import Data.List (intercalate)+import Data.String+import MarXup+import MarXup.MultiRef+import MarXup.Tex+import Numeric (showFFloat)+import Data.Traversable+import Data.Foldable+import Data.Monoid+import Control.Monad.Reader++instance Element Expr where+ type Target Expr = Dia+ element x = do+ v <- valueOf x+ diaRaw $ showDistance v++instance Element (Diagram ()) where+ type Target (Diagram ()) = TeX+ element d = do+ texLn "" -- otherwise beamer does not understand where a tikzpicture ends (?!!)+ braces $ do+ cmd0 "normalsize"+ -- otherwise the boxes use "normalsize", while tikz inherits+ -- the smaller or bigger size from the current scope. Actually,+ -- every text styling should be reset, but I don't know how to+ -- do that.+ env "tikzpicture" $+ Tex $ runDiagram d++--------------------+-- Point rendering+instance Element Point where+ type Target Point = Diagram ()+ element (Point x y) = "(" <> element x <> "," <> element y <> ")"++diaDebug msg = diaRaw $ "\n%DBG:" ++ msg ++ "\n"++instance (Element (Point' v),Monoid (Target (Point' v)), IsString (Target (Point' v))) => Element (Segment v) where+ type Target (Segment v) = Target (Point' v)+ element (StraightTo p) = "--" <> element p+ element (CurveTo c d p) = "..controls" <> element c <> "and" <> element d <> ".." <> element p+ element Cycle = "--cycle"+ -- element (VH p) = "|-" <> element p+ -- element (HV p) = "-|" <> element p+ -- element (Rounded Nothing) = "[sharp corners]"+ -- element (Rounded (Just r)) = "[" <> element (constant r) <> "]"++instance Element Path where+ type Target Path = Diagram ()+ element = path++path :: Path -> Dia+path = frozenPath <=< freeze++frozenPath :: FrozenPath -> Dia+frozenPath p = do+ options <- view diaPathOptions+ diaRaw $ "\\path"+ <> element options+ <> case p of+ EmptyPath -> ""+ (Path start segs) -> element start ++ concatMap element segs+ diaRaw ";\n"+++showDistance :: Constant -> String+showDistance x = showFFloat (Just 4) x tikzUnit+ where tikzUnit = "pt"++instance Element FrozenPoint where+ type Target FrozenPoint = String+ element pt = frozenPointElim pt $ \x y -> "(" <> showDistance x <> "," <> showDistance y <> ")"+++-----------------+-- Path Options++localPathOptions :: (PathOptions -> PathOptions) -> Diagram a -> Diagram a+localPathOptions f = local (over diaPathOptions f)++instance Show LineTip where+ show t = case t of+ ToTip -> "to"+ StealthTip -> "stealth"+ CircleTip -> "o"+ NoTip -> ""+ LatexTip -> "latex"+ ReversedTip x -> show x ++ " reversed"+ BracketTip -> "["+ ParensTip -> "("+++ultraThin, veryThin, thin, semiThick, thick, veryThick, ultraThick :: Constant+ultraThin = 0.1+veryThin = 0.2+thin = 0.4+semiThick = 0.6+thick = 0.8+veryThick = 1.2+ultraThick = 1.6+++showDashPat :: DashPattern -> String+showDashPat xs = intercalate " " ["on " <> showDistance on <>+ " off " <> showDistance off | (on,off) <- xs]++solid o@PathOptions{..} = o { _dashPattern = [] }+dotted o@PathOptions{..} = o { _dashPattern = [(_lineWidth,2)] }+denselyDotted o@PathOptions{..} = o { _dashPattern = [(_lineWidth, 1)] }+looselyDotted o@PathOptions{..} = o { _dashPattern = [(_lineWidth, 4)] }+dashed o@PathOptions{..} = o { _dashPattern = [(3, 3)] }+denselyDashed o@PathOptions{..} = o { _dashPattern = [(3, 2)] }+looselyDashed o@PathOptions{..} = o { _dashPattern = [(3, 6)] }+dashdotted o@PathOptions{..} = o { _dashPattern = [(3, 2), (_lineWidth, 2)] }+denselyDashdotted o@PathOptions{..} = o { _dashPattern = [(3, 1), (_lineWidth, 1)] }+looselyDashdotted o@PathOptions{..} = o { _dashPattern = [(3, 4), (_lineWidth, 4)] }++using = localPathOptions+stroke color = using (outline color)+draw = stroke "black"++noOutline = set drawColor Nothing+outline color = set drawColor (Just color)+fill color = set fillColor (Just color)++zigzagDecoration = set decoration (Decoration "zigzag")++instance Element PathOptions where+ type Target PathOptions = String+ element PathOptions{..} = "["+ <> show _startTip <> "-" <> show _endTip <> ","+ <> col "draw" _drawColor+ <> col "fill" _fillColor+ <> "line width=" <> showDistance _lineWidth <> ","+ <> "line cap=" <> (case _lineCap of+ RoundCap -> "round"+ RectCap -> "rect"+ ButtCap -> "butt") <> ","+ <> "line join=" <> (case _lineJoin of+ RoundJoin -> "round"+ BevelJoin -> "bevel"+ MiterJoin -> "miter") <> ","+ <> "dash pattern=" <> showDashPat _dashPattern+ <> (case _decoration of+ Decoration [] -> ""+ Decoration d -> ",decorate,decoration=" ++ d)+ <> "]"+ where col attr = maybe "" (\c -> attr <> "=" <> c <> ",")++----------+-- Text++drawText :: Point -> TeX -> Diagram BoxSpec+drawText point t = do+ diaRawTex $ tex $ "\\node[anchor=north west,inner sep=0] at "+ element point+ (_,box) <- diaRawTex $ inBox $ braces $ t+ diaRawTex $ tex ";\n"+ return box++
MarXup/Latex.hs view
@@ -1,23 +1,80 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings, RecordWildCards #-} module MarXup.Latex where -import Control.Applicative+import MarXup+import MarXup.Verbatim+import Control.Monad (forM_) import MarXup.Tex-import MarXup.MetaPost-import Data.List (intersperse)+import Data.List (intersperse,groupBy,elemIndex,nub) import Data.Monoid+import Control.Applicative+import Data.Function (on) --- Separate the arguments with '\\'-mkrows :: [TeX] -> TeX-mkrows ls = sequence_ $ intersperse newline ls --- Separate the arguments with '&'+-- | Separate the arguments with '\\'+mkrows,mkcols :: [TeX] -> TeX+mkrows ls = sequence_ $ intersperse newline ls++-- | Separate the arguments with '&' mkcols = sequence_ . intersperse newcol -vspace = cmd "vspace"-hspace = cmd "hspace"+vspace, hspace :: String -> TeX+vspace = cmd "vspace" . textual+hspace = cmd "hspace" . textual+hfill = cmd0 "hfill"++title :: TeX -> TeX title = cmd "title" ++data ClassFile = Plain | LNCS | SIGPlan | IEEE | EPTCS | Beamer+ deriving Eq+type AuthorInfoStyle = ClassFile++data AuthorInfo = AuthorInfo {authorName :: String, authorEmail :: String, authorInst :: String}++-- | author info in as triplets name, institution, email+authorinfo :: AuthorInfoStyle -> [AuthorInfo] -> TeX+authorinfo LNCS as = do+ cmd "author" $ mconcat $ intersperse (cmd0 "and") $ map oneauthor as+ cmd "institute" $ mconcat $ intersperse (cmd0 "and") $ map textual $ insts+ where oneauthor AuthorInfo{..} = textual authorName <> (if length insts > 1 then cmd "inst" (textual $ show $ 1 + instIdx) else mempty)+ where Just instIdx = elemIndex authorInst insts+ insts = nub $ map authorInst as++authorinfo SIGPlan as = forM_ (groupBy ((==) `on` authorInst) as) $ \ (g@((AuthorInfo _ _ institution):_)) -> do+ let names = map authorName g+ emails = mconcat $ intersperse (cmd0 "and") $ map (textual . authorEmail) g+ cmdn "authorinfo" [mconcat $ intersperse (cmd0 "and") $ map textual names, textual institution, emails]+ return ()+authorinfo EPTCS as = mconcat $ intersperse and' $+ flip map (groupBy ((==) `on` authorInst) as) $ \ (g@((AuthorInfo _ _ institution):_)) -> do+ cmd "author" $ do+ mconcat $ intersperse dquad $ map (textual . authorName) g+ cmd "institute" $ textual institution+ cmd "email" $ mconcat $ intersperse dquad $ map (textual . authorEmail) g+ return ()+ where dquad = cmd0 "quad" <> cmd0 "quad"+ and' = cmd0 "and"+authorinfo IEEE as = cmd "author" $ do+ cmd "IEEEauthorblockN" $ mconcat $ intersperse (hspace "1cm") $ map (textual . authorName) as+ tex "\n\n" -- for some reason the IEEE class wants a paragraph separation here.+ cmd "IEEEauthorblockA" $ mkrows $ [textual inst,"email: " <> textual (mconcat $ intersperse " " $ map authorEmail as)]+ where (AuthorInfo {authorInst = inst}:_) = as+authorinfo _ {- Plain, EPTCS, Beamer -} as = cmd "author" $ mconcat $ intersperse (cmd0 "and") $ map oneauthor as+ where oneauthor (AuthorInfo name _ institution) = textual name <> newline <> textual institution++keywords :: ClassFile -> [String] -> TeX+keywords LNCS ks = do+ cmd "keywords" $ mconcat $ intersperse ", " $ map textual ks+keywords IEEE ks = env "IEEEkeywords" $ do+ mconcat $ intersperse ", " $ map textual ks+keywords SIGPlan ks = do+ cmd0 "keywords"+ mconcat $ intersperse ", " $ map textual ks+keywords _ _ = return ()++ newline = backslash <> backslash newcol = tex "&" newpara = texLines ["",""]@@ -25,114 +82,154 @@ maketitle :: Tex () maketitle = cmd "maketitle" $ return () +ldots :: TeX ldots = cmd "ldots" (return ()) -section s = - do cmd "section" s- label--subsection s = - do cmd "subsection" s- label+-- | Sectioning+section,subsection,paragraph :: TeX -> Tex SortedLabel+section s = cmd "section" s >> label "Sec."+subsection s = cmd "subsection" s >> label "Sec."+subsubsection s = cmd "subsubsection" s >> label "Sec."+paragraph s = cmd "paragraph" s >> label "Sec." color :: String -> Tex a -> Tex a-color col bod = do +color col bod = do [_,x] <- cmdn' "textcolor" [] [tex col >> return undefined, bod] return x ---------------- -- Preamble stuff -usepackage opts name = cmd' "usepackage" opts (Tex name) -stdPreamble = do - usepackage [] "graphicx"- usepackage ["mathletters"] "ucs"- usepackage ["utf8x"] "inputenc"+usepackage :: String -> [String] -> Tex ()+usepackage name opts = cmd' "usepackage" opts (tex name)++stdPreamble :: TeX+stdPreamble = do+ usepackage "graphicx" []+ usepackage "inputenc" ["utf8"] return () -latexDocument :: String -> [String] -> Tex a -> Tex a -> Tex ()-latexDocument docClass options pre body = do- preamble- Metapost $ metaPostPreamble preamble- env "document" body- Metapost $ metaPostEpilogue- where - preamble = do- cmd' "documentclass" options (Tex docClass)- pre+documentClass :: String -> [String] -> TeX+documentClass docClass options = cmd' "documentclass" options (tex docClass) ---------- -- Lists -item :: Tex a -> Tex a-item x = cmdn' "item" [] [] >> x+item = cmd0 "item"+enumerate = env "enumerate"+itemize = env "itemize" -enumerate :: [Tex a] -> Tex [a]-enumerate [] = return [] -- latex does not like empty lists.-enumerate xs = env "enumerate" $ - mapM item xs+------------------------+-- Various environments +tabular :: [String] -> String -> [[TeX]] -> TeX+tabular opts format bod = do+ env' "tabular" opts $ do+ braces (tex format)+ mkrows (map mkcols bod)+ return ()++center :: Tex a -> Tex a+center = env "center"++figure_ :: TeX -> TeX -> Tex SortedLabel+figure_ caption body = env "figure*" $ do+ body+ cmd "caption" caption+ label "Fig."++figure :: TeX -> TeX -> Tex SortedLabel+figure caption body = env "figure" $ do+ body+ cmd "caption" caption+ label "Fig."+ ---------- -- Fonts -sf, em :: Tex a -> Tex a-sf = cmd "textsf"-em = cmd "emph"+data TextSize = Tiny | ScriptSize | FootnoteSize | Small | NormalSize | Large | Larger | Largerr | Huge | Huger -------------- Math+textSize :: TextSize -> Tex a -> Tex a+textSize sz x = braces (cmd0 latexSize >> x)+ where latexSize = case sz of+ Tiny -> "tiny"+ ScriptSize -> "scriptsize"+ FootnoteSize -> "footnotesize"+ Small -> "small"+ NormalSize -> "normalsize"+ Large -> "large"+ Larger -> "Large"+ Largerr -> "LARGE"+ Huge -> "huge"+ Huger -> "Huge" -align = env "align*" . mkrows . map mkcols --- | A block-block :: [TeX] -> TeX-block bod = do- cmdn' "begin" [] [tex "array", tex "l"]- mkrows $ bod- cmdn' "end" [] [tex "array"]- return () -math = cmd "ensuremath"-mbox = cmd "mbox"+bold,sans, emph, smallcaps :: Tex a -> Tex a+sans = cmd "textsf"+emph = cmd "emph"+bold = cmd "textbf" -displayMath body = Tex "\\[" *> body <* Tex "\\]"+smallcaps x = braces (cmd0 "sc" >> x) +italic :: Tex a -> Tex a+italic = cmd "textit"++teletype :: Tex a -> Tex a+teletype = cmd "texttt"++-------------------------+-- Scaling and rotating++scalebox :: Double -> Tex a -> Tex a+scalebox factor x = do+ cmd "scalebox" $ tex $ show factor+ braces x++-----------+-- Parens+qu :: TeX -> TeX+qu x = tex "``" <> x <> tex "''"++paren,brack,brac,bigBrac,bigParen :: Tex a -> Tex a paren = parenthesize (tex "(") (tex ")") brack = parenthesize (tex "[") (tex "]") brac = parenthesize (backslash >> tex "{") (backslash >> tex "}")-bigBraces = bigParenthesize (backslash >> tex "{") (backslash >> tex "}")+bigBrac = bigParenthesize (backslash >> tex "{") (backslash >> tex "}")+bigParen = bigParenthesize (tex "(") (tex ")") +parenthesize,bigParenthesize :: TeX -> TeX -> Tex a -> Tex a bigParenthesize l r bod = do- Tex "\\left" >> l+ tex "\\left" >> l x <- bod- Tex "\\right" >> r+ tex "\\right" >> r return x- + parenthesize l r bod = do l x <- bod r return x +inferrule' :: TeX -> [TeX] -> TeX -> TeX+inferrule' name xs y = cmdm "inferrule" [name] [mkrows xs,y] >> return () -mathsf = cmd "mathsf"+inferrule :: [TeX] -> TeX -> TeX+inferrule xs y = cmdn "inferrule" [mkrows xs,y] >> return () -instance Fractional TeX where- a / b = cmdn_ "frac" [a,b]+----------------------+-- Listings -instance Floating TeX where- pi = cmd "pi" nil- exp x = "e^" <> braces x- sqrt = cmd "sqrt"+listing :: [String] -> Verbatim () -> TeX+listing opt (Verbatim s _) =+ env' "lstlisting" opt (tex s) -instance Num TeX where- fromInteger x = text $ show x- (+) = binop $ text "+"- (-) = binop $ text "-"- (*) = binop $ text "*"- negate x = "-" <> x+lstinline :: [String] -> Verbatim () -> TeX+lstinline opt (Verbatim s _) =+ let sep = tex "$"+ opt' = tex $ mconcat . intersperse ", "+ $ "basicstyle=\\ttfamily" : opt in+ backslash <> "lstinline" <> brackets opt' <> sep <> tex s <> sep -binop :: TeX -> TeX -> TeX -> TeX-binop op a b = a <> op <> b
+ MarXup/Latex/Bib.hs view
@@ -0,0 +1,19 @@+module MarXup.Latex.Bib where+import MarXup.Tex ++-------------+-- Bib+++bibliographystyle :: String -> TeX+bibliographystyle x = cmd "bibliographystyle" $ tex x++bibliography :: String -> TeX+bibliography x = do+ texLn "" -- some tools can detect bibliography command only if it stands on its own line.+ cmd "bibliography" $ tex x+ texLn ""++citet,citep :: String -> TeX+[citet,citep] = map (\c -> cmd c . tex) ["citet","citep"]+
+ MarXup/Latex/Math.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE OverloadedStrings #-}+module MarXup.Latex.Math where+import Control.Applicative+import MarXup.Latex+import MarXup.Tex+import MarXup+import Data.Monoid+import Data.Ratio+import Control.Monad (unless)++align = env "align*" . mkrows . map mkcols++array :: [String] -> String -> [[TeX]] -> TeX+array opts format bod = ensureMath $ do+ env' "array" opts $ do+ braces (tex format)+ mkrows (map mkcols bod)+ return ()++-- | A block+block :: [TeX] -> TeX+block bod = do+ env "array" $ do+ braces (tex "l")+ mkrows $ bod+ return ()++displayMath,ensureMath,mbox :: Tex a -> Tex a+ensureMath = cmd "ensuremath"+mbox = cmd "mbox"+fbox :: TeX -> TeX+fbox = cmd "fbox"+superscript y = tex "^" <> braces y+subscript x = tex "_" <> braces x++displayMath = env "displaymath"++mathsf :: Tex a -> Tex a+mathsf = cmd "mathsf"++mathpreamble :: ClassFile -> TeX+mathpreamble sty = do+ usepackage "graphicx" []+ usepackage "amsmath" []+ unless (sty == LNCS) $ usepackage "amsthm" []+ usepackage "amssymb" [] -- extra symbols such as □+ usepackage "stmaryrd" [] -- has ⟦ and ⟧+ usepackage "mathpartir" [] -- mathpar environment++ unless (sty == LNCS || sty == Beamer) $ do+ newtheorem "theorem" "Theorem"+ newtheorem "corollary" "Corollary"+ newtheorem "lemma" "Lemma"+ newtheorem "definition" "Definition"+ newtheorem "proposition" "Proposition"++mathpar :: [[TeX]] -> TeX+mathpar = env "mathpar" . mkrows . map mk . filter (not . null)+ where mk = foldr1 (\x y -> x <> cmd0 "and" <> y)++mathbox = mbox . ensureMath++newtheorem :: String -> TeX -> TeX+newtheorem ident txt = cmd "newtheorem" (tex ident) >> braces txt++deflike :: String -> String -> TeX -> TeX -> Tex SortedLabel+deflike reference nv name statement = env'' nv [] [name] $ do+ statement+ label reference++thmlike :: String -> String -> TeX -> TeX -> TeX -> Tex SortedLabel+thmlike reference nv name statement proof = do+ x <- deflike reference nv name statement+ env "proof" proof+ return x++theorem,lemma :: TeX -> TeX -> TeX -> Tex SortedLabel+theorem = thmlike "Thm." "theorem"+lemma = thmlike "Lem." "lemma"++definition,corollary :: TeX -> TeX -> Tex SortedLabel+definition = deflike "Def." "definition"+corollary = deflike "Cor." "corollary"+proposition = deflike "Prop." "proposition"+example = deflike "Ex." "example"++-- Other stuff+oxford :: Tex a -> Tex a+oxford = bigParenthesize (textual "⟦") (textual "⟧")++multiline' body = env "multline*" $ mkrows body++frac x y = cmdn_ "frac" [x,y]++centerVertically = ensureMath . cmd "vcenter" . cmd "hbox"++qedhere = cmd0 "qedhere"
+ MarXup/Math.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE OverloadedStrings, TypeFamilies #-}+module MarXup.Math where++import Control.Applicative+import MarXup.Latex+import MarXup.Latex.Math+import MarXup.Tex+import MarXup+import Data.Monoid+import Data.Ratio+import Data.String+import Control.Monad (unless)++instance Element Math where+ type Target Math = TeX+ element = inline++instance IsString Math where+ fromString = Con . fromString++inline x = " " <> (cmd "ensuremath" . mRender 0 $ x) <> " "+-- display = cmd "displaymath" . mRender 0+display x = tex "$$" <> mRender 0 x <> tex "$$"++text :: TeX -> Math+text = Con . cmd "text"++-- type MathShallow = Int -> Tex++data Math = BinOp Int (TeX -> TeX -> TeX) Int Int Math Math+ | UnOp Int (TeX -> TeX) Int Math+ | Con TeX+ | Math (Int -> TeX)+ | Invisible (TeX -> TeX) Math++parp p p' = if p' < p then bigParen else id++mRender :: Int -> Math -> TeX+mRender _ (Con x) = x+mRender p (Math x) = x p+mRender p (BinOp p' f pl pr l r) = parp p p' $ f (mRender pl l) (mRender pr r)+mRender p (UnOp p' f px x) = parp p p' $ f (mRender px x)+mRender p (Invisible f x) = f $ mRender p x++ternaryOp :: Int -> (TeX -> TeX -> TeX -> TeX) -> Int -> Int -> Int -> Math -> Math -> Math -> Math+ternaryOp p' f px py pz x y z = Math $ \p -> parp p p' $ f (mRender px x)(mRender py y)(mRender pz z)+ +binop :: Int -> TeX -> Math -> Math -> Math+binop prec op = BinOp prec (\x y -> x <> op <> y) prec prec+preop prec op = UnOp prec (\x -> x <> op) prec+outop left right = UnOp 100 (parenthesize left right) 0+fct x = UnOp 6 (x <>) 7++--------------+-- Operators++(=:) = binop 0 "="++instance Num Math where+ (+) = binop 1 "+"+ (-) = binop 1 "-"+ (*) = binop 2 ""+ abs = outop (cmd0 "mid") (cmd0 "mid")+ signum = preop 10 $ cmd0 "delta"+ fromInteger x = Con $ textual $ show x+ negate = preop 1 "-"++instance Fractional Math where+ (/) = BinOp 10 (\a b -> cmdn_ "frac" [a,b]) 0 0+ fromRational r = fromInteger (numerator r) / fromInteger (denominator r)++instance Floating Math where+ pi = Con $ cmd0 "pi"+ exp = UnOp 20 (\x -> tex "e^" <> braces x) 0+ sqrt = UnOp 10 (cmd "sqrt") 0+ log = fct (cmd "mathnormal" "log")+ sin = fct (cmd "mathnormal" "sin")+ cos = fct (cmd "mathnormal" "cos")+ asin = fct (cmd "mathnormal" "asin")+ acos = fct (cmd "mathnormal" "acos")+ atan = fct (cmd "mathnormal" "atan")+ sinh = fct (cmd "mathnormal" "sinh")+ cosh = fct (cmd "mathnormal" "cosh")+ asinh = fct (cmd "mathnormal" "asinh")+ acosh = fct (cmd "mathnormal" "acosh")+ atanh = fct (cmd "mathnormal" "atanh")+ (**) = (^^^) ++ceiling, floor :: Math -> Math+ceiling = outop "⌈" "⌉"+floor = outop "⌊" "⌋"+++++(^^^) = BinOp 5 (\x y -> braces x <> superscript y) 5 6+($$$) = BinOp 5 (\x y -> braces x <> subscript y) 5 6++
− MarXup/MetaPost.hs
@@ -1,27 +0,0 @@--module MarXup.MetaPost where--import MarXup.Tex-- -metaPostPreamble :: Tex a -> Tex ()-metaPostPreamble texPreamble = do- texLines ["outputtemplate := \"%j-%c.mps\";",- "input drv;",- "verbatimtex %&latex",- ""]- texPreamble- texLines ["",- "\\begin{document}",- "etex;",- "prologues:=3;"] - -metaPostEpilogue = texLn "end"- --metapostFigure :: Label -> Tex a -> Tex ()-metapostFigure lab t = Metapost $ do- Tex "beginfig(" >> Refer lab >> Tex ")\n"- t- texLn "endfig;"-
+ MarXup/MultiRef.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, GADTs, PackageImports #-}++module MarXup.MultiRef where++import Control.Monad.Fix+import "mtl" Control.Monad.RWS.Lazy+import Control.Applicative+import Control.Arrow (first)++newtype Multi a = Multi {fromMulti :: RWS InterpretMode String (References,[BoxSpec]) a }+ deriving (Functor, Monad, Applicative, MonadWriter String, MonadState (References,[BoxSpec]), MonadFix, MonadReader InterpretMode)++-----------------------------------+-- Basic datatype and semantics+type Label = Int++-- | Size of a box, in points. boxDepth is how far the baseline is+-- from the bottom. boxHeight is how far the baseline is from the top.+-- (These are TeX meanings)+data BoxSpec = BoxSpec {boxWidth, boxHeight, boxDepth :: Double}+ deriving (Show)++nilBoxSpec :: BoxSpec+nilBoxSpec = BoxSpec 0 0 0++raw :: String -> Multi ()+raw s = tell s++getBoxSpec :: Multi BoxSpec+getBoxSpec = do+ (refs,bs) <- get+ case bs of+ [] -> error "display: ran out of boxes!"+ (b:bs') -> do+ put (refs,bs')+ return b+ +++-- Reference management+newLabel :: Multi Label -- create a new label+newLabel = do x <- fst <$> get; modify (first (+1)); return x++type References = Int -- how many labels have been allocated+emptyRefs :: References+emptyRefs = 0++type Mode = InterpretMode -> Bool+data InterpretMode = OutsideBox | InsideBox | Regular deriving Eq+
+ MarXup/PrettyPrint.hs view
@@ -0,0 +1,442 @@+{-# LANGUAGE OverloadedStrings #-}++module MarXup.PrettyPrint where++import Control.Applicative+import Data.Monoid+-- import MarXup.Latex ()+import MarXup.Tex+-- import MarXup.MultiRef (BoxSpec(..))++import MarXup.PrettyPrint.Core+import MarXup.PrettyPrint.Core as MarXup.PrettyPrint++type Docu = Tex Doc++text :: TeX -> Tex Doc+text body = do+ b <- justBox body+ return $ Text $ TeX body b++infixr 5 </>,<//>,<$$$>,<$$>+infixr 6 <+>++-- -- | The document @(list xs)@ comma separates the documents @xs@ and+-- -- encloses them in square brackets. The documents are rendered+-- -- horizontally if that fits the page. Otherwise they are aligned+-- -- vertically. All comma separators are put in front of the elements.+list :: [Doc] -> Tex Doc+list = enclosure "[" "]" ","++-- -- | The document @(tupled xs)@ comma separates the documents @xs@ and+-- -- encloses them in parenthesis. The documents are rendered+-- -- horizontally if that fits the page. Otherwise they are aligned+-- -- vertically. All comma separators are put in front of the elements.+-- tupled :: [Doc] -> Doc+-- tupled = enclosure lparen rparen comma+++-- -- | The document @(semiBraces xs)@ separates the documents @xs@ with+-- -- semi colons and encloses them in braces. The documents are rendered+-- -- horizontally if that fits the page. Otherwise they are aligned+-- -- vertically. All semi colons are put in front of the elements.+-- semiBraces :: [Doc] -> Doc+-- semiBraces = enclosure lbrace rbrace semi++-- | The document @(enclosure l r sep xs)@ concatenates the documents+-- @xs@ separated by @sep@ and encloses the resulting document by @l@+-- and @r@. The documents are rendered horizontally if that fits the+-- page. Otherwise they are aligned vertically. All separators are put+-- in front of the elements. For example, the combinator 'list' can be+-- defined with @enclosure@:+--+-- > list xs = enclosure lbracket rbracket comma xs+-- > test = text "list" <+> (list (map int [10,200,3000]))+--+-- Which is layed out with a page width of 20 as:+--+-- @+-- list [10,200,3000]+-- @+--+-- But when the page width is 15, it is layed out as:+--+-- @+-- list [10+-- ,200+-- ,3000]+-- @+encloseSep :: Doc -> Doc -> Doc -> [Doc] -> Doc+encloseSep left right sep ds+ = case ds of+ [] -> left <> right+ [d] -> left <> d <> right+ _ -> align (cat (zipWith (<>) (left : repeat sep) ds) <> right)+++enclosure :: TeX -> TeX -> TeX -> [Doc] -> Tex Doc+enclosure left right separ ds = do+ l <- text left+ r <- text right+ s <- text separ+ return $ encloseSep l r s ds++-----------------------------------------------------------+-- punctuate p [d1,d2,...,dn] => [d1 <> p,d2 <> p, ... ,dn]+-----------------------------------------------------------+++-- | @(punctuate p xs)@ concatenates all documents in @xs@ with+-- document @p@ except for the last document.+--+-- > someText = map text ["words","in","a","tuple"]+-- > test = parens (align (cat (punctuate comma someText)))+--+-- This is layed out on a page width of 20 as:+--+-- @+-- (words,in,a,tuple)+-- @+--+-- But when the page width is 15, it is layed out as:+--+-- @+-- (words,+-- in,+-- a,+-- tuple)+-- @+--+-- (If you want put the commas in front of their elements instead of+-- at the end, you should use 'tupled' or, in general, 'encloseSep'.)+punctuate :: Doc -> [Doc] -> [Doc]+punctuate p [] = []+punctuate p [d] = [d]+punctuate p (d:ds) = (d <> p) : punctuate p ds+++-----------------------------------------------------------+-- high-level combinators+-----------------------------------------------------------+++-- | The document @(sep xs)@ concatenates all documents @xs@ either+-- horizontally with @(\<+\>)@, if it fits the page, or vertically with+-- @(\<$\>)@.+--+-- > sep xs = group (vsep xs)+sep :: [Doc] -> Doc+sep = group . vsep++-- | The document @(fillSep xs)@ concatenates documents @xs@+-- horizontally with @(\<+\>)@ as long as its fits the page, than+-- inserts a @line@ and continues doing that for all documents in+-- @xs@.+--+-- > fillSep xs = foldr (\<\/\>) empty xs+fillSep :: [Doc] -> Doc+fillSep = foldDoc (</>)++-- | The document @(hsep xs)@ concatenates all documents @xs@+-- horizontally with @(\<+\>)@.+hsep :: [Doc] -> Doc+hsep = foldDoc (<+>)+++-- | The document @(vsep xs)@ concatenates all documents @xs@+-- vertically with @(\<$\>)@. If a 'group' undoes the line breaks+-- inserted by @vsep@, all documents are separated with a space.+--+-- > someText = map text (words ("text to lay out"))+-- >+-- > test = text "some" <+> vsep someText+--+-- This is layed out as:+--+-- @+-- some text+-- to+-- lay+-- out+-- @+--+-- The 'align' combinator can be used to align the documents under+-- their first element+--+-- > test = text "some" <+> align (vsep someText)+--+-- Which is printed as:+--+-- @+-- some text+-- to+-- lay+-- out+-- @+vsep :: [Doc] -> Doc+vsep = foldDoc (<$$$>)++-- | The document @(cat xs)@ concatenates all documents @xs@ either+-- horizontally with @(\<\>)@, if it fits the page, or vertically with+-- @(\<$$\>)@.+--+-- > cat xs = group (vcat xs)+cat :: [Doc] -> Doc+cat = group . vcat++-- | The document @(fillCat xs)@ concatenates documents @xs@+-- horizontally with @(\<\>)@ as long as its fits the page, than inserts+-- a @linebreak@ and continues doing that for all documents in @xs@.+--+-- > fillCat xs = foldr (\<\/\/\>) empty xs+fillCat :: [Doc] -> Doc+fillCat = foldDoc (<//>)++-- | The document @(hcat xs)@ concatenates all documents @xs@+-- horizontally with @(\<\>)@.+hcat :: [Doc] -> Doc+hcat = foldDoc (<>)++-- | The document @(vcat xs)@ concatenates all documents @xs@+-- vertically with @(\<$$\>)@. If a 'group' undoes the line breaks+-- inserted by @vcat@, all documents are directly concatenated.+vcat :: [Doc] -> Doc+vcat = foldDoc (<$$>)++foldDoc :: (Doc -> Doc -> Doc) -> [Doc] -> Doc+foldDoc f [] = mempty+foldDoc f ds = foldr1 f ds++-- | The document @(x \<+\> y)@ concatenates document @x@ and @y@ with a+-- @space@ in between. (infixr 6)+(<+>) :: Doc -> Doc -> Doc+x <+> y = x <> space <> y++-- | The document @(x \<\/\> y)@ concatenates document @x@ and @y@ with a+-- 'softline' in between. This effectively puts @x@ and @y@ either+-- next to each other (with a @space@ in between) or underneath each+-- other. (infixr 5)+(</>) :: Doc -> Doc -> Doc+x </> y = x <> softline <> y++-- | The document @(x \<\/\/\> y)@ concatenates document @x@ and @y@ with+-- a 'softbreak' in between. This effectively puts @x@ and @y@ either+-- right next to each other or underneath each other. (infixr 5)+(<//>) :: Doc -> Doc -> Doc+x <//> y = x <> softbreak <> y++-- | The document @(x \<$\> y)@ concatenates document @x@ and @y@ with a+-- 'line' in between. (infixr 5)+(<$$$>) :: Doc -> Doc -> Doc+x <$$$> y = x <> line <> y++-- | The document @(x \<$$\> y)@ concatenates document @x@ and @y@ with+-- a @linebreak@ in between. (infixr 5)+(<$$>) :: Doc -> Doc -> Doc+x <$$> y = x <> linebreak <> y++-- | The document @softline@ behaves like 'space' if the resulting+-- output fits the page, otherwise it behaves like 'line'.+--+-- > softline = group line+softline :: Doc+softline = group line++-- | The document @softbreak@ behaves like 'empty' if the resulting+-- output fits the page, otherwise it behaves like 'line'.+--+-- > softbreak = group linebreak+softbreak :: Doc+softbreak = group linebreak++-- -- | Document @(squotes x)@ encloses document @x@ with single quotes+-- -- \"'\".+-- squotes :: Doc -> Doc+-- squotes = enclose squote squote++-- -- | Document @(dquotes x)@ encloses document @x@ with double quotes+-- -- '\"'.+-- dquotes :: Doc -> Doc+-- dquotes = enclose dquote dquote++-- -- | Document @(braces x)@ encloses document @x@ in braces, \"{\" and+-- -- \"}\".+-- braces :: Doc -> Doc+-- braces = enclose lbrace rbrace++-- -- | Document @(parens x)@ encloses document @x@ in parenthesis, \"(\"+-- -- and \")\".+-- parens :: Doc -> Doc+-- parens = enclose lparen rparen++-- -- | Document @(angles x)@ encloses document @x@ in angles, \"\<\" and+-- -- \"\>\".+-- angles :: Doc -> Doc+-- angles = enclose langle rangle++-- -- | Document @(brackets x)@ encloses document @x@ in square brackets,+-- -- \"[\" and \"]\".+-- brackets :: Doc -> Doc+-- brackets = enclose lbracket rbracket++-- | The document @(enclose l r x)@ encloses document @x@ between+-- documents @l@ and @r@ using @(\<\>)@.+--+-- > enclose l r x = l <> x <> r+enclose :: Doc -> Doc -> Doc -> Doc+enclose l r x = l <> x <> r++-----------------------------------------------------------+-- semi primitive: fill and fillBreak+-----------------------------------------------------------++-- | The document @(fillBreak i x)@ first renders document @x@. It+-- than appends @space@s until the width is equal to @i@. If the+-- width of @x@ is already larger than @i@, the nesting level is+-- increased by @i@ and a @line@ is appended. When we redefine @ptype@+-- in the previous example to use @fillBreak@, we get a useful+-- variation of the previous output:+--+-- > ptype (name,tp)+-- > = fillBreak 6 (text name) <+> text "::" <+> text tp+--+-- The output will now be:+--+-- @+-- let empty :: Doc+-- nest :: Double -> Doc -> Doc+-- linebreak+-- :: Doc+-- @+fillBreak :: Double -> Doc -> Doc+fillBreak f x = width x (\w ->+ if (w > f) then nest f linebreak+ else spacing (f - w))+++-- | The document @(fill i x)@ renders document @x@. It than appends+-- @space@s until the width is equal to @i@. If the width of @x@ is+-- already larger, nothing is appended. This combinator is quite+-- useful in practice to output a list of bindings. The following+-- example demonstrates this.+--+-- > types = [("empty","Doc")+-- > ,("nest","Double -> Doc -> Doc")+-- > ,("linebreak","Doc")]+-- >+-- > ptype (name,tp)+-- > = fill 6 (text name) <+> text "::" <+> text tp+-- >+-- > test = text "let" <+> align (vcat (map ptype types))+--+-- Which is layed out as:+--+-- @+-- let empty :: Doc+-- nest :: Double -> Doc -> Doc+-- linebreak :: Doc+-- @+fill :: Double -> Doc -> Doc+fill f d = width d (\w ->+ if (w >= f) then mempty+ else spacing (f - w))++width :: Doc -> (Double -> Doc) -> Doc+width d f = column (\k1 -> d <> column (\k2 -> f (k2 - k1)))+++-----------------------------------------------------------+-- semi primitive: Alignment and indentation+-----------------------------------------------------------++-- | The document @(indent i x)@ indents document @x@ with @i@ spaces.+--+-- > test = indent 4 (fillSep (map text+-- > (words "the indent combinator indents these words !")))+--+-- Which lays out with a page width of 20 as:+--+-- @+-- the indent+-- combinator+-- indents these+-- words !+-- @+indent :: Double -> Doc -> Doc+indent i d = hang i (spacing i <> d)++-- | The hang combinator implements hanging indentation. The document+-- @(hang i x)@ renders document @x@ with a nesting level set to the+-- current column plus @i@. The following example uses hanging+-- indentation for some text:+--+-- > test = hang 4 (fillSep (map text+-- > (words "the hang combinator indents these words !")))+--+-- Which lays out on a page with a width of 20 characters as:+--+-- @+-- the hang combinator+-- indents these+-- words !+-- @+--+-- The @hang@ combinator is implemented as:+--+-- > hang i x = align (nest i x)+hang :: Double -> Doc -> Doc+hang i d = align (nest i d)++-- | The document @(align x)@ renders document @x@ with the nesting+-- level set to the current column. It is used for example to+-- implement 'hang'.+--+-- As an example, we will put a document right above another one,+-- regardless of the current nesting level:+--+-- > x $$ y = align (x <$$$> y)+--+-- > test = text "hi" <+> (text "nice" $$ text "world")+--+-- which will be layed out as:+--+-- @+-- hi nice+-- world+-- @+align :: Doc -> Doc+align d = column (\k ->+ nesting (\i -> nest (k - i) d)) --nesting might be negative :-)+++-- | The @line@ document advances to the next line and indents to the+-- current nesting level. Document @line@ behaves like @(text \" \")@+-- if the line break is undone by 'group'.+line :: Doc+line = Line False++-- | The @linebreak@ document advances to the next line and indents to+-- the current nesting level. Document @linebreak@ behaves like+-- 'empty' if the line break is undone by 'group'.+linebreak :: Doc+linebreak = Line True++-- | The document @(nest i x)@ renders document @x@ with the current+-- indentation level increased by i (See also 'hang', 'align' and+-- 'indent').+--+-- > nest 2 (text "hello" <$$$> text "world") <$$$> text "!"+--+-- outputs as:+--+-- @+-- hello+-- world+-- !+-- @+nest :: Double -> Doc -> Doc+nest i x = Nest i x++column, nesting :: (Double -> Doc) -> Doc+column f = Column f+nesting f = Nesting f
+ MarXup/PrettyPrint/Core.hs view
@@ -0,0 +1,245 @@+{-# LANGUAGE RecordWildCards #-}+module MarXup.PrettyPrint.Core(Doc(..),pretty,group,flatten,space,spacing,BoxTex(..)) where++import Data.Monoid+import MarXup (textual)+import MarXup.Latex+import MarXup.Tex+import MarXup.MultiRef +import MarXup.Diagram.Tikz (showDistance)+import Data.Foldable (forM_)+import Control.Applicative+import Data.Function (on)+import Data.List (partition,minimumBy,sort)+import Data.Either (partitionEithers)++data BoxTex = TeX TeX BoxSpec | Spacing Double+++data Doc = Empty+ | Text BoxTex+ | Line !Bool -- True <=> when undone by group, do not insert a space+ | Cat Doc Doc+ | Nest Double Doc+ | Union Doc Doc -- invariant: first lines of first doc longer than the first lines of the second doc+ | Column (Double -> Doc)+ | Nesting (Double -> Doc)+++-- | Document "process"+data SimpleDoc = SEmpty+ | SText BoxTex SimpleDoc+ | SLine Double SimpleDoc -- Line, indented.++toksToSimple [] = SEmpty+toksToSimple (Ln d:ts) = SLine d $ toksToSimple ts+toksToSimple (Tx s:ts) = SText s $ toksToSimple ts++instance Monoid Doc where+ mempty = Empty+ mappend = Cat+ +group :: Doc -> Doc+group x = Union (flatten x) x++flatten :: Doc -> Doc+flatten (Cat x y) = Cat (flatten x) (flatten y)+flatten (Nest i x) = Nest i (flatten x)+flatten (Line noSpace) = if noSpace then Empty else Text (Spacing 3.5)+flatten (Union x _y) = flatten x+flatten (Column f) = Column (flatten . f)+flatten (Nesting f) = Nesting (flatten . f)+flatten other = other --Empty,Char,Text++++space = spacing 3.5++spacing = Text . Spacing+-- d = Text (hspace (showDistance d),BoxSpec {boxWidth = d, boxHeight = 0, boxDepth = 0})+++len (TeX _ b)= boxWidth b+len (Spacing x) = x+hei (TeX _ x) = boxHeight x + boxDepth x+hei (Spacing _) = 0++-- | Does the first line of the document fit in the given width?+fits w _x | w < 0 = False+fits _w SEmpty = True+fits w (SText s x) = fits (w - len s) x+fits w (SLine i x) = True+++data Docs = Nil+ | Cons !Double Doc Docs++++data Token = Ln Double | Tx BoxTex++data Process = Process {overflow :: Double+ ,curIndent :: !Double -- current indentation+ ,numToks :: Int -- total number of non-space tokens produced+ ,tokens :: [Token] -- tokens produced, in reverse order+ ,rest :: !Docs -- rest of the input document to process+ }+-- The ⟨filtering⟩ step takes all process states starting at the current+-- line, and discards those that are dominated. A process state+-- dominates another one if it was able to produce more tokens while+-- having less indentation. This is implemented by first sorting the+-- process states by following 'measure', and then applying the+-- 'filtering' function.++measure = \Process{..} -> (curIndent, negate numToks)+instance Eq Process where+ (==) = (==) `on` measure+instance Ord Process where+ compare = compare `on` measure++filtering :: [Process] -> [Process]+filtering (x:y:xs) | numToks x >= numToks y = filtering (x:xs)+ | otherwise = x:filtering (y:xs)+filtering xs = xs++renderAll :: Double -> Double -> Doc -> SimpleDoc+renderAll rfrac w doc = toksToSimple $ reverse $ loop [Process 0 0 0 [] $ Cons 0 doc Nil]+ where+ loop ps = case dones of+ ((_,done):_) -> done -- here we could attempt to do a better choice. Seems to be fine for now.+ [] -> case conts of+ (_:_) -> loop $ filtering $ sort $ conts -- See the comment ⟨filtering⟩ above+ [] -> case conts'over of+ (_:_) -> loop [minimumBy (compare `on` overflow) conts'over]+ [] -> case dones'over of+ ((_,done):_) -> done+ [] -> [Tx $ TeX (textual "Pretty print: Panic") (BoxSpec 0 0 0)]++ where+ -- advance all processes by one line (if possible)+ ps' = concatMap (\Process{..} -> rall numToks tokens curIndent curIndent rest) ps+ -- Have some processes reached the end?+ (dones0,conts0) = partitionEithers ps'+ (conts,conts'over) = partition (\p -> overflow p <= 0) conts0+ (dones,dones'over) = partition (\(o,_) -> o <= 0) dones0++ -- r :: the ribbon width in characters+ r = max 0 (min w (w * rfrac))++ -- Automatically inserted spacing does not count as doing more production.+ count (Spacing _) = 0+ count (TeX _ _) = 1++ -- Compute the state(s) after reaching the end of line.+ -- rall :: n = indentation of current line+ -- k = current column+ -- (ie. (k >= n) && (k - n == count of inserted characters)+ rall :: Int -> [Token] -> Double -> Double -> Docs -> [Either (Double,[Token]) Process]+ rall nts ts n k ds0 = case ds0 of+ Nil -> [Left $ (overflow,ts)] -- Done!+ Cons i d ds -> case d of+ Empty -> rall nts ts n k ds+ Text s -> let k' = k+len s in seq k' (rall (nts+count s) (Tx s:ts) n k' ds)+ Line _ -> [Right $ Process overflow i nts (Ln i:ts) ds] -- "yield" when the end of line is reached+ Cat x y -> rall nts ts n k (Cons i x (Cons i y ds))+ Nest j x -> let i' = i+j in seq i' (rall nts ts n k (Cons i' x ds))+ Union x y -> rall nts ts n k (Cons i x ds) ++ rall nts ts n k (Cons i y ds)+ Column f -> rall nts ts n k (Cons i (f k) ds)+ Nesting f -> rall nts ts n k (Cons i (f i) ds)+ where overflow = negate $ min (w - k) (r - k + n)++-- countLines :: SimpleDoc -> Int+-- countLines = length . linify0++-- measureWidth :: SimpleDoc -> Double+-- measureWidth = maximum . map lineWidth . linify0+-- where lineWidth (i,boxes) = i + sum (map len boxes)++-- The original function implemented by Daan Leijen. Wadler derives a+-- similar function in his paper ("A prettier printer"). Unfortunately+-- it does not produce pretty layouts: the assumptions that enable the+-- amount of greediness implemented here do not hold after adding the+-- Column and Nesting combinators. So this function tends to generate+-- layouts with a long first line and a cramped column of stuff.++renderPretty :: Double -> Double -> Doc -> SimpleDoc+renderPretty rfrac w doc+ = best 0 0 (Cons 0 doc Nil)+ where+ -- r :: the ribbon width in characters+ r = max 0 (min w (w * rfrac))++ -- best :: n = indentation of current line+ -- k = current column+ -- (ie. (k >= n) && (k - n == count of inserted characters)+ best _n _k Nil = SEmpty+ best n k (Cons i d ds)+ = case d of+ Empty -> best n k ds+ Text s -> let k' = k+len s in seq k' (SText s (best n k' ds))+ Line _ -> SLine i (best i i ds)+ Cat x y -> best n k (Cons i x (Cons i y ds))+ Nest j x -> let i' = i+j in seq i' (best n k (Cons i' x ds))+ Union x y -> nicest n k (best n k (Cons i x ds))+ (best n k (Cons i y ds))++ Column f -> best n k (Cons i (f k) ds)+ Nesting f -> best n k (Cons i (f i) ds)++ --nicest :: r = ribbon width, w = page width,+ -- n = indentation of current line, k = current column+ -- x and y, the (simple) documents to chose from.+ -- precondition: first lines of x are longer than the first lines of y.+ nicest n k x y | fits width x = x+ | otherwise = y+ where+ width = min (w - k) (r - k + n)++linify0 :: SimpleDoc -> [(Double, [BoxTex])]+linify0 d = linify d 0 []++-- | Turn a simpledoc into a list of lines and indentation.+linify :: SimpleDoc -> Double -> [BoxTex] -> [(Double,[BoxTex])]+linify SEmpty i t = [(i,t)]+linify (SText s x) i t = linify x i (t ++ [s])+linify (SLine i' x) i t = (i,t):linify x i' mempty++computeHeights :: BoxTex -> [(Double,[BoxTex])] -> [Double]+computeHeights strut ls = scanl (\y (_i,boxes) -> y - maximum (map hei (strut:boxes))) 0 ls++heights :: BoxTex -> [(Double,[BoxTex])] -> [(Double,(Double, [BoxTex]))]+heights strut ls = zip (computeHeights strut ls) ls++computeWidths :: Double -> [BoxTex] -> [Double]+computeWidths = scanl (\x b -> len b + x)++layout :: SimpleDoc -> Tex ()+layout d = env "tikzpicture" $ do+ strutBox <- justBox $ -- textual "qM" -- slightly too small ones+ cmd0 "strut" -- this gives slightly too big spaces sometimes+ let strut = TeX mempty strutBox+ forM_ (heights strut $ linify0 d) $ \(y,(i,boxes)) -> do+ let mh = maximum (map hei (strut:boxes))+ forM_ (zip boxes $ computeWidths i boxes) $ \(tx,x) -> do+ case tx of+ Spacing _ -> return ()+ TeX t box -> do+ let y' = y - (mh - boxHeight box)+ tex $ "\\node[anchor=north west,inner sep=0] at (" ++ showDistance x ++ "," ++ showDistance y' ++ ")"+ braces $ t+ tex ";\n"++pretty :: Double -> Double -> Doc -> TeX+pretty rfrac w d = do+ layout $ renderAll rfrac w d+++-- getBoxes :: Doc -> Tex Doc+-- getBoxes Empty = pure Empty+-- getBoxes (Cat d e) = Cat <$> getBoxes d <*> getBoxes e+-- getBoxes (Union d e) = Union <$> getBoxes d <*> getBoxes e+-- getBoxes (Tex (t,_)) = do+-- b <- justBox t+-- return (TEXT (t,b))+-- getBoxes (NEST i d) = NEST i <$> getBoxes d+-- getBoxes LINE = pure LINE
MarXup/Tex.hs view
@@ -1,170 +1,258 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies,TypeSynonymInstances,FlexibleInstances, PackageImports #-} module MarXup.Tex where -import Control.Monad.Fix-import Control.Monad.RWS.Lazy+import MarXup+import "mtl" Control.Monad.Reader+import "mtl" Control.Monad.RWS import Control.Applicative-import Data.Either import GHC.Exts( IsString(..) )-import System.FilePath-import System.Environment import Data.List (intersperse)+import MarXup.MultiRef+import System.Process+import System.Directory (doesFileExist) +newtype Tex a = Tex {fromTex :: Multi a}+ deriving (Monad, MonadFix, Applicative, Functor)+ ------------------------------------ Marchup interface-textual = Tex -- TODO: escape \, &, etc.-text = textual +-- MarXup interface+instance Textual Tex where+ textual s = tex $ concatMap escape s +kern :: String -> TeX+kern x = braces $ tex $ "\\kern " ++ x -element :: Tex a -> Tex a-element = id+escape '\\' = "\\ensuremath{\\backslash{}}"+escape '~' = "\\ensuremath{\\sim{}}"+escape '<' = "\\ensuremath{<}"+escape '>' = "\\ensuremath{>}"+escape c | c `elem` "#^_{}&$%" = '\\':c:[]+escape c = [c] --------------------------------------- Basic datatype and semantics-type Label = Int+instance Element (Tex a) where+ type Target (Tex a) = Tex a+ element = id -data Tex a where- Return :: a -> Tex a- Bind :: Tex a -> (a -> Tex b) -> Tex b+texInMode :: Mode -> String ->TeX+texInMode mode s = whenMode mode $ Tex $ raw s - Tex :: String -> Tex () -- ^ raw TeX code+tex :: String -> TeX+tex = texInMode (`elem` [Regular,InsideBox]) - -- Reference management- Label :: Tex Label- Refer :: Label -> Tex Label- MFix :: (a -> Tex a) -> Tex a +texComment :: String -> TeX+texComment s =+ forM_ (lines s) $ \line ->+ tex $ "% " <> line <> "\n" - -- MetaPOST- Metapost :: Tex a -> Tex a -- the output should go in the metapost file- MPFigure :: Label -> Tex () -- inclusion of a metapost figure- -tex = Tex type TeX = Tex () -newLabel = Label -reference = Refer--instance MonadFix Tex where- mfix = MFix+reference :: Label -> Tex ()+reference l = tex (show l) -instance Monad Tex where- (>>=) = Bind- return = Return- -instance Applicative Tex where- (<*>) = ap- pure = Return- -instance Functor Tex where- fmap = liftM- -instance Monoid (Tex ()) where - mempty = Tex ""+instance Monoid (TeX) where+ mempty = textual "" mappend = (>>)- -instance IsString (Tex ()) where - fromString = Tex- -type References = Int -- how many labels have been allocated-emptyRefs :: References-emptyRefs = 0- -select :: Bool -> a -> Either a a-select True x = Left x-select False x = Right x- -type TexAndMPost = [Either String String]--newtype Displayer a = Displayer {fromDisplayer :: RWS () TexAndMPost References a }- deriving (Monad, MonadWriter TexAndMPost, MonadState References, MonadFix)--- | Produces a list of strings (either for LaTeX or MetaPOST).-display :: String -> Bool -> Tex a -> Displayer a -display fname mp t = case t of- (Tex s) -> tell' s- (Return a) -> return a- (Bind k f) -> rec k >>= (rec . f)- Label -> do x <- get; put $ x + 1; return x- (Refer x) -> do tell [select mp $ show x]; return x- (MFix f) -> mfix (rec . f)- (Metapost x) -> display fname True x - (MPFigure l) -> tell' $ fname ++ "-" ++ show l ++ ".mps"- where tell' :: String -> Displayer ()- tell' s = tell [select mp s] - rec :: Tex a -> Displayer a- rec = display fname mp- -sho :: Show a => a -> Tex ()-sho = Tex . show- -render :: Tex a -> IO () -render t = do - fname <- getProgName- let (_,xs) = evalRWS (fromDisplayer $ display fname False t) () emptyRefs - (mp,tex) = partitionEithers xs- writeFile (fname <.> "tex") (concat tex)- writeFile (fname <.> "mp") (concat mp)- +instance IsString (TeX) where+ fromString = textual -texLn :: String -> Tex () -texLn s = Tex s >> Tex "\n"+texLn :: String -> TeX+texLn s = tex s >> tex "\n" texLines :: [String] -> Tex () texLines = mapM_ texLn genParen :: String -> Tex a -> Tex a-genParen [l,r] x = Tex [l] *> x <* Tex [r]+genParen [l,r] x = tex [l] *> x <* tex [r] -braces :: Tex a -> Tex a+braces,brackets :: Tex a -> Tex a braces = genParen "{}" brackets = genParen "[]" -backslash = Tex ['\\']+backslash :: TeX+backslash = tex ['\\'] -nil = braces (Tex "")+nil :: TeX+nil = braces (tex "") +-- | Command with no argument+cmd0 :: String -> Tex () cmd0 c = cmdn' c [] [] >> return () +-- | Command with one argument+cmd :: String -> Tex a -> Tex a cmd c = cmd' c [] +-- | Command with options+cmd' :: String -> [String] -> Tex b -> Tex b cmd' cmd options arg = do [x] <- cmdn' cmd options [arg] return x +-- | Command with options and many arguments cmdn' :: String -> [String] -> [Tex a] -> Tex [a]-cmdn' cmd options args = do - backslash >> Tex cmd+cmdn' cmd options args = do+ backslash >> tex cmd when (not $ null options) $ brackets $ sequence_ $ map tex $ intersperse "," options res <- sequence $ map braces args- when (null args) $ Tex "{}" -- so that this does not get glued with the next thing.+ when (null args) $ tex "{}" -- so that this does not get glued with the next thing. return res +-- | Command with tex options and many arguments cmdm :: String -> [Tex a] -> [Tex a] -> Tex [a]-cmdm cmd options args = do - backslash >> Tex cmd+cmdm cmd options args = do+ backslash >> tex cmd when (not $ null options) $ sequence_ $ map brackets $ options res <- sequence $ map braces args- when (null args) $ Tex "{}" -- so that this does not get glued with the next thing.+ when (null args) $ tex "{}" -- so that this does not get glued with the next thing. return res -cmdn'_ :: String -> [String] -> [Tex a] -> Tex ()+cmdn'_ :: String -> [String] -> [TeX] -> Tex () cmdn'_ cmd options args = cmdn' cmd options args >> return () -cmdn cmd args = cmdn' cmd [] args+-- | Command with n arguments+cmdn :: String -> [Tex a] -> Tex [a]+cmdn c args = cmdn' c [] args++cmdn_ :: String -> [TeX] -> Tex () cmdn_ cmd args = cmdn'_ cmd [] args +-- | Environment env :: String -> Tex a -> Tex a-env e body = do- cmd "begin" $ Tex e+env x = env' x []++-- | Environment with options+env' :: String -> [String] -> Tex a -> Tex a+env' e opts body = env'' e opts [] body++-- | Environment with a tex option+env'' :: String -> [String] -> [TeX] -> Tex a -> Tex a+env'' e opts args body = do+ cmd "begin" $ tex e+ when (not $ null opts) $ brackets $ sequence_ $ map tex $ intersperse "," opts+ mapM_ braces args x <- body- cmd "end" $ Tex e+ cmd "end" $ tex e return x -label = do- l <- Label- cmd "label" (Refer l)+------------------+-- Sorted labels++data SortedLabel = SortedLabel String Label++label :: String -> Tex SortedLabel+label s = do+ l <- Tex newLabel+ cmd "label" (reference l)+ return $ SortedLabel s l++xref :: SortedLabel -> TeX+xref (SortedLabel _ l) = do+ cmd "ref" (reference l)+ return ()++fxref :: SortedLabel -> TeX+fxref l@(SortedLabel s _) = do+ textual s+ tex "~" -- non-breakable space here+ xref l++pageref :: SortedLabel -> TeX+pageref (SortedLabel _ l) = do+ cmd "pageref" (reference l)+ return () -xref l = do- cmd "ref" (Refer l)+instance Element SortedLabel where+ type Target SortedLabel = TeX+ element x = fxref x >> return ()++-----------------+-- Generate boxes++outputAlsoInBoxMode :: Tex a -> Tex a+outputAlsoInBoxMode (Tex a) = Tex $ local moveInBox $ a+ where moveInBox m = case m of+ OutsideBox -> InsideBox+ _ -> m++texAlways = texInMode (const True)++inBoxComputMode :: String -> TeX+inBoxComputMode = texInMode (`elem` [OutsideBox,InsideBox])++whenMode :: Mode -> Tex () -> Tex ()+whenMode mode act = do+ interpretMode <- Tex ask+ when (mode interpretMode) act++inBox :: Tex a -> Tex (a, BoxSpec)+inBox x = do+ inBoxComputMode $ "\n\\savebox{\\marxupbox}{"+ a <- outputAlsoInBoxMode x+ inBoxComputMode $ + "}"+ ++ writeBox "wd"+ ++ writeBox "ht"+ ++ writeBox "dp"+ ++ "\n"+ b <- Tex getBoxSpec++ return (a,b)+ where writeBox l = "\\immediate\\write\\boxesfile{\\number\\"++ l ++"\\marxupbox}"+++justBox :: Tex a -> Tex BoxSpec+justBox x = do+ whenMode (`elem` [OutsideBox, InsideBox]) $ outputAlsoInBoxMode $ do+ tex "\n\\savebox{\\marxupbox}{"+ x+ tex $ + "}"+ ++ writeBox "wd"+ ++ writeBox "ht"+ ++ writeBox "dp"+ ++ "\n"+ b <- Tex getBoxSpec++ return b+ where writeBox l = "\\immediate\\write\\boxesfile{\\number\\"++ l ++"\\marxupbox}"++renderWithBoxes :: [BoxSpec] -> InterpretMode -> Tex a -> String+renderWithBoxes bs mode (Tex t) = doc+ where (_,_,doc) = runRWS (fromMulti $ t) mode (0,bs)++renderSimple :: TeX -> String+renderSimple = renderWithBoxes [] Regular+ +renderTex :: (Bool -> TeX) -> TeX -> IO String+renderTex preamble body = do+ let bxsTex = renderWithBoxes (repeat nilBoxSpec) OutsideBox (wholeDoc True)+ boxesName = "mpboxes"+ boxesTxt = boxesName ++ ".txt"+ wholeDoc inBoxMode = do+ outputAlsoInBoxMode (preamble inBoxMode)+ inBoxComputMode $ "\\newwrite\\boxesfile"+ texAlways "\\begin{document}"+ inBoxComputMode $ "\\immediate\\openout\\boxesfile="++boxesTxt++"\n \\newsavebox{\\marxupbox}"+ body+ inBoxComputMode "\n\\immediate\\closeout\\boxesfile"+ texAlways "\\end{document}"+ writeFile (boxesName ++ ".tex") bxsTex+ system $ "latex " ++ boxesName+ boxes <- do+ e <- doesFileExist boxesTxt+ if e+ then do+ boxData <- map read . lines <$> readFile boxesTxt+ return $ getBoxInfo boxData+ else return []+ putStrLn $ "Number of boxes found: " ++ show (length boxes)+ return $ renderWithBoxes boxes Regular $ (wholeDoc False)++getBoxInfo :: [Int] -> [BoxSpec]+getBoxInfo [] = []+getBoxInfo (width:height:depth:bs) = BoxSpec (scale width) (scale height) (scale depth):getBoxInfo bs+ where scale x = fromIntegral x / 65536+
+ MarXup/Verbatim.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, TypeFamilies,TypeSynonymInstances,FlexibleInstances, PackageImports, DeriveFunctor #-}++module MarXup.Verbatim where++import MarXup+import Control.Monad.Fix++data Verbatim a = Verbatim {fromVerbatim::String, value::a}+ deriving Functor++instance Textual Verbatim where+ textual s = Verbatim s ()++instance Monad Verbatim where+ return x = Verbatim "" x+ (Verbatim s0 x) >>= f =+ Verbatim (s0 ++ s1) y+ where Verbatim s1 y = f x++instance MonadFix Verbatim where+ mfix f = let Verbatim _ x = f x in f x+
examples/LaTeX.hs view
@@ -1,63 +1,187 @@-{-# OPTIONS_GHC -XTypeSynonymInstances -XOverloadedStrings -XDoRec -pgmF marxup -F #-}+{-# OPTIONS_GHC -XTypeSynonymInstances -XOverloadedStrings -XRecursiveDo -pgmF marxup3 -F #-} +import MarXup import MarXup.Latex+import MarXup.Latex.Math+import MarXup.Math import MarXup.Tex import MarXup.DerivationTrees+import MarXup.PrettyPrint as PP hiding (width)+import MarXup.PrettyPrint.Core as PC import Control.Applicative+import Data.Monoid+import Control.Monad (unless)+import MarXup.Diagram+import MarXup.Diagram.Graphviz+import Control.Lens (set)+import Data.GraphViz+import Data.String+import Data.Traversable+import Data.GraphViz.Attributes.Complete+ (Attribute(RankSep,Shape,Label,Margin,Width,Len,RankDir),+ Shape(..),Label(StrLabel),DPoint(..),RankDir(..)) -preamble :: Tex ()-preamble = do- usepackage ["mathletters"] "ucs"- usepackage ["utf8x"] "inputenc"- usepackage [] "graphicx"+data SExp = Atom String | SX [SExp] +prettyS :: SExp -> Tex Doc+prettyS (Atom x) = PP.text (textual x)+prettyS (SX xs) = do+ xs' <- traverse prettyS xs+ enclosure "(" ")" " " xs' -someTree = derivationTree [] $ Node (rule (mbox "modus ponens") "A → B") []+expr :: TeX+expr = do+ d <- prettyS six+ paragraph "1000"+ PC.pretty 1 1000 d+ paragraph "100"+ PC.pretty 1 200 d+ paragraph "10"+ PC.pretty 1 10 d+ where+ three = SX $ map Atom ["arstarsx","wftwfy","varstw","x","M"]+ six = SX [ three , three , three ] -(∶) = binop ":"-γ = cmd "Gamma" nil-(⊢) = binop $ cmd "vdash" nil+preamble inMP = do+ documentClass "article" []+ usepackage "inputenc" ["utf8x"]+ unless inMP $ usepackage "tikz" []+ usepackage "graphicx" [] -x = Tex "x"-y = Tex "y"-a = Tex "a"-b = Tex "b"+-- arrow :: Object -> Object -> Diagram Incidence+-- arrow src trg = using (outline "black" . set endTip ToTip) $ do+-- edge src trg -(≜) = binop "="+autoLab s i = do+ o <- labelObj s+ autoLabel o i -main = render $ latexDocument "article" ["11pt"] preamble $ @"-@intro<-section{Intro}+(▸) = flip (#) +grDiag = graph Dot gr++nod x = DotNode x [Margin (DVal 0),Width 0, Shape Circle, Label $ StrLabel $ fromString x]+edg x y z = DotEdge x y [Label $ StrLabel z, Len 0.1]+gr :: DotGraph String+gr = DotGraph False True Nothing+ (DotStmts [GraphAttrs [RankSep [0.1], RankDir FromLeft]] []+ [nod "A", nod "B", nod "C", nod "D"]+ [edg "A" "B" "1"+ ,edg "A" "C" "2"+ ,edg "B" "D" "3"+ ,edg "D" "A" "4"])++testDiagram = do+ -- draw $ path $ circle (Point 0 0) 5+ a <- labelObj $ ensureMath $ "a"+ b <- labelObj $ ensureMath $ "b"+ a' <- draw $ circleShape -- labelObj $ ensureMath $ "c"+ width a' === 15+ b' <- labelObj $ ensureMath $ "d"+ a'' <- labelObj $ ensureMath $ "."+ b'' <- labelObj $ ensureMath $ "."++ -- c <- texObj $ ensureMath $ "c"+ -- Center ▸ c === MP.center [E ▸ a'', E ▸ b''] + (20 +: 0)++ let width = 70+ vdist b a === 30+ hdist a a' === width+ hdist a' a'' === width+ alignMatrix [[Center ▸ a, Center ▸ a',Center ▸ a'']+ ,[Center ▸ b, Center ▸ b',Center ▸ b'']+ ]+ autoLab "bing" =<< arrow a a'+ autoLab "bang" =<< arrow b b'+ autoLab "oops" . swap =<< arrow a b+ autoLab "pif" =<< arrow a' a''+ autoLab "paf" =<< arrow b' b'' ++ draw $ do+ autoLab "equal" =<< edge a'' b''+ return ()++ax c = Rule {delimiter = mempty, ruleStyle = outline "black", ruleLabel = mempty, conclusion = c}++someTree = derivationTreeD $ Node (rule ("modus ponens") "B")+ [defaultLink ::> Node (ax "X") []+ ,defaultLink {steps = 0} ::> Node (rule "" "A")+ [defaultLink {steps = 0} ::> Node (rule (braces $ cmd0 "small" <> "mystery") "A1")+ [defaultLink ::> Node (ax "Y") []+ ,defaultLink ::> Node (rule "" "A2")+ [defaultLink ::> Node (rule "" "A3")+ [defaultLink ::> Node (ax "Z") []]]]]+ ,defaultLink {steps = 3} ::> Node (rule "abs" "A --> B")+ [defaultLink ::> Node (rule "" "B")+ [defaultLink ::> Node (ax "A") []+ ]+ ]+ ]++(∶) = binop 2 ", "+γ = Con $ cmd "Gamma" nil+(⊢) = binop 1 (cmd0 "vdash")++x = Con "x"+y = Con "y"+a = Con "a"+b = Con "b"++(≜) = binop 1 "="++main = writeFile ("LaTeX.tex") =<< renderTex preamble «++@intro<-section«Intro»+ At-syntax is used to call a Haskell function. The result can be bound.-For example, the @sf{section} command returns a label that can be used+For example, the @sans«section» command returns a label that can be used for references. This is section @xref(intro). Note that cross-references are checked at ``compile-time''. Forward references also work (see sec. @xref(concl)). -@section{Markup}+@section«Markup» -Here comes @sf{some sans-serif text with @em{emphasis}!}+Here comes @sans«some sans-serif text with @emph«emphasis»!» Note that arguments put in braces are markup. --@section{Math}+@section«Math» Arguments in parenthesis are Haskell. Combined with unicode syntax,-this can make writing all sorts of mathy stuff rather pleasant. For-example: @math(γ ⊢ x ∶ a).+this can make writing all sorts mathy stuff rather pleasant. For+example: @(γ ⊢ x ∶ a). The operators are overloaded to work on text as well:-@displayMath(b ≜ sqrt (a + (x/y)))+@display(b ≜ sqrt (a * (b + (x/y)))) +There is also special support for derivation trees: -@concl<-section{Conclusion}+@section«Pretty Printer»+@expr +@section«Derivation Trees» +Here is some derivation tree: -Marχup is awesome.+@someTree -@"+@section«Diagrams»++One can also draw diagrams:+@testDiagram++@section«Graphviz»++There is partial, rudimentary support for layout of graphs using graphviz.++grDiag+++@concl<-section«Conclusion»++Mar@ensureMath«@cmd0"chi"»up is awesome :p .++»
marxup.cabal view
@@ -1,5 +1,5 @@ name: marxup-version: 1.0.2+version: 3.0.0 category: Text synopsis: Markup language preprocessor for Haskell description:@@ -18,26 +18,62 @@ examples/LaTeX.hs -executable marxup+-- executable marxup+-- extensions: FlexibleInstances, TupleSections+-- main-is: Main.hs+-- build-depends: base>=4.2&&<=5+-- build-depends: pretty==1.1.*+-- build-depends: parsec>=3+-- build-depends: dlist>=0.5++executable marxup3 extensions: FlexibleInstances, TupleSections- main-is: Main.hs- build-depends: base>=4.2&&<=5+ main-is: Main3.hs+ build-depends: configurator>=0.2&&<2+ build-depends: base>=4.2&&<=58 build-depends: pretty==1.1.*- build-depends: parsec==2.1.*+ build-depends: parsek==1.*+ build-depends: dlist>=0.7 library extensions: FlexibleInstances, TypeSynonymInstances, GADTs- build-depends: base==4.*--- build-depends: pandoc==1.5.* (broken)- build-depends: mtl==2.1.*- build-depends: labeled-tree==1.* - build-depends: filepath==1.3.* + build-depends: base>=4.2&&<5+-- build-depends: pandoc==1.5.* (support broken)+ build-depends: mtl>=2.1+ build-depends: labeled-tree==1.*+ build-depends: filepath==1.3.*+ build-depends: containers>=0.4 &&<1+ build-depends: process>=1.1+ build-depends: glpk-hs>=0.3.4+ build-depends: cubicbezier>=0.2+ build-depends: lens>=3.10+ build-depends: directory>=1.2+ build-depends: typography-geometry+ build-depends: polynomials-bernstein==1.*+ build-depends: vector+ build-depends: graphviz+ build-depends: text + exposed-modules: MarXup exposed-modules: MarXup.Tex- exposed-modules: MarXup.MetaPost exposed-modules: MarXup.Latex+ exposed-modules: MarXup.Latex.Math+ exposed-modules: MarXup.Math+ exposed-modules: MarXup.Latex.Bib exposed-modules: MarXup.Beamer- exposed-modules: MarXup.DerivationTrees + exposed-modules: MarXup.DerivationTrees exposed-modules: MarXup.Text+ exposed-modules: MarXup.Diagram+ exposed-modules: MarXup.Diagram.Object+ exposed-modules: MarXup.Diagram.Path+ exposed-modules: MarXup.Diagram.Point+ exposed-modules: MarXup.Diagram.Layout+ exposed-modules: MarXup.Diagram.Tikz+ exposed-modules: MarXup.Diagram.Graphviz+ exposed-modules: MarXup.MultiRef+ exposed-modules: MarXup.Verbatim+ exposed-modules: MarXup.PrettyPrint.Core+ exposed-modules: MarXup.PrettyPrint+ -- exposed-modules: MarXup.Pandoc (broken)