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