Connectors.hs

{-# OPTIONS -Wall #-}

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

module Wumpus.Drawing.Paths.Connectors
  ( 

    ConnectorPath
  , DConnectorPath
  , sconnect

  , connLine

  , connRightVH
  , connRightHV
  , connRightVHV
  , connRightHVH

  , connIsosceles
  , connIsosceles2
  , connLightningBolt

  , connIsoscelesCurve
  , connSquareCurve
  , connUSquareCurve

  , connTrapezoidCurve
  , connZSquareCurve
  , connUZSquareCurve

  ) where

import Wumpus.Drawing.Paths.Base
import Wumpus.Drawing.Paths.ControlPoints

import Wumpus.Basic.Kernel                      -- package: wumpus-basic
import Wumpus.Core                              -- package: wumpus-core

import Data.AffineSpace                         -- package: vector-space

import Control.Applicative
import Prelude hiding ( length )


-- | Note - a ConnectorPath is not drawn automatically, it is a
-- @ConnectorCF@ not a @ConnectorGraphic@ or @ConnectorImage@.
--
type ConnectorPath u = ConnectorCF u (Path u)

type DConnectorPath = ConnectorPath Double



-- Maybe this should be ConnectorPath u -> ConnectorImage u (Path u) instead?
-- This would be closer to the new shapes...
--
sconnect :: Num u 
         => ConnectorPath u -> Point2 u -> Point2 u -> Image u (Path u)
sconnect mf p0 p1 = 
    connect mf p0 p1 >>= \cpath -> 
    intoImage (pure cpath) (openStroke $ toPrimPath cpath)  
                    

-- | Build the path with interior round corners.
-- 
roundCornerPath :: (Real u, Floating u, FromPtSize u) 
                => [Point2 u] -> CF (Path u)
roundCornerPath xs = getRoundCornerSize >>= \sz -> 
    if sz == 0 then return (traceLinePoints xs) 
               else return (roundInterior  sz xs)



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

-- | Connect with a straight line.
--
connLine :: Floating u => ConnectorPath u
connLine = promoteR2 $ \p0 p1 -> pure $ line p0 p1



-- | Right-angled connector - go vertical, then go horizontal.
--
connRightVH :: (Real u, Floating u, FromPtSize u) => ConnectorPath u
connRightVH = promoteR2 $ \ p0@(P2 x0 _) p1@(P2 _ y1) ->
    let mid = P2 x0 y1 in roundCornerPath [p0, mid, p1]



-- | Right-angled connector - go horizontal, then go vertical.
--
connRightHV :: (Real u, Floating u, FromPtSize u) 
            => ConnectorPath u
connRightHV = promoteR2 $ \ p0@(P2 _ y0) p1@(P2 x1 _) -> 
    let mid = P2 x1 y0 in roundCornerPath [p0, mid, p1]

-- | Right-angled connector - go vertical for the supplied 
-- distance, go horizontal, go vertical again for the 
-- remaining distance.
-- 
connRightVHV :: (Real u, Floating u, FromPtSize u) 
             => u -> ConnectorPath u
connRightVHV v = promoteR2 $ \ p0@(P2 x0 _) p1@(P2 x1 _) ->
    let a0 = p0 .+^ vvec v
        a1 = a0 .+^ hvec (x1 - x0)
    in roundCornerPath [p0, a0, a1, p1]


-- | Right-angled connector - go horizontal for the supplied 
-- distance, go verical, go horizontal again for the 
-- remaining distance.
-- 
connRightHVH :: (Real u, Floating u, FromPtSize u) 
             => u -> ConnectorPath u
connRightHVH h = promoteR2 $ \ p0@(P2 _ y0) p1@(P2 _ y1) -> 
    let a0 = p0 .+^ hvec h
        a1 = a0 .+^ vvec (y1 - y0)
    in roundCornerPath [p0,a0,a1,p1]


-- | /Triangular/ joint.
-- 
-- @u@ is the altitude of the triangle.
--
connIsosceles :: (Real u, Floating u, FromPtSize u) 
              => u -> ConnectorPath u 
connIsosceles dy = promoteR2 $ \ p0 p1 -> 
    let mid_pt  = midpointIsosceles dy p0 p1
    in roundCornerPath [p0, mid_pt, p1]
 
    



-- | Double /triangular/ joint.
-- 
-- @u@ is the altitude of the triangle.
--
connIsosceles2 :: (Real u, Floating u, FromPtSize u)
               => u -> ConnectorPath u 
connIsosceles2 u = promoteR2 $ \ p0 p1 -> 
    let (cp0,cp1) = dblpointIsosceles u p0 p1
    in roundCornerPath [ p0, cp0, cp1, p1 ]



-- | /Lightning bolt/ joint - a two joint connector with an /axis/
-- perpendicular to the connector direction.
-- 
-- @u@ is the half length of the of the axis.
--
connLightningBolt :: (Real u, Floating u, FromPtSize u) 
                  => u -> ConnectorPath u 
connLightningBolt u = promoteR2 $ \ p0 p1 -> 
    let cp0 = midpointIsosceles   u  p0 p1
        cp1 = midpointIsosceles (-u) p0 p1
    in roundCornerPath [ p0, cp0, cp1, p1 ]

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



-- | Form a curve inside an isosceles triangle. 
--
-- The two Bezier control points take the same point - the
-- altitude of the triangle. The curve tends to be quite shallow
-- relative to the altitude.
--
-- @u@ is the altitude of the triangle.
--
connIsoscelesCurve :: (Real u, Floating u, FromPtSize u) 
                   => u -> ConnectorPath u 
connIsoscelesCurve u = promoteR2 $ \ p0 p1 ->
    let control_pt  = midpointIsosceles u p0 p1
    in pure $ traceCurvePoints [p0, control_pt, control_pt, p1]
   
    

-- | Form a curve inside a square. 
--
-- The two Bezier control points take the /top/ corners. The
-- curve tends to be very deep.
-- 
connSquareCurve :: (Real u, Floating u, FromPtSize u) 
                => ConnectorPath u 
connSquareCurve = promoteR2 $ \ p0 p1 ->
    let (cp0,cp1) = squareFromBasePoints p0 p1
    in pure $ traceCurvePoints [p0, cp0, cp1, p1]



-- | Form a curve inside a square. 
--
-- As per 'connSquareCurve' but the curve is drawn /underneath/
-- the line formed between the start and end points.
-- 
-- (Underneath is modulo the direction, of course).
-- 
connUSquareCurve :: (Real u, Floating u, FromPtSize u) 
                 => ConnectorPath u 
connUSquareCurve = promoteR2 $ \ p0 p1 -> 
    let (cp0,cp1) = usquareFromBasePoints p0 p1
    in pure $ traceCurvePoints [p0, cp0, cp1, p1]


-- | altitude * ratio_to_base 
--
-- Form a curve inside a trapeziod.
-- 
connTrapezoidCurve :: (Real u, Floating u, FromPtSize u) 
                   => u -> u -> ConnectorPath u 
connTrapezoidCurve u ratio_to_base = promoteR2 $ \p0 p1 -> 
    let (cp0,cp1)  = trapezoidFromBasePoints u ratio_to_base p0 p1
    in pure $ traceCurvePoints [p0, cp0, cp1, p1]


-- | Make a curve within a square, following the corner points as
-- a Z.
--
connZSquareCurve :: (Real u, Floating u, FromPtSize u) 
                 => ConnectorPath u 
connZSquareCurve = promoteR2 $ \p0 p1 -> 
    let (cp0,cp1)  = squareFromCornerPoints p0 p1
    in pure $ traceCurvePoints [p0,cp0,cp1,p1]

-- | Make a curve within a square, following the corner points as
-- a Z.
--
-- The order of tracing flips the control points, so this is an
-- /underneath/ version of 'connZSquareCurve'.
-- 
connUZSquareCurve :: (Real u, Floating u, FromPtSize u) 
                  => ConnectorPath u 
connUZSquareCurve = promoteR2 $ \ p0 p1 ->  
   let (cp0,cp1)  = squareFromCornerPoints p0 p1 
   in pure $ traceCurvePoints [p0,cp1,cp0,p1]