gruff-0.3: src/Progress.hs

module Progress (Progress(..), progressNew, Cont) where

import Control.Monad (forM_, when)

import Graphics.UI.Gtk (Pixbuf)

import Fractal.RUFF.Mandelbrot.Address
import Fractal.RUFF.Mandelbrot.Atom
import Fractal.RUFF.Types.Complex

import Number (R)
import StatusDialog

-- | A continuation gets passed the result.
type Cont a = (Maybe a -> IO ()) -> IO ()

-- | Cancellable actions with status updates.
data Progress = Progress
  { progressLocate  :: Complex Rational -> Double -> Cont (MuAtom Rational)
  , progressAtom    :: AngledInternalAddress -> Cont (MuAtom Rational)
  , progressAddress :: MuAtom Rational -> Cont AngledInternalAddress
  }

-- | Create a new Progress with a status dialog.
progressNew :: Pixbuf -> IO Progress
progressNew icon = do
  -- FIXME this is a horrible hack to avoid race conditions when re-using the same status dialog
  sd1 <- statusDialogNew icon
  sd2 <- statusDialogNew icon
  sd3 <- statusDialogNew icon
  return Progress
    { progressLocate  = progressLocate'  sd1
    , progressAtom    = progressAtom'    sd2
    , progressAddress = progressAddress' sd3
    }

-- | Much like Fractal.RUFF.Mandelbrot.Atom.locate_
progressLocate' :: StatusDialog -> Complex Rational -> Double -> Cont (MuAtom Rational)
progressLocate' sd (re :+ im) r next = do
  statusDialog sd "gruff status" $ \progress' -> do
    let c = fromRational re :+ fromRational im :: Complex R
    forM_ (locate c r) $ \mp -> case mp of
      LocateScanTodo       -> progress' "Scanning for period..."
      LocateScan           -> progress' "Scanning for period..."
      LocateScanDone p     -> progress'$"Scanning for period... " ++ show p
      LocateNucleusTodo    -> progress' "Computing nucleus..."
      LocateNucleus i      -> when (i `mod` 20 == 0) . progress'$"Computing nucleus... " ++ show i
      LocateNucleusDone _  -> progress' "Computing nucleus... done"
      LocateBondTodo       -> progress' "Computing bond..."
      LocateBond i         -> when (i `mod` 20 == 0) . progress'$"Computing bond... " ++ show i
      LocateBondDone _     -> progress' "Computing bond... done"
      LocateSuccess mu     -> do
        progress' "Success!"
        let (re' :+ im') = muNucleus mu
        next $ Just mu{ muNucleus = toRational re' :+ toRational im' }
      LocateFailed         -> do
        progress' "Failed!"
        next $ Nothing

-- | Much like Fractal.RUFF.Mandelbrot.Atom.findAddress_
progressAddress' :: StatusDialog -> MuAtom Rational -> Cont AngledInternalAddress
progressAddress' sd mu next = do
  statusDialog sd "gruff status" $ \progress' -> do
    let re :+ im = muNucleus mu
        c = fromRational re :+ fromRational im :: Complex R
    forM_ (findAddress mu{ muNucleus = c }) $ \mp' -> case mp' of
      AddressCuspTodo       -> progress' "Computing cusp..."
      AddressCuspDone _     -> progress' "Computing cusp... done"
      AddressDwellTodo      -> progress' "Computing dwell..."
      AddressDwell i        -> when (i `mod` 100 == 0) . progress'$"Computing dwell... " ++ show i
      AddressDwellDone _    -> progress' "Computing dwell... done"
      AddressRayOutTodo     -> progress' "Tracing rays..."
      AddressRayOut i       -> progress'$"Tracing rays... " ++ show (round $ i * 100 :: Int) ++ "%"
      AddressRayOutDone _   -> progress' "Tracing rays... done"
      AddressExternalTodo   -> progress' "Computing angle..."
      AddressExternalDone _ -> progress' "Computing angle... done"
      AddressAddressTodo    -> progress' "Finding address..."
      AddressSuccess a      -> do
        progress' "Success!"
        next $ Just a
      AddressFailed         -> do
        progress' "Failed!"
        next $ Nothing

-- | Much like Fractal.RUFF.Mandelbrot.Atom.findAtom_
progressAtom' :: StatusDialog -> AngledInternalAddress -> Cont (MuAtom Rational)
progressAtom' sd addr next = do
  statusDialog sd "gruff status" $ \progress' -> do
    forM_ (findAtom addr) $ \mp -> case mp of
      AtomSplitTodo      -> progress' "Splitting address..."
      AtomSplitDone _ _  -> progress' "Splitting address... done"
      AtomAnglesTodo     -> progress' "Computing angles..."
      AtomAnglesDone _ _ -> progress' "Computing angles... done"
      AtomRayTodo        -> progress' "Tracing rays..."
      AtomRay n          -> when (n `mod` 20 == 0) . progress'$"Tracing rays... " ++ show n
      AtomRayDone _      -> progress' "Tracing rays... done"
      AtomNucleusTodo    -> progress' "Computing nucleus..."
      AtomNucleus n      -> when (n `mod` 20 == 0) . progress'$"Computing nucleus... " ++ show n
      AtomNucleusDone _  -> progress' "Computing nucleus... done"
      AtomBondTodo       -> progress' "Computing bond..."
      AtomBond n         -> when (n `mod` 20 == 0) . progress'$"Computing bond... " ++ show n
      AtomBondDone _     -> progress' "Computing bond... done"
      AtomSuccess mu     -> do
        progress' "Success!"
        let (re' :+ im') = muNucleus mu :: Complex R
        next $ Just mu{ muNucleus = toRational re' :+ toRational im' }
      AtomFailed         -> do
        progress' "Failed!"
        next $ Nothing