Data commit

Task/Display-an-outline-as-a-nested-table/Haskell/display-an-outline-as-a-nested-table.hs

@@ -0,0 +1,142 @@
+{-# LANGUAGE TupleSections #-}
+
+module OutlineTree where
+
+import Data.Bifunctor (first)
+import Data.Bool (bool)
+import Data.Char (isSpace)
+import Data.List (find, intercalate)
+import Data.Tree (Tree (..), foldTree, levels)
+
+---------------- NESTED TABLES FROM OUTLINE --------------
+
+wikiTablesFromOutline :: [String] -> String -> String
+wikiTablesFromOutline colorSwatch outline =
+  intercalate "\n\n" $
+    wikiTableFromTree colorSwatch
+      <$> ( forestFromLineIndents
+              . indentLevelsFromLines
+              . lines
+          )
+        outline
+
+wikiTableFromTree :: [String] -> Tree String -> String
+wikiTableFromTree colorSwatch =
+  wikiTableFromRows
+    . levels
+    . paintedTree colorSwatch
+    . widthLabelledTree
+    . (paddedTree "" <*> treeDepth)
+
+--------------------------- TEST -------------------------
+main :: IO ()
+main =
+  ( putStrLn
+      . wikiTablesFromOutline
+        [ "#ffffe6",
+          "#ffebd2",
+          "#f0fff0",
+          "#e6ffff",
+          "#ffeeff"
+        ]
+  )
+    "Display an outline as a nested table.\n\
+    \    Parse the outline to a tree,\n\
+    \        measuring the indent of each line,\n\
+    \        translating the indentation to a nested structure,\n\
+    \        and padding the tree to even depth.\n\
+    \    count the leaves descending from each node,\n\
+    \        defining the width of a leaf as 1,\n\
+    \        and the width of a parent node as a sum.\n\
+    \            (The sum of the widths of its children)\n\
+    \    and write out a table with 'colspan' values\n\
+    \        either as a wiki table,\n\
+    \        or as HTML."
+
+------------- TREE STRUCTURE FROM NESTED TEXT ------------
+
+forestFromLineIndents :: [(Int, String)] -> [Tree String]
+forestFromLineIndents = go
+  where
+    go [] = []
+    go ((n, s) : xs) =
+      let (subOutline, rest) = span ((n <) . fst) xs
+       in Node s (go subOutline) : go rest
+
+indentLevelsFromLines :: [String] -> [(Int, String)]
+indentLevelsFromLines xs =
+  let pairs = first length . span isSpace <$> xs
+      indentUnit = maybe 1 fst (find ((0 <) . fst) pairs)
+   in first (`div` indentUnit) <$> pairs
+
+---------------- TREE PADDED TO EVEN DEPTH ---------------
+
+paddedTree :: a -> Tree a -> Int -> Tree a
+paddedTree padValue = go
+  where
+    go tree n
+      | 1 >= n = tree
+      | otherwise =
+        Node
+          (rootLabel tree)
+          ( (`go` pred n)
+              <$> bool nest [Node padValue []] (null nest)
+          )
+      where
+        nest = subForest tree
+
+treeDepth :: Tree a -> Int
+treeDepth = foldTree go
+  where
+    go _ [] = 1
+    go _ xs = (succ . maximum) xs
+
+----------------- SUBTREE WIDTHS MEASURED ----------------
+
+widthLabelledTree :: Tree a -> Tree (a, Int)
+widthLabelledTree = foldTree go
+  where
+    go x [] = Node (x, 1) []
+    go x xs =
+      Node
+        (x, foldr ((+) . snd . rootLabel) 0 xs)
+        xs
+
+------------------- COLOR SWATCH APPLIED -----------------
+
+paintedTree :: [String] -> Tree a -> Tree (String, a)
+paintedTree [] tree = fmap ("",) tree
+paintedTree (color : colors) tree =
+  Node
+    (color, rootLabel tree)
+    ( zipWith
+        (fmap . (,))
+        (cycle colors)
+        (subForest tree)
+    )
+
+-------------------- WIKITABLE RENDERED ------------------
+
+wikiTableFromRows :: [[(String, (String, Int))]] -> String
+wikiTableFromRows rows =
+  let wikiRow = unlines . fmap cellText
+      cellText (color, (txt, width))
+        | null txt = "| |"
+        | otherwise =
+          "| "
+            <> cw color width
+            <> "| "
+            <> txt
+      cw color width =
+        let go w
+              | 1 < w = " colspan=" <> show w
+              | otherwise = ""
+         in "style=\"background:"
+              <> color
+              <> "; \""
+              <> go width
+              <> " "
+   in "{| class=\"wikitable\" "
+        <> "style=\"text-align: center;\"\n|-\n"
+        <> intercalate "|-\n" (wikiRow <$> rows)
+        <> "|}"