use new browser interface; simplify gui removing seldom-used features; use new muatom...
[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_, liftM2)
6 import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef, writeIORef)
7 import Data.Maybe (isJust, fromMaybe)
8 --import Data.Ratio ((%))
9 import Graphics.UI.Gtk hiding (get, Region, Size, Window)
10 import qualified Graphics.UI.Gtk as GTK
11 import Graphics.UI.Gtk.OpenGL (initGL)
12 import System.Directory (getAppUserDataDirectory, createDirectoryIfMissing)
13 import System.FilePath ((</>))
14 import Data.Vec (NearZero, nearZero)
15
16 import Fractal.RUFF.Mandelbrot.Address
17   ( AngledInternalAddress, Angle
18   , parseAngledInternalAddress, parseAngle, parseAngles
19   , prettyAngledInternalAddress, prettyAngle, prettyAngles
20   , splitAddress, joinAddress, addressPeriod
21   , angledInternalAddress, externalAngles
22   )
23 import Fractal.RUFF.Mandelbrot.Nucleus (findPeriod, findNucleus, findBond)
24 import Fractal.RUFF.Mandelbrot.Ray (externalRay) -- , externalRayOut)
25 import Fractal.RUFF.Types.Complex (Complex((:+)), magnitude, magnitude2, phase, realPart, imagPart)
26
27 import Paths_gruff (getDataFileName)
28 import Number (R)
29 import Browser
30 import MuAtom
31 import View
32 --import CacheView (cInitialize)
33 import GLUTGtk (glut, Size(Size))
34 import Logger (logger, LogLevel(Debug))
35 import qualified Logger as Log
36 import StatusDialog
37 import Utils (safeRead, catchIO)
38
39
40 exit :: (LogLevel -> String -> IO ()) -> FilePath -> Gruff -> IO ()
41 exit lg stateFile g = do
42   lg Debug "exitCallback"
43   aDoSave stateFile g
44   mainQuit
45
46 data GruffGUI = GruffGUI
47   { dStatus                 :: StatusDialog
48   -- buttons
49   , bHome
50   , bLoad
51   , bSave
52   , bStop
53   , bAddressToCoordinates
54 {-
55   , bAddressToIslandChild
56   , bIslandChildToAddress
57   , bAddressToAngles
58   , bIslandToAngles
59   , bLowerAngleToAddress
60   , bUpperAngleToAddress
61 -}
62   , bPeriodScan             :: Button
63   -- entries
64   , eAddress
65 {-
66   , eIsland
67   , eChild
68   , eLowerAngle
69   , eUpperAngle
70 -}
71   , eRealM, eRealE
72   , eImagM, eImagE
73   , eSizeM, eSizeE
74   , eRota                   :: Entry
75 --  , eHueShift
76 --  , eHueScale
77   -- colour pickers
78   , cInterior
79   , cBorder
80   , cExterior               :: ColorButton
81   -- windows
82   , wMain
83   , wImage                  :: GTK.Window
84   }
85
86 main :: IO ()
87 main = do
88   -- contexts
89   _ <- initGUI
90   _ <- initGL
91   gl' <- glut minSize
92 --  glC <- glut minSize
93   -- directories
94   appDir <- getAppUserDataDirectory "gruff"
95   let cacheDir' = appDir </> "cache"
96       logDir    = appDir </> "log"
97       stateFile = appDir </> "state.gruff"
98   createDirectoryIfMissing False appDir
99   createDirectoryIfMissing False logDir
100   lg <- logger logDir
101   icon <- pixbufNewFromFile =<< getDataFileName "icon.png"
102   -- widget window
103   browser <- browserNew gl' icon lg cacheDir'
104   let iw = browserWindow browser
105   -- (iw, iUpdate, iInitializeLate, iStop) <- iInitialize gl' icon lg cacheDir'
106 --  (cw, cUpdate, cInitializeLate       ) <- cInitialize glC icon cacheDir'
107   -- widget window
108   sg <- sizeGroupNew SizeGroupHorizontal
109   let spacing = 2
110       entryNewWithMnemonic m = do
111         e <- entryNew
112         entrySetWidthChars e 80
113         l <- labelNewWithMnemonic m
114         labelSetMnemonicWidget l e
115         sizeGroupAddWidget sg l
116         h <- hBoxNew False spacing
117         boxPackStart h l PackNatural 0
118         boxPackStartDefaults h e
119         return (e, h)
120       entryNewExponent = do
121         e <- entryNew
122         entrySetWidthChars e 4
123         l <- labelNew (Just "e")
124         h <- hBoxNew False spacing
125         boxPackStart h l PackNatural 0
126         boxPackStart h e PackNatural 0
127         return (e, h)
128       frameNewWithContents box t r ws = do
129         f <- frameNew
130         frameSetLabel f t
131         frameSetLabelAlign f (if r then 1 else 0) 0.5
132         v <- box False spacing
133         forM_ ws $ boxPackStartDefaults v
134         set f [ containerChild := v ]
135         return f
136   dStatus'                  <- statusDialogNew
137   b01@bHome'                <- buttonNewWithLabel "Home"
138   b02@bLoad'                <- buttonNewWithLabel "Load"
139   b03@bSave'                <- buttonNewWithLabel "Save"
140   b04@bStop'                <- buttonNewWithLabel "Stop"
141   b7@bAddressToCoordinates' <- buttonNewWithLabel "Address"
142 {-
143   b1@bAddressToIslandChild' <- buttonNewWithLabel "Address → Island + Child"
144   b2@bIslandChildToAddress' <- buttonNewWithLabel "Island + Child → Address"
145   b3@bAddressToAngles'      <- buttonNewWithLabel "Address → Lower + Upper"
146   b4@bIslandToAngles'       <- buttonNewWithLabel "Island → Lower + Upper"
147   b5@bLowerAngleToAddress'  <- buttonNewWithLabel "Lower → Address"
148   b6@bUpperAngleToAddress'  <- buttonNewWithLabel "Upper → Address"
149 -}
150   b8@bPeriodScan'           <- buttonNewWithLabel "Scan"
151   (eAddress', fa1) <- entryNewWithMnemonic "_Address"
152 {-
153   (eIsland',  fa2) <- entryNewWithMnemonic "I_sland"
154   (eChild',   fa3) <- entryNewWithMnemonic "_Child"
155   (eLowerAngle', fe1) <- entryNewWithMnemonic "_Lower"
156   (eUpperAngle', fe2) <- entryNewWithMnemonic "_Upper"
157 -}
158   (eRealM', fc1m) <- entryNewWithMnemonic "_Real"
159   (eRealE', fc1e) <- entryNewExponent
160   (eImagM', fc2m) <- entryNewWithMnemonic "_Imag"
161   (eImagE', fc2e) <- entryNewExponent
162   (eSizeM', fc3m) <- entryNewWithMnemonic "Si_ze"
163   (eSizeE', fc3e) <- entryNewExponent
164   (eRota', fc4) <- entryNewWithMnemonic "R_otation"
165 --  (eHueShift', fh1) <- entryNewWithMnemonic "Hue Shift"
166 --  (eHueScale', fh2) <- entryNewWithMnemonic "Hue Scale"
167   cInterior' <- colorButtonNewWithColor red
168   cBorder'   <- colorButtonNewWithColor black
169   cExterior' <- colorButtonNewWithColor white
170 {-
171   b0 <- hBoxNew False spacing
172   mapM_ (boxPackStartDefaults b0) [b01, b02, b03, b04]
173   fb <- frameNewWithContents vBoxNew "Actions" False $ toWidget b0 : map toWidget [b7, b1, b2, b3, b4, b5, b6, b8]
174 -}
175   fb <- frameNewWithContents vBoxNew "Actions" False [b01, b02, b03, b04, b7, b8]
176   fa <- frameNewWithContents vBoxNew "Angled Internal Address" True [fa1] -- , fa2, fa3]
177 --  fe <- frameNewWithContents vBoxNew "External Angles" True [fe1, fe2]
178   fh <- frameNewWithContents hBoxNew "Colours" True [cInterior', cBorder', cExterior']
179   let packMantissaExponent m e = do
180         h <- hBoxNew False spacing
181         boxPackStartDefaults h m
182         boxPackStart h e PackNatural 0
183         return h
184   fc1 <- packMantissaExponent fc1m fc1e
185   fc2 <- packMantissaExponent fc2m fc2e
186   fc3 <- packMantissaExponent fc3m fc3e
187   fc <- frameNewWithContents vBoxNew "Coordinates" True [fc1, fc2, fc3, fc4]
188   v <- vBoxNew False spacing
189 --  mapM_ (\w -> boxPackStart v w PackNatural 0) [fc, fa, fe, fh]
190   mapM_ (\w -> boxPackStart v w PackNatural 0) [fa, fc, fh]
191   h <- hBoxNew False spacing
192   boxPackStart h fb PackNatural 0
193   boxPackStartDefaults h v
194   ww <- windowNew
195   set ww [ windowIcon := Just icon, windowTitle := "gruff control" ]
196   containerAdd ww h
197   mg <- aDoLoad stateFile
198   gR <- newIORef $ case mg of
199     Nothing -> initialGruff
200     Just g -> g
201   let g0 = GruffGUI
202             { dStatus               = dStatus'
203             , bHome                 = bHome'
204             , bLoad                 = bLoad'
205             , bSave                 = bSave'
206             , bStop                 = bStop'
207             , bAddressToCoordinates = bAddressToCoordinates'
208 {-
209             , bAddressToIslandChild = bAddressToIslandChild'
210             , bIslandChildToAddress = bIslandChildToAddress'
211             , bAddressToAngles      = bAddressToAngles'
212             , bIslandToAngles       = bIslandToAngles'
213             , bLowerAngleToAddress  = bLowerAngleToAddress'
214             , bUpperAngleToAddress  = bUpperAngleToAddress'
215 -}
216             , bPeriodScan           = bPeriodScan'
217             , eAddress              = eAddress'
218 {-
219             , eIsland               = eIsland'
220             , eChild                = eChild'
221             , eLowerAngle           = eLowerAngle'
222             , eUpperAngle           = eUpperAngle'
223 -}
224             , eRealM                = eRealM'
225             , eRealE                = eRealE'
226             , eImagM                = eImagM'
227             , eImagE                = eImagE'
228             , eSizeM                = eSizeM'
229             , eSizeE                = eSizeE'
230             , eRota                 = eRota'
231             , cInterior             = cInterior'
232             , cBorder               = cBorder'
233             , cExterior             = cExterior'
234             , wMain                 = ww
235             , wImage                = iw
236             }
237       but b a = do
238         _ <- b g0 `onClicked` wrapA g0 gR a
239         return ()
240       butI b a = do
241         _ <- b g0 `onClicked` (wrapA g0 gR a >> upI)
242         return ()
243       butJ b a = do
244         _ <- b g0 `onClicked` (wrapA' g0 gR a upI)
245         return ()
246       butO b a = do
247         _ <- b g0 `onClicked` a
248         return ()
249       ent e a = do
250         _ <- e g0 `onEntryActivate` (entryGetText (e g0) >>= wrapE g0 gR a)
251         return ()
252       entI e a = do
253         _ <- e g0 `onEntryActivate` (entryGetText (e g0) >>= wrapE g0 gR a >> upI)
254         return ()
255       colI cbi cbb cbe a = forM_ [cbi, cbb, cbe] $ \c -> do
256         _ <- c g0 `onColorSet` (do
257           ci <- colorButtonGetColor (cbi g0)
258           cb <- colorButtonGetColor (cbb g0)
259           ce <- colorButtonGetColor (cbe g0)
260           _ <- a ci cb ce gR
261           upI)
262         return ()
263       entME m e a = do
264         let a' = do
265                   ms <- entryGetText (m g0)
266                   es <- entryGetText (e g0)
267                   let s = ms ++ if null es then "" else "e" ++ es
268                   wrapE g0 gR a s
269                   upI
270         _ <- m g0 `onEntryActivate` a'
271         _ <- e g0 `onEntryActivate` a'
272         return ()
273       upI = do
274         g <- readIORef gR
275         browserRender browser Image
276           { imageColours = let (c1, c2, c3) = gColours g in Colours (fromColor c1) (fromColor c2) (fromColor c3)
277           , imageLocation = Location
278               { center = toRational (fromMaybe 0 (gReal g)) :+ toRational (fromMaybe 0 (gImag g))
279               , radius = fromMaybe 0 (gSize g)
280               }
281           , imageViewport = Viewport
282               { aspect = 16 / 9 -- FIXME
283               , orient = fromMaybe 0 (gRota g)
284               }
285           , imageWindow = defWindow -- FIXME
286           } (return ()) (return ())
287       aUpdate (re :+ im) z = do
288         atomicModifyIORef gR $ \g ->
289           ( g{ gReal = Just re, gImag = Just im, gSize = Just z }, () )
290         g <- readIORef gR
291         uReal g0 g
292         uImag g0 g
293         uSize g0 g
294         uRota g0 g
295         upI
296   butI bHome aHome
297   butI bLoad aLoad
298   but  bSave aSave
299   butO bStop (browserAbort browser)
300   butJ bAddressToCoordinates aAddressToCoordinates
301 {-
302   but  bAddressToIslandChild aAddressToIslandChild
303   but  bIslandChildToAddress aIslandChildToAddress
304   but  bAddressToAngles      aAddressToAngles
305   but  bIslandToAngles       aIslandToAngles
306   but  bLowerAngleToAddress  aLowerAngleToAddress
307   but  bUpperAngleToAddress  aUpperAngleToAddress
308 -}
309   butJ bPeriodScan           aPeriodScan
310   ent  eAddress              aAddress
311 {-
312   ent  eIsland               aIsland
313   ent  eChild                aChild
314   ent  eLowerAngle           aLowerAngle
315   ent  eUpperAngle           aUpperAngle
316 -}
317   entME eRealM eRealE aReal
318   entME eImagM eImagE aImag
319   entME eSizeM eSizeE aSize
320   entI  eRota aRota
321   colI cInterior cBorder cExterior aColours
322   let aExit' = (exit (Log.log lg) stateFile =<< readIORef gR)
323   browserSetExitCallback browser aExit'
324   browserSetMouseCallback browser aUpdate
325 --  cInitializeLate         aExit'
326   _ <- ww `onDestroy` aExit'
327   g <- readIORef gR
328   uEverything g0 g
329   upI
330   refreshGUI g0 g
331   widgetShowAll iw
332   widgetShowAll ww
333 --  widgetShowAll cw
334   mainGUI
335
336 data Gruff = Gruff
337   { gAddress    :: Maybe AngledInternalAddress
338   , gIsland     :: Maybe AngledInternalAddress
339   , gChild      :: Maybe [Angle]
340   , gLowerAngle :: Maybe Angle
341   , gUpperAngle :: Maybe Angle
342   , gReal       :: Maybe R
343   , gImag       :: Maybe R
344   , gSize       :: Maybe Double
345   } | Gruff2
346   { gAddress    :: Maybe AngledInternalAddress
347 {-
348   , gIsland     :: Maybe AngledInternalAddress
349   , gChild      :: Maybe [Angle]
350   , gLowerAngle :: Maybe Angle
351   , gUpperAngle :: Maybe Angle
352 -}
353   , gReal       :: Maybe R
354   , gImag       :: Maybe R
355   , gSize       :: Maybe Double
356   , gRota       :: Maybe Double
357   , gColours    :: (Color, Color, Color)
358 --  , gHueShift   :: Maybe Double
359 --  , gHueScale   :: Maybe Double
360   }
361   deriving (Read, Show)
362 deriving instance Read Color
363
364 initialGruff :: Gruff
365 initialGruff = Gruff2
366   { gAddress    = parseAngledInternalAddress "1"
367 {-
368   , gIsland     = parseAngledInternalAddress "1"
369   , gChild      = Just []
370   , gLowerAngle = Just 0
371   , gUpperAngle = Just 1
372 -}
373   , gReal       = Just 0
374   , gImag       = Just 0
375   , gSize       = Just 1
376   , gRota       = Just 0
377 --  , gHueShift   = Just 0
378 --  , gHueScale   = Just 1
379   , gColours    = (red, black, white)
380   }
381
382 refreshGUI :: GruffGUI -> Gruff -> IO ()
383 refreshGUI g0 g = do
384   can bAddressToCoordinates $ j gAddress
385 {-
386   can bAddressToIslandChild $ j gAddress
387   can bIslandChildToAddress $ j gIsland && j gChild
388   can bAddressToAngles      $ j gAddress
389   can bIslandToAngles       $ j gIsland
390   can bLowerAngleToAddress  $ j gLowerAngle
391   can bUpperAngleToAddress  $ j gUpperAngle
392 -}
393   can bPeriodScan           $ True
394   where
395     can w = widgetSetSensitive (w g0)
396     j a = isJust (a g)
397
398 -- button actions
399
400 type A = GruffGUI -> Gruff -> IO Gruff
401 type A' = GruffGUI -> Gruff -> (Gruff -> IO ()) -> IO ()
402
403 wrapA :: GruffGUI -> IORef Gruff -> A -> IO ()
404 wrapA g0 gR a = do
405   g <- readIORef gR
406   g' <- a g0 g
407   writeIORef gR $! g'
408   refreshGUI g0 g'
409
410 wrapA' :: GruffGUI -> IORef Gruff -> A' -> IO () -> IO ()
411 wrapA' g0 gR a upI = do
412   g <- readIORef gR
413   a g0 g $ \g' -> postGUISync $ do
414     writeIORef gR $! g'
415     upI
416     refreshGUI g0 g'
417
418 aHome :: A
419 aHome g0 _ = do
420   let g = initialGruff
421   uEverything g0 g
422   return g
423
424 aDoLoad :: FilePath -> IO (Maybe Gruff)
425 aDoLoad ff = (do
426     gr <- safeRead `fmap` readFile ff
427     return $ case gr of
428 --      Just (Gruff a b c d e f g h) -> Just (Gruff1 a b c d e f g h (Just 0) (Just 1))
429       Just (Gruff a _ _ _ _ b c d) -> Just (Gruff2 a b c d (Just 0) (red, black, white))
430       g -> g
431   ) `catchIO` const (return Nothing)
432
433 aLoad :: A
434 aLoad g0 g = do
435   fc <- fileChooserDialogNew (Just "gruff load") (Just $ wMain g0) FileChooserActionOpen [("Load", ResponseAccept), ("Cancel", ResponseCancel)]
436   widgetShow fc
437   r <- dialogRun fc
438   g' <- case r of
439     ResponseAccept -> do
440       mf <- fileChooserGetFilename fc
441       case mf of
442         Nothing -> return g
443         Just f -> do
444           mg <- aDoLoad f
445           case mg of
446             Nothing -> return g
447             Just g' -> uEverything g0 g' >> return g'
448     _ -> return g
449   widgetDestroy fc
450   return g'
451
452 aDoSave :: FilePath -> Gruff -> IO ()
453 aDoSave f g = writeFile f (show g) `catchIO` const (return ())
454
455 aSave :: A
456 aSave g0 g = do
457   fc <- fileChooserDialogNew (Just "gruff save") (Just $ wMain g0) FileChooserActionSave [("Save", ResponseAccept), ("Cancel", ResponseCancel)]
458   widgetShow fc
459   r <- dialogRun fc
460   case r of
461     ResponseAccept -> do
462       mf <- fileChooserGetFilename fc
463       case mf of
464         Nothing -> return ()
465         Just f -> aDoSave f g
466     _ -> return ()
467   widgetDestroy fc
468   return g
469
470 aPeriodScan :: A'
471 aPeriodScan g0 g gn = do
472   statusDialog (dStatus g0) "gruff status" $ \progress -> do
473     progress "Scanning for period..."
474     let ps = do
475           re <- gReal g
476           im <- gImag g
477           r  <- gSize g
478           let c = re :+ im
479           p <- findPeriod 10000000 (realToFrac r) c
480           return (p, r, c)
481     g' <- case ps of
482       Just (p, _r, c) -> do
483         let n = c
484         progress $ "Computing nucleus (" ++ show p ++ ")..."
485         case converge $ findNucleus p n of
486           Just c0@(re :+ im) | abs re + abs im >= 0 -> case converge $ findBond p c0 0.5 of
487             Just b -> let z = magnitude (b - c0) / 0.75 in
488               if 10 > z && z > 0 then do
489 --              progress $ "Computing external angle of cusp..."
490                 let g1 = g{ gReal = Just re, gImag = Just im, gSize = Just (4 * realToFrac z), gRota = Just (realToFrac $ phase (b - c0) - pi / 2) }
491 {-
492                   root = findBond p c0 0
493                   cusp = c0 + 2 * (root - c0)
494                   iter !k !zz !cc
495                     | magnitude2 zz > er2 = k
496                     | k > maxIters = maxIters
497                     | otherwise = iter (k + 1) (zz * zz + cc) cc
498                   m = sharpness * iter 0 0 cusp
499                   er = 2 ** 24
500                   er2 = er * er
501                   sharpness = 8
502                   maxIters = 10000
503                   rs = externalRayOut maxIters (2**(-200)) sharpness er cusp
504                   go [(_, c)] = return c
505                   go ((n, _):xs) = do
506                     progress $ "Computing external angle of cusp... (" ++ show n ++ "/" ++ show m ++ ") (period " ++ show p ++ ")"
507                     go xs
508               c1 <- go $ [(0::Int)..] `zip` rs
509               let af0 = phase c1 / (2 * pi)
510                   af = af0 - fromIntegral (floor af0 :: Int)
511                   d = 2 ^ p - 1
512                   af' = af * fromInteger d
513                   ai = round af'
514                   ar = ai % d
515                   err = af - fromRational ar
516               print (ar, err)
517               if (magnitude2 c1 > er2)
518                 then do
519                   progress $ "Computing angled internal address..."
520                   case angledInternalAddress ar of
521                     Just aia -> return g1{ gAddress = Just aia }
522                     _ -> return g1
523                 else return g1
524 -}
525                 return g1
526                else return g
527             _ -> return g
528           _ -> return g
529       _ -> return g
530     progress "Done!"
531     postGUISync $ do
532       uReal g0 g'
533       uImag g0 g'
534       uSize g0 g'
535       uRota g0 g'
536       uAddress g0 g'
537     gn g'
538
539 aAddressToCoordinates :: A'
540 aAddressToCoordinates g0 g gn = do
541   statusDialog (dStatus g0) "gruff status" $ \progress -> case gAddress g of
542     Nothing -> progress "nothing to do" >> gn g
543     Just addr -> do
544       forM_ (muFromAddress addr) $ \mp -> do
545         case mp of
546           MuSplitTodo      -> progress "Splitting address..."
547           MuSplitDone _ _  -> progress "Splitting address... done"
548           MuAnglesTodo     -> progress "Computing angles..."
549           MuAnglesDone _ _ -> progress "Computing angles... done"
550           MuRayTodo        -> progress "Tracing rays..."
551           MuRay n          -> progress$"Tracing rays... " ++ show n
552           MuRayDone _      -> progress "Tracing rays... done"
553           MuNucleusTodo    -> progress "Computing nucleus..."
554           MuNucleus n      -> progress$"Computing nucleus... " ++ show n
555           MuNucleusDone _  -> progress "Computing nucleus... done"
556           MuBondTodo       -> progress "Computing bond..."
557           MuBond n         -> progress$"Computing bond... " ++ show n
558           MuBondDone _     -> progress "Computing bond... done"
559           MuSuccess mu     -> do
560             let g' = g{ gReal = Just . realPart . muNucleus $ mu
561                       , gImag = Just . imagPart . muNucleus $ mu
562                       , gSize = Just . (* 4) . muSize $ mu
563                       , gRota = Just . subtract (pi/2) . muOrient $ mu
564                       }
565             progress "Done!"
566             postGUISync $ do
567               uReal g0 g'
568               uImag g0 g'
569               uSize g0 g'
570               uRota g0 g'
571             gn g'
572           MuFailed         -> progress "Failed!" >> gn g
573 {-
574     progress "Splitting address..."
575     g1 <- aAddressToIslandChild g0 g
576     progress "Finding external angles..."
577     g2 <- aIslandToAngles g0 g1
578     progress "Tracing external rays..."
579     g' <- aAnglesChildToCoordinates (progress "Computing nucleus...") g0 g2
580     progress "Done!"
581     postGUISync $ do
582       uReal g0 g'
583       uImag g0 g'
584       uSize g0 g'
585       uRota g0 g'
586     gn g'
587
588 aAnglesChildToCoordinates :: IO () -> A
589 aAnglesChildToCoordinates progress _g0 g = do
590   case liftM2 (,) (gIsland g) (gLowerAngle g) of
591     Just (a, lo) ->
592       let eps = 2 ** negate (fromIntegral p + 16)
593           eps' = 2 ** negate (fromIntegral p + 8)
594           p = addressPeriod a
595           rlo = externalRay eps 8 (2**24) lo
596           ok w = magnitude2 w < 2 * (2**24) ^ (2::Int) -- NaN -> False
597           converge' [] = Nothing
598           converge' [x] = Just x
599           converge' (x:m@(y:_))
600             | not $ magnitude (x - y) < eps' = converge' m
601             | otherwise = Just x
602           rend = converge' . takeWhile ok . take (8 * (fromIntegral p + 32)) $ rlo
603       in  case rend of
604         Just c -> progress >> case converge $ findNucleus p c of
605           Just c0@(re :+ im) -> case converge $ findBond p c0 0.5 of
606             Just b -> let z = magnitude (b - c0) / 0.75
607                       in if 10 > z && z > 0 then return g{ gReal = Just re, gImag = Just im, gSize = Just (4 * realToFrac z), gRota = Just (realToFrac $ phase (b - c0) - pi / 2) } else return g
608             _ -> return g
609           _ -> return g
610         Nothing -> return g
611     Nothing -> return g
612
613 aAddressToIslandChild :: A
614 aAddressToIslandChild g0 g = do
615   let g' = fromMaybe g $ do
616         a <- gAddress g
617         let (i, c) = splitAddress a
618         return g{ gIsland = Just i, gChild = Just c }
619   uIsland g0 g'
620   uChild g0 g'
621   return g'
622
623 aIslandChildToAddress :: A
624 aIslandChildToAddress g0 g = do
625   let g' = g{ gAddress = liftM2 joinAddress (gIsland g) (gChild g) }
626   uAddress g0 g'
627   return g'
628
629 aAddressToAngles :: A
630 aAddressToAngles g0 g = do
631   let g' = case externalAngles =<< gAddress g of
632             Just (lo, up) -> g{ gLowerAngle = Just lo, gUpperAngle = Just up }
633             Nothing -> g
634   uLowerAngle g0 g'
635   uUpperAngle g0 g'
636   return g'
637
638 aIslandToAngles :: A
639 aIslandToAngles g0 g = do
640   let g' = case externalAngles =<< gIsland g of
641             Just (lo, up) -> g{ gLowerAngle = Just lo, gUpperAngle = Just up }
642             Nothing -> g
643   -- strictness hack to prevent evaluation in gui thread...
644   case (gLowerAngle g', gUpperAngle g') of
645     (Just lo, Just up) | lo + up > 0 -> return ()
646     _ -> return ()
647   uLowerAngle g0 g'
648   uUpperAngle g0 g'
649   return g'
650
651 aLowerAngleToAddress :: A
652 aLowerAngleToAddress g0 g = do
653   let a = angledInternalAddress =<< gLowerAngle g
654       g' = g{ gAddress = a }
655   case a of
656     Just _ -> return ()
657     Nothing -> return ()
658   uAddress g0 g'
659   return g'
660
661 aUpperAngleToAddress :: A
662 aUpperAngleToAddress g0 g = do
663   let a = angledInternalAddress =<< gUpperAngle g
664       g' = g{ gAddress = a }
665   case a of
666     Just _ -> return ()
667     Nothing -> return ()
668   uAddress g0 g'
669   return g'
670
671 -}
672
673 -- entry update
674
675 type U = GruffGUI -> Gruff -> IO ()
676
677 uEverything, uAddress, {- uIsland, uChild, uLowerAngle, uUpperAngle -} uReal, uImag, uSize, uRota :: U
678 uEverything g0 g = forM_ [uAddress, {- uIsland, uChild, uLowerAngle, uUpperAngle, -} uReal, uImag, uSize] $ \u -> u g0 g
679 uAddress g0 g = do
680   let s = prettyAngledInternalAddress
681   entrySetText (eAddress g0) (maybe "" s (gAddress g))
682 {-
683 uIsland g0 g = do
684   let s = prettyAngledInternalAddress
685   entrySetText (eIsland g0) (maybe "" s (gIsland g))
686 uChild g0 g = do
687   let s = prettyAngles
688   entrySetText (eChild g0) (maybe "" s (gChild g))
689 uLowerAngle g0 g = do
690   let s = prettyAngle
691   entrySetText (eLowerAngle g0) (maybe "" s (gLowerAngle g))
692 uUpperAngle g0 g = do
693   let s = prettyAngle
694   entrySetText (eUpperAngle g0) (maybe "" s (gUpperAngle g))
695 -}
696 uReal g0 g = uMantissaExponent (eRealM g0) (eRealE g0) (maybe "" show (gReal g))
697 uImag g0 g = uMantissaExponent (eImagM g0) (eImagE g0) (maybe "" show (gImag g))
698 uSize g0 g = uMantissaExponent (eSizeM g0) (eSizeE g0) (maybe "" show (gSize g))
699 uRota g0 g = entrySetText (eRota g0) (maybe "" show (gRota g))
700
701 uMantissaExponent :: (EntryClass a, EntryClass b) => a -> b -> String -> IO ()
702 uMantissaExponent m e s = do
703   let (ms, me) = break (== 'e') s
704   entrySetText m ms
705   entrySetText e (drop 1 me)
706
707 -- entry actions
708
709 type E = Gruff -> String -> Gruff
710
711 wrapE :: GruffGUI -> IORef Gruff -> E -> String -> IO ()
712 wrapE g0 gR e s = do
713   g <- readIORef gR
714   let g' = e g s
715   writeIORef gR $! g'
716   refreshGUI g0 g'
717
718 aAddress, {- aIsland, aChild, aLowerAngle, aUpperAngle, -} aReal, aImag, aSize, aRota :: E -- , aHueShift, aHueScale :: E
719 aAddress    g s = g{ gAddress    = parseAngledInternalAddress s }
720 {-
721 aIsland     g s = g{ gIsland     = parseAngledInternalAddress s }
722 aChild      g s = g{ gChild      = parseAngles s }
723 aLowerAngle g s = g{ gLowerAngle = parseAngle  s }
724 aUpperAngle g s = g{ gUpperAngle = parseAngle  s }
725 -}
726 aReal       g s = g{ gReal       = safeRead    s }
727 aImag       g s = g{ gImag       = safeRead    s }
728 aSize       g s = g{ gSize       = safeRead    s }
729 aRota       g s = g{ gRota       = safeRead    s }
730
731 aColours :: Color -> Color -> Color -> IORef Gruff -> IO ()
732 aColours i b e gR = atomicModifyIORef gR $ \g -> (g{ gColours = (i, b, e) }, ())
733
734 --aHueShift   g s = g{ gHueShift   = safeRead    s }
735 --aHueScale   g s = g{ gHueScale   = safeRead    s }
736
737 minSize :: Size
738 minSize = Size 160 100
739
740 converge :: NearZero n => [n] -> Maybe n
741 converge (x:y:zs)
742   | nearZero (x - y) = Just x
743   | otherwise = converge (y:zs)
744 converge [x] = Just x
745 converge _ = Nothing
746
747 red, black, white :: Color
748 red = Color 65535 0 0
749 black = Color 0 0 0
750 white = Color 65535 65535 65535
751
752 fromColor :: Color -> Colour
753 fromColor (Color r g b) = Colour (fromIntegral r / 65535) (fromIntegral g / 65535) (fromIntegral b / 65535)