Vous avez reçu un message "Your GitLab account has been locked ..." ? Pas d'inquiétude : lisez cet article https://docs.gricad-pages.univ-grenoble-alpes.fr/help/unlock/

Commit 46445ee7 authored by Marc Coiffier's avatar Marc Coiffier
Browse files

Start offering basic SVG generation of formulae with the %g format in CaPriCon

parent 67bf7e8c
......@@ -199,6 +199,7 @@ runCOCBuiltin COCB_Format = do
ex <- runExtraState get
let format ('%':'s':s) (StackSymbol h:t) = first (h+) (format s t)
format ('%':'v':s) (x:t) = first (showStackVal doc2raw (ex^.showDir) (ex^.context) x+) (format s t)
format ('%':'g':s) (x:t) = first (showStackVal doc2svg (ex^.showDir) (ex^.context) x+) (format s t)
format ('%':'l':s) (x:t) = first (showStackVal doc2latex (ex^.showDir) (ex^.context) x+) (format s t)
format (c:s) t = first (fromString [c]+) (format s t)
format "" t = ("",t)
......
......@@ -8,7 +8,7 @@ module Data.CaPriCon(
StringPattern,NodeDir(..),AHDir(..),ApDir,
findPattern,freshContext,
-- * Showing nodes
ListBuilder(..),NodeDoc(..),doc2raw,doc2latex,showNode,showNode'
ListBuilder(..),NodeDoc(..),doc2raw,doc2latex,doc2svg,showNode,showNode'
) where
import Definitive
......@@ -379,6 +379,7 @@ data NodeDoc str = DocSeq [NodeDoc str]
| DocParen (NodeDoc str)
| DocMu (NodeDoc str)
| DocSubscript (NodeDoc str) (NodeDoc str)
| DocSuperscript (NodeDoc str) (NodeDoc str)
| DocAssoc str (NodeDoc str)
| DocVarName str
| DocText str
......@@ -393,6 +394,7 @@ instance Functor NodeDoc where
map f (DocParen x) = DocParen (map f x)
map f (DocMu x) = DocMu (map f x)
map f (DocSubscript x y) = DocSubscript (map f x) (map f y)
map f (DocSuperscript x y) = DocSuperscript (map f x) (map f y)
map f (DocAssoc v x) = DocAssoc (f v) (map f x)
map f (DocText x) = DocText (f x)
map f (DocVarName x) = DocVarName (f x)
......@@ -405,6 +407,7 @@ doc2raw (DocSeq l) = fold (map doc2raw l)
doc2raw (DocParen p) = "("+doc2raw p+")"
doc2raw (DocMu m) = "μ("+doc2raw m+")"
doc2raw (DocSubscript v x) = doc2raw v+doc2raw x
doc2raw (DocSuperscript v x) = doc2raw v+"^"+doc2raw x
doc2raw (DocAssoc x v) = "("+x+" : "+doc2raw v+")"
doc2raw DocArrow = " -> "
doc2raw (DocText x) = x
......@@ -416,12 +419,40 @@ doc2latex (DocSeq l) = fold (map doc2latex l)
doc2latex (DocParen p) = "("+doc2latex p+")"
doc2latex (DocMu m) = "\\mu("+doc2latex m+")"
doc2latex (DocSubscript v x) = doc2latex v+"_{"+doc2latex x+"}"
doc2latex (DocSuperscript v x) = doc2latex v+"^{"+doc2latex x+"}"
doc2latex (DocAssoc x v) = "("+latexName x+":"+doc2latex v+")"
doc2latex DocArrow = " \\rightarrow "
doc2latex (DocText x) = x
doc2latex (DocVarName x) = latexName x
doc2latex DocSpace = "\\,"
doc2svg :: IsCapriconString str => NodeDoc str -> str
doc2svg = \x -> snd $ (go x^.from state) (0::Double)
where
sym s = get >>= \x -> if x == 0 then return s
else ("<tspan dy=\""+fromString (show x)+"em\">"+s+"</tspan>") <$ put 0
go (DocSeq l) = fold<$>traverse go l
go (DocParen p) = liftA3 (\x y z -> x+y+z) (sym "(") (go p) (sym ")")
go (DocMu m) = liftA3 (\x y z -> x+y+z) (sym "μ(") (go m) (sym ")")
go (DocSubscript v x) = sub (go v) (go x)
go (DocSuperscript v x) = super (go v) (go x)
go (DocAssoc x v) = fold<$>sequence [sym "(",svgName x,sym ":",go v,sym ")"]
go DocArrow = sym " → "
go (DocText x) = sym x
go (DocVarName x) = svgName x
go DocSpace = sym " "
super mv mx = liftA2 (\x y -> x+"<tspan dy=\"-0.5em\"><tspan class=\"small\">"+y+"</tspan></tspan>") mv (mx <* put (0.5))
sub mv mx = liftA2 (\x y -> x+"<tspan dy=\"0.3em\"><tspan class=\"small\">"+y+"</tspan></tspan>") mv (mx <* put (-0.3))
svgName s = map (\x -> "<tspan class=\"variable\">"+x+"</tspan>") $ nm $ toString s
where nm ('.':t) = super (nm t) (sym "P")
nm x =
let (n,y) = span (\c -> c>='0' && c<='9') (reverse x) in
case n of
"" -> sym (fromString (reverse y))
_ -> sub (sym (fromString (reverse y))) (sym (fromString (reverse n)))
latexName :: IsCapriconString str => str -> str
latexName s = fromString $ go $ toString s
where go ('.':t) = go t+"^P"
......
......@@ -64,6 +64,33 @@
) args ""))
(_ args)))
(princ
(curly-lambda-match
((:many . e)
(concat "\\(?:" (apply 'curly-re-construct e) "\\)*"))
((:optional . e)
(concat "\\(?:" (apply 'curly-re-construct e) "\\)?"))
((:sep-by sep . e)
(concat (apply 'curly-re-construct e)
"\\(?:" (curly-re-construct sep) (apply 'curly-re-construct e) "\\)*"))
((:or . e)
(concat "\\(?:" (mapconcat 'curly-re-construct e "\\|") "\\)"))
((:capture . e)
(concat "\\(" (apply 'curly-re-construct e) "\\)"))
((:partial e) (curly-re-construct e))
((:partial e . es)
(concat (curly-re-construct e) (curly-re-construct `(:optional (:partial . ,es)))))
(:bol "^")
(:eol "$")
(:bow "\\<")
(:eow "\\>")
(:word "\\<\\sw*[^[:blank:]:=]")
(:spc "\\s-*")
(:nbsp "\\s-+")
((@ l (_ . _)) (apply 'curly-re-construct l))
(x x)
))
(defmacro curly-regex (&rest args) (curly-re-construct args))
(defmacro curly-keyword (re &rest args)
"" (declare (indent 1))
......
......@@ -72,7 +72,8 @@ instance Semigroup CellMetrics where
CellMetrics (lw+rw) (lw'+rw') (max bh bh') (max th th')
data CellCoords = CellCoords {
cellX,cellY :: Int,
cellMetrics :: CellMetrics
cellMetrics :: CellMetrics,
glyphMetrics :: CellMetrics
}
deriving Show
data StringImage = StringImage {
......@@ -126,14 +127,20 @@ renderString fc (RenderParams sz align mode) str = withFacePtr fc $ \fcp -> do
start | incr > 0 = FTBMP.buffer bmp`plusPtr`((h-1)*incr)
| otherwise = FTBMP.buffer bmp
rowPtrs = iterate (`plusPtr`negate incr) start
adv = fromIntegral (FT.horiAdvance m`div`64)
-- putStrLn $ "Copying rows of size "++show w++" from "++show start++" to "++show (pret`plusPtr`dx)++" (size "++show (sizeX-dx)++")"
for_ (take h rowPtrs `zip` iterate (`plusPtr`sizeX) (pret `plusPtr` dx)) $ \(rowsrc,rowdst) -> do
copyArray rowdst rowsrc w
k (dx + adv) (insert c (CellCoords dx 0 (CellMetrics adv h
(fromIntegral (FT.horiBearingX m)`div`64 + w`div`2)
(fromIntegral (FT.height m P.- FT.horiBearingY m)`div`64))) ret)
let adv = fromIntegral (FT.horiAdvance m`div`64)
bearX = fromIntegral (FT.horiBearingX m`div`64)
bearY = fromIntegral (FT.horiBearingX m`div`64)
mh = fromIntegral (FT.height m`div`64)
mw = fromIntegral (FT.width m`div`64)
k (dx + adv) (insert c (CellCoords dx 0
(let lw = bearX + mw`div`2 in
CellMetrics lw (adv-lw) (mh-bearY) bearY)
(let lw = mw`div`2 in
CellMetrics lw (mw-lw) (mh-bearY) bearY)) ret)
return (StringImage sizeX sizeY (V.unsafeFromForeignPtr0 ret (sizeX*sizeY)) cs)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment