    --------------------------------------------------------------------------------
    -- |
    -- Module      :  Graphics.UI.GLUT.Fonts
    -- Copyright   :  (c) Sven Panne 2002-2005
    -- License     :  BSD-style (see the file libraries/GLUT/LICENSE)
    --
    -- Maintainer  :  sven.panne@aedion.de
    -- 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 Data.Char ( ord )
    import Foreign.C.String ( CString, withCString )
    import Foreign.C.Types ( CInt )
    import Foreign.Ptr ( Ptr )
    import Graphics.Rendering.OpenGL.GL.BasicTypes ( GLint, GLfloat )
    import Graphics.UI.GLUT.Extensions

    #ifdef __HUGS__
    {-# CFILES cbits/HsGLUT.c #-}
    #endif

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

    #include "HsGLUTExt.h"

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

    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 :: a -> String -> IO ()

       -- | 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 :: a -> String -> IO 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 width in units.

       fontHeight :: a -> IO GLfloat

    instance Font BitmapFont where
       renderString = bitmapString
       stringWidth  = bitmapLength
       fontHeight   = bitmapHeight

    instance Font StrokeFont where
       renderString = strokeString
       stringWidth  = strokeLength
       fontHeight   = strokeHeight

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

    -- | The bitmap fonts available in GLUT. The exact bitmap to be used is
    -- defined by the standard X glyph bitmaps for the X font with the given name.

    data BitmapFont
       = Fixed8By13   -- ^ A fixed width font with every character fitting in an 8
                      --   by 13 pixel rectangle.
                      --   (@-misc-fixed-medium-r-normal--13-120-75-75-C-80-iso8859-1@)
       | Fixed9By15   -- ^ A fixed width font with every character fitting in an 9
                      --   by 15 pixel rectangle.
                      --   (@-misc-fixed-medium-r-normal--15-140-75-75-C-90-iso8859-1@)
       | TimesRoman10 -- ^ A 10-point proportional spaced Times Roman font.
                      --   (@-adobe-times-medium-r-normal--10-100-75-75-p-54-iso8859-1@)
       | TimesRoman24 -- ^ A 24-point proportional spaced Times Roman font.
                      --   (@-adobe-times-medium-r-normal--24-240-75-75-p-124-iso8859-1@)
       | Helvetica10  -- ^ A 10-point proportional spaced Helvetica font.
                      --   (@-adobe-helvetica-medium-r-normal--10-100-75-75-p-56-iso8859-1@)
       | Helvetica12  -- ^ A 12-point proportional spaced Helvetica font.
                      --   (@-adobe-helvetica-medium-r-normal--12-120-75-75-p-67-iso8859-1@)
       | Helvetica18  -- ^ A 18-point proportional spaced Helvetica font.
                      --   (@-adobe-helvetica-medium-r-normal--18-180-75-75-p-98-iso8859-1@)
       deriving ( Eq, Ord, Show )

    -- Alas, fonts in GLUT are not denoted by some integral value, but by opaque
    -- pointers on the C side. Even worse: For WinDoze, they are simply small ints,
    -- casted to void*, for other platforms addresses of global variables are used.
    -- And all is done via ugly #ifdef-ed #defines... Aaaaargl! So the only portable
    -- way is using integers on the Haskell side and doing the marshaling via some
    -- small C wrappers around those macros. *sigh*
    type GLUTbitmapFont = Ptr ()

    foreign import ccall unsafe "hs_GLUT_marshalBitmapFont"
       hs_GLUT_marshalBitmapFont :: CInt -> IO GLUTbitmapFont

    marhshalBitmapFont :: BitmapFont -> IO GLUTbitmapFont
    marhshalBitmapFont x = case x of
       Fixed8By13 -> hs_GLUT_marshalBitmapFont 0
       Fixed9By15 -> hs_GLUT_marshalBitmapFont 1
       TimesRoman10 -> hs_GLUT_marshalBitmapFont 2
       TimesRoman24 -> hs_GLUT_marshalBitmapFont 3
       Helvetica10 -> hs_GLUT_marshalBitmapFont 4
       Helvetica12 -> hs_GLUT_marshalBitmapFont 5
       Helvetica18 -> hs_GLUT_marshalBitmapFont 6

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

    -- | The stroke fonts available in GLUT.
    data StrokeFont
       = Roman     -- ^ A proportionally spaced Roman Simplex font for ASCII
                   --   characters 32 through 127. The maximum top character in the
                   --   font is 119.05 units; the bottom descends 33.33 units.
       | MonoRoman -- ^ A mono-spaced spaced Roman Simplex font (same characters as
                   --   'Roman') for ASCII characters 32 through 127. The maximum
                   --   top character in the font is 119.05 units; the bottom
                   --   descends 33.33 units. Each character is 104.76 units wide.
       deriving ( Eq, Ord, Show )

    -- Same remarks as for GLUTbitmapFont
    type GLUTstrokeFont = Ptr ()

    foreign import ccall unsafe "hs_GLUT_marshalStrokeFont"
       hs_GLUT_marshalStrokeFont :: CInt -> IO GLUTstrokeFont

    marhshalStrokeFont :: StrokeFont -> IO GLUTstrokeFont
    marhshalStrokeFont x = case x of
       Roman -> hs_GLUT_marshalStrokeFont 0
       MonoRoman -> hs_GLUT_marshalStrokeFont 1

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

    bitmapString :: BitmapFont -> String -> IO ()
    bitmapString f s = do
       i <- marhshalBitmapFont f
       mapM_ (\c -> withChar c (glutBitmapCharacter i)) s

    withChar :: Char -> (CInt -> IO a) -> IO a
    withChar c f = f . fromIntegral . ord $ c

    foreign import CALLCONV "glutBitmapCharacter" glutBitmapCharacter ::
       GLUTbitmapFont -> CInt -> IO ()

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

    strokeString :: StrokeFont -> String -> IO ()
    strokeString f s = do
       i <- marhshalStrokeFont f
       mapM_ (\c -> withChar c (glutStrokeCharacter i)) s

    foreign import CALLCONV unsafe "glutStrokeCharacter"
       glutStrokeCharacter :: GLUTstrokeFont -> CInt -> IO ()

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

    bitmapLength :: BitmapFont -- ^ Bitmap font to use.
                 -> String     -- ^ String to return width of (not confined to 8
                               --   bits).
                 -> IO GLint   -- ^ Width in pixels.
    bitmapLength f s = do
       i <- marhshalBitmapFont f
       fmap fromIntegral $ withCString s (glutBitmapLength i)

    foreign import CALLCONV unsafe "glutBitmapLength"
       glutBitmapLength :: GLUTbitmapFont -> CString -> IO CInt

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

    strokeLength :: StrokeFont -- ^ Stroke font to use.
                 -> String     -- ^ String to return width of (not confined to 8
                               --   bits).
                 -> IO GLint   -- ^ Width in units.
    strokeLength f s = do
       i <- marhshalStrokeFont f
       fmap fromIntegral $ withCString s (glutStrokeLength i)

    foreign import CALLCONV unsafe "glutStrokeLength"
       glutStrokeLength :: GLUTstrokeFont -> CString -> IO CInt

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

    bitmapHeight :: BitmapFont -- ^ Bitmap font to use.
                 -> IO GLfloat -- ^ Height in pixels.
    bitmapHeight f = fmap fromIntegral $ glutBitmapHeight =<< marhshalBitmapFont f

    EXTENSION_ENTRY(unsafe,"freeglut",glutBitmapHeight,GLUTbitmapFont -> IO CInt)

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

    strokeHeight :: StrokeFont -- ^ Stroke font to use.
                 -> IO GLfloat -- ^ Height in units.
    strokeHeight f = glutStrokeHeight =<< marhshalStrokeFont f

    EXTENSION_ENTRY(unsafe,"freeglut",glutStrokeHeight,GLUTstrokeFont -> IO GLfloat)