--------------------------------------------------------------------------------
-- |
-- Module      :  Graphics.UI.GLUT.Fonts
-- Copyright   :  (c) Sven Panne 2002-2018
-- License     :  BSD3
--
-- Maintainer  :  Sven Panne <svenpanne@gmail.com>
-- Stability   :  stable
-- Portability :  portable
--
-- GLUT supports two types of font rendering: stroke fonts, meaning each
-- character is rendered as a set of line segments; and bitmap fonts, where each
-- character is a bitmap generated with
-- 'Graphics.Rendering.OpenGL.GL.Bitmaps.bitmap'. Stroke fonts have the
-- advantage that because they are geometry, they can be arbitrarily scale and
-- rendered. Bitmap fonts are less flexible since they are rendered as bitmaps
-- but are usually faster than stroke fonts.
--
--------------------------------------------------------------------------------

module Graphics.UI.GLUT.Fonts (
   Font(..), BitmapFont(..), StrokeFont(..),
) where

import Control.Monad.IO.Class ( MonadIO(..) )
import Data.Char ( ord )
import Foreign.C.String ( withCString )
import Foreign.C.Types ( CInt )
import Foreign.Ptr ( castPtr )
import Graphics.Rendering.OpenGL ( GLint, GLfloat )

import Graphics.UI.GLUT.Raw

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

class Font a where
   -- | Render the string in the named font, without using any display lists.
   -- Rendering a nonexistent character has no effect.
   --
   -- If the font is a bitmap font, 'renderString' automatically sets the OpenGL
   -- unpack pixel storage modes it needs appropriately and saves and restores
   -- the previous modes before returning. The generated call to
   -- 'Graphics.Rendering.OpenGL.GL.bitmap' will adjust the current raster
   -- position based on the width of the string.
   -- If the font is a stroke font,
   -- 'Graphics.Rendering.OpenGL.GL.CoordTrans.translate' is used to translate
   -- the current model view matrix to advance the width of the string.

   renderString :: MonadIO m => a -> String -> m ()

   -- | For a bitmap font, return the width in pixels of a string. For a stroke
   -- font, return the width in units. While the width of characters in a font
   -- may vary (though fixed width fonts do not vary), the maximum height
   -- characteristics of a particular font are fixed.

   stringWidth :: MonadIO m => a -> String -> m GLint

   -- | (/freeglut only/) For a bitmap font, return the maximum height of the
   -- characters in the given font measured in pixels. For a stroke font,
   -- return the height in units.

   fontHeight :: MonadIO m => a -> m GLfloat

instance Font BitmapFont where
   renderString :: BitmapFont -> String -> m ()
renderString = BitmapFont -> String -> m ()
forall (m :: * -> *). MonadIO m => BitmapFont -> String -> m ()
bitmapString
   stringWidth :: BitmapFont -> String -> m GLint
stringWidth  = BitmapFont -> String -> m GLint
forall (m :: * -> *). MonadIO m => BitmapFont -> String -> m GLint
bitmapLength
   fontHeight :: BitmapFont -> m GLfloat
fontHeight   = BitmapFont -> m GLfloat
forall (m :: * -> *). MonadIO m => BitmapFont -> m GLfloat
bitmapHeight


instance Font StrokeFont where
   renderString :: StrokeFont -> String -> m ()
renderString = StrokeFont -> String -> m ()
forall (m :: * -> *). MonadIO m => StrokeFont -> String -> m ()
strokeString
   stringWidth :: StrokeFont -> String -> m GLint
stringWidth  = StrokeFont -> String -> m GLint
forall (m :: * -> *). MonadIO m => StrokeFont -> String -> m GLint
strokeLength
   fontHeight :: StrokeFont -> m GLfloat
fontHeight   = StrokeFont -> m GLfloat
forall (m :: * -> *). MonadIO m => StrokeFont -> m GLfloat
strokeHeight

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

bitmapString :: MonadIO m => BitmapFont -> String -> m ()
bitmapString :: BitmapFont -> String -> m ()
bitmapString BitmapFont
f String
s = do
   GLUTbitmapFont
i <- BitmapFont -> m GLUTbitmapFont
forall (m :: * -> *). MonadIO m => BitmapFont -> m GLUTbitmapFont
marshalBitmapFont BitmapFont
f
   (Char -> m ()) -> String -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Char
c -> Char -> (CInt -> m ()) -> m ()
forall (m :: * -> *) a. Char -> (CInt -> m a) -> m a
withChar Char
c (GLUTbitmapFont -> CInt -> m ()
forall (m :: * -> *) a. MonadIO m => Ptr a -> CInt -> m ()
glutBitmapCharacter GLUTbitmapFont
i)) String
s

withChar :: Char -> (CInt -> m a) -> m a
withChar :: Char -> (CInt -> m a) -> m a
withChar Char
c CInt -> m a
f = CInt -> m a
f (CInt -> m a) -> (Char -> CInt) -> Char -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CInt) -> (Char -> Int) -> Char -> CInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Int
ord (Char -> m a) -> Char -> m a
forall a b. (a -> b) -> a -> b
$ Char
c

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

strokeString :: MonadIO m => StrokeFont -> String -> m ()
strokeString :: StrokeFont -> String -> m ()
strokeString StrokeFont
f String
s = do
   GLUTbitmapFont
i <- StrokeFont -> m GLUTbitmapFont
forall (m :: * -> *). MonadIO m => StrokeFont -> m GLUTbitmapFont
marshalStrokeFont StrokeFont
f
   (Char -> m ()) -> String -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Char
c -> Char -> (CInt -> m ()) -> m ()
forall (m :: * -> *) a. Char -> (CInt -> m a) -> m a
withChar Char
c (GLUTbitmapFont -> CInt -> m ()
forall (m :: * -> *) a. MonadIO m => Ptr a -> CInt -> m ()
glutStrokeCharacter GLUTbitmapFont
i)) String
s

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

bitmapLength :: MonadIO m
             => BitmapFont -- ^ Bitmap font to use.
             -> String     -- ^ String to return width of (not confined to 8
                           --   bits).
             -> m GLint    -- ^ Width in pixels.
bitmapLength :: BitmapFont -> String -> m GLint
bitmapLength BitmapFont
f String
s = IO GLint -> m GLint
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GLint -> m GLint) -> IO GLint -> m GLint
forall a b. (a -> b) -> a -> b
$ do
   GLUTbitmapFont
i <- BitmapFont -> IO GLUTbitmapFont
forall (m :: * -> *). MonadIO m => BitmapFont -> m GLUTbitmapFont
marshalBitmapFont BitmapFont
f
   (CInt -> GLint) -> IO CInt -> IO GLint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CInt -> GLint
forall a b. (Integral a, Num b) => a -> b
fromIntegral (IO CInt -> IO GLint) -> IO CInt -> IO GLint
forall a b. (a -> b) -> a -> b
$ String -> (CString -> IO CInt) -> IO CInt
forall a. String -> (CString -> IO a) -> IO a
withCString String
s (GLUTbitmapFont -> Ptr CUChar -> IO CInt
forall (m :: * -> *) a. MonadIO m => Ptr a -> Ptr CUChar -> m CInt
glutBitmapLength GLUTbitmapFont
i (Ptr CUChar -> IO CInt)
-> (CString -> Ptr CUChar) -> CString -> IO CInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CString -> Ptr CUChar
forall a b. Ptr a -> Ptr b
castPtr)

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

strokeLength :: MonadIO m
             => StrokeFont -- ^ Stroke font to use.
             -> String     -- ^ String to return width of (not confined to 8
                           --   bits).
             -> m GLint    -- ^ Width in units.
strokeLength :: StrokeFont -> String -> m GLint
strokeLength StrokeFont
f String
s = IO GLint -> m GLint
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GLint -> m GLint) -> IO GLint -> m GLint
forall a b. (a -> b) -> a -> b
$ do
   GLUTbitmapFont
i <- StrokeFont -> IO GLUTbitmapFont
forall (m :: * -> *). MonadIO m => StrokeFont -> m GLUTbitmapFont
marshalStrokeFont StrokeFont
f
   (CInt -> GLint) -> IO CInt -> IO GLint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CInt -> GLint
forall a b. (Integral a, Num b) => a -> b
fromIntegral (IO CInt -> IO GLint) -> IO CInt -> IO GLint
forall a b. (a -> b) -> a -> b
$ String -> (CString -> IO CInt) -> IO CInt
forall a. String -> (CString -> IO a) -> IO a
withCString String
s (GLUTbitmapFont -> Ptr CUChar -> IO CInt
forall (m :: * -> *) a. MonadIO m => Ptr a -> Ptr CUChar -> m CInt
glutStrokeLength GLUTbitmapFont
i (Ptr CUChar -> IO CInt)
-> (CString -> Ptr CUChar) -> CString -> IO CInt
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CString -> Ptr CUChar
forall a b. Ptr a -> Ptr b
castPtr)

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

bitmapHeight :: MonadIO m
             => BitmapFont -- ^ Bitmap font to use.
             -> m GLfloat  -- ^ Height in pixels.
bitmapHeight :: BitmapFont -> m GLfloat
bitmapHeight BitmapFont
f = IO GLfloat -> m GLfloat
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GLfloat -> m GLfloat) -> IO GLfloat -> m GLfloat
forall a b. (a -> b) -> a -> b
$ do
  GLUTbitmapFont
i <- BitmapFont -> IO GLUTbitmapFont
forall (m :: * -> *). MonadIO m => BitmapFont -> m GLUTbitmapFont
marshalBitmapFont BitmapFont
f
  CInt -> GLfloat
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> GLfloat) -> IO CInt -> IO GLfloat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` GLUTbitmapFont -> IO CInt
forall (m :: * -> *) a. MonadIO m => Ptr a -> m CInt
glutBitmapHeight  GLUTbitmapFont
i

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

strokeHeight :: MonadIO m
             => StrokeFont -- ^ Stroke font to use.
             -> m GLfloat  -- ^ Height in units.
strokeHeight :: StrokeFont -> m GLfloat
strokeHeight StrokeFont
f = GLUTbitmapFont -> m GLfloat
forall (m :: * -> *) a. MonadIO m => Ptr a -> m GLfloat
glutStrokeHeight (GLUTbitmapFont -> m GLfloat) -> m GLUTbitmapFont -> m GLfloat
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< StrokeFont -> m GLUTbitmapFont
forall (m :: * -> *). MonadIO m => StrokeFont -> m GLUTbitmapFont
marshalStrokeFont StrokeFont
f