-- | Diagrams of non-crossing partitions
--
-- The code
--
-- > drawNonCrossingCircleDiagram' orange True $ NonCrossing [[3],[5,4,2],[7,6,1],[9,8]]
--
-- produces the diagram
--
-- <<svg/noncrossing.svg>>
--

{-# LANGUAGE FlexibleContexts, TypeFamilies #-}
module Math.Combinat.Diagrams.Partitions.NonCrossing where

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

import Math.Combinat.Partitions.NonCrossing

import Linear.Vector
import Linear.Affine

import Data.Colour

import Diagrams.Core
import Diagrams.Prelude
import Diagrams.TwoD.Text

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


-- | Draws a Ferrers diagram with the default settings (English notation, no boxes)
drawNonCrossingCircleDiagram :: (Renderable (Path V2 Double) b, Renderable (Text Double) b) => NonCrossing -> QDiagram b V2 Double Any
drawNonCrossingCircleDiagram = drawNonCrossingCircleDiagram' grey False


drawNonCrossingCircleDiagram' 
  :: (Renderable (Path V2 Double) b, Renderable (Text Double) b)
  => Colour Double            -- ^ color
  -> Bool                     -- ^ whether to write numbers from @[1..n]@ next to the set elements
  -> NonCrossing
  -> QDiagram b V2 Double Any
drawNonCrossingCircleDiagram' color hasnumbers (NonCrossing nc) = final where
   
  final  = xdots <> xparts <> xcirc <> (if hasnumbers then numbers else mempty)
  xparts = mconcat (map worker nc) # lc black # lwL linewidth # fc color
  xdots  = dots0 # lw none # fc black
  xcirc  = circle radius # lc red # lwL (linewidth*4)

  linewidth = 0.02 :: Double

  radius  = 1.0
  radius2 = radius + extraradius

  extraradius = 0.10
  ballradius  = 0.05

  superradius = 1.30

  n  = length $ concat nc
  fn = fromIntegral n

  r2p2 :: V2 Double -> P2 Double
  r2p2 v = origin .+^ v

  p2r2 :: P2 Double -> V2 Double
  p2r2 p = p .-. origin

  numbers = mconcat ns # lw none # fc blue 
  ns = [ translate v (scale 0.3 $ translate (r2 (0,-0.35)) $ text (show i)) 
       | (i,v) <- zip [1..n] (verticesR superradius) ] 

  verticesR :: Double -> [V2 Double]
  verticesR r = [ r2 (r * sin phi , r * cos phi) | i <- [0..n-1] , let phi = fromIntegral i * 2*pi/fn ]

  verticesP :: Double -> [P2 Double]
  verticesP r = map r2p2 (verticesR r)

  vtxs = verticesP radius  

  dots0 = mconcat [ translate vtx (circle ballradius # lc black) | vtx <- verticesR radius ]

  worker part = makeRoundedPolygonCCW extraradius [ vtxs!!(i-1) | i<-part ]

{-
  mkloop ixs  = ixs ++ [head ixs]
  worker [ix] = let p = vtxs !! (ix-1)
                in  translate (p2r2 p) (circle extraradius)
  worker part = translate (p2r2 $ vtxs !! (head part - 1)) 
              $ (strokeTrail $ glueTrail $ trailFromVertices $ mkloop [ vtxs!!(i-1) | i<-part ])
-}

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

makeRoundedPolygonCCW :: Renderable (Path V2 Double) b => Double -> [P2 Double] -> QDiagram b V2 Double Any
makeRoundedPolygonCCW radius xs = 

  case xs of 
    []      -> mempty
    [x]     -> translate (p2r2 x           ) $ circle radius
    (x:_)   -> translate (p2r2 x ^+^ iniOfs) $ strokeTrail stuff

  where

    stuff = glueTrail $ mconcat $ concat $ go (xs ++ take 2 xs)

    iniOfs = case xs of (p:q:_) -> iniOfs' p q 
    iniOfs' p q = radius *^ nx where
      u = q .-. p
      (ux,uy) = unr2 u
      ua  = atan2 uy ux
      ua' = ua - pi/2    
      nx  = r2 (cos ua' , sin ua')

    go (p:rest@(q:r:_)) = [ mySeg `mappend` myArc ] : go rest where
      mySeg = trailFromOffsets [u]

      myArc = scale radius arcCCW (angleDir angle1) (angleDir angle2)     

      u = q .-. p
      v = r .-. q
      (ux,uy) = unr2 u
      (vx,vy) = unr2 v
      ua = atan2 uy ux
      va = atan2 vy vx 
      ua' = ua - pi/2  :: Double 
      va' = va - pi/2  :: Double
      angle1 = ua' @@ rad :: Angle Double
      angle2 = va' @@ rad :: Angle Double  
      -- nx = radius *^ r2 (cos ua' , sin ua')
    go _ = []

    r2p2 :: V2 Double -> P2 Double
    r2p2 v = origin .+^ v

    p2r2 :: P2 Double -> V2 Double
    p2r2 p = p .-. origin

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