98 lines
4.0 KiB
Haskell
98 lines
4.0 KiB
Haskell
{-# LANGUAGE RankNTypes #-}
|
|
-- | Types specific to Rendering-Issues
|
|
module Render.Types (createFlatCam, createSphereCam, Camera, GLCamera(..)) where
|
|
|
|
import Linear
|
|
import Foreign.C (CFloat)
|
|
import Render.Misc (lookAt)
|
|
import Map.Map (giveMapHeight)
|
|
import Map.Types (PlayMap)
|
|
import GHC.Float
|
|
import qualified Debug.Trace as D
|
|
|
|
type Distance = Double
|
|
type Pitch = Double
|
|
type Yaw = Double
|
|
type Radius = Double
|
|
type Height = Double
|
|
|
|
-- | a Typclass for different Cameras
|
|
class GLCamera a where
|
|
-- | Gets the current Camera-Matrix for a given Cam, Distance Pitch and Yaw
|
|
getCam :: a -> Distance -> Pitch -> Yaw -> M44 CFloat
|
|
-- | Moves the Camera-Target on a projected 2D-plane
|
|
moveBy :: a -> (Position -> Position) -> PlayMap -> a
|
|
-- | Moves the Camera-Target to an absoloute position
|
|
move :: a -> Position -> PlayMap -> a
|
|
|
|
-- | Alias for a camera-position onto the 2d-plane it moves on
|
|
type Position = (Double, Double)
|
|
|
|
-- | Camera-Type. Either a Camera onto a 2D-flat-map or a spherical map
|
|
data Camera = Flat Position Height
|
|
| Sphere Position Radius
|
|
|
|
-- | create a Flatcam-Camera starting at given x/z-Coordinates
|
|
createFlatCam :: Double -> Double -> PlayMap -> Camera
|
|
createFlatCam x z map' = Flat (x,z) (giveMapHeight map' (x, z))
|
|
|
|
-- | create a Flatcam-Camera starting at given pitch/azimuth/radius
|
|
createSphereCam :: Double -> Double -> Double -> Camera
|
|
createSphereCam p a = Sphere (p,a)
|
|
|
|
-- | our Camera is indeed a GLCamera that we can use
|
|
--
|
|
-- TODO: Sphere-Cam still undefined
|
|
instance GLCamera Camera where
|
|
getCam (Flat (x',z') y') dist' xa' ya' =
|
|
lookAt (cpos ^+^ at') at' up
|
|
where
|
|
at' = V3 x (y+2) z
|
|
cpos = crot !* (V3 0 0 (-dist))
|
|
crot = (
|
|
(fromQuaternion $ axisAngle upmap (xa::CFloat))
|
|
!*!
|
|
(fromQuaternion $ axisAngle (V3 0 1 0) (ya::CFloat))
|
|
) ::M33 CFloat
|
|
upmap = ((fromQuaternion $ axisAngle (V3 0 1 0) (ya::CFloat)) :: M33 CFloat)
|
|
!* (V3 1 0 0)
|
|
x = realToFrac x'
|
|
y = realToFrac y'
|
|
z = realToFrac z'
|
|
dist = realToFrac dist'
|
|
xa = realToFrac xa'
|
|
ya = realToFrac ya'
|
|
up = V3 0 1 0
|
|
getCam (Sphere (inc',az') r') dist' xa' ya' = --inclination (pitch), azimuth (yaw)
|
|
lookAt (cpos ^+^ at') at' up
|
|
where
|
|
at' = sphereToCart (r+1) inc az
|
|
cpos = crot !* (V3 0 0 (-dist))
|
|
crot = (
|
|
(fromQuaternion $ axisAngle upmap (xa::CFloat))
|
|
!*!
|
|
(fromQuaternion $ axisAngle (V3 0 1 0) (ya::CFloat))
|
|
) ::M33 CFloat
|
|
upmap = ((fromQuaternion $ axisAngle (V3 0 1 0) (ya::CFloat)) :: M33 CFloat)
|
|
!* (V3 1 0 0)
|
|
up = (sphereToCart (r+1) inc az) ^-^ at'
|
|
r = realToFrac r'
|
|
inc = realToFrac inc'
|
|
az = realToFrac az'
|
|
dist = realToFrac dist'
|
|
xa = realToFrac xa'
|
|
ya = realToFrac ya'
|
|
moveBy (Sphere (inc, az) r) f map = undefined
|
|
moveBy (Flat (x', z') y) f map = Flat (x,z) y
|
|
where
|
|
(x,z) = f (x', z')
|
|
y = giveMapHeight map (x,z)
|
|
move c (x', z') map = moveBy c (\(x,z) -> (x+x',z+z')) map
|
|
|
|
-- | converting spherical to cartesian coordinates
|
|
sphereToCart :: (Floating a) => a -> a -> a -> V3 a
|
|
sphereToCart r inc az = V3
|
|
(r * (sin inc) * (cos az))
|
|
(r * (sin inc) * (sin az))
|
|
(r * (cos inc))
|