wumpus-basic 0.22.0 → 0.24.0

raw patch · 25 files changed

+829/−2284 lines, 25 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• src/Wumpus/Basic/Geometry.hs +0/−33
• src/Wumpus/Basic/Geometry/Base.hs +0/−494
• src/Wumpus/Basic/Geometry/Illustrate.hs +0/−69
• src/Wumpus/Basic/Geometry/Intersection.hs +0/−201
• src/Wumpus/Basic/Geometry/Quadrant.hs +0/−601
• src/Wumpus/Basic/Geometry/Vertices.hs +0/−142
• src/Wumpus/Basic/Kernel.hs +15/−0
• src/Wumpus/Basic/Kernel/Base/BaseDefs.hs +153/−12
• src/Wumpus/Basic/Kernel/Base/Units.hs +1/−1
• src/Wumpus/Basic/Kernel/Drawing/Basis.hs +4/−4
• src/Wumpus/Basic/Kernel/Drawing/Chain.hs +177/−89
• src/Wumpus/Basic/Kernel/Drawing/LocDrawing.hs +2/−3
• src/Wumpus/Basic/Kernel/Drawing/LocTrace.hs +2/−3
• src/Wumpus/Basic/Kernel/Drawing/PosObject.hs +17/−10
• src/Wumpus/Basic/Kernel/Drawing/TraceDrawing.hs +2/−3
• src/Wumpus/Basic/Kernel/Objects/Basis.hs +24/−14
• src/Wumpus/Basic/Kernel/Objects/Bounded.hs +4/−4
• src/Wumpus/Basic/Kernel/Objects/Displacement.hs +29/−66
• src/Wumpus/Basic/Kernel/Objects/DrawingPrimitives.hs +16/−0
• src/Wumpus/Basic/Kernel/Objects/Image.hs +6/−6
• src/Wumpus/Basic/Kernel/Objects/Trail.hs +343/−86
• src/Wumpus/Basic/System/FontLoader.hs +4/−2
• src/Wumpus/Basic/Utils/FormatCombinators.hs +0/−430
• src/Wumpus/Basic/VersionNumber.hs +3/−3
• wumpus-basic.cabal +27/−8

@@ -1,33 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Kernel--- Copyright   :  (c) Stephen Tetley 2011--- License     :  BSD3------ Maintainer  :  stephen.tetley@gmail.com--- Stability   :  highly unstable--- Portability :  GHC ------ Import shim for @Wumpus.Basic.Geometry@ modules.-----------------------------------------------------------------------------------------module Wumpus.Basic.Geometry-  (-    module Wumpus.Basic.Geometry.Base-  , module Wumpus.Basic.Geometry.Illustrate-  , module Wumpus.Basic.Geometry.Intersection-  , module Wumpus.Basic.Geometry.Quadrant-  , module Wumpus.Basic.Geometry.Vertices--  ) where---import Wumpus.Basic.Geometry.Base-import Wumpus.Basic.Geometry.Illustrate-import Wumpus.Basic.Geometry.Intersection-import Wumpus.Basic.Geometry.Quadrant-import Wumpus.Basic.Geometry.Vertices

@@ -1,494 +0,0 @@-{-# LANGUAGE TypeFamilies               #-}-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Geometry.Base--- Copyright   :  (c) Stephen Tetley 2011--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Base geometric types and operations.--------------------------------------------------------------------------------------module Wumpus.Basic.Geometry.Base-  ( ---  -- * 2x2 Matrix-    Matrix2'2(..)-  , DMatrix2'2-  , identity2'2-  , det2'2-  , transpose2'2--  -- * Line -  , Line(..)-  , inclinedLine-  -  -- * Line in equational form -  , LineEquation(..)-  , DLineEquation-  , lineEquation-  , pointViaX-  , pointViaY-  , pointLineDistance--  -- * Line segment-  , LineSegment(..)-  , DLineSegment-  -  , rectangleLineSegments-  , polygonLineSegments--  -- * Cubic Bezier curves-  -  , BezierCurve(..)-  , DBezierCurve--  , bezierLength-  , subdivide-  , subdividet-  -  , bezierArcPoints-  , bezierMinorArc--  -- * Functions-  , affineComb-  , midpoint-  , lineAngle---  ) -  where--import Wumpus.Basic.Kernel--import Wumpus.Core                              -- package: wumpus-core--import Data.AffineSpace                         -- package: vector-space-import Data.VectorSpace------------------------------------------------------------------------------------------- 2x2 matrix----- | 2x2 matrix, considered to be in row-major form.--- --- > (M2'2 a b--- >       c d)------ --data Matrix2'2 u = M2'2 !u !u   !u !u-  deriving (Eq)--type instance DUnit (Matrix2'2 u) = u--type DMatrix2'2 = Matrix2'2 Double----instance Functor Matrix2'2 where-  fmap f (M2'2 a b  c d) = M2'2 (f a) (f b)  (f c) (f d)--instance Show u => Show (Matrix2'2 u) where-  show (M2'2 a b c d) = "(M2'2 " ++ body ++ ")" -    where-      body = show [[a,b],[c,d]]--lift2Matrix2'2 :: (u -> u -> u) -> Matrix2'2 u -> Matrix2'2 u -> Matrix2'2 u-lift2Matrix2'2 op (M2'2 a b c d) (M2'2 m n o p) = -      M2'2 (a `op` m) (b `op` n) -           (c `op` o) (d `op` p)--instance Num u => Num (Matrix2'2 u) where-  (+) = lift2Matrix2'2 (+) -  (-) = lift2Matrix2'2 (-)--  (*) (M2'2 a b c d) (M2'2 m n o p) = -      M2'2 (a*m + b*o) (a*n + b*p)  -           (c*m + d*o) (c*n + d*p) -  -  abs    = fmap abs -  negate = fmap negate-  signum = fmap signum-  fromInteger a = M2'2 a' a'  a' a' where a' = fromInteger a----- | Construct the identity 2x2 matrix:------ > (M2'2 1 0 --- >       0 1 )----identity2'2 :: Num u => Matrix2'2 u-identity2'2 = M2'2  1 0  -                    0 1----- | Determinant of a 2x2 matrix.----det2'2 :: Num u => Matrix2'2 u -> u-det2'2 (M2'2 a b c d) = a*d - b*c----- | Transpose a 2x2 matrix.----transpose2'2 :: Matrix2'2 u -> Matrix2'2 u-transpose2'2 (M2'2 a b -                   c d) = M2'2 a c-                               b d--------------------------------------------------------------------------------------- | Infinite line represented by two points.----data Line u = Line (Point2 u) (Point2 u)-  deriving (Eq,Show)--type instance DUnit (Line u) = u------ | 'inclinedLine' : @ point * ang -> Line @------ Make an infinite line passing through the supplied point --- inclined by @ang@.----inclinedLine :: Floating u => Point2 u -> Radian -> Line u-inclinedLine radial_ogin ang = Line radial_ogin (radial_ogin .+^ avec ang 100)------------------------------------------------------------------------------------------ | Line in equational form, i.e. @Ax + By + C = 0@.----data LineEquation u = LineEquation -      { line_eqn_A :: !u-      , line_eqn_B :: !u-      , line_eqn_C :: !u -      }-  deriving (Eq,Show)--type instance DUnit (LineEquation u) = u---type DLineEquation = LineEquation Double----- | 'lineEquation' : @ point1 * point2 -> LineEquation @--- --- Construct a line in equational form bisecting the supplied --- points.----lineEquation :: Num u => Point2 u -> Point2 u -> LineEquation u-lineEquation (P2 x1 y1) (P2 x2 y2) = LineEquation a b c -  where-    a = y1 - y2-    b = x2 - x1-    c = (x1*y2) - (x2*y1)---- | 'pointViaX' : @ x * line_equation -> Point @------ Calculate the point on the line for the supplied @x@ value.--- -pointViaX :: Fractional u => u -> LineEquation u -> Point2 u-pointViaX x (LineEquation a b c) = P2 x y-  where-    y = ((a*x) + c) / (-b)----- | 'pointViaY' : @ y * line_equation -> Point @------ Calculate the point on the line for the supplied @y@ value.--- -pointViaY :: Fractional u => u -> LineEquation u -> Point2 u-pointViaY y (LineEquation a b c) = P2 x y-  where-    x = ((b*y) + c) / (-a)----- | 'pointLineDistance' : @ point -> line -> Distance @------ Find the distance from a point to a line in equational form--- using this formula:--- --- > P(u,v) --- > L: Ax + By + C = 0--- >--- > (A*u) + (B*v) + C --- > -------------------- > sqrt $ (A^2) +(B^2)------ A positive distance indicates the point is above the line, --- negative indicates below.----pointLineDistance :: Floating u => Point2 u -> LineEquation u -> u-pointLineDistance (P2 u v) (LineEquation a b c) = -    ((a*u) + (b*v) + c) / base-  where-    base = sqrt $ (a^two) + (b^two)-    two  :: Integer-    two  = 2------------------------------------------------------------------------------------data LineSegment u = LineSegment (Point2 u) (Point2 u)-  deriving (Eq,Ord,Show)--type instance DUnit (LineSegment u) = u---type DLineSegment = LineSegment Double------- | 'rectangleLineSegments' : @ half_width * half_height -> [LineSegment] @------ Compute the line segments of a rectangle.----rectangleLineSegments :: Num u => u -> u -> Point2 u -> [LineSegment u]-rectangleLineSegments hw hh ctr = -    [ LineSegment br tr, LineSegment tr tl, LineSegment tl bl-    , LineSegment bl br -    ]-  where-    br = ctr .+^ vec hw    (-hh)-    tr = ctr .+^ vec hw    hh-    tl = ctr .+^ vec (-hw) hh-    bl = ctr .+^ vec (-hw) (-hh)----- | 'polygonLineSegments' : @ [point] -> [LineSegment] @------ Build the line segments of a polygon fome a list of --- its vertices.----polygonLineSegments :: [Point2 u] -> [LineSegment u]-polygonLineSegments []     = []-polygonLineSegments (x:xs) = step x xs -  where-    step a []        = [LineSegment a x]-    step a (b:bs)    = (LineSegment a b) : step b bs---------------------------------------------------------------------------------------- Bezier curves----- | A Strict cubic Bezier curve.----data BezierCurve u = BezierCurve !(Point2 u) !(Point2 u) !(Point2 u) !(Point2 u)-  deriving (Eq,Ord,Show)--type instance DUnit (BezierCurve u) = u---type DBezierCurve = BezierCurve Double------- | 'bezierLength' : @ start_point * control_1 * control_2 * ---        end_point -> Length @ ------ Find the length of a Bezier curve. The result is an --- approximation, with the /tolerance/ is 0.1 of a point. This--- seems good enough for drawing (potentially the tolerance could --- be larger still). ------ The result is found through repeated subdivision so the --- calculation is potentially costly.----bezierLength :: (Floating u, Ord u, Tolerance u)-             => BezierCurve u -> u-bezierLength = gravesenLength length_tolerance ------ | Jens Gravesen\'s bezier arc-length approximation. ------ Note this implementation is parametrized on error tolerance.----gravesenLength :: (Floating u, Ord u) => u -> BezierCurve u -> u-gravesenLength err_tol crv = step crv -  where-    step c = let l1 = ctrlPolyLength c-                 l0 = cordLength c-             in if   l1-l0 > err_tol-                then let (a,b) = subdivide c in step a + step b-                else 0.5*l0 + 0.5*l1---- | Length of the tree lines spanning the control points.----ctrlPolyLength :: Floating u => BezierCurve u -> u-ctrlPolyLength (BezierCurve p0 p1 p2 p3) = len p0 p1 + len p1 p2 + len p2 p3-  where-    len pa pb = vlength $ pvec pa pb----- | Length of the cord - start point to end point.----cordLength :: Floating u => BezierCurve u -> u-cordLength (BezierCurve p0 _ _ p3) = vlength $ pvec p0 p3------- | Curve subdivision via de Casteljau\'s algorithm.----subdivide :: Fractional u -          => BezierCurve u -> (BezierCurve u, BezierCurve u)-subdivide (BezierCurve p0 p1 p2 p3) =-    (BezierCurve p0 p01 p012 p0123, BezierCurve p0123 p123 p23 p3)-  where-    p01   = midpoint p0    p1-    p12   = midpoint p1    p2-    p23   = midpoint p2    p3-    p012  = midpoint p01   p12-    p123  = midpoint p12   p23-    p0123 = midpoint p012  p123---- | subdivide with an affine weight along the line...----subdividet :: Real u-           => u -> BezierCurve u -> (BezierCurve u, BezierCurve u)-subdividet t (BezierCurve p0 p1 p2 p3) = -    (BezierCurve p0 p01 p012 p0123, BezierCurve p0123 p123 p23 p3)-  where-    p01   = affineComb t p0    p1-    p12   = affineComb t p1    p2-    p23   = affineComb t p2    p3-    p012  = affineComb t p01   p12-    p123  = affineComb t p12   p23-    p0123 = affineComb t p012  p123-----kappa :: Floating u => u-kappa = 4 * ((sqrt 2 - 1) / 3)------ | 'bezierArcPoints' : @ apex_angle * radius * inclination * center -> [Point] @------ > ang should be in the range 0 < ang < 360deg.------ > if   0 < ang <=  90 returns 4 points--- > if  90 < ang <= 180 returns 7 points--- > if 180 < ang <= 270 returns 10 points--- > if 270 < ang <  360 returns 13 points----bezierArcPoints ::  Floating u -                => Radian -> u -> Radian -> Point2 u -> [Point2 u]-bezierArcPoints ang radius theta pt = go (circularModulo ang)-  where-    go a | a <= half_pi = wedge1 a-         | a <= pi      = wedge2 (a/2)-         | a <= 1.5*pi  = wedge3 (a/3)-         | otherwise    = wedge4 (a/4)-    -    wedge1 a = -      let (BezierCurve p0 p1 p2 p3) = bezierMinorArc a radius theta pt-      in [p0,p1,p2,p3]--    wedge2 a = -      let (BezierCurve  p0 p1 p2 p3) = bezierMinorArc a radius theta pt-          (BezierCurve _   p4 p5 p6) = bezierMinorArc a radius (theta+a) pt-      in [ p0,p1,p2,p3, p4,p5,p6 ] --    wedge3 a = -      let (BezierCurve p0 p1 p2 p3) = bezierMinorArc a radius theta pt-          (BezierCurve _  p4 p5 p6) = bezierMinorArc a radius (theta+a) pt-          (BezierCurve _  p7 p8 p9) = bezierMinorArc a radius (theta+a+a) pt-      in [ p0,p1,p2,p3, p4,p5,p6, p7, p8, p9 ] -  -    wedge4 a = -      let (BezierCurve p0 p1 p2 p3)    = bezierMinorArc a radius theta pt-          (BezierCurve _  p4 p5 p6)    = bezierMinorArc a radius (theta+a) pt-          (BezierCurve _  p7 p8 p9)    = bezierMinorArc a radius (theta+a+a) pt-          (BezierCurve _  p10 p11 p12) = bezierMinorArc a radius (theta+a+a+a) pt-      in [ p0,p1,p2,p3, p4,p5,p6, p7,p8,p9, p10,p11, p12 ] ----- | 'bezierMinorArc' : @ apex_angle * radius * rotation * center -> BezierCurve @------ > ang should be in the range 0 < ang <= 90deg.----bezierMinorArc :: Floating u -               => Radian -> u -> Radian -> Point2 u -> BezierCurve u-bezierMinorArc ang radius theta pt = BezierCurve p0 c1 c2 p3-  where-    kfactor = fromRadian $ ang / (0.5*pi)-    rl      = kfactor * radius * kappa-    totang  = circularModulo $ ang + theta--    p0      = dispParallel radius theta pt-    c1      = dispPerpendicular rl theta p0-    c2      = dispPerpendicular (-rl) totang p3-    p3      = dispParallel radius totang pt------------------------------------------------------------------------------------------- | Affine combination...----affineComb :: Real u => u -> Point2 u -> Point2 u -> Point2 u-affineComb t p1 p2 = p1 .+^ t *^ (p2 .-. p1)----- | 'midpoint' : @ start_point * end_point -> Midpoint @--- --- Mid-point on the line formed between the two supplied points.----midpoint :: Fractional u => Point2 u -> Point2 u -> Point2 u-midpoint p0 p1 = p0 .+^ v1 ^/ 2 where v1 = p1 .-. p0------ | 'lineAngle' : @ start_point * end_point -> Angle @------ Calculate the counter-clockwise angle between the line formed --- by the two points and the horizontal plane.----lineAngle :: (Floating u, Real u) => Point2 u -> Point2 u -> Radian-lineAngle (P2 x1 y1) (P2 x2 y2) = step (x2 - x1) (y2 - y1)-  where-    -- north-east quadrant -    step x y | pve x && pve y = toRadian $ atan (y/x)          -    -    -- north-west quadrant-    step x y | pve y          = pi     - (toRadian $ atan (y / abs x))--    -- south-east quadrant-    step x y | pve x          = (2*pi) - (toRadian $ atan (abs y / x)) --    -- otherwise... south-west quadrant-    step x y                  = pi     + (toRadian $ atan (y/x))--    pve a                     = signum a >= 0---- Ideally this would be in Geometry.Quadrant.--- And surely there is a simpler formulation...--

@@ -1,69 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Geometry.Illustrate--- Copyright   :  (c) Stephen Tetley 2011--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Draw the geometrical objects.--------------------------------------------------------------------------------------module Wumpus.Basic.Geometry.Illustrate-  ( --    illustrateLine-  , illustrateLineSegment--  ) -  where--import Wumpus.Basic.Geometry.Base--import Wumpus.Basic.Kernel--import Wumpus.Core                              -- package: wumpus-core-import Wumpus.Core.Colour --import Data.Monoid---emline :: InterpretUnit u => Vec2 Em -> LocGraphic u-emline = uconvF . locStraightLine--enDot :: InterpretUnit u => LocGraphic u-enDot = uconvF body-  where-    body :: LocGraphic En-    body = localize (fill_colour white) $ dcDisk DRAW_FILL_STROKE 0.5--illustrateLine :: (Real u, Floating u, InterpretUnit u) -               => Line u -> Graphic u-illustrateLine (Line p1 p2) = -    mconcat [ prefix, join_line, suffix, d1, d2 ]-  where-    join_line = straightLine p1 p2-    v1        = pvec p1 p2-    dir       = vdirection v1-    -    prefix    = localize dotted_line $ emline (avec dir (-6)) `at` p1-    suffix    = localize dotted_line $ emline (avec dir 6)    `at` p2-    d1        = enDot `at` p1-    d2        = enDot `at` p2--       ----illustrateLineSegment :: InterpretUnit u => LineSegment u -> Graphic u-illustrateLineSegment (LineSegment p1 p2) = -    join_line `mappend` d1 `mappend` d2-  where-    join_line = straightLine p1 p2-    d1        = enDot `at` p1-    d2        = enDot `at` p2

@@ -1,201 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Geometry.Intersection--- Copyright   :  (c) Stephen Tetley 2011--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Intersection of line to line and line to plane.--- --- \*\* - WARNING \*\* - this uses quite a high tolerance for --- floating point equality. --------------------------------------------------------------------------------------module Wumpus.Basic.Geometry.Intersection-  ( --    interLineLine-  , interLinesegLineseg-  , interLinesegLine-  , interCurveLine--  , findIntersect---  ) -  where--import Wumpus.Basic.Geometry.Base--import Wumpus.Core                              -- package: wumpus-core------- Potentially lines hould be a new datatype.----- | 'interLineLine' : @ line1 * line2 -> Maybe Point @--- --- Find the intersection of two lines, if there is one. ------ Lines are infinite they are represented by points on them, --- they are not line segments.------ An answer of @Nothing@ may indicate either the lines coincide--- or the are parallel.----interLineLine :: Fractional u -              => Line u -> Line u -> Maybe (Point2 u)-interLineLine (Line p1 p2) (Line q1 q2) = -    if det_co == 0 then Nothing -                   else Just $ P2 (det_xm / det_co) (det_ym / det_co)-  where-    -- Ax + By + C = 0-    LineEquation a1 b1 c1 = lineEquation p1 p2-    LineEquation a2 b2 c2 = lineEquation q1 q2--    coeffM                = M2'2 a1 b1  a2 b2-    det_co                = det2'2 coeffM--    xM                    = M2'2  (negate c1) b1  (negate c2) b2-    det_xm                = det2'2 xM--    yM                    = M2'2  a1 (negate c1) a2 (negate c2)-    det_ym                = det2'2 yM------ | 'interLinesegLineseg' : @ line_segment1 * line_segment2 -> Maybe Point @--- --- Find the intersection of two line segments, if there is one. ------ An answer of @Nothing@ indicates that the line segments --- coincide, or that there is no intersection.----interLinesegLineseg :: (Fractional u, Ord u, Tolerance u)-                    => LineSegment u -> LineSegment u -> Maybe (Point2 u)-interLinesegLineseg a@(LineSegment p q) b@(LineSegment s t) = -    interLineLine (Line p q) (Line s t) >>= segcheck-  where-    segcheck = mbCheck (\pt -> withinPoints pt a && withinPoints pt b)- ---- | 'interLinesegLine' : @ line_segment * line -> Maybe Point @--- --- Find the intersection of a line and a line segment, if there --- is one. ------ An answer of @Nothing@ indicates that the the line and line--- segment coincide, or that there is no intersection.----interLinesegLine :: (Fractional u, Ord u, Tolerance u)-                 => LineSegment u -> Line u -> Maybe (Point2 u)-interLinesegLine a@(LineSegment p q) line = -    interLineLine (Line p q) line >>= segcheck-  where-    segcheck = mbCheck (\pt -> withinPoints pt a)---mbCheck :: (a -> Bool) -> a -> Maybe a-mbCheck test a = if test a then Just a else Nothing---- | Check the point is \"within\" the span of the line.------ Note - this function is to be used \*after\* an intersection--- has been found. Hence it is not exported.----withinPoints :: (Ord u, Fractional u, Tolerance u) -             => Point2 u -> LineSegment u -> Bool-withinPoints (P2 x y) (LineSegment (P2 x0 y0) (P2 x1 y1)) =  -    between x (ordpair x0 x1) && between y (ordpair y0 y1)-  where-    ordpair a b     = (min a b, max a b)-    between a (s,t) = (s `tLTE` a) && (a `tLTE` t)----pve :: (Fractional u, Ord u, Tolerance u) => u -> Bool-pve a = a > eq_tolerance--nve :: (Fractional u, Ord u, Tolerance u) => u -> Bool-nve a = a < (negate eq_tolerance)--------------------------------------------------------------------------------------- intersection of line and Bezier curve--interCurveLine :: (Floating u , Ord u, Tolerance u)-               => BezierCurve u -> Line u -> Maybe (Point2 u)-interCurveLine c0 (Line p q) = step c0-  where-    eqline  = lineEquation p q-    step c  = case cut c eqline of-                Left pt     -> Just pt      -- cut at start or end-                Right False -> Nothing-                Right True  -> let (a,b) = subdivide c-                               in case step a of-                                   Just pt -> Just pt-                                   Nothing -> step b- --- | Is the curve cut by the line? ------ The curve might cut at the start or end points - which is good--- as it saves performing a subdivision. But make the return type--- a bit involved.----cut :: (Floating u , Ord u, Tolerance u)-    => BezierCurve u -> LineEquation u -> Either (Point2 u) Bool-cut (BezierCurve p0 p1 p2 p3) eqline = -    if d0 `tEQ` 0 then Left p0 else-    if d3 `tEQ` 0 then Left p3 else-    let ds = [d0,d1,d2,d3] in Right $ not $ all pve ds || all nve ds-  where-    d0  = pointLineDistance p0 eqline -    d1  = pointLineDistance p1 eqline -    d2  = pointLineDistance p2 eqline -    d3  = pointLineDistance p3 eqline ----    -------------------------------------------------------------------------------------- Intersection of shape boundaries...------ | 'findIntersect' :: @ radial_origin * theta * [line_segment] -> Maybe Point @------ Find the first intersection of a line through @radial_origin@ --- at angle @theta@ and the supplied line segments, if there --- is one. ----findIntersect :: (Floating u, Real u, Ord u, Tolerance u)-              => Point2 u -> Radian -> [LineSegment u] -              -> Maybe (Point2 u)-findIntersect radial_ogin ang = step -  where-    line1       = inclinedLine radial_ogin ang-    step []     = Nothing-    step (x:xs) = case interLinesegLine x line1 of -                     Just pt | quadrantCheck ang radial_ogin pt -> Just pt-                     _       -> step xs----- | The tolerance on Radian equality should be acceptable...----quadrantCheck :: (Real u, Floating u) -              => Radian -> Point2 u -> Point2 u -> Bool-quadrantCheck theta ctr pt = theta == lineAngle ctr pt---

@@ -1,601 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Geometry.Quadrant--- Copyright   :  (c) Stephen Tetley 2011--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Quadrants and trigonometric calculations.--- --- \*\* - WARNING \*\* - in progress. --------------------------------------------------------------------------------------module Wumpus.Basic.Geometry.Quadrant-  ( -    Quadrant(..)--  , quadrant--  , RadialIntersect-  , QuadrantAlg(..)-  , runQuadrantAlg---  , hypotenuseQI-  , rectangleQI-  , hquadrilAcuteQI-  , hquadrilObtusQI--  , rectangleQuadrantAlg-  , diamondQuadrantAlg-  , isoscelesTriQuadrantAlg--  -- OLD...-  , rectRadialVector-  , diamondRadialVector-  , triangleRadialVector-  , triangleQI-  , rightTrapezoidQI-  -  , rightTrapeziumBaseWidth--  ) -  where--import Wumpus.Basic.Kernel--import Wumpus.Core                              -- package: wumpus-core--data Quadrant = QUAD_NE | QUAD_NW | QUAD_SW | QUAD_SE-  deriving (Enum,Eq,Ord,Show)---- | 'quadrant' : @ ang -> Quadrant @------ Get the quadrant of an angle.----quadrant :: Radian -> Quadrant-quadrant = fn . circularModulo-  where-    fn a | a < 0.5*pi   = QUAD_NE-         | a < pi       = QUAD_NW-         | a < 1.5*pi   = QUAD_SW-         | otherwise    = QUAD_SE----- | 'reflectionModuloQI' : @ ang -> Radian @--- --- Modulo an angle so it lies in quadrant I (north east) --- /by reflection/ - thats to say:--- --- > If the angle is in QI the result is identity.------ > If the angle is in QII it is reflected about the Y-axis.--- >--- > e.g. 170deg becomes 10deg.--- --- > If the angle is in QIII it is reflected about both axes.--- >--- > e.g. 190deg becomes 10deg.--- --- > If the angle is in QIV it is reflected about the X-axis.--- >--- > e.g. 350deg becomes 10deg.--- ----reflectionModuloQI :: Radian -> Radian-reflectionModuloQI = step . circularModulo -  where-    step ang | ang < 0.5*pi   = ang-             | ang < pi       = pi - ang-             | ang < 1.5*pi   = ang - pi-             | otherwise      = two_pi - ang---type RadialIntersect u = Radian -> Vec2 u----- | A /Quadrant algorithm/.----data QuadrantAlg u = QuadrantAlg -      { calc_quad1 :: RadialIntersect u-      , calc_quad2 :: RadialIntersect u-      , calc_quad3 :: RadialIntersect u-      , calc_quad4 :: RadialIntersect u-      }--runQuadrantAlg :: Radian -> QuadrantAlg u -> Vec2 u-runQuadrantAlg a qa = step (circularModulo a)-  where-    step ang | ang < half_pi  = calc_quad1 qa ang-             | ang < pi       = calc_quad2 qa ang-             | ang < 1.5*pi   = calc_quad3 qa ang-             | otherwise      = calc_quad4 qa ang--    ---- | Reuse a QI algorithm to work in QII /provided/ it works--- under reflection.----reflectCalcQ2ToQ1 :: Num u => RadialIntersect u -> RadialIntersect u-reflectCalcQ2ToQ1 q1Fun = negateX . q1Fun . reflectionModuloQI----- | Reuse a QI algorithm to work in QIII /provided/ it works--- under reflection.----reflectCalcQ3ToQ1 :: Num u => RadialIntersect u -> RadialIntersect u-reflectCalcQ3ToQ1 q1Fun = negateXY . q1Fun . reflectionModuloQI----- | Reuse a QI algorithm to work in QIV /provided/ it works--- under reflection.----reflectCalcQ4ToQ1 :: Num u => RadialIntersect u -> RadialIntersect u-reflectCalcQ4ToQ1 q1Fun = negateY . q1Fun . reflectionModuloQI--------- Negating vectors - aka relfecting them:---- | Negate a vector in X - aka reflect it about the Y-axis.----negateX :: Num u => Vec2 u -> Vec2 u-negateX (V2 x y) = V2 (-x) y---- | Negate a vector in Y - aka reflect it about the X-axis.----negateY :: Num u => Vec2 u -> Vec2 u-negateY (V2 x y) = V2 x (-y)---- | Negate a vector in X and Y - aka reflect it about both axes.----negateXY :: Num u => Vec2 u -> Vec2 u-negateXY (V2 x y) = V2 (-x) (-y)------ | Builder for the usual case of /Quadrant algorithm/ where--- each quadrant is calculated in QI then the answer is reflected --- to the respective quadrant.------ Calulating for QI is usually easier...----makeReflectionQuadrantAlg :: Num u -                          => RadialIntersect u -                          -> RadialIntersect u-                          -> RadialIntersect u -                          -> RadialIntersect u-                          -> QuadrantAlg u-makeReflectionQuadrantAlg f1 f2 f3 f4 = -    QuadrantAlg { calc_quad1 = f1-                , calc_quad2 = reflectCalcQ2ToQ1 f2-                , calc_quad3 = reflectCalcQ3ToQ1 f3-                , calc_quad4 = reflectCalcQ4ToQ1 f4-                }---------------------------------------------------------------------------------------- | 'triangleQI' : @ dx * dy -> RadialIntersect @------ Find where a line from (0,0) with elevation @ang@ intersects --- the hypotenuse a right triangle in QI (the legs of the triangle --- take the x and y-axes).  ------ > ang must be in the @range 0 < ang <= 90@.--- >--- > width and height must be positive.----hypotenuseQI :: (Real u, Floating u) => u -> u -> RadialIntersect u-hypotenuseQI dx dy ang = avec ang dist-  where-    base_ang = atan (dy / dx)-    apex_c   = pi - (base_ang + fromRadian ang)-    dist     = sin base_ang * (dx / sin apex_c)------ | 'rectangleQI' : @ width * height * ang -> Vec @------ Find where a line from (0,0) in direction @ang@ intersects the --- top or right side of a rectangle in QI (left side is the --- y-axis, bottom is the x-axis).  ------ > ang must be in the @range 0 < ang <= 90 deg@.--- >--- > width and height must be positive.----rectangleQI :: (Real u, Floating u) => u -> u -> Radian -> Vec2 u    -rectangleQI dx dy ang-    | ang < theta  = let y1 = dx * fromRadian (tan ang) in V2 dx y1-    | otherwise    = let x1 = dy / fromRadian (tan ang) in V2 x1 dy-  where-    theta               = toRadian $ atan (dy/dx)------ | 'hquadrilAcuteQI' : @ dx * dy * ang -> RadialIntersect @------ Find where a line from (0,0) with elevation @ang@ intersects --- a quadrilateral in /H acute/ form in QI.  ------ > ang must be in the @range 0 < ang <= 90@.--- >--- > dx (top width @bc@) and dy (height @ab) must be positive.------ Horizontal acute quadrilateral (@H@ because one of the two --- \"sides of interest\" is horizontal, /acute/ because the --- angle of interest @bcd@ is acute:------ >      --- >  b---*----c--- >  |       /--- >  |      %--- >  |     /--- >  a----d--- >----hquadrilAcuteQI :: (Real u, Floating u) -                => u -> u -> Radian -> RadialIntersect u-hquadrilAcuteQI bc ab bcd ang = -    if ang >= cad then bisectingHTop ab ang else bisecting_dc ad adc ang-  where-    cad           = half_pi - (atan $ toRadian $ bc / ab)-    adc           = pi - bcd-    star_c        = ab / (fromRadian $ tan bcd)-    ad            = bc - star_c--    --- This is intersecting dc at percent-sign - now called z.------ Know one side (ad) and two angs (zad which is ang) and (adc == adz)--- Use law of sines to find (az) :--- --- >--- >         z--- >    . ' /--- >  a----d--- > ----bisecting_dc :: Floating u => u -> Radian -> Radian -> Vec2 u-bisecting_dc ad adc ang = avec ang az-  where-    adz  = adc-    azd  = pi - (ang + adz)-    sine = fromRadian . sin-    az   = (ad * (sine adz)) / sine azd -  ----- This is intersecting bc at star now called o.------ >  b---o----c--- >  |  / --- >  | /  --- >  |/    --- >  a---------bisectingHTop :: Fractional u => u -> Radian -> Vec2 u-bisectingHTop ab ang = V2 bo ab-  where-    bao = half_pi - ang -    bo  = ab * (fromRadian $ tan bao)-     ---- | 'hquadrilObtusQI' : @ dx * dy * ang -> RadialIntersect @------ Find where a line from (0,0) with elevation @ang@ intersects --- a quadrilateral in /H obtus/ form in QI.  ------ > ang must be in the @range 0 < ang <= 90@.--- >--- > dx (top width @bc@) and dy (height @ab) must be positive.------ H Obtus quadrilateral (@H@ because one of the two --- \"sides of interest\" is horizontal, /obtus/ because the --- angle interest @bcd@ is obtuse:------ >      --- >  b---*----c--- >  |         \--- >  |          %--- >  |           \--- >  a------------d--- >----hquadrilObtusQI :: (Real u, Floating u) -                => u -> u -> Radian -> RadialIntersect u-hquadrilObtusQI bc ab bcd ang = -    if ang < cad then bisecting_dc ad adc ang else bisectingHTop ab ang -  where-    cad           = half_pi - (atan $ toRadian $ bc / ab)-    adc           = pi - bcd-    star_c        = ab / (fromRadian $ tan bcd)-    ad            = bc - star_c------     ------- | 'diamondQuadrantAlg' : @ width * height -> QuadrantAlg @------ Find where a radial line extended from (0,0) with the elevation--- @ang@ intersects with an enclosing diamond. The diamond is --- centered at (0,0).--- --- Internally the calculation is made in quadrant I (north east),--- symmetry is used to translate result to the other quadrants.----diamondQuadrantAlg :: (Real u, Floating u) => u -> u -> QuadrantAlg u-diamondQuadrantAlg w h = makeReflectionQuadrantAlg q1 q1 q1 q1-  where-    hw = 0.5 * w-    hh = 0.5 * h-    q1 = hypotenuseQI hw hh----- | 'rectangleQuadrantAlg' : @ width * height -> QuadrantAlg @------ Find where a radial line extended from (0,0) with the elevation--- @ang@ intersects with an enclosing rectangle. The rectangle is --- centered at (0,0).--- --- Internally the calculation is made in quadrant I (north east),--- symmetry is used to translate result to the other quadrants.----rectangleQuadrantAlg :: (Real u, Floating u) => u -> u -> QuadrantAlg u-rectangleQuadrantAlg w h = makeReflectionQuadrantAlg q1 q1 q1 q1-  where-    hw = 0.5 * w-    hh = 0.5 * h-    q1 = rectangleQI hw hh---- | 'isoscelesTriQuadrantAlg' : @ base_width * height -> QuadrantAlg @------ Find where a radial line extended from (0,0) with the elevation--- @ang@ intersects with an enclosing isosceles triangle. --- --- Note the /center/ of the triangle (0,0) is the centroid not the--- incenter.--- --- Internally the calculation is made in quadrant I (north east),--- symmetry is used to translate result to the other quadrants.----isoscelesTriQuadrantAlg :: (Real u, Floating u) => u -> u -> QuadrantAlg u-isoscelesTriQuadrantAlg bw h = -    makeReflectionQuadrantAlg qtop qtop qbase qbase-  where-    ymaj      = 2 * (h / 3)-    ymin      = h / 3-    hbw       = 0.5 * bw-    half_apex = atan (toRadian $ hbw / h)-    ctrdw     = ymaj * (fromRadian $ tan half_apex)-    ang       = half_pi - half_apex--    qtop      = hypotenuseQI ctrdw ymaj-    qbase     = hquadrilAcuteQI hbw ymin ang-    ----- OLD ...---- | 'rectRadialVector' : @ half_width * half_height * ang -> Vec @------ Find where a radial line extended from (0,0) with the elevation--- @ang@ intersects with an enclosing rectangle. The rectangle is --- centered at (0,0).--- --- Internally the calculation is made in quadrant I (north east),--- symmetry is used to translate result to the other quadrants.----rectRadialVector :: (Real u, Floating u) => u -> u -> Radian -> Vec2 u-rectRadialVector hw hh ang = fn $ circularModulo ang-  where-    fn a | a < 0.5*pi   = rectangleQI hw hh a-         | a < pi       = negateX  $ rectangleQI hw hh (pi - a)-         | a < 1.5*pi   = negateXY $ rectangleQI hw hh (a - pi) -         | otherwise    = negateY  $ rectangleQI hw hh (2*pi - a)------ | 'diamondRadialVector' : @ half_width * half_height * ang -> Vec @------ Find where a radial line extended from (0,0) with the elevation--- @ang@ intersects with an enclosing diamond. The diamond is --- centered at (0,0).--- --- Internally the calculation is made in quadrant I (north east),--- symmetry is used to translate result to the other quadrants.----diamondRadialVector :: (Real u, Floating u) => u -> u -> Radian -> Vec2 u-diamondRadialVector hw hh ang = fn $ circularModulo ang-  where-    fn a | a < 0.5*pi   = triangleQI hw hh a-         | a < pi       = negateX  $ triangleQI hw hh (pi - a)-         | a < 1.5*pi   = negateXY $ triangleQI hw hh (a - pi) -         | otherwise    = negateY  $ triangleQI hw hh (2*pi - a)----- | 'triangleRadialVector' : @ half_base_width * height_minor * ---        height_minor * ang -> Vec @------ Find where a radial line extended from (0,0) with the elevation--- @ang@ intersects with an enclosing triangle. The triangle has --- the centroid at (0,0), so solutions in quadrants I and II are --- intersections with a simple line. Intersections in quadrants--- III and IV can intersect either the respective side or the --- base.--- ----triangleRadialVector :: (Real u, Floating u) => u -> u -> u -> Radian -> Vec2 u-triangleRadialVector hbw hminor hmajor ang = fn $ circularModulo ang-  where-    fn a | a < 0.5*pi   = triangleQI major_width hmajor a-         | a < pi       = negateX  $ triangleQI major_width hmajor (pi - a)-         | a < 1.5*pi   = negateXY $ rightTrapezoidQI hbw hminor base_rang (a - pi) -         | otherwise    = negateY  $ rightTrapezoidQI hbw hminor base_rang (2*pi - a)--    height              = hmajor + hminor-    base_rang           = toRadian $ atan (height / hbw)-    major_width         = hmajor / (fromRadian $ tan base_rang)----- | 'triangleQI' : @ width * height * ang -> Vec @------ Find where a line from (0,0) with elevation @ang@ intersects --- the hypotenuse a right triangle in QI (the legs of the triangle --- take the x and y-axes).  ------ > ang must be in the @range 0 < ang <= 90@.--- >--- > width and height must be positive.----triangleQI :: (Real u, Floating u) => u -> u -> Radian -> Vec2 u-triangleQI w h ang = avec ang dist-  where-    base_ang = atan (h / w)-    apex_c   = pi - (base_ang + fromRadian ang)-    dist     = sin base_ang * (w / sin apex_c)------ | 'rightTrapezoidQI' : @ top_width * height * top_right_ang -> Vec @------ Find where a line from (0,0) with elevation @ang@ intersects --- the either the lines A_B or B_D in a right trapezoid in QI. --- --- The right trapezoid has a variable right side. Left side is the--- y-axis (C_A), bottom side is the x-axis (C_D), top side is --- parallel to the x-axis (A_B).------ >  A   B--- >  -------- >  |    \--- >  |     \     --- >  ---------- >  C      D------ >  A      B--- >  ---------- >  |     /--- >  |    /     --- >  -------- >  C   D------ > ang must be in the range 0 < ang <= 90.--- >--- > top_width and height must be positive.----rightTrapezoidQI :: (Real u, Floating u) -                 => u -> u -> Radian -> Radian -> Vec2 u-rightTrapezoidQI tw h top_rang ang = -    if w0 <= tw then dv else avec ang minor_dist-  where-    -- dist is hypotenuse of a right triangle1-    dist         = h / (fromRadian $ sin ang)-    -    -- potentially this vector is *too long*.-    dv@(V2 w0 _) = avec ang dist--    -- this is dist *cut short* because it intersects the right-    -- side rather than the top-    minor_dist   = triangleLeftSide base_width ang lr_ang-    -    lr_ang       = pi - top_rang--    base_width   = rightTrapeziumBaseWidth tw h top_rang----- Legend:--- --- > @top_rang@ is A/B\C.--- >--- > @ang@ is B/C\D.--- > --- > w (width) is A_B.------ > h (height) is C_A.--- --- >  A     B--- >  ------ --- >  |    / .--- >  |   /   .--- >  |  /     .--- >  | /       .     --- >  |/..........--- >  C          D------ Synthetically:------ > Right triangle 1 is ABC.--- >--- > @dist@ is C_B.--- >--- > @base_width@ is C_D.--- >--- > @lr_ang is C/D\B. ---   ----- | 'traingleLeftSide' : @ base_width * left_ang * right_ang -> Length @------ >  --- >        C   --- >       /\--- >      /  \--- >     /    \--- >    /      \    --- >   /________\--- >  A          B--- >--- --- > Calculate A_C given side A_B, angle C/A\B and angle A/B\C.----triangleLeftSide :: Fractional u => u -> Radian -> Radian -> u-triangleLeftSide base_width lang rang =-    (fromRadian $ sin rang) / factor -  where-    apex_c = pi - (lang + rang)-    factor = (fromRadian $ sin apex_c) / base_width----- | 'rightTrapeziumBaseWidth' : @ top_width * height * top_right_ang -> Length @--- --- Find the length of the line C_D:------ >  A   B--- >  -------- >  |    \--- >  |     \     --- >  ---------- >  C      D------ >  A      B--- >  ---------- >  |     /--- >  |    /     --- >  -------- >  C   D------ -rightTrapeziumBaseWidth :: Fractional u => u -> u -> Radian -> u-rightTrapeziumBaseWidth tw h tr_ang -    | tr_ang < half_pi = tw - shorten-    | tr_ang > half_pi = tw + extend-    | otherwise        = tw-  where-    shorten  = h / fromRadian (tan tr_ang)-    extend   = let lr_ang = pi - tr_ang in h / fromRadian (tan lr_ang)

@@ -1,142 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Drawing.Basic.Vertices--- Copyright   :  (c) Stephen Tetley 2011--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Vertices generators for elementary objects - triangles.--------------------------------------------------------------------------------------module Wumpus.Basic.Geometry.Vertices-  ( -    -    Vertices2-  , Vertices3-  , Vertices4--  , runVertices2-  , runVertices3-  , runVertices4---  , rectangleVertices  -  , isoscelesTriangleVertices-  , equilateralTriangleVertices--  , parallelogramVertices--  , isoscelesTrapeziumVertices--  ) -  where----import Wumpus.Core                              -- package: wumpus-core--import Data.AffineSpace                         -- package: vector-space-import Data.VectorSpace---type Vertices2 u = (Vec2 u, Vec2 u)-type Vertices3 u = (Vec2 u, Vec2 u, Vec2 u)-type Vertices4 u = (Vec2 u, Vec2 u, Vec2 u, Vec2 u)---runVertices2 :: Num u => Point2 u -> Vertices2 u -> [Point2 u]-runVertices2 ctr (v1,v2) = [ctr .+^ v1, ctr .+^ v2]--runVertices3 :: Num u => Point2 u -> Vertices3 u -> [Point2 u]-runVertices3 ctr (v1,v2,v3) = [ctr .+^ v1, ctr .+^ v2, ctr .+^ v3]--runVertices4 :: Num u => Point2 u -> Vertices4 u -> [Point2 u]-runVertices4 ctr (v1,v2,v3,v4) = -    [ctr .+^ v1, ctr .+^ v2, ctr .+^ v3, ctr .+^ v4]----- | Vertices are from the center to (bl, br, tr, tl).----rectangleVertices :: Num u => u -> u -> Vertices4 u-rectangleVertices hw hh = (bl, br, tr, tl)-  where-    bl = V2 (-hw) (-hh)-    br = V2   hw  (-hh)-    tr = V2   hw    hh-    tl = V2 (-hw)   hh --------- | @base_width * height -> (BL,BR,Apex)@------ Vertices are from the centeriod to (bl, br,apex).------- | @ height -> (BL,BR,Apex)@--- --- Point is centroid (not incenter).----isoscelesTriangleVertices :: Floating u => u -> u -> Vertices3 u-isoscelesTriangleVertices bw h = (bl, br, top) -  where-    hw            = 0.5*bw -    centroid_min  = 1 * (h / 3)-    centroid_maj  = h - centroid_min-    top           = vvec centroid_maj-    br            = V2   hw  (-centroid_min)-    bl            = V2 (-hw) (-centroid_min)-------- | @ side_length -> (BL,BR,Apex)@----equilateralTriangleVertices :: Floating u => u -> Vertices3 u-equilateralTriangleVertices h = isoscelesTriangleVertices sl h-  where-    sl = 2.0 * (h / tan (pi/3))----parallelogramVertices :: Floating u => u -> u -> Radian -> Vertices4 u-parallelogramVertices w h bl_ang = (to_bl, to_br, to_tr, to_tl)-  where-    hw              = 0.5 * w-    hh              = 0.5 * h-    hypo            = hh / (fromRadian $ sin bl_ang)--    to_bl           = hvec (-hw) ^+^ avec bl_ang (-hypo)-    to_br           = hvec hw    ^+^ avec bl_ang (-hypo)-    to_tl           = hvec (-hw) ^+^ avec bl_ang hypo-    to_tr           = hvec hw    ^+^ avec bl_ang hypo------- Trapezium - make an isosceles trapezium...--- base - top - height ---- -isoscelesTrapeziumVertices :: Floating u-                           => u -> u -> u -> Vertices4 u-isoscelesTrapeziumVertices wbase wtop h = -    (to_bl, to_br, to_tr, to_tl)-  where-    hh    = 0.5 * h-    hbw   = 0.5 * wbase-    htw   = 0.5 * wtop    -    to_bl = V2 (-hbw) (-hh) -    to_br = V2   hbw  (-hh) -    to_tl = V2 (-htw)   hh -    to_tr = V2   htw    hh-

@@ -12,6 +12,21 @@ -- -- Import shim for @Wumpus.Basic.Kernel@ modules. --+-- @Kernel.Base@ - low-level objects, general enumerations, unit +-- and @DrawingContext@ support. @DrawingContext@ is comparative +-- to the /graphics state/ in PostScript, but it is a read-only+-- environment (cf. the Reader monad). Like the Reader monad it +-- supports branching update through @local@ - here called +-- @localize@.+-- +-- @Kernel.Objects@ - \"elementary\" drawing objects, plus some +-- catalogues of named, predefined drawing objects +-- (DrawingPrimitives) and useful operations (named vectors - +-- Displacement).+--+-- @Kernel.Drawing@ - \"collective\" drawing objects. @Drawing@ is +-- considered a higher layer than @Objects@, so there should be +-- dependencies only from @Drawing@ to @Objects@. -- -------------------------------------------------------------------------------- 

@@ -4,7 +4,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Basic.Kernal.Base.BaseDefs--- Copyright   :  (c) Stephen Tetley 2010-2011+-- Copyright   :  (c) Stephen Tetley 2010-2012 -- License     :  BSD3 -- -- Maintainer  :  stephen.tetley@gmail.com@@ -61,7 +61,7 @@   , closedMode    -- * Drawing layers-  , ZDeco(..)  +  , ZOrder(..)      -- * Alignment   , HAlign(..)@@ -76,7 +76,23 @@   -- * Direction enumeration   , Direction(..)   , ClockDirection(..)  +  , clockDirection +  , HDirection(..)+  , horizontalDirection+  , VDirection(..)+  , verticalDirection++  -- * Quadrant enumeration+  , Quadrant(..)+  , quadrant++  -- * Beziers++  , bezierArcPoints  +  , bezierMinorArc+  +   -- * Misc    , both@@ -87,6 +103,9 @@ import Wumpus.Core                              -- package: wumpus-core  +import Data.AffineSpace                         -- package: vector-space+import Data.VectorSpace+ import Control.Applicative import Data.Monoid @@ -112,7 +131,7 @@ ang150          = 5 * ang30  ang120          :: Radian -ang120          = 3 * ang60+ang120          = 2 * ang60  ang90           :: Radian ang90           = pi / 2@@ -211,7 +230,7 @@ -- Units may or may not depend on current font size -- -class Num u => InterpretUnit u where+class (Eq u, Num u) => InterpretUnit u where   normalize :: FontSize -> u -> Double   dinterp   :: FontSize -> Double -> u @@ -293,7 +312,7 @@ -- | Draw closed paths.  --  -- > OSTROKE - open and stroked-+-- -- > CSTROKE - closed and stroke -- -- > CFILL - closed and filled@@ -311,7 +330,7 @@ -- -- > DRAW_FILL - closed and filled ----- > CLOSED_FILL_STROKE - the path is filled, its edge is stroked.+-- > DRAW_FILL_STROKE - the path is filled, its edge is stroked. -- data DrawMode = DRAW_STROKE | DRAW_FILL | DRAW_FILL_STROKE   deriving (Bounded,Enum,Eq,Ord,Show)@@ -328,13 +347,9 @@   --- | Decorating with resepct to the Z-order --- --- > SUPERIOR - in front. ------ > ANTERIOR - behind.+-- | Enumerated type for drawing with respect to the z-order. ---data ZDeco = SUPERIOR | ANTERIOR+data ZOrder = ZBELOW | ZABOVE   deriving (Bounded,Enum,Eq,Ord,Show)  @@ -392,12 +407,138 @@    deriving (Enum,Eq,Ord,Show)   +-- | An enumerated type representing horizontal direction.+--+data HDirection = LEFTWARDS | RIGHTWARDS+   deriving (Enum,Eq,Ord,Show) +++horizontalDirection :: Radian -> HDirection+horizontalDirection = fn . circularModulo+  where+    fn a | a <= 0.5*pi || a > 1.5*pi = RIGHTWARDS+         | otherwise                 = LEFTWARDS++-- | An enumerated type representing vertical direction.+--+data VDirection = UPWARDS | DOWNWARDS+   deriving (Enum,Eq,Ord,Show) +++verticalDirection :: Radian -> VDirection+verticalDirection = fn . circularModulo+  where+    fn a | a <= pi   = UPWARDS+         | otherwise = DOWNWARDS+  + -- | An enumerated type representing /clock/ directions. -- data ClockDirection = CW | CCW    deriving (Enum,Eq,Ord,Show)   ++-- | Note - behaviour at the continuity (0 deg, 180 deg, ...) is+-- unspecified.+--+clockDirection :: (Real u, Floating u) +               => Vec2 u -> Vec2 u -> ClockDirection+clockDirection v1 v2 = if a1 < asum then CW else CCW+  where+    a1   = r2d $ vdirection v1+    asum = r2d $ vdirection (v1 ^+^ v2)++++-- | An enumerated type representing quadrants.+-- +data Quadrant = QUAD_NE | QUAD_NW | QUAD_SW | QUAD_SE+  deriving (Enum,Eq,Ord,Show)++-- | 'quadrant' : @ ang -> Quadrant @+--+-- Get the quadrant of an angle.+--+quadrant :: Radian -> Quadrant+quadrant = fn . circularModulo+  where+    fn a | a < 0.5*pi   = QUAD_NE+         | a < pi       = QUAD_NW+         | a < 1.5*pi   = QUAD_SW+         | otherwise    = QUAD_SE++++--------------------------------------------------------------------------------+-- Beziers++kappa :: Floating u => u+kappa = 4 * ((sqrt 2 - 1) / 3)++++-- | 'bezierArcPoints' : @ apex_angle * radius * inclination * center -> [Point] @+--+-- > ang should be in the range 0 < ang < 360deg.+--+-- > if   0 < ang <=  90 returns 4 points+-- > if  90 < ang <= 180 returns 7 points+-- > if 180 < ang <= 270 returns 10 points+-- > if 270 < ang <  360 returns 13 points+--+bezierArcPoints ::  Floating u +                => Radian -> u -> Radian -> Point2 u -> [Point2 u]+bezierArcPoints ang radius theta pt = go (circularModulo ang)+  where+    go a | a <= half_pi = wedge1 a+         | a <= pi      = wedge2 (a/2)+         | a <= 1.5*pi  = wedge3 (a/3)+         | otherwise    = wedge4 (a/4)+    +    wedge1 a = +      let (p0,p1,p2,p3) = bezierMinorArc a radius theta pt+      in [p0,p1,p2,p3]++    wedge2 a = +      let (p0,p1,p2,p3) = bezierMinorArc a radius theta pt+          (_ ,p4,p5,p6) = bezierMinorArc a radius (theta+a) pt+      in [ p0,p1,p2,p3, p4,p5,p6 ] ++    wedge3 a = +      let (p0,p1,p2,p3) = bezierMinorArc a radius theta pt+          (_ ,p4,p5,p6) = bezierMinorArc a radius (theta+a) pt+          (_ ,p7,p8,p9) = bezierMinorArc a radius (theta+a+a) pt+      in [ p0,p1,p2,p3, p4,p5,p6, p7, p8, p9 ] +  +    wedge4 a = +      let (p0,p1,p2,p3)    = bezierMinorArc a radius theta pt+          (_ ,p4,p5,p6)    = bezierMinorArc a radius (theta+a) pt+          (_ ,p7,p8,p9)    = bezierMinorArc a radius (theta+a+a) pt+          (_ ,p10,p11,p12) = bezierMinorArc a radius (theta+a+a+a) pt+      in [ p0,p1,p2,p3, p4,p5,p6, p7,p8,p9, p10,p11, p12 ] +++-- | 'bezierMinorArc' : @ apex_angle * radius * rotation * center -> BezierCurve @+--+-- > ang should be in the range 0 < ang <= 90deg.+--+bezierMinorArc :: Floating u +               => Radian -> u -> Radian -> Point2 u +               -> (Point2 u, Point2 u, Point2 u, Point2 u)+bezierMinorArc ang radius theta pt = (p0,p1,p2,p3)+  where+    kfactor = fromRadian $ ang / (0.5*pi)+    rl      = kfactor * radius * kappa+    totang  = circularModulo $ ang + theta++    p0      = pt .+^ orthoVec radius 0 theta+    p1      = p0 .+^ orthoVec 0 rl theta+    p2      = p3 .+^ orthoVec 0 (-rl) totang+    p3      = pt .+^ orthoVec radius 0 totang+++--------------------------------------------------------------------------------   -- | Applicative /both/ - run both computations return the pair

@@ -4,7 +4,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Basic.Kernel.Base.Units--- Copyright   :  (c) Stephen Tetley 2011+-- Copyright   :  (c) Stephen Tetley 2011-2012 -- License     :  BSD3 -- -- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>

@@ -4,7 +4,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Basic.Kernel.Drawing.Basis--- Copyright   :  (c) Stephen Tetley 2011+-- Copyright   :  (c) Stephen Tetley 2011-2012 -- License     :  BSD3 -- -- Maintainer  :  stephen.tetley@gmail.com@@ -42,9 +42,9 @@   class (Applicative m, Monad m) => UserStateM (m :: * -> *) where-  getState    :: st ~ UState m  => m st-  setState    :: st ~ UState m  => st -> m ()-  updateState :: st ~ UState m  => (st -> st) -> m ()+  getState    :: st ~ UState (m a) => m st+  setState    :: st ~ UState (m a) => st -> m ()+  updateState :: st ~ UState (m a) => (st -> st) -> m ()      

@@ -6,14 +6,14 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Basic.Kernel.Drawing.Chain--- Copyright   :  (c) Stephen Tetley 2011+-- Copyright   :  (c) Stephen Tetley 2011-2012 -- License     :  BSD3 -- -- Maintainer  :  stephen.tetley@gmail.com -- Stability   :  highly unstable -- Portability :  GHC  ----- Chaining moveable LocGraphics.+-- Chaining LocGraphics. -- -------------------------------------------------------------------------------- @@ -34,27 +34,32 @@   , runChain_    , chain1-  , sequenceChain+  , chainSkip_+  , chainMany+  , chainReplicate+  , chainCount -  , setChainScheme+  , iterationScheme+  , sequenceScheme+  , catTrailScheme+  , countingScheme -  , chainPrefix -  , chainIterate+  , horizontalScheme+  , verticalScheme -  , horizontalChainScm-  , verticalChainScm-  , runChainH-  , runChainV -  , tableRowwiseScm-  , tableColumnwiseScm+  , rowwiseTableScheme+  , columnwiseTableScheme   -  , runTableRowwise-  , runTableColumnwise -  , radialChain+  , distribRowwiseTable+  , duplicateRowwiseTable+  , distribColumnwiseTable+  , duplicateColumnwiseTable +  , radialChainScheme+   ) where  @@ -66,6 +71,7 @@ import Wumpus.Basic.Kernel.Objects.Displacement import Wumpus.Basic.Kernel.Objects.Image import Wumpus.Basic.Kernel.Objects.LocImage+import Wumpus.Basic.Kernel.Objects.Trail  import Wumpus.Core                              -- package: wumpus-core @@ -79,8 +85,8 @@                         -> (a, DPoint2, ChainSt st u, CatPrim) }  -type instance DUnit (GenChain st u a) = u-type instance UState  (GenChain st u) = st+type instance DUnit (GenChain st u a)   = u+type instance UState  (GenChain st u a) = st  type Chain u a   = GenChain () u a @@ -100,7 +106,8 @@   data ChainSt st u = forall cst. ChainSt -       { chain_st         :: cst+       { chain_count      :: Int+       , chain_st         :: cst        , chain_next       :: Point2 u -> cst -> (Point2 u,cst)         , chain_user_state :: st        }@@ -150,12 +157,12 @@ -- UserStateM   instance UserStateM (GenChain st u) where-  getState        = GenChain $ \_ pt s@(ChainSt _ _ ust) -> +  getState        = GenChain $ \_ pt s@(ChainSt _ _ _ ust) ->                        (ust, pt, s, mempty)-  setState ust    = GenChain $ \_ pt (ChainSt a b _) -> -                      ((), pt, ChainSt a b ust, mempty)-  updateState upd = GenChain $ \_ pt (ChainSt a b ust) -> -                      ((), pt, ChainSt a b (upd ust), mempty)+  setState ust    = GenChain $ \_ pt (ChainSt i a b _) -> +                      ((), pt, ChainSt i a b ust, mempty)+  updateState upd = GenChain $ \_ pt (ChainSt i a b ust) -> +                      ((), pt, ChainSt i a b (upd ust), mempty)   -- LocationM@@ -182,7 +189,8 @@             => ChainScheme u -> st -> GenChain st u a -> LocImage u (a,st) runGenChain (ChainScheme start step) ust ma = promoteLoc $ \pt ->      askDC >>= \ctx ->-    let st_zero     = ChainSt { chain_st         = start pt+    let st_zero     = ChainSt { chain_count      = 0+                              , chain_st         = start pt                               , chain_next       = step                               , chain_user_state = ust }         dpt         = normalizeF (dc_font_size ctx) pt@@ -225,43 +233,116 @@ -------------------------------------------------------------------------------- -- Operations ++-- | Demand a point on the Chain and draw the LocImage+-- at it.+-- chain1 :: InterpretUnit u -        => LocImage u a -> GenChain st u a-chain1 gf  = GenChain $ \ctx pt (ChainSt s0 sf ust) -> +       => LocImage u a -> GenChain st u a+chain1 gf  = GenChain $ \ctx pt (ChainSt i0 s0 sf ust) ->      let upt       = dinterpF (dc_font_size ctx) pt         (a,w1)    = runImage ctx $ applyLoc gf upt         (pt1,st1) = sf upt s0         dpt1      = normalizeF (dc_font_size ctx) pt1-        new_st    = ChainSt { chain_st         = st1+        new_st    = ChainSt { chain_count      = i0 + 1+                            , chain_st         = st1                             , chain_next       = sf                             , chain_user_state = ust }     in (a, dpt1, new_st, w1) -sequenceChain :: InterpretUnit u -              => [LocImage u a] -> GenChain st u (UNil u)-sequenceChain = ignoreAns . mapM_ chain1 +-- | Demand the next position, but draw nothing. ----- Note - onChain draws at the initial position, then increments --- the next position.+chainSkip_ :: InterpretUnit u => GenChain st u ()+chainSkip_ = GenChain $ \ctx pt (ChainSt i0 s0 sf ust) -> +    let upt       = dinterpF (dc_font_size ctx) pt+        (pt1,st1) = sf upt s0+        dpt1      = normalizeF (dc_font_size ctx) pt1+        new_st    = ChainSt { chain_count      = i0 + 1+                            , chain_st         = st1+                            , chain_next       = sf+                            , chain_user_state = ust }+    in ((), dpt1, new_st, mempty)++++-- | Chain a list of images, each demanding a succesive start +-- point. --+chainMany :: InterpretUnit u +          => [LocImage u a] -> GenChain st u (UNil u)+chainMany = ignoreAns . mapM_ chain1  -setChainScheme :: InterpretUnit u -               => ChainScheme u -> GenChain st u ()-setChainScheme (ChainScheme start step) = -    GenChain $ \ctx pt (ChainSt _ _ ust) -> -      let upt     = dinterpF (dc_font_size ctx) pt-          new_st  = ChainSt { chain_st         = start upt-                            , chain_next       = step-                            , chain_user_state = ust }-      in ((), pt, new_st, mempty) +-- | Replicate a LocImage @n@ times along a Chain.+--+chainReplicate :: InterpretUnit u +               => Int -> LocImage u a -> GenChain st u (UNil u)+chainReplicate n = chainMany . replicate n   +-- | Return the count of chain steps.+--+chainCount :: GenChain st u Int+chainCount = GenChain $ \_ dpt st@(ChainSt i _ _ _) -> (i, dpt, st, mempty)+              -chainPrefix :: ChainScheme u -> Int -> ChainScheme u -> ChainScheme u-chainPrefix (ChainScheme astart astep) ntimes chb@(ChainScheme bstart bstep)-    | ntimes < 1 = chb++++--------------------------------------------------------------------------------+-- Schemes+++-- | General scheme - iterate the next point with the supplied+-- function.+--+iterationScheme :: (Point2 u -> Point2 u) -> ChainScheme u+iterationScheme fn = ChainScheme { chain_init = const ()+                                 , chain_step = \pt _ -> (fn pt, ())+                                 }++-- | General scheme - displace successively by the elements of the+-- list of vectors. +-- +-- Note - the list is cycled to make the chain infinite.+--+sequenceScheme :: Num u => [Vec2 u] -> ChainScheme u+sequenceScheme [] = error "sequenceScheme - empty list."+sequenceScheme vs = ChainScheme { chain_init = const $ cycle vs+                                , chain_step = step+                                }+  where+    step _  []     = error "sequenceScheme - unreachable, cycled."+    step pt (w:ws) = (displace w pt, ws) +++-- | Derive a ChainScheme from a CatTrail.+--+-- Note - this iterates the control points of curves, it does not+-- iterate points on the curve.+--+catTrailScheme :: Num u => CatTrail u -> ChainScheme u+catTrailScheme = sequenceScheme . linear . destrCatTrail+  where+    linear (TLine v0 :xs)        = v0 : linear xs+    linear (TCurve v0 v1 v2 :xs) = v0 : v1 : v2 : linear xs+    linear []                    = []+++-- | Build an (infinite) ChainScheme for a prefix list of counted +-- schemes and a final scheme that runs out to infinity.+--+countingScheme :: [(Int, ChainScheme u)] -> ChainScheme u -> ChainScheme u+countingScheme []     rest = rest+countingScheme (x:xs) rest = chainPrefix  x (countingScheme xs rest)+++-- | Helper - complicated...+--+chainPrefix :: (Int, ChainScheme u) -> ChainScheme u -> ChainScheme u+chainPrefix (ntimes, ChainScheme astart astep) rest@(ChainScheme bstart bstep)+    | ntimes < 1 = rest     | otherwise  = ChainScheme { chain_init = start, chain_step = next }   where     start pt = (astart pt,ntimes, bstart pt)@@ -276,40 +357,17 @@   ------------------------------------------------------------------------------------- Schemes--chainIterate :: (Point2 u -> Point2 u) -> ChainScheme u-chainIterate fn = ChainScheme { chain_init = const ()-                              , chain_step = \pt _ -> (fn pt, ())-                              }---horizontalChainScm :: Num u => u -> ChainScheme u-horizontalChainScm dx = -    ChainScheme { chain_init = const ()-                , chain_step = \pt _ -> (displace (hvec dx) pt, ())-                }+horizontalScheme :: Num u => u -> ChainScheme u+horizontalScheme dx = iterationScheme (displace (hvec dx))+                    -verticalChainScm :: Num u => u -> ChainScheme u-verticalChainScm dy = -    ChainScheme { chain_init = const ()-                , chain_step = \pt _ -> (displace (vvec dy) pt, ())-                }+verticalScheme :: Num u => u -> ChainScheme u+verticalScheme dy = iterationScheme (displace (vvec dy))+                 --- Horizontal and vertical chains are common enough to merit --- dedicated run functions. -runChainH :: InterpretUnit u => u -> Chain u a -> LocImage u a-runChainH dx ma = runChain (horizontalChainScm dx) ma --runChainV :: InterpretUnit u => u -> Chain u a -> LocImage u a-runChainV dy ma = runChain (verticalChainScm dy) ma-- -- | Outer and inner steppers. -- scStepper :: PointDisplace u -> Int -> PointDisplace u @@ -323,37 +381,65 @@                                     in (o1, (o1,1))   -tableRowwiseScm :: Num u => Int -> (u,u) -> ChainScheme u-tableRowwiseScm num_cols (col_width,row_height) = ++-- | Generate a tabular scheme going rowwise (left-to-right) and+-- downwards.+--+-- TODO - should probably account for the initial position... +--+rowwiseTableScheme :: Num u => Int -> (u,u) -> ChainScheme u+rowwiseTableScheme num_cols (col_width,row_height) =      scStepper downF num_cols rightF   where     downF   = displace $ vvec $ negate row_height     rightF  = displace $ hvec col_width -tableColumnwiseScm :: Num u => Int -> (u,u) -> ChainScheme u-tableColumnwiseScm num_rows (col_width,row_height) = +-- | Generate a tabular scheme going columwise (top-to-bottom) +-- and rightwards.+--+-- TODO - should probably account for the initial position... +--+columnwiseTableScheme :: Num u => Int -> (u,u) -> ChainScheme u+columnwiseTableScheme num_rows (col_width,row_height) =      scStepper rightF num_rows downF   where     downF   = displace $ vvec $ negate row_height     rightF  = displace $ hvec col_width  -runTableRowwise :: InterpretUnit u -             => Int -> (u,u) -> Chain u a -> LocImage u a-runTableRowwise num_cols dims ma = -    runChain (tableRowwiseScm num_cols dims) ma  -runTableColumnwise :: InterpretUnit u -             => Int -> (u,u) -> Chain u a -> LocImage u a-runTableColumnwise num_rows dims ma = -    runChain (tableColumnwiseScm num_rows dims) ma+distribRowwiseTable :: (Monoid a, InterpretUnit u)+                    => Int -> (u,u) -> [LocImage u a] -> LocImage u a+distribRowwiseTable num_cols dims gs = fmap mconcat $ +    runChain (rowwiseTableScheme num_cols dims) $ mapM chain1 gs+   +duplicateRowwiseTable :: (Monoid a, InterpretUnit u)+                      => Int -> Int -> (u,u) -> LocImage u a -> LocImage u a+duplicateRowwiseTable i num_cols dims gf =+    distribRowwiseTable num_cols dims (replicate i gf)   -radialChain :: Floating u -            => u -> Radian -> Radian -> ChainScheme u-radialChain radius angstart angi = ++distribColumnwiseTable :: (Monoid a, InterpretUnit u)+                       => Int -> (u,u) -> [LocImage u a] -> LocImage u a+distribColumnwiseTable num_rows dims gs = fmap mconcat $ +    runChain (columnwiseTableScheme num_rows dims) $ mapM chain1 gs+  ++duplicateColumnwiseTable :: (Monoid a, InterpretUnit u)+                         => Int -> Int -> (u,u) -> LocImage u a -> LocImage u a+duplicateColumnwiseTable i num_rows dims gf = +    distribColumnwiseTable num_rows dims (replicate i gf) ++++-- | TODO - account for CW CCW or just rely on +ve -ve angles?...+--+radialChainScheme :: Floating u +                  => u -> Radian -> Radian -> ChainScheme u+radialChainScheme radius angstart angi =      ChainScheme { chain_init = start, chain_step = step }   where     start pt           = let ogin = displace (avec angstart (-radius)) pt@@ -370,6 +456,8 @@ -- point.  --- Note - radialChains stepper is oblivious to the previous point... ++    +     

@@ -5,7 +5,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Basic.Kernel.Drawing.LocDrawing--- Copyright   :  (c) Stephen Tetley 2011+-- Copyright   :  (c) Stephen Tetley 2011-2012 -- License     :  BSD3 -- -- Maintainer  :  stephen.tetley@gmail.com@@ -52,7 +52,6 @@   import Control.Applicative-import Control.Monad import Data.Monoid  @@ -72,7 +71,7 @@     getGenLocDrawing :: DrawingContext -> st -> (a, st, CatPrim)}  type instance DUnit  (GenLocDrawing st u a) = u-type instance UState (GenLocDrawing st u)   = st+type instance UState (GenLocDrawing st u a) = st  type LocDrawing u a = GenLocDrawing () u a 

@@ -5,7 +5,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Basic.Kernel.Drawing.LocTrace--- Copyright   :  (c) Stephen Tetley 2011+-- Copyright   :  (c) Stephen Tetley 2011-2012 -- License     :  BSD3 -- -- Maintainer  :  stephen.tetley@gmail.com@@ -50,7 +50,6 @@ import Data.AffineSpace                         -- package: vector-space  import Control.Applicative-import Control.Monad import Data.Monoid  @@ -66,7 +65,7 @@                    -> (a, DPoint2, st, CatPrim)}  type instance DUnit  (GenLocTrace st u a) = u-type instance UState (GenLocTrace st u)   = st+type instance UState (GenLocTrace st u a) = st  type LocTrace u a = GenLocTrace () u a 

@@ -4,7 +4,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Basic.Kernel.Drawing.PosObject--- Copyright   :  (c) Stephen Tetley 2011+-- Copyright   :  (c) Stephen Tetley 2011-2012 -- License     :  BSD3 -- -- Maintainer  :  stephen.tetley@gmail.com@@ -109,6 +109,11 @@ import Control.Applicative import Data.Monoid +--+-- Note - PosObject could be in the @Object@ rather than @Drawing@+-- namespace.+--+ type DOrt = Orientation Double  -- | A positionable \"Object\".@@ -117,7 +122,7 @@     getGenPosObject :: DrawingContext -> DPoint2 -> st -> (a, st, DOrt, CatPrim) }  type instance DUnit   (GenPosObject st u a) = u-type instance UState  (GenPosObject st u)   = st+type instance UState  (GenPosObject st u a) = st  type GenPosGraphic st u = GenPosObject st u (UNil u) @@ -272,25 +277,27 @@   elaboratePosObject :: (Fractional u, Ord u, InterpretUnit u)-                   => ZDeco -> RectAddress -> LocGraphic u -> GenPosObject st u a+                   => ZOrder -> RectAddress -> LocGraphic u                     -> GenPosObject st u a-elaboratePosObject zdec raddr gf ma = decoratePosObject zdec fn ma+                   -> GenPosObject st u a+elaboratePosObject zo raddr gf ma = decoratePosObject zo fn ma   where     fn ortt = moveStart (vtoRectAddress ortt raddr) gf    decoratePosObject :: InterpretUnit u -                  => ZDeco -> (Orientation u -> LocGraphic u) -> GenPosObject st u a+                  => ZOrder -> (Orientation u -> LocGraphic u)                    -> GenPosObject st u a-decoratePosObject zdec fn ma = GenPosObject $ \ctx pt s -> +                  -> GenPosObject st u a+decoratePosObject zo fn ma = GenPosObject $ \ctx pt s ->      let (a,s1,o1,w1) = getGenPosObject ma ctx pt s         uortt        = dinterpF (dc_font_size ctx) o1         upt          = dinterpF (dc_font_size ctx) pt         (_,w2)       = runLocImage ctx upt $ fn uortt-        wout         = case zdec of-                         ANTERIOR -> w2 `mappend` w1-                         SUPERIOR -> w1  `mappend` w2+        wout         = case zo of+                         ZABOVE -> w1 `mappend` w2+                         ZBELOW -> w2 `mappend` w1     in (a,s1,o1,wout)  @@ -340,7 +347,7 @@     let dpt         = normalizeF (dc_font_size ctx) pt          (_,_,o1,w1) = getGenPosObject mf ctx dpt ()         uort        = dinterpF (dc_font_size ctx) o1-    in adecorate (primGraphic w1) (illustrateOrientation uort `at` pt)+    in decorateBelow (primGraphic w1) (illustrateOrientation uort `at` pt)   illustrateOrientation :: InterpretUnit u 

@@ -4,7 +4,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Basic.Kernel.Drawing.TraceDrawing--- Copyright   :  (c) Stephen Tetley 2010-2011+-- Copyright   :  (c) Stephen Tetley 2010-2012 -- License     :  BSD3 -- -- Maintainer  :  stephen.tetley@gmail.com@@ -70,7 +70,6 @@ import Wumpus.Core                              -- package: wumpus-core  import Control.Applicative-import Control.Monad import Data.Monoid  @@ -93,7 +92,7 @@   type instance DUnit   (GenTraceDrawing st u a) = u-type instance UState  (GenTraceDrawing st u)   = st+type instance UState  (GenTraceDrawing st u a) = st  type TraceDrawing u a = GenTraceDrawing () u a 

@@ -29,11 +29,11 @@   , replaceAns    , Decorate(..)-  , sdecorate-  , adecorate+  , decorateAbove+  , decorateBelow -  , selaborate-  , aelaborate+  , elaborateAbove+  , elaborateBelow    ) where @@ -81,25 +81,35 @@ -- it with the graphic from the second. -- class Decorate (f :: * -> * -> *) where-  decorate    :: ZDeco -> f u a -> f u z -> f u a-  elaborate   :: ZDeco -> f u a -> (a -> f u z) -> f u a+  -- | Should be read as @ decorate (above|below) A with B @+  decorate    :: ZOrder -> f u a -> f u z -> f u a+  elaborate   :: ZOrder -> f u a -> (a -> f u z) -> f u a   obliterate  :: f u a -> f u a   hyperlink   :: XLink -> f u a -> f u a   svgId       :: String -> f u a -> f u a   svgAnnotate :: [SvgAttr] -> f u a -> f u a -sdecorate :: Decorate f => f u a -> f u z -> f u a-sdecorate = decorate SUPERIOR -adecorate :: Decorate f => f u a -> f u z -> f u a-adecorate = decorate ANTERIOR +-- | Decorate (ABOVE) a with b.+--+decorateAbove :: Decorate f => f u a -> f u z -> f u a+decorateAbove = decorate ZABOVE -selaborate :: Decorate f => f u a -> (a -> f u z) -> f u a-selaborate = elaborate SUPERIOR+-- | Decorate (BELOW) a with b.+--+decorateBelow :: Decorate f => f u a -> f u z -> f u a+decorateBelow = decorate ZBELOW -aelaborate :: Decorate f => f u a -> (a -> f u z) -> f u a-aelaborate = elaborate ANTERIOR+-- | Elaborate (ABOVE) a with b.+--+elaborateAbove :: Decorate f => f u a -> (a -> f u z) -> f u a+elaborateAbove = elaborate ZABOVE++-- | Elaborate (BELOW) a with b.+--+elaborateBelow :: Decorate f => f u a -> (a -> f u z) -> f u a+elaborateBelow = elaborate ZBELOW   

@@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Basic.Kernel.Objects.Bounded--- Copyright   :  (c) Stephen Tetley 2010-2011+-- Copyright   :  (c) Stephen Tetley 2010-2012 -- License     :  BSD3 -- -- Maintainer  :  stephen.tetley@gmail.com@@ -132,7 +132,7 @@ -- illustrateBoundedGraphic :: InterpretUnit u                          => Image u (BoundingBox u) -> Image u (BoundingBox u)-illustrateBoundedGraphic gf = aelaborate gf bbrectangle+illustrateBoundedGraphic gf = elaborateBelow gf bbrectangle   @@ -141,7 +141,7 @@ illustrateBoundedLocGraphic :: InterpretUnit u                             => LocImage u (BoundingBox u)                              -> LocImage u (BoundingBox u)-illustrateBoundedLocGraphic gf = aelaborate gf fn+illustrateBoundedLocGraphic gf = elaborateBelow gf fn   where     fn bb = promoteLoc $ \_ -> bbrectangle bb @@ -153,7 +153,7 @@ illustrateBoundedLocThetaGraphic :: InterpretUnit u                                  => LocThetaImage u (BoundingBox u)                                  -> LocThetaImage u (BoundingBox u)-illustrateBoundedLocThetaGraphic gf = aelaborate gf fn+illustrateBoundedLocThetaGraphic gf = elaborateBelow gf fn   where     fn bb = promoteLocTheta $ \_ _ -> bbrectangle bb 

@@ -72,6 +72,10 @@   , theta_down_left   , theta_down_right +  , theta_adj_grazing+  , theta_bkwd_adj_grazing++   ) where  @@ -154,8 +158,8 @@ -- displaced in parallel and the y component displaced -- perpendicular.  -- -dispOrtho :: Floating u => Vec2 u -> ThetaPointDisplace u-dispOrtho (V2 x y) = \theta -> dispParallel x theta . dispPerpendicular y theta+dispOrtho :: Floating u => u -> u -> ThetaPointDisplace u+dispOrtho x y = \theta -> dispParallel x theta . dispPerpendicular y theta   @@ -318,78 +322,37 @@   --------------------------------------------------------------------------------- --{----- ORPHANS - need a new home...---- | Absolute units.--- -centerRelative :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a) -               => (Int,Int) -> a -> Query (Anchor u)-centerRelative coord a = snapmove coord >>= \v -> return $ center a .+^ v---- TODO - These are really for Anchors.+-- | Return @a-o@ when supplied length of @b-o@ and the grazing +-- angle @boa@: ----- Should the have a separate module or be rolled into the same--- module as the classes?+-- >    a+-- >    .\+-- >    . \+-- >  ..b..o ------ | Value is 1 snap unit right.+-- This is useful for building arrowhead vectors. ----- This function should be considered obsolete, pending a --- re-think.--- -right_of        :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a) -                => a -> Query (Anchor u)-right_of        = centerRelative (1,0)+theta_adj_grazing :: Floating u => u -> Radian -> Radian -> Vec2 u +theta_adj_grazing adj_len ang theta = orthoVec adj_len (-opp) theta+  where+    opp = adj_len * (fromRadian $ tan ang) --- | Value is 1 snap move left.------ This function should be considered obsolete, pending a --- re-think.--- -left_of         :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a) -                => a -> Query (Anchor u)-left_of         = centerRelative ((-1),0) --- | Value is 1 snap move up, 1 snap move right.+-- | Return @o-c@ when supplied length of @b-o@ and the grazing +-- angle @boc@: ----- This function should be considered obsolete, pending a --- re-think.--- -above_right_of  :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a) -                => a -> Query (Anchor u)-above_right_of  = centerRelative (1,1)---- | Value is 1 snap move below, 1 snap move right. ----- This function should be considered obsolete, pending a --- re-think.--- -below_right_of  :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a) -                => a -> Query (Anchor u)-below_right_of  = centerRelative (1, (-1))---- | Value is 1 snap move up, 1 snap move left.+-- >  ..b..o+-- >    . /+-- >    ./+-- >    c ----- This function should be considered obsolete, pending a --- re-think.--- -above_left_of   :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a) -                => a -> Query (Anchor u)-above_left_of   = centerRelative ((-1),1)---- | Value is 1 snap move down, 1 snap move left.+-- This is useful for building arrowhead vectors. ----- This function should be considered obsolete, pending a --- re-think.--- -below_left_of   :: (CenterAnchor a, Fractional u, InterpretUnit u, u ~ DUnit a) -                => a -> Query (Anchor u)-below_left_of   = centerRelative ((-1),(-1))- +theta_bkwd_adj_grazing :: Floating u => u -> Radian -> Radian -> Vec2 u +theta_bkwd_adj_grazing adj_len ang theta = orthoVec (-adj_len) (-opp) theta+  where+    opp = adj_len * (fromRadian $ tan ang) --}+

@@ -64,7 +64,10 @@   , dcDisk   , dcEllipseDisk +  -- * Arc+  , dcArc +   ) where  import Wumpus.Basic.Kernel.Base.BaseDefs@@ -596,3 +599,16 @@                            fillStrokeEllipse frgb attr srgb drx dry pt)  ++--------------------------------------------------------------------------------++++-- | dcArc : radius * apex_angle+-- +-- Always open-stroked.+--+dcArc :: (Floating u, InterpretUnit u) => u -> Radian -> LocThetaGraphic u+dcArc radius ang = promoteLocTheta $ \pt inclin -> +    let ps = bezierArcPoints ang radius inclin pt+    in liftQuery (curvePP ps) >>= dcOpenPath

@@ -212,23 +212,23 @@  -- | Decorate Image. ---decorateImage :: ZDeco -> Image u a -> Image u z -> Image u a+decorateImage :: ZOrder -> Image u a -> Image u z -> Image u a decorateImage zo ma mb = Image $ \ctx ->      step zo (getImage ma ctx) (getImage mb ctx)   where-    step SUPERIOR (a,w1) (_,w2) = (a, w1 `mappend` w2)-    step ANTERIOR (a,w1) (_,w2) = (a, w2 `mappend` w1)+    step ZABOVE (a,w1) (_,w2) = (a, w1 `mappend` w2)+    step ZBELOW (a,w1) (_,w2) = (a, w2 `mappend` w1)   -- | Elaborate Image. ---elaborateImage :: ZDeco -> Image u a -> (a -> Image u z) -> Image u a+elaborateImage :: ZOrder -> Image u a -> (a -> Image u z) -> Image u a elaborateImage zo ma k = Image $ \ ctx ->     let (a,w1) = getImage ma ctx         (_,w2) = getImage (k a) ctx      in case zo of-      SUPERIOR -> (a, w1 `mappend` w2)-      ANTERIOR -> (a, w2 `mappend` w1)+      ZABOVE -> (a, w1 `mappend` w2)+      ZBELOW -> (a, w2 `mappend` w1)   obliterateImage :: Image u a -> Image u a

@@ -13,36 +13,52 @@ -- -- /Trails/ - prototype paths. Less resource heavy than the Path -- object in Wumpus-Drawing.+-- +-- @CatTrail@ supports concatenation. @AnaTrail@ supports +-- /initial displacement/ - this can account for drawing +-- rectangles from their center, for example. -- --------------------------------------------------------------------------------  module Wumpus.Basic.Kernel.Objects.Trail   ( +  -- * Trail types     TrailSegment(..)   , CatTrail-  , PlacedTrail+  , AnaTrail -  , drawPlacedTrail-  , drawCatTrail+  -- * Trail operations+  , renderAnaTrail+  , renderCatTrail -  , destrPlacedTrail+  , destrAnaTrail   , destrCatTrail -  , placeCatTrail+  , anaCatTrail+  , modifyAna      , trailIterateLocus -  , placedTrailPoints+  , anaTrailPoints ++  , catline+  , catcurve+  , orthoCatTrail++  , diffCurve+  , diffLines+  ++  -- * Shape trails   , rectangleTrail   , diamondTrail   , polygonTrail+  , wedgeTrail  -  , catline-  , catcurve-  +  -- * Named Trail constructors   , trail_up   , trail_down   , trail_left@@ -62,7 +78,8 @@   , trail_down_left   , trail_down_right -  , orthoCatline+  , trail_para+  , trail_perp    , trail_theta_up   , trail_theta_down@@ -83,18 +100,17 @@   , trail_theta_down_left   , trail_theta_down_right +  , trail_theta_adj_grazing+  , trail_theta_bkwd_adj_grazing - -  , semicircleCW-  , semicircleCCW -  , minorCircleSweepCW-  , minorCircleSweepCCW-  , circleSweepCW-  , circleSweepCCW-  , circularArcCW-  , circularArcCCW +  , semicircleTrail+  , semiellipseTrail+  , minorCircleSweep+  , circleSweep+  , circularArc+   , sineWave   , sineWave1   , squareWave@@ -102,13 +118,12 @@   , squiggleWave   , semicircleWave -  , tricurve-  , rectcurve-  , trapcurveCW-  , trapcurveCCW-  , bowcurve-  , wedgecurve-  , loopcurve+  , triCurve+  , rectCurve+  , trapCurve+  , bowCurve+  , wedgeCurve+  , loopCurve    ) where @@ -128,19 +143,32 @@ import Data.List ( unfoldr ) import Data.Monoid -data PlacedTrail u = PlacedTrail++--------------------------------------------------------------------------------+-- Trail types ++-- | Trail with an initial (undrawn) displacement - an anacrusis.+--+-- This allows trails to represent centered objects.+--+data AnaTrail u = AnaTrail       { pt_init_vec :: Vec2 u       , pt_segments :: [TrailSegment u]       }   deriving (Eq,Ord,Show) -type instance DUnit (PlacedTrail u) = u+type instance DUnit (AnaTrail u) = u +-- | Trail supporting concatenation.+-- newtype CatTrail u = CatTrail { getCatTrail :: H (TrailSegment u) }  type instance DUnit (CatTrail u) = u  +-- | Trail segment - trails are /prototype/ paths, so the are +-- built from the usual straight lines and Bezier curves.+-- data TrailSegment u = TLine (Vec2 u)                     | TCurve (Vec2 u) (Vec2 u) (Vec2 u)   deriving (Eq,Ord,Show)@@ -159,15 +187,19 @@   ---------------------------------------------------------------------------------+-- Trail operations -drawCatTrail :: InterpretUnit u => PathMode -> CatTrail u -> LocGraphic u-drawCatTrail mode (CatTrail ct) = promoteLoc $ \pt -> +-- | Render a 'CatTrail' to make a drawable 'LocGraphic'.+--+renderCatTrail :: InterpretUnit u => PathMode -> CatTrail u -> LocGraphic u+renderCatTrail mode (CatTrail ct) = promoteLoc $ \pt ->      drawTrailBody mode (toListH ct) pt   -drawPlacedTrail :: InterpretUnit u => PathMode -> PlacedTrail u -> LocGraphic u-drawPlacedTrail mode (PlacedTrail v0 xs) = promoteLoc $ \pt -> +-- | Render an 'AnaTrail' to make a drawable 'LocGraphic'.+--+renderAnaTrail :: InterpretUnit u => PathMode -> AnaTrail u -> LocGraphic u+renderAnaTrail mode (AnaTrail v0 xs) = promoteLoc $ \pt ->      drawTrailBody mode xs (pt .+^ v0)  @@ -190,10 +222,10 @@     stepB f _   v0 ys            = stepA (f `snocH` relLineTo v0) ys  --- | /Destructor/ for the opaque 'PlacedTrail' type.+-- | /Destructor/ for the opaque 'AnaTrail' type. ---destrPlacedTrail :: PlacedTrail u -> (Vec2 u, [TrailSegment u])-destrPlacedTrail (PlacedTrail v0 ss) = (v0,ss)+destrAnaTrail :: AnaTrail u -> (Vec2 u, [TrailSegment u])+destrAnaTrail (AnaTrail v0 ss) = (v0,ss)  -- | /Destructor/ for the opaque 'CatTrail' type. --@@ -202,20 +234,22 @@   --- | Turn a 'CatTrail' into a 'PlacedTrail'.+-- | Turn a 'CatTrail' into a 'AnaTrail'. ---placeCatTrail :: Vec2 u -> CatTrail u -> PlacedTrail u-placeCatTrail vinit cat = PlacedTrail { pt_init_vec = vinit-                                      , pt_segments = getCatTrail cat []-                                      }+anaCatTrail :: Vec2 u -> CatTrail u -> AnaTrail u+anaCatTrail vinit cat = AnaTrail { pt_init_vec = vinit+                                 , pt_segments = getCatTrail cat []+                                 }  +modifyAna :: (Vec2 u -> Vec2 u) -> AnaTrail u -> AnaTrail u+modifyAna upd (AnaTrail v1 body) = AnaTrail (upd v1) body --- | Create a PlacedTrail from the vector list - each vector in the +-- | Create a AnaTrail from the vector list - each vector in the  -- input list iterates to the start point rather then the  -- cumulative tip. ----- When the PlacedTrail is run, the supplied point is the /locus/ of +-- When the AnaTrail is run, the supplied point is the /locus/ of  -- the path and it does not form part of the path proper. --  -- Like 'trailStartIsLocus', this constructor is typically used to @@ -223,16 +257,16 @@ -- iterated displacements of the center rather than  -- /turtle drawing/.  -- -trailIterateLocus :: Num u => [Vec2 u] -> PlacedTrail u-trailIterateLocus []      = PlacedTrail zeroVec []-trailIterateLocus (v0:xs) = PlacedTrail v0 (step v0 xs)+trailIterateLocus :: Num u => [Vec2 u] -> AnaTrail u+trailIterateLocus []      = AnaTrail zeroVec []+trailIterateLocus (v0:xs) = AnaTrail v0 (step v0 xs)   where     step v1 []      = [ TLine (v0 ^-^ v1) ]     step v1 (v2:vs) = TLine (v2 ^-^ v1) : step v2 vs  -placedTrailPoints :: InterpretUnit u => PlacedTrail u -> LocQuery u [Point2 u]-placedTrailPoints (PlacedTrail v0 ts) = qpromoteLoc $ \pt -> +anaTrailPoints :: InterpretUnit u => AnaTrail u -> LocQuery u [Point2 u]+anaTrailPoints (AnaTrail v0 ts) = qpromoteLoc $ \pt ->      return $ step (pt .+^ v0) ts   where     step p1 []                    = [p1]@@ -242,13 +276,59 @@                                         p4 = p3 .+^ v3                                      in p1 : p2 : p3 : step p4 xs --- | 'rectangleTrail' : @ width * height -> PlacedTrail @++catline :: Vec2 u -> CatTrail u +catline = CatTrail . wrapH . TLine+++-- | Alternative to @catline@, specifying the vector components +-- rather the vector itself. ---rectangleTrail :: Fractional u => u -> u -> PlacedTrail u+-- (cf. orthoVec from Wumpus-Core)+--+orthoCatTrail :: Floating u => u -> u -> Radian -> CatTrail u +orthoCatTrail x y ang = catline (orthoVec x y ang)+++catcurve :: Vec2 u -> Vec2 u -> Vec2 u -> CatTrail u+catcurve v1 v2 v3 = CatTrail $ wrapH $ TCurve v1 v2 v3++-- | Form a Bezier CatTrail from the vectors between four control +-- points.+--+diffCurve :: Num u +          => Point2 u -> Point2 u -> Point2 u -> Point2 u -> CatTrail u+diffCurve p0 p1 p2 p3 = +    catcurve (pvec p0 p1) (pvec p1 p2) (pvec p2 p3)++++-- | Form a CatTrail from the linear segment joining the list of +-- points.+-- +-- Some configurations of vectors seem easier to specify using +-- located points then making them coordinate free by taking +-- the joining vectors.+--+diffLines :: Num u => [Point2 u] -> CatTrail u+diffLines []     = mempty+diffLines (x:xs) = step mempty x xs +  where+    step ac a (b:bs) = step (ac `mappend` catline (pvec a b)) b bs+    step ac _ []     = ac++++--------------------------------------------------------------------------------+-- Shape Trails++-- | 'rectangleTrail' : @ width * height -> AnaTrail @+--+rectangleTrail :: Fractional u => u -> u -> AnaTrail u rectangleTrail w h = -    PlacedTrail { pt_init_vec = ctr_to_bl -                , pt_segments = map TLine spec-                }+    AnaTrail { pt_init_vec = ctr_to_bl +             , pt_segments = map TLine spec+             }   where     ctr_to_bl = vec (negate $ 0.5*w) (negate $ 0.5*h)     spec      = [ go_right w, go_up h, go_left w, go_down h ]@@ -256,9 +336,9 @@   --- | 'diamondTrail' : @ half_width * half_height -> PlacedTrail @+-- | 'diamondTrail' : @ half_width * half_height -> AnaTrail @ ---diamondTrail :: Num u => u -> u -> PlacedTrail u+diamondTrail :: Num u => u -> u -> AnaTrail u diamondTrail hw hh = trailIterateLocus [ vs,ve,vn,vw ]   where     vs = vvec (-hh)@@ -267,9 +347,9 @@     vw = hvec (-hw)  --- | 'polygonTrail' : @ num_points * radius -> PlacedTrail @ +-- | 'polygonTrail' : @ num_points * radius -> AnaTrail @  ---polygonTrail :: Floating u => Int -> u -> PlacedTrail u+polygonTrail :: Floating u => Int -> u -> AnaTrail u polygonTrail n radius = trailIterateLocus $ unfoldr phi (0,top)   where     top                     = 0.5*pi@@ -280,15 +360,24 @@   --catline :: Vec2 u -> CatTrail u -catline = CatTrail . wrapH . TLine+-- | wedgeTrail : radius * apex_angle+-- +-- Wedge is drawn at the apex.+--+wedgeTrail :: (Real u, Floating u) +           => u -> Radian -> Radian -> AnaTrail u+wedgeTrail radius ang theta = +    anaCatTrail zeroVec $ line_in `mappend` w_arc `mappend` line_out+  where+    half_ang = 0.5 * ang +    line_in  = catline $ avec (theta + half_ang)   radius+    line_out = catline $ avec (theta - half_ang) (-radius)+    w_arc    = circularArcCW ang radius (theta - half_pi)   -catcurve :: Vec2 u -> Vec2 u -> Vec2 u -> CatTrail u-catcurve v1 v2 v3 = CatTrail $ wrapH $ TCurve v1 v2 v3-+--------------------------------------------------------------------------------+-- Named Trail constructors  trail_up :: Num u => u -> CatTrail u trail_up = catline . go_up@@ -342,13 +431,13 @@ trail_down_right = catline . go_down_right  --- | Alternative to @catline@, specifying the vector components --- rather the vector itself.----orthoCatline :: Floating u => u -> u -> Radian -> CatTrail u -orthoCatline x y ang = catline (orthoVec x y ang)+trail_perp :: Floating u => u -> Radian -> CatTrail u+trail_perp = trail_theta_up +trail_para :: Floating u => u -> Radian -> CatTrail u+trail_para = trail_theta_right + trail_theta_up :: Floating u => u -> Radian -> CatTrail u trail_theta_up u = catline . theta_up u @@ -402,6 +491,37 @@   +-- | Return the line @a-o@ when supplied length of @b-o@ and the +-- grazing angle @boa@:+--+-- >    a+-- >    .\+-- >    . \+-- >  ..b..o+--+-- This is useful for building arrowhead vectors.+--+trail_theta_adj_grazing :: Floating u => u -> Radian -> Radian -> CatTrail u +trail_theta_adj_grazing adj_len ang = +    catline . theta_adj_grazing adj_len ang+++-- | Return the line @o-c@ when supplied length of @b-o@ and the +-- grazing angle @boc@:+--+--+-- >  ..b..o+-- >    . /+-- >    ./+-- >    c+--+-- This is useful for building arrowhead vectors.+--+trail_theta_bkwd_adj_grazing :: Floating u => u -> Radian -> Radian -> CatTrail u +trail_theta_bkwd_adj_grazing adj_len ang = +    catline . theta_bkwd_adj_grazing adj_len ang ++ --------------------------------------------------------------------------------  --@@ -448,12 +568,30 @@ kappa = 4 * ((sqrt 2 - 1) / 3)  --- DESIGN NOTE - different functions for CW and CCW or same --- function with @ClockDirection@ as first argument?+--+-- DESIGN NOTE +--+-- The API seems better exposing ClockDirection as an argument +-- rather than providing two different functions for CW and CCW +-- (even though some functions are defined by independent CW and +-- CCW versions).+--   -- | 'semicircleCW' : @ base_vector -> CatTrail @  -- +-- Make an open semicircle from two Bezier curves. +--+-- Although this function produces an approximation of a +-- semicircle, the approximation seems fine in practice.+--+semicircleTrail :: (Real u, Floating u) +                => ClockDirection -> Vec2 u -> CatTrail u+semicircleTrail CW = semicircleCW+semicircleTrail _  = semicircleCCW++-- | 'semicircleCW' : @ base_vector -> CatTrail @ +--  -- Make a clockwise semicircle from two Bezier curves. Although  -- this function produces an approximation of a semicircle, the  -- approximation seems fine in practice.@@ -502,8 +640,57 @@     v6      = orthoVec circum 0 ang  +-- | 'semicircleTrail' : @ clock_direction * ry * base_vector -> CatTrail @ +-- +-- Make an open semiellipse from two Bezier curves. +--+-- Although this function produces an approximation of a +-- semiellipse, the approximation seems fine in practice.+--+semiellipseTrail :: (Real u, Floating u) +               => ClockDirection -> u -> Vec2 u -> CatTrail u+semiellipseTrail CW = semiellipseBasis theta_up+semiellipseTrail _  = semiellipseBasis theta_down  ++-- | theta_up for CW, theta_down for CCW...+--+semiellipseBasis :: (Real u, Floating u) +                 => (u -> Radian -> Vec2 u) -> u -> Vec2 u -> CatTrail u+semiellipseBasis perpfun ry base_vec = +              catcurve (pvec p00 c01) (pvec c01 c02) (pvec c02 p03)+    `mappend` catcurve (pvec p03 c04) (pvec c04 c05) (pvec c05 p06) +  where+    rx    = 0.5 * vlength base_vec+    ang   = vdirection base_vec+    lrx   = rx * kappa+    lry   = ry * kappa+    para  = theta_right `flip` ang+    perp  = perpfun `flip` ang++    p00   = zeroPt .+^ theta_left rx ang+    c01   = p00 .+^ perp lry+    c02   = p03 .+^ para (-lrx)++    p03   = zeroPt .+^ perpfun ry ang  +    c04   = p03 .+^ para lrx+    c05   = p06 .+^ perp lry++    p06   = zeroPt .+^ theta_right rx ang+++-- | 'minorCircleSweep' : @ clock_direction * angle * radius +--      * inclination -> CatTrail @+--+-- > ang should be in the range 0 < ang <= 90deg.+--+minorCircleSweep :: (Real u, Floating u)+                 => ClockDirection -> Radian -> u -> Radian -> CatTrail u+minorCircleSweep CW = minorCircleSweepCW +minorCircleSweep _  = minorCircleSweepCCW++ -- | 'minorCircleSweepCW' : @ angle * radius * inclination -> CatTrail @ -- -- > ang should be in the range 0 < ang <= 90deg.@@ -542,7 +729,22 @@     p3      = displace (avec totang radius) zeroPt  +-- | 'circleSweep' : @ clock_direction * apex_angle * radius +--      * inclination -> CatTrail @+--+-- > ang should be in the range 0 < ang < 360deg.+--+-- > if   0 < ang <=  90 returns 1 segment+-- > if  90 < ang <= 180 returns 2 segments+-- > if 180 < ang <= 270 returns 3 segments+-- > if 270 < ang <  360 returns 4 segmenets+--+circleSweep :: (Real u, Floating u)+            => ClockDirection -> Radian -> u -> Radian -> CatTrail u+circleSweep CW = circleSweepCW+circleSweep _  = circleSweepCCW + -- | 'circleSweepCW' : @ apex_angle * radius * inclination -> CatTrail @ -- -- > ang should be in the range 0 < ang < 360deg.@@ -610,7 +812,12 @@                `mappend` minorCircleSweepCCW a radius (theta+a+a)                `mappend` minorCircleSweepCCW a radius (theta+a+a+a) +circularArc :: (Real u, Floating u) +            => ClockDirection -> Radian -> u -> Radian -> CatTrail u +circularArc CW = circularArcCW+circularArc _  = circularArcCCW + -- | inclination is the inclination of the chord. -- circularArcCW :: (Real u, Floating u) => Radian -> u -> Radian -> CatTrail u @@ -710,54 +917,89 @@  -------------------------------------------------------------------------------- +-- | 'triCurve' : @ clock_direction * base_width * height * +--      base_inclination -> CatTrail @+-- +-- Curve in a triangle - base_width and height are expected to +-- be positive.+-- +triCurve :: Floating u => ClockDirection -> u -> u -> Radian -> CatTrail u+triCurve CW  bw h ang = ctriCW bw h ang+triCurve CCW bw h ang = ctriCW bw (-h) ang   -- | Curve in a triangle. -- -tricurve :: Floating u => u -> u -> Radian -> CatTrail u-tricurve bw h ang = catcurve v1 zeroVec v2+ctriCW :: Floating u => u -> u -> Radian -> CatTrail u+ctriCW bw h ang = catcurve v1 zeroVec v2   where     v1 = orthoVec (0.5 * bw) h ang     v2 = orthoVec (0.5 * bw) (-h) ang  +-- | 'rectCurve' : @ clock_direction * base_width * height * +--      base_inclination -> CatTrail @+-- +-- Curve in a rectangle.+-- +rectCurve :: Floating u => ClockDirection -> u -> u -> Radian -> CatTrail u+rectCurve CW  bw h ang = crectCW bw h ang+rectCurve CCW bw h ang = crectCW bw (-h) ang + -- | Curve in a rectangle. -- -rectcurve :: Floating u => u -> u -> Radian -> CatTrail u-rectcurve bw h ang = catcurve v1 v2 v3+crectCW :: Floating u => u -> u -> Radian -> CatTrail u+crectCW bw h ang = catcurve v1 v2 v3   where     v1 = orthoVec 0    h  ang     v2 = orthoVec bw   0  ang     v3 = orthoVec 0  (-h) ang +++-- | Curve in a trapezium.+-- +trapCurve :: Floating u +          => ClockDirection -> u -> u -> Radian -> Radian -> CatTrail u+trapCurve CW  = ctrapCW+trapCurve CCW = ctrapCCW+ -- | Curve in a trapezium (CW). -- -trapcurveCW :: Floating u => u -> u -> Radian -> Radian -> CatTrail u-trapcurveCW bw h interior_ang ang = catcurve v1 v2 v3+-- h must be positive.+--+ctrapCW :: Floating u => u -> u -> Radian -> Radian -> CatTrail u+ctrapCW bw h interior_ang ang = catcurve v1 v2 v3   where     minor_bw = h / (fromRadian $ tan interior_ang)     v1       = orthoVec minor_bw                h  ang     v2       = orthoVec (bw - (2 * minor_bw))   0  ang     v3       = orthoVec minor_bw              (-h) ang -- -- | Curve in a trapezium (CCW). -- -trapcurveCCW :: Floating u => u -> u -> Radian -> Radian -> CatTrail u-trapcurveCCW bw h interior_ang ang = catcurve v1 v2 v3+-- h must be positive.+--+ctrapCCW :: Floating u => u -> u -> Radian -> Radian -> CatTrail u+ctrapCCW bw h interior_ang ang = catcurve v1 v2 v3   where     minor_bw = h / (fromRadian $ tan interior_ang)     v1       = orthoVec minor_bw              (-h)  ang     v2       = orthoVec (bw - (2 * minor_bw))   0  ang     v3       = orthoVec minor_bw                h ang +-- | Curve in half a /bowtie/.+-- +bowCurve :: Floating u +         => ClockDirection -> u -> u -> Radian -> CatTrail u+bowCurve CW  bw h ang = cbowCW bw h ang+bowCurve CCW bw h ang = cbowCW bw (-h) ang  -- | Curve in half a /bowtie/. -- -bowcurve :: Floating u => u -> u -> Radian -> CatTrail u-bowcurve bw h ang = catcurve v1 v2 v3+cbowCW :: Floating u => u -> u -> Radian -> CatTrail u+cbowCW bw h ang = catcurve v1 v2 v3   where     v1 = orthoVec 0    h  ang     v2 = orthoVec bw (-h)  ang@@ -766,8 +1008,15 @@  -- | Wedge curve formed inside a bowtie rotated by 90deg. -- -wedgecurve :: Floating u => u -> u -> Radian -> CatTrail u-wedgecurve bw h ang = catcurve v1 v2 v3+wedgeCurve :: Floating u +           => ClockDirection -> u -> u -> Radian -> CatTrail u+wedgeCurve CW  bw h ang = cwedgeCW bw h ang+wedgeCurve CCW bw h ang = cwedgeCW bw (-h) ang++-- | Wedge curve clockwise.+-- +cwedgeCW :: Floating u => u -> u -> Radian -> CatTrail u+cwedgeCW bw h ang = catcurve v1 v2 v3   where     v1 = orthoVec   bw    h  ang     v2 = orthoVec (-bw)   0  ang@@ -776,8 +1025,16 @@  -- | Variation of wedge curve that draws a loop. -- -loopcurve :: Floating u => u -> u -> Radian -> CatTrail u-loopcurve bw h ang = catcurve v1 v2 v3+loopCurve :: Floating u +          => ClockDirection -> u -> u -> Radian -> CatTrail u+loopCurve CW  bw h ang = cloopCW bw h ang+loopCurve CCW bw h ang = cloopCW bw (-h) ang+++-- | loop curve clockwise.+-- +cloopCW :: Floating u => u -> u -> Radian -> CatTrail u+cloopCW bw h ang = catcurve v1 v2 v3   where     ww = 2.0 * bw      v1 = orthoVec  (1.5 * bw)    h  ang

@@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Basic.System.FontLoader--- Copyright   :  (c) Stephen Tetley 2011+-- Copyright   :  (c) Stephen Tetley 2011-2012 -- License     :  BSD3 -- -- Maintainer  :  stephen.tetley@gmail.com@@ -30,8 +30,9 @@ import Wumpus.Basic.System.FontLoader.GSTopLevel  import Control.Monad+import Control.Exception ( try ) import System.Environment-import System.IO.Error+-- import System.IO.Error   @@ -105,6 +106,7 @@ envLookup :: String -> IO (Maybe String) envLookup name = liftM fn $ try $ getEnv name   where+    fn :: Either IOError String -> Maybe String     fn (Left _)  = Nothing     fn (Right a) = Just a 

@@ -1,430 +0,0 @@-{-# OPTIONS -Wall #-}------------------------------------------------------------------------------------- |--- Module      :  Wumpus.Basic.Utils.FormatCombinators--- Copyright   :  (c) Stephen Tetley 2010--- License     :  BSD3------ Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>--- Stability   :  highly unstable--- Portability :  GHC------ Formatting combinators - pretty printers without the fitting.------ Note - indentation support is very limited. Generally one --- should use a proper pretty printing library.--- -----------------------------------------------------------------------------------module Wumpus.Basic.Utils.FormatCombinators-  (-    Doc-  , DocS-  , Format(..)-  , empty-  , showsDoc-  , (<>)-  , (<+>)  -  , vconcat-  , separate-  , hcat-  , hsep-  , vcat--  , text-  , char-  , int-  , integer-  , integral-  , float-  , double-  , hex4--  , space-  , comma-  , semicolon-  , line--  , fill-  , fillStringR-  , fillStringL--  , punctuate-  , enclose-  , squotes-  , dquotes-  , parens-  , brackets-  , braces-  , angles--  , lparen-  , rparen-  , lbracket-  , rbracket-  , lbrace-  , rbrace-  , langle-  , rangle--  , list-  , tupled-  , semiBraces--  , indent--  , writeDoc-    -  ) where--import Data.Monoid-import Numeric---- | Doc is a Join List ...----data Doc = Doc1   ShowS -         | Join   Doc   Doc-         | Line-         | Indent !Int  Doc ---type DocS = Doc -> Doc----- Join could be improved...----unDoc :: Doc -> ShowS-unDoc = step 0 id-  where-   step _ acc (Doc1 sf)    = acc . sf-   step n acc (Join a b)   = let acc' = step n acc a in step n acc' b-   step n acc Line         = acc . showChar '\n' . indentS n-   step n acc (Indent i d) = step (n+i) (acc . (indentS i)) d---indentS :: Int -> ShowS-indentS i | i < 1     = id-          | otherwise = showString $ replicate i ' '--runDoc :: Doc -> String-runDoc = ($ "") . unDoc---instance Show Doc where-  show = runDoc--instance Monoid Doc where-  mempty = empty-  mappend = (<>)---class Format a where format :: a -> Doc-----------------------------------------------------------------------------------        -infixr 6 <>, <+>------ | Create an empty, zero length document.----empty :: Doc-empty = Doc1 id---- | Create a document from a ShowS function.----showsDoc :: ShowS -> Doc-showsDoc = Doc1----- | Horizontally concatenate two documents with no space --- between them.--- -(<>) :: Doc -> Doc -> Doc-a <> b = Join a b ----- | Horizontally concatenate two documents with a single space --- between them.--- -(<+>) :: Doc -> Doc -> Doc-a <+> b = Join a (Join space b)---- | Vertical concatenate two documents with a line break.--- -vconcat :: Doc -> Doc -> Doc-vconcat a b = a <> Line <> b----separate :: Doc -> [Doc] -> Doc-separate _   []     = empty-separate sep (a:as) = step a as-  where-    step acc []     = acc-    step acc (x:xs) = step (acc <> sep <> x) xs---- | Horizontally concatenate a list of documents with @(\<\>)@.----hcat :: [Doc] -> Doc-hcat = foldr (<>) empty---- | Horizontally concatenate a list of documents with @(\<+\>)@.----hsep :: [Doc] -> Doc-hsep = separate space---- | Vertically concatenate a list of documents, with a line --- break between each doc.----vcat :: [Doc] -> Doc-vcat []     = empty-vcat (x:xs) = step x xs -  where-    step acc (z:zs) = step (acc `vconcat` z) zs-    step acc []     = acc---- | Create a document from a literal string.--- --- The string should not contain newlines (though this is not --- enforced). ----text :: String -> Doc-text = Doc1 . showString----- | Create a document from a literal character.------ The char should not be a tab or newline. ----char :: Char -> Doc-char = Doc1 . showChar---- | Show the Int as a Doc.------ > int  = text . show----int :: Int -> Doc-int  = Doc1 . showInt---- | Show the Integer as a Doc.----integer :: Integer -> Doc-integer = Doc1 . showInt---- | Show an \"integral value\" as a Doc via 'fromIntegral'.----integral :: Integral a => a -> Doc-integral = Doc1 . showInt---- | Show the Float as a Doc.----float :: Double -> Doc-float = Doc1 . showFloat---- | Show the Double as a Doc.----double :: Double -> Doc-double = Doc1 . showFloat---- | Show the Int as hexadecimal, padding up to 4 digits if --- necessary.------ No trucation occurs if the value has more than 4 digits.----hex4 :: Int -> Doc-hex4 n | n < 0x0010 = text "000" <> showsDoc (showHex n)-       | n < 0x0100 = text "00"  <> showsDoc (showHex n)-       | n < 0x1000 = text "0"   <> showsDoc (showHex n)-       | otherwise  = showsDoc (showHex n)- --- | Create a Doc containing a single space character.----space :: Doc-space = char ' '---- | Create a Doc containing a comma, \",\".----comma :: Doc-comma = char ','---- | Create a Doc containing a semi colon, \";\".----semicolon :: Doc-semicolon = char ';'---- | Create a Doc containing newline, \"\\n\".----line :: Doc -line = char '\n'--------------------------------------------------------------------------------------- | Fill a doc to the supplied length, padding the right-hand--- side with spaces.------ Note - this function is expensive - it unrolls the functional--- representation of the String. --- --- Also it should only be used for single line Doc\'s.--- -fill :: Int -> Doc -> Doc-fill i d = Doc1 (padr i ' ' $ unDoc d) --padr :: Int -> Char -> ShowS -> ShowS-padr i c df = step (length $ df []) -  where-    step len | len >= i  = df-             | otherwise = df . showString (replicate (i-len) c)---- | String version of 'fill'.------ This is more efficient than 'fill' as the input is a string--- so its length is more accesible.------ Padding is the space character appended to the right.--- -fillStringR :: Int -> String -> Doc-fillStringR i s = step (length s)-  where-    step n | n >= i = text s-    step n          = text s <> text (replicate (i-n) ' ')---- | Left-padding version of 'fillStringR'.----fillStringL :: Int -> String -> Doc-fillStringL i s = step (length s)-  where-    step n | n >= i = text s-    step n          = text (replicate (i-n) ' ') <> text s-------------------------------------------------------------------------------------- | Punctuate the Doc list with the separator, producing a Doc. ----punctuate :: Doc -> [Doc] -> Doc-punctuate _ []     = empty-punctuate _ [x]    = x-punctuate s (x:xs) = x <> s <> punctuate s xs----- | Enclose the final Doc within the first two.------ There are no spaces between the documents:------ > enclose l r d = l <> d <> r----enclose :: Doc -> Doc -> Doc -> Doc-enclose l r d = l <> d <> r------ | Enclose the Doc within single quotes.----squotes :: Doc -> Doc-squotes = enclose (char '\'') (char '\'')---- | Enclose the Doc within double quotes.----dquotes :: Doc -> Doc-dquotes = enclose (char '"') (char '"')---- | Enclose the Doc within parens @()@.----parens :: Doc -> Doc-parens = enclose lparen rparen---- | Enclose the Doc within square brackets @[]@.----brackets :: Doc -> Doc-brackets = enclose lbracket rbracket---- | Enclose the Doc within curly braces @{}@.----braces :: Doc -> Doc-braces = enclose lbrace rbrace---- | Enclose the Doc within angle brackets @\<\>@.----angles :: Doc -> Doc-angles = enclose langle rangle------ | Create a Doc containing a left paren, \'(\'.----lparen :: Doc-lparen = char '('---- | Create a Doc containing a right paren, \')\'.----rparen :: Doc-rparen = char ')'---- | Create a Doc containing a left square bracket, \'[\'.----lbracket :: Doc-lbracket = char '['---- | Create a Doc containing a right square bracket, \']\'.----rbracket :: Doc-rbracket = char ']'---- | Create a Doc containing a left curly brace, \'{\'.----lbrace :: Doc-lbrace = char '{'---- | Create a Doc containing a right curly brace, \'}\'.----rbrace :: Doc-rbrace = char '}'---- | Create a Doc containing a left angle bracket, \'\<\'.----langle :: Doc-langle = char '<'---- | Create a Doc containing a right angle bracket, \'\>\'.----rangle :: Doc-rangle = char '>'---- | Comma separate the list of documents and enclose in square--- brackets.----list :: [Doc] -> Doc-list = brackets . punctuate comma---- | Comma separate the list of documents and enclose in parens.----tupled :: [Doc] -> Doc-tupled = parens . punctuate comma---- | Separate the list with a semicolon and enclose in curly --- braces.----semiBraces :: [Doc] -> Doc-semiBraces = braces . punctuate semicolon----- | Horizontally indent a Doc.------ Note - this space-prefixes the Doc on /the current line/. It--- does not indent subsequent lines if the Doc spans multiple --- lines.----indent :: Int -> Doc -> Doc-indent i d | i < 1     = d-           | otherwise = Indent i d--------------------------------------------------------------------------------------- | Write a Doc to file.----writeDoc :: FilePath -> Doc -> IO ()-writeDoc filepath d = writeFile filepath $ show d 

@@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module      :  Wumpus.Basic.VersionNumber--- Copyright   :  (c) Stephen Tetley 2010-2011+-- Copyright   :  (c) Stephen Tetley 2010-2012 -- License     :  BSD3 -- -- Maintainer  :  stephen.tetley@gmail.com@@ -23,7 +23,7 @@  -- | Version number ----- > (0,22,0)+-- > (0,24,0) -- wumpus_basic_version :: (Int,Int,Int)-wumpus_basic_version = (0,22,0)+wumpus_basic_version = (0,24,0)

@@ -1,5 +1,5 @@ name:             wumpus-basic-version:          0.22.0+version:          0.24.0 license:          BSD3 license-file:     LICENSE copyright:        Stephen Tetley <stephen.tetley@gmail.com>@@ -29,7 +29,33 @@   .   .   Changelog:+  . +  v0.23.0 to v0.24.0:   .+  * Changes to type funs to work with GHC 7.4.+  . +  * Removed FormatCombinators module.+  .+  v0.22.0 to v0.23.0:+  .+  * Re-worked the Chain module and API.+  .+  * Replaced @ZDeco@ enumeration with @ZOrder@.+  .+  * Removed the @Basic.Geometry@ modules, they are superseded in +    Wumpus-Drawing. Some of the equivalent functionality is now+    internal to the respective modules in Wumpus-Drawing - Wumpus+    has scaled back the amount of /geometric/ types and operations+    it wants to expose.  +  .+  * Renamed the @PlacedTrail@ object to @AnaTrail@ - the prefix +    vector is considered an /anacrusis/. Tidied up the API of the +    @Trail@ module.+  .+  * Moved @bezierArcPoints@ and @BezierMinorArc@ from +    @Basic.Geometry@ and marked the @Basic.Geometry@ code as +    obsolute.+  .   v0.21.0 to v0.22.0:   .   * Reverted argument order of @run@ functions they back to the @@ -96,12 +122,6 @@       exposed-modules:-    Wumpus.Basic.Geometry,-    Wumpus.Basic.Geometry.Base,-    Wumpus.Basic.Geometry.Illustrate,-    Wumpus.Basic.Geometry.Intersection,-    Wumpus.Basic.Geometry.Quadrant,-    Wumpus.Basic.Geometry.Vertices,     Wumpus.Basic.Kernel,     Wumpus.Basic.Kernel.Base.BaseDefs,     Wumpus.Basic.Kernel.Base.DrawingContext,@@ -139,7 +159,6 @@     Wumpus.Basic.System.FontLoader.FontLoadMonad,     Wumpus.Basic.System.FontLoader.GSTopLevel,     Wumpus.Basic.Utils.HList,-    Wumpus.Basic.Utils.FormatCombinators,     Wumpus.Basic.Utils.JoinList,     Wumpus.Basic.Utils.ParserCombinators,     Wumpus.Basic.Utils.TokenParsers,