PointOfView.hs

module Test.PointOfView where

import Graphics.Rendering.OpenGL
import Graphics.UI.GLUT
import Data.IORef
import System(ExitCode(..), exitWith)
import Data.List (nub)
-- import Graphics.UI.GLUT ( Key(SpecialKey, Char) )

setPointOfView :: IORef [Key] -> IORef (GLdouble,GLdouble,GLdouble, GLdouble,GLdouble,GLdouble, GLdouble,GLdouble,GLdouble) -> IO ()
setPointOfView ks pPos = do
  keystate <- get ks
  if Char 'w' `elem` keystate then do move_vw pPos 0.01          -- vorward
                                      postRedisplay Nothing
                              else return()
  if Char 's' `elem` keystate then do move_vw pPos (negate 0.01) -- backward
                                      postRedisplay Nothing
                              else return()
  if Char 'a' `elem` keystate then do strafe pPos  (0.01)        -- left
                                      postRedisplay Nothing
                              else return()
  if Char 'd' `elem` keystate then do strafe pPos  (negate 0.01)
                                      postRedisplay Nothing     -- right
                              else return()
  if (SpecialKey KeyLeft)  `elem` keystate then do rot pPos (0,negate 0.002)
                                                   postRedisplay Nothing
                                           else return()
  if (SpecialKey KeyRight) `elem` keystate then do rot pPos (0, 0.002)
                                                   postRedisplay Nothing
                                           else return()
  if (SpecialKey KeyUp)    `elem` keystate then do rot pPos (0.002, 0)
                                                   postRedisplay Nothing
                                           else return()
  if (SpecialKey KeyDown)  `elem` keystate then do rot pPos (negate 0.002,0)
                                                   postRedisplay Nothing
                                           else return()
  (x,y,z,lx,ly,lz,ux,uy,uz) <- get pPos
  lookAt (Vertex3 x y z) (Vertex3 lx ly lz) (Vector3 ux uy uz) -- x y z: the point where the viewer is situated
                                                               -- lx ly lz: the point at which the viewer is looking
															   -- ux uy uz: a vector, which is up for the viewer

keyboard :: IORef [Key] -> Key -> KeyState -> t -> t1 -> IO ()
keyboard keystate key ks _ _ = do
  case (key,ks) of
    (Char '\27',_) -> do exitWith ExitSuccess
    (Char 'q',_) -> do exitWith ExitSuccess
    (_,Down) -> modifyIORef keystate $ nub . (++[key])
    (_,Up) -> modifyIORef keystate $ filter (/=key)

--move_vw :: IORef (GLdouble,GLdouble,GLdouble,GLdouble,GLdouble,GLdouble,GLdouble,GLdouble,GLdouble) -> GLdouble -> IO ()
move_vw pPos delta = do
  (x,y,z,lx,ly,lz,ux,uy,uz) <- get pPos
  let dx = (lx-x)*delta
      dy = (ly-y)*delta
      dz = (lz-z)*delta
  pPos $= (x+dx, y+dy, z+dz, lx+dx, ly+dy, lz+dz, ux,uy,uz)

kreuz (v0,v1,v2) (w0,w1,w2) = (v1*w2-v2*w1, v2*w0-v0*w2, v0*w1-v1*w0)
kreuz2 (v0,v1,v2,pr) (w0,w1,w2,_) = (v1*w2-v2*w1, v2*w0-v0*w2, v0*w1-v1*w0, pr)
set_len (x,y,z) l = (x*c*l, y*c*l, z*c*l) where c = 1 / v_len (x,y,z)
v_len (x,y,z) = sqrt (x*x+y*y+z*z)

strafe pPos delta = do
  (x,y,z,lx,ly,lz,ux,uy,uz) <- get pPos
  let (dx, dy, dz) = set_len (kreuz (x-lx,y-ly,z-lz) (ux,uy,uz)) delta
  pPos $= (x+dx, y+dy, z+dz, lx+dx, ly+dy, lz+dz, ux,uy,uz)

divide (x,y,z) c = (x/c, y/c, z/c)
mul (x,y,z) c = (x*c, y*c, z*c)

rot pPos (alpha, beta) = do
  (px,py,pz,lx,ly,lz,ux,uy,uz) <- get pPos
  return (set_len (ux,uy,uz) (v_len (lx-px,ly-py,lz-pz)))
  let lx_alpha = px + (lx-px)*(cos alpha) + ux*(sin alpha)
      ly_alpha = py + (ly-py)*(cos alpha) + uy*(sin alpha)
      lz_alpha = pz + (lz-pz)*(cos alpha) + uz*(sin alpha)
      ux_alpha =    - (lx-px)*(sin alpha) + ux*(cos alpha)
      uy_alpha =    - (ly-py)*(sin alpha) + uy*(cos alpha)
      uz_alpha =    - (lz-pz)*(sin alpha) + uz*(cos alpha)
      k = (kreuz (lx_alpha-px, ly_alpha-py, lz_alpha-pz) (ux_alpha, uy_alpha, uz_alpha))
      (kx,ky,kz) = (k `divide` (v_len k)) `mul` (v_len (ux, uy, uz))

  pPos $= (px, py, pz,
           px + (lx_alpha-px)*(cos beta) + kx*(sin beta),
		   py + (ly_alpha-py)*(cos beta) + ky*(sin beta),
           pz + (lz_alpha-pz)*(cos beta) + kz*(sin beta),
           ux_alpha, uy_alpha, uz_alpha)

idle pPos = do
  postRedisplay Nothing

reshape screenSize@(Size w h) = do
  viewport $= ((Position 0 0), screenSize)
  matrixMode $= Projection
  loadIdentity
  let near = 0.001
      far  = 40
      fov  = 90
      ang  = (fov*pi)/(360) -- equals 45 degree
      top  = near / ( cos(ang) / sin(ang) ) -- top/near has the same value as 1/(x/y)
      aspect = fromIntegral(w)/fromIntegral(h)
      right = top*aspect
  frustum (-right) right (-top) top near far
  matrixMode $= Modelview 0