module Wumpus.Core.Picture
(
blankPicture
, frame
, frameWithin
, frameMulti
, multi
, path
, lineTo
, curveTo
, vertexPath
, curvedPath
, wumpus_default_font
, Stroke(..)
, zostroke
, zcstroke
, Fill(..)
, zfill
, clip
, TextLabel(..)
, ztextlabel
, Ellipse(..)
, zellipse
, extendBoundary
, picMoveBy
, picOver
, picBeside
, illustrateBounds
, illustrateBoundsPrim
, illustrateControlPoints
) where
import Wumpus.Core.BoundingBox
import Wumpus.Core.Colour
import Wumpus.Core.Geometry
import Wumpus.Core.GraphicsState
import Wumpus.Core.OneList
import Wumpus.Core.PictureInternal
import Wumpus.Core.TextEncodingInternal
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 :: (Real u, Floating u) => Primitive u -> Picture u
frame p = Single (stdFrame, boundary p) p
frameWithin :: (Real u, Floating 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 :: (Real u, Floating 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) $ step ps
where
sconcat [] = error err_msg
sconcat (x:xs) = foldr append x xs
step [x] = one x
step (x:xs) = x `cons` step xs
step _ = error err_msg
err_msg = "Wumpus.Core.Picture.multi - empty list"
path :: Point2 u -> [PathSegment u] -> Path u
path = Path
lineTo :: Point2 u -> PathSegment u
lineTo = PLineTo
curveTo :: Point2 u -> Point2 u -> Point2 u -> PathSegment u
curveTo = PCurveTo
vertexPath :: [Point2 u] -> Path u
vertexPath [] = error "Picture.vertexPath - empty point list"
vertexPath (x:xs) = Path x (map PLineTo 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) = PCurveTo a b c : fn ys
fn _ = []
wumpus_default_font :: FontAttr
wumpus_default_font = FontAttr "Courier" "Courier New" SVG_REGULAR 24
ostrokePath :: Num u => PSRgb -> [StrokeAttr] -> Path u -> Primitive u
ostrokePath c attrs p = PPath (c, OStroke attrs) p
cstrokePath :: Num u => PSRgb -> [StrokeAttr] -> Path u -> Primitive u
cstrokePath c attrs p = PPath (c, CStroke attrs) p
class Stroke t where
ostroke :: Num u => t -> Path u -> Primitive u
cstroke :: Num 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 => Path u -> Primitive u
zostroke = ostrokePath psBlack []
zcstroke :: Num u => Path u -> Primitive u
zcstroke = cstrokePath psBlack []
fillPath :: Num u => PSRgb -> Path u -> Primitive u
fillPath c p = PPath (c,CFill) p
class Fill t where
fill :: Num 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 => 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 :: Num u => PSRgb -> FontAttr -> String -> Point2 u -> Primitive u
mkTextLabel c attr txt pt = PLabel (c,attr) lbl
where
lbl = Label pt (lexLabel txt) identityCTM
class TextLabel t where
textlabel :: Num u => t -> String -> Point2 u -> Primitive u
instance TextLabel () where
textlabel () = mkTextLabel psBlack wumpus_default_font
instance TextLabel (RGB3 Double) where
textlabel c = mkTextLabel (psColour c) wumpus_default_font
instance TextLabel (HSB3 Double) where
textlabel c = mkTextLabel (psColour c) wumpus_default_font
instance TextLabel (Gray Double) where
textlabel c = mkTextLabel (psColour c) wumpus_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 :: Num u => String -> Point2 u -> Primitive u
ztextlabel = mkTextLabel psBlack wumpus_default_font
mkEllipse :: Num u
=> PSRgb -> DrawEllipse -> u -> u -> Point2 u -> Primitive u
mkEllipse c dp hw hh pt = PEllipse (c,dp) (PrimEllipse pt hw hh identityCTM)
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
infixr 6 `picBeside`, `picOver`
picOver :: (Num u, Ord u) => Picture u -> Picture u -> Picture u
a `picOver` b = Picture (ortho zeroPt, bb) (cons a $ one b)
where
bb = union (boundary a) (boundary b)
picMoveBy :: Num u => Picture u -> Vec2 u -> Picture u
p `picMoveBy` v = v `movePic` p
picBeside :: (Num u, Ord u) => Picture u -> Picture u -> Picture u
a `picBeside` b = a `picOver` (b `picMoveBy` v)
where
v = hvec $ rightPlane (boundary a) leftPlane (boundary b)
illustrateBounds :: (Real u, Floating u) => DRGB -> Picture u -> Picture u
illustrateBounds rgb p = p `picOver` (frameMulti $ boundsPrims rgb p)
illustrateBoundsPrim :: (Real u, Floating u)
=> DRGB -> Primitive u -> Picture u
illustrateBoundsPrim rgb p = frameMulti (boundsPrims rgb p ++ [p])
boundsPrims :: (Num u, Ord u, Boundary t, u ~ DUnit t)
=> DRGB -> t -> [Primitive u]
boundsPrims rgb a = [ bbox_rect, bl_to_tr, br_to_tl ]
where
(bl,br,tr,tl) = corners $ boundary a
bbox_rect = cstroke rgb $ vertexPath [bl,br,tr,tl]
bl_to_tr = ostroke rgb $ vertexPath [bl,tr]
br_to_tl = ostroke rgb $ vertexPath [br,tl]
illustrateControlPoints :: (Real u, Floating u)
=> DRGB -> Primitive u -> Picture u
illustrateControlPoints rgb prim = step prim
where
step (PEllipse _ e) = frameMulti (prim : ellipseCtrlLines rgb e)
step (PPath _ p) = frameMulti (prim : pathCtrlLines rgb p)
step _ = frame prim
pathCtrlLines :: (Num u, Ord u) => DRGB -> Path u -> [Primitive u]
pathCtrlLines rgb (Path start ss) = step start ss
where
step _ [] = []
step _ (PLineTo e:xs) = step e xs
step s (PCurveTo c1 c2 e:xs) = mkLine s c1 : mkLine c2 e : step e xs
mkLine s e = ostroke rgb (Path s [lineTo e])
ellipseCtrlLines :: (Real u, Floating u)
=> DRGB -> PrimEllipse u -> [Primitive u]
ellipseCtrlLines rgb pe = start all_points
where
all_points = ellipseControlPoints pe
start (s:c1:c2:e:xs) = mkLine s c1 : mkLine c2 e : rest e xs
start _ = []
rest s (c1:c2:e:xs) = mkLine s c1 : mkLine c2 e : rest e xs
rest _ _ = []
mkLine s e = ostroke rgb (Path s [lineTo e])