{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Wumpus.Drawing.Connectors.ConnectorPaths
-- Copyright   :  (c) Stephen Tetley 2011
-- License     :  BSD3
--
-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
-- Stability   :  highly unstable
-- Portability :  GHC
--
-- Primitive connectors
--
--------------------------------------------------------------------------------

module Wumpus.Drawing.Connectors.ConnectorPaths
  ( 

    conn_line

  , conna_arc
  , connb_arc

  , conn_hdiagh
  , conn_vdiagv
  
  , conn_diagh
  , conn_diagv

  , conn_hdiag
  , conn_vdiag

  , conna_bar
  , connb_bar
  
  , conna_flam
  , connb_flam

  , conna_orthohbar
  , connb_orthohbar

  , conna_orthovbar
  , connb_orthovbar

  , conna_right
  , connb_right

  , conn_hrr
  , conn_rrh
  , conn_vrr
  , conn_rrv

  , conna_loop
  , connb_loop

  , conn_hbezier
  , conn_vbezier

  ) where

import Wumpus.Drawing.Basis.InclineTrails
import Wumpus.Drawing.Connectors.Base
import Wumpus.Drawing.Connectors.ConnectorProps
import Wumpus.Drawing.Paths

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

import Wumpus.Core                              -- package: wumpus-core

import Data.AffineSpace                         -- package: vector-space

import Control.Applicative




-- | Build as Path as a CatTrail between two points.
--
catConnector :: (Floating u, Ord u, InterpretUnit u, Tolerance u) 
             => (ConnectorProps -> Point2 u -> Point2 u -> Query u (CatTrail u)) 
             -> ConnectorPathSpec u
catConnector mf = ConnectorPathSpec $ \props -> 
    qpromoteConn $ \p0 p1 -> catTrailPath p0 <$> mf props p0 p1 


horizontally :: (Real u, Floating u) 
             => (Vec2 u -> a) -> (Vec2 u -> a) -> Vec2 u -> a
horizontally rightf leftf v1 = 
    case horizontalDirection $ vdirection v1 of
      RIGHTWARDS -> rightf v1
      LEFTWARDS  -> leftf v1

-- | Straight line connector.
--
conn_line :: (Real u, Floating u, InterpretUnit u, Tolerance u) 
          => ConnectorPathSpec u
conn_line = catConnector $ \_ p0 p1 -> pure $ catline $ pvec p0 p1




-- | Form an arc connector.
-- 
-- If the conn_arc_angle in the Drawing context is positive the arc
-- will be formed /above/ the straight line joining the points. 
-- If the angle is negative it will be drawn below. 
-- 
-- The notion of /above/ is respective to the line direction, of 
-- course.
-- 
-- TODO - above and below versions...
--
conna_arc :: (Real u, Floating u, Ord u, InterpretUnit u, Tolerance u) 
          => ConnectorPathSpec u
conna_arc = connArcBody (vtriCurve CW) (vtriCurve CCW)

-- | Below version of 'conna_arc'.
--
connb_arc :: (Real u, Floating u, Ord u, InterpretUnit u, Tolerance u) 
          => ConnectorPathSpec u
connb_arc = connArcBody (vtriCurve CCW) (vtriCurve CW)


connArcBody :: (Real u, Floating u, Ord u, InterpretUnit u, Tolerance u) 
            => (u -> Vec2 u -> CatTrail u) 
            -> (u -> Vec2 u -> CatTrail u) 
            -> ConnectorPathSpec u
connArcBody rightf leftf = catConnector $ \props p0 p1 -> 
    let arc_ang = conn_arc_ang props 
        v1      = pvec p0 p1
        h       = (0.5 * vlength v1) * (fromRadian $ tan arc_ang)
    in return $ horizontally (rightf h) (leftf h) v1 




-- | Horizontal-diagonal-horizontal connector.
--
-- >      --@
-- >     /
-- >  o--
-- 
-- Horizontal /arms/ are drawn from the start and end points, a
-- diagonal segment joins the arms. 
-- 
conn_hdiagh :: (Real u, Floating u, Tolerance u, InterpretUnit u)
           => ConnectorPathSpec u
conn_hdiagh = catConnector $ \props p0 p1 -> 
    connectorLegs props >>= \(src_leg, dst_leg) ->
    return $ trail_hdiagh src_leg dst_leg $ pvec p0 p1


-- probably want trail_hdiagh as a library function

-- | Vertical-diagonal-vertical connector.
--
-- >  @
-- >  |
-- >   \
-- >    |
-- >    o
--
-- Vertical /arms/ are drawn from the start and end points, a
-- diagonal segment joins the arms. 
-- 
conn_vdiagv :: (Real u, Floating u, Tolerance u, InterpretUnit u)
            => ConnectorPathSpec u
conn_vdiagv = catConnector $ \props p0 p1 -> 
    connectorLegs props >>= \(src_leg, dst_leg) ->
    return $ trail_vdiagv src_leg dst_leg $ pvec p0 p1


-- | Diagonal-horizontal connector.
--
-- >    --@
-- >   /
-- >  o
-- 
-- Restricted variant of 'hconndiag' - a diagonal segment is drawn 
-- from the start point joining a horizontal arm drawn from the 
-- end point
-- 
conn_diagh :: (Real u, Floating u, Tolerance u, InterpretUnit u)
           => ConnectorPathSpec u
conn_diagh = catConnector $ \props p0 p1 -> 
    connectorLegs props >>= \(_, dst_leg) ->
    return $ trail_diagh dst_leg $ pvec p0 p1


-- | Diagonal-vertical connector.
--
-- >    @
-- >    |
-- >   /
-- >  o
--
-- Restricted variant of 'vconndiag' - a diagonal segment is drawn 
-- from the start point joining a vertical arm drawn from the end 
-- point.
-- 
conn_diagv :: (Real u, Floating u, Tolerance u, InterpretUnit u)
           => ConnectorPathSpec u
conn_diagv = catConnector $ \props p0 p1 -> 
    connectorLegs props >>= \(_, dst_leg) ->
    return $ trail_diagv dst_leg $ pvec p0 p1



-- | Horizontal-diagonal connector.
--
-- >      @
-- >     /
-- >  o--
--
-- Restricted variant of 'hconndiag' - a horizontal arm is drawn
-- from the start point joining a diagonal segment drawn from the 
-- end point.
-- 
conn_hdiag :: (Real u, Floating u, Tolerance u, InterpretUnit u)
           => ConnectorPathSpec u
conn_hdiag = catConnector $ \props p0 p1 -> 
    connectorLegs props >>= \(src_leg, _) ->
    return $ trail_hdiag src_leg $ pvec p0 p1


-- | Vertical-diagonal connector.
--
-- >    @
-- >   /
-- >  |
-- >  o
--
-- Restricted variant of 'vconndiag' - a horizontal arm is drawn
-- from the start point joining a vertical segment drawn from the 
-- end point.
-- 
conn_vdiag :: (Real u, Floating u, Tolerance u, InterpretUnit u)
           => ConnectorPathSpec u
conn_vdiag = catConnector $ \props p0 p1 -> 
    connectorLegs props >>= \(src_leg, _) ->
    return $ trail_vdiag src_leg $ pvec p0 p1



-- DESIGN NOTE - should the concept of /above/ and /below/ use 
-- ClockDirection instead?
--


-- | Bar connector.
--
-- >  ,----, 
-- >  |    |
-- >  o    @  
--
-- The bar is drawn /above/ the points.
--
conna_bar :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
          => ConnectorPathSpec u
conna_bar = connBarBody (trail_perp_bar2 CW) (trail_perp_bar2 CCW)


-- | Bar connector.
-- 
-- >  o    @ 
-- >  |    |
-- >  '----'  
--
-- The bar is drawn /below/ the points.
--
connb_bar :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
          => ConnectorPathSpec u
connb_bar = connBarBody (trail_perp_bar2 CCW) (trail_perp_bar2 CW)


connBarBody :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
            => (u -> u -> Vec2 u -> CatTrail u) 
            -> (u -> u -> Vec2 u -> CatTrail u) 
            -> ConnectorPathSpec u
connBarBody rightf leftf = catConnector $ \props p0 p1 ->
    connectorLegs props >>= \(src, dst) ->
    return $ horizontally (rightf src dst) (leftf src dst) $ pvec p0 p1



-- | /Flam/ connector.
--
-- >    ,- '
-- >  ,-   | 
-- >  |    |
-- >  o    @  
--
-- The bar is drawn /above/ the points.
--
conna_flam :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
           => ConnectorPathSpec u
conna_flam = connFlamBody (trail_vflam CW) (trail_vflam CCW)

-- | /Flam/ connector - bleow.
--
connb_flam :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
         => ConnectorPathSpec u
connb_flam = connFlamBody (trail_vflam CCW) (trail_vflam CW)  


connFlamBody :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
             => (u -> u -> Vec2 u -> CatTrail u) 
             -> (u -> u -> Vec2 u -> CatTrail u) 
             -> ConnectorPathSpec u
connFlamBody rightf leftf = catConnector $ \props p0 p1 ->
    connectorLegs props >>= \(src,dst) ->
    return $ horizontally (rightf src dst) (leftf src dst) $ pvec p0 p1




-- | Bar connector - always orthonormal .
--
-- >  
-- >  ,----, 
-- >  |    |
-- >  o    @  
--
-- The bar is drawn /above/ the points.
--
conna_orthohbar :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
                => ConnectorPathSpec u
conna_orthohbar = connOrthobarBody (trail_ortho_hbar CW) (trail_ortho_hbar CCW)

-- | Bar connector orthonormal - below.
--
connb_orthohbar :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
                => ConnectorPathSpec u
connb_orthohbar = connOrthobarBody (trail_ortho_hbar CCW) (trail_ortho_hbar CW)



connOrthobarBody :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
                 => (u -> Vec2 u -> CatTrail u)
                 -> (u -> Vec2 u -> CatTrail u)
                 -> ConnectorPathSpec u
connOrthobarBody rightf leftf = catConnector $ \props p0 p1 ->
    connectorLoopSize props >>= \looph ->
    return $ horizontally (rightf looph) (leftf looph) $ pvec p0 p1


-- | Bar connector - always orthonormal.
--
-- >  
-- >  ,--- o 
-- >  |   
-- >  '--- @  
-- > 
--
-- The bar is drawn /left/ of the points.
--
conna_orthovbar :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
                => ConnectorPathSpec u
conna_orthovbar = connOrthobarBody (trail_ortho_vbar CW) (trail_ortho_vbar CCW)

-- | Bar connector orthonormal - right of the points.
--
connb_orthovbar :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
                => ConnectorPathSpec u
connb_orthovbar = connOrthobarBody (trail_ortho_vbar CCW) (trail_ortho_vbar CW)



-- | Right angle connector.
-- 
-- >  ,----@ 
-- >  | 
-- >  o   
--
-- The bar is drawn /above/ the points.
--
conna_right :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
            => ConnectorPathSpec u
conna_right = catConnector $ \_ p0 p1 ->
    return $ trail_vright $ pvec p0 p1


-- | Right angle connector.
-- 
-- >       @ 
-- >       |
-- >  o----'  
--
-- The bar is drawn /below/ the points.
--
connb_right :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
            => ConnectorPathSpec u
connb_right = catConnector $ \_ p0 p1 -> 
    return $ trail_hright $ pvec p0 p1




-- | Connector with two horizontal segments and a joining 
-- vertical segment.
--
-- >       ,--@
-- >       |
-- >  o----'  
--
-- The length of the first horizontal segment is the source arm 
-- length. The length of the final segment is the remaining 
-- horizontal distance. 
--
conn_hrr :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
         => ConnectorPathSpec u
conn_hrr = catConnector $ \props p0 p1 ->
    connectorLegs props >>= \(src_leg,_) ->
    return $ trail_hrr src_leg $ pvec p0 p1


-- | Connector with two horizontal segements and a joining 
-- vertical segment.
--
-- >     ,----@
-- >     |
-- >  o--'  
--
-- The length of the final horizontal segment is the destination 
-- arm length. The length of the initial segment is the remaining
-- horizontal distance. 
--
conn_rrh :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
         => ConnectorPathSpec u
conn_rrh = catConnector $ \props p0 p1 ->
    connectorLegs props >>= \(_,dst_leg) ->
    return $ trail_rrh dst_leg $ pvec p0 p1


-- | Connector with two right angles...
--
-- >       @
-- >       |
-- >  ,----'
-- >  |
-- >  o  
--
-- The length of the first vertical segment is the source arm 
-- length. The length of the final segment is the remaining 
-- vertical distance. 
--
conn_vrr :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
         => ConnectorPathSpec u
conn_vrr = catConnector $ \props p0 p1 ->
    connectorLegs props >>= \(src_leg,_) ->
    return $ trail_vrr src_leg $ pvec p0 p1


-- | Connector with two right angles...
--
-- >       @
-- >       |
-- >  ,----'
-- >  |
-- >  o  
--
-- The length of the final vertical segment is the destination 
-- arm length. The length of the initial segment is the remaining
-- vertical distance. 
--
conn_rrv :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
         => ConnectorPathSpec u
conn_rrv = catConnector $ \props p0 p1 ->
    connectorLegs props >>= \(_,dst_leg) ->
    return $ trail_rrv dst_leg $ pvec p0 p1



-- | Loop connector.
--
-- >  ,---------, 
-- >  |         |
-- >  '-o    @--'
--
-- The loop is drawn /above/ the points.
--
conna_loop :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
           => ConnectorPathSpec u
conna_loop = connLoopBody (trail_rect_loop CW) (trail_rect_loop CCW)
  

-- | Loop connector.
--
-- >  ,-o    @--, 
-- >  |         |
-- >  '---------'
--
-- The loop is drawn /below/ the points.
--
connb_loop :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
           => ConnectorPathSpec u
connb_loop = connLoopBody (trail_rect_loop CCW) (trail_rect_loop CW)


connLoopBody :: (Real u, Floating u, Tolerance u, InterpretUnit u) 
             => (u -> u -> u -> Vec2 u -> CatTrail u) 
             -> (u -> u -> u -> Vec2 u -> CatTrail u) 
             -> ConnectorPathSpec u
connLoopBody rightf leftf = catConnector $ \props p0 p1 -> 
    connectorLegs props     >>= \(src,dst) ->
    connectorLoopSize props >>= \looph ->
    return $ horizontally (rightf src dst looph) (leftf src dst looph) 
           $ pvec p0 p1



-- | Bezier curve connector - the control points are positioned 
-- horizontally respective to the source and dest.
--
-- >  *--@ 
-- >    .  
-- >   . 
-- >  o--*  
--
-- Note - the source and dest arm lengths are doubled, generally 
-- this produces nicer curves.
-- 
conn_hbezier :: (Real u, Floating u, InterpretUnit u, Tolerance u)
             => ConnectorPathSpec u
conn_hbezier = ConnectorPathSpec $ \props -> 
    qpromoteConn $ \p0 p1 -> 
    fmap (\(a,b) -> (2*a,2*b)) (connectorArms props) >>= \(src_arm,dst_arm) ->
    case horizontalDirection $ vdirection $ pvec p0 p1 of
      RIGHTWARDS -> right p0 p1 src_arm dst_arm
      _          -> left  p0 p1 src_arm dst_arm
  where
    right p0 p1 h0 h1 = return $ curve1 p0 (p0 .+^ hvec h0) (p1 .-^ hvec h1) p1

    left  p0 p1 h0 h1 = return $ curve1 p0 (p0 .-^ hvec h0) (p1 .+^ hvec h1) p1


-- | Bezier curve connector - the control points are positioned 
-- vertically respective to the source and dest.
--
-- >        @ 
-- >       .|  
-- >  *  .  *
-- >  |.
-- >  o
--
-- Note - the source and dest arm lengths are doubled, generally 
-- this produces nicer curves.
--
conn_vbezier :: (Real u, Floating u, InterpretUnit u, Tolerance u)
             => ConnectorPathSpec u
conn_vbezier = ConnectorPathSpec $ \props -> 
    qpromoteConn $ \p0 p1 -> 
    fmap (\(a,b) -> (2*a,2*b)) (connectorArms props) >>= \(src_arm,dst_arm) ->
      case verticalDirection $ vdirection $ pvec p0 p1 of
        UPWARDS -> up   p0 p1 src_arm dst_arm
        _       -> down p0 p1 src_arm dst_arm
  where
    up   p0 p1 v0 v1 = return $ curve1 p0 (p0 .+^ vvec v0) (p1 .-^ vvec v1) p1
    down p0 p1 v0 v1 = return $ curve1 p0 (p0 .-^ vvec v0) (p1 .+^ vvec v1) p1