Shootout/Mandelbrot

-- The Great Computer Language Shootout
-- http://shootout.alioth.debian.org/
-- Based on version by Don Stewart
-- Contributed by Trevor McCort
 
import System
import Data.Bits
import Data.Word
import GHC.Base
 
main = do
    w <- getArgs >>= readIO . head
 
    let ch = chr.fromIntegral
        sh = show $ fromEnum w
        (bw::Int) = ceiling $ w / 8
 
        gb x ci b n
            | x == w    = ch $ b `shiftL` n
            | n == 0    = ch b
            | otherwise = gb (x+1) ci (b+b+(lp 0.0 0.0 50 cr ci)) (n-1)
            where cr = x * 2.0 / w - 1.5
 
        ms bx x y ci
            | y == w    = []
            | bx == bw  = gb x ci 0 8 : ms 1 0 (y+1) ((y+1) * 2.0 / w - 1.0)
            | otherwise = gb x ci 0 8 : ms (bx+1) (x+8) y ci
 
    putStrLn ("P4\n"++sh++" "++sh)
    mapM_ putChar $ ms 1 0 0 (-1.0)
 
lp r i k cr ci | r2 + i2 > (4.0 :: Double) = 0 :: Word32
               | k == (0 :: Word32)        = 1
               | otherwise                 = lp (r2-i2+cr) ((r+r)*i+ci) (k-1) cr ci
    where r2 = r*r ; i2 = i*i

-- The Great Computer Language Shootout
-- http://shootout.alioth.debian.org/
-- Based on the SML version, written by Matthias Blume.
-- Implemented in Haskell by Don Stewart
--
import System; import Data.Bits; import Data.Word; import GHC.Base
 
main = do (w::Word32) <- getArgs >>= readIO . head
          putStrLn ("P4\n"++show w++" "++show w) >> yl 0 w w
 
yl y h w = if y < h then xl 0 y 0 8 h w else return ()
 
xl x y b n h w
    | x == w    = putChar (unsafeChr $ b `shiftL` n) >> yl (y+1) h w
    | otherwise = do
        (b',n') <- if n == 0 then putChar (chr b) >> return (0,8) else return (b,n)
        xl (x+1) y (b'+b'+ fromEnum (p x y w h)) (n'-1) h w
 
p (x::Word32) y w h = lp 0.0 0.0 50 (f x * 2.0 / f w - 1.5) (f y * 2.0 / f h - 1.0) 
    where f = fromIntegral
 
lp r i k cr ci | r2 + i2 > (4.0 :: Double) = 0 :: Word32
               | k == (0 :: Word32)        = 1
               | otherwise                 = lp (r2-i2+cr) ((r+r)*i+ci) (k-1) cr ci
    where r2 = r*r ; i2 = i*i

{-# OPTIONS -O2 -optc-O2 #-}
--
-- Based on the SML version, written by Matthias Blume.
-- Implemented in Haskell by Don Stewart
--
 
import System
import Data.Bits
import Data.Word
import GHC.Base
 
main = do w <- getArgs >>= return . read . head
          putStrLn $ "P4\n" ++ show w ++ " " ++ show w
          yl 0 w w
 
yl y h w = if y < h then xl 0 y 0 8 h w else return ()
 
xl x y b n h w
    | x == w    = putChar (unsafeChr $ b `shiftL` n) >> yl (y+1) h w
    | otherwise = do
        (b',n') <- if n == 0 then putChar (chr b) >> return (0,8) else return (b,n)
        xl (x+1) y (b'+b'+ fromEnum (p x y w h)) (n'-1) h w
 
p :: Word32 -> Word32 -> Word32 -> Word32 -> Word32
p x y w h = lp 0.0 0.0 50 (f x * 2.0 / f w - 1.5) (f y * 2.0 / f h - 1.0)
    where f = fromIntegral
 
lp r i k cr ci | r2 + i2 > (4.0 :: Double) = 0 :: Word32
               | k == (0 :: Word32)        = 1
               | otherwise                 = lp (r2-i2+cr) ((r+r)*i+ci) (k-1) cr ci
    where (r2,i2) = (r*r, i*i)

-- contributed by Greg Buchholz
-- modified by Alson Kemp
-- improvements by Jean-Philippe Bernardy
 
-- compile:  ghc -O2 -o mandelbrot mandelbrot.hs
-- run: mandelbrot 600 >mandel.pbm
 
import Complex
import System(getArgs)
import Char(chr)
import System.IO
 
limit  = 4.0::Double
 
iter   = 50::Int
 
main = do [arg] <- getArgs
          let width = read arg
          --AK:optional;prevent newline mangle on PC
          hSetBinaryMode stdout True
          putStr $ "P4\n" ++ show width ++ " " ++ show width ++ "\n"
          mapM_ putStr $ map (makePBM 0 0) $ fractal (points width width)
 
points :: Int -> Int -> [[Complex Double]]
points width height = [[(2.0*x/w - 1.5) :+ (2.0*y/h - 1) | x<-[0..w-1]] | y<-[0..h-1]]
    where w = fromIntegral width
          h = fromIntegral height
 
fractal :: [[Complex Double]] -> [[Int]]
fractal = map $ map $ fractal' (0.0 :+ 0.0) iter
 
-- magnitude is sloooooowwwwww, so hand code abs^2
fractal' :: Complex Double -> Int -> Complex Double -> Int
fractal' z i c | (realPart z')*(realPart z') + (imagPart z')*(imagPart z') > limit = 0
               | (i == 1) = 1
               | otherwise = fractal' z' (i-1) c
    where z' = z*z+c
 
 
makePBM :: Int -> Int -> [Int] -> [Char]
makePBM i acc []     = chr (acc * 2^(8-i)) : []
makePBM i acc (x:xs) | i==8      = chr acc : makePBM 0 0 (x:xs)
                     | otherwise = makePBM (i+1) (acc*2 + x) xs