Haskell port of F# http://fssnip.net/si

random_art.hs

{-|
    Haskell port of F# http://fssnip.net/si
-}
import Control.Applicative ((<$>), (<*>))
import System.Random (randomIO, randomRIO)
import qualified Data.ByteString.Lazy as B
import Data.Word8

data Expr =
    VariableX
  | VariableY
  | Constant
  | Sum Expr Expr
  | Product Expr Expr
  | Mod Expr Expr
  | Well Expr
  | Tent Expr
  | Sin Expr
  | Level Expr Expr Expr
  | Mix Expr Expr Expr
  deriving Show

data Rgb a = Rgb a a a

instance (Show a) => Show (Rgb a) where
  show (Rgb r g b) = "Rgb (" ++ show r ++ "," ++ show g ++ "," ++ show b ++ ")"

instance Functor Rgb where
  fmap f (Rgb r g b) = Rgb (f r) (f g) (f b)

type Point = (Double, Double)

-- http://goo.gl/yFsQqL
mod' :: RealFrac a => a -> a -> a
mod' a 0 = a
mod' a b =
  let k = floor $ a / b
  in a - (fromInteger k) * b

next :: IO Double
next = randomIO :: IO Double

nextInt :: Int -> IO Int
nextInt max = randomRIO (0, max) :: IO Int

average :: Rgb Double -> Rgb Double -> Double -> Rgb Double
average (Rgb r g b) (Rgb r' g' b') w =
    Rgb (go r r') (go g g') (go r r')
        where go c c' = w * c + (1.0 - w) * c'

well :: Double -> Double
well x = 1.0 - 2.0 / (1.0 + x * x) ** 8.0

tent :: Double -> Double
tent x = 1.0 - 2.0 * abs x

eval :: Expr -> IO (Point -> Rgb Double)
eval VariableX = return $ \(x,y) -> Rgb x x x
eval VariableY = return $ \(x,y) -> Rgb y y y
eval Constant = do
                    (r,g,b) <- (,,) <$> next <*> next <*> next
                    return $ \(x,y) -> Rgb r g b
eval (Sum e e') = do
                    (f,f') <- (,) <$> eval e <*> eval e'
                    return $ \(x,y) -> average (f(x,y)) (f'(x,y)) 0.5
eval (Product e e') = do
                        (f,f') <- (,) <$> eval e <*> eval e'
                        return $ \(x,y) -> let Rgb r g b = f(x,y)
                                               Rgb r' g' b' = f'(x,y)
                                           in  Rgb (r * r') (g * g') (b * b')
eval (Mod e e') = do
                    (f,f') <- (,) <$> eval e <*> eval e'
                    return $ \(x, y) -> let Rgb r g b = f(x,y)
                                            Rgb r' g' b' = f'(x,y)
                                        in  Rgb (r `mod'` r') (g `mod'` g') (b `mod'` b')
eval (Well e) = do
                    f <- eval e
                    return $ \(x, y) -> fmap (well) (f(x,y))
eval (Tent e) = do
                    f <- eval e
                    return $ \(x, y) -> fmap (tent) (f(x,y))
eval (Sin e) = do
                    (phase',freq',f) <- (,,) <$> next <*> next <*> eval e
                    return $ \(x, y) -> let Rgb r g b = f(x,y)
                                            phase = phase' * pi
                                            freq = (freq' * 5.0) + 1.0
                                        in  Rgb (sin (phase + r * freq)) (sin (phase + g * freq)) (sin (phase + b * freq))
eval (Level e e' e'') = do
                            (f,f',f'',threshold') <- (,,,) <$> eval e <*> eval e' <*> eval e'' <*> next
                            return $ \(x, y) -> let Rgb r g b = f(x,y)
                                                    Rgb r' g' b' = f'(x,y)
                                                    Rgb r'' g'' b'' = f''(x,y)
                                                    threshold = (threshold' * 2.0) - 1.0
                                                    r_ = if r < threshold then r' else r''
                                                    g_ = if g < threshold then g' else g''
                                                    b_ = if b < threshold then b' else b''
                                                in  Rgb r_ g_ b_
eval (Mix e e' e'') = do
                            (f,f',f'') <- (,,) <$> eval e <*> eval e' <*> eval e''
                            return $ \(x, y) -> let Rgb n _ _ = f(x,y)
                                                    w = 0.5 * (n + 1.0)
                                                    c = f'(x,y)
                                                    c' = f''(x,y)
                                                in  average c c' w

gen :: Int -> IO Expr
gen k = do
    next' <- next
    if k <= 0 || next' < 0.01
        then do
            let terminals = [VariableX, VariableY, Constant]
            index' <- nextInt ((length terminals) - 1)
            return (terminals !! index')
        else do
            let n = \() -> nextInt k
            let operators = [  \() -> do
                                        (n',n'') <- (,) <$> n() <*> n()
                                        (e,e') <- (,) <$> gen n' <*> gen n''
                                        return $ Sum e e'
                             , \() -> do
                                        (n',n'') <- (,) <$> n() <*> n()
                                        (e,e') <- (,) <$> gen n' <*> gen n''
                                        return $ Product e e'
                             , \() -> do
                                        (n',n'') <- (,) <$> n() <*> n()
                                        (e,e') <- (,) <$> gen n' <*> gen n''
                                        return $ Mod e e'
                             , \() -> do
                                        n' <- n()
                                        e <- gen n'
                                        return $ Well e
                             , \() -> do
                                        n' <- n()
                                        e <- gen n'
                                        return $ Tent e
                             , \() -> do
                                        n' <- n()
                                        e <- gen n'
                                        return $ Sin e
                             , \() -> do
                                        (n',n'',m) <- (,,) <$> n() <*> n() <*> n()
                                        (e,e',e'') <- (,,) <$> gen n' <*> gen n'' <*> gen m
                                        return $ Level e e' e''
                             , \() -> do
                                        (n',n'',m) <- (,,) <$> n() <*> n() <*> n()
                                        (e,e',e'') <- (,,) <$> gen n' <*> gen n'' <*> gen m
                                        return $ Mix e e' e''
                            ]
            index' <- nextInt ((length operators) - 1)
            (operators !! index') ()

tga :: (Point -> Rgb Double) -> Int -> Int -> String -> IO ()
tga f width height path = do
    B.writeFile path (B.pack contents')
    where
        pxs = [((adjust x width),(adjust y height)) | y <- [0..height-1], x <- [0..width-1]]
        pxs' = fmap f pxs
        adjust p dim = (((toDouble p) + 0.5) - (toDouble dim) / 2) / (toDouble dim)
        header =
            [0,0,2,0,0,0,0,0,0,0,0,0,
                width `mod` 256, truncate (toDouble width / 256),
                height `mod` 256, truncate (toDouble height / 256),
                24,0]
        contents = header ++ (concat $ fmap (\(Rgb r g b) -> asByte b : asByte g : [asByte r]) pxs')
        contents' = fmap toWord8 contents
        asByte x = min 255 (max 0 (truncate (128.0 * (x + 1.0))))
        toWord8 x = (fromIntegral x) :: Word8
        toDouble x = (fromIntegral x) :: Double

save :: Int -> IO ()
save n = do
    e <- gen 50
    f <- eval e
    tga f 512 384 ("/Users/giacomo/temp/random/Random" ++ show n ++ ".tga")

loop :: Int -> (Int -> IO ()) -> IO ()
loop n f = loop' n f 0
  where loop' 0 f _   = return $ ()
        loop' n f acc = do
                          let n' = acc + 1
                          _ <- f n'
                          loop' (n - 1) f n'

main :: IO ()
main = do
    loop 1000 save
    putStrLn "done."

Personal excercize to learn Haskell... :) Comments are wellcome.

Thanks to SO guys for help with mod': http://stackoverflow.com/questions/32724534/find-the-origin-of-ratio-has-zero-denominator-exception/32725021#32725021.

Two examples: