graphics-drawingcombinators 1.5 → 1.5.1

raw patch · 4 files changed

+87/−127 lines, 4 filesdep +bitmap-opengldep ~GLFW-bPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: bitmap-opengl

Dependency ranges changed: GLFW-b

API changes (from Hackage documentation)

Files

• demo/example.hs +66/−30
• graphics-drawingcombinators.cabal +3/−4
• src/Graphics/DrawingCombinators.hs +18/−5
• src/Graphics/DrawingCombinators/Bitmap.hs +0/−88

@@ -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

@@ -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

@@ -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

@@ -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----------------------------------------------------------------------------------