field.hs

{-# LANGUAGE BangPatterns #-}


-- Preview on Youtube: http://www.youtube.com/watch?v=bK01Bgh32Sc

import Data.Complex

type C = Complex Float
type Color = (Float,Float,Float)
type Point = (Float,Float)

main :: IO ()
main = flip mapM_ [0 :: Float, 0.1 .. 5] $ \t -> do -- 125 = 1 period
  print t
  let output = renderer (2000,1000) (-1.2,-1.5) (0.5,0.6) function t
  writeFile ("temp/field/testimage_" ++ show t ++ ".ppm") output

function :: Float -> Point -> Color
function !t' !(x',y') = c2c $ n $ tc ** pc
  where
    pc = x :+ y
    tc = 8 * (n $ t ** x :+ (y - t))
    x  = x' + 0.6
    y  = y' + 0.3
    t  = 40 * (sin (t'/20) + 1)

c2c :: Complex Float -> Color
c2c !p@(r :+ i) = (r, i, (magnitude p))

n :: C -> C
n !(x :+ y) = nf sin x :+ nf cos y

nf :: Fractional a => (t -> a) -> t -> a
nf !fun !x = (fun x + 1) / 2

-- ppm

renderer :: (Int, Int) -> (Float, Float) -> (Float, Float) -> (Float -> Point -> Color) -> Float -> String
renderer !size !lowbound !highbound !fun !time = header size body
  where
    xs     = steps (fst lowbound) (fst highbound) (fst size)
    ys     = steps (snd lowbound) (snd highbound) (snd size)
    body   = unlines $ map line ys
    line y = decolor . point fun time y =<< xs

header :: (Show a, Show a1) => (a, a1) -> [Char] -> [Char]
header !(w,h) x = "P3\n" ++ show w ++ " " ++ show h ++ "\n255\n" ++ x

steps :: Float -> Float -> Int -> [Float]
steps !l !h !p = take p [l, l + (h - l) / fromIntegral p .. h]

point :: (t1 -> (t2, t3) -> t) -> t1 -> t3 -> t2 -> t
point !f !t !y !x = f t (x,y)

decolor :: Color -> String
decolor !(r,g,b) = ' ' : unwords [sf r, sf g, sf b]

-- The mod here is intentional, as part of the cool look comes from overflowing the bounds of the color values.
sf :: Float -> String
sf = (show :: Int -> String) . flip mod 255 . floor . (*255)