diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ # Changelog for typograffiti +## 03-02-2023 Typograffiti 0.2 +* Refactored to incorporate Harfbuzz text shaping, exposing new styling options & broadening language support. +* Allow dependency-injecting alternative glyph-rasterization functions. + ## Unreleased changes diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Author name here (c) 2018 +Copyright (c) 2022, Adrian Cochrane All rights reserved. @@ -13,7 +13,7 @@ disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of Author name here nor the names of other + * Neither the name of Adrian Cochrane nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,11 @@ -# typograffiti -Typograffiti aims to make working with text in multimedia applications easy. +# Typograffiti +Typograffiti aims to make working with text across a broad range of written languages in multimedia applications easy. Whilst exposing low-level APIs for use by fancier text layout/rendering engines. +Typograffiti is part of [The Argonaut Stack](https://argonaut-constellation.org/) browser engine. + ## requirements * opengl 3.x * freetype 2.x +* harfbuzz 3.3+ + +The demo program additionally requires SDL2. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,70 +1,65 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} module Main where -import Control.Monad (unless) -import Control.Monad.Except (runExceptT, MonadError) -import Control.Monad.IO.Class (MonadIO (..)) -import Data.Function (fix) -import Graphics.GL -import SDL hiding (rotate) -import System.FilePath (()) - -import Typograffiti - - -myTextStuff - :: ( MonadIO m - , MonadError TypograffitiError m - ) - => Window -> m () -myTextStuff w = do - let ttfName = "assets" "Lora-Regular.ttf" - store <- newDefaultFontStore (get $ windowSize w) - RenderedText draw size <- - getTextRendering - store - ttfName - (GlyphSizeInPixels 16 16) - $ unlines - [ "Hey there!" - , "This is a test of the emergency word system." - , "Quit at any time." - ] - liftIO $ print ("text size", size) - - fix $ \loop -> do - events <- fmap eventPayload - <$> pollEvents - - glClearColor 0 0 0 1 - glClear GL_COLOR_BUFFER_BIT +import System.Environment (getArgs) +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 - (V2 dw dh) <- glGetDrawableSize w - glViewport 0 0 (fromIntegral dw) (fromIntegral dh) +import Data.Function (fix) +import Data.Text.Lazy (pack) +import Control.Monad (unless) - draw [move 20 32, rotate (pi / 4), color 1 0 1 1, alpha 0.5] +main :: IO () +main = do + SDL.initializeAll - glSwapWindow w - unless (QuitEvent `elem` events) loop + let openGL = defaultOpenGL { glProfile = Core Debug 3 3 } + wcfg = defaultWindow { + windowInitialSize = V2 640 480, + windowGraphicsContext = OpenGLContext openGL, + windowResizable = True + } + w <- createWindow "Typograffiti" wcfg + _ <- glCreateContext w + let ttfName = "assets/Lora-Regular.ttf" + args <- getArgs + let text = pack $ case args of + [] -> unlines [ + "Decoder Ring Theatre brings you the continuing adventures", + "of Canada's greatest superhero, that scourage of the underworld,", + "hunter of those who pray upon the innocent,", + "that marvelous masked mystery man", + "known only as The Red Panda!", + "", + "The Red Panda, masked crucader for justice, hides his secret identity", + "as one of the city's wealthiest men in his neverending battle", + "against crime & corruption. Only his trust driver, Kit Baxter", + "who joins him in the guise of The Flying Squirrel,", + "knows who wears the mask of The Red Panda!"] + _ -> unwords args + drawText <- makeDrawText' ttfName 0 (PixelSize 15 15) $ defaultSample { sampleText = text } + runExceptT $ do + drawText0 <- liftEither drawText + drawText' <- drawText0 $ txt text -main :: IO () -main = do - SDL.initializeAll + fix $ \loop -> do + events <- fmap eventPayload <$> pollEvents + liftIO $ glClearColor 0 0 0 1 + liftIO $ glClear GL_COLOR_BUFFER_BIT - let openGL = defaultOpenGL - { glProfile = Core Debug 3 3 } - wcfg = defaultWindow - { windowInitialSize = V2 640 480 - , windowOpenGL = Just openGL - , windowResizable = True - } + sz@(V2 dw dh) <- liftIO $ glGetDrawableSize w + liftIO $ glViewport 0 0 (fromIntegral dw) (fromIntegral dh) - w <- createWindow "Typograffiti" wcfg - _ <- glCreateContext w + liftIO $ arDraw drawText' [ + TextTransformSpatial $ SpatialTransformTranslate $ fromIntegral 10 + ] (fromIntegral <$> sz) - runExceptT (myTextStuff w) - >>= either (fail . show) return + liftIO $ glSwapWindow w + unless (QuitEvent `elem` events) loop + return () diff --git a/src/Typograffiti.hs b/src/Typograffiti.hs --- a/src/Typograffiti.hs +++ b/src/Typograffiti.hs @@ -1,47 +1,36 @@ -- | -- Module: Typograffiti --- Copyright: (c) 2018 Schell Scivally +-- Copyright: (c) 2018 Schell Scivally, 2023 Adrian Cochrane -- License: MIT -- Maintainer: Schell Scivally +-- & Adrian Cochrane -- --- This module provides easy freetype2-based font rendering with a nice --- Haskell interface. -module Typograffiti - ( - -- * Some simple default text rendering operations - RenderedText (..) - , TextRenderingData (..) - , FontStore - , newDefaultFontStore - , getTextRendering - -- * Transforming rendered text - , TextTransform (..) - -- TODO Vector variants of the transformation helpers. - -- i.e. moveV2, scaleV2, colorV4 - , move - , scale - , rotate - , color - , alpha - , Layout (..) - -- * Getting low - , allocAtlas - , loadText - , unloadMissingWords - , stringTris - , makeDefaultAllocateWord - , asciiChars - -- * Types - , GlyphSize (..) - , CharSize (..) - , Atlas (..) - , WordCache (..) - , AllocatedRendering (..) - -- * Errors - , TypograffitiError (..) - ) where +-- This module provides easy freetype2 & Harfbuzz based font rendering with a +-- nice Haskell interface, whilst exposing low-level APIs for those who need it. +module Typograffiti( + TypograffitiError(..), + allocAtlas, freeAtlas, stringTris, Atlas(..), GlyphMetrics(..), + makeDrawGlyphs, AllocatedRendering(..), Layout(..), + SpatialTransform(..), TextTransform(..), move, scale, rotate, skew, color, alpha, + withFontStore, newFontStore, FontStore(..), Font(..), + SampleText (..), defaultSample, addSampleFeature, parseSampleFeature, parseSampleFeatures, + addFontVariant, parseFontVariant, parseFontVariants, + 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, 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, + rBounds, ruby, styleAlt, sciInferior, smallCaps, simpleCJ, subscript, + superscript, swash, titling, traditionNameJ, tabularFig, traditionCJ, + thirdWidth, unicase, vAlt, vert, vHalfAlt, vKanaAlt, vKerning, vPropAlt, + vRotAlt, vrot, slash0, altFrac, ctxtAlt, ctxtLig, optLigs, lig, rand, + GlyphSize(..), makeDrawTextCached, makeDrawText, makeDrawText' +) where -import Typograffiti.Atlas -import Typograffiti.Cache -import Typograffiti.Glyph -import Typograffiti.Store +import Typograffiti.Atlas +import Typograffiti.Cache +import Typograffiti.Store +import Typograffiti.Text +import Typograffiti.Rich diff --git a/src/Typograffiti/Atlas.hs b/src/Typograffiti/Atlas.hs --- a/src/Typograffiti/Atlas.hs +++ b/src/Typograffiti/Atlas.hs @@ -1,19 +1,21 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} -- | -- Module: Typograffiti.Atlas --- Copyright: (c) 2018 Schell Scivally +-- Copyright: (c) 2018 Schell Scivally, 2023 Adrian Cochrane -- License: MIT -- Maintainer: Schell Scivally +-- & Adrian Cochrane -- -- This module provides a font-character atlas to use in font rendering with -- opengl. -- module Typograffiti.Atlas where +import Control.Exception (try) import Control.Monad import Control.Monad.Except (MonadError (..)) +import Control.Monad.Fail (MonadFail (..)) import Control.Monad.IO.Class import Data.IntMap (IntMap) import qualified Data.IntMap as IM @@ -21,177 +23,161 @@ import qualified Data.Vector.Unboxed as UV import Foreign.Marshal.Utils (with) import Graphics.GL.Core32 -import Graphics.GL.Types -import Graphics.Rendering.FreeType.Internal.Bitmap as BM -import Graphics.Rendering.FreeType.Internal.GlyphMetrics as GM -import Linear - -import Typograffiti.GL -import Typograffiti.Glyph -import Typograffiti.Utils +import Graphics.GL.Types (GLuint) +import FreeType.Core.Base +import FreeType.Core.Types as BM +import FreeType.Exception (FtError (..)) +import Linear (V2 (..)) +import Data.Int (Int32) +import Data.Word (Word32) +import Data.Text.Glyphize (GlyphInfo (..), GlyphPos (..)) +import Foreign.Storable (peek) +import Foreign.Ptr (castPtr) +import Foreign.C.String (withCString) +import Typograffiti.GL +-- | Represents a failure to render text. data TypograffitiError = - TypograffitiErrorNoGlyphMetricsForChar Char + TypograffitiErrorNoMetricsForGlyph Int -- ^ The are no glyph metrics for this character. This probably means -- the character has not been loaded into the atlas. - | TypograffitiErrorFreetype String String + | TypograffitiErrorFreetype String Int32 -- ^ There was a problem while interacting with the freetype2 library. | TypograffitiErrorGL String -- ^ There was a problem while interacting with OpenGL. deriving (Show, Eq) - --------------------------------------------------------------------------------- --- Atlas --------------------------------------------------------------------------------- - - -data Atlas = Atlas { atlasTexture :: GLuint - , atlasTextureSize :: V2 Int - , atlasLibrary :: FT_Library - , atlasFontFace :: FT_Face - , atlasMetrics :: IntMap GlyphMetrics - , atlasGlyphSize :: GlyphSize - , atlasFilePath :: FilePath - } - +------ +--- Atlas +------ -emptyAtlas :: FT_Library -> FT_Face -> GLuint -> Atlas -emptyAtlas lib fce t = Atlas t 0 lib fce mempty (GlyphSizeInPixels 0 0) "" +-- | Size & position of a Glyph in the `Atlas`. +data GlyphMetrics = GlyphMetrics { + glyphTexBB :: (V2 Int, V2 Int), + -- ^ Bounding box 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. +} deriving (Show) -data AtlasMeasure = AM { amWH :: V2 Int - , amXY :: V2 Int - , rowHeight :: Int - } deriving (Show, Eq) +-- | 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 - +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, MonadError TypograffitiError m) => FT_Face -> GlyphRetriever m +glyphRetriever font glyph = do + liftFreetype $ ft_Load_Glyph font (fromIntegral $ fromEnum glyph) FT_LOAD_RENDER + font' <- liftIO $ peek font + slot <- liftIO $ 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 - :: FT_Face - -> Int - -> (IntMap AtlasMeasure, AtlasMeasure) - -> Char - -> FreeTypeIO (IntMap AtlasMeasure, AtlasMeasure) -measure fce maxw (prev, am@AM{..}) char - -- Skip chars that have already been measured - | fromEnum char `IM.member` prev = return (prev, am) - | otherwise = do - let V2 x y = amXY - V2 w h = amWH - -- Load the char, replacing the glyph according to - -- https://www.freetype.org/freetype2/docs/tutorial/step1.html - loadChar fce (fromIntegral $ fromEnum char) ft_LOAD_RENDER - -- Get the glyph slot - slot <- liftIO $ peek $ glyph fce - -- Get the bitmap - bmp <- liftIO $ peek $ bitmap slot - let bw = fromIntegral $ BM.width bmp - bh = fromIntegral $ rows bmp - gotoNextRow = (x + bw + spacing) >= maxw - rh = if gotoNextRow then 0 else max bh rowHeight - nx = if gotoNextRow then 0 else x + bw + spacing - nw = max w (x + bw + spacing) - nh = max h (y + rh + spacing) - ny = if gotoNextRow then nh else y - am1 = AM { amWH = V2 nw nh - , amXY = V2 nx ny - , rowHeight = rh - } - return (IM.insert (fromEnum char) am prev, am1) - - -texturize :: IntMap (V2 Int) -> Atlas -> Char -> FreeTypeIO Atlas -texturize xymap atlas@Atlas{..} char - | Just pos@(V2 x y) <- IM.lookup (fromEnum char) xymap = do - -- Load the char - loadChar atlasFontFace (fromIntegral $ fromEnum char) ft_LOAD_RENDER - -- Get the slot and bitmap - slot <- liftIO $ peek $ glyph atlasFontFace - bmp <- liftIO $ peek $ bitmap slot - -- Update our texture by adding the bitmap - glTexSubImage2D - GL_TEXTURE_2D - 0 - (fromIntegral x) - (fromIntegral y) - (fromIntegral $ BM.width bmp) - (fromIntegral $ rows bmp) - GL_RED - GL_UNSIGNED_BYTE - (castPtr $ buffer bmp) - -- Get the glyph metrics - ftms <- liftIO $ peek $ metrics slot - -- Add the metrics to the atlas - let vecwh = fromIntegral <$> V2 (BM.width bmp) (rows bmp) - canon = floor @Double @Int . (* 0.015625) . fromIntegral - vecsz = canon <$> V2 (GM.width ftms) (GM.height ftms) - vecxb = canon <$> V2 (horiBearingX ftms) (horiBearingY ftms) - vecyb = canon <$> V2 (vertBearingX ftms) (vertBearingY ftms) - vecad = canon <$> V2 (horiAdvance ftms) (vertAdvance ftms) - mtrcs = GlyphMetrics { glyphTexBB = (pos, pos + vecwh) - , glyphTexSize = vecwh - , glyphSize = vecsz - , glyphHoriBearing = vecxb - , glyphVertBearing = vecyb - , glyphAdvance = vecad - } - return atlas{ atlasMetrics = IM.insert (fromEnum char) mtrcs atlasMetrics } +measure :: (MonadIO m, MonadError TypograffitiError m) => + GlyphRetriever m -> Int -> AtlasMeasure -> Word32 -> m AtlasMeasure +measure cb maxw am@AM{..} glyph + | Just _ <- IM.lookup (fromEnum glyph) amMap = return am + | otherwise = do + let V2 x y = amXY + V2 w h = amWH + (bmp, _) <- cb glyph + let bw = fromIntegral $ bWidth bmp + bh = fromIntegral $ bRows bmp + gotoNextRow = (x + bw + spacing >= maxw) + rh = if gotoNextRow then 0 else max bh rowHeight + nx = if gotoNextRow then 0 else x + bw + spacing + nw = max w (x + bw + spacing) + nh = max h (y + rh + spacing) + ny = if gotoNextRow then nh else y + am = AM { + amWH = V2 nw nh, + amXY = V2 nx ny, + rowHeight = rh, + amMap = IM.insert (fromEnum glyph) amXY amMap + } + return am - | otherwise = do - liftIO $ putStrLn "could not find xy" - return atlas +-- | Uploads glyphs into an `Atlas` texture for the GPU to composite. +texturize :: (MonadIO m, MonadError TypograffitiError 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 + (bmp, metrics) <- cb glyph + glTexSubImage2D GL_TEXTURE_2D 0 + (fromIntegral x) (fromIntegral y) + (fromIntegral $ bWidth bmp) (fromIntegral $ bRows bmp) + GL_RED GL_UNSIGNED_BYTE + (castPtr $ bBuffer bmp) + let vecwh = fromIntegral <$> V2 (bWidth bmp) (bRows bmp) + canon = floor . (* 0.5) . (* 0.015625) . realToFrac . fromIntegral + vecsz = canon <$> V2 (gmWidth metrics) (gmHeight metrics) + vecxb = canon <$> V2 (gmHoriBearingX metrics) (gmHoriBearingY metrics) + vecyb = canon <$> V2 (gmVertBearingX metrics) (gmVertBearingY metrics) + vecad = canon <$> V2 (gmHoriAdvance metrics) (gmVertAdvance metrics) + mtrcs = GlyphMetrics { + glyphTexBB = (pos, pos + vecwh), + glyphSize = vecsz + } + 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 - , MonadError TypograffitiError m - ) - => FilePath - -- ^ Path to the font file to use for this Atlas. - -> GlyphSize - -- ^ Size of glyphs in this Atlas. - -> String - -- ^ The characters to include in this 'Atlas'. - -> m Atlas -allocAtlas fontFilePath gs str = do - e <- liftIO $ runFreeType $ do - fce <- newFace fontFilePath - case gs of - GlyphSizeInPixels w h -> setPixelSizes fce w h - GlyphSizeByChar (CharSize w h dpix dpiy) -> setCharSize fce w h dpix dpiy - - (amMap, am) <- foldM (measure fce 512) (mempty, emptyAM) str +allocAtlas :: (MonadIO m, MonadFail m, MonadError TypograffitiError m) => + GlyphRetriever m -> [Word32] -> m Atlas +allocAtlas cb glyphs = do + AM {..} <- foldM (measure cb 512) emptyAM glyphs + let V2 w h = amWH + xymap = amMap - let V2 w h = amWH am - xymap :: IntMap (V2 Int) - xymap = amXY <$> amMap + t <- allocAndActivateTex 0 - t <- liftIO $ do - t <- allocAndActivateTex GL_TEXTURE0 - glPixelStorei GL_UNPACK_ALIGNMENT 1 - withCString (replicate (w * h) $ toEnum 0) $ + glPixelStorei GL_UNPACK_ALIGNMENT 1 + liftIO $ withCString (replicate (w * h) $ toEnum 0) $ glTexImage2D GL_TEXTURE_2D 0 GL_RED (fromIntegral w) (fromIntegral h) - 0 GL_RED GL_UNSIGNED_BYTE . castPtr - return t - - lib <- getLibrary - atlas <- foldM (texturize xymap) (emptyAtlas lib fce t) str + 0 GL_RED GL_UNSIGNED_BYTE . castPtr + atlas <- foldM (texturize cb xymap) (emptyAtlas t) glyphs glGenerateMipmap GL_TEXTURE_2D glTexParameteri GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT @@ -200,98 +186,57 @@ glTexParameteri GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_LINEAR glBindTexture GL_TEXTURE_2D 0 glPixelStorei GL_UNPACK_ALIGNMENT 4 - return - atlas{ atlasTextureSize = V2 w h - , atlasGlyphSize = gs - , atlasFilePath = fontFilePath - } - - either - (throwError . TypograffitiErrorFreetype "cannot alloc atlas") - (return . fst) - e - + return atlas { atlasTextureSize = V2 w h } -- | Releases all resources associated with the given 'Atlas'. freeAtlas :: MonadIO m => Atlas -> m () -freeAtlas a = liftIO $ do - _ <- ft_Done_FreeType (atlasLibrary a) - -- _ <- unloadMissingWords a "" - with (atlasTexture a) $ \ptr -> glDeleteTextures 1 ptr - +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 - -- ^ The atlas that contains the metrics for the given character. - -> Bool - -- ^ Whether or not to use kerning. - -> Int - -- ^ The current "pen position". - -> Maybe FT_UInt - -- ^ The freetype index of the previous character, if available. - -> Char - -- ^ The character to generate geometry for. - -> m (Vector (V2 Float, V2 Float), Int, Maybe FT_UInt) - -- ^ Returns the generated geometry (position in 2-space and UV parameters), - -- the next pen position and the freetype index of the given character, if - -- available. -makeCharQuad Atlas{..} useKerning penx mLast char = do - let ichar = fromEnum char - eNdx <- withFreeType (Just atlasLibrary) $ getCharIndex atlasFontFace ichar - let mndx = either (const Nothing) Just eNdx - px <- case (,,) <$> mndx <*> mLast <*> Just useKerning of - Just (ndx,lndx,True) -> do - e <- withFreeType (Just atlasLibrary) $ - getKerning atlasFontFace lndx ndx ft_KERNING_DEFAULT - return $ either (const penx) ((+penx) . floor . (* 0.015625) . fromIntegral . fst) e - _ -> return $ fromIntegral penx - case IM.lookup ichar atlasMetrics of - Nothing -> throwError $ TypograffitiErrorNoGlyphMetricsForChar char - Just GlyphMetrics{..} -> do - let V2 dx dy = fromIntegral <$> glyphHoriBearing - x = fromIntegral px + dx - y = -dy - V2 w h = fromIntegral <$> glyphSize - V2 aszW aszH = fromIntegral <$> atlasTextureSize - V2 texL texT = fromIntegral <$> fst glyphTexBB - V2 texR texB = fromIntegral <$> snd glyphTexBB - - tl = (V2 x y , V2 (texL/aszW) (texT/aszH)) - tr = (V2 (x+w) y , V2 (texR/aszW) (texT/aszH)) - br = (V2 (x+w) (y+h), V2 (texR/aszW) (texB/aszH)) - bl = (V2 x (y+h), V2 (texL/aszW) (texB/aszH)) - let vs = UV.fromList [ tl, tr, br - , tl, br, bl - ] - let V2 ax _ = glyphAdvance - return (vs, px + ax, mndx) - +makeCharQuad :: (MonadIO m, MonadError TypograffitiError m) => + Atlas -> Quads -> (GlyphInfo, GlyphPos) -> m Quads +makeCharQuad Atlas {..} (penx, peny, mLast) (GlyphInfo {codepoint=glyph}, GlyphPos {..}) = do + let iglyph = fromEnum glyph + case IM.lookup iglyph atlasMetrics of + Nothing -> throwError $ TypograffitiErrorNoMetricsForGlyph iglyph + Just GlyphMetrics {..} -> do + let x = penx + f x_offset + y = peny + f y_offset + V2 w h = f' <$> glyphSize + V2 aszW aszH = f' <$> atlasTextureSize + V2 texL texT = f' <$> fst glyphTexBB + V2 texR texB = f' <$> snd glyphTexBB --- | A string containing all standard ASCII characters. --- This is often passed as the 'String' parameter in 'allocAtlas'. -asciiChars :: String -asciiChars = map toEnum [32..126] + tl = (V2 (x) (y-h), V2 (texL/aszW) (texT/aszH)) + tr = (V2 (x+w) (y-h), V2 (texR/aszW) (texT/aszH)) + br = (V2 (x+w) y, V2 (texR/aszW) (texB/aszH)) + bl = (V2 (x) y, V2 (texL/aszW) (texB/aszH)) + return (penx + f x_advance/150, peny + f y_advance/150, + UV.fromList [tl, tr, br, tl, br, bl] : mLast) + where + f :: Int32 -> Float + f = fromIntegral + 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 - -- ^ The font atlas. - -> Bool - -- ^ Whether or not to use kerning. - -> String - -- ^ The string. - -> m (Vector (V2 Float, V2 Float)) -stringTris atlas useKerning str = do - (vs, _, _) <- foldM gen (mempty, 0, Nothing) str - return $ UV.concat vs - where gen (vs, penx, mndx) c = do - (newVs, newPenx, newMndx) <- makeCharQuad atlas useKerning penx mndx c - return (vs ++ [newVs], newPenx, newMndx) +stringTris' :: (MonadIO m, MonadError TypograffitiError m) => + Atlas -> [(GlyphInfo, GlyphPos)] -> m (Vector (V2 Float, V2 Float)) +stringTris' atlas glyphs = do + (_, _, ret) <- stringTris atlas glyphs + return $ UV.concat $ reverse ret + +-- | Internal utility to propagate FreeType errors into Typograffiti errors. +liftFreetype :: (MonadIO m, MonadError TypograffitiError m) => IO a -> m a +liftFreetype cb = do + err <- liftIO $ try $ cb + case err of + Left (FtError func code) -> throwError $ TypograffitiErrorFreetype func code + Right ret -> return ret diff --git a/src/Typograffiti/Cache.hs b/src/Typograffiti/Cache.hs --- a/src/Typograffiti/Cache.hs +++ b/src/Typograffiti/Cache.hs @@ -1,52 +1,43 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -- | -- Module: Typograffiti.Cache --- Copyright: (c) 2018 Schell Scivally +-- Copyright: (c) 2018 Schell Scivally, 2023 Adrian Cochrane -- License: MIT -- Maintainer: Schell Scivally +-- & Adrian Cochrane -- -- This module provides a method of caching rendererd text, making it suitable -- for interactive rendering. You can use the defaultCache or provide your own. -- module Typograffiti.Cache where -import Control.Monad (foldM) -import Control.Monad.Except (MonadError (..), liftEither, - runExceptT) +import Control.Monad.Except (MonadError (..), liftEither) +import Control.Monad.Fail (MonadFail (..)) import Control.Monad.IO.Class (MonadIO (..)) import Data.Bifunctor (first) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B8 -import qualified Data.IntMap as IM -import Data.Map (Map) -import qualified Data.Map as M -import Data.Maybe (fromMaybe) import qualified Data.Vector.Unboxed as UV -import Foreign.Marshal.Array +import Foreign.Marshal.Array (withArray) import Graphics.GL -import Linear +import Linear (V2 (..), V3 (..), V4 (..), M44 (..), + (!*!), identity) +import Data.Text.Glyphize (GlyphInfo(..), GlyphPos(..)) import Typograffiti.Atlas import Typograffiti.GL -import Typograffiti.Glyph - -- | 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 -> IO () + { arDraw :: t -> V2 Int -> IO () -- ^ Draw the text with some transformation in some monad. , arRelease :: IO () -- ^ Release the allocated draw function in some monad. @@ -54,167 +45,170 @@ -- ^ The size (in pixels) of the drawn text. } - -newtype WordCache t = WordCache - { unWordCache :: Map String (AllocatedRendering t) } - deriving (Semigroup, Monoid) - - --- | Load a string of words into the WordCache. -loadWords +-- | Constructs a callback for for computing the geometry for +-- rendering given glyphs out of the given texture. +makeDrawGlyphs :: ( MonadIO m , MonadError TypograffitiError m + , MonadIO n + , MonadFail n + , MonadError TypograffitiError n ) - => (Atlas -> String -> m (AllocatedRendering t)) - -- ^ Operation used to allocate a word. - -> Atlas - -- ^ The character atlas that holds our letters, which is used to generate - -- the word geometry. - -> WordCache t - -- ^ The atlas to load the words into. - -> String - -- ^ The string of words to load, with each word separated by spaces. - -> m (WordCache t) -loadWords f atlas (WordCache cache) str = - WordCache - <$> foldM loadWord cache (words str) - where loadWord wm word - | M.member word wm = return wm - | otherwise = - flip (M.insert word) wm <$> f atlas word - - --- | Unload any words from the cache that are not contained in the source string. -unloadMissingWords - :: MonadIO m - => WordCache t - -- ^ The WordCache to unload words from. - -> String - -- ^ The source string. - -> m (WordCache t) -unloadMissingWords (WordCache cache) str = do - let ws = M.fromList $ zip (words str) (repeat ()) - missing = M.difference cache ws - retain = M.difference cache missing - liftIO - $ sequence_ - $ arRelease <$> missing - return $ WordCache retain - + => m (Atlas + -> [(GlyphInfo, GlyphPos)] + -> n (AllocatedRendering [TextTransform]) + ) +makeDrawGlyphs = do + let position = 0 + uv = 1 + vert <- liftGL $ compileOGLShader vertexShader GL_VERTEX_SHADER + frag <- liftGL $ compileOGLShader fragmentShader GL_FRAGMENT_SHADER + prog <- liftGL $ compileOGLProgram [ + ("position", fromIntegral position), + ("uv", fromIntegral uv) + ] [vert, frag] + glUseProgram prog + glEnable GL_BLEND + glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA + -- Get uniform locations + pjU <- getUniformLocation prog "projection" + mvU <- getUniformLocation prog "modelview" + multU <- getUniformLocation prog "mult_color" + texU <- getUniformLocation prog "tex" + return $ \atlas glyphs -> do + vao <- newBoundVAO + pbuf <- newBuffer + uvbuf <- newBuffer + (ps, uvs) <- UV.unzip <$> stringTris' atlas glyphs + bufferGeometry position pbuf ps + bufferGeometry uv uvbuf uvs + glBindVertexArray 0 --- | Constructs a 'Renderer2' from the given color and string. The 'WordMap' --- record of the given 'Atlas' is used to construct the string geometry, greatly --- improving performance and allowing longer strings to be compiled and renderered --- in real time. To create a new 'Atlas' see 'allocAtlas'. --- --- Note that since word geometries are stored in the 'Atlas' 'WordMap' and multiple --- renderers can reference the same 'Atlas', the returned 'Renderer2' contains a --- clean up operation that does nothing. It is expected that the programmer --- will call 'freeAtlas' manually when the 'Atlas' is no longer needed. -loadText - :: forall m t. - ( MonadIO m - , MonadError TypograffitiError m - , Layout t - ) - => (Atlas -> String -> m (AllocatedRendering t)) - -- ^ Operation used to allocate a word. - -> Atlas - -- ^ The character atlas that holds our letters. - -> WordCache t - -- ^ The WordCache to load AllocatedRenderings into. - -> String - -- ^ The string to render. - -- This string may contain newlines, which will be respected. - -> m (t -> IO (), V2 Int, WordCache t) - -- ^ Returns a function for rendering the text, the size of the text and the - -- new WordCache with the allocated renderings of the text. -loadText f atlas wc str = do - wc1@(WordCache cache) <- loadWords f atlas wc str - let glyphw = round $ pixelWidth $ atlasGlyphSize atlas - spacew :: Int - spacew = fromMaybe glyphw $ do - metrcs <- IM.lookup (fromEnum ' ') $ atlasMetrics atlas - let V2 x _ = glyphAdvance metrcs - return x - glyphh = pixelHeight $ atlasGlyphSize atlas - spaceh = round glyphh - isWhiteSpace c = c == ' ' || c == '\n' || c == '\t' - renderWord :: t -> V2 Int -> String -> IO () - renderWord _ _ "" = return () - renderWord t (V2 _ y) ('\n':cs) = renderWord t (V2 0 (y + spaceh)) cs - renderWord t (V2 x y) (' ':cs) = renderWord t (V2 (x + spacew) y) cs - renderWord t v@(V2 x y) cs = do - let word = takeWhile (not . isWhiteSpace) cs - rest = drop (length word) cs - case M.lookup word cache of - Nothing -> renderWord t v rest - Just ar -> do - let t1 = translate t $ fromIntegral <$> v - V2 w _ = arSize ar - pen = V2 (x + fromIntegral w) y - arDraw ar t1 - renderWord t pen rest - rr t = renderWord t 0 str - measureString :: (V2 Int, V2 Int) -> String -> (V2 Int, V2 Int) - measureString xywh "" = xywh - measureString (V2 x y, V2 w _) (' ':cs) = - let nx = x + spacew in measureString (V2 nx y, V2 (max w nx) y) cs - measureString (V2 x y, V2 w h) ('\n':cs) = - let ny = y + spaceh in measureString (V2 x ny, V2 w (max h ny)) cs - measureString (V2 x y, V2 w h) cs = - let word = takeWhile (not . isWhiteSpace) cs - rest = drop (length word) cs - n = case M.lookup word cache of - Nothing -> (V2 x y, V2 w h) - Just ar -> let V2 ww _ = arSize ar - nx = x + ww - in (V2 nx y, V2 (max w nx) y) - in measureString n rest - V2 szw szh = snd $ measureString (0,0) str - return (rr, V2 szw (max spaceh szh), wc1) + let draw ts wsz = do + let (mv, multVal) = transformToUniforms ts + glUseProgram prog + let pj = orthoProjection wsz + updateUniform prog pjU pj + updateUniform prog mvU mv + updateUniform prog multU multVal + updateUniform prog texU (0 :: Int) + glBindVertexArray vao + withBoundTextures [atlasTexture atlas] $ do + drawVAO prog vao GL_TRIANGLES (fromIntegral $ UV.length ps) + glBindVertexArray 0 + release = do + withArray [pbuf, uvbuf] $ glDeleteBuffers 2 + withArray [vao] $ glDeleteVertexArrays 1 + (tl, br) = boundingBox ps + size = br - tl + return AllocatedRendering { + arDraw = draw, + arRelease = release, + arSize = round <$> size + } +-- | The GPU code to finalize the position of glyphs onscreen. +vertexShader :: ByteString +vertexShader = B8.pack $ unlines + [ "#version 330 core" + , "uniform mat4 projection;" + , "uniform mat4 modelview;" + , "in vec2 position;" + , "in vec2 uv;" + , "out vec2 fuv;" + , "void main () {" + , " fuv = uv;" + , " gl_Position = projection * modelview * vec4(position.xy, 0.0, 1.0);" + , "}" + ] --------------------------------------------------------------------------------- --- Default word allocation --------------------------------------------------------------------------------- +-- | The GPU code to composite the recoloured glyph into the output image. +fragmentShader :: ByteString +fragmentShader = B8.pack $ unlines + [ "#version 330 core" + , "in vec2 fuv;" + , "out vec4 fcolor;" + , "uniform sampler2D tex;" + , "uniform vec4 mult_color;" + , "void main () {" + , " vec4 tcolor = texture(tex, fuv);" + , " fcolor = vec4(mult_color.rgb, mult_color.a * tcolor.r);" + , "}" + ] +------ +--- 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. + | SpatialTransformSkew Float + -- ^ Skew the text, approximating italics (or rather obliques). + | SpatialTransform (M44 Float) + -- ^ Apply an arbitrary matrix transform to 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) = + (mv, clr * c) + toUniform (mv, clr) (TextTransformSpatial s) = + let mv1 = case s of + SpatialTransformTranslate (V2 x y) -> + mv !*! mat4Translate (V3 x y 0) + SpatialTransformScale (V2 x y) -> + mv !*! mat4Scale (V3 x y 1) + SpatialTransformRotate r -> + mv !*! mat4Rotate r (V3 0 0 1) + SpatialTransformSkew x -> + mv !*! mat4SkewXbyY x + SpatialTransform mat -> mv !*! mat + 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 +skew :: Float -> TextTransform +skew = TextTransformSpatial . SpatialTransformSkew +matrix :: M44 Float -> TextTransform +matrix = TextTransformSpatial . SpatialTransform + +-- | 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 @@ -224,53 +218,7 @@ instance Layout [TextTransform] where translate ts (V2 x y) = ts ++ [move x y] - -transformToUniforms - :: [TextTransform] - -> (M44 Float, V4 Float) -transformToUniforms = foldl toUniform (identity, 1.0) - where toUniform (mv, clr) (TextTransformMultiply c) = - (mv, clr * c) - toUniform (mv, clr) (TextTransformSpatial s) = - let mv1 = case s of - SpatialTransformTranslate (V2 x y) -> - mv !*! mat4Translate (V3 x y 0) - SpatialTransformScale (V2 x y) -> - mv !*! mat4Scale (V3 x y 1) - SpatialTransformRotate r -> - mv !*! mat4Rotate r (V3 0 0 1) - in (mv1, clr) - - -vertexShader :: ByteString -vertexShader = B8.pack $ unlines - [ "#version 330 core" - , "uniform mat4 projection;" - , "uniform mat4 modelview;" - , "in vec2 position;" - , "in vec2 uv;" - , "out vec2 fuv;" - , "void main () {" - , " fuv = uv;" - , " gl_Position = projection * modelview * vec4(position.xy, 0.0, 1.0);" - , "}" - ] - - -fragmentShader :: ByteString -fragmentShader = B8.pack $ unlines - [ "#version 330 core" - , "in vec2 fuv;" - , "out vec4 fcolor;" - , "uniform sampler2D tex;" - , "uniform vec4 mult_color;" - , "void main () {" - , " vec4 tcolor = texture(tex, fuv);" - , " fcolor = vec4(mult_color.rgb, mult_color.a * tcolor.r);" - , "}" - ] - - +-- | Utility for calling OpenGL APIs in a error monad. liftGL :: ( MonadIO m , MonadError TypograffitiError m @@ -280,83 +228,3 @@ liftGL n = do let lft = liftEither . first TypograffitiErrorGL n >>= lft - - --- | A default operation for allocating one word worth of geometry. This is "word" as in --- an English word, not a data type. -makeDefaultAllocateWord - :: ( MonadIO m - , MonadError TypograffitiError m - , Integral i - ) - => IO (V2 i) - -- ^ A monadic operation that returns the current context's dimentions. - -- This is used to set the orthographic projection for rendering text. - -> m (Atlas - -> String - -> IO (Either TypograffitiError (AllocatedRendering [TextTransform])) - ) -makeDefaultAllocateWord getContextSize = do - let position = 0 - uv = 1 - vert <- liftGL $ compileOGLShader vertexShader GL_VERTEX_SHADER - frag <- liftGL $ compileOGLShader fragmentShader GL_FRAGMENT_SHADER - prog <- liftGL $ compileOGLProgram - [ ("position", fromIntegral position) - , ("uv", fromIntegral uv) - ] - [vert, frag] - glUseProgram prog - glEnable GL_BLEND - glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA - -- Get our uniform locations - pjU <- getUniformLocation prog "projection" - mvU <- getUniformLocation prog "modelview" - multU <- getUniformLocation prog "mult_color" - texU <- getUniformLocation prog "tex" - -- Return a function that will generate new words - return $ \atlas string -> do - vao <- newBoundVAO - pbuf <- newBuffer - uvbuf <- newBuffer - -- Generate our string geometry - runExceptT (stringTris atlas True string) >>= \case - Left err -> return $ Left err - Right geom -> do - let (ps, uvs) = UV.unzip geom - -- Buffer the geometry into our attributes - bufferGeometry position pbuf ps - bufferGeometry uv uvbuf uvs - glBindVertexArray 0 - - let draw :: [TextTransform] -> IO () - draw ts = do - let (mv, multVal) = transformToUniforms ts - glUseProgram prog - wsz <- getContextSize - let pj :: M44 Float = orthoProjection wsz - updateUniform prog pjU pj - updateUniform prog mvU mv - updateUniform prog multU multVal - updateUniform prog texU (0 :: Int) - glBindVertexArray vao - withBoundTextures [atlasTexture atlas] $ do - drawVAO - prog - vao - GL_TRIANGLES - (fromIntegral $ UV.length ps) - glBindVertexArray 0 - - release = do - withArray [pbuf, uvbuf] $ glDeleteBuffers 2 - withArray [vao] $ glDeleteVertexArrays 1 - (tl, br) = boundingBox ps - - size = br - tl - return - $ Right AllocatedRendering - { arDraw = draw - , arRelease = release - , arSize = round <$> size - } diff --git a/src/Typograffiti/GL.hs b/src/Typograffiti/GL.hs --- a/src/Typograffiti/GL.hs +++ b/src/Typograffiti/GL.hs @@ -24,7 +24,7 @@ import Linear import Linear.V (Finite, Size, dim, toV) - +-- | 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 @@ -34,7 +34,7 @@ glBindTexture GL_TEXTURE_2D t return t - +-- | Report any exceptions encounted by OpenGL. clearErrors :: MonadIO m => String -> m () clearErrors str = do err' <- glGetError @@ -42,7 +42,7 @@ 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 @@ -52,7 +52,8 @@ 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 @@ -61,7 +62,7 @@ glBindVertexArray 0 return r - +-- | Allocates a new buffer on the GPU. newBuffer :: MonadIO m => m GLuint @@ -71,7 +72,7 @@ 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 >>=) @@ -106,7 +107,7 @@ 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 = @@ -124,6 +125,8 @@ 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 @@ -142,7 +145,7 @@ glDrawArrays mode 0 num clearErrors "drawBuffer:glDrawArrays" - +-- | Compiles GLSL code to GPU opcodes, or returns an error message. compileOGLShader :: MonadIO m => ByteString @@ -182,7 +185,8 @@ 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)] @@ -226,14 +230,15 @@ -- 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 @@ -244,7 +249,7 @@ -- ^ 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 () @@ -327,15 +332,15 @@ -- 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) @@ -343,7 +348,14 @@ (V4 0 0 z 0) (V4 0 0 0 1) +mat4SkewXbyY :: Num a => a -> M44 a +mat4SkewXbyY a = + V4 (V4 1 a 0 0) + (V4 0 1 0 0) + (V4 0 0 1 0) + (V4 0 0 0 1) +-- | Constructs a matrix that converts screen coordinates to range 1,-1; with perspective. orthoProjection :: Integral a => V2 a @@ -353,7 +365,7 @@ 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/Glyph.hs b/src/Typograffiti/Glyph.hs deleted file mode 100644 --- a/src/Typograffiti/Glyph.hs +++ /dev/null @@ -1,54 +0,0 @@ -module Typograffiti.Glyph where - - -import Linear - - --- | The size of one freetype font character. --- https://www.freetype.org/freetype2/docs/tutorial/step1.html#section-5 -data CharSize = CharSize - { charSizeWidth :: Int - -- ^ Width of a character specified in 1/64 of points. - , charSizeHeight :: Int - -- ^ Height of a character specified in 1/64 of points. - , charSizeWidthDPI :: Int - -- ^ Horizontal device resolution - , charSizeHeightDPI :: Int - -- ^ Vertical device resolution - } deriving (Show, Eq, Ord) - - -data GlyphSize = GlyphSizeByChar CharSize - | GlyphSizeInPixels Int Int - deriving (Show, Eq, Ord) - - -pixelWidth :: GlyphSize -> Float -pixelWidth (GlyphSizeInPixels w h) - | w == 0 = fromIntegral h - | otherwise = fromIntegral w -pixelWidth (GlyphSizeByChar (CharSize w h xdpi ydpi)) = - let dpi = if xdpi == 0 then ydpi else xdpi - sz = if w == 0 then h else w - in fromIntegral sz * fromIntegral dpi / 72 - - -pixelHeight :: GlyphSize -> Float -pixelHeight (GlyphSizeInPixels w h) - | h == 0 = fromIntegral w - | otherwise = fromIntegral h -pixelHeight (GlyphSizeByChar (CharSize w h xdpi ydpi)) = - let dpi = if ydpi == 0 then xdpi else ydpi - sz = if h == 0 then w else h - in fromIntegral sz * fromIntegral dpi / 72 - - --- | https://www.freetype.org/freetype2/docs/tutorial/step2.html -data GlyphMetrics = GlyphMetrics - { glyphTexBB :: (V2 Int, V2 Int) - , glyphTexSize :: V2 Int - , glyphSize :: V2 Int - , glyphHoriBearing :: V2 Int - , glyphVertBearing :: V2 Int - , glyphAdvance :: V2 Int - } deriving (Show, Eq) diff --git a/src/Typograffiti/Rich.hs b/src/Typograffiti/Rich.hs new file mode 100644 --- /dev/null +++ b/src/Typograffiti/Rich.hs @@ -0,0 +1,412 @@ +-- | +-- Module: Typograffiti.Rich +-- Copyright: (c) 2023 Adrian Cochrane +-- License: MIT +-- Maintainer: Schell Scivally +-- & Adrian Cochrane +-- +-- Abstraction for building richtext strings to be rendered via Typograffiti. +-- +module Typograffiti.Rich where +import Data.Text.Lazy (Text, append, pack) +import qualified Data.Text.Lazy as Txt +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] +} + +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, + features = let n = length' ltext in lfeat ++ [ + feat { featStart = start + n, featEnd = end + n } + | 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 + } + | otherwise = rich + +alt, case_, centerCJKPunct, capSpace, ctxtSwash, petiteCaps', smallCaps', 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, 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" +-- | 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" +-- | 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 --- a/src/Typograffiti/Store.hs +++ b/src/Typograffiti/Store.hs @@ -3,149 +3,178 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} -- | -- Module: Typograffiti.Monad --- Copyright: (c) 2018 Schell Scivally +-- Copyright: (c) 2018 Schell Scivally, 2023 Adrian Cochrane -- License: MIT -- Maintainer: Schell Scivally +-- & Adrian Cochrane -- -- A storage context an ops for rendering text with multiple fonts --- and sizes, hiding the details of the Atlas and WordCache. +-- and sizes, hiding the details of the Atlas, Cache, and the Harfbuzz library. module Typograffiti.Store where import Control.Concurrent.STM (TMVar, atomically, newTMVar, putTMVar, readTMVar, takeTMVar) -import Control.Monad.Except (MonadError (..), liftEither) +import Control.Monad.Except (MonadError (..), runExceptT, ExceptT (..)) import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Fail (MonadFail (..)) +import Control.Monad (unless, forM) import Data.Map (Map) import qualified Data.Map as M -import Data.Set (Set) -import qualified Data.Set as S -import Linear - +import qualified Data.IntSet as IS +import qualified Data.ByteString as B +import Data.Text.Glyphize (defaultBuffer, Buffer(..), shape, + GlyphInfo(..), GlyphPos(..), FontOptions) +import qualified Data.Text.Glyphize as HB +import qualified Data.Text.Lazy as Txt +import FreeType.Core.Base +import FreeType.Core.Types (FT_Fixed) +import FreeType.Format.Multiple (ft_Set_Var_Design_Coordinates) import Typograffiti.Atlas import Typograffiti.Cache -import Typograffiti.Glyph - +import Typograffiti.Text (GlyphSize(..), drawLinesWrapper, SampleText(..)) +import Typograffiti.Rich (RichText(..)) --- | A pre-rendered bit of text, ready to display given --- some post compilition transformations. Also contains --- the text size. -data RenderedText t m = RenderedText - { drawRenderedText :: t -> m () - , sizeOfRenderedText :: V2 Int +-- | Stored fonts at specific sizes. +data FontStore n = FontStore { + fontMap :: TMVar (Map (FilePath, GlyphSize, Int, FontOptions) 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 -> + m (RichText -> n (AllocatedRendering [TextTransform])) +makeDrawTextCached store filepath index fontsize SampleText {..} = do + s <- liftIO $ atomically $ readTMVar $ fontMap store + font <- case M.lookup (filepath, fontsize, index, fontOptions) s of + Nothing -> allocFont store filepath index fontsize fontOptions + Just font -> return font -data Font t = Font - { fontAtlas :: Atlas - , fontWordCache :: WordCache t - } + let glyphs = map (codepoint . fst) $ + shape (harfbuzz font) defaultBuffer { + HB.text = Txt.replicate (toEnum $ succ $ length sampleFeatures) sampleText + } sampleFeatures + let glyphset = IS.fromList $ map fromEnum glyphs + a <- liftIO $ atomically $ readTMVar $ atlases font + atlas <- case [a' | (gs, a') <- a, glyphset `IS.isSubsetOf` gs] of + (atlas:_) -> return atlas + _ -> allocAtlas' (atlases font) (freetype font) glyphset -data TextRenderingData t = TextRenderingData - { textRenderingDataAllocWord :: Atlas -> String -> IO (Either TypograffitiError (AllocatedRendering t)) - -- ^ The operation used to alloc a word. - -- Generate geometry, use a shader program, set uniforms, etc. - , textRenderingDataFontMap :: Map (FilePath, GlyphSize) (Font t) - -- ^ The cached fonts. - , textRenderingDataCharSet :: Set Char - -- ^ The character set to have available in all allocated Atlas types. - } + return $ drawLinesWrapper tabwidth minLineHeight $ + \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, MonadError TypograffitiError m) => + FontStore n -> FilePath -> Int -> GlyphSize -> HB.FontOptions -> m Font +allocFont FontStore {..} filepath index fontsize options = liftFreetype $ do + font <- ft_New_Face lib filepath $ toEnum index + case fontsize of + PixelSize w h -> ft_Set_Pixel_Sizes font (toEnum $ x2 w) (toEnum $ x2 h) + CharSize w h dpix dpiy -> ft_Set_Char_Size font (floor $ 26.6 * 2 * w) + (floor $ 26.6 * 2 * h) + (toEnum dpix) (toEnum dpiy) --- | Stored fonts at specific sizes. -newtype FontStore t = FontStore - { unFontStore :: TMVar (TextRenderingData t)} + bytes <- B.readFile filepath + let font' = HB.createFontWithOptions options $ HB.createFace bytes $ toEnum index + let designCoords = map float2fixed $ HB.fontVarCoordsDesign font' + unless (null designCoords) $ liftIO $ ft_Set_Var_Design_Coordinates font designCoords -getTextRendering - :: ( MonadIO m - , MonadError TypograffitiError m - , Layout t - ) - => FontStore t - -- ^ The font store. - -> FilePath - -- ^ The path to the font to use - -- for rendering. - -> GlyphSize - -- ^ The size of the font glyphs. - -> String - -- ^ The string to render. - -> m (RenderedText t m) - -- ^ The rendered text, ready to draw to the screen. -getTextRendering store file sz str = do - let mvar = unFontStore store - s <- liftIO $ atomically $ readTMVar mvar - font <- case M.lookup (file, sz) $ textRenderingDataFontMap s of - Nothing -> allocFont store file sz - Just font -> return font - (draw, tsz, cache) <- - loadText - (\x y -> liftIO (textRenderingDataAllocWord s x y) >>= liftEither) - (fontAtlas font) - (fontWordCache font) - str - liftIO - $ atomically $ do - s1 <- takeTMVar mvar - let alterf Nothing = Just $ Font (fontAtlas font) cache - alterf (Just (Font atlas _)) = Just $ Font atlas cache - fontmap = M.alter alterf (file,sz) - $ textRenderingDataFontMap s1 - putTMVar mvar s1{ textRenderingDataFontMap = fontmap } - return RenderedText - { drawRenderedText = liftIO . draw - , sizeOfRenderedText = tsz - } + atlases <- liftIO $ atomically $ newTMVar [] + let ret = Font font' font atlases + atomically $ do + map <- takeTMVar fontMap + putTMVar fontMap $ M.insert (filepath, fontsize, index, options) ret map + return ret + where + x2 = (*2) + float2fixed :: Float -> FT_Fixed + float2fixed = toEnum . fromEnum . (*65536) -newDefaultFontStore - :: ( MonadIO m - , MonadError TypograffitiError m - , Integral i - ) - => IO (V2 i) - -> m (FontStore [TextTransform]) -newDefaultFontStore getDims = do - aw <- makeDefaultAllocateWord getDims - let dat = TextRenderingData - { textRenderingDataAllocWord = aw - , textRenderingDataFontMap = mempty - , textRenderingDataCharSet = S.fromList asciiChars - } - FontStore - <$> liftIO (atomically $ newTMVar dat) +-- | Allocates a new Atlas for the given font & glyphset, +-- loading it into the atlas cache before returning. +allocAtlas' :: (MonadIO m, MonadFail m, MonadError TypograffitiError m) => + TMVar [(IS.IntSet, Atlas)] -> FT_Face -> IS.IntSet -> m Atlas +allocAtlas' atlases font glyphset = do + let glyphs = map toEnum $ IS.toList glyphset + atlas <- allocAtlas (glyphRetriever font) glyphs + liftIO $ atomically $ do + a <- takeTMVar atlases + putTMVar atlases $ ((glyphset, atlas):a) + return atlas -allocFont - :: ( MonadIO m - , MonadError TypograffitiError m - , Layout t - ) - => FontStore t - -> FilePath - -> GlyphSize - -> m (Font t) -allocFont store file sz = do - let mvar = unFontStore store - s <- liftIO $ atomically $ takeTMVar mvar - atlas <- - allocAtlas - file - sz - $ S.toList - $ textRenderingDataCharSet s - let fontmap = textRenderingDataFontMap s - font = Font - { fontAtlas = atlas - , fontWordCache = mempty - } - liftIO - $ atomically - $ putTMVar mvar - $ s{ textRenderingDataFontMap = M.insert (file, sz) font fontmap } - return font +-- | Frees fonts identified by filepath, index, and\/or fontsize. +-- Returns the glyphsets covered by their newly-freed atlases in case +-- callers wish to make an informed reallocation. +freeFonts :: (MonadIO m, MonadError TypograffitiError m) => + FontStore n -> Maybe FilePath -> Maybe Int -> Maybe GlyphSize -> m IS.IntSet +freeFonts store filepath index size = do + let test (filepath', size', index', _) = case (filepath, index, size) of + (Just f, Just i, Just s) -> filepath' == f && index' == i && size' == s + (Nothing,Just i, Just s) -> index' == i && size' == s + (Just f, Nothing,Just s) -> filepath' == f && size' == s + (Nothing,Nothing,Just s) -> size' == s + (Just f, Just i, Nothing)-> filepath' == f && index' == i + (Nothing,Just i, Nothing)-> index' == i + (Just f, Nothing,Nothing)-> filepath' == f + (Nothing,Nothing,Nothing)-> True + fonts <- liftIO $ atomically $ do + fonts <- readTMVar $ fontMap store + putTMVar (fontMap store) $ M.filterWithKey (\k _ -> not $ test k) fonts + return fonts + + glyphsets <- forM [v | (k, v) <- M.toList fonts, test k] $ \font -> do + liftFreetype $ ft_Done_Face $ freetype font + -- Harfbuzz font auto-frees. + atlases' <- liftIO $ atomically $ readTMVar $ atlases font + glyphsets <- forM atlases' $ \(glyphset, atlas) -> do + freeAtlas atlas + return glyphset + return $ IS.unions glyphsets + return $ IS.unions glyphsets + +-- | 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 $ do + store <- newFontStore lib + ret <- cb store + freeFonts store Nothing Nothing Nothing + return ret + +-- | 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 + drawGlyphs <- makeDrawGlyphs + store <- liftIO $ atomically $ newTMVar M.empty + + return $ FontStore store drawGlyphs lib diff --git a/src/Typograffiti/Text.hs b/src/Typograffiti/Text.hs new file mode 100644 --- /dev/null +++ b/src/Typograffiti/Text.hs @@ -0,0 +1,218 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module: Typograffiti.Monad +-- Copyright: (c) 2018 Schell Scivally +-- License: MIT +-- Maintainer: Schell Scivally +-- & Adrian Cochrane +-- +-- Text rendering abstraction, hiding the details of +-- the Atlas, Cache, and the Harfbuzz library. +module Typograffiti.Text where + + +import Control.Monad.Except (MonadError (..), runExceptT) +import Control.Monad.Fail (MonadFail (..)) +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad (foldM, forM, unless) +import qualified Data.IntSet as IS +import Linear (V2 (..)) +import qualified Data.ByteString as B +import Data.Text.Glyphize (defaultBuffer, shape, GlyphInfo (..), + parseFeature, parseVariation, Variation (..), + FontOptions (..), defaultFontOptions) +import qualified Data.Text.Glyphize as HB +import FreeType.Core.Base +import FreeType.Core.Types (FT_Fixed) +import FreeType.Format.Multiple (ft_Set_Var_Design_Coordinates) +import Data.Text.Lazy (Text, pack) +import qualified Data.Text.Lazy as Txt +import Data.Word (Word32) + +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 spaces. + fontOptions :: FontOptions, + -- ^ Additional font options offered by Harfbuzz. + minLineHeight :: Float + -- ^ Number of pixels tall each line should be at minimum. + -- Defaults to 10px. +} + +-- | Constructs a `SampleText` with default values. +defaultSample :: SampleText +defaultSample = SampleText [] (pack $ map toEnum [32..126]) 4 defaultFontOptions 10 +-- | 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 = + HB.Feature (HB.tag_from_string name) value (n*i) (n*succ i) : sampleFeatures + } + where + n = w $ fromEnum $ Txt.length sampleText + 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) { + optionVariations = Variation (HB.tag_from_string name) val : + 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) { + optionVariations = var : optionVariations (fontOptions 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 -> + m (RichText -> n (AllocatedRendering [TextTransform])) +makeDrawText lib filepath index fontsize SampleText {..} = do + font <- liftFreetype $ ft_New_Face lib filepath $ toEnum index + liftFreetype $ case fontsize of + PixelSize w h -> ft_Set_Pixel_Sizes font (toEnum $ x2 w) (toEnum $ x2 h) + CharSize w h dpix dpiy -> ft_Set_Char_Size font (floor $ 26.6 * 2 * w) + (floor $ 26.6 * 2 * h) + (toEnum dpix) (toEnum dpiy) + + bytes <- liftIO $ B.readFile filepath + let font' = HB.createFontWithOptions fontOptions $ HB.createFace bytes $ toEnum index + let glyphs = map (codepoint . fst) $ + shape font' defaultBuffer { + HB.text = Txt.replicate (toEnum $ succ $ length sampleFeatures) sampleText + } sampleFeatures + let glyphs' = map toEnum $ IS.toList $ IS.fromList $ map fromEnum glyphs + + let designCoords = map float2fixed $ HB.fontVarCoordsDesign font' + unless (null designCoords) $ + liftFreetype $ ft_Set_Var_Design_Coordinates font designCoords + + atlas <- allocAtlas (glyphRetriever font) glyphs' + liftFreetype $ ft_Done_Face font + + drawGlyphs <- makeDrawGlyphs + return $ freeAtlasWrapper atlas $ drawLinesWrapper tabwidth minLineHeight + $ \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. +type TextRenderer m = RichText -> m (AllocatedRendering [TextTransform]) +drawLinesWrapper :: (MonadIO m, MonadFail m) => Int -> Float -> TextRenderer m -> TextRenderer m +drawLinesWrapper indent lineheight cb RichText {..} = do + let features' = splitFeatures 0 features (Txt.lines text) ++ repeat [] + let cb' (a, b) = cb $ RichText a b + renderers <- mapM cb' $ flip zip features' $ map processLine $ Txt.lines text + let drawLine ts wsz y renderer = do + arDraw renderer (move 0 y:ts) wsz + let V2 _ height = arSize renderer + return (y + max lineheight (toEnum height)) + let draw ts wsz = do + foldM (drawLine ts wsz) 0 renderers + return () + let sizes = map arSize renderers + let size = V2 (maximum [x | V2 x _ <- sizes]) (sum [y | V2 _ y <- sizes]) + let release = do + forM renderers arRelease + return () + return AllocatedRendering { + arDraw = draw, + arRelease = release, + arSize = size + } + where + splitFeatures :: Word -> [HB.Feature] -> [Text] -> [[HB.Feature]] + splitFeatures _ [] _ = [] + splitFeatures _ _ [] = [] + splitFeatures offset features' (line:lines') = let n = fromEnum $ Txt.length line + in [feat { + HB.featStart = max 0 (start - offset), + HB.featEnd = min (toEnum n) (end - offset) + } + | feat@HB.Feature {HB.featStart = start, HB.featEnd = end} <- features', + fromEnum end <= n + fromEnum offset && end >= offset] : + splitFeatures (offset + toEnum n) features' lines' + + processLine :: Text -> Text + processLine cs = expandTabs 0 cs + -- monospace tabshaping, good enough outside full line-layout. + expandTabs n cs = case Txt.break (== '\t') cs of + (tail, "") -> tail + (pre, cs') -> + let spaces = indent - ((fromEnum (Txt.length pre) + fromEnum n) `rem` indent) + in Txt.concat [pre, Txt.replicate (toEnum spaces) " ", + expandTabs (n + Txt.length pre + toEnum spaces) $ Txt.tail cs'] + +freeAtlasWrapper :: MonadIO m => Atlas -> TextRenderer m -> TextRenderer m +freeAtlasWrapper atlas cb text = do + ret <- cb text + return ret { + arRelease = do + arRelease ret + freeAtlas atlas + } diff --git a/src/Typograffiti/Utils.hs b/src/Typograffiti/Utils.hs deleted file mode 100644 --- a/src/Typograffiti/Utils.hs +++ /dev/null @@ -1,128 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TupleSections #-} -module Typograffiti.Utils ( - module FT - , FreeTypeT - , FreeTypeIO - , getAdvance - , getCharIndex - , getLibrary - , getKerning - , glyphFormatString - , hasKerning - , loadChar - , loadGlyph - , newFace - , setCharSize - , setPixelSizes - , withFreeType - , runFreeType -) where - -import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad.Except -import Control.Monad.State.Strict -import Control.Monad (unless) -import Graphics.Rendering.FreeType.Internal as FT -import Graphics.Rendering.FreeType.Internal.PrimitiveTypes as FT -import Graphics.Rendering.FreeType.Internal.Library as FT -import Graphics.Rendering.FreeType.Internal.FaceType as FT -import Graphics.Rendering.FreeType.Internal.Face as FT hiding (generic) -import Graphics.Rendering.FreeType.Internal.GlyphSlot as FT -import Graphics.Rendering.FreeType.Internal.Bitmap as FT -import Graphics.Rendering.FreeType.Internal.Vector as FT -import Foreign as FT -import Foreign.C.String as FT - --- TODO: Tease out the correct way to handle errors. --- They're kinda thrown all willy nilly. - -type FreeTypeT m = ExceptT String (StateT FT_Library m) -type FreeTypeIO = FreeTypeT IO - - -glyphFormatString :: FT_Glyph_Format -> String -glyphFormatString fmt - | fmt == ft_GLYPH_FORMAT_COMPOSITE = "ft_GLYPH_FORMAT_COMPOSITE" - | fmt == ft_GLYPH_FORMAT_OUTLINE = "ft_GLYPH_FORMAT_OUTLINE" - | fmt == ft_GLYPH_FORMAT_PLOTTER = "ft_GLYPH_FORMAT_PLOTTER" - | fmt == ft_GLYPH_FORMAT_BITMAP = "ft_GLYPH_FORMAT_BITMAP" - | otherwise = "ft_GLYPH_FORMAT_NONE" - - -liftE :: MonadIO m => String -> IO (Either FT_Error a) -> FreeTypeT m a -liftE msg f = liftIO f >>= \case - Left e -> fail $ unwords [msg, show e] - Right a -> return a - - -runIOErr :: MonadIO m => String -> IO FT_Error -> FreeTypeT m () -runIOErr msg f = do - e <- liftIO f - unless (e == 0) $ fail $ unwords [msg, show e] - - -runFreeType :: MonadIO m => FreeTypeT m a -> m (Either String (a, FT_Library)) -runFreeType f = do - (e,lib) <- liftIO $ alloca $ \p -> do - e <- ft_Init_FreeType p - lib <- peek p - return (e,lib) - if e /= 0 - then do - _ <- liftIO $ ft_Done_FreeType lib - return $ Left $ "Error initializing FreeType2:" ++ show e - else fmap (,lib) <$> evalStateT (runExceptT f) lib - -withFreeType :: MonadIO m => Maybe FT_Library -> FreeTypeT m a -> m (Either String a) -withFreeType Nothing f = runFreeType f >>= \case - Left e -> return $ Left e - Right (a,lib) -> do - _ <- liftIO $ ft_Done_FreeType lib - return $ Right a -withFreeType (Just lib) f = evalStateT (runExceptT f) lib - -getLibrary :: MonadIO m => FreeTypeT m FT_Library -getLibrary = lift get - -newFace :: MonadIO m => FilePath -> FreeTypeT m FT_Face -newFace fp = do - ft <- lift get - liftE "ft_New_Face" $ withCString fp $ \str -> - alloca $ \ptr -> ft_New_Face ft str 0 ptr >>= \case - 0 -> Right <$> peek ptr - e -> return $ Left e - -setCharSize :: (MonadIO m, Integral i) => FT_Face -> i -> i -> i -> i -> FreeTypeT m () -setCharSize ff w h dpix dpiy = runIOErr "ft_Set_Char_Size" $ - ft_Set_Char_Size ff (fromIntegral w) (fromIntegral h) - (fromIntegral dpix) (fromIntegral dpiy) - -setPixelSizes :: (MonadIO m, Integral i) => FT_Face -> i -> i -> FreeTypeT m () -setPixelSizes ff w h = - runIOErr "ft_Set_Pixel_Sizes" $ ft_Set_Pixel_Sizes ff (fromIntegral w) (fromIntegral h) - -getCharIndex :: (MonadIO m, Integral i) - => FT_Face -> i -> FreeTypeT m FT_UInt -getCharIndex ff ndx = liftIO $ ft_Get_Char_Index ff $ fromIntegral ndx - -loadGlyph :: MonadIO m => FT_Face -> FT_UInt -> FT_Int32 -> FreeTypeT m () -loadGlyph ff fg flags = runIOErr "ft_Load_Glyph" $ ft_Load_Glyph ff fg flags - -loadChar :: MonadIO m => FT_Face -> FT_ULong -> FT_Int32 -> FreeTypeT m () -loadChar ff char flags = runIOErr "ft_Load_Char" $ ft_Load_Char ff char flags - -hasKerning :: MonadIO m => FT_Face -> FreeTypeT m Bool -hasKerning = liftIO . ft_HAS_KERNING - -getKerning :: MonadIO m => FT_Face -> FT_UInt -> FT_UInt -> FT_Kerning_Mode -> FreeTypeT m (Int,Int) -getKerning ff prevNdx curNdx flags = liftE "ft_Get_Kerning" $ alloca $ \ptr -> - ft_Get_Kerning ff prevNdx curNdx (fromIntegral flags) ptr >>= \case - 0 -> do FT_Vector vx vy <- peek ptr - return $ Right (fromIntegral vx, fromIntegral vy) - e -> return $ Left e - -getAdvance :: MonadIO m => FT_GlyphSlot -> FreeTypeT m (Int,Int) -getAdvance slot = do - FT_Vector vx vy <- liftIO $ peek $ advance slot - return (fromIntegral vx, fromIntegral vy) diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 --- a/test/Spec.hs +++ /dev/null @@ -1,2 +0,0 @@ -main :: IO () -main = putStrLn "Test suite not yet implemented" diff --git a/typograffiti.cabal b/typograffiti.cabal --- a/typograffiti.cabal +++ b/typograffiti.cabal @@ -1,13 +1,7 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.30.0. --- --- see: https://github.com/sol/hpack --- --- hash: 58a65504b2800f14642c208ec25bd060eb483a4891bd92d25c071db247c52aa5 - name: typograffiti -version: 0.1.0.3 +version: 0.2.0.0 synopsis: Just let me draw nice text already description: This is a text rendering library that uses OpenGL and freetype2 to render TTF font strings quickly. It is fast enough to render large chunks of text in real time. This library exists because text rendering is one of the biggest hurdles in Haskell graphics programming - and it shouldn't be! Typograffiti includes an MTL style typeclass and a default monad transformer. It does not assume you are using any specific windowing solution. It does assume you are using OpenGL 3.3+. @@ -18,7 +12,7 @@ bug-reports: https://github.com/schell/typograffiti/issues author: Schell Scivally maintainer: schell@takt.com -copyright: 2018 Schell Scivally +copyright: 2018 Schell Scivally & others license: BSD3 license-file: LICENSE build-type: Simple @@ -36,70 +30,19 @@ Typograffiti.Atlas Typograffiti.Cache Typograffiti.GL - Typograffiti.Glyph Typograffiti.Store - Typograffiti.Utils - other-modules: - Paths_typograffiti - hs-source-dirs: - src - build-depends: - base >=4.7 && <5 - , bytestring >=0.10 - , containers >=0.6 - , freetype2 >=0.1 - , gl >=0.8 - , linear >=1.20 - , mtl >=2.2 - , pretty-show >=1.9 - , stm >=2.5 - , template-haskell >=2.14 - , vector >=0.12 - default-language: Haskell2010 + Typograffiti.Text + Typograffiti.Rich + build-depends: base >=4.12 && <4.13, linear>=1.20, containers >= 0.6, + freetype2 >= 0.2, gl >= 0.8, mtl >= 2.2, stm >= 2.5, text, + vector >= 0.12, harfbuzz-pure >= 1.0.2, bytestring >= 0.10 + hs-source-dirs: src + default-language: Haskell2010 -executable typograffiti-exe - main-is: Main.hs - other-modules: - Paths_typograffiti - hs-source-dirs: - app - ghc-options: -threaded -rtsopts -with-rtsopts=-N - build-depends: - base >=4.7 && <5 - , bytestring >=0.10 - , containers >=0.6 - , filepath >=1.4 - , freetype2 >=0.1 - , gl >=0.8 - , linear >=1.20 - , mtl >=2.2 - , pretty-show >=1.9 - , sdl2 >=2.4.1 - , stm >=2.5 - , template-haskell >=2.14 - , typograffiti - , vector >=0.12 - default-language: Haskell2010 -test-suite typograffiti-test - type: exitcode-stdio-1.0 - main-is: Spec.hs - other-modules: - Paths_typograffiti - hs-source-dirs: - test - ghc-options: -threaded -rtsopts -with-rtsopts=-N - build-depends: - base >=4.7 && <5 - , bytestring >=0.10 - , containers >=0.6 - , freetype2 >=0.1 - , gl >=0.8 - , linear >=1.20 - , mtl >=2.2 - , pretty-show >=1.9 - , stm >=2.5 - , template-haskell >=2.14 - , typograffiti - , vector >=0.12 - 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 +