Hieroglyph 2.24 → 3
raw patch · 8 files changed
+790/−530 lines, 8 filesdep +buster-gtkdep +glibdep ~base
Dependencies added: buster-gtk, glib
Dependency ranges changed: base
Files
- Graphics/Rendering/Hieroglyph/Cache.hs +88/−19
- Graphics/Rendering/Hieroglyph/Cairo.hs +1/−10
- Graphics/Rendering/Hieroglyph/OpenGL.hs +92/−494
- Graphics/Rendering/Hieroglyph/OpenGL/Compile.hs +264/−0
- Graphics/Rendering/Hieroglyph/OpenGL/Data.hs +123/−0
- Graphics/Rendering/Hieroglyph/OpenGL/Render.hs +202/−0
- Graphics/Rendering/Hieroglyph/Primitives.hs +11/−1
- Hieroglyph.cabal +9/−6
Graphics/Rendering/Hieroglyph/Cache.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE NoMonomorphismRestriction #-} ----------------------------------------------------------------------------- -- -- Module : Graphics.UI.Hieroglyph.Cache@@ -16,43 +17,111 @@ import qualified Data.Map as Map import qualified Data.IntMap as IntMap+import Debug.Trace -data Cache k a = Cache { store :: Map.Map k a, times :: IntMap.IntMap k, now :: Int, maxsize :: Int, size :: Int, decimation :: Int }+m ! k = case Map.lookup k m of Just v -> v; Nothing -> error $ "lookup failed for " ++ show k -empty mxsz dec = Cache Map.empty IntMap.empty 0 mxsz 0 dec+data Cache k a = Cache + { store :: Map.Map k a+ , times :: IntMap.IntMap k+ , now :: Int+ , maxsize :: Int+ , size :: Int+ , decimation :: Int } deriving Show -get :: Ord k => k -> Cache k a -> (Cache k a,Maybe a)++-- get :: Ord k => k -> Cache k a -> (Cache k a,Maybe a) get key cache = (cache',value) where value = Map.lookup key (store cache)- cache' = maybe (cache{ now = now cache + 1 }) (\_ -> cache{ now = now cache + 1, times = IntMap.insert (now cache) key (times cache) }) value+ cache' = maybe (cache{ now = now cache + 1 }) + (\_ -> cache{ now = now cache + 1+ , times = IntMap.insert (now cache) key . IntMap.filter (/=key) . times $ cache }) + value -put :: Ord k => k -> a -> Cache k a -> Cache k a+-- putList :: Ord k => Cache k a -> [(k,a)] -> Cache k a+putList = foldr (\(a,b) m -> put a b m)++-- put :: Ord k => k -> a -> Cache k a -> Cache k a put key value cache- | size cache < maxsize cache && (not $ Map.member key (store cache)) = cache { now = now cache + 1, times = IntMap.insert (now cache) key (times cache), store = Map.insert key value (store cache) , size = size cache + 1 }- | size cache < maxsize cache = cache { now = now cache + 1, times = IntMap.insert (now cache) key (times cache), store = Map.insert key value (store cache) }- | size cache >= maxsize cache && (Map.member key (store cache)) = cache { now = now cache + 1, times = IntMap.insert (now cache) key (times cache), store = Map.insert key value (store cache) }- | size cache >= maxsize cache = cache{ now = now cache + 1, times = IntMap.insert (now cache) key times', store = Map.insert key value store', size = size cache - decimation cache }+ | size cache < maxsize cache && (not $ Map.member key (store cache)) = cache + { now = now cache + 1+ , times = IntMap.insert (now cache) key . times $ cache+ , store = Map.insert key value (store cache) + , size = size cache + 1 }+ | size cache < maxsize cache = cache + { now = now cache + 1+ , times = IntMap.insert (now cache) key . IntMap.filter (/=key) . times $ cache+ , store = Map.insert key value (store cache) }+ | size cache >= maxsize cache && (Map.member key (store cache)) = cache + { now = now cache + 1+ , times = IntMap.insert (now cache) key . IntMap.filter (/=key) . times $ cache+ , store = Map.insert key value (store cache) }+ | size cache >= maxsize cache = cache + { now = now cache + 1+ , times = IntMap.insert (now cache) key times'+ , store = Map.insert key value store'+ , size = size cache - decimation cache } where times' = foldr IntMap.delete (times cache) lowtimes (lowtimes,lowtimekeys) = unzip . take (decimation cache) . IntMap.toAscList . times $ cache store' = foldr Map.delete (store cache) lowtimekeys -put' :: Ord k => k -> a -> Cache k a -> ([a], Cache k a)+-- put' :: Ord k => k -> a -> Cache k a -> ([a], Cache k a) put' key value cache- | size cache < maxsize cache && (not $ Map.member key (store cache)) = ([],cache { now = now cache + 1, times = IntMap.insert (now cache) key (times cache), store = Map.insert key value (store cache) , size = size cache + 1 })- | size cache < maxsize cache = ([],cache { now = now cache + 1, times = IntMap.insert (now cache) key (times cache), store = Map.insert key value (store cache) })- | size cache >= maxsize cache && (Map.member key (store cache)) = ([],cache { now = now cache + 1, times = IntMap.insert (now cache) key (times cache), store = Map.insert key value (store cache) })- | size cache >= maxsize cache = (freed, cache{ now = now cache + 1, times = IntMap.insert (now cache) key times', store = Map.insert key value store', size = size cache - decimation cache })+ | size cache < maxsize cache && (not $ Map.member key (store cache)) = ([] ,cache + { now = now cache + 1+ , times = IntMap.insert (now cache) key . times $ cache+ , store = Map.insert key value (store cache) + , size = size cache + 1 })+ | size cache < maxsize cache = ([] ,cache + { now = now cache + 1+ , times = IntMap.insert (now cache) key . IntMap.filter (/=key) . times $ cache+ , store = Map.insert key value (store cache) })+ | size cache >= maxsize cache && (Map.member key (store cache)) = ([] ,cache + { now = now cache + 1+ , times = IntMap.insert (now cache) key . IntMap.filter (/=key) . times $ cache+ , store = Map.insert key value (store cache) })+ | size cache >= maxsize cache = (freed, cache + { now = now cache + 1+ , times = IntMap.insert (now cache) key times'+ , store = Map.insert key value store'+ , size = size cache - decimation cache }) where times' = foldr IntMap.delete (times cache) lowtimes (lowtimes,lowtimekeys) = unzip . take (decimation cache) . IntMap.toAscList . times $ cache store' = foldr Map.delete (store cache) lowtimekeys freed = map (store cache Map.!) lowtimekeys -free :: Ord k => Cache k a -> ((k,a),Cache k a)-free cache = ((minkey,minval),cache')- where minkey = IntMap.findMin (times cache)- minval = store cache Map.! minkey- cache' = cache{ now = now cache + 1, times = IntMap.deleteMin (times cache), store = Map.delete minkey (store cache), size = (size cache) }+free cache = + case minval of+ Nothing -> free cache{ times= IntMap.deleteMin (times cache) }+ Just mv -> ((minkey,mv), cache')+ where minkey = IntMap.findMin $ (times cache)+ minval = Map.lookup minkey (store cache)+ cache' = cache{ now = now cache + 1+ , times = IntMap.deleteMin (times cache)+ , store = Map.delete minkey (store cache)+ , size = size cache - 1 } + +{- +-- free :: Ord k => Cache k a -> ((k,a),Cache k a)+free cache = + ( (minkey,minval)+ , cache' )+ where minkey = Map.findMin (times cache)+ minval = store cache ! minkey+ cache' = cache{ now = now cache + 1+ , times = Map.deleteMin (times cache)+ , store = Map.delete minkey (store cache)+ , size = size cache - 1 }+-}+++empty mxsz dec = Cache Map.empty IntMap.empty 0 mxsz 0 dec+ member :: Ord k => k -> Cache k a -> Bool member key cache = Map.member key (store cache)++keys = Map.keys . store+elems = Map.elems . store+isEmpty x = store x == Map.empty
Graphics/Rendering/Hieroglyph/Cairo.hs view
@@ -1,13 +1,4 @@--- | Cairo backend to Hieroglyph. Future plans include making 'StateModifier' part--- of the base distribution and making 'Frame' the basis for all backends to--- Hieroglyph. The real challenge will be making all implementations /look/ the--- same.------ Note in particular that pattern functionality and Pango layouts and font--- rendering engines are not implemented yet. This is both because these--- features are fairly complicated, and because I haven't figured out yet--- how I might make them portable to OpenGL using textures and FTGL. if--- someone wants to take this task on, I'd be pleased as punch.+-- | Cairo backend to Hieroglyph. -- -- [@Author@] Jeff Heard --
Graphics/Rendering/Hieroglyph/OpenGL.hs view
@@ -13,7 +13,15 @@ -- ----------------------------------------------------------------------------- -module Graphics.Rendering.Hieroglyph.OpenGL where+module Graphics.Rendering.Hieroglyph.OpenGL + ( module Graphics.Rendering.Hieroglyph.OpenGL.Data+ , mouseSelectionBehaviour+ , boilerplateOpenGLMain+ , renderOnExpose+ , renderBehaviour+ , selectionBehaviour+ , initializeBus)+where import qualified Graphics.Rendering.Hieroglyph.Cache as Cache import System.Exit@@ -22,6 +30,7 @@ import Control.Concurrent import Control.Applicative import Control.Monad.Trans+import qualified System.Glib.MainLoop as Gtk import Data.List (partition) import qualified Data.Set as Set import Data.Maybe@@ -46,401 +55,118 @@ import qualified Data.ByteString as SB import Foreign.C import qualified App.EventBus as Buster+import qualified App.Widgets.GtkMouseKeyboard 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+import Graphics.Rendering.Hieroglyph.OpenGL.Render+import Graphics.Rendering.Hieroglyph.OpenGL.Data+import Graphics.Rendering.Hieroglyph.OpenGL.Compile -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))+-- | Select based on mouse clicks+mouseSelectionBehaviour :: Buster.Behaviour [Buster.EData HieroglyphGLRuntime]+mouseSelectionBehaviour bus = Buster.pollFullyQualifiedEventWith bus "Mouse" "Hieroglyph.KeyboardMouseWidget" "SingleClick" $ \event -> do+ --print "MouseSelectionBehaviour"+ let (Buster.EAssocL alist) = head . Buster.eventdata $ event+ (Buster.EDoubleL (x:y:_)) = fromJust $ "coords" `lookup` alist+ --print "Leaving mouse selection behaviour"+ Buster.listM $ Buster.produce "Hieroglyph" "Hieroglyph" "PleaseSelect" Buster.once [Buster.EDouble x, Buster.EDouble 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)+boilerplateOpenGLMain widgets behaviour = do+ evBus <- newMVar Buster.emptyBus+ forM_ widgets ($evBus)+ b <- takeMVar evBus+ putMVar evBus b -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+ let Just (Buster.EOther glarea) = fmap (head . Buster.eventdata) $ Buster.eventByQName "Hieroglyph" "Hieroglyph" "RenderData" b+ loop mv = do+ Gtk.mainContextIteration Gtk.mainContextDefault True+ Buster.busIteration mv behaviour+ loop mv -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 }+ let mk = Buster.bindMouseKeyboardWidget (Gtk.castToWidget (window glarea))+ mk evBus+ loop evBus -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'+-- | 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 . catMaybes . map getGeo . concat . map Buster.eventdata $ drawingEs+ drawingEs = Set.toList $ Buster.eventsByGroup "Visible" bus -colourToGL :: AlphaColour Double -> GL.Color4 Double-colourToGL = (\(r,g,b,a) -> GL.Color4 r g b a) . colourToTuple+ 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' -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+-- | 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 $ [] -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+-- | 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 -- print "Selection requested"+ let [Buster.EDouble selx, Buster.EDouble sely] = Buster.eventdata sreq+ (p, GL.Size sx sy ) <- GL.get GL.viewport+ GL.depthFunc $= Just GL.Less+ GL.clear [GL.ColorBuffer, GL.DepthBuffer]+ GL.matrixMode $= GL.Projection+ GL.loadIdentity+ GL.pickMatrix (selx-2, (fromIntegral sy)-sely+2) (6,6) (p, GL.Size sx sy)+ GL.ortho 0 (fromIntegral sx) 0 (fromIntegral sy) 1 10247680+ (runtime', recs) <- GL.getHitRecords 5 $ renderObjects [1::Double,2..] (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 do+ --print names+ print names'+ Buster.produce "Selection" "Hieroglyph" (concat names') Buster.once+ [Buster.EDouble . realToFrac $ x+ , Buster.EDouble . realToFrac $ y+ , Buster.EStringL $ names'] -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 [] = []+ runtimeE' <- Buster.produce "Hieroglyph" "Hieroglyph" "RenderData" Buster.Persistent [Buster.EOther runtime']+ Buster.future bus . return $ [Buster.Deletion sreq , runtimeE'] ++ selectionEvents -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)+ Nothing -> Buster.future bus . return $ []+ where runtimeE = fromJust $ Buster.eventByQName "Hieroglyph" "Hieroglyph" "RenderData" bus+ Buster.EOther runtime = head . Buster.eventdata $ runtimeE+ drawing = primitives . catMaybes . map getGeo . concat . map Buster.eventdata $ drawingEs+ drawingEs = Set.toList $ Buster.eventsByGroup "Visible" bus+ selectionRequested = Buster.eventByQName "Hieroglyph" "Hieroglyph" "PleaseSelect" bus -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+ let numTextures = 512 + numBufferObjects = 256+ 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]+ Gtk.initGL >>= mapM_ putStrLn+ config <- Gtk.glConfigNew [Gtk.GLModeRGBA, Gtk.GLModeMultiSample, Gtk.GLModeDouble, Gtk.GLModeDepth, Gtk.GLModeAlpha] area <- Gtk.glDrawingAreaNew config Gtk.onRealize area $ do@@ -457,136 +183,8 @@ context <- Gtk.cairoCreateContext Nothing - let edata = HgGL textures buffers Map.empty Map.empty area win context ( Cache.empty 1024768000 0)+ let edata = HgGL textures (Cache.empty 1024768000 0) [] buffers (Cache.empty 1024768000 0) [] Map.empty area win context Map.empty 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]--------------
+ Graphics/Rendering/Hieroglyph/OpenGL/Compile.hs view
@@ -0,0 +1,264 @@+{-# LANGUAGE BangPatterns #-}+-----------------------------------------------------------------------------+--+-- Module : Graphics.Rendering.Hieroglyph.OpenGL+-- Copyright :+-- License : BSD3+--+-- Maintainer : J.R. Heard+-- Stability :+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module Graphics.Rendering.Hieroglyph.OpenGL.Compile where++import Graphics.Rendering.Hieroglyph.OpenGL.Data+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 qualified System.Glib.MainLoop as Gtk+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 qualified App.Widgets.GtkMouseKeyboard as Buster+import Data.Colour+import Data.Colour.Names+import Data.Colour.SRGB+import qualified Text.PrettyPrint as Pretty+import System.Mem.Weak+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+ +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 p@(Dots ds attrs s) = (maybe e (\n -> e{ namemap=Map.insert (fromIntegral s) n (namemap e)}) (aname attrs), CompiledDots p (vdata ds) (fromIntegral s))+ where vdata ((Point x y):vs) = x:y:vdata vs+ vdata [] = []++compileArc e p@(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+ p+ (cx : cy : arcVertices 180+ (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 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 p@(Rectangle (Point x y) w h attrs sg) =+ (maybe e+ (\n -> e{ namemap=Map.insert (fromIntegral sg) n (namemap e) })+ (aname attrs)+ , CompiledRectangle p x y w 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+ +getFreeTexture e = if texture_whitelist e /= []+ then return (e{ texture_whitelist = tail $ texture_whitelist e }, head (texture_whitelist e))+ else (if Cache.isEmpty (texture_greylist e) + then GL.genObjectNames 1 >>= (\obj -> return (e, head obj)) + else return (e{ texture_greylist = c' }, t)) + where ((_,t),c') = Cache.free . texture_greylist $ e+ +compileText e txt+ | cachetxt txt `Cache.member` texture_greylist e = do+ let Point x y = bottomleft txt+ (c', Just tex) = Cache.get (cachetxt txt) (texture_greylist e)+ (w,h) = texdims e Map.! tex+ return ( e{ texture_greylist = c' }, CompiledImage txt x y w h tex (fromIntegral (sig txt)))++ | otherwise = do+ (e', tex) <- getFreeTexture e + + 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 ex ey ew eh) <- layoutGetExtents layout+ let (po2w,po2h) = nearestPowerOfTwo ew eh+ potw = 2 ^ (max 0 $ ceiling po2w)+ poth = 2 ^ (max 0 $ ceiling po2h)+ w = fromIntegral potw+ h = fromIntegral poth+ Point x y = bottomleft txt++ 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 (-ex) (-ey)+ let (fr,fg,fb,fa) = colourToTuple . afillRGBA $ state+ (sr,sg,sb,sa) = colourToTuple . astrokeRGBA $ state+ state = attribs txt+ when (afilled state) $ do + Cairo.setSourceRGBA fr fg fb fa + Cairo.showLayout layout + Cairo.fill+ when (aoutlined state) $ do+ Cairo.setSourceRGBA sr sg sb sa+ Cairo.showLayout layout + Cairo.stroke+ Cairo.restore+ Cairo.imageSurfaceGetData surf++ GL.textureBinding GL.Texture2D $= Just tex+ 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 ( e'{ texdims = Map.insert tex (w, h) (texdims e')+ , texture_greylist = Cache.put (cachetxt txt) tex (texture_greylist e') + }+ , CompiledImage txt x y w h tex (fromIntegral (sig txt)))+++compileImage e img+ | cacheimg img `Cache.member` texture_greylist e = do+ let (c',Just tex) = Cache.get (cacheimg img) (texture_greylist e)+ (w,h) = texdims e Map.! tex+ return ( e{texture_greylist = c'} , CompiledImage img x y w h tex (fromIntegral (sig img)))++ | otherwise = 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++ (e', tex) <- getFreeTexture e+ + GL.textureBinding GL.Texture2D $= Just tex+ 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 (w',h') = case dimensions img of+ Left _ -> (fromIntegral w, fromIntegral h)+ Right (Rect _ _ w0 h0) -> (w0,h0)++ return ( e'{ texdims = Map.insert tex (w',h') (texdims e') + , texture_greylist = Cache.put (cacheimg img) tex (texture_greylist e')+ }+ , CompiledImage img x y w' h' tex (fromIntegral (sig img)))+ where (x, y) = case dimensions img of+ Left (Point x0 y0) -> (x0, y0)+ Right (Rect x0 y0 _ _) -> (x0,y0)++{-# 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 ^ (max 0 $ ceiling potw)+ h = 2 ^ (max 0 $ 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)+
+ Graphics/Rendering/Hieroglyph/OpenGL/Data.hs view
@@ -0,0 +1,123 @@+{-# LANGUAGE BangPatterns #-}+-----------------------------------------------------------------------------+--+-- Module : Graphics.Rendering.Hieroglyph.OpenGL+-- Copyright :+-- License : BSD3+--+-- Maintainer : J.R. Heard+-- Stability :+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module Graphics.Rendering.Hieroglyph.OpenGL.Data 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 qualified System.Glib.MainLoop as Gtk+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 qualified App.Widgets.GtkMouseKeyboard 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 {+ texture_whitelist :: [GL.TextureObject]+ , texture_greylist :: Cache.Cache String GL.TextureObject+ , texture_blacklist :: [GL.TextureObject]++ , buffer_whitelist :: [GL.BufferObject]+ , buffer_greylist :: Cache.Cache Int GL.BufferObject+ , buffer_blacklist :: [GL.BufferObject]++ , namemap :: Map.Map GLuint String+ , drawarea :: Gtk.GLDrawingArea+ , window :: Gtk.Window+ , context ::PangoContext+ , texdims :: Map.Map GL.TextureObject (Double,Double)+ }+ | 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))++data CompiledData =+ CompiledDots+ { original :: Primitive+ , vertices :: [Double]+ , uid :: GLuint }+ | CompiledArc+ { original :: Primitive+ , vertices :: [Double]+ , uid :: GLuint }+ | CompiledPath+ { original :: Primitive+ , vertices :: [Double]+ , uid :: GLuint }+ | CompiledRectangle+ { original :: Primitive+ , xx :: Double+ , yy :: Double+ , ww :: Double+ , hh :: Double+ , uid :: GLuint }+ | CompiledImage+ { original :: Primitive+ , xx :: Double+ , yy :: Double+ , ww :: Double+ , hh :: Double+ , texture :: GL.TextureObject+ , uid :: GLuint }+++texturedObjects (CompiledImage _ _ _ _ _ _ _) = True+texturedObjects _ = False++colourToTuple :: AlphaColour Double -> (Double,Double,Double,Double)+colourToTuple c = (r,g,b,alpha)+ where alpha = alphaChannel c+ c' = if alpha > 0 then (1/alpha) `darken` (c `Data.Colour.over` black) else 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++cacheimg img = show (filename img, {- show $ dimensions img,-} preserveaspect img)+cachetxt txt = show (show . str $ txt,align txt,wrapwidth txt,wrapmode txt,justify txt,indent txt,spacing txt)+
+ Graphics/Rendering/Hieroglyph/OpenGL/Render.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE BangPatterns #-}+-----------------------------------------------------------------------------+--+-- Module : Graphics.Rendering.Hieroglyph.OpenGL+-- Copyright :+-- License : BSD3+--+-- Maintainer : J.R. Heard+-- Stability :+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module Graphics.Rendering.Hieroglyph.OpenGL.Render 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 qualified System.Glib.MainLoop as Gtk+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 qualified App.Widgets.GtkMouseKeyboard as Buster+import Data.Colour+import Data.Colour.Names+import Data.Colour.SRGB+import qualified Text.PrettyPrint as Pretty+import System.Mem.Weak++import Graphics.Rendering.Hieroglyph.OpenGL.Compile+import Graphics.Rendering.Hieroglyph.OpenGL.Data++renderCompiledGeometry z (CompiledDots prim vdata iid) = do+ let verticesFrom (x:y:vs) = GL.Vertex3 x y z : verticesFrom vs+ verticesFrom [] = []+ loadAttrs . attribs $ prim+ GL.color . colourToGL . afillRGBA . attribs $ prim+ GL.withName (GL.Name iid) . GL.renderPrimitive GL.Points . mapM_ GL.vertex . verticesFrom $ vdata++renderCompiledGeometry z obj@(CompiledArc _ _ _) =+ (GL.textureBinding GL.Texture2D $= Nothing) >> renderObject z obj++renderCompiledGeometry z obj@(CompiledPath _ _ _) =+ (GL.textureBinding GL.Texture2D $= Nothing) >> renderObject z obj++renderCompiledGeometry z obj@(CompiledRectangle prim x y w h iid) = do+ GL.textureBinding GL.Texture2D $= Nothing+ loadAttrs attrs++ GL.lineSmooth $= GL.Disabled+ GL.polygonSmooth $= GL.Disabled+ GL.color . colourToGL . afillRGBA $ attrs++ when (afilled attrs) .+ GL.withName (GL.Name iid) .+ GL.renderPrimitive GL.Quads .+ mapM_ GL.vertex+ $ take 4 vertices++ GL.color . colourToGL . astrokeRGBA $ attrs+ GL.lineSmooth $= GL.Enabled+ GL.polygonSmooth $= GL.Enabled++ when (aoutlined attrs) .+ GL.withName (GL.Name iid) .+ GL.renderPrimitive GL.LineStrip .+ mapM_ GL.vertex+ $ vertices++ where attrs = attribs prim+ vertices = [GL.Vertex3 x y z+ ,GL.Vertex3 (x+w) y z+ ,GL.Vertex3 (x+w) (y+h) z+ ,GL.Vertex3 x (y+h) z+ ,GL.Vertex3 x y z]+ + ++renderCompiledGeometry z obj@(CompiledImage original x y w h tex iid) = do+ 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.lineSmooth $= GL.Disabled+ GL.polygonSmooth $= GL.Disabled++ GL.withName (GL.Name iid) . GL.renderPrimitive GL.Quads $ do+ GL.texCoord $ GL.TexCoord2 0 (1::Double)+ GL.vertex $ GL.Vertex3 x y z+ GL.texCoord $ GL.TexCoord2 1 (1::Double)+ GL.vertex $ GL.Vertex3 (x+w) y z+ GL.texCoord $ GL.TexCoord2 1 (0::Double)+ GL.vertex $ GL.Vertex3 (x+w) (y+h) z+ GL.texCoord $ GL.TexCoord2 0 (0::Double)+ GL.vertex $ GL.Vertex3 x (y+h) z+ GL.flush++ GL.lineSmooth $= GL.Enabled+ GL.polygonSmooth $= GL.Enabled++renderObject z obj+ | afilled (attribs . original $ obj) = GL.preservingMatrix $ do+ + GL.textureBinding GL.Texture2D $= Nothing+ loadAttrs (attribs . original $ obj )+ GL.color . colourToGL . afillRGBA . attribs . original $ obj+ GL.withName (GL.Name (uid obj)) . GL.renderPrimitive GL.TriangleFan . mapM_ GL.vertex . verticesFrom $ vertices obj+ GL.color . colourToGL . astrokeRGBA . attribs . original $ obj+ when (aoutlined (attribs . original $ obj)) $ (GL.withName (GL.Name (uid obj)) . GL.renderPrimitive GL.LineStrip . mapM_ GL.vertex . verticesFrom . drop 2 $ vertices obj)+ | otherwise = GL.preservingMatrix $ do+ + loadAttrs (attribs . original $ obj)+ GL.color . colourToGL . astrokeRGBA . attribs . original $ 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.Vertex3 x y z : verticesFrom vs+ verticesFrom [] = []++++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+++getGeo (Buster.EOther (Geometry x)) = Just x+getGeo _ = Nothing++render runtime geo = Gtk.withGLDrawingArea (drawarea runtime) $ \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.ortho 0 (fromIntegral sx) 0 (fromIntegral sy) 1 2+ GL.clearColor $= GL.Color4 1 1 1 1+ GL.clear [GL.ColorBuffer, GL.DepthBuffer]+ GL.depthFunc $= Just GL.Less+ GL.blend $= GL.Enabled+ GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)+ GL.lineSmooth $= GL.Enabled+ GL.polygonSmooth $= GL.Enabled+ GL.pointSmooth $= GL.Enabled+ r' <- renderObjects [1::Double,2..] (sort geo) runtime+ Gtk.glDrawableSwapBuffers drawable+ return r'{ texture_blacklist = [] }+++renderObjects (z:zs) (o:os) !r = renderObj ((-2) + z/(z+1)) o r >>= renderObjects zs os+renderObjects _ [] r = return r++renderObj :: Double -> Primitive -> HieroglyphGLRuntime -> IO HieroglyphGLRuntime+renderObj z obj runtime = do+ (runtime',cg0) <- compile runtime obj+ renderCompiledGeometry z cg0+ return runtime'{ namemap=Map.insert (uid cg0)+ (fromMaybe "" . aname . attribs . original $ cg0)+ (namemap runtime') }+
Graphics/Rendering/Hieroglyph/Primitives.hs view
@@ -444,6 +444,16 @@ hidden :: Primitive -- ^ A hidden object. hidden = sign $ Hidden plain 0 -image :: Primitive -- ^ An image. These are efficiently cached using weak references where possible+image :: Primitive -- ^ An image. These are efficiently cached where possible image = sign $ Image "" (Left origin) False plain 0 +textExtents context txt = unsafePerformIO $ do + layout <- layoutEmpty context + layoutSetMarkup layout . 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+ return (x,y,w,h)
Hieroglyph.cabal view
@@ -1,15 +1,15 @@ name: Hieroglyph-version: 2.24+version: 3 cabal-version: >=1.2 build-type: Simple license: BSD3 license-file: LICENSE copyright: maintainer: J.R. Heard-build-depends: IfElse -any, OpenGL -any, array -any, base -any,+build-depends: IfElse -any, OpenGL -any, array -any, base <=5, buster >=2.0, bytestring -any, cairo -any, colour -any, containers -any, gtk -any, gtkglext -any, mtl -any, parallel -any,- pretty -any, random -any+ pretty -any, random -any, glib -any, buster-gtk -any stability: homepage: http://vis.renci.org/jeff/hieroglyph package-url:@@ -22,14 +22,17 @@ tested-with: data-files: data-dir: ""-extra-source-files:+extra-source-files: extra-tmp-files: exposed-modules: Graphics.Rendering.Hieroglyph Graphics.Rendering.Hieroglyph.Cairo Graphics.Rendering.Hieroglyph.OpenGL- Graphics.Rendering.Hieroglyph.Cache Graphics.Rendering.Hieroglyph.Primitives Graphics.Rendering.Hieroglyph.Visual+ Graphics.Rendering.Hieroglyph.OpenGL.Data+ Graphics.Rendering.Hieroglyph.OpenGL.Render + Graphics.Rendering.Hieroglyph.OpenGL.Compile + Graphics.Rendering.Hieroglyph.Cache exposed: True buildable: True build-tools:@@ -49,7 +52,7 @@ other-modules: ghc-prof-options: ghc-shared-options:-ghc-options:+ghc-options: -O2 -fvia-C -optc-O3 hugs-options: nhc98-options: jhc-options: