{-# LANGUAGE StandaloneDeriving #-}
module Main (main) where

import Prelude hiding (catch, log)
import Control.Monad (forM_, liftM3, when)
import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef, writeIORef)
import Data.Maybe (isJust, fromMaybe)
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.Mandelbrot.Address (AngledInternalAddress, Angle, parseAngledInternalAddress, prettyAngledInternalAddress)
import Fractal.RUFF.Types.Complex (Complex((:+)), realPart, imagPart)

import Paths_gruff (getDataFileName)
import Number (R)
import Browser (Browser(..), browserNew)
import MuAtom (MuAtom(..), MuProgress(..), muFromAddress, MuProgress'(..), muToAddress, MuProgress''(..), muLocate)
import View (Image(..), Location(..), Viewport(..), Window(..), Colours(..), Colour(..), defWindow, defViewport)
import GLUTGtk (glut, Size(Size), postRedisplay)
import Logger (logger, LogLevel(Debug))
import qualified Logger as Log
import StatusDialog (StatusDialog, statusDialog, statusDialogNew)
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
  { dStatus                 :: StatusDialog
  -- buttons
  , bHome
  , bLoad
  , bSave
  , bStop
  , bAddressToCoordinates
  , bPeriodScan
  , bPeriodScanPlus         :: Button
  -- entries
  , eAddress
  , 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
      frameNewWithContents' _ _ _ [] = error "frameNewWithContents': []"
      frameNewWithContents' box t r (w:ws) = do
        f <- frameNew
        frameSetLabel f t
        frameSetLabelAlign f (if r then 1 else 0) 0.5
        v <- box False spacing
        boxPackStart v w PackGrow 0
        forM_ ws $ \w' -> boxPackStart v w' PackNatural 0
        set f [ containerChild := v ]
        return f
  dStatus'                  <- statusDialogNew
  b01@bHome'                <- buttonNewWithLabel "Home"
  b02@bLoad'                <- buttonNewWithLabel "Load"
  b03@bSave'                <- buttonNewWithLabel "Save"
  b04@bStop'                <- buttonNewWithLabel "Stop"
  b7@bAddressToCoordinates' <- buttonNewWithLabel "Go"
  b8@bPeriodScan'           <- buttonNewWithLabel "Scan"
  b9@bPeriodScanPlus'       <- buttonNewWithLabel "Scan+"
  (eAddress', fa1) <- entryNewWithMnemonic "_Address"
  (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
  fb <- frameNewWithContents  vBoxNew "Actions" False [b01, b02, b03, b04, b8, b9]
  fa <- frameNewWithContents' hBoxNew "Angled Internal Address" True [toWidget fa1, toWidget b7]
  fh <- frameNewWithContents  hBoxNew "Colours" True [cInterior', cBorder', cExterior']
  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
            { dStatus               = dStatus'
            , bHome                 = bHome'
            , bLoad                 = bLoad'
            , bSave                 = bSave'
            , bStop                 = bStop'
            , bAddressToCoordinates = bAddressToCoordinates'
            , bPeriodScan           = bPeriodScan'
            , bPeriodScanPlus       = bPeriodScanPlus'
            , eAddress              = eAddress'
            , 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 ()
      butJ b a = do
        _ <- b g0 `onClicked` (wrapA' g0 gR a upI)
        return ()
      butO b a = do
        _ <- b g0 `onClicked` a
        return ()
      ent e a = do
        _ <- e g0 `onEntryActivate` (entryGetText (e g0) >>= wrapE g0 gR a)
        return ()
      entI e a = do
        _ <- e g0 `onEntryActivate` (entryGetText (e g0) >>= wrapE g0 gR a >> upI)
        return ()
      entI' e a = do
        _ <- e g0 `onEntryActivate` (do
          entryGetText (e g0) >>= wrapE g0 gR a
          g <- readIORef gR
          browserResize browser (width (gWindow g)) (height (gWindow g)) (supersamples (gWindow g))
          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 = do
        g <- readIORef gR
        browserRender browser Image
          { imageColours = let (c1, c2, c3) = gColours g in Colours (fromColor c1) (fromColor c2) (fromColor c3)
          , imageLocation = Location
              { center = toRational (fromMaybe 0 (gReal g)) :+ toRational (fromMaybe 0 (gImag g))
              , radius = fromMaybe 0 (gSize g)
              }
          , imageViewport = (gViewport g){ orient = fromMaybe 0 (gRota g) }
          , imageWindow = gWindow g
          } (return ()) (return ())
        postRedisplay gl'
      aUpdate (re :+ im) z = do
        atomicModifyIORef gR $ \g ->
          ( g{ gReal = Just re, gImag = Just im, gSize = Just z }, () )
        g <- readIORef gR
        uReal g0 g
        uImag g0 g
        uSize g0 g
        uRota g0 g
        upI
      aReshape w' h' = do
        atomicModifyIORef gR $ \g ->
          ( g { gWindow = (gWindow g){ width = w', height = h' }
              , gViewport = (gViewport 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)
  butJ bAddressToCoordinates aAddressToCoordinates
  butJ bPeriodScan           (aPeriodScan False)
  butJ bPeriodScanPlus       (aPeriodScan True)
  ent  eAddress              aAddress
  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'
  browserSetMouseCallback browser aUpdate
  browserSetReshapeCallback browser aReshape
  _ <- ww `onDestroy` aExit'
  g <- readIORef gR
  uEverything g0 g
  upI
  refreshGUI g0 g
  widgetShowAll iw
  widgetShowAll ww
  mainGUI

data Gruff = Gruff
  { gAddress    :: Maybe AngledInternalAddress
  , gIsland     :: Maybe AngledInternalAddress
  , gChild      :: Maybe [Angle]
  , gLowerAngle :: Maybe Angle
  , gUpperAngle :: Maybe Angle
  , gReal       :: Maybe R
  , gImag       :: Maybe R
  , gSize       :: Maybe Double
  } | Gruff2
  { gAddress    :: Maybe AngledInternalAddress
  , gReal       :: Maybe R
  , gImag       :: Maybe R
  , gSize       :: Maybe Double
  , gRota       :: Maybe Double
  , gColours    :: (Color, Color, Color)
  , gWindow     :: Window
  , gViewport   :: Viewport
  }
  deriving (Read, Show)
deriving instance Read Color

initialGruff :: Gruff
initialGruff = Gruff2
  { gAddress    = parseAngledInternalAddress "1"
  , gReal       = Just 0
  , gImag       = Just 0
  , gSize       = Just 1
  , gRota       = Just 0
  , gColours    = (red, black, white)
  , gWindow     = defWindow
  , gViewport   = defViewport
  }

refreshGUI :: GruffGUI -> Gruff -> IO ()
refreshGUI g0 g = do
  can bAddressToCoordinates $ j gAddress
  can bPeriodScan           $ True
  where
    can w = widgetSetSensitive (w g0)
    j a = isJust (a g)

-- button actions

type A = GruffGUI -> Gruff -> IO Gruff
type A' = GruffGUI -> Gruff -> (Gruff -> IO ()) -> IO ()

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

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

aHome :: A
aHome g0 g = do
  let g' = initialGruff{ gColours = gColours g, gWindow = gWindow g, gViewport = gViewport g }
  uEverything g0 g'
  return g'

aDoLoad :: FilePath -> IO (Maybe Gruff)
aDoLoad ff = (do
    gr <- safeRead `fmap` readFile ff
    return $ case gr of
      Just (Gruff a _ _ _ _ b c d) -> Just (Gruff2 a b c d (Just 0) (red, black, white) defWindow defViewport)
      g -> g
  ) `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

aPeriodScan :: Bool -> A'
aPeriodScan plus g0 g gn = do
  statusDialog (dStatus g0) "gruff status" $ \progress -> case liftM3 (,,) (gReal g) (gImag g) (gSize g) of
    Nothing -> progress "nothing to do" >> gn g
    Just (re, im, r) -> do
      forM_ (muLocate (re:+im) r) $ \mp -> case mp of
        MuScanTodo       -> progress "Scanning for period..."
        MuScan           -> progress "Scanning for period..."
        MuScanDone p     -> progress$"Scanning for period... " ++ show p
        MuNucleusTodo'   -> progress "Computing nucleus..."
        MuNucleus' i     -> when (i `mod` 20 == 0) . progress$"Computing nucleus... " ++ show i
        MuNucleusDone' _ -> progress "Computing nucleus... done"
        MuBondTodo'      -> progress "Computing bond..."
        MuBond' i        -> when (i `mod` 20 == 0) . progress$"Computing bond... " ++ show i
        MuBondDone' _    -> progress "Computing bond... done"
        MuSuccess'' mu -> do
          let g' = g{ gReal = Just . realPart . muNucleus $ mu
                    , gImag = Just . imagPart . muNucleus $ mu
                    , gSize = Just . (* 4) . muSize $ mu
                    , gRota = Just . subtract (pi/2) . muOrient $ mu
                    }
          progress "Found!"
          postGUISync $ do
            uReal g0 g'
            uImag g0 g'
            uSize g0 g'
            uRota g0 g'
          if plus
            then
              forM_ (muToAddress mu) $ \mp' -> case mp' of
                MuCuspTodo       -> progress "Computing cusp..."
                MuCuspDone _     -> progress "Computing cusp... done"
                MuDwellTodo      -> progress "Computing dwell..."
                MuDwell i        -> when (i `mod` 100 == 0) . progress$"Computing dwell... " ++ show i
                MuDwellDone _    -> progress "Computing dwell... done"
                MuRayOutTodo     -> progress "Tracing rays..."
                MuRayOut i       -> progress$"Tracing rays... " ++ show (round $ i * 100 :: Int) ++ "%"
                MuRayOutDone _   -> progress "Tracing rays... done"
                MuExternalTodo   -> progress "Computing angle..."
                MuExternalDone _ -> progress "Computing angle... done"
                MuAddressTodo    -> progress "Finding address..."
                MuSuccess' a     -> do
                  let g'' = g'{ gAddress = Just a }
                  progress "Complete!"
                  postGUISync $ do
                    uAddress g0 g''
                  gn g''
                MuFailed'         -> progress "Failed!" >> gn g'
            else
              gn g'
        MuFailed''       -> progress "Failed!" >> gn g

aAddressToCoordinates :: A'
aAddressToCoordinates g0 g gn = do
  statusDialog (dStatus g0) "gruff status" $ \progress -> case gAddress g of
    Nothing -> progress "nothing to do" >> gn g
    Just addr -> do
      forM_ (muFromAddress addr) $ \mp -> do
        case mp of
          MuSplitTodo      -> progress "Splitting address..."
          MuSplitDone _ _  -> progress "Splitting address... done"
          MuAnglesTodo     -> progress "Computing angles..."
          MuAnglesDone _ _ -> progress "Computing angles... done"
          MuRayTodo        -> progress "Tracing rays..."
          MuRay n          -> when (n `mod` 20 == 0) . progress$"Tracing rays... " ++ show n
          MuRayDone _      -> progress "Tracing rays... done"
          MuNucleusTodo    -> progress "Computing nucleus..."
          MuNucleus n      -> when (n `mod` 20 == 0) . progress$"Computing nucleus... " ++ show n
          MuNucleusDone _  -> progress "Computing nucleus... done"
          MuBondTodo       -> progress "Computing bond..."
          MuBond n         -> when (n `mod` 20 == 0) . progress$"Computing bond... " ++ show n
          MuBondDone _     -> progress "Computing bond... done"
          MuSuccess mu     -> do
            let g' = g{ gReal = Just . realPart . muNucleus $ mu
                      , gImag = Just . imagPart . muNucleus $ mu
                      , gSize = Just . (* 4) . muSize $ mu
                      , gRota = Just . subtract (pi/2) . muOrient $ mu
                      }
            progress "Done!"
            postGUISync $ do
              uReal g0 g'
              uImag g0 g'
              uSize g0 g'
              uRota g0 g'
            gn g'
          MuFailed         -> progress "Failed!" >> gn g

-- entry update

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

uEverything, uAddress, uReal, uImag, uSize, uRota, uColours, uWidth, uHeight, uSamples :: U
uEverything g0 g = forM_ [uAddress, uReal, uImag, uSize, uRota, uColours, uWidth, uHeight, uSamples] $ \u -> u g0 g
uAddress g0 g = entrySetText (eAddress g0) (maybe "" prettyAngledInternalAddress (gAddress g))
uReal g0 g = uMantissaExponent (eRealM g0) (eRealE g0) (maybe "" show (gReal g))
uImag g0 g = uMantissaExponent (eImagM g0) (eImagE g0) (maybe "" show (gImag g))
uSize g0 g = uMantissaExponent (eSizeM g0) (eSizeE g0) (maybe "" show (gSize g))
uRota g0 g = entrySetText (eRota g0) (maybe "" show (gRota g))
uColours g0 g = do
  let (ci, cb, ce) = gColours g
  colorButtonSetColor (cInterior g0) ci
  colorButtonSetColor (cBorder   g0) cb
  colorButtonSetColor (cExterior g0) ce
uWidth   g0 g = entrySetText (eWidth   g0) (show . width . gWindow $ g)
uHeight  g0 g = entrySetText (eHeight  g0) (show . height . gWindow $ g)
uSamples g0 g = entrySetText (eSamples g0) (show . supersamples . gWindow $ 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'
  refreshGUI g0 g'

aAddress, aReal, aImag, aSize, aRota, aWidth, aHeight, aSamples :: E
aAddress g s = g{ gAddress = parseAngledInternalAddress s }
aReal    g s = g{ gReal    = safeRead s }
aImag    g s = g{ gImag    = safeRead s }
aSize    g s = g{ gSize    = safeRead s }
aRota    g s = g{ gRota    = safeRead s }
aWidth   g s = case safeRead s of
  Nothing -> g
  Just r -> g{ gWindow  = (gWindow g){ width = r } }
aHeight  g s = case safeRead s of
  Nothing -> g
  Just r -> g{ gWindow  = (gWindow g){ height = r } }
aSamples g s = case safeRead s of
  Nothing -> g
  Just r -> g{ gWindow  = (gWindow g){ supersamples = r } }

aColours :: Color -> Color -> Color -> IORef Gruff -> IO ()
aColours i b e gR = atomicModifyIORef gR $ \g -> (g{ gColours = (i, b, e) }, ())

minSize :: Size
minSize = Size 160 100

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

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