video rendering (commented out)
[maximus:gmndl.git] / gmndl.hs
1 {-
2
3     gmndl -- Mandelbrot Set explorer
4     Copyright (C) 2010  Claude Heiland-Allen <claudiusmaximus@goto10.org>
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)
25 import GHC.Conc (forkOnIO, numCapabilities)
26
27 -- some simple helpers
28 import Data.List (isPrefixOf)
29
30 -- the dependency on mtl is just for this!
31 import Control.Monad.Trans (liftIO)
32
33 -- the main program thread needs to store some thread-local state
34 import Data.IORef (newIORef, readIORef, writeIORef)
35
36 -- build the interface with GTK to allow more fancy controls later
37 import Graphics.UI.Gtk
38
39 -- use OpenGL to display frequently update images on a textured quad
40 import Graphics.UI.Gtk.OpenGL
41 import qualified Graphics.Rendering.OpenGL as GL
42 import Graphics.Rendering.OpenGL (($=))
43
44 -- need a hack to ensure correct qd operation
45 import Numeric.QD.QuadDouble (QuadDouble())
46 import Numeric.QD.FPU.Raw (fpu_fix_start)
47 import Foreign (nullPtr)
48
49 -- mu-atom properties
50 import Calculate
51 import qualified Image
52 import MuAtom (muAtom)
53
54 -- the state we need for everything
55 data GMNDL
56   = Invalid
57   | GMNDL
58       { center :: Complex QuadDouble
59       , zoom :: Int
60       , image :: Image.Image
61       , stop :: IO ()
62       }
63
64 -- command line arguments: currently only initial window dimensions
65 data Args = Args{ aWidth :: Int, aHeight :: Int }
66
67 -- and the defaults are suitable for PAL DVD rendering, if that should
68 -- come to pass in the future
69 defaultArgs :: Args
70 defaultArgs = Args{ aWidth = 788, aHeight = 576 }
71
72 -- braindead argument parser: latest argument takes priority
73 -- probably should use Monoid instances for this stuff
74 combineArgs :: Args -> String -> Args
75 combineArgs a0 s
76   | "--width="  `isPrefixOf` s = a0{ aWidth  = read $ "--width="  `dropPrefix` s }
77   | "--height=" `isPrefixOf` s = a0{ aHeight = read $ "--height=" `dropPrefix` s }
78   | "-w=" `isPrefixOf` s = a0{ aWidth  = read $ "-w=" `dropPrefix` s }
79   | "-h=" `isPrefixOf` s = a0{ aHeight = read $ "-h=" `dropPrefix` s }
80   | otherwise = a0
81
82 -- this is a bit silly, especially with the duplicated string literals..
83 dropPrefix :: String -> String -> String
84 dropPrefix p s = drop (length p) s
85
86
87 -- the main program!
88 main :: IO ()
89 main = do
90   args <- foldl combineArgs defaultArgs `fmap` unsafeInitGUIForThreadedRTS
91   let width = aWidth args
92       height = aHeight args
93       rng = ((0, 0), (height - 1, width - 1))
94   _ <- initGL
95   -- dirty hack to set FPU control words as recommended by libqd docs
96   -- because it relies on 64bit doubles and some FPU use 80bits inside
97   mapM_ (flip forkOnIO $ fpu_fix_start nullPtr) [ 0 .. numCapabilities - 1 ]
98   glconfig <- glConfigNew [ GLModeRGBA, GLModeDouble ]
99   canvas <- glDrawingAreaNew glconfig
100   widgetSetSizeRequest canvas width height
101   window <- windowNew
102   eventb <- eventBoxNew
103   vbox <- vBoxNew False 0
104   status <- vBoxNew False 0
105   statusRe <- labelNew Nothing
106   statusIm <- labelNew Nothing
107   statusZo <- labelNew Nothing
108   ratios <- entryNew
109   boxPackStart vbox eventb PackGrow 0
110   boxPackStart vbox status PackGrow 0
111   boxPackStart vbox ratios PackGrow 0
112   boxPackStart status statusRe PackGrow 0
113   boxPackStart status statusIm PackGrow 0
114   boxPackStart status statusZo PackGrow 0
115   let -- update the status bar
116       updateStatus re im zo = do
117         labelSetText statusRe (reshow $ show re)
118         labelSetText statusIm (reshow $ show im)
119         labelSetText statusZo (show zo)
120   set window [ containerBorderWidth := 0, containerChild := vbox, windowResizable := False ]
121   set eventb [ containerBorderWidth := 0, containerChild := canvas ]
122   -- initial state is invalid because...
123   sR <- newIORef Invalid
124   let -- restart the renderer
125       restart :: IO ()
126       restart = do
127         g <- readIORef sR
128         stop g
129         Image.clear (image g)
130         stop' <- renderer rng (Image.plot (image g)) (center g) (zoom g)
131         writeIORef sR $! g{ stop = stop' }
132         let re :+ im = center g
133         updateStatus re im (zoom g)
134   -- ...need to initialize OpenGL stuff etc in this callback
135   _ <- onRealize canvas $ {-# SCC "cbRz" #-} withGLDrawingArea canvas $ \_ -> do
136     GL.matrixMode $= GL.Projection
137     GL.loadIdentity
138     GL.ortho 0.0 1.0 0.0 1.0 (-1.0) 1.0
139     GL.drawBuffer $= GL.BackBuffers
140     GL.texture GL.Texture2D $= GL.Enabled
141     i <- Image.new width height
142     writeIORef sR $! GMNDL{ image = i, center = c0, zoom = zoom0, stop = return () }
143     restart
144   -- when the mouse button is pressed, center and zoom in or out
145   _ <- eventb `on` buttonPressEvent $ {-# SCC "cbEv" #-} tryEvent $ do
146     b <- eventButton
147     (x, y) <- eventCoordinates
148     liftIO $ do
149       g <- readIORef sR
150       let w2 = fromIntegral width  / 2
151           h2 = fromIntegral height / 2
152           p  = convert x :+ convert (-y)
153           s  = (1/2^^zoom g) :+ 0
154           c  = center g + (p - (w2 :+ (-h2))) * s
155           zoom' = zoom g + delta
156           delta | b == LeftButton = 1
157                 | b == RightButton = -1
158                 | otherwise = 0
159       writeIORef sR $! g{ center = c, zoom = zoom' }
160       restart
161   -- when pressing return in the ratios list, zoom to that mu-atom
162   _ <- ratios `onEntryActivate` do
163     s <- entryGetText ratios
164     case rationalize s of
165       Nothing -> return ()
166       Just qs -> do
167         _ <- ratios `widgetSetSensitive` False
168         g <- readIORef sR
169         stop g
170         _ <- forkIO $ do
171           let (cr, ci, radius, _period) = muAtom qs
172               zoom' = floor $ (logBase 2 . fromIntegral $ width `min` height) - (logBase 2 radius) - 2
173               c'@(cr' :+ ci') = convert cr :+ convert ci
174           cr' `seq` ci' `seq` zoom' `seq` postGUISync $ do
175             writeIORef sR $! g{ center = c', zoom = zoom' }
176             _ <- ratios `widgetSetSensitive` True
177             restart
178         return ()
179   -- time to draw the image: upload to the texture and draw a quad
180   _ <- onExpose canvas $ {-# SCC "cbEx" #-} \_ -> do
181     withGLDrawingArea canvas $ \glwindow -> do
182       GMNDL{ image = i } <- readIORef sR
183       Image.upload i
184       Image.draw i
185       glDrawableSwapBuffers glwindow
186     return True
187   -- need an exit strategy
188   _ <- onDestroy window mainQuit
189   -- make sure the expose callback gets called regularly (5fps)
190   _ <- timeoutAdd (widgetQueueDraw canvas >> return True) 200
191 --  _ <- timeoutAdd (do { GMNDL{ image = i } <- readIORef sR ; Image.putPPM i ; return True }) 200
192   -- and we're off!
193   widgetShowAll window
194   mainGUI
195
196 -- initial center coordinates
197 -- using the maximum precision available from the start for this makes
198 -- sure that nothing weird happens when precision gets close to the edge
199 c0 :: Complex QuadDouble
200 c0 = 0
201
202 -- initial zoom level
203 -- neighbouring pixel are 2^(-zoom) units apart
204 -- the initial zoom level should probably depend on initial image size
205 zoom0 :: Int
206 zoom0 = 6
207
208 -- convert scientific notation like "-4.12345600000000e-03"
209 -- into human-readable numbers like "-0.004123456"
210 -- do it by string manipulation as QuadDouble has a lot of precision
211 -- and the show instance for QuadDouble gives the problematic form...
212 reshow :: String -> String
213 reshow s =
214   let (front, 'e':rear) = break (=='e') s
215       (sign, mantissa) = case front of
216                           '-':m -> (True, m)
217                           m -> (False, m)
218       (big, '.':small) = break (=='.') mantissa
219       expo = read (dropWhile (=='+') rear) + length big
220       digits = if expo < 0  then "0." ++ replicate (-expo) '0' ++ big ++ small
221                             else let (x,y) = splitAt expo (big ++ small)
222                                  in  case x of
223                                       [] -> "0." ++ y
224                                       x' -> x' ++ "." ++ y
225   in  reverse . dropWhile (=='.') . dropWhile (=='0') . reverse . (if sign then ('-':) else id) $ digits
226
227 -- convert a string of space separated fractions into rationals
228 -- moreover ensure that they are all in 0<q<1
229 rationalize :: String -> Maybe [Rational]
230 rationalize s =
231   let f '/' = '%'
232       f  c  = c
233       r t = case reads t of
234         [(q, "")] | 0 < q && q < 1 -> Just q
235         _ -> Nothing
236   in  mapM r . words . map f $ s