Render tableaux

standardsemiconductor · May 23, 2024 · 85bda84 · 85bda84
1 parent 621cb48
commit 85bda84
Showing 1 changed file with 15 additions and 0 deletions.
diff --git a/src/Bayeux/Tableaux.hs b/src/Bayeux/Tableaux.hs
@@ -1,10 +1,25 @@
 {-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE LambdaCase        #-}
 
 module Bayeux.Tableaux
   ( Tableaux(..)
+  , renderTableaux
   ) where
 
 data Tableaux a = Leaf   a
                 | Stem   a (Tableaux a)
                 | Branch a (Tableaux a) (Tableaux a)
   deriving (Eq, Foldable, Functor, Read, Show, Traversable)
+
+renderTableaux :: Tableaux String -> String
+renderTableaux = unlines . draw
+  where
+    draw = \case
+      Leaf a       -> lines a
+      Stem a t     -> lines a ++ drawSubTrees [t]
+      Branch a l r -> lines a ++ drawSubTrees [l, r]
+    drawSubTrees = \case
+      []   -> []
+      [t]  -> "\x2502" : shift "\x2502" "" (draw t)
+      t:ts -> "\x2502" : shift "\x251C\x2500\x2510" "\x2502 " (draw t) ++ drawSubTrees ts
+    shift first other = zipWith (++) (first : repeat other)