don't use removed browserResize; fix warnings
[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.Types.Complex (Complex((:+)), realPart, imagPart)
17
18 import Paths_gruff (getDataFileName)
19 import Number (R)
20 import Browser (Browser(..), browserNew, browserRenders)
21 import MuAtom (MuAtom(..), MuProgress(..), muFromAddress, MuProgress'(..), muToAddress, MuProgress''(..), muLocate)
22 import View (Image(..), Location(..), Viewport(..), Window(..), Colours(..), Colour(..), defWindow, defViewport, defColours)
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           } (return ()) (return ())
248         postRedisplay gl'
249       aUpdate (re :+ im) z = do
250         atomicModifyIORef gR $ \g ->
251           ( g{ gReal = Just re, gImag = Just im, gSize = Just z }, () )
252         g <- readIORef gR
253         uReal g0 g
254         uImag g0 g
255         uSize g0 g
256         uRota g0 g
257         upI
258       aReshape w' h' = do
259         atomicModifyIORef gR $ \g ->
260           ( g { gWindow = (gWindow g){ width = w', height = h' }
261               , gViewport = (gViewport g){ aspect = fromIntegral w' / fromIntegral h' }
262               }
263           , () )
264         g <- readIORef gR
265         uEverything g0 g
266 --        upI
267   butI bHome aHome
268   butI bLoad aLoad
269   but  bSave aSave
270   butO bStop (browserAbort browser)
271   butJ bAddressToCoordinates aAddressToCoordinates
272   butJ bPeriodScan           (aPeriodScan False)
273   butJ bPeriodScanPlus       (aPeriodScan True)
274   ent  eAddress              aAddress
275   entME eRealM eRealE aReal
276   entME eImagM eImagE aImag
277   entME eSizeM eSizeE aSize
278   entI eRota aRota
279   entI eWidth aWidth
280   entI eHeight aHeight
281   entI eSamples aSamples
282 {-
283   entI' eWidth aWidth
284   entI' eHeight aHeight
285   entI' eSamples aSamples
286 -}
287   colI cInterior cBorder cExterior aColours
288   let aExit' = (exit (Log.log lg) stateFile =<< readIORef gR)
289   browserSetExitCallback browser aExit'
290   browserSetMouseCallback browser aUpdate
291   browserSetReshapeCallback browser aReshape
292   _ <- ww `onDestroy` aExit'
293   g <- readIORef gR
294   uEverything g0 g
295   upI
296   refreshGUI g0 g
297   widgetShowAll iw
298   widgetShowAll ww
299   _ <- forkIO $ script browser
300   mainGUI
301
302 data Gruff = Gruff
303   { gAddress    :: Maybe AngledInternalAddress
304   , gIsland     :: Maybe AngledInternalAddress
305   , gChild      :: Maybe [Angle]
306   , gLowerAngle :: Maybe Angle
307   , gUpperAngle :: Maybe Angle
308   , gReal       :: Maybe R
309   , gImag       :: Maybe R
310   , gSize       :: Maybe Double
311   } | Gruff2
312   { gAddress    :: Maybe AngledInternalAddress
313   , gReal       :: Maybe R
314   , gImag       :: Maybe R
315   , gSize       :: Maybe Double
316   , gRota       :: Maybe Double
317   , gColours    :: (Color, Color, Color)
318   , gWindow     :: Window
319   , gViewport   :: Viewport
320   }
321   deriving (Read, Show)
322 deriving instance Read Color
323
324 initialGruff :: Gruff
325 initialGruff = Gruff2
326   { gAddress    = parseAngledInternalAddress "1"
327   , gReal       = Just 0
328   , gImag       = Just 0
329   , gSize       = Just 1
330   , gRota       = Just 0
331   , gColours    = (red, black, white)
332   , gWindow     = defWindow
333   , gViewport   = defViewport
334   }
335
336 refreshGUI :: GruffGUI -> Gruff -> IO ()
337 refreshGUI g0 g = do
338   can bAddressToCoordinates $ j gAddress
339   can bPeriodScan           $ True
340   where
341     can w = widgetSetSensitive (w g0)
342     j a = isJust (a g)
343
344 -- button actions
345
346 type A = GruffGUI -> Gruff -> IO Gruff
347 type A' = GruffGUI -> Gruff -> (Gruff -> IO ()) -> IO ()
348
349 wrapA :: GruffGUI -> IORef Gruff -> A -> IO ()
350 wrapA g0 gR a = do
351   g <- readIORef gR
352   g' <- a g0 g
353   writeIORef gR $! g'
354   refreshGUI g0 g'
355
356 wrapA' :: GruffGUI -> IORef Gruff -> A' -> IO () -> IO ()
357 wrapA' g0 gR a upI = do
358   g <- readIORef gR
359   a g0 g $ \g' -> postGUISync $ do
360     writeIORef gR $! g'
361     upI
362     refreshGUI g0 g'
363
364 aHome :: A
365 aHome g0 g = do
366   let g' = initialGruff{ gColours = gColours g, gWindow = gWindow g, gViewport = gViewport g }
367   uEverything g0 g'
368   return g'
369
370 aDoLoad :: FilePath -> IO (Maybe Gruff)
371 aDoLoad ff = (do
372     gr <- safeRead `fmap` readFile ff
373     return $ case gr of
374       Just (Gruff a _ _ _ _ b c d) -> Just (Gruff2 a b c d (Just 0) (red, black, white) defWindow defViewport)
375       g -> g
376   ) `catchIO` const (return Nothing)
377
378 aLoad :: A
379 aLoad g0 g = do
380   fc <- fileChooserDialogNew (Just "gruff load") (Just $ wMain g0) FileChooserActionOpen [("Load", ResponseAccept), ("Cancel", ResponseCancel)]
381   widgetShow fc
382   r <- dialogRun fc
383   g' <- case r of
384     ResponseAccept -> do
385       mf <- fileChooserGetFilename fc
386       case mf of
387         Nothing -> return g
388         Just f -> do
389           mg <- aDoLoad f
390           case mg of
391             Nothing -> return g
392             Just g' -> uEverything g0 g' >> return g'
393     _ -> return g
394   widgetDestroy fc
395   return g'
396
397 aDoSave :: FilePath -> Gruff -> IO ()
398 aDoSave f g = writeFile f (show g) `catchIO` const (return ())
399
400 aSave :: A
401 aSave g0 g = do
402   fc <- fileChooserDialogNew (Just "gruff save") (Just $ wMain g0) FileChooserActionSave [("Save", ResponseAccept), ("Cancel", ResponseCancel)]
403   widgetShow fc
404   r <- dialogRun fc
405   case r of
406     ResponseAccept -> do
407       mf <- fileChooserGetFilename fc
408       case mf of
409         Nothing -> return ()
410         Just f -> aDoSave f g
411     _ -> return ()
412   widgetDestroy fc
413   return g
414
415 aPeriodScan :: Bool -> A'
416 aPeriodScan plus g0 g gn = do
417   statusDialog (dStatus g0) "gruff status" $ \progress -> case liftM3 (,,) (gReal g) (gImag g) (gSize g) of
418     Nothing -> progress "nothing to do" >> gn g
419     Just (re, im, r) -> do
420       forM_ (muLocate (re:+im) r) $ \mp -> case mp of
421         MuScanTodo       -> progress "Scanning for period..."
422         MuScan           -> progress "Scanning for period..."
423         MuScanDone p     -> progress$"Scanning for period... " ++ show p
424         MuNucleusTodo'   -> progress "Computing nucleus..."
425         MuNucleus' i     -> when (i `mod` 20 == 0) . progress$"Computing nucleus... " ++ show i
426         MuNucleusDone' _ -> progress "Computing nucleus... done"
427         MuBondTodo'      -> progress "Computing bond..."
428         MuBond' i        -> when (i `mod` 20 == 0) . progress$"Computing bond... " ++ show i
429         MuBondDone' _    -> progress "Computing bond... done"
430         MuSuccess'' mu -> do
431           let g' = g{ gReal = Just . realPart . muNucleus $ mu
432                     , gImag = Just . imagPart . muNucleus $ mu
433                     , gSize = Just . (* 4) . muSize $ mu
434                     , gRota = Just . subtract (pi/2) . muOrient $ mu
435                     }
436           progress "Found!"
437           postGUISync $ do
438             uReal g0 g'
439             uImag g0 g'
440             uSize g0 g'
441             uRota g0 g'
442           if plus
443             then
444               forM_ (muToAddress mu) $ \mp' -> case mp' of
445                 MuCuspTodo       -> progress "Computing cusp..."
446                 MuCuspDone _     -> progress "Computing cusp... done"
447                 MuDwellTodo      -> progress "Computing dwell..."
448                 MuDwell i        -> when (i `mod` 100 == 0) . progress$"Computing dwell... " ++ show i
449                 MuDwellDone _    -> progress "Computing dwell... done"
450                 MuRayOutTodo     -> progress "Tracing rays..."
451                 MuRayOut i       -> progress$"Tracing rays... " ++ show (round $ i * 100 :: Int) ++ "%"
452                 MuRayOutDone _   -> progress "Tracing rays... done"
453                 MuExternalTodo   -> progress "Computing angle..."
454                 MuExternalDone _ -> progress "Computing angle... done"
455                 MuAddressTodo    -> progress "Finding address..."
456                 MuSuccess' a     -> do
457                   let g'' = g'{ gAddress = Just a }
458                   progress "Complete!"
459                   postGUISync $ do
460                     uAddress g0 g''
461                   gn g''
462                 MuFailed'         -> progress "Failed!" >> gn g'
463             else
464               gn g'
465         MuFailed''       -> progress "Failed!" >> gn g
466
467 aAddressToCoordinates :: A'
468 aAddressToCoordinates g0 g gn = do
469   statusDialog (dStatus g0) "gruff status" $ \progress -> case gAddress g of
470     Nothing -> progress "nothing to do" >> gn g
471     Just addr -> do
472       forM_ (muFromAddress addr) $ \mp -> do
473         case mp of
474           MuSplitTodo      -> progress "Splitting address..."
475           MuSplitDone _ _  -> progress "Splitting address... done"
476           MuAnglesTodo     -> progress "Computing angles..."
477           MuAnglesDone _ _ -> progress "Computing angles... done"
478           MuRayTodo        -> progress "Tracing rays..."
479           MuRay n          -> when (n `mod` 20 == 0) . progress$"Tracing rays... " ++ show n
480           MuRayDone _      -> progress "Tracing rays... done"
481           MuNucleusTodo    -> progress "Computing nucleus..."
482           MuNucleus n      -> when (n `mod` 20 == 0) . progress$"Computing nucleus... " ++ show n
483           MuNucleusDone _  -> progress "Computing nucleus... done"
484           MuBondTodo       -> progress "Computing bond..."
485           MuBond n         -> when (n `mod` 20 == 0) . progress$"Computing bond... " ++ show n
486           MuBondDone _     -> progress "Computing bond... done"
487           MuSuccess mu     -> do
488             let g' = g{ gReal = Just . realPart . muNucleus $ mu
489                       , gImag = Just . imagPart . muNucleus $ mu
490                       , gSize = Just . (* 4) . muSize $ mu
491                       , gRota = Just . subtract (pi/2) . muOrient $ mu
492                       }
493             progress "Done!"
494             postGUISync $ do
495               uReal g0 g'
496               uImag g0 g'
497               uSize g0 g'
498               uRota g0 g'
499             gn g'
500           MuFailed         -> progress "Failed!" >> gn g
501
502 -- entry update
503
504 type U = GruffGUI -> Gruff -> IO ()
505
506 uEverything, uAddress, uReal, uImag, uSize, uRota, uColours, uWidth, uHeight, uSamples :: U
507 uEverything g0 g = forM_ [uAddress, uReal, uImag, uSize, uRota, uColours, uWidth, uHeight, uSamples] $ \u -> u g0 g
508 uAddress g0 g = entrySetText (eAddress g0) (maybe "" prettyAngledInternalAddress (gAddress g))
509 uReal g0 g = uMantissaExponent (eRealM g0) (eRealE g0) (maybe "" show (gReal g))
510 uImag g0 g = uMantissaExponent (eImagM g0) (eImagE g0) (maybe "" show (gImag g))
511 uSize g0 g = uMantissaExponent (eSizeM g0) (eSizeE g0) (maybe "" show (gSize g))
512 uRota g0 g = entrySetText (eRota g0) (maybe "" show (gRota g))
513 uColours g0 g = do
514   let (ci, cb, ce) = gColours g
515   colorButtonSetColor (cInterior g0) ci
516   colorButtonSetColor (cBorder   g0) cb
517   colorButtonSetColor (cExterior g0) ce
518 uWidth   g0 g = entrySetText (eWidth   g0) (show . width . gWindow $ g)
519 uHeight  g0 g = entrySetText (eHeight  g0) (show . height . gWindow $ g)
520 uSamples g0 g = entrySetText (eSamples g0) (show . supersamples . gWindow $ g)
521
522 uMantissaExponent :: (EntryClass a, EntryClass b) => a -> b -> String -> IO ()
523 uMantissaExponent m e s = do
524   let (ms, me) = break (== 'e') s
525   entrySetText m ms
526   entrySetText e (drop 1 me)
527
528 -- entry actions
529
530 type E = Gruff -> String -> Gruff
531
532 wrapE :: GruffGUI -> IORef Gruff -> E -> String -> IO ()
533 wrapE g0 gR e s = do
534   g <- readIORef gR
535   let g' = e g s
536   writeIORef gR $! g'
537   refreshGUI g0 g'
538
539 aAddress, aReal, aImag, aSize, aRota, aWidth, aHeight, aSamples :: E
540 aAddress g s = g{ gAddress = parseAngledInternalAddress s }
541 aReal    g s = g{ gReal    = safeRead s }
542 aImag    g s = g{ gImag    = safeRead s }
543 aSize    g s = g{ gSize    = safeRead s }
544 aRota    g s = g{ gRota    = safeRead s }
545 aWidth   g s = case safeRead s of
546   Nothing -> g
547   Just r -> g{ gWindow  = (gWindow g){ width = r } }
548 aHeight  g s = case safeRead s of
549   Nothing -> g
550   Just r -> g{ gWindow  = (gWindow g){ height = r } }
551 aSamples g s = case safeRead s of
552   Nothing -> g
553   Just r -> g{ gWindow  = (gWindow g){ supersamples = r } }
554
555 aColours :: Color -> Color -> Color -> IORef Gruff -> IO ()
556 aColours i b e gR = atomicModifyIORef gR $ \g -> (g{ gColours = (i, b, e) }, ())
557
558 minSize :: Size
559 minSize = Size 160 100
560
561 red, black, white :: Color
562 red = Color 65535 0 0
563 black = Color 0 0 0
564 white = Color 65535 65535 65535
565
566 fromColor :: Color -> Colour
567 fromColor (Color r g b) = Colour (fromIntegral r / 65535) (fromIntegral g / 65535) (fromIntegral b / 65535)
568
569 {-
570 strings :: [String]
571 strings =  [ "1 1/3 " ++ (unwords . map show . scanl (+) 3) (replicate m 1 ++ replicate (n - m) 2) | m <- [0 .. n - 1] ]
572         ++ [ "1 1/3 " ++ (unwords . map show . scanl (+) 3) (replicate m 2 ++ replicate (n - m) 1) | m <- [0 .. n - 1] ]
573   where n = 21 -- 15
574 -}
575
576 filename :: String -> Int -> String
577 filename s n = (reverse . take 4 . (++ "0000") . reverse . show) n ++ "__" ++ map filechar s ++ ".ppm"
578   where filechar ' ' = '_'
579         filechar '/' = '-'
580         filechar  c  =  c
581
582 findMu :: AngledInternalAddress -> Maybe MuAtom
583 findMu a = case last (muFromAddress a) of
584   MuSuccess m -> Just m
585   _ -> Nothing
586
587 scene :: (String, Int) -> Maybe (View.Image, String)
588 scene (s, n) = do
589   a <- parseAngledInternalAddress s
590   m <- findMu a
591   let cx :+ cy = muNucleus m
592       f = filename s n
593       i = Image
594             { imageLocation = Location{ center = toRational cx :+ toRational cy, radius = muSize m * 8 } -- 6
595             , imageViewport = viewportDVD{ orient = muOrient m - pi / 2 }
596             , imageWindow = windowDVD
597             , imageColours = defColours
598             }
599   return (i, f)
600
601 windowDVD :: View.Window
602 windowDVD = Window{ width = 1080, height = 576, supersamples = 2 }
603
604 viewportDVD :: View.Viewport
605 viewportDVD = Viewport{ aspect = 1080/576, orient = 0 }
606
607 images :: [(View.Image, String)]
608 images = mapMaybe scene (score `zip` [0..])
609
610 script :: Browser -> IO ()
611 script b = browserRenders b images
612
613 kick, snare :: Int -> [String]
614 kick n = [ "1 2 " ++ (unwords . map show . take m . scanl (+) (3 :: Int) . repeat) 1 | m <- [n, n - 1 .. 1] ]
615 snare n = [ "1 2 " ++ (unwords . map show . take (2 * m) . filter (\x -> x `mod` 3 /= 0)) [(3 :: Int) ..] | m <- [n, n - 1 .. 1] ]
616
617 score :: [String]
618 score = concat
619   [ kick 21
620   , snare 32
621   , kick 20
622   , snare 11
623   , kick 8
624   , kick 8
625   , kick 5
626   , snare 32
627   , kick 20
628   , snare 11
629   ]