module Diagram.Hasse where

import Control.Monad
import Data.Map qualified as Map
import Data.Maybe
import Data.Set qualified as Set
import Diagram qualified as D
import Diagrams.Backend.SVG.CmdLine
import Diagrams.Prelude
import Diagrams.TwoD

colors :: [Colour Double]
colors = map sRGB24read["#000000", "#D1DBBD", "#91AA9D", "#3E606F", "#193441", "#000000"]

hasseRow :: (V c ~ V2, Alignable c, HasOrigin c, Floating (N c), Juxtaposable c, Monoid' c) => (a -> c) -> [a] -> c
hasseRow f = centerX . hcat' (with & sep .~ 2) . map f

hasseDiagram
  :: forall vtx. (IsName vtx, Ord vtx)
  => (vtx -> QDiagram B V2 Double Any)
  -> D.Diagram vtx
  -> QDiagram B V2 Double Any
hasseDiagram f d = centerXY $ drawConnections setsD
  where
    setsD = vcat' (with & sep .~ fromIntegral n)
      . map (hasseRow f)
      . reverse
      $ subsets
    grades = D.verticesByGrade d
    subsets :: [[vtx]] = fmap (Set.toList . snd) $ Map.toList grades
    n :: Int = maximum $ Map.keys grades
    drawConnections = applyAll connections
    connections = concat $ zipWith connectSome subsets (tail subsets)
    connectSome subs1 subs2 =
      [ connect p s1 s2
      | s1 <- subs1
      , s2 <- subs2
      , p <- maybeToList $ Map.lookup s1 <=< Map.lookup s2 $ D._diagram_down d
      ]
    connect p v1 v2 =
      withNames [v1, v2] $ \[b1, b2] ->
        beneath (boundaryFrom b1 unitY ~~ boundaryFrom b2 unit_Y) # polarity p # lw thick

polarity p = lc $ case p of
  D.Positive -> red
  D.Negative -> blue

c x = named x $ text (show x) <> (unitSquare # lc black # fc grey # lw thin)

Right (x :: D.Diagram Int) = D.insert 3 1 (Map.fromList [(1, D.Negative), (2, D.Positive)]) =<< D.insert 2 0 mempty =<< D.insert 1 0 mempty D.empty

example = scale 100 $ pad 1.1 $ hasseDiagram c x

main :: IO ()
main = mainWith (example :: Diagram B)