Displacement.hs

{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Wumpus.Basic.Kernel.Objects.Displacement
-- Copyright   :  (c) Stephen Tetley 2010
-- License     :  BSD3
--
-- Maintainer  :  stephen.tetley@gmail.com
-- Stability   :  highly unstable
-- Portability :  GHC 
--
-- Displacing points - often start points. 
--
--------------------------------------------------------------------------------

module Wumpus.Basic.Kernel.Objects.Displacement
  (


  -- * Moving points and angles
    PointDisplace
  , ThetaDisplace
  , ThetaPointDisplace


  , moveStart
  , moveStartTheta
  , moveStartThetaPoint
  , moveStartThetaAngle

  , displace
  , displaceVec
  , displaceH
  , displaceV

  , northwards
  , southwards 
  , eastwards
  , westwards  

  , northeastwards
  , northwestwards
  , southeastwards
  , southwestwards


  , displaceParallel
  , displacePerpendicular
  , displaceOrtho

  , thetaNorthwards
  , thetaSouthwards 
  , thetaEastwards
  , thetaWestwards  

  , thetaNortheastwards
  , thetaNorthwestwards
  , thetaSoutheastwards
  , thetaSouthwestwards

  ) where


import Wumpus.Basic.Kernel.Base.ContextFun

import Wumpus.Core                              -- package: wumpus-core

import Data.AffineSpace                         -- package: vector-space



--------------------------------------------------------------------------------
-- Displacing points

-- | 'PointDisplace' is a type representing functions 
-- @from Point to Point@.
--
-- It is especially useful for building composite graphics where 
-- one part of the graphic is drawn from a different start point 
-- to the other part.
--
type PointDisplace u = Point2 u -> Point2 u


-- | 'ThetaDisplace' is a type representing functions 
-- @from Radian to Radian@.
--
-- It is especially useful for building composite graphics where 
-- one part of the graphic is drawn from a different start point 
-- to the other part.
--
type ThetaDisplace = Radian -> Radian


-- | 'ThetaPointDisplace' is a type representing functions 
-- @from Radian * Point to Point@.
--
-- It is useful for building arrowheads which are constructed 
-- with an implicit angle representing the direction of the line 
-- at the arrow tip.
--
type ThetaPointDisplace u = Radian -> PointDisplace u



-- | Move the start-point of a 'LocCF' with the supplied 
-- displacement function.
--
moveStart :: PointDisplace u -> LocCF u a -> LocCF u a
moveStart f ma = promoteR1 $ \pt -> apply1R1 ma (f pt)



-- | Move the start-point of a 'LocThetaCF' with the supplied 
-- displacement function.
--
moveStartTheta :: ThetaPointDisplace u -> LocThetaCF u a -> LocThetaCF u a
moveStartTheta f ma = promoteR2 $ \pt theta -> let p2 = f theta pt 
                                               in apply2R2 ma p2 theta


-- | Move the start-point of a 'LocThetaCF' with the supplied 
-- displacement function.
--
moveStartThetaPoint :: PointDisplace u -> LocThetaCF u a -> LocThetaCF u a
moveStartThetaPoint f ma = promoteR2 $ \pt theta -> apply2R2 ma (f pt) theta


-- | Change the inclination of a 'LocThetaCF' with the supplied 
-- displacement function.
--
moveStartThetaAngle :: ThetaDisplace -> LocThetaCF u a -> LocThetaCF u a
moveStartThetaAngle f ma = promoteR2 $ \pt theta -> apply2R2 ma pt (f theta)



--------------------------------------------------------------------------------
-- PointDisplace functions

-- | 'displace' : @ x -> y -> PointDisplace @
--
-- Build a combinator to move @Points@ by the supplied @x@ and 
-- @y@ distances.
--
displace :: Num u => u -> u -> PointDisplace u
displace dx dy (P2 x y) = P2 (x+dx) (y+dy)


-- | 'displaceV' : @ (V2 x y) -> PointDisplace @
-- 
-- Version of 'displace' where the displacement is supplied as
-- a vector rather than two parameters.
-- 
displaceVec :: Num u => Vec2 u -> PointDisplace u
displaceVec (V2 dx dy) (P2 x y) = P2 (x+dx) (y+dy)


-- | 'displaceH' : @ x -> PointDisplace @
-- 
-- Build a combinator to move @Points@ by horizontally the 
-- supplied @x@ distance.
--
displaceH :: Num u => u -> PointDisplace u
displaceH dx (P2 x y) = P2 (x+dx) y

-- | 'displaceV' : @ y -> PointDisplace @
-- 
-- Build a combinator to move @Points@ vertically by the supplied 
-- @y@ distance.
--
displaceV :: Num u => u -> PointDisplace u
displaceV dy (P2 x y) = P2 x (y+dy)


-- Cardinal displacement 



northwards :: Num u => u -> PointDisplace u
northwards = displaceV


southwards :: Num u => u -> PointDisplace u
southwards =  displaceV . negate

eastwards :: Num u => u -> PointDisplace u
eastwards = displaceH

westwards :: Num u => u -> PointDisplace u
westwards = displaceH . negate

northeastwards :: Floating u => u -> PointDisplace u
northeastwards = displaceVec . avec (0.25 * pi)

northwestwards ::  Floating u => u -> PointDisplace u
northwestwards = displaceVec . avec (0.75 * pi)

southeastwards ::  Floating u => u -> PointDisplace u
southeastwards = displaceVec . avec (1.75 * pi)

southwestwards ::  Floating u => u -> PointDisplace u
southwestwards = displaceVec . avec (1.25 * pi)


--------------------------------------------------------------------------------
-- ThetaPointDisplace functions


-- | 'displaceParallel' : @ dist -> ThetaPointDisplace @
-- 
-- Build a combinator to move @Points@ in parallel to the 
-- direction of the implicit angle by the supplied distance 
-- @dist@. 
--
displaceParallel :: Floating u => u -> ThetaPointDisplace u
displaceParallel d = \theta pt -> pt .+^ avec (circularModulo theta) d


-- | 'displaceParallel' : @ dist -> ThetaPointDisplace @
-- 
-- Build a combinator to move @Points@ perpendicular to the 
-- inclnation of the implicit angle by the supplied distance 
-- @dist@. 
--
displacePerpendicular :: Floating u => u -> ThetaPointDisplace u
displacePerpendicular d = 
    \theta pt -> pt .+^ avec (circularModulo $ theta + (0.5*pi)) d



-- | 'displaceOrtho' : @ vec -> ThetaPointDisplace @
-- 
-- This is a combination of @displaceParallel@ and 
-- @displacePerpendicular@, with the x component of the vector
-- displaced in parallel and the y component displaced
-- perpendicular. 
-- 
displaceOrtho :: Floating u => Vec2 u -> ThetaPointDisplace u
displaceOrtho (V2 x y) = \theta -> 
    displaceParallel x theta . displacePerpendicular y theta


thetaNorthwards :: Floating u => u -> ThetaPointDisplace u
thetaNorthwards = displacePerpendicular


thetaSouthwards :: Floating u => u -> ThetaPointDisplace u
thetaSouthwards = displacePerpendicular . negate


thetaEastwards :: Floating u => u -> ThetaPointDisplace u
thetaEastwards = displaceParallel


thetaWestwards :: Floating u => u -> ThetaPointDisplace u
thetaWestwards = displaceParallel . negate

thetaNortheastwards :: Floating u => u -> ThetaPointDisplace u
thetaNortheastwards d = 
    \theta pt -> pt .+^ avec (circularModulo $ theta + (0.25*pi)) d


thetaNorthwestwards :: Floating u => u -> ThetaPointDisplace u
thetaNorthwestwards d = 
    \theta pt -> pt .+^ avec (circularModulo $ theta + (0.75*pi)) d


thetaSoutheastwards :: Floating u => u -> ThetaPointDisplace u
thetaSoutheastwards d = 
    \theta pt -> pt .+^ avec (circularModulo $ theta + (1.75*pi)) d


thetaSouthwestwards :: Floating u => u -> ThetaPointDisplace u
thetaSouthwestwards d = 
    \theta pt -> pt .+^ avec (circularModulo $ theta + (1.25*pi)) d