htrace/src/Scene/Renderer.hs

{-# LANGUAGE OverloadedStrings #-}
module Scene.Renderer (render) where

import Control.Applicative
import Control.Arrow
import Codec.Picture.Png
import Codec.Picture.Types
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import Data.Vector hiding ((++),map, foldl, filter, foldl1)
import Data.Word (Word8)
import Data.Maybe
import Linear

import Scene.Parser
import Scene.Types

import Debug.Trace

data Ray = Ray (V3 Float) (V3 Float)

-- | Collision position normal distance object
data Collision = Collision (V3 Float) (V3 Float) Float Collidable
                    deriving (Eq)

instance Ord Collision where
    compare (Collision _ _ a _) (Collision _ _ b _) = compare a b

render :: Int -> Int -> Scene -> Int -> PixelRGB8
render w h s index = PixelRGB8 (ci cr) (ci cg) (ci cb)
        where
            (V3 cr cg cb) =
                case raytrace ray s of
                  Nothing -> bgColor $ sceneBackground s
                  Just c@(Collision pos _ _ obj) ->
                         -- ambient lighting
                         ((*) <$> (ambColor . ambientLight $ s) <*> (materialAmbience . getMaterial $ obj))
                         -- + diffuse lighting
                         ^+^ (foldl1 (^+^) $ (diffuse c s) <$> sceneLights s)
                         -- + reflections - TODO
            ray = camRay x y (sceneCamera s)
            y = fromIntegral $ index `mod` w
            x = fromIntegral $ index `div` w
            ci = floor . (clamp 0 255) . (*255)
            --wrong format:
            --Ray (eye cam) $ rotCam x y w h (center cam ^-^ eye cam) (up cam) (fovy cam)
            --cam = sceneCamera s

diffuse :: Collision -> Scene -> Light -> V3 Float
diffuse (Collision pos n _ obj) s (Light lpos color int) =
            case blocked of
                Nothing                   -> ill
                Just (Collision _ _ dist _) -> if dist < norm lightdir
                                            then
                                                V3 0 0 0 --light is blocked -> no lighting from here.
                                            else
                                                ill
        where
            ill = (*) (dot n $ normalize lightdir) <$> illumination
            illumination = (*) <$> color ^* i <*> materialDiffuse mat
            mat = getMaterial obj
            blocked = raytrace (Ray pos lightdir) s
            lightdir = (lpos ^-^ pos)
            i = case int of
                    Nothing -> 1
                    Just a -> a

clamp :: Ord a => a -> a -> a -> a
clamp min max x
        | x < min = min
        | x > max = max
        | otherwise = x

raytrace :: Ray -> Scene -> Maybe Collision
raytrace r s = case possibleCollisions of
                    [] -> Nothing
                    _  -> Just $ foldl1 min possibleCollisions
               where
                    possibleCollisions :: [Collision]
                    possibleCollisions = map fromJust $ filter isJust $ (intersect r) <$> (sceneObjects s)

camRay :: Float -> Float -> Camera -> Ray
camRay x y c = Ray (eye c) (lowerLeft c ^+^ x *^ xDir c ^+^ y *^ yDir c ^-^ eye c)

rotateDegAx :: Float -> V3 Float -> V3 Float -> V3 Float
rotateDegAx phi axis = rotate q
                where
                    q = axisAngle axis phi

intersect :: Ray -> Collidable -> Maybe Collision
intersect (Ray ro rd) s@(S (Sphere sc sr _)) = if (d > 0 && int > 0) then
                                                Just (Collision pos (normalize $ pos ^-^ sc) int s)
                                              else
                                                Nothing
                                where
                                    a = dot rd rd
                                    b = 2 * dot rd oc
                                    c = dot oc oc - sr*sr
                                    d = b * b - 4 * a * c
                                    oc = ro ^-^ sc
                                    pos = ro ^+^ (rd ^* int)
                                    int = case ints of
                                            [] -> 0
                                            a  -> foldl1 min a
                                    ints = filter (uncurry (&&).(&&&) (>0.00001) (not.isNaN)) [(-b-(sqrt d))/(2*a),(-b+(sqrt d))/(2*a)]
intersect _ _ = undefined


-- deprecated - wrong calculation of rays.
rotCam :: Float -> Float -> Int -> Int -> V3 Float -> V3 Float -> Float -> V3 Float
rotCam x y w h dir up fovy = rotxy
            where
                rotxy = rotateDegAx (rad $ fovy*dy) (cross up roty) roty
                roty  = rotateDegAx (rad $ fovy*dx*(-1)) up dir
                dx = (x - (fromIntegral w) / 2)/(fromIntegral w)
                dy = (y - (fromIntegral h) / 2)/(fromIntegral h)
                rad = (*pi).(/180)