packages feed

minitypeset-opengl (empty) → 0.1.0.0

raw patch · 14 files changed

+1875/−0 lines, 14 filesdep +OpenGLdep +basedep +containerssetup-changed

Dependencies added: OpenGL, base, containers, filepath, stb-truetype

Files

+ LICENSE view
@@ -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.+
+ Setup.lhs view
@@ -0,0 +1,3 @@+#! /usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ example/GL.hs view
@@ -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
+
+--------------------------------------------------------------------------------
+
+ example/UnicodeMath.hs view
@@ -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' 
+
+--------------------------------------------------------------------------------
+ example/example-STIX.hs view
@@ -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) 
+
+--------------------------------------------------------------------------------
+
+
+ example/example-boxes.hs view
@@ -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) 
+
+--------------------------------------------------------------------------------
+
+
+ minitypeset-opengl.cabal view
@@ -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++--------------------------------------------------------------------------------+
+ src/Graphics/Rendering/MiniTypeset.hs view
@@ -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++--------------------------------------------------------------------------------
+ src/Graphics/Rendering/MiniTypeset/Box.hs view
@@ -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)++--------------------------------------------------------------------------------
+ src/Graphics/Rendering/MiniTypeset/Common.hs view
@@ -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,[])++--------------------------------------------------------------------------------
+ src/Graphics/Rendering/MiniTypeset/FontTexture.hs view
@@ -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
+
+--------------------------------------------------------------------------------
+ src/Graphics/Rendering/MiniTypeset/Layout.hs view
@@ -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
+
+--------------------------------------------------------------------------------
+ src/Graphics/Rendering/MiniTypeset/MultiFont.hs view
@@ -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
+
+--------------------------------------------------------------------------------
+ src/Graphics/Rendering/MiniTypeset/Render.hs view
@@ -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 ()
+
+--------------------------------------------------------------------------------