fixed compiler warnings.
most of them .. not all are my modules.
This commit is contained in:
parent
413c74c0a7
commit
d0ce4dcf6a
@ -1,529 +0,0 @@
|
|||||||
{-# LANGUAGE BangPatterns #-}
|
|
||||||
module Main where
|
|
||||||
|
|
||||||
import Graphics.UI.Gtk (AttrOp ((:=)))
|
|
||||||
import qualified Graphics.UI.Gtk as Gtk
|
|
||||||
import qualified Graphics.UI.Gtk.OpenGL as GtkGL
|
|
||||||
|
|
||||||
import qualified Data.Array.IArray as A
|
|
||||||
import Graphics.Rendering.OpenGL as GL
|
|
||||||
import qualified Graphics.UI.Gtk.Gdk.EventM as Event
|
|
||||||
|
|
||||||
import Map.Coordinates
|
|
||||||
import Map.Map
|
|
||||||
|
|
||||||
import Data.IntSet as IS
|
|
||||||
import Data.IORef
|
|
||||||
import Data.Maybe (fromMaybe)
|
|
||||||
import Debug.Trace
|
|
||||||
|
|
||||||
import Control.Concurrent
|
|
||||||
import Control.Concurrent.STM
|
|
||||||
import Control.Monad
|
|
||||||
import Control.Monad.IO.Class (liftIO)
|
|
||||||
import Foreign.Ptr (nullPtr)
|
|
||||||
import GHC.Conc.Sync (unsafeIOToSTM)
|
|
||||||
import Prelude as P
|
|
||||||
import System.IO.Unsafe (unsafePerformIO)
|
|
||||||
import Foreign.Marshal.Array (allocaArray)
|
|
||||||
import Render.Misc (dumpInfo)
|
|
||||||
|
|
||||||
data ProgramState = PS { keysPressed :: IntSet
|
|
||||||
, px :: GLfloat
|
|
||||||
, py :: GLfloat
|
|
||||||
, pz :: GLfloat
|
|
||||||
, heading :: GLfloat
|
|
||||||
, pitch :: GLfloat
|
|
||||||
, dx :: GLfloat
|
|
||||||
, dy :: GLfloat
|
|
||||||
, dz :: GLfloat
|
|
||||||
, dheading :: GLfloat
|
|
||||||
, dpitch :: GLfloat
|
|
||||||
, showShadowMap :: Bool }
|
|
||||||
deriving (Show)
|
|
||||||
|
|
||||||
type RenderObject = (Vector3 GLfloat, Color3 GLfloat, [Vertex3 GLfloat])
|
|
||||||
|
|
||||||
(Vertex4 a b c d) .+ (Vertex4 w x y z) = Vertex4 (a+w) (b+x) (c+y) (d+z)
|
|
||||||
(Vertex4 a b c d) .* e = Vertex4 (a*e) (b*e) (c*e) (d*e)
|
|
||||||
|
|
||||||
animationWaitTime = 3 :: Int
|
|
||||||
canvasWidth = 1024 :: Int
|
|
||||||
canvasHeight = 768 :: Int
|
|
||||||
deltaV = 0.10
|
|
||||||
deltaH = 0.5
|
|
||||||
deltaP = 0.15
|
|
||||||
black = Color3 0 0 0 :: Color3 GLfloat
|
|
||||||
shadowMapSize :: TextureSize2D
|
|
||||||
shadowMapSize = TextureSize2D 512 512
|
|
||||||
|
|
||||||
up :: Vector3 GLdouble
|
|
||||||
up = Vector3 0 1 0
|
|
||||||
|
|
||||||
origin :: Vertex3 GLdouble
|
|
||||||
origin = Vertex3 0 0 0
|
|
||||||
|
|
||||||
sun = Light 0
|
|
||||||
|
|
||||||
-- TODO: Put render-stuff in render-modul
|
|
||||||
|
|
||||||
--gets Sun position in given format
|
|
||||||
getSunPos :: (GLdouble -> GLdouble -> GLdouble -> a) -> IO a
|
|
||||||
getSunPos f = do
|
|
||||||
Vertex4 x y z _ <- get (position sun)
|
|
||||||
return $ f (realToFrac x) (realToFrac y) (realToFrac z)
|
|
||||||
|
|
||||||
glTexCoord2f (x,y) = texCoord (TexCoord2 x y :: TexCoord2 GLfloat)
|
|
||||||
glVertex3f (x,y,z) = vertex (Vertex3 x y z :: Vertex3 GLfloat)
|
|
||||||
glNormal3f (x,y,z) = normal (Normal3 x y z :: Normal3 GLfloat)
|
|
||||||
|
|
||||||
prepareRenderTile :: PlayMap -> ((Int,Int),MapEntry) -> (Vector3 GLfloat, Color3 GLfloat, [Vertex3 GLfloat])
|
|
||||||
prepareRenderTile m (c@(cx,cz),(_,t)) =
|
|
||||||
(
|
|
||||||
Vector3 (1.5 * fromIntegral cx) 0.0
|
|
||||||
(if even cx then 2 * fromIntegral cz else
|
|
||||||
2 * fromIntegral cz - 1)
|
|
||||||
,
|
|
||||||
case t of
|
|
||||||
Water -> Color3 0.5 0.5 1 :: Color3 GLfloat
|
|
||||||
Grass -> Color3 0.3 0.9 0.1 :: Color3 GLfloat
|
|
||||||
Sand -> Color3 0.9 0.85 0.7 :: Color3 GLfloat
|
|
||||||
Mountain -> Color3 0.5 0.5 0.5 :: Color3 GLfloat
|
|
||||||
,getTileVertices m c)
|
|
||||||
|
|
||||||
renderTile :: RenderObject -> IO ()
|
|
||||||
renderTile (coord,c,ts) =
|
|
||||||
preservingMatrix $ do
|
|
||||||
translate coord
|
|
||||||
{-color black
|
|
||||||
lineWidth $= 4.0
|
|
||||||
lineSmooth $= Enabled
|
|
||||||
_ <- renderPrimitive LineLoop $ do
|
|
||||||
glNormal3f(0.0,0.0,1.0)
|
|
||||||
mapM vertex ts-}
|
|
||||||
color c
|
|
||||||
_ <- renderPrimitive Polygon $ do
|
|
||||||
glNormal3f(0.0,1.0,0.0)
|
|
||||||
mapM vertex ts
|
|
||||||
return ()
|
|
||||||
|
|
||||||
drawSphere :: IO ()
|
|
||||||
drawSphere = renderQuadric
|
|
||||||
(QuadricStyle (Just Smooth) GenerateTextureCoordinates Outside
|
|
||||||
FillStyle)
|
|
||||||
(Sphere 2.0 48 48)
|
|
||||||
|
|
||||||
drawObjects :: [RenderObject] -> [RenderObject] -> Bool -> IO ()
|
|
||||||
drawObjects map ent shadowRender = do
|
|
||||||
textureOn <- get (texture Texture2D) --are textures enabled?
|
|
||||||
|
|
||||||
when shadowRender $
|
|
||||||
texture Texture2D $= Disabled --disable textures if we render shadows.
|
|
||||||
|
|
||||||
--draw something throwing shadows
|
|
||||||
preservingMatrix $ do
|
|
||||||
pos <- getSunPos Vector3
|
|
||||||
translate $ fmap (+ (-15.0)) pos
|
|
||||||
drawSphere
|
|
||||||
preservingMatrix $ do
|
|
||||||
pos <- getSunPos Vector3
|
|
||||||
translate $ fmap (+ (-10.0)) pos
|
|
||||||
drawSphere
|
|
||||||
--draw sun-indicator
|
|
||||||
{- preservingMatrix $ do
|
|
||||||
pos <- getSunPos Vector3
|
|
||||||
translate pos
|
|
||||||
color (Color4 1.0 1.0 0.0 1.0 :: Color4 GLfloat)
|
|
||||||
drawSphere
|
|
||||||
--putStrLn $ unwords ["sun at", show pos]
|
|
||||||
-- -}
|
|
||||||
--draw map
|
|
||||||
mapM_ renderTile map
|
|
||||||
|
|
||||||
|
|
||||||
when (shadowRender && textureOn == Enabled) $ --reset texture-rendering
|
|
||||||
texture Texture2D $= Enabled
|
|
||||||
|
|
||||||
-- OpenGL polygon-function for drawing stuff.
|
|
||||||
display :: MVar ProgramState -> PlayMap -> IO ()
|
|
||||||
display state t =
|
|
||||||
let
|
|
||||||
-- Todo: have tiles static somewhere .. dont calculate every frame
|
|
||||||
tiles = P.map (prepareRenderTile t) (A.assocs t)
|
|
||||||
in
|
|
||||||
do
|
|
||||||
ps@PS {
|
|
||||||
px = px
|
|
||||||
, py = py
|
|
||||||
, pz = pz
|
|
||||||
, pitch = pitch
|
|
||||||
, heading = heading
|
|
||||||
, showShadowMap = showShadowMap }
|
|
||||||
<- readMVar state
|
|
||||||
loadIdentity
|
|
||||||
GL.rotate pitch (Vector3 1.0 0.0 0.0 :: Vector3 GLfloat)
|
|
||||||
GL.rotate heading (Vector3 0.0 1.0 0.0 :: Vector3 GLfloat)
|
|
||||||
translate (Vector3 (-px) (-py) (-pz)::Vector3 GLfloat)
|
|
||||||
|
|
||||||
generateShadowMap tiles []
|
|
||||||
generateTextureMatrix
|
|
||||||
unless showShadowMap $ do
|
|
||||||
clear [ ColorBuffer, DepthBuffer ]
|
|
||||||
preservingMatrix $ do
|
|
||||||
drawObjects tiles [] False
|
|
||||||
|
|
||||||
return ()
|
|
||||||
|
|
||||||
updateCamera :: MVar ProgramState -> IO ()
|
|
||||||
updateCamera state = do
|
|
||||||
ps@PS { dx = dx
|
|
||||||
, dy = dy
|
|
||||||
, dz = dz
|
|
||||||
, px = px
|
|
||||||
, py = py
|
|
||||||
, pz = pz
|
|
||||||
, pitch = pitch
|
|
||||||
, heading = heading
|
|
||||||
, dpitch = dpitch
|
|
||||||
, dheading = dheading
|
|
||||||
}
|
|
||||||
<- takeMVar state
|
|
||||||
|
|
||||||
d@((dx,dy,dz),(heading',pitch')) <-
|
|
||||||
if any (/= 0.0) [dx,dy,dz,dpitch,dheading] then
|
|
||||||
preservingMatrix $ do
|
|
||||||
-- putStrLn $ unwords $ P.map show [dx,dy,dz,dpitch,dheading]
|
|
||||||
loadIdentity
|
|
||||||
|
|
||||||
-- in direction of current heading and pitch
|
|
||||||
rotate (-heading) (Vector3 0.0 1.0 0.0 :: Vector3 GLfloat)
|
|
||||||
rotate (-pitch) (Vector3 1.0 0.0 0.0 :: Vector3 GLfloat)
|
|
||||||
|
|
||||||
-- perform motion
|
|
||||||
translate (Vector3 (-dx) (-dy) (-dz))
|
|
||||||
|
|
||||||
|
|
||||||
-- get changes in location components
|
|
||||||
mat <- get (matrix Nothing) :: IO (GLmatrix GLfloat)
|
|
||||||
comps <- getMatrixComponents ColumnMajor mat
|
|
||||||
-- putStrLn $ show $ comps
|
|
||||||
let [dx', dy', dz', _] = drop 12 comps
|
|
||||||
(heading', pitch') = (heading + dheading, pitch + dpitch)
|
|
||||||
return ((dx',dy',dz'),(heading',pitch'))
|
|
||||||
else
|
|
||||||
return ((0,0,0),(heading, pitch))
|
|
||||||
putMVar state ps { px = px + dx
|
|
||||||
, py = py + dy
|
|
||||||
, pz = pz + dz
|
|
||||||
, pitch = pitch'
|
|
||||||
, heading = heading'
|
|
||||||
}
|
|
||||||
|
|
||||||
-- Note: preservingViewport is not exception safe, but it doesn't matter here
|
|
||||||
preservingViewport :: IO a -> IO a
|
|
||||||
preservingViewport act = do
|
|
||||||
v <- get viewport
|
|
||||||
x <- act
|
|
||||||
viewport $= v
|
|
||||||
return x
|
|
||||||
|
|
||||||
generateTextureMatrix :: IO ()
|
|
||||||
generateTextureMatrix = do
|
|
||||||
-- Set up projective texture matrix. We use the Modelview matrix stack and
|
|
||||||
-- OpenGL matrix commands to make the matrix.
|
|
||||||
m <- preservingMatrix $ do
|
|
||||||
loadIdentity
|
|
||||||
-- resolve overloading, not needed in "real" programs
|
|
||||||
let translatef = translate :: Vector3 GLfloat -> IO ()
|
|
||||||
scalef = scale :: GLfloat -> GLfloat -> GLfloat -> IO ()
|
|
||||||
translatef (Vector3 0.5 0.5 0.0)
|
|
||||||
scalef 0.5 0.5 1.0
|
|
||||||
ortho (-20) 20 (-20) 20 1 100
|
|
||||||
lightPos' <- getSunPos Vertex3
|
|
||||||
lookAt lightPos' origin up
|
|
||||||
get (matrix (Just (Modelview 0)))
|
|
||||||
|
|
||||||
[ sx, sy, sz, sw,
|
|
||||||
tx, ty, tz, tw,
|
|
||||||
rx, ry, rz, rw,
|
|
||||||
qx, qy, qz, qw ] <- getMatrixComponents RowMajor (m :: GLmatrix GLdouble)
|
|
||||||
|
|
||||||
textureGenMode S $= Just (ObjectLinear (Plane sx sy sz sw))
|
|
||||||
textureGenMode T $= Just (ObjectLinear (Plane tx ty tz tw))
|
|
||||||
textureGenMode R $= Just (ObjectLinear (Plane rx ry rz rw))
|
|
||||||
textureGenMode Q $= Just (ObjectLinear (Plane qx qy qz qw))
|
|
||||||
|
|
||||||
generateShadowMap :: [RenderObject] -> [RenderObject] -> IO ()
|
|
||||||
generateShadowMap tiles obj = do
|
|
||||||
lightPos' <- getSunPos Vertex3
|
|
||||||
let (TextureSize2D shadowMapWidth shadowMapHeight) = shadowMapSize
|
|
||||||
shadowMapSize' = Size shadowMapWidth shadowMapHeight
|
|
||||||
|
|
||||||
preservingViewport $ do
|
|
||||||
viewport $= (Position 0 0, shadowMapSize')
|
|
||||||
|
|
||||||
clear [ ColorBuffer, DepthBuffer ]
|
|
||||||
|
|
||||||
cullFace $= Just Front -- only backsides cast shadows -> less polys
|
|
||||||
|
|
||||||
matrixMode $= Projection
|
|
||||||
preservingMatrix $ do
|
|
||||||
loadIdentity
|
|
||||||
ortho (-20) 20 (-20) 20 10 100
|
|
||||||
matrixMode $= Modelview 0
|
|
||||||
preservingMatrix $ do
|
|
||||||
loadIdentity
|
|
||||||
lookAt lightPos' origin up
|
|
||||||
drawObjects tiles obj True
|
|
||||||
matrixMode $= Projection
|
|
||||||
matrixMode $= Modelview 0
|
|
||||||
|
|
||||||
copyTexImage2D Texture2D 0 DepthComponent' (Position 0 0) shadowMapSize 0
|
|
||||||
|
|
||||||
cullFace $= Just Back
|
|
||||||
|
|
||||||
when True $ do
|
|
||||||
let numShadowMapPixels = fromIntegral (shadowMapWidth * shadowMapHeight)
|
|
||||||
allocaArray numShadowMapPixels $ \depthImage -> do
|
|
||||||
let pixelData fmt = PixelData fmt Float depthImage :: PixelData GLfloat
|
|
||||||
readPixels (Position 0 0) shadowMapSize' (pixelData DepthComponent)
|
|
||||||
(_, Size viewPortWidth _) <- get viewport
|
|
||||||
windowPos (Vertex2 (fromIntegral viewPortWidth / 2 :: GLfloat) 0)
|
|
||||||
drawPixels shadowMapSize' (pixelData Luminance)
|
|
||||||
|
|
||||||
--Adjust size to given dimensions
|
|
||||||
reconfigure :: Int -> Int -> IO (Int, Int)
|
|
||||||
reconfigure w h = do
|
|
||||||
-- maintain aspect ratio
|
|
||||||
let aspectRatio = fromIntegral canvasWidth / fromIntegral canvasHeight
|
|
||||||
(w1, h1) = (fromIntegral w, fromIntegral w / aspectRatio)
|
|
||||||
(w2, h2) = (fromIntegral h * aspectRatio, fromIntegral h)
|
|
||||||
(w', h') = if h1 <= fromIntegral h
|
|
||||||
then (floor w1, floor h1)
|
|
||||||
else (floor w2, floor h2)
|
|
||||||
reshape $ Just (w', h')
|
|
||||||
return (w', h')
|
|
||||||
|
|
||||||
-- Called by reconfigure to fix the OpenGL viewport according to the
|
|
||||||
-- dimensions of the widget, appropriately.
|
|
||||||
reshape :: Maybe (Int, Int) -> IO ()
|
|
||||||
reshape dims = do
|
|
||||||
let (width, height) = fromMaybe (canvasWidth, canvasHeight) dims
|
|
||||||
viewport $= (Position 0 0, Size (fromIntegral width) (fromIntegral height))
|
|
||||||
matrixMode $= Projection
|
|
||||||
loadIdentity
|
|
||||||
let (w, h) = if width <= height
|
|
||||||
then (fromIntegral height, fromIntegral width )
|
|
||||||
else (fromIntegral width, fromIntegral height)
|
|
||||||
-- open, aspect-ratio, near-plane, far-plane
|
|
||||||
perspective 60.0 (fromIntegral canvasWidth / fromIntegral canvasHeight) 1.0 100.0
|
|
||||||
matrixMode $= Modelview 0
|
|
||||||
loadIdentity
|
|
||||||
|
|
||||||
keyEvent state press = do
|
|
||||||
code <- Event.eventHardwareKeycode
|
|
||||||
val <- Event.eventKeyVal
|
|
||||||
mods <- Event.eventModifier
|
|
||||||
name <- Event.eventKeyName
|
|
||||||
liftIO $ do
|
|
||||||
ps@PS { keysPressed = kp
|
|
||||||
, dx = dx
|
|
||||||
, dy = dy
|
|
||||||
, dz = dz
|
|
||||||
, px = px
|
|
||||||
, py = py
|
|
||||||
, pz = pz
|
|
||||||
, pitch = pitch
|
|
||||||
, heading = heading
|
|
||||||
, dpitch = dpitch
|
|
||||||
, dheading = dheading
|
|
||||||
, showShadowMap = showShadowMap }
|
|
||||||
<- takeMVar state
|
|
||||||
-- Only process the key event if it is not a repeat
|
|
||||||
(ps',ret) <- if (fromIntegral code `member` kp && not press) ||
|
|
||||||
(fromIntegral code `notMember` kp && press)
|
|
||||||
then let
|
|
||||||
accept a = return (a, True)
|
|
||||||
deny a = return (a, False)
|
|
||||||
in do
|
|
||||||
-- keep list of pressed keys up2date
|
|
||||||
ps <- return (if not press then
|
|
||||||
(ps{keysPressed = fromIntegral code `delete` kp})
|
|
||||||
else
|
|
||||||
(ps{keysPressed = fromIntegral code `insert` kp}))
|
|
||||||
putStrLn $ unwords [name , show val, show code, show ps] -- trace (unwords [name , show val]) -- debugging
|
|
||||||
-- process keys
|
|
||||||
case press of
|
|
||||||
-- on PRESS only
|
|
||||||
True
|
|
||||||
| code == 9 -> Gtk.mainQuit >> deny ps
|
|
||||||
| code == 26 -> accept $ ps { dz = dz + deltaV }
|
|
||||||
| code == 40 -> accept $ ps { dz = dz - deltaV }
|
|
||||||
| code == 39 -> accept $ ps { dx = dx + deltaV }
|
|
||||||
| code == 41 -> accept $ ps { dx = dx - deltaV }
|
|
||||||
| code == 65 -> accept $ ps { dy = dy - deltaV }
|
|
||||||
| code == 66 -> accept $ ps { dy = dy + deltaV }
|
|
||||||
| code == 25 -> accept $ ps { dheading = dheading - deltaH }
|
|
||||||
| code == 27 -> accept $ ps { dheading = dheading + deltaH }
|
|
||||||
| code == 42 -> accept $ ps { showShadowMap = not showShadowMap }
|
|
||||||
| code == 31 -> dumpInfo >> accept ps
|
|
||||||
| otherwise -> deny ps
|
|
||||||
-- on RELEASE only
|
|
||||||
False
|
|
||||||
| code == 26 -> accept $ ps { dz = dz - deltaV }
|
|
||||||
| code == 40 -> accept $ ps { dz = dz + deltaV }
|
|
||||||
| code == 39 -> accept $ ps { dx = dx - deltaV }
|
|
||||||
| code == 41 -> accept $ ps { dx = dx + deltaV }
|
|
||||||
| code == 65 -> accept $ ps { dy = dy + deltaV }
|
|
||||||
| code == 66 -> accept $ ps { dy = dy - deltaV }
|
|
||||||
| code == 25 -> accept $ ps { dheading = dheading + deltaH }
|
|
||||||
| code == 27 -> accept $ ps { dheading = dheading - deltaH }
|
|
||||||
| otherwise -> deny ps
|
|
||||||
else return (ps, False)
|
|
||||||
putMVar state ps'
|
|
||||||
return ret
|
|
||||||
|
|
||||||
main :: IO ()
|
|
||||||
main = do
|
|
||||||
! terrain <- testmap
|
|
||||||
-- create TVar using unsafePerformIO -> currently no other thread -> OK
|
|
||||||
state <- newMVar PS { keysPressed = IS.empty
|
|
||||||
, px = 7.5
|
|
||||||
, py = 20
|
|
||||||
, pz = 15
|
|
||||||
, heading = 0
|
|
||||||
, pitch = 60
|
|
||||||
, dx = 0
|
|
||||||
, dy = 0
|
|
||||||
, dz = 0
|
|
||||||
, dheading = 0
|
|
||||||
, dpitch = 0
|
|
||||||
, showShadowMap = False }
|
|
||||||
trace (show terrain) Gtk.initGUI
|
|
||||||
-- Initialise the Gtk+ OpenGL extension
|
|
||||||
-- (including reading various command line parameters)
|
|
||||||
GtkGL.initGL
|
|
||||||
|
|
||||||
-- We need a OpenGL frame buffer configuration to be able to create other
|
|
||||||
-- OpenGL objects.
|
|
||||||
glconfig <- GtkGL.glConfigNew [GtkGL.GLModeRGBA,
|
|
||||||
GtkGL.GLModeDepth,
|
|
||||||
GtkGL.GLModeDouble]
|
|
||||||
|
|
||||||
-- Create an OpenGL drawing area widget
|
|
||||||
canvas <- GtkGL.glDrawingAreaNew glconfig
|
|
||||||
|
|
||||||
Gtk.widgetSetSizeRequest canvas canvasWidth canvasHeight
|
|
||||||
|
|
||||||
-- Initialise some GL setting just before the canvas first gets shown
|
|
||||||
-- (We can't initialise these things earlier since the GL resources that
|
|
||||||
-- we are using wouldn't heve been setup yet)
|
|
||||||
Gtk.onRealize canvas $ GtkGL.withGLDrawingArea canvas $ \_ -> do
|
|
||||||
reconfigure canvasWidth canvasHeight
|
|
||||||
--set up shadow-map
|
|
||||||
texImage2D Texture2D NoProxy 0 DepthComponent' shadowMapSize 0
|
|
||||||
(PixelData DepthComponent UnsignedByte nullPtr)
|
|
||||||
|
|
||||||
materialAmbient Front $= Color4 0.4 0.4 0.4 1.0
|
|
||||||
materialDiffuse Front $= Color4 0.4 0.4 0.4 1.0
|
|
||||||
materialSpecular Front $= Color4 0.8 0.8 0.8 1.0
|
|
||||||
materialShininess Front $= 25.0
|
|
||||||
|
|
||||||
ambient sun $= Color4 0.3 0.3 0.3 1.0
|
|
||||||
diffuse sun $= Color4 1.0 1.0 1.0 1.0
|
|
||||||
specular sun $= Color4 0.8 0.8 0.8 1.0
|
|
||||||
lightModelAmbient $= Color4 0.2 0.2 0.2 1.0
|
|
||||||
position sun $= (Vertex4 2.0 1.0 1.3 1.0 :: Vertex4 GLfloat) .* (1/2.5865) .* 45
|
|
||||||
spotDirection sun $= (Normal3 (2.0) (1.0) (1.3) :: Normal3 GLfloat)
|
|
||||||
--spotExponent sun $= 1.0
|
|
||||||
--attenuation sun $= (1.0, 0.0, 0.0)
|
|
||||||
|
|
||||||
lighting $= Enabled
|
|
||||||
light sun $= Enabled
|
|
||||||
depthFunc $= Just Less
|
|
||||||
shadeModel $= Smooth
|
|
||||||
--lightModelLocalViewer $= Enabled
|
|
||||||
--vertexProgramTwoSide $= Enabled
|
|
||||||
|
|
||||||
clearColor $= Color4 0.0 0.0 0.0 0.0
|
|
||||||
drawBuffer $= BackBuffers
|
|
||||||
colorMaterial $= Just (FrontAndBack, AmbientAndDiffuse)
|
|
||||||
|
|
||||||
frontFace $= CCW
|
|
||||||
cullFace $= Just Back
|
|
||||||
|
|
||||||
texture Texture2D $= Enabled
|
|
||||||
|
|
||||||
textureWrapMode Texture2D S $= (Repeated, ClampToEdge)
|
|
||||||
textureWrapMode Texture2D T $= (Repeated, ClampToEdge)
|
|
||||||
textureFilter Texture2D $= ((Linear', Nothing), Linear')
|
|
||||||
textureCompareMode Texture2D $= Just Lequal
|
|
||||||
depthTextureMode Texture2D $= Luminance'
|
|
||||||
|
|
||||||
shadeModel $= Smooth
|
|
||||||
|
|
||||||
fog $= Enabled
|
|
||||||
fogMode $= Linear 45.0 50.0
|
|
||||||
fogColor $= Color4 0.5 0.5 0.5 1.0
|
|
||||||
fogDistanceMode $= EyeRadial
|
|
||||||
|
|
||||||
|
|
||||||
return ()
|
|
||||||
{-clearColor $= (Color4 0.0 0.0 0.0 0.0)
|
|
||||||
matrixMode $= Projection
|
|
||||||
loadIdentity
|
|
||||||
ortho 0.0 1.0 0.0 1.0 (-1.0) 1.0
|
|
||||||
depthFunc $= Just Less
|
|
||||||
drawBuffer $= BackBuffers-}
|
|
||||||
|
|
||||||
-- Set the repaint handler
|
|
||||||
Gtk.onExpose canvas $ \_ -> do
|
|
||||||
GtkGL.withGLDrawingArea canvas $ \glwindow -> do
|
|
||||||
GL.clear [GL.DepthBuffer, GL.ColorBuffer]
|
|
||||||
display state terrain
|
|
||||||
GtkGL.glDrawableSwapBuffers glwindow
|
|
||||||
return True
|
|
||||||
|
|
||||||
-- Setup the animation
|
|
||||||
Gtk.timeoutAddFull (do
|
|
||||||
updateCamera state
|
|
||||||
Gtk.widgetQueueDraw canvas
|
|
||||||
return True)
|
|
||||||
Gtk.priorityDefaultIdle animationWaitTime
|
|
||||||
|
|
||||||
--------------------------------
|
|
||||||
-- Setup the rest of the GUI:
|
|
||||||
--
|
|
||||||
-- Objects
|
|
||||||
window <- Gtk.windowNew
|
|
||||||
button <- Gtk.buttonNew
|
|
||||||
exitButton <- Gtk.buttonNew
|
|
||||||
label <- Gtk.labelNew (Just "Gtk2Hs using OpenGL via HOpenGL!")
|
|
||||||
vbox <- Gtk.vBoxNew False 4
|
|
||||||
|
|
||||||
--Wrench them together
|
|
||||||
|
|
||||||
Gtk.set window [ Gtk.containerBorderWidth := 10,
|
|
||||||
Gtk.containerChild := canvas,
|
|
||||||
Gtk.windowTitle := "Pioneer" ]
|
|
||||||
|
|
||||||
------
|
|
||||||
-- Events
|
|
||||||
--
|
|
||||||
Gtk.afterClicked button (putStrLn "Hello World")
|
|
||||||
Gtk.afterClicked exitButton Gtk.mainQuit
|
|
||||||
Gtk.onDestroy window Gtk.mainQuit
|
|
||||||
|
|
||||||
Gtk.on window Gtk.keyPressEvent $ keyEvent state True
|
|
||||||
|
|
||||||
Gtk.on window Gtk.keyReleaseEvent $ keyEvent state False
|
|
||||||
|
|
||||||
-- "reshape" event handler
|
|
||||||
Gtk.on canvas Gtk.configureEvent $ Event.tryEvent $ do
|
|
||||||
(w, h) <- Event.eventSize
|
|
||||||
(w', h') <- liftIO $ reconfigure w h
|
|
||||||
liftIO $ Gtk.labelSetText label $ unwords ["Width:",show w',"Height:",show h']
|
|
||||||
|
|
||||||
Gtk.widgetShowAll window
|
|
||||||
Gtk.mainGUI
|
|
||||||
|
|
||||||
@ -1,665 +0,0 @@
|
|||||||
{-# LANGUAGE BangPatterns #-}
|
|
||||||
module Main (main) where
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
|
|
||||||
import Control.Concurrent.STM (TQueue, atomically,
|
|
||||||
newTQueueIO,
|
|
||||||
tryReadTQueue,
|
|
||||||
writeTQueue)
|
|
||||||
import Control.Monad (unless, void, when)
|
|
||||||
import Control.Monad.RWS.Strict (RWST, ask, asks,
|
|
||||||
evalRWST, get, liftIO,
|
|
||||||
modify, put)
|
|
||||||
import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT)
|
|
||||||
import Data.Distributive (distribute, collect)
|
|
||||||
import Data.List (intercalate)
|
|
||||||
import Data.Maybe (catMaybes)
|
|
||||||
import Foreign (Ptr, castPtr, with)
|
|
||||||
import Foreign.C (CFloat)
|
|
||||||
import Linear as L
|
|
||||||
import Text.PrettyPrint
|
|
||||||
|
|
||||||
import qualified Graphics.Rendering.OpenGL.GL as GL
|
|
||||||
import Graphics.Rendering.OpenGL.Raw.Core31
|
|
||||||
import qualified Graphics.UI.GLFW as GLFW
|
|
||||||
|
|
||||||
import Map.Map
|
|
||||||
import Render.Misc (checkError,
|
|
||||||
createFrustum, getCam,
|
|
||||||
lookAt, up)
|
|
||||||
import Render.Render (initRendering,
|
|
||||||
initShader)
|
|
||||||
import Control.Lens ((^.),transposeOf)
|
|
||||||
import Data.Traversable (traverse)
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
|
|
||||||
--Static Read-Only-State
|
|
||||||
data Env = Env
|
|
||||||
{ envEventsChan :: TQueue Event
|
|
||||||
, envWindow :: !GLFW.Window
|
|
||||||
, envZDistClosest :: !Double
|
|
||||||
, envZDistFarthest :: !Double
|
|
||||||
}
|
|
||||||
|
|
||||||
--Mutable State
|
|
||||||
data State = State
|
|
||||||
{ stateWindowWidth :: !Int
|
|
||||||
, stateWindowHeight :: !Int
|
|
||||||
--- IO
|
|
||||||
, stateXAngle :: !Double
|
|
||||||
, stateYAngle :: !Double
|
|
||||||
, stateZDist :: !Double
|
|
||||||
, stateMouseDown :: !Bool
|
|
||||||
, stateDragging :: !Bool
|
|
||||||
, stateDragStartX :: !Double
|
|
||||||
, stateDragStartY :: !Double
|
|
||||||
, stateDragStartXAngle :: !Double
|
|
||||||
, stateDragStartYAngle :: !Double
|
|
||||||
, statePositionX :: !Double
|
|
||||||
, statePositionY :: !Double
|
|
||||||
, stateFrustum :: !(M44 CFloat)
|
|
||||||
--- pointer to bindings for locations inside the compiled shader
|
|
||||||
--- mutable because shaders may be changed in the future.
|
|
||||||
, shdrVertexIndex :: !GL.AttribLocation
|
|
||||||
, shdrColorIndex :: !GL.AttribLocation
|
|
||||||
, shdrNormalIndex :: !GL.AttribLocation
|
|
||||||
, shdrProjMatIndex :: !GL.UniformLocation
|
|
||||||
, shdrViewMatIndex :: !GL.UniformLocation
|
|
||||||
, shdrModelMatIndex :: !GL.UniformLocation
|
|
||||||
, shdrNormalMatIndex :: !GL.UniformLocation
|
|
||||||
--- the map
|
|
||||||
, stateMap :: !GL.BufferObject
|
|
||||||
, mapVert :: !GL.NumArrayIndices
|
|
||||||
}
|
|
||||||
|
|
||||||
type Pioneer = RWST Env () State IO
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
|
|
||||||
data Event =
|
|
||||||
EventError !GLFW.Error !String
|
|
||||||
| EventWindowPos !GLFW.Window !Int !Int
|
|
||||||
| EventWindowSize !GLFW.Window !Int !Int
|
|
||||||
| EventWindowClose !GLFW.Window
|
|
||||||
| EventWindowRefresh !GLFW.Window
|
|
||||||
| EventWindowFocus !GLFW.Window !GLFW.FocusState
|
|
||||||
| EventWindowIconify !GLFW.Window !GLFW.IconifyState
|
|
||||||
| EventFramebufferSize !GLFW.Window !Int !Int
|
|
||||||
| EventMouseButton !GLFW.Window !GLFW.MouseButton !GLFW.MouseButtonState !GLFW.ModifierKeys
|
|
||||||
| EventCursorPos !GLFW.Window !Double !Double
|
|
||||||
| EventCursorEnter !GLFW.Window !GLFW.CursorState
|
|
||||||
| EventScroll !GLFW.Window !Double !Double
|
|
||||||
| EventKey !GLFW.Window !GLFW.Key !Int !GLFW.KeyState !GLFW.ModifierKeys
|
|
||||||
| EventChar !GLFW.Window !Char
|
|
||||||
deriving Show
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
|
|
||||||
main :: IO ()
|
|
||||||
main = do
|
|
||||||
let width = 640
|
|
||||||
height = 480
|
|
||||||
|
|
||||||
eventsChan <- newTQueueIO :: IO (TQueue Event)
|
|
||||||
|
|
||||||
withWindow width height "Pioneers" $ \win -> do
|
|
||||||
GLFW.setErrorCallback $ Just $ errorCallback eventsChan
|
|
||||||
GLFW.setWindowPosCallback win $ Just $ windowPosCallback eventsChan
|
|
||||||
GLFW.setWindowSizeCallback win $ Just $ windowSizeCallback eventsChan
|
|
||||||
GLFW.setWindowCloseCallback win $ Just $ windowCloseCallback eventsChan
|
|
||||||
GLFW.setWindowRefreshCallback win $ Just $ windowRefreshCallback eventsChan
|
|
||||||
GLFW.setWindowFocusCallback win $ Just $ windowFocusCallback eventsChan
|
|
||||||
GLFW.setWindowIconifyCallback win $ Just $ windowIconifyCallback eventsChan
|
|
||||||
GLFW.setFramebufferSizeCallback win $ Just $ framebufferSizeCallback eventsChan
|
|
||||||
GLFW.setMouseButtonCallback win $ Just $ mouseButtonCallback eventsChan
|
|
||||||
GLFW.setCursorPosCallback win $ Just $ cursorPosCallback eventsChan
|
|
||||||
GLFW.setCursorEnterCallback win $ Just $ cursorEnterCallback eventsChan
|
|
||||||
GLFW.setScrollCallback win $ Just $ scrollCallback eventsChan
|
|
||||||
GLFW.setKeyCallback win $ Just $ keyCallback eventsChan
|
|
||||||
GLFW.setCharCallback win $ Just $ charCallback eventsChan
|
|
||||||
|
|
||||||
GLFW.swapInterval 1
|
|
||||||
|
|
||||||
(fbWidth, fbHeight) <- GLFW.getFramebufferSize win
|
|
||||||
|
|
||||||
initRendering
|
|
||||||
--generate map vertices
|
|
||||||
(mapBuffer, vert) <- getMapBufferObject
|
|
||||||
(ci, ni, vi, pri, vii, mi, nmi) <- initShader
|
|
||||||
|
|
||||||
let zDistClosest = 10
|
|
||||||
zDistFarthest = zDistClosest + 20
|
|
||||||
fov = 90 --field of view
|
|
||||||
near = 1 --near plane
|
|
||||||
far = 100 --far plane
|
|
||||||
ratio = fromIntegral fbWidth / fromIntegral fbHeight
|
|
||||||
frust = createFrustum fov near far ratio
|
|
||||||
env = Env
|
|
||||||
{ envEventsChan = eventsChan
|
|
||||||
, envWindow = win
|
|
||||||
, envZDistClosest = zDistClosest
|
|
||||||
, envZDistFarthest = zDistFarthest
|
|
||||||
}
|
|
||||||
state = State
|
|
||||||
{ stateWindowWidth = fbWidth
|
|
||||||
, stateWindowHeight = fbHeight
|
|
||||||
, stateXAngle = pi/6
|
|
||||||
, stateYAngle = pi/2
|
|
||||||
, stateZDist = 10
|
|
||||||
, statePositionX = 5
|
|
||||||
, statePositionY = 5
|
|
||||||
, stateMouseDown = False
|
|
||||||
, stateDragging = False
|
|
||||||
, stateDragStartX = 0
|
|
||||||
, stateDragStartY = 0
|
|
||||||
, stateDragStartXAngle = 0
|
|
||||||
, stateDragStartYAngle = 0
|
|
||||||
, shdrVertexIndex = vi
|
|
||||||
, shdrNormalIndex = ni
|
|
||||||
, shdrColorIndex = ci
|
|
||||||
, shdrProjMatIndex = pri
|
|
||||||
, shdrViewMatIndex = vii
|
|
||||||
, shdrModelMatIndex = mi
|
|
||||||
, shdrNormalMatIndex = nmi
|
|
||||||
, stateMap = mapBuffer
|
|
||||||
, mapVert = vert
|
|
||||||
, stateFrustum = frust
|
|
||||||
}
|
|
||||||
runDemo env state
|
|
||||||
|
|
||||||
putStrLn "ended!"
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
|
|
||||||
-- GLFW-b is made to be very close to the C API, so creating a window is pretty
|
|
||||||
-- clunky by Haskell standards. A higher-level API would have some function
|
|
||||||
-- like withWindow.
|
|
||||||
|
|
||||||
withWindow :: Int -> Int -> String -> (GLFW.Window -> IO ()) -> IO ()
|
|
||||||
withWindow width height title f = do
|
|
||||||
GLFW.setErrorCallback $ Just simpleErrorCallback
|
|
||||||
r <- GLFW.init
|
|
||||||
when r $ do
|
|
||||||
m <- GLFW.createWindow width height title Nothing Nothing
|
|
||||||
case m of
|
|
||||||
(Just win) -> do
|
|
||||||
GLFW.makeContextCurrent m
|
|
||||||
f win
|
|
||||||
GLFW.setErrorCallback $ Just simpleErrorCallback
|
|
||||||
GLFW.destroyWindow win
|
|
||||||
Nothing -> return ()
|
|
||||||
GLFW.terminate
|
|
||||||
where
|
|
||||||
simpleErrorCallback e s =
|
|
||||||
putStrLn $ unwords [show e, show s]
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
|
|
||||||
-- Each callback does just one thing: write an appropriate Event to the events
|
|
||||||
-- TQueue.
|
|
||||||
|
|
||||||
errorCallback :: TQueue Event -> GLFW.Error -> String -> IO ()
|
|
||||||
windowPosCallback :: TQueue Event -> GLFW.Window -> Int -> Int -> IO ()
|
|
||||||
windowSizeCallback :: TQueue Event -> GLFW.Window -> Int -> Int -> IO ()
|
|
||||||
windowCloseCallback :: TQueue Event -> GLFW.Window -> IO ()
|
|
||||||
windowRefreshCallback :: TQueue Event -> GLFW.Window -> IO ()
|
|
||||||
windowFocusCallback :: TQueue Event -> GLFW.Window -> GLFW.FocusState -> IO ()
|
|
||||||
windowIconifyCallback :: TQueue Event -> GLFW.Window -> GLFW.IconifyState -> IO ()
|
|
||||||
framebufferSizeCallback :: TQueue Event -> GLFW.Window -> Int -> Int -> IO ()
|
|
||||||
mouseButtonCallback :: TQueue Event -> GLFW.Window -> GLFW.MouseButton -> GLFW.MouseButtonState -> GLFW.ModifierKeys -> IO ()
|
|
||||||
cursorPosCallback :: TQueue Event -> GLFW.Window -> Double -> Double -> IO ()
|
|
||||||
cursorEnterCallback :: TQueue Event -> GLFW.Window -> GLFW.CursorState -> IO ()
|
|
||||||
scrollCallback :: TQueue Event -> GLFW.Window -> Double -> Double -> IO ()
|
|
||||||
keyCallback :: TQueue Event -> GLFW.Window -> GLFW.Key -> Int -> GLFW.KeyState -> GLFW.ModifierKeys -> IO ()
|
|
||||||
charCallback :: TQueue Event -> GLFW.Window -> Char -> IO ()
|
|
||||||
|
|
||||||
errorCallback tc e s = atomically $ writeTQueue tc $ EventError e s
|
|
||||||
windowPosCallback tc win x y = atomically $ writeTQueue tc $ EventWindowPos win x y
|
|
||||||
windowSizeCallback tc win w h = atomically $ writeTQueue tc $ EventWindowSize win w h
|
|
||||||
windowCloseCallback tc win = atomically $ writeTQueue tc $ EventWindowClose win
|
|
||||||
windowRefreshCallback tc win = atomically $ writeTQueue tc $ EventWindowRefresh win
|
|
||||||
windowFocusCallback tc win fa = atomically $ writeTQueue tc $ EventWindowFocus win fa
|
|
||||||
windowIconifyCallback tc win ia = atomically $ writeTQueue tc $ EventWindowIconify win ia
|
|
||||||
framebufferSizeCallback tc win w h = atomically $ writeTQueue tc $ EventFramebufferSize win w h
|
|
||||||
mouseButtonCallback tc win mb mba mk = atomically $ writeTQueue tc $ EventMouseButton win mb mba mk
|
|
||||||
cursorPosCallback tc win x y = atomically $ writeTQueue tc $ EventCursorPos win x y
|
|
||||||
cursorEnterCallback tc win ca = atomically $ writeTQueue tc $ EventCursorEnter win ca
|
|
||||||
scrollCallback tc win x y = atomically $ writeTQueue tc $ EventScroll win x y
|
|
||||||
keyCallback tc win k sc ka mk = atomically $ writeTQueue tc $ EventKey win k sc ka mk
|
|
||||||
charCallback tc win c = atomically $ writeTQueue tc $ EventChar win c
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
|
|
||||||
runDemo :: Env -> State -> IO ()
|
|
||||||
runDemo env state = void $ evalRWST (adjustWindow >> run) env state
|
|
||||||
|
|
||||||
run :: Pioneer ()
|
|
||||||
run = do
|
|
||||||
win <- asks envWindow
|
|
||||||
|
|
||||||
-- draw Scene
|
|
||||||
draw
|
|
||||||
liftIO $ do
|
|
||||||
GLFW.swapBuffers win
|
|
||||||
GLFW.pollEvents
|
|
||||||
-- getEvents & process
|
|
||||||
processEvents
|
|
||||||
|
|
||||||
-- update State
|
|
||||||
|
|
||||||
state <- get
|
|
||||||
-- change in camera-angle
|
|
||||||
if stateDragging state
|
|
||||||
then do
|
|
||||||
let sodx = stateDragStartX state
|
|
||||||
sody = stateDragStartY state
|
|
||||||
sodxa = stateDragStartXAngle state
|
|
||||||
sodya = stateDragStartYAngle state
|
|
||||||
(x, y) <- liftIO $ GLFW.getCursorPos win
|
|
||||||
let myrot = (x - sodx) / 2
|
|
||||||
mxrot = (y - sody) / 2
|
|
||||||
newXAngle = curb (pi/12) (0.45*pi) newXAngle'
|
|
||||||
newXAngle' = sodxa + mxrot/100
|
|
||||||
newYAngle
|
|
||||||
| newYAngle' > pi = newYAngle' - 2 * pi
|
|
||||||
| newYAngle' < (-pi) = newYAngle' + 2 * pi
|
|
||||||
| otherwise = newYAngle'
|
|
||||||
newYAngle' = sodya + myrot/100
|
|
||||||
put $ state
|
|
||||||
{ stateXAngle = newXAngle
|
|
||||||
, stateYAngle = newYAngle
|
|
||||||
}
|
|
||||||
-- liftIO $ putStrLn $ unwords $ map show $ [newXAngle, newYAngle]
|
|
||||||
else do
|
|
||||||
(jxrot, jyrot) <- liftIO $ getJoystickDirections GLFW.Joystick'1
|
|
||||||
put $ state
|
|
||||||
{ stateXAngle = stateXAngle state + (2 * jxrot)
|
|
||||||
, stateYAngle = stateYAngle state + (2 * jyrot)
|
|
||||||
}
|
|
||||||
|
|
||||||
-- get cursor-keys - if pressed
|
|
||||||
--TODO: Add sin/cos from stateYAngle
|
|
||||||
(kxrot, kyrot) <- liftIO $ getCursorKeyDirections win
|
|
||||||
modify $ \s ->
|
|
||||||
let
|
|
||||||
multc = cos $ stateYAngle s
|
|
||||||
mults = sin $ stateYAngle s
|
|
||||||
in
|
|
||||||
s {
|
|
||||||
statePositionX = statePositionX s - 0.2 * kxrot * multc
|
|
||||||
- 0.2 * kyrot * mults
|
|
||||||
, statePositionY = statePositionY s + 0.2 * kxrot * mults
|
|
||||||
- 0.2 * kyrot * multc
|
|
||||||
}
|
|
||||||
|
|
||||||
{-
|
|
||||||
--modify the state with all that happened in mt time.
|
|
||||||
mt <- liftIO GLFW.getTime
|
|
||||||
modify $ \s -> s
|
|
||||||
{
|
|
||||||
}
|
|
||||||
-}
|
|
||||||
|
|
||||||
q <- liftIO $ GLFW.windowShouldClose win
|
|
||||||
unless q run
|
|
||||||
|
|
||||||
processEvents :: Pioneer ()
|
|
||||||
processEvents = do
|
|
||||||
tc <- asks envEventsChan
|
|
||||||
me <- liftIO $ atomically $ tryReadTQueue tc
|
|
||||||
case me of
|
|
||||||
Just e -> do
|
|
||||||
processEvent e
|
|
||||||
processEvents
|
|
||||||
Nothing -> return ()
|
|
||||||
|
|
||||||
processEvent :: Event -> Pioneer ()
|
|
||||||
processEvent ev =
|
|
||||||
case ev of
|
|
||||||
(EventError e s) -> do
|
|
||||||
printEvent "error" [show e, show s]
|
|
||||||
win <- asks envWindow
|
|
||||||
liftIO $ GLFW.setWindowShouldClose win True
|
|
||||||
|
|
||||||
(EventWindowPos _ x y) ->
|
|
||||||
printEvent "window pos" [show x, show y]
|
|
||||||
|
|
||||||
(EventWindowSize _ width height) ->
|
|
||||||
printEvent "window size" [show width, show height]
|
|
||||||
|
|
||||||
(EventWindowClose _) ->
|
|
||||||
printEvent "window close" []
|
|
||||||
|
|
||||||
(EventWindowRefresh _) ->
|
|
||||||
printEvent "window refresh" []
|
|
||||||
|
|
||||||
(EventWindowFocus _ fs) ->
|
|
||||||
printEvent "window focus" [show fs]
|
|
||||||
|
|
||||||
(EventWindowIconify _ is) ->
|
|
||||||
printEvent "window iconify" [show is]
|
|
||||||
|
|
||||||
(EventFramebufferSize _ width height) -> do
|
|
||||||
printEvent "framebuffer size" [show width, show height]
|
|
||||||
modify $ \s -> s
|
|
||||||
{ stateWindowWidth = width
|
|
||||||
, stateWindowHeight = height
|
|
||||||
}
|
|
||||||
adjustWindow
|
|
||||||
|
|
||||||
(EventMouseButton _ mb mbs mk) -> do
|
|
||||||
printEvent "mouse button" [show mb, show mbs, showModifierKeys mk]
|
|
||||||
when (mb == GLFW.MouseButton'1) $ do
|
|
||||||
let pressed = mbs == GLFW.MouseButtonState'Pressed
|
|
||||||
modify $ \s -> s
|
|
||||||
{ stateMouseDown = pressed
|
|
||||||
}
|
|
||||||
unless pressed $
|
|
||||||
modify $ \s -> s
|
|
||||||
{ stateDragging = False
|
|
||||||
}
|
|
||||||
|
|
||||||
(EventCursorPos _ x y) -> do
|
|
||||||
{-let x' = round x :: Int
|
|
||||||
y' = round y :: Int
|
|
||||||
printEvent "cursor pos" [show x', show y']-}
|
|
||||||
state <- get
|
|
||||||
when (stateMouseDown state && not (stateDragging state)) $
|
|
||||||
put $ state
|
|
||||||
{ stateDragging = True
|
|
||||||
, stateDragStartX = x
|
|
||||||
, stateDragStartY = y
|
|
||||||
, stateDragStartXAngle = stateXAngle state
|
|
||||||
, stateDragStartYAngle = stateYAngle state
|
|
||||||
}
|
|
||||||
|
|
||||||
(EventCursorEnter _ cs) ->
|
|
||||||
printEvent "cursor enter" [show cs]
|
|
||||||
|
|
||||||
(EventScroll _ x y) -> do
|
|
||||||
let x' = round x :: Int
|
|
||||||
y' = round y :: Int
|
|
||||||
printEvent "scroll" [show x', show y']
|
|
||||||
env <- ask
|
|
||||||
modify $ \s -> s
|
|
||||||
{ stateZDist =
|
|
||||||
let zDist' = stateZDist s + realToFrac (negate $ y)
|
|
||||||
in curb (envZDistClosest env) (envZDistFarthest env) zDist'
|
|
||||||
}
|
|
||||||
adjustWindow
|
|
||||||
|
|
||||||
(EventKey win k scancode ks mk) -> do
|
|
||||||
when (ks == GLFW.KeyState'Pressed) $ do
|
|
||||||
-- Q, Esc: exit
|
|
||||||
when (k == GLFW.Key'Q || k == GLFW.Key'Escape) $
|
|
||||||
liftIO $ GLFW.setWindowShouldClose win True
|
|
||||||
-- i: print GLFW information
|
|
||||||
when (k == GLFW.Key'I) $
|
|
||||||
liftIO $ printInformation win
|
|
||||||
unless (elem k [GLFW.Key'Up
|
|
||||||
,GLFW.Key'Down
|
|
||||||
,GLFW.Key'Left
|
|
||||||
,GLFW.Key'Right
|
|
||||||
]) $ do
|
|
||||||
printEvent "key" [show k, show scancode, show ks, showModifierKeys mk]
|
|
||||||
|
|
||||||
(EventChar _ c) ->
|
|
||||||
printEvent "char" [show c]
|
|
||||||
|
|
||||||
adjustWindow :: Pioneer ()
|
|
||||||
adjustWindow = do
|
|
||||||
state <- get
|
|
||||||
let fbWidth = stateWindowWidth state
|
|
||||||
fbHeight = stateWindowHeight state
|
|
||||||
fov = 90 --field of view
|
|
||||||
near = 1 --near plane
|
|
||||||
far = 100 --far plane
|
|
||||||
ratio = fromIntegral fbWidth / fromIntegral fbHeight
|
|
||||||
frust = createFrustum fov near far ratio
|
|
||||||
liftIO $ glViewport 0 0 (fromIntegral fbWidth) (fromIntegral fbHeight)
|
|
||||||
put $ state {
|
|
||||||
stateFrustum = frust
|
|
||||||
}
|
|
||||||
|
|
||||||
draw :: Pioneer ()
|
|
||||||
draw = do
|
|
||||||
env <- ask
|
|
||||||
state <- get
|
|
||||||
let xa = stateXAngle state
|
|
||||||
ya = stateYAngle state
|
|
||||||
(GL.UniformLocation proj) = shdrProjMatIndex state
|
|
||||||
(GL.UniformLocation nmat) = shdrNormalMatIndex state
|
|
||||||
(GL.UniformLocation vmat) = shdrViewMatIndex state
|
|
||||||
vi = shdrVertexIndex state
|
|
||||||
ni = shdrNormalIndex state
|
|
||||||
ci = shdrColorIndex state
|
|
||||||
numVert = mapVert state
|
|
||||||
map' = stateMap state
|
|
||||||
frust = stateFrustum state
|
|
||||||
camX = statePositionX state
|
|
||||||
camY = statePositionY state
|
|
||||||
zDist = stateZDist state
|
|
||||||
liftIO $ do
|
|
||||||
--(vi,GL.UniformLocation proj) <- initShader
|
|
||||||
GL.clear [GL.ColorBuffer, GL.DepthBuffer]
|
|
||||||
checkError "foo"
|
|
||||||
--set up projection (= copy from state)
|
|
||||||
with (distribute $ frust) $ \ptr ->
|
|
||||||
glUniformMatrix4fv proj 1 0 (castPtr (ptr :: Ptr (M44 CFloat)))
|
|
||||||
checkError "foo"
|
|
||||||
|
|
||||||
--set up camera
|
|
||||||
let ! cam = getCam (camX,camY) zDist xa ya
|
|
||||||
with (distribute $ cam) $ \ptr ->
|
|
||||||
glUniformMatrix4fv vmat 1 0 (castPtr (ptr :: Ptr (M44 CFloat)))
|
|
||||||
checkError "foo"
|
|
||||||
|
|
||||||
--set up normal--Mat transpose((model*camera)^-1)
|
|
||||||
let normal = (case inv33 ((fmap (^._xyz) cam) ^. _xyz) of
|
|
||||||
(Just a) -> a
|
|
||||||
Nothing -> eye3) :: M33 CFloat
|
|
||||||
nmap = (collect (fmap id) normal) :: M33 CFloat --transpose...
|
|
||||||
|
|
||||||
with (distribute $ nmap) $ \ptr ->
|
|
||||||
glUniformMatrix3fv nmat 1 0 (castPtr (ptr :: Ptr (M33 CFloat)))
|
|
||||||
|
|
||||||
checkError "nmat"
|
|
||||||
|
|
||||||
GL.bindBuffer GL.ArrayBuffer GL.$= Just map'
|
|
||||||
GL.vertexAttribPointer ci GL.$= fgColorIndex
|
|
||||||
GL.vertexAttribArray ci GL.$= GL.Enabled
|
|
||||||
GL.vertexAttribPointer ni GL.$= fgNormalIndex
|
|
||||||
GL.vertexAttribArray ni GL.$= GL.Enabled
|
|
||||||
GL.vertexAttribPointer vi GL.$= fgVertexIndex
|
|
||||||
GL.vertexAttribArray vi GL.$= GL.Enabled
|
|
||||||
checkError "beforeDraw"
|
|
||||||
|
|
||||||
GL.drawArrays GL.Triangles 0 numVert
|
|
||||||
checkError "draw"
|
|
||||||
|
|
||||||
getCursorKeyDirections :: GLFW.Window -> IO (Double, Double)
|
|
||||||
getCursorKeyDirections win = do
|
|
||||||
y0 <- isPress `fmap` GLFW.getKey win GLFW.Key'Up
|
|
||||||
y1 <- isPress `fmap` GLFW.getKey win GLFW.Key'Down
|
|
||||||
x0 <- isPress `fmap` GLFW.getKey win GLFW.Key'Left
|
|
||||||
x1 <- isPress `fmap` GLFW.getKey win GLFW.Key'Right
|
|
||||||
let x0n = if x0 then (-1) else 0
|
|
||||||
x1n = if x1 then 1 else 0
|
|
||||||
y0n = if y0 then (-1) else 0
|
|
||||||
y1n = if y1 then 1 else 0
|
|
||||||
return (x0n + x1n, y0n + y1n)
|
|
||||||
|
|
||||||
getJoystickDirections :: GLFW.Joystick -> IO (Double, Double)
|
|
||||||
getJoystickDirections js = do
|
|
||||||
maxes <- GLFW.getJoystickAxes js
|
|
||||||
return $ case maxes of
|
|
||||||
(Just (x:y:_)) -> (-y, x)
|
|
||||||
_ -> ( 0, 0)
|
|
||||||
|
|
||||||
isPress :: GLFW.KeyState -> Bool
|
|
||||||
isPress GLFW.KeyState'Pressed = True
|
|
||||||
isPress GLFW.KeyState'Repeating = True
|
|
||||||
isPress _ = False
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
|
|
||||||
printInformation :: GLFW.Window -> IO ()
|
|
||||||
printInformation win = do
|
|
||||||
version <- GLFW.getVersion
|
|
||||||
versionString <- GLFW.getVersionString
|
|
||||||
monitorInfos <- runMaybeT getMonitorInfos
|
|
||||||
joystickNames <- getJoystickNames
|
|
||||||
clientAPI <- GLFW.getWindowClientAPI win
|
|
||||||
cv0 <- GLFW.getWindowContextVersionMajor win
|
|
||||||
cv1 <- GLFW.getWindowContextVersionMinor win
|
|
||||||
cv2 <- GLFW.getWindowContextVersionRevision win
|
|
||||||
robustness <- GLFW.getWindowContextRobustness win
|
|
||||||
forwardCompat <- GLFW.getWindowOpenGLForwardCompat win
|
|
||||||
debug <- GLFW.getWindowOpenGLDebugContext win
|
|
||||||
profile <- GLFW.getWindowOpenGLProfile win
|
|
||||||
|
|
||||||
putStrLn $ render $
|
|
||||||
nest 4 (
|
|
||||||
text "------------------------------------------------------------" $+$
|
|
||||||
text "GLFW C library:" $+$
|
|
||||||
nest 4 (
|
|
||||||
text "Version:" <+> renderVersion version $+$
|
|
||||||
text "Version string:" <+> renderVersionString versionString
|
|
||||||
) $+$
|
|
||||||
text "Monitors:" $+$
|
|
||||||
nest 4 (
|
|
||||||
renderMonitorInfos monitorInfos
|
|
||||||
) $+$
|
|
||||||
text "Joysticks:" $+$
|
|
||||||
nest 4 (
|
|
||||||
renderJoystickNames joystickNames
|
|
||||||
) $+$
|
|
||||||
text "OpenGL context:" $+$
|
|
||||||
nest 4 (
|
|
||||||
text "Client API:" <+> renderClientAPI clientAPI $+$
|
|
||||||
text "Version:" <+> renderContextVersion cv0 cv1 cv2 $+$
|
|
||||||
text "Robustness:" <+> renderContextRobustness robustness $+$
|
|
||||||
text "Forward compatibility:" <+> renderForwardCompat forwardCompat $+$
|
|
||||||
text "Debug:" <+> renderDebug debug $+$
|
|
||||||
text "Profile:" <+> renderProfile profile
|
|
||||||
) $+$
|
|
||||||
text "------------------------------------------------------------"
|
|
||||||
)
|
|
||||||
where
|
|
||||||
renderVersion (GLFW.Version v0 v1 v2) =
|
|
||||||
text $ intercalate "." $ map show [v0, v1, v2]
|
|
||||||
|
|
||||||
renderVersionString =
|
|
||||||
text . show
|
|
||||||
|
|
||||||
renderMonitorInfos =
|
|
||||||
maybe (text "(error)") (vcat . map renderMonitorInfo)
|
|
||||||
|
|
||||||
renderMonitorInfo (name, (x,y), (w,h), vms) =
|
|
||||||
text (show name) $+$
|
|
||||||
nest 4 (
|
|
||||||
location <+> size $+$
|
|
||||||
fsep (map renderVideoMode vms)
|
|
||||||
)
|
|
||||||
where
|
|
||||||
location = int x <> text "," <> int y
|
|
||||||
size = int w <> text "x" <> int h <> text "mm"
|
|
||||||
|
|
||||||
renderVideoMode (GLFW.VideoMode w h r g b rr) =
|
|
||||||
brackets $ res <+> rgb <+> hz
|
|
||||||
where
|
|
||||||
res = int w <> text "x" <> int h
|
|
||||||
rgb = int r <> text "x" <> int g <> text "x" <> int b
|
|
||||||
hz = int rr <> text "Hz"
|
|
||||||
|
|
||||||
renderJoystickNames pairs =
|
|
||||||
vcat $ map (\(js, name) -> text (show js) <+> text (show name)) pairs
|
|
||||||
|
|
||||||
renderContextVersion v0 v1 v2 =
|
|
||||||
hcat [int v0, text ".", int v1, text ".", int v2]
|
|
||||||
|
|
||||||
renderClientAPI = text . show
|
|
||||||
renderContextRobustness = text . show
|
|
||||||
renderForwardCompat = text . show
|
|
||||||
renderDebug = text . show
|
|
||||||
renderProfile = text . show
|
|
||||||
|
|
||||||
type MonitorInfo = (String, (Int,Int), (Int,Int), [GLFW.VideoMode])
|
|
||||||
|
|
||||||
getMonitorInfos :: MaybeT IO [MonitorInfo]
|
|
||||||
getMonitorInfos =
|
|
||||||
getMonitors >>= mapM getMonitorInfo
|
|
||||||
where
|
|
||||||
getMonitors :: MaybeT IO [GLFW.Monitor]
|
|
||||||
getMonitors = MaybeT GLFW.getMonitors
|
|
||||||
|
|
||||||
getMonitorInfo :: GLFW.Monitor -> MaybeT IO MonitorInfo
|
|
||||||
getMonitorInfo mon = do
|
|
||||||
name <- getMonitorName mon
|
|
||||||
vms <- getVideoModes mon
|
|
||||||
MaybeT $ do
|
|
||||||
pos <- liftIO $ GLFW.getMonitorPos mon
|
|
||||||
size <- liftIO $ GLFW.getMonitorPhysicalSize mon
|
|
||||||
return $ Just (name, pos, size, vms)
|
|
||||||
|
|
||||||
getMonitorName :: GLFW.Monitor -> MaybeT IO String
|
|
||||||
getMonitorName mon = MaybeT $ GLFW.getMonitorName mon
|
|
||||||
|
|
||||||
getVideoModes :: GLFW.Monitor -> MaybeT IO [GLFW.VideoMode]
|
|
||||||
getVideoModes mon = MaybeT $ GLFW.getVideoModes mon
|
|
||||||
|
|
||||||
getJoystickNames :: IO [(GLFW.Joystick, String)]
|
|
||||||
getJoystickNames =
|
|
||||||
catMaybes `fmap` mapM getJoystick joysticks
|
|
||||||
where
|
|
||||||
getJoystick js =
|
|
||||||
fmap (maybe Nothing (\name -> Just (js, name)))
|
|
||||||
(GLFW.getJoystickName js)
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
|
|
||||||
printEvent :: String -> [String] -> Pioneer ()
|
|
||||||
printEvent cbname fields =
|
|
||||||
liftIO $ putStrLn $ cbname ++ ": " ++ unwords fields
|
|
||||||
|
|
||||||
showModifierKeys :: GLFW.ModifierKeys -> String
|
|
||||||
showModifierKeys mk =
|
|
||||||
"[mod keys: " ++ keys ++ "]"
|
|
||||||
where
|
|
||||||
keys = if null xs then "none" else unwords xs
|
|
||||||
xs = catMaybes ys
|
|
||||||
ys = [ if GLFW.modifierKeysShift mk then Just "shift" else Nothing
|
|
||||||
, if GLFW.modifierKeysControl mk then Just "control" else Nothing
|
|
||||||
, if GLFW.modifierKeysAlt mk then Just "alt" else Nothing
|
|
||||||
, if GLFW.modifierKeysSuper mk then Just "super" else Nothing
|
|
||||||
]
|
|
||||||
|
|
||||||
curb :: Ord a => a -> a -> a -> a
|
|
||||||
curb l h x
|
|
||||||
| x < l = l
|
|
||||||
| x > h = h
|
|
||||||
| otherwise = x
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
|
|
||||||
joysticks :: [GLFW.Joystick]
|
|
||||||
joysticks =
|
|
||||||
[ GLFW.Joystick'1
|
|
||||||
, GLFW.Joystick'2
|
|
||||||
, GLFW.Joystick'3
|
|
||||||
, GLFW.Joystick'4
|
|
||||||
, GLFW.Joystick'5
|
|
||||||
, GLFW.Joystick'6
|
|
||||||
, GLFW.Joystick'7
|
|
||||||
, GLFW.Joystick'8
|
|
||||||
, GLFW.Joystick'9
|
|
||||||
, GLFW.Joystick'10
|
|
||||||
, GLFW.Joystick'11
|
|
||||||
, GLFW.Joystick'12
|
|
||||||
, GLFW.Joystick'13
|
|
||||||
, GLFW.Joystick'14
|
|
||||||
, GLFW.Joystick'15
|
|
||||||
, GLFW.Joystick'16
|
|
||||||
]
|
|
||||||
143
src/Main.hs
143
src/Main.hs
@ -1,17 +1,13 @@
|
|||||||
{-# LANGUAGE BangPatterns, DoAndIfThenElse #-}
|
{-# LANGUAGE BangPatterns, DoAndIfThenElse #-}
|
||||||
module Main where
|
module Main where
|
||||||
|
|
||||||
import Data.Int (Int8)
|
import Graphics.Rendering.OpenGL.GL.Texturing.Specification (texImage2D,TextureTarget2D(Texture2D))
|
||||||
import Graphics.Rendering.OpenGL.GL.Texturing.Specification (TextureSize2D)
|
|
||||||
import Graphics.Rendering.OpenGL.GL.PixelRectangles.ColorTable (PixelInternalFormat(..))
|
import Graphics.Rendering.OpenGL.GL.PixelRectangles.ColorTable (PixelInternalFormat(..))
|
||||||
import Graphics.Rendering.OpenGL.GL.Texturing.Specification (texImage2D)
|
|
||||||
import Graphics.Rendering.OpenGL.GL.Texturing.Parameters (textureFilter)
|
|
||||||
import Graphics.Rendering.OpenGL.GL.Texturing.Specification (TextureTarget2D(Texture2D))
|
|
||||||
import Graphics.Rendering.OpenGL.GL.Texturing.Objects (textureBinding)
|
import Graphics.Rendering.OpenGL.GL.Texturing.Objects (textureBinding)
|
||||||
import Graphics.Rendering.OpenGL.GL.Texturing.Parameters (TextureFilter(..))
|
import Graphics.Rendering.OpenGL.GL.Texturing.Parameters (TextureFilter(..),textureFilter)
|
||||||
|
|
||||||
-- Monad-foo and higher functional stuff
|
-- Monad-foo and higher functional stuff
|
||||||
import Control.Monad (unless, void, when, join, liftM)
|
import Control.Monad (unless, when, join)
|
||||||
import Control.Arrow ((***))
|
import Control.Arrow ((***))
|
||||||
|
|
||||||
-- data consistency/conversion
|
-- data consistency/conversion
|
||||||
@ -19,10 +15,7 @@ import Control.Concurrent (threadDelay)
|
|||||||
import Control.Concurrent.STM (TQueue,
|
import Control.Concurrent.STM (TQueue,
|
||||||
newTQueueIO)
|
newTQueueIO)
|
||||||
|
|
||||||
import Control.Monad.RWS.Strict (RWST, ask, asks,
|
import Control.Monad.RWS.Strict (ask, evalRWST, get, liftIO, modify)
|
||||||
evalRWST, get, liftIO,
|
|
||||||
modify, put)
|
|
||||||
import Control.Monad.Trans.Class
|
|
||||||
import Control.Monad.Trans.State (evalStateT)
|
import Control.Monad.Trans.State (evalStateT)
|
||||||
import Data.Functor ((<$>))
|
import Data.Functor ((<$>))
|
||||||
import Data.Distributive (distribute, collect)
|
import Data.Distributive (distribute, collect)
|
||||||
@ -31,10 +24,8 @@ import Data.Monoid (mappend)
|
|||||||
-- FFI
|
-- FFI
|
||||||
import Foreign (Ptr, castPtr, with, sizeOf)
|
import Foreign (Ptr, castPtr, with, sizeOf)
|
||||||
import Foreign.C (CFloat)
|
import Foreign.C (CFloat)
|
||||||
import Foreign.C.Types (CInt)
|
|
||||||
import Foreign.Marshal.Array (pokeArray)
|
import Foreign.Marshal.Array (pokeArray)
|
||||||
import Foreign.Marshal.Alloc (allocaBytes)
|
import Foreign.Marshal.Alloc (allocaBytes)
|
||||||
import Data.Word (Word8)
|
|
||||||
|
|
||||||
-- Math
|
-- Math
|
||||||
import Control.Lens ((^.), (.~), (%~))
|
import Control.Lens ((^.), (.~), (%~))
|
||||||
@ -42,8 +33,6 @@ import qualified Linear as L
|
|||||||
|
|
||||||
-- GUI
|
-- GUI
|
||||||
import Graphics.UI.SDL as SDL
|
import Graphics.UI.SDL as SDL
|
||||||
--import Graphics.UI.SDL.TTF as TTF
|
|
||||||
--import Graphics.UI.SDL.TTF.Types
|
|
||||||
|
|
||||||
-- Render
|
-- Render
|
||||||
import qualified Graphics.Rendering.OpenGL.GL as GL
|
import qualified Graphics.Rendering.OpenGL.GL as GL
|
||||||
@ -54,58 +43,53 @@ import Graphics.GLUtil.BufferObjects (offset0)
|
|||||||
import Graphics.Rendering.OpenGL.Raw.ARB.TessellationShader
|
import Graphics.Rendering.OpenGL.Raw.ARB.TessellationShader
|
||||||
-- Our modules
|
-- Our modules
|
||||||
import Map.Graphics
|
import Map.Graphics
|
||||||
import Render.Misc (checkError,
|
import Render.Misc (checkError, createFrustum, getCam, curb,
|
||||||
createFrustum, getCam,
|
|
||||||
curb, tryWithTexture,
|
|
||||||
genColorData)
|
genColorData)
|
||||||
import Render.Render (initRendering,
|
import Render.Render (initRendering,
|
||||||
initMapShader,
|
initMapShader,
|
||||||
initHud)
|
initHud)
|
||||||
import UI.Callbacks
|
import UI.Callbacks
|
||||||
import UI.GUIOverlay
|
|
||||||
import Types
|
import Types
|
||||||
import Importer.IQM.Parser
|
import Importer.IQM.Parser
|
||||||
import Data.Attoparsec.Char8 (parseTest)
|
import Data.Attoparsec.Char8 (parseTest)
|
||||||
import qualified Data.ByteString as B
|
import qualified Data.ByteString as B
|
||||||
|
|
||||||
--import ThirdParty.Flippers
|
-- import qualified Debug.Trace as D (trace)
|
||||||
|
|
||||||
import qualified Debug.Trace as D (trace)
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
testParser :: IO ()
|
testParser :: IO ()
|
||||||
testParser = do
|
testParser = do
|
||||||
f <- B.readFile "sample.iqm"
|
f <- B.readFile "sample.iqm"
|
||||||
parseTest (evalStateT parseIQM 0) f
|
parseTest (evalStateT parseIQM 0) f
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = do
|
main =
|
||||||
SDL.withInit [InitVideo, InitAudio, InitEvents, InitTimer] $ do --also: InitNoParachute -> faster, without parachute!
|
SDL.withInit [InitVideo, InitAudio, InitEvents, InitTimer] $ --also: InitNoParachute -> faster, without parachute!
|
||||||
SDL.withWindow "Pioneers" (SDL.Position 100 100) (Size 1024 600) [WindowOpengl -- we want openGL
|
SDL.withWindow "Pioneers" (SDL.Position 100 100) (Size 1024 600) [WindowOpengl -- we want openGL
|
||||||
,WindowShown -- window should be visible
|
,WindowShown -- window should be visible
|
||||||
,WindowResizable -- and resizable
|
,WindowResizable -- and resizable
|
||||||
,WindowInputFocus -- focused (=> active)
|
,WindowInputFocus -- focused (=> active)
|
||||||
,WindowMouseFocus -- Mouse into it
|
,WindowMouseFocus -- Mouse into it
|
||||||
--,WindowInputGrabbed-- never let go of input (KB/Mouse)
|
--,WindowInputGrabbed-- never let go of input (KB/Mouse)
|
||||||
] $ \window -> do
|
] $ \window' -> do
|
||||||
withOpenGL window $ do
|
withOpenGL window' $ do
|
||||||
|
|
||||||
--Create Renderbuffer & Framebuffer
|
--Create Renderbuffer & Framebuffer
|
||||||
-- We will render to this buffer to copy the result into textures
|
-- We will render to this buffer to copy the result into textures
|
||||||
renderBuffer <- GL.genObjectName
|
renderBuffer <- GL.genObjectName
|
||||||
frameBuffer <- GL.genObjectName
|
frameBuffer <- GL.genObjectName
|
||||||
GL.bindFramebuffer GL.Framebuffer GL.$= frameBuffer
|
GL.bindFramebuffer GL.Framebuffer GL.$= frameBuffer
|
||||||
GL.bindRenderbuffer GL.Renderbuffer GL.$= renderBuffer
|
GL.bindRenderbuffer GL.Renderbuffer GL.$= renderBuffer
|
||||||
|
|
||||||
(Size fbWidth fbHeight) <- glGetDrawableSize window
|
(Size fbWidth fbHeight) <- glGetDrawableSize window'
|
||||||
initRendering
|
initRendering
|
||||||
--generate map vertices
|
--generate map vertices
|
||||||
(mapBuffer, vert) <- getMapBufferObject
|
(mapBuffer, vert) <- getMapBufferObject
|
||||||
(mapprog, ci, ni, vi, pri, vii, mi, nmi, tli, tlo, mapTex) <- initMapShader
|
(mapprog, ci, ni, vi, pri, vii, mi, nmi, tli, tlo, mapTex) <- initMapShader
|
||||||
print window
|
print window'
|
||||||
eventQueue <- newTQueueIO :: IO (TQueue Event)
|
eventQueue <- newTQueueIO :: IO (TQueue Event)
|
||||||
putStrLn "foo"
|
putStrLn "foo"
|
||||||
now <- getCurrentTime
|
now <- getCurrentTime
|
||||||
@ -114,9 +98,9 @@ main = do
|
|||||||
--TTF.setFontStyle font TTFNormal
|
--TTF.setFontStyle font TTFNormal
|
||||||
--TTF.setFontHinting font TTFHNormal
|
--TTF.setFontHinting font TTFHNormal
|
||||||
|
|
||||||
glHud <- initHud
|
glHud' <- initHud
|
||||||
let zDistClosest = 1
|
let zDistClosest' = 1
|
||||||
zDistFarthest = zDistClosest + 50
|
zDistFarthest' = zDistClosest' + 50
|
||||||
--TODO: Move near/far/fov to state for runtime-changability & central storage
|
--TODO: Move near/far/fov to state for runtime-changability & central storage
|
||||||
fov = 90 --field of view
|
fov = 90 --field of view
|
||||||
near = 1 --near plane
|
near = 1 --near plane
|
||||||
@ -129,7 +113,7 @@ main = do
|
|||||||
, _left = False
|
, _left = False
|
||||||
, _right = False
|
, _right = False
|
||||||
}
|
}
|
||||||
glMap = GLMapState
|
glMap' = GLMapState
|
||||||
{ _shdrVertexIndex = vi
|
{ _shdrVertexIndex = vi
|
||||||
, _shdrNormalIndex = ni
|
, _shdrNormalIndex = ni
|
||||||
, _shdrColorIndex = ci
|
, _shdrColorIndex = ci
|
||||||
@ -147,11 +131,9 @@ main = do
|
|||||||
}
|
}
|
||||||
env = Env
|
env = Env
|
||||||
{ _eventsChan = eventQueue
|
{ _eventsChan = eventQueue
|
||||||
, _windowObject = window
|
, _windowObject = window'
|
||||||
, _zDistClosest = zDistClosest
|
, _zDistClosest = zDistClosest'
|
||||||
, _zDistFarthest = zDistFarthest
|
, _zDistFarthest = zDistFarthest'
|
||||||
--, _renderer = renderer
|
|
||||||
--, envFont = font
|
|
||||||
}
|
}
|
||||||
state = State
|
state = State
|
||||||
{ _window = WindowState
|
{ _window = WindowState
|
||||||
@ -188,8 +170,8 @@ main = do
|
|||||||
{ _arrowsPressed = aks
|
{ _arrowsPressed = aks
|
||||||
}
|
}
|
||||||
, _gl = GLState
|
, _gl = GLState
|
||||||
{ _glMap = glMap
|
{ _glMap = glMap'
|
||||||
, _glHud = glHud
|
, _glHud = glHud'
|
||||||
, _glRenderbuffer = renderBuffer
|
, _glRenderbuffer = renderBuffer
|
||||||
, _glFramebuffer = frameBuffer
|
, _glFramebuffer = frameBuffer
|
||||||
}
|
}
|
||||||
@ -203,8 +185,8 @@ main = do
|
|||||||
|
|
||||||
putStrLn "init done."
|
putStrLn "init done."
|
||||||
uncurry mappend <$> evalRWST (adjustWindow >> run) env state
|
uncurry mappend <$> evalRWST (adjustWindow >> run) env state
|
||||||
putStrLn "shutdown complete."
|
putStrLn "shutdown complete."
|
||||||
|
|
||||||
--SDL.glDeleteContext mainGlContext
|
--SDL.glDeleteContext mainGlContext
|
||||||
--SDL.destroyRenderer renderer
|
--SDL.destroyRenderer renderer
|
||||||
--destroyWindow window
|
--destroyWindow window
|
||||||
@ -214,31 +196,28 @@ main = do
|
|||||||
draw :: Pioneers ()
|
draw :: Pioneers ()
|
||||||
draw = do
|
draw = do
|
||||||
state <- get
|
state <- get
|
||||||
env <- ask
|
|
||||||
let xa = state ^. camera.xAngle
|
let xa = state ^. camera.xAngle
|
||||||
ya = state ^. camera.yAngle
|
ya = state ^. camera.yAngle
|
||||||
(GL.UniformLocation proj) = state ^. gl.glMap.shdrProjMatIndex
|
(GL.UniformLocation proj) = state ^. gl.glMap.shdrProjMatIndex
|
||||||
(GL.UniformLocation nmat) = state ^. gl.glMap.shdrNormalMatIndex
|
(GL.UniformLocation nmat) = state ^. gl.glMap.shdrNormalMatIndex
|
||||||
(GL.UniformLocation vmat) = state ^. gl.glMap.shdrViewMatIndex
|
(GL.UniformLocation vmat) = state ^. gl.glMap.shdrViewMatIndex
|
||||||
(GL.UniformLocation tli) = state ^. gl.glMap.shdrTessInnerIndex
|
(GL.UniformLocation tli) = state ^. gl.glMap.shdrTessInnerIndex
|
||||||
(GL.UniformLocation tlo) = state ^. gl.glMap.shdrTessOuterIndex
|
(GL.UniformLocation tlo) = state ^. gl.glMap.shdrTessOuterIndex
|
||||||
vi = state ^. gl.glMap.shdrVertexIndex
|
vi = state ^. gl.glMap.shdrVertexIndex
|
||||||
ni = state ^. gl.glMap.shdrNormalIndex
|
ni = state ^. gl.glMap.shdrNormalIndex
|
||||||
ci = state ^. gl.glMap.shdrColorIndex
|
ci = state ^. gl.glMap.shdrColorIndex
|
||||||
numVert = state ^. gl.glMap.mapVert
|
numVert = state ^. gl.glMap.mapVert
|
||||||
map' = state ^. gl.glMap.stateMap
|
map' = state ^. gl.glMap.stateMap
|
||||||
frust = state ^. camera.frustum
|
frust = state ^. camera.frustum
|
||||||
camX = state ^. camera.camPosition._x
|
camX = state ^. camera.camPosition._x
|
||||||
camY = state ^. camera.camPosition._y
|
camY = state ^. camera.camPosition._y
|
||||||
zDist' = state ^. camera.zDist
|
zDist' = state ^. camera.zDist
|
||||||
tessFac = state ^. gl.glMap.stateTessellationFactor
|
tessFac = state ^. gl.glMap.stateTessellationFactor
|
||||||
window = env ^. windowObject
|
|
||||||
rb = state ^. gl.glRenderbuffer
|
|
||||||
when (state ^. ui . uiHasChanged) prepareGUI
|
when (state ^. ui . uiHasChanged) prepareGUI
|
||||||
liftIO $ do
|
liftIO $ do
|
||||||
--bind renderbuffer and set sample 0 as target
|
--bind renderbuffer and set sample 0 as target
|
||||||
--GL.bindRenderbuffer GL.Renderbuffer GL.$= rb
|
--GL.bindRenderbuffer GL.Renderbuffer GL.$= rb
|
||||||
--GL.bindFramebuffer GL.Framebuffer GL.$= GL.defaultFramebufferObject
|
--GL.bindFramebuffer GL.Framebuffer GL.$= GL.defaultFramebufferObject
|
||||||
--checkError "bind renderbuffer"
|
--checkError "bind renderbuffer"
|
||||||
|
|
||||||
--checkError "clear renderbuffer"
|
--checkError "clear renderbuffer"
|
||||||
@ -251,7 +230,7 @@ draw = do
|
|||||||
|
|
||||||
-- draw map
|
-- draw map
|
||||||
--(vi,GL.UniformLocation proj) <- initShader
|
--(vi,GL.UniformLocation proj) <- initShader
|
||||||
|
|
||||||
GL.bindFramebuffer GL.Framebuffer GL.$= (state ^. gl.glFramebuffer)
|
GL.bindFramebuffer GL.Framebuffer GL.$= (state ^. gl.glFramebuffer)
|
||||||
GL.bindRenderbuffer GL.Renderbuffer GL.$= (state ^. gl.glRenderbuffer)
|
GL.bindRenderbuffer GL.Renderbuffer GL.$= (state ^. gl.glRenderbuffer)
|
||||||
GL.framebufferRenderbuffer
|
GL.framebufferRenderbuffer
|
||||||
@ -260,14 +239,14 @@ draw = do
|
|||||||
GL.Renderbuffer
|
GL.Renderbuffer
|
||||||
(state ^. gl.glRenderbuffer)
|
(state ^. gl.glRenderbuffer)
|
||||||
textureBinding GL.Texture2D GL.$= Just (state ^. gl.glMap.mapTexture)
|
textureBinding GL.Texture2D GL.$= Just (state ^. gl.glMap.mapTexture)
|
||||||
|
|
||||||
GL.framebufferTexture2D
|
GL.framebufferTexture2D
|
||||||
GL.Framebuffer
|
GL.Framebuffer
|
||||||
(GL.ColorAttachment 0)
|
(GL.ColorAttachment 0)
|
||||||
GL.Texture2D
|
GL.Texture2D
|
||||||
(state ^. gl.glMap.mapTexture)
|
(state ^. gl.glMap.mapTexture)
|
||||||
0
|
0
|
||||||
|
|
||||||
-- Render to FrameBufferObject
|
-- Render to FrameBufferObject
|
||||||
GL.drawBuffers GL.$= [GL.FBOColorAttachment 0]
|
GL.drawBuffers GL.$= [GL.FBOColorAttachment 0]
|
||||||
checkError "setup Render-Target"
|
checkError "setup Render-Target"
|
||||||
@ -314,7 +293,8 @@ draw = do
|
|||||||
checkError "beforeDraw"
|
checkError "beforeDraw"
|
||||||
|
|
||||||
glPatchParameteri gl_PATCH_VERTICES 3
|
glPatchParameteri gl_PATCH_VERTICES 3
|
||||||
glPolygonMode gl_FRONT gl_LINE
|
|
||||||
|
GL.cullFace GL.$= Just GL.Front
|
||||||
|
|
||||||
glDrawArrays gl_PATCHES 0 (fromIntegral numVert)
|
glDrawArrays gl_PATCHES 0 (fromIntegral numVert)
|
||||||
checkError "draw map"
|
checkError "draw map"
|
||||||
@ -345,11 +325,11 @@ draw = do
|
|||||||
GL.activeTexture GL.$= GL.TextureUnit 1
|
GL.activeTexture GL.$= GL.TextureUnit 1
|
||||||
textureBinding GL.Texture2D GL.$= Just (state ^. gl.glMap.mapTexture)
|
textureBinding GL.Texture2D GL.$= Just (state ^. gl.glMap.mapTexture)
|
||||||
GL.uniform (hud ^. hudBackIndex) GL.$= GL.Index1 (1::GL.GLint)
|
GL.uniform (hud ^. hudBackIndex) GL.$= GL.Index1 (1::GL.GLint)
|
||||||
|
|
||||||
GL.bindBuffer GL.ArrayBuffer GL.$= Just (hud ^. hudVBO)
|
GL.bindBuffer GL.ArrayBuffer GL.$= Just (hud ^. hudVBO)
|
||||||
GL.vertexAttribPointer (hud ^. hudVertexIndex) GL.$= (GL.ToFloat, vad)
|
GL.vertexAttribPointer (hud ^. hudVertexIndex) GL.$= (GL.ToFloat, vad)
|
||||||
GL.vertexAttribArray (hud ^. hudVertexIndex) GL.$= GL.Enabled
|
GL.vertexAttribArray (hud ^. hudVertexIndex) GL.$= GL.Enabled
|
||||||
|
|
||||||
GL.bindBuffer GL.ElementArrayBuffer GL.$= Just (hud ^. hudEBO)
|
GL.bindBuffer GL.ElementArrayBuffer GL.$= Just (hud ^. hudEBO)
|
||||||
GL.drawElements GL.TriangleStrip 4 GL.UnsignedInt offset0
|
GL.drawElements GL.TriangleStrip 4 GL.UnsignedInt offset0
|
||||||
|
|
||||||
@ -393,14 +373,14 @@ run = do
|
|||||||
| newYAngle' < (-pi) = newYAngle' + 2 * pi
|
| newYAngle' < (-pi) = newYAngle' + 2 * pi
|
||||||
| otherwise = newYAngle'
|
| otherwise = newYAngle'
|
||||||
newYAngle' = sodya + myrot/100
|
newYAngle' = sodya + myrot/100
|
||||||
|
|
||||||
modify $ ((camera.xAngle) .~ newXAngle)
|
modify $ ((camera.xAngle) .~ newXAngle)
|
||||||
. ((camera.yAngle) .~ newYAngle)
|
. ((camera.yAngle) .~ newYAngle)
|
||||||
|
|
||||||
-- get cursor-keys - if pressed
|
-- get cursor-keys - if pressed
|
||||||
--TODO: Add sin/cos from stateYAngle
|
--TODO: Add sin/cos from stateYAngle
|
||||||
(kxrot, kyrot) <- fmap (join (***) fromIntegral) getArrowMovement
|
(kxrot, kyrot) <- fmap (join (***) fromIntegral) getArrowMovement
|
||||||
let
|
let
|
||||||
multc = cos $ state ^. camera.yAngle
|
multc = cos $ state ^. camera.yAngle
|
||||||
mults = sin $ state ^. camera.yAngle
|
mults = sin $ state ^. camera.yAngle
|
||||||
modx x' = x' - 0.2 * kxrot * multc
|
modx x' = x' - 0.2 * kxrot * multc
|
||||||
@ -419,23 +399,24 @@ run = do
|
|||||||
-}
|
-}
|
||||||
|
|
||||||
mt <- liftIO $ do
|
mt <- liftIO $ do
|
||||||
|
let double = fromRational.toRational :: (Real a) => a -> Double
|
||||||
now <- getCurrentTime
|
now <- getCurrentTime
|
||||||
diff <- return $ diffUTCTime now (state ^. io.clock) -- get time-diffs
|
diff <- return $ diffUTCTime now (state ^. io.clock) -- get time-diffs
|
||||||
title <- return $ unwords ["Pioneers @ ",show ((round .fromRational.toRational $ 1.0/diff)::Int),"fps"]
|
title <- return $ unwords ["Pioneers @ ",show ((round . double $ 1.0/diff)::Int),"fps"]
|
||||||
setWindowTitle (env ^. windowObject) title
|
setWindowTitle (env ^. windowObject) title
|
||||||
sleepAmount <- return $ floor (max 0 (0.04 - diff))*1000000 -- get time until next frame in microseconds
|
sleepAmount <- return $ floor (max 0 (0.04 - diff))*1000000 -- get time until next frame in microseconds
|
||||||
threadDelay sleepAmount
|
threadDelay sleepAmount
|
||||||
return now
|
return now
|
||||||
-- set state with new clock-time
|
-- set state with new clock-time
|
||||||
modify $ io.clock .~ mt
|
modify $ io.clock .~ mt
|
||||||
shouldClose <- return $ state ^. window.shouldClose
|
shouldClose' <- return $ state ^. window.shouldClose
|
||||||
unless shouldClose run
|
unless shouldClose' run
|
||||||
|
|
||||||
getArrowMovement :: Pioneers (Int, Int)
|
getArrowMovement :: Pioneers (Int, Int)
|
||||||
getArrowMovement = do
|
getArrowMovement = do
|
||||||
state <- get
|
state <- get
|
||||||
aks <- return $ state ^. (keyboard.arrowsPressed)
|
aks <- return $ state ^. (keyboard.arrowsPressed)
|
||||||
let
|
let
|
||||||
horz = left' + right'
|
horz = left' + right'
|
||||||
vert = up'+down'
|
vert = up'+down'
|
||||||
left' = if aks ^. left then -1 else 0
|
left' = if aks ^. left then -1 else 0
|
||||||
@ -447,7 +428,6 @@ getArrowMovement = do
|
|||||||
adjustWindow :: Pioneers ()
|
adjustWindow :: Pioneers ()
|
||||||
adjustWindow = do
|
adjustWindow = do
|
||||||
state <- get
|
state <- get
|
||||||
env <- ask
|
|
||||||
let fbWidth = state ^. window.width
|
let fbWidth = state ^. window.width
|
||||||
fbHeight = state ^. window.height
|
fbHeight = state ^. window.height
|
||||||
fov = 90 --field of view
|
fov = 90 --field of view
|
||||||
@ -466,7 +446,7 @@ adjustWindow = do
|
|||||||
renderBuffer <- GL.genObjectName
|
renderBuffer <- GL.genObjectName
|
||||||
GL.bindRenderbuffer GL.Renderbuffer GL.$= renderBuffer
|
GL.bindRenderbuffer GL.Renderbuffer GL.$= renderBuffer
|
||||||
GL.renderbufferStorage
|
GL.renderbufferStorage
|
||||||
GL.Renderbuffer -- use the only available renderbuffer
|
GL.Renderbuffer -- use the only available renderbuffer
|
||||||
-- - must be this constant.
|
-- - must be this constant.
|
||||||
GL.DepthComponent' -- 32-bit float-rgba-color
|
GL.DepthComponent' -- 32-bit float-rgba-color
|
||||||
(GL.RenderbufferSize fbCWidth fbCHeight) -- size of buffer
|
(GL.RenderbufferSize fbCWidth fbCHeight) -- size of buffer
|
||||||
@ -521,7 +501,7 @@ processEvent e = do
|
|||||||
_ ->
|
_ ->
|
||||||
return ()
|
return ()
|
||||||
--liftIO $ putStrLn $ unwords ["Unhandled Window-Event:",show e]
|
--liftIO $ putStrLn $ unwords ["Unhandled Window-Event:",show e]
|
||||||
Keyboard movement _ isRepeated key -> --up/down window(ignored) true/false actualKey
|
Keyboard movement _ _{-isRepeated-} key -> --up/down window(ignored) true/false actualKey
|
||||||
-- need modifiers? use "keyModifiers key" to get them
|
-- need modifiers? use "keyModifiers key" to get them
|
||||||
let aks = keyboard.arrowsPressed in
|
let aks = keyboard.arrowsPressed in
|
||||||
case keyScancode key of
|
case keyScancode key of
|
||||||
@ -551,7 +531,7 @@ processEvent e = do
|
|||||||
liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ state ^. gl.glMap.stateTessellationFactor]
|
liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ state ^. gl.glMap.stateTessellationFactor]
|
||||||
_ ->
|
_ ->
|
||||||
return ()
|
return ()
|
||||||
MouseMotion _ mouseId st (SDL.Position x y) xrel yrel -> do
|
MouseMotion _ _{-mouseId-} _{-st-} (SDL.Position x y) _{-xrel-} _{-yrel-} -> do
|
||||||
state <- get
|
state <- get
|
||||||
when (state ^. mouse.isDown && not (state ^. mouse.isDragging)) $
|
when (state ^. mouse.isDown && not (state ^. mouse.isDragging)) $
|
||||||
modify $ (mouse.isDragging .~ True)
|
modify $ (mouse.isDragging .~ True)
|
||||||
@ -559,10 +539,10 @@ processEvent e = do
|
|||||||
. (mouse.dragStartY .~ (fromIntegral y))
|
. (mouse.dragStartY .~ (fromIntegral y))
|
||||||
. (mouse.dragStartXAngle .~ (state ^. camera.xAngle))
|
. (mouse.dragStartXAngle .~ (state ^. camera.xAngle))
|
||||||
. (mouse.dragStartYAngle .~ (state ^. camera.yAngle))
|
. (mouse.dragStartYAngle .~ (state ^. camera.yAngle))
|
||||||
|
|
||||||
modify $ (mouse.mousePosition. Types._x .~ (fromIntegral x))
|
modify $ (mouse.mousePosition. Types._x .~ (fromIntegral x))
|
||||||
. (mouse.mousePosition. Types._y .~ (fromIntegral y))
|
. (mouse.mousePosition. Types._y .~ (fromIntegral y))
|
||||||
MouseButton _ mouseId button state (SDL.Position x y) ->
|
MouseButton _ _{-mouseId-} button state (SDL.Position x y) ->
|
||||||
case button of
|
case button of
|
||||||
LeftButton -> do
|
LeftButton -> do
|
||||||
let pressed = state == Pressed
|
let pressed = state == Pressed
|
||||||
@ -577,10 +557,9 @@ processEvent e = do
|
|||||||
when (state == Released) $ alternateClickHandler (UI.Callbacks.Pixel x y)
|
when (state == Released) $ alternateClickHandler (UI.Callbacks.Pixel x y)
|
||||||
_ ->
|
_ ->
|
||||||
return ()
|
return ()
|
||||||
MouseWheel _ mouseId hscroll vscroll -> do
|
MouseWheel _ _{-mouseId-} _{-hscroll-} vscroll -> do
|
||||||
env <- ask
|
|
||||||
state <- get
|
state <- get
|
||||||
let zDist' = (state ^. camera.zDist) + realToFrac (negate vscroll) in
|
let zDist' = (state ^. camera.zDist) + realToFrac (negate vscroll) in
|
||||||
modify $ camera.zDist .~ (curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist')
|
modify $ camera.zDist .~ (curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist')
|
||||||
Quit -> modify $ window.shouldClose .~ True
|
Quit -> modify $ window.shouldClose .~ True
|
||||||
-- there is more (joystic, touchInterface, ...), but currently ignored
|
-- there is more (joystic, touchInterface, ...), but currently ignored
|
||||||
|
|||||||
@ -1,4 +1,4 @@
|
|||||||
module PioneerTypes
|
module PioneerTypes
|
||||||
where
|
where
|
||||||
|
|
||||||
data Structure = Flag -- Flag
|
data Structure = Flag -- Flag
|
||||||
@ -36,7 +36,7 @@ data Structure = Flag -- Flag
|
|||||||
deriving (Show, Eq)
|
deriving (Show, Eq)
|
||||||
|
|
||||||
data Amount = Infinite -- Neverending supply
|
data Amount = Infinite -- Neverending supply
|
||||||
| Finite Int -- Finite supply
|
| Finite Int -- Finite supply
|
||||||
|
|
||||||
-- Extremely preliminary, expand when needed
|
-- Extremely preliminary, expand when needed
|
||||||
data Commodity = WoodPlank
|
data Commodity = WoodPlank
|
||||||
@ -54,9 +54,9 @@ data Resource = Coal
|
|||||||
|
|
||||||
instance Show Amount where
|
instance Show Amount where
|
||||||
show (Infinite) = "inexhaustable supply"
|
show (Infinite) = "inexhaustable supply"
|
||||||
show (Finite n) = (show n) ++ " left"
|
show (Finite n) = show n ++ " left"
|
||||||
|
|
||||||
instance Show Commodity where
|
instance Show Commodity where
|
||||||
show WoodPlank = "wooden plank"
|
show WoodPlank = "wooden plank"
|
||||||
show Sword = "sword"
|
show Sword = "sword"
|
||||||
show Fish = "fish"
|
show Fish = "fish"
|
||||||
|
|||||||
@ -8,7 +8,6 @@ import Graphics.Rendering.OpenGL.GL.Shaders
|
|||||||
import Graphics.Rendering.OpenGL.GL.StateVar
|
import Graphics.Rendering.OpenGL.GL.StateVar
|
||||||
import Graphics.Rendering.OpenGL.GL.StringQueries
|
import Graphics.Rendering.OpenGL.GL.StringQueries
|
||||||
import Graphics.Rendering.OpenGL.GLU.Errors
|
import Graphics.Rendering.OpenGL.GLU.Errors
|
||||||
import Graphics.Rendering.OpenGL.Raw.Core31
|
|
||||||
import Graphics.UI.SDL.Types (Texture)
|
import Graphics.UI.SDL.Types (Texture)
|
||||||
import System.IO (hPutStrLn, stderr)
|
import System.IO (hPutStrLn, stderr)
|
||||||
import Linear
|
import Linear
|
||||||
@ -62,7 +61,7 @@ createProgramUsing shaders = do
|
|||||||
|
|
||||||
createFrustum :: Float -> Float -> Float -> Float -> M44 CFloat
|
createFrustum :: Float -> Float -> Float -> Float -> M44 CFloat
|
||||||
createFrustum fov n' f' rat =
|
createFrustum fov n' f' rat =
|
||||||
let
|
let
|
||||||
f = realToFrac f'
|
f = realToFrac f'
|
||||||
n = realToFrac n'
|
n = realToFrac n'
|
||||||
s = realToFrac $ recip (tan $ fov*0.5 * pi / 180)
|
s = realToFrac $ recip (tan $ fov*0.5 * pi / 180)
|
||||||
@ -78,7 +77,7 @@ createFrustum fov n' f' rat =
|
|||||||
|
|
||||||
-- from vmath.h
|
-- from vmath.h
|
||||||
lookAt :: V3 CFloat -> V3 CFloat -> V3 CFloat -> M44 CFloat
|
lookAt :: V3 CFloat -> V3 CFloat -> V3 CFloat -> M44 CFloat
|
||||||
lookAt eye@(V3 ex ey ez) center up =
|
lookAt eye center up' =
|
||||||
V4
|
V4
|
||||||
(V4 xx xy xz (-dot x eye))
|
(V4 xx xy xz (-dot x eye))
|
||||||
(V4 yx yy yz (-dot y eye))
|
(V4 yx yy yz (-dot y eye))
|
||||||
@ -86,7 +85,7 @@ lookAt eye@(V3 ex ey ez) center up =
|
|||||||
(V4 0 0 0 1)
|
(V4 0 0 0 1)
|
||||||
where
|
where
|
||||||
z@(V3 zx zy zz) = normalize (eye ^-^ center)
|
z@(V3 zx zy zz) = normalize (eye ^-^ center)
|
||||||
x@(V3 xx xy xz) = normalize (cross up z)
|
x@(V3 xx xy xz) = normalize (cross up' z)
|
||||||
y@(V3 yx yy yz) = normalize (cross z x)
|
y@(V3 yx yy yz) = normalize (cross z x)
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
@ -2,8 +2,6 @@
|
|||||||
module Render.Render where
|
module Render.Render where
|
||||||
|
|
||||||
import qualified Data.ByteString as B
|
import qualified Data.ByteString as B
|
||||||
import Data.Array.Storable
|
|
||||||
import qualified Data.Vector.Storable as V
|
|
||||||
import Foreign.Marshal.Array (withArray)
|
import Foreign.Marshal.Array (withArray)
|
||||||
import Foreign.Storable
|
import Foreign.Storable
|
||||||
import Graphics.Rendering.OpenGL.GL.BufferObjects
|
import Graphics.Rendering.OpenGL.GL.BufferObjects
|
||||||
@ -14,13 +12,10 @@ import Graphics.Rendering.OpenGL.GL.Shaders
|
|||||||
import Graphics.Rendering.OpenGL.GL.StateVar
|
import Graphics.Rendering.OpenGL.GL.StateVar
|
||||||
import Graphics.Rendering.OpenGL.GL.Texturing.Objects (TextureObject)
|
import Graphics.Rendering.OpenGL.GL.Texturing.Objects (TextureObject)
|
||||||
import Graphics.Rendering.OpenGL.GL.VertexArrays (Capability (..),
|
import Graphics.Rendering.OpenGL.GL.VertexArrays (Capability (..),
|
||||||
vertexAttribArray,
|
vertexAttribArray)
|
||||||
VertexArrayDescriptor,
|
|
||||||
DataType(Float))
|
|
||||||
import Graphics.Rendering.OpenGL.GL.VertexSpec
|
import Graphics.Rendering.OpenGL.GL.VertexSpec
|
||||||
import Graphics.Rendering.OpenGL.Raw.Core31
|
import Graphics.Rendering.OpenGL.Raw.Core31
|
||||||
import Render.Misc
|
import Render.Misc
|
||||||
import Foreign.Ptr (Ptr, wordPtrToPtr)
|
|
||||||
|
|
||||||
import Types
|
import Types
|
||||||
import Graphics.GLUtil.BufferObjects (makeBuffer)
|
import Graphics.GLUtil.BufferObjects (makeBuffer)
|
||||||
@ -169,7 +164,7 @@ initHud = do
|
|||||||
, _hudEBO = ebo
|
, _hudEBO = ebo
|
||||||
, _hudProgram = program
|
, _hudProgram = program
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
@ -3,7 +3,7 @@ module Types where
|
|||||||
|
|
||||||
import Control.Concurrent.STM (TQueue)
|
import Control.Concurrent.STM (TQueue)
|
||||||
import qualified Graphics.Rendering.OpenGL.GL as GL
|
import qualified Graphics.Rendering.OpenGL.GL as GL
|
||||||
import Graphics.UI.SDL as SDL (Event, Window, Texture, Renderer)
|
import Graphics.UI.SDL as SDL (Event, Window)
|
||||||
import Foreign.C (CFloat)
|
import Foreign.C (CFloat)
|
||||||
import Data.Time (UTCTime)
|
import Data.Time (UTCTime)
|
||||||
import Linear.Matrix (M44)
|
import Linear.Matrix (M44)
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user