module Graphics.Rendering.FTGL where
import Control.Monad.IO.Class
import System.IO.Unsafe (unsafePerformIO)
import Foreign.C
import Foreign.Ptr
import Foreign.Marshal.Alloc
import Foreign.Marshal.Array
import Data.Bits
import Data.Char (ord)
import qualified Data.ByteString.Char8 as BS8
import Data.StateVar.Trans
import Control.Applicative ((<$>))
foreign import ccall unsafe "ftglCreateBitmapFont" fcreateBitmapFont :: CString -> IO Font
createBitmapFont :: BS8.ByteString -> IO Font
createBitmapFont = flip BS8.useAsCString $ fcreateBitmapFont
foreign import ccall unsafe "ftglCreateBufferFont" fcreateBufferFont :: CString -> IO Font
createBufferFont :: BS8.ByteString -> IO Font
createBufferFont = flip BS8.useAsCString fcreateBufferFont
foreign import ccall unsafe "ftglCreateOutlineFont" fcreateOutlineFont :: CString -> IO Font
createOutlineFont :: BS8.ByteString -> IO Font
createOutlineFont = flip BS8.useAsCString fcreateOutlineFont
foreign import ccall unsafe "ftglCreatePixmapFont" fcreatePixmapFont :: CString -> IO Font
createPixmapFont :: BS8.ByteString -> IO Font
createPixmapFont = flip BS8.useAsCString fcreatePixmapFont
foreign import ccall unsafe "ftglCreatePolygonFont" fcreatePolygonFont :: CString -> IO Font
createPolygonFont :: BS8.ByteString -> IO Font
createPolygonFont = flip BS8.useAsCString fcreatePolygonFont
foreign import ccall unsafe "ftglCreateTextureFont" fcreateTextureFont :: CString -> IO Font
createTextureFont :: BS8.ByteString -> IO Font
createTextureFont = flip BS8.useAsCString fcreateTextureFont
foreign import ccall unsafe "ftglCreateExtrudeFont" fcreateExtrudeFont :: CString -> IO Font
createExtrudeFont :: BS8.ByteString -> IO Font
createExtrudeFont = flip BS8.useAsCString fcreateExtrudeFont
foreign import ccall unsafe "ftglCreateSimpleLayout" createSimpleLayout :: IO Layout
foreign import ccall unsafe "ftglSetLayoutFont" setLayoutFont :: Layout -> Font -> IO ()
foreign import ccall unsafe "ftglGetLayoutFont" getLayoutFont :: Layout -> IO Font
layoutFont :: MonadIO m => Layout -> StateVar m Font
layoutFont l = makeStateVar (liftIO $ getLayoutFont l) (liftIO . setLayoutFont l)
foreign import ccall unsafe "ftglSetLayoutLineLength" setLayoutLineLength :: Layout -> CFloat -> IO ()
foreign import ccall unsafe "ftglGetLayoutLineLength" fgetLayoutLineLength :: Layout -> IO CFloat
layoutLineLength :: MonadIO m => Layout -> StateVar m CFloat
layoutLineLength l = makeStateVar
(liftIO $ realToFrac <$> fgetLayoutLineLength l)
(liftIO . setLayoutLineLength l)
foreign import ccall unsafe "ftglSetLayoutAlignment" fsetLayoutAlignment :: Layout -> CInt -> IO ()
foreign import ccall unsafe "ftglGetLayoutAlignement" fgetLayoutAlignment :: Layout -> IO CInt
layoutAlignment :: MonadIO m => Layout -> StateVar m TextAlignment
layoutAlignment l = makeStateVar
(liftIO $ toEnum . fromIntegral <$> fgetLayoutAlignment l)
(liftIO . fsetLayoutAlignment l . fromIntegral . fromEnum)
foreign import ccall unsafe "ftglSetLayoutLineSpacing" fsetLayoutLineSpacing :: Layout -> CFloat -> IO ()
layoutLineSpacing :: MonadIO m => Layout -> SettableStateVar m Float
layoutLineSpacing l = makeSettableStateVar $ liftIO . fsetLayoutLineSpacing l . realToFrac
foreign import ccall unsafe "ftglDestroyFont" destroyFont :: Font -> IO ()
foreign import ccall unsafe "ftglAttachFile" fattachFile :: Font -> CString -> IO ()
attachFile :: Font -> BS8.ByteString -> IO ()
attachFile font str = BS8.useAsCString str $ fattachFile font
foreign import ccall unsafe "ftglAttachData" attachData :: Font -> Ptr () -> IO ()
foreign import ccall unsafe "ftglSetFontCharMap" fsetFontCharMap :: Font -> CInt -> IO ()
charMap :: MonadIO m => Font -> SettableStateVar m CharMap
charMap font = makeSettableStateVar $ \charmap -> liftIO $ fsetFontCharMap font (marshalCharMap charmap)
foreign import ccall unsafe "ftglGetFontCharMapCount" fgetFontCharMapCount :: Font -> IO CInt
getFontCharMapCount :: Font -> Int
getFontCharMapCount f = fromIntegral . unsafePerformIO $ fgetFontCharMapCount f
foreign import ccall unsafe "ftglGetFontCharMapList" fgetFontCharMapList :: Font -> IO (Ptr CInt)
getFontCharMapList :: Font -> Ptr CInt
getFontCharMapList f = unsafePerformIO $ fgetFontCharMapList f
foreign import ccall unsafe "ftglSetFontFaceSize" fsetFontFaceSize :: Font -> CInt -> CInt -> IO CInt
setFontFaceSize :: Font -> Int -> Int -> IO CInt
setFontFaceSize f s x = fsetFontFaceSize f (fromIntegral s) (fromIntegral x)
foreign import ccall unsafe "ftglGetFontFaceSize" fgetFontFaceSize :: Font -> IO CInt
fontFaceSize :: MonadIO m => Font -> GettableStateVar m Int
fontFaceSize f = makeGettableStateVar $ liftIO $ fromIntegral <$> fgetFontFaceSize f
foreign import ccall unsafe "ftglSetFontDepth" fsetFontDepth :: Font -> CFloat -> IO ()
fontDepth :: MonadIO m => Font -> SettableStateVar m Float
fontDepth font = makeSettableStateVar $ \depth -> liftIO $ fsetFontDepth font (realToFrac depth)
foreign import ccall unsafe "ftglSetFontOutset" fsetFontOutset :: Font -> CFloat -> CFloat -> IO ()
setFontOutset :: Font -> Float -> Float -> IO ()
setFontOutset font d o = fsetFontOutset font (realToFrac d) (realToFrac o)
foreign import ccall unsafe "ftglGetFontBBox" fgetFontBBox :: Font -> CString -> Int -> Ptr CFloat -> IO ()
getFontBBox :: Font -> BS8.ByteString -> IO [Float]
getFontBBox f s = allocaBytes 24 $ \pf -> do
BS8.useAsCString s $ \ps -> fgetFontBBox f ps (1) pf
map realToFrac <$> peekArray 6 pf
foreign import ccall unsafe "ftglGetFontAscender" fgetFontAscender :: Font -> CFloat
getFontAscender :: Font -> Float
getFontAscender = realToFrac . fgetFontAscender
foreign import ccall unsafe "ftglGetFontDescender" fgetFontDescender :: Font -> CFloat
getFontDescender :: Font -> Float
getFontDescender = realToFrac . fgetFontDescender
foreign import ccall unsafe "ftglGetFontLineHeight" fgetFontLineHeight :: Font -> CFloat
getFontLineHeight :: Font -> Float
getFontLineHeight = realToFrac . fgetFontLineHeight
foreign import ccall unsafe "ftglGetFontAdvance" fgetFontAdvance :: Font -> CString -> IO CFloat
getFontAdvance :: Font -> BS8.ByteString -> IO Float
getFontAdvance font str = realToFrac <$> (BS8.useAsCString str $ fgetFontAdvance font)
foreign import ccall unsafe "ftglRenderFont" frenderFont :: Font -> CString -> CInt -> IO ()
renderFont :: Font -> RenderMode -> BS8.ByteString -> IO ()
renderFont font mode str = BS8.useAsCString str $ \p -> frenderFont font p (fromIntegral $ fromEnum mode)
foreign import ccall unsafe "ftglGetFontError" fgetFontError :: Font -> IO CInt
fontError :: MonadIO m => Font -> GettableStateVar m Int
fontError f = makeGettableStateVar $ liftIO $ fromIntegral <$> fgetFontError f
foreign import ccall unsafe "ftglDestroyLayout" destroyLayout :: Layout -> IO ()
foreign import ccall unsafe "ftglRenderLayout" frenderLayout :: Layout -> CString -> IO ()
renderLayout :: Layout -> BS8.ByteString -> IO ()
renderLayout layout str = BS8.useAsCString str $ frenderLayout layout
foreign import ccall unsafe "ftglGetLayoutError" fgetLayoutError :: Layout -> IO CInt
layoutError :: MonadIO m => Layout -> GettableStateVar m CInt
layoutError f = makeGettableStateVar $ liftIO $ fgetLayoutError f
data RenderMode = Front | Back | Side | All deriving (Show, Eq)
instance Enum RenderMode where
fromEnum Front = 0x0001
fromEnum Back = 0x0002
fromEnum Side = 0x0004
fromEnum All = 0xffff
toEnum 0x0001 = Front
toEnum 0x0002 = Back
toEnum 0x0004 = Side
toEnum 0xffff = All
toEnum x = error $ "Unknown RenderMode as " ++ show x
data TextAlignment = AlignLeft | AlignCenter | AlignRight | Justify
deriving (Show, Eq, Enum)
data Glyph_Opaque
data Font_Opaque
data Layout_Opaque
type Glyph = Ptr Glyph_Opaque
type Font = Ptr Font_Opaque
type Layout = Ptr Layout_Opaque
data CharMap =
EncodingNone
| EncodingMSSymbol
| EncodingUnicode
| EncodingSJIS
| EncodingGB2312
| EncodingBig5
| EncodingWanSung
| EncodingJohab
| EncodingAdobeStandard
| EncodingAdobeExpert
| EncodingAdobeCustom
| EncodingAdobeLatin1
| EncodingOldLatin2
| EncodingAppleRoman
encodeTag :: Char -> Char -> Char -> Char -> CInt
encodeTag a b c d =
(fromIntegral (ord a) `shift` 24)
.|. (fromIntegral (ord b) `shift` 16)
.|. (fromIntegral (ord c) `shift` 8)
.|. (fromIntegral (ord d))
marshalCharMap :: CharMap -> CInt
marshalCharMap EncodingNone = 0
marshalCharMap EncodingMSSymbol = encodeTag 's' 'y' 'm' 'b'
marshalCharMap EncodingUnicode =encodeTag 'u' 'n' 'i' 'c'
marshalCharMap EncodingSJIS = encodeTag 's' 'j' 'i' 's'
marshalCharMap EncodingGB2312 = encodeTag 'g' 'b' ' ' ' '
marshalCharMap EncodingBig5= encodeTag 'b' 'i' 'g' '5'
marshalCharMap EncodingWanSung= encodeTag 'w' 'a' 'n' 's'
marshalCharMap EncodingJohab= encodeTag 'j' 'o' 'h' 'a'
marshalCharMap EncodingAdobeStandard= encodeTag 'A' 'D' 'O' 'B'
marshalCharMap EncodingAdobeExpert= encodeTag 'A' 'D' 'B' 'E'
marshalCharMap EncodingAdobeCustom= encodeTag 'A' 'D' 'B' 'C'
marshalCharMap EncodingAdobeLatin1= encodeTag 'l' 'a' 't' '1'
marshalCharMap EncodingOldLatin2= encodeTag 'l' 'a' 't' '2'
marshalCharMap EncodingAppleRoman= encodeTag 'a' 'r' 'm' 'n'