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 @@ -34,6 +34,9 @@ import Control.Monad.IfElse import Data.Foldable (foldlM) import Data.List (sort) +import Data.Colour +import Data.Colour.SRGB +import Data.Colour.Names (black) toCairoFontSlant FontSlantNormal = Cairo.FontSlantNormal toCairoFontSlant FontSlantItalic = Cairo.FontSlantItalic @@ -69,9 +72,16 @@ toCairoOperator OperatorAdd = Cairo.OperatorAdd toCairoOperator OperatorSaturate = Cairo.OperatorSaturate +colourToTuple :: AlphaColour Double -> (Double,Double,Double,Double) +colourToTuple c = (r,g,b,alpha) + where alpha = alphaChannel c + c' = (1/alpha) `darken` (c `Data.Colour.over` black) + RGB r g b = toSRGB c' + + fillStrokeAndClip state = do - let (fr,fg,fb,fa) = fillRGBA state - (sr,sg,sb,sa) = strokeRGBA state + let (fr,fg,fb,fa) = colourToTuple . fillRGBA $ state + (sr,sg,sb,sa) = colourToTuple . strokeRGBA $ state when (filled state) $ Cairo.setSourceRGBA fr fg fb fa >> if (outlined state) then Cairo.fillPreserve else Cairo.fill @@ -157,6 +167,7 @@ whendifferent fillrule . Cairo.setFillRule . toCairoFillRule . fillrule $ b whendifferent dash . maybe (return ()) (uncurry Cairo.setDash) . dash $ b whendifferent antialias . Cairo.setAntialias . toCairoAntialias . antialias $ b + whendifferent linewidth . Cairo.setLineWidth . linewidth $ b whendifferent linecap . Cairo.setLineCap . toCairoLineCap . linecap $ b whendifferent linejoin . Cairo.setLineJoin . toCairoLineJoin . linejoin $ b whendifferent miterlimit . Cairo.setMiterLimit . miterlimit $ b @@ -237,3 +248,4 @@ else do pbuf <- pixbufNewFromFile filename wk <- mkWeakPtr pbuf Nothing return ((M.insert (show im) wk dict), pbuf) + diff --git a/Graphics/Rendering/Hieroglyph/Interactive.hs b/Graphics/Rendering/Hieroglyph/Interactive.hs --- a/Graphics/Rendering/Hieroglyph/Interactive.hs +++ b/Graphics/Rendering/Hieroglyph/Interactive.hs @@ -14,6 +14,7 @@ import qualified Graphics.UI.Gtk.Cairo as Gtk import qualified Graphics.Rendering.Cairo as Cairo import qualified Graphics.UI.Gtk as Gtk +import qualified Graphics.UI.Gtk.Gdk.Events as Gtk import Control.Parallel.Strategies import Data.List @@ -159,29 +160,25 @@ -- window or expose any windows. guiInit :: (Interactive a, Visual b) => MVar a -- ^ The current Interactive - -> (a->b) -- ^ The scene to render + -> (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 + -> IO Gtk.DrawingArea -- ^ Returns the window that was created guiInit state scene name motionSensitive = do Gtk.unsafeInitGUIForThreadedRTS - window <- Gtk.windowNew - canvas <- Gtk.drawingAreaNew - Gtk.windowSetTitle window name - Gtk.containerAdd window canvas + canvas <- Gtk.drawingAreaNew imgcache <- initImageCache - modifyMVar_ state $ return . setDrawing (Just . Gtk.castToWidget $ canvas) . setImageCache (Just imgcache) primitiveData <- newMVar [] Gtk.onExpose canvas $ \evt -> renderer primitiveData state scene >> return True - Gtk.onConfigure window $ resize state + Gtk.onConfigure canvas $ resize state Gtk.onButtonPress canvas $ mouseButtonHandler state Gtk.onButtonRelease canvas $ mouseReleaseHandler state - Gtk.onKeyPress window $ keyboardHandler state + Gtk.onKeyPress canvas $ keyboardHandler state when motionSensitive $ (Gtk.onMotionNotify canvas True $ mouseMotionHandler state) >> return () - return window + return canvas -- | A higher level function for creating a GUI. Does not set the size of the -- window or expose any windows, but does kill the app if this window is @@ -194,7 +191,10 @@ -> IO Gtk.Window guiConstruct state scene name motionSensitive = do mvar <- newMVar state - window <- guiInit mvar scene name motionSensitive + canvas <- guiInit mvar scene name motionSensitive + window <- Gtk.windowNew + Gtk.windowSetTitle window name + Gtk.containerAdd window canvas Gtk.onDestroy window Gtk.mainQuit return window 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 @@ -17,6 +17,9 @@ import Data.Function (on) import Data.Maybe (fromMaybe) import Data.List +import Data.Colour +import Data.Colour.Names +import Data.Colour.SRGB --import Data.Foldable import qualified Data.Map as M import qualified Data.IntMap as IM @@ -41,6 +44,10 @@ ordinal (Spline _ _ _) = 1 ordinal (EndPoint _) = 2 +instance (Floating a, Ord a) => Ord (AlphaColour a) where + compare a b = fromMaybe EQ . find (/=EQ) . zipWith compare [channelRed a', channelGreen a', channelBlue a'] $ [channelRed b', channelGreen b', channelBlue b'] + where a' = toSRGB $ if alphaChannel a == 0 then black else a `Data.Colour.over` black + b' = toSRGB $ if alphaChannel b == 0 then black else b `Data.Colour.over` black instance Ord Rect where compare Plane Plane = EQ @@ -101,7 +108,8 @@ , 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 + -- | Not a primitive shape, exactly, but the union of several primitives. No order is implied in a union, merely that the areas that intersect are + | Union { prims :: [Primitive] , attribs :: Attributes } @@ -123,9 +131,9 @@ , 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] + , fillRGBA :: AlphaColour Double -- ^ The components of the stroke color in the range [0..1] , dash :: Maybe ([Double],Double) -- ^ The shape of the line dashing, if any - , strokeRGBA :: (Double,Double,Double,Double) -- ^ The components of the stroke color in the range [0..1] + , strokeRGBA :: AlphaColour Double -- ^ The components of the stroke color in the range [0..1] , antialias :: Antialias -- ^ The way things are antialiased , linecap :: LineCap -- ^ The way lines are capped , linejoin :: LineJoin -- ^ The way lines are joined @@ -267,9 +275,9 @@ , fontweight = FontWeightNormal , fontsize = 10 , fillrule = FillRuleWinding - , fillRGBA = (1,1,1,1) + , fillRGBA = opaque white , dash = Nothing - , strokeRGBA = (1,1,1,1) + , strokeRGBA = opaque white , antialias = AntialiasDefault , linecap = LineCapButt , linejoin = LineJoinMiter diff --git a/Hieroglyph.cabal b/Hieroglyph.cabal --- a/Hieroglyph.cabal +++ b/Hieroglyph.cabal @@ -1,5 +1,5 @@ Name: Hieroglyph -Version: 0.99 +Version: 1.1 Cabal-Version: >= 1.2 License: BSD3 License-File: LICENSE @@ -13,7 +13,7 @@ Build-Type: Simple Library - Build-Depends: cairo, base, mtl, gtk, IfElse, containers, parallel + Build-Depends: cairo, base, mtl, gtk, IfElse, containers, parallel, colour Exposed-Modules: Graphics.Rendering.Hieroglyph Graphics.Rendering.Hieroglyph.Cairo