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
, Monoid(..), Any(..)
)
where
import Graphics.DrawingCombinators.Affine
import Control.Applicative (Applicative(..), liftA2, (*>), (<$>))
import Control.Monad (unless)
import Data.Monoid (Monoid(..), Any(..))
import qualified Graphics.Rendering.OpenGL.GL as GL
import qualified Codec.Image.STB as Image
import qualified Data.Bitmap.OpenGL as Bitmap
import System.IO.Unsafe (unsafePerformIO)
#ifdef LAME_FONTS
import qualified Graphics.UI.GLUT as GLUT
#else
import qualified Graphics.Rendering.FTGL as FTGL
import System.Mem.Weak (addFinalizer)
#endif
type Renderer = Affine -> Color -> IO ()
type Picker a = R2 -> a
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 {
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
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 white
clearRender :: Image a -> IO ()
clearRender d = do
GL.clear [GL.ColorBuffer]
render d
sample :: Image a -> R2 -> a
sample = dPick
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
point :: R2 -> Image Any
point p = Image render' (const (Any False))
where
render' tr _ = GL.renderPrimitive GL.Points . GL.vertex $ toVertex tr p
line :: R2 -> R2 -> Image Any
line src dest = Image render' (const (Any False))
where
render' tr _ = GL.renderPrimitive GL.Lines $ do
GL.vertex $ toVertex tr src
GL.vertex $ toVertex tr dest
regularPoly :: Int -> Image Any
regularPoly n = convexPoly [ (cos theta, sin theta) | i <- [0..n1], let theta = fromIntegral i * (2 * pi / fromIntegral n) ]
circle :: Image Any
circle = regularPoly 24
convexPoly :: [R2] -> Image Any
convexPoly points@(_:_:_:_) = Image render' pick
where
render' tr _ = 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)) = (yy1)*(x2x1) (xx1)*(y2y1)
sign | side p (last points, head points) >= 0 = (>= 0)
| otherwise = (<= 0)
convexPoly _ = error "convexPoly must be given at least three points"
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)
infixr 1 %%
(%%) :: 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')
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
| otherwise = \x y -> (a*x + (1a)*a'*y)/γ
white :: Color
white = Color 1 1 1 1
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 = Image render' pick
where
render' 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
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)
#ifdef LAME_FONTS
data Font = Font
openFont :: String -> IO Font
openFont _ = do
inited <- GLUT.get GLUT.initState
unless inited $ GLUT.initialize "" [] >> return ()
return Font
text :: Font -> String -> Image Any
text Font str = Image render' pick
where
render' tr _ = GL.preservingMatrix $ do
multGLmatrix tr
GL.scale (1/64 :: GL.GLdouble) (1/64) 1
GLUT.renderString GLUT.Roman str
pick (x,y) | 0 <= x && x <= textWidth Font str && 0 <= y && y <= 1 = Any True
| otherwise = Any False
textWidth :: Font -> String -> R
textWidth Font str = (1/64) * fromIntegral (unsafePerformIO (GLUT.stringWidth GLUT.Roman str))
#else
data Font = Font { getFont :: FTGL.Font }
openFont :: String -> IO Font
openFont path = do
font <- FTGL.createPolygonFont path
addFinalizer font (FTGL.destroyFont font)
_ <- FTGL.setFontFaceSize font 72 72
return $ Font font
text :: Font -> String -> Image Any
text font str = Image render' pick
where
render' tr _ = GL.preservingMatrix $ do
multGLmatrix tr
GL.scale (1/36 :: GL.GLdouble) (1/36) 1
FTGL.renderFont (getFont font) str FTGL.All
return ()
pick (x,y) | 0 <= x && x <= textWidth font str && 0 <= y && y <= 1 = Any True
| otherwise = Any False
textWidth :: Font -> String -> R
textWidth font str = (/36) . realToFrac . unsafePerformIO $ FTGL.getFontAdvance (getFont font) str
#endif