Render hasse diagram v0

proto.cabal

@@ -1,25 +1,5 @@
 cabal-version:      3.0
--- The cabal-version field refers to the version of the .cabal specification,
--- and can be different from the cabal-install (the tool) version and the
--- Cabal (the library) version you are using. As such, the Cabal (the library)
--- version used must be equal or greater than the version stated in this field.
--- Starting from the specification version 2.2, the cabal-version field must be
--- the first thing in the cabal file.
-
--- Initial package description 'proto' generated by
--- 'cabal init'. For further documentation, see:
---   http://haskell.org/cabal/users-guide/
---
--- The name of the package.
 name:               proto
-
--- The package version.
--- See the Haskell package versioning policy (PVP) for standards
--- guiding when and how versions should be incremented.
--- https://pvp.haskell.org
--- PVP summary:     +-+------- breaking API changes
---                  | | +----- non-breaking API additions
---                  | | | +--- code changes with no API change
 version:            0.1.0.0
 
 -- A short (one-line) description of the package.
@@ -28,55 +8,42 @@ version:            0.1.0.0
 -- A longer description of the package.
 -- description:
 
--- The license under which the package is released.
 license:            BSD-3-Clause
-
--- The file containing the license text.
 license-file:       LICENSE
-
--- The package author(s).
-author:             Obsidian Systems
-
--- An email address to which users can send suggestions, bug reports, and patches.
+author:             Ali Abrar, Cale Gibbard, Obsidian Systems
 maintainer:         maintainer@obsidian.systems
-
--- A copyright notice.
--- copyright:
+copyright: 2025 Obsidian Systems
 build-type:         Simple
-
--- Extra doc files to be distributed with the package, such as a CHANGELOG or a README.
 extra-doc-files:    CHANGELOG.md
 
--- Extra source files to be distributed with the package, such as examples, or a tutorial module.
--- extra-source-files:
-
 common warnings
     ghc-options: -Wall
 
 library
-    -- Import common warning flags.
     import:           warnings
 
-    -- Modules exported by the library.
-    exposed-modules: Diagram
+    exposed-modules:
+      Diagram
+      Diagram.Hasse
 
-    -- Modules included in this library but not exported.
-    -- other-modules:
-
-    -- LANGUAGE extensions used by modules in this package.
     default-extensions:
+      FlexibleContexts
       ImportQualifiedPost
       LambdaCase
       RankNTypes
+      ScopedTypeVariables
+      TypeOperators
 
-    -- Other library packages from which modules are imported.
     build-depends:    base ^>=4.19.2.0
                     , containers
                     , semialign
                     , these
+                    , colour
+                    , diagrams-contrib
+                    , diagrams-core
+                    , diagrams-lib
+                    , diagrams-svg
 
-    -- Directories containing source files.
     hs-source-dirs:   src
 
-    -- Base language which the package is written in.
     default-language: Haskell2010

src/Diagram.hs

@@ -1,9 +1,13 @@
 module Diagram
   ( Polarity(..)
   , Diagram
+  , _diagram_grades
+  , _diagram_down
+  , _diagram_up
   , empty
   , insert
   , InsertError(..)
+  , verticesByGrade
   ) where
 
 import Control.Monad
@@ -76,3 +80,7 @@ insert vtx grade down d = do
       That _ -> Left $ InsertError_UnknownDownVertex k
       These g _ | g == grade-1 -> pure ()
       These _ _ -> Left $ InsertError_DownVertexUnreachable k
+
+verticesByGrade :: Ord vtx => Diagram vtx -> Map Int (Set vtx)
+verticesByGrade (Diagram grades _ _) =
+  Map.fromListWith Set.union [ (grade, Set.singleton vtx) | (vtx, grade) <- Map.toList grades ]

src/Diagram/Hasse.hs

@@ -0,0 +1,55 @@
+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)