From 2ce41d174adb22a99400e6bb8782f0116f218c46 Mon Sep 17 00:00:00 2001 From: Adrian Cochrane Date: Fri, 30 Dec 2022 17:02:32 +1300 Subject: [PATCH] Init (Transliterated from Gelatin to raw OpenGL with Harfbuzz glyphs). --- CHANGELOG.md | 5 + LICENSE | 30 +++++ Setup.hs | 2 + cabal.sandbox.config | 27 ++++ src/Graphics/Text/Font/Render.hs | 224 +++++++++++++++++++++++++++++++ src/Main.hs | 4 + typograffiti2.cabal | 90 +++++++++++++ 7 files changed, 382 insertions(+) create mode 100644 CHANGELOG.md create mode 100644 LICENSE create mode 100644 Setup.hs create mode 100644 cabal.sandbox.config create mode 100644 src/Graphics/Text/Font/Render.hs create mode 100644 src/Main.hs create mode 100644 typograffiti2.cabal diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..b06a41c --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for typograffiti2 + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..cce3c10 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2022, Adrian Cochrane + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * 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. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cabal.sandbox.config b/cabal.sandbox.config new file mode 100644 index 0000000..745df70 --- /dev/null +++ b/cabal.sandbox.config @@ -0,0 +1,27 @@ +-- This is a Cabal package environment file. +-- THIS FILE IS AUTO-GENERATED. DO NOT EDIT DIRECTLY. +-- Please create a 'cabal.config' file in the same directory +-- if you want to change the default settings for this sandbox. + + +local-repo: /home/alcinnz/argonaut/typograffiti2/.cabal-sandbox/packages +logs-dir: /home/alcinnz/argonaut/typograffiti2/.cabal-sandbox/logs +world-file: /home/alcinnz/argonaut/typograffiti2/.cabal-sandbox/world +user-install: False +package-db: /home/alcinnz/argonaut/typograffiti2/.cabal-sandbox/x86_64-linux-ghc-8.6.5-packages.conf.d +build-summary: /home/alcinnz/argonaut/typograffiti2/.cabal-sandbox/logs/build.log + +install-dirs + prefix: /home/alcinnz/argonaut/typograffiti2/.cabal-sandbox + bindir: $prefix/bin + libdir: $prefix/lib + libsubdir: $abi/$libname + dynlibdir: $libdir/$abi + libexecdir: $prefix/libexec + libexecsubdir: $abi/$pkgid + datadir: $prefix/share + datasubdir: $abi/$pkgid + docdir: $datadir/doc/$abi/$pkgid + htmldir: $docdir/html + haddockdir: $htmldir + sysconfdir: $prefix/etc diff --git a/src/Graphics/Text/Font/Render.hs b/src/Graphics/Text/Font/Render.hs new file mode 100644 index 0000000..ef84369 --- /dev/null +++ b/src/Graphics/Text/Font/Render.hs @@ -0,0 +1,224 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE FlexibleContexts #-} +module Graphics.Text.Font.Render where + +import Data.Map (Map) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IM +import Linear.V2 (V2(..)) +import Linear.V (toV, dim, Finite, Size) +import FreeType.Core.Base (FT_Library, FT_Face, + FT_GlyphSlotRec(..), FT_Glyph_Metrics(..)) +import FreeType.Core.Types (FT_Bitmap(..)) + +import Graphics.GL as GL +import qualified Graphics.GL.Core32 as GL +import Control.Monad (foldM, when) +import Control.Exception (assert) +import qualified Data.Foldable as F +import GHC.TypeNats (KnownNat) + +import Foreign.Ptr (castPtr, nullPtr) +import Foreign.C.String (withCString) +import Foreign.Marshal.Array (peekArray, allocaArray) +import Foreign.Marshal.Utils (with) +import Foreign.Storable (Storable(..)) +import qualified Data.Vector.Storable as SV +import Data.Vector.Unboxed (Unbox) +import qualified Data.Vector.Unboxed as UV + +------ +--- Atlas +------ + +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) + +data Atlas = Atlas { + atlasTexture :: GLuint, + atlasTextureSize :: V2 Int, + atlasMetrics :: IntMap GlyphMetrics, + atlasFilePath :: FilePath +} + +emptyAtlas t = Atlas t 0 mempty "" + +data AtlasMeasure = AM { + amWH :: V2 Int, + amXY :: V2 Int, + rowHeight :: Int, + amMap :: IntMap (V2 Int) +} deriving (Show, Eq) + +emptyAM :: AtlasMeasure +emptyAM = AM 0 (V2 1 1) 0 mempty + +spacing :: Int +spacing = 1 + +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 + +texturize cb xymap atlas@Atlas{..} glyph + | Just pos@(V2 x y) <- IM.lookup (fromIntegral $ fromEnum glyph) xymap = do + (bmp, metrics) <- cb glyph + glTexSubImage2D GL.GL_TEXTURE_2D 0 + (fromIntegral x) (fromIntegral y) + (fromIntegral $ bWidth bmp) (fromIntegral $ bRows bmp) + GL.GL_RED GL.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), + glyphTexSize = vecwh, + glyphSize = vecsz, + glyphHoriBearing = vecxb, + glyphVertBearing = vecyb, + glyphAdvance = vecad + } + return atlas { atlasMetrics = IM.insert (fromEnum glyph) mtrcs atlasMetrics } + | otherwise = do + putStrLn ("Cound not find glyph " ++ show glyph) + return atlas + +allocAtlas cb glyphs = do + AM {..} <- foldM (measure cb 512) emptyAM glyphs + let V2 w h = amWH + xymap = amMap + + [t] <- allocaArray 1 $ \ptr -> do + glGenTextures 1 ptr + peekArray 1 ptr + glActiveTexture 0 + glBindTexture GL.GL_TEXTURE_2D t + + glPixelStorei GL.GL_UNPACK_ALIGNMENT 1 + withCString (replicate (w * h) $ toEnum 0) $ + glTexImage2D GL.GL_TEXTURE_2D 0 GL.GL_RED (fromIntegral w) (fromIntegral h) + 0 GL.GL_RED GL.GL_UNSIGNED_BYTE . castPtr + atlas <- foldM (texturize cb xymap) (emptyAtlas t) glyphs + + glGenerateMipmap GL.GL_TEXTURE_2D + glTexParameteri GL.GL_TEXTURE_2D GL.GL_TEXTURE_WRAP_S GL.GL_REPEAT + glTexParameteri GL.GL_TEXTURE_2D GL.GL_TEXTURE_WRAP_T GL.GL_REPEAT + glTexParameteri GL.GL_TEXTURE_2D GL.GL_TEXTURE_MAG_FILTER GL.GL_LINEAR + glTexParameteri GL.GL_TEXTURE_2D GL.GL_TEXTURE_MIN_FILTER GL.GL_LINEAR + glBindTexture GL.GL_TEXTURE_2D 0 + glPixelStorei GL.GL_UNPACK_ALIGNMENT 4 + return atlas { atlasTextureSize = V2 w h } + +freeAtlas a = with (atlasTexture a) $ \ptr -> glDeleteTextures 1 ptr + +makeCharQuad Atlas {..} (penx, mLast) glyph = do + let iglyph = fromEnum glyph + case IM.lookup iglyph atlasMetrics of + Nothing -> return (penx, mLast) + Just GlyphMetrics {..} -> do + -- TODO incorporate Harfbuzz positioning. + let V2 dx dy = fromIntegral <$> glyphHoriBearing + x = (fromIntegral penx) + 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 V2 ax _ = glyphAdvance + + return (penx + ax, mLast ++ [tl, tr, br, tl, br, bl]) + +stringTris atlas = foldM (makeCharQuad atlas) (0, []) + +drawGlyphs atlas@Atlas {..} glyphs = do + glBindTexture GL.GL_TEXTURE_2D atlasTexture + + (geom', texcoords') <- unzip <$> snd <$> stringTris atlas glyphs + geom <- newBuffer + texcoords <- newBuffer + bufferGeometry 0 geom $ UV.fromList geom' + bufferGeometry 1 texcoords $ UV.fromList texcoords' + glDrawArrays GL.GL_TRIANGLES 0 $ toEnum $ SV.length $ convertVec $ UV.fromList geom' + +------ +--- OpenGL Utilities +------ + +newBuffer = do + [b] <- allocaArray 1 $ \ptr -> do + glGenBuffers 1 ptr + peekArray 1 ptr + return b + +-- | Buffer some geometry into an attribute. +-- The type variable 'f' should be V0, V1, V2, V3 or V4. +bufferGeometry + :: ( Foldable f + , Unbox (f Float) + , Storable (f Float) + , Finite f + , KnownNat (Size f) + ) + => GLuint + -- ^ The attribute location. + -> GLuint + -- ^ The buffer identifier. + -> UV.Vector (f Float) + -- ^ The geometry to buffer. + -> IO () +bufferGeometry loc buf as + | UV.null as = return () + | otherwise = do + let v = UV.head as + asize = UV.length as * sizeOf v + n = fromIntegral $ dim $ toV v + glBindBuffer GL.GL_ARRAY_BUFFER buf + SV.unsafeWith (convertVec as) $ \ptr -> + glBufferData GL.GL_ARRAY_BUFFER (fromIntegral asize) (castPtr ptr) GL.GL_STATIC_DRAW + glEnableVertexAttribArray loc + glVertexAttribPointer loc n GL.GL_FLOAT GL.GL_FALSE 0 nullPtr + clearErrors "bufferGeometry" + +convertVec + :: (Unbox (f Float), Foldable f) => UV.Vector (f Float) -> SV.Vector GLfloat +convertVec = + SV.convert . UV.map realToFrac . UV.concatMap (UV.fromList . F.toList) + +clearErrors str = do + err' <- glGetError + when (err' /= 0) $ do + putStrLn $ unwords [str, show err'] + assert False $ return () diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 index 0000000..65ae4a0 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,4 @@ +module Main where + +main :: IO () +main = putStrLn "Hello, Haskell!" diff --git a/typograffiti2.cabal b/typograffiti2.cabal new file mode 100644 index 0000000..f051029 --- /dev/null +++ b/typograffiti2.cabal @@ -0,0 +1,90 @@ +-- Initial typograffiti2.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +-- The name of the package. +name: typograffiti2 + +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented. +-- https://wiki.haskell.org/Package_versioning_policy +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.0 + +-- A short (one-line) description of the package. +synopsis: Just let me draw nice text already + +-- A longer description of the package. +-- description: + +-- URL for the project homepage or repository. +homepage: https://argonaut-constellation.org/ + +-- The license under which the package is released. +license: BSD3 + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: Adrian Cochrane + +-- An email address to which users can send suggestions, bug reports, and +-- patches. +maintainer: adrian@openwork.nz + +-- A copyright notice. +-- copyright: + +category: Graphics + +build-type: Simple + +-- Extra files to be distributed with the package, such as examples or a +-- README. +extra-source-files: CHANGELOG.md + +-- Constraint on the version of Cabal needed to build this package. +cabal-version: >=1.10 + + +library + -- Modules exported by the library. + exposed-modules: Graphics.Text.Font.Render + + -- Modules included in this library but not exported. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: base >=4.12 && <4.13, linear, containers, freetype2, gl, vector + + -- Directories containing source files. + hs-source-dirs: src + + -- Base language which the package is written in. + default-language: Haskell2010 + + +executable typograffiti2 + -- .hs or .lhs file containing the Main module. + main-is: Main.hs + + -- Modules included in this executable, other than Main. + -- other-modules: + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: base >=4.12 && <4.13 + + -- Directories containing source files. + hs-source-dirs: src + + -- Base language which the package is written in. + default-language: Haskell2010 + -- 2.30.2