{-# LANGUAGE BangPatterns #-}
module Main where
import Control.Applicative
import Control.Monad ()
import Data.Complex
import Data.List as L
import System.Environment
sa :: Show a => a -> ShowS
sa = shows
sc :: Char -> ShowS
sc = showChar
ss :: String -> ShowS
ss = showString
hsvToRgb :: (Double, Double, Double) -> (Double, Double, Double)
hsvToRgb (h, s, v)
| s == 0 = (v, v, v)
| v > 1 = hsvToRgb (h, s, 1)
| h < 1 = (v, t, p)
| h < 2 = (q, v, p)
| h < 3 = (p, v, t)
| h < 4 = (p, q, v)
| h < 5 = (t, p, v)
| otherwise = (v, p, q)
where
f = h - fromIntegral (floor h)
p = v * (1 - s)
q = v * (1 - s * f)
t = v * (1 - s * (1 - f))
rgbToXTerm :: (Double, Double, Double) -> Integer
rgbToXTerm (r, g, b) = round $ 16 + r * 216 + g * 36 + b * 6
rgb255 :: (Double, Double, Double) -> (Integer, Integer, Integer)
rgb255 (r, g, b) = (c r, c g, c b)
where c = floor . (* 255)
hsvToXTerm :: (Double, Double, Double) -> Integer
hsvToXTerm = rgbToXTerm . hsvToRgb
mandelbrot :: Integer -> Double -> Double -> Double -> [Integer]
mandelbrot w yOff xOff zoom = getIntensity <$> xCoords <*> yCoords
where
wOff = 2 / fromIntegral (w - 1)
xCoords = L.genericTake w $ iterate (+ wOff * zoom) (- zoom + xOff)
yCoords = L.genericTake w $ iterate (+ wOff * 0.5 * zoom) (-zoom + yOff)
getIntensity x y = fst . iterations p . (,) 0 $ p
where p = y :+ x
iterations _ (500, _) = (0, 0 :+ 0)
iterations c (count, z) = if isIn then next else (count, z)
where
z' = z ^ 2 + c
isIn = magnitude z' < 2
next = iterations c (count + 1, z')
gen :: (Bool -> Integer -> ShowS) -> Integer -> [Integer] -> ShowS
gen f w = fst . foldl' put (ss "", 0)
where
put (!s, x) !i = let last = x >= w - 1 in (s . f last i, if last then 0 else x + 1)
genHsv :: Double -> Integer -> (Double, Double, Double)
genHsv fac i = (fromIntegral i / 83, 1, sqrt (fromIntegral i / 5) * fac)
genAEC :: Integer -> [Integer] -> String
genAEC w = ($ "\ESC[0m") . gen put w
where
col 0 _ = col 1 ' '
col i c = ss "\ESC[48;5;" . cl . ss "m\ESC[38;5;" . cl . sc 'm' . sc c . ss "\ESC[0m"
where
cl = sa . hsvToXTerm . genHsv 0.04 $ i
put False i = col i '*'
put True i = put False i . sc '\n'
genPPM :: Integer -> [Integer] -> String
genPPM w c = ss "P3\n" . sa w . sc ' ' . sa len . ss "\n255\n" . gen put w c $ ""
where
--len = L.genericLength c `quot` w
len = w
endChar True = '\n'
endChar False = '\t'
put last i = case rgb255 . hsvToRgb . genHsv 0.5 $ i of
(b, g, r) -> sa r . sc ' ' . sa g . sc ' ' . sa b . sc (endChar last)
main :: IO ()
main = getArgs >>= \as -> case as of
(w : x : y : z : (f : []) : _) -> ma w x y z f
(w : x : y : z : _) -> ma w x y z 'a'
(w : x : y : []) -> ma w x y "0.5" 'a'
(w : x : []) -> ma w x "0" "0.5" 'a'
(w : [] ) -> ma w "0.5" "0" "0.5" 'a'
[] -> ma "80" "0.5" "0" "0.5" 'a'
where ma ws xs ys zs fs =
let
w = read ws :: Integer
x = read xs :: Double
y = read ys :: Double
z = 1 / read zs :: Double
f = case fs of
'a' -> genAEC
'p' -> genPPM
_ -> error "Invalid format."
in putStrLn . f w . mandelbrot w x y $ z
