module Wumpus.Basic.Geometry.Paths
(
PathAlg
, runPathAlgPoint
, runPathAlgVec
, drawVertexPathAlg
, pathStartIsStart
, pathStartIsLocus
, pathIterateLocus
, rectanglePathAlg
, blRectanglePathAlg
, diamondPathAlg
, isoscelesTriPathAlg
, polygonPathAlg
, arcPathAlg
, circlePathAlg
, parallelogramPathAlg
, isoscelesTrapeziumPathAlg
)
where
import Wumpus.Basic.Geometry.Base
import Wumpus.Basic.Geometry.Vertices
import Wumpus.Basic.Kernel
import Wumpus.Core
import Data.AffineSpace
import Data.VectorSpace
import Data.List ( unfoldr )
data PathAlgScheme = START_IS_START | START_IS_LOCUS
deriving (Enum,Eq,Ord,Show)
data PathAlg u = PathAlg { path_alg_scheme :: PathAlgScheme
, path_alg_steps :: [Vec2 u]
}
type instance DUnit (PathAlg u) = u
runPathAlgPoint :: Num u => Point2 u -> PathAlg u -> [Point2 u]
runPathAlgPoint _ (PathAlg _ []) = []
runPathAlgPoint p0 (PathAlg scm (v0:xs))
| scm == START_IS_START = p0 : step (p0 .+^ v0) xs
| otherwise = step (p0 .+^ v0) xs
where
step pt [] = [pt]
step pt (v:vs) = pt : step (pt .+^ v) vs
runPathAlgVec :: PathAlg u -> (Maybe (Vec2 u), [Vec2 u])
runPathAlgVec (PathAlg START_IS_LOCUS (v:vs)) = (Just v, vs)
runPathAlgVec (PathAlg _ vs) = (Nothing, vs)
drawVertexPathAlg :: InterpretUnit u
=> DrawStyle -> PathAlg u -> LocGraphic u
drawVertexPathAlg style alg = promoteLoc $ \pt ->
zapQuery (vertexPP $ runPathAlgPoint pt alg) >>= dcClosedPath style
pathStartIsStart :: [Vec2 u] -> PathAlg u
pathStartIsStart vs = PathAlg { path_alg_scheme = START_IS_START
, path_alg_steps = vs }
pathStartIsLocus :: [Vec2 u] -> PathAlg u
pathStartIsLocus vs = PathAlg { path_alg_scheme = START_IS_LOCUS
, path_alg_steps = vs }
pathIterateLocus :: Num u => [Vec2 u] -> PathAlg u
pathIterateLocus [] = pathStartIsLocus []
pathIterateLocus (v0:xs) = pathStartIsLocus $ v0 : step v0 xs
where
step v1 [] = [v0 ^-^ v1]
step v1 (v2:vs) = (v2 ^-^ v1) : step v2 vs
rectanglePathAlg :: Fractional u => u -> u -> PathAlg u
rectanglePathAlg w h =
pathStartIsLocus [ to_bl, to_br, to_tr, to_tl ]
where
to_bl = vec (negate $ 0.5*w) (negate $ 0.5*h)
to_br = hvec w
to_tr = vvec h
to_tl = hvec (w)
blRectanglePathAlg :: Num u => u -> u -> PathAlg u
blRectanglePathAlg w h = pathStartIsStart [ vbr, vtr, vtl, vbl ]
where
vbr = hvec w
vtr = vvec h
vtl = hvec (w)
vbl = vvec (h)
diamondPathAlg :: Num u => u -> u -> PathAlg u
diamondPathAlg hw hh = pathIterateLocus [ vs,ve,vn,vw ]
where
vs = vvec (hh)
ve = hvec hw
vn = vvec hh
vw = hvec (hw)
isoscelesTriPathAlg :: Floating u => u -> u -> PathAlg u
isoscelesTriPathAlg bw h =
pathIterateLocus [ to_bl, to_br, to_apex ]
where
(to_bl, to_br, to_apex) = isoscelesTriangleVertices bw h
polygonPathAlg :: Floating u => Int -> u -> PathAlg u
polygonPathAlg n radius = pathIterateLocus $ unfoldr phi (0,top)
where
top = 0.5*pi
theta = (2*pi) / fromIntegral n
phi (i,ang) | i < n = Just (avec ang radius, (i+1,ang+theta))
| otherwise = Nothing
arcPathAlg :: Floating u => u -> Radian -> Radian -> PathAlg u
arcPathAlg r ang1 ang2 = pathStartIsLocus $ step1 $ arcdiv ang1 ang2
where
step1 [] = []
step1 ((a,b):xs) = let (v0,v1,v2,v3) = minorArcQuadVec r a b
in v0 : v1: v2: v3 : step xs
step [] = []
step ((a,b):xs) = let (_,v1,v2,v3) = minorArcQuadVec r a b
in v1: v2: v3 : step xs
minorArcQuadVec :: Floating u
=> u -> Radian -> Radian -> (Vec2 u, Vec2 u, Vec2 u, Vec2 u)
minorArcQuadVec r ang1 ang2 = (v0, v1, v2, v3)
where
(p1,p2,p3,p4) = bezierArc r ang1 ang2 zeroPt
v0 = pvec zeroPt p1
v1 = pvec p1 p2
v2 = pvec p2 p3
v3 = pvec p3 p4
circlePathAlg :: (Fractional u, Floating u)
=> u -> PathAlg u
circlePathAlg r = pathStartIsLocus vs
where
vs = hvec r : diff (flip pvec) (bezierCircle r zeroPt)
diff :: (a -> a -> b) -> [a] -> [b]
diff _ [] = []
diff op (x:xs) = step x xs
where
step _ [] = []
step a (b:bs) = b `op` a : step b bs
arcdiv :: Radian -> Radian -> [(Radian,Radian)]
arcdiv ang1 ang2 | ang1 > ang2 = step ang1 (ang2 + 2 * pi)
| otherwise = step ang1 ang2
where
step a1 a2 | a1 == a2 = []
step a1 a2 | a2 a1 > half_pi = norm (a1,a1+half_pi) : step (a1+half_pi) a2
| otherwise = [(a1,a2)]
norm (a,b) = (circularModulo a, circularModulo b)
parallelogramPathAlg :: Floating u => u -> u -> Radian -> PathAlg u
parallelogramPathAlg w h bl_ang =
pathIterateLocus [ bl, br, tr, tl ]
where
(bl, br, tr, tl) = parallelogramVertices w h bl_ang
isoscelesTrapeziumPathAlg :: Floating u => u -> u -> u -> PathAlg u
isoscelesTrapeziumPathAlg bw tw h =
pathIterateLocus [ bl, br, tr, tl ]
where
(bl, br, tr, tl) = isoscelesTrapeziumVertices bw tw h