diff --git a/CHANGES.md b/CHANGES.md --- a/CHANGES.md +++ b/CHANGES.md @@ -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) ---------------------- diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -2,7 +2,9 @@ Jan Bracker Chris Mears + Jeffrey Rosenbluth Tillmann Vogt + Robert Vollmert Ryan Yates Brent Yorgey diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 diff --git a/SVGFonts.cabal b/SVGFonts.cabal --- a/SVGFonts.cabal +++ b/SVGFonts.cabal @@ -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 (). 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 , 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: - - . - 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 (). 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 , 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: + + . + 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 diff --git a/src/Graphics/SVGFonts.hs b/src/Graphics/SVGFonts.hs --- a/src/Graphics/SVGFonts.hs +++ b/src/Graphics/SVGFonts.hs @@ -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) diff --git a/src/Graphics/SVGFonts/Fonts.hs b/src/Graphics/SVGFonts/Fonts.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/SVGFonts/Fonts.hs @@ -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. +-- +-- 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" diff --git a/src/Graphics/SVGFonts/ReadFont.hs b/src/Graphics/SVGFonts/ReadFont.hs --- a/src/Graphics/SVGFonts/ReadFont.hs +++ b/src/Graphics/SVGFonts/ReadFont.hs @@ -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 --- --- <> -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 --- --- <> -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" --- --- <> -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 @@ -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 @@ -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: - -- - -- <> - | 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: - -- - -- <> - | 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. - -- - -- <> - 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 --- -data Spacing = HADV -- ^ Every glyph has a unique horiz. advance - -- - -- <> - | KERN -- ^ Recommended, same as HADV but sometimes overridden by kerning: - -- As You can see there is less space between \"A\" and \"V\": - -- - -- <> - 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: , 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 [] diff --git a/src/Graphics/SVGFonts/ReadPath.hs b/src/Graphics/SVGFonts/ReadPath.hs --- a/src/Graphics/SVGFonts/ReadPath.hs +++ b/src/Graphics/SVGFonts/ReadPath.hs @@ -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 diff --git a/src/Graphics/SVGFonts/Text.hs b/src/Graphics/SVGFonts/Text.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/SVGFonts/Text.hs @@ -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 +-- +-- <> +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 +-- +-- <> +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" +-- +-- <> +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: + -- + -- <> + | 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: + -- + -- <> + | 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. + -- + -- <> + deriving Show + + +-- | See +-- +data Spacing = HADV -- ^ Every glyph has a unique horiz. advance + -- + -- <> + | KERN -- ^ Recommended, same as HADV but sometimes overridden by kerning: + -- As You can see there is less space between \"A\" and \"V\": + -- + -- <> + 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 diff --git a/src/Graphics/SVGFonts/WriteFont.hs b/src/Graphics/SVGFonts/WriteFont.hs --- a/src/Graphics/SVGFonts/WriteFont.hs +++ b/src/Graphics/SVGFonts/WriteFont.hs @@ -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