diff --git a/src/Wumpus/Basic/Geometry.hs b/src/Wumpus/Basic/Geometry.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Geometry.hs +++ /dev/null @@ -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 diff --git a/src/Wumpus/Basic/Geometry/Base.hs b/src/Wumpus/Basic/Geometry/Base.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Geometry/Base.hs +++ /dev/null @@ -1,494 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Geometry.Base --- Copyright : (c) Stephen Tetley 2011 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- 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... - - diff --git a/src/Wumpus/Basic/Geometry/Illustrate.hs b/src/Wumpus/Basic/Geometry/Illustrate.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Geometry/Illustrate.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Geometry.Illustrate --- Copyright : (c) Stephen Tetley 2011 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- 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 diff --git a/src/Wumpus/Basic/Geometry/Intersection.hs b/src/Wumpus/Basic/Geometry/Intersection.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Geometry/Intersection.hs +++ /dev/null @@ -1,201 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Geometry.Intersection --- Copyright : (c) Stephen Tetley 2011 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- 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 - - - diff --git a/src/Wumpus/Basic/Geometry/Quadrant.hs b/src/Wumpus/Basic/Geometry/Quadrant.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Geometry/Quadrant.hs +++ /dev/null @@ -1,601 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Geometry.Quadrant --- Copyright : (c) Stephen Tetley 2011 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- 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) diff --git a/src/Wumpus/Basic/Geometry/Vertices.hs b/src/Wumpus/Basic/Geometry/Vertices.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Geometry/Vertices.hs +++ /dev/null @@ -1,142 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Drawing.Basic.Vertices --- Copyright : (c) Stephen Tetley 2011 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- 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 - diff --git a/src/Wumpus/Basic/Kernel.hs b/src/Wumpus/Basic/Kernel.hs --- a/src/Wumpus/Basic/Kernel.hs +++ b/src/Wumpus/Basic/Kernel.hs @@ -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@. -- -------------------------------------------------------------------------------- diff --git a/src/Wumpus/Basic/Kernel/Base/BaseDefs.hs b/src/Wumpus/Basic/Kernel/Base/BaseDefs.hs --- a/src/Wumpus/Basic/Kernel/Base/BaseDefs.hs +++ b/src/Wumpus/Basic/Kernel/Base/BaseDefs.hs @@ -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 diff --git a/src/Wumpus/Basic/Kernel/Base/Units.hs b/src/Wumpus/Basic/Kernel/Base/Units.hs --- a/src/Wumpus/Basic/Kernel/Base/Units.hs +++ b/src/Wumpus/Basic/Kernel/Base/Units.hs @@ -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 diff --git a/src/Wumpus/Basic/Kernel/Drawing/Basis.hs b/src/Wumpus/Basic/Kernel/Drawing/Basis.hs --- a/src/Wumpus/Basic/Kernel/Drawing/Basis.hs +++ b/src/Wumpus/Basic/Kernel/Drawing/Basis.hs @@ -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 () diff --git a/src/Wumpus/Basic/Kernel/Drawing/Chain.hs b/src/Wumpus/Basic/Kernel/Drawing/Chain.hs --- a/src/Wumpus/Basic/Kernel/Drawing/Chain.hs +++ b/src/Wumpus/Basic/Kernel/Drawing/Chain.hs @@ -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... + + + diff --git a/src/Wumpus/Basic/Kernel/Drawing/LocDrawing.hs b/src/Wumpus/Basic/Kernel/Drawing/LocDrawing.hs --- a/src/Wumpus/Basic/Kernel/Drawing/LocDrawing.hs +++ b/src/Wumpus/Basic/Kernel/Drawing/LocDrawing.hs @@ -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 diff --git a/src/Wumpus/Basic/Kernel/Drawing/LocTrace.hs b/src/Wumpus/Basic/Kernel/Drawing/LocTrace.hs --- a/src/Wumpus/Basic/Kernel/Drawing/LocTrace.hs +++ b/src/Wumpus/Basic/Kernel/Drawing/LocTrace.hs @@ -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 diff --git a/src/Wumpus/Basic/Kernel/Drawing/PosObject.hs b/src/Wumpus/Basic/Kernel/Drawing/PosObject.hs --- a/src/Wumpus/Basic/Kernel/Drawing/PosObject.hs +++ b/src/Wumpus/Basic/Kernel/Drawing/PosObject.hs @@ -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 diff --git a/src/Wumpus/Basic/Kernel/Drawing/TraceDrawing.hs b/src/Wumpus/Basic/Kernel/Drawing/TraceDrawing.hs --- a/src/Wumpus/Basic/Kernel/Drawing/TraceDrawing.hs +++ b/src/Wumpus/Basic/Kernel/Drawing/TraceDrawing.hs @@ -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 diff --git a/src/Wumpus/Basic/Kernel/Objects/Basis.hs b/src/Wumpus/Basic/Kernel/Objects/Basis.hs --- a/src/Wumpus/Basic/Kernel/Objects/Basis.hs +++ b/src/Wumpus/Basic/Kernel/Objects/Basis.hs @@ -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 diff --git a/src/Wumpus/Basic/Kernel/Objects/Bounded.hs b/src/Wumpus/Basic/Kernel/Objects/Bounded.hs --- a/src/Wumpus/Basic/Kernel/Objects/Bounded.hs +++ b/src/Wumpus/Basic/Kernel/Objects/Bounded.hs @@ -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 diff --git a/src/Wumpus/Basic/Kernel/Objects/Displacement.hs b/src/Wumpus/Basic/Kernel/Objects/Displacement.hs --- a/src/Wumpus/Basic/Kernel/Objects/Displacement.hs +++ b/src/Wumpus/Basic/Kernel/Objects/Displacement.hs @@ -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) --} + diff --git a/src/Wumpus/Basic/Kernel/Objects/DrawingPrimitives.hs b/src/Wumpus/Basic/Kernel/Objects/DrawingPrimitives.hs --- a/src/Wumpus/Basic/Kernel/Objects/DrawingPrimitives.hs +++ b/src/Wumpus/Basic/Kernel/Objects/DrawingPrimitives.hs @@ -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 diff --git a/src/Wumpus/Basic/Kernel/Objects/Image.hs b/src/Wumpus/Basic/Kernel/Objects/Image.hs --- a/src/Wumpus/Basic/Kernel/Objects/Image.hs +++ b/src/Wumpus/Basic/Kernel/Objects/Image.hs @@ -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 diff --git a/src/Wumpus/Basic/Kernel/Objects/Trail.hs b/src/Wumpus/Basic/Kernel/Objects/Trail.hs --- a/src/Wumpus/Basic/Kernel/Objects/Trail.hs +++ b/src/Wumpus/Basic/Kernel/Objects/Trail.hs @@ -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 diff --git a/src/Wumpus/Basic/System/FontLoader.hs b/src/Wumpus/Basic/System/FontLoader.hs --- a/src/Wumpus/Basic/System/FontLoader.hs +++ b/src/Wumpus/Basic/System/FontLoader.hs @@ -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 diff --git a/src/Wumpus/Basic/Utils/FormatCombinators.hs b/src/Wumpus/Basic/Utils/FormatCombinators.hs deleted file mode 100644 --- a/src/Wumpus/Basic/Utils/FormatCombinators.hs +++ /dev/null @@ -1,430 +0,0 @@ -{-# OPTIONS -Wall #-} - --------------------------------------------------------------------------------- --- | --- Module : Wumpus.Basic.Utils.FormatCombinators --- Copyright : (c) Stephen Tetley 2010 --- License : BSD3 --- --- Maintainer : Stephen Tetley --- 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 diff --git a/src/Wumpus/Basic/VersionNumber.hs b/src/Wumpus/Basic/VersionNumber.hs --- a/src/Wumpus/Basic/VersionNumber.hs +++ b/src/Wumpus/Basic/VersionNumber.hs @@ -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) diff --git a/wumpus-basic.cabal b/wumpus-basic.cabal --- a/wumpus-basic.cabal +++ b/wumpus-basic.cabal @@ -1,5 +1,5 @@ name: wumpus-basic -version: 0.22.0 +version: 0.24.0 license: BSD3 license-file: LICENSE copyright: Stephen Tetley @@ -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,