Haskell IFS (Iterated Funcion System) image generator

ifs.hs

import System.Random
import Graphics.Rendering.Cairo

data IfsFunction a = IfsFunction a a a a a a a deriving Show
type Ifs a = [IfsFunction a]

calcIfs (IfsFunction a b c d e f _) (x, y) = (a*x + b*y + c, d*x + e*y + f)

-- Calculates [p1, p1 + p2, p1 + p2 + p3, ..., p1 + ... + pn] list
-- of give Ifs, where p_i is i'th function probability.
getProbSum ifs = getProbSum' ifs 0 where
    getProbSum' [] _ = []
    getProbSum' ((IfsFunction _ _ _ _ _ _ p):xs) s = ps:prest where
        ps = p + s
        prest = (getProbSum' xs ps)

-- Gets function selected by r value.
getFunc ifs probSum r = parseResult result where
    parseResult [] = last ifs
    parseResult l = fst $ head result

    result = dropWhile condition (zip ifs probSum)
    condition = \(_, p) -> p < r

-- Makes an infinite list of points which belongs to this ifs
producePoints ifs randomGen startPoint = fst $ unzip $ drop 1 pairList where
    pairList = iterate f (startPoint, randomList)
    randomList = randoms randomGen :: (Random t, Fractional t) => [t]
    probSum = getProbSum ifs

    f (point, r:rs) = let
        newPoint = calcIfs (getFunc ifs probSum r) point
        in (newPoint, rs)

-- Scales ifs points into image plane. May give points outside image bounds.
ifsToImage width height minX maxX minY maxY = map mapFunc where
    ratioX = (maxX - minX) / width
    ratioY = (maxY - minY) / height
    mapFunc (x, y) = ((x - minX) / ratioX, (y - minY) / ratioY)

-- Filters out points outside image bounds.
filterOutsidePoints width height = filter filterFunc where
    filterFunc (x, y) = (x >= 0) && (x < width) && (y >= 0) && (y < height)

produceImagePoints ifs randomGen startPoint iterations
    width height minX maxX minY maxY= let
        points = producePoints ifs randomGen startPoint
        imagePoints = take iterations $ ifsToImage width height
                                                   minX maxX minY maxY points
        filteredPoints = filterOutsidePoints width height imagePoints
    in filteredPoints

-------------------------------------------------------------------------------

ifs1 = [IfsFunction 0.0 0.0 0.16 0.0 0.0 0.0 0.01,
        IfsFunction 0.85 0.04 0.0 0.04 0.85 1.6 0.85,
        IfsFunction 0.2 (-0.26) 0.0 0.23 0.22 1.6 0.07,
        IfsFunction 0.15 0.28 0 0.26 0.24 0.44 0.07]

-------------------------------------------------------------------------------

main = do
    gen <- getStdGen

    let pnw = 600
        pnh = 600
        imagePoints = produceImagePoints ifs1 gen (0.0, 0.0) 100000
                      (fromIntegral pnw) (fromIntegral pnh) (-5) 5 (-5) 5

    withImageSurface FormatARGB32 pnw pnh $ draw imagePoints pnw pnh

draw imagePoints pnw pnh srf = do
    renderWith srf (do setSourceRGB 1 1 1; paint)
    renderWith srf (drawPoints imagePoints)
    surfaceWriteToPNG srf "myDraw.png"

drawPoints [] = return ()
drawPoints ((x,y):ps) = do
    setSourceRGB 0 1 0
    rectangle x y 1 1
    fill
    drawPoints ps