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

capricon/src/CaPriCon/Run.hs

@@ -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)

capricon/src/Data/CaPriCon.hs

@@ -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"

curly/data/emacs/curly-utils.el

@@ -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))

logos/src/Data/Font.hs

@@ -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)