Hieroglyph 0.85 → 0.99
raw patch · 12 files changed
+776/−581 lines, 12 filesdep +parallel
Dependencies added: parallel
Files
- Graphics/Rendering/Hieroglyph.hs +4/−4
- Graphics/Rendering/Hieroglyph/BasicUIState.hs +0/−64
- Graphics/Rendering/Hieroglyph/Cairo.hs +139/−240
- Graphics/Rendering/Hieroglyph/Colors.hs +38/−60
- Graphics/Rendering/Hieroglyph/ImageCache.hs +10/−0
- Graphics/Rendering/Hieroglyph/Interactive.hs +58/−70
- Graphics/Rendering/Hieroglyph/Primitives.hs +257/−70
- Graphics/Rendering/Hieroglyph/Scaffolds/Interactive.hs +186/−0
- Graphics/Rendering/Hieroglyph/UIState.hs +0/−66
- Graphics/Rendering/Hieroglyph/Visual.hs +76/−0
- Hieroglyph.cabal +7/−6
- LICENSE +1/−1
Graphics/Rendering/Hieroglyph.hs view
@@ -1,13 +1,13 @@ module Graphics.Rendering.Hieroglyph - (module Graphics.Rendering.Hieroglyph.UIState- ,module Graphics.Rendering.Hieroglyph.Cairo+ (module Graphics.Rendering.Hieroglyph.Cairo ,module Graphics.Rendering.Hieroglyph.Primitives ,module Graphics.Rendering.Hieroglyph.Interactive- ,module Graphics.Rendering.Hieroglyph.Colors) where+ ,module Graphics.Rendering.Hieroglyph.Colors+ ,module Graphics.Rendering.Hieroglyph.Visual) where -import Graphics.Rendering.Hieroglyph.UIState import Graphics.Rendering.Hieroglyph.Cairo import Graphics.Rendering.Hieroglyph.Primitives import Graphics.Rendering.Hieroglyph.Interactive import Graphics.Rendering.Hieroglyph.Colors+import Graphics.Rendering.Hieroglyph.Visual
− Graphics/Rendering/Hieroglyph/BasicUIState.hs
@@ -1,64 +0,0 @@--- | If the items in the UIState module are the only state you need in your--- program, then it is sufficient to import this module and start with the--- defaultBasicState.------ [@Author@] Jeff Heard------ [@Copyright@] © 2008 Renaissance Computing Institute----module Graphics.Rendering.Hieroglyph.BasicUIState where--import qualified Graphics.Rendering.Hieroglyph.UIState as U-import Graphics.Rendering.Hieroglyph.Primitives-import qualified Graphics.UI.Gtk as Gtk-import Control.Concurrent (MVar)-import Data.Map (Map)----- The most basic implementation of a UIState-data BasicUIState = BasicUIState - { mousePosition :: Point- , mouseLeftButtonDown :: Bool- , mouseRightButtonDown :: Bool- , mouseMiddleButtonDown :: Bool- , mouseWheel :: Int- , keyCtrl :: Bool- , keyShift :: Bool- , keyAlt :: Bool- , key :: U.Key - , drawing :: Maybe Gtk.Widget - , sizeX :: Double- , sizeY :: Double - , imageCache :: Maybe U.ImageCache }--instance U.UIState BasicUIState where- mousePosition = mousePosition- mouseLeftButtonDown = mouseLeftButtonDown- mouseRightButtonDown = mouseRightButtonDown- mouseMiddleButtonDown = mouseMiddleButtonDown- mouseWheel = mouseWheel- keyCtrl = keyCtrl- keyShift = keyShift- keyAlt = keyAlt- key = key- drawing = drawing- sizeX = sizeX- sizeY = sizeY- imageCache = imageCache-- setMousePosition p a = a{ mousePosition = p }- setMouseLeftButtonDown p a = a{ mouseLeftButtonDown = p }- setMouseRightButtonDown p a = a{ mouseRightButtonDown = p }- setMouseMiddleButtonDown p a = a{ mouseMiddleButtonDown = p }- setMouseWheel p a = a{ mouseWheel = p }- setKeyCtrl p a = a{ keyCtrl = p }- setKeyShift p a = a{ keyShift = p }- setKeyAlt p a = a{ keyAlt = p }- setKey p a = a{ key = p }- setDrawing p a = a{ drawing = p }- setSizeX p a = a{ sizeX = p }- setSizeY p a = a{ sizeY = p }- setImageCache p a = a{ imageCache = p }---- This is the default state you should pass to the interactive function.-defaultBasicUIState = BasicUIState (Point 0 0) False False False 0 False False False (U.Character '\0') Nothing 800 600 Nothing
Graphics/Rendering/Hieroglyph/Cairo.hs view
@@ -25,115 +25,85 @@ import Control.Concurrent import Control.Monad.Trans (liftIO) import Graphics.Rendering.Hieroglyph.Primitives+import Graphics.Rendering.Hieroglyph.ImageCache+import Graphics.Rendering.Hieroglyph.Visual import Graphics.UI.Gtk.Gdk.Pixbuf import qualified Graphics.UI.Gtk.Cairo as Cairo import qualified Graphics.Rendering.Cairo as Cairo import Control.Monad import Control.Monad.IfElse-import Data.List (foldl')-import Graphics.Rendering.Hieroglyph.UIState+import Data.Foldable (foldlM)+import Data.List (sort) --- | Modifies the way that primitives are drawn in subtrees where a 'Setup' marker --- in the parent nodes. All state changes are inherited lie you might think they--- ought to be. All colors are specified like in Cairo, using Doubles in the --- range [0..1].-data StateModifier = - ResetClip -- ^ Reset the clipping plane- | Translate Double Double -- ^ @Translate x y@ translates all subitems by x and y- | Scale Double Double -- ^ @Scale x y@ scales the subitems by x and y - | Rotate Double -- ^ @Rotate r@ everything clockwise by r radians- | Font String -- ^ Set the font family. See 'Graphics.Rendering.Cairo.selectFontFace' for behaviour.- | FontSlant Cairo.FontSlant -- ^ Set the font slant. - | FontWeight Cairo.FontWeight -- ^ Set the font weight. - | FillRule Cairo.FillRule -- ^ Set the way patterns are filled. Does nothing if you haven't yet set the pattern yourself.- | FillRed Double -- ^ Set the fill color's red component without changing anything else- | FillGreen Double -- ^ Set the fill color's green component without changing anything else- | FillBlue Double -- ^ Set the fill color's blue component without changing anything else- | FillAlpha Double -- ^ Set the fill color's alpha component without changing anything else- | FillRGB Double Double Double -- ^ @FillRGB r g b@ sets the fill RGB to r g b and the alpha component to 1- | StrokeRGB Double Double Double -- ^ @StrokeRGB r g b@ sets the stroke RGB to r g b and the alpha component to 1- | StrokeRGBA Double Double Double Double -- ^ @StrokeRGBA r g b a@ sets the stroke color- | FillRGBA Double Double Double Double -- ^ @FillRGBA r g b a@ sets the fill color- | Dash [Double] Double -- ^ @Dash pattern width@ sets the dash pattern for lines (OpenGL will need to use a stipple pattern, I think) - | StrokeRed Double -- ^ Set the stroke color's red component without changing anything else- | StrokeGreen Double -- ^ Set the stroke color's green component without changing anything else- | StrokeBlue Double -- ^ Set the stroke color's blue component without changing anything else- | StrokeAlpha Double -- ^ Set the stroke color's alpha component without changing anything else- | Antialias Cairo.Antialias -- ^ Set the way antialiasing is performed. This may be non-portable between Cairo and OpenGL without employing a shader- | LineCap Cairo.LineCap -- ^ Set the line cap style- | LineJoin Cairo.LineJoin -- ^ Set the line join style- | LineWidth Double -- ^ Set the width of the line in points- | MiterLimit Double -- ^ Set the miter limit for corners- | Tolerance Double -- ^ Set the trapezoidal tolerance. This may be irrelevant in OpenGL, but it controls the quality of lines in Cairo.- | Operator Cairo.Operator -- ^ Set the way the source is transferred to the surface through the stencil. Emulating this functionality in OpenGL may be difficult.- | CurrentPoint Point -- ^ Set the current point that the pen is at. Note that this only sets it, any changes made to the current point by the children are still changes. To ensure that this is the current point, use a 'Pen' draw command.+toCairoFontSlant FontSlantNormal = Cairo.FontSlantNormal+toCairoFontSlant FontSlantItalic = Cairo.FontSlantItalic+toCairoFontSlant FontSlantOblique = Cairo.FontSlantOblique --- | A tree structure that defines a frame. The first argument is either a --- 'Draw' or a 'Setup' command and the list is a list of children. -data Object = Group [Object]- | Draw Primitive- | Context [StateModifier] Object+toCairoFontWeight FontWeightNormal = Cairo.FontWeightNormal+toCairoFontWeight FontWeightBold = Cairo.FontWeightBold --- | The current state of the renderer. Carried down the tree and modified with 'StateModifier' 'Node's. -data RendererState = RendererState- { fontfamily :: String -- ^ The font name- , fontslant :: Cairo.FontSlant -- ^ The font slant- , fontsize :: Double -- ^ The font size in points- , fontweight :: Cairo.FontWeight -- ^ The font weight- , fillrule :: Cairo.FillRule -- ^ The pattern fill rule- , fillred :: Double -- ^ The red component of the fill color in the range [0..1]- , fillgreen :: Double -- ^ The green component of the fill color in the range [0..1]- , fillblue :: Double -- ^ The blue component of the fill color in the range [0..1]- , fillalpha :: Double -- ^ The alpha component of the fill color in the range [0..1]- , dash :: Maybe ([Double],Double) -- ^ The shape of the line dashing, if any- , strokered :: Double -- ^ The red component of the stroke color in the range [0..1]- , strokegreen :: Double -- ^ The red component of the stroke color in the range [0..1]- , strokeblue :: Double -- ^ The red component of the stroke color in the range [0..1]- , strokealpha :: Double -- ^ The red component of the stroke color in the range [0..1]- , antialias :: Cairo.Antialias -- ^ The way things are antialiased- , linecap :: Cairo.LineCap -- ^ The way lines are capped- , linejoin :: Cairo.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 :: Cairo.Operator -- ^ The transfer operator. See Cairo's documentation for more <http://cairographics.org>- , currentpoint :: Point -- ^ Current base point for the first child's graphics operation - , 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 current clockwise rotation in radians.+toCairoAntialias AntialiasDefault = Cairo.AntialiasDefault +toCairoAntialias AntialiasNone = Cairo.AntialiasNone +toCairoAntialias AntialiasGray = Cairo.AntialiasGray +toCairoAntialias AntialiasSubpixel = Cairo.AntialiasSubpixel -fillStrokeAndClip state isfilled isoutlined isclipped = do - when isfilled $ - Cairo.setSourceRGBA (fillred state) (fillgreen state) (fillblue state) (fillalpha state) >> - if isoutlined then Cairo.fillPreserve else Cairo.fill- when isoutlined $ - Cairo.setSourceRGBA (strokered state) (strokegreen state) (strokeblue state) (strokealpha state) >>+toCairoFillRule FillRuleWinding = Cairo.FillRuleWinding +toCairoFillRule FillRuleEvenOdd = Cairo.FillRuleEvenOdd++toCairoLineCap LineCapButt = Cairo.LineCapButt +toCairoLineCap LineCapRound = Cairo.LineCapRound +toCairoLineCap LineCapSquare = Cairo.LineCapSquare ++toCairoLineJoin LineJoinMiter = Cairo.LineJoinMiter +toCairoLineJoin LineJoinRound = Cairo.LineJoinRound +toCairoLineJoin LineJoinBevel = Cairo.LineJoinBevel ++toCairoOperator OperatorClear = Cairo.OperatorClear+toCairoOperator OperatorSource = Cairo.OperatorSource+toCairoOperator OperatorOver = Cairo.OperatorOver+toCairoOperator OperatorIn = Cairo.OperatorIn+toCairoOperator OperatorOut = Cairo.OperatorOut+toCairoOperator OperatorAtop = Cairo.OperatorAtop+toCairoOperator OperatorDest = Cairo.OperatorDest+toCairoOperator OperatorXor = Cairo.OperatorXor+toCairoOperator OperatorAdd = Cairo.OperatorAdd+toCairoOperator OperatorSaturate = Cairo.OperatorSaturate++fillStrokeAndClip state = do + let (fr,fg,fb,fa) = fillRGBA state+ (sr,sg,sb,sa) = strokeRGBA state+ when (filled state) $ + Cairo.setSourceRGBA fr fg fb fa >> + if (outlined state) then Cairo.fillPreserve else Cairo.fill+ when (outlined state) $ + Cairo.setSourceRGBA sr sg sb sa >> Cairo.stroke- when isclipped $ Cairo.clip+ when (clipped 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 + -- | @renderPrimitive state prim@ draws a single primitive.-renderPrimitive :: ImageCache -> RendererState -> Primitive -> Cairo.Render ()-renderPrimitive _ state (Arc (Point cx cy) radius angle0 angle1 isnegative f o c) = do+renderPrimitive :: ImageCache -> Attributes -> Primitive -> Cairo.Render Attributes+renderPrimitive _ s0 (Arc (Point cx cy) radius angle0 angle1 isnegative state) = do + applyAttributeDelta s0 state if isnegative then Cairo.arcNegative cx cy radius angle0 angle1 else Cairo.arc cx cy radius angle0 angle1- fillStrokeAndClip state f o c--renderPrimitive _ state (Curve (Point ox oy) segs isclosed f o c) = do - Cairo.moveTo ox oy- forM_ segs $ \(Point x1 y1,Point x2 y2,Point x3 y3) -> Cairo.curveTo x1 y1 x2 y2 x3 y3- when isclosed (Cairo.lineTo ox oy)- fillStrokeAndClip state f o c+ fillStrokeAndClip state+ return state -renderPrimitive _ state (Line (Point ox oy) segs isclosed f o c) = do+renderPrimitive _ s0 (Path (Point ox oy) segs isclosed state) = do + applyAttributeDelta s0 state Cairo.moveTo ox oy- mapM (\seg -> case seg of Point x y -> Cairo.lineTo x y) segs+ forM_ segs $ renderCurveSegs when isclosed (Cairo.lineTo ox oy)- fillStrokeAndClip state f o c+ fillStrokeAndClip state+ return state -renderPrimitive images state i@(Image filename (Left (Point ox oy)) _) = do+renderPrimitive images s0 i@(Image filename (Left (Point ox oy)) _ state) = do+ applyAttributeDelta s0 state pbuf <- loadImage images i w <- liftIO $ pixbufGetWidth pbuf h <- liftIO $ pixbufGetHeight pbuf@@ -142,181 +112,110 @@ Cairo.rectangle ox oy (fromIntegral w) (fromIntegral h) Cairo.fill Cairo.restore-renderPrimitive images state i@(Image filename (Right (Rect ox oy w h)) _) = do+ return state++renderPrimitive images s0 i@(Image filename (Right (Rect ox oy w h)) _ state) = do+ applyAttributeDelta s0 state pbuf <- loadImage images i Cairo.save Cairo.setSourcePixbuf pbuf ox oy Cairo.rectangle ox oy w h Cairo.fill Cairo.restore--renderPrimitive _ _ Hidden = return () -renderPrimitive _ _ (Pen (Point ox oy)) = Cairo.moveTo ox oy-renderPrimitive _ state (Rectangle (Point ox oy) w h f o c) = Cairo.rectangle ox oy w h >> fillStrokeAndClip state f o c-renderPrimitive _ state (Text str (Point ox oy) f o c) = Cairo.showText str >> fillStrokeAndClip state f o c-renderPrimitive images state (Compound prims f o c) = mapM (renderPrimitive images state . unfoc) prims >> fillStrokeAndClip state f o c- where unfoc prim = prim{ filled=False, outlined=False, clipped=False }---- | The initial state of Cairo, encoded as an object.-defaultState :: RendererState-defaultState = - RendererState - { fontfamily = "arial"- , fontslant = Cairo.FontSlantNormal- , fontweight = Cairo.FontWeightNormal- , fontsize = 10- , fillrule = Cairo.FillRuleWinding- , fillred = 1- , fillgreen = 1- , fillblue = 1- , fillalpha = 1- , dash = Nothing- , strokered = 1- , strokegreen = 1- , strokeblue = 1- , strokealpha = 1- , antialias = Cairo.AntialiasDefault- , linecap = Cairo.LineCapButt- , linejoin = Cairo.LineJoinMiter- , linewidth = 1- , miterlimit = 0- , tolerance = 0.1- , operator = Cairo.OperatorOver- , currentpoint = origin - , translatex = 0- , translatey = 0- , scalex = 1- , scaley = 1- , rotation = 0 } + return state --- | Load the Cairo state machine with a 'RenderState' object.-loadStateIntoCairo :: RendererState -> Cairo.Render ()+renderPrimitive _ s0 (Hidden _) = return s0+renderPrimitive _ s0 (Rectangle (Point ox oy) w h state) = do + applyAttributeDelta s0 state+ Cairo.rectangle ox oy w h + fillStrokeAndClip state+ return state+ +renderPrimitive _ s0 (Text str (Point ox oy) state) = do+ applyAttributeDelta s0 state + Cairo.moveTo ox oy+ Cairo.showText str + fillStrokeAndClip state+ return state+ +renderPrimitive images s0 (Union prims state) = do+ let unfoc prim = prim{ attribs = (attribs prim){filled=False, outlined=False, clipped=False } }+ applyAttributeDelta s0 state+ mapM_ (renderPrimitive images state . unfoc) prims >> fillStrokeAndClip state+ return state+ +render images d = loadStateIntoCairo attrs0+ >> (foldlM (renderPrimitive images) attrs0 . sort $ vis)+ >> return ()+ where vis = 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 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 + +-- | Load the Cairo state with a 'RenderState' Drawing.+loadStateIntoCairo :: Attributes -> Cairo.Render () loadStateIntoCairo s = do- Cairo.selectFontFace (fontfamily s) (fontslant s) (fontweight s)- Cairo.setFillRule . fillrule $ s+ 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 . antialias $ s- Cairo.setLineCap . linecap $ s- Cairo.setLineJoin . linejoin $ s+ Cairo.setAntialias . toCairoAntialias . antialias $ s+ + Cairo.setLineJoin . toCairoLineJoin . linejoin $ s Cairo.setLineWidth . linewidth $ s Cairo.setMiterLimit . miterlimit $ s Cairo.setTolerance . tolerance $ s- Cairo.setOperator . operator $ s- case currentpoint s of (Point px py) -> Cairo.moveTo px py+ Cairo.setOperator . toCairoOperator . operator $ s+ Cairo.translate (translatex s) (translatey s) Cairo.scale (scalex s) (scaley s) Cairo.rotate (rotation s) -changeRenderState :: RendererState -> [StateModifier] -> Cairo.Render RendererState-changeRenderState state changes = do- let state' = foldl' applyStateChangeToLocalEnv state changes- mapM (applyStateChangeToCairo state') changes- return state'--applyStateChangeToLocalEnv state ResetClip = state-applyStateChangeToLocalEnv state (Translate byx byy) = state{ translatex = byx, translatey = byy }-applyStateChangeToLocalEnv state (Scale byx byy) = state{ scalex = byx, scaley = byy }-applyStateChangeToLocalEnv state (Rotate by) = state{ rotation = by }-applyStateChangeToLocalEnv state (Font s) = state{ fontfamily=s }-applyStateChangeToLocalEnv state (FontSlant s) = state{ fontslant=s }-applyStateChangeToLocalEnv state (FontWeight s) = state{ fontweight=s }-applyStateChangeToLocalEnv state (FillRule s) = state{ fillrule=s }-applyStateChangeToLocalEnv state (FillRed s) = state{ fillred=s }-applyStateChangeToLocalEnv state (FillGreen s) = state{ fillgreen=s }-applyStateChangeToLocalEnv state (FillBlue s) = state{ fillblue=s }-applyStateChangeToLocalEnv state (FillAlpha s) = state{ fillalpha=s }-applyStateChangeToLocalEnv state (Dash a b) = state{ dash=Just (a,b) }-applyStateChangeToLocalEnv state (StrokeRed s) = state{ strokered=s }-applyStateChangeToLocalEnv state (StrokeGreen s) = state{ strokegreen=s }-applyStateChangeToLocalEnv state (StrokeBlue s) = state{ strokeblue=s }-applyStateChangeToLocalEnv state (StrokeAlpha s) = state{ strokealpha=s }-applyStateChangeToLocalEnv state (Antialias s) = state{ antialias=s }-applyStateChangeToLocalEnv state (LineCap s) = state{ linecap=s }-applyStateChangeToLocalEnv state (LineJoin s) = state{ linejoin=s }-applyStateChangeToLocalEnv state (LineWidth s) = state{ linewidth=s } -applyStateChangeToLocalEnv state (MiterLimit s) = state{ miterlimit=s }-applyStateChangeToLocalEnv state (Tolerance s) = state{ tolerance=s }-applyStateChangeToLocalEnv state (Operator s) = state{ operator=s }-applyStateChangeToLocalEnv state (CurrentPoint s) = state{ currentpoint=s }-applyStateChangeToLocalEnv state (FillRGB r g b) = state{ fillred = r, fillgreen = g, fillblue = b }-applyStateChangeToLocalEnv state (FillRGBA r g b a) = state{ fillred = r, fillgreen = g, fillblue = b , fillalpha = a }-applyStateChangeToLocalEnv state (StrokeRGB r g b) = state{ strokered = r, strokegreen=g, strokeblue = b }-applyStateChangeToLocalEnv state (StrokeRGBA r g b a) = state{strokered = r, strokegreen=g, strokeblue = b, strokealpha = a } --applyStateChangeToCairo state ResetClip = Cairo.resetClip-applyStateChangeToCairo state (Translate byx byy) = Cairo.translate byx byy-applyStateChangeToCairo state (Scale byx byy) = Cairo.scale byx byy-applyStateChangeToCairo state (Rotate by) = Cairo.rotate by-applyStateChangeToCairo state (Font s) = Cairo.selectFontFace s (fontslant state) (fontweight state)-applyStateChangeToCairo state (FontSlant s) = Cairo.selectFontFace (fontfamily state) s (fontweight state)-applyStateChangeToCairo state (FontWeight s) = Cairo.selectFontFace (fontfamily state) (fontslant state) s-applyStateChangeToCairo state (FillRule s) = Cairo.setFillRule s-applyStateChangeToCairo state (FillRed s) = return ()-applyStateChangeToCairo state (FillGreen s) = return ()-applyStateChangeToCairo state (FillBlue s) = return ()-applyStateChangeToCairo state (FillAlpha s) = return ()-applyStateChangeToCairo state (Dash a b) = Cairo.setDash a b-applyStateChangeToCairo state (StrokeRed s) = return ()-applyStateChangeToCairo state (StrokeGreen s) = return ()-applyStateChangeToCairo state (StrokeBlue s) = return ()-applyStateChangeToCairo state (StrokeAlpha s) = return ()-applyStateChangeToCairo state (Antialias s) = Cairo.setAntialias s-applyStateChangeToCairo state (LineCap s) = Cairo.setLineCap s-applyStateChangeToCairo state (LineJoin s) = Cairo.setLineJoin s-applyStateChangeToCairo state (LineWidth s) = Cairo.setLineWidth s-applyStateChangeToCairo state (MiterLimit s) = Cairo.setMiterLimit s-applyStateChangeToCairo state (Tolerance s) = Cairo.setTolerance s-applyStateChangeToCairo state (Operator s) = Cairo.setOperator s-applyStateChangeToCairo state (CurrentPoint (Point px py)) = Cairo.moveTo px py-applyStateChangeToCairo state (FillRGB r g b) = return ()-applyStateChangeToCairo state (FillRGBA r g b a) = return ()-applyStateChangeToCairo state (StrokeRGB r g b) = return ()-applyStateChangeToCairo state (StrokeRGBA r g b a) = return ()---renderObject :: ImageCache -> Object -> Cairo.Render () -renderObject images = renderObjectWithState images defaultState --renderObjectWithState :: ImageCache -> RendererState -> Object -> Cairo.Render ()-renderObjectWithState images state (Group objects) = mapM_ (renderObjectWithState images state) objects-renderObjectWithState images state (Draw prim) = renderPrimitive images state prim-renderObjectWithState images state (Context setup object) = do - Cairo.save- state' <- changeRenderState state setup- renderObjectWithState images state' object- Cairo.restore- loadStateIntoCairo state- -- | @renderFrameToSurface surface frame@ renders a frame to a particular surface-renderObjectToSurfaceWithImageCache :: ImageCache -> Cairo.Surface -> Object -> IO ()-renderObjectToSurfaceWithImageCache images surf frame = Cairo.renderWith surf (renderObject images frame)+renderToSurfaceWithImageCache :: Visual t => ImageCache -> Cairo.Surface -> t -> IO ()+renderToSurfaceWithImageCache images surf frame = Cairo.renderWith surf (render images frame) -renderObjectToSurface :: Cairo.Surface -> Object -> IO ()-renderObjectToSurface s o = do { i <- initImageCache; renderObjectToSurfaceWithImageCache i s o }+renderToSurface :: Visual t => Cairo.Surface -> t -> IO ()+renderToSurface s o = do { i <- initImageCache; renderToSurfaceWithImageCache i s o } -- | @renderframeToPNGWithImageCache filename xres yres frame@ renders a frame to an image file-renderObjectToPNGWithImageCache :: ImageCache -> FilePath -> Int -> Int -> Object -> IO ()-renderObjectToPNGWithImageCache images filename xres yres frame = Cairo.withImageSurface Cairo.FormatARGB32 xres yres $ \s -> renderObjectToSurfaceWithImageCache images s frame >> Cairo.surfaceWriteToPNG s filename-renderObjectToPNG f w h o = do { i <- initImageCache ; renderObjectToPNGWithImageCache i f w h o }+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 } --- | @renderObjectToPDFWithImageCache filename width height frame@ renders a frame to a PDF file. width and height are in points.-renderObjectToPDFWithImageCache :: ImageCache -> FilePath -> Double -> Double -> Object -> IO ()-renderObjectToPDFWithImageCache images filename width height frame = Cairo.withPDFSurface filename width height $ \s -> renderObjectToSurfaceWithImageCache images s frame-renderObjectToPDF f w h o = do { i <- initImageCache ; renderObjectToPDFWithImageCache 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 } --- | @renderObjectToPostscriptWithImageCache filename width height frame@ renders a frame to a Postscript file. width and height are in points.-renderObjectToPostscriptWithImageCache :: ImageCache -> FilePath -> Double -> Double -> Object -> IO ()-renderObjectToPostscriptWithImageCache images filename width height frame = Cairo.withPSSurface filename width height $ \s -> renderObjectToSurfaceWithImageCache images s frame-renderObjectToPostscript f w h o = do { i <- initImageCache ; renderObjectToPostscriptWithImageCache 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 } --- | @renderObjectToSVGWithImageCache filename width height frame@ renders a frame to a SVG file. width and height are in points.-renderObjectToSVGWithImageCache :: ImageCache -> FilePath -> Double -> Double -> Object -> IO ()-renderObjectToSVGWithImageCache images filename width height frame = Cairo.withSVGSurface filename width height $ \s -> renderObjectToSurfaceWithImageCache images s frame-renderObjectToSVG f w h o = do { i <- initImageCache ; renderObjectToSVGWithImageCache 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 } -- | @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+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)@@ -327,7 +226,7 @@ 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+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)
Graphics/Rendering/Hieroglyph/Colors.hs view
@@ -1,72 +1,50 @@+-- | A module defining some basic color tuples. The old 16 color standard plus+-- a variable gray and some functions to attenuate, and fade colors. module Graphics.Rendering.Hieroglyph.Colors where -import Graphics.Rendering.Hieroglyph.Cairo+import Graphics.Rendering.Hieroglyph.Primitives -strokeWhite = StrokeRGBA 1 1 1 1-strokeBlack = StrokeRGBA 0 0 0 1-strokeRed = StrokeRGBA 1 0 0 1-strokeGreen = StrokeRGBA 0 1 0 1-strokeBlue = StrokeRGBA 0 0 1 1-strokeYellow = StrokeRGBA 1 1 0 1-strokeViolet = StrokeRGBA 1 0 1 1-strokeCyan = StrokeRGBA 0 1 1 1-strokeDarkRed = attenuate 0.5 strokeRed-strokeDarkGreen = attenuate 0.5 strokeGreen-strokeDarkBlue = attenuate 0.5 strokeBlue-strokeDarkYellow = attenuate 0.5 strokeYellow -strokeDarkViolet = attenuate 0.5 strokeViolet-strokeDarkCyan = attenuate 0.5 strokeCyan+white = (1,1,1,1)+black = (0,0,0,1)+red = (1,0,0,1)+green = (0,1,0,1)+blue = (0,0,1,1)+yellow = (1,1,0,1)+violet = (1,0,1,1)+cyan = (0,1,1,1)+darkRed = attenuate 0.5 red+darkGreen = attenuate 0.5 green+darkBlue = attenuate 0.5 blue+darkYellow = attenuate 0.5 yellow+darkViolet = attenuate 0.5 violet+darkCyan = attenuate 0.5 cyan -strokeGrey90 = attenuate 0.9 strokeWhite-strokeGrey80 = attenuate 0.8 strokeWhite-strokeGrey70 = attenuate 0.7 strokeWhite-strokeGrey60 = attenuate 0.6 strokeWhite-strokeGrey50 = attenuate 0.5 strokeWhite-strokeGrey40 = attenuate 0.4 strokeWhite-strokeGrey30 = attenuate 0.3 strokeWhite-strokeGrey20 = attenuate 0.2 strokeWhite-strokeGrey10 = attenuate 0.1 strokeWhite+-- | Grey. Domain of the input values is the bounded interval [0..100]+pctGrey :: Double -> (Double,Double,Double,Double) +pctGrey k + | k >= 0 && k <= 100 = (k*0.01,k*0.01,k*0.01,k*0.01)+ | k < 0 = black+ | k > 0 = white -fillWhite = FillRGBA 1 1 1 1-fillBlack = FillRGBA 0 0 0 1-fillRed = FillRGBA 1 0 0 1-fillGreen = FillRGBA 0 1 0 1-fillBlue = FillRGBA 0 0 1 1-fillYellow = FillRGBA 1 1 0 1-fillViolet = FillRGBA 1 0 1 1-fillCyan = FillRGBA 0 1 1 1-fillDarkRed = attenuate 0.5 fillRed-fillDarkGreen = attenuate 0.5 fillGreen-fillDarkBlue = attenuate 0.5 fillBlue-fillDarkYellow = attenuate 0.5 fillYellow -fillDarkViolet = attenuate 0.5 fillViolet-fillDarkCyan = attenuate 0.5 fillCyan+-- | Lighten the color by a floating point amount between [0..1]+unattenuate :: Double -> (Double,Double,Double,Double) -> (Double,Double,Double,Double)+unattenuate by ( r, g, b, a) = ((clamp 0 1 $ (1+by)*r), (clamp 0 1 $ (1+by)*g), (clamp 0 1 $ (1+by)*b), a) -fillGrey90 = attenuate 0.9 fillWhite-fillGrey80 = attenuate 0.8 fillWhite-fillGrey70 = attenuate 0.7 fillWhite-fillGrey60 = attenuate 0.6 fillWhite-fillGrey50 = attenuate 0.5 fillWhite-fillGrey40 = attenuate 0.4 fillWhite-fillGrey30 = attenuate 0.3 fillWhite-fillGrey20 = attenuate 0.2 fillWhite-fillGrey10 = attenuate 0.1 fillWhite+-- | Darken the color by a floating point amount between [0..1]+attenuate :: Double -> (Double,Double,Double,Double) -> (Double,Double,Double,Double)+attenuate by (r, g, b, a) = ((clamp 0 1 $ by*r), (clamp 0 1 $ by*g), (clamp 0 1 $ by*b), a) -toStroke (FillRGBA r g b a) = (StrokeRGBA r g b a)-toStroke (StrokeRGBA r g b a) = (StrokeRGBA r g b a)-toFill (StrokeRGBA r g b a) = (FillRGBA r g b a)-toFill (FillRGBA r g b a) = (FillRGBA r g b a)+-- | Make the color more transparent by multiplying the alpha component by a floating point amount between [0..1]+fade :: Double -> (Double,Double,Double,Double) -> (Double,Double,Double,Double)+fade by (r, g, b, a) = (r, g, b, (clamp 0 1 $ by*a)) -unattenuate by (FillRGBA r g b a) = FillRGBA (clamp 0 1 $ (1+by)*r) (clamp 0 1 $ (1+by)*g) (clamp 0 1 $ (1+by)*b) a-unattenuate by (StrokeRGBA r g b a) = StrokeRGBA (clamp 0 1 $ (1+by)*r) (clamp 0 1 $ (1+by)*g) (clamp 0 1 $ (1+by)*b) a-attenuate by (FillRGBA r g b a) = FillRGBA (clamp 0 1 $ by*r) (clamp 0 1 $ by*g) (clamp 0 1 $ by*b) a-attenuate by (StrokeRGBA r g b a) = StrokeRGBA (clamp 0 1 $ by*r) (clamp 0 1 $ by*g) (clamp 0 1 $ by*b) a-fade by (FillRGBA r g b a) = FillRGBA r g b (clamp 0 1 $ by*a)-fade by (StrokeRGBA r g b a) = StrokeRGBA r g b (clamp 0 1 $ by*a)-unfade by (FillRGBA r g b a) = FillRGBA r g b (clamp 0 1 $ (1+by)*a)-unfade by (StrokeRGBA r g b a) = StrokeRGBA r g b (clamp 0 1 $ (1+by)*a)+-- | Make the color less transparent by multiplying the alpha component by a floating point amount between [0..1]+unfade :: Double -> (Double,Double,Double,Double) -> (Double,Double,Double,Double)+unfade by (r, g, b, a) = (r, g, b, (clamp 0 1 $ (1+by)*a)) -mix ratio (FillRGBA r1 g1 b1 a1) (FillRGBA r2 g2 b2 a2) = (FillRGBA r' g' b' a') +-- | Mix two colors together with a ratio.+mix :: Double -> (Double,Double,Double,Double) -> (Double,Double,Double,Double) -> (Double,Double,Double,Double)+mix ratio ( r1, g1, b1, a1) ( r2, g2, b2, a2) = ( r', g', b', a') where r' = clamp 0 1 $ (r1+r2) * ratio g' = clamp 0 1 $ (g1+g2) * ratio b' = clamp 0 1 $ (b1+b2) * ratio
+ Graphics/Rendering/Hieroglyph/ImageCache.hs view
@@ -0,0 +1,10 @@+module Graphics.Rendering.Hieroglyph.ImageCache where++import Data.Map (Map,empty)+import Control.Concurrent+import System.Mem.Weak+import qualified Graphics.UI.Gtk as Gtk++type ImageCache = MVar (Map String (Weak Gtk.Pixbuf))++initImageCache = newMVar empty
Graphics/Rendering/Hieroglyph/Interactive.hs view
@@ -7,46 +7,41 @@ module Graphics.Rendering.Hieroglyph.Interactive where import Graphics.Rendering.Hieroglyph.Primitives+import Graphics.Rendering.Hieroglyph.ImageCache import Graphics.Rendering.Hieroglyph.Cairo-import Graphics.Rendering.Hieroglyph.UIState+import Graphics.Rendering.Hieroglyph.Scaffolds.Interactive+import Graphics.Rendering.Hieroglyph.Visual import qualified Graphics.UI.Gtk.Cairo as Gtk import qualified Graphics.Rendering.Cairo as Cairo import qualified Graphics.UI.Gtk 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 --- | A scene element. This is the basic building block of your interactive app.-data SceneElement a = - StaticElement Object Rect -- ^ An unreactive element in the scene. Not modified by program state.- | BoundedElement (a -> Object) Rect -- ^ A reactive, but bounded element in the scene. The element reacts to a UIState instance, but is confined within a particular rectangle. - | UnboundedElement (a -> Object) -- ^ An unbounded reactive element in the scene. The element reacts to a UIState instance, but can go anywhere in the scene. - | BoundedActiveElement (a -> (a, Object)) Rect - | UnboundedActiveElement (a -> (a,Object)) +-- | 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 + 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' --- | The scene itself-type Scene a = [SceneElement a] --- | Applies the current UIState instance to a single scene element, returning an Object--- FIXME: Should do bounds checking.-renderSceneElement :: UIState a => a -> SceneElement a -> (a, Object)-renderSceneElement uistate (StaticElement obj _) = (uistate, obj)-renderSceneElement uistate (BoundedElement obj _) = (uistate, obj uistate)-renderSceneElement uistate (UnboundedElement obj) = (uistate, obj uistate)-renderSceneElement uistate (BoundedActiveElement obj _) = obj uistate-renderSceneElement uistate (UnboundedActiveElement obj) = obj uistate---- | @renderScene state scene@ applies the current UIState to the entire scene-renderScene :: UIState a => a -> Scene a -> (a, Object)-renderScene state elts = (state', Group objs)- where (state', objs) = mapAccumL renderSceneElement state elts---- | Gets the keyboard state from Gtk and changes the UIState. You do not need+-- | Gets the keyboard state from Gtk and changes the Interactive. You do not need -- to call this in your own code-keyboardHandler :: UIState a => MVar a -> Scene a ->Gtk.Event -> IO Bool-keyboardHandler uistate_mvar scene event = do+keyboardHandler :: Interactive a => MVar a -> Gtk.Event -> IO Bool+keyboardHandler uistate_mvar event = do let k = case Gtk.eventKeyName event of "Insert" -> Insert "Delete" -> Delete@@ -71,23 +66,23 @@ _ -> Character '\0' modifyMVar_ uistate_mvar $ return . setKey k withMVar uistate_mvar $ \s -> do- dwin <- Gtk.widgetGetDrawWindow . fromJust . drawing $ s- Gtk.drawWindowInvalidateRect dwin (Gtk.Rectangle 0 0 (round . sizeX $ s) (round . sizeY $ s)) False+ 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 UIState to reflect it. YOu do not need this in your own code.-mouseMotionHandler :: UIState a => MVar a -> Gtk.Event -> IO Bool+-- | 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 state <- takeMVar uistate_mvar putMVar uistate_mvar $ setMousePosition (Point (Gtk.eventX event) (Gtk.eventY event)) state- dwin <- Gtk.widgetGetDrawWindow . fromJust . drawing $ state+ dwin <- Gtk.widgetGetDrawWindow . fromJust . getDrawing $ state Gtk.drawWindowGetPointer dwin- Gtk.drawWindowInvalidateRect dwin (Gtk.Rectangle 0 0 (round . sizeX $ state) (round . sizeY $ state)) False+ Gtk.drawWindowInvalidateRect dwin (Gtk.Rectangle 0 0 (round . getSizeX $ state) (round . getSizeY $ state)) False return False -mouseReleaseHandler :: UIState a => MVar a -> Scene a -> Gtk.Event -> IO Bool-mouseReleaseHandler uistate_mvar scene event = do+mouseReleaseHandler :: Interactive a => MVar a -> Gtk.Event -> IO Bool+mouseReleaseHandler uistate_mvar event = do let x = Gtk.eventX event y = Gtk.eventY event button = Gtk.eventButton event@@ -110,13 +105,13 @@ Gtk.MiddleButton -> setMouseRightButtonDown False . setMouseWheel 0) withMVar uistate_mvar $ \s -> do- dwin <- Gtk.widgetGetDrawWindow . fromJust . drawing $ s- Gtk.drawWindowInvalidateRect dwin (Gtk.Rectangle 0 0 (round . sizeX $ s) (round . sizeY $ s)) False+ dwin <- Gtk.widgetGetDrawWindow . fromJust . getDrawing $ s+ Gtk.drawWindowInvalidateRect dwin (Gtk.Rectangle 0 0 (round . getSizeX $ s) (round . getSizeY $ s)) False return True --- | Gets the mouse button state and changes the UIState to reflect it. You do not need this in your own code.-mouseButtonHandler :: UIState a => MVar a -> Scene a -> Gtk.Event -> IO Bool-mouseButtonHandler uistate_mvar scene event = do+-- | Gets the mouse button state and changes the Interactive to reflect it. You do not need this in your own code.+mouseButtonHandler :: Interactive a => MVar a -> Gtk.Event -> IO Bool+mouseButtonHandler uistate_mvar event = do let x = Gtk.eventX event y = Gtk.eventY event button = Gtk.eventButton event@@ -145,37 +140,29 @@ . setMouseRightButtonDown True . setMouseWheel 0) withMVar uistate_mvar $ \s -> do- dwin <- Gtk.widgetGetDrawWindow . fromJust . drawing $ s- Gtk.drawWindowInvalidateRect dwin (Gtk.Rectangle 0 0 (round . sizeX $ s) (round . sizeY $ s)) False+ dwin <- Gtk.widgetGetDrawWindow . fromJust . getDrawing $ s+ Gtk.drawWindowInvalidateRect dwin (Gtk.Rectangle 0 0 (round . getSizeX $ s) (round . getSizeY $ s)) False return True --- | Window resize handler. Changes the UIState to reflect the new sizing. You do not need this in your own code.-resize state scene event = do+-- | Window resize handler. Changes the Interactive to reflect the new sizing. You do not need this in your own code.+resize state event = do let sizex = Gtk.eventWidth event sizey = Gtk.eventHeight event modifyMVar_ state $ return . setSizeX (fromIntegral sizex) . setSizeY (fromIntegral sizey) withMVar state $ \s -> do- dwin <- Gtk.widgetGetDrawWindow . fromJust . drawing $ s+ dwin <- Gtk.widgetGetDrawWindow . fromJust . getDrawing $ s Gtk.drawWindowInvalidateRect dwin (Gtk.Rectangle 0 0 sizex sizey) False return False --- | Render function. All Cairo is called through here. You do not need to call this in your own code.-renderer :: UIState a => MVar a -> Scene a -> IO ()-renderer state scene = modifyMVar_ state $ \st -> do- dwin <- Gtk.widgetGetDrawWindow . fromJust . drawing $ st- let (state',object) = renderScene st scene- Gtk.renderWithDrawable dwin $ (renderObject (fromJust (imageCache st)) object)- return state'- -- | A lowish level funtion for creating a GUI. Does not set the size of the -- window or expose any windows.-guiInit :: UIState a - => MVar a -- ^ The current UIState - -> Scene a -- ^ The scene graph to render- -> String -- ^ The name of the window - -> Bool -- ^ Whether or not to make this GUI motion sensitive- -> IO Gtk.Window -- ^ Returns the window that was created+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.Window -- ^ Returns the window that was created guiInit state scene name motionSensitive = do Gtk.unsafeInitGUIForThreadedRTS @@ -186,21 +173,22 @@ imgcache <- initImageCache modifyMVar_ state $ return . setDrawing (Just . Gtk.castToWidget $ canvas) . setImageCache (Just imgcache)+ primitiveData <- newMVar [] - Gtk.onExpose canvas $ \evt -> renderer state scene >> return True- Gtk.onConfigure window $ resize state scene- Gtk.onButtonPress canvas $ mouseButtonHandler state scene- Gtk.onButtonRelease canvas $ mouseReleaseHandler state scene- Gtk.onKeyPress window $ keyboardHandler state scene+ Gtk.onExpose canvas $ \evt -> renderer primitiveData state scene >> return True+ Gtk.onConfigure window $ resize state+ Gtk.onButtonPress canvas $ mouseButtonHandler state + Gtk.onButtonRelease canvas $ mouseReleaseHandler state + Gtk.onKeyPress window $ keyboardHandler state when motionSensitive $ (Gtk.onMotionNotify canvas True $ mouseMotionHandler state) >> return () return window -- | 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 :: UIState a - => a -- ^ The default UIState- -> Scene a -- ^ The scene to render+guiConstruct :: (Interactive a, Visual b)+ => a -- ^ The default Interactive+ -> ( a -> b ) -- ^ The scene to render -> String -- ^ The name of the scene -> Bool -- ^ Whether or not this GUI is motion sensitive -> IO Gtk.Window@@ -213,9 +201,9 @@ -- | A high level function for creating a GUI. Just specify a default -- state, the name of the scene, and the scene, and you get an 800 by -- 600 motion insensitive GUI.-simpleGui :: UIState a +simpleGui :: (Interactive a, Visual b) => a - -> Scene a + -> (a -> b) -> String -> IO () simpleGui state scene name = do
Graphics/Rendering/Hieroglyph/Primitives.hs view
@@ -14,123 +14,310 @@ -- module Graphics.Rendering.Hieroglyph.Primitives where -import qualified Graphics.Rendering.Cairo as Cairo+import Data.Function (on)+import Data.Maybe (fromMaybe)+import Data.List+--import Data.Foldable +import qualified Data.Map as M+import qualified Data.IntMap as IM -- | A 2D point-data Point = Point Double Double deriving (Show, Read, Eq)+data Point = Point Double Double deriving (Show, Read, Eq, Ord) -data Rect = Rect Double Double Double Double deriving (Show, Read, Eq)+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)++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] + $ [p',q',r']+ compare a b = (ordinal %=> compare) a b+ where ordinal (Line _) = 0+ ordinal (Spline _ _ _) = 1+ ordinal (EndPoint _) = 2+ ++instance Ord Rect where+ compare Plane Plane = EQ+ compare Singularity Singularity = EQ+ compare Plane Singularity = GT+ compare Singularity Plane = LT+ compare (Rect _ _ _ _) Plane = GT+ 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] + $ [xb1,xb2,yb1,yb2]++overlaps :: Rect -> Rect -> Bool+overlaps _ Plane = True+overlaps Plane _ = True+overlaps _ Singularity = False+overlaps Singularity _ = False+overlaps (Rect lx1 ly1 lx2 ly2) (Rect rx1 ry1 rx2 ry2) = xoverlaps && yoverlaps+ where xoverlaps = (lx1' > rx1' && lx1' < rx2') || (lx2' > rx1' && lx2' < rx2')+ yoverlaps = (ly1' > ry1' && ly1' < ry2') || (ly2' > ry1' && ly2' < ry2')+ (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) + -- | A 2D primitive in an arbitrary Cartesian 2d space data Primitive = -- | An arc- Arc -- A possibly filled pie slice or arc- { center :: Point -- ^ center of the 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- , filled :: Bool -- ^ pie, or just crust?- , outlined :: Bool -- ^ crustless pie?- , clipped :: Bool -- ^ add this to the clipping plane+ , attribs :: Attributes } -- | A cubic spline- | Curve -- An arbitrary cubic spline- { begin :: Point -- ^ starting point- , curve_segments :: [(Point,Point,Point)] -- ^ A sequential list of curve segments. Note that the first two points are control points.+ | 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- , filled :: Bool -- ^ Whether or not to fill the curve- , outlined :: Bool -- ^ Whether or not to outline the curve- , clipped :: Bool -- ^ Add the curve to the clipping plane- }- -- | A series of straight lines- | Line -- An arbitrary series of line segments- { begin :: Point -- ^ Starting Point- , segments :: [Point] -- ^ Line segments.- , closed :: Bool -- ^ Whether or not to finish this curve with a last line from the end segment to the begin point.- , filled :: Bool -- ^ Whether or not to fill the curve- , outlined :: Bool -- ^ Whether or not to draw the outline- , clipped :: Bool -- ^ Add to the clipping plane+ , attribs :: Attributes }- -- | Move the pen- | Pen - { moveto :: Point -- ^ Move the current point. Matters for arcs sometimes. May remove the begin point for Curve and Line in favor of this.- } -- | A rectangle- | Rectangle -- An possibly filled rectangle- { topleft :: Point -- ^ The top left point+ | Rectangle -- An rectangle+ { topleft :: Point -- ^ The top left point , width :: Double -- ^ The width , height :: Double -- ^ The height- , filled :: Bool -- ^ Fill the rectangle?- , outlined :: Bool -- ^ Draw the outline?- , clipped :: Bool -- ^ Add to the clipping plane?+ , attribs :: Attributes } -- | A simple text object | Text -- A simple text string { str :: String -- ^ The string to print - , bottomleft :: Point -- ^ The anchor point for the text. Baseline, not bottom.- , filled :: Bool -- ^ Fill the text? Usually you want this and not outline.- , outlined :: Bool -- ^ Draw the outline?- , clipped :: Bool -- ^ Add to the clipping plane? - }- -- | A compound object- | Compound -- Use this to create an arbitrary shape before calling fill, stroke, and clip.- { primitives :: [Primitive] -- ^ primitives to use- , filled :: Bool -- ^ fill the result?- , outlined :: Bool -- ^ outline the result?- , clipped :: Bool -- ^ clip the result?+ , bottomleft :: Point -- ^ The anchor point for the text. Baseline, not bottom.+ , attribs :: Attributes }+ | 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 + { prims :: [Primitive]+ , attribs :: Attributes+ } + -- | A rectangular image | Image - { filename :: String- , dimensions :: Either Point Rect- , preserveaspect :: Bool+ { 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 + , attribs :: Attributes }+ -- | 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 :: (Double,Double,Double,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 :: (Double,Double,Double,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+ , 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+ , 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 +-- 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+ ]++-- | 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+ ++-- | 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 + deriving (Show,Read,Ord,Eq)+ +-- | See the Cairo meanings of these. I plan to introduce OpenGL equivalents+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 + | LineCapSquare+ deriving (Show,Read,Ord,Eq)++-- | See the Cairo meanings of these. I plan to introduce OpenGL equivalents+data LineJoin = + LineJoinMiter + | LineJoinRound + | LineJoinBevel+ deriving (Show,Read,Ord,Eq)++-- | See the Cairo meanings of these. I plan to introduce OpenGL equivalents+data Operator = + OperatorClear+ | OperatorSource+ | OperatorOver+ | OperatorIn+ | OperatorOut+ | OperatorAtop + | OperatorDest + | OperatorDestOver+ | OperatorDestIn+ | OperatorDestOut+ | OperatorDestAtop+ | OperatorXor+ | OperatorAdd+ | 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 = (1,1,1,1)+ , dash = Nothing+ , strokeRGBA = (1,1,1,1)+ , 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 + , layer = 0+ , lod = 0+ , name = Nothing } + -- | the origin point origin :: Point origin = Point 0 0 arc :: Primitive -- ^ A unit circle by default, modifiable with record syntax.-arc = Arc origin 1 0 (2*pi) False False True False--arcFilled :: Primitive -- ^ A filled unit circle by default, modifiable with record syntax.-arcFilled = Arc origin 1 0 (2*pi) False True False False--curve :: Primitive -- ^ A cubic spline with a starting point of the origin.-curve = Curve origin [] False False True False--curveFilled :: Primitive -- ^ A filled loop with a starting point at the origin.-curveFilled = Curve origin [] True True False False+arc = Arc origin 1 0 (2*pi) False plain -line :: Primitive -- ^ A line starting at the origin.-line = Line origin [] False False True False+path :: Primitive -- ^ A line starting at the origin.+path = Path origin [] False plain polygon :: Primitive -- ^ An arbitrary filled polygon starting at the origin.-polygon = Line origin [] True True False False--pen :: Primitive -- ^ move the pen to the origin-pen = Pen origin+polygon = Path origin [] True plain{ filled=True } rectangle :: Primitive -- ^ an outlined rectangle-rectangle = Rectangle (Point 0 1) 1 1 False True False--rectangleFilled :: Primitive -- ^ A filled, but not outlined rectanglee-rectangleFilled = Rectangle (Point 0 1) 1 1 True False False+rectangle = Rectangle (Point 0 1) 1 1 plain text :: Primitive -- ^ A rendered string starting at the origin.-text = Text [] origin True False False +text = Text "" origin plain compound :: Primitive -- ^ An outlined compound object-compound = Compound [] True False False+compound = Union [] plain degrees :: Double -> Double -- ^ Convert degrees to radians degrees x = x * 0.0174532925 hidden :: Primitive -- ^ A hidden object.-hidden = Hidden+hidden = Hidden plain image :: Primitive -- ^ An image. These are efficiently cached using weak references where possible-image = Image "" (Left origin) False +image = Image "" (Left origin) False plain
+ Graphics/Rendering/Hieroglyph/Scaffolds/Interactive.hs view
@@ -0,0 +1,186 @@+-- | If the items in the UIState module are the only state you need in your+-- program, then it is sufficient to import this module and start with the+-- defaultBasicState.+--+-- [@Author@] Jeff Heard+--+-- [@Copyright@] © 2008 Renaissance Computing Institute+--+module Graphics.Rendering.Hieroglyph.Scaffolds.Interactive where++import Graphics.Rendering.Hieroglyph.Primitives+import Graphics.Rendering.Hieroglyph.ImageCache+import Graphics.Rendering.Hieroglyph.Visual+import qualified Graphics.UI.Gtk as Gtk+import Control.Concurrent +import Data.Map (Map,empty)+import System.Mem.Weak+++-- | A keystroke+data Key =+ Character Char+ | Enter + | Tab + | BackSpace+ | Insert + | Delete+ | Home + | End + | PgUp + | PgDown+ | PF1 | PF2 | PF3 | PF4 | PF5 | PF6 | PF7 | PF8 | PF9 | PF10 | PF11 | PF12++-- | All that you need to provide interactivity+data Scaffolding = Scaffolding + { mousePosition :: Point+ , mouseLeftButtonDown :: Bool+ , mouseRightButtonDown :: Bool+ , mouseMiddleButtonDown :: Bool+ , mouseWheel :: Int+ , keyCtrl :: Bool+ , keyShift :: Bool+ , keyAlt :: Bool+ , key :: Key + , drawing :: Maybe Gtk.Widget + , sizeX :: Double+ , sizeY :: Double + , imageCache :: Maybe ImageCache }+ +instance Interactive Scaffolding where+ getInteractiveScaffolding = id+ setInteractiveScaffolding a b = b+ interactionFold a b = a ++-- | Implement this class to make your application interactive+class Interactive a where+ getInteractiveScaffolding :: a -> Scaffolding -- ^ get the interactive Scaffolding record from your data+ setInteractiveScaffolding :: a -> Scaffolding -> a -- ^ set the Interactive Scaffolding record in your data + -- | Interaction can be thought of as a foldr on an infinite list of data.+ -- The intent of implementing this function is that the implementer will+ -- fold the given event data (in the Scaffolding instance) with the data+ -- being visualized and the geometry that goes with the event data to + -- produce a new set of data to visualize.+ interactionFold :: a -> [Primitive] -> a + +-- | The initial Scaffolding record. Start with this.+scaffold :: Scaffolding +scaffold = Scaffolding (Point 0 0) False False False 0 False False False (Character '\0') Nothing 800 600 Nothing++-- | Get the mouse position in window coordinates+getMousePosition :: Interactive a => a -> Point+getMousePosition = mousePosition . getInteractiveScaffolding++-- | Get the left button state+getMouseLeftButtonDown :: Interactive a => a -> Bool+getMouseLeftButtonDown = mouseLeftButtonDown . getInteractiveScaffolding++-- | Get the right button state+getMouseRightButtonDown :: Interactive a => a -> Bool+getMouseRightButtonDown = mouseRightButtonDown . getInteractiveScaffolding++-- | Get the middle button state+getMouseMiddleButtonDown :: Interactive a => a -> Bool+getMouseMiddleButtonDown = mouseMiddleButtonDown . getInteractiveScaffolding++-- | Get the number of clicks up or down the mouse button has gone+getMouseWheel :: Interactive a => a -> Int+getMouseWheel = mouseWheel . getInteractiveScaffolding++-- | Get the ctrl modifier state+getKeyCtrl :: Interactive a => a -> Bool+getKeyCtrl = keyCtrl . getInteractiveScaffolding++-- | Get the shift modifier state+getKeyShift :: Interactive a => a -> Bool+getKeyShift = keyShift . getInteractiveScaffolding++-- | Get the shift modifier state+getKeyAlt :: Interactive a => a -> Bool+getKeyAlt = keyAlt . getInteractiveScaffolding++-- | Get the key that was pressed+getKey :: Interactive a => a -> Key+getKey = key . getInteractiveScaffolding++-- | Get the drawing window. Not usually needed by the user, as there's not much you can do with it.+getDrawing :: Interactive a => a -> Maybe Gtk.Widget +getDrawing = drawing . getInteractiveScaffolding++-- | Get the width of the drawing window+getSizeX :: Interactive a => a -> Double+getSizeX = sizeX . getInteractiveScaffolding++-- | Get the height of the drawing window+getSizeY :: Interactive a => a -> Double +getSizeY = sizeY . getInteractiveScaffolding++-- | Get the image cache+getImageCache :: Interactive a => a -> Maybe ImageCache+getImageCache = imageCache . getInteractiveScaffolding++setMousePosition :: Interactive a => Point -> a -> a+setMousePosition p v = setInteractiveScaffolding v s' + where s = getInteractiveScaffolding v+ s' = s{ mousePosition = p } + +setMouseLeftButtonDown :: Interactive a => Bool -> a -> a+setMouseLeftButtonDown p v = setInteractiveScaffolding v s'+ where s = getInteractiveScaffolding v+ s' = s{ mouseLeftButtonDown = p }++setMouseRightButtonDown :: Interactive a => Bool -> a -> a+setMouseRightButtonDown p v = setInteractiveScaffolding v s'+ where s = getInteractiveScaffolding v+ s' = s{ mouseRightButtonDown = p }+ +setMouseMiddleButtonDown :: Interactive a => Bool -> a -> a+setMouseMiddleButtonDown p v = setInteractiveScaffolding v s'+ where s = getInteractiveScaffolding v+ s' = s{ mouseMiddleButtonDown = p }+ +setMouseWheel :: Interactive a => Int -> a -> a+setMouseWheel p v = setInteractiveScaffolding v s'+ where s = getInteractiveScaffolding v+ s' = s{ mouseWheel = p }++setKeyCtrl :: Interactive a => Bool -> a -> a+setKeyCtrl p v = setInteractiveScaffolding v s'+ where s = getInteractiveScaffolding v+ s' = s{ keyCtrl = p }+ +setKeyShift :: Interactive a => Bool -> a -> a+setKeyShift p v = setInteractiveScaffolding v s'+ where s = getInteractiveScaffolding v+ s' = s{ keyShift = p }+ +setKeyAlt :: Interactive a => Bool -> a -> a+setKeyAlt p v = setInteractiveScaffolding v s'+ where s = getInteractiveScaffolding v+ s' = s{ keyAlt = p }++setKey :: Interactive a => Key -> a -> a+setKey p v = setInteractiveScaffolding v s'+ where s = getInteractiveScaffolding v+ s' = s{ key = p }+ +setDrawing :: Interactive a => Maybe Gtk.Widget -> a -> a+setDrawing p v = setInteractiveScaffolding v s'+ where s = getInteractiveScaffolding v+ s' = s{ drawing = p }++setSizeX :: Interactive a => Double -> a -> a+setSizeX p v = setInteractiveScaffolding v s'+ where s = getInteractiveScaffolding v+ s' = s{ sizeX = p }++setSizeY :: Interactive a => Double -> a -> a+setSizeY p v = setInteractiveScaffolding v s'+ where s = getInteractiveScaffolding v+ s' = s{ sizeY = p }++setImageCache :: Interactive a => Maybe ImageCache -> a -> a+setImageCache p v = setInteractiveScaffolding v s'+ where s = getInteractiveScaffolding v+ s' = s{ imageCache = p }+
− Graphics/Rendering/Hieroglyph/UIState.hs
@@ -1,66 +0,0 @@--- | Establish a class for all things that are utterly required to be part of --- the program state for the interactive renderer. These will all be set --- by the interactive system for you, so they just must be defined in your --- state object.------ [@Author@] Jeff Heard ------ [@Copyright@] © 2008 Renaissance Computing Institute--- -module Graphics.Rendering.Hieroglyph.UIState where--import Graphics.Rendering.Hieroglyph.Primitives-import qualified Graphics.UI.Gtk as Gtk-import Data.Map (Map, empty)-import Control.Concurrent -import Graphics.UI.Gtk.Gdk.Pixbuf (Pixbuf)-import System.Mem.Weak--type ImageCache = MVar (Map String (Weak Pixbuf))--initImageCache = newMVar empty---- | A keystroke-data Key =- Character Char- | Enter - | Tab - | BackSpace- | Insert - | Delete- | Home - | End - | PgUp - | PgDown- | PF1 | PF2 | PF3 | PF4 | PF5 | PF6 | PF7 | PF8 | PF9 | PF10 | PF11 | PF12---- | The basic UI state. This will get passed to all scene elements-class UIState a where- mousePosition :: a -> Point -- ^ The current mouse position- mouseLeftButtonDown :: a -> Bool -- ^ Mouse left button. Is it down?- mouseRightButtonDown :: a -> Bool -- ^ Mouse right button, is it down?- mouseMiddleButtonDown :: a -> Bool -- ^ Mouse middle button, is it down?- mouseWheel :: a -> Int -- ^ Moues wheel, has it moved?- keyCtrl :: a -> Bool -- ^ Is the control key down?- keyShift :: a -> Bool -- ^ Is the shift key down?- keyAlt :: a -> Bool -- ^ Is the alt key down?- key :: a -> Key -- ^ Is there a real key down?- drawing :: a -> Maybe Gtk.Widget -- ^ The draw window- sizeX :: a -> Double -- ^ The width of the drawing area- sizeY :: a -> Double -- ^ The height of the drawing area- imageCache :: a -> Maybe ImageCache-- setMousePosition :: Point -> a-> a -- ^ Set the mouse position (do not call in your own code)- setMouseLeftButtonDown :: Bool -> a-> a -- ^ Set the left button (do not call in your own code)- setMouseRightButtonDown :: Bool -> a-> a -- ^ Set the right button (do not call in your own code)- setMouseMiddleButtonDown :: Bool -> a-> a -- ^ Set the middle button (do not call in your own code)- setMouseWheel :: Int -> a-> a -- ^ Set the mouse wheel delta (do not call in your own code)- setKeyCtrl :: Bool -> a-> a -- ^ Set the control modifier state (do not call in your own code)- setKeyShift :: Bool -> a-> a -- ^ Set the shift modifier state (do not call in your own code)- setKeyAlt :: Bool -> a-> a -- ^ Set the alt modifier state (do not call in your own code)- setKey :: Key -> a-> a -- ^ Set the key that is pressed (do not call in your own code)- setDrawing :: Maybe Gtk.Widget -> a-> a -- ^ Set the draw window (do not call in your own code)- setSizeX :: Double -> a -> a -- ^ Set the drawing area width (do not call in your own code)- setSizeY :: Double -> a -> a -- ^ Set the drawing area height (do not call in your own code)- setImageCache :: Maybe ImageCache -> a -> a-
+ Graphics/Rendering/Hieroglyph/Visual.hs view
@@ -0,0 +1,76 @@+-- | 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 +-- forall a, Visual b : a -> Visual b+-- {-# LANGUAGE FlexibleInstances,IncoherentInstances #-}+module Graphics.Rendering.Hieroglyph.Visual where++import qualified Data.Map as M+import qualified Data.IntMap as IM+import qualified Data.Set as S+-- import Data.Foldable+import Data.List+import Graphics.Rendering.Hieroglyph.Primitives++type BaseVisual = [Primitive]++-- | 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 +-- this is the instance of Foldable that I choose to have people implement.+class Visual t where+ primitives :: t -> BaseVisual++-- | 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]+ +-- | 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 + +-- | 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++-- | 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 ++-- | A set of Visuals also comprises a Visual.+instance Visual t => Visual (S.Set t) where+ primitives = Prelude.concat . Prelude.map 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 = maxlev+1 }}) . primitives $ this) ++ primitives that+ where maxlev = maximum . map (layer . attribs) . primitives $ that + +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 = minimum . map (lod . attribs) . primitives $ that+ +-- | 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++-- | 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+
Hieroglyph.cabal view
@@ -1,5 +1,5 @@ Name: Hieroglyph-Version: 0.85+Version: 0.99 Cabal-Version: >= 1.2 License: BSD3 License-File: LICENSE@@ -13,14 +13,15 @@ Build-Type: Simple Library- Build-Depends: cairo, base, mtl, gtk, IfElse, containers+ Build-Depends: cairo, base, mtl, gtk, IfElse, containers, parallel Exposed-Modules: Graphics.Rendering.Hieroglyph- Graphics.Rendering.Hieroglyph.Primitives Graphics.Rendering.Hieroglyph.Cairo- Graphics.Rendering.Hieroglyph.BasicUIState- Graphics.Rendering.Hieroglyph.UIState- Graphics.Rendering.Hieroglyph.Interactive Graphics.Rendering.Hieroglyph.Colors+ Graphics.Rendering.Hieroglyph.ImageCache+ Graphics.Rendering.Hieroglyph.Interactive+ Graphics.Rendering.Hieroglyph.Primitives+ Graphics.Rendering.Hieroglyph.Scaffolds.Interactive+ Graphics.Rendering.Hieroglyph.Visual
LICENSE view
@@ -1,4 +1,4 @@-Copyright 2008, Jeff Heard. All rights reserved.+Copyright 2008, Renaissance Computing Institute. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: