module Object.Sphere where

import Control.Applicative
import Data.Sequence

import AABB
import Colour
import Mesh
import Vec
import Ray
import Texture
import Object.Object

-------------------------------------------------------------------------------
-- Sphere
data Sphere = Sphere Vector3 Texture Material Double String

instance Show Sphere where
    show (Sphere o _ _ r i) = i ++ "::" ++ show o ++ "::" ++ show r

{- instance Show Sphere where -}
    {- [>show (Sphere o _ _ r _) = "-Sphere " ++ show o ++ "::" ++ show r ++ "-"<] -}
    {- show = getID -}

mkSphere :: Vector3 -> Texture -> Material -> Double -> String -> SceneObject
mkSphere = ((((SO.).).).) . Sphere

instance SceneObjectC Sphere where

    getMaterial (Sphere _ _ m _ _) = m
    getTexture  (Sphere _ t _ _ _) = t
    getID (Sphere _ _ _ _ i)       = i

    isIntersect (Ray oR dirR) (Sphere oS _ _ r _) =
        (isHit, Just $ singleton a |> b |> disc)
        where
            a      = vdot dirR dirR
            oc     = oR - oS
            b      = (2 |* dirR) `vdot` oc
            c      = (vdot oc oc) - r**2
            disc   = b**2 - 4*a*c
            isHit  = disc > eps

    intersectRay (Ray oR dirR) memVals s@(Sphere oS _ _ r _) =
        boolToMaybe isHit $ Intersection pnt dist (SO s)
        where
            oc   = oR - oS
            a    = maybe (vdot dirR dirR) (`index` 0) memVals
            b    = maybe (2 * dirR `vdot` oc) (`index` 1) memVals
            c    = (vdot oc oc) - r**2
            disc = maybe (b**2 - 4*a*c) (`index` 2) memVals

            rtDisc = sqrt disc
            inv_2a = 1 / (2*a)
            dist1  = -b - rtDisc
            dist2  = rtDisc - b -- the far distance
            dist   = (*inv_2a) $ if (dist1 > eps)
                                    then dist1
                                        else if (dist2 > eps)
                                                then dist2
                                                else 0.0
            pnt    = dist |* dirR + oR
            isHit  = dist /= 0.0

    isIntersectAABB (AABB (V3 bcx bcy bcz) (V3 hx hy hz)) (Sphere (V3 sx sy sz) _ _ sr _) =
        maybe False (<= (sr**2)) dmin
        where
            bxMin = bcx-hx
            byMin = bcy-hy
            bzMin = bcz-hz
            bxMax = bcx+hx
            byMax = bcy+hy
            bzMax = bcz+hz
            exMin = sx-bxMin
            eyMin = sy-byMin
            ezMin = sz-bzMin
            exMax = sx-bxMax
            eyMax = sy-byMax
            ezMax = sz-bzMax

            sr' = sr - eps

            testAxis emin emax =
                if emin < 0
                   then if emin < (-sr')
                           then Nothing
                           else Just (emin**2)
                   else if emax > 0
                           then if emax > sr'
                                   then Nothing
                                   else Just (emax**2)
                           else Just 0

            dmin = ((+).).(+) <$> testAxis exMin exMax
                              <*> testAxis eyMin eyMax
                              <*> testAxis ezMin ezMax

    isInSlab a c1 c2 (Sphere os _ _ rs _) =
        let c = getVec3 a os
        in  ((c1 - c) < rs) && ((c - c2) < rs)

    normAt p (Sphere origin _ _ _ _) = vnormalise $ p - origin
    translateS p (Sphere o t m r i)  = mkSphere (o+p) t m r i
    rotateS _ = SO

    pointToUV p (Sphere origin _ _ r _) = (u, v)
        where
            p'@(V3 x y _) = p - origin
            mag                = sqrt (p' `vdot` p')
            u'                 = x / mag
            v'                 = y / mag
            u                  = (u' + 1) / 2
            v                  = (v' + 1) / 2

    boundary axis (Sphere origin _ _ r _) = [b1, b2]
        where
            on = onVec3 axis id
            b1 = on origin - r -- - eps
            b2 = on origin + r -- + eps

