Use Unicode for tree drawing

This commit is contained in:
George Thomas 2026-01-07 00:55:46 +00:00
parent fb2d412f95
commit aefb7f067f

View File

@ -49,6 +49,7 @@ module Pre (
allUnorderedPairs, allUnorderedPairs,
adjacentPairs, adjacentPairs,
sortPair, sortPair,
drawTree,
HList (..), HList (..),
HListC (..), HListC (..),
HListF (..), HListF (..),
@ -127,7 +128,7 @@ import Data.Text.IO qualified as T
import Data.Text.Lazy qualified as TL import Data.Text.Lazy qualified as TL
import Data.Time import Data.Time
import Data.Traversable import Data.Traversable
import Data.Tree import Data.Tree hiding (drawTree)
import Data.Tuple.Extra ((&&&)) import Data.Tuple.Extra ((&&&))
import Data.Void import Data.Void
import Data.Word import Data.Word
@ -184,6 +185,19 @@ adjacentPairs = \case
sortPair :: (Ord a) => (a, a) -> (a, a) sortPair :: (Ord a) => (a, a) -> (a, a)
sortPair (a, b) = if a <= b then (a, b) else (b, a) sortPair (a, b) = if a <= b then (a, b) else (b, a)
-- | This is `Data.Tree.drawTree` with the ASCII characters replaced with Unicode box drawing characters.
drawTree :: Tree String -> String
drawTree = unlines . draw
where
draw (Node x ts0) = lines x ++ drawSubTrees ts0
where
drawSubTrees [] = []
drawSubTrees [t] =
"" : shift_ "└─ " " " (draw t)
drawSubTrees (t : ts) =
"" : shift_ "├─ " "" (draw t) ++ drawSubTrees ts
shift_ first_ other = zipWith (++) (first_ : repeat other)
type PuzzleParts input = HListF ((Fanout ((->) input) (Op Text))) type PuzzleParts input = HListF ((Fanout ((->) input) (Op Text)))
infixr 9 /\\ infixr 9 /\\
(/\\) :: (input -> output, output -> Text) -> PuzzleParts input outputs -> PuzzleParts input (output : outputs) (/\\) :: (input -> output, output -> Text) -> PuzzleParts input outputs -> PuzzleParts input (output : outputs)