mandulia-0.4: src/Interface.hs

{-
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 Interface (Interface(..), interface, closeInterface, reshape, render, keyboard, atexit) where

import Control.Exception (try, IOException)
import Control.Monad (forM_, liftM3)
import Data.IORef
import System.FilePath ((</>), replaceFileName)
import System.Directory (getAppUserDataDirectory)

import Scripting.Lua (LuaState)
import qualified Scripting.Lua as Lua

import Paths_mandulia (getDataFileName)

-- interface

data Interface =
  Interface
    { iLua         :: LuaState -- initialized in interface
    , iQuit        :: Bool     -- can only be set by Lua 'quit'
    -- these are all updated from Lua globals in Haskell 'update'
    , iRecord      :: Bool
    , iWidth       :: Int
    , iHeight      :: Int
    , iFPS         :: Double
    , iFullScreen  :: Bool
    , iDetail      :: Double
    , iDisplaySize :: Double
    , iJuliaSize   :: Int
    , iJobs        :: Int
    , iImages      :: Int
    , iTextures    :: Int
    , iWorkers     :: Int
    , iView        :: (Double, Double, Double)
    }

-- constructor

interface :: FilePath -> [String] -> IO (Maybe (IORef Interface))
interface f args = do
  l <- Lua.newstate
  iR <- newIORef Interface
    { iLua = l
    , iQuit = False
    , iRecord = False
    , iWidth = 1920
    , iHeight = 1080
    , iFullScreen = False
    , iFPS = 25
    , iDetail = 11
    , iDisplaySize = 96
    , iJuliaSize = 256
    , iJobs = 1024
    , iImages = 512
    , iTextures = 2048
    , iWorkers = 2
    , iView = (0, 0, 0)
    }
  Lua.openlibs l
  path <- getDataFileName "?.lua"
  appp <- getAppUserDataDirectory "mandulia"
  paths <- do
    Lua.getglobal2 l "package.path"
    r <- Lua.peek l (-1)
    Lua.pop l 1
    return r
  let paths' = ("."  </> "?.lua") ++ ";" ++     -- current dir
               (appp </> "?.lua") ++ ";" ++     -- user dir
               path ++                          -- cabal dir
               maybe "" (";" ++) paths          -- preset
      setPath p = do
        Lua.getglobal l "package"
        Lua.pushstring l "path"
        Lua.pushstring l p
        Lua.settable l (-3)
        Lua.pop l 1
  setPath paths'
  Lua.newtable l
  Lua.pushstring l "quit"
  Lua.pushhsfunction l (quit iR)
  Lua.settable l (-3)
  Lua.pushstring l "args"
  Lua.newtable l
  forM_ ([(1::Int) .. ] `zip` args) $ \(i,a) -> do
    Lua.push l i
    Lua.push l a
    Lua.settable l (-3)
  Lua.settable l (-3)
  Lua.setglobal l "mandulia"
  r1 <- (try $ do
    r <- Lua.loadfile l f
    if r /= 0 then return r else do
      let rel = replaceFileName f "?.lua"       -- relative dir
      setPath $ rel ++ ";" ++ paths'
      Lua.pcall l 0 0 0) :: IO (Either IOException Int)
  r2 <- if r1 == Right 0 then return r1 else do
    _ <- Lua.callproc l "require" f
    return $ Right 0
  if r2 == Right 0 then update iR >> return (Just iR) else Lua.close l >> return Nothing

-- destructor

closeInterface :: IORef Interface -> IO ()
closeInterface iR = do
  l <- iLua `fmap` readIORef iR
  Lua.close l

-- update from Lua

update :: IORef Interface -> IO ()
update iR = do
  l <- iLua `fmap` readIORef iR
  let g s = do
        Lua.getglobal2 l ("mandulia." ++ s)
        r <- Lua.peek l (-1)
        Lua.pop l 1
        return r
  record      <- g "record"
  width       <- g "width"
  height      <- g "height"
  fps         <- g "fps"
  full        <- g "fullscreen"
  detail      <- g "detail"
  displaysize <- g "displaysize"
  juliasize   <- g "juliasize"
  jobs        <- g "jobs"
  images      <- g "images"
  textures    <- g "textures"
  workers     <- g "workers"
  viewX       <- g "view.x"
  viewY       <- g "view.y"
  viewZ       <- g "view.z"
  modifyIORef iR $ \i ->
    let f k v = case v of
                  Nothing -> k i
                  Just x  -> x
    in  i { iRecord      = f iRecord      record
          , iWidth       = f iWidth       width
          , iHeight      = f iHeight      height
          , iFPS         = f iFPS         fps
          , iFullScreen  = f iFullScreen  full
          , iDetail      = f iDetail      detail
          , iDisplaySize = f iDisplaySize displaysize
          , iJuliaSize   = f iJuliaSize   juliasize
          , iJobs        = f iJobs        jobs
          , iImages      = f iImages      images
          , iTextures    = f iTextures    textures
          , iWorkers     = f iWorkers     workers
          , iView        = case liftM3 (,,) viewX viewY viewZ of
                             Just v -> v
                             _      -> iView i
          }

-- callbacks from Lua

quit :: IORef Interface -> IO ()
quit iR = modifyIORef iR $ \i -> i{ iQuit = True }

-- callbacks into Lua

reshape :: IORef Interface -> Int -> Int -> IO ()
reshape iR w h = do
  l <- iLua `fmap` readIORef iR
  _ <- Lua.callproc l "mandulia.reshape" w h
  update iR

render :: IORef Interface -> IO ()
render iR = do
  l <- iLua `fmap` readIORef iR
  _ <- Lua.callproc l "mandulia.render"
  update iR

keyboard :: IORef Interface -> String -> IO ()
keyboard iR s = do
  l <- iLua `fmap` readIORef iR
  _ <- Lua.callproc l "mandulia.keyboard" s
  update iR

atexit :: IORef Interface -> IO ()
atexit iR = do
  l <- iLua `fmap` readIORef iR
  _ <- Lua.callproc l "mandulia.atexit"
  update iR