rationalize gui; prune lots of now-dead code; drop support for old-format gruff files...
[ruff:gruff.git] / src / gruff.hs
1 module Main (main) where
2
3 import Prelude hiding (catch, log)
4 import Control.Concurrent (forkIO)
5 import Control.Monad (forM_)
6 import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef, writeIORef)
7 import Data.Maybe (mapMaybe)
8 import Graphics.UI.Gtk hiding (get, Region, Size, Window, Viewport)
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.Types.Complex (Complex((:+)), realPart, imagPart)
15
16 import Paths_gruff (getDataFileName)
17 import Number (R)
18 import Browser (Browser(..), browserNew, browserRenders)
19 import Progress (progressNew)
20 import Interact (mouseCallbacks)
21 import View
22   ( Image(..), Location(..), Viewport(..), Window(..)
23   , Colours(..), Colour(..), defImage, defLocation
24   )
25 import GLUTGtk (glut, Size(Size), postRedisplay)
26 import Logger (logger, LogLevel(Debug))
27 import qualified Logger as Log
28 import Utils (safeRead, catchIO)
29
30 exit :: (LogLevel -> String -> IO ()) -> FilePath -> Gruff -> IO ()
31 exit lg stateFile g = do
32   lg Debug "exitCallback"
33   aDoSave stateFile g
34   mainQuit
35
36 data GruffGUI = GruffGUI
37   -- buttons
38   { bHome
39   , bLoad
40   , bSave
41   , bStop
42   , bClear                  :: Button
43   -- entries
44   , eRealM, eRealE
45   , eImagM, eImagE
46   , eSizeM, eSizeE
47   , eRota
48   , eWidth
49   , eHeight
50   , eSamples                :: Entry
51   -- colour pickers
52   , cInterior
53   , cBorder
54   , cExterior               :: ColorButton
55   -- windows
56   , wMain
57   , wImage                  :: GTK.Window
58   }
59
60 main :: IO ()
61 main = do
62   -- contexts
63   _ <- initGUI
64   _ <- initGL
65   gl' <- glut minSize
66   -- directories
67   appDir <- getAppUserDataDirectory "gruff"
68   let cacheDir' = appDir </> "cache"
69       logDir    = appDir </> "log"
70       stateFile = appDir </> "state.gruff"
71   createDirectoryIfMissing False appDir
72   createDirectoryIfMissing False logDir
73   lg <- logger logDir
74   icon <- pixbufNewFromFile =<< getDataFileName "icon.png"
75   browser <- browserNew gl' icon lg cacheDir'
76   let iw = browserWindow browser
77   sg <- sizeGroupNew SizeGroupHorizontal
78
79   let spacing = 2
80
81       entryNewWithMnemonic m = entryNewWithMnemonic' m 30
82
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
94       entryNewExponent = do
95         e <- entryNew
96         entrySetWidthChars e 4
97         l <- labelNew (Just "e")
98         h <- hBoxNew False spacing
99         boxPackStart h l PackNatural 0
100         boxPackStart h e PackNatural 0
101         return (e, h)
102
103       frameNewWithContents box t r ws = do
104         f <- frameNew
105         frameSetLabel f t
106         frameSetLabelAlign f (if r then 1 else 0) 0.5
107         v <- box False spacing
108         forM_ ws $ boxPackStartDefaults v
109         set f [ containerChild := v ]
110         return f
111
112   b01@bHome'  <- buttonNewWithLabel "Home"
113   b02@bLoad'  <- buttonNewWithLabel "Load"
114   b03@bSave'  <- buttonNewWithLabel "Save"
115   b04@bStop'  <- buttonNewWithLabel "Stop"
116   b05@bClear' <- buttonNewWithLabel "Clear"
117
118   (eRealM', fc1m) <- entryNewWithMnemonic "_Real"
119   (eRealE', fc1e) <- entryNewExponent
120   (eImagM', fc2m) <- entryNewWithMnemonic "_Imag"
121   (eImagE', fc2e) <- entryNewExponent
122   (eSizeM', fc3m) <- entryNewWithMnemonic "Si_ze"
123   (eSizeE', fc3e) <- entryNewExponent
124   (eRota', fvR)    <- entryNewWithMnemonic' "R_otation" 15
125   (eWidth', fvW)   <- entryNewWithMnemonic' "_Width"     5
126   (eHeight', fvH)  <- entryNewWithMnemonic' "_Height"    5
127   (eSamples', fvS) <- entryNewWithMnemonic' "_Samples"   3
128
129   cInterior' <- colorButtonNewWithColor red
130   cBorder'   <- colorButtonNewWithColor black
131   cExterior' <- colorButtonNewWithColor white
132
133   labelColourR <- newIORef (fromColor blue)
134   cLabels'   <- colorButtonNewWithColor blue
135   _ <- cLabels' `onColorSet` (colorButtonGetColor cLabels' >>= writeIORef labelColourR . fromColor)
136
137   fb <- frameNewWithContents  vBoxNew "Actions" False [b01, b02, b03, b04, b05]
138   fh <- frameNewWithContents  hBoxNew "Colours" True [cInterior', cBorder', cExterior', cLabels']
139   fv <- frameNewWithContents  hBoxNew "Viewport" True [fvR, fvW, fvH, fvS]
140
141   let packMantissaExponent m e = do
142         h <- hBoxNew False spacing
143         boxPackStartDefaults h m
144         boxPackStart h e PackNatural 0
145         return h
146   fc1 <- packMantissaExponent fc1m fc1e
147   fc2 <- packMantissaExponent fc2m fc2e
148   fc3 <- packMantissaExponent fc3m fc3e
149   fc <- frameNewWithContents vBoxNew "Coordinates" True [fc1, fc2, fc3]
150   v <- vBoxNew False spacing
151   mapM_ (\w -> boxPackStart v w PackNatural 0) [fc, fv, {- fa, -} fh]
152   h <- hBoxNew False spacing
153   boxPackStart h fb PackNatural 0
154   boxPackStartDefaults h v
155
156   ww <- windowNew
157   set ww [ windowIcon := Just icon, windowTitle := "gruff control" ]
158
159   containerAdd ww h
160   mg <- aDoLoad stateFile
161   gR <- newIORef $ case mg of
162     Nothing -> initialGruff
163     Just g -> g
164
165   let g0 = GruffGUI
166             { bHome                 = bHome'
167             , bLoad                 = bLoad'
168             , bSave                 = bSave'
169             , bStop                 = bStop'
170             , bClear                = bClear'
171             , eRealM                = eRealM'
172             , eRealE                = eRealE'
173             , eImagM                = eImagM'
174             , eImagE                = eImagE'
175             , eSizeM                = eSizeM'
176             , eSizeE                = eSizeE'
177             , eRota                 = eRota'
178             , eWidth                = eWidth'
179             , eHeight               = eHeight'
180             , eSamples              = eSamples'
181             , cInterior             = cInterior'
182             , cBorder               = cBorder'
183             , cExterior             = cExterior'
184             , wMain                 = ww
185             , wImage                = iw
186             }
187       but b a = do
188         _ <- b g0 `onClicked` wrapA g0 gR a
189         return ()
190       butI b a = do
191         _ <- b g0 `onClicked` (wrapA g0 gR a >> upI)
192         return ()
193
194       butO b a = do
195         _ <- b g0 `onClicked` a
196         return ()
197
198       entI e a = do
199         _ <- e g0 `onEntryActivate` (entryGetText (e g0) >>= wrapE g0 gR a >> upI)
200         return ()
201
202       colI cbi cbb cbe a = forM_ [cbi, cbb, cbe] $ \c -> do
203         _ <- c g0 `onColorSet` (do
204           ci <- colorButtonGetColor (cbi g0)
205           cb <- colorButtonGetColor (cbb g0)
206           ce <- colorButtonGetColor (cbe g0)
207           _ <- a ci cb ce gR
208           upI)
209         return ()
210
211       entME m e a = do
212         let a' = do
213                   ms <- entryGetText (m g0)
214                   es <- entryGetText (e g0)
215                   let s = ms ++ if null es then "" else "e" ++ es
216                   wrapE g0 gR a s
217                   upI
218         _ <- m g0 `onEntryActivate` a'
219         _ <- e g0 `onEntryActivate` a'
220         return ()
221
222       upI :: IO ()
223       upI = do
224         g <- readIORef gR
225         browserRender browser g (return ()) (return ())
226         postRedisplay gl'
227
228       aUpdate :: Maybe View.Image -> IO ()
229       aUpdate Nothing = return ()
230       aUpdate (Just i) = do
231         writeIORef gR i
232         uReal g0 i
233         uImag g0 i
234         uSize g0 i
235         uRota g0 i
236         upI
237
238       aReshape :: Int -> Int -> IO ()
239       aReshape w' h' = do
240         atomicModifyIORef gR $ \g ->
241           ( g { imageWindow = (imageWindow g){ width = w', height = h' }
242               , imageViewport = (imageViewport g){ aspect = fromIntegral w' / fromIntegral h' }
243               }
244           , () )
245         g <- readIORef gR
246         uEverything g0 g
247         upI
248
249   butI bHome aHome
250   butI bLoad aLoad
251   but  bSave aSave
252   butO bStop (browserAbort browser)
253   butI bClear aClear
254
255   entME eRealM eRealE aReal
256   entME eImagM eImagE aImag
257   entME eSizeM eSizeE aSize
258   entI eRota aRota
259   entI eWidth aWidth
260   entI eHeight aHeight
261   entI eSamples aSamples
262   colI cInterior cBorder cExterior aColours
263   let aExit' = (exit (Log.log lg) stateFile =<< readIORef gR)
264   browserSetExitCallback browser aExit'
265
266   progress <- progressNew icon
267   let mcbs = mouseCallbacks (readIORef labelColourR) progress aUpdate
268   browserSetMouseCallback browser mcbs
269
270   browserSetReshapeCallback browser aReshape
271   _ <- ww `onDestroy` aExit'
272   g <- readIORef gR
273   uEverything g0 g
274   upI
275   refreshGUI g0 g
276   widgetShowAll iw
277   widgetShowAll ww
278   _ <- forkIO $ script browser
279   mainGUI
280
281 type Gruff = View.Image
282
283 initialGruff :: Gruff
284 initialGruff = defImage
285
286 -- button actions
287
288 type A = GruffGUI -> Gruff -> IO Gruff
289
290 wrapA :: GruffGUI -> IORef Gruff -> A -> IO ()
291 wrapA g0 gR a = do
292   g <- readIORef gR
293   g' <- a g0 g
294   writeIORef gR $! g'
295   refreshGUI g0 g'
296
297 aHome :: A
298 aHome g0 g = do
299   let g' = g{ imageLocation = defLocation, imageViewport = (imageViewport g){ orient = 0 } }
300   uEverything g0 g'
301   return g'
302
303 aClear :: A
304 aClear g0 g = do
305   let g' = g{ imageLabels = [], imageLines = [] }
306   uEverything g0 g'
307   return g'
308
309 aDoLoad :: FilePath -> IO (Maybe Gruff)
310 aDoLoad ff = (do
311     gr <- safeRead `fmap` readFile ff
312     case gr of
313       g@(Just _) -> return g
314       _ -> putStrLn "file format not supported, sorry" >> return Nothing
315   ) `catchIO` const (return Nothing)
316
317 aLoad :: A
318 aLoad g0 g = do
319   fc <- fileChooserDialogNew (Just "gruff load") (Just $ wMain g0) FileChooserActionOpen [("Load", ResponseAccept), ("Cancel", ResponseCancel)]
320   widgetShow fc
321   r <- dialogRun fc
322   g' <- case r of
323     ResponseAccept -> do
324       mf <- fileChooserGetFilename fc
325       case mf of
326         Nothing -> return g
327         Just f -> do
328           mg <- aDoLoad f
329           case mg of
330             Nothing -> return g
331             Just g' -> uEverything g0 g' >> return g'
332     _ -> return g
333   widgetDestroy fc
334   return g'
335
336 aDoSave :: FilePath -> Gruff -> IO ()
337 aDoSave f g = writeFile f (show g) `catchIO` const (return ())
338
339 aSave :: A
340 aSave g0 g = do
341   fc <- fileChooserDialogNew (Just "gruff save") (Just $ wMain g0) FileChooserActionSave [("Save", ResponseAccept), ("Cancel", ResponseCancel)]
342   widgetShow fc
343   r <- dialogRun fc
344   case r of
345     ResponseAccept -> do
346       mf <- fileChooserGetFilename fc
347       case mf of
348         Nothing -> return ()
349         Just f -> aDoSave f g
350     _ -> return ()
351   widgetDestroy fc
352   return g
353
354 -- entry update
355
356 type U = GruffGUI -> Gruff -> IO ()
357
358 uEverything, uReal, uImag, uSize, uRota, uColours, uWidth, uHeight, uSamples :: U
359 uEverything g0 g = forM_ [uReal, uImag, uSize, uRota, uColours, uWidth, uHeight, uSamples] $ \u -> u g0 g
360 uReal g0 g = uMantissaExponent (eRealM g0) (eRealE g0) (show . (fromRational :: Rational -> R) . realPart . center . imageLocation $ g)
361 uImag g0 g = uMantissaExponent (eImagM g0) (eImagE g0) (show . (fromRational :: Rational -> R) . imagPart . center . imageLocation $ g)
362 uSize g0 g = uMantissaExponent (eSizeM g0) (eSizeE g0) (show . radius . imageLocation $ g)
363 uRota g0 g = entrySetText (eRota g0) (show . orient . imageViewport $ g)
364 uColours g0 g = do
365   colorButtonSetColor (cInterior g0) (fromColour . colourInterior . imageColours $ g)
366   colorButtonSetColor (cBorder   g0) (fromColour . colourBoundary . imageColours $ g)
367   colorButtonSetColor (cExterior g0) (fromColour . colourExterior . imageColours $ g)
368 uWidth   g0 g = entrySetText (eWidth   g0) (show . width  . imageWindow $ g)
369 uHeight  g0 g = entrySetText (eHeight  g0) (show . height . imageWindow $ g)
370 uSamples g0 g = entrySetText (eSamples g0) (show . supersamples . imageWindow $ g)
371
372 uMantissaExponent :: (EntryClass a, EntryClass b) => a -> b -> String -> IO ()
373 uMantissaExponent m e s = do
374   let (ms, me) = break (== 'e') s
375   entrySetText m ms
376   entrySetText e (drop 1 me)
377
378 -- entry actions
379
380 type E = Gruff -> String -> Gruff
381
382 wrapE :: GruffGUI -> IORef Gruff -> E -> String -> IO ()
383 wrapE g0 gR e s = do
384   g <- readIORef gR
385   let g' = e g s
386   writeIORef gR $! g'
387   refreshGUI g0 g'
388
389 aReal, aImag, aSize, aRota, aWidth, aHeight, aSamples :: E
390 aReal    g s = let _ :+ i = center (imageLocation g) in case safeRead s :: Maybe R of
391   Nothing -> g
392   Just r -> g{ imageLocation = (imageLocation g){ center = toRational r :+ i } }
393 aImag    g s = let r :+ _ = center (imageLocation g) in case safeRead s :: Maybe R of
394   Nothing -> g
395   Just i -> g{ imageLocation = (imageLocation g){ center = r :+ toRational i } }
396 aSize    g s = case safeRead s :: Maybe Double of
397   Nothing -> g
398   Just r -> g{ imageLocation = (imageLocation g){ radius = r } }
399 aRota    g s =  case safeRead s :: Maybe Double of
400   Nothing -> g
401   Just a -> g{ imageViewport = (imageViewport g){ orient = a } }
402 aWidth   g s = case safeRead s of
403   Nothing -> g
404   Just r -> (\g' -> g'{ imageViewport = (imageViewport g'){ aspect = (fromIntegral . width . imageWindow) g' / (fromIntegral . height . imageWindow) g' } }) (g{ imageWindow  = (imageWindow g){ width  = r } })
405 aHeight  g s = case safeRead s of
406   Nothing -> g
407   Just r -> (\g' -> g'{ imageViewport = (imageViewport g'){ aspect = (fromIntegral . width . imageWindow) g' / (fromIntegral . height . imageWindow) g' } }) (g{ imageWindow  = (imageWindow g){ height = r } })
408 aSamples g s = case safeRead s of
409   Nothing -> g
410   Just r -> g{ imageWindow = (imageWindow g){ supersamples = r } }
411
412 aColours :: Color -> Color -> Color -> IORef Gruff -> IO ()
413 aColours i b e gR = atomicModifyIORef gR $ \g -> (g{ imageColours = Colours{ colourInterior = fromColor i, colourBoundary = fromColor b, colourExterior = fromColor e} }, ())
414
415 minSize :: Size
416 minSize = Size 160 100
417
418 red, black, white, blue :: Color
419 red = Color 65535 0 0
420 black = Color 0 0 0
421 white = Color 65535 65535 65535
422 blue = Color 0 0 65535
423
424 fromColor :: Color -> Colour
425 fromColor (Color r g b) = Colour (fromIntegral r / 65535) (fromIntegral g / 65535) (fromIntegral b / 65535)
426
427 fromColour :: Colour -> Color
428 fromColour (Colour r g b) = Color (round $ r * 65535) (round $ g * 65535) (round $ b * 65535)
429
430 script :: Browser -> IO ()
431 script b = do
432   c <- getContents
433   case mapMaybe readMay (lines c) of
434     [] -> return ()
435     images@(_:_) -> browserRenders b images
436
437 readMay :: Read a => String -> Maybe a
438 readMay s = case reads s of
439   [(a, "")] -> Just a
440   _ -> Nothing