Hieroglyph 1.21 → 2.0
raw patch · 6 files changed
+973/−376 lines, 6 filesdep +FTGLdep +OpenGLdep +array
Dependencies added: FTGL, OpenGL, array, buster, bytestring, gtkglext, pretty, random
Files
- Graphics/Rendering/Hieroglyph/Cairo.hs +125/−112
- Graphics/Rendering/Hieroglyph/Interactive.hs +39/−35
- Graphics/Rendering/Hieroglyph/OpenGL.hs +493/−0
- Graphics/Rendering/Hieroglyph/Primitives.hs +206/−167
- Graphics/Rendering/Hieroglyph/Visual.hs +53/−35
- Hieroglyph.cabal +57/−27
Graphics/Rendering/Hieroglyph/Cairo.hs view
@@ -1,24 +1,28 @@--- | Cairo backend to Hieroglyph. Future plans include making 'StateModifier' part --- of the base distribution and making 'Frame' the basis for all backends to +-- | 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 +-- 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. -- -- [@Author@] Jeff Heard--- +-- -- [@Copyright@] © 2008 Renaissance Computing Institute--- +-- -- [@License@] A LICENSE file should be included as part of this distribution -- -- [@Version@] 0.5 -- module Graphics.Rendering.Hieroglyph.Cairo where +import qualified Data.Set as Set+import qualified Graphics.UI.Gtk.Cairo as Gtk+import Graphics.UI.Gtk.Pango.Context+import Graphics.UI.Gtk.Pango.Layout import Data.Map (Map) import qualified Data.Map as M import System.Mem.Weak@@ -27,7 +31,7 @@ import Graphics.Rendering.Hieroglyph.Primitives import Graphics.Rendering.Hieroglyph.ImageCache import Graphics.Rendering.Hieroglyph.Visual-import Graphics.UI.Gtk.Gdk.Pixbuf +import Graphics.UI.Gtk.Gdk.Pixbuf import qualified Graphics.UI.Gtk.Cairo as Cairo import qualified Graphics.Rendering.Cairo as Cairo import Control.Monad@@ -37,29 +41,24 @@ import Data.Colour import Data.Colour.SRGB import Data.Colour.Names (black)+import qualified Text.PrettyPrint as Pretty -toCairoFontSlant FontSlantNormal = Cairo.FontSlantNormal-toCairoFontSlant FontSlantItalic = Cairo.FontSlantItalic-toCairoFontSlant FontSlantOblique = Cairo.FontSlantOblique -toCairoFontWeight FontWeightNormal = Cairo.FontWeightNormal-toCairoFontWeight FontWeightBold = Cairo.FontWeightBold--toCairoAntialias AntialiasDefault = Cairo.AntialiasDefault -toCairoAntialias AntialiasNone = Cairo.AntialiasNone -toCairoAntialias AntialiasGray = Cairo.AntialiasGray -toCairoAntialias AntialiasSubpixel = Cairo.AntialiasSubpixel +toCairoAntialias AntialiasDefault = Cairo.AntialiasDefault+toCairoAntialias AntialiasNone = Cairo.AntialiasNone+toCairoAntialias AntialiasGray = Cairo.AntialiasGray+toCairoAntialias AntialiasSubpixel = Cairo.AntialiasSubpixel -toCairoFillRule FillRuleWinding = Cairo.FillRuleWinding +toCairoFillRule FillRuleWinding = Cairo.FillRuleWinding toCairoFillRule FillRuleEvenOdd = Cairo.FillRuleEvenOdd -toCairoLineCap LineCapButt = Cairo.LineCapButt -toCairoLineCap LineCapRound = Cairo.LineCapRound -toCairoLineCap LineCapSquare = Cairo.LineCapSquare +toCairoLineCap LineCapButt = Cairo.LineCapButt+toCairoLineCap LineCapRound = Cairo.LineCapRound+toCairoLineCap LineCapSquare = Cairo.LineCapSquare -toCairoLineJoin LineJoinMiter = Cairo.LineJoinMiter -toCairoLineJoin LineJoinRound = Cairo.LineJoinRound -toCairoLineJoin LineJoinBevel = Cairo.LineJoinBevel +toCairoLineJoin LineJoinMiter = Cairo.LineJoinMiter+toCairoLineJoin LineJoinRound = Cairo.LineJoinRound+toCairoLineJoin LineJoinBevel = Cairo.LineJoinBevel toCairoOperator OperatorClear = Cairo.OperatorClear toCairoOperator OperatorSource = Cairo.OperatorSource@@ -77,36 +76,44 @@ where alpha = alphaChannel c c' = (1/alpha) `darken` (c `Data.Colour.over` black) RGB r g b = toSRGB c'- -fillStrokeAndClip state action = do - let (fr,fg,fb,fa) = colourToTuple . fillRGBA $ state- (sr,sg,sb,sa) = colourToTuple . strokeRGBA $ state- when (filled state) $ Cairo.setSourceRGBA fr fg fb fa >> action >> Cairo.fill- when (outlined state) $ Cairo.setSourceRGBA sr sg sb sa >> action >> Cairo.stroke- when (clipped state) $ Cairo.clip +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+ renderCurveSegs (Line (Point x0 y0)) = Cairo.lineTo x0 y0 renderCurveSegs (EndPoint (Point x0 y0)) = Cairo.moveTo x0 y0-renderCurveSegs (Spline (Point x0 y0) (Point x1 y1) (Point x2 y2)) = Cairo.curveTo x0 y0 x1 y1 x2 y2 +renderCurveSegs (Spline (Point x0 y0) (Point x1 y1) (Point x2 y2)) = Cairo.curveTo x0 y0 x1 y1 x2 y2 -- | @renderPrimitive state prim@ draws a single primitive.-renderPrimitive :: ImageCache -> Attributes -> Primitive -> Cairo.Render Attributes-renderPrimitive _ s0 (Arc (Point cx cy) radius angle0 angle1 isnegative state) = do - applyAttributeDelta s0 state - fillStrokeAndClip state $ +renderPrimitive :: PangoContext -> ImageCache -> Attributes -> Primitive -> Cairo.Render Attributes+renderPrimitive _ _ s0 (Arc (Point cx cy) radius angle0 angle1 isnegative state _) = do+ applyAttributeDelta s0 state+ fillStrokeAndClip state $ if isnegative then Cairo.arcNegative cx cy radius angle0 angle1 else Cairo.arc cx cy radius angle0 angle1 return state -renderPrimitive _ s0 (Path (Point ox oy) segs isclosed state) = do +renderPrimitive _ _ s0 (Dots ats attrs sig) = do+ applyAttributeDelta s0 attrs+ fillStrokeAndClip attrs $ do+ forM_ ats $ \(Point ox oy) -> do+ Cairo.moveTo ox oy+ Cairo.arc ox oy (alinewidth attrs) 0 (2*pi)+ return attrs++renderPrimitive _ _ s0 (Path (Point ox oy) segs isclosed state _) = do applyAttributeDelta s0 state fillStrokeAndClip state $ do Cairo.moveTo ox oy forM_ segs $ renderCurveSegs- when isclosed (Cairo.lineTo ox oy) + when isclosed (Cairo.lineTo ox oy) return state -renderPrimitive images s0 i@(Image filename (Left (Point ox oy)) _ state) = do+renderPrimitive _ images s0 i@(Image filename (Left (Point ox oy)) _ state _) = do applyAttributeDelta s0 state pbuf <- loadImage images i w <- liftIO $ pixbufGetWidth pbuf@@ -118,7 +125,7 @@ Cairo.restore return state -renderPrimitive images s0 i@(Image filename (Right (Rect ox oy w h)) _ state) = do+renderPrimitive _ images s0 i@(Image filename (Right (Rect ox oy w h)) _ state _) = do applyAttributeDelta s0 state pbuf <- loadImage images i Cairo.save@@ -128,117 +135,123 @@ Cairo.restore return state -renderPrimitive _ s0 (Hidden _) = return s0-renderPrimitive _ s0 (Rectangle (Point ox oy) w h state) = do +renderPrimitive _ _ s0 (Hidden _ _) = return s0+renderPrimitive _ _ s0 (Rectangle (Point ox oy) w h state _) = do applyAttributeDelta s0 state- fillStrokeAndClip state $ Cairo.rectangle ox oy w h + fillStrokeAndClip state $ Cairo.rectangle ox oy w h return state- -renderPrimitive _ s0 (Text str (Point ox oy) state) = do- applyAttributeDelta s0 state - fillStrokeAndClip state $ do ++renderPrimitive context _ s0 txt@(Text _ (Point ox oy) _ _ _ _ _ _ _ _) = do+ layout <- liftIO $ layoutEmpty context >>= \layout -> do+ 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+ return layout+ applyAttributeDelta s0 (attribs txt)+ fillStrokeAndClip (attribs txt) $ do Cairo.moveTo ox oy- Cairo.showText str - return state- -renderPrimitive images s0 (Union prims state) = do- let unfoc prim = prim{ attribs = (attribs prim){filled=False, outlined=False, clipped=False } }+ Cairo.showLayout layout+ return (attribs txt)++renderPrimitive context images s0 (Union prims state _) = do+ let unfoc prim = prim{ attribs = (attribs prim){afilled=False, aoutlined=False, aclipped=False } } applyAttributeDelta s0 state- fillStrokeAndClip state $ forM_ prims (renderPrimitive images state . unfoc) + fillStrokeAndClip state $ forM_ prims (renderPrimitive context images state . unfoc) return state- -render images d = loadStateIntoCairo attrs0- >> (foldlM (renderPrimitive images) attrs0 . sort $ vis)++render context images d = loadStateIntoCairo attrs0+ >> (foldlM (renderPrimitive context images) attrs0 . sort $ vis) >> return ()- where vis = primitives d - attrs0 = attribs . head $ vis - + where vis = Set.toAscList $ primitives d+ attrs0 = attribs . head $ vis+ applyAttributeDelta a b = do let different f = ((f %=> (/=)) a b) whendifferent f = when (different f)- when (different fontfamily || different fontslant || different fontweight) $ Cairo.selectFontFace (fontfamily b) (toCairoFontSlant . fontslant $ b) (toCairoFontWeight . fontweight $ b)- whendifferent fillrule . Cairo.setFillRule . toCairoFillRule . fillrule $ b- whendifferent dash . maybe (return ()) (uncurry Cairo.setDash) . dash $ b- whendifferent antialias . Cairo.setAntialias . toCairoAntialias . antialias $ b- whendifferent linewidth . Cairo.setLineWidth . linewidth $ b- whendifferent linecap . Cairo.setLineCap . toCairoLineCap . linecap $ b- whendifferent linejoin . Cairo.setLineJoin . toCairoLineJoin . linejoin $ b- whendifferent miterlimit . Cairo.setMiterLimit . miterlimit $ b- whendifferent tolerance . Cairo.setTolerance . tolerance $ b- whendifferent operator . Cairo.setOperator . toCairoOperator . operator $ b- when (different scalex || different scaley || different rotation || different translatex || different translatey) $ do- Cairo.translate (translatex b) (translatey b)- Cairo.scale (scalex b) (scaley b)- Cairo.rotate (rotation b)- return b - + whendifferent afillrule . Cairo.setFillRule . toCairoFillRule . afillrule $ b+ whendifferent adash . maybe (return ()) (uncurry Cairo.setDash) . adash $ b+ whendifferent aantialias . Cairo.setAntialias . toCairoAntialias . aantialias $ b+ whendifferent alinewidth . Cairo.setLineWidth . alinewidth $ b+ whendifferent alinecap . Cairo.setLineCap . toCairoLineCap . alinecap $ b+ whendifferent alinejoin . Cairo.setLineJoin . toCairoLineJoin . alinejoin $ b+ whendifferent amiterlimit . Cairo.setMiterLimit . amiterlimit $ b+ whendifferent atolerance . Cairo.setTolerance . atolerance $ b+ whendifferent aoperator . Cairo.setOperator . toCairoOperator . aoperator $ b+ when (different ascalex || different ascaley || different arotation || different atranslatex || different atranslatey) $ do+ Cairo.translate (atranslatex b) (atranslatey b)+ Cairo.scale (ascalex b) (ascaley b)+ Cairo.rotate (arotation b)+ return b+ -- | Load the Cairo state with a 'RenderState' Drawing. loadStateIntoCairo :: Attributes -> Cairo.Render () loadStateIntoCairo s = do- Cairo.selectFontFace (fontfamily s) (toCairoFontSlant . fontslant $ s) (toCairoFontWeight . fontweight $ s)- Cairo.setFillRule . toCairoFillRule . fillrule $ s- awhen (dash s) $ \(a,b) -> Cairo.setDash a b- Cairo.setAntialias . toCairoAntialias . antialias $ s- - Cairo.setLineJoin . toCairoLineJoin . linejoin $ s- Cairo.setLineWidth . linewidth $ s- Cairo.setMiterLimit . miterlimit $ s- Cairo.setTolerance . tolerance $ s- Cairo.setOperator . toCairoOperator . operator $ s- - Cairo.translate (translatex s) (translatey s)- Cairo.scale (scalex s) (scaley s)- Cairo.rotate (rotation s)+ Cairo.setFillRule . toCairoFillRule . afillrule $ s+ awhen (adash s) $ \(a,b) -> Cairo.setDash a b+ Cairo.setAntialias . toCairoAntialias . aantialias $ s + Cairo.setLineJoin . toCairoLineJoin . alinejoin $ s+ Cairo.setLineWidth . alinewidth $ s+ Cairo.setMiterLimit . amiterlimit $ s+ Cairo.setTolerance . atolerance $ s+ Cairo.setOperator . toCairoOperator . aoperator $ s++ Cairo.translate (atranslatex s) (atranslatey s)+ Cairo.scale (ascalex s) (ascaley s)+ Cairo.rotate (arotation s)+ -- | @renderFrameToSurface surface frame@ renders a frame to a particular surface-renderToSurfaceWithImageCache :: Visual t => ImageCache -> Cairo.Surface -> t -> IO ()-renderToSurfaceWithImageCache images surf frame = Cairo.renderWith surf (render images frame)+renderToSurfaceWithImageCache :: Visual t => PangoContext -> ImageCache -> Cairo.Surface -> t -> IO ()+renderToSurfaceWithImageCache context images surf frame = Cairo.renderWith surf (render context images frame) -renderToSurface :: Visual t => Cairo.Surface -> t -> IO ()-renderToSurface s o = do { i <- initImageCache; renderToSurfaceWithImageCache i s o }+renderToSurface :: Visual t => PangoContext -> Cairo.Surface -> t -> IO ()+renderToSurface c s o = do { i <- initImageCache; renderToSurfaceWithImageCache c i s o } -- | @renderframeToPNGWithImageCache filename xres yres frame@ renders a frame to an image file-renderToPNGWithImageCache :: Visual t => ImageCache -> FilePath -> Int -> Int -> t -> IO ()-renderToPNGWithImageCache images filename xres yres frame = Cairo.withImageSurface Cairo.FormatARGB32 xres yres $ \s -> renderToSurfaceWithImageCache images s frame >> Cairo.surfaceWriteToPNG s filename-renderToPNG f w h o = do { i <- initImageCache ; renderToPNGWithImageCache i f w h o }+renderToPNGWithImageCache :: Visual t => PangoContext -> ImageCache -> FilePath -> Int -> Int -> t -> IO ()+renderToPNGWithImageCache c images filename xres yres frame = Cairo.withImageSurface Cairo.FormatARGB32 xres yres $ \s -> renderToSurfaceWithImageCache c images s frame >> Cairo.surfaceWriteToPNG s filename+renderToPNG f w h o = do { c <- Gtk.cairoCreateContext Nothing ; i <- initImageCache ; renderToPNGWithImageCache c i f w h o } -- | @renderToPDFWithImageCache filename width height frame@ renders a frame to a PDF file. width and height are in points.-renderToPDFWithImageCache :: Visual t => ImageCache -> FilePath -> Double -> Double -> t -> IO ()-renderToPDFWithImageCache images filename width height frame = Cairo.withPDFSurface filename width height $ \s -> renderToSurfaceWithImageCache images s frame-renderToPDF f w h o = do { i <- initImageCache ; renderToPDFWithImageCache i f w h o } +renderToPDFWithImageCache :: Visual t => PangoContext -> ImageCache -> FilePath -> Double -> Double -> t -> IO ()+renderToPDFWithImageCache c images filename width height frame = Cairo.withPDFSurface filename width height $ \s -> renderToSurfaceWithImageCache c images s frame+renderToPDF f w h o = do { c <- Gtk.cairoCreateContext Nothing ; i <- initImageCache ; renderToPDFWithImageCache c i f w h o } -- | @renderToPostscriptWithImageCache filename width height frame@ renders a frame to a Postscript file. width and height are in points.-renderToPostscriptWithImageCache :: Visual t => ImageCache -> FilePath -> Double -> Double -> t -> IO ()-renderToPostscriptWithImageCache images filename width height frame = Cairo.withPSSurface filename width height $ \s -> renderToSurfaceWithImageCache images s frame-renderToPostscript f w h o = do { i <- initImageCache ; renderToPostscriptWithImageCache i f w h o }+renderToPostscriptWithImageCache :: Visual t => PangoContext -> ImageCache -> FilePath -> Double -> Double -> t -> IO ()+renderToPostscriptWithImageCache c images filename width height frame = Cairo.withPSSurface filename width height $ \s -> renderToSurfaceWithImageCache c images s frame+renderToPostscript f w h o = do { c <- Gtk.cairoCreateContext Nothing ; i <- initImageCache ; renderToPostscriptWithImageCache c i f w h o } -- | @renderToSVGWithImageCache filename width height frame@ renders a frame to a SVG file. width and height are in points.-renderToSVGWithImageCache :: Visual t => ImageCache -> FilePath -> Double -> Double -> t -> IO ()-renderToSVGWithImageCache images filename width height frame = Cairo.withSVGSurface filename width height $ \s -> renderToSurfaceWithImageCache images s frame-renderToSVG f w h o = do { i <- initImageCache ; renderToSVGWithImageCache i f w h o }+renderToSVGWithImageCache :: Visual t => PangoContext -> ImageCache -> FilePath -> Double -> Double -> t -> IO ()+renderToSVGWithImageCache c images filename width height frame = Cairo.withSVGSurface filename width height $ \s -> renderToSurfaceWithImageCache c images s frame+renderToSVG f w h o = do { c <- Gtk.cairoCreateContext Nothing ; i <- initImageCache ; renderToSVGWithImageCache c i f w h o } -- | @loadImage dictRef image@ pulls an image out of the cache's hat. loadImage :: ImageCache -> Primitive -> Cairo.Render (Pixbuf)-loadImage dictRef im@(Image filename (Right (Rect x y w h)) aspect _) = do- liftIO $ modifyMVar dictRef $ \dict -> +loadImage dictRef im@(Image filename (Right (Rect x y w h)) aspect _ _) = do+ liftIO $ modifyMVar dictRef $ \dict -> if (show im) `M.member` dict then do value <- deRefWeak $ dict M.! (show im) pbuf <- case value of- Just pb -> return pb + Just pb -> return pb Nothing -> pixbufNewFromFileAtScale filename (round w) (round h) aspect return (dict,pbuf) else do pbuf <- pixbufNewFromFileAtScale filename (round w) (round h) aspect wk <- mkWeakPtr pbuf Nothing return ((M.insert (show im) wk dict), pbuf)-loadImage dictRef im@(Image filename (Left (Point x y)) _ _) = do- liftIO $ modifyMVar dictRef $ \dict -> +loadImage dictRef im@(Image filename (Left (Point x y)) _ _ _) = do+ liftIO $ modifyMVar dictRef $ \dict -> if (show im) `M.member` dict then do value <- deRefWeak $ dict M.! (show im) pbuf <- case value of- Just pb -> return pb - Nothing -> pixbufNewFromFile filename + Just pb -> return pb+ Nothing -> pixbufNewFromFile filename return (dict,pbuf)- else do pbuf <- pixbufNewFromFile filename + else do pbuf <- pixbufNewFromFile filename wk <- mkWeakPtr pbuf Nothing return ((M.insert (show im) wk dict), pbuf)
Graphics/Rendering/Hieroglyph/Interactive.hs view
@@ -1,4 +1,4 @@--- | An interactive scene graph library for Cairo +-- | An interactive scene graph library for Cairo -- -- [@Author@] Jeff Heard --@@ -6,6 +6,8 @@ -- module Graphics.Rendering.Hieroglyph.Interactive where +import qualified Data.Set as Set+import Graphics.UI.Gtk.Pango.Context import Graphics.Rendering.Hieroglyph.Primitives import Graphics.Rendering.Hieroglyph.ImageCache import Graphics.Rendering.Hieroglyph.Cairo@@ -14,36 +16,37 @@ import qualified Graphics.UI.Gtk.Cairo as Gtk import qualified Graphics.Rendering.Cairo as Cairo import qualified Graphics.UI.Gtk as Gtk+import qualified Graphics.UI.Gtk.Cairo as Gtk import qualified Graphics.UI.Gtk.Gdk.Events as Gtk import Control.Parallel.Strategies import Data.List import Data.Maybe import Control.Monad-import Control.Concurrent.MVar - +import Control.Concurrent.MVar+ -- | Applies the current Interactive instance to a single scene element, returning an Object applyDataToVisual :: (Interactive a, Visual b) => a -> (a -> b) -> b applyDataToVisual vdata obj = obj vdata -- | Render function. All Cairo is called through here. You do not need to call this in your own code.-renderer :: (Interactive a, Visual b) => MVar [Primitive] -> MVar a -> (a -> b) -> IO ()-renderer extant_geometry state scene = do +renderer :: (Interactive a, Visual b) => PangoContext -> MVar [Primitive] -> MVar a -> (a -> b) -> IO ()+renderer context extant_geometry state scene = do geom <- takeMVar extant_geometry st <- takeMVar state let state' = interactionFold st geom geom' = scene state'- dwin <- Gtk.widgetGetDrawWindow . fromJust . getDrawing $ st - Gtk.renderWithDrawable dwin (render (fromJust (getImageCache st)) geom')- putMVar extant_geometry . primitives $ geom'- putMVar state state' + dwin <- Gtk.widgetGetDrawWindow . fromJust . getDrawing $ st+ Gtk.renderWithDrawable dwin (render context (fromJust (getImageCache st)) geom')+ putMVar extant_geometry . Set.toList . primitives $ geom'+ putMVar state state' -- | Gets the keyboard state from Gtk and changes the Interactive. You do not need -- to call this in your own code keyboardHandler :: Interactive a => MVar a -> Gtk.Event -> IO Bool keyboardHandler uistate_mvar event = do- let k = case Gtk.eventKeyName event of + let k = case Gtk.eventKeyName event of "Insert" -> Insert "Delete" -> Delete "Enter" -> Enter@@ -70,12 +73,12 @@ dwin <- Gtk.widgetGetDrawWindow . fromJust . getDrawing $ s Gtk.drawWindowInvalidateRect dwin (Gtk.Rectangle 0 0 (round . getSizeX $ s) (round . getSizeY $ s)) False return False- + -- | Gets the mouse position and changes the Interactive to reflect it. YOu do not need this in your own code. mouseMotionHandler :: Interactive a => MVar a -> Gtk.Event -> IO Bool-mouseMotionHandler uistate_mvar event = do +mouseMotionHandler uistate_mvar event = do state <- takeMVar uistate_mvar- putMVar uistate_mvar + putMVar uistate_mvar $ setMousePosition (Point (Gtk.eventX event) (Gtk.eventY event)) state dwin <- Gtk.widgetGetDrawWindow . fromJust . getDrawing $ state Gtk.drawWindowGetPointer dwin@@ -91,16 +94,16 @@ shift = elem Gtk.Shift modifiers alt = elem Gtk.Alt modifiers ctrl = elem Gtk.Control modifiers- - modifyMVar_ uistate_mvar - $ return ++ modifyMVar_ uistate_mvar+ $ return . setMousePosition (Point x y) . setKeyShift shift . setKeyAlt alt . setKeyCtrl ctrl . (case button of Gtk.LeftButton -> setMouseLeftButtonDown False- . setMouseWheel 0 + . setMouseWheel 0 Gtk.RightButton -> setMouseRightButtonDown False . setMouseWheel 0 Gtk.MiddleButton -> setMouseRightButtonDown False@@ -120,9 +123,9 @@ shift = elem Gtk.Shift modifiers alt = elem Gtk.Alt modifiers ctrl = elem Gtk.Control modifiers- - modifyMVar_ uistate_mvar - $ return ++ modifyMVar_ uistate_mvar+ $ return . setMousePosition (Point x y) . setKeyShift shift . setKeyAlt alt@@ -131,7 +134,7 @@ Gtk.LeftButton -> setMouseLeftButtonDown True . setMouseRightButtonDown False . setMouseMiddleButtonDown False- . setMouseWheel 0 + . setMouseWheel 0 Gtk.RightButton -> setMouseLeftButtonDown False . setMouseRightButtonDown True . setMouseMiddleButtonDown False@@ -158,30 +161,31 @@ -- | A lowish level funtion for creating a GUI. Does not set the size of the -- window or expose any windows.-guiInit :: (Interactive a, Visual b) - => MVar a -- ^ The current Interactive - -> (a->b) -- ^ The scene to render- -> String -- ^ The name of the window +guiInit :: (Interactive a, Visual b)+ => MVar a -- ^ The current Interactive+ -> (a-> b) -- ^ The scene to render+ -> String -- ^ The name of the window -> Bool -- ^ Whether or not to make this GUI motion sensitive -> IO Gtk.DrawingArea -- ^ Returns the window that was created-guiInit state scene name motionSensitive = do +guiInit state scene name motionSensitive = do Gtk.unsafeInitGUIForThreadedRTS - canvas <- Gtk.drawingAreaNew + canvas <- Gtk.drawingAreaNew imgcache <- initImageCache modifyMVar_ state $ return . setDrawing (Just . Gtk.castToWidget $ canvas) . setImageCache (Just imgcache) primitiveData <- newMVar []+ context <- Gtk.cairoCreateContext Nothing - Gtk.onExpose canvas $ \evt -> renderer primitiveData state scene >> return True+ Gtk.onExpose canvas $ \evt -> renderer context primitiveData state scene >> return True Gtk.onConfigure canvas $ resize state- Gtk.onButtonPress canvas $ mouseButtonHandler state - Gtk.onButtonRelease canvas $ mouseReleaseHandler state - Gtk.onKeyPress canvas $ keyboardHandler state + Gtk.onButtonPress canvas $ mouseButtonHandler state+ Gtk.onButtonRelease canvas $ mouseReleaseHandler state+ Gtk.onKeyPress canvas $ keyboardHandler state when motionSensitive $ (Gtk.onMotionNotify canvas True $ mouseMotionHandler state) >> return () return canvas --- | A higher level function for creating a GUI. Does not set the size of the --- window or expose any windows, but does kill the app if this window is +-- | A higher level function for creating a GUI. Does not set the size of the+-- window or expose any windows, but does kill the app if this window is -- closed guiConstruct :: (Interactive a, Visual b) => a -- ^ The default Interactive@@ -202,9 +206,9 @@ -- state, the name of the scene, and the scene, and you get an 800 by -- 600 motion insensitive GUI. simpleGui :: (Interactive a, Visual b)- => a + => a -> (a -> b)- -> String + -> String -> IO () simpleGui state scene name = do win <- guiConstruct state scene name False
+ Graphics/Rendering/Hieroglyph/OpenGL.hs view
@@ -0,0 +1,493 @@+{-# LANGUAGE BangPatterns #-}+-----------------------------------------------------------------------------+--+-- Module : Graphics.Rendering.Hieroglyph.OpenGL+-- Copyright :+-- License : BSD3+--+-- Maintainer : J.R. Heard+-- Stability :+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module Graphics.Rendering.Hieroglyph.OpenGL () where++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 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++data HieroglyphGLRuntime = HgGL {+ freetextures :: [GL.TextureObject]+ , freebuffers :: [GL.BufferObject]+ , compiledgeometry :: Map.Map GLuint CompiledData+ , namemap :: Map.Map GLuint String+ , window :: Gtk.GLDrawingArea+ , context ::PangoContext+ }+ | 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+ , bpc :: 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++freeAllTextures env = env{ compiledgeometry = Map.fromList $ zip liveids live, freetextures = freed }+ where (tofree,live) = partition texturedObjects . Map.elems . compiledgeometry $ env+ freed = map texture tofree+ liveids = map uid live++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) = (e, 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) = (e,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 = (e, 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) = (e,CompiledRectangle attrs [x, y, x+w, y, x+w, y+h, x, y+h] (fromIntegral sg))++dataFrom (SB.PS d _ _) = d++compileText e txt = 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+ textSurface <- Cairo.withImageSurface Cairo.FormatARGB32 (round w) (round h) $ \surf -> do+ Cairo.renderWith surf $ do+ Cairo.setOperator Cairo.OperatorSource+ Cairo.rectangle x y w h+ Cairo.fill+ Cairo.setOperator Cairo.OperatorOver+ Cairo.updateContext (context e)+ liftIO $ layoutContextChanged layout+ fillStrokeAndClip (attribs txt) $ Cairo.showLayout layout+ Cairo.imageSurfaceGetData surf++ let e0 = case freetextures e of+ [] -> freeAllTextures e0+ ts -> e0++ GL.texture GL.Texture2D $= GL.Enabled+ GL.textureBinding GL.Texture2D $= Just (head (freetextures e0))+ GL.texImage2D Nothing GL.NoProxy 0 GL.RGBA' (GL.TextureSize2D (round w) (round h)) 0 (GL.PixelData GL.RGBA GL.Double (unsafeForeignPtrToPtr (dataFrom textSurface)))+ return ( e0{ freetextures=tail (freetextures e0) }+ , CompiledText (attribs txt) [x,y,x+w,y,x+w,y+h,x,y+h] (head (freetextures e0)) [0,0,1,0,1,1,0,1] (fromIntegral (sig txt)))++compileImage e img = do+ pbuf <- (case dimensions img of+ Right (Rect x y w h) -> Gtk.pixbufNewFromFileAtScale (filename img) (round w) (round h) (preserveaspect img)+ Left (Point x y) -> Gtk.pixbufNewFromFile (filename img))+ width <- Gtk.pixbufGetWidth pbuf+ height <- Gtk.pixbufGetHeight pbuf+ channels <- Gtk.pixbufGetNChannels pbuf+ bpc <- (`quot`8) <$> Gtk.pixbufGetBitsPerSample pbuf+ pixels <- Gtk.pixbufGetPixels pbuf :: IO (Gtk.PixbufData Int Word8)+ stride <- Gtk.pixbufGetRowstride pbuf+ buffer <- SB.create (width*height*channels*bpc) $ \ptr ->+ forM_ [0::Int .. height] $ \row -> let stsample = row*stride in+ forM_ [0::Int .. width*channels*bpc] $ \col -> let sample = stsample + col*channels*bpc in+ forM_ [0::Int .. channels] $ \channel -> A.readArray pixels (sample+channel) >>= poke ptr+ let vertexdata = case dimensions img of+ Right (Rect x y w h) -> [x,y,x+w,y,x+w,y+h,x,y+h]+ Left (Point x y) -> [x,y,x+fromIntegral width,y,x+fromIntegral width, y+fromIntegral height, x, y+fromIntegral height]++ e0 = case freetextures e of+ [] -> freeAllTextures e0+ ts -> e0++ GL.texture GL.Texture2D $= GL.Enabled+ GL.textureBinding GL.Texture2D $= Just (head (freetextures e0))+ GL.texImage2D Nothing GL.NoProxy 0 GL.RGBA' (GL.TextureSize2D (fromIntegral width) (fromIntegral height)) 0 (GL.PixelData GL.RGBA GL.Double (unsafeForeignPtrToPtr $ dataFrom buffer))+ return ( e0{ freetextures=tail (freetextures e0) }+ , CompiledImage (attribs img) vertexdata channels bpc (fromIntegral width) (fromIntegral height) (head (freetextures e0)) [0,0,1,0,1,1,0,1] (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 _ _ _) =+ (GL.textureBinding GL.Texture2D $= Nothing) >> renderObject obj++renderCompiledGeometry obj@(CompiledText _ vdata tex txcs iid) = do+ GL.texture GL.Texture2D $= GL.Enabled+ GL.textureBinding GL.Texture2D $= Just tex+ 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 !! 23)+ GL.vertex $ GL.Vertex2 (vdata !! 1) (vdata !! 2)+ GL.texCoord $ GL.TexCoord2 (txcs !! 3) (txcs !! 4)+ GL.vertex $ GL.Vertex2 (vdata !! 3) (vdata !! 4)+ GL.texCoord $ GL.TexCoord2 (txcs !! 0) (txcs !! 1)+ GL.vertex $ GL.Vertex2 (vdata !! 0) (vdata !! 1)+ GL.flush++renderCompiledGeometry obj@(CompiledImage _ vdata _ _ w h tex txcs iid) = do+ GL.texture GL.Texture2D $= GL.Enabled+ GL.textureBinding GL.Texture2D $= Just tex+ 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 !! 23)+ GL.vertex $ GL.Vertex2 (vdata !! 1) (vdata !! 2)+ GL.texCoord $ GL.TexCoord2 (txcs !! 3) (txcs !! 4)+ GL.vertex $ GL.Vertex2 (vdata !! 3) (vdata !! 4)+ GL.texCoord $ GL.TexCoord2 (txcs !! 0) (txcs !! 1)+ GL.vertex $ GL.Vertex2 (vdata !! 0) (vdata !! 1)+ 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.Lines . 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.Lines . 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 <http://cairographics.org>+ , 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 = 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 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++ let numTextures = 128+ numBufferObjects = 1++ Gtk.initGL+ config <- Gtk.glConfigNew [Gtk.GLModeRGBA, Gtk.GLModeMultiSample, Gtk.GLModeDouble, Gtk.GLModeAlpha, Gtk.GLModeMultiSample]+ area <- Gtk.glDrawingAreaNew config+ textures <- (GL.genObjectNames numTextures) :: IO [GL.TextureObject]+ buffers <- (GL.genObjectNames numBufferObjects) :: IO [GL.BufferObject]+ context <- Gtk.cairoCreateContext Nothing+ let edata = HgGL textures buffers Map.empty Map.empty area context+ Buster.produce' "Hieroglyph" "Hieroglyph" "RenderData" Buster.Persistent [Buster.EOther edata] bus++-- 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, sely-2) (6,6) (p, GL.Size sx sy)+ GL.ortho2D 0 (fromIntegral sx) (fromIntegral sy) 0+ (runtime', recs) <- GL.getHitRecords 5 $ renderObjects (Set.toList drawing) runtime+ selectionEvents <- mapM hr2event (fromMaybe [] recs)+ runtimeE' <- Buster.produce "Hieroglyph" "Hieroglyph" "RenderData" Buster.Persistent [Buster.EOther runtime']+ Buster.future . return $ [Buster.Deletion sreq , Buster.Deletion runtimeE , runtimeE'] ++ selectionEvents+ Nothing -> Buster.future . 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 . filter ((=="Geometry") . Buster.name) $ drawingEs+ drawingEs = Set.toList $ Buster.eventsByGroup "Heiroglyph" bus+ selectionRequested = Buster.eventByQName "Hieroglyph" "Hieroglyph" "PleaseSelect" bus+ hr2event (GL.HitRecord x y names) = Buster.produce "Selection" "Hieroglyph" (show (x,y)) Buster.once [Buster.EDouble . realToFrac $ x, Buster.EDouble . realToFrac $ y, Buster.EStringL $ (fromMaybe "" . ((flip Map.lookup) (namemap runtime)) . (\(GL.Name x) -> x)) <$> names]++renderBehaviour bus =+ case renderRequested of+ Just rreq -> do runtime' <- render runtime drawing+ revent' <- Buster.produce "Hieroglyph" "Hieroglyph" "RenderData" Buster.Persistent [Buster.EOther runtime']+ Buster.future . return $ [Buster.Deletion runtimeE , Buster.Deletion rreq, revent']+ Nothing -> Buster.future . 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 . filter ((=="Geometry") . Buster.name) $ drawingEs+ drawingEs = Set.toList $ Buster.eventsByGroup "Heiroglyph" bus+ renderRequested = Buster.eventByQName "Hieroglyph" "Hieroglyph" "PleaseRender" bus++render runtime@(HgGL _ _ _ _ win _) geo = do+ (GL.Position _ _, GL.Size sx sy ) <- GL.get GL.viewport+ GL.matrixMode $= GL.Projection+ GL.loadIdentity+ GL.ortho2D 0 (fromIntegral sx) (fromIntegral sy) 0+ GL.clearColor $= GL.Color4 0 0 0 1+ GL.clear [GL.ColorBuffer]+ GL.blend $= GL.Enabled+ GL.blendFunc $= (GL.SrcColor, GL.OneMinusSrcColor)+ r' <- renderObjects (Set.toList geo) runtime+ drawable <- Gtk.toGLDrawable <$> Gtk.glDrawingAreaGetGLWindow win+ 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 =+ if (fromIntegral . sig $ obj) `Map.member` (compiledgeometry runtime)+ then do+ renderCompiledGeometry $ (compiledgeometry runtime) Map.! (fromIntegral . sig $ obj)+ return runtime+ else 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') }+++++++++++++++++++++
Graphics/Rendering/Hieroglyph/Primitives.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns, FlexibleContexts, UndecidableInstances, StandaloneDeriving #-} -- | This is Hieroglyph, a 2D scenegraph library similar in functionality to a barebones -- stripped down version of Processing, but written in a purely functional manner. --@@ -5,45 +6,94 @@ -- for more information on how to use this library. -- -- [@Author@] Jeff Heard--- +-- -- [@Copyright@] © 2008 Renaissance Computing Institute--- +-- -- [@License@] A LICENSE file should be included as part of this distribution -- -- [@Version@] 0.5 -- module Graphics.Rendering.Hieroglyph.Primitives where+import Graphics.UI.Gtk.Pango.Layout +import Control.Applicative ((<$>))++import System.IO.Unsafe import Data.Function (on) import Data.Maybe (fromMaybe) import Data.List import Data.Colour import Data.Colour.Names import Data.Colour.SRGB---import Data.Foldable -import qualified Data.Map as M+--import Data.Foldable+import qualified Data.Map as Map import qualified Data.IntMap as IM+import Text.PrettyPrint (Doc, (<>), (<+>), render, char, empty, text)+import qualified Text.PrettyPrint+import qualified Data.HashTable+import System.Random +deriving instance Eq LayoutWrapMode+deriving instance Show LayoutWrapMode+deriving instance Ord LayoutWrapMode+deriving instance Eq LayoutAlignment+deriving instance Show LayoutAlignment+deriving instance Ord LayoutAlignment+deriving instance Read LayoutWrapMode+deriving instance Read LayoutAlignment++instance Read Doc where+ readsPrec i = (\s -> [])+ -- | A 2D point data Point = Point Double Double deriving (Show, Read, Eq, Ord) +xplus x (Point a b) = Point (x+a) b+yplus y (Point a b) = Point a (b+y)++pmap f (Point a b) = Point (f a) (f b)++comb f (Point x0 y0) (Point x1 y1) = Point (f x0 x1) (f y0 y1)++instance Num Point where+ (+) = comb (+)+ (*) = comb (*)+ (-) = comb (-)+ abs = pmap abs+ signum = pmap signum+ fromInteger x = let x' = fromInteger x in Point x' x'++instance Fractional Point where+ (/) = comb (/)+ fromRational a = Point (fromRational a) (fromRational a)++dist (Point x0 y0) (Point x1 y1) = sqrt $ (x1-x0)**2 + (y1-y0)**2++centroid ps = centroid' (Point 0 0) 0 ps+centroid' !s !n (p:ps) = centroid' (s+p) (n+1) ps+centroid' s n [] = s/n+ data Rect = Plane | Singularity | Rect { x1 :: Double, y1 :: Double, x2 :: Double, y2 :: Double } deriving (Show, Read, Eq) data LineSegment = Line Point | Spline Point Point Point | EndPoint Point deriving (Show,Read,Eq) +ls2pt (Line x) = x+ls2pt (Spline _ _ x) = x+ls2pt (EndPoint x) = x+ instance Ord LineSegment where compare (Line p) (Line p') = compare p p' compare (EndPoint p) (EndPoint p') = compare p p'- compare (Spline p q r) (Spline p' q' r') = - fromMaybe EQ - . find (/=EQ) - . zipWith compare [p,q,r] + compare (Spline p q r) (Spline p' q' r') =+ fromMaybe EQ+ . find (/=EQ)+ . zipWith compare [p,q,r] $ [p',q',r'] compare a b = (ordinal %=> compare) a b where ordinal (Line _) = 0 ordinal (Spline _ _ _) = 1 ordinal (EndPoint _) = 2- + instance (Floating a, Ord a) => Ord (AlphaColour a) where compare a b = fromMaybe EQ . find (/=EQ) . zipWith compare [channelRed a', channelGreen a', channelBlue a'] $ [channelRed b', channelGreen b', channelBlue b'] where a' = toSRGB $ if alphaChannel a == 0 then black else a `Data.Colour.over` black@@ -58,10 +108,10 @@ compare (Rect _ _ _ _) Singularity = GT compare Plane (Rect _ _ _ _) = LT compare Singularity (Rect _ _ _ _) = LT- compare (Rect xa1 ya1 xa2 ya2) (Rect xb1 xb2 yb1 yb2) = - fromMaybe EQ - . find (/=EQ) - . zipWith compare [xa1,xa2,ya1,ya2] + compare (Rect xa1 ya1 xa2 ya2) (Rect xb1 xb2 yb1 yb2) =+ fromMaybe EQ+ . find (/=EQ)+ . zipWith compare [xa1,xa2,ya1,ya2] $ [xb1,xb2,yb1,yb2] overlaps :: Rect -> Rect -> Bool@@ -75,25 +125,33 @@ (lx1',lx2') = if lx1 < lx2 then (lx1,lx2) else (lx2,lx1) (ly1',ly2') = if ly1 < ly2 then (ly1,ly2) else (ly2,ly1) (rx1',rx2') = if rx1 < rx2 then (rx1,rx2) else (rx2,rx1)- (ry1',ry2') = if ry1 < ry2 then (ry1,ry2) else (ry2,ry1) + (ry1',ry2') = if ry1 < ry2 then (ry1,ry2) else (ry2,ry1) -- | A 2D primitive in an arbitrary Cartesian 2d space-data Primitive = +data Primitive =+ -- | A list of points that is renderable.+ Dots+ { at :: [Point] -- The coordinates of the points in space+ , attribs :: Attributes -- The attributes of the points+ , sig :: Int+ } -- | An arc- Arc -- A pie slice or arc+ | Arc -- A pie slice or arc { center :: Point -- ^ center of the arc , radius :: Double -- ^ radius of the arc , angle1 :: Double -- ^ begin angle , angle2 :: Double -- ^ end angle , negative :: Bool -- ^ whether or not to consider this a slice of or a slice out of the pie , attribs :: Attributes- } + , sig :: Int+ } -- | A cubic spline | Path -- An arbitrary line or cubic spline { begin :: Point -- ^ starting point , segments :: [LineSegment] -- ^ A sequential list of curve segments. Note that the first two points are control points. , closed :: Bool -- ^ Whether or not to close this curve with a final line , attribs :: Attributes+ , sig :: Int } -- | A rectangle | Rectangle -- An rectangle@@ -101,231 +159,212 @@ , width :: Double -- ^ The width , height :: Double -- ^ The height , attribs :: Attributes+ , sig :: Int } -- | A simple text object | Text -- A simple text string- { str :: String -- ^ The string to print + { str :: Doc -- ^ The string to print, in Pango markup format , bottomleft :: Point -- ^ The anchor point for the text. Baseline, not bottom.+ , align :: LayoutAlignment+ , wrapwidth :: Maybe Double+ , wrapmode :: LayoutWrapMode+ , justify :: Bool+ , indent :: Double , attribs :: Attributes+ , spacing :: Double+ , sig :: Int }- -- | Not a primitive shape, exactly, but the union of several primitives. No order is implied in a union, merely that the areas that intersect are - | Union + -- | Not a primitive shape, exactly, but the union of several primitives. No order is implied in a union, merely that the areas that intersect are+ | Union { prims :: [Primitive] , attribs :: Attributes- } + , sig :: Int+ } -- | A rectangular image- | Image + | Image { filename :: String -- ^ The filename of the image. Should be something openable by Gdkpixbuf , dimensions :: Either Point Rect -- ^ The dimensions of the image in current coordinates. Either you use a point, and the image is full size, top left anchored to the point, or a rectangle- , preserveaspect :: Bool -- ^ Whether or not to scale preserving aspect ratio + , preserveaspect :: Bool -- ^ Whether or not to scale preserving aspect ratio , attribs :: Attributes+ , sig :: Int } -- | A hidden item. Used for state manipulation and to hide an object based on the current state- | Hidden - { attribs :: Attributes } - deriving (Show,Read,Eq) - -data Attributes = Attributes - { fontfamily :: String -- ^ The font name- , fontslant :: FontSlant -- ^ The font slant- , fontsize :: Double -- ^ The font size in points- , fontweight :: FontWeight -- ^ The font weight- , fillrule :: FillRule -- ^ The pattern fill rule- , fillRGBA :: AlphaColour Double -- ^ The components of the stroke color in the range [0..1]- , dash :: Maybe ([Double],Double) -- ^ The shape of the line dashing, if any- , strokeRGBA :: AlphaColour Double -- ^ The components of the stroke color in the range [0..1]- , antialias :: Antialias -- ^ The way things are antialiased- , linecap :: LineCap -- ^ The way lines are capped- , linejoin :: LineJoin -- ^ The way lines are joined- , linewidth :: Double -- ^ The width of a line in points- , miterlimit :: Double -- ^ The miter limit of lines. See Cairo's documentation- , tolerance :: Double -- ^ The trapezoidal tolerance. See Cairo's documentation- , operator :: Operator -- ^ The transfer operator. See Cairo's documentation for more <http://cairographics.org>- , translatex :: Double -- ^ The current translation x component- , translatey :: Double -- ^ The current translation y component - , scalex :: Double -- ^ The current scale x component- , scaley :: Double -- ^ The current scale y component- , rotation :: Double -- ^ The rotation in degrees that this primitive is seen in- , filled :: Bool -- ^ Whether or not this primitive is filled in- , outlined :: Bool -- ^ Whether or not this primitive is outlined- , clipped :: Bool -- ^ Whether or not this primitive is part of the clipping plane+ | Hidden+ { attribs :: Attributes+ , sig :: Int+ }+ deriving (Show,Read,Eq)+++instance Eq Doc where+ x == y = show x == show y++instance Ord Doc where+ compare = show %=> compare++data Attributes = Attributes+ { 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 <http://cairographics.org>+ , 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. - , name :: Maybe String -- ^ The name of the object+ , 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- } + } deriving (Show,Read,Eq)- + g %=> f = f `on` g --- | define some instance of Ord over attributes that compares attribute sets --- based on the occlusion layer and rendering cost of setting two primitives +-- | define some instance of Ord over attributes that compares attribute sets+-- based on the occlusion layer and rendering cost of setting two primitives -- next to one another. instance Ord Attributes where- compare a b = fromMaybe EQ - . find (/=EQ)- . map ($(a,b)) . map uncurry $ - [ layer %=> compare- , fontfamily %=> compare- , fontweight %=> compare - , fontslant %=> compare - , fontsize %=> compare - , scalex %=> compare- , scaley %=> compare- , translatex %=> compare- , translatey %=> compare- , rotation %=> compare- , operator %=> compare- , linecap %=> compare- , linejoin %=> compare- , linewidth %=> compare- , fillRGBA %=> compare- , strokeRGBA %=> compare- , miterlimit %=> compare- , tolerance %=> compare- , bbox %=> compare- , fillrule %=> compare- , lod %=> compare- ]+ compare a b = fromMaybe EQ $ find (/=EQ) . map ($(a,b)) . map uncurry $ [layer %=> compare, aname %=>compare] -- | define a total ordering over the primitives based on layer and rendering cost instance Ord Primitive where- compare a b = let cmp = (attribs %=> compare) a b in if cmp == EQ then (compareprim a b) else cmp- where compareprim (Arc o r t0 t1 n _) (Arc o' r' t0' t1' n' _) = fromMaybe EQ . find (/=EQ) $ [compare r r', compare t0 t0', compare t1 t1', compare o o', compare n n']- compareprim (Path b s c _) (Path b' s' c' _) = fromMaybe EQ . find (/=EQ) $ [compare b b', compare s s', compare c c']- compareprim (Rectangle t w h _) (Rectangle t' w' h' _) = fromMaybe EQ . find (/=EQ) $ [compare w w', compare h h', compare t t']- compareprim (Text s b _) (Text s' b' _) = fromMaybe EQ . find (/=EQ) $ [compare b b', compare s s']- compareprim (Image f d p _) (Image f' d' p' _) = fromMaybe EQ . find (/=EQ) $ [compare f f', compare d d', compare p p']- compareprim (Hidden _) (Hidden _) = EQ- compareprim a b = (ordinal %=> compare) a b- ordinal (Arc _ _ _ _ _ _) = 0- ordinal (Path _ _ _ _) = 1- ordinal (Rectangle _ _ _ _) = 2- ordinal (Text _ _ _) = 3- ordinal (Union _ _) = 4- ordinal (Image _ _ _ _) = 5- ordinal (Hidden _) = 6- + compare a b = let cmp = (attribs %=> compare) a b in if cmp == EQ then (sig %=> compare) a b else cmp -- | See the Cairo meanings of these. I plan to introduce OpenGL equivalents-data FontSlant = - FontSlantNormal - | FontSlantItalic - | FontSlantOblique- deriving (Show,Read,Ord,Eq)- --- | See the Cairo meanings of these. I plan to introduce OpenGL equivalents-data FontWeight = - FontWeightNormal - | FontWeightBold- deriving (Show,Read,Ord,Eq)- --- | See the Cairo meanings of these. I plan to introduce OpenGL equivalents-data Antialias = - AntialiasDefault - | AntialiasNone - | AntialiasGray - | AntialiasSubpixel +data Antialias =+ AntialiasDefault+ | AntialiasNone+ | AntialiasGray+ | AntialiasSubpixel deriving (Show,Read,Ord,Eq)- + -- | See the Cairo meanings of these. I plan to introduce OpenGL equivalents-data FillRule = +data FillRule = FillRuleWinding | FillRuleEvenOdd deriving (Show,Read,Ord,Eq) --- | See the Cairo meanings of these. I plan to introduce OpenGL equivalents -data LineCap = - LineCapButt - | LineCapRound +-- | See the Cairo meanings of these. I plan to introduce OpenGL equivalents+data LineCap =+ LineCapButt+ | LineCapRound | LineCapSquare deriving (Show,Read,Ord,Eq) -- | See the Cairo meanings of these. I plan to introduce OpenGL equivalents-data LineJoin = - LineJoinMiter - | LineJoinRound +data LineJoin =+ LineJoinMiter+ | LineJoinRound | LineJoinBevel deriving (Show,Read,Ord,Eq) -- | See the Cairo meanings of these. I plan to introduce OpenGL equivalents-data Operator = +data Operator = OperatorClear | OperatorSource | OperatorOver | OperatorIn | OperatorOut- | OperatorAtop - | OperatorDest + | OperatorAtop+ | OperatorDest | OperatorDestOver | OperatorDestIn | OperatorDestOut | OperatorDestAtop | OperatorXor | OperatorAdd- | OperatorSaturate + | OperatorSaturate deriving (Show,Read,Ord,Eq)- + -- | The default primitive attributes. See source code for more details. plain :: Attributes-plain = - Attributes - { fontfamily = "Arial.ttf"- , fontslant = FontSlantNormal- , fontweight = FontWeightNormal- , fontsize = 10- , fillrule = FillRuleWinding- , fillRGBA = opaque white- , dash = Nothing- , strokeRGBA = opaque white- , antialias = AntialiasDefault- , linecap = LineCapButt- , linejoin = LineJoinMiter- , linewidth = 1- , miterlimit = 0- , tolerance = 0.1- , operator = OperatorOver- , translatex = 0- , translatey = 0- , scalex = 1- , scaley = 1- , rotation = 0 - , outlined = True- , clipped = False- , filled = False- , bbox = Plane +plain =+ Attributes+ { afillrule = FillRuleWinding+ , afillRGBA = opaque white+ , adash = Nothing+ , astrokeRGBA = opaque white+ , aantialias = AntialiasDefault+ , alinecap = LineCapButt+ , alinejoin = LineJoinMiter+ , alinewidth = 1+ , amiterlimit = 0+ , atolerance = 0.1+ , aoperator = OperatorOver+ , atranslatex = 0+ , atranslatey = 0+ , ascalex = 1+ , ascaley = 1+ , arotation = 0+ , aoutlined = True+ , aclipped = False+ , afilled = False+ , bbox = Plane , layer = 0 , lod = 0- , name = Nothing } + , aname = Nothing } ++-- | following combinators added to Text.PrettyPrint+span a s = mark ("span " ++ a) s++mark m d = char '<' <> text m <> char '>' <> d <> text "</" <> text m <> char '>'+bold = mark "b"+bigger = mark "big"+italic = mark "i"+strikethrough = mark "s"+subscript = mark "sub"+superscript = mark "sup"+smaller = mark "small"+monospace = mark "tt"+underline = mark "u"++-- end Text.PrettyPrint combinators.++nguid :: () -> Int -- GAAAH!!! Just name your objects, folks, please.+nguid () = unsafePerformIO $ getStdRandom (randomR (0,2147483648))++sign x = x{ sig = fromMaybe (nguid ()) (fromIntegral . Data.HashTable.hashString <$> (aname . attribs $ x)) }+ -- | the origin point origin :: Point-origin = Point 0 0 +origin = Point 0 0 arc :: Primitive -- ^ A unit circle by default, modifiable with record syntax.-arc = Arc origin 1 0 (2*pi) False plain+arc = sign $ Arc origin 1 0 (2*pi) False plain 0 path :: Primitive -- ^ A line starting at the origin.-path = Path origin [] False plain+path = sign $ Path origin [] False plain 0 polygon :: Primitive -- ^ An arbitrary filled polygon starting at the origin.-polygon = Path origin [] True plain{ filled=True }+polygon = sign $ Path origin [] True plain{ afilled=True } 0 rectangle :: Primitive -- ^ an outlined rectangle-rectangle = Rectangle (Point 0 1) 1 1 plain+rectangle = sign $ Rectangle (Point 0 1) 1 1 plain 0 -text :: Primitive -- ^ A rendered string starting at the origin.-text = Text "" origin plain+string :: Primitive -- ^ A rendered string starting at the origin.+string = sign $ Text empty origin AlignLeft (Just 0) WrapWholeWords False 0 plain 0 0 compound :: Primitive -- ^ An outlined compound object-compound = Union [] plain+compound = sign $ Union [] plain 0 degrees :: Double -> Double -- ^ Convert degrees to radians degrees x = x * 0.0174532925 hidden :: Primitive -- ^ A hidden object.-hidden = Hidden plain+hidden = sign $ Hidden plain 0 image :: Primitive -- ^ An image. These are efficiently cached using weak references where possible-image = Image "" (Left origin) False plain+image = sign $ Image "" (Left origin) False plain 0
Graphics/Rendering/Hieroglyph/Visual.hs view
@@ -1,11 +1,12 @@+{-# LANGUAGE NoMonomorphismRestriction #-} -- | Here I describe and define the class Visual and some example instances -- for the basic data structures in the GHC standard library, including -- Data.Map, Data.IntMap, Data.Set, and Lists. This gives a rich library--- of data structures that are Visual as a direct transformation from +-- of data structures that are Visual as a direct transformation from -- forall a, Visual b : a -> Visual b--- {-# LANGUAGE FlexibleInstances,IncoherentInstances #-} module Graphics.Rendering.Hieroglyph.Visual where +import Data.Monoid import qualified Data.Map as M import qualified Data.IntMap as IM import qualified Data.Set as S@@ -13,14 +14,14 @@ import Data.List import Graphics.Rendering.Hieroglyph.Primitives -type BaseVisual = [Primitive]+type BaseVisual = S.Set Primitive --- | A Visual is an unstructured collection of primitives. Conceptually, the +-- | A Visual is an unstructured collection of primitives. Conceptually, the -- only requirement of a Visual is that it is Enumerable (or Foldable) in -- terms of Primitives. I initially wanted to implement this in terms of -- the Foldable typeclass from Data.Foldable, but very few things provide--- instances of Foldable that are conceptually so. A list is Foldable, --- and I have certain guarantees of efficiency by operating on lists, so +-- instances of Foldable that are conceptually so. A list is Foldable,+-- and I have certain guarantees of efficiency by operating on lists, so -- this is the instance of Foldable that I choose to have people implement. class Visual t where primitives :: t -> BaseVisual@@ -28,49 +29,66 @@ -- | A Primitive by itself is a Visual. That is, a single piece of geometry -- standing alone is in fact Visual. instance Visual Primitive where- primitives a = [a]+ primitives a = S.singleton a --- | A any list of Visuals can be flattenend into a list of Primitives by +-- | A any list of Visuals can be flattenend into a list of Primitives by -- a right fold, therefore a List of Visuals is a Visual instance Visual a => Visual [a] where- primitives = Prelude.concat . Prelude.map primitives - + primitives x = mconcat $ primitives `map` x+ -- | A map to Visuals is Foldable over the elements in terms of Visuals, which -- are in turn Foldable in terms of Primitives, therefore a map of instance Visual b => Visual (M.Map a b) where- primitives = Prelude.concat . Prelude.map primitives . M.elems+ primitives = primitives . M.elems -- | An intmap is merely a map, so once again if the elements are Visuals, the -- whole structure is a Visual. instance Visual b => Visual (IM.IntMap b) where- primitives = Prelude.concat . Prelude.map primitives . IM.elems + primitives = primitives . IM.elems -- | A set of Visuals also comprises a Visual. instance Visual t => Visual (S.Set t) where- primitives = Prelude.concat . Prelude.map primitives . S.toList+ primitives = primitives . S.toList -- | Declare that a Visual possibly occludes another Visual-over :: (Visual t, Visual u) => t -> u -> BaseVisual-over this that = (map (\p -> p{ attribs = (attribs p){ layer = layer (attribs p) + maxlev + 1 }}) . primitives $ this) ++ primitives that- where maxlev = if primitives that /= [] then maximum . map (layer . attribs) . primitives $ that else 0- -infixr 9 `over`-infixr 9 `moreSpecific` - --- | Declare that a Visual is more specific than another Visual. This way one drawing can have multiple levels of detail. -moreSpecific :: (Visual t, Visual u) => t -> u -> BaseVisual-moreSpecific this that = (map (\p -> p{ attribs = (attribs p){ lod = maxlev+1 }}) . primitives $ this) ++ primitives that- where maxlev = if primitives that /= [] then minimum . map (lod . attribs) . primitives $ that else 0- --- | Get an ordering of two Visuals to see if one possibly occludes the other. The greater one is on top.-isOverOrUnder :: (Visual t, Visual u) => t -> u -> Ordering-isOverOrUnder a b = compare maxb maxa- where maxa = maximum . map (layer . attribs) . primitives $ a- maxb = maximum . map (layer . attribs) . primitives $ b+occludes :: (Visual t, Visual u) => t -> u -> BaseVisual+occludes this that = ((\p -> p{ layer = maxlev+1 }) <%> primitives this) `mappend` (primitives that)+ where maxlev = maximum . map (layer . attribs) . S.toList . primitives $ that --- | Get an ordering of two Visuals to see if one is more specific than another. Useful for filtering out detail for a higher level vis.-isMoreSpecific :: (Visual t, Visual u) => t -> u -> Ordering-isMoreSpecific a b = compare maxb maxa- where maxa = maximum . map (lod . attribs) . primitives $ a- maxb = maximum . map (lod . attribs) . primitives $ b+beside :: (Visual t, Visual u) => t -> u -> BaseVisual+beside this that = ((\p -> p{ layer = maxlev }) <%> primitives this) `mappend` (primitives that)+ where maxlev = maximum . map (layer . attribs) . S.toList . primitives $ that++pure x = S.singleton x++f <%> x = S.map (\a -> a{ attribs = (f . attribs $ a)}) x+(#+#) = beside+(#/#) = occludes+(#\#) = flip occludes++infixr 9 `occludes`+infixl 4 <%>+infixr 8 #+#+infixr 9 #/#+infixr 9 #\#++fillrule x os = (\o -> o{ afillrule = x }) <%> primitives os+fillcolour x os = (\o -> o{ afillRGBA = x }) <%> primitives os+dash x os = (\o -> o{adash = x}) <%> primitives os+strokecolour x os = (\o -> o{ astrokeRGBA = x }) <%> primitives os+linecap x os = (\o -> o{alinecap = x}) <%> primitives os+miterlimit x os = (\o -> o{amiterlimit = x}) <%> primitives os+tolerance x os = (\o -> o{atolerance = x}) <%> primitives os+scalex x os = (\o -> o{ascalex = x}) <%> primitives os+scaley x os = (\o -> o{ascaley = x}) <%> primitives os+scale x y os = (\o -> o{ascalex = x * ascalex o, ascaley = y * ascaley o})<%> primitives os+settranslatex x os = (\o -> o{atranslatex = x })<%> primitives os+settranslatey y os = (\o -> o{atranslatey = y })<%> primitives os+translate x y os = (\o -> o{atranslatex = x + atranslatex o, atranslatey = y + atranslatey o})<%> primitives os+rotation x os = (\o -> o{arotation = x}) <%> primitives os+filled x os = (\o -> o{afilled = x}) <%> primitives os+outlined x os = (\o -> o{aoutlined = x}) <%> primitives os+clipped x os = (\o -> o{aclipped = x}) <%> primitives os+name x os = (\o -> o{aname = Just x}) <%> primitives os+
Hieroglyph.cabal view
@@ -1,27 +1,57 @@-Name: Hieroglyph-Version: 1.21-Cabal-Version: >= 1.2-License: BSD3-License-File: LICENSE-Author: J.R. Heard-Maintainer: J.R. Heard <jefferson.r.heard@gmail.com>-Category: Graphics-Description: - A purely functional 2D scenegraph library with functionality similar to a barebones Processing.- Currently entirely implmeneted using Cairo, although I would like to go to OpenGL as well.-Synopsis: Purely functional 2D drawing-Build-Type: Simple--Library- Build-Depends: cairo, base, mtl, gtk, IfElse, containers, parallel, colour- ghc-options: -O2 -fvia-C -optc-O2- Exposed-Modules:- Graphics.Rendering.Hieroglyph- Graphics.Rendering.Hieroglyph.Cairo- Graphics.Rendering.Hieroglyph.ImageCache- Graphics.Rendering.Hieroglyph.Interactive- Graphics.Rendering.Hieroglyph.Primitives- Graphics.Rendering.Hieroglyph.Scaffolds.Interactive- Graphics.Rendering.Hieroglyph.Visual--+name: Hieroglyph+version: 2.0+cabal-version: >=1.2+build-type: Simple+license: BSD3+license-file: LICENSE+copyright:+maintainer: J.R. Heard+build-depends: FTGL -any, IfElse -any, OpenGL -any, array -any,+ base -any, buster -any, bytestring -any, cairo -any, colour -any,+ containers -any, gtk -any, gtkglext -any, mtl -any, parallel -any,+ pretty -any, random -any+stability:+homepage: http://vis.renci.org/jeff/hieroglyph+package-url:+bug-reports:+synopsis: Purely functional 2D drawing+description: A purely functional 2D scenegraph library with functionality similar to a barebones Processing.+ Currently entirely implmeneted using Cairo, although I would like to go to OpenGL as well.+category: Graphics+author: J.R. Heard+tested-with:+data-files:+data-dir: ""+extra-source-files:+extra-tmp-files:+exposed-modules: Graphics.Rendering.Hieroglyph+ Graphics.Rendering.Hieroglyph.Cairo+ Graphics.Rendering.Hieroglyph.OpenGL+ Graphics.Rendering.Hieroglyph.ImageCache+ Graphics.Rendering.Hieroglyph.Interactive+ Graphics.Rendering.Hieroglyph.Primitives+ Graphics.Rendering.Hieroglyph.Visual+ Graphics.Rendering.Hieroglyph.Scaffolds.Interactive+exposed: True+buildable: True+build-tools:+cpp-options:+cc-options:+ld-options:+pkgconfig-depends:+frameworks:+c-sources:+extensions:+extra-libraries:+extra-lib-dirs:+includes:+install-includes:+include-dirs:+hs-source-dirs: .+other-modules:+ghc-prof-options:+ghc-shared-options:+ghc-options:+hugs-options:+nhc98-options:+jhc-options: