module Wumpus.Basic.Paths.RoundCorners
(
cornerCurve
, illustratePath
, roundEvery
) where
import Wumpus.Basic.Colour.SVGColours
import Wumpus.Basic.Graphic
import Wumpus.Basic.Paths.Base hiding ( length )
import Wumpus.Basic.Utils.Intersection
import Wumpus.Core
import Data.AffineSpace
cornerCurve :: (Real u, Floating u)
=> Point2 u -> Point2 u -> Point2 u -> Path u
cornerCurve p1 p2 p3 = curve p1 cp1 cp2 p3
where
len1 = 0.6 * (vlength $ pvec p1 p2)
len2 = 0.6 * (vlength $ pvec p3 p2)
cp1 = p1 .+^ (avec (langle p1 p2) len1)
cp2 = p3 .+^ (avec (langle p3 p2) len2)
roundEvery :: (Real u, Floating u)
=> u -> [Point2 u] -> Path u
roundEvery u (start:b:c:xs) = step (twoParts u start b c) (b:c:xs)
where
step acc (m:n:o:ps) = step (acc `append` twoParts u m n o) (n:o:ps)
step acc [n,o] = acc `append` twoParts u n o start
`append` twoParts u o start b
step acc _ = acc
roundEvery _ _ = error "roundEvery - input list too short."
twoParts :: (Real u, Floating u)
=> u -> Point2 u -> Point2 u -> Point2 u -> Path u
twoParts u a b c = line p1 p2 `append` cornerCurve p2 b p3
where
p1 = a .+^ (avec (direction $ pvec a b) u)
p2 = b .+^ (avec (direction $ pvec b a) u)
p3 = b .+^ (avec (direction $ pvec b c) u)
illustratePath :: Fractional u => Path u -> Graphic u
illustratePath = localize (strokeColour black) . step1 . pathViewL
where
step1 (PathOneL e) = drawPath1 e
step1 (e :<< se) = drawPathBoth e `oplus` rest (pathViewL se)
rest (PathOneL e) = drawPath1 e
rest (e :<< se) = drawPath1 e `oplus` rest (pathViewL se)
drawPathBoth :: Fractional u => PathSegment u -> Graphic u
drawPathBoth pa@(Line1 p1 _) = drawPath1 pa `oplus` pathPoint p1
drawPathBoth pa@(Curve1 p1 _ _ _) = drawPath1 pa `oplus` pathPoint p1
drawPath1 :: Fractional u => PathSegment u -> Graphic u
drawPath1 (Line1 p1 p2) =
straightLineBetween p1 p2 `oplus` pathPoint p2
drawPath1 (Curve1 p1 p2 p3 p4) =
oconcat (bezierCtrl p1 p2) [ bezierCtrl p4 p3, curveBetween p1 p2 p3 p4
, pathPoint p4 ]
bezierCtrl :: Fractional u => Point2 u -> Point2 u -> Graphic u
bezierCtrl p1 p2 =
localize (strokeColour light_steel_blue . fillColour red) $
straightLineBetween p1 p2 `oplus` filledDisk 1 p2
pathPoint :: Num u => Point2 u -> Graphic u
pathPoint = localize bothStrokeColour . filledDisk 1