{-# LANGUAGE TypeFamilies #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Basic.Kernel.Base.Anchors -- Copyright : (c) Stephen Tetley 2010 -- License : BSD3 -- -- Maintainer : Stephen Tetley <stephen.tetley@gmail.com> -- Stability : highly unstable -- Portability : GHC -- -- Anchor points on shapes, bounding boxes, etc. -- -- Anchors are addressable positions, an examplary use is taking -- anchors on node shapes to get the start and end points for -- connectors in a network (graph) diagram. -- -------------------------------------------------------------------------------- module Wumpus.Basic.Kernel.Base.Anchors ( -- * Anchors CenterAnchor(..) , CardinalAnchor(..) , CardinalAnchor2(..) , RadialAnchor(..) -- * Extended anchor points , northwards , southwards , eastwards , westwards , northeastwards , southeastwards , southwestwards , northwestwards , radialConnectorPoints ) where import Wumpus.Core -- package: wumpus-core import Data.AffineSpace -- package: vector-space -- | Center of an object. -- class CenterAnchor t where center :: DUnit t ~ u => t -> Point2 u -- | Cardinal (compass) positions on an object. -- -- Note - in TikZ cardinal anchors are not necessarily at the -- equivalent radial position, for instance reactangle north-east -- is the top-right corner whether or not this is incident at -- 45deg. -- -- Wumpus generally follows the TikZ convention. -- class CardinalAnchor t where north :: DUnit t ~ u => t -> Point2 u south :: DUnit t ~ u => t -> Point2 u east :: DUnit t ~ u => t -> Point2 u west :: DUnit t ~ u => t -> Point2 u -- | Secondary group of cardinal (compass) positions on an object. -- -- It seems possible that for some objects defining the primary -- compass points (north, south,...) will be straight-forward -- whereas defining the secondary compass points may be -- problemmatic, hence the compass points are split into two -- classes. -- class CardinalAnchor2 t where northeast :: DUnit t ~ u => t -> Point2 u southeast :: DUnit t ~ u => t -> Point2 u southwest :: DUnit t ~ u => t -> Point2 u northwest :: DUnit t ~ u => t -> Point2 u -- | Anchor on a border that can be addressed by an angle. -- -- The angle is counter-clockwise from the right-horizontal, i.e. -- 0 is /east/. -- class RadialAnchor t where radialAnchor :: DUnit t ~ u => Radian -> t -> Point2 u extendPtDist :: (Real u, Floating u) => u -> Point2 u -> Point2 u -> Point2 u extendPtDist d p1 p2 = let v = pvec p1 p2 ang = vdirection v len = vlength v in p1 .+^ avec ang (len+d) -- | 'northwards' : @ dist * object -> Point @ -- -- Project the anchor along a line from the center that goes -- through the north anchor. -- -- If the distance is zero the answer with be the north anchor. -- -- If the distance is negative the answer within the object before -- the north anchor. -- -- If the distance is positive the anchor outside the object. -- northwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t , u ~ DUnit t ) => u -> t -> Point2 u northwards u a = extendPtDist u (center a) (north a) -- | 'southwards' : @ dist * object -> Point @ -- -- Variant of the function 'northwards', but projecting the line -- southwards from the center of the object. -- southwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t , u ~ DUnit t ) => u -> t -> Point2 u southwards u a = extendPtDist u (center a) (south a) -- | 'eastwards' : @ dist * object -> Point @ -- -- Variant of the function 'northwards', but projecting the line -- eastwards from the center of the object. -- eastwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t , u ~ DUnit t ) => u -> t -> Point2 u eastwards u a = extendPtDist u (center a) (east a) -- | 'westwards' : @ dist * object -> Point @ -- -- Variant of the function 'northwards', but projecting the line -- westwards from the center of the object. -- westwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor t , u ~ DUnit t ) => u -> t -> Point2 u westwards u a = extendPtDist u (center a) (west a) -- | 'northeastwards' : @ dist * object -> Point @ -- -- Variant of the function 'northwards', but projecting the line -- northeastwards from the center of the object. -- northeastwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t , u ~ DUnit t ) => u -> t -> Point2 u northeastwards u a = extendPtDist u (center a) (northeast a) -- | 'southeastwards' : @ dist * object -> Point @ -- -- Variant of the function 'northwards', but projecting the line -- southeastwards from the center of the object. -- southeastwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t , u ~ DUnit t ) => u -> t -> Point2 u southeastwards u a = extendPtDist u (center a) (southeast a) -- | 'southwestwards' : @ dist * object -> Point @ -- -- Variant of the function 'northwards', but projecting the line -- southwestwards from the center of the object. -- southwestwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t , u ~ DUnit t ) => u -> t -> Point2 u southwestwards u a = extendPtDist u (center a) (southwest a) -- | 'northwestwards' : @ dist * object -> Point @ -- -- Variant of the function 'northwards', but projecting the line -- northwestwards from the center of the object. -- northwestwards :: ( Real u, Floating u, CenterAnchor t, CardinalAnchor2 t , u ~ DUnit t ) => u -> t -> Point2 u northwestwards u a = extendPtDist u (center a) (northwest a) -------------------------------------------------------------------------------- -- | 'radialConnectorPoints' : @ object_a * object_b -> (Point_a, Point_b) @ -- -- Find the radial connectors points for objects @a@ and @b@ along -- the line joining their centers. -- radialConnectorPoints :: ( Real u, Floating u , CenterAnchor t1, RadialAnchor t1 , CenterAnchor t2, RadialAnchor t2 , u ~ DUnit t1, DUnit t1 ~ DUnit t2 ) => t1 -> t2 -> (Point2 u, Point2 u) radialConnectorPoints a b = (radialAnchor theta a, radialAnchor (theta+pi) b) where theta = vdirection $ pvec (center a) (center b) -------------------------------------------------------------------------------- -- Instances instance Fractional u => CenterAnchor (BoundingBox u) where center (BBox (P2 xl ylo) (P2 xr yhi)) = P2 x y where x = xl+0.5*(xr-xl) y = ylo+0.5*(yhi-ylo) instance Fractional u => CardinalAnchor (BoundingBox u) where north (BBox (P2 xl _ ) (P2 xr yhi)) = P2 (xl+0.5*(xr-xl)) yhi south (BBox (P2 xl ylo) (P2 xr _ )) = P2 (xl+0.5*(xr-xl)) ylo east (BBox (P2 _ ylo) (P2 xr yhi)) = P2 xr (ylo+0.5*(yhi-ylo)) west (BBox (P2 xl ylo) (P2 _ yhi)) = P2 xl (ylo+0.5*(yhi-ylo)) instance Fractional u => CardinalAnchor2 (BoundingBox u) where northeast (BBox _ ur) = ur southeast (BBox (P2 _ ylo) (P2 xr _)) = P2 xr ylo southwest (BBox ll _) = ll northwest (BBox (P2 xl _) (P2 _ yhi)) = P2 xl yhi