{- |

Module : $Header$

Description : auxiliary functions for LaTeX printing

Copyright : (c) Klaus L�ttich, Uni Bremen 2002-2006

License : similar to LGPL, see HetCATS/LICENSE.txt or LIZENZ.txt

Maintainer : luettich@tzi.de

Stability : provisional

Portability : portable

Auxiliary functions for LaTeX printing

Functions to calculate the length of a given word as it would be

printed with LaTeX according to one of four categories of words

useful for CASL:

* keywords -- all the things that were printed in boldface

* structid -- all the names used in the structured context of CASL

* annotation -- all the comments and annotations of CASL in a smaller font

* axiom -- identifiers in math mode for CASL Basic specs

-}

{-

TODO:

- itCorrection should be based on a map of character pairs to

corrections and not on one fixed value for every pair

-}

module Common.LaTeX_funs

( calc_line_length

, axiom_width

, latex_macro

, flushright

, casl_comment_latex

, casl_normal_latex

, hc_sty_small_keyword

, hc_sty_plain_keyword

, hc_sty_casl_keyword

, hc_sty_axiom

, hc_sty_structid

, hc_sty_structid_indexed

, hc_sty_id

, startTab, endTab, setTab

, setTabWSp

, startAnno

, endAnno

, escapeLatex

) where

import qualified Data.Map as Map

import Data.Char

import Data.List (isPrefixOf)

import Common.LaTeX_maps

import Common.Lib.Pretty as Pretty

import Text.ParserCombinators.Parsec as Parsec

-- |

-- a constant String for starting a LaTeX indentation with tab stop

startTab :: String

startTab = "\\@begT@"

-- |

-- a constant String for releasing a LaTeX indentation with tab stop

endTab :: String

endTab = "\\@endT@"

-- |

-- a constant String to set a tab stop and enable it

setTab :: String

setTab = "\\="

-- | a constant String indicating the start of a space based indentation

setTabWSp :: String

setTabWSp = "\\@setTS@{"

{- functions for calculating an integer value according to a given

length in LaTeX units

Units per mm found in: Karsten G�nther, "Einf�hrung in LaTeX2e" (p.376)

-}

calc_line_length :: String -> Int

calc_line_length s =

let (r_unit,r_number) =

(\(x,y) -> (reverse x,reverse y)) $ span isAlpha $ reverse s

unit = case r_unit of

"mm" -> 1

"cm" -> 10

"pt" -> 0.351

"in" -> 25.4

u -> error ( "unknown or unsupported LaTeX unit: " ++ u )

len :: Double

len = read $ map (\c -> case c of ',' -> '.';_ -> c) r_number

in truncate (len * unit * 1000)

{- functions to calculate a word-width in integer with a given word

type or purpose

-}

data Word_type =

Keyword | StructId | Normal | Comment | Annotation | AnnotationBold | Axiom

deriving (Show,Eq)

calc_word_width :: Word_type -> String -> Int

calc_word_width wt s =

case Map.lookup s wFM of

Just l -> l

Nothing -> sum_char_width_deb ( showString "In map \""

. showsPrec 0 wt

. showString "\" \'") wFM k_wFM s

- correction

where (wFM,k_wFM) = case wt of

Keyword -> (keyword_map,key_keyword_map)

StructId -> (structid_map,key_structid_map)

Comment -> (comment_map,key_comment_map)

Annotation -> (annotation_map,key_annotation_map)

AnnotationBold -> (annotationbf_map,

key_annotationbf_map)

Axiom -> (axiom_map,key_axiom_map)

Normal -> (normal_map,key_normal_map)

correction = case wt of

Axiom -> itCorrection s

_ -> 0

itCorrection :: String -> Int

itCorrection [] = 0

itCorrection s

| length s < 2 || head s == '\\' = 0

| otherwise = itCorrection' 0 s

where itCorrection' :: Int -> String -> Int

itCorrection' _ [] = error "itCorrection' applied to empty List"

itCorrection' r ys@(y1:[y2])

| not (isAlphaNum y1) = r

| not (isAlphaNum y2) = r

| otherwise = r + lookupCorrection ys

itCorrection' r (y1:(ys@(y2:_)))

| not (isAlphaNum y1) = itCorrection' r ys

| otherwise =

itCorrection'

(r + lookupCorrection (y1:y2:[]))

ys

itCorrection' _ _ = error ("itCorrection' doesn't work with " ++ s)

lookupCorrection str = Map.findWithDefault def_cor str

italiccorrection_map

-- TODO: Build a nice correction map

def_cor = 610

sum_char_width_deb :: (String -> String) -- only used for an hackie debug thing

-> Map.Map String Int

-> Map.Map Char [String] -> String -> Int

sum_char_width_deb _pref_fun cFM key_cFM s = sum_char_width' s 0

where sum_char_width' [] r = r

sum_char_width' [c] r

| c == ' ' = r + lookupWithDefault_cFM "~"

| otherwise = r + lookupWithDefault_cFM (c:[])

sum_char_width' full@(c1:rest@(c2:cs)) r

| isLigature (c1:c2:[]) = case Map.lookup (c1:c2:[]) cFM of

Just l -> sum_char_width' cs (r+l)

Nothing -> sum_char_width' rest nl

| (c1:c2:[]) == "\\ " =

sum_char_width' cs (r + lookupWithDefault_cFM "~")

| c1 == ' ' =

sum_char_width' rest (r + lookupWithDefault_cFM "~")

| otherwise = case prefixIsKey full key_cFM of

Just key -> sum_char_width'

(drop (length key) full)

$ r + (cFM Map.! key)

Nothing -> if c1 == '\\' then

sum_char_width'

(dropWhile isAlpha rest)

$ r + lookupWithDefault_cFM "~"

else sum_char_width' rest nl

where nl = r + lookupWithDefault_cFM (c1:[])

lookupWithDefault_cFM s' = case Map.lookup s' cFM of

Nothing -> 2200 -- do something here?

Just w -> w

prefixIsKey :: String -> Map.Map Char [String] -> Maybe String

prefixIsKey [] _ = Nothing

prefixIsKey ls@(c:_) key_cFM = case filter (flip isPrefixOf ls)

$ Map.findWithDefault [] c key_cFM of

[] -> Nothing

s : _ -> Just s

isLigature :: String -> Bool

isLigature s

| (length s) /= 2 = False

| otherwise = Map.findWithDefault False s ligatures

keyword_width, structid_width, axiom_width, annotationbf_width,

comment_width, normal_width :: String -> Int

annotationbf_width = calc_word_width AnnotationBold

keyword_width = calc_word_width Keyword

structid_width = calc_word_width StructId

comment_width = calc_word_width Comment

normal_width = calc_word_width Normal

axiom_width = sum . map (calc_word_width Axiom) . parseAxiomString

-- |

-- latex_macro creates a document ('Doc') containing String

-- that has a zero width.

-- So it can be used for LaTeX-macros not needing any space, i.e.

-- @\textit{@ or @}@

latex_macro :: String -> Doc

latex_macro = sp_text 0

casl_keyword_latex, casl_annotationbf_latex,

casl_axiom_latex,

casl_comment_latex, casl_structid_latex,

casl_normal_latex :: String -> Doc

casl_annotationbf_latex s = sp_text (annotationbf_width s) s

casl_structid_latex s = sp_text (structid_width s) s

casl_comment_latex s = sp_text (comment_width s) s

casl_keyword_latex s = sp_text (keyword_width s) s

casl_normal_latex s = sp_text (normal_width s) s

casl_axiom_latex s = sp_text (axiom_width s) s

-- | sort, op, pred, type and its plurals

hc_sty_casl_keyword :: String -> Doc

hc_sty_casl_keyword str =

sp_text (keyword_width "preds") $ "\\" ++ map toUpper str

hc_sty_plain_keyword :: String -> Doc

hc_sty_plain_keyword kw =

latex_macro "\\KW{" <> casl_keyword_latex (escapeUnderline kw)

<> latex_macro "}"

hc_sty_small_keyword :: String -> Doc

hc_sty_small_keyword kw =

latex_macro "\\KW{" <> casl_annotationbf_latex (escapeUnderline kw)

<> latex_macro "}"

hc_sty_axiom, hc_sty_structid, hc_sty_id,hc_sty_structid_indexed

:: String -> Doc

hc_sty_structid sid = latex_macro "\\SId{"<>sid_doc<>latex_macro "}"

where sid_doc = casl_structid_latex (escapeUnderline sid)

hc_sty_structid_indexed sid =

latex_macro "\\SIdIndex{"<>sid_doc<>latex_macro "}"

where sid_doc = casl_structid_latex (escapeUnderline sid)

hc_sty_id i = latex_macro "\\Id{"<>id_doc<>latex_macro "}"

where id_doc = casl_axiom_latex i

hc_sty_axiom ax = latex_macro "\\Ax{"<>ax_doc<>latex_macro "}"

where ax_doc = casl_axiom_latex ax

-- | flush argument doc to the right

flushright :: Doc -> Doc

flushright d = latex_macro "\\`" <> d

-- |

-- a constant String for the start of annotations

startAnno :: String

startAnno = "{\\small{}"

-- |

-- a constant string ending an annotation

endAnno :: String

endAnno = "%@%small@}"

escapeUnderline :: String -> String

escapeUnderline = concatMap ( \ c -> if c == '_' then "\\_" else [c])

escapeLatex :: Bool -> String -> String

escapeLatex addAx = concatMap ( \ c ->

if elem c "_%$&{}#" then

if addAx then "\\Ax{\\" ++ c : "}"

else '\\' : [c]

else if addAx && elem c "<|>=-!()[]?:;,./*+@" then "\\Ax{" ++ c : "}"

else Map.findWithDefault [c] c escapeMap)

parseAxiomString :: String -> [String]

parseAxiomString s = case parse axiomString "" s of

Left _ -> [s]

Right l -> l

axiomString :: CharParser st [String]

axiomString = do

l <- many parseAtom

eof

return $ concat l

parseAtom :: CharParser st [String]

parseAtom = do

try (string "\\Ax{") <|> try (string "\\Id{") <|> string "{"

l <- many parseAtom

Parsec.char '}'

return (concat l)

<|> do

b <- Parsec.char '\\'

s <- fmap (: []) (satisfy (\ c -> isSpace c

|| elem c "_~^|\'\",;:.`\\{}[]%$&#()"))

<|> many1 (satisfy isAlpha)

return [b : s]

<|> do

s <- many1 (satisfy isAlpha)

return [s]

<|> do

c <- satisfy (/= '}')

return [[c]]

-- | a character map for special latex characters

escapeMap :: Map.Map Char String

escapeMap = Map.fromList

[('\\',"\\Ax{\\setminus}"),

('^',"\\Ax{\\hat{\\ }}"),

('"',"''"),

('~',"\\Ax{\\sim}"),

('\160',"\\ "),

('\162',"\\Id{\\textcent}"),

('\164',"\\Id{\\textcurrency}"),

('\165',"\\Id{\\textyen}"),

('\166',"\\Id{\\textbrokenbar}"),

('\170',"\\Id{\\textordfeminine}"),

('\171',"\\Id{\\guillemotleft}"),

('\172',"\\Ax{\\neg}"),

('\173',"-"),

('\174',"\\Id{\\textregistered}"),

('\175',"\\Ax{\\bar{\\ }}"),

('\176',"\\Id{\\textdegree}"),

('\177',"\\Ax{\\pm}"),

('\178',"\\Ax{^2}"),

('\179',"\\Ax{^3}"),

('\180',"\\Ax{\\acute{\\ }}"),

('\181',"\\Ax{\\mu}"),

('\185',"\\Ax{^1}"),

('\186',"\\Id{\\textordmasculine}"),

('\187',"\\Id{\\guillemotright}"),

('\192',"\\Ax{\\grave{A}}"),

('\193',"\\Ax{\\acute{A}}"),

('\200',"\\Ax{\\grave{E}}"),

('\201',"\\Ax{\\acute{E}}"),

('\204',"\\Ax{\\grave{I}}"),

('\205',"\\Ax{\\acute{I}}"),

('\208',"\\Id{\\DH}"),

('\210',"\\Ax{\\grave{O}}"),

('\211',"\\Ax{\\acute{O}}"),

('\215',"\\Ax{\\times}"),

('\217',"\\Ax{\\grave{U}}"),

('\218',"\\Ax{\\acute{U}}"),

('\221',"\\Ax{\\acute{Y}}"),

('\222',"\\Id{\\TH}"),

('\224',"\\Ax{\\grave{a}}"),

('\225',"\\Ax{\\acute{a}}"),

('\232',"\\Ax{\\grave{e}}"),

('\233',"\\Ax{\\acute{e}}"),

('\236',"\\Ax{\\grave{\\Id{\\i}}}"),

('\237',"\\Ax{\\acute{\\Id{\\i}}}"),

('\240',"\\Id{\\dh}"),

('\242',"\\Ax{\\grave{o}}"),

('\243',"\\Ax{\\acute{o}}"),

('\247',"\\Ax{\\div}"),

('\249',"\\Ax{\\grave{u}}"),

('\250',"\\Ax{\\acute{u}}"),

('\253',"\\Ax{\\acute{y}}"),

('\254',"\\Id{\\th}")]

{- acute and grave characters don't work in a tabbing environment

\textcent upto textbrokenbar requires \usepackage{textcomp}

whereas \guillemot, eth, and thorn \usepackage[T1]{fontenc}

-}