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
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
-> Bool
-> 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..n1] , 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!!(i1) | 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
go _ = []
r2p2 :: V2 Double -> P2 Double
r2p2 v = origin .+^ v
p2r2 :: P2 Double -> V2 Double
p2r2 p = p .-. origin