{-# 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

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]