minitypeset-opengl 0.1.0.0 → 0.2.0.0
raw patch · 13 files changed
+961/−305 lines, 13 filesdep ~OpenGLdep ~containers
Dependency ranges changed: OpenGL, containers
Files
- example/GL.hs +62/−21
- example/UnicodeMath.hs +6/−0
- example/example-STIX.hs +85/−33
- example/example-boxes.hs +22/−23
- minitypeset-opengl.cabal +3/−2
- src/Graphics/Rendering/MiniTypeset.hs +13/−3
- src/Graphics/Rendering/MiniTypeset/Box.hs +260/−76
- src/Graphics/Rendering/MiniTypeset/Common.hs +42/−30
- src/Graphics/Rendering/MiniTypeset/Document.hs +243/−0
- src/Graphics/Rendering/MiniTypeset/FontTexture.hs +18/−6
- src/Graphics/Rendering/MiniTypeset/Layout.hs +157/−63
- src/Graphics/Rendering/MiniTypeset/MultiFont.hs +11/−4
- src/Graphics/Rendering/MiniTypeset/Render.hs +39/−44
example/GL.hs view
@@ -9,6 +9,7 @@ import Control.Monad import Control.Concurrent +import Control.Concurrent.MVar import Data.IORef import System.Exit @@ -19,14 +20,34 @@ -------------------------------------------------------------------------------- +{-# NOINLINE theExitFlag #-} +theExitFlag :: IORef Bool +theExitFlag = Unsafe.unsafePerformIO $ newIORef False + +{-# NOINLINE theRefreshTrigger #-} +theRefreshTrigger :: MVar () +theRefreshTrigger = Unsafe.unsafePerformIO $ newMVar () -- newEmptyMVar + +{-# NOINLINE theWindowSize #-} theWindowSize :: IORef (Int,Int) theWindowSize = Unsafe.unsafePerformIO $ newIORef $ error "window size not set" +{-# NOINLINE theDisplayFunction #-} +theDisplayFunction :: IORef (Window -> Double -> IO ()) +theDisplayFunction = Unsafe.unsafePerformIO $ newIORef nodisplay where + nodisplay _ _ = return () + +-------------------------------------------------------------------------------- + +triggerExit :: IO () +triggerExit = writeIORef theExitFlag True + setWindowCoordSystem :: IO () setWindowCoordSystem = do + (w,h) <- readIORef theWindowSize + viewport $=! (Position 0 0 , Size (fromIntegral w) (fromIntegral h)) matrixMode $=! Projection loadIdentity - (w,h) <- readIORef theWindowSize GL.ortho 0 (fromIntegral w) (fromIntegral h) 0 (-1) (1::Double) matrixMode $=! Modelview 0 loadIdentity @@ -36,12 +57,12 @@ myErrorCallback :: GLFW.Error -> String -> IO () myErrorCallback err msg = do putStrLn $ msg ++ "(" ++ show err ++ ")" - myExit + triggerExit myKeyCallback :: Window -> Key -> Int -> KeyState -> ModifierKeys -> IO () myKeyCallback _ key nrepeat keyState modif = case key of - Key'Escape -> myExit + Key'Escape -> triggerExit _ -> return () myCharCallback :: Window -> Char -> IO () @@ -49,22 +70,21 @@ return () myWinCloseCallback :: Window -> IO () -myWinCloseCallback window = myExit +myWinCloseCallback window = triggerExit myFrBufSizeCallback :: Window -> Int -> Int -> IO () myFrBufSizeCallback window xsiz ysiz = do - writeIORef theWindowSize (xsiz,ysiz) - putStrLn $ "framebuffer resized to " ++ show (xsiz,ysiz) + -- writeIORef theWindowSize (xsiz,ysiz) + -- putStrLn $ "framebuffer resized to " ++ show (xsiz,ysiz) + return () myRefreshCallback :: Window -> IO () myRefreshCallback window = do + -- putStrLn "refresh callback" + _ <- tryTakeMVar theRefreshTrigger + putMVar theRefreshTrigger () return () -myExit :: IO () -myExit = do - -- terminate - exitWith ExitSuccess - -------------------------------------------------------------------------------- {- @@ -77,16 +97,32 @@ -------------------------------------------------------------------------------- -renderLoop :: (Window -> Double -> IO ()) -> Window -> IO () -renderLoop display window = loop where +redraw :: Window -> IO () +redraw window = do + Just time <- getTime + + (xsiz,ysiz) <- getFramebufferSize window -- window resizing is broken in glfw + writeIORef theWindowSize (xsiz,ysiz) -- this helps a little. + + display <- readIORef theDisplayFunction + display window time + swapBuffers window + +renderLoop :: Window -> IO () +renderLoop window = loop where loop = do - Just time <- getTime - -- print time - display window time - swapBuffers window - threadDelay 50 - loop + _ <- takeMVar theRefreshTrigger + redraw window + exit <- readIORef theExitFlag + unless exit loop +eventLoop :: IO () +eventLoop = do + threadDelay 1 + waitEvents + exit <- readIORef theExitFlag + unless exit eventLoop + -------------------------------------------------------------------------------- initGL :: IO precalc -> (precalc -> Window -> Double -> IO ()) -> IO () @@ -116,9 +152,14 @@ makeContextCurrent (Just window) swapInterval 1 precalc <- userPrecalc - renderLoop (userDisplay precalc) window + writeIORef theDisplayFunction (userDisplay precalc) + renderLoop window - forever waitEvents + eventLoop + + putStrLn "calling terminate" + terminate + exitWith ExitSuccess --------------------------------------------------------------------------------
example/UnicodeMath.hs view
@@ -98,6 +98,9 @@ coprod = '\x2210' sum_ = '\x2211' +infty = '\x221e' +rightarrow = '\x2192' + oplus = '\x2295' ominus = '\x2296' otimes = '\x2297' @@ -110,6 +113,9 @@ hbar = '\x210f' ell = '\x2113' aleph = '\x2135' + +aa = '\x1d538' +pp = '\x2119' cc = '\x2102' nn = '\x2115'
example/example-STIX.hs view
@@ -9,11 +9,14 @@ -- * compile this source file with @ghc -O --make -threaded@ -- +{-# LANGUAGE OverloadedStrings #-} module Main where -------------------------------------------------------------------------------- import Data.Char hiding ( Space ) +import Data.List ( isPrefixOf ) +import Data.String import Control.Monad import Data.IORef @@ -35,50 +38,94 @@ document :: Document String document = Identified "document" - $ VertCat AlignRight + $ vcatR [ block12 - , Space - , block3 +-- , space + , hcatT [ vcat [ summation , over ] , (margin' 50 40 20 30 block3) ] + , block4 ] -block12 = HorzCat AlignBottom [ block1 , Space , block2 ] +block12 = hcat [ block1 , Space , block2 ] block1 = Identified "block1" - $ VertCat AlignLeft [line1a,line1b,line1c,line1d] + $ vcat [line1a,line1b,line1c,line1d] -block2 = VertCat AlignRight [line2a,line2b,line2c,line2d,line2e] +block2 = vcatR [line2a,line2b,line2c,line2d,line2e] block3 = Identified "block3" - $ VertCat AlignLeft [ WithColor (Col 1 1 0) (String greeks), Space, WithColor (Col 1 1 1) equ ] + $ vcat [ rgb 1 1 0 (string greeks), rgb 0.3 0.4 1 subsup, white equ ] -line1a = String "Lorem ipsum dolor sit amet," -line1b = WithColor (Col 0.7 0 0) - $ String "consectetur adipiscing elit," +block4 = vcat [line4a,line4b,line4c,line4d,line4e,line4f,line4g] + +line1a = "Lorem ipsum dolor sit amet," +line1b = rgb 0.7 0 0 + $ "consectetur adipiscing elit," line1c = Identified "line1c" - $ WithStyle Italic - $ String "sed do eiusmod tempor incididunt" -line1d = HorzCat AlignBottom - [ String "ut labore et " - , Identified "dolore" $ WithStyle BoldItalic $ WithColor (Col 0 0 0.75) $ String "dolore" - , String " magna aliqua." + $ italic + $ "sed do eiusmod tempor incididunt" +line1d = hcat + [ "ut labore et " + , Identified "dolore" $ boldItalic $ rgb 0 0 0.75 $ "dolore" + , " magna aliqua." ] -line2a = String "Ut enim ad minim veniam," +line2a = hcat [ "Ut enim ad " , Identified "bbox1" "minim" , " veniam," ] line2b = Identified "line2b" - $ WithStyle Bold - $ String "quis nostrud exercitation" -line2c = String "ullamco laboris nisi ut" -line2d = WithColor (Col 0 0.4 0) - $ WithStyle BoldItalic - $ String "aliquip ex ea commodo" -line2e = String "consequat." + $ bold + $ "quis nostrud exercitation" +line2c = "ullamco laboris nisi ut" +line2d = rgb 0 0.4 0 + $ boldItalic + $ "aliquip ex ea commodo" +line2e = hcat [ "conse" , Identified "bbox2" ("qua") , "t." ] -equ = HorzCat AlignBottom - [ String $ take 8 math_test - , Identified "formula" $ WithColor (Col 0.5 0.5 1) $ String $ take 5 (drop 8 math_test) - , String $ drop 13 math_test +line4a = hcat [ "In printed documents " , blue (underline "underlinin" <|> "g") , " is generally avoided," ] +line4b = hcat [ "with " , white (overline (italic "italics")) , " or " , green (hcat [ overline "sma" , "ll " , overline "caps"]) , " often used instead, or" ] +line4c = "(especially in headings) using capitalization or bold type." +line4d = hcat [ "In a ", strike "manuscript to be typeset" , ", various forms of underlining" ] +line4e = "were therefore conventionally used to indicate that text should" +line4f = hcat [ "be set in special type such as italics, " , underline "part of a procedure" ] +line4g = "known as markup." + +over1 = rgb 1.0 0.2 0.3 $ vcatR ["overlay on top","of each other"] +over2 = rgb 0.9 0.9 0.2 $ vcatR ["////","\\\\\\\\","####"] +over = Overlay (AlignRight,AlignBottom) [ over1 , over2 ] + +equ = hcat + [ string $ take 8 math_test + , Identified "formula" $ rgb 0.5 0.5 1 $ string $ take 5 (drop 8 math_test) + , string $ drop 13 math_test ] +subsup = vcat + [ black "see if the gaps between lines..." + , hcat [ supscript (char pp) "m" , space + , subSup "X" ("alma","(7)") , space + , subscript mm "g" , space + , subSup (char zz) ("p","2") , space + ] + , hcat [ supscript "10" "10" , space + , supscript "10" (supscript "10" "10") , space + , supscript "10" (supscript "10" (supscript "10" "10")) , space + , supscript "10" (supscript "10" (Identified "bbox_scr" (supscript "10" (supscript "10" "10")))) , space + , supscript "X" "5" , space + , supscript (supscript "X" "5") "7" , space + , supscript "x" "2" , "y" , supscript "z" "3" + ] + , black "...increase or not when using subscripts" + ] + +summation = vcat + [ "summation" + , white $ hcat + [ aboveBelow (char sum_) (char infty , "n=0") , "f(n)" , space , space + , below "lim" (string ['x',rightarrow,infty]) , " g(x)" , space , space + ] + , "and limits" + ] + +mm = char '\x2133' + -------------------------------------------------------------------------------- -- | An enum encoding the font files we use @@ -141,11 +188,13 @@ -- | Our \"multifont\" configuration myUFC :: UserFontConfig MyFontFile MyStyle myUFC = UserFontConfig - { _ufcFontFiles = myFontFileMap - , _ufcCharMap = myCharMap - , _ufcStyleMap = myStyleMap + { _ufcFontFiles = myFontFileMap + , _ufcCharMap = myCharMap + , _ufcStyleMap = myStyleMap + , _ufcLineGapFactor = 1.0 } +{-# NOINLINE theMultiFont #-} theMultiFont :: IORef (MultiFont MyFontFile MyStyle) theMultiFont = Unsafe.unsafePerformIO $ newIORef $ error "multifont not loaded" @@ -168,10 +217,13 @@ -- query bounding box positions, and render them usertable <- dryrunLayout lout pos0 - color $ Color4 1 1 1 (0.1 :: Double) blend $=! Enabled blendFunc $=! (SrcAlpha,One) -- MinusSrcAlpha) - mapM_ renderOuterBoxQuad (Map.elems usertable) + let isbbox = isPrefixOf "bbox" + color $ Color4 1 1 1 (0.1 :: Double) + mapM_ renderOuterBoxQuad $ Map.elems $ Map.filterWithKey (\k v -> not (isbbox k)) $ usertable + color $ Color4 1 0 0 (0.2 :: Double) + mapM_ renderBoundingBoxQuad $ Map.elems $ Map.filterWithKey (\k v -> isbbox k ) $ usertable blend $=! Disabled -- render the text
example/example-boxes.hs view
@@ -30,20 +30,19 @@ box1, box2 :: Box -box1 = Box 50 75 5 10 15 20 10 5 -box2 = Box 63 105 10 25 5 5 12 8 +mkBox w h l r t b hgap vgap = Box (w,h) outer bound gap where + outer = Quad (-l,-t) (w+r ,h+b ) + gap = Quad (-l,-t) (w+r+hgap,h+b+vgap) + bound = Quad (-l/2,-t/3) (w*2/3,h*3/4) +box1 = mkBox 50 75 5 10 15 20 10 5 +box2 = mkBox 63 105 10 25 5 5 12 8 + -------------------------------------------------------------------------------- -scaleCol :: Double -> Col -> Col +scaleCol :: Float -> Col -> Col scaleCol s (Col r g b) = Col (s*r) (s*g) (s*b) -setCol :: Col -> IO () -setCol (Col r g b) = color (Color3 r g b) - -setColAlpha :: Col -> Double -> IO () -setColAlpha (Col r g b) a = color (Color4 r g b a) - withPos :: Pos -> IO a -> IO a withPos (Pos x y) action = do GL.translate (Vector3 x y 0) @@ -54,18 +53,18 @@ -------------------------------------------------------------------------------- renderBoxOutline :: Col -> Box -> IO () -renderBoxOutline col (Box w h l r t b hgap vgap) = do - setCol (scaleCol 0.5 col) ; renderQuadOutline (-l,-t) (w+r+hgap,h+b+vgap) - setCol (scaleCol 0.75 col) ; renderQuadOutline (-l,-t) (w+r,h+b) - setCol col ; renderQuadOutline ( 0, 0) (w,h) +renderBoxOutline col box = do + setCol (scaleCol 0.5 col) ; renderQuadOutline (boxGapQuad box) + setCol (scaleCol 0.75 col) ; renderQuadOutline (boxOuterQuad box) + setCol col ; renderQuadOutline (boxInnerQuad box) -renderBoxFilled:: Col -> Double -> Box -> IO () -renderBoxFilled col alpha (Box w h l r t b hgap vgap) = do +renderBoxFilled:: Col -> Float -> Box -> IO () +renderBoxFilled col alpha box = do blend $= Enabled blendFunc $= (SrcAlpha, OneMinusSrcAlpha) - setColAlpha (scaleCol 0.5 col) alpha ; renderQuadFilled (-l,-t) (w+r+hgap,h+b+vgap) - setColAlpha (scaleCol 0.75 col) alpha ; renderQuadFilled (-l,-t) (w+r,h+b) - setColAlpha col alpha ; renderQuadFilled ( 0, 0) (w,h) + setColAlpha (scaleCol 0.5 col) alpha ; renderQuadFilled (boxGapQuad box) + setColAlpha (scaleCol 0.75 col) alpha ; renderQuadFilled (boxOuterQuad box) + setColAlpha col alpha ; renderQuadFilled (boxInnerQuad box) blend $= Disabled withAbsBox :: AbsBox -> (Box -> IO a) -> IO a @@ -73,16 +72,16 @@ -------------------------------------------------------------------------------- -renderQuadOutline :: (Double,Double) -> (Double,Double) -> IO () -renderQuadOutline (x1,y1) (x2,y2) = do +renderQuadOutline :: Quad -> IO () +renderQuadOutline (Quad (x1,y1) (x2,y2)) = do renderPrimitive LineLoop $ do vertex (Vertex2 x1 y1) vertex (Vertex2 x2 y1) vertex (Vertex2 x2 y2) vertex (Vertex2 x1 y2) -renderQuadFilled :: (Double,Double) -> (Double,Double) -> IO () -renderQuadFilled (x1,y1) (x2,y2) = do +renderQuadFilled :: Quad -> IO () +renderQuadFilled (Quad (x1,y1) (x2,y2)) = do renderPrimitive Quads $ do vertex (Vertex2 x1 y1) vertex (Vertex2 x2 y1) @@ -102,7 +101,7 @@ renderOuterBoxQuad abox renderInnerBoxQuad abox setColAlpha (Col 1 1 1) 0.25 - renderBoxGap abox +-- renderBoxGap abox blend $= Disabled renderBoxOutline (Col 1 0 0) box
minitypeset-opengl.cabal view
@@ -1,5 +1,5 @@ Name: minitypeset-opengl-Version: 0.1.0.0+Version: 0.2.0.0 Synopsis: Layout and render text with TrueType fonts using OpenGL Description: This is a library to render text with OpenGL. TrueType (and OpenType) fonts are supported; glyph rendering@@ -31,11 +31,12 @@ Library - Build-Depends: base >= 4 && < 5, containers, filepath, OpenGL, stb-truetype >= 0.1.4+ Build-Depends: base >= 4 && < 5, containers >= 0.5, filepath, OpenGL >= 3, stb-truetype >= 0.1.4 Exposed-Modules: Graphics.Rendering.MiniTypeset Graphics.Rendering.MiniTypeset.Box Graphics.Rendering.MiniTypeset.Common+ Graphics.Rendering.MiniTypeset.Document Graphics.Rendering.MiniTypeset.Layout Graphics.Rendering.MiniTypeset.MultiFont Graphics.Rendering.MiniTypeset.FontTexture
src/Graphics/Rendering/MiniTypeset.hs view
@@ -3,19 +3,28 @@ -- -- It is enough to import this module to use the library. --+-- To render text, first initialize your fonts with 'newMultiFont'; +-- then build a 'Document' describing what you want to render;+-- after that, create a 'Layout' out of it using 'createLayout';+-- finally render it with 'renderLayout'. Optionally you can also +-- query the screen location of identified parts of the document,+-- and do something with them.+-- -- There is an example program (@example-STIX.hs@) in the example subdirectory -- illustrating how to use it. -- module Graphics.Rendering.MiniTypeset - ( module Graphics.Rendering.MiniTypeset.Common+ ( -- * Common types+ module Graphics.Rendering.MiniTypeset.Common+ -- * Documents+ , module Graphics.Rendering.MiniTypeset.Document -- * Boxes , module Graphics.Rendering.MiniTypeset.Box -- * \"Multifonts\" , UserFontConfig(..) , MultiFont , newMultiFont , MultiFontGlyph -- * Layout- , Document(..)- , Layout(..)+ , Layout -- Layout(..) , LayoutDecoration(..) , createLayout, createLayout' , dryrunLayout, renderLayout, renderLayout' -- * Rendering@@ -28,6 +37,7 @@ import Graphics.Rendering.MiniTypeset.Box import Graphics.Rendering.MiniTypeset.Common hiding ( mapAccumM ) import Graphics.Rendering.MiniTypeset.Layout+import Graphics.Rendering.MiniTypeset.Document import Graphics.Rendering.MiniTypeset.FontTexture import Graphics.Rendering.MiniTypeset.MultiFont import Graphics.Rendering.MiniTypeset.Render
src/Graphics/Rendering/MiniTypeset/Box.hs view
@@ -1,43 +1,135 @@ --- | Boxes are rectangular shapes having a margin and an extra gap between--- boxes placed next to each other.+-- | Boxes are rectangular shapes used for layouting. They consisting of +-- several quads having a relative position to each other: ----- A 'Box' has an /inner box/, and an /outer box/ which is like a margin. --- The inner boxes are used for relative placement, while the outer boxes--- determine the extent. Furthermore, extra gaps between boxes placed next --- to each other are supported.+-- * \"inner boxes\" are used for aligning several boxes together ----- Boxes has their origin at the top-left corner of their inner box.--- Absolute boxes ('AbsBox') have an extra offset.+-- * \"outer boxes\" describe the logical extent +-- +-- * \"bounding boxes\" are the bounding boxes of the actual content abstracted+-- by the box --+-- * \"gap boxes\" control the gap between boxes placed next to each other.+--+-- Relative boxes has their origin at the top-left corner of their inner box.+-- Absolute boxes has an absolute offset.+-- -- We use screen-space coordinate system (Y increase downwards). --+-- In case of font glyphs, the inner box has height 0, and it coincides with+-- the base line of the glyph; while the outer box is defined by the ascent+-- and the descent. Both have horizontal dimensions equal to the advance width.+-- -{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP, BangPatterns #-} module Graphics.Rendering.MiniTypeset.Box where -------------------------------------------------------------------------------- +import Data.Monoid+ import Graphics.Rendering.MiniTypeset.Common --------------------------------------------------------------------------------+-- * Quads +-- | A quad is a rectangular region, defined by its top-left and bottom-right corner+data Quad = Quad+ { quadTopLeft :: {-# UNPACK #-} !(Double,Double)+ , quadBotRight :: {-# UNPACK #-} !(Double,Double)+ }+ deriving (Eq,Show)++quadTopRight :: Quad -> (Double,Double)+quadTopRight (Quad (_,y) (x,_)) = (x,y)++quadBotLeft :: Quad -> (Double,Double)+quadBotLeft (Quad (x,_) (_,y)) = (x,y)++quadL,quadR,quadT,quadB :: Quad -> Double+quadL = fst . quadTopLeft+quadT = snd . quadTopLeft+quadR = fst . quadBotRight+quadB = snd . quadBotRight++quadWidth :: Quad -> Double+quadWidth (Quad (l,t) (r,b)) = r-l++quadHeight :: Quad -> Double+quadHeight (Quad (l,t) (r,b)) = b-t++quadSize :: Quad -> (Double,Double)+quadSize (Quad (l,t) (r,b)) = (r-l , b-t)++instance Translate Quad where+ translate ofs (Quad tl br) = Quad (translate ofs tl) (translate ofs br) ++zeroQuad :: Quad +zeroQuad = Quad (0,0) (0,0)++-- | Least upper bounding quad+quadLUB :: Quad -> Quad -> Quad+quadLUB (Quad (u1,v1) (u2,v2)) (Quad (p1,q1) (p2,q2)) = Quad (x1,y1) (x2,y2) where+ x1 = min u1 p1+ y1 = min v1 q1+ x2 = max u2 p2+ y2 = max v2 q2++ofsLUB :: (Pos,Quad) -> (Pos,Quad) -> Quad+ofsLUB (ofs1,quad1) (ofs2,quad2) = quadLUB (translate ofs1 quad1) (translate ofs2 quad2)++-- It probably should be a semigroup, but I don't care too much :)+instance Monoid Quad where+ mempty = zeroQuad+ mappend = quadLUB++-- | Extend a quad with margins+marginQuad :: Margin -> Quad -> Quad+marginQuad (Margin l r t b) (Quad (x1,y1) (x2,y2)) = Quad (x1-l,y1-t) (x2+r,y2+b)++--------------------------------------------------------------------------------+-- * Boxes+ -- | A (relative) box data Box = Box- { _rboxXSize :: !Double- , _rboxYSize :: !Double- , _rboxLeftMarg :: !Double- , _rboxRightMarg :: !Double- , _rboxTopMarg :: !Double- , _rboxBotMarg :: !Double- , _rboxXGap :: !Double -- ^ gap on the right side- , _rboxYGap :: !Double -- ^ gap on the bottom side+ { boxInnerSize :: {-# UNPACK #-} !(Double,Double)+ , boxOuterQuad :: !Quad+ , boxBoundingQuad :: !Quad+ , boxGapQuad :: !Quad } deriving (Show) +boxInnerQuad :: Box -> Quad+boxInnerQuad (Box inner outer bounding gap) = Quad (0,0) inner+ emptyBox :: Box-emptyBox = Box 0 0 0 0 0 0 0 0+emptyBox = Box (0,0) zeroQuad zeroQuad zeroQuad +-- | Enumerating the four different quads in a 'Box'+data WhichQuad+ = InnerQuad+ | OuterQuad+ | BoundingQuad+ | GapQuad+ deriving (Eq,Ord,Show)++-- | Replace the inner box by the given box. Since the inner box is used for+-- alignment, this amounts to changing the alignment +realignBox :: WhichQuad -> Box -> Box+realignBox which box@(Box _ outer bounding gap) = + case which of+ InnerQuad -> box+ OuterQuad -> realign outer+ BoundingQuad -> realign bounding+ GapQuad -> realign gap+ where+ realign quad = Box (quadSize quad) (f outer) (f bounding) (f gap) where+ ofs = negate (pairToPos $ quadTopLeft quad)+ f :: Quad -> Quad+ f = translate ofs++--------------------------------------------------------------------------------+ -- | An absolute box data AbsBox = AbsBox { _aboxOffset :: !Pos@@ -48,87 +140,78 @@ instance Translate AbsBox where translate ofs (AbsBox pos relbox) = AbsBox (ofs+pos) relbox +absboxInnerQuad :: AbsBox -> Quad+absboxInnerQuad (AbsBox ofs relbox) = translate ofs (boxInnerQuad relbox)++absboxOuterQuad :: AbsBox -> Quad+absboxOuterQuad (AbsBox ofs relbox) = translate ofs (boxOuterQuad relbox)++absboxBoundingQuad :: AbsBox -> Quad+absboxBoundingQuad (AbsBox ofs relbox) = translate ofs (boxBoundingQuad relbox)++absboxGapQuad :: AbsBox -> Quad+absboxGapQuad (AbsBox ofs relbox) = translate ofs (boxGapQuad relbox)+ --------------------------------------------------------------------------------+-- * Concatenating boxes -- | Concatantes two boxes horizontally, using the inner boxes to align them. -- The two positions we return are relative positions of the two boxes from -- the origin (top-left inner corner) of the concatenated box.-hcatBox :: VAlign -> Box -> Box -> (Box,Pos,Pos)-hcatBox !valign !box1 !box2 = - case valign of+hcatBox :: VAlign -> Box -> Box -> (Box,(Pos,Pos))+hcatBox !valign !box1 !box2 = (box,(pos1,pos2)) where - AlignTop -> ( Box w h l r t b hgap vgap , Pos 0 0 , Pos x 0 ) where- x = w1 + r1 + hgap1 + l2- t = max t1 t2- w = x + w2- h = max h1 h2- l = l1- r = r2- hgap = hgap2- b = max (h1 + b1) (h2 + b2) - h- vgap = max (h1 + b1 + vgap1) (h2 + b2 + vgap2) - (h + b) + box = Box (w,h) outer bound gap - AlignBottom -> ( Box w h l r t b hgap vgap , Pos 0 y1 , Pos x y2 ) where- x = w1 + r1 + hgap1 + l2- y1 = max 0 (h2 - h1)- y2 = max 0 (h1 - h2)- b = max b1 b2- w = x + w2- h = max h1 h2- l = l1- r = r2- hgap = hgap2- t = max (h1 + t1) (h2 + t2) - h- vgap = max (b1 + vgap1) (b2 + vgap2) - b + (y1,y2) = case valign of { AlignTop -> (0,0) ; AlignBottom -> (h-h1 , h-h2) } - where- Box w1 h1 l1 r1 t1 b1 hgap1 vgap1 = box1- Box w2 h2 l2 r2 t2 b2 hgap2 vgap2 = box2+ pos1 = Pos 0 y1 + pos2 = Pos x y2 + x = quadR gap1 - quadL gap2++ w = x + w2+ h = max h1 h2+ outer = ofsLUB (pos1,outer1) (pos2,outer2)+ bound = ofsLUB (pos1,bound1) (pos2,bound2)+ gap = ofsLUB (pos1, gap1) (pos2, gap2)++ Box (w1,h1) outer1 bound1 gap1 = box1+ Box (w2,h2) outer2 bound2 gap2 = box2+ -------------------------------------------------------------------------------- -- | Concatantes two boxes vertically, using the inner boxes to align them. -- The two positions we return are relative positions of the two boxes from -- the origin (top-left inner corner) of the concatenated box.-vcatBox :: HAlign -> Box -> Box -> (Box,Pos,Pos)-vcatBox !halign !box1 !box2 = - case halign of+vcatBox :: HAlign -> Box -> Box -> (Box,(Pos,Pos))+vcatBox !halign !box1 !box2 = (box,(pos1,pos2)) where - AlignLeft -> ( Box w h l r t b hgap vgap , Pos 0 0 , Pos 0 y ) where- y = h1 + b1 + vgap1 + t2- l = max l1 l2- h = y + h2- w = max w1 w2- t = t1- b = b2- vgap = vgap2- r = max (w1 + r1) (w2 + r2) - w- hgap = max (w1 + r1 + hgap1) (w2 + r2 + hgap2) - (w + r) + box = Box (w,h) outer bound gap - AlignRight -> ( Box w h l r t b hgap vgap , Pos x1 0, Pos x2 y ) where- y = h1 + b1 + vgap1 + t2- x1 = max 0 (w2 - w1)- x2 = max 0 (w1 - w2)- r = max r1 r2- h = y + h2- w = max w1 w2- t = t1- b = b2- vgap = vgap2- l = max (w1 + l1) (w2 + l2) - w- hgap = max (r1 + hgap1) (r2 + hgap2) - r + (x1,x2) = case halign of { AlignLeft -> (0,0) ; AlignRight -> (w-w1 , w-w2) } - where- Box w1 h1 l1 r1 t1 b1 hgap1 vgap1 = box1- Box w2 h2 l2 r2 t2 b2 hgap2 vgap2 = box2+ pos1 = Pos x1 0 + pos2 = Pos x2 y + y = quadB gap1 - quadT gap2++ h = y + h2+ w = max w1 w2+ outer = ofsLUB (pos1,outer1) (pos2,outer2)+ bound = ofsLUB (pos1,bound1) (pos2,bound2)+ gap = ofsLUB (pos1, gap1) (pos2, gap2)++ Box (w1,h1) outer1 bound1 gap1 = box1+ Box (w2,h2) outer2 bound2 gap2 = box2+ -------------------------------------------------------------------------------- hcatBox2 :: VAlign -> Box -> Box -> (Box,(AbsBox,AbsBox))-hcatBox2 valign box1 box2 = (box, (AbsBox p1 box1, AbsBox p2 box2)) where (box,p1,p2) = hcatBox valign box1 box2+hcatBox2 valign box1 box2 = (box, (AbsBox p1 box1, AbsBox p2 box2)) where (box,(p1,p2)) = hcatBox valign box1 box2 vcatBox2 :: HAlign -> Box -> Box -> (Box,(AbsBox,AbsBox))-vcatBox2 halign box1 box2 = (box, (AbsBox p1 box1, AbsBox p2 box2)) where (box,p1,p2) = vcatBox halign box1 box2+vcatBox2 halign box1 box2 = (box, (AbsBox p1 box1, AbsBox p2 box2)) where (box,(p1,p2)) = vcatBox halign box1 box2 -------------------------------------------------------------------------------- @@ -151,3 +234,104 @@ in (box, translate p12 ab1 : translate p12 ab2 : abs) --------------------------------------------------------------------------------+-- * Overlay boxes++-- | Overlay two boxes (so the corners given by the alignments coincide)+overlayBox :: HAlign -> VAlign -> Box -> Box -> (Box,(Pos,Pos))+overlayBox !halign !valign !box1 !box2 = (box,(pos1,pos2)) where++ box = Box (w,h) outer bound gap ++ Box (w1,h1) outer1 bound1 gap1 = box1+ Box (w2,h2) outer2 bound2 gap2 = box2++ (x1,x2) = case halign of { AlignLeft -> (0,0) ; AlignRight -> (w-w1 , w-w2) }+ (y1,y2) = case valign of { AlignTop -> (0,0) ; AlignBottom -> (h-h1 , h-h2) }+ + pos1 = Pos x1 y1+ pos2 = Pos x2 y2++ w = max w1 w2+ h = max h1 h2++ outer = ofsLUB (pos1,outer1) (pos2,outer2)+ bound = ofsLUB (pos1,bound1) (pos2,bound2)+ gap = ofsLUB (pos1, gap1) (pos2, gap2)++--------------------------------------------------------------------------------++overlayBox2 :: HAlign -> VAlign -> Box -> Box -> (Box,(AbsBox,AbsBox))+overlayBox2 halign valign box1 box2 = (box, (AbsBox p1 box1, AbsBox p2 box2)) where+ (box,(p1,p2)) = overlayBox halign valign box1 box2++overlayBoxes :: HAlign -> VAlign -> [Box] -> (Box,[AbsBox])+overlayBoxes !halign !valign boxes = case boxes of+ [] -> ( emptyBox, [] )+ [b] -> ( b, [AbsBox (Pos 0 0) b] ) + (b1:b2:bs) -> let (b12,(ab1,ab2) ) = overlayBox2 halign valign b1 b2+ (box,(ab12:abs)) = overlayBoxes halign valign (b12:bs) + p12 = _aboxOffset ab12+ in (box, translate p12 ab1 : translate p12 ab2 : abs)++--------------------------------------------------------------------------------+-- * Subscripts and superscripts++-- | Subscripts\/superscripts are special enough that it seems simpler to +-- just add a specific combinator for them.+subSupScriptBox :: Box -> (Double,Box) -> (Double,Box) -> (Box,(Pos,Pos))+subSupScriptBox box0 (y1,box1) (y2,box2) = (box,(pos1,pos2)) where++ box = Box (w,h) outer bound gap ++ pos1 = Pos x (h0+y1) + pos2 = Pos x (h0+y2)++ x = max (quadR gap0 - quadL gap1) + (quadR gap0 - quadL gap2)++ w = x + max w1 w2+ h = h0++ outer = outer0 <> ofsLUB (pos1,outer1) (pos2,outer2)+ bound = bound0 <> ofsLUB (pos1,bound1) (pos2,bound2)+ gap = gap0 <> ofsLUB (pos1, gap1) (pos2, gap2)++ Box (w0,h0) outer0 bound0 gap0 = box0+ Box (w1,h1) outer1 bound1 gap1 = box1+ Box (w2,h2) outer2 bound2 gap2 = box2++--------------------------------------------------------------------------------+-- * Above and below++-- | Positions are relative!+aboveBelowBox :: Box -> (Pos,Box) -> (Pos,Box) -> (Box,(Pos,Pos))+aboveBelowBox box0 (Pos x1ofs y1ofs, box1) (Pos x2ofs y2ofs, box2) = (box,(pos1,pos2)) where++ box = Box (w,h) outer bound gap ++ Quad (u1,v1) (u2,v2) = bound0++ xc = 0.5 * (u1+u2)++ x1 = xc - 0.5 * w1 + x1ofs - quadL bound1+ x2 = xc - 0.5 * w2 + x2ofs - quadL bound2++ y1 = v1 + y1ofs - quadB bound1+ y2 = v2 + y2ofs - quadT bound2++ pos1 = Pos x1 y1+ pos2 = Pos x2 y2++ w = w0+ h = h0++ outer = outer0 <> ofsLUB (pos1,outer1) (pos2,outer2)+ bound = bound0 <> ofsLUB (pos1,bound1) (pos2,bound2)+ gap = gap0 <> ofsLUB (pos1, gap1) (pos2, gap2)++ Box (w0,h0) outer0 bound0 gap0 = box0+ Box (w1,h1) outer1 bound1 gap1 = box1+ Box (w2,h2) outer2 bound2 gap2 = box2++--------------------------------------------------------------------------------+
src/Graphics/Rendering/MiniTypeset/Common.hs view
@@ -1,6 +1,7 @@ -- | Common data types and functions +{-# LANGUAGE FlexibleInstances, PatternSynonyms #-} module Graphics.Rendering.MiniTypeset.Common where --------------------------------------------------------------------------------@@ -23,15 +24,16 @@ -- * Colors data Col - = Col !Double !Double !Double+ = Col !Float !Float !Float deriving (Eq,Ord,Show) -colToTriple :: Col -> (Double,Double,Double)+colToTriple :: Col -> (Float,Float,Float) colToTriple (Col r g b) = (r,g,b) -tripleToCol :: (Double,Double,Double) -> Col+tripleToCol :: (Float,Float,Float) -> Col tripleToCol (r,g,b) = Col r g b +{- black, white, red, green, blue, yellow, cyan, magenta :: Col black = Col 0 0 0 white = Col 1 1 1@@ -41,6 +43,7 @@ yellow = Col 1 1 0 cyan = Col 0 1 1 magenta = Col 1 0 1+-} -------------------------------------------------------------------------------- -- * Alignment@@ -52,16 +55,36 @@ deriving (Eq,Ord,Show) -} +-- | Horizontal alignment data HAlign = AlignLeft | AlignRight deriving (Eq,Ord,Show) +-- | Vertical alignment data VAlign- = AlignBottom- | AlignTop+ = AlignTop+ | AlignBottom deriving (Eq,Ord,Show) +{-+pattern AlignLeft = AlignLeft' 0+pattern AlignRight = AlignRight' 0++pattern AlignTop = AlignTop' 0+pattern AlignBottom = AlignBottom' 0++data HAlign+ = AlignLeft' !Double -- ^ the number is an extra horizontal offset+ | AlignRight' !Double+ deriving (Eq,Ord,Show) ++data VAlign+ = AlignTop' !Double -- ^ the number is an extra vertical offset+ | AlignBottom' !Double+ deriving (Eq,Ord,Show) +-}+ -------------------------------------------------------------------------------- -- * Positions @@ -76,6 +99,9 @@ posToPair :: Pos -> (Double,Double) posToPair (Pos x y) = (x,y) +pairToPos :: (Double,Double) -> Pos+pairToPos (x,y) = (Pos x y) + instance Num Pos where (+) (Pos x y) (Pos u v) = Pos (x+u) (y+v) (-) (Pos x y) (Pos u v) = Pos (x-u) (y-v)@@ -104,34 +130,20 @@ instance Translate Pos where translate = (+) +instance Translate (Double,Double) where+ translate (Pos x y) (u,v) = (x+u, y+v)+ ----------------------------------------------------------------------------------- * Brackets+-- * Margins -data Bracket- = Paren- | Square- | Brace- | Angle -- 2329 / 232a- | Ceil -- 2308 / 2309- | Floor -- 230a / 230b- | Top -- 231c / 231d- | Bottom -- 231e / 231f- | AngleQuote -- 2039 / 203a- | FrenchQuote -- 00ab / 00bb+-- | A margin definition+data Margin = Margin+ { _leftMargin :: !Double+ , _rightMargin :: !Double+ , _topMargin :: !Double+ , _bottomMargin :: !Double+ } deriving (Eq,Ord,Show)--bracketChars :: Bracket -> (Char,Char)-bracketChars b = case b of- Paren -> ( '(' , ')' )- Square -> ( '[' , ']' )- Brace -> ( '{' , '}' )- Angle -> ( '\x2329' , '\x232a' )- Ceil -> ( '\x2308' , '\x2309' )- Floor -> ( '\x230a' , '\x230b' )- Top -> ( '\x231c' , '\x231d' )- Bottom -> ( '\x231e' , '\x231f' )- AngleQuote -> ( '\x2039' , '\x203a' )- FrenchQuote -> ( '\x00ab' , '\x00bb' ) -------------------------------------------------------------------------------- -- * misc utility
+ src/Graphics/Rendering/MiniTypeset/Document.hs view
@@ -0,0 +1,243 @@++-- | The document type, which expresses the intent of the user about+-- what to render.+--+-- We support general layouting \/ formatting, and also construction+-- specific to mathematical documents (similar to LaTeX).+--+-- TODO: fractions, brackets, mathemetical accents, compound symbols+--++{-# LANGUAGE OverloadedStrings, BangPatterns #-}+module Graphics.Rendering.MiniTypeset.Document where++--------------------------------------------------------------------------------++import Data.String++-- import qualified Data.Text as T ; import Data.Text (Text)++import Graphics.Rendering.MiniTypeset.Common+import Graphics.Rendering.MiniTypeset.Box ( WhichQuad(..) )++--------------------------------------------------------------------------------+-- * The document data type++-- | This data type describes what the user want to render.+--+-- The type parameter @ident@ is used when the user want to know positions (bounding boxes) of+-- different parts of the rendered text. It must have an 'Ord' instance.+--+data Document ident+ = Symbol !Char -- ^ a single character or symbol+ | String !String -- ^ a string + | Space -- ^ a space character (do we need this to be separate?)+ | HorzCat !VAlign [Document ident] -- ^ horizontal concatenation+ | VertCat !HAlign [Document ident] -- ^ vertical concatenation+ | Overlay !(HAlign,VAlign) [Document ident] -- ^ overlaying on the top of each other+ | SubSupScript !(SubSup ident) !(Document ident) -- ^ add subscript and\/or superscript+ | AboveBelow !(AboveBelow ident) !(Document ident) -- ^ above\/below (like in a summation or limit)+ | WithColor !Col !(Document ident) -- ^ change color+ | WithStyle !BasicStyle !(Document ident) -- ^ change font family+ | Decorated !TextDecoration !(Document ident) -- ^ add text decoration+ | Identified !ident !(Document ident) -- ^ user identifier so that the layout engine can return position information+ | AddMargin !Margin !(Document ident) -- ^ an extra margin around the document+ | Realign !WhichQuad !(Document ident) -- ^ change the alignment box+ | EmptyDoc -- ^ the empty document+ deriving (Eq,Ord,Show)++--------------------------------------------------------------------------------++-- | A text decoration+data TextDecoration + = Underline+ | Overline+ | StrikeThrough+ deriving (Eq,Ord,Show)++--------------------------------------------------------------------------------++-- | A subscript or a superscript, or both+data SubSup ident+ = Subscript !(Document ident)+ | Superscript !(Document ident)+ | SubAndSupscript !(Document ident) !(Document ident) -- ^ first is the subscript, second the superscript+ deriving (Eq,Ord,Show)++subSupDocs :: SubSup ident -> (Document ident, Document ident)+subSupDocs subsup = case subsup of+ Subscript sub -> (sub , EmptyDoc)+ Superscript sup -> (EmptyDoc , sup ) + SubAndSupscript sub sup -> (sub , sup )++--------------------------------------------------------------------------------++-- | Limits of summations and similar things.+data AboveBelow ident+ = Above !(Document ident)+ | Below !(Document ident)+ | AboveAndBelow !(Document ident) !(Document ident) -- ^ first is the above, second is below+ deriving (Eq,Ord,Show)++aboveBelowDocs :: AboveBelow ident -> (Document ident, Document ident)+aboveBelowDocs abelow = case abelow of+ Above ab -> (ab , EmptyDoc)+ Below be -> (EmptyDoc , be ) + AboveAndBelow ab be -> (ab , be )++--------------------------------------------------------------------------------+-- * Atomic documents++instance IsString (Document ident) where+ fromString = String++-- text :: Text -> Document a+-- text = String . T.unpack++string :: String -> Document a+string = String ++char :: Char -> Document a+char = Symbol++-- | A normal space+space :: Document a+space = Space++-- | A zero-width space (hopefully your chosen unicode font supports it)+zeroWidthSpace :: Document a+zeroWidthSpace = Symbol '\x200B'++--------------------------------------------------------------------------------+-- * Document combinators++-- | Horizontal concatenation+(<|>) :: Document a -> Document a -> Document a +(<|>) x y = hcat [x,y]++-- | Vertical concatenation+(<->) :: Document a -> Document a -> Document a +(<->) x y = vcat [x,y]++-- | Overlay+(<#>) :: Document a -> Document a -> Document a +(<#>) x y = overlay [x,y]++-- | Horizontal concatenation of several document fragments+hcat :: [Document a] -> Document a+hcat = hcatB++-- | Vertical concatenation of several document fragments+vcat :: [Document a] -> Document a+vcat = vcatL++-- | Overlay of several document fragments on top of each other+overlay :: [Document a] -> Document a+overlay = Overlay (AlignLeft,AlignBottom)++hcatB :: [Document a] -> Document a+hcatB = HorzCat AlignBottom++hcatT :: [Document a] -> Document a+hcatT = HorzCat AlignTop++vcatL :: [Document a] -> Document a+vcatL = VertCat AlignLeft++vcatR :: [Document a] -> Document a+vcatR = VertCat AlignRight++-- * Subscript and superscript++subscript :: Document a -> Document a -> Document a+subscript doc sub = SubSupScript (Subscript sub) doc++supscript :: Document a -> Document a -> Document a+supscript doc sup = SubSupScript (Superscript sup) doc++subSup :: Document a -> (Document a, Document a) -> Document a+subSup doc (sub,sup) = SubSupScript (SubAndSupscript sub sup) doc++-- * Above and below++-- | Used for \"big\" mathematical operators (like summation)+above :: Document a -> Document a -> Document a+above doc ab = AboveBelow (Above ab) doc++below :: Document a -> Document a -> Document a+below doc be = AboveBelow (Below be) doc++aboveBelow :: Document a -> (Document a, Document a) -> Document a+aboveBelow doc (ab,be) = AboveBelow (AboveAndBelow ab be) doc++-- * Text decoration++underline, overline, strike :: Document a -> Document a+underline = Decorated Underline +overline = Decorated Overline +strike = Decorated StrikeThrough ++-- * Font variations++regular, bold, italic, boldItalic :: Document a -> Document a+regular = WithStyle Regular+bold = WithStyle Bold+italic = WithStyle Italic+boldItalic = WithStyle BoldItalic++-- * Colors++white, black, red, green, blue :: Document a -> Document a+white = WithColor (Col 1 1 1)+black = WithColor (Col 0 0 0)+red = WithColor (Col 1 0 0)+green = WithColor (Col 0 1 0)+blue = WithColor (Col 0 0 1)++rgb :: Float -> Float -> Float -> Document a -> Document a+rgb r g b = WithColor (Col r g b)++-- * Margins++margin :: Double -> Document a -> Document a +margin x = AddMargin (Margin x x x x)++hmargin :: Double -> Document a -> Document a +hmargin x = AddMargin (Margin x x 0 0)++vmargin :: Double -> Document a -> Document a +vmargin x = AddMargin (Margin 0 0 x x)++margin' :: Double -> Double -> Double -> Double -> Document a -> Document a +margin' l r t b = AddMargin (Margin l r t b)++--------------------------------------------------------------------------------+-- * Brackets (not implemented yet)++data Bracket+ = Paren+ | Square+ | Brace+ | Angle -- 2329 / 232a+ | Ceil -- 2308 / 2309+ | Floor -- 230a / 230b+ | Top -- 231c / 231d+ | Bottom -- 231e / 231f+ | AngleQuote -- 2039 / 203a+ | FrenchQuote -- 00ab / 00bb+ deriving (Eq,Ord,Show)++bracketChars :: Bracket -> (Char,Char)+bracketChars b = case b of+ Paren -> ( '(' , ')' )+ Square -> ( '[' , ']' )+ Brace -> ( '{' , '}' )+ Angle -> ( '\x2329' , '\x232a' )+ Ceil -> ( '\x2308' , '\x2309' )+ Floor -> ( '\x230a' , '\x230b' )+ Top -> ( '\x231c' , '\x231d' )+ Bottom -> ( '\x231e' , '\x231f' )+ AngleQuote -> ( '\x2039' , '\x203a' )+ FrenchQuote -> ( '\x00ab' , '\x00bb' )++--------------------------------------------------------------------------------
src/Graphics/Rendering/MiniTypeset/FontTexture.hs view
@@ -32,6 +32,11 @@ -------------------------------------------------------------------------------- +replacementCharacter :: Char +replacementCharacter = '\xfffd' + +-------------------------------------------------------------------------------- + -- newtype FontIdx = FontIdx { unFontIdx :: Int } -- | The location of a glyph in a font texture collection @@ -128,6 +133,7 @@ , _ftexBufSize :: !(Int,Int) , _ftexCursor :: !(IORef TexCursor) , _ftexBufs :: !(IORef [TexBuf]) + , _ftexLGapFactor :: !Double } instance Show FontTexture where @@ -140,11 +146,11 @@ defaultTextureSize = (512,512) -- (128,128) -- (512,512) -- (1024,1024) newFontTexture :: Font -> Float -> String -> IO FontTexture -newFontTexture font height name = newFontTexture' font height name defaultTextureSize +newFontTexture font height name = newFontTexture' font height name defaultTextureSize 1 -- | Creates a new (empty) font texture -newFontTexture' :: Font -> Float -> String -> (Int,Int) -> IO FontTexture -newFontTexture' font height name size = do +newFontTexture' :: Font -> Float -> String -> (Int,Int) -> Double -> IO FontTexture +newFontTexture' font height name size lgapfactor = do uc <- newUnicodeCache vmu <- getFontVerticalMetrics font let s = scaleForPixelHeight vmu height @@ -165,19 +171,25 @@ , _ftexBufSize = size , _ftexCursor = cur , _ftexBufs = texbufref + , _ftexLGapFactor = lgapfactor } void $ allocateTexBuf ftex -- allocate the very first buffer return ftex -- | Finds a character in the font texture (rendering it first if necessary). --- If the glyph is not present in the font, we return the \"not defined glyph\" --- instead. +-- If the glyph is not present in the font, we return the \"replacement character\" +-- instead. If that doesn't exist either, then we return the \"not defined glyph\" +-- (glyph #0) lookupFontTexture :: FontTexture -> Char -> IO BufLoc lookupFontTexture ftex ch = do mb <- mbLookupFontTexture ftex ch case mb of - Nothing -> lookupFontTexture ftex notDefinedGlyphChar Just bufloc -> return bufloc + Nothing -> do + mb <- mbLookupFontTexture ftex replacementCharacter + case mb of + Just bufloc -> return bufloc + Nothing -> lookupFontTexture ftex notDefinedGlyphChar -- | Finds a character in the font texture (rendering it first if necessary) mbLookupFontTexture :: FontTexture -> Char -> IO (Maybe BufLoc)
src/Graphics/Rendering/MiniTypeset/Layout.hs view
@@ -19,72 +19,71 @@ import Graphics.Rendering.MiniTypeset.Common import Graphics.Rendering.MiniTypeset.Box +import Graphics.Rendering.MiniTypeset.Document import Graphics.Rendering.MiniTypeset.FontTexture import Graphics.Rendering.MiniTypeset.MultiFont import Graphics.Rendering.MiniTypeset.Render -------------------------------------------------------------------------------- - --- | Subscript \/ superscript relative sizes -subSuperSize = 0.66 :: Double -superPos = 0.27 :: Double -subPos = -0.16 :: Double +-- * Relative position and size constants (mathematical coordinate system!) --------------------------------------------------------------------------------- +subSupSize = 0.65 :: Double -- Subscript \/ superscript relative sizes +supPos = 0.40 :: Double -- Superscript relative position +subPos = -0.20 :: Double -- Subscript relative position --- | This data type describes what the user want to render. --- --- The type parameter @ident@ is used when the user want to know positions (bounding boxes) of --- different parts of the rendered text. It must have an 'Ord' instance. --- -data Document ident - = Symbol !Char - | String !String - | Space - | HorzCat !VAlign [Document ident] - | VertCat !HAlign [Document ident] - | WithColor !Col !(Document ident) - | WithStyle !BasicStyle !(Document ident) - | Identified !ident !(Document ident) -- ^ user identifier so that the layout engine can return position information - deriving (Eq,Ord,Show) +underlinePos = -0.10 :: Double -- Underline relative position +overlinePos = 0.10 :: Double -- Overline relative position +strikeThroughPos = 0.48 :: Double -- Strike-through relative position +horizLineWidth = 0.045 :: Double -- Text decoration line width --- | SubScript !Document !Document !LeftRight --- | SuperScript !Document !Document !LeftRight --- | Above !Document !Document !Bool -- choose or fraction (the bool is separator line) --- | InBrackets !Bracket !Document +abovePos = 0.15 :: Double +belowPos = -0.15 :: Double -------------------------------------------------------------------------------- +-- * Subscript size indexing -- | 0 is the default size, 1 is smaller, 2 is even smaller, etc (each subscript newtype SizeIndex = SizeIndex Int deriving (Eq,Ord,Show) - --------------------------------------------------------------------------------- + +succSizeIndex :: SizeIndex -> SizeIndex +succSizeIndex (SizeIndex n) = SizeIndex (n+1) -mfgRelBox :: MultiFontGlyph -> Box -mfgRelBox (MFG ftex bufloc) = Box width height 0 0 top bottom 0 lgap where - vm = _ftexVM ftex - hm = _locHM bufloc - top = float2Double (ascent vm) - bottom = negate $ float2Double (descent vm) -- note: we change the sign here!!! - lgap = float2Double (lineGap vm) - width = float2Double (advanceWidth hm) - height = 0 +calculateSizeHeight :: Height -> SizeIndex -> Int +calculateSizeHeight (Height height) = go where + go (SizeIndex n) + | n == 0 = height + | n == 1 = round (fromIntegral height * subSupSize) + | n == 2 = round (fromIntegral height * subSupSize * subSupSize) + | n == 3 = round (fromIntegral height * subSupSize * subSupSize * 0.8) + | n > 3 = go (SizeIndex 3) -------------------------------------------------------------------------------- +-- * The layout data type -- | This data type is the output of the layout engine. The ``identifying'' part -- is retained, because everything is still relative, and only during the rendering -- will positions become absolute. See 'dryrunLayout' data Layout ident style - = LoutGlyph Pos style Col Char MultiFontGlyph - | LoutGroup Box [Layout ident style] - | LoutOfs Pos (Layout ident style) - | LoutIdent ident (Layout ident style) + = LoutGlyph !Pos !style !Col !Char !MultiFontGlyph + | LoutGroup !Box [Layout ident style] + | LoutBox !Box (Layout ident style) + | LoutOfs !Pos (Layout ident style) + | LoutIdent !ident (Layout ident style) + | LoutDecor !LayoutDecoration (Layout ident style) | LoutEmpty deriving (Show) +data LayoutDecoration + = HorizLine + { _hlineCol :: !Col + , _hlineVAlign :: !VAlign + , _hlineVPos :: !Double + , _hlineLineWidth :: !Double + } + deriving (Show) + instance Translate (Layout ident style) where translate = translateLayout @@ -94,8 +93,40 @@ LoutOfs ofs0 lout -> LoutOfs (ofs0+ofs) lout -- minor optimization _ -> LoutOfs ofs layout +reboxLayout :: Box -> Layout ident style -> Layout ident style +reboxLayout box layout = case layout of + LoutGroup _ louts -> LoutGroup box louts + LoutBox _ lout -> LoutBox box lout + _ -> LoutBox box layout + -------------------------------------------------------------------------------- +-- * The box of a glyph +mfgRelBox :: MultiFontGlyph -> Box +mfgRelBox (MFG ftex bufloc) = Box (width,height) outer bound gap where + vm = _ftexVM ftex + hm = _locHM bufloc + + top = - float2Double (ascent vm) -- ascent is normally positive + bottom = - float2Double (descent vm) -- descent is normally negative + lgap = float2Double (lineGap vm) * lgapfactor + width = float2Double (advanceWidth hm) + height = 0 + lgapfactor = _ftexLGapFactor ftex + + outer = Quad (0,top) (width,bottom) + gap = Quad (0,top) (width,bottom+lgap) + + bound = Quad (fi ofsx , fi ofsy) (fi (ofsx+sizx) , fi (ofsy+sizy)) + + (ofsx,ofsy) = _locBufOfs bufloc + (sizx,sizy) = _locBufSiz bufloc + + fi = fromIntegral :: Int -> Double + +-------------------------------------------------------------------------------- +-- * Rendering a layout + -- | Renders the layout to the OpenGL framebuffer. -- -- Note: you should set up the OpenGL coordinate transformation matrices @@ -138,10 +169,19 @@ unless dryrun $ renderMFG (pos+ofs) col mfg return (AbsBox pos $ mfgRelBox mfg) + LoutDecor decor lout -> do + absbox <- go table pos lout + unless dryrun $ renderLayoutDecoration absbox decor + return absbox + LoutGroup relbox louts -> do mapM_ (go table pos) louts return (AbsBox pos relbox) + LoutBox relbox lout -> do + go table pos lout + return (AbsBox pos relbox) + LoutOfs ofs lout -> go table (pos + ofs) lout LoutIdent ident lout -> do @@ -153,6 +193,19 @@ -------------------------------------------------------------------------------- +renderLayoutDecoration :: AbsBox -> LayoutDecoration -> IO () +renderLayoutDecoration absbox decor = case decor of + + HorizLine col valign vpos lwidth -> do + let Quad (x1,y1) (x2,y2) = absboxBoundingQuad absbox + let y = case valign of + AlignTop -> y1 - vpos + AlignBottom -> y2 - vpos + renderLine col (max 1 lwidth) (Pos x1 y) (Pos x2 y) + +-------------------------------------------------------------------------------- +-- * Creating a layouting + -- | Creates a layout from a document. Then you can render the resulting layout -- with 'renderLayout' createLayout @@ -165,11 +218,13 @@ (box0,lout0) <- createLayout' multifont height doc -- The layout origin is not the top-left corner, but the baseline of the first line. -- Normally you want to shift it down so that the first line is visible, too. - let ofs = Pos (_rboxLeftMarg box0) (_rboxTopMarg box0) + let outer@(Quad (l,t) _) = boxOuterQuad box0 + let ofs = Pos (-l) (-t) return $ translate ofs lout0 -------------------------------------------------------------------------------- +-- | A type used by 'createLayout' data Cfg = Cfg { _currentSize :: !SizeIndex , _currentStyle :: !BasicStyle @@ -191,48 +246,86 @@ -> Height -> Document ident -> IO (Box, Layout ident style) -createLayout' multifont (Height height) doc = go initialCfg doc where +createLayout' multifont height doc = go initialCfg doc where styleMap = (_ufcStyleMap . _mfUserConfig) multifont initialCfg = defaultCfg sizeHeight :: SizeIndex -> Int - sizeHeight (SizeIndex n) - | n == 0 = height - | n == 1 = round (fromIntegral height * subSuperSize) - | n == 2 = round (fromIntegral height * subSuperSize * subSuperSize) - | n == 3 = round (fromIntegral height * subSuperSize * subSuperSize * 0.8) - | n > 3 = sizeHeight (SizeIndex 3) + sizeHeight = calculateSizeHeight height - hcat :: Cfg -> VAlign -> [Document ident] -> IO (Box, Layout ident style) - hcat !cfg !valign docs = case docs of - [] -> return (emptyBox, LoutEmpty) - [d] -> go cfg d - _ -> do - bls <- mapM (go cfg) docs - let (boxes,louts) = unzip bls - (box,aboxes) = hcatBoxes valign boxes - offsets = map _aboxOffset aboxes - return (box, LoutGroup box (zipWith translate offsets louts)) + fsizeHeight :: SizeIndex -> Double + fsizeHeight = fromIntegral . sizeHeight - vcat :: Cfg -> HAlign -> [Document ident] -> IO (Box, Layout ident style) - vcat !cfg !halign docs = case docs of + relativePlacement :: ([Box] -> (Box,[AbsBox])) -> Cfg -> [Document ident] -> IO (Box, Layout ident style) + relativePlacement place !cfg docs = case docs of [] -> return (emptyBox, LoutEmpty) [d] -> go cfg d _ -> do bls <- mapM (go cfg) docs let (boxes,louts) = unzip bls - (box,aboxes) = vcatBoxes halign boxes + (box,aboxes) = place boxes offsets = map _aboxOffset aboxes return (box, LoutGroup box (zipWith translate offsets louts)) go :: Cfg -> Document ident -> IO (Box, Layout ident style) go cfg doc = case doc of + EmptyDoc -> return (emptyBox, LoutEmpty) + WithColor col doc -> go cfg' doc where cfg' = cfg { _currentColor = col } WithStyle sty doc -> go cfg' doc where cfg' = cfg { _currentStyle = sty } + Decorated decor doc -> do + (box,lout) <- go cfg doc + let col = _currentColor cfg + ht = fsizeHeight (_currentSize cfg) + lwidth = horizLineWidth * ht + ldecor = case decor of + Underline -> HorizLine col AlignBottom (underlinePos * ht) lwidth + Overline -> HorizLine col AlignTop (overlinePos * ht) lwidth + StrikeThrough -> HorizLine col AlignBottom (strikeThroughPos * ht) lwidth + return (box, LoutDecor ldecor lout) + + SubSupScript subsup doc -> do + let (doc1,doc2) = subSupDocs subsup + (box0,lout0) <- go cfg doc + let cfg' = cfg { _currentSize = succSizeIndex (_currentSize cfg) } + (box1,lout1) <- go cfg' doc1 + (box2,lout2) <- go cfg' doc2 + let ht = fsizeHeight (_currentSize cfg) + ofs1 = - subPos * ht + ofs2 = - supPos * ht + let (box,(pos1,pos2)) = subSupScriptBox box0 (ofs1,box1) (ofs2,box2) + lout = LoutGroup box [ lout0, translate pos1 lout1 , translate pos2 lout2 ] + return (box,lout) + + AboveBelow aboveBelow doc -> do + let (doc1,doc2) = aboveBelowDocs aboveBelow + (box0,lout0) <- go cfg doc + let cfg' = cfg { _currentSize = succSizeIndex (_currentSize cfg) } + (box1,lout1) <- go cfg' doc1 + (box2,lout2) <- go cfg' doc2 + let ht = fsizeHeight (_currentSize cfg) + ofs1 = Pos 0 (- abovePos * ht) + ofs2 = Pos 0 (- belowPos * ht) + let (box,(pos1,pos2)) = aboveBelowBox box0 (ofs1,box1) (ofs2,box2) + lout = LoutGroup box [ lout0, translate pos1 lout1 , translate pos2 lout2 ] + return (box,lout) + + Realign which doc -> do + (box , lout) <- go cfg doc + let box' = realignBox which box + return (box', reboxLayout box' lout) + + AddMargin margin doc -> do + (Box siz outer bound gap , lout) <- go cfg doc + let outer' = marginQuad margin outer -- should we also extend the outer box or not?? + gap' = marginQuad margin gap + box' = Box siz outer' bound gap' + return (box' , reboxLayout box' lout) + Identified uid doc -> do (box, lout) <- go cfg doc return (box, LoutIdent uid lout) @@ -249,7 +342,8 @@ String chars -> go cfg (HorzCat AlignBottom $ map Symbol chars) - HorzCat valign docs -> hcat cfg valign docs - VertCat halign docs -> vcat cfg halign docs + HorzCat valign docs -> relativePlacement (hcatBoxes valign) cfg docs + VertCat halign docs -> relativePlacement (vcatBoxes halign) cfg docs + Overlay (ha,va) docs -> relativePlacement (overlayBoxes ha va) cfg docs --------------------------------------------------------------------------------
src/Graphics/Rendering/MiniTypeset/MultiFont.hs view
@@ -56,9 +56,10 @@ -- font files and styles. They should be an enumerated type for efficiency. @fontfile@ -- must have 'Eq' and 'Ord' instances, too. data UserFontConfig fontfile style = UserFontConfig - { _ufcFontFiles :: fontfile -> FilePath -- ^ the mapping from abstract to physical font files - , _ufcCharMap :: style -> Char -> fontfile -- ^ the mapping from characters to font files - , _ufcStyleMap :: BasicStyle -> style -- ^ mapping the basic style into the user styles + { _ufcFontFiles :: fontfile -> FilePath -- ^ the mapping from abstract to physical font files + , _ufcCharMap :: style -> Char -> fontfile -- ^ the mapping from characters to font files + , _ufcStyleMap :: BasicStyle -> style -- ^ mapping the basic style into the user styles + , _ufcLineGapFactor :: !Double -- ^ extend or shrink the font default line gap } data MultiFont fontfile style = MultiFont @@ -69,6 +70,9 @@ mfCharMap :: MultiFont fontfile style -> style -> Char -> fontfile mfCharMap = _ufcCharMap . _mfUserConfig +mfLineGapFactor :: MultiFont fontfile style -> Double +mfLineGapFactor = _ufcLineGapFactor . _mfUserConfig + newMultiFont :: Ord fontfile => UserFontConfig fontfile style -> IO (MultiFont fontfile style) newMultiFont ufc = do tbl <- newIORef Map.empty @@ -101,7 +105,7 @@ old_table <- readIORef (_mfFontTexs mf) let fpath = (_ufcFontFiles $ _mfUserConfig mf) ffile font <- loadFontFile fpath - ftex <- newFontTexture' font (fromIntegral height) (takeFileName fpath) (stdFontTextureSize height) + ftex <- newFontTexture' font (fromIntegral height) (takeFileName fpath) (stdFontTextureSize height) (mfLineGapFactor mf) let new_table = mapInsert (IntMap.singleton height ftex) (IntMap.insert height ftex) ffile old_table writeIORef (_mfFontTexs mf) new_table @@ -111,6 +115,9 @@ data MultiFontGlyph = MFG !FontTexture !BufLoc deriving Show + +mfgLineGapFactor :: MultiFontGlyph -> Double +mfgLineGapFactor (MFG ftex _) = _ftexLGapFactor ftex {- mbLkpMultiFont :: Ord fontfile => MultiFont fontfile style -> Int -> style -> Char -> IO (Maybe MultiFontGlyph)
src/Graphics/Rendering/MiniTypeset/Render.hs view
@@ -27,68 +27,63 @@ import Graphics.Rendering.MiniTypeset.MultiFont -------------------------------------------------------------------------------- + +setCol :: Col -> IO () +setCol !(Col r g b) = color (Color3 r g b) + +setColAlpha :: Col -> Float -> IO () +setColAlpha !(Col r g b) !a = color (Color4 r g b a) + +-------------------------------------------------------------------------------- -- * Render boxes --- | Renders the outer box as a quad -renderOuterBoxQuad :: AbsBox -> IO () -renderOuterBoxQuad (AbsBox (Pos x0 y0) (Box w h l r t b hgap vgap)) = do - let x1 = x0 - l - x2 = x0 + w + r - let y1 = y0 - t - y2 = y0 + h + b +renderQuad :: Quad -> IO () +renderQuad (Quad (x1,y1) (x2,y2)) = renderPrimitive Quads $ do vertex (Vertex2 x1 y1) vertex (Vertex2 x2 y1) vertex (Vertex2 x2 y2) vertex (Vertex2 x1 y2) +-- | Renders the outer box as a quad +renderOuterBoxQuad :: AbsBox -> IO () +renderOuterBoxQuad = renderQuad . absboxOuterQuad + -- | Renders the inner box as a quad renderInnerBoxQuad :: AbsBox -> IO () -renderInnerBoxQuad (AbsBox (Pos x0 y0) (Box w h l r t b hgap vgap)) = do - let x1 = x0 - x2 = x0 + w - let y1 = y0 - y2 = y0 + h - renderPrimitive Quads $ do - vertex (Vertex2 x1 y1) - vertex (Vertex2 x2 y1) - vertex (Vertex2 x2 y2) - vertex (Vertex2 x1 y2) +renderInnerBoxQuad = renderQuad . absboxInnerQuad --- | Renders the gap of a box (useful for debugging) -renderBoxGap :: AbsBox -> IO () -renderBoxGap (AbsBox (Pos x0 y0) (Box w h l r t b hgap vgap)) = do +-- | Renders the gap quad (useful for debugging) +renderGapBoxQuad :: AbsBox -> IO () +renderGapBoxQuad = renderQuad . absboxGapQuad - renderPrimitive Quads $ do - - when (hgap > 0) $ do - let x1 = x0 + w + r - x2 = x1 + hgap - let y1 = y0 - t - y2 = y0 + h + b + vgap - vertex (Vertex2 x1 y1) - vertex (Vertex2 x2 y1) - vertex (Vertex2 x2 y2) - vertex (Vertex2 x1 y2) +-- | Renders the bounding box quad (useful for debugging) +renderBoundingBoxQuad :: AbsBox -> IO () +renderBoundingBoxQuad = renderQuad . absboxBoundingQuad - when (vgap > 0) $ do - let x1 = x0 - l - x2 = x0 + w + r {- + hgap -} -- there should be no overlap, because it ruins blending - let y1 = y0 + h + b - y2 = y1 + vgap - vertex (Vertex2 x1 y1) - vertex (Vertex2 x2 y1) - vertex (Vertex2 x2 y2) - vertex (Vertex2 x1 y2) +-------------------------------------------------------------------------------- +-- * Render lines +-- TODO: finetune line rendering (retina display, antialising, position hinting based on width, etc...) +renderLine :: Col -> Double -> Pos -> Pos -> IO () +renderLine !col !lwidth !(Pos x1 y1) !(Pos x2 y2) = do + setCol col + lineWidth $= double2Float lwidth + let hwidth = 0.5 * lwidth + renderPrimitive Lines $ do + vertex $ Vertex2 (dround x1) (dround y1) + vertex $ Vertex2 (dround x2) (dround y2) + where + dround :: Double -> Double + dround !x = fromIntegral (round x :: Int) + -------------------------------------------------------------------------------- -- * Render characters -- | Renders a multifont glyph with the given color. renderMFG :: Pos -> Col -> MultiFontGlyph -> IO () -renderMFG pos (Col colr colg colb) (MFG ftex bufloc) = do - - color (Color3 colr colg colb) +renderMFG !pos !col !(MFG ftex bufloc) = do + setCol col renderChar' pos ftex bufloc -------------------------------------------------------------------------------- @@ -111,7 +106,7 @@ -------------------------------------------------------------------------------- renderChar' :: Pos -> FontTexture -> BufLoc -> IO () -renderChar' pos@(Pos x0 y0) ftex bufloc = do +renderChar' !pos@(Pos x0 y0) !ftex !bufloc = do bufs <- readIORef (_ftexBufs ftex) let texBuf@(TexBuf texobj texsiz) = bufs!!(_locBufIdx bufloc)