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