Instantly share code, notes, and snippets.

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

 {-| 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."
Owner Author

### gsscoder commented Sep 21, 2015

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