{-
   Quake-like player data structure for movement and  my favourite
   FPS key binding :-)
   Sven Panne 2000.   mailto:Sven.Panne@informatik.uni-muenchen.de
-}

module Player(
   PlayerState(PlayerState, playerFrame), makePlayerState,
   Movement(..), move, positionCamera, quakeBindings
) where

import Data.IORef  ( IORef, modifyIORef )
import System.Exit ( exitWith, ExitCode(ExitSuccess) )

import GL
import GLU hiding ( Angle )
import Graphics.UI.GLUT

import Geometry as G
import UserInput

---------------------------------------------------------------------------
-- The player has the origin in his stomach, his right arm is the x-axis,
-- the y-axis points through his head. He is positioned at the origin of
-- his frame turned <pitch> degrees about his right arm (right-hand rule),
-- and turned <yaw> degrees about the *world*'s y-axis (which points
-- upwards). This representation is redundant, but the angles help keeping
-- the basis orthonormal in the presence of rounding errors. An alternative
-- would be to re-orthonormalize the basis from time to time. Doing nothing
-- about this issue would result in visible shearing after some movements.

data PlayerState = PlayerState {
   playerFrame :: Frame Float,
   pitch, yaw  :: Angle
 } deriving (Eq, Show)

makePlayerState :: Point Float -> Angle -> Angle -> PlayerState
makePlayerState position thePitch theYaw = PlayerState {
   playerFrame = Frame {
      origin = position,
      basis  = Basis {
         basisRight = Vector  cy        0  (-sy),
         basisUp    = Vector (sy*sp)   cp  ( cy*sp),
         basisBack  = Vector (sy*cp) (-sp) ( cy*cp) }},
   pitch = thePitch,
   yaw   = theYaw }
   where cp = cosD thePitch
         sp = sinD thePitch
         cy = cosD theYaw
         sy = sinD theYaw

data Movement =
   -- changing position
     MBack      Float -- move backwards
   | MForward   Float -- move forwards
   | MMoveRight Float -- side step to the right
   | MMoveLeft  Float -- side step to the left
   | MMoveUp    Float -- move upwards (in world coordinates)
   | MMoveDown  Float -- move downwards (in world coordinates)
   -- changing viewing direction
   | MLeft      Angle -- turn left  (via world's y-axis)
   | MRight     Angle -- turn right (via world's y-axis)
   | MLookUp    Angle -- look up
   | MLookDown  Angle -- look down

move :: Movement -> PlayerState -> PlayerState
move movement ps@(PlayerState { playerFrame = frame@(Frame { basis = b, origin = o })}) =
   case movement of
      MBack      t -> translateBy t (basisBack  b)
      MForward   t -> translateBy t (basisBack  b `scaledBy` (-1))
      MMoveRight t -> translateBy t (basisRight b)
      MMoveLeft  t -> translateBy t (basisRight b `scaledBy` (-1))
      MMoveUp    t -> translateBy t (Vector 0   1  0)
      MMoveDown  t -> translateBy t (Vector 0 (-1) 0)
      MLeft      a -> rotateBy   0   a
      MRight     a -> rotateBy   0 (-a)
      MLookUp    a -> rotateBy   a   0
      MLookDown  a -> rotateBy (-a)  0

   where translateBy incTransl vec = ps {
            playerFrame = frame {
               origin = o `pAdd` (vec `scaledBy` incTransl) }}

         rotateBy pitchInc yawInc =
            makePlayerState o (addAngle (pitch ps) pitchInc)
                              (addAngle (yaw   ps) yawInc  )

---------------------------------------------------------------------------
-- Viewing transformation

positionCamera :: PlayerState -> IO ()
positionCamera (PlayerState { playerFrame = Frame { origin = eye, basis = base }}) = do
   let pointToTriple (G.Point x y z) = (realToFrac x, realToFrac y, realToFrac z)
   loadIdentity
   lookAt (pointToTriple  eye)
          (pointToTriple (eye         `pAdd` (basisBack base `scaledBy` (-1))))
          (pointToTriple (worldOrigin `pAdd`  basisUp base))

---------------------------------------------------------------------------
-- Move with the following keys: s/f, a/SPACE, d/e, cursor keys.

quakeBindings :: Float -> Angle -> IORef PlayerState -> IO (KeyBinder, StillDownHandler)
quakeBindings translSpeed rotSpeed playerState = do
   (bindKey, stillDown) <- initUserInput
   let bind key direction = 
          bindKey key StillDown (Just (\_ _ -> modifyIORef playerState (move direction)))

   bind (Char  's')               (MMoveLeft  translSpeed)
   bind (Char  'f')               (MMoveRight translSpeed)
   bind (Char  ' ')               (MMoveUp    translSpeed)
   bind (Char  'a')               (MMoveDown  translSpeed)
   bind (Char  'd')               (MBack      translSpeed)
   bind (Char  'e')               (MForward   translSpeed)

   bind (SpecialKey KeyRight)     (MRight     rotSpeed)
   bind (SpecialKey KeyLeft)      (MLeft      rotSpeed)
   bind (SpecialKey KeyUp)        (MLookDown  rotSpeed) -- yes, inverted!
   bind (SpecialKey KeyDown)      (MLookUp    rotSpeed)

   bind (MouseButton RightButton) (MForward   translSpeed)

   bindKey (Char '\27') Press (Just (\_ _ -> exitWith ExitSuccess))

   return (bindKey, stillDown)
