Hieroglyph-2.24: Graphics/Rendering/Hieroglyph/OpenGL.hs
{-# LANGUAGE BangPatterns #-}
-----------------------------------------------------------------------------
--
-- Module : Graphics.Rendering.Hieroglyph.OpenGL
-- Copyright :
-- License : BSD3
--
-- Maintainer : J.R. Heard
-- Stability :
-- Portability :
--
-- |
--
-----------------------------------------------------------------------------
module Graphics.Rendering.Hieroglyph.OpenGL where
import qualified Graphics.Rendering.Hieroglyph.Cache as Cache
import System.Exit
import GHC.Float
import Data.List
import Control.Concurrent
import Control.Applicative
import Control.Monad.Trans
import Data.List (partition)
import qualified Data.Set as Set
import Data.Maybe
import Graphics.UI.Gtk.Cairo as Cairo
import qualified Graphics.Rendering.Cairo as Cairo
import qualified Data.Array.MArray as A
import Control.Monad
import Graphics.UI.Gtk.Pango.Context
import Graphics.UI.Gtk.Pango.Layout
import Foreign
import qualified Data.Map as Map
import qualified Graphics.UI.Gtk as Gtk
import qualified Graphics.UI.Gtk.OpenGL as Gtk
import qualified Graphics.UI.Gtk.OpenGL.Drawable as Gtk
import qualified Graphics.UI.Gtk.Gdk.Events as Gtk
import qualified Data.ByteString.Internal as SB
import qualified Graphics.Rendering.Cairo as Cairo -- for rendering fonts
import qualified Graphics.Rendering.OpenGL as GL
import Graphics.Rendering.OpenGL(GLuint, Vertex2, ($=))
import Graphics.Rendering.Hieroglyph.Primitives
import Graphics.Rendering.Hieroglyph.Visual
import qualified Data.ByteString as SB
import Foreign.C
import qualified App.EventBus as Buster
import Data.Colour
import Data.Colour.Names
import Data.Colour.SRGB
import qualified Text.PrettyPrint as Pretty
import System.Mem.Weak
data HieroglyphGLRuntime = HgGL {
freetextures :: [GL.TextureObject]
, freebuffers :: [GL.BufferObject]
, compiledgeometry :: Map.Map GLuint CompiledData
, namemap :: Map.Map GLuint String
, drawarea :: Gtk.GLDrawingArea
, window :: Gtk.Window
, context ::PangoContext
, imagecache :: Cache.Cache Primitive ([Double],GL.TextureObject)
}
| Geometry BaseVisual
reverseMouseCoords b x y = do
let renderDataE = fromJust $ Buster.eventByQName "Hieroglyph" "Hieroglyph" "RenderData" b
(_,sy) <- Gtk.widgetGetSize . Gtk.castToWidget . drawarea . (\(Buster.EOther a) -> a) . head . Buster.eventdata $ renderDataE
return (Point x (fromIntegral sy-y))
arcFn _ _ _ [] = []
arcFn x y r (t:ts) = (x + r * cos t) : (y + r * sin t) : arcFn x y r ts
arcVertices nvertices (Point cx cy) r t1 t2 = arcFn cx cy r $ [t1+t | t <- [0,(t2-t1)/nvertices..t2-t1]]
interleave (x:xs) (y:ys) = x:y:interleave xs ys
interleave [] _ = []
interleave _ [] = []
cubic a c0 c1 b ts = fmap interpolateCubic ts
where interpolateCubic t = interpolate p20 p21 t
where p20 = interpolate p10 p11 t
p21 = interpolate p11 p12 t
p10 = interpolate a c0 t
p11 = interpolate c0 c1 t
p12 = interpolate c1 b t
interpolate x0 x1 t = x0 + ((x1 - x0)*t)
splineVertices nvertices (Point ax ay) (Point c0x c0y) (Point c1x c1y) (Point bx by) = interleave xs ys
where xs = cubic ax c0x c1x bx [m / nvertices' | m <- [0 .. nvertices']]
ys = cubic ay c0y c1y by [m / nvertices' | m <- [0 .. nvertices']]
nvertices' = (fromIntegral nvertices) :: Double
data CompiledData =
CompiledDots
{ attributes :: Attributes
, vertices :: [Double]
, uid :: GLuint }
| CompiledArc
{ attributes :: Attributes
, vertices :: [Double]
, uid :: GLuint }
| CompiledPath
{ attributes :: Attributes
, vertices :: [Double]
, uid :: GLuint }
| CompiledRectangle
{ attributes :: Attributes
, vertices :: [Double]
, uid :: GLuint }
| CompiledText
{ attributes :: Attributes
, vertices :: [Double]
, texture :: GL.TextureObject
, texcoords :: [Double]
, uid :: GLuint }
| CompiledImage
{ attributes :: Attributes
, vertices :: [Double]
, channels :: Int
, ww :: Double
, hh :: Double
, texture :: GL.TextureObject
, texcoords :: [Double]
, uid :: GLuint }
| Optimized
{ attributes :: Attributes
, vbo :: GL.BufferObject
, tbo :: Maybe GL.BufferObject
, tobj :: Maybe GL.TextureObject
, uid :: GLuint
, startindex :: Int
, len :: Int }
texturedObjects (CompiledDots _ _ _) = False
texturedObjects (CompiledArc _ _ _) = False
texturedObjects (CompiledPath _ _ _) = False
texturedObjects (CompiledRectangle _ _ _) = False
texturedObjects (CompiledText _ _ _ _ _) = True
texturedObjects (CompiledImage _ _ _ _ _ _ _ _) = True
texturedObjects (Optimized _ _ _ (Just _) _ _ _) = True
texturedObjects _ = False
colourToTuple :: AlphaColour Double -> (Double,Double,Double,Double)
colourToTuple c = (r,g,b,alpha)
where alpha = alphaChannel c
c' = (1/alpha) `darken` (c `Data.Colour.over` black)
RGB r g b = toSRGB c'
colourToGL :: AlphaColour Double -> GL.Color4 Double
colourToGL = (\(r,g,b,a) -> GL.Color4 r g b a) . colourToTuple
fillStrokeAndClip state action = do
let (fr,fg,fb,fa) = colourToTuple . afillRGBA $ state
(sr,sg,sb,sa) = colourToTuple . astrokeRGBA $ state
when (afilled state) $ Cairo.setSourceRGBA fr fg fb fa >> action >> Cairo.fill
when (aoutlined state) $ Cairo.setSourceRGBA sr sg sb sa >> action >> Cairo.stroke
when (aclipped state) $ Cairo.clip
compile e a@(Dots _ _ _) = return $ compileDots e a
compile e a@(Arc _ _ _ _ _ _ _) = return $ compileArc e a
compile e a@(Path _ _ _ _ _ ) = return $ compilePath e a
compile e a@(Rectangle _ _ _ _ _) = return $ compileRectangle e a
compile e a@(Text _ _ _ _ _ _ _ _ _ _) = compileText e a
compile e a@(Image _ _ _ _ _) = compileImage e a
compileDots e (Dots ds attrs s) = (maybe e (\n -> e{ namemap=Map.insert (fromIntegral s) n (namemap e)}) (aname attrs), CompiledDots attrs (vdata ds) (fromIntegral s))
where vdata ((Point x y):vs) = x:y:vdata vs
vdata [] = []
compileArc e (Arc (Point cx cy) r t1 t2 reverse attrs sg) = (maybe e (\n -> e{ namemap=Map.insert (fromIntegral sg) n (namemap e)}) (aname attrs),a0)
where a0 = CompiledArc
attrs
(cx : cy : arcVertices 360
(Point cx cy)
r
(if reverse then t2 else t1)
(if reverse then t1 else t2))
(fromIntegral sg)
compilePath e p = (maybe e (\n -> e{ namemap=Map.insert (fromIntegral (sig p)) n (namemap e) }) (aname . attribs $ p) , CompiledPath (attribs p) (fillablePath p) (fromIntegral (sig p)))
where fillablePath p = pathOutline' (centroid (begin p:(ls2pt <$> segments p))) (Line (begin p): segments p)
pathOutline p = pathOutline' (begin p) (segments p)
pathOutline' (Point x0 y0) (Line (Point x1 y1) : ps) = [x0,y0,x1,y1] ++ pathOutline' (Point x1 y1) ps
pathOutline' (Point x0 y0) (EndPoint (Point x1 y1) : ps) = pathOutline' (Point x1 y1) ps
pathOutline' a (Spline c0 c1 b:ps) = splineVertices 256 a c0 c1 b ++ pathOutline' b ps
pathOutline' _ [] = []
compileRectangle e (Rectangle (Point x y) w h attrs sg) = (maybe e (\n -> e{ namemap=Map.insert (fromIntegral sg) n (namemap e) }) (aname attrs),CompiledRectangle attrs [x, y, x+w, y, x+w, y+h, x, y+h] (fromIntegral sg))
dataFrom (SB.PS d _ _) = d
nearestPowerOfTwo w h = (log2 $ wf, log2 $ hf)
where log2 x = logDouble x / logDouble 2
wf = w
hf = h
compileText e txt
| txt `Cache.member` (imagecache e) =
let (cache',Just (vertexdata, tex)) = Cache.get txt (imagecache e)
e0 = maybe e (\n -> e{ namemap=Map.insert (fromIntegral (sig txt)) n (namemap e) }) (aname . attribs $ txt)
in return (e0{ imagecache=cache' }, CompiledText (attribs txt) vertexdata tex [0,1,1,1,1,0,0,0] (fromIntegral (sig txt)))
| otherwise = do
layout <- layoutEmpty (context e)
layoutSetMarkup layout . Pretty.render . str $ txt
layoutSetAlignment layout . align $ txt
layoutSetJustify layout . justify $ txt
layoutSetWidth layout . wrapwidth $ txt
layoutSetWrap layout . wrapmode $ txt
layoutSetIndent layout . indent $ txt
(PangoRectangle _ _ _ _, PangoRectangle x y w h) <- layoutGetExtents layout
let (po2w,po2h) = nearestPowerOfTwo w h
potw = 2 ^ ceiling po2w
poth = 2 ^ ceiling po2h
Point strx stry = bottomleft txt
-- print ("Power of two ", x,y,w,h, potw,poth)
textSurface <- Cairo.withImageSurface Cairo.FormatARGB32 potw poth $ \surf -> do
Cairo.renderWith surf $ do
Cairo.setOperator Cairo.OperatorSource
Cairo.setSourceRGBA 1 1 1 0
Cairo.rectangle 0 0 w h
Cairo.fill
Cairo.setOperator Cairo.OperatorOver
Cairo.updateContext (context e)
liftIO $ layoutContextChanged layout
Cairo.save
Cairo.translate (-x) (-y)
fillStrokeAndClip (attribs txt) $ Cairo.showLayout layout
Cairo.restore
-- Cairo.surfaceWriteToPNG surf "foo.png"
Cairo.imageSurfaceGetData surf
let ((_,(_,tex)),imagecache') = Cache.free (imagecache e)
freetextures' = tex:(freetextures e)
e0 = case freetextures e of
[] -> e{ freetextures = freetextures', imagecache = imagecache' }
ts -> e
e1 = maybe e0 (\n -> e0{ namemap=Map.insert (fromIntegral (sig txt)) n (namemap e0) }) (aname . attribs $ txt)
GL.textureBinding GL.Texture2D $= Just (head (freetextures e0))
GL.textureWrapMode GL.Texture2D GL.S $= (GL.Repeated, GL.Clamp)
GL.textureWrapMode GL.Texture2D GL.T $= (GL.Repeated, GL.Clamp)
GL.textureFilter GL.Texture2D $= ((GL.Linear', Nothing), GL.Linear')
GL.textureFunction $= GL.Decal
GL.texImage2D Nothing
GL.NoProxy
0
GL.RGBA'
(GL.TextureSize2D (fromIntegral potw) (fromIntegral poth))
0
(GL.PixelData GL.BGRA
GL.UnsignedByte
(unsafeForeignPtrToPtr (dataFrom textSurface)))
return ( e1{ freetextures=tail (freetextures e0)
, imagecache = Cache.put txt ([strx,stry
,strx+fromIntegral potw
,stry,strx+fromIntegral potw,stry+fromIntegral poth
,strx,stry+fromIntegral poth]
,(head (freetextures e0)))
(imagecache e0) }
, CompiledImage (attribs txt)
[strx,stry
,strx+fromIntegral potw,stry
,strx+fromIntegral potw,stry+fromIntegral poth
,strx,stry+fromIntegral poth]
3 0 0
(head (freetextures e0))
[0,1,1,1,1,0,0,0]
(fromIntegral (sig txt)))
compileImage e img = do
let (cache', cachehit) = Cache.get img (imagecache e)
case cachehit of
Just (vdata, tex) -> return (e{ imagecache=cache' }, CompiledImage (attribs img) vdata 0 0 0 tex [0,1,1,1,1,0,0,0] (fromIntegral (sig img)))
Nothing -> do
(w,h,potw,poth,channels,buffer) <- case dimensions img of
(Left (Point x y)) -> Gtk.pixbufNewFromFile (filename img) >>= copydata
(Right (Rect x y w h)) -> Gtk.pixbufNewFromFileAtScale (filename img) (round w) (round h) (preserveaspect img) >>= copydata
let ((_,(_,tex)),imagecache') = Cache.free (imagecache e)
freetextures' = tex:(freetextures e)
e0 = case freetextures e of
[] -> e{ freetextures = freetextures', imagecache = imagecache' }
ts -> e
GL.textureBinding GL.Texture2D $= Just (head (freetextures e0))
GL.textureWrapMode GL.Texture2D GL.S $= (GL.Repeated, GL.Clamp)
GL.textureWrapMode GL.Texture2D GL.T $= (GL.Repeated, GL.Clamp)
GL.textureFilter GL.Texture2D $= ((GL.Linear', Nothing), GL.Linear')
GL.textureFunction $= GL.Decal
GL.texImage2D Nothing
GL.NoProxy
0
(if channels == 4 then GL.RGBA' else GL.RGB')
(GL.TextureSize2D (fromIntegral potw) (fromIntegral poth))
0
(GL.PixelData (if channels == 4 then GL.RGBA else GL.RGB)
GL.UnsignedByte
(unsafeForeignPtrToPtr (dataFrom buffer)))
let vertexdata = case dimensions img of
Left (Point x y) -> [x,y,x+fromIntegral w,y,x+fromIntegral w, y+fromIntegral h, x, y+fromIntegral h]
Right (Rect x y w' h') -> [x,y,x+w',y,x+w',y+h',x,y+h']
let e1 = maybe e0 (\n -> e0{ namemap=Map.insert (fromIntegral (sig img)) n (namemap e0) }) (aname . attribs $ img)
return ( e1{ freetextures=tail (freetextures e1) }
, CompiledImage (attribs img) vertexdata channels (fromIntegral w) (fromIntegral h) (head (freetextures e0)) [0,1,1,1,1,0,0,0] (fromIntegral (sig img)))
renderCompiledGeometry (CompiledDots attrs vdata iid) = do
let verticesFrom (x:y:vs) = GL.Vertex2 x y : verticesFrom vs
verticesFrom [] = []
GL.color . colourToGL . afillRGBA $ attrs
GL.withName (GL.Name iid) . GL.renderPrimitive GL.Points . mapM_ GL.vertex . verticesFrom $ vdata
renderCompiledGeometry obj@(CompiledArc attrs vdata iid) =
(GL.textureBinding GL.Texture2D $= Nothing) >> renderObject obj
renderCompiledGeometry obj@(CompiledPath _ _ _) =
(GL.textureBinding GL.Texture2D $= Nothing) >> renderObject obj
renderCompiledGeometry obj@(CompiledRectangle attrs vdata iid) = do
GL.textureBinding GL.Texture2D $= Nothing
loadAttrs attrs
GL.color . colourToGL . afillRGBA . attributes $ obj
when (afilled attrs) . GL.withName (GL.Name iid) . GL.renderPrimitive GL.Quads . mapM_ GL.vertex $ verticesFrom vdata
GL.color . colourToGL . astrokeRGBA . attributes $ obj
when (aoutlined attrs) . GL.withName (GL.Name iid) . GL.renderPrimitive GL.LineStrip $ (mapM_ GL.vertex . verticesFrom $ vdata) >> (GL.vertex . head . verticesFrom $ vdata)
where verticesFrom (x:y:vs) = GL.Vertex2 x y : verticesFrom vs
verticesFrom [] = []
renderCompiledGeometry obj@(CompiledText _ vdata tex txcs iid) = do
-- let (GL.TextureObject tid) = tex in print tid
GL.textureFunction $= GL.Replace
GL.color $ GL.Color4 1 1 1 (1::Double)
GL.texture GL.Texture2D $= GL.Enabled
GL.textureBinding GL.Texture2D $= Just tex
GL.texture GL.Texture2D $= GL.Enabled
GL.textureFunction $= GL.Replace
GL.withName (GL.Name iid) . GL.renderPrimitive GL.Quads $ do
GL.texCoord $ GL.TexCoord2 (txcs !! 0) (txcs !! 1)
GL.vertex $ GL.Vertex2 (vdata !! 0) (vdata !! 1)
GL.texCoord $ GL.TexCoord2 (txcs !! 2) (txcs !! 3)
GL.vertex $ GL.Vertex2 (vdata !! 2) (vdata !! 3)
GL.texCoord $ GL.TexCoord2 (txcs !! 4) (txcs !! 5)
GL.vertex $ GL.Vertex2 (vdata !! 4) (vdata !! 5)
GL.texCoord $ GL.TexCoord2 (txcs !! 6) (txcs !! 7)
GL.vertex $ GL.Vertex2 (vdata !! 6) (vdata !! 7)
GL.flush
renderCompiledGeometry obj@(CompiledImage _ vdata _ w h tex txcs iid) = do
-- let (GL.TextureObject tid) = tex in print tid
GL.textureFunction $= GL.Replace
GL.color $ GL.Color4 1 1 1 (1::Double)
GL.texture GL.Texture2D $= GL.Enabled
GL.textureBinding GL.Texture2D $= Just tex
GL.texture GL.Texture2D $= GL.Enabled
GL.textureFunction $= GL.Replace
GL.withName (GL.Name iid) . GL.renderPrimitive GL.Quads $ do
GL.texCoord $ GL.TexCoord2 (txcs !! 0) (txcs !! 1)
GL.vertex $ GL.Vertex2 (vdata !! 0) (vdata !! 1)
GL.texCoord $ GL.TexCoord2 (txcs !! 2) (txcs !! 3)
GL.vertex $ GL.Vertex2 (vdata !! 2) (vdata !! 3)
GL.texCoord $ GL.TexCoord2 (txcs !! 4) (txcs !! 5)
GL.vertex $ GL.Vertex2 (vdata !! 4) (vdata !! 5)
GL.texCoord $ GL.TexCoord2 (txcs !! 6) (txcs !! 7)
GL.vertex $ GL.Vertex2 (vdata !! 6) (vdata !! 7)
GL.flush
renderCompiledGeometry obj@(Optimized attrs vbo tbo tex iid startindex len) = do
GL.bindBuffer GL.ArrayBuffer $= Just vbo
GL.arrayPointer GL.VertexArray $= GL.VertexArrayDescriptor 2 GL.Double 0 nullPtr
maybe (return ())
(\t -> do GL.bindBuffer GL.ArrayBuffer $= Just t
GL.arrayPointer GL.TextureCoordArray $= GL.VertexArrayDescriptor 2 GL.Double 0 nullPtr) tbo
GL.texture GL.Texture2D $= GL.Enabled
GL.textureBinding GL.Texture2D $= tex
GL.color . colourToGL . afillRGBA . attributes $ obj
when (afilled attrs) $ GL.drawArrays GL.TriangleFan (fromIntegral startindex) (fromIntegral len)
GL.color . colourToGL . astrokeRGBA . attributes $ obj
when (aoutlined attrs) $ GL.drawArrays GL.LineStrip (fromIntegral $ startindex+2) (fromIntegral len)
renderObject obj
| afilled (attributes obj) = GL.preservingMatrix $ do
loadAttrs (attributes obj )
GL.color . colourToGL . afillRGBA . attributes $ obj
GL.withName (GL.Name (uid obj)) . GL.renderPrimitive GL.TriangleFan . mapM_ GL.vertex . verticesFrom $ vertices obj
GL.color . colourToGL . astrokeRGBA . attributes $ obj
when (aoutlined (attributes obj)) $ (GL.withName (GL.Name (uid obj)) . GL.renderPrimitive GL.LineStrip . mapM_ GL.vertex . verticesFrom . drop 2 $ vertices obj)
| otherwise = GL.preservingMatrix $ do
loadAttrs (attributes obj)
GL.color . colourToGL . astrokeRGBA . attributes $ obj
GL.withName (GL.Name (uid obj)) . GL.renderPrimitive GL.LineStrip . mapM_ GL.vertex . verticesFrom . drop 2 $ vertices obj
where verticesFrom (x:y:vs) = GL.Vertex2 x y : verticesFrom vs
verticesFrom [] = []
--optimize !ptr i (CompiledPoints _ attrs vs iid) =
--optimize !ptr i (CompiledArc _ attrs vs iid) =
--optimize !ptr i (CompiledPath _ attrs vs iid) =
--optimize !ptr i (CompiledRectangle _ attrs vs iid) =
--optimize !ptr i (CompiledText _ attrs vs w h t iid) =
--optimize !ptr i (CompiledImage _ attrs vs c b w h t iid) =
--optimize !ptr i (Optimized attrs vbo tbo t iid) =
loadAttrs attrs = GL.preservingMatrix $ do
GL.lineWidth $= (realToFrac . alinewidth $ attrs)
GL.matrixMode $= GL.Modelview 0
GL.loadIdentity
GL.translate $ GL.Vector3 (atranslatex attrs) (atranslatey attrs) 0
GL.scale (ascalex attrs) (ascaley attrs) 1
GL.rotate (arotation attrs) $ GL.Vector3 0 0 1
GL.lineSmooth $= GL.Enabled
GL.polygonSmooth $= GL.Enabled
-- TODO support line cap
-- TODO support line join
-- TODO support miter limit
-- TODO support trapezoidal tolerance
-- TODO support operator
-- TODO support antialias
-- TODO support dash/stipple
-- TODO support pattern fill rule
-- | Widget for initializing the bus
initializeBus :: String -> Int -> Int -> Buster.Widget [Buster.EData HieroglyphGLRuntime]
initializeBus name w h bus = do
let numTextures = 400
numBufferObjects = 1
Gtk.unsafeInitGUIForThreadedRTS
win <- Gtk.windowNew
Gtk.windowSetTitle win name
Gtk.widgetSetName win "Hieroglyph"
Gtk.onDestroy win (exitWith ExitSuccess)
Gtk.initGL
config <- Gtk.glConfigNew [Gtk.GLModeRGBA, {- Gtk.GLModeMultiSample, -} Gtk.GLModeDouble, Gtk.GLModeAlpha]
area <- Gtk.glDrawingAreaNew config
Gtk.onRealize area $ do
GL.drawBuffer $= GL.BackBuffers
Gtk.windowSetDefaultSize win w h
Gtk.containerResizeChildren win
Gtk.containerAdd win area
Gtk.widgetShowAll win
(textures, buffers) <- Gtk.withGLDrawingArea area $ \_ -> do
ts <- (GL.genObjectNames numTextures) :: IO [GL.TextureObject]
bs <- (GL.genObjectNames numBufferObjects) :: IO [GL.BufferObject]
return (ts,bs)
context <- Gtk.cairoCreateContext Nothing
let edata = HgGL textures buffers Map.empty Map.empty area win context ( Cache.empty 1024768000 0)
Buster.produce' "Hieroglyph" "Hieroglyph" "RenderData" Buster.Persistent [Buster.EOther edata] bus
Gtk.onExpose area (\_ -> renderOnExpose bus >> return True)
return ()
-- | a behaviour to render hieroglyph data to the selection buffer when it sees a (Hieroglyph,Hieroglyph,PleaseSelect) event.
-- Produces (Selection,Hieroglyph,@objectname@) events.
selectionBehaviour :: Buster.Behaviour [Buster.EData HieroglyphGLRuntime]
selectionBehaviour bus =
case selectionRequested of
Just sreq -> do let [Buster.EDouble selx, Buster.EDouble sely] = Buster.eventdata sreq
(p, GL.Size sx sy ) <- GL.get GL.viewport
GL.matrixMode $= GL.Projection
GL.loadIdentity
GL.pickMatrix (selx-2, (fromIntegral sy)-sely+2) (6,6) (p, GL.Size sx sy)
GL.ortho2D 0 (fromIntegral sx) 0 (fromIntegral sy)
(runtime', recs) <- GL.getHitRecords 5 $ renderObjects (sort drawing) runtime
selectionEvents <- forM (fromMaybe [] recs) $ \(GL.HitRecord x y names) ->
let names' = (fromMaybe "" . ((flip Map.lookup) (namemap runtime')) . (\(GL.Name x) -> x)) <$> names in
Buster.produce "Selection" "Hieroglyph" (concat names') Buster.once
[Buster.EDouble . realToFrac $ x
, Buster.EDouble . realToFrac $ y
, Buster.EStringL $ names']
runtimeE' <- Buster.produce "Hieroglyph" "Hieroglyph" "RenderData" Buster.Persistent [Buster.EOther runtime']
Buster.future bus . return $ [Buster.Deletion sreq , runtimeE'] ++ selectionEvents
Nothing -> Buster.future bus . return $ []
where runtimeE = fromJust $ Buster.eventByQName "Hieroglyph" "Hieroglyph" "RenderData" bus
Buster.EOther runtime = head . Buster.eventdata $ runtimeE
drawing = primitives . map (\(Buster.EOther (Geometry x)) -> x) . concat . map Buster.eventdata $ drawingEs
drawingEs = Set.toList $ Buster.eventsByGroup "Visible" bus
selectionRequested = Buster.eventByQName "Hieroglyph" "Hieroglyph" "PleaseSelect" bus
-- | make Hieroglyph render on the main window exposure
renderOnExpose :: Buster.Widget [Buster.EData HieroglyphGLRuntime]
renderOnExpose busV = do
bus <- takeMVar busV
putMVar busV bus
let runtimeE = fromJust $ Buster.eventByQName "Hieroglyph" "Hieroglyph" "RenderData" bus
Buster.EOther runtime = head . Buster.eventdata $ runtimeE
drawing = primitives . map (\(Buster.EOther (Geometry x)) -> x) . concat . map Buster.eventdata $ drawingEs
drawingEs = Set.toList $ Buster.eventsByGroup "Visible" bus
-- print . map (aname . attribs) $ drawing
--putStrLn "Drawables:"
--mapM (print . Buster.showQName) drawingEs
-- putStrLn ""
-- print "expose event"
runtime' <- render runtime drawing
Buster.Insertion revent' <- Buster.produce "Hieroglyph" "Hieroglyph" "RenderData" Buster.Persistent [Buster.EOther runtime]
takeMVar busV
let bus' = Buster.addEvent revent' bus
putMVar busV bus'
-- | Make Hieroglyph send out expose events when it sees a (Hieroglyph,Hieroglyph,Rerender) event.
renderBehaviour bus = Buster.consumeFullyQualifiedEventWith bus "Hieroglyph" "Hieroglyph" "Rerender" $ \event -> do
let Buster.EOther renderdata = head . Buster.eventdata . fromJust $ Buster.eventByQName "Hieroglyph" "Hieroglyph" "RenderData" bus
(w,h) <- Gtk.widgetGetSize (window renderdata)
Gtk.widgetQueueDrawArea (window renderdata) 0 0 w h
return []
render runtime@(HgGL _ _ _ _ win _ _ _) geo = Gtk.withGLDrawingArea win $ \drawable -> do
GL.drawBuffer $= GL.BackBuffers
(GL.Position px py, GL.Size sx sy ) <- GL.get GL.viewport
GL.matrixMode $= GL.Projection
GL.loadIdentity
GL.ortho2D 0 (fromIntegral sx) 0 (fromIntegral sy)
GL.clearColor $= GL.Color4 1 1 1 1
GL.clear [GL.ColorBuffer]
GL.blend $= GL.Enabled
GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)
GL.lineSmooth $= GL.Enabled
GL.polygonSmooth $= GL.Enabled
r' <- renderObjects (sort geo) runtime
Gtk.glDrawableSwapBuffers drawable
return r'
renderObjects (o:os) !r = renderObj o r >>= renderObjects os
renderObjects [] r = return r
renderObj :: Primitive -> HieroglyphGLRuntime -> IO HieroglyphGLRuntime
renderObj obj runtime = do
(runtime',cg0) <- compile runtime obj
renderCompiledGeometry cg0
return runtime'{ compiledgeometry = Map.insert (uid cg0) cg0 . compiledgeometry $ runtime'
, namemap=Map.insert (uid cg0)
(fromMaybe "" . aname . attributes $ cg0)
(namemap runtime')
}
{-# INLINE copydata #-}
copydata pbuf0 = do
w0 <- Gtk.pixbufGetWidth pbuf0
h0 <- Gtk.pixbufGetHeight pbuf0
let potw = log (fromIntegral w0) / log (fromIntegral 2)
poth = log (fromIntegral h0) / log (fromIntegral 2)
w = 2 ^ ceiling potw
h = 2 ^ ceiling poth
pbuf <- if w0 == w && h0 == h then return pbuf0 else Gtk.pixbufScaleSimple pbuf0 w h Gtk.InterpBilinear
channels <- Gtk.pixbufGetNChannels pbuf
bpc <- (`quot`8) <$> Gtk.pixbufGetBitsPerSample pbuf
pixels <- Gtk.pixbufGetPixels pbuf :: IO (Gtk.PixbufData Int Word8)
stride <- Gtk.pixbufGetRowstride pbuf
buf <- SB.create (w*h*channels*bpc) $ \ptr ->
forM_ [0::Int .. h - 1] $ \row -> let stsample = row*stride in
forM_ [0::Int .. w*channels*bpc-1] $ \sample0 -> let sample = stsample + sample0 in
A.readArray pixels sample >>= pokeByteOff ptr sample
return (w0,h0,w,h,channels,buf)
-- | Select based on mouse clicks
mouseSelectionBehaviour :: Buster.Behaviour [Buster.EData HieroglyphGLRuntime]
mouseSelectionBehaviour bus = Buster.pollFullyQualifiedEventWith bus "Mouse" "Hieroglyph.KeyboardMouseWidget" "SingleClick" $ \event -> do
let (Buster.EAssocL alist) = head . Buster.eventdata $ event
(Buster.EDoubleL (x:y:_)) = fromJust $ "coords" `lookup` alist
Buster.listM $ Buster.produce "Hieroglyph" "Hieroglyph" "PleaseSelect" Buster.once [Buster.EDouble x, Buster.EDouble y]