gruff-0.3: src/gruff.hs

module Main (main) where

import Prelude hiding (catch, log)
import Control.Concurrent (forkIO)
import Control.Monad (forM_)
import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef, writeIORef)
import Data.Maybe (mapMaybe)
import Graphics.UI.Gtk hiding (get, Region, Size, Window, Viewport)
import qualified Graphics.UI.Gtk as GTK
import Graphics.UI.Gtk.OpenGL (initGL)
import System.Directory (getAppUserDataDirectory, createDirectoryIfMissing)
import System.FilePath ((</>))

import Fractal.RUFF.Types.Complex (Complex((:+)), realPart, imagPart)

import Paths_gruff (getDataFileName)
import Number (R)
import Browser (Browser(..), browserNew, browserRenders)
import Progress (progressNew)
import Interact (mouseCallbacks)
import View
  ( Image(..), Location(..), Viewport(..), Window(..)
  , Colours(..), Colour(..), defImage, defLocation
  )
import GLUTGtk (glut, Size(Size), postRedisplay)
import Logger (logger, LogLevel(Debug))
import qualified Logger as Log
import Utils (safeRead, catchIO)

exit :: (LogLevel -> String -> IO ()) -> FilePath -> Gruff -> IO ()
exit lg stateFile g = do
  lg Debug "exitCallback"
  aDoSave stateFile g
  mainQuit

data GruffGUI = GruffGUI
  -- buttons
  { bHome
  , bLoad
  , bSave
  , bStop
  , bClear                  :: Button
  -- entries
  , eRealM, eRealE
  , eImagM, eImagE
  , eSizeM, eSizeE
  , eRota
  , eWidth
  , eHeight
  , eSamples                :: Entry
  -- colour pickers
  , cInterior
  , cBorder
  , cExterior               :: ColorButton
  -- windows
  , wMain
  , wImage                  :: GTK.Window
  }

main :: IO ()
main = do
  -- contexts
  _ <- initGUI
  _ <- initGL
  gl' <- glut minSize
  -- directories
  appDir <- getAppUserDataDirectory "gruff"
  let cacheDir' = appDir </> "cache"
      logDir    = appDir </> "log"
      stateFile = appDir </> "state.gruff"
  createDirectoryIfMissing False appDir
  createDirectoryIfMissing False logDir
  lg <- logger logDir
  icon <- pixbufNewFromFile =<< getDataFileName "icon.png"
  browser <- browserNew gl' icon lg cacheDir'
  let iw = browserWindow browser
  sg <- sizeGroupNew SizeGroupHorizontal

  let spacing = 2

      entryNewWithMnemonic m = entryNewWithMnemonic' m 30

      entryNewWithMnemonic' m wc = do
        e <- entryNew
        entrySetWidthChars e wc
        l <- labelNewWithMnemonic m
        labelSetMnemonicWidget l e
        sizeGroupAddWidget sg l
        h <- hBoxNew False spacing
        boxPackStart h l PackNatural 0
        boxPackStartDefaults h e
        return (e, h)

      entryNewExponent = do
        e <- entryNew
        entrySetWidthChars e 4
        l <- labelNew (Just "e")
        h <- hBoxNew False spacing
        boxPackStart h l PackNatural 0
        boxPackStart h e PackNatural 0
        return (e, h)

      frameNewWithContents box t r ws = do
        f <- frameNew
        frameSetLabel f t
        frameSetLabelAlign f (if r then 1 else 0) 0.5
        v <- box False spacing
        forM_ ws $ boxPackStartDefaults v
        set f [ containerChild := v ]
        return f

  b01@bHome'  <- buttonNewWithLabel "Home"
  b02@bLoad'  <- buttonNewWithLabel "Load"
  b03@bSave'  <- buttonNewWithLabel "Save"
  b04@bStop'  <- buttonNewWithLabel "Stop"
  b05@bClear' <- buttonNewWithLabel "Clear"

  (eRealM', fc1m) <- entryNewWithMnemonic "_Real"
  (eRealE', fc1e) <- entryNewExponent
  (eImagM', fc2m) <- entryNewWithMnemonic "_Imag"
  (eImagE', fc2e) <- entryNewExponent
  (eSizeM', fc3m) <- entryNewWithMnemonic "Si_ze"
  (eSizeE', fc3e) <- entryNewExponent
  (eRota', fvR)    <- entryNewWithMnemonic' "R_otation" 15
  (eWidth', fvW)   <- entryNewWithMnemonic' "_Width"     5
  (eHeight', fvH)  <- entryNewWithMnemonic' "_Height"    5
  (eSamples', fvS) <- entryNewWithMnemonic' "_Samples"   3

  cInterior' <- colorButtonNewWithColor red
  cBorder'   <- colorButtonNewWithColor black
  cExterior' <- colorButtonNewWithColor white

  labelColourR <- newIORef (fromColor blue)
  cLabels'   <- colorButtonNewWithColor blue
  _ <- cLabels' `onColorSet` (colorButtonGetColor cLabels' >>= writeIORef labelColourR . fromColor)

  fb <- frameNewWithContents  vBoxNew "Actions" False [b01, b02, b03, b04, b05]
  fh <- frameNewWithContents  hBoxNew "Colours" True [cInterior', cBorder', cExterior', cLabels']
  fv <- frameNewWithContents  hBoxNew "Viewport" True [fvR, fvW, fvH, fvS]

  let packMantissaExponent m e = do
        h <- hBoxNew False spacing
        boxPackStartDefaults h m
        boxPackStart h e PackNatural 0
        return h
  fc1 <- packMantissaExponent fc1m fc1e
  fc2 <- packMantissaExponent fc2m fc2e
  fc3 <- packMantissaExponent fc3m fc3e
  fc <- frameNewWithContents vBoxNew "Coordinates" True [fc1, fc2, fc3]
  v <- vBoxNew False spacing
  mapM_ (\w -> boxPackStart v w PackNatural 0) [fc, fv, {- fa, -} fh]
  h <- hBoxNew False spacing
  boxPackStart h fb PackNatural 0
  boxPackStartDefaults h v

  ww <- windowNew
  set ww [ windowIcon := Just icon, windowTitle := "gruff control" ]

  containerAdd ww h
  mg <- aDoLoad stateFile
  gR <- newIORef $ case mg of
    Nothing -> initialGruff
    Just g -> g

  let g0 = GruffGUI
            { bHome                 = bHome'
            , bLoad                 = bLoad'
            , bSave                 = bSave'
            , bStop                 = bStop'
            , bClear                = bClear'
            , eRealM                = eRealM'
            , eRealE                = eRealE'
            , eImagM                = eImagM'
            , eImagE                = eImagE'
            , eSizeM                = eSizeM'
            , eSizeE                = eSizeE'
            , eRota                 = eRota'
            , eWidth                = eWidth'
            , eHeight               = eHeight'
            , eSamples              = eSamples'
            , cInterior             = cInterior'
            , cBorder               = cBorder'
            , cExterior             = cExterior'
            , wMain                 = ww
            , wImage                = iw
            }
      but b a = do
        _ <- b g0 `onClicked` wrapA g0 gR a
        return ()
      butI b a = do
        _ <- b g0 `onClicked` (wrapA g0 gR a >> upI)
        return ()

      butO b a = do
        _ <- b g0 `onClicked` a
        return ()

      entI e a = do
        _ <- e g0 `onEntryActivate` (entryGetText (e g0) >>= wrapE g0 gR a >> upI)
        return ()

      colI cbi cbb cbe a = forM_ [cbi, cbb, cbe] $ \c -> do
        _ <- c g0 `onColorSet` (do
          ci <- colorButtonGetColor (cbi g0)
          cb <- colorButtonGetColor (cbb g0)
          ce <- colorButtonGetColor (cbe g0)
          _ <- a ci cb ce gR
          upI)
        return ()

      entME m e a = do
        let a' = do
                  ms <- entryGetText (m g0)
                  es <- entryGetText (e g0)
                  let s = ms ++ if null es then "" else "e" ++ es
                  wrapE g0 gR a s
                  upI
        _ <- m g0 `onEntryActivate` a'
        _ <- e g0 `onEntryActivate` a'
        return ()

      upI :: IO ()
      upI = do
        g <- readIORef gR
        browserRender browser g (return ()) (return ())
        postRedisplay gl'

      aUpdate :: Maybe View.Image -> IO ()
      aUpdate Nothing = return ()
      aUpdate (Just i) = do
        writeIORef gR i
        uReal g0 i
        uImag g0 i
        uSize g0 i
        uRota g0 i
        upI

      aReshape :: Int -> Int -> IO ()
      aReshape w' h' = do
        atomicModifyIORef gR $ \g ->
          ( g { imageWindow = (imageWindow g){ width = w', height = h' }
              , imageViewport = (imageViewport g){ aspect = fromIntegral w' / fromIntegral h' }
              }
          , () )
        g <- readIORef gR
        uEverything g0 g
        upI

  butI bHome aHome
  butI bLoad aLoad
  but  bSave aSave
  butO bStop (browserAbort browser)
  butI bClear aClear

  entME eRealM eRealE aReal
  entME eImagM eImagE aImag
  entME eSizeM eSizeE aSize
  entI eRota aRota
  entI eWidth aWidth
  entI eHeight aHeight
  entI eSamples aSamples
  colI cInterior cBorder cExterior aColours
  let aExit' = (exit (Log.log lg) stateFile =<< readIORef gR)
  browserSetExitCallback browser aExit'

  progress <- progressNew icon
  let mcbs = mouseCallbacks (readIORef labelColourR) progress aUpdate
  browserSetMouseCallback browser mcbs

  browserSetReshapeCallback browser aReshape
  _ <- ww `onDestroy` aExit'
  g <- readIORef gR
  uEverything g0 g
  upI
  widgetShowAll iw
  widgetShowAll ww
  _ <- forkIO $ script browser
  mainGUI

type Gruff = View.Image

initialGruff :: Gruff
initialGruff = defImage

-- button actions

type A = GruffGUI -> Gruff -> IO Gruff

wrapA :: GruffGUI -> IORef Gruff -> A -> IO ()
wrapA g0 gR a = do
  g <- readIORef gR
  g' <- a g0 g
  writeIORef gR $! g'

aHome :: A
aHome g0 g = do
  let g' = g{ imageLocation = defLocation, imageViewport = (imageViewport g){ orient = 0 } }
  uEverything g0 g'
  return g'

aClear :: A
aClear g0 g = do
  let g' = g{ imageLabels = [], imageLines = [] }
  uEverything g0 g'
  return g'

aDoLoad :: FilePath -> IO (Maybe Gruff)
aDoLoad ff = (do
    gr <- safeRead `fmap` readFile ff
    case gr of
      g@(Just _) -> return g
      _ -> putStrLn "file format not supported, sorry" >> return Nothing
  ) `catchIO` const (return Nothing)

aLoad :: A
aLoad g0 g = do
  fc <- fileChooserDialogNew (Just "gruff load") (Just $ wMain g0) FileChooserActionOpen [("Load", ResponseAccept), ("Cancel", ResponseCancel)]
  widgetShow fc
  r <- dialogRun fc
  g' <- case r of
    ResponseAccept -> do
      mf <- fileChooserGetFilename fc
      case mf of
        Nothing -> return g
        Just f -> do
          mg <- aDoLoad f
          case mg of
            Nothing -> return g
            Just g' -> uEverything g0 g' >> return g'
    _ -> return g
  widgetDestroy fc
  return g'

aDoSave :: FilePath -> Gruff -> IO ()
aDoSave f g = writeFile f (show g) `catchIO` const (return ())

aSave :: A
aSave g0 g = do
  fc <- fileChooserDialogNew (Just "gruff save") (Just $ wMain g0) FileChooserActionSave [("Save", ResponseAccept), ("Cancel", ResponseCancel)]
  widgetShow fc
  r <- dialogRun fc
  case r of
    ResponseAccept -> do
      mf <- fileChooserGetFilename fc
      case mf of
        Nothing -> return ()
        Just f -> aDoSave f g
    _ -> return ()
  widgetDestroy fc
  return g

-- entry update

type U = GruffGUI -> Gruff -> IO ()

uEverything, uReal, uImag, uSize, uRota, uColours, uWidth, uHeight, uSamples :: U
uEverything g0 g = forM_ [uReal, uImag, uSize, uRota, uColours, uWidth, uHeight, uSamples] $ \u -> u g0 g
uReal g0 g = uMantissaExponent (eRealM g0) (eRealE g0) (show . (fromRational :: Rational -> R) . realPart . center . imageLocation $ g)
uImag g0 g = uMantissaExponent (eImagM g0) (eImagE g0) (show . (fromRational :: Rational -> R) . imagPart . center . imageLocation $ g)
uSize g0 g = uMantissaExponent (eSizeM g0) (eSizeE g0) (show . radius . imageLocation $ g)
uRota g0 g = entrySetText (eRota g0) (show . orient . imageViewport $ g)
uColours g0 g = do
  colorButtonSetColor (cInterior g0) (fromColour . colourInterior . imageColours $ g)
  colorButtonSetColor (cBorder   g0) (fromColour . colourBoundary . imageColours $ g)
  colorButtonSetColor (cExterior g0) (fromColour . colourExterior . imageColours $ g)
uWidth   g0 g = entrySetText (eWidth   g0) (show . width  . imageWindow $ g)
uHeight  g0 g = entrySetText (eHeight  g0) (show . height . imageWindow $ g)
uSamples g0 g = entrySetText (eSamples g0) (show . supersamples . imageWindow $ g)

uMantissaExponent :: (EntryClass a, EntryClass b) => a -> b -> String -> IO ()
uMantissaExponent m e s = do
  let (ms, me) = break (== 'e') s
  entrySetText m ms
  entrySetText e (drop 1 me)

-- entry actions

type E = Gruff -> String -> Gruff

wrapE :: GruffGUI -> IORef Gruff -> E -> String -> IO ()
wrapE _g0 gR e s = do
  g <- readIORef gR
  let g' = e g s
  writeIORef gR $! g'

aReal, aImag, aSize, aRota, aWidth, aHeight, aSamples :: E
aReal    g s = let _ :+ i = center (imageLocation g) in case safeRead s :: Maybe R of
  Nothing -> g
  Just r -> g{ imageLocation = (imageLocation g){ center = toRational r :+ i } }
aImag    g s = let r :+ _ = center (imageLocation g) in case safeRead s :: Maybe R of
  Nothing -> g
  Just i -> g{ imageLocation = (imageLocation g){ center = r :+ toRational i } }
aSize    g s = case safeRead s :: Maybe Double of
  Nothing -> g
  Just r -> g{ imageLocation = (imageLocation g){ radius = r } }
aRota    g s =  case safeRead s :: Maybe Double of
  Nothing -> g
  Just a -> g{ imageViewport = (imageViewport g){ orient = a } }
aWidth   g s = case safeRead s of
  Nothing -> g
  Just r -> (\g' -> g'{ imageViewport = (imageViewport g'){ aspect = (fromIntegral . width . imageWindow) g' / (fromIntegral . height . imageWindow) g' } }) (g{ imageWindow  = (imageWindow g){ width  = r } })
aHeight  g s = case safeRead s of
  Nothing -> g
  Just r -> (\g' -> g'{ imageViewport = (imageViewport g'){ aspect = (fromIntegral . width . imageWindow) g' / (fromIntegral . height . imageWindow) g' } }) (g{ imageWindow  = (imageWindow g){ height = r } })
aSamples g s = case safeRead s of
  Nothing -> g
  Just r -> g{ imageWindow = (imageWindow g){ supersamples = r } }

aColours :: Color -> Color -> Color -> IORef Gruff -> IO ()
aColours i b e gR = atomicModifyIORef gR $ \g -> (g{ imageColours = Colours{ colourInterior = fromColor i, colourBoundary = fromColor b, colourExterior = fromColor e} }, ())

minSize :: Size
minSize = Size 160 100

red, black, white, blue :: Color
red = Color 65535 0 0
black = Color 0 0 0
white = Color 65535 65535 65535
blue = Color 0 0 65535

fromColor :: Color -> Colour
fromColor (Color r g b) = Colour (fromIntegral r / 65535) (fromIntegral g / 65535) (fromIntegral b / 65535)

fromColour :: Colour -> Color
fromColour (Colour r g b) = Color (round $ r * 65535) (round $ g * 65535) (round $ b * 65535)

script :: Browser -> IO ()
script b = do
  c <- getContents
  case mapMaybe readMay (lines c) of
    [] -> return ()
    images@(_:_) -> browserRenders b images

readMay :: Read a => String -> Maybe a
readMay s = case reads s of
  [(a, "")] -> Just a
  _ -> Nothing