use MuAtom algorithms and update progress bar less often
[ruff:gruff.git] / src / gruff.hs
1 {-# LANGUAGE StandaloneDeriving #-}
2 module Main (main) where
3
4 import Prelude hiding (catch, log)
5 import Control.Monad (forM_, liftM3, when)
6 import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef, writeIORef)
7 import Data.Maybe (isJust, fromMaybe)
8 import Graphics.UI.Gtk hiding (get, Region, Size, Window)
9 import qualified Graphics.UI.Gtk as GTK
10 import Graphics.UI.Gtk.OpenGL (initGL)
11 import System.Directory (getAppUserDataDirectory, createDirectoryIfMissing)
12 import System.FilePath ((</>))
13
14 import Fractal.RUFF.Mandelbrot.Address (AngledInternalAddress, Angle, parseAngledInternalAddress, prettyAngledInternalAddress)
15 import Fractal.RUFF.Types.Complex (Complex((:+)), realPart, imagPart)
16
17 import Paths_gruff (getDataFileName)
18 import Number (R)
19 import Browser (Browser(..), browserNew)
20 import MuAtom (MuAtom(..), MuProgress(..), muFromAddress, MuProgress'(..), muToAddress, MuProgress''(..), muLocate)
21 import View (Image(..), Location(..), Viewport(..), Colours(..), Colour(..), defWindow)
22 import GLUTGtk (glut, Size(Size), postRedisplay)
23 import Logger (logger, LogLevel(Debug))
24 import qualified Logger as Log
25 import StatusDialog (StatusDialog, statusDialog, statusDialogNew)
26 import Utils (safeRead, catchIO)
27
28 exit :: (LogLevel -> String -> IO ()) -> FilePath -> Gruff -> IO ()
29 exit lg stateFile g = do
30   lg Debug "exitCallback"
31   aDoSave stateFile g
32   mainQuit
33
34 data GruffGUI = GruffGUI
35   { dStatus                 :: StatusDialog
36   -- buttons
37   , bHome
38   , bLoad
39   , bSave
40   , bStop
41   , bAddressToCoordinates
42   , bPeriodScan             :: Button
43   -- entries
44   , eAddress
45   , eRealM, eRealE
46   , eImagM, eImagE
47   , eSizeM, eSizeE
48   , eRota                   :: Entry
49   -- colour pickers
50   , cInterior
51   , cBorder
52   , cExterior               :: ColorButton
53   -- windows
54   , wMain
55   , wImage                  :: GTK.Window
56   }
57
58 main :: IO ()
59 main = do
60   -- contexts
61   _ <- initGUI
62   _ <- initGL
63   gl' <- glut minSize
64   -- directories
65   appDir <- getAppUserDataDirectory "gruff"
66   let cacheDir' = appDir </> "cache"
67       logDir    = appDir </> "log"
68       stateFile = appDir </> "state.gruff"
69   createDirectoryIfMissing False appDir
70   createDirectoryIfMissing False logDir
71   lg <- logger logDir
72   icon <- pixbufNewFromFile =<< getDataFileName "icon.png"
73   browser <- browserNew gl' icon lg cacheDir'
74   let iw = browserWindow browser
75   sg <- sizeGroupNew SizeGroupHorizontal
76   let spacing = 2
77       entryNewWithMnemonic m = do
78         e <- entryNew
79         entrySetWidthChars e 30
80         l <- labelNewWithMnemonic m
81         labelSetMnemonicWidget l e
82         sizeGroupAddWidget sg l
83         h <- hBoxNew False spacing
84         boxPackStart h l PackNatural 0
85         boxPackStartDefaults h e
86         return (e, h)
87       entryNewExponent = do
88         e <- entryNew
89         entrySetWidthChars e 4
90         l <- labelNew (Just "e")
91         h <- hBoxNew False spacing
92         boxPackStart h l PackNatural 0
93         boxPackStart h e PackNatural 0
94         return (e, h)
95       frameNewWithContents box t r ws = do
96         f <- frameNew
97         frameSetLabel f t
98         frameSetLabelAlign f (if r then 1 else 0) 0.5
99         v <- box False spacing
100         forM_ ws $ boxPackStartDefaults v
101         set f [ containerChild := v ]
102         return f
103   dStatus'                  <- statusDialogNew
104   b01@bHome'                <- buttonNewWithLabel "Home"
105   b02@bLoad'                <- buttonNewWithLabel "Load"
106   b03@bSave'                <- buttonNewWithLabel "Save"
107   b04@bStop'                <- buttonNewWithLabel "Stop"
108   b7@bAddressToCoordinates' <- buttonNewWithLabel "Go"
109   b8@bPeriodScan'           <- buttonNewWithLabel "Scan"
110   (eAddress', fa1) <- entryNewWithMnemonic "_Address"
111   (eRealM', fc1m) <- entryNewWithMnemonic "_Real"
112   (eRealE', fc1e) <- entryNewExponent
113   (eImagM', fc2m) <- entryNewWithMnemonic "_Imag"
114   (eImagE', fc2e) <- entryNewExponent
115   (eSizeM', fc3m) <- entryNewWithMnemonic "Si_ze"
116   (eSizeE', fc3e) <- entryNewExponent
117   (eRota', fc4) <- entryNewWithMnemonic "R_otation"
118   cInterior' <- colorButtonNewWithColor red
119   cBorder'   <- colorButtonNewWithColor black
120   cExterior' <- colorButtonNewWithColor white
121   fb <- frameNewWithContents vBoxNew "Actions" False [b01, b02, b03, b04, b8]
122   fa <- frameNewWithContents hBoxNew "Angled Internal Address" True [toWidget fa1, toWidget b7] -- FIXME wrong packing for b7
123   fh <- frameNewWithContents hBoxNew "Colours" True [cInterior', cBorder', cExterior']
124   let packMantissaExponent m e = do
125         h <- hBoxNew False spacing
126         boxPackStartDefaults h m
127         boxPackStart h e PackNatural 0
128         return h
129   fc1 <- packMantissaExponent fc1m fc1e
130   fc2 <- packMantissaExponent fc2m fc2e
131   fc3 <- packMantissaExponent fc3m fc3e
132   fc <- frameNewWithContents vBoxNew "Coordinates" True [fc1, fc2, fc3, fc4]
133   v <- vBoxNew False spacing
134   mapM_ (\w -> boxPackStart v w PackNatural 0) [fc, fa, fh]
135   h <- hBoxNew False spacing
136   boxPackStart h fb PackNatural 0
137   boxPackStartDefaults h v
138   ww <- windowNew
139   set ww [ windowIcon := Just icon, windowTitle := "gruff control" ]
140   containerAdd ww h
141   mg <- aDoLoad stateFile
142   gR <- newIORef $ case mg of
143     Nothing -> initialGruff
144     Just g -> g
145   let g0 = GruffGUI
146             { dStatus               = dStatus'
147             , bHome                 = bHome'
148             , bLoad                 = bLoad'
149             , bSave                 = bSave'
150             , bStop                 = bStop'
151             , bAddressToCoordinates = bAddressToCoordinates'
152             , bPeriodScan           = bPeriodScan'
153             , eAddress              = eAddress'
154             , eRealM                = eRealM'
155             , eRealE                = eRealE'
156             , eImagM                = eImagM'
157             , eImagE                = eImagE'
158             , eSizeM                = eSizeM'
159             , eSizeE                = eSizeE'
160             , eRota                 = eRota'
161             , cInterior             = cInterior'
162             , cBorder               = cBorder'
163             , cExterior             = cExterior'
164             , wMain                 = ww
165             , wImage                = iw
166             }
167       but b a = do
168         _ <- b g0 `onClicked` wrapA g0 gR a
169         return ()
170       butI b a = do
171         _ <- b g0 `onClicked` (wrapA g0 gR a >> upI)
172         return ()
173       butJ b a = do
174         _ <- b g0 `onClicked` (wrapA' g0 gR a upI)
175         return ()
176       butO b a = do
177         _ <- b g0 `onClicked` a
178         return ()
179       ent e a = do
180         _ <- e g0 `onEntryActivate` (entryGetText (e g0) >>= wrapE g0 gR a)
181         return ()
182       entI e a = do
183         _ <- e g0 `onEntryActivate` (entryGetText (e g0) >>= wrapE g0 gR a >> upI)
184         return ()
185       colI cbi cbb cbe a = forM_ [cbi, cbb, cbe] $ \c -> do
186         _ <- c g0 `onColorSet` (do
187           ci <- colorButtonGetColor (cbi g0)
188           cb <- colorButtonGetColor (cbb g0)
189           ce <- colorButtonGetColor (cbe g0)
190           _ <- a ci cb ce gR
191           upI)
192         return ()
193       entME m e a = do
194         let a' = do
195                   ms <- entryGetText (m g0)
196                   es <- entryGetText (e g0)
197                   let s = ms ++ if null es then "" else "e" ++ es
198                   wrapE g0 gR a s
199                   upI
200         _ <- m g0 `onEntryActivate` a'
201         _ <- e g0 `onEntryActivate` a'
202         return ()
203       upI = do
204         g <- readIORef gR
205         browserRender browser Image
206           { imageColours = let (c1, c2, c3) = gColours g in Colours (fromColor c1) (fromColor c2) (fromColor c3)
207           , imageLocation = Location
208               { center = toRational (fromMaybe 0 (gReal g)) :+ toRational (fromMaybe 0 (gImag g))
209               , radius = fromMaybe 0 (gSize g)
210               }
211           , imageViewport = Viewport
212               { aspect = 16 / 9 -- FIXME
213               , orient = fromMaybe 0 (gRota g)
214               }
215           , imageWindow = defWindow -- FIXME
216           } (return ()) (return ())
217         postRedisplay gl'
218       aUpdate (re :+ im) z = do
219         atomicModifyIORef gR $ \g ->
220           ( g{ gReal = Just re, gImag = Just im, gSize = Just z }, () )
221         g <- readIORef gR
222         uReal g0 g
223         uImag g0 g
224         uSize g0 g
225         uRota g0 g
226         upI
227   butI bHome aHome
228   butI bLoad aLoad
229   but  bSave aSave
230   butO bStop (browserAbort browser)
231   butJ bAddressToCoordinates aAddressToCoordinates
232   butJ bPeriodScan           aPeriodScan
233   ent  eAddress              aAddress
234   entME eRealM eRealE aReal
235   entME eImagM eImagE aImag
236   entME eSizeM eSizeE aSize
237   entI  eRota aRota
238   colI cInterior cBorder cExterior aColours
239   let aExit' = (exit (Log.log lg) stateFile =<< readIORef gR)
240   browserSetExitCallback browser aExit'
241   browserSetMouseCallback browser aUpdate
242   _ <- ww `onDestroy` aExit'
243   g <- readIORef gR
244   uEverything g0 g
245   upI
246   refreshGUI g0 g
247   widgetShowAll iw
248   widgetShowAll ww
249   mainGUI
250
251 data Gruff = Gruff
252   { gAddress    :: Maybe AngledInternalAddress
253   , gIsland     :: Maybe AngledInternalAddress
254   , gChild      :: Maybe [Angle]
255   , gLowerAngle :: Maybe Angle
256   , gUpperAngle :: Maybe Angle
257   , gReal       :: Maybe R
258   , gImag       :: Maybe R
259   , gSize       :: Maybe Double
260   } | Gruff2
261   { gAddress    :: Maybe AngledInternalAddress
262   , gReal       :: Maybe R
263   , gImag       :: Maybe R
264   , gSize       :: Maybe Double
265   , gRota       :: Maybe Double
266   , gColours    :: (Color, Color, Color)
267   }
268   deriving (Read, Show)
269 deriving instance Read Color
270
271 initialGruff :: Gruff
272 initialGruff = Gruff2
273   { gAddress    = parseAngledInternalAddress "1"
274   , gReal       = Just 0
275   , gImag       = Just 0
276   , gSize       = Just 1
277   , gRota       = Just 0
278   , gColours    = (red, black, white)
279   }
280
281 refreshGUI :: GruffGUI -> Gruff -> IO ()
282 refreshGUI g0 g = do
283   can bAddressToCoordinates $ j gAddress
284   can bPeriodScan           $ True
285   where
286     can w = widgetSetSensitive (w g0)
287     j a = isJust (a g)
288
289 -- button actions
290
291 type A = GruffGUI -> Gruff -> IO Gruff
292 type A' = GruffGUI -> Gruff -> (Gruff -> IO ()) -> IO ()
293
294 wrapA :: GruffGUI -> IORef Gruff -> A -> IO ()
295 wrapA g0 gR a = do
296   g <- readIORef gR
297   g' <- a g0 g
298   writeIORef gR $! g'
299   refreshGUI g0 g'
300
301 wrapA' :: GruffGUI -> IORef Gruff -> A' -> IO () -> IO ()
302 wrapA' g0 gR a upI = do
303   g <- readIORef gR
304   a g0 g $ \g' -> postGUISync $ do
305     writeIORef gR $! g'
306     upI
307     refreshGUI g0 g'
308
309 aHome :: A
310 aHome g0 _ = do
311   let g = initialGruff
312   uEverything g0 g
313   return g
314
315 aDoLoad :: FilePath -> IO (Maybe Gruff)
316 aDoLoad ff = (do
317     gr <- safeRead `fmap` readFile ff
318     return $ case gr of
319       Just (Gruff a _ _ _ _ b c d) -> Just (Gruff2 a b c d (Just 0) (red, black, white))
320       g -> g
321   ) `catchIO` const (return Nothing)
322
323 aLoad :: A
324 aLoad g0 g = do
325   fc <- fileChooserDialogNew (Just "gruff load") (Just $ wMain g0) FileChooserActionOpen [("Load", ResponseAccept), ("Cancel", ResponseCancel)]
326   widgetShow fc
327   r <- dialogRun fc
328   g' <- case r of
329     ResponseAccept -> do
330       mf <- fileChooserGetFilename fc
331       case mf of
332         Nothing -> return g
333         Just f -> do
334           mg <- aDoLoad f
335           case mg of
336             Nothing -> return g
337             Just g' -> uEverything g0 g' >> return g'
338     _ -> return g
339   widgetDestroy fc
340   return g'
341
342 aDoSave :: FilePath -> Gruff -> IO ()
343 aDoSave f g = writeFile f (show g) `catchIO` const (return ())
344
345 aSave :: A
346 aSave g0 g = do
347   fc <- fileChooserDialogNew (Just "gruff save") (Just $ wMain g0) FileChooserActionSave [("Save", ResponseAccept), ("Cancel", ResponseCancel)]
348   widgetShow fc
349   r <- dialogRun fc
350   case r of
351     ResponseAccept -> do
352       mf <- fileChooserGetFilename fc
353       case mf of
354         Nothing -> return ()
355         Just f -> aDoSave f g
356     _ -> return ()
357   widgetDestroy fc
358   return g
359
360 aPeriodScan :: A'
361 aPeriodScan g0 g gn = do
362   statusDialog (dStatus g0) "gruff status" $ \progress -> case liftM3 (,,) (gReal g) (gImag g) (gSize g) of
363     Nothing -> progress "nothing to do" >> gn g
364     Just (re, im, r) -> do
365       forM_ (muLocate (re:+im) r) $ \mp -> case mp of
366         MuScanTodo       -> progress "Scanning for period..."
367         MuScan           -> progress "Scanning for period..."
368         MuScanDone p     -> progress$"Scanning for period... " ++ show p
369         MuNucleusTodo'   -> progress "Computing nucleus..."
370         MuNucleus' i     -> when (i `mod` 20 == 0) . progress$"Computing nucleus... " ++ show i
371         MuNucleusDone' _ -> progress "Computing nucleus... done"
372         MuBondTodo'      -> progress "Computing bond..."
373         MuBond' i        -> when (i `mod` 20 == 0) . progress$"Computing bond... " ++ show i
374         MuBondDone' _    -> progress "Computing bond... done"
375         MuSuccess'' mu   -> do
376           let g' = g{ gReal = Just . realPart . muNucleus $ mu
377                     , gImag = Just . imagPart . muNucleus $ mu
378                     , gSize = Just . (* 4) . muSize $ mu
379                     , gRota = Just . subtract (pi/2) . muOrient $ mu
380                     }
381           progress "Found!"
382           postGUISync $ do
383             uReal g0 g'
384             uImag g0 g'
385             uSize g0 g'
386             uRota g0 g'
387           forM_ (muToAddress mu) $ \mp' -> case mp' of
388             MuCuspTodo       -> progress "Computing cusp..."
389             MuCuspDone _     -> progress "Computing cusp... done"
390             MuDwellTodo      -> progress "Computing dwell..."
391             MuDwell i        -> when (i `mod` 100 == 0) . progress$"Computing dwell... " ++ show i
392             MuDwellDone _    -> progress "Computing dwell... done"
393             MuRayOutTodo     -> progress "Tracing rays..."
394             MuRayOut i       -> progress$"Tracing rays... " ++ show (round $ i * 100 :: Int) ++ "%"
395             MuRayOutDone _   -> progress "Tracing rays... done"
396             MuExternalTodo   -> progress "Computing angle..."
397             MuExternalDone _ -> progress "Computing angle... done"
398             MuAddressTodo    -> progress "Finding address..."
399             MuSuccess' a     -> do
400               let g'' = g'{ gAddress = Just a }
401               progress "Complete!"
402               postGUISync $ do
403                 uAddress g0 g''
404               gn g''
405             MuFailed'         -> progress "Failed!" >> gn g'
406         MuFailed''       -> progress "Failed!" >> gn g
407  
408 {-        
409     progress "Scanning for period..."
410     let ps = do
411           re <- gReal g
412           im <- gImag g
413           r  <- gSize g
414           let c = re :+ im
415           p <- findPeriod 10000000 (realToFrac r) c
416           return (p, r, c)
417     g' <- case ps of
418       Just (p, _r, c) -> do
419         let n = c
420         progress $ "Computing nucleus (" ++ show p ++ ")..."
421         case converge $ findNucleus p n of
422           Just c0@(re :+ im) | abs re + abs im >= 0 -> case converge $ findBond p c0 0.5 of
423             Just b -> let z = magnitude (b - c0) / 0.75 in
424               if 10 > z && z > 0 then do
425                 let g1 = g{ gReal = Just re, gImag = Just im, gSize = Just (4 * realToFrac z), gRota = Just (realToFrac $ phase (b - c0) - pi / 2) }
426                 return g1
427                else return g
428             _ -> return g
429           _ -> return g
430       _ -> return g
431     progress "Done!"
432     postGUISync $ do
433       uReal g0 g'
434       uImag g0 g'
435       uSize g0 g'
436       uRota g0 g'
437       uAddress g0 g'
438     gn g'
439 -}
440
441 aAddressToCoordinates :: A'
442 aAddressToCoordinates g0 g gn = do
443   statusDialog (dStatus g0) "gruff status" $ \progress -> case gAddress g of
444     Nothing -> progress "nothing to do" >> gn g
445     Just addr -> do
446       forM_ (muFromAddress addr) $ \mp -> do
447         case mp of
448           MuSplitTodo      -> progress "Splitting address..."
449           MuSplitDone _ _  -> progress "Splitting address... done"
450           MuAnglesTodo     -> progress "Computing angles..."
451           MuAnglesDone _ _ -> progress "Computing angles... done"
452           MuRayTodo        -> progress "Tracing rays..."
453           MuRay n          -> when (n `mod` 20 == 0) . progress$"Tracing rays... " ++ show n
454           MuRayDone _      -> progress "Tracing rays... done"
455           MuNucleusTodo    -> progress "Computing nucleus..."
456           MuNucleus n      -> when (n `mod` 20 == 0) . progress$"Computing nucleus... " ++ show n
457           MuNucleusDone _  -> progress "Computing nucleus... done"
458           MuBondTodo       -> progress "Computing bond..."
459           MuBond n         -> when (n `mod` 20 == 0) . progress$"Computing bond... " ++ show n
460           MuBondDone _     -> progress "Computing bond... done"
461           MuSuccess mu     -> do
462             let g' = g{ gReal = Just . realPart . muNucleus $ mu
463                       , gImag = Just . imagPart . muNucleus $ mu
464                       , gSize = Just . (* 4) . muSize $ mu
465                       , gRota = Just . subtract (pi/2) . muOrient $ mu
466                       }
467             progress "Done!"
468             postGUISync $ do
469               uReal g0 g'
470               uImag g0 g'
471               uSize g0 g'
472               uRota g0 g'
473             gn g'
474           MuFailed         -> progress "Failed!" >> gn g
475
476 -- entry update
477
478 type U = GruffGUI -> Gruff -> IO ()
479
480 uEverything, uAddress, uReal, uImag, uSize, uRota :: U
481 uEverything g0 g = forM_ [uAddress, uReal, uImag, uSize, uRota] $ \u -> u g0 g
482 uAddress g0 g = entrySetText (eAddress g0) (maybe "" prettyAngledInternalAddress (gAddress g))
483 uReal g0 g = uMantissaExponent (eRealM g0) (eRealE g0) (maybe "" show (gReal g))
484 uImag g0 g = uMantissaExponent (eImagM g0) (eImagE g0) (maybe "" show (gImag g))
485 uSize g0 g = uMantissaExponent (eSizeM g0) (eSizeE g0) (maybe "" show (gSize g))
486 uRota g0 g = entrySetText (eRota g0) (maybe "" show (gRota g))
487
488 uMantissaExponent :: (EntryClass a, EntryClass b) => a -> b -> String -> IO ()
489 uMantissaExponent m e s = do
490   let (ms, me) = break (== 'e') s
491   entrySetText m ms
492   entrySetText e (drop 1 me)
493
494 -- entry actions
495
496 type E = Gruff -> String -> Gruff
497
498 wrapE :: GruffGUI -> IORef Gruff -> E -> String -> IO ()
499 wrapE g0 gR e s = do
500   g <- readIORef gR
501   let g' = e g s
502   writeIORef gR $! g'
503   refreshGUI g0 g'
504
505 aAddress, aReal, aImag, aSize, aRota :: E
506 aAddress g s = g{ gAddress = parseAngledInternalAddress s }
507 aReal    g s = g{ gReal    = safeRead s }
508 aImag    g s = g{ gImag    = safeRead s }
509 aSize    g s = g{ gSize    = safeRead s }
510 aRota    g s = g{ gRota    = safeRead s }
511
512 aColours :: Color -> Color -> Color -> IORef Gruff -> IO ()
513 aColours i b e gR = atomicModifyIORef gR $ \g -> (g{ gColours = (i, b, e) }, ())
514
515 minSize :: Size
516 minSize = Size 160 100
517
518 {-
519 converge :: NearZero n => [n] -> Maybe n
520 converge (x:y:zs)
521   | nearZero (x - y) = Just x
522   | otherwise = converge (y:zs)
523 converge [x] = Just x
524 converge _ = Nothing
525 -}
526
527 red, black, white :: Color
528 red = Color 65535 0 0
529 black = Color 0 0 0
530 white = Color 65535 65535 65535
531
532 fromColor :: Color -> Colour
533 fromColor (Color r g b) = Colour (fromIntegral r / 65535) (fromIntegral g / 65535) (fromIntegral b / 65535)