-- | Diagrams of non-crossing partitions

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

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

import Math.Combinat.Partitions.NonCrossing

-- import Data.Monoid
import Data.AffineSpace
import Data.VectorSpace
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 R2) b, Renderable Text b) => NonCrossing -> Diagram b R2
drawNonCrossingCircleDiagram = drawNonCrossingCircleDiagram' grey False


drawNonCrossingCircleDiagram' 
  :: (Renderable (Path R2) b, Renderable Text b)
  => Colour Double            -- ^ color
  -> Bool                     -- ^ whether to write numbers from @[1..n]@ next to the set elements
  -> NonCrossing
  -> Diagram b R2
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 :: R2 -> P2 
  r2p2 v = origin .+^ v

  p2r2 :: P2 -> R2
  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 -> [R2]
  verticesR r = [ r2 (r * sin phi , r * cos phi) | i <- [0..n-1] , let phi = fromIntegral i * 2*pi/fn ]

  verticesP :: Double -> [P2]
  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 R2) b => Double -> [P2] -> Diagram b R2
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 = arc' radius (ua' @@ rad) (va' @@ rad)
      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    
      va' = va - pi/2    
      -- nx = radius *^ r2 (cos ua' , sin ua')
    go _ = []

    r2p2 :: R2 -> P2 
    r2p2 v = origin .+^ v

    p2r2 :: P2 -> R2
    p2r2 p = p .-. origin

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