The koch Snowflake implementation (with bmp exports)

kochSnowflake.hs

{-# language NoMonomorphismRestriction #-}
import Control.Monad
import Test.QuickCheck hiding (scale)
import Codec.BMP
import qualified Data.ByteString
import Data.Word

--------------------- Point & Vec etc ----------------------

type Scalar = Double
type Point = (Scalar, Scalar)
type Vec = (Scalar, Scalar)
type Line = (Point, Vec) -- a point on the line and the unit vector along the line
type Rect = (Point, Vec) -- a left-bottom-most point and a vector from the left-bottom-most point to the right-top-most point

vecAdd :: Vec -> Vec -> Vec
vecAdd (xa, ya) (xb, yb) = (xa + xb, ya + yb)

vecSub :: Vec -> Vec -> Vec
vecSub (xa, ya) (xb, yb) = (xa - xb, ya - yb)

vecDot :: Vec -> Vec -> Scalar
vecDot (xa, ya) (xb, yb) = (xa * xb + ya * yb)

vecScale :: Scalar -> Vec -> Vec
vecScale k (x, y) = (x * k, y * k)

vecVeer :: Vec -> Vec
vecVeer (x, y) = (-y, x)

vecLength :: Vec -> Scalar
vecLength (x, y) = sqrt (x * x + y * y)

vecUnit :: Vec -> Vec
vecUnit (x, y) = let l = vecLength (x, y) in (x / l, y / l)

windowSampling :: Rect -> [[Point]]
windowSampling ((x, y), (dx, dy)) = [[(c, r) | c <- [x .. x + dx - 1]] | r <- [y + dy - 1, y + dy - 2 .. y]]

------------------------- Graph ----------------------------

type Pixel = Bool
data Graph = Graph (Point -> Pixel)

inside :: Graph -> Point -> Bool
inside (Graph f) p = f p

intersect :: Graph -> Graph -> Graph
intersect ga gb = Graph (\p -> (inside ga) p && (inside gb) p)

union :: Graph -> Graph -> Graph
union ga gb = Graph (\p -> (inside ga) p || (inside gb) p)

move :: Vec -> Graph -> Graph
move vec g = Graph (\p -> (inside g) (p `vecSub` vec))

scale :: Scalar -> Graph -> Graph
scale k g = Graph (\(x, y) -> (inside g) (x / k, y / k))

mirror :: Line -> Graph -> Graph
mirror l g = Graph (\p -> (inside g) (mirrorPoint l p)) where
    mirrorPoint (lp, lv) p = p' where
        ln = vecVeer lv
        d = (p `vecSub` lp) `vecDot` ln
        p' = p `vecAdd` (vecScale (-2 * d) ln)

-------------- Koch Curve & Koch Snowflake -----------------

kochCurve = Graph f where
    l = 1.0
    h = (sqrt 3 / 2)
    f (x, y) =
        if y > (h / 3) then False
        else if y <= 0 then True
        else if abs x + (1 / sqrt 3) * y <= 1 / 6 then True
        else inside (leftHalf `intersect` rightHalf) (x, y) where
            leftHalf = mirror ((0, 0), (0, 1)) rightHalf
            rightHalf = leftCurve `union` rightCurve where
                leftCurve = mirror ((1 / 6, 0), vecUnit (1, sqrt 3)) rightCurve
                rightCurve = move (1 / 3, 0) (scale (1 / 3) kochCurve)

kochCurveBBox l = ((-l/2, 0), (l, (sqrt 3 / 6) * l))

kochSnowflake = topCurve `intersect` leftCurve `intersect` rightCurve where
    topCurve = kochCurve
    leftCurve = mirror ((0, 0), (0, 1)) rightCurve
    rightCurve = mirror ((1 / 2, 0), vecUnit (sqrt 3, 1)) topCurve

kochSnowflakeBBox l = ((-l/2, -(sqrt 3 / 2)*l), (l, (sqrt 3 / 2 + sqrt 3 / 6)*l))

insideSnowflake :: Point -> Bool
insideSnowflake = inside kochSnowflake

------------------------- Console --------------------------

showPixel True = "#"
showPixel False = " "

drawAscii :: Rect -> Graph -> IO ()
drawAscii rect (Graph f) = do
    forM_ (windowSampling rect) $ \row -> do
        forM_ row $ \p -> do
            putStr $ showPixel $ f p
        putStrLn ""

drawKochCurve = let l = 60 in drawAscii (kochCurveBBox l) (scale l kochCurve)
drawSnowflake = let l = 60 in drawAscii (kochSnowflakeBBox l) (scale l kochSnowflake)

dc = drawKochCurve
ds = drawSnowflake

------------------------ Export BMP ------------------------

bmpPixel True = [0, 0, 0, 0]
bmpPixel False = [255, 255, 255, 255]

drawBmp :: Rect -> Graph -> BMP
drawBmp rect (Graph f) = packRGBA32ToBMP width height (Data.ByteString.pack pixels) where
    (_, (w, h)) = rect
    (width, height) = (round w, round h)
    pixels = concat $ do
        row <- windowSampling rect
        p <- row
        return $ bmpPixel (f p)

exportBMP = writeBMP fileName bmp where
    fileName = "./test.bmp"
    l = 500
    bmp = drawBmp (kochSnowflakeBBox l) (scale l kochSnowflake)

--------------------------- Tests --------------------------

propVecAddZero :: Vec -> Bool
propVecAddZero v = vecAdd v (0, 0) == v && vecAdd (0, 0) v == v

propVecAddAndSubReversible :: Vec -> Vec -> Bool
propVecAddAndSubReversible va vb = vecLength (vecSub (va `vecAdd` vb `vecSub` vb) va) < 1e-6

propVecVeerPeriodicity :: Vec -> Bool
propVecVeerPeriodicity v = (vecVeer . vecVeer . vecVeer . vecVeer $ v) == v

runTest = do
    let run = quickCheck
    run propVecAddZero
    run propVecAddAndSubReversible
    run propVecVeerPeriodicity