{-# 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.UI.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 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) = {- { afillrule :: FillRule -- ^ The pattern fill rule , afillRGBA :: AlphaColour Double -- ^ The components of the stroke color in the range [0..1] , adash :: Maybe ([Double],Double) -- ^ The shape of the line dashing, if any , astrokeRGBA :: AlphaColour Double -- ^ The components of the stroke color in the range [0..1] , aantialias :: Antialias -- ^ The way things are antialiased , alinecap :: LineCap -- ^ The way lines are capped , alinejoin :: LineJoin -- ^ The way lines are joined , alinewidth :: Double -- ^ The width of a line in points , amiterlimit :: Double -- ^ The miter limit of lines. See Cairo's documentation , atolerance :: Double -- ^ The trapezoidal tolerance. See Cairo's documentation , aoperator :: Operator -- ^ The transfer operator. See Cairo's documentation for more , atranslatex :: Double -- ^ The current translation x component , atranslatey :: Double -- ^ The current translation y component , ascalex :: Double -- ^ The current scale x component , ascaley :: Double -- ^ The current scale y component , arotation :: Double -- ^ The rotation in degrees that this primitive is seen in , afilled :: Bool -- ^ Whether or not this primitive is filled in , aoutlined :: Bool -- ^ Whether or not this primitive is outlined , aclipped :: Bool -- ^ Whether or not this primitive is part of the clipping plane , layer :: Int -- ^ This sorts out which primitives are located on top of each other. Do not set this yourself. Use Graphics.Rendering.Hieroglyph.Visual.over , bbox :: Rect -- ^ The clockwise rotation in radians. , aname :: Maybe String -- ^ The name of the object , lod :: Int -- ^ The level of detail that this primitive is at. Use Graphics.Rendering.Hieroglyph.Visual.moreSpecific } -} 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 -- the idea here is that we should: -- * initialize the GL subsystem -- * allocate some number of textures -- * allocate some buffer objects for tex coords and vertices -- * add any other state variables we want to check on to save time. -- * add lookup tables for geometry. -- * add weak table for optimized geometry. initializeBus name w h bus = do -- b <- takeMVar bus -- let numTexturesE = Buster.topEvent . Buster.eventsFor (Just "Environment") Nothing (Just "numTextures") $ b -- numBufferObjectsE = Buster.topEvent . Buster.eventsFor (Just "Environment") Nothing (Just "numBufferObjects") $ b -- Buster.EInt numTextures = head . Buster.eventdata $ numTexturesE -- Buster.EInt numBufferObjects = head . Buster.eventdata $ numBufferObjectsE -- putMVar bus b 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 () -- print "bus initialized" -- a behaviour to actually render hieroglyph data. -- On a separate thread and using STM: -- * get the lookup tables for geometry and optimized geometry. -- * merge the two by checking the guids of the current geometry against the optimized geometry and the non-optimized geometry -- * compile any uncompiled geometry -- * load unloaded textures -- * queue geometry to optimize -- * clear the buffers -- * setup GL state machine for a fresh render. -- * setup the viewport -- * setup the frustum -- * render the buffer -- * optimize any queued optimizable geometry -- * add optimized geometry to the weak table -- * wash hands, rinse, repeat. 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 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' 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 -- print "rendering" GL.drawBuffer $= GL.BackBuffers (GL.Position px py, GL.Size sx sy ) <- GL.get GL.viewport -- print (px,py) -- print (sx,sy) 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 -- print "finished rednering objects" Gtk.glDrawableSwapBuffers drawable -- print "swapped buffers" return r' renderObjects (o:os) !r = {- print o >> -} renderObj o r >>= renderObjects os renderObjects [] r = return r renderObj :: Primitive -> HieroglyphGLRuntime -> IO HieroglyphGLRuntime renderObj obj runtime = do -- print (aname . attribs $ obj) (runtime',cg0) <- compile runtime obj -- print "compiled" 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) mouseSelectionBehaviour bus = Buster.pollFullyQualifiedEventWith bus "Mouse" "Hierolgyph.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]