Visualize FTGL indicators

testftgl.hs

import Control.Monad
import Data.IORef
import System.Environment (getArgs)
import System.Mem.Weak (addFinalizer)
import qualified Graphics.Rendering.FTGL as FTGL
import qualified Graphics.Rendering.OpenGL.GL as GL
import qualified Graphics.UI.GLFW as GLFW

resX, resY :: Int
resX = 640
resY = 480

initScreen :: IO GLFW.Window
initScreen = do
  True <- GLFW.init
  -- Do we want to give these window hints?
-- [GLFW.DisplayRGBBits 8 8 8,
--  GLFW.DisplayDepthBits 8]
  Just win <-
    GLFW.createWindow
    (fromIntegral resX)
    (fromIntegral resY)
    "Graphics-drawingcombinators demo"
    Nothing Nothing
  GLFW.makeContextCurrent $ Just win
  return win

color :: GL.GLfloat -> GL.GLfloat -> GL.GLfloat -> GL.GLfloat -> GL.Color4 GL.GLfloat
color = GL.Color4

withoutTextures :: IO a -> IO a
withoutTextures action =
    GL.texture GL.Texture2D GL.$= GL.Disabled >> action

r2f :: (Real a, Fractional b) => a -> b
r2f = realToFrac

vector3 :: GL.GLdouble -> GL.GLdouble -> GL.GLdouble -> GL.Vector3 GL.GLdouble
vector3 = GL.Vector3

setAttrs :: IO a -> IO a
setAttrs code =
    GL.preservingAttrib [GL.AllServerAttributes] $ do
        GL.blend GL.$= GL.Enabled
        GL.blendFunc GL.$= (GL.SrcAlpha, GL.OneMinusSrcAlpha)
        -- For now we assume the user wants antialiasing; the general solution is not clear - maybe let the
        -- user do the opengl setup stuff himself? otherwise need to wrap all of the possible things GL lets
        -- you set.
        GL.polygonSmooth GL.$= GL.Enabled
        GL.lineSmooth GL.$= GL.Enabled
        GL.lineWidth GL.$= 1.5
        GL.hint GL.LineSmooth GL.$= GL.DontCare
        code

main :: IO ()
main = do
    [ttfFile] <- getArgs
    font <- FTGL.createTextureFont ttfFile
    let ftSize :: Num a => a
        ftSize = 288
    FTGL.setFontFaceSize font ftSize ftSize
    addFinalizer font (FTGL.destroyFont font)
    win <- initScreen
    let r = 1/fromIntegral resX :: GL.GLdouble
    GLFW.setWindowCloseCallback win $ Just $ const $ error "Quit"
    let strs =
            [ "(Heƒjjo)"
            , "f"
            , "  "
            , " "
            , ""
            , "xxx"
            , "x"
            , " x "
            ]
    putStrLn $ "Ascender=" ++ show (FTGL.getFontAscender font)
    putStrLn $ "Descender=" ++ show (FTGL.getFontDescender font)
    putStrLn $ "LineHeight=" ++ show (FTGL.getFontLineHeight font)
    finishIteration <- newIORef False
    let loop act = do
            p <- readIORef finishIteration
            unless p $ act >> loop act
    GLFW.setKeyCallback win $ Just $ const $
      \_key _i ks _mods ->
      when (ks==GLFW.KeyState'Pressed) $
      writeIORef finishIteration True
    forM_ (cycle strs) $ \str -> do
        print str
        writeIORef finishIteration False
        loop $ GL.preservingMatrix $ do
            GL.clearColor GL.$= color 0 0 0 1
            GL.clear [GL.ColorBuffer]
            let rect ::
                    Float -> Float -> Float -> Float ->
                    [GL.Vertex2 GL.GLfloat]
                rect llx lly urx ury =
                  [ GL.Vertex2 (r2f llx) (r2f lly)
                  , GL.Vertex2 (r2f urx) (r2f lly)
                  , GL.Vertex2 (r2f urx) (r2f ury)
                  , GL.Vertex2 (r2f llx) (r2f ury)
                  ]
            let yMin = FTGL.getFontDescender font
            let yMax = FTGL.getFontAscender font
            let drawRect col llx lly urx ury =
                    withoutTextures $ do
                        GL.color col
                        GL.renderPrimitive GL.Polygon $
                          mapM_ GL.vertex $ rect llx lly urx ury

            advance <- FTGL.getFontAdvance font str
            [llx, lly, _, urx, ury, _] <- FTGL.getFontBBox font str

            let totalWidth = llx + urx
            let lineHeight = FTGL.getFontLineHeight font
                baseLine = 0

            setAttrs $ do
                GL.scale r r 1
                GL.translate $ vector3 (-r2f totalWidth/2) 0 0

                -- boxes:
                -- full box:
                drawRect (color 1.0 0.0 0.0 0.8) 0   yMin     totalWidth (yMin+lineHeight)
                -- bounding box
                drawRect (color 0.0 0.0 1.0 0.8) llx lly      urx        ury

                GL.color $ color 1 1 1 1
                FTGL.renderFont font str FTGL.All

                -- vertical lines:
                -- descender to ascender
                drawRect (color 0.0 1.0 1.0 0.8) 10  yMin     20 yMax
                -- baseLine up half-way
                drawRect (color 0.0 1.0 0.0 0.8) 30  baseLine 40 ((yMax-yMin)/2)

                -- horiz lines:
                -- text-advance (0..advance)
                drawRect (color 0.0 1.0 0.0 0.8) 0   10       advance    20

            GLFW.swapBuffers win
            GLFW.pollEvents