Drawing language: first attempt

Drawing.hs

{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wall #-}

-- Set your font to a monospace font which makes this character the same as the line-height: │
--
-- Otherwise, you'll see an ugly gap between connected lines if the
-- line-height of the font is high.
--
-- Example fonts:
--
-- * Menlo

import           Data.List
import           Data.List.Split
import           Data.Maybe
import           Data.String
import           Data.Tree
import           Data.Vector (Vector)
import qualified Data.Vector as V

--------------------------------------------------------------------------------
-- Demos

demo :: Tree Matrix
demo =
  Node
    "a"
    [ Node "a.a" [Node "a.a.a" [], Node "a.a.b" [], Node "a.a.c" []]
    , Node "a.b" [Node "a.b.a" [], Node "a.b.b" []]
    ]

html :: Tree Matrix
html =
  Node
    "html"
    [ Node "head" [Node "title" [], Node "meta" [], Node "link" []]
    , Node
        "body"
        [ Node "div" [Node "p" [Node "span" []], Node "blockquote" []]
        , Node "form" [Node "p" [Node "input" []]]
        ]
    ]

bigdemo :: Matrix
bigdemo =
  sideBySide
    (box (layoutTree Root demo))
    (aboveAndBelow
       (box "That is a tree!")
       (aboveAndBelow
          "This is some text."
          (box
             (grid
                [ map box ["Process", "CPU", "RAM"]
                , ["grep", "3%", "122MB"]
                , ["ghc", "23%", "58MB"]
                ]))))

--------------------------------------------------------------------------------
-- Simple tree drawing library

data Position = Root | Start | Middle | End

-- | WARNING: gnarly code.
layoutTree :: Position -> Tree Matrix -> Matrix
layoutTree position (Node label children) =
  if null children
    then boxPlusLimbs
    else aboveAndBelow
           (center (matrixWidth below) boxPlusLimbs)
           (if length childs == 1
              then below
              else aboveAndBelow connectors below)
  where
    boxPlusLimbs =
      merge
        (merge boxedLabel (center (matrixWidth boxedLabel) connector))
        (if null children
           then ""
           else shiftDown
                  (matrixHeight boxedLabel - 1)
                  (center (matrixWidth boxedLabel) "┬"))
      where
        boxedLabel = box label
        connector =
          case position of
            Root -> "─"
            _ -> "┴"
    connectors =
      mergeWith
        (\_ y ->
           case y of
             '┬' -> '┼'
             '─' -> '┴'
             _ -> y)
        inner
        (center (matrixWidth inner) "%")
      where
        inner =
          foldr1
            merge
            (snd
               (mapAccumL
                  (\x (pos, w) ->
                     ( x + w
                     , shiftRight
                         x
                         (let c =
                                center
                                  w
                                  (if length childs > 1
                                     then case pos of
                                            Start -> "╭"
                                            End -> "╮"
                                            Middle
                                              | length childs == 1 -> "│"
                                            _ -> "┬"
                                     else "│")
                          in merge
                               (fromString
                                  (map
                                     (\j ->
                                        case pos of
                                          Start
                                            | j <= div w 2 -> ' '
                                            | otherwise -> '─'
                                          End
                                            | j > div w 2 -> ' '
                                            | otherwise -> '─'
                                          _ -> '─')
                                     [1 .. w]))
                               c)))
                  0
                  childs))
    childs :: [(Position, Int)]
    childs = fst below0
    below = snd below0
    below0 =
      foldr
        (\(p, m1) (ws, m) -> ((p, matrixWidth m1) : ws, sideBySide m1 m))
        ([], "")
        (zipWith
           (\i c ->
              let position' =
                    if i == 1
                      then Start
                      else if i == length children
                             then End
                             else Middle
              in (position', layoutTree position' c))
           [1 ..]
           children)

--------------------------------------------------------------------------------
-- A simple box drawing library

-- | Center a matrix within the given width.
center :: Int -> Matrix -> Matrix
center w m = shiftRight ((div w 2) - (div (matrixWidth m) 2)) m

-- | Put the given matrix in a box.
box :: Matrix -> Matrix
box m =
  sideBySide
    (sideBySide verticalTop (aboveAndBelow (aboveAndBelow horizontal m) horizontal))
    verticalBottom
  where
    horizontal = fromString (replicate (matrixWidth m) '─')
    verticalTop =
      fromString
        (intersperse '\n' ('╭' : replicate (matrixHeight m) '│' ++ "╰"))
    verticalBottom =
      fromString
        (intersperse '\n' ('╮' : replicate (matrixHeight m) '│' ++ "╯"))

-- | Layout the set of matrixes in a grid.
grid :: [[Matrix]] -> Matrix
grid rows =
  foldr1
    aboveAndBelow
    (map (foldr1 sideBySide . zipWith merge columnPadding) rows)
  where
    columnPadding :: [Matrix]
    columnPadding =
      map
        (fromString . flip replicate ' ' . matrixWidth)
        (foldl'
           (\paddings columns ->
              zipWith (mergeWith (\_ _ -> ' ')) paddings columns)
           (repeat "")
           rows)

--------------------------------------------------------------------------------
-- A simple matrix library

render :: Matrix -> IO ()
render = putStrLn . printMatrix

-- | A 2D matrix of lines.
data Matrix = Matrix
  { matrixDim :: (Int, Int)
  , matrixGrid :: Vector Char
  } deriving (Show)

matrixWidth :: Matrix -> Int
matrixWidth = fst . matrixDim

matrixHeight :: Matrix -> Int
matrixHeight = snd . matrixDim

-- | To support string literals.
instance IsString Matrix where
  fromString s =
    Matrix
    { matrixDim = (w, length ls)
    , matrixGrid = V.fromList (concat ls)
    }
    where
      w = foldl' max 0 (map length ls0)
      ls = map (\line -> line ++ replicate (w - length line) ' ' ) ls0
      ls0 = splitOn "\n" s

-- | Render a matrix as its original string.
printMatrix :: Matrix -> String
printMatrix (Matrix (w, _) v) =
  concat
    (V.toList
       (V.imap
          (\i c ->
             if mod (1+i) w == 0 && i /= (V.length v-1)
               then [c, '\n']
               else [c])
          v))

-- | Position the matrices such that the first is above and the second is below.
aboveAndBelow :: Matrix -> Matrix -> Matrix
aboveAndBelow left@(Matrix (_, h) _) right = merge left (shiftDown h right)

-- | Merge two matrices by first shifting the right one to the width of the left one.
sideBySide :: Matrix -> Matrix -> Matrix
sideBySide left@(Matrix (w, _) _) right = merge left (shiftRight w right)

-- | Shift the characters in the matrix n rows down.
shiftDown :: Int -> Matrix -> Matrix
shiftDown n (Matrix (w0, h0) m) =
  Matrix
    (w0, h)
    (V.fromList
       [ fromMaybe ' ' (index x (y - n) w0 h0 m)
       | y <- [0 .. h - 1]
       , x <- [0 .. w0 - 1]
       ])
  where
    h = h0 + n

-- | Shift the characters in the matrix n columns to the right.
shiftRight :: Int -> Matrix -> Matrix
shiftRight n (Matrix (w0, h0) m) =
  Matrix
    (w, h0)
    (V.fromList
       [ fromMaybe ' ' (index (x - n) y w0 h0 m)
       | y <- [0 .. h0 - 1]
       , x <- [0 .. w - 1]
       ])
  where
    w = w0 + n

-- | Right-biased merge matrix a and matrix b.
merge :: Matrix -> Matrix -> Matrix
merge = mergeWith const

-- | Merge matrix a and matrix b with @f b a@.
mergeWith :: (Char -> Char -> Char) -> Matrix -> Matrix -> Matrix
mergeWith f (Matrix (w1, h1) m1) (Matrix (w2, h2) m2) =
  Matrix
    (w, h)
    (V.fromList
       [ fromMaybe
         ' '
         (case index x y w2 h2 m2 of
            Just c ->
              if c == ' '
                then index x y w1 h1 m1
                else case index x y w1 h1 m1 of
                       Just c' -> pure (f c c')
                       Nothing -> pure c
            Nothing -> index x y w1 h1 m1)
       | y <- [0 .. h - 1]
       , x <- [0 .. w - 1]
       ])
  where
    w = max w1 w2
    h = max h1 h2

-- | Index with bounds checks.
index :: Int -> Int -> Int -> Int -> Vector a -> Maybe a
index x y w h m =
  if x < 0 || y < 0 || x >= w || y >= h
    then Nothing
    else m V.!? (y * w + x)