prune dead code
[maximus:mandulia.git] / src / Mandulia.hs
1 {-
2 Mandulia -- Mandelbrot/Julia explorer
3 Copyright (C) 2010  Claude Heiland-Allen <claudiusmaximus@goto10.org>
4
5 This program is free software: you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation, either version 3 of the License, or
8 (at your option) any later version.
9
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
13 GNU General Public License for more details.
14
15 You should have received a copy of the GNU General Public License
16 along with this program.  If not, see <http://www.gnu.org/licenses/>.
17 -}
18
19 module Main (main) where
20
21 import Control.Concurrent (ThreadId(), forkIO, killThread)
22 import Control.Monad (replicateM, when)
23 import Data.Either (partitionEithers)
24 import Data.IORef
25 import Data.Maybe (isNothing, catMaybes)
26 import Data.Version (showVersion)
27 import System.Environment (getArgs)
28 import System.Exit (exitFailure, exitSuccess)
29 import System.IO (hPutStr, stderr, stdout)
30
31 import Graphics.UI.GLUT hiding (scale, translate, fullScreen)
32 import qualified Graphics.UI.GLUT as G
33 import Unsafe.Coerce (unsafeCoerce)
34
35 import Paths_mandulia (version)
36
37 import AmmannA3
38 import Bounds
39 import Image
40 import Interface (Interface(..), interface, closeInterface)
41 import qualified Interface as I
42 import JobQueue
43 import Julia
44 import ResourcePool
45 import Snapshot
46 import Sort
47 import StatsLogger
48 import TextureCache
49 import Utils
50 import Vector
51
52 data Mandulia =
53   Mandulia
54     { tiling     :: Maybe AmmannA3
55     , viewMax    :: Bounds
56     , view       :: Bounds
57     , width      :: Int
58     , height     :: Int
59     , fullScreen :: Bool
60     , oldWidth   :: Int
61     , oldHeight  :: Int
62     , iface      :: IORef Interface
63     , workers    :: [ThreadId]
64     , jobs       :: JobQueue JuliaJob
65     , textures   :: TextureCache
66     , images     :: ResourcePool Image
67     , logStats   :: String -> Double -> IO ()
68     , getStats   :: IO [(String, (Double, Double, Double))]
69     }
70
71 main :: IO ()
72 main = do
73   args <- getArgs
74   let (opts, args') = span (\o -> "-" == take 1 o) args
75   when ("--version" `elem` opts || "-V" `elem` opts) $ do
76     putStr $ unlines
77       [ "mandulia " ++ showVersion version
78       , "Copyright (C) 2010  Claude Heiland-Allen <claudiusmaximus@goto10.org>"
79       , "This is free software; see the source for copying conditions.  There is NO"
80       , "warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE."
81       ]
82     exitSuccess
83   when ("--help" `elem` opts || "-h" `elem` opts || "-?" `elem` opts) $ do
84     putStr $ unlines
85       [ "Usage: mandulia [OPTION]... CONFIGURATION [ARGUMENT]..."
86       , ""
87       , "CONFIGURATION is considered (in this order):"
88       , "  as a file to load directly;"
89       , "  as a module to load from the current directory;"
90       , "  as a module to load from the user settings directory;"
91       , "  as a module to load from the global settings directory."
92       , ""
93       , "Configurations available in this package may include:"
94       , "  interactive"
95       , "  random"
96       , ""
97       , "The ARGUMENT list is supplied to the selected configuration."
98       , ""
99       , "Options:"
100       , "  +RTS [OPTION].. -RTS   options for the run time system"
101       , "                         (Try `mandulia +RTS -? -RTS' for help)"
102       , "  -?, -h, --help         print this help text"
103       , "  -V, --version          print program version"
104       , ""
105       , "Report bugs to <claudiusmaximus@goto10.org>."
106       ]
107     exitSuccess
108   when (null args') $ do
109     hPutStr stderr $ unlines
110       [ "No configuration specified."
111       , "Try `mandulia --help' for more information."
112       ]
113     exitFailure
114   hPutStr stderr $ unlines
115       [ "mandulia (GPLv3+) 2010 Claude Heiland-Allen <claudiusmaximus@goto10.org>"
116       ]
117   mif <- interface (head args') (tail args')
118   when (isNothing mif) $ do
119     hPutStr stderr $ unlines
120       [ "Configuration error."
121       ]
122     exitFailure
123   let Just iR = mif
124   i <- readIORef iR
125   let jsize  = clamp 1 1024 $ iJuliaSize i -- FIXME check power of two
126       imagen = 1 `max` iImages   i
127       texn   = 1 `max` iTextures i
128       workn  = 1 `max` iWorkers  i
129       winW   = 1 `max` I.iWidth  i
130       winH   = 1 `max` I.iHeight i
131       full   = I.iFullScreen i
132       mspf   = 1 `max` (ceiling $ 1000 / (iFPS i `max` 0.01))
133       view0  = mkView winW winH 0 0 0
134   (logStats', getStats') <- statsLogger
135   jobq      <- jobQueue
136   imgpool   <- resourcePool (image jsize jsize 4) imagen
137   let texcache = textureCache texn
138   wtids     <- replicateM workn
139     (forkIO $ juliaWorker logStats' jsize jsize imgpool jobq)
140   manduliaR <- newIORef Mandulia { tiling = Nothing
141                                  , viewMax = view0
142                                  , view = view0
143                                  , width = winW
144                                  , height = winH
145                                  , fullScreen = full
146                                  , oldWidth = winW
147                                  , oldHeight = winH
148                                  , iface = iR
149                                  , workers = wtids
150                                  , jobs = jobq
151                                  , textures = texcache
152                                  , images = imgpool
153                                  , logStats = logStats'
154                                  , getStats = getStats'
155                                  }
156   initialWindowSize $= Size (fromIntegral winW) (fromIntegral winH)
157   initialDisplayMode $= [RGBAMode, DoubleBuffered]
158   _ <- getArgsAndInitialize
159   _ <- createWindow "Mandulia"
160   displayCallback       $=       display manduliaR
161   reshapeCallback       $= Just (reshape manduliaR)
162   keyboardMouseCallback $= Just (kmouse  manduliaR)
163   addTimerCallback mspf $        timer   manduliaR
164   mainLoop
165
166 mkView :: Int -> Int -> Double -> Double -> Double -> Bounds
167 mkView winW winH x y z =
168   let w = fromIntegral winW
169       h = fromIntegral winH
170       ax = if winW > winH then 1 else w / h
171       ay = if winW < winH then 1 else h / w
172       r = 16 * phi' ** z
173       x0 = x - r * ax
174       y0 = y - r * ay
175       x1 = x + r * ax
176       y1 = y + r * ay
177   in  bounds [ V x0 y0 1, V x1 y1 1 ]
178
179 quit :: IORef Mandulia -> IO ()
180 quit mR = do
181   m <- readIORef mR
182   mapM_ killThread (workers m)
183   I.atexit (iface m)
184   closeInterface (iface m)
185   exitSuccess
186
187 update :: IORef Mandulia -> IO (Julia -> Double)
188 update mR = do
189   m0 <- readIORef mR
190   s <- getStats m0
191   modifyIORef' (iface m0) (\i -> i{ iStatistics = s })
192   I.render (iface m0)
193   i <- readIORef (iface m0)
194   when (iQuit i) (quit mR)
195   fullscreen mR (iFullScreen i)
196   m <- readIORef mR
197   let (x, y, z) = iView i
198       v = mkView (width m) (height m) x y z
199   if v `insideOrEqual` viewMax m
200    then do
201     case zoomTo v (ammannA3 $ viewMax m) of
202       t@(Just _) -> do
203         writeIORef mR m{ tiling = t, view = v }
204         return $ score z x y
205       Nothing -> return $ score z x y -- FIXME should never happen?
206    else return $ score z x y -- FIXME what to do when out of range?
207
208 data Quad =
209   Quad
210     { quadX :: !R
211     , quadY :: !R
212     , quadR :: !R
213     , quadT :: !TextureObject
214     }
215
216 radius :: R -> R -> Int -> R
217 radius d z i = let x = d + z - fromIntegral i
218                in  clamp 0 1 $ x * 4 / d -- FIXME configure the 4
219
220 quads :: IORef Mandulia -> IO ([Julia], [Quad])
221 quads mR = do
222   m <- readIORef mR
223   i <- readIORef (iface m)
224   let w = fromIntegral (width m)
225       h = fromIntegral (height m)
226       window = bounds [ V 0 0 1, V w h 1]
227       viewT  = view m `into` window
228       ctiles = case tiling m of
229         Just t -> filter ((==) C . tTile) . tiles (ceiling d) $ t
230         Nothing -> []
231       d = iDetail i
232       (_, _, z) = iView i
233       s = iDisplaySize i
234       rads = map ((s *) . radius d z) [0 ..]
235   return $ partitionEithers
236         [ case mt of
237             Nothing  -> Left j
238             Just tex -> Right Quad{ quadX = x
239                                   , quadY = y
240                                   , quadR = r
241                                   , quadT = tex
242                                   }
243         | t <- ctiles
244         , let V cx cy _ = tCenter t
245         , let V  x  y _ = viewT ^^*^ V cx cy 1
246         , let ii = tId t
247         , let l = tDepth t
248         , let r = rads !! l
249         , let j = Julia{ jId = ii, jLevel = l, jCX = cx, jCY = cy }
250         , let mt = lookupTexture (textures m) j
251         ]
252
253 r2gl :: R -> GLdouble
254 r2gl = unsafeCoerce -- FIXME there must be a better way...
255
256 drawQuad :: Quad -> IO ()
257 drawQuad Quad{ quadX = x0, quadY = y0, quadR = s, quadT = tex } = do
258   let t x y = texCoord $ TexCoord2 (x :: GLdouble) (y :: GLdouble)
259       v x y = vertex   $ Vertex2 (r2gl x) (r2gl y)
260   textureBinding Texture2D $= Just tex
261   renderPrimitive Quads $ do
262     color $ Color3 1 1 (1::GLdouble)
263     t 0 1 >> v (x0 - s) (y0 + s)
264     t 0 0 >> v (x0 - s) (y0 - s)
265     t 1 0 >> v (x0 + s) (y0 - s)
266     t 1 1 >> v (x0 + s) (y0 + s)
267
268 display0 :: IORef Mandulia -> IO ()
269 display0 mR = do
270   curScore <- update mR
271   qs <- computeJobs mR curScore
272   drawQuads qs
273   swapBuffers
274   completeJobs mR curScore
275   record mR
276   reportErrors
277
278 display :: IORef Mandulia -> IO ()
279 display mR = do
280   m <- readIORef mR
281   (dt, r) <- time $ display0 mR
282   logStats m "display" dt
283   return r
284
285 computeJobs :: IORef Mandulia -> (Julia -> Double) -> IO [Quad]
286 computeJobs mR curScore = do
287   m <- readIORef mR
288   i <- readIORef (iface m)
289   (js, qs) <- quads mR
290   cs <- sortIO curScore . filter (notCached (textures m)) $ js
291   let job j = JuliaJob{ jCoords = j, jDoneAction = Nothing }
292       js' = map job . take (iJobs i) $ cs
293       visible q = not ( quadX q + 2 * quadR q < 0
294                      || fromIntegral (width m)  < quadX q - 2 * quadR q
295                      || quadY q + 2 * quadR q < 0
296                      || fromIntegral (height m) < quadY q - 2 * quadR q
297                      ) && quadR q > 0
298   reprioritise (jobs m) (const js')
299   return $ filter visible qs
300
301 black :: Color4 GLclampf
302 black = Color4 0 0 0 1
303
304 drawQuads :: [Quad] -> IO ()
305 drawQuads qs = do
306   clearColor $= black
307   clear [ColorBuffer]
308   blend $= Enabled
309   blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
310   texture Texture2D $= Enabled
311   mapM_ drawQuad qs
312   textureBinding Texture2D $= Nothing
313   texture Texture2D $= Disabled
314   blend $= Disabled
315
316 completeJobs :: IORef Mandulia -> (Julia -> Double) -> IO ()
317 completeJobs mR curScore = do
318   m <- readIORef mR
319   tc <- cacheTextures curScore (textures m) . catMaybes . map jDoneAction =<< completed (jobs m)
320   writeIORef mR m{ textures = tc }
321
322 record :: IORef Mandulia -> IO ()
323 record mR = do
324   m <- readIORef mR
325   i <- readIORef (iface m)
326   when (iRecord i) $ do
327     hSnapshot stdout (Position 0 0) (Size (fromIntegral (width m)) (fromIntegral (height m)))
328
329 fullscreen :: IORef Mandulia -> Bool -> IO ()
330 fullscreen mR fs = do
331   m <- readIORef mR
332   when (fullScreen m /= fs) $ do
333     if fs
334      then do
335       writeIORef mR m{ oldWidth = width m, oldHeight = height m, fullScreen = fs }
336       G.fullScreen
337      else do
338       writeIORef mR m{ fullScreen = fs }
339       windowSize $= Size (fromIntegral $ oldWidth m) (fromIntegral $ oldHeight m)
340
341 reshape :: IORef Mandulia -> Size -> IO ()
342 reshape mR (Size w h) = do
343   modifyIORef mR $ \m' -> m'{ width = fromIntegral w, height = fromIntegral h }
344   m <- readIORef mR
345   I.reshape (iface m) (fromIntegral w) (fromIntegral h)
346   i <- readIORef (iface m)
347   let (x, y, z) = iView i
348       s = ceiling $ iDisplaySize i
349   modifyIORef mR $ \m' -> m'{ view = mkView (width m') (height m') x y z }
350   viewport $= (Position (-s) (-s), (Size (w + 2 * fromIntegral s) (h + 2 * fromIntegral s)))
351   matrixMode $= Projection
352   loadIdentity
353   ortho 0 (fromIntegral w) 0 (fromIntegral h) (-1) 1
354   matrixMode $= Modelview 0
355   loadIdentity
356   postRedisplay Nothing
357
358 timer :: IORef Mandulia -> IO ()
359 timer mR = do
360   m <- readIORef mR
361   i <- readIORef (iface m)
362   let mspf = ceiling $ 1000 / (iFPS i `max` 0.01)
363   addTimerCallback mspf $ timer mR
364   postRedisplay Nothing
365
366 kmouse :: IORef Mandulia -> Key -> KeyState -> Modifiers -> Position -> IO  ()
367 kmouse mR (Char    '\27') Down _m _p = key mR "Escape"
368 kmouse mR (Char        k) Down _m _p = key mR [ k ]
369 kmouse mR (SpecialKey sk) Down _m _p = case show sk of
370                                          'K':'e':'y':key' -> key mR key'
371                                          key'             -> key mR key'
372 kmouse _r _k              _s   _m _p = return () -- FIXME handle everything
373
374 key :: IORef Mandulia -> String -> IO ()
375 key mR k = do
376   m <- readIORef mR
377   I.keyboard (iface m) k