diff --git a/Graphics/Rendering/Hieroglyph/Cairo.hs b/Graphics/Rendering/Hieroglyph/Cairo.hs --- a/Graphics/Rendering/Hieroglyph/Cairo.hs +++ b/Graphics/Rendering/Hieroglyph/Cairo.hs @@ -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) diff --git a/Graphics/Rendering/Hieroglyph/Interactive.hs b/Graphics/Rendering/Hieroglyph/Interactive.hs --- a/Graphics/Rendering/Hieroglyph/Interactive.hs +++ b/Graphics/Rendering/Hieroglyph/Interactive.hs @@ -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 diff --git a/Graphics/Rendering/Hieroglyph/OpenGL.hs b/Graphics/Rendering/Hieroglyph/OpenGL.hs new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Hieroglyph/OpenGL.hs @@ -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 + , 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') } + + + + + + + + + + + + + + + + + + + + + diff --git a/Graphics/Rendering/Hieroglyph/Primitives.hs b/Graphics/Rendering/Hieroglyph/Primitives.hs --- a/Graphics/Rendering/Hieroglyph/Primitives.hs +++ b/Graphics/Rendering/Hieroglyph/Primitives.hs @@ -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 - , 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 + , 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 diff --git a/Graphics/Rendering/Hieroglyph/Visual.hs b/Graphics/Rendering/Hieroglyph/Visual.hs --- a/Graphics/Rendering/Hieroglyph/Visual.hs +++ b/Graphics/Rendering/Hieroglyph/Visual.hs @@ -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 + diff --git a/Hieroglyph.cabal b/Hieroglyph.cabal --- a/Hieroglyph.cabal +++ b/Hieroglyph.cabal @@ -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 -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: