1 files changed, 89 insertions, 0 deletions
diff --git a/app/Pretty.hs b/app/Pretty.hs
new file mode 100644
index 0000000..8054acc
--- /dev/null
+++ b/app/Pretty.hs
@@ -0,0 +1,89 @@
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
+
+module Pretty
+  ( Doc (..),
+    Pretty,
+    pretty,
+    diagram,
+    module Pretty.Color,
+    color,
+    colorDull,
+  )
+where
+
+import Pretty.Color
+
+data Doc
+  = Col [Doc]
+  | Lit (Maybe (Intensity, Color)) String
+  deriving (Show, Eq)
+
+class Pretty a where
+  pretty :: a -> Doc
+
+instance Pretty Char where
+  pretty = pretty . (: [])
+
+instance Pretty String where
+  pretty = Lit Nothing
+
+diagram :: Int -> [Float] -> Doc
+diagram w xs = Col (map chart (discretize xs'))
+  where
+    xs' = replicate (2 * w - length xs) 0 ++ reverse (take (2 * w) xs)
+
+    chart :: (Int, Int) -> Doc
+    chart n = colorize n (pretty (chart' n))
+
+    chart' (0, 0) = '⠀'
+    chart' (0, 1) = '⢀'
+    chart' (0, 2) = '⢠'
+    chart' (0, 3) = '⢰'
+    chart' (0, 4) = '⢸'
+    chart' (1, 0) = '⡀'
+    chart' (1, 1) = '⣀'
+    chart' (1, 2) = '⣠'
+    chart' (1, 3) = '⣰'
+    chart' (1, 4) = '⣸'
+    chart' (2, 0) = '⡄'
+    chart' (2, 1) = '⣄'
+    chart' (2, 2) = '⣤'
+    chart' (2, 3) = '⣴'
+    chart' (2, 4) = '⣼'
+    chart' (3, 0) = '⡆'
+    chart' (3, 1) = '⣆'
+    chart' (3, 2) = '⣦'
+    chart' (3, 3) = '⣶'
+    chart' (3, 4) = '⣾'
+    chart' (4, 0) = '⡇'
+    chart' (4, 1) = '⣇'
+    chart' (4, 2) = '⣧'
+    chart' (4, 3) = '⣷'
+    chart' (4, 4) = '⣿'
+    chart' _ = error "chart': argument >4 (or <0)"
+
+    colorize (n, m) = colorize' (max n m)
+
+    colorize' 0 = colorDull Green
+    colorize' 1 = color Green
+    colorize' 2 = colorDull Yellow
+    colorize' 3 = color Yellow
+    colorize' 4 = color Red
+    colorize' _ = error "colorize': argument >4 (or <0)"
+
+    discretize :: [Float] -> [(Int, Int)]
+    discretize [] = []
+    discretize (_ : []) = []
+    discretize (x1 : x2 : xs) =
+      (round (x1 * 4), round (x2 * 4)) : discretize xs
+
+color :: Color -> Doc -> Doc
+color c = color' (Vivid, c)
+
+colorDull :: Color -> Doc -> Doc
+colorDull c = color' (Dull, c)
+
+color' :: (Intensity, Color) -> Doc -> Doc
+color' c (Lit _ s) = Lit (Just c) s
+color' c (Col ds) = Col (map (color' c) ds)