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 @@ -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 diff --git a/Graphics/Rendering/Hieroglyph/OpenGL/Compile.hs b/Graphics/Rendering/Hieroglyph/OpenGL/Compile.hs --- a/Graphics/Rendering/Hieroglyph/OpenGL/Compile.hs +++ b/Graphics/Rendering/Hieroglyph/OpenGL/Compile.hs @@ -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) diff --git a/Graphics/Rendering/Hieroglyph/OpenGL/Render.hs b/Graphics/Rendering/Hieroglyph/OpenGL/Render.hs --- a/Graphics/Rendering/Hieroglyph/OpenGL/Render.hs +++ b/Graphics/Rendering/Hieroglyph/OpenGL/Render.hs @@ -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 = [] } 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 @@ -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 diff --git a/Graphics/Rendering/Hieroglyph/Stylesheets.hs b/Graphics/Rendering/Hieroglyph/Stylesheets.hs new file mode 100644 --- /dev/null +++ b/Graphics/Rendering/Hieroglyph/Stylesheets.hs @@ -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) + 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 @@ -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 + diff --git a/Hieroglyph.cabal b/Hieroglyph.cabal --- a/Hieroglyph.cabal +++ b/Hieroglyph.cabal @@ -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: