56 lines
1.8 KiB
Haskell
56 lines
1.8 KiB
Haskell
|
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)
|