module Fractal.RUFF.Mandelbrot.Image
( simpleImage, complexImage, imageLoop, coordinates, ascii, unicode
, Channel(..), Coordinates, border
) where
import Control.Monad.ST (ST)
import Data.Array.ST (newArray, writeArray, runSTUArray)
import Data.STRef (STRef, newSTRef, readSTRef, writeSTRef)
import Data.Array.Unboxed (UArray, (!), bounds, range, amap, ixmap)
import Data.Strict.Tuple (Pair((:!:)))
import Data.Ix (Ix)
import Data.Data (Data)
import Data.Typeable (Typeable)
import Fractal.RUFF.Types.Complex (Complex((:+)), magnitude)
import Fractal.RUFF.Mandelbrot.Iterate (iterates, initial, Mode(Simple, DistanceEstimate), Iterate(), Output(OutSimple, OutDistanceEstimate), escapeTime, distanceEstimate, finalAngle, outUser)
simpleImage :: (Ord r, Floating r) => Coordinates r -> Int -> UArray (Int, Int) Bool
simpleImage (bs, cs) n0 = runSTUArray $ do
a <- newArray bs True
s <- newSTRef (0 :: Int)
imageLoop s a n0 0 False 64 i0s (out s a)
where
i0s = map (uncurry $ initial Simple) cs
out s a (OutSimple{ outUser = j :!: i }) = do
writeArray a (j, i) False
modifySTRef' s (+ 1)
out _ _ _ = return ()
complexImage :: (Ord r, Real r, Floating r) => Coordinates r -> Int -> UArray (Int, Int, Channel) Float
complexImage (((jlo,ilo),(jhi,ihi)), cs) !n0 = runSTUArray $ do
a <- newArray bs (1)
s <- newSTRef (0 :: Int)
imageLoop s a n0 0 False 64 i0s (out s a)
where
bs = ((jlo,ilo,minBound), (jhi,ihi,maxBound))
(_, cx0):(_, cx1):_ = cs
pixelSpacing = magnitude (cx1 cx0)
i0s = map (uncurry $ initial DistanceEstimate) cs
out !s !a (OutDistanceEstimate{ escapeTime = et, distanceEstimate = de, finalAngle = fa, outUser = j :!: i }) = do
writeArray a (j, i, EscapeTime) (realToFrac et)
writeArray a (j, i, DistanceEstimate') (realToFrac (de / pixelSpacing))
writeArray a (j, i, FinalAngle) (realToFrac fa)
modifySTRef' s (+ 1)
out _ _ _ = return ()
data Channel = EscapeTime | DistanceEstimate' | FinalAngle
deriving (Eq, Ord, Enum, Bounded, Ix, Read, Show, Data, Typeable)
imageLoop :: (Ord r, Floating r) => STRef s Int -> a -> Int -> Int -> Bool -> Int -> [Iterate u r] -> (Output u r -> ST s ()) -> ST s a
imageLoop s a !n0 !n1 !f1 !m1 is1 out = loop f1 n1 m1 is1
where
loop !f !n !m is = do
writeSTRef s 0
is' <- iterates m is out
o <- readSTRef s
if null is || (f && o == 0) || n > n0 then return a else loop (f || o > 0) (n + m) (m * 2) is'
type Coordinates r = (((Int,Int),(Int,Int)), [(Pair Int Int, Complex r)])
coordinates :: (Ord r, Floating r) => Int -> Int -> Complex r -> r -> Coordinates r
coordinates !width !height !(c0r :+ c0i) !r0 = (bs, cs)
where
bs = ((0, 0), (height 1, width 1))
cs = [ (j :!: i, c)
| (j,i) <- range bs
, let y = (fromIntegral j h) / h
, let x = (fromIntegral i w) / h
, let ci = c0i + r0 * y
, let cr = c0r + r0 * x
, let c = cr :+ ci
]
w = fromIntegral $ width `div` 2
h = fromIntegral $ height `div` 2
border :: UArray (Int, Int, Channel) Float -> UArray (Int, Int) Bool
border a = amap (\x -> x > 0 && x < 1) . ixmap bs (\(j, i) -> (j, i, DistanceEstimate')) $ a
where
((jlo, ilo, _), (jhi, ihi, _)) = bounds a
bs = ((jlo, ilo), (jhi, ihi))
ascii :: UArray (Int, Int) Bool -> String
ascii a = unlines . map concat $ [ [ b (a ! (j, i)) | i <- [ ilo .. ihi ] ] | j <- [ jhi, jhi 1 .. jlo ] ]
where
((jlo, ilo), (jhi, ihi)) = bounds a
b False = " "
b True = "##"
unicode :: UArray (Int, Int) Bool -> String
unicode a = unlines [ [ b (a ! (j, i)) (a ! (j 1, i)) | i <- [ ilo .. ihi ] ] | j <- [ jhi, jhi 2 .. jlo ] ]
where
((jlo, ilo), (jhi, ihi)) = bounds a
b False False = ' '
b True False = '\x2580'
b False True = '\x2584'
b True True = '\x2588'
modifySTRef' :: STRef s a -> (a -> a) -> ST s ()
modifySTRef' s f = do
x <- readSTRef s
writeSTRef s $! f x