{-# LANGUAGE TypeFamilies #-} {-# OPTIONS -Wall #-} -------------------------------------------------------------------------------- -- | -- Module : Wumpus.Drawing.Shapes.Triangle -- Copyright : (c) Stephen Tetley 2011 -- License : BSD3 -- -- Maintainer : Stephen Tetley -- Stability : highly unstable -- Portability : GHC -- -- Isosceles triangle. -- -------------------------------------------------------------------------------- module Wumpus.Drawing.Shapes.Triangle ( Triangle , DTriangle , triangle ) where import Wumpus.Drawing.Paths.Absolute import Wumpus.Drawing.Shapes.Base import Wumpus.Basic.Geometry -- package: wumpus-basic import Wumpus.Basic.Kernel import Wumpus.Core -- package: wumpus-core import Control.Applicative -- Datatype -- | An isosceles triangle, oriented /upwards/. -- data Triangle u = Triangle { tri_ctm :: ShapeCTM u , tri_base_width :: !u , tri_height :: !u } type instance DUnit (Triangle u) = u data SyntheticProps u = SyntheticProps { tri_hmajor :: u , tri_hminor :: u , tri_base_ang :: Radian , tri_apex_ang :: Radian } type DTriangle = Triangle Double instance Functor Triangle where fmap f (Triangle ctm bw h) = Triangle (fmap f ctm) (f bw) (f h) synthesizeProps :: (Real u, Fractional u) => u -> u -> SyntheticProps u synthesizeProps bw h = SyntheticProps { tri_hmajor = hmajor , tri_hminor = hminor , tri_base_ang = base_ang , tri_apex_ang = apex_ang } where half_base = 0.5 * bw hminor = h / 3 hmajor = 2 * hminor base_ang = atan $ toRadian (h / half_base) apex_ang = 2 * ((pi/4) - base_ang) -------------------------------------------------------------------------------- -- Affine trans mapCTM :: (ShapeCTM u -> ShapeCTM u) -> Triangle u -> Triangle u mapCTM f = (\s i -> s { tri_ctm = f i }) <*> tri_ctm instance (Real u, Floating u) => Rotate (Triangle u) where rotate ang = mapCTM (rotate ang) instance (Real u, Floating u) => RotateAbout (Triangle u) where rotateAbout ang pt = mapCTM (rotateAbout ang pt) instance Fractional u => Scale (Triangle u) where scale sx sy = mapCTM (scale sx sy) instance InterpretUnit u => Translate (Triangle u) where translate dx dy = mapCTM (translate dx dy) -------------------------------------------------------------------------------- -- Anchors -- | 'runDisplaceCenter' : @ ( half_base_width -- * height_minor -- * height_major -- * base_ang -> Vec ) * traingle -> Point @ -- runDisplaceCenter :: (Real u, Floating u) => (u -> u -> u -> Radian -> Vec2 u) -> Triangle u -> Anchor u runDisplaceCenter fn (Triangle { tri_ctm = ctm , tri_base_width = bw , tri_height = h }) = projectFromCtr (fn (0.5*bw) hminor hmajor base_ang) ctm where props = synthesizeProps bw h hminor = tri_hminor props hmajor = tri_hmajor props base_ang = tri_base_ang props instance (Real u, Floating u) => CenterAnchor (Triangle u) where center = runDisplaceCenter $ \_ _ _ _ -> V2 0 0 instance (Real u, Floating u) => ApexAnchor (Triangle u) where apex = runDisplaceCenter $ \_ _ hmaj _ -> V2 0 hmaj instance (Real u, Floating u) => BottomCornerAnchor (Triangle u) where bottomLeftCorner = runDisplaceCenter $ \hbw hmin _ _ -> V2 (-hbw) (-hmin) bottomRightCorner = runDisplaceCenter $ \hbw hmin _ _ -> V2 hbw (-hmin) -- east and west should be parallel to the centroid. -- instance (Real u, Floating u) => CardinalAnchor (Triangle u) where north = runDisplaceCenter $ \_ _ hmaj _ -> V2 0 hmaj south = runDisplaceCenter $ \_ hmin _ _ -> V2 0 (-hmin) east = runDisplaceCenter $ \hbw hmin _ ang -> findEast hbw hmin ang west = runDisplaceCenter $ \hbw hmin _ ang -> findWest hbw hmin ang instance (Real u, Floating u) => SideMidpointAnchor (Triangle u) where sideMidpoint n a = step (n `mod` 3) where step 1 = midpoint (apex a) (bottomLeftCorner a) step 2 = midpoint (bottomLeftCorner a) (bottomRightCorner a) step _ = midpoint (bottomRightCorner a) (apex a) findEast :: Fractional u => u -> u -> Radian -> Vec2 u findEast half_base_width hminor base_ang = V2 xdist 0 where b1 = hminor / (fromRadian $ tan base_ang) xdist = half_base_width - b1 findWest :: Fractional u => u -> u -> Radian -> Vec2 u findWest hbw hm ang = let (V2 xdist 0) = findEast hbw hm ang in V2 (-xdist) 0 instance (Real u, Floating u) => CardinalAnchor2 (Triangle u) where northeast = radialAnchor (0.25*pi) southeast = radialAnchor (1.75*pi) southwest = radialAnchor (1.25*pi) northwest = radialAnchor (0.75*pi) instance (Real u, Floating u) => RadialAnchor (Triangle u) where radialAnchor theta = runDisplaceCenter $ \hbw hmin hmaj _ -> triangleRadialVector hbw hmin hmaj theta -------------------------------------------------------------------------------- -- Construction -- | 'triangle' : @ base_width * height -> Shape @ -- -- triangle :: (Real u, Floating u, InterpretUnit u, Tolerance u) => u -> u -> Shape Triangle u triangle bw h = let props = synthesizeProps bw h hminor = tri_hminor props hmajor = tri_hmajor props in makeShape (mkTriangle bw h) (mkTrianglePath 0 bw hminor hmajor) mkTriangle :: (Real u, Fractional u, InterpretUnit u) => u -> u -> LocThetaQuery u (Triangle u) mkTriangle bw h = qpromoteLocTheta $ \ctrd theta -> pure $ Triangle { tri_ctm = makeShapeCTM ctrd theta , tri_base_width = bw , tri_height = h } mkTrianglePath :: (Real u, Floating u, InterpretUnit u, Tolerance u) => u -> u -> u -> u -> LocThetaQuery u (AbsPath u) mkTrianglePath rnd bw hminor hmajor = qpromoteLocTheta $ \ctr theta -> let xs = runVertices3 ctr $ trianglePath bw hminor hmajor in roundCornerShapePath rnd $ map (rotateAbout theta ctr) xs trianglePath :: (Real u, Floating u) => u -> u -> u -> Vertices3 u trianglePath bw hminor hmajor = (br, apx, bl) where half_base = 0.5 * bw br = V2 half_base (-hminor) apx = V2 0 hmajor bl = V2 (-half_base) (-hminor)