Render.hs

module Topkata.World.Render (drawWorld, inWall) where

import Topkata.World.Base
import Data.Array
import Data.List 
import Graphics.UI.GLUT
    (Vertex3(..), GLfloat(..), Normal3(..), Vector3(..),
     renderPrimitive, PrimitiveMode(..),
     normal, vertex, 
     translate,
     color, Color4(..))


borderWidth = 0.025

boxSelect SideFront  = [1, 2, 3, 4]
boxSelect SideBack   = [5, 6, 7, 8]
boxSelect SideLeft   = [1, 5, 8, 4]
boxSelect SideTop    = [1, 2, 6, 5]
boxSelect SideRight  = [2, 6, 7, 3]
boxSelect SideBottom = [4, 8, 7, 3]


cubicVertices (ix, iy, iz) =
    let x, y, z :: GLfloat
        x = fromIntegral ix - 1 
        y = fromIntegral iy - 1
        z = fromIntegral iz - 1
   in
    listArray (1, 8)
     [Vector3 x y (-z),
      Vector3 (x+1) y (-z),
      Vector3 (x+1) (y+1) (-z),
      Vector3 x (y+1) (-z),
      Vector3 x y (-z-1),
      Vector3 (x+1) y (-z-1),
      Vector3 (x+1) (y+1) (-z-1),
      Vector3 x (y+1) (-z-1)]

boxVertices pos block =
      [ [ vs ! s | s <- sel side] | side <- solidSides ]
    where vs = cubicVertices pos
          sel side   = boxSelect side
          solidSides = allSides \\ block


worldQuads world = [boxVertices pos block | (pos, block) <- assocs world ]

prod (Vector3 x1 y1 z1) (Vector3 x2 y2 z2) =
    Vector3
      (y1 * z2 - z1 * y2)
      (z1 * x2 - x1 * z2)
      (x1 * y2 - y1 * x2)


normalize (Vector3 x y z) = Vector3 (x/d) (y/d) (z/d)
  where d = sqrt (x*x+y*y+z*z)

vop op (Vector3 x y z) (Vector3 x' y' z') =
    Vector3 (op x x') (op y y') (op z z')

vdiff = vop (-)
vadd  = vop (+)
vscale (Vector3 x y z) s =  (Vector3 (x*s) (y*s) (z*s))
vneg (Vector3 x y z) = (Vector3 (-x) (-y) (-z))
v2n (Vector3 x y z) = Normal3 x y z
vec2vex (Vector3 x y z) = Vertex3 x y z

drawQuad vs = do
    mapM_ oneQuad vs
  where
    qnormal v1 v2 = normalize (prod v1 v2)
    oneQuad vs@(v1:v2:v3:v4:_) = 
      let  orthoV        = qnormal (vdiff v2 v1) (vdiff v3 v2)
           borderV       = vscale orthoV borderWidth
           bigSide       = map (vadd borderV) vs
                           
      in do
        renderPrimitive Quads $ do
            normal $ v2n orthoV
            mapM_ (vertex . vec2vex) bigSide
            mapM_ (vertex . vec2vex) vs 
        renderPrimitive QuadStrip $ do
                mapM_ (\ (v1, v2) -> do
                         -- putStrLn $ show (v1, (vadd v1 orthoV))
                         vertex (vec2vex v1)
                         vertex (vec2vex (vadd v1 borderV))
                         normal $ v2n $ qnormal (vdiff v2 v1) (vneg orthoV))
                  (zip (vs ++ [v1]) (tail vs ++ [v1, v2]))  
           

drawBoxAtPos world pos = drawQuad $ boxVertices pos block
 where block = world ! pos

drawWorld world pos = do
    --drawQuad $ take 4 $ head $ worldQuads world
    color (Color4 1 1 (1.0 :: GLfloat) 1.0)
    --color (Color4 1.0 1.0 (1.0 :: GLfloat) 1)
    mapM_ drawQuad $ worldQuads world
    --drawBoxAtPos world pos

inWall x = f < 2 * borderWidth  + 0.3
    where x'     =  abs (realToFrac x) + borderWidth
          (_, f) = properFraction x'