module Graphics.DrawingCombinators
(
module Graphics.DrawingCombinators.Affine
, Image, render, clearRender
, sample
, init
, point, line, regularPoly, circle, convexPoly, (%%)
, Color(..), modulate, tint
, Sprite, SpriteScaling(..), surfaceToSprite, imageToSprite, sprite
, 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)
type Renderer = Affine -> Color -> IO ()
type Picker a = Affine -> GL.GLuint -> IO (GL.GLuint, Set.Set GL.GLuint -> 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 {
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
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
clearRender :: Image a -> IO ()
clearRender d = do
GL.clear [GL.ColorBuffer]
render d
selectRegion :: R2 -> R2 -> Image a -> IO a
selectRegion ll ur drawing = do
(lookup, recs) <- GL.getHitRecords 64 $ do
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 :: R2 -> Image a -> IO a
sample (px,py) = selectRegion (pxe,pye) (px+e,py+e)
where
e = 1/1024
init :: IO ()
init = do
wasinit <- TTF.wasInit
when (not wasinit) $ do
success <- TTF.init
when (not success) $ fail "SDL_ttf initialization failed"
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)
point :: R2 -> Image Any
point p = Image render (picker render)
where
render tr col = GL.renderPrimitive GL.Points . GL.vertex $ toVertex tr p
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
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)
circle :: Image Any
circle = regularPoly 24
convexPoly :: [R2] -> Image Any
convexPoly points = Image render (picker render)
where
render tr col =
GL.renderPrimitive GL.Polygon $
mapM_ (GL.vertex . toVertex tr) points
infixr 1 %%
(%%) :: 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
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 + (1a)*y
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 :: 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
data Sprite = Sprite { spriteObject :: GL.TextureObject
, spriteWidthRat :: R
, spriteHeightRat :: R
, spriteWidth :: R
, spriteHeight :: R
}
textureHack :: IORef [GL.GLuint]
textureHack = unsafePerformIO $ newIORef [1..]
allocateTexture :: IO GL.TextureObject
allocateTexture = do
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,()))
data SpriteScaling
= ScaleMax
| ScaleWidth
| ScaleHeight
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')
(GL.TextureSize2D
(fromIntegral $ SDL.surfaceGetWidth surf')
(fromIntegral $ SDL.surfaceGetHeight surf'))
0
(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
imageToSprite :: SpriteScaling -> FilePath -> IO Sprite
imageToSprite scaling path = Image.load path >>= surfaceToSprite scaling
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
data Font = Font { getFont :: TTF.Font }
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
text :: Font -> String -> Image Any
text font str = sprite $ unsafePerformIO $ textSprite font str