hps-0.1: Help/Fractal.hs

module Fractal (fractal, fractalArrow, sierpinski) where

import Graphics.PS

-- | ftp://ftp.scsh.net/pub/scsh/contrib/fps/doc/examples/fractal-sqr.html
fractal :: Pt -> Pt -> Int -> [(Pt, Pt)]
fractal p1 p2 0 = [(p1, p2)]
fractal p1 p2 d = fractal p1 p3 (d - 1) ++ fractal p3 p2 (d - 1)
    where (Pt x1 y1) = p1
          (Pt x2 y2) = p2
          x3         = ((x1 + x2) / 2) + ((y2 - y1) / 2)
          y3         = ((y1 + y2) / 2) - ((x2 - x1) / 2)
          p3         = Pt x3 y3

-- | ftp://ftp.scsh.net/pub/scsh/contrib/fps/doc/examples/fractal-arrow.html
fractalArrow :: Double -> Int -> Path
fractalArrow h d = (translate x y . scale h h) a
    where x = (576 - h) / 2 + h / 2
          y = (720 - h) / 2
          a = unitArrow d

unitArrow :: Int -> Path
unitArrow 1 = MoveTo (Pt 0 0) +++ LineTo (Pt 0 1)
unitArrow d = unitArrow 1
              +++ (translate 0 1 . rotate cw)  sa
              +++ (translate 0 1 . rotate ccw) sa
    where s   = 0.6
          sa  = scale s s (unitArrow (d - 1))
          cw  = - (radians 135)
          ccw = - cw

-- | Equilateral right angled triangle
erat :: Pt -> Double -> Path
erat (Pt x y) n = polygon [Pt x y, Pt (x+n) y, Pt x (y+n)]

-- | Sierpinski triangle.
sierpinski :: Pt -> Double -> Double -> Path
sierpinski p n limit | n <= limit = erat p n
                     | otherwise  = t1 +++ t2 +++ t3
    where m        = n / 2
          (Pt x y) = p
          s q      = sierpinski q m limit
          t1       = s p
          t2       = s (Pt x (y + m))
          t3       = s (Pt (x + m) y)