Drezil/pioneers
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Merge with master

Browse Source
This commit is contained in:
Jonas Betzendahl 2014-04-22 01:09:09 +02:00
commit 673c64946b
12 changed files with 378 additions and 1359 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
Pioneers.cabal
View File

@ -1,6 +1,6 @@
name: Pioneers
version: 0.1
cabal-version: >=1.2
cabal-version: >= 1.16
build-type: Simple
author: sdressel
@ -16,6 +16,9 @@ executable Pioneers
Map.Graphics,
Map.Creation,
Map.StaticMaps,
IQM.Types,
IQM.TestMain,
IQM.Parser,
Render.Misc,
Render.Render,
Render.RenderObject,
@ -32,14 +35,16 @@ executable Pioneers
text >=0.11,
array >=0.4,
random >=1.0.1,
transformers >=0.3.0 && <0.4,
transformers >=0.3.0,
mtl >=2.1.2,
stm >=2.4.2,
vector >=0.10.9 && <0.11,
distributive >=0.3.2 && <0.4,
linear >=1.3.1 && <1.4,
lens >=3.10.1 && <3.11,
distributive >=0.3.2,
linear >=1.3.1,
lens >=4.0,
SDL2 >= 0.1.0,
time >=1.4.0 && <1.5,
GLUtil >= 0.7
time >=1.4.0,
GLUtil >= 0.7,
attoparsec >= 0.11.2
Default-Language: Haskell2010

BIN
sample.iqm Normal file
View File

Binary file not shown.

160
src/Importer/IQM/Parser.hs Normal file
View File

@ -0,0 +1,160 @@
{-# LANGUAGE RankNTypes #-}
module Importer.IQM.Parser where
import Importer.IQM.Types
import Data.Attoparsec.ByteString.Char8
import Data.Attoparsec.ByteString
import Data.ByteString.Char8 (pack)
import Data.ByteString (split, null)
import Data.Word
import Data.Int
import Unsafe.Coerce
import Control.Monad.Trans.State
import Control.Monad.Trans.Class
import Control.Monad
import Prelude as P hiding (take, null)
w8ToInt :: Integral a => a -> a -> a
w8ToInt i add = 256*i + add
parseNum :: (Integral a, Integral b) => [a] -> b
parseNum = (foldl1 w8ToInt) . map fromIntegral
int16 :: CParser Int16
int16 = do
ret <- lift $ do
a <- anyWord8 :: Parser Word8
b <- anyWord8 :: Parser Word8
return $ parseNum [b,a]
modify (+2)
return ret
int32 :: CParser Int32
int32 = do
ret <- lift $ do
a <- anyWord8 :: Parser Word8
b <- anyWord8 :: Parser Word8
c <- anyWord8 :: Parser Word8
d <- anyWord8 :: Parser Word8
return $ parseNum [d,c,b,a]
modify (+4)
return $ ret
readHeader :: CParser IQMHeader
readHeader = do
_ <- lift $ string (pack "INTERQUAKEMODEL\0")
v <- int32
-- when v /= 2 then --TODO: error something
size' <- int32
flags' <- int32
num_text' <- int32
ofs_text' <- int32
num_meshes' <- int32
ofs_meshes' <- int32
num_vertexarrays' <- int32
num_vertexes' <- int32
ofs_vertexarrays' <- int32
num_triangles' <- int32
ofs_triangles' <- int32
ofs_adjacency' <- int32
num_joints' <- int32
ofs_joints' <- int32
num_poses' <- int32
ofs_poses' <- int32
num_anims' <- int32
ofs_anims' <- int32
num_frames' <- int32
num_framechannels' <- int32
ofs_frames' <- int32
ofs_bounds' <- int32
num_comment' <- int32
ofs_comment' <- int32
num_extensions' <- int32
ofs_extensions' <- int32
return IQMHeader { version = v
, filesize = size'
, flags = flags'
, num_text = num_text'
, ofs_text = ofs_text'
, num_meshes = num_meshes'
, ofs_meshes = ofs_meshes'
, num_vertexarrays = num_vertexarrays'
, num_vertexes = num_vertexes'
, ofs_vertexarrays = ofs_vertexarrays'
, num_triangles = num_triangles'
, ofs_triangles = ofs_triangles'
, ofs_adjacency = ofs_adjacency'
, num_joints = num_joints'
, ofs_joints = ofs_joints'
, num_poses = num_poses'
, ofs_poses = ofs_poses'
, num_anims = num_anims'
, ofs_anims = ofs_anims'
, num_frames = num_frames'
, num_framechannels = num_framechannels'
, ofs_frames = ofs_frames'
, ofs_bounds = ofs_bounds'
, num_comment = num_comment'
, ofs_comment = ofs_comment'
, num_extensions = num_extensions'
, ofs_extensions = ofs_extensions'
}
readMesh :: CParser IQMMesh
readMesh = do
name <- int32
mat <- int32
fv <- int32
nv <- int32
ft <- int32
nt <- int32
return IQMMesh
{ meshName = if name == 0 then Nothing else Just (Mesh name)
, meshMaterial = mat
, meshFirstVertex = fv
, meshNumVertexes = nv
, meshFirstTriangle = ft
, meshNumTriangles = nt
}
readMeshes :: Int -> CParser [IQMMesh]
readMeshes 1 = do
m <- readMesh
return [m]
readMeshes n = do
m <- readMesh
ms <- readMeshes (n-1)
return $ m:ms
(.-) :: forall a a1 a2.
(Num a, Integral a2, Integral a1) =>
a1 -> a2 -> a
(.-) a b = (fromIntegral a) - (fromIntegral b)
infix 5 .-
skipToCounter :: Integral a => a -> CParser ()
skipToCounter a = do
let d = fromIntegral a
c <- get
when (d < c) $ fail "wanting to skip to counter already passed"
_ <- lift $ take $ d .- c
put d
parseIQM :: CParser IQM
parseIQM = do
put 0 --start at offset 0
h <- readHeader --read header
skipToCounter $ ofs_text h --skip 0-n bytes to get to text
text <- lift . take . fromIntegral $ num_text h --read texts
modify . (+) . fromIntegral $ num_text h --put offset forward
skipToCounter $ ofs_meshes h --skip 0-n bytes to get to meshes
meshes' <- readMeshes (fromIntegral (num_meshes h)) --read meshes
return IQM
{ header = h
, texts = filter (not.null) (split (unsafeCoerce '\0') text)
, meshes = meshes'
}

62
src/Importer/IQM/Types.hs Normal file
View File

@ -0,0 +1,62 @@
module Importer.IQM.Types where
import Data.Int
import Data.ByteString
import Data.Attoparsec.ByteString.Char8
import Control.Monad.Trans.State.Lazy (StateT)
newtype Mesh = Mesh Int32 deriving (Show, Eq)
type CParser a = StateT Int64 Parser a
-- Int32 or Int64 - depending on implementation. Format just specifies "uint".
-- 4-Byte indicates Int32
-- | ofs_* fields are relative tot he beginning of the iqmheader struct
-- ofs_* fields are set to 0 when data is empty
-- ofs_* fields are aligned at 4-byte-boundaries
data IQMHeader = IQMHeader
{ version :: Int32 -- ^ Must be 2
, filesize :: Int32
, flags :: Int32
, num_text :: Int32
, ofs_text :: Int32
, num_meshes :: Int32
, ofs_meshes :: Int32
, num_vertexarrays :: Int32
, num_vertexes :: Int32
, ofs_vertexarrays :: Int32
, num_triangles :: Int32
, ofs_triangles :: Int32
, ofs_adjacency :: Int32
, num_joints :: Int32
, ofs_joints :: Int32
, num_poses :: Int32
, ofs_poses :: Int32
, num_anims :: Int32
, ofs_anims :: Int32
, num_frames :: Int32
, num_framechannels :: Int32
, ofs_frames :: Int32
, ofs_bounds :: Int32
, num_comment :: Int32
, ofs_comment :: Int32
, num_extensions :: Int32 -- ^ stored as linked list, not as array.
, ofs_extensions :: Int32
} deriving (Show, Eq)
data IQMMesh = IQMMesh
{ meshName :: Maybe Mesh
, meshMaterial :: Int32
, meshFirstVertex :: Int32
, meshNumVertexes :: Int32
, meshFirstTriangle :: Int32
, meshNumTriangles :: Int32
} deriving (Show, Eq)
data IQM = IQM
{ header :: IQMHeader
, texts :: [ByteString]
, meshes :: [IQMMesh]
} deriving (Show, Eq)

529
src/Main.deprecated.hs
View File

@ -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

665
src/Main.glfw.deprecated.hs
View File

@ -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
]

220
src/Main.hs
View File

@ -1,46 +1,38 @@
{-# LANGUAGE BangPatterns, DoAndIfThenElse #-}
module Main where
import Data.Int (Int8)
import Graphics.Rendering.OpenGL.GL.Texturing.Specification (TextureSize2D)
import Graphics.Rendering.OpenGL.GL.Texturing.Specification (texImage2D,TextureTarget2D(Texture2D))
import Graphics.Rendering.OpenGL.GL.PixelRectangles.ColorTable (PixelInternalFormat(..))
import Graphics.Rendering.OpenGL.GL.Texturing.Specification (texImage2D)
import Control.Monad (liftM)
import Foreign.Marshal.Array (pokeArray)
import Foreign.Marshal.Alloc (allocaBytes)
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.Parameters (TextureFilter(..))
import Graphics.Rendering.OpenGL.GL.Texturing.Parameters (TextureFilter(..),textureFilter)
-- Monad-foo and higher functional stuff
import Control.Monad (unless, void, when, join)
import Control.Arrow ((***))
import Control.Monad (unless, when, join)
import Control.Arrow ((***))
-- data consistency/conversion
import Control.Concurrent (threadDelay)
import Control.Concurrent.STM (TQueue,
newTQueueIO)
import Control.Monad.RWS.Strict (RWST, ask, asks,
evalRWST, get, liftIO,
modify, put)
import Control.Monad.RWS.Strict (ask, evalRWST, get, liftIO, modify)
import Control.Monad.Trans.State (evalStateT)
import Data.Functor ((<$>))
import Data.Distributive (distribute, collect)
import Data.Monoid (mappend)
-- FFI
import Foreign (Ptr, castPtr, with, sizeOf)
import Foreign.C (CFloat)
import Foreign.C.Types (CInt)
import Data.Word (Word8)
import Foreign.Marshal.Array (pokeArray)
import Foreign.Marshal.Alloc (allocaBytes)
-- Math
import Control.Lens ((^.), (.~), (%~))
import Linear as L
import qualified Linear as L
-- GUI
import Graphics.UI.SDL as SDL
--import Graphics.UI.SDL.TTF as TTF
--import Graphics.UI.SDL.TTF.Types
-- Render
import qualified Graphics.Rendering.OpenGL.GL as GL
@ -51,56 +43,53 @@ import Graphics.GLUtil.BufferObjects (offset0)
import Graphics.Rendering.OpenGL.Raw.ARB.TessellationShader
-- Our modules
import Map.Graphics
import Render.Misc (checkError,
createFrustum, getCam,
curb, tryWithTexture,
import Render.Misc (checkError, createFrustum, getCam, curb,
genColorData)
import Render.Render (initRendering,
initMapShader,
initHud)
import UI.Callbacks
import UI.GUIOverlay
import Types
import Importer.IQM.Parser
import Data.Attoparsec.Char8 (parseTest)
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 = do
f <- B.readFile "sample.iqm"
parseTest (evalStateT parseIQM 0) f
--------------------------------------------------------------------------------
main :: IO ()
main = do
SDL.withInit [InitVideo, InitAudio, InitEvents, InitTimer] $ do --also: InitNoParachute -> faster, without parachute!
{- (window, renderer) <- SDL.createWindowAndRenderer (Size 1024 600) [WindowOpengl -- we want openGL
main =
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
,WindowShown -- window should be visible
,WindowResizable -- and resizable
,WindowResizable -- and resizable
,WindowInputFocus -- focused (=> active)
,WindowMouseFocus -- Mouse into it
--,WindowInputGrabbed-- never let go of input (KB/Mouse)
] -}
SDL.withWindow "Pioneers" (SDL.Position 100 100) (Size 1024 600) [WindowOpengl -- we want openGL
,WindowShown -- window should be visible
,WindowResizable -- and resizable
,WindowInputFocus -- focused (=> active)
,WindowMouseFocus -- Mouse into it
--,WindowInputGrabbed-- never let go of input (KB/Mouse)
] $ \window -> do
--mainGlContext <- SDL.glCreateContext window
withOpenGL window $ do
--TTF.withInit $ do
] $ \window' -> do
withOpenGL window' $ do
--Create Renderbuffer & Framebuffer
-- We will render to this buffer to copy the result into textures
renderBuffer <- GL.genObjectName
frameBuffer <- GL.genObjectName
GL.bindFramebuffer GL.Framebuffer GL.$= frameBuffer
GL.bindRenderbuffer GL.Renderbuffer GL.$= renderBuffer
(Size fbWidth fbHeight) <- glGetDrawableSize window
(Size fbWidth fbHeight) <- glGetDrawableSize window'
initRendering
--generate map vertices
(mapBuffer, vert) <- getMapBufferObject
(mapprog, ci, ni, vi, pri, vii, mi, nmi, tli, tlo, mapTex) <- initMapShader
putStrLn $ show window
print window'
eventQueue <- newTQueueIO :: IO (TQueue Event)
putStrLn "foo"
now <- getCurrentTime
@ -109,9 +98,9 @@ main = do
--TTF.setFontStyle font TTFNormal
--TTF.setFontHinting font TTFHNormal
glHud <- initHud
let zDistClosest = 1
zDistFarthest = zDistClosest + 50
glHud' <- initHud
let zDistClosest' = 1
zDistFarthest' = zDistClosest' + 50
--TODO: Move near/far/fov to state for runtime-changability & central storage
fov = 90 --field of view
near = 1 --near plane
@ -124,7 +113,7 @@ main = do
, _left = False
, _right = False
}
glMap = GLMapState
glMap' = GLMapState
{ _shdrVertexIndex = vi
, _shdrNormalIndex = ni
, _shdrColorIndex = ci
@ -142,11 +131,9 @@ main = do
}
env = Env
{ _eventsChan = eventQueue
, _windowObject = window
, _zDistClosest = zDistClosest
, _zDistFarthest = zDistFarthest
--, _renderer = renderer
--, envFont = font
, _windowObject = window'
, _zDistClosest = zDistClosest'
, _zDistFarthest = zDistFarthest'
}
state = State
{ _window = WindowState
@ -160,8 +147,8 @@ main = do
, _zDist = 10
, _frustum = frust
, _camPosition = Types.Position
{ Types._x = 25
, Types._y = 25
{ Types.__x = 25
, Types.__y = 25
}
}
, _io = IOState
@ -175,16 +162,16 @@ main = do
, _dragStartXAngle = 0
, _dragStartYAngle = 0
, _mousePosition = Types.Position
{ Types._x = 5
, Types._y = 5
{ Types.__x = 5
, Types.__y = 5
}
}
, _keyboard = KeyboardState
{ _arrowsPressed = aks
}
, _gl = GLState
{ _glMap = glMap
, _glHud = glHud
{ _glMap = glMap'
, _glHud = glHud'
, _glRenderbuffer = renderBuffer
, _glFramebuffer = frameBuffer
}
@ -197,8 +184,9 @@ main = do
}
putStrLn "init done."
void $ evalRWST (adjustWindow >> run) env state
uncurry mappend <$> evalRWST (adjustWindow >> run) env state
putStrLn "shutdown complete."
--SDL.glDeleteContext mainGlContext
--SDL.destroyRenderer renderer
--destroyWindow window
@ -208,34 +196,28 @@ main = do
draw :: Pioneers ()
draw = do
state <- get
env <- ask
let xa = state ^. camera.xAngle
ya = state ^. camera.yAngle
(GL.UniformLocation proj) = state ^. gl.glMap.shdrProjMatIndex
(GL.UniformLocation nmat) = state ^. gl.glMap.shdrNormalMatIndex
(GL.UniformLocation vmat) = state ^. gl.glMap.shdrViewMatIndex
(GL.UniformLocation tli) = state ^. gl.glMap.shdrTessInnerIndex
(GL.UniformLocation tlo) = state ^. gl.glMap.shdrTessOuterIndex
vi = state ^. gl.glMap.shdrVertexIndex
ni = state ^. gl.glMap.shdrNormalIndex
ci = state ^. gl.glMap.shdrColorIndex
numVert = state ^. gl.glMap.mapVert
map' = state ^. gl.glMap.stateMap
frust = state ^. camera.frustum
camX = state ^. camera.camPosition.x
camY = state ^. camera.camPosition.y
(GL.UniformLocation proj) = state ^. gl.glMap.shdrProjMatIndex
(GL.UniformLocation nmat) = state ^. gl.glMap.shdrNormalMatIndex
(GL.UniformLocation vmat) = state ^. gl.glMap.shdrViewMatIndex
(GL.UniformLocation tli) = state ^. gl.glMap.shdrTessInnerIndex
(GL.UniformLocation tlo) = state ^. gl.glMap.shdrTessOuterIndex
vi = state ^. gl.glMap.shdrVertexIndex
ni = state ^. gl.glMap.shdrNormalIndex
ci = state ^. gl.glMap.shdrColorIndex
numVert = state ^. gl.glMap.mapVert
map' = state ^. gl.glMap.stateMap
frust = state ^. camera.frustum
camX = state ^. camera.camPosition._x
camY = state ^. camera.camPosition._y
zDist' = state ^. camera.zDist
tessFac = state ^. gl.glMap.stateTessellationFactor
window = env ^. windowObject
rb = state ^. gl.glRenderbuffer
if state ^. ui.uiHasChanged then
prepareGUI
else
return ()
when (state ^. ui . uiHasChanged) prepareGUI
liftIO $ do
--bind renderbuffer and set sample 0 as target
--GL.bindRenderbuffer GL.Renderbuffer GL.$= rb
--GL.bindFramebuffer GL.Framebuffer GL.$= GL.defaultFramebufferObject
--GL.bindFramebuffer GL.Framebuffer GL.$= GL.defaultFramebufferObject
--checkError "bind renderbuffer"
--checkError "clear renderbuffer"
@ -248,7 +230,7 @@ draw = do
-- draw map
--(vi,GL.UniformLocation proj) <- initShader
GL.bindFramebuffer GL.Framebuffer GL.$= (state ^. gl.glFramebuffer)
GL.bindRenderbuffer GL.Renderbuffer GL.$= (state ^. gl.glRenderbuffer)
GL.framebufferRenderbuffer
@ -257,14 +239,14 @@ draw = do
GL.Renderbuffer
(state ^. gl.glRenderbuffer)
textureBinding GL.Texture2D GL.$= Just (state ^. gl.glMap.mapTexture)
GL.framebufferTexture2D
GL.Framebuffer
(GL.ColorAttachment 0)
GL.Texture2D
(state ^. gl.glMap.mapTexture)
0
-- Render to FrameBufferObject
GL.drawBuffers GL.$= [GL.FBOColorAttachment 0]
checkError "setup Render-Target"
@ -278,23 +260,23 @@ draw = do
checkError "setting up buffer"
--set up projection (= copy from state)
with (distribute frust) $ \ptr ->
glUniformMatrix4fv proj 1 0 (castPtr (ptr :: Ptr (M44 CFloat)))
glUniformMatrix4fv proj 1 0 (castPtr (ptr :: Ptr (L.M44 CFloat)))
checkError "copy projection"
--set up camera
let ! cam = getCam (camX,camY) zDist' xa ya
with (distribute cam) $ \ptr ->
glUniformMatrix4fv vmat 1 0 (castPtr (ptr :: Ptr (M44 CFloat)))
glUniformMatrix4fv vmat 1 0 (castPtr (ptr :: Ptr (L.M44 CFloat)))
checkError "copy cam"
--set up normal--Mat transpose((model*camera)^-1)
let normal = (case inv33 (fmap (^. _xyz) cam ^. _xyz) of
let normal = (case L.inv33 (fmap (^. L._xyz) cam ^. L._xyz) of
(Just a) -> a
Nothing -> eye3) :: M33 CFloat
nmap = collect id normal :: M33 CFloat --transpose...
Nothing -> L.eye3) :: L.M33 CFloat
nmap = collect id normal :: L.M33 CFloat --transpose...
with (distribute nmap) $ \ptr ->
glUniformMatrix3fv nmat 1 0 (castPtr (ptr :: Ptr (M33 CFloat)))
glUniformMatrix3fv nmat 1 0 (castPtr (ptr :: Ptr (L.M33 CFloat)))
checkError "nmat"
@ -311,7 +293,8 @@ draw = do
checkError "beforeDraw"
glPatchParameteri gl_PATCH_VERTICES 3
glPolygonMode gl_FRONT gl_LINE
GL.cullFace GL.$= Just GL.Front
glDrawArrays gl_PATCHES 0 (fromIntegral numVert)
checkError "draw map"
@ -342,11 +325,11 @@ draw = do
GL.activeTexture GL.$= GL.TextureUnit 1
textureBinding GL.Texture2D GL.$= Just (state ^. gl.glMap.mapTexture)
GL.uniform (hud ^. hudBackIndex) GL.$= GL.Index1 (1::GL.GLint)
GL.bindBuffer GL.ArrayBuffer GL.$= Just (hud ^. hudVBO)
GL.vertexAttribPointer (hud ^. hudVertexIndex) GL.$= (GL.ToFloat, vad)
GL.vertexAttribArray (hud ^. hudVertexIndex) GL.$= GL.Enabled
GL.bindBuffer GL.ElementArrayBuffer GL.$= Just (hud ^. hudEBO)
GL.drawElements GL.TriangleStrip 4 GL.UnsignedInt offset0
@ -379,8 +362,8 @@ run = do
sody = state ^. mouse.dragStartY
sodxa = state ^. mouse.dragStartXAngle
sodya = state ^. mouse.dragStartYAngle
x' = state ^. mouse.mousePosition.x
y' = state ^. mouse.mousePosition.y
x' = state ^. mouse.mousePosition._x
y' = state ^. mouse.mousePosition._y
myrot = (x' - sodx) / 2
mxrot = (y' - sody) / 2
newXAngle = curb (pi/12) (0.45*pi) newXAngle'
@ -390,22 +373,22 @@ run = do
| newYAngle' < (-pi) = newYAngle' + 2 * pi
| otherwise = newYAngle'
newYAngle' = sodya + myrot/100
modify $ ((camera.xAngle) .~ newXAngle)
. ((camera.yAngle) .~ newYAngle)
-- get cursor-keys - if pressed
--TODO: Add sin/cos from stateYAngle
(kxrot, kyrot) <- fmap (join (***) fromIntegral) getArrowMovement
let
let
multc = cos $ state ^. camera.yAngle
mults = sin $ state ^. camera.yAngle
modx x' = x' - 0.2 * kxrot * multc
- 0.2 * kyrot * mults
mody y' = y' + 0.2 * kxrot * mults
- 0.2 * kyrot * multc
modify $ (camera.camPosition.x %~ modx)
. (camera.camPosition.y %~ mody)
modify $ (camera.camPosition._x %~ modx)
. (camera.camPosition._y %~ mody)
{-
--modify the state with all that happened in mt time.
@ -416,23 +399,24 @@ run = do
-}
mt <- liftIO $ do
let double = fromRational.toRational :: (Real a) => a -> Double
now <- getCurrentTime
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
sleepAmount <- return $ floor (max 0 (0.04 - diff))*1000000 -- get time until next frame in microseconds
threadDelay sleepAmount
return now
-- set state with new clock-time
modify $ io.clock .~ mt
shouldClose <- return $ state ^. window.shouldClose
unless shouldClose run
shouldClose' <- return $ state ^. window.shouldClose
unless shouldClose' run
getArrowMovement :: Pioneers (Int, Int)
getArrowMovement = do
state <- get
aks <- return $ state ^. (keyboard.arrowsPressed)
let
aks <- return $ state ^. (keyboard.arrowsPressed)
let
horz = left' + right'
vert = up'+down'
left' = if aks ^. left then -1 else 0
@ -444,7 +428,6 @@ getArrowMovement = do
adjustWindow :: Pioneers ()
adjustWindow = do
state <- get
env <- ask
let fbWidth = state ^. window.width
fbHeight = state ^. window.height
fov = 90 --field of view
@ -463,7 +446,7 @@ adjustWindow = do
renderBuffer <- GL.genObjectName
GL.bindRenderbuffer GL.Renderbuffer GL.$= renderBuffer
GL.renderbufferStorage
GL.Renderbuffer -- use the only available renderbuffer
GL.Renderbuffer -- use the only available renderbuffer
-- - must be this constant.
GL.DepthComponent' -- 32-bit float-rgba-color
(GL.RenderbufferSize fbCWidth fbCHeight) -- size of buffer
@ -510,15 +493,15 @@ processEvent e = do
Closing ->
modify $ window.shouldClose .~ True
Resized {windowResizedTo=size} -> do
modify $ (window.width .~ (sizeWidth size))
. (window.height .~ (sizeHeight size))
modify $ (window . width .~ sizeWidth size)
. (window . height .~ sizeHeight size)
adjustWindow
SizeChanged ->
adjustWindow
_ ->
return ()
--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
let aks = keyboard.arrowsPressed in
case keyScancode key of
@ -548,7 +531,7 @@ processEvent e = do
liftIO $ putStrLn $ unwords ["Tessellation at: ", show $ state ^. gl.glMap.stateTessellationFactor]
_ ->
return ()
MouseMotion _ mouseId st (SDL.Position x y) xrel yrel -> do
MouseMotion _ _{-mouseId-} _{-st-} (SDL.Position x y) _{-xrel-} _{-yrel-} -> do
state <- get
when (state ^. mouse.isDown && not (state ^. mouse.isDragging)) $
modify $ (mouse.isDragging .~ True)
@ -556,10 +539,10 @@ processEvent e = do
. (mouse.dragStartY .~ (fromIntegral y))
. (mouse.dragStartXAngle .~ (state ^. camera.xAngle))
. (mouse.dragStartYAngle .~ (state ^. camera.yAngle))
modify $ (mouse.mousePosition. Types.x .~ (fromIntegral x))
. (mouse.mousePosition. Types.y .~ (fromIntegral y))
MouseButton _ mouseId button state (SDL.Position x y) ->
modify $ (mouse.mousePosition. Types._x .~ (fromIntegral x))
. (mouse.mousePosition. Types._y .~ (fromIntegral y))
MouseButton _ _{-mouseId-} button state (SDL.Position x y) ->
case button of
LeftButton -> do
let pressed = state == Pressed
@ -574,10 +557,9 @@ processEvent e = do
when (state == Released) $ alternateClickHandler (UI.Callbacks.Pixel x y)
_ ->
return ()
MouseWheel _ mouseId hscroll vscroll -> do
env <- ask
MouseWheel _ _{-mouseId-} _{-hscroll-} vscroll -> do
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')
Quit -> modify $ window.shouldClose .~ True
-- there is more (joystic, touchInterface, ...), but currently ignored

24
src/Map/Graphics.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE OverloadedStrings, BangPatterns #-}
module Map.Graphics
module Map.Graphics
(
mapVertexArrayDescriptor,
@ -12,6 +12,10 @@ getMapBufferObject
where
import Data.Array.IArray
<<<<<<< HEAD
=======
import Data.Text as T
>>>>>>> master
import Prelude as P
--import Graphics.Rendering.OpenGL.GL
@ -31,8 +35,12 @@ import Linear
import Map.Types
import Map.StaticMaps
<<<<<<< HEAD
type MapEntry = ( Float, -- Height
TileType )
=======
type Height = Float
type GraphicsMap = Array (Int, Int) MapEntry
@ -86,10 +94,10 @@ getMapBufferObject = do
return (bo,len)
--generateTriangles :: PlayMap -> [GLfloat]
generateTriangles :: GraphicsMap -> [GLfloat]
generateTriangles :: GraphicsMap -> [GLfloat]
generateTriangles map' =
let ((xl,yl),(xh,yh)) = bounds map' in
P.concat [P.concat $ P.map (generateFirstTriLine map' y) [xl .. xh - 2]
P.concat [P.concat $ P.map (generateFirstTriLine map' y) [xl .. xh - 2]
++ P.map (generateSecondTriLine map' (y == yh) y) [xl .. xh - 2]
| y <- [yl..yh]]
@ -124,8 +132,8 @@ generateSecondTriLine _ True _ _ = []
lookupVertex :: GraphicsMap -> Int -> Int -> [GLfloat]
lookupVertex map' x y =
let
lookupVertex map' x y =
let
(cr, cg, cb) = colorLookup map' (x,y)
(V3 vx vy vz) = coordLookup (x,y) $ heightLookup map' (x,y)
(V3 nx ny nz) = normalLookup map' x y
@ -149,7 +157,7 @@ normalLookup map' x y = normalize $ normN + normNE + normSE + normS + normSW + n
normNW = cross (vNW-vC) (vW -vC)
--Vertex Normals
vC = coordLookup (x,y) $ heightLookup map' (x,y)
--TODO: kill guards with eo
--TODO: kill guards with eo
vNW
| even x = coordLookup (x-1,y-1) $ heightLookup map' (x-1,y-1)
| otherwise = coordLookup (x-1,y ) $ heightLookup map' (x-1,y )
@ -172,12 +180,12 @@ normalLookup map' x y = normalize $ normN + normNE + normSE + normS + normSW + n
heightLookup :: GraphicsMap -> (Int,Int) -> GLfloat
heightLookup hs t = if inRange (bounds hs) t then fromRational $ toRational h else 0.0
where
where
(h,_) = hs ! t
colorLookup :: GraphicsMap -> (Int,Int) -> (GLfloat, GLfloat, GLfloat)
colorLookup hs t = if inRange (bounds hs) t then c else (0.0, 0.0, 0.0)
where
where
(_,tp) = hs ! t
c = case tp of
Ocean -> (0.50, 0.50, 1.00)

8
src/PioneerTypes.hs
View File

@ -1,4 +1,4 @@
module PioneerTypes
module PioneerTypes
where
data Structure = Flag -- Flag
@ -36,7 +36,7 @@ data Structure = Flag -- Flag
deriving (Show, Eq)
data Amount = Infinite -- Neverending supply
| Finite Int -- Finite supply
| Finite Int -- Finite supply
-- Extremely preliminary, expand when needed
data Commodity = WoodPlank
@ -54,9 +54,9 @@ data Resource = Coal
instance Show Amount where
show (Infinite) = "inexhaustable supply"
show (Finite n) = (show n) ++ " left"
show (Finite n) = show n ++ " left"
instance Show Commodity where
show WoodPlank = "wooden plank"
show Sword = "sword"
show Sword = "sword"
show Fish = "fish"

7
src/Render/Misc.hs
View File

@ -8,7 +8,6 @@ import Graphics.Rendering.OpenGL.GL.Shaders
import Graphics.Rendering.OpenGL.GL.StateVar
import Graphics.Rendering.OpenGL.GL.StringQueries
import Graphics.Rendering.OpenGL.GLU.Errors
import Graphics.Rendering.OpenGL.Raw.Core31
import Graphics.UI.SDL.Types (Texture)
import System.IO (hPutStrLn, stderr)
import Linear
@ -62,7 +61,7 @@ createProgramUsing shaders = do
createFrustum :: Float -> Float -> Float -> Float -> M44 CFloat
createFrustum fov n' f' rat =
let
let
f = realToFrac f'
n = realToFrac n'
s = realToFrac $ recip (tan $ fov*0.5 * pi / 180)
@ -78,7 +77,7 @@ createFrustum fov n' f' rat =
-- from vmath.h
lookAt :: V3 CFloat -> V3 CFloat -> V3 CFloat -> M44 CFloat
lookAt eye@(V3 ex ey ez) center up =
lookAt eye center up' =
V4
(V4 xx xy xz (-dot x 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)
where
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)

37
src/Render/Render.hs
View File

@ -2,8 +2,6 @@
module Render.Render where
import qualified Data.ByteString as B
import Data.Array.Storable
import qualified Data.Vector.Storable as V
import Foreign.Marshal.Array (withArray)
import Foreign.Storable
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.Texturing.Objects (TextureObject)
import Graphics.Rendering.OpenGL.GL.VertexArrays (Capability (..),
vertexAttribArray,
VertexArrayDescriptor,
DataType(Float))
vertexAttribArray)
import Graphics.Rendering.OpenGL.GL.VertexSpec
import Graphics.Rendering.OpenGL.Raw.Core31
import Render.Misc
import Foreign.Ptr (Ptr, wordPtrToPtr)
import Types
import Graphics.GLUtil.BufferObjects (makeBuffer)
@ -53,18 +48,20 @@ initBuffer varray =
return bufferObject
initMapShader :: IO (
Program -- ^ the GLSL-Program
, AttribLocation -- ^ color
, AttribLocation -- ^ normal
, AttribLocation -- ^ vertex
, UniformLocation -- ^ ProjectionMat
, UniformLocation -- ^ ViewMat
, UniformLocation -- ^ ModelMat
, UniformLocation -- ^ NormalMat
, UniformLocation -- ^ TessLevelInner
, UniformLocation -- ^ TessLevelOuter
, TextureObject -- ^ Texture where to draw into
)
Program -- the GLSL-Program
, AttribLocation -- color
, AttribLocation -- normal
, AttribLocation -- vertex
, UniformLocation -- ProjectionMat
, UniformLocation -- ViewMat
, UniformLocation -- ModelMat
, UniformLocation -- NormalMat
, UniformLocation -- TessLevelInner
, UniformLocation -- TessLevelOuter
, TextureObject -- Texture where to draw into
) -- ^ (the GLSL-Program, color, normal, vertex, ProjectionMat, ViewMat,
-- ModelMat, NormalMat, TessLevelInner, TessLevelOuter,
-- Texture where to draw into)
initMapShader = do
! vertexSource <- B.readFile mapVertexShaderFile
! tessControlSource <- B.readFile mapTessControlShaderFile
@ -143,7 +140,7 @@ initHud = do
texIndex <- get (uniformLocation program "tex[1]")
checkError "ui-tex"
-- | simple triangle over the whole screen.
-- simple triangle over the whole screen.
let vertexBufferData = reverse [-1, -1, 1, -1, -1, 1, 1, 1] :: [GLfloat]
vertexIndex <- get (attribLocation program "position")
@ -169,7 +166,7 @@ initHud = do
, _hudEBO = ebo
, _hudProgram = program
}

6
src/Types.hs
View File

@ -3,7 +3,7 @@ module Types where
import Control.Concurrent.STM (TQueue)
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 Data.Time (UTCTime)
import Linear.Matrix (M44)
@ -26,8 +26,8 @@ data Env = Env
--Mutable State
data Position = Position
{ _x :: !Double
, _y :: !Double
{ __x :: !Double
, __y :: !Double
}
data WindowState = WindowState