topkata-0.2.4: Labygen/Render.hs

module Labygen.Render 
  (render)
where

import Labygen
--import Graphics.UI.GLFW
import Graphics.Rendering.OpenGL
import Data.Array
import Data.Ix
import Debug.Trace
import Control.Monad ( when )
import Data.Maybe (isJust)

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

front  = [1, 2, 3, 4]
back   = [5, 6, 7, 8]
left   = [1, 5, 8, 4]
top    = [1, 2, 6, 5]
right  = [2, 6, 7, 3]
bottom = [4, 8, 7, 3]


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


vnormalize (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 l vs = do
  renderPrimitive Quads $ mapM_ oneQuad vs
  where
    qnormal v1 v2 = vnormalize (prod v1 v2)
    oneQuad vs@(v1@(Vector3 x1 y1 z1):v2:v3:v4:_) = 
      let  orthoV   = qnormal (vdiff v2 v1) (vdiff v3 v2)
      in do
        normal $ v2n orthoV 
        mapM_ (\ (Vector3 x y z, tc) -> do
                 texCoord tc
                 vertex (Vertex3 x y z)
              ) $ zip vs [TexCoord2 0 0, TexCoord2 l 0, TexCoord2 l l, TexCoord2 0 (l ::GLfloat)]


quadsOfBlock  _                Free  = []
quadsOfBlock (Pos3 (x, y, z))  Block = map idx2v [front, back, left, right, top, bottom]
   where vs    = cubicVertices  (x, y, z)
         idx2v  is = [vs !i | i <- is]


render :: Maybe TextureObject -> World Pos3 -> IO ()
render brickTex laby = do
    texture Texture2D $= Disabled
    preservingMatrix $ do
      color (Color4 1.0 1 (1 :: GLfloat) 1)
      renderPrimitive Quads $ do
          let y :: GLdouble
              y = 0 
              tr x = {- trace (show x) -} x
          normal $ Normal3 0 1 (0  :: GLdouble)
          vertex $ tr $ Vertex3 (-10) y (-10)
          vertex $ tr $ Vertex3 (f (x2 + 1 - x1 + 10)) y (-10)
          vertex $ tr $ Vertex3 (f (x2 + 1 - x1 + 10)) y (f (z2 + 1 - z1 + 10 ))
          vertex $ tr $ Vertex3 (-10) y (f (z2 + 1 - z1 + 10))
    texture Texture2D $= Enabled
    textureFunction $= Modulate
    when (isJust brickTex) $ textureBinding Texture2D $= brickTex
    sequence_ [drawQuad 5 (quadsOfBlock p b) | (p, b) <- assocs laby, b /= Free] 
    sequence_ [drawQuad 5 (quadsOfBlock p Block) | p <- border]
    return ()

  where (origin@(Pos3 (x1, y1, z1)), Pos3 (x2, y2, z2)) = bounds laby
        f :: Int -> GLdouble
        f                                     = fromIntegral
        border  = [Pos3 (x, y1, (z1-1)) | x <- [x1-1 .. x2+1] ] ++
                  [Pos3 (x, y1, (z2+1)) | x <- [x1-1 .. x2+1] ] ++
                  [Pos3 ((x1-1), y1, z) | z <- [z1-1 .. z2+1 ] ] ++
                  [Pos3 ((x2+1), y1, z) | z <- (z2+1):[z1-1 .. z2-1 ] ]