-- License: GPL v2 or later
{-# LANGUAGE ForeignFunctionInterface #-}

module Display(doDisplay, initDisplay) where

import Graphics.UI.GLUT
import qualified Sim
import Data.Array.Unboxed
import Data.Word(Word32)
import Control.Monad(when, unless, liftM2, forM_)
import System.Random
import ArrayUtils (arraySize)
import Foreign.Marshal.Array (withArray)
import Foreign.Ptr (Ptr)
import Foreign.C.Types (CFloat(CFloat))

-- This C code is for speed.  I first wrote this code before vertex buffers
-- even existed in the OpenGL standard (and before I knew about them);
-- it's quite likely that modern GHC and OpenGL (ES) 2.0 could be plenty fast
-- without using C code.
foreign import ccall unsafe "foreignPollution" foreignPollution :: Word32 -> Ptr Double -> Word32 -> Word32 -> IO ()

-- We don't use the Random instance of GLfloat (CFloat) directly
-- because it uses realToFrac which might be slow.
randomRIOGLF :: (Float, Float) -> IO GLfloat
randomRIOGLF range_ = do
  result <- randomRIO range_
  return (CFloat result)

initDisplay :: IO ()
initDisplay = do
	ortho2D 0 1 0 1
	blend $= Enabled ; blendFunc $= (SrcAlpha, OneMinusSrcAlpha)

-- Possibly the three int-like arguments should be better distinguished
-- or combined ("data TimeSituation"?) somehow.  Or even made into one
-- value, simStepsSinceLastUpdate(Float), which could be used fine as a random
-- seed (which ms is currently used for), most likely (just transform it appropriately).
-- TODO.
doDisplay :: Sim.World -> Int{-milliseconds per step-}
	-> Word32{-current time-} -> Word32{-last update time-} -> IO ()
doDisplay (Sim.World worldMap worldParticles worldCreatures worldPollution worldHour)
  msPerStep ms lastUpdateTime = do
	let simStepsSinceLastUpdate = fromIntegral (ms - lastUpdateTime) / fromIntegral msPerStep :: GLfloat
	let ((minX,minY),(maxX,maxY)) = bounds worldMap
	let (numX,numY) = (fromIntegral $ maxX + 1 - minX, fromIntegral $ maxY + 1 - minY)
	let rotationReference = Vector3 0 0 1 :: Vector3 GLfloat
	let distFromCenter = 0.5 :: GLfloat
	let translatingTo :: Integral coord => (coord,coord) -> IO a -> IO a
	    translatingTo (x,y) io = preservingMatrix $ do
			translate (Vector3 (fromIntegral x + distFromCenter) (fromIntegral y + distFromCenter) 0 :: Vector3 GLfloat)
			io
	preservingMatrix $ do
		scale (recip numX) (recip numY :: GLfloat) 1
		-- draw the floors
		--timeL "flor" $ 
		renderPrimitive Quads $ forM_ (assocs worldMap) $ \ ((x,y), _maybeMachine) -> do
			let (x',y') = (fromIntegral x :: GLfloat, fromIntegral y :: GLfloat)
			color (Color3 0.50 0.50 0.60 :: Color3 GLfloat); vertex (Vertex2  x'     y'    )
			color (Color3 0.45 0.55 0.45 :: Color3 GLfloat); vertex (Vertex2 (x'+1)  y'    )
			color (Color3 0.60 0.60 0.50 :: Color3 GLfloat); vertex (Vertex2 (x'+1) (y'+1) )
			color (Color3 0.40 0.35 0.40 :: Color3 GLfloat); vertex (Vertex2  x'    (y'+1) )
		-- draw the creatures (what about multiple creatures in the same place?
		-- I guess one just gets drawn first, then the next...)
		--timeL "cret" $ 
		forM_ worldCreatures $ \ (loc, creature) -> translatingTo loc $ do
		    case creature of
			Sim.Water _rng -> do
				color (Color4 0.4 0.5 0.9 0.6 :: Color4 GLfloat)
				renderPrimitive Quads $ do
					let shortDist = 0.5 :: GLfloat
					let longDist = 0.5 :: GLfloat
					vertex $ Vertex2 (-longDist) (-shortDist)
					vertex $ Vertex2 ( longDist) (-shortDist)
					vertex $ Vertex2 ( longDist) ( shortDist)
					vertex $ Vertex2 (-longDist) ( shortDist)
			Sim.Creature { Sim.creatureEnergy = energy } -> do
				renderPrimitive Quads $ do
					let legSpread = 0.35 :: GLfloat
					let legHeight = -0.4 :: GLfloat
					let waistSpread = 0.2 :: GLfloat
					let waistHeight = 0 :: GLfloat
					let armSpread = 0.3 :: GLfloat
					let shoulderSpread = 0.2 :: GLfloat
					let neckSpread = 0.1 :: GLfloat
					let neckHeight = 0.2 :: GLfloat
					let headHeight = 0.45 :: GLfloat
					let headSpread = 0.2 :: GLfloat
					color (Color3 0.5 0.5 (0.7 + realToFrac energy / 20) :: Color3 GLfloat)
					vertex $ Vertex2 (-legSpread) (legHeight)
					vertex $ Vertex2 ( legSpread) (legHeight)
					vertex $ Vertex2 ( waistSpread) (waistHeight)
					vertex $ Vertex2 (-waistSpread) (waistHeight)
					color (Color3 0.4 0.9 0.6 :: Color3 GLfloat)
					vertex $ Vertex2 (-armSpread) (waistHeight)
					vertex $ Vertex2 ( armSpread) (waistHeight)
					vertex $ Vertex2 ( shoulderSpread) (neckHeight)
					vertex $ Vertex2 (-shoulderSpread) (neckHeight)
					color (Color3 0.9 0.7 0.5 :: Color3 GLfloat)
					vertex $ Vertex2 (-neckSpread) (neckHeight)
					vertex $ Vertex2 ( neckSpread) (neckHeight)
					vertex $ Vertex2 ( headSpread) (headHeight)
					vertex $ Vertex2 (-headSpread) (headHeight)
		-- draw the particles (what relation to machines? what about the dangerous particles?)
		--timeL "part" $ 
		forM_ worldParticles $ \ (loc, Sim.Particle dir pType) -> translatingTo loc $ do
		    rotate (Sim.dirAngle dir) rotationReference
		    translate (Vector3 (simStepsSinceLastUpdate) 0 0)
		    --hmm, could separate list by particle-type and
		    --encompass more with each renderPrimitive...
		    case pType of
		    	Sim.Energy strength -> do
				color (Color4 0.9 0.9 0.2 (log $ fromIntegral strength) :: Color4 GLfloat)
				renderPrimitive Quads $ do
					let shortDist = 0.15 :: GLfloat
					let longDist = 0.25 :: GLfloat
					vertex $ Vertex2 (-longDist) (-shortDist)
					vertex $ Vertex2 ( longDist) (-shortDist)
					vertex $ Vertex2 ( longDist) ( shortDist)
					vertex $ Vertex2 (-longDist) ( shortDist)
			-- could draw this after the machines...
			Sim.Chaos _rng -> do
				let
					io :: IO ()
					io = do
						alpha1 <- randomRIOGLF (0.7,1.0)
						color (Color4 0.7 0.2 0.7 alpha1 :: Color4 GLfloat)
						let randPos = randomRIOGLF (-0.5, 0.5)
						let randVertex = vertex =<< liftM2 Vertex2 randPos randPos
						randVertex ; randVertex ; randVertex
						randVal <- randomRIO (1, 10 :: Int)
						unless (randVal == 1) io
				renderPrimitive Triangles $ io
		
		-- draw the machines
		--timeL "mach" $ 
		forM_ [(l,m) | (l,Just m) <- assocs worldMap] $ \ (loc,machine) -> translatingTo loc $ do
		    case machine of
			Sim.Generator dir energy -> do
				rotate (Sim.dirAngle dir) (Vector3 0 0 1 :: Vector3 GLfloat)
				renderPrimitive Quads $ do
					let dist = 0.3 :: GLfloat
					color (Color3 0.6 0.6 0.6 :: Color3 GLfloat)
					vertex $ Vertex2 (-dist) (-dist)
					vertex $ Vertex2 ( dist) (-dist)
					vertex $ Vertex2 ( dist) ( dist)
					vertex $ Vertex2 (-dist) ( dist)
					let shortDist = 0.1 :: GLfloat
					let yellow = fromIntegral energy / 10
					color (Color3 yellow yellow 0.0 :: Color3 GLfloat)
					vertex $ Vertex2 (-shortDist) (-shortDist)
					vertex $ Vertex2 ( dist) (-shortDist)
					vertex $ Vertex2 ( dist) ( shortDist)
					vertex $ Vertex2 (-shortDist) ( shortDist)
			Sim.Mirror mdir lSilvered rSilvered -> do
				rotate (case mdir of { Sim.NW_SE -> 0; Sim.SW_NE -> -90 } :: GLfloat) rotationReference
				let
					dist = 0.25 :: GLfloat
					silverDepth = 0.07 -- orthogonal, in both directions
				renderPrimitive Quads $ do
					color (Color3 0.9 0.9 0.9 :: Color3 GLfloat)
					vertex $ Vertex2 (-dist) (distFromCenter)
					vertex $ Vertex2 (distFromCenter) (-dist)
					vertex $ Vertex2 (dist) (-distFromCenter)
					vertex $ Vertex2 (-distFromCenter) (dist)
					
					color (Color3 0.7 0.7 0.8 :: Color3 GLfloat)
					when lSilvered $ do
						vertex $ Vertex2 (-(distFromCenter-silverDepth)) (dist+silverDepth)
						vertex $ Vertex2 (dist+silverDepth) (-(distFromCenter-silverDepth))
						vertex $ Vertex2 (dist) (-distFromCenter)
						vertex $ Vertex2 (-distFromCenter) (dist)
					
					when rSilvered $ do
						vertex $ Vertex2 (-dist) (distFromCenter)
						vertex $ Vertex2 (distFromCenter) (-dist)
						vertex $ Vertex2 (distFromCenter-silverDepth) (-(dist+silverDepth))
						vertex $ Vertex2 (-(dist+silverDepth)) (distFromCenter-silverDepth)
			Sim.Greenery -> do
				renderPrimitive Polygon $ do
					color (Color3 0.2 0.9 0.3 :: Color3 GLfloat)
					vertex $ Vertex2 (-0.3) (0.2 :: GLfloat)
					vertex $ Vertex2 (0) (distFromCenter)
					vertex $ Vertex2 (0.3) (0.2 :: GLfloat)
					vertex $ Vertex2 (0.5) (-0.3 :: GLfloat)
					vertex $ Vertex2 (0.3) (-0.4 :: GLfloat)
					vertex $ Vertex2 (0.1) (-0.35 :: GLfloat)
					vertex $ Vertex2 (-0.1) (-0.35 :: GLfloat)
					vertex $ Vertex2 (-0.3) (-0.4 :: GLfloat)
					vertex $ Vertex2 (-0.5) (-0.3 :: GLfloat)
				renderPrimitive Triangles $ do
					color (Color3 0.6 0.4 0.3 :: Color3 GLfloat)
					let trunkWidth = 0.1 :: GLfloat
					let trunkY = 0.25 :: GLfloat
					vertex $ Vertex2 (0) (trunkY)
					vertex $ Vertex2 (trunkWidth) (-distFromCenter)
					vertex $ Vertex2 (-trunkWidth) (-distFromCenter)
					let branchTipY = -0.1 :: GLfloat
					let branchTipX = 0.25 :: GLfloat
					let branchStartHigh = -0.3 :: GLfloat
					let branchStartLow = -0.4 :: GLfloat
					vertex $ Vertex2 (0) (branchStartHigh)
					vertex $ Vertex2 (branchTipX) (branchTipY)
					vertex $ Vertex2 (0) (branchStartLow)

					vertex $ Vertex2 (0) (branchStartHigh)
					vertex $ Vertex2 (-branchTipX) (branchTipY)
					vertex $ Vertex2 (0) (branchStartLow)
			Sim.Storm energy _rng -> do
				let
					io :: Double -> Int -> IO ()
					io amount side = do
						alpha1 <- randomRIOGLF (0.7,1.0)
						color (Color4 0.4 0.3 0.7 alpha1 :: Color4 GLfloat)
						let randPos a b = randomRIOGLF (a, b)
						let randVertex = [
							vertex =<< liftM2 Vertex2 (randPos 0 0.5) (randPos (-0.5) 0.5),
							vertex =<< liftM2 Vertex2 (randPos (-0.5) 0) (randPos (-0.5) 0.5),
							vertex =<< liftM2 Vertex2 (randPos (-0.5) 0.5) (randPos 0 0.5),
							vertex =<< liftM2 Vertex2 (randPos (-0.5) 0.5) (randPos (-0.5) 0)]
							 !! side
						randVertex ; randVertex ; randVertex
						unless (amount < 0) ( io (amount - 1) ( (side + 1) `mod` 4 ) )
				renderPrimitive Triangles $ io ((energy+2) * 4) 0
			Sim.Mountain -> do
				-- How about shadows i.e. "The sun rises in the east"?
				renderPrimitive Triangles $ do
					let width = 0.3 :: GLfloat
					let height = 0.4 :: GLfloat
					let offsetX = 0.15 :: GLfloat
					let offsetY = 0.35 :: GLfloat
					color (Color3 0.45 0.4 0.35 :: Color3 GLfloat)
					vertex $ Vertex2 ((-width)-offsetX) (offsetY-0.1)
					vertex $ Vertex2 (-offsetX) (height+offsetY-0.1)
					vertex $ Vertex2 (width-offsetX) (offsetY-0.1)
					color (Color3 0.25 0.2 0.15 :: Color3 GLfloat)
					vertex $ Vertex2 ((-width)+offsetX) (offsetY)
					vertex $ Vertex2 (offsetX) (height+offsetY)
					vertex $ Vertex2 (width+offsetX) (offsetY)
					color (Color3 0.35 0.4 0.45 :: Color3 GLfloat)
					vertex $ Vertex2 (-width) (0)
					vertex $ Vertex2 (0) (height)
					vertex $ Vertex2 (width) (0)
					color (Color3 0.2 0.2 0.2 :: Color3 GLfloat)
					vertex $ Vertex2 ((-width)-offsetX) (-offsetY)
					vertex $ Vertex2 (-offsetX) (height-offsetY)
					vertex $ Vertex2 (width-offsetX) (-offsetY)
					color (Color3 0.3 0.4 0.3 :: Color3 GLfloat)
					vertex $ Vertex2 ((-width)+offsetX) ((-offsetY)+0.05)
					vertex $ Vertex2 (offsetX) ((height-offsetY)+0.05)
					vertex $ Vertex2 (width+offsetX) ((-offsetY)+0.05)
			Sim.Riverbed{} -> error "Unimplemented yet"

		-- draw the pollution!
		-- (the 'resolution' should depend on windowsize / (i.e.?) number of places displayed)
		-- currently just 5x5 per place though
		-- should it be invisible where really low?
		do
			let (width, height) = arraySize worldPollution
			-- marshalling takes about 1 ms by last measurement
			withArray (elems worldPollution) (\cArr -> foreignPollution ms cArr (fromIntegral width) (fromIntegral height))
		-- draw the night-time! (er.) (HACK!!!)
		do
			let dayFraction = case worldHour of Sim.WorldHour h -> (realToFrac h + simStepsSinceLastUpdate) / realToFrac Sim.dayLength
			let dayLight = if dayFraction >= 0.5 then 0 else sin (dayFraction * pi * 2)
			let nightMasking = (1 - dayLight) / 2 /10--since it doesn't do anything
			color (Color4 0.1 0.1 0.3 nightMasking :: Color4 GLfloat)
			renderPrimitive Quads $ do
				vertex $ Vertex2 0 (0::GLfloat)
				vertex $ Vertex2 numX (0::GLfloat)
				vertex $ Vertex2 numX numY
				vertex $ Vertex2 0 numY

	swapBuffers
	reportErrors