-- |
-- Module: Graphics.Chalkboard.Viewer
-- Copyright: (c) 2009 Andy Gill
-- License: BSD3
--
-- Maintainer: Andy Gill <andygill@ku.edu>
-- Stability: unstable
-- Portability: ghc
--
-- Simple Viewer for Chalkboard Images, using OpenGL.


module Graphics.Chalkboard.Viewer 
        ( initBoardViewer
        , BoardViewerInit(..)
        ) where

import Data.Time.Clock
import Data.Array 

import Foreign ( pokeElemOff, Storable, mallocBytes, free )
import Data.Word
import Data.IORef 

import Control.Concurrent.MVar
import Graphics.UI.GLUT
import Graphics.Rendering.OpenGL ( Color4 )

import qualified Graphics.Chalkboard as CB

data SceneState = SceneState
	{ frame :: Int				-- counter
	, theTm :: UTCTime			-- to compute frame counts #
	, theBoard :: MVar (CB.Board CB.RGB)	-- The board to write the screen using
	, liveBoard :: (CB.Board CB.RGB) 	-- The board *written* to the screen
	, boardTexture :: TextureObject		-- where we draw the board
	, squares :: Int			-- how big are the pixels? 1x1, 2x2, ...
	, zoom :: Bool			        -- do you want to letterbox the output, or to fix to screen?
	}

data BoardViewerInit
        = WindowSize Int Int                    -- ^ initial window size
        | WindowPos  Int Int                    -- ^ initial window position
        | PixelSize Int                         -- ^ big pixels; great for prototyping
        | Zoom                                  -- ^ do we sample beyond the unit square (not yet supported)
        | Background CB.RGB                     -- ^ default background in non-zoom mode
        | FrameTarget Int                       -- ^ how many frames per second?
        
-- | 'initBoardViewer' never returns, and must be run from the main thread.
-- Two arguments should be provided; the inital window setup, and the MVar that
-- will contain the Board to be displayed.
initBoardViewer :: [BoardViewerInit] -> MVar (CB.Board CB.RGB) -> IO ()
initBoardViewer initInfos var =  do

  getArgsAndInitialize 

  initialDisplayMode $= [ DoubleBuffered, Multisampling ]

  sequence_ [ 
         case initInfo of
               WindowSize x y -> initialWindowSize $= Size (fromIntegral x) (fromIntegral y)
               WindowPos x y  -> initialWindowPosition $= Position (fromIntegral x) (fromIntegral y)
               _ -> return ()
    | initInfo <- initInfos ]

  let bgColor = head $ [ Color4 r g b 1
                       | Background (CB.RGB r g b) <- initInfos
                       ] ++ [Color4 1 1 1 (1 :: Float)]

  let frameTarget = head $ 
        [ frame' | FrameTarget frame' <- initInfos ] ++ [25]

  let sq = head $ 
        [ p |  PixelSize p <- initInfos ] ++ [1]


  let zoomQ = head $
        [ True | Zoom <- initInfos ] ++ [False]

     -- window starts at upper left corner of the screen

  createWindow "Chalkboard Viewer"

  multisample $= Enabled

  textureFunction $= Replace
  texture Texture2D $= Enabled

  pointSmooth $= Enabled
  hint PointSmooth $=Nicest

  lineSmooth $= Enabled
  hint LineSmooth $=Nicest

  polygonSmooth $= Enabled
  hint PolygonSmooth $=Nicest

  polygonMode $= (Fill,Fill)

  clearColor $= bgColor

  Size width height <- get windowSize
 
  tm <- getCurrentTime
  [texName] <- genObjectNames 1
  svar <- newIORef $ SceneState 1 tm var (CB.pure CB.white) texName sq zoomQ

  displayCallback $= (drawTheScene svar)

  reshapeCallback $= Just (resizeScene svar)

   -- 25 frames per second (optimistic!)
  let anim = addTimerCallback (1000 `div` frameTarget) $ do
			postRedisplay Nothing
			anim
  anim

  resizeScene svar (Size width height)
 
  mainLoop

-- changes state, hmm.
resizeScene :: IORef SceneState -> Size -> IO ()
resizeScene v (Size w 0) = resizeScene v (Size w 1) -- prevent divide by zero
resizeScene v s@(Size width height) = do
  scene <- readIORef v
  viewport   $= (Position 0 0, s)	-- the whole screen
  matrixMode $= Projection
  loadIdentity
  let w = fromIntegral width / 1
      h = fromIntegral height
  ortho2D (-w) w (-h) (h) --  (fromIntegral width / sz) 0 (fromIntegral height / sz)
  depthFunc $= Nothing
  matrixMode $= Modelview 0
  loadIdentity

  flush

  tryPutMVar (theBoard scene) (liveBoard scene)


  return ()

drawTheScene :: IORef SceneState -> IO ()
drawTheScene v = do
  scene <- readIORef v
  let n = frame scene
  let tm = theTm scene
  tm' <- getCurrentTime
  if (n `mod` 100 == 0) then do
      putStrLn $ show ((1 / (diffUTCTime tm' tm)) * 100) ++ " fps (" ++ show n ++ ")"
      writeIORef v (scene { frame = succ n, theTm = tm' })
    else writeIORef v (scene { frame = succ n })
  scene' <- readIORef v
  resp <- tryTakeMVar (theBoard scene')

  case resp of
     Nothing -> return ()	-- no redraw required 
     Just board -> do

	writeIORef v (scene' { liveBoard = board })

  	Size width height <- get windowSize

	let sz0 = min width height

	-- times 2, because we want the underlying surface to have details we can actually see via anti-aliasing
	let sz1 = 2 * fromIntegral sz0 `div` (squares scene')

	let sz2 = last $ takeWhile (<= sz1) (iterate (*2) 1) 
			
	let board1 = fmap (\ (CB.RGB r g b) -> Color3 (toW8 r) (toW8 g) (toW8 b)) board
	let board2 = CB.scale (fromIntegral sz2) $ CB.move (0.5,0.5) $ board1

        let arr = CB.boardToArray (sz2 - 1,sz2 - 1) 2 board2

        clearColor $= Color4 0 0 0 0 
  	clear [ColorBuffer] -- clear the screen

	buildTexture (boardTexture scene') $ arr
  	loadIdentity

  --      textureFilter Texture2D $= ((Linear',Nothing),Linear')

  	let wh = fromIntegral (min width height) / 1.0

  	renderPrimitive Quads $ do
            texCoord (TexCoord2 0 (0 :: Float))
            vertex (Vertex2 (-wh) (-wh :: Float))
            texCoord (TexCoord2 0 (1 :: Float))
            vertex (Vertex2 (-wh) (wh :: Float))
            texCoord (TexCoord2 1 (1 :: Float))
            vertex (Vertex2 wh (wh :: Float))
            texCoord (TexCoord2 1 (0 :: Float))
            vertex (Vertex2 wh (-wh :: Float))

  	swapBuffers

	return ()

------------------------------------------------------------------------------

-- The x direction needs to be a power of 2, both should really be a power of 2.
buildTexture :: TextureObject -> Array (Int,Int) (Color3 Word8) -> IO ()
buildTexture texName arr = do
  let (width,height) = case bounds arr of
 			 ((0,0),(w,h)) -> (w+1,h+1)
 			 _ -> error "failure in buildTexture"
  p <- mallocBytes (width * height * 3)		-- choice
  sequence_ [ case arr ! (w,h) of
	       (Color3 r g b) -> do pokeElemOff p (off+0) r
				    pokeElemOff p (off+1) g
				    pokeElemOff p (off+2) b
	    | (off,(w,h)) <- zip [0,3 ..] [ (w,h) | h <- [ 0 .. height - 1 ], w <- [ 0 .. width - 1 ], True]
	    ]

  textureBinding Texture2D $= Just texName
  textureFilter  Texture2D $= ((Nearest, Nothing), Nearest)

  textureWrapMode Texture2D S $= (Repeated, Repeat)	-- Hmm; not sure about this.
  textureWrapMode Texture2D T $= (Repeated, Repeat)

  let pd = PixelData RGB UnsignedByte p
  texImage2D Nothing NoProxy 0 RGB' (TextureSize2D (fromIntegral width) (fromIntegral height)) 0 pd
  free p
  return ()

toW8 :: Float -> Word8
toW8 n | n > 1 = 255
       | n < 0 = 0
       | otherwise = round (n * 255)

-- Having this here is a bit fishy.
instance CB.Average Word8 where
  average xs = floor (CB.average $ map (fromIntegral :: Word8 -> CB.UI) xs)

instance (CB.Average c) => CB.Average (Color3 c) where
  average cs = Color3 (CB.average reds) (CB.average greens) (CB.average blues)
     where
        reds   = [ r | Color3 r _ _ <- cs ]
        greens = [ g | Color3 _ g _ <- cs ]
        blues  = [ b | Color3 _ _ b <- cs ]