jort-1.0.0: Trace.hs

module Trace where

import Basics
import Objects
import Lights
import Colors
import Data.List(delete, minimumBy)
import World
import Debug.Trace
import Env

maxLevel = 4

minIntensity = 0.01

switchInside objectId insideList =
    if objectId `elem` insideList
       then delete objectId insideList
       else objectId : insideList

traceRay level world from dir insideList refrCoef = color
    where (hitDist, hitObject) = 
	      minimumBy compFst distances
	  distances = [(distance from dir obj, obj) | obj <- worldObjects world]
	  color = if hitDist == infinite 
		    then envColor
		    else objectColor
	  envColor = worldEnv world $ dir
	  objectColor = diffuseColor +  
			if level < maxLevel
			   then reflectionCol + refractionCol
			   else blackColor

	  (objectRefl, objectRefr) = 
	      if critic > 0
		 then (materialReflection hitMaterial, materialRefraction hitMaterial)
		 else (materialReflection hitMaterial + materialRefraction hitMaterial, 0)

          hitMaterial = hitTexture hit

          reflectionCol = objectRefl <*> traceRay (level+1) world
			  (hit+reflectionDir) reflectionDir insideList
                          refrCoef
	  refractionCol = objectRefr <*> traceRay (level+1) world
			  (hit+refractionDir) refractionDir (switchInside hitId insideList)
			  (materialRefrCoef hitMaterial)
  
          col1 <*> col2 = if intensity col1 > minIntensity
			    then col1 * col2
			    else blackColor

          ratio = refrCoef / (materialRefrCoef hitMaterial)

	  hit = hitDist `scale` dir + from
	  ci = normal .* dir
	  critic = 1 + sq ratio * (sq ci - 1) -- 1 / sq ratio + sq ci - 1

	  reflectionDir = dir - (2 * ci) `scale` normal 
	  refractionDir = ratio `scale` dir - (ratio * ci - sqrt critic) `scale` normal
             	          -- ratio `scale` (dir - (ci - sqrt critic) `scale` normal)
	  normal' = getNormal hitObject hit

	  normal = if normal' `dotProd` dir < 0 then negate normal' else normal'

	  Object hitId hitShape hitTexture = hitObject

	  diffuseColor = sum $
			 map (lighten world hitMaterial hit normal') $
			 worldLights world 
	  
	  

    
compFst (x, _) (y, _) = compare x y