{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Drawing.Shapes.Parallelogram -- Copyright : (c) Stephen Tetley 2011 -- License : BSD3 -- -- Maintainer : Stephen Tetley -- Stability : highly unstable -- Portability : GHC -- -- Parallelogram. -- -- -------------------------------------------------------------------------------- module Wumpus.Drawing.Shapes.Parallelogram ( Parallelogram , DParallelogram , parallelogram , zparallelogram ) where import Wumpus.Drawing.Paths import Wumpus.Drawing.Shapes.Base import Wumpus.Basic.Geometry.Base -- package: wumpus-basic import Wumpus.Basic.Geometry.Intersection import Wumpus.Basic.Geometry.Paths import Wumpus.Basic.Kernel import Wumpus.Core -- package: wumpus-core import Control.Applicative -------------------------------------------------------------------------------- -- Parallelogram -- | A Paralleogram. -- data Parallelogram u = Parallelogram { pll_ctm :: ShapeCTM u , pll_base_width :: !u , pll_height :: !u , pll_base_l_ang :: Radian , pll_syn_props :: SyntheticProps u } -- | Note (center) is a line dropped from the center of the -- paralleogram. -- -- > base_minor is the (center) to left corner. -- > base_major is the (center) to right corner. -- data SyntheticProps u = SyntheticProps { pll_base_minor :: u , pll_base_major :: u } type DParallelogram = Parallelogram Double type instance DUnit (Parallelogram u) = u -------------------------------------------------------------------------------- -- Affine trans mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Parallelogram u -> Parallelogram u mapCTM f = (\s i -> s { pll_ctm = f i }) <*> pll_ctm instance Num u => Scale (Parallelogram u) where scale sx sy = mapCTM (scale sx sy) instance Rotate (Parallelogram u) where rotate ang = mapCTM (rotate ang) instance (Real u, Floating u) => RotateAbout (Parallelogram u) where rotateAbout ang pt = mapCTM (rotateAbout ang pt) instance Num u => Translate (Parallelogram u) where translate dx dy = mapCTM (translate dx dy) -------------------------------------------------------------------------------- -- Anchors -- | 'runDisplaceCenter' : @ ( half_base_width -- * half_height -- * base_minor -- * base_major -> Vec ) * parallelogram -> Point @ -- runDisplaceCenter :: (Real u, Floating u) => (u -> u -> u -> u -> Vec2 u) -> Parallelogram u -> Point2 u runDisplaceCenter fn (Parallelogram { pll_ctm = ctm , pll_base_width = bw , pll_height = h , pll_syn_props = syn }) = displaceCenter (fn (0.5 * bw) (0.5 * h) (pll_base_minor syn) (pll_base_major syn)) ctm instance (Real u, Floating u) => CenterAnchor (Parallelogram u) where center = runDisplaceCenter $ \_ _ _ _ -> V2 0 0 -- top anchors swap the base minor and major... -- instance (Real u, Floating u) => TopCornerAnchor (Parallelogram u) where topLeftCorner = runDisplaceCenter $ \_ hh _ bmaj -> V2 (-bmaj) hh topRightCorner = runDisplaceCenter $ \_ hh bmin _ -> V2 bmin hh instance (Real u, Floating u) => BottomCornerAnchor (Parallelogram u) where bottomLeftCorner = runDisplaceCenter $ \_ hh bmin _ -> V2 (-bmin) (-hh) bottomRightCorner = runDisplaceCenter $ \_ hh _ bmaj -> V2 bmaj (-hh) instance (Real u, Floating u) => SideMidpointAnchor (Parallelogram u) where sideMidpoint n a = step (n `mod` 4) where step 1 = midpoint (topRightCorner a) (topLeftCorner a) step 2 = midpoint (topLeftCorner a) (bottomLeftCorner a) step 3 = midpoint (bottomLeftCorner a) (bottomRightCorner a) step _ = midpoint (bottomRightCorner a) (topRightCorner a) instance (Real u, Floating u) => CardinalAnchor (Parallelogram u) where north = runDisplaceCenter $ \_ hh _ _ -> V2 0 hh south = runDisplaceCenter $ \_ hh _ _ -> V2 0 (-hh) east = runDisplaceCenter $ \hw _ _ _ -> V2 hw 0 west = runDisplaceCenter $ \hw _ _ _ -> V2 (-hw) 0 instance (Real u, Floating u, FromPtSize u) => CardinalAnchor2 (Parallelogram u) where northeast = pllRadialAnchor (0.25*pi) southeast = pllRadialAnchor (1.75*pi) southwest = pllRadialAnchor (1.25*pi) northwest = pllRadialAnchor (0.75*pi) instance (Real u, Floating u, FromPtSize u) => RadialAnchor (Parallelogram u) where radialAnchor = pllRadialAnchor -- TODO - update this to a quadrant function... -- pllRadialAnchor :: (Real u, Floating u, FromPtSize u) => Radian -> Parallelogram u -> Point2 u pllRadialAnchor theta (Parallelogram { pll_ctm = ctm , pll_height = h , pll_syn_props = syn }) = post $ findIntersect zeroPt theta $ polygonLineSegments ps where ps = pllPoints (pll_base_minor syn) (pll_base_major syn) h post = \ans -> case ans of Nothing -> displaceCenter (V2 0 0) ctm Just (P2 x y) -> displaceCenter (V2 x y) ctm -------------------------------------------------------------------------------- -- Construction -- | 'parallelogram' : @ width * height * bottom_left_ang -> Parallelogram @ -- -- parallelogram :: (Real u, Floating u, FromPtSize u) => u -> u -> Radian -> Shape u (Parallelogram u) parallelogram bw h lang = let props = synthesizeProps bw h lang in makeShape (mkParallelogram bw h lang props) (mkParallelogramPath (pll_base_minor props) (pll_base_major props) h) -- | 'zparallelogram' : @ base_width * height -> Parallelogram @ -- -- zparallelogram :: (Real u, Floating u, FromPtSize u) => u -> u -> Shape u (Parallelogram u) zparallelogram bw h = parallelogram bw h ang where ang = d2r (60::Double) -------------------------------------------------------------------------------- mkParallelogram :: (Real u, Fractional u) => u -> u -> Radian -> SyntheticProps u -> LocThetaCF u (Parallelogram u) mkParallelogram bw h lang props = promoteR2 $ \ctr theta -> pure $ Parallelogram { pll_ctm = makeShapeCTM ctr theta , pll_base_width = bw , pll_height = h , pll_base_l_ang = lang , pll_syn_props = props } -- Note - expects ang value 0 < ang < 180, though does not check... -- synthesizeProps :: Fractional u => u -> u -> Radian -> SyntheticProps u synthesizeProps bw h lang | lang == 0.5*pi = let hw = 0.5 * bw in SyntheticProps hw hw | lang > 0.5*pi = less_ninety | otherwise = grtr_ninety where less_ninety = let extw = h / (fromRadian $ tan lang) half_rect_width = 0.5 * (bw + extw) in SyntheticProps half_rect_width (half_rect_width - extw) grtr_ninety = let extw = h / (fromRadian $ tan (pi-lang)) half_rect_width = 0.5 * (bw + extw) in SyntheticProps (half_rect_width - extw) half_rect_width mkParallelogramPath :: (Real u, Floating u, FromPtSize u) => u -> u -> u -> LocThetaCF u (Path u) mkParallelogramPath bw_minor bw_major h = promoteR2 $ \ctr theta -> roundCornerShapePath $ map (rotateAbout theta ctr) $ pllPath bw_minor bw_major h ctr pllPath :: (Real u, Floating u) => u -> u -> u -> LocCoordPath u pllPath bw_minor bw_major h (P2 x y) = [ bl, br, tr, tl ] where hh = 0.5 * h bl = P2 (x - bw_minor) (y - hh) br = P2 (x + bw_major) (y - hh) tl = P2 (x - bw_major) (y + hh) -- topleft subtracts major tr = P2 (x + bw_minor) (y + hh) -- topright adds minor pllPoints :: (Real u, Floating u) => u -> u -> u -> [Point2 u] pllPoints bw_minor bw_major h = [ bl, br, tr, tl ] where hh = 0.5 * h bl = P2 (-bw_minor) (-hh) br = P2 bw_major (-hh) tl = P2 (-bw_major) hh tr = P2 bw_minor hh