1
\$\begingroup\$

Here is an earlier attempt to solve the original problem: Solving Sierpinski Triangle in Haskell

I was never satisfied with my solution and found it was awkward and twisty. Here is another attempt to solve the same problem using Data.Array and I found that by using mutable arrays the solution becomes much shorter and easy to read.

import qualified Data.Array as DA (Array, listArray, (//), assocs)
import qualified Data.List as DL (groupBy, intercalate)
import qualified Data.Function as DF (on)

type Point = (Int, Int)
data Triangle = Triangle { up :: Point, height :: Int } deriving Show
type Canvas = DA.Array Point Char

emptyCanvas maxLevel = DA.listArray ((0, 1-h), (h-1, h-1)) $ repeat '_'
  where 
    h = 2^maxLevel -- 1*(2^maxLevel)

drawTriangle :: Triangle -> Canvas -> Canvas
drawTriangle (Triangle (r, c) h) canvas = foldr drawLine canvas $ map line [1..h]
  where 
    line h = let h' = h-1 in [(r+h', j) | j <- [c-h'..c+h']]
    drawLine l c = c DA.// map (\p -> (p, '1')) l

drawCanvas :: Canvas -> IO ()
drawCanvas canvas = putStrLn pic
  where
    rows = DL.groupBy ((==) `DF.on` (fst . fst)) . DA.assocs
    pic = DL.intercalate "\n" $ map (map snd) (rows canvas)

split hLvl (r, c) = let w = 2^(hLvl-1) in [(r, c), (r+w, c-w), (r+w, c+w)]

splitSier maxLevel (sierLevel, ts) = (sierLevel+1, ts')
  where
    ts' = ts >>= (split (maxLevel-sierLevel))

mkSierpinski :: Int -> Int -> Canvas
mkSierpinski maxLevel sierLevel
  | maxLevel >= sierLevel = foldr drawTriangle c $ allTriangles
  | otherwise = c
  where
    c = emptyCanvas maxLevel
    (l', ts') = head $ drop sierLevel $ iterate (splitSier maxLevel) (0, [(0, 0)])
    allTriangles = map (\p -> Triangle p (2^(maxLevel-l'))) ts'

main = do 
    sierLevel <- readLn
    drawCanvas $ mkSierpinski 5 sierLevel

The idea is to model the canvas by a 2-D array of Characters and attempt to draw easy individual triangles on top of the empty canvas. In this solution it starts with one big triangle and keep splitting to generate Sierpinski pattern. Another solution that I didn't post here attempts to solve it by starting with the smallest triangle at the top, and repeatedly copy what is current on canvas to its lower left corner and lower right corner. Both solutions look very similar at the end.

Please let me know if you have suggestions. Thank you in advance.

\$\endgroup\$
1
\$\begingroup\$

// is best called with one bulk list because each call incurs one O(n) array copy.

Folds over iterates when you need an index and know its range, it's like for vs. while.

drawCanvas :: Canvas -> IO ()
drawCanvas = putStrLn . unlines . map (map snd)
  . DL.groupBy ((==) `DF.on` fst . fst) . DA.assocs

mkSierpinski :: Int -> Int -> Canvas
mkSierpinski maxLevel sierLevel = emptyCanvas maxLevel DA.//
  [ ((r+h, j), '1')
  | maxLevel >= sierLevel
  , (r, c) <- DF.foldrM split (0, 0) [maxLevel-sierLevel+1..maxLevel]
  , h <- [0..2^(maxLevel-sierLevel)-1]
  , j <- [c-h..c+h]
  ]
\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.