module Wumpus.Core.Picture
(
blankPicture
, frame
, frameWithin
, frameMulti
, multi
, path
, lineTo
, curveTo
, vertexPath
, curvedPath
, Stroke(..)
, zostroke
, zcstroke
, Fill(..)
, zfill
, clip
, TextLabel(..)
, ztextlabel
, multilabel
, Ellipse(..)
, zellipse
, extendBoundary
) where
import Wumpus.Core.BoundingBox
import Wumpus.Core.Colour
import Wumpus.Core.Geometry
import Wumpus.Core.GraphicsState
import Wumpus.Core.PictureInternal
import Wumpus.Core.PictureLanguage
import Wumpus.Core.TextEncodingInternal
import Wumpus.Core.Utils
import Data.Semigroup
psBlack :: PSRgb
psBlack = RGB3 0 0 0
stdFrame :: Num u => Frame2 u
stdFrame = ortho zeroPt
blankPicture :: Num u => BoundingBox u -> Picture u
blankPicture bb = PicBlank (stdFrame, bb)
frame :: (Fractional u, Ord u) => Primitive u -> Picture u
frame p = Single (stdFrame, boundary p) p
frameWithin :: (Fractional u, Ord u) => Primitive u -> BoundingBox u -> Picture u
frameWithin p@(PLabel _ _) bb = Single (stdFrame,bb) p
frameWithin p bb = Single (stdFrame,bb `append` boundary p) p
frameMulti :: (Fractional u, Ord u) => [Primitive u] -> Picture u
frameMulti [] = error "Wumpus.Core.Picture.frameMulti - empty list"
frameMulti xs = multi $ map frame xs
multi :: (Fractional u, Ord u) => [Picture u] -> Picture u
multi ps = Picture (stdFrame, sconcat $ map boundary ps) ones
where
sconcat [] = error err_msg
sconcat (x:xs) = foldr append x xs
ones = fromListErr err_msg ps
err_msg = "Wumpus.Core.Picture.multi - empty list"
path :: Point2 u -> [PathSegment u] -> Path u
path = Path
lineTo :: Point2 u -> PathSegment u
lineTo = PLine
curveTo :: Point2 u -> Point2 u -> Point2 u -> PathSegment u
curveTo = PCurve
vertexPath :: [Point2 u] -> Path u
vertexPath [] = error "Picture.vertexPath - empty point list"
vertexPath (x:xs) = Path x (map PLine xs)
curvedPath :: [Point2 u] -> Path u
curvedPath [] = error "Picture.curvedPath - empty point list"
curvedPath (x:xs) = Path x (fn xs) where
fn (a:b:c:ys) = PCurve a b c : fn ys
fn _ = []
ostrokePath :: (Num u, Ord u)
=> PSRgb -> [StrokeAttr] -> Path u -> Primitive u
ostrokePath c attrs p = PPath (c, OStroke attrs) p
cstrokePath :: (Num u, Ord u)
=> PSRgb -> [StrokeAttr] -> Path u -> Primitive u
cstrokePath c attrs p = PPath (c, CStroke attrs) p
class Stroke t where
ostroke :: (Num u, Ord u) => t -> Path u -> Primitive u
cstroke :: (Num u, Ord u) => t -> Path u -> Primitive u
instance Stroke () where
ostroke () = ostrokePath psBlack []
cstroke () = cstrokePath psBlack []
instance Stroke (RGB3 Double) where
ostroke c = ostrokePath (psColour c) []
cstroke c = cstrokePath (psColour c) []
instance Stroke (HSB3 Double) where
ostroke c = ostrokePath (psColour c) []
cstroke c = cstrokePath (psColour c) []
instance Stroke (Gray Double) where
ostroke c = ostrokePath (psColour c) []
cstroke c = cstrokePath (psColour c) []
instance Stroke StrokeAttr where
ostroke x = ostrokePath psBlack [x]
cstroke x = cstrokePath psBlack [x]
instance Stroke [StrokeAttr] where
ostroke xs = ostrokePath psBlack xs
cstroke xs = cstrokePath psBlack xs
instance Stroke (RGB3 Double,StrokeAttr) where
ostroke (c,x) = ostrokePath (psColour c) [x]
cstroke (c,x) = cstrokePath (psColour c) [x]
instance Stroke (HSB3 Double,StrokeAttr) where
ostroke (c,x) = ostrokePath (psColour c) [x]
cstroke (c,x) = cstrokePath (psColour c) [x]
instance Stroke (Gray Double,StrokeAttr) where
ostroke (c,x) = ostrokePath (psColour c) [x]
cstroke (c,x) = cstrokePath (psColour c) [x]
instance Stroke (RGB3 Double,[StrokeAttr]) where
ostroke (c,xs) = ostrokePath (psColour c) xs
cstroke (c,xs) = cstrokePath (psColour c) xs
instance Stroke (HSB3 Double,[StrokeAttr]) where
ostroke (c,xs) = ostrokePath (psColour c) xs
cstroke (c,xs) = cstrokePath (psColour c) xs
instance Stroke (Gray Double,[StrokeAttr]) where
ostroke (c,xs) = ostrokePath (psColour c) xs
cstroke (c,xs) = cstrokePath (psColour c) xs
zostroke :: (Num u, Ord u) => Path u -> Primitive u
zostroke = ostrokePath psBlack []
zcstroke :: (Num u, Ord u) => Path u -> Primitive u
zcstroke = cstrokePath psBlack []
fillPath :: (Num u, Ord u) => PSRgb -> Path u -> Primitive u
fillPath c p = PPath (c,CFill) p
class Fill t where
fill :: (Num u, Ord u) => t -> Path u -> Primitive u
instance Fill () where fill () = fillPath psBlack
instance Fill (RGB3 Double) where fill = fillPath . psColour
instance Fill (HSB3 Double) where fill = fillPath . psColour
instance Fill (Gray Double) where fill = fillPath . psColour
zfill :: (Num u, Ord u) => Path u -> Primitive u
zfill = fillPath psBlack
clip :: (Num u, Ord u) => Path u -> Picture u -> Picture u
clip cp p = Clip (ortho zeroPt, boundary cp) cp p
mkTextLabel :: PSRgb -> FontAttr -> Point2 u -> String -> Primitive u
mkTextLabel c attr pt txt = PLabel (c,attr) (Label pt $ lexLabel txt)
default_font :: FontAttr
default_font = FontAttr "Courier" "Courier New" SVG_REGULAR 12
class TextLabel t where
textlabel :: t -> Point2 u -> String -> Primitive u
instance TextLabel () where textlabel () = mkTextLabel psBlack default_font
instance TextLabel (RGB3 Double) where
textlabel c = mkTextLabel (psColour c) default_font
instance TextLabel (HSB3 Double) where
textlabel c = mkTextLabel (psColour c) default_font
instance TextLabel (Gray Double) where
textlabel c = mkTextLabel (psColour c) default_font
instance TextLabel FontAttr where
textlabel a = mkTextLabel psBlack a
instance TextLabel (RGB3 Double,FontAttr) where
textlabel (c,a) = mkTextLabel (psColour c) a
instance TextLabel (HSB3 Double,FontAttr) where
textlabel (c,a) = mkTextLabel (psColour c) a
instance TextLabel (Gray Double,FontAttr) where
textlabel (c,a) = mkTextLabel (psColour c) a
ztextlabel :: Point2 u -> String -> Primitive u
ztextlabel = mkTextLabel psBlack default_font
multilabel :: (Fractional u, Ord u, TextLabel t)
=> t -> u -> VAlign -> Point2 u -> [String]-> Picture u
multilabel _ _ _ _ [] = error $
"Wumpus.Core.Picture.multilabel - empty list."
multilabel attr n va pt (x:xs) =
moveAll $ vsepA va n line1 (map mkPic xs)
where
line1 = mkPic x
mkPic = frame . textlabel attr zeroPt
vdelta p = boundaryHeight (boundary p) boundaryHeight (boundary line1)
moveAll p = moveV (vdelta p) $ p `at` pt
mkEllipse :: Num u
=> PSRgb -> DrawEllipse -> u -> u -> Point2 u -> Primitive u
mkEllipse c dp hw hh pt = PEllipse (c,dp) pt hw hh
ellipseDefault :: EllipseProps
ellipseDefault = (psBlack, EFill)
class Ellipse t where
ellipse :: Fractional u => t -> u -> u -> Point2 u -> Primitive u
instance Ellipse () where ellipse () = zellipse
instance Ellipse DrawEllipse where ellipse dp = mkEllipse psBlack dp
instance Ellipse StrokeAttr where
ellipse = mkEllipse psBlack . EStroke . return
instance Ellipse [StrokeAttr] where
ellipse = mkEllipse psBlack . EStroke
instance Ellipse (RGB3 Double) where
ellipse c = mkEllipse (psColour c) EFill
instance Ellipse (HSB3 Double) where
ellipse c = mkEllipse (psColour c) EFill
instance Ellipse (Gray Double) where
ellipse c = mkEllipse (psColour c) EFill
instance Ellipse (RGB3 Double,DrawEllipse) where
ellipse (c,dp) = mkEllipse (psColour c) dp
instance Ellipse (HSB3 Double,DrawEllipse) where
ellipse (c,dp) = mkEllipse (psColour c) dp
instance Ellipse (Gray Double,DrawEllipse) where
ellipse (c,dp) = mkEllipse (psColour c) dp
instance Ellipse (RGB3 Double,StrokeAttr) where
ellipse (c,x) = mkEllipse (psColour c) (EStroke [x])
instance Ellipse (HSB3 Double,StrokeAttr) where
ellipse (c,x) = mkEllipse (psColour c) (EStroke [x])
instance Ellipse (Gray Double,StrokeAttr) where
ellipse (c,x) = mkEllipse (psColour c) (EStroke [x])
instance Ellipse (RGB3 Double,[StrokeAttr]) where
ellipse (c,xs) = mkEllipse (psColour c) (EStroke xs)
instance Ellipse (HSB3 Double,[StrokeAttr]) where
ellipse (c,xs) = mkEllipse (psColour c) (EStroke xs)
instance Ellipse (Gray Double,[StrokeAttr]) where
ellipse (c,xs) = mkEllipse (psColour c) (EStroke xs)
zellipse :: Num u => u -> u -> Point2 u -> Primitive u
zellipse = uncurry mkEllipse ellipseDefault
extendBoundary :: (Num u, Ord u) => u -> u -> Picture u -> Picture u
extendBoundary x y = mapLocale (\(fr,bb) -> (fr, extBB (posve x) (posve y) bb))
where
extBB x' y' (BBox (P2 x0 y0) (P2 x1 y1)) = BBox pt1 pt2 where
pt1 = P2 (x0x') (y0y')
pt2 = P2 (x1+x') (y1+y')
posve n | n < 0 = 0
| otherwise = n