Solving Sierpinski Triangle in Haskell

Question

I am a Haskell beginner with a background in C++ and Python. I have been teaching myself Haskell for about half a year on and off and recently I started doing Hackerrank problems to improve my Haskell muscle. Sometimes I found myself struggling with problems that would be solved fairly easily with an imperative language. Sierpinski triangle is one of them.

My solution ends up much longer than I would have written in Python. Some of the submissions I read at Hackerrank took advantage of the fact that it is a 32 by 63 image to print out while I took a more general approach that should work for any 2^n by 2^(n+1)-1 image. First there is probably a much better general solution to the problem and further more, even with the general solution I have, I still believe that there should be a much more compact way of writing it in Haskell.

Here is my wall of text solution:

import Data.List (groupBy, sortBy, intercalate)

-- a triangle is defined by its vertices. (Int, Int) 
type Point = (Int, Int)
data Triangle = Triangle
                { upper :: Point
                , left :: Point
                , right :: Point
                , height :: Int } deriving (Show)

-- make a triangle from its upper vertex and its height
makeTriangle :: Point -> Int -> Triangle
makeTriangle upperVertex@(ux, uy) h
    | h > 1 && h `mod` 2 /= 0 = error ("no triangle with height " ++ show h)
    | otherwise = Triangle { upper=upperVertex
                           , left=leftVertex
                           , right=rightVertex
                           , height=h }
    where leftVertex = (ux-h+1, uy-h+1)
          rightVertex = (ux+h-1, uy-h+1)

getSection :: Int -> Triangle -> (Int, Int)
getSection h t
    | h < 1 || h > height t = error ("section out side of triangle:" ++ show h)
    | otherwise = let (ux, uy) = upper t
                  in (ux-h+1, ux+h-1)

-- returned triangles are sorted by their position from upper to bottom, 
-- and left to right
split :: Triangle -> [Triangle]
split t
    | h < 2 = error ("cannot split triangle with height less then 2")
    | h `mod` 2 /= 0 = error ("triangle height not multiplier of 2")
    | otherwise = [ upperOne
                  , (makeTriangle lUpperVertex h')
                  , (makeTriangle rUpperVertex h') ]
    where h = height t
          h' = h `div` 2
          upperOne = makeTriangle (upper t) h'
          lUpperVertex = let (x, y) = left upperOne in (x-1, y-1)
          rUpperVertex = let (x, y) = right upperOne in (x+1, y-1)

toWidth h = 2*h-1

triangleOrder :: Triangle -> Triangle -> Ordering
triangleOrder t1 t2
    | height t1 < height t2 = LT
    | height t2 > height t2 = GT
    | otherwise = if uy1 /= uy2 
                  then flip compare uy1 uy2 
                  else ux1 `compare` ux2
    where (ux1, uy1) = upper t1
          (ux2, uy2) = upper t2

-- total height -> iteration -> triangles 
sierpinski :: Int -> Int -> [Triangle]
sierpinski h 0 = [makeTriangle (h, h) h] 
sierpinski h n = concat $ map split $ sierpinski h (n-1)

groupTriangles ts = groupBy f $ sortBy triangleOrder ts
    where f t1 t2 = let (_, y1) = upper t1
                        (_, y2) = upper t2
                    in y1 == y2

type Picture = [[Char]]

makeCanvas :: Int -> Picture
makeCanvas h = replicate h $ replicate w '_'
    where w = toWidth h

drawPicture :: Picture -> IO ()
drawPicture picture = putStrLn $ intercalate "\n" picture

makeAscii :: Int -> [Triangle] -> Picture
makeAscii h ts = concat $ map drawGroup ts' 
    where ts' = groupTriangles ts
          w = toWidth h
          --tGroup is a group of triangles at the same height
          drawGroup tGroup = map draw [1..groupH]
                where groupH = height $ head tGroup
                      drawLine 0 _ = []
                      drawLine col [] = '_' : (drawLine (col-1) []) 
                      drawLine col intervals@((start, end):(ints))
                        | pos < start = '_' : (drawLine (col-1) intervals)
                        | pos > end = drawLine col ints
                        | otherwise = '1' : (drawLine (col-1) intervals)    
                        where pos = w - col + 1
                      draw l = drawLine w $ map (getSection l) tGroup


main = do
    n <- readLn :: IO Int
    drawPicture $ makeAscii 32 $ sierpinski 32 n

Answer 1

Just some details that can make your code shorter:

I'd keep just one of the points and the height in Triangle. And instead of the height, I'd keep its logarithm, which makes operations on triangles much easier. In general, it's better to keep just the data you need in your data types with as little additional constraints as possible.

type Point = (Int, Int)

data Triangle = Triangle
    { upper :: Point
    , heightLog :: Int
    } deriving (Eq, Show)

For comparing them, you can define an Ord instance to simplify your code. Instead of describing all the possible comparison states explicitly, you can take advantage of the Ord instance for tuples. So if you want to compare first by height, then by the Y axis and then by the X axis, you can write:

instance Ord Triangle where
    compare (Triangle (x1, y1) hl1) (Triangle (x2, y2) hl2) =
        compare (hl1, y1, x1) (hl2, y2, x2)

If you want to compare by Y in the opposite order, you can write compare (hl1, y2, x1) (hl2, y1, x2).

Now you don't need makeTriangle at all, and splitting them becomes simpler:

-- | Splits a triangle into its 3 components.
-- Returned triangles are sorted by their position from upper to bottom, 
-- and left to right
split :: Triangle -> [Triangle]
split (Triangle _ 0) = error "Cannot split singleton triangle"
split (Triangle u@(x, y) hl) =
    [ Triangle u hl'
    , Triangle (x - shift, y + shift) hl'
    , Triangle (x + shift, y + shift) hl'
    ]
  where
    hl' = hl - 1
    shift = 2^hl'

For iteration inside serpinski you can benefit from iterate and take the n-th element of the output. Note that thanks to laziness, you don't have to care that further elements in the list are not defined.

-- total height -> iteration -> triangles 
sierpinski :: Int -> Int -> [Triangle]
sierpinski h = (iterate (concatMap split) [Triangle (0, 0) h] !!)

For grouping, sorting etc. according to some property there are two very useful combinators: on, which we use here:

groupTriangles :: [Triangle] -> [[Triangle]]
groupTriangles = groupBy (on (==) (snd . upper)) . sort

and comparing.

(Unfortunately I don't have more time to review the rest, maybe later or someone else can continue.)

---

And I recommend reading various ways of constructing Serpinski triangle, it's quite likely that it's possible to build one straight from the top very easily.

Answer 2

I am also on my way to dive deeper into Haskell and it turns out that I am going through the same learning path in Hackerank. If you'd like to, I made a much shorter solution that still requires minor fixes but works with any height, width (2*height-1) and depth level. I still didn't figure out where does reside the problem yet in my code (works fine with depth <= 3), but maybe you can be inspired for a much shorter solution:

import Data.List (intercalate)

data Triangle = Triangle { up     :: Int
                         , height :: Int }
              deriving (Show, Eq)

fill :: Int -> Int -> Int -> [String]
fill h w s = let fillLn n = replicate (s-n) '_'   ++
                            replicate (1+2*n) '1' ++
                            replicate (w-s-n-1) '_'
              in map fillLn [0..h-1]

sierpinski :: Int -> Int -> [String]
sierpinski hgt n =
    let initt :: Int -> Int -> Int -> Int -> Int -> [String]
        initt h w s 0 _ = fill h w s
        initt h w s l d =
            let lvl1   = initt (div h 2) w s (l-1) (d+1)
                lvl2_1 = initt (div h 2) s (s-1-div w (2^(d+1))) (l-1) d
                lvl2_2 = initt (div h 2) (w-s-1) (div w (2^(d+1))) (l-1) d
                lvl2   = zipWith (++) lvl2_1 $ zipWith (++) (replicate (div h 2) "_") lvl2_2
             in lvl1 ++ lvl2
     in initt hgt (2*hgt-1) (hgt-1) n 1

draw :: [String] -> IO ()
draw mat = putStrLn $ intercalate "\n" mat

main :: IO ()
main = do
    n <- readLn :: IO Int
    draw $ sierpinski 32 n