The ugly Christmas tree, Haskell style

Question

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

Answer 1

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 <- [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.