ControlPoints.hs

{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Wumpus.Drawing.Paths.ControlPoints
-- Copyright   :  (c) Stephen Tetley 2010
-- License     :  BSD3
--
-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
-- Stability   :  highly unstable
-- Portability :  GHC
--
-- Collection of point manufacturing functions.
--
-- \*\* WARNING \*\* this module is experimental and may change 
-- significantly in future revisions.
-- 
--------------------------------------------------------------------------------

module Wumpus.Drawing.Paths.ControlPoints
  ( 

    midpointIsosceles
  , dblpointIsosceles

  , rectangleFromBasePoints
  , squareFromBasePoints
  , usquareFromBasePoints

  , trapezoidFromBasePoints

  , squareFromCornerPoints

  ) where

import Wumpus.Basic.Kernel

import Wumpus.Core                              -- package: wumpus-core

import Data.AffineSpace                         -- package: vector-space




-- | 'midpointIsosceles' : 
-- @ altitude * start_pt * end_pt -> mid_pt @
--
-- Triangular midpoint.
-- 
-- @u@ is the altitude of the triangle - negative values of u 
-- form the triangle below the line.
--
midpointIsosceles :: (Real u, Floating u) 
                  => u -> Point2 u -> Point2 u -> Point2 u
midpointIsosceles u p1@(P2 x1 y1) p2@(P2 x2 y2) = 
    mid_pt .+^ avec perp_ang u
  where
    mid_pt    = P2 (x1 + 0.5*(x2-x1)) (y1 + 0.5*(y2-y1))
    perp_ang  = (pi*0.5) + direction (pvec p1 p2) 



-- | 'dblpointIsosceles' : 
-- @ altitude * start_pt * end_pt * (third_pt, two_thirds_pt) @
-- 
-- Double triangular joint - one joint at a third of the line
-- length, the other at two thirds.
-- 
dblpointIsosceles :: (Real u, Floating u) 
                      => u -> Point2 u -> Point2 u -> (Point2 u, Point2 u)  
dblpointIsosceles u p1@(P2 x1 y1) p2@(P2 x2 y2) = 
    (mid1 .+^ avec perp_ang u, mid2 .-^ avec perp_ang u)
  where
    mid1      = P2 (x1 + 0.33*(x2-x1)) (y1 + 0.33*(y2-y1))
    mid2      = P2 (x1 + 0.66*(x2-x1)) (y1 + 0.66*(y2-y1))
    perp_ang  = (pi*0.5) + direction (pvec p1 p2) 


--------------------------------------------------------------------------------



-- | 'rectangleFromBasePoints' : 
-- @ altitude * start_pt * end_pt * (top_left, top_right) @
-- 
-- Control points forming a rectangle. 
--
-- The two manufactured control points form the top corners, 
-- so the supplied points map as @start_point == bottom_left@ and 
-- @end_point == bottom_right@.
--
rectangleFromBasePoints :: (Real u, Floating u) 
                  => u -> Point2 u -> Point2 u -> (Point2 u, Point2 u)
rectangleFromBasePoints u p1 p2 = (cp1, cp2)
  where
    base_vec  = pvec p1 p2
    theta     = direction base_vec
    cp1       = displacePerpendicular u theta p1
    cp2       = displacePerpendicular u theta p2


-- | 'squareFromBasePoints' : 
-- @ start_pt -> end_pt -> (top_left, top_right) @
-- 
-- Control points forming a square - side_len derived from the 
-- distance between start and end points.
--
-- The two manufactured control points form the top corners, 
-- so the supplied points map as @start_point == bottom_left@ and 
-- @end_point == bottom_right@.
--
squareFromBasePoints :: (Real u, Floating u) 
                     => Point2 u -> Point2 u -> (Point2 u, Point2 u)
squareFromBasePoints p1 p2 = rectangleFromBasePoints side_len p1 p2
  where
    side_len  = vlength $ pvec p1 p2


-- | 'usquareFromBasePoints' : 
-- @ start_pt -> end_pt -> (bottom_left, bottom_right) @
-- 
-- Control points forming a square - side_len derived from the 
-- distance between start and end points.
--
-- As per 'squareFromBasePoints' but the square is drawn 
-- /underneath/ the line formed between the start and end points.
-- (Underneath is modulo the direction, of course).
--
-- The two manufactured control points form the /bottom/ corners, 
-- so the supplied points map as @start_point == top_left@ and 
-- @end_point == top_right@.
-- 
usquareFromBasePoints :: (Real u, Floating u) 
                      => Point2 u -> Point2 u -> (Point2 u, Point2 u)
usquareFromBasePoints p1 p2 = rectangleFromBasePoints side_len p1 p2
  where
    side_len  = negate $ vlength $ pvec p1 p2





-- | 'trapezoidFromBasePoints' : 
-- @ altitude * ratio_to_base * start_pt * end_pt -> (top_left, top_right) @
--
-- Control points form an isosceles trapezoid.
--
-- The two manufactured control points form the top corners, 
-- so the supplied points map as @start_point == bottom_left@ and 
-- @end_point == bottom_right@.
-- 
trapezoidFromBasePoints :: (Real u, Floating u) 
                        => u -> u -> Point2 u -> Point2 u 
                        -> (Point2 u, Point2 u) 
trapezoidFromBasePoints u ratio_to_base p1 p2 = (cp1, cp2)
  where
    base_vec  = pvec p1 p2
    base_len  = vlength base_vec
    theta     = direction base_vec
    half_ulen = 0.5 * ratio_to_base * base_len
    base_mid  = displaceParallel (0.5 * base_len) theta p1
    ubase_mid = displacePerpendicular u theta base_mid
    cp1       = displaceParallel (-half_ulen) theta ubase_mid
    cp2       = displaceParallel   half_ulen  theta ubase_mid




-- | 'squareFromCornerPoints' : 
-- @ altitude * start_pt * end_pt * (top_left, bottom_right) @
-- 
-- Control points forming a square bisected by the line from 
-- start_pt to end_pt. 
--
-- The two manufactured control points form the top_left and
-- bottom_right corners, so the supplied points map as 
-- @start_point == bottom_left@ and @end_point == top_right@.
--
squareFromCornerPoints :: (Real u, Floating u) 
                       => Point2 u -> Point2 u -> (Point2 u, Point2 u) 
squareFromCornerPoints p1 p2 = (cp1, cp2)
  where
    base_vec  = pvec p1 p2
    half_len  = 0.5 * (vlength base_vec)
    theta     = direction base_vec
    base_mid  = displaceParallel half_len theta p1
    cp1       = displacePerpendicular   half_len  theta base_mid
    cp2       = displacePerpendicular (-half_len) theta base_mid