graphics-drawingcombinators 1.4.4 → 1.4.4.1
raw patch · 9 files changed
+679/−665 lines, 9 filesdep +GLFW-bdep +graphics-drawingcombinatorsdep −containersdep ~OpenGLdep ~basenew-component:exe:examplePVP ok
version bump matches the API change (PVP)
Dependencies added: GLFW-b, graphics-drawingcombinators
Dependencies removed: containers
Dependency ranges changed: OpenGL, base
API changes (from Hackage documentation)
Files
- Graphics/DrawingCombinators.hs +0/−412
- Graphics/DrawingCombinators/Affine.hs +0/−93
- Graphics/DrawingCombinators/Bitmap.hs +0/−88
- demo/example.hs +67/−0
- example.hs +0/−67
- graphics-drawingcombinators.cabal +19/−5
- src/Graphics/DrawingCombinators.hs +412/−0
- src/Graphics/DrawingCombinators/Affine.hs +93/−0
- src/Graphics/DrawingCombinators/Bitmap.hs +88/−0
− Graphics/DrawingCombinators.hs
@@ -1,412 +0,0 @@-{-# LANGUAGE CPP #-}------------------------------------------------------------------- |--- Module : Graphics.DrawingCombinators--- Copyright : (c) Luke Palmer 2008-2010--- License : BSD3------ Maintainer : Luke Palmer <lrpalmer@gmail.com>--- Stability : experimental--- Portability : tested on GHC only------ Drawing combinators as a functional interface to 2D graphics using OpenGL.------ This module is intended to be imported @qualified@, as in:------ > import qualified Graphics.DrawingCombinators as Draw------ Whenever possible, a /denotational semantics/ for operations in this library--- is given. Read @[[x]]@ as \"the meaning of @x@\".------ Intuitively, an 'Image' @a@ is an infinite plane of pairs of colors /and/--- @a@\'s. The colors are what are drawn on the screen when you 'render', and--- the @a@\'s are what you can recover from coordinates using 'sample'. The--- latter allows you to tell, for example, what a user clicked on.------ The following discussion is about the associated data. If you are only--- interested in drawing, rather than mapping from coordinates to values, you--- can ignore the following and just use 'mappend' and 'mconcat' to overlay images.------ Wrangling the @a@\'s -- the associated data with each \"pixel\" -- is done--- using the 'Functor', 'Applicative', and 'Monoid' instances.------ The primitive @Image@s such as 'circle' and 'text' all return @Image Any@--- objects. 'Any' is just a wrapper around 'Bool', with @(||)@ as its monoid--- operator. So e.g. the points inside the circle will have the value @Any--- True@, and those outside will have the value @Any False@. Returning @Any@--- instead of plain @Bool@ allows you to use @Image@s as a monoid, e.g.--- 'mappend' to overlay two images. But if you are doing anything with--- sampling, you probably want to map this to something. Here is a drawing--- with two circles that reports which one was hit:------ > twoCircles :: Image String--- > twoCircles = liftA2 test (translate (-1,0) %% circle) (translate (1,0) %% circle)--- > where--- > test (Any False) (Any False) = "Miss!"--- > test (Any False) (Any True) = "Hit Right!"--- > test (Any True) (Any False) = "Hit Left!"--- > test (Any True) (Any True) = "Hit Both??!"------ The last case would only be possible if the circles were overlapping.------ Note, the area-less shapes such as 'point', 'line', and 'bezierCurve'--- /always/ return @Any False@ when sampled, even if the exact same--- coordinates are given. This is because miniscule floating-point error--- can make these shapes very brittle under transformations. If you need--- a point to be clickable, make it, for example, a very small box.-----------------------------------------------------------------module Graphics.DrawingCombinators- (- module Graphics.DrawingCombinators.Affine- -- * Basic types- , Image, render, clearRender- -- * Selection- , sample- -- * Geometry- , point, line, regularPoly, circle, convexPoly, (%%), bezierCurve- -- * Colors- , Color(..), modulate, tint- -- * Sprites (images from files)- , Sprite, openSprite, sprite- -- * Text- , Font, openFont, text, textWidth- -- * Extensions- , unsafeOpenGLImage- , Monoid(..), Any(..)- )-where--import Graphics.DrawingCombinators.Affine-import Control.Applicative (Applicative(..), liftA2, (*>), (<$>))-import Data.Monoid (Monoid(..), Any(..))-import qualified Graphics.DrawingCombinators.Bitmap 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--#ifdef LAME_FONTS-import qualified Graphics.UI.GLUT as GLUT-import Control.Monad (unless)-#else-import qualified Graphics.Rendering.FTGL as FTGL-import System.Mem.Weak (addFinalizer)-#endif--type Renderer = Affine -> Color -> IO ()-type Picker a = R2 -> a---- | The type of images.------ > [[Image a]] = R2 -> (Color, a)------ The semantics of the instances are all consistent with /type class morphism/.--- I.e. Functor, Applicative, and Monoid act point-wise, using the 'Color' monoid--- described below.-data Image a = Image { dRender :: Renderer- , dPick :: Picker a- }--instance Functor Image where- fmap f d = Image {- dRender = dRender d,- dPick = fmap f (dPick d)- }--instance Applicative Image where- pure x = Image {- dRender = (pure.pure.pure) (),- dPick = const x- }-- df <*> dx = Image {- -- reversed so that things that come first go on top- dRender = (liftA2.liftA2) (*>) (dRender dx) (dRender df),- dPick = dPick df <*> dPick dx- }--instance (Monoid m) => Monoid (Image m) where- mempty = pure mempty- mappend = liftA2 mappend---- |Draw an Image on the screen in the current OpenGL coordinate--- system (which, in absense of information, is (-1,-1) in the--- lower left and (1,1) in the upper right).-render :: Image a -> IO ()-render d = GL.preservingAttrib [GL.AllServerAttributes] $ do- GL.blend GL.$= GL.Enabled- GL.blendFunc GL.$= (GL.SrcAlpha, GL.OneMinusSrcAlpha)- -- For now we assume the user wants antialiasing; the general solution is not clear - maybe let the- -- user do the opengl setup stuff himself? otherwise need to wrap all of the possible things GL lets- -- you set.- GL.polygonSmooth GL.$= GL.Enabled- GL.lineSmooth GL.$= GL.Enabled- GL.lineWidth GL.$= 1.5- GL.hint GL.LineSmooth GL.$= GL.DontCare-- dRender d identity white---- |Like 'render', but clears the screen first. This is so--- you can use this module and pretend that OpenGL doesn't--- exist at all.-clearRender :: Image a -> IO ()-clearRender d = do- GL.clear [GL.ColorBuffer]- render d---- | Sample the value of the image at a point.------ > [[sample i p]] = snd ([[i]] p)-sample :: Image a -> R2 -> a-sample = dPick--{----------------- Geometry------------------}--toVertex :: Affine -> R2 -> GL.Vertex2 GL.GLdouble-toVertex tr p = let (x,y) = tr `apply` p in GL.Vertex2 x y--toVertex3 :: R -> Affine -> R2 -> GL.Vertex3 GL.GLdouble-toVertex3 z tr p = let (x,y) = tr `apply` p in GL.Vertex3 x y z---- | A single \"pixel\" at the specified point.------ > [[point p]] r | [[r]] == [[p]] = (one, Any True)--- > | otherwise = (zero, Any False)-point :: R2 -> Image Any-point p = Image render' (const (Any False))- where- render' tr _ = withoutTextures . GL.renderPrimitive GL.Points . GL.vertex $ toVertex tr p--withoutTextures :: IO a -> IO a-withoutTextures action =- GL.texture GL.Texture2D GL.$= GL.Disabled >> action---- | A line connecting the two given points.-line :: R2 -> R2 -> Image Any-line src dest = Image render' (const (Any False))- where- render' tr _ = withoutTextures . GL.renderPrimitive GL.Lines $ do- GL.vertex $ toVertex tr src- GL.vertex $ toVertex tr dest----- | A regular polygon centered at the origin with n sides.-regularPoly :: Int -> Image Any-regularPoly n = convexPoly [ (cos theta, sin theta) | i <- [0..n-1], let theta = fromIntegral i * (2 * pi / fromIntegral n) ]---- | An (imperfect) unit circle centered at the origin. Implemented as:------ > circle = regularPoly 24-circle :: Image Any-circle = regularPoly 24---- | A convex polygon given by the list of points.-convexPoly :: [R2] -> Image Any-convexPoly points@(_:_:_:_) = Image render' pick- where- render' tr _ =- withoutTextures . GL.renderPrimitive GL.Polygon $ mapM_ (GL.vertex . toVertex tr) points- pick p = Any $ all (sign . side p) edges- where- edges = zipWith (,) points (tail points)- side (x,y) ((x1,y1), (x2,y2)) = (y-y1)*(x2-x1) - (x-x1)*(y2-y1)- sign | side p (last points, head points) >= 0 = (>= 0)- | otherwise = (<= 0)-convexPoly _ = error "convexPoly must be given at least three points"---- | A Bezier curve given a list of control points. It is a curve--- that begins at the first point in the list, ends at the last one,--- and smoothly interpolates between the rest. It is the empty--- image ('mempty') if zero or one points are given.-bezierCurve :: [R2] -> Image Any-bezierCurve controlPoints = Image render' (const (Any False))- where- render' tr _ = do- let ps = map (toVertex3 0 tr) controlPoints- m <- GL.newMap1 (0,1) ps :: IO (GL.GLmap1 (GL.Vertex3) R)- GL.map1 GL.$= Just m- GL.mapGrid1 GL.$= (100, (0::R, 1))- GL.evalMesh1 GL.Line (1,100)--{------------------ Transformations-------------------}--infixr 1 %%---- | Transform an image by an 'Affine' transformation.------ > [[tr % im]] = [[im]] . inverse [[tr]]-(%%) :: Affine -> Image a -> Image a-tr' %% d = tr' `seq` Image render' pick- where- render' tr col = dRender d (tr `compose` tr') col- pick = dPick d . apply (inverse tr')---{------------- Colors--------------}---- | Color is defined in the usual computer graphics sense:--- a 4 vector containing red, green, blue, and alpha.------ The Monoid instance is given by alpha composition, described--- at @http:\/\/lukepalmer.wordpress.com\/2010\/02\/05\/associative-alpha-blending\/@------ In the semantcs the values @zero@ and @one@ are used, which are defined as:------ > zero = Color 0 0 0 0--- > one = Color 1 1 1 1-data Color = Color !R !R !R !R- deriving (Eq,Show)--instance Monoid Color where- mempty = Color 0 0 0 0- mappend (Color r g b a) (Color r' g' b' a') = Color (i r r') (i g g') (i b b') γ- where- γ = a + a' - a * a'- i | γ == 0 = \_ _ -> 0 -- imples a = a' = 0- | otherwise = \x y -> (a*x + (1-a)*a'*y)/γ--white :: Color-white = Color 1 1 1 1---- | Modulate two colors by each other.------ > modulate (Color r g b a) (Color r' g' b' a')--- > = Color (r*r') (g*g') (b*b') (a*a')-modulate :: Color -> Color -> Color-modulate (Color r g b a) (Color r' g' b' a') = Color (r*r') (g*g') (b*b') (a*a')---- | Tint an image by a color; i.e. modulate the colors of an image by--- a color.------ > [[tint c im]] = first (modulate c) . [[im]]--- > where first f (x,y) = (f x, y)-tint :: Color -> Image a -> Image a-tint c d = Image render' (dPick d)- where- render' tr col = do- let oldColor = col- newColor = modulate c col- setColor newColor- result <- dRender d tr newColor- setColor oldColor- return result- setColor (Color r g b a) = GL.color $ GL.Color4 r g b a---{-------------------------- Sprites (bitmap images)--------------------------}---- | A Sprite represents a finite bitmap image.------ > [[Sprite]] = [-1,1]^2 -> Color-data Sprite = Sprite { spriteObject :: GL.TextureObject }---- | Load an image from a file and create a sprite out of it.-openSprite :: FilePath -> IO Sprite-openSprite path = do- e <- Image.loadImage path- case e of- Left err -> fail err- Right bmp -> Sprite <$> Bitmap.makeSimpleBitmapTexture bmp---- | The image of a sprite at the origin.------ > [[sprite s]] p | p `elem` [-1,1]^2 = ([[s]] p, Any True)--- > | otherwise = (zero, Any False)-sprite :: Sprite -> Image Any-sprite spr = Image render' pick- where- render' tr _ = do- GL.texture GL.Texture2D GL.$= GL.Enabled- oldtex <- GL.get (GL.textureBinding GL.Texture2D)- GL.textureBinding GL.Texture2D GL.$= (Just $ spriteObject spr)- GL.renderPrimitive GL.Quads $ do- texcoord 0 0- GL.vertex $ toVertex tr (-1, 1)- texcoord 1 0- GL.vertex $ toVertex tr (1, 1)- texcoord 1 1- GL.vertex $ toVertex tr (1,-1)- texcoord 0 1- GL.vertex $ toVertex tr (-1,-1)- GL.textureBinding GL.Texture2D GL.$= oldtex- pick (x,y) | -1 <= x && x <= 1 && -1 <= y && y <= 1 = Any True- | otherwise = Any False- texcoord x y = GL.texCoord $ GL.TexCoord2 (x :: GL.GLdouble) (y :: GL.GLdouble)--{---------- Text----------}---- | The image representing some text rendered with a font. The baseline--- is at y=0, the text starts at x=0, and the height of a lowercase x is--- 1 unit.-text :: Font -> String -> Image Any-text font str = Image render' pick- where- render' tr _ = withMultGLmatrix tr $ renderText font str- pick (x,y)- | 0 <= x && x <= textWidth font str && 0 <= y && y <= 1 = Any True- | otherwise = Any False--#ifdef LAME_FONTS--data Font = Font--openFont :: String -> IO Font-openFont _ = do- inited <- GLUT.get GLUT.initState- unless inited $ GLUT.initialize "" [] >> return ()- return Font--renderText :: Font -> String -> IO ()-renderText Font str = do- GL.scale (1/64 :: GL.GLdouble) (1/64) 1- GLUT.renderString GLUT.Roman str--textWidth :: Font -> String -> R-textWidth Font str = (1/64) * fromIntegral (unsafePerformIO (GLUT.stringWidth GLUT.Roman str))--#else--data Font = Font { getFont :: FTGL.Font }--renderText :: Font -> String -> IO ()-renderText font str = do- GL.scale (1/36 :: GL.GLdouble) (1/36) 1- FTGL.renderFont (getFont font) str FTGL.All---- | Load a TTF font from a file.-openFont :: String -> IO Font-openFont path = do- font <- FTGL.createTextureFont path- addFinalizer font (FTGL.destroyFont font)- _ <- FTGL.setFontFaceSize font 72 72- return $ Font font---- | @textWidth font str@ is the width of the text in @text font str@.-textWidth :: Font -> String -> R-textWidth font str =- (/36) . realToFrac . unsafePerformIO $- FTGL.getFontAdvance (getFont font) str--#endif---- | Import an OpenGL action and pure sampler function into an Image.--- This ought to be a well-behaved, compositional action (make sure--- it responds to different initial ModelViews, don't change matrix--- modes or render or anything like that). The color given to the--- action is the current tint color; modulate all your colors by this--- before setting them.-unsafeOpenGLImage :: (Color -> IO ()) -> (R2 -> a) -> Image a-unsafeOpenGLImage draw pick = Image render' pick- where- render' tr col = GL.preservingAttrib [GL.AllServerAttributes] . withMultGLmatrix tr $ draw col
− Graphics/DrawingCombinators/Affine.hs
@@ -1,93 +0,0 @@-{- | An affine transformation is a linear transformation followed by-a translation; i.e. it is a function--> \x -> A*x + b--Where A is a linear transformation. Affine transformations are the-set of image transformations supported by Graphics.DrawingCombinators,-roughly translate, rotate, scale, and compositions thereof.--}--module Graphics.DrawingCombinators.Affine- ( R, R2, Affine- , compose, apply, identity, translate, rotate, scale, inverse- , multGLmatrix, withMultGLmatrix- )-where--import qualified Graphics.Rendering.OpenGL.GL as GL-import Data.Monoid--type R = GL.GLdouble-type R2 = (R,R)---- | An Affine transformation from R2 to R2.------ > [[Affine]] = R2 -> R2------ With the Monoid instance @(identity, compose)@-data Affine = M !R !R !R- !R !R !R- -- 0 0 1--instance Monoid Affine where- mempty = identity- mappend = compose---- | > [[compose a b]] = [[a]] . [[b]]-compose :: Affine -> Affine -> Affine-M x11 x12 x13 x21 x22 x23 `compose` M y11 y12 y13 y21 y22 y23 =- M (x11*y11+x12*y21) (x11*y12+x12*y22) (x11*y13+x12*y23+x13)- (x21*y11+x22*y21) (x21*y12+x22*y22) (x21*y13+x22*y23+x23)---- | > [[apply a]] = [[a]]-apply :: Affine -> R2 -> R2-apply (M x11 x12 x13 x21 x22 x23) (y1,y2) =- (x11*y1+x12*y2+x13, x21*y1+x22*y2+x23)---- | > [[identity]] = id-identity :: Affine-identity = M 1 0 0- 0 1 0---- | > [[inverse x]] = inverse [[x]]------ If the transformation is not invertible, this operation is--- undefined.-inverse :: Affine -> Affine-inverse (M x11 x12 x13 x21 x22 x23) =- M (s*x22) (-s*x12) (-s*x22*x13 + s*x12*x23)- (-s*x21) (s*x11) ( s*x21*x13 - s*x11*x23)- where- s = 1 / (x11*x22 - x12*x21)---- | > [[translate t]] x = [[t]] x + t-translate :: R2 -> Affine-translate (x,y) = M 1 0 x- 0 1 y---- | > [[rotate r]] (x,y) = (cos(r)x - sin(r)y, sin(r)x + cos(r)y)-rotate :: R -> Affine-rotate t = M cost (-sint) 0- sint cost 0- where- cost = cos t- sint = sin t---- | > [[scale xs ys]] (x,y) = (xs*x, ys*y)-scale :: R -> R -> Affine-scale x y = M x 0 0- 0 y 0---- | Multiply this Affine by the top of the OpenGL matrix stack.--- Don't mind this, it\'s an implementation detail.-multGLmatrix :: Affine -> IO ()-multGLmatrix (M x11 x12 x13 x21 x22 x23) = do- m <- GL.newMatrix GL.ColumnMajor [ x11 , x21 , 0 , 0- , x12 , x22 , 0 , 0- , 0 , 0 , 1 , 0- , x13 , x23 , 0 , 1 ]- GL.multMatrix (m :: GL.GLmatrix R)--withMultGLmatrix :: Affine -> IO a -> IO a-withMultGLmatrix m f = GL.preservingMatrix $ multGLmatrix m >> f
− Graphics/DrawingCombinators/Bitmap.hs
@@ -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 Nothing 0 pf pif 0 - --- | Creates a new OpenGL texture from a bitmap-makeTextureFromBitmap - :: PixelComponent t - => Bitmap t -> Maybe CubeMapTarget -> Level -> PixelFormat -> PixelInternalFormat -> Border -> IO TextureObject-makeTextureFromBitmap bm cubemap level pf pif border = do- old_binding <- get (textureBinding Texture2D)- [tex] <- genObjectNames 1 - textureBinding Texture2D $= Just tex - textureFilter Texture2D $= ((Linear',Nothing),Linear')- texImageFromBitmap bm cubemap level pf pif border - textureBinding Texture2D $= old_binding- return tex--texImageFromBitmap- :: forall t. PixelComponent t - => Bitmap t -> Maybe CubeMapTarget -> Level -> PixelFormat -> PixelInternalFormat -> Border -> IO ()-texImageFromBitmap bm cubemap 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 cubemap NoProxy level pif size border pdata--- rowLength Unpack $= old_rowlength - rowAlignment Unpack $= old_alignment- ---------------------------------------------------------------------------------
+ demo/example.hs view
@@ -0,0 +1,67 @@+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 System.Environment(getArgs)++resX, resY :: Int+resX = 640+resY = 480++initScreen :: IO ()+initScreen = do+ True <- GLFW.initialize+ True <- GLFW.openWindow GLFW.defaultDisplayOptions {+ GLFW.displayOptions_width = resX,+ GLFW.displayOptions_height = resY+ }++ return ()++unitText :: Draw.Font -> String -> Draw.Image Any+unitText font str = (Draw.translate (-1,0) %% Draw.scale (2/w) (2/w) %% Draw.text font str)+ `mappend`+ Draw.tint (Draw.Color 1 0 0 1) (Draw.line (-1,0) (1,0))+ where+ w = Draw.textWidth font str++quadrants :: (Monoid a) => Draw.Image a -> Draw.Image a+quadrants img = mconcat [+ (Draw.translate (-0.5,0.5) %%),+ (Draw.translate (0.5,0.5) `Draw.compose` Draw.rotate (-pi/2) %%),+ (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++main :: IO ()+main = do+ initScreen+ args <- getArgs+ font <- case args of+ [fontName] -> do+ font <- Draw.openFont fontName+ return font+ _ -> error "Usage: drawingcombinators-example some_font.ttf"+++ doneRef <- newIORef False+ GLFW.setWindowCloseCallback $ do+ writeIORef doneRef True+ return True+ waitClose doneRef $ quadrants (circleText font "Hello, World!")+ GLFW.terminate+ return ()+ where++ waitClose doneRef image = do+ isDone <- readIORef doneRef+ unless isDone $ do+ Draw.clearRender image+ GLFW.swapBuffers+ GLFW.pollEvents+ waitClose doneRef $ Draw.rotate (-0.01) %% image
− example.hs
@@ -1,67 +0,0 @@-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 System.Environment(getArgs)--resX, resY :: Int-resX = 640-resY = 480--initScreen :: IO ()-initScreen = do- True <- GLFW.initialize- True <- GLFW.openWindow GLFW.defaultDisplayOptions {- GLFW.displayOptions_width = resX,- GLFW.displayOptions_height = resY- }-- return ()--unitText :: Draw.Font -> String -> Draw.Image Any-unitText font str = (Draw.translate (-1,0) %% Draw.scale (2/w) (2/w) %% Draw.text font str)- `mappend`- Draw.tint (Draw.Color 1 0 0 1) (Draw.line (-1,0) (1,0))- where- w = Draw.textWidth font str--quadrants :: (Monoid a) => Draw.Image a -> Draw.Image a-quadrants img = mconcat [- (Draw.translate (-0.5,0.5) %%),- (Draw.translate (0.5,0.5) `Draw.compose` Draw.rotate (-pi/2) %%),- (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--main :: IO ()-main = do- initScreen- args <- getArgs- font <- case args of- [fontName] -> do- font <- Draw.openFont fontName- return font- _ -> error "Usage: drawingcombinators-example some_font.ttf"--- doneRef <- newIORef False- GLFW.setWindowCloseCallback $ do- writeIORef doneRef True- return True- waitClose doneRef $ quadrants (circleText font "Hello, World!")- GLFW.terminate- return ()- where-- waitClose doneRef image = do- isDone <- readIORef doneRef- unless isDone $ do- Draw.clearRender image- GLFW.swapBuffers- GLFW.pollEvents- waitClose doneRef $ Draw.rotate (-0.01) %% image
graphics-drawingcombinators.cabal view
@@ -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.4.4+Version: 1.4.4.1 Stability: experimental Synopsis: A functional interface to 2D drawing in OpenGL License: BSD3@@ -13,8 +13,8 @@ Homepage: http://github.com/luqui/graphics-drawingcombinators Maintainer: lrpalmer@gmail.com Build-Type: Simple-Extra-Source-Files: example.hs-cabal-Version: >= 1.6+Extra-Source-Files: demo/example.hs+cabal-Version: >= 1.8 source-repository head type: git@@ -24,14 +24,28 @@ Description: Does the system have FTGL, thus we could use not sucky fonts Library- Build-Depends: base == 4.*, containers, OpenGL >= 2.4 && < 2.7, stb-image == 0.2.*, bitmap >= 0.0.2+ Build-Depends: base == 4.*, OpenGL >= 2.2 && < 2.9, stb-image == 0.2.*, bitmap >= 0.0.2+ 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) Build-Depends: FTGL else Build-Depends: GLUT CPP-Options: -DLAME_FONTS++Flag examples+ Description: Build example programs+ Default: False++Executable example+ Main-is: demo/example.hs+ if !flag(examples)+ Buildable: False+ else+ Buildable: True+ Build-depends: base >= 3 && < 5,+ GLFW-b, OpenGL >= 2.2 && < 2.7, graphics-drawingcombinators+ ghc-options: -Wall
+ src/Graphics/DrawingCombinators.hs view
@@ -0,0 +1,412 @@+{-# LANGUAGE CPP #-}++--------------------------------------------------------------+-- |+-- Module : Graphics.DrawingCombinators+-- Copyright : (c) Luke Palmer 2008-2010+-- License : BSD3+--+-- Maintainer : Luke Palmer <lrpalmer@gmail.com>+-- Stability : experimental+-- Portability : tested on GHC only+--+-- Drawing combinators as a functional interface to 2D graphics using OpenGL.+--+-- This module is intended to be imported @qualified@, as in:+--+-- > import qualified Graphics.DrawingCombinators as Draw+--+-- Whenever possible, a /denotational semantics/ for operations in this library+-- is given. Read @[[x]]@ as \"the meaning of @x@\".+--+-- Intuitively, an 'Image' @a@ is an infinite plane of pairs of colors /and/+-- @a@\'s. The colors are what are drawn on the screen when you 'render', and+-- the @a@\'s are what you can recover from coordinates using 'sample'. The+-- latter allows you to tell, for example, what a user clicked on.+--+-- The following discussion is about the associated data. If you are only+-- interested in drawing, rather than mapping from coordinates to values, you+-- can ignore the following and just use 'mappend' and 'mconcat' to overlay images.+--+-- Wrangling the @a@\'s -- the associated data with each \"pixel\" -- is done+-- using the 'Functor', 'Applicative', and 'Monoid' instances.+--+-- The primitive @Image@s such as 'circle' and 'text' all return @Image Any@+-- objects. 'Any' is just a wrapper around 'Bool', with @(||)@ as its monoid+-- operator. So e.g. the points inside the circle will have the value @Any+-- True@, and those outside will have the value @Any False@. Returning @Any@+-- instead of plain @Bool@ allows you to use @Image@s as a monoid, e.g.+-- 'mappend' to overlay two images. But if you are doing anything with+-- sampling, you probably want to map this to something. Here is a drawing+-- with two circles that reports which one was hit:+--+-- > twoCircles :: Image String+-- > twoCircles = liftA2 test (translate (-1,0) %% circle) (translate (1,0) %% circle)+-- > where+-- > test (Any False) (Any False) = "Miss!"+-- > test (Any False) (Any True) = "Hit Right!"+-- > test (Any True) (Any False) = "Hit Left!"+-- > test (Any True) (Any True) = "Hit Both??!"+--+-- The last case would only be possible if the circles were overlapping.+--+-- Note, the area-less shapes such as 'point', 'line', and 'bezierCurve'+-- /always/ return @Any False@ when sampled, even if the exact same+-- coordinates are given. This is because miniscule floating-point error+-- can make these shapes very brittle under transformations. If you need+-- a point to be clickable, make it, for example, a very small box.+--------------------------------------------------------------++module Graphics.DrawingCombinators+ (+ module Graphics.DrawingCombinators.Affine+ -- * Basic types+ , Image, render, clearRender+ -- * Selection+ , sample+ -- * Geometry+ , point, line, regularPoly, circle, convexPoly, (%%), bezierCurve+ -- * Colors+ , Color(..), modulate, tint+ -- * Sprites (images from files)+ , Sprite, openSprite, sprite+ -- * Text+ , Font, openFont, text, textWidth+ -- * Extensions+ , unsafeOpenGLImage+ , Monoid(..), Any(..)+ )+where++import Graphics.DrawingCombinators.Affine+import Control.Applicative (Applicative(..), liftA2, (*>), (<$>))+import Data.Monoid (Monoid(..), Any(..))+import qualified Graphics.DrawingCombinators.Bitmap 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++#ifdef LAME_FONTS+import qualified Graphics.UI.GLUT as GLUT+import Control.Monad (unless)+#else+import qualified Graphics.Rendering.FTGL as FTGL+import System.Mem.Weak (addFinalizer)+#endif++type Renderer = Affine -> Color -> IO ()+type Picker a = R2 -> a++-- | The type of images.+--+-- > [[Image a]] = R2 -> (Color, a)+--+-- The semantics of the instances are all consistent with /type class morphism/.+-- I.e. Functor, Applicative, and Monoid act point-wise, using the 'Color' monoid+-- described below.+data Image a = Image { dRender :: Renderer+ , dPick :: Picker a+ }++instance Functor Image where+ fmap f d = Image {+ dRender = dRender d,+ dPick = fmap f (dPick d)+ }++instance Applicative Image where+ pure x = Image {+ dRender = (pure.pure.pure) (),+ dPick = const x+ }++ df <*> dx = Image {+ -- reversed so that things that come first go on top+ dRender = (liftA2.liftA2) (*>) (dRender dx) (dRender df),+ dPick = dPick df <*> dPick dx+ }++instance (Monoid m) => Monoid (Image m) where+ mempty = pure mempty+ mappend = liftA2 mappend++-- |Draw an Image on the screen in the current OpenGL coordinate+-- system (which, in absense of information, is (-1,-1) in the+-- lower left and (1,1) in the upper right).+render :: Image a -> IO ()+render d = GL.preservingAttrib [GL.AllServerAttributes] $ do+ GL.blend GL.$= GL.Enabled+ GL.blendFunc GL.$= (GL.SrcAlpha, GL.OneMinusSrcAlpha)+ -- For now we assume the user wants antialiasing; the general solution is not clear - maybe let the+ -- user do the opengl setup stuff himself? otherwise need to wrap all of the possible things GL lets+ -- you set.+ GL.polygonSmooth GL.$= GL.Enabled+ GL.lineSmooth GL.$= GL.Enabled+ GL.lineWidth GL.$= 1.5+ GL.hint GL.LineSmooth GL.$= GL.DontCare++ dRender d identity white++-- |Like 'render', but clears the screen first. This is so+-- you can use this module and pretend that OpenGL doesn't+-- exist at all.+clearRender :: Image a -> IO ()+clearRender d = do+ GL.clear [GL.ColorBuffer]+ render d++-- | Sample the value of the image at a point.+--+-- > [[sample i p]] = snd ([[i]] p)+sample :: Image a -> R2 -> a+sample = dPick++{----------------+ Geometry+-----------------}++toVertex :: Affine -> R2 -> GL.Vertex2 GL.GLdouble+toVertex tr p = let (x,y) = tr `apply` p in GL.Vertex2 x y++toVertex3 :: R -> Affine -> R2 -> GL.Vertex3 GL.GLdouble+toVertex3 z tr p = let (x,y) = tr `apply` p in GL.Vertex3 x y z++-- | A single \"pixel\" at the specified point.+--+-- > [[point p]] r | [[r]] == [[p]] = (one, Any True)+-- > | otherwise = (zero, Any False)+point :: R2 -> Image Any+point p = Image render' (const (Any False))+ where+ render' tr _ = withoutTextures . GL.renderPrimitive GL.Points . GL.vertex $ toVertex tr p++withoutTextures :: IO a -> IO a+withoutTextures action =+ GL.texture GL.Texture2D GL.$= GL.Disabled >> action++-- | A line connecting the two given points.+line :: R2 -> R2 -> Image Any+line src dest = Image render' (const (Any False))+ where+ render' tr _ = withoutTextures . GL.renderPrimitive GL.Lines $ do+ GL.vertex $ toVertex tr src+ GL.vertex $ toVertex tr dest+++-- | A regular polygon centered at the origin with n sides.+regularPoly :: Int -> Image Any+regularPoly n = convexPoly [ (cos theta, sin theta) | i <- [0..n-1], let theta = fromIntegral i * (2 * pi / fromIntegral n) ]++-- | An (imperfect) unit circle centered at the origin. Implemented as:+--+-- > circle = regularPoly 24+circle :: Image Any+circle = regularPoly 24++-- | A convex polygon given by the list of points.+convexPoly :: [R2] -> Image Any+convexPoly points@(_:_:_:_) = Image render' pick+ where+ render' tr _ =+ withoutTextures . GL.renderPrimitive GL.Polygon $ mapM_ (GL.vertex . toVertex tr) points+ pick p = Any $ all (sign . side p) edges+ where+ edges = zipWith (,) points (tail points)+ side (x,y) ((x1,y1), (x2,y2)) = (y-y1)*(x2-x1) - (x-x1)*(y2-y1)+ sign | side p (last points, head points) >= 0 = (>= 0)+ | otherwise = (<= 0)+convexPoly _ = error "convexPoly must be given at least three points"++-- | A Bezier curve given a list of control points. It is a curve+-- that begins at the first point in the list, ends at the last one,+-- and smoothly interpolates between the rest. It is the empty+-- image ('mempty') if zero or one points are given.+bezierCurve :: [R2] -> Image Any+bezierCurve controlPoints = Image render' (const (Any False))+ where+ render' tr _ = do+ let ps = map (toVertex3 0 tr) controlPoints+ m <- GL.newMap1 (0,1) ps :: IO (GL.GLmap1 (GL.Vertex3) R)+ GL.map1 GL.$= Just m+ GL.mapGrid1 GL.$= (100, (0::R, 1))+ GL.evalMesh1 GL.Line (1,100)++{-----------------+ Transformations+------------------}++infixr 1 %%++-- | Transform an image by an 'Affine' transformation.+--+-- > [[tr % im]] = [[im]] . inverse [[tr]]+(%%) :: Affine -> Image a -> Image a+tr' %% d = tr' `seq` Image render' pick+ where+ render' tr col = dRender d (tr `compose` tr') col+ pick = dPick d . apply (inverse tr')+++{------------+ Colors+-------------}++-- | Color is defined in the usual computer graphics sense:+-- a 4 vector containing red, green, blue, and alpha.+--+-- The Monoid instance is given by alpha composition, described+-- at @http:\/\/lukepalmer.wordpress.com\/2010\/02\/05\/associative-alpha-blending\/@+--+-- In the semantcs the values @zero@ and @one@ are used, which are defined as:+--+-- > zero = Color 0 0 0 0+-- > one = Color 1 1 1 1+data Color = Color !R !R !R !R+ deriving (Eq,Show)++instance Monoid Color where+ mempty = Color 0 0 0 0+ mappend (Color r g b a) (Color r' g' b' a') = Color (i r r') (i g g') (i b b') γ+ where+ γ = a + a' - a * a'+ i | γ == 0 = \_ _ -> 0 -- imples a = a' = 0+ | otherwise = \x y -> (a*x + (1-a)*a'*y)/γ++white :: Color+white = Color 1 1 1 1++-- | Modulate two colors by each other.+--+-- > modulate (Color r g b a) (Color r' g' b' a')+-- > = Color (r*r') (g*g') (b*b') (a*a')+modulate :: Color -> Color -> Color+modulate (Color r g b a) (Color r' g' b' a') = Color (r*r') (g*g') (b*b') (a*a')++-- | Tint an image by a color; i.e. modulate the colors of an image by+-- a color.+--+-- > [[tint c im]] = first (modulate c) . [[im]]+-- > where first f (x,y) = (f x, y)+tint :: Color -> Image a -> Image a+tint c d = Image render' (dPick d)+ where+ render' tr col = do+ let oldColor = col+ newColor = modulate c col+ setColor newColor+ result <- dRender d tr newColor+ setColor oldColor+ return result+ setColor (Color r g b a) = GL.color $ GL.Color4 r g b a+++{-------------------------+ Sprites (bitmap images)+-------------------------}++-- | A Sprite represents a finite bitmap image.+--+-- > [[Sprite]] = [-1,1]^2 -> Color+data Sprite = Sprite { spriteObject :: GL.TextureObject }++-- | Load an image from a file and create a sprite out of it.+openSprite :: FilePath -> IO Sprite+openSprite path = do+ e <- Image.loadImage path+ case e of+ Left err -> fail err+ Right bmp -> Sprite <$> Bitmap.makeSimpleBitmapTexture bmp++-- | The image of a sprite at the origin.+--+-- > [[sprite s]] p | p `elem` [-1,1]^2 = ([[s]] p, Any True)+-- > | otherwise = (zero, Any False)+sprite :: Sprite -> Image Any+sprite spr = Image render' pick+ where+ render' tr _ = do+ GL.texture GL.Texture2D GL.$= GL.Enabled+ oldtex <- GL.get (GL.textureBinding GL.Texture2D)+ GL.textureBinding GL.Texture2D GL.$= (Just $ spriteObject spr)+ GL.renderPrimitive GL.Quads $ do+ texcoord 0 0+ GL.vertex $ toVertex tr (-1, 1)+ texcoord 1 0+ GL.vertex $ toVertex tr (1, 1)+ texcoord 1 1+ GL.vertex $ toVertex tr (1,-1)+ texcoord 0 1+ GL.vertex $ toVertex tr (-1,-1)+ GL.textureBinding GL.Texture2D GL.$= oldtex+ pick (x,y) | -1 <= x && x <= 1 && -1 <= y && y <= 1 = Any True+ | otherwise = Any False+ texcoord x y = GL.texCoord $ GL.TexCoord2 (x :: GL.GLdouble) (y :: GL.GLdouble)++{---------+ Text+---------}++-- | The image representing some text rendered with a font. The baseline+-- is at y=0, the text starts at x=0, and the height of a lowercase x is+-- 1 unit.+text :: Font -> String -> Image Any+text font str = Image render' pick+ where+ render' tr _ = withMultGLmatrix tr $ renderText font str+ pick (x,y)+ | 0 <= x && x <= textWidth font str && 0 <= y && y <= 1 = Any True+ | otherwise = Any False++#ifdef LAME_FONTS++data Font = Font++openFont :: String -> IO Font+openFont _ = do+ inited <- GLUT.get GLUT.initState+ unless inited $ GLUT.initialize "" [] >> return ()+ return Font++renderText :: Font -> String -> IO ()+renderText Font str = do+ GL.scale (1/64 :: GL.GLdouble) (1/64) 1+ GLUT.renderString GLUT.Roman str++textWidth :: Font -> String -> R+textWidth Font str = (1/64) * fromIntegral (unsafePerformIO (GLUT.stringWidth GLUT.Roman str))++#else++data Font = Font { getFont :: FTGL.Font }++renderText :: Font -> String -> IO ()+renderText font str = do+ GL.scale (1/36 :: GL.GLdouble) (1/36) 1+ FTGL.renderFont (getFont font) str FTGL.All++-- | Load a TTF font from a file.+openFont :: String -> IO Font+openFont path = do+ font <- FTGL.createTextureFont path+ addFinalizer font (FTGL.destroyFont font)+ _ <- FTGL.setFontFaceSize font 72 72+ return $ Font font++-- | @textWidth font str@ is the width of the text in @text font str@.+textWidth :: Font -> String -> R+textWidth font str =+ (/36) . realToFrac . unsafePerformIO $+ FTGL.getFontAdvance (getFont font) str++#endif++-- | Import an OpenGL action and pure sampler function into an Image.+-- This ought to be a well-behaved, compositional action (make sure+-- it responds to different initial ModelViews, don't change matrix+-- modes or render or anything like that). The color given to the+-- action is the current tint color; modulate all your colors by this+-- before setting them.+unsafeOpenGLImage :: (Color -> IO ()) -> (R2 -> a) -> Image a+unsafeOpenGLImage draw pick = Image render' pick+ where+ render' tr col = GL.preservingAttrib [GL.AllServerAttributes] . withMultGLmatrix tr $ draw col
+ src/Graphics/DrawingCombinators/Affine.hs view
@@ -0,0 +1,93 @@+{- | An affine transformation is a linear transformation followed by+a translation; i.e. it is a function++> \x -> A*x + b++Where A is a linear transformation. Affine transformations are the+set of image transformations supported by Graphics.DrawingCombinators,+roughly translate, rotate, scale, and compositions thereof.+-}++module Graphics.DrawingCombinators.Affine+ ( R, R2, Affine+ , compose, apply, identity, translate, rotate, scale, inverse+ , multGLmatrix, withMultGLmatrix+ )+where++import qualified Graphics.Rendering.OpenGL.GL as GL+import Data.Monoid++type R = GL.GLdouble+type R2 = (R,R)++-- | An Affine transformation from R2 to R2.+--+-- > [[Affine]] = R2 -> R2+--+-- With the Monoid instance @(identity, compose)@+data Affine = M !R !R !R+ !R !R !R+ -- 0 0 1++instance Monoid Affine where+ mempty = identity+ mappend = compose++-- | > [[compose a b]] = [[a]] . [[b]]+compose :: Affine -> Affine -> Affine+M x11 x12 x13 x21 x22 x23 `compose` M y11 y12 y13 y21 y22 y23 =+ M (x11*y11+x12*y21) (x11*y12+x12*y22) (x11*y13+x12*y23+x13)+ (x21*y11+x22*y21) (x21*y12+x22*y22) (x21*y13+x22*y23+x23)++-- | > [[apply a]] = [[a]]+apply :: Affine -> R2 -> R2+apply (M x11 x12 x13 x21 x22 x23) (y1,y2) =+ (x11*y1+x12*y2+x13, x21*y1+x22*y2+x23)++-- | > [[identity]] = id+identity :: Affine+identity = M 1 0 0+ 0 1 0++-- | > [[inverse x]] = inverse [[x]]+--+-- If the transformation is not invertible, this operation is+-- undefined.+inverse :: Affine -> Affine+inverse (M x11 x12 x13 x21 x22 x23) =+ M (s*x22) (-s*x12) (-s*x22*x13 + s*x12*x23)+ (-s*x21) (s*x11) ( s*x21*x13 - s*x11*x23)+ where+ s = 1 / (x11*x22 - x12*x21)++-- | > [[translate t]] x = [[t]] x + t+translate :: R2 -> Affine+translate (x,y) = M 1 0 x+ 0 1 y++-- | > [[rotate r]] (x,y) = (cos(r)x - sin(r)y, sin(r)x + cos(r)y)+rotate :: R -> Affine+rotate t = M cost (-sint) 0+ sint cost 0+ where+ cost = cos t+ sint = sin t++-- | > [[scale xs ys]] (x,y) = (xs*x, ys*y)+scale :: R -> R -> Affine+scale x y = M x 0 0+ 0 y 0++-- | Multiply this Affine by the top of the OpenGL matrix stack.+-- Don't mind this, it\'s an implementation detail.+multGLmatrix :: Affine -> IO ()+multGLmatrix (M x11 x12 x13 x21 x22 x23) = do+ m <- GL.newMatrix GL.ColumnMajor [ x11 , x21 , 0 , 0+ , x12 , x22 , 0 , 0+ , 0 , 0 , 1 , 0+ , x13 , x23 , 0 , 1 ]+ GL.multMatrix (m :: GL.GLmatrix R)++withMultGLmatrix :: Affine -> IO a -> IO a+withMultGLmatrix m f = GL.preservingMatrix $ multGLmatrix m >> f
+ src/Graphics/DrawingCombinators/Bitmap.hs view
@@ -0,0 +1,88 @@+-- | 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 Nothing 0 pf pif 0 + +-- | Creates a new OpenGL texture from a bitmap+makeTextureFromBitmap + :: PixelComponent t + => Bitmap t -> Maybe CubeMapTarget -> Level -> PixelFormat -> PixelInternalFormat -> Border -> IO TextureObject+makeTextureFromBitmap bm cubemap level pf pif border = do+ old_binding <- get (textureBinding Texture2D)+ [tex] <- genObjectNames 1 + textureBinding Texture2D $= Just tex + textureFilter Texture2D $= ((Linear',Nothing),Linear')+ texImageFromBitmap bm cubemap level pf pif border + textureBinding Texture2D $= old_binding+ return tex++texImageFromBitmap+ :: forall t. PixelComponent t + => Bitmap t -> Maybe CubeMapTarget -> Level -> PixelFormat -> PixelInternalFormat -> Border -> IO ()+texImageFromBitmap bm cubemap 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 cubemap NoProxy level pif size border pdata+-- rowLength Unpack $= old_rowlength + rowAlignment Unpack $= old_alignment+ +--------------------------------------------------------------------------------