The ugly Christmas tree, Haskell style

Inspired by a few inverse tree ascii art F# questions, I wanted to give it a shot in Haskell.

As seen in the linked questions, the resulting program reads an Int from stdin (\$0 \leq n \leq 5\$), and displays a tree of dimensions 100 * 63, consisting of \$n\$ Y-formed "trunks-and-branches" of which the three arms each have a height of \$16/2^{i-1}\$ (that is, the branch is \$16/2^{i-1}\$ high, and the branches are \$16/2^{i-1}\$ high). After each branch, the next Y-formed iterations start at the tops of the last Ys, until \$i\$ reaches \$n\$.

The Ys are drawn in a 100 * 63 field of _ characters, and drawn with 1 characters. An example for \$n = 0\$ would be (halving all given dimensions to save space):

```
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
_________________________________________

You can change your Point definition to some type that implements Bifunctor. Earlier bifunctor was part of bifunctors package. Bifunctor is functor of two arguments. Here you can find more info. In case you wouldn't like to change definition of Point you can define bimap-like function for your type.

Your formatTree function inefficient, since you are sorting, grouping and do some other operations with list. I've used 2D array to represent canvas state, that approach asymptotically better, since we can loop only one time. During initialization array is mutable in ST monad and then converted to immutable via runSTArray.

Also, I added error handling.

Here's my attempt:

module Main where

import Control.Monad (forM_, mapM_)
import Control.Applicative (())
import Data.Bifunctor (bimap, first, second)
import Data.Array.MArray (newArray, writeArray)
import Data.Array.ST (runSTArray)
import Data.Array (Array, bounds, (!))
import Text.Read (readMaybe)

type Point = (Int, Int)
type Tree = [Point]
type CordSum = (Int -> Int -> Int)
type Canvas = Array (Int, Int) Bool

makePoint :: Int -> Int -> Point
makePoint = (,)

line :: CordSum -> CordSum -> Point -> Int -> Tree
line fX fY p height
    | height > 0 = [bimap (fX h) (fY h) p | h  Int -> Tree
verticalLine = line (flip const) (+) 

-- draw diagonal line to right
diagonalLineR :: Point -> Int -> Tree
diagonalLineR = line (+) (+)

-- draw diagonal line to left
diagonalLineL :: Point -> Int -> Tree
diagonalLineL = line subtract (+)

-- draw subtree
subtree :: Point -> Int -> Tree
subtree p height = verticalLine p height ++
                   diagonalLineL pl height ++
                   diagonalLineR pr height
  where
    pl = bimap (subtract 1) (+height) p
    pr = bimap (+1) (+height) p

-- calc cords of next subtree
subtreeNext :: Point -> Int -> (Point, Point)
subtreeNext p h = (pel, per)
  where
    next_h = 2 * h
    pel = bimap (subtract h) (+ next_h) p
    per = bimap (+ h) (+ next_h) p

tree :: Point -> Int -> Int -> Tree
tree _ _ 0 = []
tree _ 0 _ = []
tree start height splits = subtree start height ++ left_tree ++ right_tree
  where
    height' = height `div` 2
    splits' = splits - 1
    (pl, pr) = subtreeNext start height
    left_tree = tree pl height' splits'
    right_tree = tree pr height' splits'

toCanvas :: Int -> Int -> Tree -> Maybe Canvas
toCanvas width height tree
    | width > 0 && height > 0 = Just canvasArr
    | otherwise = Nothing
  where
    pointToIndex = id
    canvasArr = runSTArray $ do
        arr  writeArray arr (pointToIndex p) True
        return arr

canvasToStrings :: Char -> Char -> Canvas -> [String]
canvasToStrings f t can = strLine  yCords
  where
    (_, (maxX, maxY)) = bounds can
    xCords = enumFromThenTo maxX (maxX - 1) 0
    yCords = enumFromThenTo maxY (maxY - 1) 0
    toChar False = f
    toChar True = t
    strLine y = (\x -> toChar $ can ! (x, y))  xCords

drawCanvas :: Canvas -> IO ()
drawCanvas can = mapM_ putStrLn $ canvasToStrings '_' '1' can

main :: IO ()
main = do
    mSize  getLine
    case mSize of
        Just sp -> case toCanvas 100 63 (tree (makePoint 50 0) 16 sp) of
            Just canv -> drawCanvas canv
            Nothing   -> putStrLn "N is to small"
        Nothing -> putStrLn "Please type integer"

Also you can view code here.

Some notes:

• You to often pattern match your Point type, you can define some access functions or use record syntax. For example you can define getX and getY functions to access x and y coordinates.

• groupBy (\(Point _ y1) (Point _ y2) -> y1 == y2) can be rewritten as groupBy ((==) on getY) in case you define getY. Here you can find more about on function.

StackExchange Code Review Q#113952, answer score: 6