-- | This is Hieroglyph, a 2D scenegraph library similar in functionality to a barebones -- stripped down version of Processing, but written in a purely functional manner. -- -- See individual implementations (like the Graphics.Rendering.Hieroglyph.Cairo module) -- for more information on how to use this library. -- -- [@Author@] Jeff Heard -- -- [@Copyright@] © 2008 Renaissance Computing Institute -- -- [@License@] A LICENSE file should be included as part of this distribution -- -- [@Version@] 0.5 -- module Graphics.Rendering.Hieroglyph.Primitives where 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 -- | A 2D point data Point = Point Double Double deriving (Show, Read, Eq, Ord) 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 (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 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 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 , attribs :: Attributes } -- | A cubic spline | 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 , attribs :: Attributes } -- | A rectangle | Rectangle -- An rectangle { topleft :: Point -- ^ The top left point , width :: Double -- ^ The width , height :: Double -- ^ The height , 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. , attribs :: Attributes } -- | 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 } -- | A rectangular image | Image { 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 :: 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 :: 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 , 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 , 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 = opaque white , dash = Nothing , strokeRGBA = opaque white , 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 plain path :: Primitive -- ^ A line starting at the origin. path = Path origin [] False plain polygon :: Primitive -- ^ An arbitrary filled polygon starting at the origin. polygon = Path origin [] True plain{ filled=True } rectangle :: Primitive -- ^ an outlined rectangle rectangle = Rectangle (Point 0 1) 1 1 plain text :: Primitive -- ^ A rendered string starting at the origin. text = Text "" origin plain compound :: Primitive -- ^ An outlined compound object compound = Union [] plain degrees :: Double -> Double -- ^ Convert degrees to radians degrees x = x * 0.0174532925 hidden :: Primitive -- ^ A hidden object. hidden = Hidden plain image :: Primitive -- ^ An image. These are efficiently cached using weak references where possible image = Image "" (Left origin) False plain