{-
Mandulia -- Mandelbrot/Julia explorer
Copyright (C) 2010  Claude Heiland-Allen <claudiusmaximus@goto10.org>

This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program.  If not, see <http://www.gnu.org/licenses/>.
-}

module Main (main) where

import Control.Concurrent (ThreadId(), forkIO, killThread)
import Control.Monad (replicateM, when)
import Data.Either (partitionEithers)
import Data.IORef
import Data.Maybe (isNothing, catMaybes)
import Data.Version (showVersion)
import System.Environment (getArgs)
import System.Exit (exitFailure, exitSuccess)
import System.IO (hPutStr, stderr, stdout)

import Graphics.UI.GLUT hiding (scale, translate, fullScreen)
import qualified Graphics.UI.GLUT as G
import Unsafe.Coerce (unsafeCoerce)

import Paths_mandulia (version)

import AmmannA3
import Bounds
import Image
import Interface (Interface(..), interface, closeInterface)
import qualified Interface as I
import JobQueue
import Julia
import ResourcePool
import Snapshot
import Sort
import StatsLogger
import TextureCache
import Utils
import Vector

data Mandulia =
  Mandulia
    { tiling     :: Maybe AmmannA3
    , viewMax    :: Bounds
    , view       :: Bounds
    , width      :: Int
    , height     :: Int
    , fullScreen :: Bool
    , oldWidth   :: Int
    , oldHeight  :: Int
    , iface      :: IORef Interface
    , workers    :: [ThreadId]
    , jobs       :: JobQueue JuliaJob
    , textures   :: TextureCache
    , images     :: ResourcePool Image
    , logStats   :: String -> Double -> IO ()
    , getStats   :: IO [(String, (Double, Double, Double))]
    }

main :: IO ()
main = do
  args <- getArgs
  let (opts, args') = span (\o -> "-" == take 1 o) args
  when ("--version" `elem` opts || "-V" `elem` opts) $ do
    putStr $ unlines
      [ "mandulia " ++ showVersion version
      , "Copyright (C) 2010  Claude Heiland-Allen <claudiusmaximus@goto10.org>"
      , "This is free software; see the source for copying conditions.  There is NO"
      , "warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE."
      ]
    exitSuccess
  when ("--help" `elem` opts || "-h" `elem` opts || "-?" `elem` opts) $ do
    putStr $ unlines
      [ "Usage: mandulia [OPTION]... CONFIGURATION [ARGUMENT]..."
      , ""
      , "CONFIGURATION is considered (in this order):"
      , "  as a file to load directly;"
      , "  as a module to load from the current directory;"
      , "  as a module to load from the user settings directory;"
      , "  as a module to load from the global settings directory."
      , ""
      , "Configurations available in this package may include:"
      , "  interactive"
      , "  random"
      , ""
      , "The ARGUMENT list is supplied to the selected configuration."
      , ""
      , "Options:"
      , "  +RTS [OPTION].. -RTS   options for the run time system"
      , "                         (Try `mandulia +RTS -? -RTS' for help)"
      , "  -?, -h, --help         print this help text"
      , "  -V, --version          print program version"
      , ""
      , "Report bugs to <claudiusmaximus@goto10.org>."
      ]
    exitSuccess
  when (null args') $ do
    hPutStr stderr $ unlines
      [ "No configuration specified."
      , "Try `mandulia --help' for more information."
      ]
    exitFailure
  hPutStr stderr $ unlines
      [ "mandulia (GPLv3+) 2010 Claude Heiland-Allen <claudiusmaximus@goto10.org>"
      ]
  mif <- interface (head args') (tail args')
  when (isNothing mif) $ do
    hPutStr stderr $ unlines
      [ "Configuration error."
      ]
    exitFailure
  let Just iR = mif
  i <- readIORef iR
  let jsize  = clamp 1 1024 $ iJuliaSize i -- FIXME check power of two
      imagen = 1 `max` iImages   i
      texn   = 1 `max` iTextures i
      workn  = 1 `max` iWorkers  i
      winW   = 1 `max` I.iWidth  i
      winH   = 1 `max` I.iHeight i
      full   = I.iFullScreen i
      mspf   = 1 `max` (ceiling $ 1000 / (iFPS i `max` 0.01))
      view0  = mkView winW winH 0 0 0
  (logStats', getStats') <- statsLogger
  jobq      <- jobQueue
  imgpool   <- resourcePool (image jsize jsize 4) imagen
  let texcache = textureCache texn
  wtids     <- replicateM workn
    (forkIO $ juliaWorker logStats' jsize jsize imgpool jobq)
  manduliaR <- newIORef Mandulia { tiling = Nothing
                                 , viewMax = view0
                                 , view = view0
                                 , width = winW
                                 , height = winH
                                 , fullScreen = full
                                 , oldWidth = winW
                                 , oldHeight = winH
                                 , iface = iR
                                 , workers = wtids
                                 , jobs = jobq
                                 , textures = texcache
                                 , images = imgpool
                                 , logStats = logStats'
                                 , getStats = getStats'
                                 }
  initialWindowSize $= Size (fromIntegral winW) (fromIntegral winH)
  initialDisplayMode $= [RGBAMode, DoubleBuffered]
  _ <- getArgsAndInitialize
  _ <- createWindow "Mandulia"
  displayCallback       $=       display manduliaR
  reshapeCallback       $= Just (reshape manduliaR)
  keyboardMouseCallback $= Just (kmouse  manduliaR)
  addTimerCallback mspf $        timer   manduliaR
  mainLoop

mkView :: Int -> Int -> Double -> Double -> Double -> Bounds
mkView winW winH x y z =
  let w = fromIntegral winW
      h = fromIntegral winH
      ax = if winW > winH then 1 else w / h
      ay = if winW < winH then 1 else h / w
      r = 16 * phi' ** z
      x0 = x - r * ax
      y0 = y - r * ay
      x1 = x + r * ax
      y1 = y + r * ay
  in  bounds [ V x0 y0 1, V x1 y1 1 ]

quit :: IORef Mandulia -> IO ()
quit mR = do
  m <- readIORef mR
  mapM_ killThread (workers m)
  I.atexit (iface m)
  closeInterface (iface m)
  exitSuccess

update :: IORef Mandulia -> IO (Julia -> Double)
update mR = do
  m0 <- readIORef mR
  s <- getStats m0
  modifyIORef' (iface m0) (\i -> i{ iStatistics = s })
  I.render (iface m0)
  i <- readIORef (iface m0)
  when (iQuit i) (quit mR)
  fullscreen mR (iFullScreen i)
  m <- readIORef mR
  let (x, y, z) = iView i
      v = mkView (width m) (height m) x y z
  if v `insideOrEqual` viewMax m
   then do
    case zoomTo v (ammannA3 $ viewMax m) of
      t@(Just _) -> do
        writeIORef mR m{ tiling = t, view = v }
        return $ score z x y
      Nothing -> return $ score z x y -- FIXME should never happen?
   else return $ score z x y -- FIXME what to do when out of range?

data Quad =
  Quad
    { quadX :: !R
    , quadY :: !R
    , quadR :: !R
    , quadT :: !TextureObject
    }

radius :: R -> R -> Int -> R
radius d z i = let x = d + z - fromIntegral i
               in  clamp 0 1 $ x * 4 / d -- FIXME configure the 4

quads :: IORef Mandulia -> IO ([Julia], [Quad])
quads mR = do
  m <- readIORef mR
  i <- readIORef (iface m)
  let w = fromIntegral (width m)
      h = fromIntegral (height m)
      s = iDisplaySize i
      window = bounds [ V (-s) (-s) 1, V (w+s) (h+s) 1]
      viewT  = view m `into` window
      ctiles = case tiling m of
        Just t -> filter ((==) C . tTile) . tiles (ceiling d) $ t
        Nothing -> []
      d = iDetail i
      (_, _, z) = iView i
      rads = map ((s *) . radius d z) [0 ..]
  return $ partitionEithers
        [ case mt of
            Nothing  -> Left j
            Just tex -> Right Quad{ quadX = x
                                  , quadY = y
                                  , quadR = r
                                  , quadT = tex
                                  }
        | t <- ctiles
        , let V cx cy _ = tCenter t
        , let V  x  y _ = viewT ^^*^ V cx cy 1
        , let ii = tId t
        , let l = tDepth t
        , let r = rads !! l
        , let j = Julia{ jId = ii, jLevel = l, jCX = cx, jCY = cy }
        , let mt = lookupTexture (textures m) j
        ]

r2gl :: R -> GLdouble
r2gl = unsafeCoerce -- FIXME there must be a better way...

drawQuad :: Quad -> IO ()
drawQuad Quad{ quadX = x0, quadY = y0, quadR = s, quadT = tex } = do
  let t x y = texCoord $ TexCoord2 (x :: GLdouble) (y :: GLdouble)
      v x y = vertex   $ Vertex2 (r2gl x) (r2gl y)
  textureBinding Texture2D $= Just tex
  renderPrimitive Quads $ do
    color $ Color3 1 1 (1::GLdouble)
    t 0 1 >> v (x0 - s) (y0 + s)
    t 0 0 >> v (x0 - s) (y0 - s)
    t 1 0 >> v (x0 + s) (y0 - s)
    t 1 1 >> v (x0 + s) (y0 + s)

display0 :: IORef Mandulia -> IO ()
display0 mR = do
  curScore <- update mR
  qs <- computeJobs mR curScore
  drawQuads qs
  swapBuffers
  completeJobs mR curScore
  record mR
  reportErrors

display :: IORef Mandulia -> IO ()
display mR = do
  m <- readIORef mR
  (dt, r) <- time $ display0 mR
  logStats m "display" dt
  return r

computeJobs :: IORef Mandulia -> (Julia -> Double) -> IO [Quad]
computeJobs mR curScore = do
  m <- readIORef mR
  i <- readIORef (iface m)
  (js, qs) <- quads mR
  cs <- sortIO curScore . filter (notCached (textures m)) $ js
  let job j = JuliaJob{ jCoords = j, jDoneAction = Nothing }
      js' = map job . take (iJobs i) $ cs
      visible q = not ( quadX q + 2 * quadR q < 0
                     || fromIntegral (width m)  < quadX q - 2 * quadR q
                     || quadY q + 2 * quadR q < 0
                     || fromIntegral (height m) < quadY q - 2 * quadR q
                     ) && quadR q > 0
  reprioritise (jobs m) (const js')
  return $ filter visible qs

black :: Color4 GLclampf
black = Color4 0 0 0 1

drawQuads :: [Quad] -> IO ()
drawQuads qs = do
  clearColor $= black
  clear [ColorBuffer]
  blend $= Enabled
  blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
  texture Texture2D $= Enabled
  mapM_ drawQuad qs
  textureBinding Texture2D $= Nothing
  texture Texture2D $= Disabled
  blend $= Disabled

completeJobs :: IORef Mandulia -> (Julia -> Double) -> IO ()
completeJobs mR curScore = do
  m <- readIORef mR
  tc <- cacheTextures curScore (textures m) . catMaybes . map jDoneAction =<< completed (jobs m)
  writeIORef mR m{ textures = tc }

record :: IORef Mandulia -> IO ()
record mR = do
  m <- readIORef mR
  i <- readIORef (iface m)
  when (iRecord i) $ do
    hSnapshot stdout (Position 0 0) (Size (fromIntegral (width m)) (fromIntegral (height m)))

fullscreen :: IORef Mandulia -> Bool -> IO ()
fullscreen mR fs = do
  m <- readIORef mR
  when (fullScreen m /= fs) $ do
    if fs
     then do
      writeIORef mR m{ oldWidth = width m, oldHeight = height m, fullScreen = fs }
      G.fullScreen
     else do
      writeIORef mR m{ fullScreen = fs }
      windowSize $= Size (fromIntegral $ oldWidth m) (fromIntegral $ oldHeight m)

reshape :: IORef Mandulia -> Size -> IO ()
reshape mR (Size w h) = do
  modifyIORef mR $ \m' -> m'{ width = fromIntegral w, height = fromIntegral h }
  m <- readIORef mR
  I.reshape (iface m) (fromIntegral w) (fromIntegral h)
  i <- readIORef (iface m)
  let (x, y, z) = iView i
      s = ceiling $ 2 * iDisplaySize i
  modifyIORef mR $ \m' -> m'{ view = mkView (width m') (height m') x y z }
  viewport $= (Position (-s) (-s), (Size (w + 2 * fromIntegral s) (h + 2 * fromIntegral s)))
  matrixMode $= Projection
  loadIdentity
  ortho (-fromIntegral s) (fromIntegral w + fromIntegral s) (-fromIntegral s) (fromIntegral h + fromIntegral s) (-1) 1
  matrixMode $= Modelview 0
  loadIdentity
  postRedisplay Nothing

timer :: IORef Mandulia -> IO ()
timer mR = do
  m <- readIORef mR
  i <- readIORef (iface m)
  let mspf = ceiling $ 1000 / (iFPS i `max` 0.01)
  addTimerCallback mspf $ timer mR
  postRedisplay Nothing

kmouse :: IORef Mandulia -> Key -> KeyState -> Modifiers -> Position -> IO  ()
kmouse mR (Char    '\27') Down _m _p = key mR "Escape"
kmouse mR (Char        k) Down _m _p = key mR [ k ]
kmouse mR (SpecialKey sk) Down _m _p = case show sk of
                                         'K':'e':'y':key' -> key mR key'
                                         key'             -> key mR key'
kmouse _r _k              _s   _m _p = return () -- FIXME handle everything

key :: IORef Mandulia -> String -> IO ()
key mR k = do
  m <- readIORef mR
  I.keyboard (iface m) k