mandulia-0.7: 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.Time (UTCTime, getCurrentTime, diffUTCTime)
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 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 :: Maybe 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))]
, frameTime :: Maybe UTCTime
}
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:"
, " main"
, ""
, "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))
view0 = mkView winW winH 0 0 0
(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 = Nothing
, 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'
, frameTime = Nothing
}
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)
I.atexit (iface m)
closeInterface (iface m)
exitSuccess
update :: IORef Mandulia -> IO (Julia -> Double)
update mR = do
m0 <- readIORef mR
s <- getStats m0
modifyIORef' (iface m0) (\i -> i{ iStatistics = s })
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 (ammannA3 $ viewMax m) of
t@(Just _) -> 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)
s = iDisplaySize i
window = bounds [ V (-s) (-s) 1, V (w+s) (h+s) 1]
viewT = view m `into` window
ctiles = case tiling m of
Just t -> filter ((==) C . tTile) . tiles (ceiling d) $ t
Nothing -> []
d = iDetail i
(_, _, z) = iView 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
swapBuffers
t1 <- getCurrentTime
mt0 <- frameTime `fmap` readIORef mR
modifyIORef' mR $ \m -> m{ frameTime = Just t1 }
case mt0 of
Nothing -> return ()
Just t0 -> do
let dt = realToFrac (diffUTCTime t1 t0)
readIORef mR >>= \m -> logStats m "frame" dt
curScore <- update mR
qs <- computeJobs mR curScore
drawQuads qs
completeJobs mR curScore
record mR
reportErrors
display :: IORef Mandulia -> IO ()
display mR = do
m <- readIORef mR
(dt, ()) <- time $ display0 mR
logStats m "display" dt
return ()
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
black :: Color4 GLclampf
black = Color4 0 0 0 1
drawQuads :: [Quad] -> IO ()
drawQuads qs = do
clearColor $= black
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 $ 2 * 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 (-fromIntegral s) (fromIntegral w + fromIntegral s) (-fromIntegral s) (fromIntegral h + fromIntegral s) (-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