-------------------------------------------------------------- -- | -- Module : Graphics.DrawingCombinators -- Copyright : (c) Luke Palmer 2008-2010 -- License : BSD3 -- -- Maintainer : Luke Palmer -- Stability : experimental -- Portability : needs GADTs and rank n types -- -- Drawing combinators as a functional interface to OpenGL -- (for 2D drawings only... for now). -- -- This module is intended to be imported @qualified@, as in: -- -- > import Graphics.DrawingCombinators as Draw -- -- It is recommended that you use this module in combination -- with SDL; it has not been tested in any other environments. -- For some reason the GL picking stuff ('sample') crashes GHCi, -- but it works okay compiled. -------------------------------------------------------------- module Graphics.DrawingCombinators ( module Graphics.DrawingCombinators.Affine -- * Basic types , Image, render, clearRender -- * Selection , sample -- * Initialization , init -- * Geometry -- -- $geometry , point, line, regularPoly, circle, convexPoly, (%%) -- * Colors , Color(..), modulate, tint -- * Sprites (images from files) , Sprite, SpriteScaling(..), surfaceToSprite, imageToSprite, sprite -- * Text , Font, openFont, text ) where import Prelude hiding (init) import Graphics.DrawingCombinators.Affine import Control.Applicative (Applicative(..), liftA2, (*>)) import Control.Monad (when, forM_) import Data.Monoid (Monoid(..), Any(..)) import System.Mem.Weak (addFinalizer) import qualified Data.Set as Set import qualified Graphics.Rendering.OpenGL.GL as GL import qualified Graphics.Rendering.OpenGL.GLU as GLU import qualified Graphics.UI.SDL as SDL import qualified Graphics.UI.SDL.Image as Image import qualified Graphics.UI.SDL.TTF as TTF import Data.IORef (IORef, newIORef, atomicModifyIORef) import System.IO.Unsafe (unsafePerformIO) -- for hacking around OpenGL bug :-( type Renderer = Affine -> Color -> IO () type Picker a = Affine -> GL.GLuint -> IO (GL.GLuint, Set.Set GL.GLuint -> a) -- | The type of images. -- -- > [[Image a]] = R2 -> (Color, a) data Image a = Image { dRender :: Renderer , dPick :: Picker a } instance Functor Image where fmap f d = Image { dRender = dRender d, dPick = (fmap.fmap.fmap.fmap.fmap) f (dPick d) } instance Applicative Image where pure x = Image { dRender = (pure.pure.pure) (), dPick = \tr z -> pure (z, const x) } df <*> dx = Image { -- reversed so that things that come first go on top dRender = (liftA2.liftA2) (*>) (dRender dx) (dRender df), dPick = \tr z -> do (z', m') <- dPick dx tr z (z'', m) <- dPick df tr z' return (z'', m <*> m') } 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 = do GL.preservingAttrib [GL.AllServerAttributes] $ do GL.texture GL.Texture2D GL.$= GL.Enabled GL.blend GL.$= GL.Enabled GL.blendFunc GL.$= (GL.SrcAlpha, GL.OneMinusSrcAlpha) GL.depthFunc GL.$= Nothing dRender d identity mempty -- |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 -- | Given a bounding box, lower left and upper right in the default coordinate -- system (-1,-1) to (1,1), return the topmost drawing's value (with respect to -- @`over`@) intersecting that bounding box. selectRegion :: R2 -> R2 -> Image a -> IO a selectRegion ll ur drawing = do (lookup, recs) <- GL.getHitRecords 64 $ do -- XXX hard coded crap GL.preservingMatrix $ do GLU.ortho2D (fst ll) (fst ur) (snd ll) (snd ur) (_, lookup) <- dPick drawing identity 0 return lookup let nameList = concatMap (\(GL.HitRecord _ _ ns) -> ns) (maybe [] id recs) let nameSet = Set.fromList $ map (\(GL.Name n) -> n) nameList return $ lookup nameSet -- | Sample the value of the image at a point. -- -- > [[sample p i]] = snd ([[i]] [[p]]) sample :: R2 -> Image a -> IO a sample (px,py) = selectRegion (px-e,py-e) (px+e,py+e) where e = 1/1024 {---------------- Initialization ----------------} -- |Perform initialization of the library. This can throw an exception. init :: IO () init = do wasinit <- TTF.wasInit when (not wasinit) $ do success <- TTF.init when (not success) $ fail "SDL_ttf initialization failed" {---------------- Geometry -----------------} -- $geometry -- The geomertic combinators all return an 'Image' 'Any'. 'Any' -- is a wrapper around 'Bool' with @(False, (||))@ as its 'Monoid'. -- This is so you can use the 'Monoid' instance on 'Image' to -- automatically get the union of primitives. So: -- -- > circle `mappend` (translate (1,0) %% circle) -- -- Will have the value @Any True@ when /either/ of the circles is -- sampled. To extract the Bool, use 'getAny', or pattern match -- on @Any True@ and @Any False@ instead of @True@ and @False@. toVertex :: Affine -> R2 -> GL.Vertex2 GL.GLdouble toVertex tr p = let (x,y) = tr `apply` p in GL.Vertex2 x y inSet :: (Ord a) => a -> Set.Set a -> Any inSet x s = Any (x `Set.member` s) picker :: Renderer -> Picker Any picker r tr z = z `seq` do GL.withName (GL.Name z) (r tr mempty) return (z+1, inSet 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 (picker render) where render tr col = GL.renderPrimitive GL.Points . GL.vertex $ toVertex tr p -- | A line connecting the two given points. line :: R2 -> R2 -> Image Any line src dest = Image render (picker render) where render tr col = 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 = Image render (picker render) where render tr col = do let scaler = 2 * pi / fromIntegral n GL.renderPrimitive GL.TriangleFan $ do GL.vertex $ toVertex tr (0,0) forM_ [0..n] $ \s -> do let theta = scaler * fromIntegral s GL.vertex $ toVertex tr (cos theta, sin theta) -- | 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 (picker render) where render tr col = GL.renderPrimitive GL.Polygon $ mapM_ (GL.vertex . toVertex tr) points {----------------- Transformations ------------------} infixr 1 %% -- | Transform an image by an 'Affine' transformation. -- -- > [[tr % im]] = [[im]] . inverse [[tr]] (%%) :: Affine -> Image a -> Image a tr' %% d = Image render pick where render tr col = dRender d (tr `compose` tr') col pick tr z = dPick d (tr `compose` tr') z {------------ Colors -------------} -- | Color is defined in the usual computer graphics sense, of -- a 4 vector containing red, green, blue, and alpha. -- -- The Monoid instance is given by alpha transparency blending, -- so: -- -- > mempty = Color 1 1 1 1 -- > mappend c@(Color _ _ _ a) c'@(Color _ _ _ a') = a*c + (1-a)*c' -- -- Where multiplication is componentwise. 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 instance Monoid Color where mempty = Color 1 1 1 1 mappend (Color r g b a) (Color r' g' b' a') = Color (i r r') (i g g') (i b b') (i a a') where i x y = a*x + (1-a)*y -- | 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 bitmap image. -- -- > [[Sprite]] = [-1,1]^2 -> Color data Sprite = Sprite { spriteObject :: GL.TextureObject , spriteWidthRat :: R , spriteHeightRat :: R , spriteWidth :: R , spriteHeight :: R } -- FUUUUUUUUUCKKK Why doesn't glGenTextures work!!?? -- Anyway here is me hacking around it... textureHack :: IORef [GL.GLuint] textureHack = unsafePerformIO $ newIORef [1..] allocateTexture :: IO GL.TextureObject allocateTexture = do {- -- This is how it *should* be done. wtf is going on!? [obj] <- GL.genObjectNames 1 good <- GL.isObjectName obj unless good $ fail "Failed to generate valid object wtf!" return obj -} b <- atomicModifyIORef textureHack (\(x:xs) -> (xs,x)) return $ GL.TextureObject b freeTexture :: GL.TextureObject -> IO () freeTexture (GL.TextureObject b) = do GL.deleteObjectNames [GL.TextureObject b] atomicModifyIORef textureHack (\xs -> (b:xs,())) -- | Indicate how a non-square image is to be mapped to a sprite. data SpriteScaling -- | ScaleMax will set the maximum of the height and width of the image to 1. = ScaleMax -- | ScaleWidth will set the width of the image to 1, and scale the height appropriately. | ScaleWidth -- | ScaleHeight will set the height of the image to 1, and scale the width appropriately. | ScaleHeight -- | Convert an SDL.Surface to a Sprite. surfaceToSprite :: SpriteScaling -> SDL.Surface -> IO Sprite surfaceToSprite scaling surf = do surf' <- padSurface surf obj <- allocateTexture oldtex <- GL.get (GL.textureBinding GL.Texture2D) GL.textureBinding GL.Texture2D GL.$= Just obj pixels <- SDL.surfaceGetPixels surf' bytesPerPixel <- SDL.pixelFormatGetBytesPerPixel (SDL.surfaceGetPixelFormat surf') let pixelFormat = case bytesPerPixel of 3 -> GL.RGB 4 -> GL.RGBA GL.textureFunction GL.$= GL.Modulate GL.textureFilter GL.Texture2D GL.$= ((GL.Linear', Nothing), GL.Linear') GL.textureWrapMode GL.Texture2D GL.S GL.$= (GL.Mirrored, GL.Repeat) GL.textureWrapMode GL.Texture2D GL.T GL.$= (GL.Mirrored, GL.Repeat) GL.texImage2D Nothing GL.NoProxy 0 (GL.RGBA') -- ? proxy level internalformat (GL.TextureSize2D (fromIntegral $ SDL.surfaceGetWidth surf') (fromIntegral $ SDL.surfaceGetHeight surf')) 0 -- border (GL.PixelData pixelFormat GL.UnsignedByte pixels) GL.textureBinding GL.Texture2D GL.$= oldtex let (w,w') = (SDL.surfaceGetWidth surf, SDL.surfaceGetWidth surf') (h,h') = (SDL.surfaceGetHeight surf, SDL.surfaceGetHeight surf') let (scalew, scaleh) = scaleFunc w h let sprite = Sprite { spriteObject = obj , spriteWidthRat = fromIntegral w / fromIntegral w' , spriteHeightRat = fromIntegral h / fromIntegral h' , spriteWidth = scalew , spriteHeight = scaleh } addFinalizer sprite $ do freeTexture obj return sprite where scaleFunc w h = case scaling of ScaleMax -> ( fromIntegral w / fromIntegral (max w h) , fromIntegral h / fromIntegral (max w h) ) ScaleWidth -> ( 1, fromIntegral h / fromIntegral w ) ScaleHeight -> ( fromIntegral w / fromIntegral h, 1 ) nextPowerOf2 x = head $ dropWhile (< x) $ iterate (*2) 1 isPowerOf2 x = x == nextPowerOf2 x padSurface :: SDL.Surface -> IO SDL.Surface padSurface surf | newWidth == oldWidth && newHeight == oldHeight = return surf | otherwise = do surf' <- SDL.createRGBSurfaceEndian [] newWidth newHeight 32 SDL.setAlpha surf [] 0xff SDL.blitSurface surf Nothing surf' Nothing return surf' where oldWidth = SDL.surfaceGetWidth surf oldHeight = SDL.surfaceGetHeight surf newWidth = nextPowerOf2 oldWidth newHeight = nextPowerOf2 oldHeight -- | Load an image from a file and create a sprite out of it. imageToSprite :: SpriteScaling -> FilePath -> IO Sprite imageToSprite scaling path = Image.load path >>= surfaceToSprite scaling -- | 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 (picker render) where render tr colt = do oldtex <- GL.get (GL.textureBinding GL.Texture2D) GL.textureBinding GL.Texture2D GL.$= (Just $ spriteObject spr) GL.renderPrimitive GL.Quads $ do let (xofs, yofs) = (0.5 * spriteWidth spr, 0.5 * spriteHeight spr) (xrat, yrat) = (spriteWidthRat spr, spriteHeightRat spr) GL.texCoord $ GL.TexCoord2 0 (0 :: GL.GLdouble) GL.vertex $ toVertex tr (-xofs, yofs) GL.texCoord $ GL.TexCoord2 xrat 0 GL.vertex $ toVertex tr (xofs, yofs) GL.texCoord $ GL.TexCoord2 xrat yrat GL.vertex $ toVertex tr (xofs,-yofs) GL.texCoord $ GL.TexCoord2 0 yrat GL.vertex $ toVertex tr (-xofs,-yofs) GL.textureBinding GL.Texture2D GL.$= oldtex {--------- Text ---------} data Font = Font { getFont :: TTF.Font } -- | Load a TTF font from a file with the given point size (higher numbers -- mean smoother text but more expensive rendering). openFont :: String -> Int -> IO Font openFont path res = do font <- TTF.openFont path res let font' = Font font return font' textSprite :: Font -> String -> IO Sprite textSprite font str = do surf <- TTF.renderTextBlended (getFont font) str (SDL.Color 255 255 255) surfaceToSprite ScaleHeight surf -- | The image representing some text rendered with a font. The resulting -- string will have height 1. text :: Font -> String -> Image Any text font str = sprite $ unsafePerformIO $ textSprite font str