{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Drawing.Dots.AnchorDots -- Copyright : (c) Stephen Tetley 2010-2011 -- License : BSD3 -- -- Maintainer : Stephen Tetley -- Stability : highly unstable -- Portability : GHC -- -- Dots with anchors. -- -- In many cases a surrounding circle is used to locate anchor -- points - this could be improved to use the actual dot border -- at some point. -- -------------------------------------------------------------------------------- module Wumpus.Drawing.Dots.AnchorDots ( -- * Existential anchor type DotAnchor , DotLocImage , DDotLocImage -- * Dots with anchor points , dotChar , dotText , dotHLine , dotVLine , dotX , dotPlus , dotCross , dotDiamond , dotFDiamond , dotDisk , dotSquare , dotCircle , dotPentagon , dotStar , dotAsterisk , dotOPlus , dotOCross , dotFOCross , dotTriangle ) where import Wumpus.Drawing.Dots.Marks import Wumpus.Drawing.Text.Base.RotTextZero import Wumpus.Basic.Geometry.Base -- package: wumpus-basic import Wumpus.Basic.Geometry.Intersection import Wumpus.Basic.Geometry.Paths import Wumpus.Basic.Geometry.Quadrant import Wumpus.Basic.Kernel import Wumpus.Core -- package: wumpus-core import Data.AffineSpace -- package: vector-space import Control.Applicative -- An existential thing that supports anchors. -- This means any dot can retun the same (opaque) structure -- -- But it does mean that which anchor class are supported is -- fixed - the datatype needs a field for each one. -- Supporting north, southeast etc. will also be tedious... -- data DotAnchor u = forall s. DotAnchor { center_anchor :: Point2 u , radial_anchor :: Radian -> Point2 u , cardinal_anchor :: Cardinal -> Point2 u } type instance DUnit (DotAnchor u) = u instance CenterAnchor (DotAnchor u) where center (DotAnchor ca _ _) = ca instance RadialAnchor (DotAnchor u) where radialAnchor theta (DotAnchor _ ra _) = ra theta instance CardinalAnchor (DotAnchor u) where north (DotAnchor _ _ c1) = c1 NORTH south (DotAnchor _ _ c1) = c1 SOUTH east (DotAnchor _ _ c1) = c1 EAST west (DotAnchor _ _ c1) = c1 WEST instance CardinalAnchor2 (DotAnchor u) where northeast (DotAnchor _ _ c1) = c1 NORTH_EAST southeast (DotAnchor _ _ c1) = c1 SOUTH_EAST southwest (DotAnchor _ _ c1) = c1 SOUTH_WEST northwest (DotAnchor _ _ c1) = c1 NORTH_WEST radialCardinal :: Floating u => u -> Point2 u -> Cardinal -> Point2 u radialCardinal rad ctr NORTH = ctr .+^ (avec (pi/2) rad) radialCardinal rad ctr NORTH_EAST = ctr .+^ (avec (pi/4) rad) radialCardinal rad ctr EAST = ctr .+^ (avec 0 rad) radialCardinal rad ctr SOUTH_EAST = ctr .+^ (avec (7/4 * pi) rad) radialCardinal rad ctr SOUTH = ctr .+^ (avec (6/4 * pi) rad) radialCardinal rad ctr SOUTH_WEST = ctr .+^ (avec (5/4 * pi) rad) radialCardinal rad ctr WEST = ctr .+^ (avec pi rad) radialCardinal rad ctr NORTH_WEST = ctr .+^ (avec (3/4 * pi) rad) -- Rectangle cardinal points are at \"middles and corners\". -- rectCardinal :: Floating u => u -> u -> Point2 u -> Cardinal -> Point2 u rectCardinal _ hh ctr NORTH = ctr .+^ (vvec hh) rectCardinal hw hh ctr NORTH_EAST = ctr .+^ (vec hw hh) rectCardinal hw _ ctr EAST = ctr .+^ (hvec hw) rectCardinal hw hh ctr SOUTH_EAST = ctr .+^ (vec hw (-hh)) rectCardinal _ hh ctr SOUTH = ctr .+^ (vvec (-hh)) rectCardinal hw hh ctr SOUTH_WEST = ctr .+^ (vec (-hw) (-hh) ) rectCardinal hw _ ctr WEST = ctr .+^ (hvec (-hw)) rectCardinal hw hh ctr NORTH_WEST = ctr .+^ (vec (-hw) hh) polyCardinal :: Floating u => (Radian -> Point2 u) -> Cardinal -> Point2 u polyCardinal f NORTH = f (0.5 * pi) polyCardinal f NORTH_EAST = f (0.25 * pi) polyCardinal f EAST = f 0 polyCardinal f SOUTH_EAST = f (1.75 * pi) polyCardinal f SOUTH = f (1.5 * pi) polyCardinal f SOUTH_WEST = f (1.25 * pi) polyCardinal f WEST = f pi polyCardinal f NORTH_WEST = f (0.75 * pi) rectangleAnchor :: (Real u, Floating u) => u -> u -> Point2 u -> DotAnchor u rectangleAnchor hw hh ctr = DotAnchor { center_anchor = ctr , radial_anchor = fn , cardinal_anchor = rectCardinal hw hh ctr } where fn theta = displaceVec (rectRadialVector hw hh theta) ctr polygonAnchor :: (Real u, Floating u, InterpretUnit u, Tolerance u) => [Point2 u] -> Point2 u -> DotAnchor u polygonAnchor ps ctr = DotAnchor { center_anchor = ctr , radial_anchor = fn , cardinal_anchor = polyCardinal fn } where fn theta = maybe ctr id $ findIntersect ctr theta $ polygonLineSegments ps bboxRectAnchor :: (Real u, Floating u) => BoundingBox u -> DotAnchor u bboxRectAnchor (BBox bl@(P2 x1 y1) (P2 x2 y2)) = let hw = 0.5 * (x2 - x1) hh = 0.5 * (y2 - y1) in rectangleAnchor hw hh (bl .+^ vec hw hh) rectangleLDO :: (Real u, Floating u) => u -> u -> LocQuery u (DotAnchor u) rectangleLDO w h = promoteR1 $ \pt -> pure $ rectangleAnchor (w*0.5) (h*0.5) pt circleAnchor :: Floating u => u -> Point2 u -> DotAnchor u circleAnchor rad ctr = DotAnchor ctr (\theta -> ctr .+^ (avec theta rad)) (radialCardinal rad ctr) circleLDO :: (Floating u, InterpretUnit u) => LocQuery u (DotAnchor u) circleLDO = promoteR1 $ \pt -> markHeight >>= \diam -> pure $ circleAnchor (diam * 0.5) pt -- This might be better taking a function: ctr -> poly_points -- ... -- polygonLDO :: (Real u, Floating u, InterpretUnit u, Tolerance u) => (u -> Point2 u -> [Point2 u]) -> LocQuery u (DotAnchor u) polygonLDO mk = promoteR1 $ \ctr -> markHeight >>= \h -> let ps = mk h ctr in pure $ polygonAnchor ps ctr -------------------------------------------------------------------------------- type DotLocImage u = LocImage u (DotAnchor u) type DDotLocImage = DotLocImage Double dotChar :: (Floating u, Real u, InterpretUnit u) => Char -> DotLocImage u dotChar ch = dotText [ch] -- Note - dotText now uses font metrics, the generated BBox is -- fine for dots (if they are all the same text) but not good for -- tree nodes (for example). Wumpus-Tree should really be using a -- different graphic object for labelled trees. -- dotText :: (Floating u, Real u, InterpretUnit u) => String -> DotLocImage u dotText ss = pushR1 (mapAns bboxRectAnchor) $ ccTextline ss -- Note - maybe Wumpus-Basic should have a @swapAns@ function? dotHLine :: (Floating u, InterpretUnit u) => DotLocImage u dotHLine = intoLocImage circleLDO markHLine dotVLine :: (Floating u, InterpretUnit u) => DotLocImage u dotVLine = intoLocImage circleLDO markVLine dotX :: (Floating u, InterpretUnit u) => DotLocImage u dotX = intoLocImage circleLDO markX dotPlus :: (Floating u, InterpretUnit u) => DotLocImage u dotPlus = intoLocImage circleLDO markPlus dotCross :: (Floating u, InterpretUnit u) => DotLocImage u dotCross = intoLocImage circleLDO markCross dotDiamond :: (Floating u, InterpretUnit u) => DotLocImage u dotDiamond = intoLocImage circleLDO markDiamond dotFDiamond :: (Floating u, InterpretUnit u) => DotLocImage u dotFDiamond = intoLocImage circleLDO markFDiamond dotDisk :: (Floating u, InterpretUnit u) => DotLocImage u dotDisk = intoLocImage circleLDO markDisk dotSquare :: (Floating u, Real u, InterpretUnit u) => DotLocImage u dotSquare = markHeight >>= \h -> intoLocImage (rectangleLDO h h) markSquare dotCircle :: (Floating u, InterpretUnit u) => DotLocImage u dotCircle = intoLocImage circleLDO markCircle dotPentagon :: (Floating u, InterpretUnit u) => DotLocImage u dotPentagon = intoLocImage circleLDO markPentagon dotStar :: (Floating u, InterpretUnit u) => DotLocImage u dotStar = intoLocImage circleLDO markStar dotAsterisk :: (Floating u, InterpretUnit u) => DotLocImage u dotAsterisk = intoLocImage circleLDO markAsterisk dotOPlus :: (Floating u, InterpretUnit u) => DotLocImage u dotOPlus = intoLocImage circleLDO markOPlus dotOCross :: (Floating u, InterpretUnit u) => DotLocImage u dotOCross = intoLocImage circleLDO markOCross dotFOCross :: (Floating u, InterpretUnit u) => DotLocImage u dotFOCross = intoLocImage circleLDO markFOCross dotTriangle :: (Real u, Floating u, InterpretUnit u, Tolerance u) => DotLocImage u dotTriangle = intoLocImage (polygonLDO fn) markTriangle where fn h ctr = let (bl,br,top) = equilateralTrianglePoints h ctr in [bl,br,top]