module Main where

import Graphics.UI.GLUT
import Data.List
import Data.IORef
import Control.Monad
import Control.Parallel.Strategies
import System.CPUTime

type Red = Float
type Green = Float
type Blue = Float
type Alpha = Float

data VoxelColor = VoxelColor Red Green Blue Alpha

initialWindowSizeWidth :: GLsizei
initialWindowSizeWidth = 400

initialWindowSizeHeight :: GLsizei
initialWindowSizeHeight = 300

pixelResolution :: Float
pixelResolution = 1.0

fieldOfView :: Float
fieldOfView = pi / 3.0 -- in radians

depthOfField :: Int
depthOfField = 81

approxEqual :: Float -> Float -> Bool
approxEqual x y = abs (x - y) <= epsilon
                    where epsilon = 0.5

sphere :: Float -> Float -> Float -> Float -> Float -> Float -> Float -> Maybe VoxelColor
sphere x y z x0 y0 z0 r
  | x' ** 2.0 + y' ** 2.0 + z' ** 2.0 <= r ** 2.0 = Just (VoxelColor 1.0 0.0 0.0 1.0)
  | otherwise = Nothing
    where x' = x - x0
          y' = y - y0
          z' = z - z0

cube :: Float -> Float -> Float -> Float -> Float -> Float -> Float -> Maybe VoxelColor
cube x y z x0 y0 z0 a
  | (0 <= x') && (x' <= a) && (y' `approxEqual` 0) && (z' `approxEqual` 0) = Just (VoxelColor 1.0 1.0 1.0 1.0)
  | (0 <= y') && (y' <= a) && (x' `approxEqual` 0) && (z' `approxEqual` 0) = Just (VoxelColor 1.0 1.0 1.0 1.0)
  | (0 <= z') && (z' <= a) && (x' `approxEqual` 0) && (y' `approxEqual` 0) = Just (VoxelColor 1.0 1.0 1.0 1.0)
  | (0 <= x') && (x' <= a) && (y' `approxEqual` a) && (z' `approxEqual` 0) = Just (VoxelColor 1.0 1.0 1.0 1.0)
  | (0 <= y') && (y' <= a) && (x' `approxEqual` a) && (z' `approxEqual` 0) = Just (VoxelColor 1.0 1.0 1.0 1.0)
  | (0 <= z') && (z' <= a) && (x' `approxEqual` a) && (y' `approxEqual` 0) = Just (VoxelColor 1.0 1.0 1.0 1.0)
  | (0 <= x') && (x' <= a) && (y' `approxEqual` 0) && (z' `approxEqual` a) = Just (VoxelColor 1.0 1.0 1.0 1.0)
  | (0 <= y') && (y' <= a) && (x' `approxEqual` 0) && (z' `approxEqual` a) = Just (VoxelColor 1.0 1.0 1.0 1.0)
  | (0 <= z') && (z' <= a) && (x' `approxEqual` 0) && (y' `approxEqual` a) = Just (VoxelColor 1.0 1.0 1.0 1.0)
  | (0 <= x') && (x' <= a) && (y' `approxEqual` a) && (z' `approxEqual` a) = Just (VoxelColor 1.0 1.0 1.0 1.0)
  | (0 <= y') && (y' <= a) && (x' `approxEqual` a) && (z' `approxEqual` a) = Just (VoxelColor 1.0 1.0 1.0 1.0)
  | (0 <= z') && (z' <= a) && (x' `approxEqual` a) && (y' `approxEqual` a) = Just (VoxelColor 1.0 1.0 1.0 1.0)
  | (0 <= x') && (x' <= a / 2) && (x' <= y') && (y' <= a - x') && (x' <= z') && (z' <= a - x') = Just (VoxelColor 1.0 0.0 0.0 1.0)
  | (a / 2 <= x') && (x' <= a) && (a - x' <= y') && (y' <= x') && (a - x' <= z') && (z' <= x') = Just (VoxelColor 0.0 1.0 0.0 1.0)
  | (0 <= y') && (y' <= a / 2) && (y' <= x') && (x' <= a - y') && (y' <= z') && (z' <= a - y') = Just (VoxelColor 0.0 0.0 1.0 1.0)
  | (a / 2 <= y') && (y' <= a) && (a - y' <= x') && (x' <= y') && (a - y' <= z') && (z' <= y') = Just (VoxelColor 1.0 1.0 0.0 1.0)
  | (0 <= z') && (z' <= a / 2) && (z' <= y') && (y' <= a - z') && (z' <= x') && (x' <= a - z') = Just (VoxelColor 1.0 0.0 1.0 1.0)
  | (a / 2 <= z') && (z' <= a) && (a - z' <= y') && (y' <= z') && (a - z' <= x') && (x' <= z') = Just (VoxelColor 0.0 1.0 1.0 1.0)
  | otherwise = Nothing
    where x' = x - x0
          y' = y - y0
          z' = z - z0

world :: (Float, Float, Float) -> VoxelColor -- TODO
world (x, y, z) = case sphere1 `mplus` sphere2 `mplus` sphere3 `mplus` cube1 `mplus` cube2 `mplus` cube3 `mplus` cube4 `mplus` cube5 `mplus` cube6 `mplus` cube7 `mplus` cube8 `mplus` cube9 `mplus` cube10 `mplus` cube11 `mplus` cube12 of 
                    Just v -> v
                    Nothing -> VoxelColor 0.0 0.0 0.0 0.0
                    where sphere1 = (sphere x y z 340.0 200.0 60.0 20.0)
                          sphere2 = (sphere x y z 60.0 100.0 60.0 20.0) 
                          sphere3 = (sphere x y z 200.0 150.0 60.0 20.0) 
                          cube1 = (cube x y z 360.0 260.0 0.0 40.0)
                          cube2 = (cube x y z 0.0 0.0 0.0 40.0)
                          cube3 = (cube x y z 360.0 0.0 0.0 40.0)
                          cube4 = (cube x y z 0.0 260.0 0.0 40.0)
                          cube5 = (cube x y z 320.0 220.0 40.0 40.0)
                          cube6 = (cube x y z 40.0 40.0 40.0 40.0)
                          cube7 = (cube x y z 320.0 40.0 40.0 40.0)
                          cube8 = (cube x y z 40.0 220.0 40.0 40.0)
                          cube9 = (cube x y z 260.0 180.0 40.0 40.0)
                          cube10 = (cube x y z 100.0 80.0 40.0 40.0)
                          cube11 = (cube x y z 260.0 80.0 40.0 40.0)
                          cube12 = (cube x y z 100.0 180.0 40.0 40.0)

main :: IO ()
main = do
  getArgsAndInitialize 
  initialDisplayMode $= [RGBMode, DoubleBuffered]
  initialWindowSize $= Size initialWindowSizeWidth initialWindowSizeHeight
  createWindow "Voxel"
  
  projectionRays <- newIORef [] -- a list of all rays
  
  let display = do
        clear [ColorBuffer]
        rays <- readIORef projectionRays
        
        putStrLn $ "render start" 
        start <- getCPUTime
        sequence_ $ parMap rwhnf drawRay rays
        stop <- getCPUTime
        putStrLn $ "render stop, " ++ show (fromIntegral (stop - start) / 1000000000000.0 :: Double) ++ " s elapsed"
        
        swapBuffers
        
        where drawRay [] = do return ()
              drawRay ray@((x, y, _):_) = do
                currentColor $= Color4 red green blue alpha
                renderPrimitive Points $ do vertex (Vertex2 x y)
                
                where VoxelColor red green blue alpha = follow ray
                        where follow ray' = follow' (VoxelColor 0.0 0.0 0.0 0.0) ray'
                                where follow' v [] = v
                                      follow' v@(VoxelColor _ _ _ a) _ | a >= 0.999 = v
                                      follow' (VoxelColor _ _ _ a) (r:rs) | a <= 0.001 = follow' (world r) rs
                                      follow' v (r:rs) = follow' (addColor v (world r)) rs
                                      addColor (VoxelColor r1 g1 b1 a1) (VoxelColor r2 g2 b2 a2) = VoxelColor r' g' b' a' -- color 1 is "over" color 2
                                                where r' = r1 + (1.0 - a1) * r2
                                                      g' = g1 + (1.0 - a1) * g2
                                                      b' = b1 + (1.0 - a1) * b2
                                                      a' = a1 + a2 * (1.0 - a1)
  
  displayCallback $= display
  
  let reshape size@(Size width height) = do
        writeIORef projectionRays rays
        
        viewport $= (Position 0 0, size)
        
        matrixMode $= Projection
        loadIdentity
        ortho2D 0.0 pwidth 0.0 pheight
        
        matrixMode $= Modelview 0
        loadIdentity
        
        where pwidth = fromIntegral (truncate $ (fromIntegral width) * pixelResolution :: Int)
              pheight = fromIntegral (truncate $ (fromIntegral height) * pixelResolution :: Int)
              maxX = (realToFrac pwidth) - 1.0 :: Float
              maxY = (realToFrac pheight) - 1.0 :: Float
              screen = [(x, y) | x <- [0.0..maxX], y <- [0.0..maxY]]
              rays = parMap rwhnf (depth . ray) screen :: [[(Float, Float, Float)]]
                where depth r = take depthOfField r
                      ray (x, y) = unfoldr cast 0.0 :: [(Float, Float, Float)]
                        where iX = -(maxX / 2.0 - x)
                              iY = -(maxY / 2.0 - y)
                              fiX = iX * fieldOfView / maxX
                              fiY = iY * fieldOfView / maxY
                              cast z = Just ((x', y', z), z + 1.0)
                                where x' = x + (tan fiX) * z
                                      y' = y + (tan fiY) * z
  
  reshapeCallback $= Just reshape
  
  let motion pos = do
        putStrLn $ "motion: " ++ show pos
  
  motionCallback $= Just motion
  
  matrixMode $= Modelview 0
  loadIdentity
  
  mainLoop