summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorBalazsKomuves <>2019-04-14 20:03:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-04-14 20:03:00 (GMT)
commitf22d18521516c1b6b9899e26b3ad3eca7d3f39b5 (patch)
tree873b3c77c5516fdd5b70e9b0cc3f616f8e0763a1
version 0.1.0.0HEAD0.1.0.0master
-rw-r--r--LICENSE29
-rw-r--r--Setup.lhs3
-rw-r--r--example/GL.hs124
-rw-r--r--example/UnicodeMath.hs157
-rw-r--r--example/example-STIX.hs194
-rw-r--r--example/example-boxes.hs142
-rw-r--r--minitypeset-opengl.cabal54
-rw-r--r--src/Graphics/Rendering/MiniTypeset.hs35
-rw-r--r--src/Graphics/Rendering/MiniTypeset/Box.hs153
-rw-r--r--src/Graphics/Rendering/MiniTypeset/Common.hs144
-rw-r--r--src/Graphics/Rendering/MiniTypeset/FontTexture.hs287
-rw-r--r--src/Graphics/Rendering/MiniTypeset/Layout.hs255
-rw-r--r--src/Graphics/Rendering/MiniTypeset/MultiFont.hs141
-rw-r--r--src/Graphics/Rendering/MiniTypeset/Render.hs157
14 files changed, 1875 insertions, 0 deletions
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..aac9461
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,29 @@
+Copyright (c) 2018-2019, Balazs Komuves
+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 names of the copyright holders nor the names of the 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.lhs b/Setup.lhs
new file mode 100644
index 0000000..2917094
--- /dev/null
+++ b/Setup.lhs
@@ -0,0 +1,3 @@
+#! /usr/bin/env runhaskell
+> import Distribution.Simple
+> main = defaultMain \ No newline at end of file
diff --git a/example/GL.hs b/example/GL.hs
new file mode 100644
index 0000000..51a1feb
--- /dev/null
+++ b/example/GL.hs
@@ -0,0 +1,124 @@
+
+-- | Initialize an OpenGL window using the GLFW-b library
+
+module GL where
+
+--------------------------------------------------------------------------------
+
+import Data.Char hiding ( Space )
+
+import Control.Monad
+import Control.Concurrent
+import Data.IORef
+
+import System.Exit
+import System.IO.Unsafe as Unsafe
+
+import Graphics.UI.GLFW as GLFW
+import Graphics.Rendering.OpenGL as GL
+
+--------------------------------------------------------------------------------
+
+theWindowSize :: IORef (Int,Int)
+theWindowSize = Unsafe.unsafePerformIO $ newIORef $ error "window size not set"
+
+setWindowCoordSystem :: IO ()
+setWindowCoordSystem = do
+ matrixMode $=! Projection
+ loadIdentity
+ (w,h) <- readIORef theWindowSize
+ GL.ortho 0 (fromIntegral w) (fromIntegral h) 0 (-1) (1::Double)
+ matrixMode $=! Modelview 0
+ loadIdentity
+
+--------------------------------------------------------------------------------
+
+myErrorCallback :: GLFW.Error -> String -> IO ()
+myErrorCallback err msg = do
+ putStrLn $ msg ++ "(" ++ show err ++ ")"
+ myExit
+
+myKeyCallback :: Window -> Key -> Int -> KeyState -> ModifierKeys -> IO ()
+myKeyCallback _ key nrepeat keyState modif =
+ case key of
+ Key'Escape -> myExit
+ _ -> return ()
+
+myCharCallback :: Window -> Char -> IO ()
+myCharCallback _ char = do
+ return ()
+
+myWinCloseCallback :: Window -> IO ()
+myWinCloseCallback window = myExit
+
+myFrBufSizeCallback :: Window -> Int -> Int -> IO ()
+myFrBufSizeCallback window xsiz ysiz = do
+ writeIORef theWindowSize (xsiz,ysiz)
+ putStrLn $ "framebuffer resized to " ++ show (xsiz,ysiz)
+
+myRefreshCallback :: Window -> IO ()
+myRefreshCallback window = do
+ return ()
+
+myExit :: IO ()
+myExit = do
+ -- terminate
+ exitWith ExitSuccess
+
+--------------------------------------------------------------------------------
+
+{-
+frac :: Double -> Double
+frac x = x - fromIntegral (floor x :: Int)
+
+fmod :: Double -> Double -> Double
+fmod x s = frac (x/s) * s
+-}
+
+--------------------------------------------------------------------------------
+
+renderLoop :: (Window -> Double -> IO ()) -> Window -> IO ()
+renderLoop display window = loop where
+ loop = do
+ Just time <- getTime
+ -- print time
+ display window time
+ swapBuffers window
+ threadDelay 50
+ loop
+
+--------------------------------------------------------------------------------
+
+initGL :: IO precalc -> (precalc -> Window -> Double -> IO ()) -> IO ()
+initGL userPrecalc userDisplay = do
+
+ setErrorCallback (Just myErrorCallback)
+ GLFW.init
+
+ Just window <- createWindow 800 500 "window title" Nothing Nothing
+
+ (xsiz,ysiz) <- getFramebufferSize window
+ putStrLn $ "initial framebuffer size = " ++ show (xsiz,ysiz)
+ writeIORef theWindowSize (xsiz,ysiz)
+
+ major <- getWindowContextVersionMajor window
+ minor <- getWindowContextVersionMinor window
+ rev <- getWindowContextVersionRevision window
+ putStrLn $ "OpenGL context version = " ++ show major ++ "." ++ show minor ++ "." ++ show rev
+
+ setWindowCloseCallback window (Just myWinCloseCallback )
+ setKeyCallback window (Just myKeyCallback )
+ setCharCallback window (Just myCharCallback )
+ setFramebufferSizeCallback window (Just myFrBufSizeCallback)
+ setWindowRefreshCallback window (Just myRefreshCallback )
+
+ forkOS $ do
+ makeContextCurrent (Just window)
+ swapInterval 1
+ precalc <- userPrecalc
+ renderLoop (userDisplay precalc) window
+
+ forever waitEvents
+
+--------------------------------------------------------------------------------
+
diff --git a/example/UnicodeMath.hs b/example/UnicodeMath.hs
new file mode 100644
index 0000000..d68c95e
--- /dev/null
+++ b/example/UnicodeMath.hs
@@ -0,0 +1,157 @@
+
+-- | Some unicode math symbols for testing purposes
+
+module UnicodeMath where
+
+--------------------------------------------------------------------------------
+
+import qualified Data.Map as Map
+import Data.Map (Map)
+
+--------------------------------------------------------------------------------
+-- * for testing
+
+greeks =
+ [ alpha, beta, gamma, delta, epsilon, zeta, eta, theta
+ , iota, kappa, lambda, mu, nu, xi {- ,omicron -}
+ , pi_, rho, sigma, tau, upsilon, phi, chi, psi, omega
+ ]
+
+math_test =
+ [ forall_ , alpha, beta, gamma , '.' , ' '
+ , alpha , ostar , '(' , beta , oplus , gamma , ')' , ' ' , '='
+ , alpha , ostar, beta , oplus , alpha, ostar , gamma
+ ]
+
+--------------------------------------------------------------------------------
+
+latexToChar :: String -> Maybe Char
+latexToChar s = Map.lookup s latexSymbolTable
+
+latexSymbolTable :: Map String Char
+latexSymbolTable = Map.fromList
+ [
+ "forall" ~> forall_
+ , "exists" ~> exists
+ , "prod" ~> prod
+ , "coprod" ~> coprod
+ , "sum" ~> sum_
+ --
+ , "oplus" ~> oplus
+ , "ominus" ~> ominus
+ , "otimes" ~> otimes
+ , "odot" ~> odot
+ , "ostar" ~> ostar
+ -- greek
+ , "alpha" ~> alpha
+ , "beta" ~> beta
+ , "gamma" ~> gamma
+ , "delta" ~> delta
+ , "epsilon" ~> epsilon
+ , "zeta" ~> zeta
+ , "eta" ~> eta
+ , "theta" ~> theta
+ -- std blackboard numbers
+ , "Z" ~> zz
+ , "N" ~> nn
+ , "Q" ~> qq
+ , "R" ~> rr
+ , "C" ~> cc
+ -- some letterlike
+ , "ell" ~> ell
+ , "hbar" ~> hbar
+ , "aleph" ~> aleph
+ -- brackets
+ , "langle" ~> langle
+ , "rangle" ~> rangle
+ ]
+ where
+ (~>) a b = (a,b)
+
+--------------------------------------------------------------------------------
+-- * misc other
+
+openbox = '\x2423' -- blank
+
+--------------------------------------------------------------------------------
+-- * brackets
+
+langle = '\x2329'
+rangle = '\x232a'
+
+--------------------------------------------------------------------------------
+-- * ligatures
+
+ff = '\xfb00'
+fi = '\xfb01'
+fl = '\xfb02'
+ffi = '\xfb03'
+ffl = '\xfb04'
+
+--------------------------------------------------------------------------------
+-- * some math operators
+
+forall_ = '\x2200'
+exists = '\x2203'
+
+prod = '\x220f'
+coprod = '\x2210'
+sum_ = '\x2211'
+
+oplus = '\x2295'
+ominus = '\x2296'
+otimes = '\x2297'
+odot = '\x2299'
+ostar = '\x229b'
+
+--------------------------------------------------------------------------------
+-- * some letterlike
+
+hbar = '\x210f'
+ell = '\x2113'
+aleph = '\x2135'
+
+cc = '\x2102'
+nn = '\x2115'
+zz = '\x2124'
+qq = '\x211a'
+rr = '\x211d'
+
+--------------------------------------------------------------------------------
+-- * greek lowercase
+
+alpha = '\x03b1'
+beta = '\x03b2'
+gamma = '\x03b3'
+delta = '\x03b4'
+epsilon = '\x03b5'
+zeta = '\x03b6'
+eta = '\x03b7'
+theta = '\x03b8'
+iota = '\x03b9'
+kappa = '\x03ba'
+lambda = '\x03bb'
+mu = '\x03bc'
+nu = '\x03bd'
+xi = '\x03be'
+omicron = '\x03bf'
+pi_ = '\x03c0'
+rho = '\x03c1'
+sigma = '\x03c3'
+tau = '\x03c4'
+upsilon = '\x03c5'
+phi = '\x03c6'
+chi = '\x03c7'
+psi = '\x03c8'
+omega = '\x03c9'
+
+--------------------------------------------------------------------------------
+-- * some cyrillic
+
+lje = '\x0409'
+de = '\x0414'
+zhe = '\x0416'
+sha = '\x0428'
+shcha = '\x0429'
+
+--------------------------------------------------------------------------------
diff --git a/example/example-STIX.hs b/example/example-STIX.hs
new file mode 100644
index 0000000..509b40b
--- /dev/null
+++ b/example/example-STIX.hs
@@ -0,0 +1,194 @@
+
+-- | To be able to run this example,
+--
+-- * install the GLFW-b library (for example using cabal)
+--
+-- * download the STIX2 font files in OTF format from <https://github.com/stipub/stixfonts>,
+-- and put them in this directory (5 files with @.otf@ extension)
+--
+-- * compile this source file with @ghc -O --make -threaded@
+--
+
+module Main where
+
+--------------------------------------------------------------------------------
+
+import Data.Char hiding ( Space )
+
+import Control.Monad
+import Data.IORef
+import System.IO.Unsafe as Unsafe
+
+import qualified Data.Map as Map ; import Data.Map (Map)
+
+import Graphics.Rendering.OpenGL as GL
+import Graphics.UI.GLFW ( Window )
+
+import Graphics.Rendering.MiniTypeset
+
+import GL
+import UnicodeMath
+
+--------------------------------------------------------------------------------
+-- * The \"document\" we want to render (normally you want to generate this)
+
+document :: Document String
+document
+ = Identified "document"
+ $ VertCat AlignRight
+ [ block12
+ , Space
+ , block3
+ ]
+
+block12 = HorzCat AlignBottom [ block1 , Space , block2 ]
+
+block1 = Identified "block1"
+ $ VertCat AlignLeft [line1a,line1b,line1c,line1d]
+
+block2 = VertCat AlignRight [line2a,line2b,line2c,line2d,line2e]
+
+block3 = Identified "block3"
+ $ VertCat AlignLeft [ WithColor (Col 1 1 0) (String greeks), Space, WithColor (Col 1 1 1) equ ]
+
+line1a = String "Lorem ipsum dolor sit amet,"
+line1b = WithColor (Col 0.7 0 0)
+ $ String "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."
+ ]
+
+line2a = String "Ut enim ad 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."
+
+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
+ ]
+
+--------------------------------------------------------------------------------
+
+-- | An enum encoding the font files we use
+data MyFontFile
+ = Stix2TextRegular
+ | Stix2TextBold
+ | Stix2TextItalic
+ | Stix2TextBoldItalic
+ | Stix2Math
+ deriving (Eq,Ord,Show)
+
+-- | An enum encoding our typeface variations
+data MyStyle
+ = MyRegular
+ | MyBold
+ | MyItalic
+ | MyBoldItalic
+ | MyMath
+ deriving (Eq,Ord,Show)
+
+-- | Mapping standard typeface variations to ours
+myStyleMap :: BasicStyle -> MyStyle
+myStyleMap s = case s of
+ Regular -> MyRegular
+ Bold -> MyBold
+ Italic -> MyItalic
+ BoldItalic -> MyBoldItalic
+
+-- | Mapping typeface variatons to abstract fonts (not always necessary)
+myStyleDefaultFont :: MyStyle -> MyFontFile
+myStyleDefaultFont style = case style of
+ MyRegular -> Stix2TextRegular
+ MyBold -> Stix2TextBold
+ MyItalic -> Stix2TextItalic
+ MyBoldItalic -> Stix2TextBoldItalic
+ MyMath -> Stix2Math
+
+-- | Mapping abstract font files to concrete font files
+myFontFileMap :: MyFontFile -> FilePath
+myFontFileMap ff = case ff of
+ Stix2TextRegular -> "STIX2Text-Regular.otf"
+ Stix2TextBold -> "STIX2Text-Bold.otf"
+ Stix2TextItalic -> "STIX2Text-Italic.otf"
+ Stix2TextBoldItalic -> "STIX2Text-BoldItalic.otf"
+ Stix2Math -> "STIX2Math.otf"
+
+-- | Mapping (style,codepoint) pairs to (abstract) font files.
+-- For example mathematical symbols are not present in the regular fonts, so
+-- we always map them to the math font.
+--
+myCharMap :: MyStyle -> Char -> MyFontFile
+myCharMap MyMath _ = Stix2Math
+myCharMap style ch
+ | o <= 0x2100 = myStyleDefaultFont style
+ | o >= 0xfb00 = myStyleDefaultFont style
+ | otherwise = Stix2Math
+ where
+ o = ord ch
+
+-- | Our \"multifont\" configuration
+myUFC :: UserFontConfig MyFontFile MyStyle
+myUFC = UserFontConfig
+ { _ufcFontFiles = myFontFileMap
+ , _ufcCharMap = myCharMap
+ , _ufcStyleMap = myStyleMap
+ }
+
+theMultiFont :: IORef (MultiFont MyFontFile MyStyle)
+theMultiFont = Unsafe.unsafePerformIO $ newIORef $ error "multifont not loaded"
+
+--------------------------------------------------------------------------------
+
+display :: Window -> Double -> IO ()
+display window time = do
+
+ clearColor $=! (Color4 0.5 0.5 0.5 1)
+ clear [ColorBuffer,DepthBuffer]
+ setWindowCoordSystem
+
+ mf <- readIORef theMultiFont
+
+ -- create layout
+ lout <- createLayout mf (Height 40) document
+
+ -- top-left corner of the rendered text
+ let pos0 = Pos 16 16
+
+ -- 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)
+ blend $=! Disabled
+
+ -- render the text
+ renderLayout lout pos0
+
+ return ()
+
+--------------------------------------------------------------------------------
+
+initMultifont = do
+ mf <- newMultiFont myUFC
+ writeIORef theMultiFont mf
+ return ()
+
+main = do
+ initGL initMultifont (\() -> display)
+
+--------------------------------------------------------------------------------
+
+
diff --git a/example/example-boxes.hs b/example/example-boxes.hs
new file mode 100644
index 0000000..37bf155
--- /dev/null
+++ b/example/example-boxes.hs
@@ -0,0 +1,142 @@
+
+-- | This example program demonstrates how \"boxes\" work.
+--
+-- It is also useful for debugging.
+--
+-- Note: this program does not do any font rendering; for that, see the
+-- other example program (example-STIX.hs)!
+--
+
+module Main where
+
+--------------------------------------------------------------------------------
+
+import Data.Char hiding ( Space )
+
+import Control.Monad
+import Data.IORef
+import System.IO.Unsafe as Unsafe
+
+import qualified Data.Map as Map ; import Data.Map (Map)
+
+import Graphics.Rendering.OpenGL as GL
+import Graphics.UI.GLFW ( Window )
+
+import Graphics.Rendering.MiniTypeset
+
+import GL
+
+--------------------------------------------------------------------------------
+
+box1, box2 :: Box
+
+box1 = Box 50 75 5 10 15 20 10 5
+box2 = Box 63 105 10 25 5 5 12 8
+
+--------------------------------------------------------------------------------
+
+scaleCol :: Double -> 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)
+ r <- action
+ GL.translate (Vector3 (-x) (-y) 0) -- quick hack :)
+ return r
+
+--------------------------------------------------------------------------------
+
+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)
+
+renderBoxFilled:: Col -> Double -> Box -> IO ()
+renderBoxFilled col alpha (Box w h l r t b hgap vgap) = 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)
+ blend $= Disabled
+
+withAbsBox :: AbsBox -> (Box -> IO a) -> IO a
+withAbsBox (AbsBox pos box) action = withPos pos (action box)
+
+--------------------------------------------------------------------------------
+
+renderQuadOutline :: (Double,Double) -> (Double,Double) -> IO ()
+renderQuadOutline (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
+ renderPrimitive Quads $ do
+ vertex (Vertex2 x1 y1)
+ vertex (Vertex2 x2 y1)
+ vertex (Vertex2 x2 y2)
+ vertex (Vertex2 x1 y2)
+
+--------------------------------------------------------------------------------
+
+renderTriple :: (Box,(AbsBox,AbsBox)) -> IO ()
+renderTriple (box,(abox1,abox2)) = do
+ withAbsBox abox1 $ renderBoxFilled (Col 0 1 0) 0.75
+ withAbsBox abox2 $ renderBoxFilled (Col 0 0 1) 0.75
+
+ let abox = AbsBox (Pos 0 0) box
+ blend $= Enabled
+ setColAlpha (Col 1 0 0) 0.20
+ renderOuterBoxQuad abox
+ renderInnerBoxQuad abox
+ setColAlpha (Col 1 1 1) 0.25
+ renderBoxGap abox
+ blend $= Disabled
+
+ renderBoxOutline (Col 1 0 0) box
+
+display :: Window -> Double -> IO ()
+display window time = do
+
+ clearColor $=! (Color4 0 0 0 0)
+ clear [ColorBuffer,DepthBuffer]
+
+ -- setWindowCoordSystem
+ -- GL.scale 2 2 (0.5::Double)
+
+ matrixMode $= Projection
+ loadIdentity
+ ortho 0 800 500 0 (-1) (1::Double) -- to avoid issues with "retina" displays (window size /= framebuffer res)
+
+ withPos (Pos 15 25) $ renderTriple $ hcatBox2 AlignTop box1 box2
+ withPos (Pos 215 25) $ renderTriple $ hcatBox2 AlignBottom box1 box2
+ withPos (Pos 15 225) $ renderTriple $ vcatBox2 AlignLeft box1 box2
+ withPos (Pos 215 225) $ renderTriple $ vcatBox2 AlignRight box1 box2
+
+ withPos (Pos 415 25) $ renderTriple $ hcatBox2 AlignTop box2 box1
+ withPos (Pos 615 25) $ renderTriple $ hcatBox2 AlignBottom box2 box1
+ withPos (Pos 415 225) $ renderTriple $ vcatBox2 AlignLeft box2 box1
+ withPos (Pos 615 225) $ renderTriple $ vcatBox2 AlignRight box2 box1
+
+ return ()
+
+--------------------------------------------------------------------------------
+
+main = do
+ initGL (return ()) (\() -> display)
+
+--------------------------------------------------------------------------------
+
+
diff --git a/minitypeset-opengl.cabal b/minitypeset-opengl.cabal
new file mode 100644
index 0000000..1b6d0ef
--- /dev/null
+++ b/minitypeset-opengl.cabal
@@ -0,0 +1,54 @@
+Name: minitypeset-opengl
+Version: 0.1.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
+ is via @stb_truetype@. The rendered glyphs are stored in
+ OpenGL textures (built up lazily).
+ A simple typesetting\/layouting engine is included.
+License: BSD3
+License-file: LICENSE
+Author: Balazs Komuves
+Copyright: (c) 2018-2019 Balazs Komuves
+Maintainer: bkomuves (plus) hackage (at) gmail (dot) com
+Homepage: http://moire.be/haskell/
+Stability: Experimental
+Category: Math
+Tested-With: GHC == 8.0.2
+Cabal-Version: 1.24
+Build-Type: Simple
+
+extra-source-files: example/GL.hs,
+ example/example-STIX.hs,
+ example/example-boxes.hs,
+ example/UnicodeMath.hs
+
+source-repository head
+ type: darcs
+ location: http://moire.be/haskell/projects/minitypeset-opengl/
+
+--------------------------------------------------------------------------------
+
+Library
+
+ Build-Depends: base >= 4 && < 5, containers, filepath, OpenGL, stb-truetype >= 0.1.4
+
+ Exposed-Modules: Graphics.Rendering.MiniTypeset
+ Graphics.Rendering.MiniTypeset.Box
+ Graphics.Rendering.MiniTypeset.Common
+ Graphics.Rendering.MiniTypeset.Layout
+ Graphics.Rendering.MiniTypeset.MultiFont
+ Graphics.Rendering.MiniTypeset.FontTexture
+ Graphics.Rendering.MiniTypeset.Render
+
+ Default-Extensions: CPP, BangPatterns
+ Other-Extensions: ScopedTypeVariables
+
+ Default-Language: Haskell2010
+
+ Hs-Source-Dirs: src
+
+ ghc-options: -fwarn-tabs -fno-warn-unused-matches -fno-warn-name-shadowing -fno-warn-unused-imports
+
+--------------------------------------------------------------------------------
+
diff --git a/src/Graphics/Rendering/MiniTypeset.hs b/src/Graphics/Rendering/MiniTypeset.hs
new file mode 100644
index 0000000..8faa8c8
--- /dev/null
+++ b/src/Graphics/Rendering/MiniTypeset.hs
@@ -0,0 +1,35 @@
+
+-- | A text rendering and typesetting library for OpenGL.
+--
+-- It is enough to import this module to use the library.
+--
+-- 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
+ -- * Boxes
+ , module Graphics.Rendering.MiniTypeset.Box
+ -- * \"Multifonts\"
+ , UserFontConfig(..) , MultiFont , newMultiFont , MultiFontGlyph
+ -- * Layout
+ , Document(..)
+ , Layout(..)
+ , createLayout, createLayout'
+ , dryrunLayout, renderLayout, renderLayout'
+ -- * Rendering
+ , module Graphics.Rendering.MiniTypeset.Render
+ )
+ where
+
+--------------------------------------------------------------------------------
+
+import Graphics.Rendering.MiniTypeset.Box
+import Graphics.Rendering.MiniTypeset.Common hiding ( mapAccumM )
+import Graphics.Rendering.MiniTypeset.Layout
+import Graphics.Rendering.MiniTypeset.FontTexture
+import Graphics.Rendering.MiniTypeset.MultiFont
+import Graphics.Rendering.MiniTypeset.Render
+
+-------------------------------------------------------------------------------- \ No newline at end of file
diff --git a/src/Graphics/Rendering/MiniTypeset/Box.hs b/src/Graphics/Rendering/MiniTypeset/Box.hs
new file mode 100644
index 0000000..59d412d
--- /dev/null
+++ b/src/Graphics/Rendering/MiniTypeset/Box.hs
@@ -0,0 +1,153 @@
+
+-- | Boxes are rectangular shapes having a margin and an extra gap between
+-- boxes placed next 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.
+--
+-- Boxes has their origin at the top-left corner of their inner box.
+-- Absolute boxes ('AbsBox') have an extra offset.
+--
+-- We use screen-space coordinate system (Y increase downwards).
+--
+
+{-# LANGUAGE BangPatterns #-}
+module Graphics.Rendering.MiniTypeset.Box where
+
+--------------------------------------------------------------------------------
+
+import Graphics.Rendering.MiniTypeset.Common
+
+--------------------------------------------------------------------------------
+
+-- | 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
+ }
+ deriving (Show)
+
+emptyBox :: Box
+emptyBox = Box 0 0 0 0 0 0 0 0
+
+-- | An absolute box
+data AbsBox = AbsBox
+ { _aboxOffset :: !Pos
+ , _aboxRelBox :: !Box
+ }
+ deriving (Show)
+
+instance Translate AbsBox where
+ translate ofs (AbsBox pos relbox) = AbsBox (ofs+pos) relbox
+
+--------------------------------------------------------------------------------
+
+-- | 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
+
+ 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)
+
+ 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
+
+ where
+ Box w1 h1 l1 r1 t1 b1 hgap1 vgap1 = box1
+ Box w2 h2 l2 r2 t2 b2 hgap2 vgap2 = 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
+
+ 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)
+
+ 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
+
+ where
+ Box w1 h1 l1 r1 t1 b1 hgap1 vgap1 = box1
+ Box w2 h2 l2 r2 t2 b2 hgap2 vgap2 = 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
+
+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
+
+--------------------------------------------------------------------------------
+
+hcatBoxes :: VAlign -> [Box] -> (Box,[AbsBox])
+hcatBoxes !valign boxes = case boxes of
+ [] -> ( emptyBox, [] )
+ [b] -> ( b, [AbsBox (Pos 0 0) b] )
+ (b1:b2:bs) -> let (b12,(ab1,ab2) ) = hcatBox2 valign b1 b2
+ (box,(ab12:abs)) = hcatBoxes valign (b12:bs)
+ p12 = _aboxOffset ab12
+ in (box, translate p12 ab1 : translate p12 ab2 : abs)
+
+vcatBoxes :: HAlign -> [Box] -> (Box,[AbsBox])
+vcatBoxes !halign boxes = case boxes of
+ [] -> ( emptyBox, [] )
+ [b] -> ( b, [AbsBox (Pos 0 0) b] )
+ (b1:b2:bs) -> let (b12,(ab1,ab2) ) = vcatBox2 halign b1 b2
+ (box,(ab12:abs)) = vcatBoxes halign (b12:bs)
+ p12 = _aboxOffset ab12
+ in (box, translate p12 ab1 : translate p12 ab2 : abs)
+
+--------------------------------------------------------------------------------
diff --git a/src/Graphics/Rendering/MiniTypeset/Common.hs b/src/Graphics/Rendering/MiniTypeset/Common.hs
new file mode 100644
index 0000000..f54254f
--- /dev/null
+++ b/src/Graphics/Rendering/MiniTypeset/Common.hs
@@ -0,0 +1,144 @@
+
+-- | Common data types and functions
+
+module Graphics.Rendering.MiniTypeset.Common where
+
+--------------------------------------------------------------------------------
+-- * Font-related things
+
+-- | Basic variations in a typeface (font family)
+data BasicStyle
+ = Regular
+ | Bold
+ | Italic
+ | BoldItalic
+ deriving (Eq,Ord,Show)
+
+-- | Font height in pixels
+newtype Height
+ = Height Int
+ deriving (Eq,Ord,Show)
+
+--------------------------------------------------------------------------------
+-- * Colors
+
+data Col
+ = Col !Double !Double !Double
+ deriving (Eq,Ord,Show)
+
+colToTriple :: Col -> (Double,Double,Double)
+colToTriple (Col r g b) = (r,g,b)
+
+tripleToCol :: (Double,Double,Double) -> 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
+red = Col 1 0 0
+green = Col 0 1 0
+blue = Col 0 0 1
+yellow = Col 1 1 0
+cyan = Col 0 1 1
+magenta = Col 1 0 1
+
+--------------------------------------------------------------------------------
+-- * Alignment
+
+{-
+data LeftRight
+ = OnLeft
+ | OnRight
+ deriving (Eq,Ord,Show)
+-}
+
+data HAlign
+ = AlignLeft
+ | AlignRight
+ deriving (Eq,Ord,Show)
+
+data VAlign
+ = AlignBottom
+ | AlignTop
+ deriving (Eq,Ord,Show)
+
+--------------------------------------------------------------------------------
+-- * Positions
+
+-- | A position. We use screen-space coordinates here
+-- (so the top-left corner of the screen is the origin, and the vertical coordinate increases downwards).
+--
+-- It is monomorphic so that GHC can optimize it better.
+data Pos
+ = Pos !Double !Double
+ deriving (Eq,Ord,Show)
+
+posToPair :: Pos -> (Double,Double)
+posToPair (Pos x y) = (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)
+ negate (Pos x y) = Pos (negate x) (negate y)
+ (*) = error "Pos/Num/*: does not make sense"
+ fromInteger n = if n == 0
+ then Pos 0 0
+ else error "Pos/Num/fromInteger: does not make sense"
+ abs (Pos x y) = Pos (abs x) (abs y)
+ signum = error "Pos/Num/signum: does not make sense"
+
+{-
+data Pos a
+ = Pos !a !a
+ deriving (Eq,Ord,Show)
+
+posToPair :: Pos a -> (a,a)
+posToPair (Pos x y) = (x,y)
+
+instance Num a => Num (Pos a) where
+-}
+
+class Translate a where
+ translate :: Pos -> a -> a
+
+instance Translate Pos where
+ translate = (+)
+
+--------------------------------------------------------------------------------
+-- * Brackets
+
+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' )
+
+--------------------------------------------------------------------------------
+-- * misc utility
+
+mapAccumM :: Monad m => (a -> b -> m (a, c)) -> a -> [b] -> m (a, [c])
+mapAccumM f x0 ys = go x0 ys where
+ go !x (y:ys) = do { (x',z) <- f x y ; (x'',zs) <- go x' ys ; return (x'',z:zs) }
+ go !x [] = return (x,[])
+
+--------------------------------------------------------------------------------
diff --git a/src/Graphics/Rendering/MiniTypeset/FontTexture.hs b/src/Graphics/Rendering/MiniTypeset/FontTexture.hs
new file mode 100644
index 0000000..7483a75
--- /dev/null
+++ b/src/Graphics/Rendering/MiniTypeset/FontTexture.hs
@@ -0,0 +1,287 @@
+
+
+-- | Store font glyphs in OpenGL textures
+--
+-- TODO: add (optional) subpixel rendering support
+-- (pre-render say 4 versions of the same glyphs with fractional horizontal offsets)
+--
+
+module Graphics.Rendering.MiniTypeset.FontTexture where
+
+--------------------------------------------------------------------------------
+
+import Data.Word
+import Data.Char
+
+import GHC.Float
+
+import Foreign.Ptr
+import Foreign.Storable
+import Foreign.C
+import Foreign.Marshal.Array
+
+import Control.Monad
+import Control.Concurrent
+import Data.IORef
+
+import System.IO.Unsafe as Unsafe
+
+import Graphics.Rendering.OpenGL as GL
+
+import Graphics.Rendering.TrueType.STB
+
+--------------------------------------------------------------------------------
+
+-- newtype FontIdx = FontIdx { unFontIdx :: Int }
+
+-- | The location of a glyph in a font texture collection
+data BufLoc = BufLoc
+ { _locGlyph :: !Glyph
+ , _locBufIdx :: !Int -- ^ which buffer
+ , _locBufXY :: !(Int,Int) -- ^ position within the texture (buffer)
+ , _locBufSiz :: !(Int,Int) -- ^ size of the bounding box
+ , _locBufOfs :: !(Int,Int) -- ^ offset relative to the bounding box
+ , _locHM :: !(HorizontalMetrics Float) -- ^ for convenience, we cache the glyph metrics
+ }
+ deriving Show
+
+-- | A single texture buffer
+data TexBuf = TexBuf
+ { _bufTexObj :: !TextureObject
+ , _bufSize :: !(Int,Int)
+ }
+ deriving Show
+
+allocateTexBuf :: FontTexture -> IO TexBuf
+allocateTexBuf ftex = do
+
+ let (w,h) = _ftexBufSize ftex
+ texobj <- genObjectName
+ let texbuf = TexBuf
+ { _bufTexObj = texobj
+ , _bufSize = (w,h)
+ }
+ textureBinding Texture2D $=! Just texobj
+
+ textureLevelRange Texture2D $=! (0,0)
+ textureFilter Texture2D $=! ((Nearest,Nothing),Nearest)
+ textureWrapMode Texture2D S $=! (Repeated,ClampToBorder)
+ textureWrapMode Texture2D T $=! (Repeated,ClampToBorder)
+ textureWrapMode Texture2D R $=! (Repeated,ClampToBorder)
+ textureBorderColor Texture2D $=! (Color4 0 0 0 0)
+ generateMipmap Texture2D $= Disabled -- ?????
+
+{-
+ -- uninitialized texture
+ let pd = PixelData Alpha UnsignedByte nullPtr :: PixelData Word8
+ fi = fromIntegral :: Int -> GLint
+ texImage2D Texture2D NoProxy 0 Alpha8 (TextureSize2D (fi w) (fi h)) 0 pd
+-}
+
+ -- texture initialized with zeros
+ let zeros = replicate (div (w*h+7) 8) (0::Word64)
+ withArray zeros $ \ptr -> do
+ let pd = PixelData Alpha UnsignedByte (castPtr ptr) :: PixelData Word8
+ fi = fromIntegral :: Int -> GLint
+ texImage2D Texture2D NoProxy 0 Alpha8 (TextureSize2D (fi w) (fi h)) 0 pd
+
+{-
+ -- texture initialized with pixel checkerboard (useful for debugging)
+ let minta1 = concat $ replicate (div w 2) [ 0x40, 0xc0 :: Word8 ]
+ minta2 = concat $ replicate (div w 2) [ 0xc0, 0x40 :: Word8 ]
+ minta = concat $ concat $ replicate (div h 2) [ minta1 , minta2 ]
+ withArray minta $ \ptr -> do
+ let pd = PixelData Alpha UnsignedByte ptr :: PixelData Word8
+ fi = fromIntegral :: Int -> GLint
+ texImage2D Texture2D NoProxy 0 Alpha8 (TextureSize2D (fi w) (fi h)) 0 pd
+-}
+
+ --print (w,h,texobj)
+ atomicModifyIORef' (_ftexBufs ftex) $ \oldList -> (oldList ++ [texbuf],())
+ return texbuf
+
+data TexCursor = TexCursor
+ { _curBufIdx :: !Int -- ^ which buffer we are filling currently
+ , _curX :: !Int -- ^ next X position
+ , _curY :: !Int -- ^ current Y position
+ , _cutMaxHt :: !Int -- ^ maximal bitmap height in this row
+ }
+ deriving Show
+
+zeroCursor :: TexCursor
+zeroCursor = TexCursor
+ { _curBufIdx = 0
+ , _curX = 0
+ , _curY = 0
+ , _cutMaxHt = 0
+ }
+
+-- | A font texture collection: possibly several textures containing bitmaps
+-- a given font with a given height.
+data FontTexture = FontTexture
+ { _ftexFont :: !Font
+ , _ftexName :: !String
+ , _ftexHeight :: !Float
+ , _ftexScaling :: !Scaling
+ , _ftexVM :: !(VerticalMetrics Float)
+ , _ftexChars :: !(UnicodeCache (Maybe BufLoc))
+ , _ftexBufSize :: !(Int,Int)
+ , _ftexCursor :: !(IORef TexCursor)
+ , _ftexBufs :: !(IORef [TexBuf])
+ }
+
+instance Show FontTexture where
+ show ftex = "FontTexture:<" ++ _ftexName ftex ++ ">"
+
+scaleU :: Float -> Unscaled -> Float
+scaleU s x = s * fromIntegral x
+
+defaultTextureSize :: (Int,Int)
+defaultTextureSize = (512,512) -- (128,128) -- (512,512) -- (1024,1024)
+
+newFontTexture :: Font -> Float -> String -> IO FontTexture
+newFontTexture font height name = newFontTexture' font height name defaultTextureSize
+
+-- | Creates a new (empty) font texture
+newFontTexture' :: Font -> Float -> String -> (Int,Int) -> IO FontTexture
+newFontTexture' font height name size = do
+ uc <- newUnicodeCache
+ vmu <- getFontVerticalMetrics font
+ let s = scaleForPixelHeight vmu height
+ vms = fmap (scaleU s) vmu
+
+-- print vmu
+-- print vms
+
+ cur <- newIORef zeroCursor
+ texbufref <- newIORef []
+ let ftex = FontTexture
+ { _ftexFont = font
+ , _ftexName = name
+ , _ftexHeight = height
+ , _ftexScaling = (s,s)
+ , _ftexVM = vms
+ , _ftexChars = uc
+ , _ftexBufSize = size
+ , _ftexCursor = cur
+ , _ftexBufs = texbufref
+ }
+ 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.
+lookupFontTexture :: FontTexture -> Char -> IO BufLoc
+lookupFontTexture ftex ch = do
+ mb <- mbLookupFontTexture ftex ch
+ case mb of
+ Nothing -> lookupFontTexture ftex notDefinedGlyphChar
+ Just bufloc -> return bufloc
+
+-- | Finds a character in the font texture (rendering it first if necessary)
+mbLookupFontTexture :: FontTexture -> Char -> IO (Maybe BufLoc)
+mbLookupFontTexture ftex ch = lookupUnicodeCache ch allocate (_ftexChars ftex) where
+
+ font = _ftexFont ftex
+ (texw,texh) = _ftexBufSize ftex
+ scaling@(hs,vs) = _ftexScaling ftex
+
+ allocate :: Char -> IO (Maybe BufLoc)
+ allocate ch = do
+ mbglyph <- findGlyph font ch -- this is cached
+ case mbglyph of
+ Nothing -> return Nothing
+ Just glyph -> do
+ mb <- getGlyphBoundingBox font glyph
+ case mb of
+ Nothing -> return Nothing
+ Just {} -> do
+ (bm,bmofs) <- newGlyphBitmap font glyph scaling
+ let (w,h) = bitmapSize bm
+ oldCur@(TexCursor bufidx x y maxh) <- readIORef (_ftexCursor ftex)
+
+ -- figure out render location and next cursor
+ let x' = x + w + 2
+ y' = y + maxh + 2
+ w' = w + 2 -- we leave a 1 pixel (texel) border just to be safe
+ h' = h + 2
+ (rloc,newCur) <- if x' < texw && y' < texh
+ then return ( (bufidx,x,y) , TexCursor bufidx x' y (max h maxh) )
+ else if y' + h' < texh
+ then return ( (bufidx,0,y') , TexCursor bufidx w' y' h )
+ else do
+ void $ allocateTexBuf ftex
+ let bufidx' = bufidx + 1
+ return ( (bufidx',0,0) , TexCursor bufidx' w' 0 h )
+ writeIORef (_ftexCursor ftex) newCur
+ -- print (oldCur,newCur)
+
+ oldAlign <- get (rowAlignment Unpack)
+ rowAlignment Unpack $=! (1 :: GLint)
+
+ -- render character at render location rloc
+ let (rbuf,rx,ry) = rloc
+ bufs <- readIORef (_ftexBufs ftex)
+ let texBuf@(TexBuf texobj texsiz) = bufs!!rbuf
+ withBitmap bm $ \_ _ ptr -> do
+ let pd = PixelData Alpha UnsignedByte ptr
+ fi = fromIntegral :: Int -> GLint
+ textureBinding Texture2D $=! Just texobj
+ texSubImage2D Texture2D 0
+ (TexturePosition2D (fi rx + 1) (fi ry + 1))
+ (TextureSize2D (fi w ) (fi h ))
+ pd
+
+ rowAlignment Unpack $=! oldAlign
+
+ -- return location
+ hmu <- getGlyphHorizontalMetrics font glyph
+ let hms = fmap (scaleU hs) hmu
+ let bufloc = BufLoc
+ { _locGlyph = glyph
+ , _locBufIdx = rbuf
+ , _locBufXY = (rx,ry)
+ , _locBufSiz = (w,h)
+ , _locBufOfs = bmofs
+ , _locHM = hms
+ }
+ -- putStrLn $ "'" ++ [ch] ++ "' -> "
+ -- print bufloc
+ return $ Just bufloc
+
+--------------------------------------------------------------------------------
+
+-- | Renders the given font texture as a quad (useful for debugging)
+testRenderFullTextureQuad :: FontTexture -> Int -> IO ()
+testRenderFullTextureQuad ftex idx = do
+
+ bufs <- readIORef (_ftexBufs ftex)
+ let buf = bufs!!idx
+
+ matrixMode $= Projection
+ loadIdentity
+ ortho 0 1 1 0 (-1) 1
+
+ texture Texture2D $= Enabled
+ textureBinding Texture2D $= Just (_bufTexObj buf)
+
+ textureFunction $= Modulate
+
+ blend $= Enabled
+ blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
+ color (Color4 1 1 1 (1::Double))
+
+ let a = 0 :: Double
+ b = 1 :: Double
+ c = 0.1 :: Double
+ d = 0.9 :: Double
+ renderPrimitive Quads $ do
+ texCoord (TexCoord2 a a) ; vertex (Vertex2 c c)
+ texCoord (TexCoord2 a b) ; vertex (Vertex2 c d)
+ texCoord (TexCoord2 b b) ; vertex (Vertex2 d d)
+ texCoord (TexCoord2 b a) ; vertex (Vertex2 d c)
+
+ texture Texture2D $= Disabled
+
+--------------------------------------------------------------------------------
diff --git a/src/Graphics/Rendering/MiniTypeset/Layout.hs b/src/Graphics/Rendering/MiniTypeset/Layout.hs
new file mode 100644
index 0000000..f10f304
--- /dev/null
+++ b/src/Graphics/Rendering/MiniTypeset/Layout.hs
@@ -0,0 +1,255 @@
+
+-- | A simple layout engine to render text (and later also mathematics).
+
+{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}
+module Graphics.Rendering.MiniTypeset.Layout where
+
+--------------------------------------------------------------------------------
+
+import Control.Monad
+import Data.IORef
+
+import qualified Data.Map as Map ; import Data.Map (Map)
+
+import GHC.Float
+
+import Graphics.Rendering.TrueType.STB
+
+import Graphics.Rendering.OpenGL as GL hiding ( Height , translate )
+
+import Graphics.Rendering.MiniTypeset.Common
+import Graphics.Rendering.MiniTypeset.Box
+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
+
+--------------------------------------------------------------------------------
+
+-- | 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)
+
+-- | SubScript !Document !Document !LeftRight
+-- | SuperScript !Document !Document !LeftRight
+-- | Above !Document !Document !Bool -- choose or fraction (the bool is separator line)
+-- | InBrackets !Bracket !Document
+
+--------------------------------------------------------------------------------
+
+-- | 0 is the default size, 1 is smaller, 2 is even smaller, etc (each subscript
+newtype SizeIndex
+ = SizeIndex Int
+ deriving (Eq,Ord,Show)
+
+--------------------------------------------------------------------------------
+
+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
+
+--------------------------------------------------------------------------------
+
+-- | 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)
+ | LoutEmpty
+ deriving (Show)
+
+instance Translate (Layout ident style) where
+ translate = translateLayout
+
+translateLayout :: Pos -> Layout ident style -> Layout ident style
+translateLayout ofs layout = case layout of
+ LoutGlyph ofs0 sty col ch mfg -> LoutGlyph (ofs0+ofs) sty col ch mfg -- minor optimization
+ LoutOfs ofs0 lout -> LoutOfs (ofs0+ofs) lout -- minor optimization
+ _ -> LoutOfs ofs layout
+
+--------------------------------------------------------------------------------
+
+-- | Renders the layout to the OpenGL framebuffer.
+--
+-- Note: you should set up the OpenGL coordinate transformation matrices
+-- so that the coordinate system is screen-space, measured in pixels. For
+-- example something like
+--
+-- > matrixMode $= Projection
+-- > loadIdentity
+-- > ortho 0 xres yres 0 (-1) 1
+-- > matrixMode $= Modelview 0
+-- > loadIdentity
+--
+-- should do.
+--
+renderLayout :: Ord ident => Layout ident style -> Pos -> IO ()
+renderLayout lout pos = void (renderLayout' False lout pos)
+
+-- | Does not actually render, but computes the bounding boxes of the identified
+-- parts of the layout.
+dryrunLayout :: Ord ident => Layout ident style -> Pos -> IO (Map ident AbsBox)
+dryrunLayout lout pos = renderLayout' True lout pos
+
+renderLayout'
+ :: forall ident style. Ord ident
+ => Bool -- ^ @True@ = dryrun (do not render); @False@ = do the rendering
+ -> Layout ident style
+ -> Pos
+ -> IO (Map ident AbsBox )
+renderLayout' dryrun layout pos0 =
+ do
+ table <- newIORef Map.empty
+ _ <- go table pos0 layout
+ readIORef table
+
+ where
+ go :: IORef (Map ident AbsBox) -> Pos -> Layout ident style -> IO AbsBox
+ go !table !pos layout = case layout of
+
+ LoutGlyph ofs _ col _ mfg -> do
+ unless dryrun $ renderMFG (pos+ofs) col mfg
+ return (AbsBox pos $ mfgRelBox mfg)
+
+ LoutGroup relbox louts -> do
+ mapM_ (go table pos) louts
+ return (AbsBox pos relbox)
+
+ LoutOfs ofs lout -> go table (pos + ofs) lout
+
+ LoutIdent ident lout -> do
+ box <- go table pos lout
+ modifyIORef table (Map.insert ident box)
+ return box
+
+ LoutEmpty -> return (AbsBox pos emptyBox)
+
+--------------------------------------------------------------------------------
+
+-- | Creates a layout from a document. Then you can render the resulting layout
+-- with 'renderLayout'
+createLayout
+ :: forall fontfile style ident. (Ord fontfile, Ord ident)
+ => MultiFont fontfile style
+ -> Height
+ -> Document ident
+ -> IO (Layout ident style)
+createLayout multifont height doc = do
+ (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)
+ return $ translate ofs lout0
+
+--------------------------------------------------------------------------------
+
+data Cfg = Cfg
+ { _currentSize :: !SizeIndex
+ , _currentStyle :: !BasicStyle
+ , _currentColor :: !Col
+ }
+
+defaultCfg :: Cfg
+defaultCfg = Cfg
+ { _currentSize = SizeIndex 0
+ , _currentStyle = Regular
+ , _currentColor = Col 0 0 0
+ }
+
+-- Note: the layout origin is not the top-left corner, but the baseline of the first line.
+-- The function 'createLayout' does the necessary shift for you.
+createLayout'
+ :: forall fontfile style ident. (Ord fontfile, Ord ident)
+ => MultiFont fontfile style
+ -> Height
+ -> Document ident
+ -> IO (Box, Layout ident style)
+createLayout' multifont (Height 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)
+
+ 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))
+
+ vcat :: Cfg -> HAlign -> [Document ident] -> IO (Box, Layout ident style)
+ vcat !cfg !halign 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
+ 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
+
+ WithColor col doc -> go cfg' doc where cfg' = cfg { _currentColor = col }
+ WithStyle sty doc -> go cfg' doc where cfg' = cfg { _currentStyle = sty }
+
+ Identified uid doc -> do
+ (box, lout) <- go cfg doc
+ return (box, LoutIdent uid lout)
+
+ Symbol char -> do
+ let Cfg size style0 col = cfg
+ style = styleMap style0
+ mfg@(MFG ftex bufloc) <- lkpMultiFont multifont (sizeHeight size) style char
+ let relbox = mfgRelBox mfg
+ lout = LoutGlyph (Pos 0 0) style col char mfg
+ return (relbox, lout)
+
+ Space -> go cfg (Symbol ' ')
+
+ String chars -> go cfg (HorzCat AlignBottom $ map Symbol chars)
+
+ HorzCat valign docs -> hcat cfg valign docs
+ VertCat halign docs -> vcat cfg halign docs
+
+--------------------------------------------------------------------------------
diff --git a/src/Graphics/Rendering/MiniTypeset/MultiFont.hs b/src/Graphics/Rendering/MiniTypeset/MultiFont.hs
new file mode 100644
index 0000000..09b60ee
--- /dev/null
+++ b/src/Graphics/Rendering/MiniTypeset/MultiFont.hs
@@ -0,0 +1,141 @@
+
+-- | Typically, we use multiple fonts to compose a document.
+-- Some examples for this are:
+--
+-- * bold, italic, etc typefaces as separate font files
+--
+-- * greek, cyrillic and other non-latin alphabets
+--
+-- * a monospace font
+--
+-- * mathematical symbols
+--
+-- We can also use different font sizes, for example subscript, superscript, etc.
+--
+-- This module provides a layer on the top "FontTexture" to support this.
+--
+-- For a good trade-off between simplicity and generality, we opt to encode
+-- a glyph as a Unicode code point together with a user-defined style attribute,
+-- and let the user provide a mapping from this to different physical font files.
+--
+
+{-# LANGUAGE BangPatterns #-}
+module Graphics.Rendering.MiniTypeset.MultiFont where
+
+--------------------------------------------------------------------------------
+
+import Control.Monad
+import Data.IORef
+
+import qualified Data.Map as Map ; import Data.Map (Map )
+import qualified Data.IntMap as IntMap ; import Data.IntMap (IntMap)
+
+import System.FilePath ( takeFileName )
+
+-- import Graphics.Rendering.OpenGL as GL
+
+import Graphics.Rendering.TrueType.STB
+
+import Graphics.Rendering.MiniTypeset.Common
+import Graphics.Rendering.MiniTypeset.FontTexture
+
+--------------------------------------------------------------------------------
+
+-- | given a font height (in pixels), we return how big texture(s) should we allocate for this
+stdFontTextureSize :: Int -> (Int,Int)
+stdFontTextureSize height
+ | height <= 12 = ( 128,128)
+ | height <= 16 = ( 256,256)
+ | height <= 48 = ( 512,512)
+ | height <= 128 = (1024,1024)
+ | otherwise = (2048,2048)
+
+--------------------------------------------------------------------------------
+
+-- | The user-defined types @fontfile@ and @style@ should encode the available
+-- 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
+ }
+
+data MultiFont fontfile style = MultiFont
+ { _mfUserConfig :: !(UserFontConfig fontfile style) -- ^ the user-defined configuration
+ , _mfFontTexs :: !(IORef (Map fontfile (IntMap FontTexture))) -- ^ mapping from font files and heights to textures
+ }
+
+mfCharMap :: MultiFont fontfile style -> style -> Char -> fontfile
+mfCharMap = _ufcCharMap . _mfUserConfig
+
+newMultiFont :: Ord fontfile => UserFontConfig fontfile style -> IO (MultiFont fontfile style)
+newMultiFont ufc = do
+ tbl <- newIORef Map.empty
+ return $ MultiFont ufc tbl
+
+--------------------------------------------------------------------------------
+
+loadFontFile :: FilePath -> IO Font
+loadFontFile fpath = do
+ otfPackage <- loadTTF fpath
+ ofsList <- enumerateFonts otfPackage
+ font <- case ofsList of
+ [] -> error "MultiFont/loadFontFile: fatal error: empty font file"
+ [ofs] -> initFont otfPackage ofs
+ _ -> error "MultiFont/loadFontFile: multiple fonts in a font file are not (yet?) supported"
+ return font
+
+mapInsert :: Ord k => a -> (a -> a) -> k -> Map k a -> Map k a
+mapInsert y f k table = Map.alter h k table where
+ h Nothing = Just y
+ h (Just x) = Just (f x)
+
+mapIntLookup :: Ord k => k -> Int -> Map k (IntMap a) -> Maybe a
+mapIntLookup k j table = case Map.lookup k table of
+ Nothing -> Nothing
+ Just sub -> IntMap.lookup j sub
+
+mfAddNewFontTex :: Ord fontfile => MultiFont fontfile style -> (fontfile,Int) -> IO ()
+mfAddNewFontTex mf (ffile,height) = do
+ old_table <- readIORef (_mfFontTexs mf)
+ let fpath = (_ufcFontFiles $ _mfUserConfig mf) ffile
+ font <- loadFontFile fpath
+ ftex <- newFontTexture' font (fromIntegral height) (takeFileName fpath) (stdFontTextureSize height)
+ let new_table = mapInsert (IntMap.singleton height ftex) (IntMap.insert height ftex) ffile old_table
+ writeIORef (_mfFontTexs mf) new_table
+
+--------------------------------------------------------------------------------
+-- * Multifont glyphs
+
+data MultiFontGlyph
+ = MFG !FontTexture !BufLoc
+ deriving Show
+
+{-
+mbLkpMultiFont :: Ord fontfile => MultiFont fontfile style -> Int -> style -> Char -> IO (Maybe MultiFontGlyph)
+mbLkpMultiFont multifont height style char = do
+ table <- readIORef (_mfFontTexs multifont)
+ let fontfile = mfCharMap multifont style char
+ case mapIntLookup fontfile height table of
+ Nothing -> do
+ mfAddNewFontTex multifont (fontfile,height)
+ mbLkpMultiFont multifont height style char
+ Just ftex -> do
+ mbloc <- mbLookupFontTexture ftex char
+ return $ liftM (\loc -> (MFG ftex loc)) mbloc
+-}
+
+lkpMultiFont :: Ord fontfile => MultiFont fontfile style -> Int -> style -> Char -> IO MultiFontGlyph
+lkpMultiFont multifont height style char = do
+ table <- readIORef (_mfFontTexs multifont)
+ let fontfile = mfCharMap multifont style char
+ case mapIntLookup fontfile height table of
+ Nothing -> do
+ mfAddNewFontTex multifont (fontfile,height)
+ lkpMultiFont multifont height style char
+ Just ftex -> do
+ loc <- lookupFontTexture ftex char
+ return $ MFG ftex loc
+
+--------------------------------------------------------------------------------
diff --git a/src/Graphics/Rendering/MiniTypeset/Render.hs b/src/Graphics/Rendering/MiniTypeset/Render.hs
new file mode 100644
index 0000000..5e956d1
--- /dev/null
+++ b/src/Graphics/Rendering/MiniTypeset/Render.hs
@@ -0,0 +1,157 @@
+
+-- | Low-level rendering.
+--
+-- You shouldn't normally need to use this directly,
+-- though boxes can be useful for highlighting.
+
+{-# LANGUAGE BangPatterns #-}
+module Graphics.Rendering.MiniTypeset.Render where
+
+--------------------------------------------------------------------------------
+
+import Data.Word
+import Data.Char
+
+import GHC.Float
+
+import Control.Monad
+import Data.IORef
+
+import Graphics.Rendering.OpenGL as GL
+
+import Graphics.Rendering.TrueType.STB
+
+import Graphics.Rendering.MiniTypeset.Common
+import Graphics.Rendering.MiniTypeset.Box
+import Graphics.Rendering.MiniTypeset.FontTexture
+import Graphics.Rendering.MiniTypeset.MultiFont
+
+--------------------------------------------------------------------------------
+-- * 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
+ renderPrimitive Quads $ do
+ vertex (Vertex2 x1 y1)
+ vertex (Vertex2 x2 y1)
+ vertex (Vertex2 x2 y2)
+ vertex (Vertex2 x1 y2)
+
+-- | 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)
+
+-- | 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
+
+ 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)
+
+ 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 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)
+ renderChar' pos ftex bufloc
+
+--------------------------------------------------------------------------------
+
+-- | Renders a single character. Note: the position will be the position
+-- of the left end of the baseline of the character, not the top-left corner!
+--
+-- Returns the horizontal advancement.
+--
+renderCharAt :: Pos -> FontTexture -> Char -> IO Double
+renderCharAt pos ftex ch = do
+ bufloc <- lookupFontTexture ftex ch
+ renderChar' pos ftex bufloc
+ let adv = advanceWidth (_locHM bufloc)
+ return $ float2Double adv
+
+renderCharAt_ :: Pos -> FontTexture -> Char -> IO ()
+renderCharAt_ pos ftex ch = void $ renderCharAt pos ftex ch
+
+--------------------------------------------------------------------------------
+
+renderChar' :: Pos -> FontTexture -> BufLoc -> IO ()
+renderChar' pos@(Pos x0 y0) ftex bufloc = do
+
+ bufs <- readIORef (_ftexBufs ftex)
+ let texBuf@(TexBuf texobj texsiz) = bufs!!(_locBufIdx bufloc)
+
+ textureBinding Texture2D $=! Just texobj
+
+ let (wi,hi) = _locBufSiz bufloc
+ (s,t) = _locBufXY bufloc
+ (p,q) = _locBufOfs bufloc
+ -- lsb = leftSideBearing (_locHM bufloc) -- already included in the offset?
+ (x,y) = (x0 + fromIntegral p , y0 + fromIntegral q) -- tmp?
+ wf = fromIntegral wi :: Double
+ hf = fromIntegral hi :: Double
+
+ texture Texture2D $=! Enabled
+ blend $=! Enabled
+ blendFunc $=! (SrcAlpha,OneMinusSrcAlpha)
+
+ let (texw,texh) = _ftexBufSize ftex
+ ftexw = fromIntegral texw :: Double
+ ftexh = fromIntegral texh :: Double
+ fs, ft :: Int -> Double
+ fs !j = (fromIntegral j + 1.0) / ftexw
+ ft !i = (fromIntegral i + 1.0) / ftexh
+
+ let g :: Double -> Double
+ g x = fromIntegral (round x :: Int)
+
+ let tc s t = texCoord (TexCoord2 (fs s) (ft t))
+ vt x y = vertex (Vertex2 (g x) (g y))
+
+ renderPrimitive Quads $ do
+ tc s t ; vt x y
+ tc (s+wi) t ; vt (x+wf) y
+ tc (s+wi) (t+hi) ; vt (x+wf) (y+hf)
+ tc s (t+hi) ; vt x (y+hf)
+
+ blend $=! Disabled
+ texture Texture2D $=! Disabled
+
+ return ()
+
+--------------------------------------------------------------------------------