module Graphics.DrawingCombinators
(
module Graphics.DrawingCombinators.Affine
, Image, render, clearRender
, sample
, point, line, regularPoly, circle, convexPoly, (%%), bezierCurve
, Color(..), modulate, tint
, Sprite, openSprite, sprite
, Font, openFont, text, textWidth
)
where
import Graphics.DrawingCombinators.Affine
import Control.Applicative (Applicative(..), liftA2, (*>), (<$>))
import Data.Maybe(fromMaybe)
import Control.Monad (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 Codec.Image.STB as Image
import qualified Data.Bitmap.OpenGL as Bitmap
import qualified Graphics.Rendering.FTGL as FTGL
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 = \_ 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 = 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.polygonSmooth GL.$= GL.Enabled
GL.lineSmooth GL.$= GL.Enabled
GL.lineWidth GL.$= 1.5
GL.hint GL.LineSmooth GL.$= GL.DontCare
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 $
GL.preservingMatrix $ do
GL.loadIdentity
GLU.ortho2D (fst ll) (fst ur) (snd ll) (snd ur)
(_, lookup') <- dPick drawing identity 0
return lookup'
let nameList = concatMap (\(GL.HitRecord _ _ ns) -> ns) (fromMaybe [] recs)
let nameSet = Set.fromList $ map (\(GL.Name n) -> n) nameList
return $ lookup' nameSet
sample :: Image a -> R2 -> IO a
sample im (px,py) = selectRegion (pxe,pye) (px+e,py+e) im
where
e = 1/1024
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
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)
rendererImage :: Renderer -> Image Any
rendererImage f = Image f (picker f)
point :: R2 -> Image Any
point p = rendererImage $ \tr _ -> do
GL.renderPrimitive GL.Points . GL.vertex $ toVertex tr p
line :: R2 -> R2 -> Image Any
line src dest = rendererImage $ \tr _ -> do
GL.renderPrimitive GL.Lines $ do
GL.vertex $ toVertex tr src
GL.vertex $ toVertex tr dest
regularPoly :: Integral a => a -> Image Any
regularPoly n = rendererImage $ \tr _ -> 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 :: Int)
convexPoly :: [R2] -> Image Any
convexPoly points = rendererImage $ \tr _ -> do
GL.renderPrimitive GL.Polygon $
mapM_ (GL.vertex . toVertex tr) points
bezierCurve :: [R2] -> Image Any
bezierCurve controlPoints = rendererImage $ \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)
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 }
openSprite :: FilePath -> IO Sprite
openSprite path = do
e <- Image.loadImage path
case e of
Left err -> fail err
Right bmp -> Sprite <$> Bitmap.makeSimpleBitmapTexture bmp
sprite :: Sprite -> Image Any
sprite spr = rendererImage $ \tr _ -> do
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
where
texcoord x y = GL.texCoord $ GL.TexCoord2 (x :: GL.GLdouble) (y :: GL.GLdouble)
data Font = Font { getFont :: FTGL.Font }
openFont :: String -> IO Font
openFont path = do
font <- FTGL.createPolygonFont path
addFinalizer font (FTGL.destroyFont font)
return $ Font font
text :: Font -> String -> Image Any
text font str = rendererImage $ \tr _ -> do
GL.preservingMatrix $ do
multGLmatrix tr
GL.scale (1/36 :: GL.GLdouble) (1/36) 1
_ <- FTGL.setFontFaceSize (getFont font) 72 72
FTGL.renderFont (getFont font) str FTGL.All
return ()
textWidth :: Font -> String -> R
textWidth font str = (/36) . realToFrac . unsafePerformIO $ do
_ <- FTGL.setFontFaceSize (getFont font) 72 72
FTGL.getFontAdvance (getFont font) str