gruff-0.1: gruff.hs

{-# LANGUAGE Rank2Types, ScopedTypeVariables #-}
module Main (main) where

import Prelude hiding (catch, log)
import Control.Monad (forM_, liftM2)
import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef, writeIORef)
import Data.Maybe (isJust, fromMaybe)
import Data.Ratio (numerator, denominator)
import Graphics.UI.Gtk hiding (get, Region, Size)
import Graphics.UI.Gtk.OpenGL (initGL)
import System.Directory
  ( getAppUserDataDirectory, createDirectoryIfMissing )
import System.FilePath ((</>))
import Text.PrettyPrint.Leijen.Text (pretty)
import Text.FShow.Raw (DecimalFormat, nanTest, infTest)

import Numeric.QD
import Fractal.RUFF.Mandelbrot.Address (AngledInternalAddress, Angle, parse, angledInternalAddress, externalAngles)
import Fractal.RUFF.Mandelbrot.Ray (externalRay)
import Fractal.RUFF.Types.Complex (Complex((:+)), magnitude)

import GLUTGtk (glut, Size(Size))
import PeriodScan (periodScan, periodNucleus)
import Nucleus (refineNucleus)
import Address (parseAngle, parseAngles, splitAddress, joinAddress, addressPeriod)
import Logger (logger, LogLevel(Debug))
import qualified Logger as Log
import Utils (safeRead, catchIO)
import Paths_gruff (getDataFileName)
import Browser
import StatusDialog
import CacheView (cInitialize)

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
  , bAddressToCoordinates
  , bAddressToIslandChild
  , bIslandChildToAddress
  , bAddressToAngles
  , bIslandToAngles
  , bLowerAngleToAddress
  , bUpperAngleToAddress
  , bPeriodScan             :: Button
  -- entries
  , eAddress
  , eIsland
  , eChild
  , eLowerAngle
  , eUpperAngle
  , eReal
  , eImag
  , eSize
  , eHueShift
  , eHueScale               :: Entry
  -- windows
  , wMain
  , wImage                  :: Window
  }

main :: IO ()
main = do
  -- contexts
  _ <- initGUI
  _ <- initGL
  gl' <- glut minSize
  glC <- 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"
  -- widget window
  (iw, iUpdate, iInitializeLate) <- iInitialize gl' icon lg cacheDir'
  (cw, cUpdate, cInitializeLate) <- cInitialize glC icon cacheDir'
  -- widget window
  sg <- sizeGroupNew SizeGroupHorizontal
  let spacing = 2
      entryNewWithMnemonic m = do
        e <- entryNew
        entrySetWidthChars e 80
        l <- labelNewWithMnemonic m
        labelSetMnemonicWidget l e
        sizeGroupAddWidget sg l
        h <- hBoxNew False spacing
        boxPackStart h l PackNatural 0
        boxPackStartDefaults h e
        return (e, h)
      frameNewWithContents t r ws = do
        f <- frameNew
        frameSetLabel f t
        frameSetLabelAlign f (if r then 1 else 0) 0.5
        v <- vBoxNew False spacing
        forM_ ws $ boxPackStartDefaults v
        set f [ containerChild := v ]
        return f
  dStatus'                  <- statusDialogNew
  b01@bHome'                <- buttonNewWithLabel "Home"
  b02@bLoad'                <- buttonNewWithLabel "Load"
  b03@bSave'                <- buttonNewWithLabel "Save"
  b7@bAddressToCoordinates' <- buttonNewWithLabel "Address → Coordinates"
  b1@bAddressToIslandChild' <- buttonNewWithLabel "Address → Island + Child"
  b2@bIslandChildToAddress' <- buttonNewWithLabel "Island + Child → Address"
  b3@bAddressToAngles'      <- buttonNewWithLabel "Address → Lower + Upper"
  b4@bIslandToAngles'       <- buttonNewWithLabel "Island → Lower + Upper"
  b5@bLowerAngleToAddress'  <- buttonNewWithLabel "Lower → Address"
  b6@bUpperAngleToAddress'  <- buttonNewWithLabel "Upper → Address"
  b8@bPeriodScan'           <- buttonNewWithLabel "Period Scan"
  (eAddress', fa1) <- entryNewWithMnemonic "_Address"
  (eIsland',  fa2) <- entryNewWithMnemonic "I_sland"
  (eChild',   fa3) <- entryNewWithMnemonic "_Child"
  (eLowerAngle', fe1) <- entryNewWithMnemonic "_Lower"
  (eUpperAngle', fe2) <- entryNewWithMnemonic "_Upper"
  (eReal', fc1) <- entryNewWithMnemonic "_Real"
  (eImag', fc2) <- entryNewWithMnemonic "_Imag"
  (eSize', fc3) <- entryNewWithMnemonic "Si_ze"
  (eHueShift', fh1) <- entryNewWithMnemonic "Hue Shift"
  (eHueScale', fh2) <- entryNewWithMnemonic "Hue Scale"
  b0 <- hBoxNew False spacing
  mapM_ (boxPackStartDefaults b0) [b01, b02, b03]
  fb <- frameNewWithContents "Actions" False $ toWidget b0 : map toWidget [b7, b1, b2, b3, b4, b5, b6, b8]
  fa <- frameNewWithContents "Angled Internal Address" True [fa1, fa2, fa3]
  fe <- frameNewWithContents "External Angles" True [fe1, fe2]
  fh <- frameNewWithContents "Colouring" True [fh1, fh2]
  fc <- frameNewWithContents "Coordinates" True [fc1, fc2, fc3]
  v <- vBoxNew False spacing
  mapM_ (boxPackStartDefaults v) [fc, fa, fe, fh]
  h <- hBoxNew False spacing
  boxPackStartDefaults h fb
  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'
            , bAddressToCoordinates = bAddressToCoordinates'
            , bAddressToIslandChild = bAddressToIslandChild'
            , bIslandChildToAddress = bIslandChildToAddress'
            , bAddressToAngles      = bAddressToAngles'
            , bIslandToAngles       = bIslandToAngles'
            , bLowerAngleToAddress  = bLowerAngleToAddress'
            , bUpperAngleToAddress  = bUpperAngleToAddress'
            , bPeriodScan           = bPeriodScan'
            , eAddress              = eAddress'
            , eIsland               = eIsland'
            , eChild                = eChild'
            , eLowerAngle           = eLowerAngle'
            , eUpperAngle           = eUpperAngle'
            , eReal                 = eReal'
            , eImag                 = eImag'
            , eSize                 = eSize'
            , eHueShift             = eHueShift'
            , eHueScale             = eHueScale'
            , 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 ()
      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 ()
      upI = do
        g <- readIORef gR
        iUpdate (gReal g) (gImag g) (gSize g) (gHueShift g) (gHueScale g)
        cUpdate (gReal g) (gImag g) (gSize g)
      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
        cUpdate (gReal g) (gImag g) (gSize g)
  butI bHome aHome
  butI bLoad aLoad
  but  bSave aSave
  butJ bAddressToCoordinates aAddressToCoordinates
  but  bAddressToIslandChild aAddressToIslandChild
  but  bIslandChildToAddress aIslandChildToAddress
  but  bAddressToAngles      aAddressToAngles
  but  bIslandToAngles       aIslandToAngles
  but  bLowerAngleToAddress  aLowerAngleToAddress
  but  bUpperAngleToAddress  aUpperAngleToAddress
  butJ bPeriodScan           aPeriodScan
  ent  eAddress              aAddress
  ent  eIsland               aIsland
  ent  eChild                aChild
  ent  eLowerAngle           aLowerAngle
  ent  eUpperAngle           aUpperAngle
  entI eReal aReal
  entI eImag aImag
  entI eSize aSize
  entI eHueShift aHueShift
  entI eHueScale aHueScale
  let aExit' = (exit (Log.log lg) stateFile =<< readIORef gR)
  iInitializeLate aUpdate aExit'
  cInitializeLate         aExit'
  _ <- ww `onDestroy` aExit'
  g <- readIORef gR
  uEverything g0 g
  upI
  refreshGUI g0 g
  widgetShowAll ww
  widgetShowAll cw
  widgetShowAll iw
  mainGUI

data Gruff = Gruff
  { gAddress    :: Maybe AngledInternalAddress
  , gIsland     :: Maybe AngledInternalAddress
  , gChild      :: Maybe [Angle]
  , gLowerAngle :: Maybe Angle
  , gUpperAngle :: Maybe Angle
  , gReal       :: Maybe QuadDouble
  , gImag       :: Maybe QuadDouble
  , gSize       :: Maybe QuadDouble
  } | Gruff1
  { gAddress    :: Maybe AngledInternalAddress
  , gIsland     :: Maybe AngledInternalAddress
  , gChild      :: Maybe [Angle]
  , gLowerAngle :: Maybe Angle
  , gUpperAngle :: Maybe Angle
  , gReal       :: Maybe QuadDouble
  , gImag       :: Maybe QuadDouble
  , gSize       :: Maybe QuadDouble
  , gHueShift   :: Maybe Double
  , gHueScale   :: Maybe Double
  }
  deriving (Read, Show)

initialGruff :: Gruff
initialGruff = Gruff1
  { gAddress    = parse "1"
  , gIsland     = parse "1"
  , gChild      = Just []
  , gLowerAngle = Just 0
  , gUpperAngle = Just 1
  , gReal       = Just 0
  , gImag       = Just 0
  , gSize       = Just 1
  , gHueShift   = Just 0
  , gHueScale   = Just 1
  }

refreshGUI :: GruffGUI -> Gruff -> IO ()
refreshGUI g0 g = do
  can bAddressToCoordinates $ j gAddress
  can bAddressToIslandChild $ j gAddress
  can bIslandChildToAddress $ j gIsland && j gChild
  can bAddressToAngles      $ j gAddress
  can bIslandToAngles       $ j gIsland
  can bLowerAngleToAddress  $ j gLowerAngle
  can bUpperAngleToAddress  $ j gUpperAngle
  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 _ = do
  let g = initialGruff
  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 e f g h) -> Just (Gruff1 a b c d e f g h (Just 0) (Just 1))
      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 :: A'
aPeriodScan g0 g gn = do
  statusDialog (dStatus g0) "gruff status" $ \progress -> do
    progress "Scanning for period..."
    let ps = do
          re <- gReal g
          im <- gImag g
          r  <- gSize g
          let c = re :+ im
          p <- periodScan r c
          return (p, r, c)
    g' <- case ps of
      Just (p, r, c) -> do
        progress $ "Scanning for nucleus (" ++ show p ++ ")..."
        case periodNucleus p r c of
          Just n -> do
            progress $ "Computing nucleus (" ++ show p ++ ")..."
            case refineNucleus p n of
              (z, (re :+ im)) | 10 > z && z > 0 ->
                return g{ gReal = Just re, gImag = Just im, gSize = Just (z * 4) }
              _ -> return g{ gReal = Nothing, gImag = Nothing, gSize = Nothing }
          _ -> return g{ gReal = Nothing, gImag = Nothing, gSize = Nothing }
      _ -> return g{ gReal = Nothing, gImag = Nothing, gSize = Nothing }
    progress "Done!"
    postGUISync $ do
      uReal g0 g'
      uImag g0 g'
      uSize g0 g'
    gn g'

aAddressToCoordinates :: A'
aAddressToCoordinates g0 g gn = do
  statusDialog (dStatus g0) "gruff status" $ \progress -> do
    progress "Splitting address..."
    g1 <- aAddressToIslandChild g0 g
    progress "Finding external angles..."
    g2 <- aIslandToAngles g0 g1
    progress "Tracing external rays..."
    g' <- aAnglesChildToCoordinates (progress "Computing nucleus...") g0 g2
    progress "Done!"
    postGUISync $ do
      uReal g0 g'
      uImag g0 g'
      uSize g0 g'
    gn g'

aAnglesChildToCoordinates :: IO () -> A
aAnglesChildToCoordinates progress _g0 g = do
  case liftM2 (,) (gIsland g) (gLowerAngle g) of
    Just (a, lo) ->
      let eps = 2 ** negate 48
          eps' = 2 ** negate 40
          p = addressPeriod a
          rlo = externalRay eps 8 (2**24) lo
          ok' w = not (nanTest w || infTest w)
          ok (w:+x) = ok' w && ok' x
          converge [] = Nothing
          converge [x] = Just x
          converge (x:m@(y:_))
            | not $ magnitude (x - y) < eps' = converge m
            | otherwise = Just x
          rend = converge . takeWhile ok $ rlo
      in  case rend of
        Just c -> progress >> case refineNucleus p c of
          (z, (re :+ im)) | z > 0 ->
            return g{ gReal = Just re, gImag = Just im, gSize = Just (z * 4) }
          _ -> return g{ gReal = Nothing, gImag = Nothing, gSize = Nothing }
        Nothing -> return g{ gReal = Nothing, gImag = Nothing, gSize = Nothing }
    Nothing -> return g{ gReal = Nothing, gImag = Nothing, gSize = Nothing }

aAddressToIslandChild :: A
aAddressToIslandChild g0 g = do
  let g' = fromMaybe g{ gIsland = Nothing, gChild = Nothing } $ do
        a <- gAddress g
        (i, c) <- splitAddress a
        return g{ gIsland = Just i, gChild = Just c }
  postGUISync $ uIsland g0 g'
  postGUISync $ uChild g0 g'
  return g'

aIslandChildToAddress :: A
aIslandChildToAddress g0 g = do
  let g' = g{ gAddress = liftM2 joinAddress (gIsland g) (gChild g) }
  postGUISync $ uAddress g0 g'
  return g'

aAddressToAngles :: A
aAddressToAngles g0 g = do
  let (l, u) = case externalAngles =<< gAddress g of
                  Just (lo, up) -> (Just lo, Just up)
                  Nothing -> (Nothing, Nothing)
      g' = g{ gLowerAngle = l, gUpperAngle = u }
  postGUISync $ uLowerAngle g0 g'
  postGUISync $ uUpperAngle g0 g'
  return g'

aIslandToAngles :: A
aIslandToAngles g0 g = do
  let (l, u) = case externalAngles =<< gIsland g of
                  Just (lo, up) -> (Just lo, Just up)
                  Nothing -> (Nothing, Nothing)
      g' = g{ gLowerAngle = l, gUpperAngle = u }
  -- strictness hack to prevent evaluation in gui thread...
  case (gLowerAngle g', gUpperAngle g') of
    (Just lo, Just up) | lo + up > 0 -> return ()
    _ -> return ()
  postGUISync $ uLowerAngle g0 g'
  postGUISync $ uUpperAngle g0 g'
  return g'

aLowerAngleToAddress :: A
aLowerAngleToAddress g0 g = do
  let a = angledInternalAddress =<< gLowerAngle g
      g' = g{ gAddress = a }
  postGUISync $ uAddress g0 g'
  return g'

aUpperAngleToAddress :: A
aUpperAngleToAddress g0 g = do
  let a = angledInternalAddress =<< gUpperAngle g
      g' = g{ gAddress = a }
  postGUISync $ uAddress g0 g'
  return g'

-- entry update

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

uEverything, uAddress, uIsland, uChild, uLowerAngle, uUpperAngle, uReal, uImag, uSize :: U
uEverything g0 g = forM_ [uAddress, uIsland, uChild, uLowerAngle, uUpperAngle, uReal, uImag, uSize] $ \u -> u g0 g
uAddress g0 g = do
  let s = filter ('"'/=) . show . pretty
  entrySetText (eAddress g0) (maybe "" s (gAddress g))
uIsland g0 g = do
  let s = filter ('"'/=) . show . pretty
  entrySetText (eIsland g0) (maybe "" s (gIsland g))
uChild g0 g = do
  let s x = show (numerator x) ++ "/" ++ show (denominator x)
      t = unwords . map s
  entrySetText (eChild g0) (maybe "" t (gChild g))
uLowerAngle g0 g = do
  let s x = show (numerator x) ++ " / " ++ show (denominator x)
  entrySetText (eLowerAngle g0) (maybe "" s (gLowerAngle g))
uUpperAngle g0 g = do
  let s x = show (numerator x) ++ " / " ++ show (denominator x)
  entrySetText (eUpperAngle g0) (maybe "" s (gUpperAngle g))
uReal g0 g = entrySetText (eReal g0) (maybe "" show (gReal g))
uImag g0 g = entrySetText (eImag g0) (maybe "" show (gImag g))
uSize g0 g = entrySetText (eSize g0) (maybe "" show (gSize g))

-- 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, aIsland, aChild, aLowerAngle, aUpperAngle, aReal, aImag, aSize, aHueShift, aHueScale :: E
aAddress    g s = g{ gAddress    = parse       s }
aIsland     g s = g{ gIsland     = parse       s }
aChild      g s = g{ gChild      = parseAngles s }
aLowerAngle g s = g{ gLowerAngle = parseAngle  s }
aUpperAngle g s = g{ gUpperAngle = parseAngle  s }
aReal       g s = g{ gReal       = safeRead    s }
aImag       g s = g{ gImag       = safeRead    s }
aSize       g s = g{ gSize       = safeRead    s }
aHueShift   g s = g{ gHueShift   = safeRead    s }
aHueScale   g s = g{ gHueScale   = safeRead    s }

minSize :: Size
minSize = Size 160 100