diff --git a/demo/example.hs b/demo/example.hs --- a/demo/example.hs +++ b/demo/example.hs @@ -1,11 +1,10 @@ +import Control.Applicative import Control.Monad import Data.IORef import Data.Monoid import Graphics.DrawingCombinators ((%%)) import qualified Graphics.DrawingCombinators as Draw import qualified Graphics.UI.GLFW as GLFW -import Graphics.Rendering.OpenGL.GL.StateVar -import qualified Graphics.Rendering.OpenGL.GL.CoordTrans as GL(Size(..)) import System.Environment(getArgs) @@ -13,15 +12,20 @@ resX = 640 resY = 480 -initScreen :: IO () +initScreen :: IO GLFW.Window initScreen = do - True <- GLFW.initialize - True <- GLFW.openWindow (GL.Size (fromIntegral resX) (fromIntegral resY)) - [GLFW.DisplayRGBBits 8 8 8, - GLFW.DisplayDepthBits 8] - GLFW.Window - - return () + 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 unitText :: Draw.Font -> String -> Draw.Image Any unitText font str = (Draw.translate (-1,0) %% Draw.scale (2/w) (2/w) %% Draw.text font str) @@ -37,33 +41,65 @@ (Draw.translate (0.5,-0.5) `Draw.compose` Draw.rotate pi %%), (Draw.translate (-0.5,-0.5) `Draw.compose` Draw.rotate (pi/2) %%)] (Draw.scale 0.5 0.5 %% img) -circleText :: Draw.Font -> String -> Draw.Image Any -circleText font str = unitText font str `mappend` Draw.tint (Draw.Color 0 0 1 0.5) Draw.circle +fromAny :: Alternative f => a -> Any -> f a +fromAny _ (Any False) = empty +fromAny msg (Any True) = pure msg + +circleText :: Draw.Font -> String -> Draw.Image [String] +circleText font str = + mconcat + [ fromAny str <$> unitText font str + , fromAny "circle" <$> Draw.tint (Draw.Color 0 0 1 0.5) Draw.circle + ] + +toGLCoors :: GLFW.Window -> (Double, Double) -> IO Draw.R2 +toGLCoors win (x, y) = do + (w, h) <- GLFW.getFramebufferSize win + return (coor x w, - coor y h) + where + coor a b = realToFrac (2 * a / fromIntegral b - 1) + main :: IO () main = do - initScreen + win <- initScreen args <- getArgs - font <- case args of - [fontName] -> do + (font, pic) <- case args of + [fontName, picName] -> do font <- Draw.openFont fontName - return font - _ -> error "Usage: drawingcombinators-example some_font.ttf" + pic <- Draw.openSprite picName + return (font, pic) + _ -> error "Usage: drawingcombinators-example some_font.ttf some_img.png" doneRef <- newIORef False - GLFW.windowCloseCallback $= do - writeIORef doneRef True - return True - waitClose font doneRef 0 + GLFW.setWindowCloseCallback win $ Just $ const $ writeIORef doneRef True + + let mkImage rotation = + Draw.rotate rotation %% + quadrants + ( mconcat + [ Draw.scale 0.2 0.2 %% + fromAny "sprite" <$> Draw.sprite pic + , circleText font "Hej, World!" + ] ) + imageRef <- newIORef $ mkImage 0 + GLFW.setMouseButtonCallback win $ Just $ const $ \_button press _mods -> + when (press == GLFW.MouseButtonState'Pressed) $ do + image <- readIORef imageRef + pos <- GLFW.getCursorPos win + glPos <- toGLCoors win pos + let strs = Draw.sample image glPos + print strs + let waitClose rotation = do + isDone <- readIORef doneRef + unless isDone $ do + let image = mkImage rotation + writeIORef imageRef image + Draw.clearRender image + GLFW.swapBuffers win + GLFW.pollEvents + waitClose $ rotation - 0.01 + waitClose 0 GLFW.terminate return () - where - - waitClose font doneRef rotation = do - isDone <- readIORef doneRef - unless isDone $ do - Draw.clearRender $ Draw.rotate rotation %% quadrants (circleText font "Hello, World!") - GLFW.swapBuffers - GLFW.pollEvents - waitClose font doneRef $ rotation - 0.01 diff --git a/graphics-drawingcombinators.cabal b/graphics-drawingcombinators.cabal --- a/graphics-drawingcombinators.cabal +++ b/graphics-drawingcombinators.cabal @@ -4,7 +4,7 @@ have to go into the deep, dark world of imperative stateful programming just to draw stuff. It supports 2D only (for now), with support drawing geometry, images, and text. -Version: 1.5 +Version: 1.5.1 Stability: experimental Synopsis: A functional interface to 2D drawing in OpenGL License: BSD3 @@ -24,10 +24,9 @@ Description: Does the system have FTGL, thus we could use not sucky fonts Library - Build-Depends: base == 4.*, OpenGL >= 2.9 && < 2.10, stb-image == 0.2.*, bitmap >= 0.0.2 + Build-Depends: base == 4.*, OpenGL >= 2.9 && < 2.10, stb-image == 0.2.*, bitmap >= 0.0.2, bitmap-opengl >= 0.0.1.5 hs-Source-Dirs: src Exposed-Modules: Graphics.DrawingCombinators, Graphics.DrawingCombinators.Affine - Other-Modules: Graphics.DrawingCombinators.Bitmap ghc-options : -Wall Ghc-Prof-Options: -prof -auto-all if flag(ftgl) @@ -46,5 +45,5 @@ Buildable: False else Buildable: True - Build-depends: base, GLFW-b, OpenGL, graphics-drawingcombinators + Build-depends: base, GLFW-b >=1.4.6 && <1.5, OpenGL, graphics-drawingcombinators ghc-options: -Wall diff --git a/src/Graphics/DrawingCombinators.hs b/src/Graphics/DrawingCombinators.hs --- a/src/Graphics/DrawingCombinators.hs +++ b/src/Graphics/DrawingCombinators.hs @@ -71,7 +71,7 @@ -- * Sprites (images from files) , Sprite, openSprite, sprite -- * Text - , Font, openFont, text, textWidth + , Font, openFont, text, textWidth, withFont -- * Extensions , unsafeOpenGLImage , Monoid(..), Any(..) @@ -80,8 +80,9 @@ import Graphics.DrawingCombinators.Affine import Control.Applicative (Applicative(..), liftA2, (*>), (<$>)) +import qualified Control.Exception as Exception import Data.Monoid (Monoid(..), Any(..)) -import qualified Graphics.DrawingCombinators.Bitmap as Bitmap +import qualified Data.Bitmap.OpenGL as Bitmap import qualified Graphics.Rendering.OpenGL.GL as GL import qualified Codec.Image.STB as Image import System.IO.Unsafe (unsafePerformIO) -- for pure textWidth @@ -354,7 +355,7 @@ where render' tr _ = withMultGLmatrix tr $ renderText font str pick (x,y) - | 0 <= x && x <= textWidth font str && 0 <= y && y <= 1 = Any True + | 0 <= x && x <= textWidth font str && -0.5 <= y && y <= 1.5 = Any True | otherwise = Any False #ifdef LAME_FONTS @@ -385,12 +386,24 @@ FTGL.renderFont (getFont font) str FTGL.All -- | Load a TTF font from a file. -openFont :: String -> IO Font +-- +-- WARNING: This is unsafe due to the finalizer possibly running earlier than +-- expected +-- See discussion at: +-- http://hackage.haskell.org/package/base-4.8.0.0/docs/System-Mem-Weak.html#v:addFinalizer +openFont :: FilePath -> IO Font openFont path = do - font <- FTGL.createTextureFont path + font <- FTGL.createBufferFont path addFinalizer font (FTGL.destroyFont font) _ <- FTGL.setFontFaceSize font 72 72 return $ Font font + +withFont :: FilePath -> (Font -> IO a) -> IO a +withFont path act = + Exception.bracket (FTGL.createBufferFont path) FTGL.destroyFont $ + \font -> do + _ <- FTGL.setFontFaceSize font 72 72 + act (Font font) -- | @textWidth font str@ is the width of the text in @text font str@. textWidth :: Font -> String -> R diff --git a/src/Graphics/DrawingCombinators/Bitmap.hs b/src/Graphics/DrawingCombinators/Bitmap.hs deleted file mode 100644 --- a/src/Graphics/DrawingCombinators/Bitmap.hs +++ /dev/null @@ -1,88 +0,0 @@ --- | OpenGL support for Data.Bitmap - -{- Copied from the bitmap-opengl package because maintainer is - unresponsive about bug-fixes/uploads -} -{- Copyright: (c) 2009 Balazs Komuves -} - -{-# LANGUAGE ScopedTypeVariables #-} -module Graphics.DrawingCombinators.Bitmap - ( makeSimpleBitmapTexture - , makeTextureFromBitmap - , texImageFromBitmap - ) where - --------------------------------------------------------------------------------- - -import Data.Bitmap - -import Graphics.Rendering.OpenGL - --------------------------------------------------------------------------------- - --- OpenGL data type -dataType :: PixelComponent t => t -> DataType -dataType t = case pixelComponentType t of - PctWord8 -> UnsignedByte - PctWord16 -> UnsignedShort - PctWord32 -> UnsignedInt - PctFloat -> Float - --------------------------------------------------------------------------------- - --- | This function guesses the pixel format from the number of channels: --- --- * 1 ~> Alpha --- --- * 2 ~> Luminance, Alpha --- --- * 3 ~> RGB --- --- * 4 ~> RGBA --- --- For more control, use 'makeTextureFromBitmap'. -makeSimpleBitmapTexture :: forall t. PixelComponent t => Bitmap t -> IO TextureObject -makeSimpleBitmapTexture bm = do - let (pf,pif) = case pixelComponentType (undefined::t) of - PctWord8 -> case bitmapNChannels bm of - 1 -> (Alpha, Alpha8) - 2 -> (LuminanceAlpha, Luminance8Alpha8) - 3 -> (RGB, RGB8) - 4 -> (RGBA, RGBA8) - n -> error $ "Invalid bitmap channel count: " ++ show n - _ -> case bitmapNChannels bm of - 1 -> (Alpha, Alpha') - 2 -> (LuminanceAlpha, LuminanceAlpha') - 3 -> (RGB, RGB') - 4 -> (RGBA, RGBA') - n -> error $ "Invalid bitmap channel count: " ++ show n - makeTextureFromBitmap bm Texture2D 0 pf pif 0 - --- | Creates a new OpenGL texture from a bitmap -makeTextureFromBitmap - :: (PixelComponent t, TwoDimensionalTextureTarget target) - => Bitmap t -> target -> Level -> PixelFormat -> PixelInternalFormat -> Border -> IO TextureObject -makeTextureFromBitmap bm target level pf pif border = do - old_binding <- get (textureBinding Texture2D) - [tex] <- genObjectNames 1 - textureBinding Texture2D $= Just tex - textureFilter Texture2D $= ((Linear',Nothing),Linear') - texImageFromBitmap bm target level pf pif border - textureBinding Texture2D $= old_binding - return tex - -texImageFromBitmap - :: forall target t. (PixelComponent t, TwoDimensionalTextureTarget target) - => Bitmap t -> target -> Level -> PixelFormat -> PixelInternalFormat -> Border -> IO () -texImageFromBitmap bm target level pf pif border = do - withBitmap bm $ \(width,height) _nchn _pad ptr -> do --- old_rowlength <- get (rowLength Unpack) - old_alignment <- get (rowAlignment Unpack) - let pdata = PixelData pf (dataType (undefined::t)) ptr - size = TextureSize2D (fromIntegral width) (fromIntegral height) --- rowLength Unpack $= fromIntegral (bitmapPaddedRowSizeInBytes bm) - rowAlignment Unpack $= fromIntegral (bitmapRowAlignment bm) - texImage2D target NoProxy level pif size border pdata --- rowLength Unpack $= old_rowlength - rowAlignment Unpack $= old_alignment - ---------------------------------------------------------------------------------