Skip to content

Instantly share code, notes, and snippets.

@chrisdone
Last active October 7, 2017 09:12
Show Gist options
  • Save chrisdone/c46f6c76021e5e2666e835b84197a7e8 to your computer and use it in GitHub Desktop.
Save chrisdone/c46f6c76021e5e2666e835b84197a7e8 to your computer and use it in GitHub Desktop.
Drawing language: first attempt
{-# 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)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment