SVGFonts 1.4.0.3 → 1.5.0.0
raw patch · 10 files changed
+529/−440 lines, 10 filesdep +diagrams-coredep −vector-spacedep ~diagrams-lib
Dependencies added: diagrams-core
Dependencies removed: vector-space
Dependency ranges changed: diagrams-lib
Files
- CHANGES.md +10/−0
- LICENSE +2/−0
- README.md +7/−2
- SVGFonts.cabal +84/−82
- src/Graphics/SVGFonts.hs +6/−4
- src/Graphics/SVGFonts/Fonts.hs +34/−0
- src/Graphics/SVGFonts/ReadFont.hs +157/−300
- src/Graphics/SVGFonts/ReadPath.hs +39/−42
- src/Graphics/SVGFonts/Text.hs +180/−0
- src/Graphics/SVGFonts/WriteFont.hs +10/−10
CHANGES.md view
@@ -1,3 +1,13 @@+1.5.0.0 (19 April 2015)+-----------------------++- Split functionality out of `ReadFont`, into `Fonts` (built-in fonts) and+ `Text` (rendering text to Diagrams).+- `textSVG'` and `textSVG_` now have the text as a separate argument,+ distinct from `TextOptions`.+- `ReadFont` does not use `unsafePerformIO` any more. `unsafePerformIO` is+ now only used to load built-in fonts.+ 1.4.0.3 (2 June 2014) ----------------------
LICENSE view
@@ -2,7 +2,9 @@ Jan Bracker <jan.bracker@googlemail.com> Chris Mears <chris@cmears.id.au> + Jeffrey Rosenbluth <jeffrey.rosenbluth@gmail.com> Tillmann Vogt <tillk.vogt@googlemail.com> + Robert Vollmert <rvollmert@gmx.net> Ryan Yates <ryates@cs.rochester.edu> Brent Yorgey <byorgey@gmail.com>
README.md view
@@ -31,13 +31,18 @@ import Diagrams.Prelude import Diagrams.Backend.Cairo.CmdLine-import Graphics.SVGFonts.ReadFont+import Graphics.SVGFonts main = defaultMain ( (text' "Hello World") <> (rect 8 1) # alignBL ) text' t = stroke (textSVG t 1) # fc purple # fillRule EvenOdd-text'' t = stroke (textSVG_ $ TextOpts t lin INSIDE_H KERN 1 1 )+text'' t = stroke (textSVG_ (TextOpts lin INSIDE_H KERN True 1 1) t) # fc purple # fillRule EvenOdd++-- using a local font+text''' t = do+ font <- loadFont "path/to/font.xml"+ return $ stroke (textSVG' (TextOpts font INSIDE_H KERN False 1 1) t) ``` ## Usage
SVGFonts.cabal view
@@ -1,82 +1,84 @@-Name: SVGFonts -Version: 1.4.0.3 -Synopsis: Fonts from the SVG-Font format -Description: Native font support for the diagrams framework (<http://projects.haskell.org/diagrams/>). Note that this package can be used with any diagrams backend, not just the SVG backend. The SVG-font format is easy to parse - and was therefore chosen for a font library completely written in Haskell. - . - You can convert your own font to SVG with <http://fontforge.sourceforge.net/>, or use the included LinLibertine and Bitstream fonts. - . - Features: - . - * Complete implementation of the features that Fontforge produces (though not the complete SVG format) - . - * Kerning (/i.e./ the two characters in \"VA\" are closer than the characters in \"VV\") - . - * Unicode - . - * Ligatures - . - * An example that shows how to do text boxes with syntax highlighting using highlighting-kate: - <http://hackage.haskell.org/package/highlighting-kate> - . - XML speed issues can be solved by trimming the svg file to only those characters that are used (or maybe binary xml one day). - . - Version 1.0 of this library supports texturing, though this would only sense in a diagrams backend that does rasterization in Haskell. - . - Example: - . - > # LANGUAGE NoMonomorphismRestriction # - > - > import Diagrams.Prelude - > import Diagrams.Backend.Cairo.CmdLine - > import Graphics.SVGFonts.ReadFont (textSVG) - > - > main = defaultMain (text' "Hello World") - > - > text' t = stroke (textSVG t 1) # fc purple # fillRule EvenOdd - > text'' t = stroke (textSVG' $ TextOpts t lin INSIDE_H KERN False 1 1 ) # fillRule EvenOdd - > text''' t = (textSVG_ $ TextOpts t lin INSIDE_H KERN True 1 1 ) # fillRule EvenOdd - . -category: Graphics -License: BSD3 -License-file: LICENSE -Author: Tillmann Vogt -Maintainer: diagrams-discuss@googlegroups.com -build-type: Simple -Cabal-Version: >=1.10 - -data-files: fonts/*.svg -extra-source-files: CHANGES.md, README.md, diagrams/*.svg -extra-doc-files: diagrams/*.svg - -source-repository head - type: git - location: https://github.com/diagrams/SVGFonts.git - -Library - hs-source-dirs: src - ghc-options: -W -Wall -fno-warn-unused-do-bind - other-modules: Paths_SVGFonts - build-depends: - attoparsec, - base == 4.*, - containers >= 0.4 && < 0.6, - data-default-class < 0.1, - diagrams-lib >= 0.7 && < 1.3, - directory >= 1.1, - blaze-svg >= 0.3.3, - blaze-markup >= 0.5, - parsec, - split, - text, - tuple, - vector, - vector-space, - xml - exposed-modules: - Graphics.SVGFonts - Graphics.SVGFonts.ReadFont - Graphics.SVGFonts.CharReference - Graphics.SVGFonts.ReadPath - Graphics.SVGFonts.WriteFont - default-language: Haskell2010 +Name: SVGFonts+Version: 1.5.0.0+Synopsis: Fonts from the SVG-Font format+Description: Native font support for the diagrams framework (<http://projects.haskell.org/diagrams/>). Note that this package can be used with any diagrams backend, not just the SVG backend. The SVG-font format is easy to parse+ and was therefore chosen for a font library completely written in Haskell.+ .+ You can convert your own font to SVG with <http://fontforge.sourceforge.net/>, or use the included LinLibertine and Bitstream fonts.+ .+ Features:+ .+ * Complete implementation of the features that Fontforge produces (though not the complete SVG format)+ .+ * Kerning (/i.e./ the two characters in \"VA\" are closer than the characters in \"VV\")+ .+ * Unicode+ .+ * Ligatures+ .+ * An example that shows how to do text boxes with syntax highlighting using highlighting-kate:+ <http://hackage.haskell.org/package/highlighting-kate>+ .+ XML speed issues can be solved by trimming the svg file to only those characters that are used (or maybe binary xml one day).+ .+ Version 1.0 of this library supports texturing, though this only makes sense in a diagrams backend that does rasterization in Haskell, such as diagrams-rasterific.+ .+ Example:+ .+ > # LANGUAGE NoMonomorphismRestriction #+ >+ > import Diagrams.Prelude+ > import Diagrams.Backend.Rasterific.CmdLine+ > import Graphics.SVGFonts+ >+ > main = defaultMain (text' "Hello World")+ >+ > text' t = stroke (textSVG t 1) # fc purple # fillRule EvenOdd+ > text'' t = stroke (textSVG' (TextOpts lin INSIDE_H KERN False 1 1) t) # fillRule EvenOdd+ > text''' t = (textSVG_ (TextOpts lin INSIDE_H KERN True 1 1) t) # fillRule EvenOdd+ .+category: Graphics+License: BSD3+License-file: LICENSE+Author: Tillmann Vogt+Maintainer: diagrams-discuss@googlegroups.com+build-type: Simple+Cabal-Version: >=1.10++data-files: fonts/*.svg+extra-source-files: CHANGES.md, README.md, diagrams/*.svg+extra-doc-files: diagrams/*.svg+Tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.1+source-repository head+ type: git+ location: https://github.com/diagrams/SVGFonts.git++Library+ hs-source-dirs: src+ ghc-options: -W -Wall -fno-warn-unused-do-bind+ other-modules: Paths_SVGFonts+ build-depends:+ attoparsec,+ base == 4.*,+ containers >= 0.4 && < 0.6,+ data-default-class < 0.1,+ diagrams-core >= 1.3 && < 1.4,+ diagrams-lib >= 1.3 && < 1.4,+ directory >= 1.1,+ blaze-svg >= 0.3.3,+ blaze-markup >= 0.5,+ parsec,+ split,+ text,+ tuple,+ vector,+ xml+ exposed-modules:+ Graphics.SVGFonts+ Graphics.SVGFonts.Text+ Graphics.SVGFonts.ReadFont+ Graphics.SVGFonts.Fonts+ Graphics.SVGFonts.CharReference+ Graphics.SVGFonts.ReadPath+ Graphics.SVGFonts.WriteFont+ default-language: Haskell2010
src/Graphics/SVGFonts.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}- module Graphics.SVGFonts ( -- * Drawing text@@ -11,7 +8,12 @@ -- * Provided fonts , bit, lin, lin2++ -- * Loading fonts+ , loadFont ) where -import Graphics.SVGFonts.ReadFont+import Graphics.SVGFonts.Text+import Graphics.SVGFonts.Fonts (bit, lin, lin2)+import Graphics.SVGFonts.ReadFont (loadFont)
+ src/Graphics/SVGFonts/Fonts.hs view
@@ -0,0 +1,34 @@+module Graphics.SVGFonts.Fonts+ ( -- * Built-in fonts+ bit, lin, lin2+ ) where++import System.IO.Unsafe (unsafePerformIO)++import Graphics.SVGFonts.ReadFont (loadFont, PreparedFont)+import Paths_SVGFonts (getDataFileName)++-- | Get full path of data file.+-- Safe if package is installed correctly.+dataFile :: FilePath -> FilePath+dataFile = unsafePerformIO . getDataFileName++-- | Load a font from a file in the data directory.+loadDataFont :: (Read n, RealFloat n) =>+ FilePath -> PreparedFont n+loadDataFont = unsafePerformIO . loadFont . dataFile++-- | Bitstream, a standard monospaced font (used in gedit)+bit :: (Read n, RealFloat n) => PreparedFont n+bit = loadDataFont "fonts/Bitstream.svg"++-- | Linux Libertine, for non-monospaced text.+-- <http://www.linuxlibertine.org/>+-- Contains a lot of unicode characters.+lin :: (Read n, RealFloat n) => PreparedFont n+lin = loadDataFont "fonts/LinLibertine.svg"++-- | Linux Libertine, cut to contain only the most common characters.+-- This results in a smaller file and hence a quicker load time.+lin2 :: (Read n, RealFloat n) => PreparedFont n+lin2 = loadDataFont "fonts/LinLibertineCut.svg"
src/Graphics/SVGFonts/ReadFont.hs view
@@ -1,188 +1,94 @@-{-# LANGUAGE RankNTypes, FlexibleContexts #-} module Graphics.SVGFonts.ReadFont--- (openFont, outlMap, textSVG, textSVG_, Mode(..), Spacing(..), Kern, SvgGlyph, FontData, OutlineMap, TextOpts(..))-where--import Data.Char (isSpace)-import Data.Default.Class-import Data.List (intersect,sortBy)-import Data.List.Split (splitOn, splitWhen)-import Data.Maybe (fromMaybe, fromJust, isJust, isNothing, maybeToList, catMaybes)-import qualified Data.Map as Map-import qualified Data.Text as T-import Data.Tuple.Select-import Data.Vector (Vector)-import Data.VectorSpace-import Diagrams.Path-import Diagrams.Segment-import Diagrams.TwoD.Types-import Diagrams.Prelude-import qualified Data.Vector as V-import Graphics.SVGFonts.CharReference (charsFromFullName, characterStrings)-import Graphics.SVGFonts.ReadPath (pathFromString, PathCommand(..))-import Paths_SVGFonts(getDataFileName)-import System.IO.Unsafe (unsafePerformIO)-import Text.XML.Light--instance Default TextOpts where- def = TextOpts "text" lin INSIDE_H KERN False 1 1+ (+ FontData(..) --- | A short version of textSVG' with standard values. The Double value is the height.------ > import Graphics.SVGFonts--- >--- > textSVGExample = stroke $ textSVG "Hello World" 1------ <<diagrams/src_Graphics_SVGFonts_ReadFont_textSVGExample.svg#diagram=textSVGExample&width=300>>-textSVG :: String -> Double -> Path R2-textSVG t h = textSVG' with { txt = t, textHeight = h }+ , bbox_dy+ , bbox_lx, bbox_ly -data TextOpts = TextOpts- { txt :: String- , fdo :: (FontData, OutlineMap)- , mode :: Mode- , spacing :: Spacing- , underline :: Bool- , textWidth :: Double- , textHeight :: Double- } deriving Show+ , underlinePosition+ , underlineThickness --- | The origin is at the center of the text and the boundaries are--- given by the outlines of the chars.------ > import Graphics.SVGFonts--- >--- > text' t = stroke (textSVG' $ TextOpts t lin INSIDE_H KERN False 1 1 )--- > # fc blue # lc blue # bg lightgrey # fillRule EvenOdd # showOrigin--- >--- > textPic0 = (text' "Hello World") # showOrigin------ <<diagrams/src_Graphics_SVGFonts_ReadFont_textPic0.svg#diagram=textPic0&width=300>>-textSVG' :: TextOpts -> Path R2-textSVG' to =- case mode to of- INSIDE_WH -> makeString (textHeight to * sumh / maxY) (textHeight to) ((textWidth to) / (textHeight to * sumh / maxY))- INSIDE_W -> makeString (textWidth to) (textWidth to * maxY / sumh) 1 -- the third character is used to scale horizontal advances- INSIDE_H -> makeString (textHeight to * sumh / maxY) (textHeight to) 1- where- makeString w h space = (scaleY (h/maxY) $ scaleX (w/sumh) $- mconcat $- zipWith translate (horPos space)- (map polygonChar (zip str (adjusted_hs space))) ) # centerXY- (fontD,outl) = (fdo to)- polygonChar (ch,a) = (fromMaybe mempty (Map.lookup ch outl)) <> (underlineChar a)- underlineChar a | underline to = translateY ulinePos (rect a ulineThickness)- | otherwise = mempty- ulinePos = underlinePosition fontD- ulineThickness = underlineThickness fontD- horPos space = reverse $ added ( zeroV : (map (unitX ^*) (adjusted_hs space)) )- adjusted_hs space = map (*space) hs- hs = horizontalAdvances str fontD (isKern (spacing to))- sumh = sum hs- added = snd.(foldl (\(h,l) (b,_) -> (h ^+^ b, (h ^+^ b):l))- (zeroV,[])). (map (\x->(x,[]))) -- [o,o+h0,o+h0+h1,..]- maxY = bbox_dy fontD -- max height of glyph+ , horizontalAdvance+ , kernAdvance - ligatures = ((filter ((>1) . length)) . (Map.keys) . fontDataGlyphs) fontD- str = map T.unpack $ characterStrings (txt to) ligatures+ , OutlineMap+ , PreparedFont+ , loadFont+ ) where --- | The origin is at the left end of the baseline of of the text and the boundaries--- are given by the bounding box of the Font. This is best for combining Text of different--- fonts and for several lines of text.--- As you can see you can also underline text by setting underline to True.------ > import Graphics.SVGFonts--- >--- > text'' t = (textSVG_ $ TextOpts t lin INSIDE_H KERN True 1 1 )--- > # fc blue # lc blue # bg lightgrey # fillRule EvenOdd # showOrigin--- >--- > textPic1 = text'' "Hello World"------ <<diagrams/src_Graphics_SVGFonts_ReadFont_textPic1.svg#diagram=textPic1&width=300>>-textSVG_ :: forall b . Renderable (Path R2) b => TextOpts -> QDiagram b R2 Any-textSVG_ to =- case mode to of- INSIDE_WH -> makeString (textHeight to * sumh / maxY) (textHeight to) ((textWidth to) / (textHeight to * sumh / maxY))- INSIDE_W -> makeString (textWidth to) (textWidth to * maxY / sumh) 1- INSIDE_H -> makeString (textHeight to * sumh / maxY) (textHeight to) 1- where- makeString w h space =( ( translate (r2 (-w*space/2,-h/2)) $- scaleY (h/maxY) $ scaleX (w/sumh) $- translateY (- bbox_ly fontD) $- mconcat $- zipWith translate (horPos space)- (map polygonChar (zip str (adjusted_hs space))) ) # stroke # withEnvelope ((rect (w*space) h) :: D R2)- ) # alignBL # translateY (bbox_ly fontD*h/maxY)- (fontD,outl) = (fdo to)- polygonChar (ch,a) = (fromMaybe mempty (Map.lookup ch outl)) <> (underlineChar a)- underlineChar a | underline to = translateX (a/2) $ translateY ulinePos (rect a ulineThickness)- | otherwise = mempty- ulinePos = underlinePosition fontD- ulineThickness = underlineThickness fontD- horPos space = reverse $ added ( zeroV : (map (unitX ^*) (adjusted_hs space)) )- hs = horizontalAdvances str fontD (isKern (spacing to))- adjusted_hs space = map (*space) hs -- the last char should not have space to the border- sumh = sum hs- added = snd.(foldl (\(h,l) (b,_) -> (h ^+^ b, (h ^+^ b):l))- (zeroV,[])). (map (\x->(x,[]))) -- [o,o+h0,o+h0+h1,..]- maxY = bbox_dy fontD -- max height of glyph+import Data.Char (isSpace)+import Data.List (intersect, sortBy)+import Data.List.Split (splitOn, splitWhen)+import qualified Data.Map as Map+import Data.Maybe (catMaybes, fromJust,+ fromMaybe, isJust, isNothing,+ maybeToList)+import Data.Tuple.Select+import Data.Vector (Vector)+import qualified Data.Vector as V+import Diagrams.Path+import Diagrams.Prelude hiding (font)+import Text.XML.Light - ligatures = ((filter ((>1) . length)) . (Map.keys) . fontDataGlyphs) fontD- str = map T.unpack $ characterStrings (txt to) ligatures+import Graphics.SVGFonts.CharReference (charsFromFullName)+import Graphics.SVGFonts.ReadPath (PathCommand (..),+ pathFromString) --- | This type contains everything that a typical SVG font file produced by fontforge contains.------ (SvgGlyph, Kern, bbox-string, filename, (underlinePos, underlineThickness),--- (fontHadv, fontFamily, fontWeight, fontStretch, unitsPerEm, panose, ascent, descent, xHeight, capHeight, stemh, stemv, unicodeRange) )----data FontData = FontData - { fontDataGlyphs :: SvgGlyphs- , fontDataKerning :: Kern- , fontDataBoundingBox :: [Double]- , fontDataFileName :: String- , fontDataUnderlinePos :: Double- , fontDataUnderlineThickness :: Double- , fontDataOverlinePos :: Maybe Double- , fontDataOverlineThickness :: Maybe Double- , fontDataStrikethroughPos :: Maybe Double- , fontDataStrikethroughThickness :: Maybe Double- , fontDataHorizontalAdvance :: Double- , fontDataFamily :: String- , fontDataStyle :: String- , fontDataWeight :: String- , fontDataVariant :: String- , fontDataStretch :: String- , fontDataSize :: Maybe String- , fontDataUnitsPerEm :: Double- , fontDataPanose :: String- , fontDataSlope :: Maybe Double- , fontDataAscent :: Double- , fontDataDescent :: Double- , fontDataXHeight :: Double- , fontDataCapHeight :: Double- , fontDataAccentHeight :: Maybe Double- , fontDataWidths :: Maybe String- , fontDataHorizontalStem :: Maybe Double +-- | This type contains everything that a typical SVG font file produced+-- by fontforge contains.+data FontData n = FontData+ { fontDataGlyphs :: SvgGlyphs n+ , fontDataKerning :: Kern n+ , fontDataBoundingBox :: [n]+ , fontDataFileName :: String+ , fontDataUnderlinePos :: n+ , fontDataUnderlineThickness :: n+ , fontDataOverlinePos :: Maybe n+ , fontDataOverlineThickness :: Maybe n+ , fontDataStrikethroughPos :: Maybe n+ , fontDataStrikethroughThickness :: Maybe n+ , fontDataHorizontalAdvance :: n+ , fontDataFamily :: String+ , fontDataStyle :: String+ , fontDataWeight :: String+ , fontDataVariant :: String+ , fontDataStretch :: String+ , fontDataSize :: Maybe String+ , fontDataUnitsPerEm :: n+ , fontDataPanose :: String+ , fontDataSlope :: Maybe n+ , fontDataAscent :: n+ , fontDataDescent :: n+ , fontDataXHeight :: n+ , fontDataCapHeight :: n+ , fontDataAccentHeight :: Maybe n+ , fontDataWidths :: Maybe String+ , fontDataHorizontalStem :: Maybe n -- ^ This data is not available in some fonts (e.g. Source Code Pro)- , fontDataVerticalStem :: Maybe Double + , fontDataVerticalStem :: Maybe n -- ^ This data is not available in some fonts (e.g. Source Code Pro)- , fontDataUnicodeRange :: String- , fontDataRawKernings :: [(String, [String], [String], [String], [String])] - , fontDataIdeographicBaseline :: Maybe Double- , fontDataAlphabeticBaseline :: Maybe Double- , fontDataMathematicalBaseline :: Maybe Double- , fontDataHangingBaseline :: Maybe Double- , fontDataVIdeographicBaseline :: Maybe Double- , fontDataVAlphabeticBaseline :: Maybe Double- , fontDataVMathematicalBaseline :: Maybe Double- , fontDataVHangingBaseline :: Maybe Double- -- ^ (k, g1, g2, u1, u2)- } deriving Show+ , fontDataUnicodeRange :: String+ , fontDataRawKernings :: [(String, [String], [String], [String], [String])]+ , fontDataIdeographicBaseline :: Maybe n+ , fontDataAlphabeticBaseline :: Maybe n+ , fontDataMathematicalBaseline :: Maybe n+ , fontDataHangingBaseline :: Maybe n+ , fontDataVIdeographicBaseline :: Maybe n+ , fontDataVAlphabeticBaseline :: Maybe n+ , fontDataVMathematicalBaseline :: Maybe n+ , fontDataVHangingBaseline :: Maybe n+ } -- | Open an SVG-Font File and extract the data----openFont :: FilePath -> FontData-openFont file = FontData +parseFont :: (Read n, RealFloat n) => FilePath -> String -> FontData n+parseFont filename contents = readFontData fontElement filename+ where+ xml = onlyElems $ parseXML $ contents+ fontElement = head $ catMaybes $ map (findElement (unqual "font")) xml++-- | Read font data from an XML font element.+readFontData :: (Read n, RealFloat n) => Element -> FilePath -> FontData n+readFontData fontElement file = FontData { fontDataGlyphs = Map.fromList glyphs , fontDataKerning = Kern { kernU1S = transformChars u1s@@ -230,30 +136,28 @@ } where readAttr :: (Read a) => Element -> String -> a- readAttr element attr = fromJust $ fmap read $ findAttr (unqual attr) element- + readAttr e attr = fromJust $ fmap read $ findAttr (unqual attr) e+ readAttrM :: (Read a) => Element -> String -> Maybe a- readAttrM element attr = fmap read $ findAttr (unqual attr) element- + readAttrM e attr = fmap read $ findAttr (unqual attr) e+ -- | @readString e a d@ : @e@ element to read from; @a@ attribute to read; @d@ default value. readString :: Element -> String -> String -> String- readString element attr d = fromMaybe d $ findAttr (unqual attr) element- + readString e attr d = fromMaybe d $ findAttr (unqual attr) e+ readStringM :: Element -> String -> Maybe String- readStringM element attr = findAttr (unqual attr) element- - xml = onlyElems $ parseXML $ unsafePerformIO $ readFile file+ readStringM e attr = findAttr (unqual attr) e - fontElement = head $ catMaybes $ map (findElement (unqual "font")) xml fontHadv = fromMaybe ((parsedBBox!!2) - (parsedBBox!!0)) -- BBox is used if there is no "horiz-adv-x" attribute (fmap read (findAttr (unqual "horiz-adv-x") fontElement) ) fontface = fromJust $ findElement (unqual "font-face") fontElement -- there is always a font-face node bbox = readString fontface "bbox" ""- parsedBBox :: [Double]+ parsedBBox :: Read n => [n] parsedBBox = map read $ splitWhen isSpace bbox glyphElements = findChildren (unqual "glyph") fontElement kernings = findChildren (unqual "hkern") fontElement+ glyphs = map glyphsWithDefaults glyphElements -- monospaced fonts sometimes don't have a "horiz-adv-x="-value , replace with "horiz-adv-x=" in <font>@@ -272,7 +176,7 @@ g2s = map (fromMaybe "") $ map (findAttr (unqual "g2")) kernings ks = map (fromMaybe "") $ map (findAttr (unqual "k")) kernings kAr = V.fromList (map read ks)- + rawKerns = fmap getRawKern kernings getRawKern kerning = let u1 = splitWhen (==',') $ fromMaybe "" $ findAttr (unqual "u1") $ kerning@@ -283,11 +187,11 @@ in (k, g1, g2, u1, u2) transformChars chars = Map.fromList $ map ch $ multiSet $- map (\(x,y) -> (x,[y])) $ sort fst $ concat $ index chars+ map (\(x,y) -> (x,[y])) $ sort fst $ concat $ indexList chars ch (x,y) | null x = ("",y) | otherwise = (x,y) - index u = addIndex (map (splitWhen isColon) u) -- ie ["aa,b","c,d"] to [["aa","b"],["c","d"]]+ indexList u = addIndex (map (splitWhen isColon) u) -- ie ["aa,b","c,d"] to [["aa","b"],["c","d"]] isColon = (== ',') -- to [("aa",0),("b",0)],[("c",1), ("d",1)] addIndex qs = zipWith (\x y -> (map (\z -> (z,x)) y)) [0..] qs@@ -301,22 +205,14 @@ fname f = last $ init $ concat (map (splitOn "/") (splitOn "." f)) -type SvgGlyphs = Map.Map String (String, Double, String) -- ^ \[ (unicode, (glyph_name, horiz_advance, ds)) \]---- | Horizontal advances of characters inside a string.--- A character is stored with a string (because of ligatures like \"ffi\").-horizontalAdvances :: [String] -> FontData -> Bool -> [Double]-horizontalAdvances [] _ _ = []-horizontalAdvances [ch] fd _ = [hadv ch fd]-horizontalAdvances (ch0:ch1:s) fd kerning = ((hadv ch0 fd) - (ka (fontDataKerning fd))) :- (horizontalAdvances (ch1:s) fd kerning)- where ka kern | kerning = (kernAdvance ch0 ch1 kern True) + (kernAdvance ch0 ch1 kern False)- | otherwise = 0+type SvgGlyphs n = Map.Map String (String, n, String)+-- ^ \[ (unicode, (glyph_name, horiz_advance, ds)) \] -- | Horizontal advance of a character consisting of its width and spacing, extracted out of the font data-hadv :: String -> FontData -> Double-hadv ch fontD | isJust char = sel2 (fromJust char)- | otherwise = fontDataHorizontalAdvance fontD+horizontalAdvance :: RealFloat n => String -> FontData n -> n+horizontalAdvance ch fontD+ | isJust char = sel2 (fromJust char)+ | otherwise = fontDataHorizontalAdvance fontD where char = (Map.lookup ch (fontDataGlyphs fontD)) -- | See <http://www.w3.org/TR/SVG/fonts.html#KernElements>@@ -333,16 +229,16 @@ -- Now the g2s are converted in the same way as the g1s. -- Whenever two consecutive chars are being printed try to find an -- intersection of the list assigned to the first char and second char-data Kern = Kern+data Kern n = Kern { kernU1S :: Map.Map String [Int] , kernU2S :: Map.Map String [Int] , kernG1S :: Map.Map String [Int] , kernG2S :: Map.Map String [Int]- , kernK :: Vector Double+ , kernK :: Vector n } deriving Show -- | Change the horizontal advance of two consective chars (kerning)-kernAdvance :: String -> String -> Kern -> Bool -> Double+kernAdvance :: RealFloat n => String -> String -> Kern n -> Bool -> n kernAdvance ch0 ch1 kern u | u && not (null s0) = (kernK kern) V.! (head s0) | not u && not (null s1) = (kernK kern) V.! (head s1) | otherwise = 0@@ -350,8 +246,6 @@ s1 = intersect (s kernG1S ch0) (s kernG2S ch1) s sel ch = concat (maybeToList (Map.lookup ch (sel kern))) -type OutlineMap = Map.Map String (Path R2)- -- > import Graphics.SVGFonts.ReadFont -- > textWH0 = (rect 8 1) # alignBL <> ((textSVG_ $ TextOpts "SPACES" lin INSIDE_WH KERN False 8 1 ) -- > # fc blue # lc blue # bg lightgrey # fillRule EvenOdd) # alignBL@@ -371,33 +265,6 @@ -- > # fc blue # lc blue # bg lightgrey # fillRule EvenOdd) # alignBL -- > textH = textH0 # alignBL === strutY 0.5 === textH1 # alignBL -data Mode = INSIDE_H -- ^ The string fills the complete height, width adjusted. Used in text editors.- -- The result can be smaller or bigger than the bounding box:- --- -- <<diagrams/src_Graphics_SVGFonts_ReadFont_textH.svg#diagram=textH&width=400>>- | INSIDE_W -- ^ The string fills the complete width, height adjusted.- -- May be useful for single words in a diagram, or for headlines.- -- The result can be smaller or bigger than the bounding box:- --- -- <<diagrams/src_Graphics_SVGFonts_ReadFont_textW.svg#diagram=textW&width=400>>- | INSIDE_WH -- ^ The string is stretched inside Width and Height boundaries.- -- The horizontal advances are increased if the string is shorter than there is space.- -- The horizontal advances are decreased if the string is longer than there is space.- -- This feature is experimental and might change in the future.- --- -- <<diagrams/src_Graphics_SVGFonts_ReadFont_textWH.svg#diagram=textWH&width=400>>- deriving Show--mWH :: Mode -> Bool-mWH INSIDE_WH = True-mWH _ = False-mW :: Mode -> Bool-mW INSIDE_W = True-mW _ = False-mH :: Mode -> Bool-mH INSIDE_H = True-mH _ = False- -- > import Graphics.SVGFonts.ReadFont -- > textHADV = (textSVG_ $ TextOpts "AVENGERS" lin INSIDE_H HADV False 10 1 ) -- > # fc blue # lc blue # bg lightgrey # fillRule EvenOdd@@ -406,57 +273,69 @@ -- > textKern = (textSVG_ $ TextOpts "AVENGERS" lin INSIDE_H KERN False 10 1 ) -- > # fc blue # lc blue # bg lightgrey # fillRule EvenOdd --- | See <http://en.wikipedia.org/wiki/Kerning>----data Spacing = HADV -- ^ Every glyph has a unique horiz. advance- --- -- <<diagrams/src_Graphics_SVGFonts_ReadFont_textHADV.svg#diagram=textHADV&width=400>>- | KERN -- ^ Recommended, same as HADV but sometimes overridden by kerning:- -- As You can see there is less space between \"A\" and \"V\":- --- -- <<diagrams/src_Graphics_SVGFonts_ReadFont_textKern.svg#diagram=textKern&width=400>>- deriving Show -isKern :: Spacing -> Bool-isKern KERN = True-isKern _ = False--type FileName = String---- | read only of static data (safe)-ro :: FilePath -> FilePath-ro = unsafePerformIO . getDataFileName- -- | Difference between highest and lowest y-value of bounding box-bbox_dy :: FontData -> Double+bbox_dy :: RealFloat n => FontData n -> n bbox_dy fontData = (bbox!!3) - (bbox!!1) where bbox = fontDataBoundingBox fontData -- bbox = [lowest x, lowest y, highest x, highest y] -- | Lowest x-value of bounding box-bbox_lx :: FontData -> Double+bbox_lx :: RealFloat n => FontData n -> n bbox_lx fontData = (fontDataBoundingBox fontData) !! 0 -- | Lowest y-value of bounding box-bbox_ly :: FontData -> Double+bbox_ly :: RealFloat n => FontData n -> n bbox_ly fontData = (fontDataBoundingBox fontData) !! 1 -- | Position of the underline bar-underlinePosition :: FontData -> Double+underlinePosition :: RealFloat n => FontData n -> n underlinePosition fontData = fontDataUnderlinePos fontData -- | Thickness of the underline bar-underlineThickness :: FontData -> Double+underlineThickness :: RealFloat n => FontData n -> n underlineThickness fontData = fontDataUnderlineThickness fontData --- | Generate Font Data and a Map from chars to outline paths-outlMap :: String -> (FontData, OutlineMap)-outlMap str = ( fontD, Map.fromList [ (ch, outlines ch) | ch <- allUnicodes ] )+-- | A map of unicode characters to outline paths.+type OutlineMap n = Map.Map String (Path V2 n)++-- | A map of unicode characters to parsing errors.+type ErrorMap = Map.Map String String++-- | A font including its outline map.+type PreparedFont n = (FontData n, OutlineMap n)++-- | Compute a font's outline map, collecting errors in a second map.+outlineMap :: (Read n, RealFloat n) =>+ FontData n -> (OutlineMap n, ErrorMap)+outlineMap fontData =+ ( Map.fromList [(ch, outl) | (ch, Right outl) <- allOutlines]+ , Map.fromList [(ch, err) | (ch, Left err) <- allOutlines]+ ) where- allUnicodes = Map.keys (fontDataGlyphs fontD)- outlines ch = mconcat $ commandsToTrails (commands ch (fontDataGlyphs fontD)) [] zeroV zeroV zeroV- fontD = openFont str+ allUnicodes = Map.keys (fontDataGlyphs fontData)+ outlines ch = do+ cmds <- commands ch (fontDataGlyphs fontData)+ return $ mconcat $ commandsToTrails cmds [] zero zero zero+ allOutlines = [(ch, outlines ch) | ch <- allUnicodes] -commandsToTrails :: [PathCommand] -> [Segment Closed R2] -> R2 -> R2 -> R2 -> [Path R2]+-- | Prepare font for rendering, by determining its outline map.+prepareFont :: (Read n, RealFloat n) =>+ FontData n -> (PreparedFont n, ErrorMap)+prepareFont fontData = ((fontData, outlines), errs)+ where+ (outlines, errs) = outlineMap fontData++-- | Read font data from font file, and compute its outline map.+loadFont :: (Read n, RealFloat n) => FilePath -> IO (PreparedFont n)+loadFont filename = do+ fontData <- parseFont filename <$> readFile filename+ let (font, errs) = prepareFont fontData+ sequence_ [ putStrLn ("error parsing character '" ++ ch ++ "': " ++ err)+ | (ch, err) <- Map.toList errs+ ]+ return font++commandsToTrails ::RealFloat n => [PathCommand n] -> [Segment Closed V2 n] -> V2 n -> V2 n -> V2 n -> [Path V2 n] commandsToTrails [] _ _ _ _ = [] commandsToTrails (c:cs) segments l lastContr beginPoint -- l is the endpoint of the last segment | isNothing nextSegment = (translate beginPoint (pathFromTrail . wrapTrail . closeLine $ lineFromSegments segments)) :@@ -466,20 +345,20 @@ where nextSegment = go c offs | isJust nextSegment = segOffset (fromJust nextSegment)- | otherwise = zeroV+ | otherwise = zero (x0,y0) = unr2 offs (cx,cy) = unr2 lastContr -- last control point is always in absolute coordinates beginP ( M_abs (x,y) ) = r2 (x,y) beginP ( M_rel (x,y) ) = l ^+^ r2 (x,y) beginP _ = beginPoint- contr ( C_abs (_x1,_y1,x2,y2,x,y) ) = r2 (x0+x-x2, y0+y-y2 ) -- control point of bezier curve- contr ( C_rel (_x1,_y1,x2,y2,x,y) ) = r2 ( x-x2, y-y2 )- contr ( S_abs (x2,y2,x,y) ) = r2 (x0+x-x2, y0+y-y2 )- contr ( S_rel (x2,y2,x,y) ) = r2 ( x-x2, y-y2 )- contr ( Q_abs (x1,y1,x,y) ) = r2 (x0+x-x1, y0+y-y1 )- contr ( Q_rel (x1,y1,x,y) ) = r2 ( x-x1, y-y1 )- contr ( T_abs (_x,_y) ) = r2 (2*x0-cx, 2*y0-cy )- contr ( T_rel (x,y) ) = r2 ( x-cx, y-cy )+ contr ( C_abs (_x1,_y1,x2,y2,x,y) ) = r2 (x0+x - x2, y0+y - y2 ) -- control point of bezier curve+ contr ( C_rel (_x1,_y1,x2,y2,x,y) ) = r2 ( x - x2, y - y2 )+ contr ( S_abs (x2,y2,x,y) ) = r2 (x0+x - x2, y0+y - y2 )+ contr ( S_rel (x2,y2,x,y) ) = r2 ( x - x2, y - y2 )+ contr ( Q_abs (x1,y1,x,y) ) = r2 (x0+x - x1, y0+y - y1 )+ contr ( Q_rel (x1,y1,x,y) ) = r2 ( x - x1, y - y1 )+ contr ( T_abs (_x,_y) ) = r2 (2*x0 - cx, 2*y0 - cy )+ contr ( T_rel (x,y) ) = r2 ( x - cx, y - cy ) contr ( L_abs (_x,_y) ) = r2 (x0, y0) contr ( L_rel (_x,_y) ) = r2 ( 0, 0) contr ( M_abs (_x,_y) ) = r2 (x0, y0)@@ -515,29 +394,7 @@ go ( A_abs ) = Nothing go ( A_rel ) = Nothing -commands :: String -> SvgGlyphs -> [PathCommand]-commands ch glyph | isJust element = case pathFromString (sel3 $ fromJust element) of- Left err -> unsafePerformIO $ do- putStr "parse error at "- print err- return []- Right p -> p- | otherwise = []- where element = Map.lookup ch glyph---- | Bitstream, a standard monospaced font (used in gedit)-bit :: (FontData, OutlineMap)-bit = outlMap (ro "fonts/Bitstream.svg")---- | Linux Libertine, for non-monospaced text: <http://www.linuxlibertine.org/>, contains a lot of unicode characters-lin :: (FontData, OutlineMap)-lin = outlMap (ro "fonts/LinLibertine.svg")---- | Linux Libertine, cut to contain only the most common characters,--- resulting in a smaller file and hence a quicker load time.-lin2 :: (FontData, OutlineMap)-lin2 = outlMap (ro "fonts/LinLibertineCut.svg")---- | SourceCode Pro--- sourcePro :: (FontData, OutlineMap)--- sourcePro = outlMap (ro "fonts/SourceCodePro-Regular.svg")+commands :: RealFloat n => String -> SvgGlyphs n -> Either String [PathCommand n]+commands ch glyph = case Map.lookup ch glyph of+ Just e -> pathFromString (sel3 e)+ Nothing -> Right []
src/Graphics/SVGFonts/ReadPath.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-} + -------------------------------------------------------------------- -- | -- Module : Graphics.SVG.ReadPath @@ -16,48 +18,43 @@ ) where +#if __GLASGOW_HASKELL__ < 710 import Control.Applicative hiding (many, (<|>)) +#endif import Text.ParserCombinators.Parsec hiding (spaces) import Text.ParserCombinators.Parsec.Language (emptyDef) import qualified Text.ParserCombinators.Parsec.Token as P -type X = Double -type Y = Double -type Tup = (X,Y) -type X1 = X -type Y1 = Y -type X2 = X -type Y2 = Y -data PathCommand = - M_abs Tup | -- ^Establish a new current point (with absolute coords) - M_rel Tup | -- ^Establish a new current point (with coords relative to the current point) +data PathCommand n = + M_abs (n, n) | -- ^Establish a new current point (with absolute coords) + M_rel (n, n) | -- ^Establish a new current point (with coords relative to the current point) Z | -- ^Close current subpath by drawing a straight line from current point to current subpath's initial point - L_abs Tup | -- ^A line from the current point to Tup which becomes the new current point - L_rel Tup | - H_abs X | -- ^A horizontal line from the current point (cpx, cpy) to (x, cpy) - H_rel X | - V_abs Y | -- ^A vertical line from the current point (cpx, cpy) to (cpx, y) - V_rel Y | - C_abs (X1,Y1,X2,Y2,X,Y) | -- ^Draws a cubic Bézier curve from the current point to (x,y) using (x1,y1) as the + L_abs (n, n) | -- ^A line from the current point to (n, n) which becomes the new current point + L_rel (n, n) | + H_abs n | -- ^A horizontal line from the current point (cpx, cpy) to (x, cpy) + H_rel n | + V_abs n | -- ^A vertical line from the current point (cpx, cpy) to (cpx, y) + V_rel n | + C_abs (n,n,n,n,n,n) | -- ^Draws a cubic Bézier curve from the current point to (x,y) using (x1,y1) as the -- ^control point at the beginning of the curve and (x2,y2) as the control point at the end of the curve. - C_rel (X1,Y1,X2,Y2,X,Y) | - S_abs (X2,Y2,X,Y) | -- ^Draws a cubic Bézier curve from the current point to (x,y). The first control point is + C_rel (n,n,n,n,n,n) | + S_abs (n,n,n,n) | -- ^Draws a cubic Bézier curve from the current point to (x,y). The first control point is -- assumed to be the reflection of the second control point on the previous command relative to the current point. -- (If there is no previous command or if the previous command was not an C, c, S or s, assume the first control -- point is coincident with the current point.) (x2,y2) is the second control point (i.e., the control point at -- the end of the curve). - S_rel (X2,Y2,X,Y) | - Q_abs (X1,Y1,X,Y) | -- ^A quadr. Bézier curve from the curr. point to (x,y) using (x1,y1) as the control point - Q_rel (X1,Y1,X,Y) | -- ^Nearly the same as cubic, but with one point less - T_abs Tup | -- ^T_Abs = Shorthand/smooth quadratic Bezier curveto - T_rel Tup | + S_rel (n,n,n,n) | + Q_abs (n,n,n,n) | -- ^A quadr. Bézier curve from the curr. point to (x,y) using (x1,y1) as the control point + Q_rel (n,n,n,n) | -- ^Nearly the same as cubic, but with one point less + T_abs (n, n) | -- ^T_Abs = Shorthand/smooth quadratic Bezier curveto + T_rel (n, n) | A_abs | -- ^A = Elliptic arc (not used) A_rel deriving Show -- | Convert a SVG path string into a list of commands -pathFromString :: String -> Either String [PathCommand] +pathFromString :: Fractional n => String -> Either String [PathCommand n] pathFromString str = case parse path "" str of Left err -> Left (show err) Right p -> Right p @@ -65,13 +62,13 @@ spaces :: Parser () spaces = skipMany space -path :: Parser [PathCommand] +path :: Fractional n => Parser [PathCommand n] path = do{ l <- many pathElement ; eof ; return (concat l) } -pathElement :: Parser [PathCommand] +pathElement :: Fractional n => Parser [PathCommand n] pathElement = whiteSpace *> ( symbol "M" *> many1 (M_abs <$> tupel2) @@ -80,10 +77,10 @@ <|> symbol "Z" *> pure [Z] <|> symbol "L" *> many1 (L_abs <$> tupel2) <|> symbol "l" *> many1 (L_rel <$> tupel2) - <|> symbol "H" *> many1 (H_abs . realToFrac <$> myfloat) - <|> symbol "h" *> many1 (H_rel . realToFrac <$> myfloat) - <|> symbol "V" *> many1 (V_abs . realToFrac <$> myfloat) - <|> symbol "v" *> many1 (V_rel . realToFrac <$> myfloat) + <|> symbol "H" *> many1 (H_abs <$> myfloat) + <|> symbol "h" *> many1 (H_rel <$> myfloat) + <|> symbol "V" *> many1 (V_abs <$> myfloat) + <|> symbol "v" *> many1 (V_rel <$> myfloat) <|> symbol "C" *> many1 (C_abs <$> tupel6) <|> symbol "c" *> many1 (C_rel <$> tupel6) <|> symbol "S" *> many1 (S_abs <$> tupel4) @@ -92,32 +89,32 @@ <|> symbol "q" *> many1 (Q_rel <$> tupel4) <|> symbol "T" *> many1 (T_abs <$> tupel2) <|> symbol "t" *> many1 (T_rel <$> tupel2) - <|> symbol "A" *> many1 (A_abs <$ tupel2) - <|> symbol "a" *> many1 (A_rel <$ tupel2) + <|> symbol "A" *> many1 (A_abs <$ (tupel2::Parser (Double,Double))) + <|> symbol "a" *> many1 (A_rel <$ (tupel2::Parser (Double,Double))) ) comma :: Parser () comma = spaces *> (try (() <$ char ',' ) <|> spaces) -tupel2 :: Parser (X,Y) +tupel2 :: Fractional n => Parser (n,n) tupel2 = do{ x <- myfloat; comma; y <- myfloat; spaces; - return (realToFrac x, realToFrac y) + return (x, y) } -tupel4 :: Parser (X,Y,X,Y) +tupel4 :: Fractional n => Parser (n,n,n,n) tupel4 = do{ x1 <- myfloat; comma; y1 <- myfloat; spaces; x <- myfloat; comma; y <- myfloat; spaces; - return (realToFrac x1, realToFrac y1, realToFrac x, realToFrac y) + return (x1, y1, x, y) } -tupel6 :: Parser (X,Y,X,Y,X,Y) +tupel6 :: Fractional n => Parser (n,n,n,n,n,n) tupel6 = do{ x1 <- myfloat; comma; y1 <- myfloat; spaces; x2 <- myfloat; comma; y2 <- myfloat; spaces; x <- myfloat; comma; y <- myfloat; spaces; - return (realToFrac x1, realToFrac y1, realToFrac x2, realToFrac y2, realToFrac x, realToFrac y) + return (x1, y1, x2, y2, x, y) } -myfloat :: Parser Double +myfloat :: Fractional n => Parser n myfloat = try (do{ _ <- symbol "-"; n <- float; return (negate n) }) <|> try float <|> -- 0 is not recognized as a float, so recognize it as an integer and then convert to float do { i<-integer; return(fromIntegral i) } @@ -131,5 +128,5 @@ symbol = P.symbol lexer integer :: Parser Integer integer = P.integer lexer -float :: Parser Double -float = P.float lexer +float :: Fractional n => Parser n +float = realToFrac <$> P.float lexer
+ src/Graphics/SVGFonts/Text.hs view
@@ -0,0 +1,180 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Graphics.SVGFonts.Text+ ( -- * Setting text as a path using a font.++ TextOpts(..)+ , Mode(..)+ , Spacing(..)++ , textSVG+ , textSVG'+ , textSVG_++ ) where++import Data.Default.Class+import Diagrams.Prelude hiding (font, text)+import qualified Data.Map as Map+import Data.Maybe (fromMaybe)+import qualified Data.Text as T++import Graphics.SVGFonts.Fonts (lin)+import Graphics.SVGFonts.ReadFont+import Graphics.SVGFonts.CharReference (characterStrings)++data TextOpts n = TextOpts+ { textFont :: PreparedFont n+ , mode :: Mode+ , spacing :: Spacing+ , underline :: Bool+ , textWidth :: n+ , textHeight :: n+ }++instance (Read n, RealFloat n) => Default (TextOpts n) where+ def = TextOpts lin INSIDE_H KERN False 1 1++-- | A short version of textSVG' with standard values. The Double value is the height.+--+-- > import Graphics.SVGFonts+-- >+-- > textSVGExample = stroke $ textSVG "Hello World" 1+--+-- <<diagrams/src_Graphics_SVGFonts_ReadFont_textSVGExample.svg#diagram=textSVGExample&width=300>>+textSVG :: (Read n, RealFloat n) => String -> n -> Path V2 n+textSVG t h = textSVG' with { textHeight = h } t++-- | Create a path from the given text and options.+-- The origin is at the center of the text and the boundaries are+-- given by the outlines of the chars.+--+-- > import Graphics.SVGFonts+-- >+-- > text' t = stroke (textSVG' (TextOpts lin INSIDE_H KERN False 1 1) t)+-- > # fc blue # lc blue # bg lightgrey # fillRule EvenOdd # showOrigin+-- >+-- > textPic0 = (text' "Hello World") # showOrigin+--+-- <<diagrams/src_Graphics_SVGFonts_ReadFont_textPic0.svg#diagram=textPic0&width=300>>+textSVG' :: RealFloat n => TextOpts n -> String -> Path V2 n+textSVG' topts text =+ case mode topts of+ INSIDE_WH -> makeString (textHeight topts * sumh / maxY) (textHeight topts) (textWidth topts / (textHeight topts * sumh / maxY))+ INSIDE_W -> makeString (textWidth topts) (textWidth topts * maxY / sumh) 1 -- the third character is used topts scale horizontal advances+ INSIDE_H -> makeString (textHeight topts * sumh / maxY) (textHeight topts) 1+ where+ makeString w h space = (scaleY (h/maxY) $ scaleX (w/sumh) $+ mconcat $+ zipWith translate (horPos space)+ (map polygonChar (zip str (adjusted_hs space))) ) # centerXY+ (fontD,outl) = textFont topts+ polygonChar (ch,a) = (fromMaybe mempty (Map.lookup ch outl)) <> (underlineChar a)+ underlineChar a | underline topts = translateY ulinePos (rect a ulineThickness)+ | otherwise = mempty+ ulinePos = underlinePosition fontD+ ulineThickness = underlineThickness fontD+ horPos space = reverse $ added ( zero : (map (unitX ^*) (adjusted_hs space)) )+ adjusted_hs space = map (*space) hs+ hs = horizontalAdvances str fontD (isKern (spacing topts))+ sumh = sum hs+ added = snd.(foldl (\(h,l) (b,_) -> (h ^+^ b, (h ^+^ b):l))+ (zero,[])). (map (\x->(x,[]))) -- [o,o+h0,o+h0+h1,..]+ maxY = bbox_dy fontD -- max height of glyph++ ligatures = ((filter ((>1) . length)) . Map.keys . fontDataGlyphs) fontD+ str = map T.unpack $ characterStrings text ligatures+++-- | Create a path from the given text and options.+-- The origin is at the left end of the baseline of of the text and the boundaries+-- are given by the bounding box of the Font. This is best for combining Text of different+-- fonts and for several lines of text.+-- As you can see you can also underline text by setting underline to True.+--+-- > import Graphics.SVGFonts+-- >+-- > text'' t = (textSVG_ (TextOpts lin INSIDE_H KERN True 1 1) t)+-- > # fc blue # lc blue # bg lightgrey # fillRule EvenOdd # showOrigin+-- >+-- > textPic1 = text'' "Hello World"+--+-- <<diagrams/src_Graphics_SVGFonts_ReadFont_textPic1.svg#diagram=textPic1&width=300>>+textSVG_ :: forall b n. (TypeableFloat n, Renderable (Path V2 n) b) =>+ TextOpts n -> String -> QDiagram b V2 n Any+textSVG_ topts text =+ case mode topts of+ INSIDE_WH -> makeString (textHeight topts * sumh / maxY) (textHeight topts) ((textWidth topts) / (textHeight topts * sumh / maxY))+ INSIDE_W -> makeString (textWidth topts) (textWidth topts * maxY / sumh) 1+ INSIDE_H -> makeString (textHeight topts * sumh / maxY) (textHeight topts) 1+ where+ makeString w h space =( ( translate (r2 (-w*space/2,-h/2)) $+ scaleY (h/maxY) $ scaleX (w/sumh) $+ translateY (- bbox_ly fontD) $+ mconcat $+ zipWith translate (horPos space)+ (map polygonChar (zip str (adjusted_hs space))) ) # stroke # withEnvelope ((rect (w*space) h) :: D V2 n)+ ) # alignBL # translateY (bbox_ly fontD*h/maxY)+ (fontD,outl) = (textFont topts)+ polygonChar (ch,a) = (fromMaybe mempty (Map.lookup ch outl)) <> (underlineChar a)+ underlineChar a | underline topts = translateX (a/2) $ translateY ulinePos (rect a ulineThickness)+ | otherwise = mempty+ ulinePos = underlinePosition fontD+ ulineThickness = underlineThickness fontD+ horPos space = reverse $ added ( zero : (map (unitX ^*) (adjusted_hs space)) )+ hs = horizontalAdvances str fontD (isKern (spacing topts))+ adjusted_hs space = map (*space) hs -- the last char should not have space to the border+ sumh = sum hs+ added = snd.(foldl (\(h,l) (b,_) -> (h ^+^ b, (h ^+^ b):l))+ (zero,[])). (map (\x->(x,[]))) -- [o,o+h0,o+h0+h1,..]+ maxY = bbox_dy fontD -- max height of glyph++ ligatures = (filter ((>1) . length) . Map.keys . fontDataGlyphs) fontD+ str = map T.unpack $ characterStrings text ligatures+++data Mode = INSIDE_H -- ^ The string fills the complete height, width adjusted. Used in text editors.+ -- The result can be smaller or bigger than the bounding box:+ --+ -- <<diagrams/src_Graphics_SVGFonts_ReadFont_textH.svg#diagram=textH&width=400>>+ | INSIDE_W -- ^ The string fills the complete width, height adjusted.+ -- May be useful for single words in a diagram, or for headlines.+ -- The result can be smaller or bigger than the bounding box:+ --+ -- <<diagrams/src_Graphics_SVGFonts_ReadFont_textW.svg#diagram=textW&width=400>>+ | INSIDE_WH -- ^ The string is stretched inside Width and Height boundaries.+ -- The horizontal advances are increased if the string is shorter than there is space.+ -- The horizontal advances are decreased if the string is longer than there is space.+ -- This feature is experimental and might change in the future.+ --+ -- <<diagrams/src_Graphics_SVGFonts_ReadFont_textWH.svg#diagram=textWH&width=400>>+ deriving Show+++-- | See <http://en.wikipedia.org/wiki/Kerning>+--+data Spacing = HADV -- ^ Every glyph has a unique horiz. advance+ --+ -- <<diagrams/src_Graphics_SVGFonts_ReadFont_textHADV.svg#diagram=textHADV&width=400>>+ | KERN -- ^ Recommended, same as HADV but sometimes overridden by kerning:+ -- As You can see there is less space between \"A\" and \"V\":+ --+ -- <<diagrams/src_Graphics_SVGFonts_ReadFont_textKern.svg#diagram=textKern&width=400>>+ deriving Show++isKern :: Spacing -> Bool+isKern KERN = True+isKern _ = False+++-- | Horizontal advances of characters inside a string.+-- A character is stored with a string (because of ligatures like \"ffi\").+horizontalAdvances :: RealFloat n => [String] -> FontData n -> Bool -> [n]+horizontalAdvances [] _ _ = []+horizontalAdvances [ch] fd _ = [horizontalAdvance ch fd]+horizontalAdvances (ch0:ch1:s) fd kerning = ((horizontalAdvance ch0 fd) - (ka (fontDataKerning fd))) :+ (horizontalAdvances (ch1:s) fd kerning)+ where ka kern | kerning = (kernAdvance ch0 ch1 kern True) + (kernAdvance ch0 ch1 kern False)+ | otherwise = 0
src/Graphics/SVGFonts/WriteFont.hs view
@@ -17,8 +17,8 @@ import Graphics.SVGFonts.ReadFont -makeSvgFont :: (FontData, OutlineMap) -> Set.Set String -> S.Svg-makeSvgFont (fd, _) gs = do+makeSvgFont :: (Show n, S.ToValue n) => PreparedFont n -> Set.Set String -> S.Svg+makeSvgFont (fd, _) gs = font ! A.horizAdvX horizAdvX $ do -- Font meta information S.fontFace ! A.fontFamily fontFamily@@ -62,7 +62,7 @@ -- Insert all other glyphs forM_ (Set.toList gs') $ \g -> case M.lookup g (fontDataGlyphs fd) of Nothing -> return ()- Just (gName, gHAdv, gPath) -> do+ Just (gName, gHAdv, gPath) -> S.glyph ! A.glyphName (toValue gName) ! A.horizAdvX (toValue gHAdv) ! A.d (toValue gPath) @@ -75,7 +75,7 @@ u1' = filter isGlyph u1 u2' = filter isGlyph u2 case (not (null g1') && not (null g2')) || (not (null u1') && not (null u2')) of- True -> do+ True -> S.hkern ! A.k (toValue k) # maybeString A.g1 (const $ intercalate "," g1') # maybeString A.g2 (const $ intercalate "," g2')@@ -105,15 +105,15 @@ let cOrd = ord c in if cOrd >= 32 && cOrd <= 126 then [c] - else "&#x" ++ (showHex cOrd "")+ else "&#x" ++ showHex cOrd "" - maybeMaybe :: (S.ToValue a) - => (S.AttributeValue -> S.Attribute) -> (FontData -> Maybe a) - -> Maybe S.Attribute+ -- maybeMaybe :: (S.ToValue a) + -- => (S.AttributeValue -> S.Attribute) -> (FontData n -> Maybe a) + -- -> Maybe S.Attribute maybeMaybe toF fromF = (toF . toValue) `fmap` fromF fd - maybeString :: (S.AttributeValue -> S.Attribute) -> (FontData -> String) - -> Maybe S.Attribute+ -- maybeString :: (S.AttributeValue -> S.Attribute) -> (FontData n -> String) + -- -> Maybe S.Attribute maybeString toF fromF = case fromF fd of "" -> Nothing s -> Just $ toF $ toValue $ s