Hieroglyph 3.2 → 3.5
raw patch · 7 files changed
+130/−67 lines, 7 files
Files
- Graphics/Rendering/Hieroglyph/Cairo.hs +1/−11
- Graphics/Rendering/Hieroglyph/OpenGL/Compile.hs +27/−40
- Graphics/Rendering/Hieroglyph/OpenGL/Render.hs +19/−9
- Graphics/Rendering/Hieroglyph/Primitives.hs +6/−5
- Graphics/Rendering/Hieroglyph/Stylesheets.hs +68/−0
- Graphics/Rendering/Hieroglyph/Visual.hs +7/−1
- Hieroglyph.cabal +2/−1
Graphics/Rendering/Hieroglyph/Cairo.hs view
@@ -33,7 +33,6 @@ import Data.Colour.SRGB import Data.Colour.Names (black) import qualified Text.PrettyPrint as Pretty-import Data.Maybe type ImageCache = MVar (Cache.Cache Primitive Pixbuf) @@ -135,8 +134,7 @@ fillStrokeAndClip state $ Cairo.rectangle ox oy w h return state -renderPrimitive context _ s0 txt@(Text _ (Point ox oy) _ _ _ _ _ _ _ _ bg) = do- Cairo.save+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@@ -146,17 +144,9 @@ layoutSetIndent layout . indent $ txt return layout applyAttributeDelta s0 (attribs txt)- if isJust (backgroundcolour txt)- then do (PangoRectangle _ _ lw lh, _) <- liftIO (layoutGetExtents layout)- let (br,bg,bb,ba) = colourToTuple (fromJust $ backgroundcolour txt) in Cairo.setSourceRGBA br bg bb ba- Cairo.rectangle ox oy (lw+2) (lh+2)- Cairo.fill- Cairo.translate 2 2- else return () fillStrokeAndClip (attribs txt) $ do Cairo.moveTo ox oy Cairo.showLayout layout- Cairo.restore return (attribs txt) renderPrimitive context images s0 (Union prims state _) = do
Graphics/Rendering/Hieroglyph/OpenGL/Compile.hs view
@@ -54,9 +54,6 @@ import Data.Colour.SRGB import qualified Text.PrettyPrint as Pretty import System.Mem.Weak-import Control.Exception-import Debug.Trace- 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]]@@ -83,7 +80,7 @@ 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@(Text _ _ _ _ _ _ _ _ _ _) = compileText e a compile e a@(Image _ _ _ _ _) = compileImage e a compileDots e p@(Dots ds attrs s) = (maybe e (\n -> e{ namemap=Map.insert (fromIntegral s) n (namemap e)}) (aname attrs), CompiledDots p (vdata ds) (fromIntegral s))@@ -150,7 +147,7 @@ layoutSetWidth layout . wrapwidth $ txt layoutSetWrap layout . wrapmode $ txt layoutSetIndent layout . indent $ txt- (PangoRectangle ex ey ew eh, _) <- layoutGetExtents layout+ (PangoRectangle _ _ _ _, PangoRectangle ex ey ew eh) <- layoutGetExtents layout let (po2w,po2h) = nearestPowerOfTwo ew eh potw = 2 ^ (max 0 $ ceiling po2w) poth = 2 ^ (max 0 $ ceiling po2h)@@ -169,11 +166,6 @@ liftIO $ layoutContextChanged layout Cairo.save Cairo.translate (-ex) (-ey)- when (isJust . backgroundcolour $ txt) $ do- let (br,bg,bb,ba) = colourToTuple . fromJust . backgroundcolour $ txt in Cairo.setSourceRGBA br bg bb ba- Cairo.rectangle 0 0 w h- Cairo.fill- Cairo.translate 2 2 let (fr,fg,fb,fa) = colourToTuple . afillRGBA $ state (sr,sg,sb,sa) = colourToTuple . astrokeRGBA $ state state = attribs txt@@ -216,41 +208,36 @@ return ( e{texture_greylist = c'} , CompiledImage img x y w h tex (fromIntegral (sig img))) | otherwise = do- pbuf <- try $ case dimensions img of- (Left (Point x y)) -> Gtk.pixbufNewFromFile (filename img) - (Right (Rect x y w h)) -> Gtk.pixbufNewFromFileAtScale (filename img) (round w) (round h) (preserveaspect img) - - let exceptionHandler = flip $ either (\_ -> trace ("Image failed to load" ++ filename img) $ return (e, CompiledImage img x y 1 1 (GL.TextureObject 0) 0))-- exceptionHandler pbuf $ \pb -> do - (w,h,potw,poth,channels,buffer) <- copydata pb+ (w,h,potw,poth,channels,buffer) <- case dimensions img of+ (Left (Point x y)) -> Gtk.pixbufNewFromFile (filename img) >>= copydata+ (Right (Rect x y w h)) -> Gtk.pixbufNewFromFileAtScale (filename img) (round w) (round h) (preserveaspect img) >>= copydata - let (e', tex) = getFreeTexture e+ let (e', tex) = getFreeTexture e - GL.textureBinding GL.Texture2D $= Just tex- GL.textureWrapMode GL.Texture2D GL.S $= (GL.Repeated, GL.Clamp)- GL.textureWrapMode GL.Texture2D GL.T $= (GL.Repeated, GL.Clamp)- GL.textureFilter GL.Texture2D $= ((GL.Linear', Nothing), GL.Linear')- GL.textureFunction $= GL.Decal+ GL.textureBinding GL.Texture2D $= Just tex+ GL.textureWrapMode GL.Texture2D GL.S $= (GL.Repeated, GL.Clamp)+ GL.textureWrapMode GL.Texture2D GL.T $= (GL.Repeated, GL.Clamp)+ GL.textureFilter GL.Texture2D $= ((GL.Linear', Nothing), GL.Linear')+ GL.textureFunction $= GL.Decal - GL.texImage2D Nothing- GL.NoProxy- 0- (if channels == 4 then GL.RGBA' else GL.RGB')- (GL.TextureSize2D (fromIntegral potw) (fromIntegral poth))- 0- (GL.PixelData (if channels == 4 then GL.RGBA else GL.RGB)- GL.UnsignedByte- (unsafeForeignPtrToPtr (dataFrom buffer)))+ GL.texImage2D Nothing+ GL.NoProxy+ 0+ (if channels == 4 then GL.RGBA' else GL.RGB')+ (GL.TextureSize2D (fromIntegral potw) (fromIntegral poth))+ 0+ (GL.PixelData (if channels == 4 then GL.RGBA else GL.RGB)+ GL.UnsignedByte+ (unsafeForeignPtrToPtr (dataFrom buffer))) - let (w',h') = case dimensions img of- Left _ -> (fromIntegral w, fromIntegral h)- Right (Rect _ _ w0 h0) -> (w0,h0)+ let (w',h') = case dimensions img of+ Left _ -> (fromIntegral w, fromIntegral h)+ Right (Rect _ _ w0 h0) -> (w0,h0) - return ( e'{ texdims = Map.insert tex (w',h') (texdims e')- , texture_greylist = Cache.put (cacheimg img) tex (texture_greylist e')- }- , CompiledImage img x y w' h' tex (fromIntegral (sig img)))+ return ( e'{ texdims = Map.insert tex (w',h') (texdims e')+ , texture_greylist = Cache.put (cacheimg img) tex (texture_greylist e')+ }+ , CompiledImage img x y w' h' tex (fromIntegral (sig img))) where (x, y) = case dimensions img of Left (Point x0 y0) -> (x0, y0) Right (Rect x0 y0 _ _) -> (x0,y0)
Graphics/Rendering/Hieroglyph/OpenGL/Render.hs view
@@ -74,15 +74,19 @@ GL.textureBinding GL.Texture2D $= Nothing loadAttrs attrs + GL.lineSmooth $= GL.Disabled+ GL.polygonSmooth $= GL.Disabled GL.color . colourToGL . afillRGBA $ attrs when (afilled attrs) . GL.withName (GL.Name iid) .- GL.renderPrimitive GL.TriangleFan .+ GL.renderPrimitive GL.Quads . mapM_ GL.vertex $ take 4 vertices GL.color . colourToGL . astrokeRGBA $ attrs+ GL.lineSmooth $= GL.Enabled+ GL.polygonSmooth $= GL.Enabled when (aoutlined attrs) . GL.withName (GL.Name iid) .@@ -96,8 +100,8 @@ ,GL.Vertex3 (x+w) (y+h) z ,GL.Vertex3 x (y+h) z ,GL.Vertex3 x y z]--+ + renderCompiledGeometry z obj@(CompiledImage original x y w h tex iid) = do GL.textureFunction $= GL.Replace@@ -107,6 +111,9 @@ GL.texture GL.Texture2D $= GL.Enabled GL.textureFunction $= GL.Replace + GL.lineSmooth $= GL.Disabled+ GL.polygonSmooth $= GL.Disabled+ GL.withName (GL.Name iid) . GL.renderPrimitive GL.Quads $ do GL.texCoord $ GL.TexCoord2 0 (1::Double) GL.vertex $ GL.Vertex3 x y z@@ -118,10 +125,12 @@ GL.vertex $ GL.Vertex3 x (y+h) z GL.flush + GL.lineSmooth $= GL.Enabled+ GL.polygonSmooth $= GL.Enabled renderObject z obj | afilled (attribs . original $ obj) = GL.preservingMatrix $ do-+ GL.textureBinding GL.Texture2D $= Nothing loadAttrs (attribs . original $ obj ) GL.color . colourToGL . afillRGBA . attribs . original $ obj@@ -129,7 +138,7 @@ GL.color . colourToGL . astrokeRGBA . attribs . original $ obj when (aoutlined (attribs . original $ obj)) $ (GL.withName (GL.Name (uid obj)) . GL.renderPrimitive GL.LineStrip . mapM_ GL.vertex . verticesFrom . drop 2 $ vertices obj) | otherwise = GL.preservingMatrix $ do-+ loadAttrs (attribs . original $ obj) GL.color . colourToGL . astrokeRGBA . attribs . original $ obj GL.withName (GL.Name (uid obj)) . GL.renderPrimitive GL.LineStrip . mapM_ GL.vertex . verticesFrom . drop 2 $ vertices obj@@ -146,6 +155,8 @@ 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@@ -170,10 +181,9 @@ GL.depthFunc $= Just GL.Less GL.blend $= GL.Enabled GL.blendFunc $= (GL.SrcAlpha, GL.OneMinusSrcAlpha)- GL.lineSmooth $= GL.Disabled- GL.polygonSmooth $= GL.Disabled- GL.pointSmooth $= GL.Disabled- GL.multisample $= GL.Enabled+ GL.lineSmooth $= GL.Enabled+ GL.polygonSmooth $= GL.Enabled+ GL.pointSmooth $= GL.Enabled r' <- renderObjects [1::Double,2..] (sort geo) runtime Gtk.glDrawableSwapBuffers drawable return r'{ texture_blacklist = [] }
Graphics/Rendering/Hieroglyph/Primitives.hs view
@@ -187,7 +187,6 @@ , attribs :: Attributes , spacing :: Double , sig :: Int- , backgroundcolour :: Maybe (AlphaColour Double) } -- | 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@@ -242,6 +241,7 @@ , 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 , updated :: Bool+ , styleselector :: Maybe String } deriving (Show,Read,Eq) @@ -275,7 +275,7 @@ lineordering (Spline _ _ _) = 1 lineordering (EndPoint _) = 2 comparePrimitives (Rectangle o w h _ _) (Rectangle o' w' h' _ _) = fromMaybe EQ (find (/=EQ) [compare o o', compare w w', compare h h'])-comparePrimitives (Text s b _ _ _ _ _ _ _ _ _) (Text s' b' _ _ _ _ _ _ _ _ _ ) = fromMaybe EQ (find (/=EQ) [compare s s', compare b b'])+comparePrimitives (Text s b _ _ _ _ _ _ _ _) (Text s' b' _ _ _ _ _ _ _ _) = fromMaybe EQ (find (/=EQ) [compare s s', compare b b']) comparePrimitives (Union p _ _) (Union p' _ _) = fromMaybe EQ . find (/=EQ) . map (uncurry compare) $ zip p p' comparePrimitives (Image f d p _ _) (Image f' d' p' _ _) = fromMaybe EQ . find (/=EQ) $ [compare f f', compare d d', compare p p'] comparePrimitives a b = compare (primitiveOrdering a) (primitiveOrdering b)@@ -286,7 +286,7 @@ primitiveOrdering (Arc _ _ _ _ _ _ _) = 1 primitiveOrdering (Path _ _ _ _ _) = 2 primitiveOrdering (Rectangle _ _ _ _ _) = 3-primitiveOrdering (Text _ _ _ _ _ _ _ _ _ _ _) = 4+primitiveOrdering (Text _ _ _ _ _ _ _ _ _ _) = 4 primitiveOrdering (Union _ _ _) = 5 primitiveOrdering (Image _ _ _ _ _) = 6 primitiveOrdering (Hidden _ _) = 7@@ -364,7 +364,8 @@ , layer = 0 , lod = 0 , aname = Nothing- , updated = True }+ , updated = True + , styleselector = Nothing } -- | See pango span tag@@ -434,7 +435,7 @@ rectangle = sign $ Rectangle (Point 0 1) 1 1 plain 0 string :: Primitive -- ^ A rendered string starting at the origin.-string = sign $ Text empty origin AlignLeft Nothing WrapWholeWords False 0 plain{ afilled=True } 0 0 Nothing+string = sign $ Text empty origin AlignLeft Nothing WrapWholeWords False 0 plain{ afilled=True } 0 0 compound :: Primitive -- ^ An outlined compound object compound = sign $ Union [] plain 0
+ Graphics/Rendering/Hieroglyph/Stylesheets.hs view
@@ -0,0 +1,68 @@+module Graphics.Rendering.Hieroglyph.Stylesheets where+ +import Graphics.Rendering.Hieroglyph.Primitives+import Graphics.Rendering.Hieroglyph.Visual+import Data.Map (Map)+import qualified Data.Map as Map+ +type Style = BaseVisual -> BaseVisual+ +data Styling = + StyleSelector String Style+ | ArcStyle Style+ | DotsStyle Style+ | PathStyle Style+ | RectStyle Style+ | TextStyle Style+ +data Stylesheet = Stylesheet + { selectors :: Map String Style+ , arcstyle :: Style+ , dotstyle :: Style+ , pathstyle :: Style+ , rectanglestyle :: Style+ , textstyle :: Style+ }++data BaseSel = + IsArc (Maybe String) + | IsDots (Maybe String) + | IsPath (Maybe String)+ | IsRect (Maybe String)+ | IsText (Maybe String)+ | IsRest (Maybe String)+ deriving (Ord,Eq)+ +stylesheet styles = foldr mkStylesheet' (Stylesheet Map.empty id id id id id) styles + where mkStylesheet' (ArcStyle s) ss = ss{ arcstyle = s }+ mkStylesheet' (DotsStyle s) ss = ss{ dotstyle = s }+ mkStylesheet' (PathStyle s) ss = ss{ pathstyle = s }+ mkStylesheet' (RectStyle s) ss = ss{ rectanglestyle = s }+ mkStylesheet' (TextStyle s) ss = ss{ textstyle = s }+ mkStylesheet' (StyleSelector k s) ss = ss{ selectors = Map.insert k s . selectors $ ss }+ +binHelper p k = maybe + (k Nothing,p) + (\s -> (k (Just s),p)) + (styleselector . attribs $ p)+ +bin p@(Dots _ _ _) = binHelper p IsDots+bin p@(Arc _ _ _ _ _ _ _) = binHelper p IsArc+bin p@(Path _ _ _ _ _) = binHelper p IsPath+bin p@(Rectangle _ _ _ _ _) = binHelper p IsRect+bin p@(Text _ _ _ _ _ _ _ _ _ _) = binHelper p IsText+bin p = binHelper p IsRest++styledPrims ss = style ss . primitives++withStylesheet ss v = concat $ Map.elems styledVisuals+ where binnedVisuals = foldr (\(b,p) -> Map.insertWith (++) b [p]) Map.empty . map bin $ v+ styledVisuals = Map.mapWithKey applyStyle binnedVisuals+ applyStyle (IsArc s) ps = applyStyle' s (arcstyle ss) ps+ applyStyle (IsDots s) ps = applyStyle' s (dotstyle ss) ps+ applyStyle (IsPath s) ps = applyStyle' s (pathstyle ss) ps+ applyStyle (IsRect s) ps = applyStyle' s (rectanglestyle ss) ps+ applyStyle (IsText s) ps = applyStyle' s (textstyle ss) ps+ applyStyle (IsRest s) ps = applyStyle' s id ps+ applyStyle' (Just sel) f ps = maybe (f ps) ($ps) (Map.lookup sel . selectors $ ss)+
Graphics/Rendering/Hieroglyph/Visual.hs view
@@ -54,7 +54,7 @@ -- | Declare that a Visual possibly occludes another Visual occludes :: (Visual t, Visual u) => t -> u -> BaseVisual occludes this that = ((\p -> p{ layer = maxlev+1 }) <%> primitives this) ++ (primitives that)- where maxlev = if length (primitives that) > 0 then maximum . map (layer . attribs) . primitives $ that else maximum . map (layer . attribs) . primitives $ this+ where maxlev = maximum . map (layer . attribs) . primitives $ that -- | Declare that a Visual doesn't occlude another Visual beside :: (Visual t, Visual u) => t -> u -> BaseVisual@@ -163,6 +163,12 @@ fresh :: Visual a => a -> BaseVisual fresh os = (\o -> o{updated = True}) <%> primitives os +-- | Set the linewidth linewidth :: Visual a => Double -> a -> BaseVisual linewidth x os = (\o -> o{alinewidth = x}) <%> primitives os++-- | Set the stylesheet selector+style :: Visual a => String -> a -> BaseVisual+style s os = (\o -> o{ styleselector=Just s }) <%> primitives os+
Hieroglyph.cabal view
@@ -1,5 +1,5 @@ name: Hieroglyph-version: 3.2+version: 3.5 cabal-version: >=1.2 build-type: Simple license: BSD3@@ -33,6 +33,7 @@ Graphics.Rendering.Hieroglyph.OpenGL.Render Graphics.Rendering.Hieroglyph.OpenGL.Compile Graphics.Rendering.Hieroglyph.Cache+ Graphics.Rendering.Hieroglyph.Stylesheets exposed: True buildable: True build-tools: