fix compilation
[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   widgetShowAll iw
276   widgetShowAll ww
277   _ <- forkIO $ script browser
278   mainGUI
279
280 type Gruff = View.Image
281
282 initialGruff :: Gruff
283 initialGruff = defImage
284
285 -- button actions
286
287 type A = GruffGUI -> Gruff -> IO Gruff
288
289 wrapA :: GruffGUI -> IORef Gruff -> A -> IO ()
290 wrapA g0 gR a = do
291   g <- readIORef gR
292   g' <- a g0 g
293   writeIORef gR $! g'
294
295 aHome :: A
296 aHome g0 g = do
297   let g' = g{ imageLocation = defLocation, imageViewport = (imageViewport g){ orient = 0 } }
298   uEverything g0 g'
299   return g'
300
301 aClear :: A
302 aClear g0 g = do
303   let g' = g{ imageLabels = [], imageLines = [] }
304   uEverything g0 g'
305   return g'
306
307 aDoLoad :: FilePath -> IO (Maybe Gruff)
308 aDoLoad ff = (do
309     gr <- safeRead `fmap` readFile ff
310     case gr of
311       g@(Just _) -> return g
312       _ -> putStrLn "file format not supported, sorry" >> return Nothing
313   ) `catchIO` const (return Nothing)
314
315 aLoad :: A
316 aLoad g0 g = do
317   fc <- fileChooserDialogNew (Just "gruff load") (Just $ wMain g0) FileChooserActionOpen [("Load", ResponseAccept), ("Cancel", ResponseCancel)]
318   widgetShow fc
319   r <- dialogRun fc
320   g' <- case r of
321     ResponseAccept -> do
322       mf <- fileChooserGetFilename fc
323       case mf of
324         Nothing -> return g
325         Just f -> do
326           mg <- aDoLoad f
327           case mg of
328             Nothing -> return g
329             Just g' -> uEverything g0 g' >> return g'
330     _ -> return g
331   widgetDestroy fc
332   return g'
333
334 aDoSave :: FilePath -> Gruff -> IO ()
335 aDoSave f g = writeFile f (show g) `catchIO` const (return ())
336
337 aSave :: A
338 aSave g0 g = do
339   fc <- fileChooserDialogNew (Just "gruff save") (Just $ wMain g0) FileChooserActionSave [("Save", ResponseAccept), ("Cancel", ResponseCancel)]
340   widgetShow fc
341   r <- dialogRun fc
342   case r of
343     ResponseAccept -> do
344       mf <- fileChooserGetFilename fc
345       case mf of
346         Nothing -> return ()
347         Just f -> aDoSave f g
348     _ -> return ()
349   widgetDestroy fc
350   return g
351
352 -- entry update
353
354 type U = GruffGUI -> Gruff -> IO ()
355
356 uEverything, uReal, uImag, uSize, uRota, uColours, uWidth, uHeight, uSamples :: U
357 uEverything g0 g = forM_ [uReal, uImag, uSize, uRota, uColours, uWidth, uHeight, uSamples] $ \u -> u g0 g
358 uReal g0 g = uMantissaExponent (eRealM g0) (eRealE g0) (show . (fromRational :: Rational -> R) . realPart . center . imageLocation $ g)
359 uImag g0 g = uMantissaExponent (eImagM g0) (eImagE g0) (show . (fromRational :: Rational -> R) . imagPart . center . imageLocation $ g)
360 uSize g0 g = uMantissaExponent (eSizeM g0) (eSizeE g0) (show . radius . imageLocation $ g)
361 uRota g0 g = entrySetText (eRota g0) (show . orient . imageViewport $ g)
362 uColours g0 g = do
363   colorButtonSetColor (cInterior g0) (fromColour . colourInterior . imageColours $ g)
364   colorButtonSetColor (cBorder   g0) (fromColour . colourBoundary . imageColours $ g)
365   colorButtonSetColor (cExterior g0) (fromColour . colourExterior . imageColours $ g)
366 uWidth   g0 g = entrySetText (eWidth   g0) (show . width  . imageWindow $ g)
367 uHeight  g0 g = entrySetText (eHeight  g0) (show . height . imageWindow $ g)
368 uSamples g0 g = entrySetText (eSamples g0) (show . supersamples . imageWindow $ g)
369
370 uMantissaExponent :: (EntryClass a, EntryClass b) => a -> b -> String -> IO ()
371 uMantissaExponent m e s = do
372   let (ms, me) = break (== 'e') s
373   entrySetText m ms
374   entrySetText e (drop 1 me)
375
376 -- entry actions
377
378 type E = Gruff -> String -> Gruff
379
380 wrapE :: GruffGUI -> IORef Gruff -> E -> String -> IO ()
381 wrapE _g0 gR e s = do
382   g <- readIORef gR
383   let g' = e g s
384   writeIORef gR $! g'
385
386 aReal, aImag, aSize, aRota, aWidth, aHeight, aSamples :: E
387 aReal    g s = let _ :+ i = center (imageLocation g) in case safeRead s :: Maybe R of
388   Nothing -> g
389   Just r -> g{ imageLocation = (imageLocation g){ center = toRational r :+ i } }
390 aImag    g s = let r :+ _ = center (imageLocation g) in case safeRead s :: Maybe R of
391   Nothing -> g
392   Just i -> g{ imageLocation = (imageLocation g){ center = r :+ toRational i } }
393 aSize    g s = case safeRead s :: Maybe Double of
394   Nothing -> g
395   Just r -> g{ imageLocation = (imageLocation g){ radius = r } }
396 aRota    g s =  case safeRead s :: Maybe Double of
397   Nothing -> g
398   Just a -> g{ imageViewport = (imageViewport g){ orient = a } }
399 aWidth   g s = case safeRead s of
400   Nothing -> g
401   Just r -> (\g' -> g'{ imageViewport = (imageViewport g'){ aspect = (fromIntegral . width . imageWindow) g' / (fromIntegral . height . imageWindow) g' } }) (g{ imageWindow  = (imageWindow g){ width  = r } })
402 aHeight  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){ height = r } })
405 aSamples g s = case safeRead s of
406   Nothing -> g
407   Just r -> g{ imageWindow = (imageWindow g){ supersamples = r } }
408
409 aColours :: Color -> Color -> Color -> IORef Gruff -> IO ()
410 aColours i b e gR = atomicModifyIORef gR $ \g -> (g{ imageColours = Colours{ colourInterior = fromColor i, colourBoundary = fromColor b, colourExterior = fromColor e} }, ())
411
412 minSize :: Size
413 minSize = Size 160 100
414
415 red, black, white, blue :: Color
416 red = Color 65535 0 0
417 black = Color 0 0 0
418 white = Color 65535 65535 65535
419 blue = Color 0 0 65535
420
421 fromColor :: Color -> Colour
422 fromColor (Color r g b) = Colour (fromIntegral r / 65535) (fromIntegral g / 65535) (fromIntegral b / 65535)
423
424 fromColour :: Colour -> Color
425 fromColour (Colour r g b) = Color (round $ r * 65535) (round $ g * 65535) (round $ b * 65535)
426
427 script :: Browser -> IO ()
428 script b = do
429   c <- getContents
430   case mapMaybe readMay (lines c) of
431     [] -> return ()
432     images@(_:_) -> browserRenders b images
433
434 readMay :: Read a => String -> Maybe a
435 readMay s = case reads s of
436   [(a, "")] -> Just a
437   _ -> Nothing