stb-truetype-0.1.4: example/example.hs

-- This small example programs renders a single character as ASCII art

module Main where

--------------------------------------------------------------------------------

import Control.Monad

import Data.Array.IArray
import Data.Word
import Text.Read

import System.Environment
import System.Exit

import Foreign.Ptr
import Foreign.Marshal

import Graphics.Rendering.TrueType.STB 

--------------------------------------------------------------------------------

defaultSize = 32  :: Int
defaultChar = 'A' :: Char

wordToChar :: Word8 -> Char
wordToChar w 
  | w ==  0   = ' '
  | w <  50   = '.' 
  | w < 100   = '+' 
  | w < 150   = 'o' 
  | w < 200   = '$'
  | otherwise = '@'

--------------------------------------------------------------------------------

myError :: String -> IO a
myError msg = do
  putStrLn msg
  exitWith ExitSuccess

printLetter :: FilePath -> Char -> Int -> IO ()
printLetter fpath ch height = do
  ttfPackage <- loadTTF fpath
  ofsList <- enumerateFonts ttfPackage
  ofs <- case ofsList of  
    []    -> myError "error: empty TrueType font"
    (o:_) -> return o
  font <- initFont ttfPackage ofs
  mbGlyph <- findGlyph font ch
  case mbGlyph of
    Nothing -> myError "the given character is not found in the font"
    Just glyph -> renderGlyph font glyph height

renderGlyph :: Font -> Glyph -> Int -> IO ()
renderGlyph font glyph height = do

  vmu <- getFontVerticalMetrics font
  let s = scaleForPixelHeight vmu (fromIntegral height)

  (bm,ofs) <- newGlyphBitmap font glyph (s,s) 
  putStrLn $ "offset = " ++ show ofs
  arr <- bitmapArray bm
  let ((y1,x1),(y2,x2)) = bounds arr
  putStrLn ('+' : replicate (2*(x2-x1+1)) '-' ++ "+")
  forM_ [y1..y2] $ \y -> do
    putChar '|'
    forM_ [x1..x2] $ \x -> do
      let c = wordToChar $ arr!(y,x)
      putChar c
      putChar c
    putStrLn "|"
  putStrLn ('+' : replicate (2*(x2-x1+1)) '-' ++ "+")

--------------------------------------------------------------------------------

main = do
  args <- getArgs
  case args of 
    [fname]         -> printLetter fname 'A'        defaultSize
    [fname,str]     -> printLetter fname (head str) defaultSize
    [fname,str,siz] -> case readMaybe siz of
      Just h  -> printLetter fname (head str) h
      Nothing -> printUsage
    _ -> printUsage

printUsage = do
  putStrLn "usage:\n"
  putStrLn "stb-truetype-example <font.ttf>"
  putStrLn "stb-truetype-example <font.ttf> <character>"
  putStrLn "stb-truetype-example <font.ttf> <character> <size>"

--------------------------------------------------------------------------------