module Wumpus.Core.Picture
(
frame
, multi
, path
, lineTo
, curveTo
, vertexPath
, curvedPath
, xlinkhref
, Stroke(..)
, zostroke
, zcstroke
, Fill(..)
, zfill
, Ellipse(..)
, zellipse
, clip
, TextLabel(..)
, ztextlabel
, extendBoundary
, picOver
, picMoveBy
, picBeside
, printPicture
, illustrateBounds
, illustrateBoundsPrim
, illustrateControlPoints
) where
import Wumpus.Core.AffineTrans
import Wumpus.Core.BoundingBox
import Wumpus.Core.Colour
import Wumpus.Core.FormatCombinators
import Wumpus.Core.Geometry
import Wumpus.Core.GraphicsState
import Wumpus.Core.OneList
import Wumpus.Core.PictureInternal
import Wumpus.Core.PtSize
import Wumpus.Core.TextInternal
import Wumpus.Core.Utils
import Data.AffineSpace
import Data.Semigroup
frame :: (Real u, Floating u, FromPtSize u) => [Primitive u] -> Picture u
frame [] = error "Wumpus.Core.Picture.frame - empty list"
frame (p:ps) = let (bb,ones) = step p ps in Leaf (bb,[]) ones
where
step a [] = (boundary a, one a)
step a (x:xs) = let (bb', rest) = step x xs
in ( boundary a `append` bb', cons a rest )
multi :: (Fractional u, Ord u) => [Picture u] -> Picture u
multi [] = error "Wumpus.Core.Picture.multi - empty list"
multi (p:ps) = let (bb,ones) = step p ps in Picture (bb,[]) ones
where
step a [] = (boundary a, one a)
step a (x:xs) = let (bb', rest) = step x xs
in ( boundary a `append` bb', cons a rest )
path :: Point2 u -> [PrimPathSegment u] -> PrimPath u
path = PrimPath
lineTo :: Point2 u -> PrimPathSegment u
lineTo = PLineTo
curveTo :: Point2 u -> Point2 u -> Point2 u -> PrimPathSegment u
curveTo = PCurveTo
vertexPath :: [Point2 u] -> PrimPath u
vertexPath [] = error "Picture.vertexPath - empty point list"
vertexPath (x:xs) = PrimPath x (map PLineTo xs)
curvedPath :: [Point2 u] -> PrimPath u
curvedPath [] = error "Picture.curvedPath - empty point list"
curvedPath (x:xs) = PrimPath x (step xs)
where
step (a:b:c:ys) = PCurveTo a b c : step ys
step _ = []
xlinkhref :: String -> XLink
xlinkhref = XLinkHRef
ostrokePath :: Num u
=> RGBi -> [StrokeAttr] -> XLink -> PrimPath u -> Primitive u
ostrokePath rgb attrs xlink p = PPath (OStroke attrs rgb) xlink p
cstrokePath :: Num u
=> RGBi -> [StrokeAttr] -> XLink -> PrimPath u -> Primitive u
cstrokePath rgb attrs xlink p = PPath (CStroke attrs rgb) xlink p
class Stroke t where
ostroke :: Num u => t -> PrimPath u -> Primitive u
cstroke :: Num u => t -> PrimPath u -> Primitive u
instance Stroke () where
ostroke () = ostrokePath black [] NoLink
cstroke () = cstrokePath black [] NoLink
instance Stroke RGBi where
ostroke rgb = ostrokePath rgb [] NoLink
cstroke rgb = cstrokePath rgb [] NoLink
instance Stroke StrokeAttr where
ostroke x = ostrokePath black [x] NoLink
cstroke x = cstrokePath black [x] NoLink
instance Stroke [StrokeAttr] where
ostroke xs = ostrokePath black xs NoLink
cstroke xs = cstrokePath black xs NoLink
instance Stroke XLink where
ostroke xlink = ostrokePath black [] xlink
cstroke xlink = cstrokePath black [] xlink
instance Stroke (RGBi,StrokeAttr) where
ostroke (rgb,x) = ostrokePath rgb [x] NoLink
cstroke (rgb,x) = cstrokePath rgb [x] NoLink
instance Stroke (RGBi,[StrokeAttr]) where
ostroke (rgb,xs) = ostrokePath rgb xs NoLink
cstroke (rgb,xs) = cstrokePath rgb xs NoLink
instance Stroke (RGBi,XLink) where
ostroke (rgb,xlink) = ostrokePath rgb [] xlink
cstroke (rgb,xlink) = cstrokePath rgb [] xlink
instance Stroke (StrokeAttr,XLink) where
ostroke (x,xlink) = ostrokePath black [x] xlink
cstroke (x,xlink) = cstrokePath black [x] xlink
instance Stroke ([StrokeAttr],XLink) where
ostroke (xs,xlink) = ostrokePath black xs xlink
cstroke (xs,xlink) = cstrokePath black xs xlink
instance Stroke (RGBi,StrokeAttr,XLink) where
ostroke (rgb,x,xlink) = ostrokePath rgb [x] xlink
cstroke (rgb,x,xlink) = cstrokePath rgb [x] xlink
instance Stroke (RGBi,[StrokeAttr],XLink) where
ostroke (rgb,xs,xlink) = ostrokePath rgb xs xlink
cstroke (rgb,xs,xlink) = cstrokePath rgb xs xlink
zostroke :: Num u => PrimPath u -> Primitive u
zostroke = ostrokePath black [] NoLink
zcstroke :: Num u => PrimPath u -> Primitive u
zcstroke = cstrokePath black [] NoLink
fillPath :: Num u => RGBi -> XLink -> PrimPath u -> Primitive u
fillPath rgb xlink p = PPath (CFill rgb) xlink p
class Fill t where
fill :: Num u => t -> PrimPath u -> Primitive u
instance Fill () where fill () = fillPath black NoLink
instance Fill RGBi where fill rgb = fillPath rgb NoLink
instance Fill XLink where fill xlink = fillPath black xlink
instance Fill (RGBi,XLink) where
fill (rgb,xlink) = fillPath rgb xlink
zfill :: Num u => PrimPath u -> Primitive u
zfill = fillPath black NoLink
clip :: (Num u, Ord u) => PrimPath u -> Picture u -> Picture u
clip cp p = Clip (pathBoundary cp, []) cp p
mkTextLabel :: Num u
=> RGBi -> FontAttr -> XLink -> String -> Point2 u -> Primitive u
mkTextLabel rgb attr xlink txt pt = PLabel (LabelProps rgb attr) xlink lbl
where
lbl = PrimLabel pt (lexLabel txt) identityCTM
wumpus_default_font :: FontAttr
wumpus_default_font = FontAttr 14 face
where
face = FontFace { font_name = "Courier"
, svg_font_family = "Courier New"
, svg_font_style = SVG_REGULAR
}
class TextLabel t where
textlabel :: Num u => t -> String -> Point2 u -> Primitive u
instance TextLabel () where
textlabel () = mkTextLabel black wumpus_default_font NoLink
instance TextLabel RGBi where
textlabel rgb = mkTextLabel rgb wumpus_default_font NoLink
instance TextLabel FontAttr where
textlabel a = mkTextLabel black a NoLink
instance TextLabel XLink where
textlabel xlink = mkTextLabel black wumpus_default_font xlink
instance TextLabel (RGBi,FontAttr) where
textlabel (rgb,a) = mkTextLabel rgb a NoLink
instance TextLabel (RGBi,XLink) where
textlabel (rgb,xlink) = mkTextLabel rgb wumpus_default_font xlink
instance TextLabel (FontAttr,XLink) where
textlabel (a,xlink) = mkTextLabel black a xlink
instance TextLabel (RGBi,FontAttr,XLink) where
textlabel (rgb,a,xlink) = mkTextLabel rgb a xlink
ztextlabel :: Num u => String -> Point2 u -> Primitive u
ztextlabel = mkTextLabel black wumpus_default_font NoLink
mkEllipse :: Num u
=> EllipseProps -> XLink -> u -> u -> Point2 u -> Primitive u
mkEllipse props xlink hw hh pt =
PEllipse props xlink (PrimEllipse pt hw hh identityCTM)
ellipseDefault :: EllipseProps
ellipseDefault = EFill black
class Ellipse t where
ellipse :: Fractional u => t -> u -> u -> Point2 u -> Primitive u
instance Ellipse () where ellipse () = zellipse
instance Ellipse RGBi where
ellipse rgb = mkEllipse (EFill rgb) NoLink
instance Ellipse StrokeAttr where
ellipse x = mkEllipse (EStroke [x] black) NoLink
instance Ellipse [StrokeAttr] where
ellipse xs = mkEllipse (EStroke xs black) NoLink
instance Ellipse XLink where
ellipse xlink = mkEllipse (EFill black) xlink
instance Ellipse (RGBi,StrokeAttr) where
ellipse (rgb,x) = mkEllipse (EStroke [x] rgb) NoLink
instance Ellipse (RGBi,[StrokeAttr]) where
ellipse (rgb,xs) = mkEllipse (EStroke xs rgb) NoLink
instance Ellipse (RGBi,XLink) where
ellipse (rgb,xlink) = mkEllipse (EFill rgb) xlink
instance Ellipse (StrokeAttr,XLink) where
ellipse (x,xlink) = mkEllipse (EStroke [x] black) xlink
instance Ellipse ([StrokeAttr],XLink) where
ellipse (xs,xlink) = mkEllipse (EStroke xs black) xlink
instance Ellipse (RGBi,[StrokeAttr],XLink) where
ellipse (rgb,xs,xlink) = mkEllipse (EStroke xs rgb) xlink
zellipse :: Num u => u -> u -> Point2 u -> Primitive u
zellipse hw hh pt = mkEllipse ellipseDefault NoLink hw hh pt
extendBoundary :: (Num u, Ord u) => u -> u -> Picture u -> Picture u
extendBoundary x y = mapLocale (\(bb,xs) -> (extBB (posve x) (posve y) bb, xs))
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 (bb,[]) (cons a $ one b)
where
bb = boundary a `append` boundary b
picMoveBy :: (Num u, Ord u) => Picture u -> Vec2 u -> Picture u
p `picMoveBy` (V2 dx dy) = translate dx dy p
picBeside :: (Num u, Ord u) => Picture u -> Picture u -> Picture u
a `picBeside` b = a `picOver` (b `picMoveBy` v)
where
(P2 x1 _) = ur_corner $ boundary a
(P2 x2 _) = ll_corner $ boundary b
v = hvec $ x1 x2
printPicture :: (Num u, PSUnit u) => Picture u -> IO ()
printPicture pic = putStrLn (show $ format pic) >> putStrLn []
illustrateBounds :: (Real u, Floating u, FromPtSize u)
=> RGBi -> Picture u -> Picture u
illustrateBounds rgb p = p `picOver` (frame $ boundsPrims rgb p)
illustrateBoundsPrim :: (Real u, Floating u, FromPtSize u)
=> RGBi -> Primitive u -> Picture u
illustrateBoundsPrim rgb p = frame (p : boundsPrims rgb p)
boundsPrims :: (Num u, Ord u, Boundary t, u ~ DUnit t)
=> RGBi -> t -> [Primitive u]
boundsPrims rgb a = [ bbox_rect, bl_to_tr, br_to_tl ]
where
(bl,br,tr,tl) = boundaryCorners $ boundary a
bbox_rect = cstroke (rgb, line_attr) $ vertexPath [bl,br,tr,tl]
bl_to_tr = ostroke (rgb, line_attr) $ vertexPath [bl,tr]
br_to_tl = ostroke (rgb, line_attr) $ vertexPath [br,tl]
line_attr = [LineCap $ CapRound, DashPattern $ Dash 0 [(1,2)]]
illustrateControlPoints :: (Real u, Floating u, FromPtSize u)
=> RGBi -> Primitive u -> Picture u
illustrateControlPoints rgb prim = step prim
where
step (PEllipse _ _ e) = frame (prim : ellipseCtrlLines rgb e)
step (PPath _ _ p) = frame (prim : pathCtrlLines rgb p)
step _ = frame [prim]
pathCtrlLines :: (Num u, Ord u) => RGBi -> PrimPath u -> [Primitive u]
pathCtrlLines rgb (PrimPath 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 (PrimPath s [lineTo e])
ellipseCtrlLines :: (Real u, Floating u)
=> RGBi -> 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 (PrimPath s [lineTo e])
ellipseControlPoints :: (Floating u, Real u)
=> PrimEllipse u -> [Point2 u]
ellipseControlPoints (PrimEllipse (P2 x y) hw hh ctm) =
map (disp . (new_mtrx *#)) circ
where
disp = (.+^ V2 x y)
(radius,(dx,dy)) = circleScalingProps hw hh
new_mtrx = matrixRepCTM $ scaleCTM dx dy ctm
circ = bezierCircle 1 radius (P2 0 0)
circleScalingProps :: (Fractional u, Ord u) => u -> u -> (u,(u,u))
circleScalingProps hw hh = (radius, (dx,dy))
where
radius = max hw hh
(dx,dy) = if radius == hw then (1, rescale (0,hw) (0,1) hh)
else (rescale (0,hh) (0,1) hw, 1)