From f793b68c0e0c21b9c48073ed2d1e83313c38fcef Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Fri, 27 Jan 2023 14:47:33 +1300 Subject: [PATCH] Document everything and get test code working again! --- app/Main.hs | 48 +++--- src/Typograffiti.hs | 4 +- src/Typograffiti/Atlas.hs | 36 +++++ src/Typograffiti/Cache.hs | 29 +++- src/Typograffiti/GL.hs | 39 ++--- src/Typograffiti/Rich.hs | 297 ++++++++++++++++++++++++++++++++++++-- src/Typograffiti/Store.hs | 22 ++- src/Typograffiti/Text.hs | 43 +++++- typograffiti.cabal | 10 +- 9 files changed, 461 insertions(+), 67 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 7c79301..4090112 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -2,8 +2,11 @@ module Main where import System.Environment (getArgs) -import Graphics.Text.Font.Render (makeDrawText', GlyphSize(..), TextTransform(..), - AllocatedRendering(..), SpatialTransform(..)) +import Typograffiti (makeDrawText', GlyphSize(..), TextTransform(..), txt, + SampleText(..), defaultSample, AllocatedRendering(..), + SpatialTransform(..)) +import Control.Monad.Except (liftEither, runExceptT) +import Control.Monad.IO.Class (MonadIO (..)) import SDL hiding (rotate) import Graphics.GL.Core32 @@ -26,22 +29,25 @@ main = do let ttfName = "assets/Lora-Regular.ttf" text <- pack <$> unwords <$> getArgs - drawText <- makeDrawText' ttfName 0 (PixelSize 15 15) [] text - drawText' <- drawText text - - fix $ \loop -> do - events <- fmap eventPayload <$> pollEvents - glClearColor 0 0 0 1 - glClear GL_COLOR_BUFFER_BIT - - sz@(V2 dw dh) <- glGetDrawableSize w - glViewport 0 0 (fromIntegral dw) (fromIntegral dh) - - let offset = V2 0 $ fromIntegral dy - V2 _ dy = arSize drawText' - arDraw drawText' [ - TextTransformSpatial $ SpatialTransformTranslate offset - ] sz - - glSwapWindow w - unless (QuitEvent `elem` events) loop + drawText <- makeDrawText' ttfName 0 (PixelSize 15 15) $ defaultSample { sampleText = text } + runExceptT $ do + drawText0 <- liftEither drawText + drawText' <- drawText0 $ txt text + + fix $ \loop -> do + events <- fmap eventPayload <$> pollEvents + liftIO $ glClearColor 0 0 0 1 + liftIO $ glClear GL_COLOR_BUFFER_BIT + + sz@(V2 dw dh) <- liftIO $ glGetDrawableSize w + liftIO $ glViewport 0 0 (fromIntegral dw) (fromIntegral dh) + + let offset = V2 0 $ fromIntegral dy + V2 _ dy = arSize drawText' + liftIO $ arDraw drawText' [ + TextTransformSpatial $ SpatialTransformTranslate $ fromIntegral dy + ] (fromIntegral <$> sz) + + liftIO $ glSwapWindow w + unless (QuitEvent `elem` events) loop + return () diff --git a/src/Typograffiti.hs b/src/Typograffiti.hs index 493dbca..097e1ef 100644 --- a/src/Typograffiti.hs +++ b/src/Typograffiti.hs @@ -17,7 +17,7 @@ module Typograffiti( varItalic, varOptSize, varSlant, varWidth, varWeight, RichText (..), str, txt, ($$), style, apply, on, off, alternate, alt, case_, centerCJKPunct, capSpace, ctxtSwash, petiteCaps', smallCaps', - expertJ, finGlyph, fract, fullWidth, hist, hkana, hlig, hojo, halfWidth, + expertJ, finGlyph, fract, fullWidth, hist, hkana, histLig, hojo, halfWidth, italic, justifyAlt, jap78, jap83, jap90, jap04, kerning, lBounds, liningFig, localized, mathGreek, altAnnotation, nlcKanji, oldFig, ordinals, ornament, propAltWidth, petiteCaps, propKana, propFig, propWidth, quarterWidth, @@ -25,7 +25,7 @@ module Typograffiti( superscript, swash, titling, traditionNameJ, tabularFig, traditionCJ, thirdWidth, unicase, vAlt, vert, vHalfAlt, vKanaAlt, vKerning, vPropAlt, vRotAlt, vrot, slash0, altFrac, ctxtAlt, ctxtLig, optLigs, lig, rand, - makeDrawTextCached, makeDrawText + GlyphSize(..), makeDrawTextCached, makeDrawText, makeDrawText' ) where import Typograffiti.Atlas diff --git a/src/Typograffiti/Atlas.hs b/src/Typograffiti/Atlas.hs index 7ae8a45..af5d5f1 100644 --- a/src/Typograffiti/Atlas.hs +++ b/src/Typograffiti/Atlas.hs @@ -40,6 +40,7 @@ import Foreign.C.String (withCString) import Typograffiti.GL +-- | Represents a failure to render text. data TypograffitiError = TypograffitiErrorNoGlyphMetricsForChar Char -- ^ The are no glyph metrics for this character. This probably means @@ -54,36 +55,57 @@ data TypograffitiError = --- Atlas ------ +-- | Size & position of a Glyph in the `Atlas`. data GlyphMetrics = GlyphMetrics { glyphTexBB :: (V2 Int, V2 Int), + -- ^ Bounding box of the glyph in the texture. glyphTexSize :: V2 Int, + -- ^ Size of the glyph in the texture. glyphSize :: V2 Int + -- ^ Size of the glyph onscreen. } deriving (Show, Eq) +-- | Cache of rendered glyphs to be composited into place on the GPU. data Atlas = Atlas { atlasTexture :: GLuint, + -- ^ The texture holding the pre-rendered glyphs. atlasTextureSize :: V2 Int, + -- ^ The size of the texture. atlasMetrics :: IntMap GlyphMetrics, + -- ^ Mapping from glyphs to their position in the texture. atlasFilePath :: FilePath + -- ^ Filepath for the font. } deriving (Show) +-- | Initializes an empty atlas. emptyAtlas :: GLuint -> Atlas emptyAtlas t = Atlas t 0 mempty "" +-- | Precomputed positioning of glyphs in an `Atlas` texture. data AtlasMeasure = AM { amWH :: V2 Int, + -- ^ Current size of the atlas as it has been laid out so far. amXY :: V2 Int, + -- ^ Tentative position for the next glyph added to the atlas. rowHeight :: Int, + -- ^ Height of the current row, for the sake of line wrapping. amMap :: IntMap (V2 Int) + -- ^ Position of each glyph in the atlas. } deriving (Show, Eq) +-- | Initializes a new `AtlasMeasure`. emptyAM :: AtlasMeasure emptyAM = AM 0 (V2 1 1) 0 mempty +-- | The amount of spacing between glyphs rendered into the atlas's texture. spacing :: Int spacing = 1 +-- | Callback for looking up a glyph from an atlas. +-- Useful for applying synthetic styles to fonts which lack them, +-- when calling the low-level APIs. type GlyphRetriever m = Word32 -> m (FT_Bitmap, FT_Glyph_Metrics) +-- | Default callback for glyph lookups, with no modifications. glyphRetriever :: MonadIO m => FT_Face -> GlyphRetriever m glyphRetriever font glyph = liftIO $ do ft_Load_Glyph font (fromIntegral $ fromEnum glyph) FT_LOAD_RENDER @@ -91,6 +113,8 @@ glyphRetriever font glyph = liftIO $ do slot <- peek $ frGlyph font' return (gsrBitmap slot, gsrMetrics slot) +-- | Extract the measurements of a character in the FT_Face and append it to +-- the given AtlasMeasure. measure :: MonadIO m => GlyphRetriever m -> Int -> AtlasMeasure -> Word32 -> m AtlasMeasure measure cb maxw am@AM{..} glyph | Just _ <- IM.lookup (fromEnum glyph) amMap = return am @@ -114,6 +138,7 @@ measure cb maxw am@AM{..} glyph } return am +-- | Uploads glyphs into an `Atlas` texture for the GPU to composite. texturize :: MonadIO m => GlyphRetriever m -> IntMap (V2 Int) -> Atlas -> Word32 -> m Atlas texturize cb xymap atlas@Atlas{..} glyph | Just pos@(V2 x y) <- IM.lookup (fromIntegral $ fromEnum glyph) xymap = do @@ -136,9 +161,14 @@ texturize cb xymap atlas@Atlas{..} glyph } return atlas { atlasMetrics = IM.insert (fromEnum glyph) mtrcs atlasMetrics } | otherwise = do + -- TODO Throw an exception. liftIO $ putStrLn ("Cound not find glyph " ++ show glyph) return atlas +-- | Allocate a new 'Atlas'. +-- When creating a new 'Atlas' you must pass all the characters that you +-- might need during the life of the 'Atlas'. Character texturization only +-- happens once. allocAtlas :: (MonadIO m, MonadFail m) => GlyphRetriever m -> [Word32] -> m Atlas allocAtlas cb glyphs = do AM {..} <- foldM (measure cb 512) emptyAM glyphs @@ -162,10 +192,13 @@ allocAtlas cb glyphs = do glPixelStorei GL_UNPACK_ALIGNMENT 4 return atlas { atlasTextureSize = V2 w h } +-- | Releases all resources associated with the given 'Atlas'. freeAtlas :: MonadIO m => Atlas -> m () freeAtlas a = liftIO $ with (atlasTexture a) $ \ptr -> glDeleteTextures 1 ptr +-- | The geometry needed to render some text, with the position for the next glyph. type Quads = (Float, Float, [Vector (V2 Float, V2 Float)]) +-- | Construct the geometry needed to render the given character. makeCharQuad :: (MonadIO m, MonadError TypograffitiError m) => Atlas -> Quads -> (GlyphInfo, GlyphPos) -> m Quads makeCharQuad Atlas {..} (penx, peny, mLast) (GlyphInfo {codepoint=glyph}, GlyphPos {..}) = do @@ -193,11 +226,14 @@ makeCharQuad Atlas {..} (penx, peny, mLast) (GlyphInfo {codepoint=glyph}, GlyphP f' :: Int -> Float f' = fromIntegral +-- | Generate the geometry of the given string, with next-glyph position. stringTris :: (MonadIO m, MonadError TypograffitiError m) => Atlas -> [(GlyphInfo, GlyphPos)] -> m Quads stringTris atlas = foldM (makeCharQuad atlas) (0, 0, []) +-- | Generate the geometry of the given string. stringTris' :: (MonadIO m, MonadError TypograffitiError m) => Atlas -> [(GlyphInfo, GlyphPos)] -> m (Vector (V2 Float, V2 Float)) stringTris' atlas glyphs = do (_, _, ret) <- stringTris atlas glyphs + liftIO $ print ret return $ UV.concat $ reverse ret diff --git a/src/Typograffiti/Cache.hs b/src/Typograffiti/Cache.hs index 1983a4a..0102e90 100644 --- a/src/Typograffiti/Cache.hs +++ b/src/Typograffiti/Cache.hs @@ -36,9 +36,14 @@ import Data.Text.Glyphize (GlyphInfo(..), GlyphPos(..)) import Typograffiti.Atlas import Typograffiti.GL +-- | Generic operations for text layout. class Layout t where translate :: t -> V2 Float -> t +-- | Holds an allocated draw function for some amount of text. The function +-- takes one parameter that can be used to transform the text in various ways. +-- This type is generic and can be used to take advantage of your own font +-- rendering shaders. data AllocatedRendering t = AllocatedRendering { arDraw :: t -> V2 Int -> IO () -- ^ Draw the text with some transformation in some monad. @@ -48,6 +53,8 @@ data AllocatedRendering t = AllocatedRendering -- ^ The size (in pixels) of the drawn text. } +-- | Constructs a callback for for computing the geometry for +-- rendering given glyphs out of the given texture. makeDrawGlyphs :: ( MonadIO m , MonadError TypograffitiError m @@ -108,6 +115,7 @@ makeDrawGlyphs = do arSize = round <$> size } +-- | The GPU code to finalize the position of glyphs onscreen. vertexShader :: ByteString vertexShader = B8.pack $ unlines [ "#version 330 core" @@ -122,6 +130,7 @@ vertexShader = B8.pack $ unlines , "}" ] +-- | The GPU code to composite the recoloured glyph into the output image. fragmentShader :: ByteString fragmentShader = B8.pack $ unlines [ "#version 330 core" @@ -139,15 +148,21 @@ fragmentShader = B8.pack $ unlines --- Transforms ------ +-- | Geometrically transform the text. data SpatialTransform = SpatialTransformTranslate (V2 Float) + -- ^ Shift the text horizontally or vertically. | SpatialTransformScale (V2 Float) + -- ^ Resize the text. | SpatialTransformRotate Float + -- ^ Enlarge the text. - +-- | Modify the rendered text. data TextTransform = TextTransformMultiply (V4 Float) + -- ^ Adjust the colour of the rendered text. | TextTransformSpatial SpatialTransform + -- ^ Adjust the position of the rendered text. - +-- | Convert the `TextTransform`s into data that can be sent to the GPU. transformToUniforms :: [TextTransform] -> (M44 Float, V4 Float) transformToUniforms = foldl toUniform (identity, 1.0) where toUniform (mv, clr) (TextTransformMultiply c) = @@ -162,32 +177,33 @@ transformToUniforms = foldl toUniform (identity, 1.0) mv !*! mat4Rotate r (V3 0 0 1) in (mv1, clr) +-- | Shift the text horizontally or vertically. move :: Float -> Float -> TextTransform move x y = TextTransformSpatial $ SpatialTransformTranslate $ V2 x y - +-- | Resize the text. scale :: Float -> Float -> TextTransform scale x y = TextTransformSpatial $ SpatialTransformScale $ V2 x y - +-- | Rotate the text. rotate :: Float -> TextTransform rotate = TextTransformSpatial . SpatialTransformRotate - +-- | Recolour the text. color :: Float -> Float -> Float -> Float -> TextTransform color r g b a = TextTransformMultiply $ V4 r g b a - +-- | Make the text semi-transparant. alpha :: Float -> TextTransform alpha = TextTransformMultiply @@ -197,6 +213,7 @@ alpha = instance Layout [TextTransform] where translate ts (V2 x y) = ts ++ [move x y] +-- | Utility for calling OpenGL APIs in a error monad. liftGL :: ( MonadIO m , MonadError TypograffitiError m diff --git a/src/Typograffiti/GL.hs b/src/Typograffiti/GL.hs index d61e936..5166757 100644 --- a/src/Typograffiti/GL.hs +++ b/src/Typograffiti/GL.hs @@ -25,7 +25,7 @@ import Linear import Linear.V (Finite, Size, dim, toV) import Data.List (foldl') - +-- | Allocates a new active texture (image data) in the GPU. allocAndActivateTex :: (MonadIO m, MonadFail m) => GLenum -> m GLuint allocAndActivateTex u = do [t] <- liftIO $ allocaArray 1 $ \ptr -> do @@ -35,7 +35,7 @@ allocAndActivateTex u = do glBindTexture GL_TEXTURE_2D t return t - +-- | Report any exceptions encounted by OpenGL. clearErrors :: MonadIO m => String -> m () clearErrors str = do err' <- glGetError @@ -43,7 +43,7 @@ clearErrors str = do liftIO $ putStrLn $ unwords [str, show err'] assert False $ return () - +-- | Allocates a new, bound Vertex Array Object. newBoundVAO :: (MonadIO m, MonadFail m) => m GLuint newBoundVAO = do [vao] <- liftIO $ allocaArray 1 $ \ptr -> do @@ -53,7 +53,8 @@ newBoundVAO = do return vao - +-- | Runs the given callback giving a new temporarily-bound Vertex Array Object, +-- catching any errors. withVAO :: MonadIO m => (GLuint -> IO b) -> m b withVAO f = liftIO $ do vao <- newBoundVAO @@ -62,7 +63,7 @@ withVAO f = liftIO $ do glBindVertexArray 0 return r - +-- | Allocates a new buffer on the GPU. newBuffer :: MonadIO m => m GLuint @@ -72,7 +73,7 @@ newBuffer = liftIO $ do peekArray 1 ptr return b - +-- Allocates the given number of buffer objects to pass to the given callback. withBuffers :: MonadIO m => Int -> ([GLuint] -> m b) -> m b withBuffers n = (replicateM n newBuffer >>=) @@ -107,7 +108,7 @@ bufferGeometry loc buf as glVertexAttribPointer loc n GL_FLOAT GL_FALSE 0 nullPtr clearErrors "bufferGeometry" - +-- | Converts an unboxed vector to a storable vector suitable for storing in a GPU buffer. convertVec :: (Unbox (f Float), Foldable f) => UV.Vector (f Float) -> SV.Vector GLfloat convertVec = @@ -125,6 +126,8 @@ withBoundTextures ts f = do where bindTex tex u = glActiveTexture u >> glBindTexture GL_TEXTURE_2D tex +-- | Render the given slice of the given Vertex-Array Object with the given program +-- in the given mode, with exception handling. drawVAO :: MonadIO m => GLuint @@ -143,7 +146,7 @@ drawVAO program vao mode num = liftIO $ do glDrawArrays mode 0 num clearErrors "drawBuffer:glDrawArrays" - +-- | Compiles GLSL code to GPU opcodes, or returns an error message. compileOGLShader :: MonadIO m => ByteString @@ -183,7 +186,8 @@ compileOGLShader src shType = do return $ Left err else return $ Right shader - +-- Combine multiple compiled GLSL shaders into a single program, +-- or returns an error message. compileOGLProgram :: MonadIO m => [(String, Integer)] @@ -227,14 +231,15 @@ compileOGLProgram attribs shaders = do -- Uniform marshaling functions -------------------------------------------------------------------------------- - +-- | Lookup ID for a named uniform GLSL variable. getUniformLocation :: MonadIO m => GLuint -> String -> m GLint getUniformLocation program ident = liftIO $ withCString ident $ glGetUniformLocation program - +-- | Data that can be uploaded to GLSL uniform variables. class UniformValue a where + -- | Upload a value to a GLSL uniform variable. updateUniform :: MonadIO m => GLuint @@ -245,7 +250,7 @@ class UniformValue a where -- ^ The value. -> m () - +-- | Report exceptions setting GLSL uniform variables. clearUniformUpdateError :: (MonadIO m, Show a) => GLuint -> GLint -> a -> m () clearUniformUpdateError prog loc val = glGetError >>= \case 0 -> return () @@ -328,15 +333,15 @@ instance UniformValue (Int,Int) where -- Matrix helpers -------------------------------------------------------------------------------- - +-- | Constructs a matrix that shifts a vector horizontally or vertically. mat4Translate :: Num a => V3 a -> M44 a mat4Translate = mkTransformationMat identity - +-- | Constructs a matrix that rotates a vector. mat4Rotate :: (Num a, Epsilon a, Floating a) => a -> V3 a -> M44 a mat4Rotate phi v = mkTransformation (axisAngle v phi) (V3 0 0 0) - +-- | Constructs a matrix that resizes a vector. mat4Scale :: Num a => V3 a -> M44 a mat4Scale (V3 x y z) = V4 (V4 x 0 0 0) @@ -344,7 +349,7 @@ mat4Scale (V3 x y z) = (V4 0 0 z 0) (V4 0 0 0 1) - +-- | Constructs a matrix that converts screen coordinates to range 1,-1; with perspective. orthoProjection :: Integral a => V2 a @@ -354,7 +359,7 @@ orthoProjection (V2 ww wh) = let (hw,hh) = (fromIntegral ww, fromIntegral wh) in ortho 0 hw hh 0 0 1 - +-- | Computes the boundingbox for an array of points. boundingBox :: (Unbox a, Real a, Fractional a) => UV.Vector (V2 a) -> (V2 a, V2 a) boundingBox vs | UV.null vs = (0,0) diff --git a/src/Typograffiti/Rich.hs b/src/Typograffiti/Rich.hs index d2fd64a..9199794 100644 --- a/src/Typograffiti/Rich.hs +++ b/src/Typograffiti/Rich.hs @@ -5,8 +5,11 @@ import Data.Text.Glyphize (Feature(..), tag_from_string, parseFeature) import Data.String (IsString(..)) import Data.Word (Word32) +-- | Retreives the length of some text as a `Word` suitable for storing in a `Feature`. +length' :: Text -> Word length' = toEnum . fromEnum . Txt.length +-- | Styled text to be rendered. data RichText = RichText { text :: Text, features :: [Feature] @@ -14,11 +17,14 @@ data RichText = RichText { instance IsString RichText where fromString x = flip RichText [] $ pack x +-- | Converts a `String` to renderable `RichText`. str :: String -> RichText str = fromString +-- | Converts `Text` to renderable `RichText`. txt :: Text -> RichText txt = flip RichText [] +-- | Concatenate richtext data. ($$) :: RichText -> RichText -> RichText RichText ltext lfeat $$ RichText rtext rfeat = RichText { text = append ltext rtext, @@ -27,11 +33,17 @@ RichText ltext lfeat $$ RichText rtext rfeat = RichText { | feat@Feature { featStart = start, featEnd = end } <- rfeat] } +-- | Applies the given OpenType Feature to the given `RichText`. +-- Check your font for details on which OpenType features are supported. +-- Or see https://learn.microsoft.com/en-us/typography/opentype/spec/featurelist/ +-- (from which much of this documentation is taken). style :: String -> Word32 -> RichText -> RichText style feat value (RichText text feats) = RichText { text = text, features = Feature (tag_from_string feat) value 0 (length' text) : feats } +-- | Parses the given syntax akin to CSS font-feature-settings & apply to +-- The given RichText. apply :: String -> RichText -> RichText apply syntax rich | Just feat <- parseFeature syntax = rich { features = feat { featStart = 0, featEnd = length' $ text rich } : features rich @@ -39,90 +51,353 @@ apply syntax rich | Just feat <- parseFeature syntax = rich { | otherwise = rich alt, case_, centerCJKPunct, capSpace, ctxtSwash, petiteCaps', smallCaps', expertJ, - finGlyph, fract, fullWidth, hist, hkana, hlig, hojo, halfWidth, italic, justifyAlt, - jap78, jap83, jap90, jap04, kerning, lBounds, liningFig, localized, mathGreek, - altAnnotation, nlcKanji, oldFig, ordinals, ornament, propAltWidth, petiteCaps, - propKana, propFig, propWidth, quarterWidth, rBounds, ruby, styleAlt, sciInferior, - smallCaps, simpleCJ, subscript, superscript, swash, titling, traditionNameJ, - tabularFig, traditionCJ, thirdWidth, unicase, vAlt, vert, vHalfAlt, vKanaAlt, - vKerning, vPropAlt, vRotAlt, vrot, slash0 :: Word32 -> RichText -> RichText -altFrac, ctxtAlt, ctxtLig, optLigs, lig, rand :: Bool -> RichText -> RichText + finGlyph, fract, fullWidth, hist, hkana, histLig, hojo, halfWidth, italic, + justifyAlt, jap78, jap83, jap90, jap04, kerning, lBounds, liningFig, localized, + mathGreek, altAnnotation, nlcKanji, oldFig, ordinals, ornament, propAltWidth, + petiteCaps, propKana, propFig, propWidth, quarterWidth, rand, rBounds, ruby, + styleAlt, sciInferior, smallCaps, simpleCJ, subscript, superscript, swash, + titling, traditionNameJ, tabularFig, traditionCJ, thirdWidth, unicase, vAlt, + vert, vHalfAlt, vKanaAlt, vKerning, vPropAlt, vRotAlt, vrot, + slash0 :: Word32 -> RichText -> RichText +altFrac, ctxtAlt, ctxtLig, optLigs, lig :: Bool -> RichText -> RichText +-- | This feature makes all variations of a selected character accessible. +-- This serves several purposes: An application may not support the feature by +-- which the desired glyph would normally be accessed; the user may need a glyph +-- outside the context supported by the normal substitution, or the user may not +-- know what feature produces the desired glyph. Since many-to-one substitutions +-- are not covered, ligatures would not appear in this table unless they were +-- variant forms of another ligature. alt = style "aalt" +-- | Replaces figures separated by a slash with an alternative form. altFrac True= style "afrc" 4 altFrac False=style "afrc" 0 +-- | n specified situations, replaces default glyphs with alternate forms which +-- provide better joining behavior. Used in script typefaces which are designed +-- to have some or all of their glyphs join. ctxtAlt True= style "calt" 6 ctxtAlt False=style "calt" 0 +-- | Shifts various punctuation marks up to a position that works better with +-- all-capital sequences or sets of lining figures; also changes oldstyle +-- figures to lining figures. By default, glyphs in a text face are designed to +-- work with lowercase characters. Some characters should be shifted vertically +-- to fit the higher visual center of all-capital or lining text. Also, lining +-- figures are the same height (or close to it) as capitals, and fit much better +-- with all-capital text. case_ = style "case" +-- | Replaces a sequence of glyphs with a single glyph which is preferred for +-- typographic purposes. Unlike other ligature features, 'clig' specifies the +-- context in which the ligature is recommended. This capability is important +-- in some script designs and for swash ligatures. ctxtLig True= style "clig" 8 ctxtLig False=style "clig" 0 +-- | Centers specific punctuation marks for those fonts that do not include +-- centered and non-centered forms. centerCJKPunct = style "cpct" +-- | Globally adjusts inter-glyph spacing for all-capital text. Most typefaces +-- contain capitals and lowercase characters, and the capitals are positioned to +-- work with the lowercase. When capitals are used for words, they need more +-- space between them for legibility and esthetics. This feature would not apply +-- to monospaced designs. Of course the user may want to override this behavior +-- in order to do more pronounced letterspacing for esthetic reasons. capSpace = style "cpsp" +-- | This feature replaces default character glyphs with corresponding swash +-- glyphs in a specified context. Note that there may be more than one swash +-- alternate for a given character. ctxtSwash = style "cswh" +-- | This feature turns capital characters into petite capitals. It is generally +-- used for words which would otherwise be set in all caps, such as acronyms, +-- but which are desired in petite-cap form to avoid disrupting the flow of text. +-- See the 'pcap' feature description for notes on the relationship of caps, +-- smallcaps and petite caps. petiteCaps' = style "c2pc" +-- | This feature turns capital characters into small capitals. It is generally +-- used for words which would otherwise be set in all caps, such as acronyms, +-- but which are desired in small-cap form to avoid disrupting the flow of text. smallCaps' = style "c2sc" +-- | Replaces a sequence of glyphs with a single glyph which is preferred for +-- typographic purposes. This feature covers those ligatures which may be used +-- for special effect, at the user’s preference. optLigs True= style "dlig" 4 optLigs False=style "dlig" 0 +-- | Like the JIS78 Forms feature, this feature replaces standard forms in +-- Japanese fonts with corresponding forms preferred by typographers. Although +-- most of the JIS78 substitutions are included, the expert substitution goes on +-- to handle many more characters. expertJ = style "expt" +-- | Replaces line final glyphs with alternate forms specifically designed for +-- this purpose (they would have less or more advance width as need may be), to +-- help justification of text. finGlyph = style "falt" +-- | Replaces figures (digits) separated by a slash (U+002F or U+2044) with +-- “common” (diagonal) fractions. fract = style "frac" +-- | Replaces glyphs set on other widths with glyphs set on full (usually em) +-- widths. In a CJKV font, this may include “lower ASCII” Latin characters and +-- various symbols. In a European font, this feature replaces proportionally-spaced +-- glyphs with monospaced glyphs, which are generally set on widths of 0.6 em. fullWidth = style "fwid" +-- | Some letterforms were in common use in the past, but appear anachronistic +-- today. The best-known example is the long form of s; others would include the +-- old Fraktur k. Some fonts include the historical forms as alternates, so they +-- can be used for a “period” effect. This feature replaces the default (current) +-- forms with the historical alternates. While some ligatures are also used for +-- historical effect, this feature deals only with single characters. hist = style "hist" +-- | Replaces standard kana with forms that have been specially designed for only +-- horizontal writing. This is a typographic optimization for improved fit and +-- more even color. Also see 'vkana'. hkana = style "hkna" -hlig = style "hlig" +-- | Some ligatures were in common use in the past, but appear anachronistic today. +-- Some fonts include the historical forms as alternates, so they can be used for +-- a “period” effect. This feature replaces the default (current) forms with the +-- historical alternates. +histLig = style "hlig" +-- | The JIS X 0212-1990 (aka, “Hojo Kanji”) and JIS X 0213:2004 character sets +-- overlap significantly. In some cases their prototypical glyphs differ. When +-- building fonts that support both JIS X 0212-1990 and JIS X 0213:2004 (such as +-- those supporting the Adobe-Japan 1-6 character collection), it is recommended +-- that JIS X 0213:2004 forms be preferred as the encoded form. The 'hojo' +-- feature is used to access the JIS X 0212-1990 glyphs for the cases when the +-- JIS X 0213:2004 form is encoded. hojo = style "hojo" +-- | Replaces glyphs on proportional widths, or fixed widths other than half an +-- em, with glyphs on half-em (en) widths. Many CJKV fonts have glyphs which are +-- set on multiple widths; this feature selects the half-em version. There are +-- various contexts in which this is the preferred behavior, including +-- compatibility with older desktop documents. halfWidth = style "hwid" +-- | Some fonts (such as Adobe’s Pro Japanese fonts) will have both Roman and +-- Italic forms of some characters in a single font. This feature replaces the +-- Roman glyphs with the corresponding Italic glyphs. italic = style "ital" +-- | Improves justification of text by replacing glyphs with alternate forms +-- specifically designed for this purpose (they would have less or more advance +-- width as need may be). justifyAlt = style "jalt" +-- | This feature replaces default (JIS90) Japanese glyphs with the corresponding +-- forms from the JIS C 6226-1978 (JIS78) specification. jap78 = style "jp78" +-- | This feature replaces default (JIS90) Japanese glyphs with the corresponding +-- forms from the JIS X 0208-1983 (JIS83) specification. jap83 = style "jp83" +-- | This feature replaces Japanese glyphs from the JIS78 or JIS83 specifications +-- with the corresponding forms from the JIS X 0208-1990 (JIS90) specification. jap90 = style "jp90" +-- | The National Language Council (NLC) of Japan has defined new glyph shapes +-- for a number of JIS characters, which were incorporated into JIS X 0213:2004 +-- as new prototypical forms. The 'jp04' feature is a subset of the 'nlck' +-- feature, and is used to access these prototypical glyphs in a manner that +-- maintains the integrity of JIS X 0213:2004. jap04 = style "jp04" +-- | Adjusts amount of space between glyphs, generally to provide optically +-- consistent spacing between glyphs. Although a well-designed typeface has +-- consistent inter-glyph spacing overall, some glyph combinations require +-- adjustment for improved legibility. Besides standard adjustment in the +-- horizontal direction, this feature can supply size-dependent kerning data +-- via device tables, “cross-stream” kerning in the Y text direction, and +-- adjustment of glyph placement independent of the advance adjustment. Note +-- that this feature may apply to runs of more than two glyphs, and would not +-- be used in monospaced fonts. Also note that this feature does not apply to +-- text set vertically. kerning = style "kern" +-- | Aligns glyphs by their apparent left extents at the left ends of horizontal +-- lines of text, replacing the default behavior of aligning glyphs by their origins. lBounds = style "lfbd" +-- | Replaces a sequence of glyphs with a single glyph which is preferred for +-- typographic purposes. This feature covers the ligatures which the +-- designer or manufacturer judges should be used in normal conditions. lig True = style "liga" 4 lig False = style "liga" 0 +-- | This feature changes selected non-lining figures (digits) to lining figures. liningFig = style "lnum" +-- | Many scripts used to write multiple languages over wide geographical areas +-- have developed localized variant forms of specific letters, which are used by +-- individual literary communities. For example, a number of letters in the +-- Bulgarian and Serbian alphabets have forms distinct from their Russian +-- counterparts and from each other. In some cases the localized form differs +-- only subtly from the script “norm”, in others the forms are radically distinct. +-- This feature enables localized forms of glyphs to be substituted for default forms. localized = style "locl" +-- | Replaces standard typographic forms of Greek glyphs with corresponding forms +-- commonly used in mathematical notation (which are a subset of the Greek alphabet). mathGreek = style "mgrk" +-- | Replaces default glyphs with various notational forms (e.g. glyphs placed +-- in open or solid circles, squares, parentheses, diamonds or rounded boxes). +-- In some cases an annotation form may already be present, but the user may want +-- a different one. altAnnotation=style "nalt" +-- | The National Language Council (NLC) of Japan has defined new glyph shapes +-- for a number of JIS characters in 2000. nlcKanji = style "nlck" +-- | This feature changes selected figures from the default or lining style to +-- oldstyle form. oldFig = style "onum" +-- | Replaces default alphabetic glyphs with the corresponding ordinal forms for +-- use after figures. One exception to the follows-a-figure rule is the numero +-- character (U+2116), which is actually a ligature substitution, but is best +-- accessed through this feature. ordinals = style "ordn" +-- | This is a dual-function feature, which uses two input methods to give the +-- user access to ornament glyphs (e.g. fleurons, dingbats and border elements) +-- in the font. One method replaces the bullet character with a selection from +-- the full set of available ornaments; the other replaces specific “lower ASCII” +-- characters with ornaments assigned to them. The first approach supports the +-- general or browsing user; the second supports the power user. ornament = style "ornm" +-- | Re-spaces glyphs designed to be set on full-em widths, fitting them onto +-- individual (more or less proportional) horizontal widths. This differs from +-- 'pwid' in that it does not substitute new glyphs (GPOS, not GSUB feature). +-- The user may prefer the monospaced form, or may simply want to ensure that +-- the glyph is well-fit and not rotated in vertical setting (Latin forms +-- designed for proportional spacing would be rotated). propAltWidth= style "palt" +-- | Some fonts contain an additional size of capital letters, shorter than the +-- regular smallcaps and whimsically referred to as petite caps. Such forms are +-- most likely to be found in designs with a small lowercase x-height, where they +-- better harmonise with lowercase text than the taller smallcaps (for examples +-- of petite caps, see the Emigre type families Mrs Eaves and Filosofia). This +-- feature turns glyphs for lowercase characters into petite capitals. Forms +-- related to petite capitals, such as specially designed figures, may be included. petiteCaps = style "pcap" +-- | Replaces glyphs, kana and kana-related, set on uniform widths (half or +-- full-width) with proportional glyphs. propKana = style "pkna" +-- | Replaces figure glyphs set on uniform (tabular) widths with corresponding +-- glyphs set on glyph-specific (proportional) widths. Tabular widths will +-- generally be the default, but this cannot be safely assumed. Of course this +-- feature would not be present in monospaced designs. propFig = style "pnum" +-- | Replaces glyphs set on uniform widths (typically full or half-em) with +-- proportionally spaced glyphs. The proportional variants are often used for the +-- Latin characters in CJKV fonts, but may also be used for Kana in Japanese fonts. propWidth = style "pwid" +-- | Replaces glyphs on other widths with glyphs set on widths of one quarter +-- of an em (half an en). The characters involved are normally figures and +-- some forms of punctuation. quarterWidth= style "qwid" -rand True = style "rand" 3 -rand False = style "rand" 0 +-- | In order to emulate the irregularity and variety of handwritten text, this +-- feature allows multiple alternate forms to be used. +rand = style "rand" +-- | Aligns glyphs by their apparent right extents at the right ends of horizontal +-- lines of text, replacing the default behavior of aligning glyphs by their origins. rBounds = style "rtbd" +-- | Japanese typesetting often uses smaller kana glyphs, generally in +-- superscripted form, to clarify the meaning of kanji which may be unfamiliar +-- to the reader. These are called “ruby”, from the old typesetting term for +-- four-point-sized type. This feature identifies glyphs in the font which have +-- been designed for this use, substituting them for the default designs. ruby = style "ruby" +-- | Many fonts contain alternate glyph designs for a purely esthetic effect; +-- these don’t always fit into a clear category like swash or historical. As in +-- the case of swash glyphs, there may be more than one alternate form. This +-- feature replaces the default forms with the stylistic alternates. styleAlt = style "salt" +-- | Replaces lining or oldstyle figures (digits) with inferior figures (smaller +-- glyphs which sit lower than the standard baseline, primarily for chemical or +-- mathematical notation). May also replace glyphs for lowercase characters with +-- alphabetic inferiors. sciInferior = style "sinf" +-- | This feature turns glyphs for lowercase characters into small capitals. It +-- is generally used for display lines set in Large & small caps, such as titles. +-- Forms related to small capitals, such as oldstyle figures, may be included. smallCaps = style "smcp" +-- | Replaces “traditional” Chinese or Japanese forms with the corresponding +-- “simplified” forms. simpleCJ = style "smpl" +-- | The 'subs' feature may replace a default glyph with a subscript glyph, or it +-- may combine a glyph substitution with positioning adjustments for proper placement. subscript = style "subs" +-- | Replaces lining or oldstyle figures with superior figures (primarily for +-- footnote indication), and replaces lowercase letters with superior letters +-- (primarily for abbreviated French titles). superscript = style "sups" +-- | This feature replaces default character glyphs with corresponding swash glyphs. +-- Note that there may be more than one swash alternate for a given character. swash = style "swsh" +-- | This feature replaces the default glyphs with corresponding forms designed +-- specifically for titling. These may be all-capital and\/or larger on the body, +-- and adjusted for viewing at larger sizes. titling = style "titl" +-- | Replaces “simplified” Japanese kanji forms with the corresponding +-- “traditional” forms. This is equivalent to the Traditional Forms feature, +-- but explicitly limited to the traditional forms considered proper for use +-- in personal names (as many as 205 glyphs in some fonts). traditionNameJ = style "tnam" +-- | Replaces figure glyphs set on proportional widths with corresponding glyphs +-- set on uniform (tabular) widths. Tabular widths will generally be the default, +-- but this cannot be safely assumed. Of course this feature would not be present +-- in monospaced designs. tabularFig = style "tnum" +-- | Replaces 'simplified' Chinese hanzi or Japanese kanji forms with the +-- corresponding 'traditional' forms. traditionCJ = style "trad" +-- | Replaces glyphs on other widths with glyphs set on widths of one third of an +-- em. The characters involved are normally figures and some forms of punctuation. thirdWidth = style "twid" +-- | This feature maps upper- and lowercase letters to a mixed set of lowercase +-- and small capital forms, resulting in a single case alphabet (for an example +-- of unicase, see the Emigre type family Filosofia). The letters substituted +-- may vary from font to font, as appropriate to the design. If aligning to the +-- x-height, smallcap glyphs may be substituted, or specially designed unicase +-- forms might be used. Substitutions might also include specially designed figures. unicase = style "unic" +-- | Repositions glyphs to visually center them within full-height metrics, for +-- use in vertical setting. Applies to full-width Latin, Greek, or Cyrillic +-- glyphs, which are typically included in East Asian fonts, and whose glyphs +-- are aligned on a common horizontal baseline and not rotated relative to the +-- page or text frame. vAlt = style "valt" +-- | Transforms default glyphs into glyphs that are appropriate for upright +-- presentation in vertical writing mode. While the glyphs for most characters +-- in East Asian writing systems remain upright when set in vertical writing +-- mode, some must be transformed — usually by rotation, shifting, or different +-- component ordering — for vertical writing mode. vert = style "vert" +-- | Re-spaces glyphs designed to be set on full-em heights, fitting them onto +-- half-em heights. This differs from 'valt', which repositions a glyph but does +-- not affect its advance. vHalfAlt = style "vhal" +-- | Replaces standard kana with forms that have been specially designed for only +-- vertical writing. This is a typographic optimization for improved fit and more +-- even color. Also see 'hkna'. vKanaAlt = style "vkna" +-- | Adjusts amount of space between glyphs, generally to provide optically +-- consistent spacing between glyphs. Although a well-designed typeface has +-- consistent inter-glyph spacing overall, some glyph combinations require +-- adjustment for improved legibility. Besides standard adjustment in the +-- vertical direction, this feature can supply size-dependent kerning data +-- via device tables, “cross-stream” kerning in the X text direction, and +-- adjustment of glyph placement independent of the advance adjustment. Note +-- that this feature may apply to runs of more than two glyphs, and would not +-- be used in monospaced fonts. Also note that this feature applies only to +-- text set vertically. vKerning = style "vkrn" +-- | Re-spaces glyphs designed to be set on full-em heights, fitting them onto +-- individual (more or less proportional) vertical heights. This differs from +-- 'valt', which repositions a glyph but does not affect its advance. vPropAlt = style "vpal" +-- | Replaces some fixed-width (half-, third- or quarter-width) or +-- proportional-width glyphs (mostly Latin or katakana) with forms suitable for +-- vertical writing (that is, rotated 90 degrees clockwise). Note that these are +-- a superset of the glyphs covered in the 'vert' table. vRotAlt = style "vrt2" +-- | Transforms default glyphs into glyphs that are appropriate for sideways +-- presentation in vertical writing mode. While the glyphs for most characters +-- in East Asian writing systems remain upright when set in vertical writing mode, +-- glyphs for other characters — such as those of other scripts or for particular +-- Western-style punctuation — are expected to be presented sideways in vertical writing. vrot = style "vrtr" +-- | Some fonts contain both a default form of zero, and an alternative form +-- which uses a diagonal slash through the counter. Especially in condensed +-- designs, it can be difficult to distinguish between 0 and O (zero and capital +-- O) in any situation where capitals and lining figures may be arbitrarily mixed. +-- This feature allows the user to change from the default 0 to a slashed form. slash0 = style "zero" off, on, alternate :: Word32 +-- | Typical word to turn a font-feature off. off = 0 +-- | Typical word to turn a font-feature on on = 1 +-- | Typical word to switch to the alternate setting for a font-feature. alternate = 3 diff --git a/src/Typograffiti/Store.hs b/src/Typograffiti/Store.hs index 69e0af0..c18820b 100644 --- a/src/Typograffiti/Store.hs +++ b/src/Typograffiti/Store.hs @@ -20,6 +20,7 @@ import Control.Concurrent.STM (TMVar, atomically, newTMVar, putTMVar, import Control.Monad.Except (MonadError (..), liftEither, runExceptT, ExceptT (..)) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Fail (MonadFail (..)) +import Control.Monad (unless) import Data.Map (Map) import qualified Data.Map as M import Data.Set (Set) @@ -41,17 +42,27 @@ import Typograffiti.Cache import Typograffiti.Text (GlyphSize(..), drawLinesWrapper, SampleText(..)) import Typograffiti.Rich (RichText(..)) +-- | Stored fonts at specific sizes. data FontStore n = FontStore { fontMap :: TMVar (Map (FilePath, GlyphSize, Int) Font), + -- ^ Map for looking up previously-opened fonts & their atlases. drawGlyphs :: Atlas -> [(GlyphInfo, GlyphPos)] -> n (AllocatedRendering [TextTransform]), + -- ^ Cached routine for compositing from the given atlas. lib :: FT_Library + -- ^ Globals for FreeType. } +-- | An opened font. In Harfbuzz, FreeType, & Atlas formats. data Font = Font { harfbuzz :: HB.Font, + -- ^ Font as represented by Harfbuzz. freetype :: FT_Face, + -- ^ Font as represented by FreeType. atlases :: TMVar [(IS.IntSet, Atlas)] + -- ^ Glyphs from the font rendered into GPU atleses. } +-- | Opens a font sized to given value & prepare to render text in it. +-- The fonts are cached for later reuse. makeDrawTextCached :: (MonadIO m, MonadFail m, MonadError TypograffitiError m, MonadIO n, MonadFail n, MonadError TypograffitiError n) => FontStore n -> FilePath -> Int -> GlyphSize -> SampleText -> @@ -76,6 +87,8 @@ makeDrawTextCached store filepath index fontsize SampleText {..} = do return $ drawLinesWrapper tabwidth $ \RichText {..} -> drawGlyphs store atlas $ shape (harfbuzz font) defaultBuffer { HB.text = text } [] +-- | Opens & sizes the given font using both FreeType & Harfbuzz, +-- loading it into the `FontStore` before returning. allocFont :: (MonadIO m) => FontStore n -> FilePath -> Int -> GlyphSize -> HB.FontOptions -> m Font allocFont FontStore {..} filepath index fontsize options = liftIO $ do @@ -88,7 +101,9 @@ allocFont FontStore {..} filepath index fontsize options = liftIO $ do bytes <- B.readFile filepath let font' = HB.createFontWithOptions options $ HB.createFace bytes $ toEnum index - liftIO $ ft_Set_Var_Design_Coordinates font $ map float2fixed $ HB.fontVarCoordsDesign font' + + let designCoords = map float2fixed $ HB.fontVarCoordsDesign font' + unless (null designCoords) $ liftIO $ ft_Set_Var_Design_Coordinates font designCoords atlases <- liftIO $ atomically $ newTMVar [] let ret = Font font' font atlases @@ -102,6 +117,8 @@ allocFont FontStore {..} filepath index fontsize options = liftIO $ do float2fixed :: Float -> FT_Fixed float2fixed = toEnum . fromEnum . (*65536) +-- | Allocates a new Atlas for the given font & glyphset, +-- loading it into the atlas cache before returning. allocAtlas' :: (MonadIO m, MonadFail m) => TMVar [(IS.IntSet, Atlas)] -> FT_Face -> IS.IntSet -> m Atlas allocAtlas' atlases font glyphset = do @@ -113,11 +130,14 @@ allocAtlas' atlases font glyphset = do putTMVar atlases $ ((glyphset, atlas):a) return atlas +-- | Runs the given callback with a new `FontStore`. +-- Due to FreeType limitations this font store should not persist outside the callback. withFontStore :: (MonadIO n, MonadError TypograffitiError n, MonadFail n) => (FontStore n -> ExceptT TypograffitiError IO a) -> IO (Either TypograffitiError a) withFontStore cb = ft_With_FreeType $ \lib -> runExceptT $ (newFontStore lib >>= cb) +-- | Allocates a new FontStore wrapping given FreeType state. newFontStore :: (MonadIO m, MonadError TypograffitiError m, MonadIO n, MonadError TypograffitiError n, MonadFail n) => FT_Library -> m (FontStore n) newFontStore lib = do diff --git a/src/Typograffiti/Text.hs b/src/Typograffiti/Text.hs index c906a03..662cbc2 100644 --- a/src/Typograffiti/Text.hs +++ b/src/Typograffiti/Text.hs @@ -21,7 +21,7 @@ import Control.Concurrent.STM (TMVar, atomically, newTMVar, putTMVar, import Control.Monad.Except (MonadError (..), liftEither, runExceptT) import Control.Monad.Fail (MonadFail (..)) import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad (foldM, forM) +import Control.Monad (foldM, forM, unless) import Data.Map (Map) import qualified Data.Map as M import Data.Set (Set) @@ -44,19 +44,34 @@ import Typograffiti.Atlas import Typograffiti.Cache import Typograffiti.Rich (RichText(..)) +-- | How large the text should be rendered. data GlyphSize = CharSize Float Float Int Int + -- ^ Size in Pts at given DPI. | PixelSize Int Int + -- ^ Size in device pixels. deriving (Show, Eq, Ord) +-- | Extra parameters for constructing a font atlas, +-- and determining which glyphs should be in it. data SampleText = SampleText { sampleFeatures :: [HB.Feature], + -- ^ Which OpenType Features you want available to be used in the rendered text. + -- Defaults to none. sampleText :: Text, + -- ^ Indicates which characters & ligatures will be in the text to be rendered. + -- Defaults to ASCII, no ligatures. tabwidth :: Int, + -- ^ How many spaces wide should a tab be rendered? + -- Defaults to 4. fontOptions :: FontOptions + -- ^ Additional font options offered by Harfbuzz. } +-- | Constructs a `SampleText` with default values. defaultSample :: SampleText defaultSample = SampleText [] (pack $ map toEnum [32..126]) 4 defaultFontOptions +-- | Appends an OpenType feature callers may use to the `Sample` ensuring its +-- glyphs are available. Call after setting `sampleText`. addSampleFeature :: String -> Word32 -> SampleText -> SampleText addSampleFeature name value sample@SampleText {..} = sample { sampleFeatures = @@ -67,13 +82,18 @@ addSampleFeature name value sample@SampleText {..} = sample { i = w $ length sampleFeatures w :: Int -> Word w = toEnum +-- | Parse an OpenType feature into this font using syntax akin to +-- CSS font-feature-settings. parseSampleFeature :: String -> SampleText -> SampleText parseSampleFeature syntax sample | Just feat <- parseFeature syntax = sample { sampleFeatures = feat : sampleFeatures sample } | otherwise = sample +-- | Parse multiple OpenType features into this font. parseSampleFeatures :: [String] -> SampleText -> SampleText parseSampleFeatures = flip $ foldl $ flip parseSampleFeature +-- | Alter which OpenType variant of this font will be rendered. +-- Please check your font which variants are supported. addFontVariant :: String -> Float -> SampleText -> SampleText addFontVariant name val sampleText = sampleText { fontOptions = (fontOptions sampleText) { @@ -81,6 +101,8 @@ addFontVariant name val sampleText = sampleText { optionVariations (fontOptions sampleText) } } +-- | Parse a OpenType variant into the configured font using syntax akin to +-- CSS font-variant-settings. parseFontVariant :: String -> SampleText -> SampleText parseFontVariant syntax sample | Just var <- parseVariation syntax = sample { fontOptions = (fontOptions sample) { @@ -88,15 +110,23 @@ parseFontVariant syntax sample | Just var <- parseVariation syntax = sample { } } | otherwise = sample +-- | Parse multiple OpenType variants into this font. parseFontVariants :: [String] -> SampleText -> SampleText parseFontVariants = flip $ foldl $ flip parseFontVariant +-- | Standard italic font variant. Please check if your font supports this. varItalic = "ital" +-- | Standard optical size font variant. Please check if your font supports this. varOptSize = "opsz" +-- | Standard slant (oblique) font variant. Please check if your font supports this. varSlant = "slnt" +-- | Standard width font variant. Please check if your font supports this. varWidth = "wdth" +-- | Standard weight (boldness) font variant. Please check if your font supports this. varWeight = "wght" +-- | Opens a font sized to the given value & prepare to render text in it. +-- There is no need to keep the given `FT_Library` live before rendering the text. makeDrawText :: (MonadIO m, MonadFail m, MonadError TypograffitiError m, MonadIO n, MonadFail n, MonadError TypograffitiError n) => FT_Library -> FilePath -> Int -> GlyphSize -> SampleText -> @@ -116,22 +146,27 @@ makeDrawText lib filepath index fontsize SampleText {..} = do HB.text = Txt.replicate (toEnum $ succ $ length sampleFeatures) sampleText } sampleFeatures let glyphs' = map toEnum $ IS.toList $ IS.fromList $ map fromEnum glyphs - -- FIXME expose this function... - liftIO $ ft_Set_Var_Design_Coordinates font $ map float2fixed $ HB.fontVarCoordsDesign font' + + let designCoords = map float2fixed $ HB.fontVarCoordsDesign font' + unless (null designCoords) $ liftIO $ ft_Set_Var_Design_Coordinates font designCoords + atlas <- allocAtlas (glyphRetriever font) glyphs' liftIO $ ft_Done_Face font drawGlyphs <- makeDrawGlyphs - return $ drawLinesWrapper tabwidth $ \RichText {..} -> + -- FIXME get drawLinesWrapper working again! + return $ \RichText {..} -> drawGlyphs atlas $ shape font' defaultBuffer { HB.text = text } features where x2 = (*2) float2fixed :: Float -> FT_Fixed float2fixed = toEnum . fromEnum . (*65536) +-- | Variant of `makeDrawText` which initializes FreeType itself. makeDrawText' a b c d = ft_With_FreeType $ \ft -> runExceptT $ makeDrawText ft a b c d +-- | Internal utility for rendering multiple lines of text & expanding tabs as configured. drawLinesWrapper :: (MonadIO m, MonadFail m) => Int -> (RichText -> m (AllocatedRendering [TextTransform])) -> RichText -> m (AllocatedRendering [TextTransform]) diff --git a/typograffiti.cabal b/typograffiti.cabal index 4069ea3..3b4bcb6 100644 --- a/typograffiti.cabal +++ b/typograffiti.cabal @@ -40,9 +40,9 @@ library default-language: Haskell2010 ---executable typograffiti --- main-is: Main.hs --- build-depends: base >=4.12 && <4.13, typograffiti, sdl2 >= 2.5.4, text, gl --- hs-source-dirs: app --- default-language: Haskell2010 +executable typograffiti + main-is: Main.hs + build-depends: base >=4.12 && <4.13, typograffiti, sdl2 >= 2.5.4, text, gl, mtl + hs-source-dirs: app + default-language: Haskell2010 -- 2.30.2