mandulia-0.4: src/Mandulia.hs
{-
Mandulia -- Mandelbrot/Julia explorer
Copyright (C) 2010 Claude Heiland-Allen <claudiusmaximus@goto10.org>
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
-}
module Main (main) where
import Control.Concurrent (ThreadId(), forkIO, killThread)
import Control.Monad (replicateM, when)
import Data.Either (partitionEithers)
import Data.IORef
import Data.Maybe (isNothing, catMaybes)
import Data.Version (showVersion)
import System.Environment (getArgs)
import System.Exit (exitFailure, exitSuccess)
import System.IO (hPutStr, stderr, stdout)
import Graphics.UI.GLUT hiding (scale, translate, fullScreen)
import qualified Graphics.UI.GLUT as G
import Unsafe.Coerce (unsafeCoerce)
--import Numeric (showFFloat)
import Paths_mandulia (version)
import AmmannA3
import Bounds
import Image
import Interface (Interface(..), interface, closeInterface)
import qualified Interface as I
import JobQueue
import Julia
import ResourcePool
import Snapshot
import Sort
import StatsLogger
import TextureCache
import Utils
import Vector
data Mandulia =
Mandulia
{ tiling :: AmmannA3
, viewMax :: Bounds
, view :: Bounds
, width :: Int
, height :: Int
, fullScreen :: Bool
, oldWidth :: Int
, oldHeight :: Int
, iface :: IORef Interface
, workers :: [ThreadId]
, jobs :: JobQueue JuliaJob
, textures :: TextureCache
, images :: ResourcePool Image
, logStats :: String -> Double -> IO ()
, getStats :: IO [(String, (Double, Double, Double))]
}
main :: IO ()
main = do
args <- getArgs
let (opts, args') = span (\o -> "-" == take 1 o) args
when ("--version" `elem` opts || "-V" `elem` opts) $ do
putStr $ unlines
[ "mandulia " ++ showVersion version
, "Copyright (C) 2010 Claude Heiland-Allen <claudiusmaximus@goto10.org>"
, "This is free software; see the source for copying conditions. There is NO"
, "warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE."
]
exitSuccess
when ("--help" `elem` opts || "-h" `elem` opts || "-?" `elem` opts) $ do
putStr $ unlines
[ "Usage: mandulia [OPTION]... CONFIGURATION [ARGUMENT]..."
, ""
, "CONFIGURATION is considered (in this order):"
, " as a file to load directly;"
, " as a module to load from the current directory;"
, " as a module to load from the user settings directory;"
, " as a module to load from the global settings directory."
, ""
, "Configurations available in this package may include:"
, " interactive"
, " random"
, ""
, "The ARGUMENT list is supplied to the selected configuration."
, ""
, "Options:"
, " +RTS [OPTION].. -RTS options for the run time system"
, " (Try `mandulia +RTS -? -RTS' for help)"
, " -?, -h, --help print this help text"
, " -V, --version print program version"
, ""
, "Report bugs to <claudiusmaximus@goto10.org>."
]
exitSuccess
when (null args') $ do
hPutStr stderr $ unlines
[ "No configuration specified."
, "Try `mandulia --help' for more information."
]
exitFailure
hPutStr stderr $ unlines
[ "mandulia (GPLv3+) 2010 Claude Heiland-Allen <claudiusmaximus@goto10.org>"
]
mif <- interface (head args') (tail args')
when (isNothing mif) $ do
hPutStr stderr $ unlines
[ "Configuration error."
]
exitFailure
let Just iR = mif
i <- readIORef iR
let jsize = clamp 1 1024 $ iJuliaSize i -- FIXME check power of two
imagen = 1 `max` iImages i
texn = 1 `max` iTextures i
workn = 1 `max` iWorkers i
winW = 1 `max` I.iWidth i
winH = 1 `max` I.iHeight i
full = I.iFullScreen i
mspf = 1 `max` (ceiling $ 1000 / (iFPS i `max` 0.01))
detail = 1 `max` (ceiling $ iDetail i)
view0 = mkView winW winH 0 0 0
tiling0 = iterate stepIn (ammannA3 view0) !! detail
(logStats', getStats') <- statsLogger
jobq <- jobQueue
imgpool <- resourcePool (image jsize jsize 4) imagen
let texcache = textureCache texn
wtids <- replicateM workn
(forkIO $ juliaWorker logStats' jsize jsize imgpool jobq)
manduliaR <- newIORef Mandulia { tiling = tiling0
, viewMax = view0
, view = view0
, width = winW
, height = winH
, fullScreen = full
, oldWidth = winW
, oldHeight = winH
, iface = iR
, workers = wtids
, jobs = jobq
, textures = texcache
, images = imgpool
, logStats = logStats'
, getStats = getStats'
}
initialWindowSize $= Size (fromIntegral winW) (fromIntegral winH)
initialDisplayMode $= [RGBAMode, DoubleBuffered]
_ <- getArgsAndInitialize
_ <- createWindow "Mandulia"
displayCallback $= display manduliaR
reshapeCallback $= Just (reshape manduliaR)
keyboardMouseCallback $= Just (kmouse manduliaR)
addTimerCallback mspf $ timer manduliaR
mainLoop
mkView :: Int -> Int -> Double -> Double -> Double -> Bounds
mkView winW winH x y z =
let w = fromIntegral winW
h = fromIntegral winH
ax = if winW > winH then 1 else w / h
ay = if winW < winH then 1 else h / w
r = 16 * phi' ** z
x0 = x - r * ax
y0 = y - r * ay
x1 = x + r * ax
y1 = y + r * ay
in bounds [ V x0 y0 1, V x1 y1 1 ]
quit :: IORef Mandulia -> IO ()
quit mR = do
m <- readIORef mR
mapM_ killThread (workers m)
-- hPutStrLn stderr "what\tcount\tmean\tstddev"
-- mapM_ (hPutStrLn stderr . uncurry printStat) =<< getStats m
I.atexit (iface m)
closeInterface (iface m)
exitSuccess
{-
printStat :: String -> (Double, Double, Double) -> String
printStat name (n, m, d) =
name ++ "\t" ++
show (floor n :: Integer) ++ "\t" ++
showFFloat (Just 8) m "" ++ "\t" ++
showFFloat (Just 8) d ""
-}
update :: IORef Mandulia -> IO (Julia -> Double)
update mR = do
m0 <- readIORef mR
I.render (iface m0)
i <- readIORef (iface m0)
when (iQuit i) (quit mR)
fullscreen mR (iFullScreen i)
m <- readIORef mR
let (x, y, z) = iView i
v = mkView (width m) (height m) x y z
if v `insideOrEqual` viewMax m
then do
case zoomTo v (tiling m) of
Just t -> do
writeIORef mR m{ tiling = t, view = v }
return $ score z x y
Nothing -> return $ score z x y -- FIXME should never happen?
else return $ score z x y -- FIXME what to do when out of range?
data Quad =
Quad
{ quadX :: !R
, quadY :: !R
, quadR :: !R
, quadT :: !TextureObject
}
radius :: R -> R -> Int -> R
radius d z i = let x = d + z - fromIntegral i
in clamp 0 1 $ x * 4 / d -- FIXME configure the 4
quads :: IORef Mandulia -> IO ([Julia], [Quad])
quads mR = do
m <- readIORef mR
i <- readIORef (iface m)
let w = fromIntegral (width m)
h = fromIntegral (height m)
window = bounds [ V 0 0 1, V w h 1]
viewT = view m `into` window
ctiles = filter ((==) C . tTile) . tiles 0 . tiling $ m
d = iDetail i
(_, _, z) = iView i
s = iDisplaySize i
rads = map ((s *) . radius d z) [0 ..]
return $ partitionEithers
[ case mt of
Nothing -> Left j
Just tex -> Right Quad{ quadX = x
, quadY = y
, quadR = r
, quadT = tex
}
| t <- ctiles
, let V cx cy _ = tCenter t
, let V x y _ = viewT ^^*^ V cx cy 1
, let ii = tId t
, let l = tDepth t
, let r = rads !! l
, let j = Julia{ jId = ii, jLevel = l, jCX = cx, jCY = cy }
, let mt = lookupTexture (textures m) j
]
r2gl :: R -> GLdouble
r2gl = unsafeCoerce -- FIXME there must be a better way...
drawQuad :: Quad -> IO ()
drawQuad Quad{ quadX = x0, quadY = y0, quadR = s, quadT = tex } = do
let t x y = texCoord $ TexCoord2 (x :: GLdouble) (y :: GLdouble)
v x y = vertex $ Vertex2 (r2gl x) (r2gl y)
textureBinding Texture2D $= Just tex
renderPrimitive Quads $ do
color $ Color3 1 1 (1::GLdouble)
t 0 1 >> v (x0 - s) (y0 + s)
t 0 0 >> v (x0 - s) (y0 - s)
t 1 0 >> v (x0 + s) (y0 - s)
t 1 1 >> v (x0 + s) (y0 + s)
display0 :: IORef Mandulia -> IO ()
display0 mR = do
curScore <- update mR
qs <- computeJobs mR curScore
drawQuads qs
swapBuffers
completeJobs mR curScore
record mR
reportErrors
display :: IORef Mandulia -> IO ()
display mR = do
m <- readIORef mR
(dt, r) <- time $ display0 mR
logStats m "display" dt
return r
computeJobs :: IORef Mandulia -> (Julia -> Double) -> IO [Quad]
computeJobs mR curScore = do
m <- readIORef mR
i <- readIORef (iface m)
(js, qs) <- quads mR
cs <- sortIO curScore . filter (notCached (textures m)) $ js
let job j = JuliaJob{ jCoords = j, jDoneAction = Nothing }
js' = map job . take (iJobs i) $ cs
visible q = not ( quadX q + 2 * quadR q < 0
|| fromIntegral (width m) < quadX q - 2 * quadR q
|| quadY q + 2 * quadR q < 0
|| fromIntegral (height m) < quadY q - 2 * quadR q
) && quadR q > 0
reprioritise (jobs m) (const js')
return $ filter visible qs
color0 :: Color4 GLclampf
color0 = Color4 1 (0.5 * cos 1 + 0.5) (0.5 * cos 2 + 0.5) 1
drawQuads :: [Quad] -> IO ()
drawQuads qs = do
clearColor $= color0
clear [ColorBuffer]
blend $= Enabled
blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
texture Texture2D $= Enabled
mapM_ drawQuad qs
textureBinding Texture2D $= Nothing
texture Texture2D $= Disabled
blend $= Disabled
completeJobs :: IORef Mandulia -> (Julia -> Double) -> IO ()
completeJobs mR curScore = do
m <- readIORef mR
tc <- cacheTextures curScore (textures m) . catMaybes . map jDoneAction =<< completed (jobs m)
writeIORef mR m{ textures = tc }
record :: IORef Mandulia -> IO ()
record mR = do
m <- readIORef mR
i <- readIORef (iface m)
when (iRecord i) $ do
hSnapshot stdout (Position 0 0) (Size (fromIntegral (width m)) (fromIntegral (height m)))
fullscreen :: IORef Mandulia -> Bool -> IO ()
fullscreen mR fs = do
m <- readIORef mR
when (fullScreen m /= fs) $ do
if fs
then do
writeIORef mR m{ oldWidth = width m, oldHeight = height m, fullScreen = fs }
G.fullScreen
else do
writeIORef mR m{ fullScreen = fs }
windowSize $= Size (fromIntegral $ oldWidth m) (fromIntegral $ oldHeight m)
reshape :: IORef Mandulia -> Size -> IO ()
reshape mR (Size w h) = do
modifyIORef mR $ \m' -> m'{ width = fromIntegral w, height = fromIntegral h }
m <- readIORef mR
I.reshape (iface m) (fromIntegral w) (fromIntegral h)
i <- readIORef (iface m)
let (x, y, z) = iView i
s = ceiling $ iDisplaySize i
modifyIORef mR $ \m' -> m'{ view = mkView (width m') (height m') x y z }
viewport $= (Position (-s) (-s), (Size (w + 2 * fromIntegral s) (h + 2 * fromIntegral s)))
matrixMode $= Projection
loadIdentity
ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1
matrixMode $= Modelview 0
loadIdentity
postRedisplay Nothing
timer :: IORef Mandulia -> IO ()
timer mR = do
m <- readIORef mR
i <- readIORef (iface m)
let mspf = ceiling $ 1000 / (iFPS i `max` 0.01)
addTimerCallback mspf $ timer mR
postRedisplay Nothing
kmouse :: IORef Mandulia -> Key -> KeyState -> Modifiers -> Position -> IO ()
kmouse mR (Char '\27') Down _m _p = key mR "Escape"
kmouse mR (Char k) Down _m _p = key mR [ k ]
kmouse mR (SpecialKey sk) Down _m _p = case show sk of
'K':'e':'y':key' -> key mR key'
key' -> key mR key'
kmouse _r _k _s _m _p = return () -- FIXME handle everything
key :: IORef Mandulia -> String -> IO ()
key mR k = do
m <- readIORef mR
I.keyboard (iface m) k