update maintainer email address
[maximus:gmndl.git] / gmndl.hs
1 {-
2
3     gmndl -- Mandelbrot Set explorer
4     Copyright (C) 2010,2011  Claude Heiland-Allen <claude@mathr.co.uk>
5
6     This program is free software; you can redistribute it and/or modify
7     it under the terms of the GNU General Public License as published by
8     the Free Software Foundation; either version 2 of the License, or
9     (at your option) any later version.
10
11     This program is distributed in the hope that it will be useful,
12     but WITHOUT ANY WARRANTY; without even the implied warranty of
13     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14     GNU General Public License for more details.
15
16     You should have received a copy of the GNU General Public License along
17     with this program; if not, write to the Free Software Foundation, Inc.,
18     51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
19
20 -}
21
22 module Main (main) where
23
24 import Control.Concurrent (forkIO, newEmptyMVar, takeMVar, putMVar)
25 import GHC.Conc (forkOnIO, numCapabilities)
26 import Control.Monad (forever)
27
28 -- some simple helpers
29 import Data.List (isPrefixOf)
30
31 -- the dependency on mtl is just for this!
32 import Control.Monad.Trans (liftIO)
33
34 -- the main program thread needs to store some thread-local state
35 import Data.IORef (newIORef, readIORef, writeIORef)
36
37 -- build the interface with GTK to allow more fancy controls later
38 import Graphics.UI.Gtk
39
40 -- use OpenGL to display frequently update images on a textured quad
41 import Graphics.UI.Gtk.OpenGL
42 import qualified Graphics.Rendering.OpenGL as GL
43 import Graphics.Rendering.OpenGL (($=))
44
45 import Data.Complex (Complex((:+)))
46
47 -- need a hack to ensure correct qd operation
48 import Numeric.QD.QuadDouble (QuadDouble())
49 import Numeric.QD.FPU.Raw (fpu_fix_start)
50 import Foreign (nullPtr)
51
52 -- mu-atom properties
53 import Calculate
54 import qualified Image
55 import Address (parse, parameter)
56
57 -- the state we need for everything
58 data GMNDL
59   = Invalid
60   | GMNDL
61       { center :: Complex QuadDouble
62       , zradius :: QuadDouble
63       , image :: Image.Image
64       , stop :: IO ()
65       }
66
67 -- command line arguments: currently only initial window dimensions
68 data Args = Args{ aWidth :: Int, aHeight :: Int, aOversample :: Int, aRe :: QuadDouble, aIm :: QuadDouble, aZr :: QuadDouble }
69
70 -- and the defaults are suitable for PAL DVD rendering, if that should
71 -- come to pass in the future
72 defaultArgs :: Args
73 defaultArgs = Args{ aWidth = 788, aHeight = 576, aOversample = 1, aRe = 0, aIm = 0, aZr = 2 }
74
75 -- braindead argument parser: latest argument takes priority
76 -- probably should use Monoid instances for this stuff
77 combineArgs :: Args -> String -> Args
78 combineArgs a0 s
79   | "--width="  `isPrefixOf` s = a0{ aWidth  = read $ "--width="  `dropPrefix` s }
80   | "-w="       `isPrefixOf` s = a0{ aWidth  = read $ "-w="       `dropPrefix` s }
81   | "--height=" `isPrefixOf` s = a0{ aHeight = read $ "--height=" `dropPrefix` s }
82   | "-h="       `isPrefixOf` s = a0{ aHeight = read $ "-h="       `dropPrefix` s }
83   | "--aa="     `isPrefixOf` s = a0{ aOversample = read $ "--aa=" `dropPrefix` s }
84   | "--re="     `isPrefixOf` s = a0{ aRe = read $ "--re=" `dropPrefix` s }
85   | "--im="     `isPrefixOf` s = a0{ aIm = read $ "--im=" `dropPrefix` s }
86   | "--zr="     `isPrefixOf` s = a0{ aZr = read $ "--zr=" `dropPrefix` s }
87   | otherwise = a0
88
89 -- this is a bit silly, especially with the duplicated string literals..
90 dropPrefix :: String -> String -> String
91 dropPrefix p s = drop (length p) s
92
93 -- the main program!
94 main :: IO ()
95 main = do
96   args <- foldl combineArgs defaultArgs `fmap` unsafeInitGUIForThreadedRTS
97   let width = aWidth args
98       height = aHeight args
99       oversample = aOversample args
100       rng = ((0, 0), (oversample * height - 1, oversample * width - 1))
101   _ <- initGL
102   -- dirty hack to set FPU control words as recommended by libqd docs
103   -- because it relies on 64bit doubles and some FPU use 80bits inside
104   mapM_ (flip forkOnIO $ fpu_fix_start nullPtr) [ 0 .. numCapabilities - 1 ]
105   glconfig <- glConfigNew [ GLModeRGBA, GLModeDouble ]
106   canvas <- glDrawingAreaNew glconfig
107   widgetSetSizeRequest canvas width height
108   window <- windowNew
109   eventb <- eventBoxNew
110   vbox <- vBoxNew False 0
111   status <- vBoxNew False 0
112   statusRe <- entryNew
113   statusIm <- entryNew
114   statusZr <- entryNew
115   ratios <- entryNew
116   boxPackStart vbox eventb PackGrow 0
117   boxPackStart vbox status PackGrow 0
118   boxPackStart vbox ratios PackGrow 0
119   boxPackStart status statusRe PackGrow 0
120   boxPackStart status statusIm PackGrow 0
121   boxPackStart status statusZr PackGrow 0
122   let -- update the status bar
123       updateStatus re im zr = do
124         entrySetText statusRe (show re)
125         entrySetText statusIm (show im)
126         entrySetText statusZr (show zr)
127   set window [ containerBorderWidth := 0, containerChild := vbox, windowResizable := False ]
128   set eventb [ containerBorderWidth := 0, containerChild := canvas ]
129   -- initial state is invalid because...
130   sR <- newIORef Invalid
131   done <- newEmptyMVar
132   let -- restart the renderer
133       restart :: IO ()
134       restart = do
135         g <- readIORef sR
136         stop g
137         Image.clear (image g)
138         stop' <- renderer done rng (Image.plot (image g)) (center g) (zradius g)
139         writeIORef sR $! g{ stop = stop' }
140         let re :+ im = center g
141         updateStatus re im (zradius g)
142   -- ...need to initialize OpenGL stuff etc in this callback
143   _ <- onRealize canvas $ {-# SCC "cbRz" #-} withGLDrawingArea canvas $ \_ -> do
144     GL.matrixMode $= GL.Projection
145     GL.loadIdentity
146     GL.ortho 0.0 1.0 0.0 1.0 (-1.0) 1.0
147     GL.drawBuffer $= GL.BackBuffers
148     GL.texture GL.Texture2D $= GL.Enabled
149     i <- Image.new (oversample * width) (oversample * height)
150     writeIORef sR $! GMNDL{ image = i, center = aRe args :+ aIm args, zradius = aZr args, stop = return () }
151     restart
152   -- when the mouse button is pressed, center and zoom in or out
153   _ <- eventb `on` buttonPressEvent $ {-# SCC "cbEv" #-} tryEvent $ do
154     b <- eventButton
155     (x, y) <- eventCoordinates
156     liftIO $ do
157       g <- readIORef sR
158       let w2 = fromIntegral width  / 2
159           h2 = fromIntegral height / 2
160           p  = convert x :+ convert (-y)
161           s  = (zradius g / (w2 `min` h2)) :+ 0
162           c  = center g + (p - (w2 :+ (-h2))) * s
163           zradius' = zradius g * delta
164           delta | b == LeftButton = 0.5
165                 | b == RightButton = 2
166                 | otherwise = 1
167       writeIORef sR $! g{ center = c, zradius = zradius' }
168       restart
169   -- when typing in the coordinate boxes, zoom to the new place
170   _ <- statusRe `onEntryActivate` do
171     s <- entryGetText statusRe
172     liftIO $ do
173       g <- readIORef sR
174       case safeRead s of
175         Just re -> do
176           let _ :+ im = center g
177           writeIORef sR $! g{ center = re :+ im }
178           restart
179         Nothing -> return ()
180   _ <- statusIm `onEntryActivate` do
181     s <- entryGetText statusIm
182     liftIO $ do
183       g <- readIORef sR
184       case safeRead s of
185         Just im -> do
186           let re :+ _ = center g
187           writeIORef sR $! g{ center = re :+ im }
188           restart
189         Nothing -> return ()
190   _ <- statusZr `onEntryActivate` do
191     s <- entryGetText statusZr
192     liftIO $ do
193       g <- readIORef sR
194       case safeRead s of
195         Just zradius' -> do
196           writeIORef sR $! g{ zradius = zradius' }
197           restart
198         Nothing -> return ()
199   -- when pressing return in the ratios list, zoom to that mu-atom
200   muQueue <- newEmptyMVar
201   _ <- forkIO . forever $ do
202     qs <- takeMVar muQueue
203     case parameter =<< parse qs of
204       Nothing -> postGUISync $ do
205         _ <- ratios `widgetSetSensitive` True
206         return ()
207       Just (cr, ci, radius) -> do
208         let zradius' = radius * 3
209         cr `seq` ci `seq` zradius' `seq` postGUISync $ do
210           g <- readIORef sR
211           if isNaN cr || isNaN ci
212             then writeIORef sR $! g{ center = c0, zradius = zradius0 }
213             else writeIORef sR $! g{ center = cr :+ ci, zradius = zradius' }
214           _ <- ratios `widgetSetSensitive` True
215           restart
216   _ <- ratios `onEntryActivate` do
217     s <- entryGetText ratios
218     _ <- ratios `widgetSetSensitive` False
219     g <- readIORef sR
220     stop g
221     putMVar muQueue s
222   -- time to draw the image: upload to the texture and draw a quad
223   _ <- onExpose canvas $ {-# SCC "cbEx" #-} \_ -> do
224     withGLDrawingArea canvas $ \glwindow -> do
225       GMNDL{ image = i } <- readIORef sR
226       Image.upload i
227       Image.draw i
228       glDrawableSwapBuffers glwindow
229     return True
230   -- need an exit strategy
231   _ <- onDestroy window mainQuit
232   -- make sure the expose callback gets called regularly (5fps)
233   _ <- timeoutAdd (widgetQueueDraw canvas >> return True) 200
234   -- and we're off!
235   widgetShowAll window
236   mainGUI
237
238 -- initial center coordinates
239 -- using the maximum precision available from the start for this makes
240 -- sure that nothing weird happens when precision gets close to the edge
241 c0 :: Complex QuadDouble
242 c0 = 0
243
244 -- initial zoom level
245 -- the initial zoom level should probably depend on initial image size
246 zradius0 :: QuadDouble
247 zradius0 = 2
248
249 safeRead :: Read a => String -> Maybe a
250 safeRead s = case reads s of
251   [(a, "")] -> Just a
252   _ -> Nothing