Skip to content

Instantly share code, notes, and snippets.

@gsscoder gsscoder/RandomArt.hs
Last active Sep 23, 2015

Embed
What would you like to do?
Haskell port of F# http://fssnip.net/si
{-|
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."
@gsscoder

This comment has been minimized.

Copy link
Owner Author

gsscoder commented Sep 21, 2015

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

@gsscoder

This comment has been minimized.

@gsscoder

This comment has been minimized.

Copy link
Owner Author

gsscoder commented Sep 23, 2015

Two examples:
random22
random31

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.