Hieroglyph 0.99 → 1.1
raw patch · 4 files changed
+40/−20 lines, 4 filesdep +colour
Dependencies added: colour
Files
- Graphics/Rendering/Hieroglyph/Cairo.hs +14/−2
- Graphics/Rendering/Hieroglyph/Interactive.hs +11/−11
- Graphics/Rendering/Hieroglyph/Primitives.hs +13/−5
- Hieroglyph.cabal +2/−2
Graphics/Rendering/Hieroglyph/Cairo.hs view
@@ -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)+
Graphics/Rendering/Hieroglyph/Interactive.hs view
@@ -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
Graphics/Rendering/Hieroglyph/Primitives.hs view
@@ -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
Hieroglyph.cabal view
@@ -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