# 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):

__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________


$n = 1$ would give:

__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
__________________________________________________
________________1_______________1_________________
_________________1_____________1__________________
__________________1___________1___________________
___________________1_________1____________________
____________________1_______1_____________________
_____________________1_____1______________________
______________________1___1_______________________
_______________________1_1________________________
________________________1_________________________
________________________1_________________________
________________________1_________________________
________________________1_________________________
________________________1_________________________
________________________1_________________________
________________________1_________________________
________________________1_________________________


And $n = 4$ would show:

__________________________________________________
_________1_1_1_1_1_1_1_1_1_1_1_1_1_1_1_1__________
__________1___1___1___1___1___1___1___1___________
__________1___1___1___1___1___1___1___1___________
___________1_1_____1_1_____1_1_____1_1____________
____________1_______1_______1_______1_____________
____________1_______1_______1_______1_____________
____________1_______1_______1_______1_____________
_____________1_____1_________1_____1______________
______________1___1___________1___1_______________
_______________1_1_____________1_1________________
________________1_______________1_________________
________________1_______________1_________________
________________1_______________1_________________
________________1_______________1_________________
________________1_______________1_________________
_________________1_____________1__________________
__________________1___________1___________________
___________________1_________1____________________
____________________1_______1_____________________
_____________________1_____1______________________
______________________1___1_______________________
_______________________1_1________________________
________________________1_________________________
________________________1_________________________
________________________1_________________________
________________________1_________________________
________________________1_________________________
________________________1_________________________
________________________1_________________________
________________________1_________________________


The code is not as clean as I'd like it to be, and I'm sure it's not idiomatic Haskell (I don't see any Arrows, Functors or more than two types), but I'd like to learn and improve my skills. Please have at it :)

module Main where

import Data.List (groupBy, sortOn)

data Point = Point Int Int
deriving Show

type Tree = [Point]

trunk :: Point -> Int -> Tree
trunk (Point x y) size = [Point x (y + d) | d <- [1..size]]

split :: Point -> [Point]
split (Point x y) = [Point (x + 1) (y + 1), Point (x - 1) (y + 1)]

branch :: Point -> Int -> Tree
branch start = branch' [start]
where branch' _ 0 = []
branch' [single] size = split single ++ branch' (split single) (size - 1)
branch' points size = widen points ++ branch' (widen points) (size - 1)
where widen [Point leftx lefty, Point rightx righty] = [Point (leftx + 1) (lefty + 1), Point (rightx - 1) (righty + 1)]

tree :: Point -> Int -> Int -> Tree
tree _ _ 0 = []
tree start size splits =
let trunks = trunk start size
branches = branch (last trunks) size
in
trunks ++ branches ++ concat [tree st (size div 2) (splits - 1) | st <- take 2 $reverse branches] formatTree :: Int -> Int -> Tree -> [String] formatTree width height = take height . flip (++) (repeat (replicate width '_')) . map (\points -> map (\x -> if x elem map (\(Point x _) -> x) points then '1' else '_') [1..width]) . groupBy (\(Point _ y1) (Point _ y2) -> y1 == y2) . sortOn (\(Point _ y) -> y) main :: IO () main = do sizeStr <- getLine let splits = read sizeStr mapM_ putStrLn$ reverse $formatTree 100 63$ tree (Point 50 0) 16 splits

• What is sortOn? – Caridorc Dec 14 '15 at 20:55
• hackage.haskell.org/package/base-4.8.1.0/docs/…. It works kind of like sortBy, but returns a value that is an instance of Ord, instead of an Ordering. – joranvar Dec 14 '15 at 21:01
• yes, thanks for the info, it is my ghc that is too old... – Caridorc Dec 14 '15 at 21:03

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.

Here's my attempt:

module Main where

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 <- [0..(height -1)]] | otherwise = [] -- draw vertical line verticalLine :: Point -> 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 <- newArray ((0, 0), (width - 1, height - 1)) False
forM_ tree $\p -> 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 <- readMaybe <$> 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.
• Interesting! I will certainly look into the Bifunctor class. I'm a bit hesitant to use mutability (even in Array.ST) but I will definitely experiment with it. Thanks for the clear answer! – joranvar Dec 17 '15 at 6:47