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

Merge branch 'master' into ui

Browse Source 
Conflicts:
	src/UI/Callbacks.hs

caused by using TMVar for camera state
This commit is contained in:
tpajenka
2014-05-21 14:57:39 +02:00
parent 9523e733c6 aa6a5c060f
commit 9761e7c6c2
16 changed files with 457 additions and 296 deletions
Download Patch File Download Diff File Expand all files Collapse all files

26
src/Importer/IQM/Parser.hs
View File

@@ -13,6 +13,8 @@ import Data.ByteString.Char8 (pack)
import Data.ByteString (split, null, ByteString)
import Data.ByteString.Unsafe (unsafeUseAsCString)
import qualified Data.ByteString as B
import Graphics.GLUtil
import Graphics.Rendering.OpenGL.GL.BufferObjects
import Data.Word
import Data.Int
import Unsafe.Coerce
@@ -211,10 +213,29 @@ parseIQM a =
-- Fill Vertex-Arrays with data of Offsets
let va = vertexArrays raw
va' <- mapM (readInVAO f) va
return $ raw {
vertexArrays = va'
vbo <- sequence $ map toVBOfromVAO va
return $ raw
{ vertexArrays = va'
, vertexArrayObjects = vbo
}
-- | Creates a BufferObject on the Graphicscard for each BufferObject
toVBOfromVAO :: IQMVertexArray -> IO BufferObject
toVBOfromVAO (IQMVertexArray type' _ _ num _ ptr) =
fromPtr (toBufferTargetfromVAType type') (fromIntegral num) ptr
-- | translates from VA-type to BufferTarget
toBufferTargetfromVAType :: IQMVertexArrayType -> BufferTarget
toBufferTargetfromVAType IQMPosition = ArrayBuffer
toBufferTargetfromVAType IQMTexCoord = TextureBuffer
toBufferTargetfromVAType IQMNormal = ArrayBuffer
toBufferTargetfromVAType IQMBlendIndexes = ElementArrayBuffer
toBufferTargetfromVAType IQMBlendWeights = ArrayBuffer
toBufferTargetfromVAType IQMColor = ArrayBuffer
toBufferTargetfromVAType _ = ArrayBuffer
-- | Allocates memory for the Vertex-data and copies it over there
-- from the given input-String
--
@@ -254,6 +275,7 @@ doIQMparse =
, texts = filter (not.null) (split (unsafeCoerce '\0') text)
, meshes = meshes'
, vertexArrays = vaf
, vertexArrayObjects = [] --initialized later, after vaf get allocated.
}
-- | Helper-Function for Extracting a random substring out of a Bytestring

2
src/Importer/IQM/Types.hs
View File

@@ -13,6 +13,7 @@ import Graphics.Rendering.OpenGL.Raw.Types
import Prelude as P
import Foreign.Storable
import Foreign.C.Types
import Graphics.Rendering.OpenGL.GL.BufferObjects hiding (Offset)
-- | Mesh-Indices to distinguish the meshes referenced
newtype Mesh = Mesh Word32 deriving (Show, Eq)
@@ -108,6 +109,7 @@ data IQM = IQM
, texts :: [ByteString]
, meshes :: [IQMMesh]
, vertexArrays :: [IQMVertexArray]
, vertexArrayObjects :: [BufferObject]
} deriving (Show, Eq)
-- | Different Vertex-Array-Types in IQM

83
src/Main.hs
View File

@@ -12,8 +12,8 @@ import Control.Arrow ((***))
-- data consistency/conversion
import Control.Concurrent (threadDelay)
import Control.Concurrent.STM (TQueue,
newTQueueIO)
import Control.Concurrent.STM (TQueue, newTQueueIO, atomically)
import Control.Concurrent.STM.TVar (newTVarIO, writeTVar, readTVar)
import Control.Monad.RWS.Strict (ask, evalRWST, get, liftIO, modify)
import Data.Functor ((<$>))
@@ -43,6 +43,7 @@ import Render.Render (initRendering,
import Render.Types
import UI.Callbacks
import Map.Graphics
import Map.Creation (exportedMap)
import Types
import qualified UI.UIBase as UI
import Importer.IQM.Parser
@@ -54,7 +55,7 @@ import Importer.IQM.Parser
--------------------------------------------------------------------------------
testParser :: String -> IO ()
testParser a = putStrLn . show =<< parseIQM a
testParser a = print =<< parseIQM a
{-do
f <- B.readFile a
putStrLn "reading in:"
@@ -86,22 +87,33 @@ main =
(SDL.Size fbWidth fbHeight) <- SDL.glGetDrawableSize window'
initRendering
--generate map vertices
glMap' <- initMapShader 4 =<< getMapBufferObject
curMap <- exportedMap
glMap' <- initMapShader 4 =<< getMapBufferObject curMap
eventQueue <- newTQueueIO :: IO (TQueue SDL.Event)
now <- getCurrentTime
--font <- TTF.openFont "fonts/ttf-04B_03B_/04B_03B_.TTF" 10
--TTF.setFontStyle font TTFNormal
--TTF.setFontHinting font TTFHNormal
glHud' <- initHud
let zDistClosest' = 1
zDistFarthest' = zDistClosest' + 50
--TODO: Move near/far/fov to state for runtime-changability & central storage
let
fov = 90 --field of view
near = 1 --near plane
far = 500 --far plane
ratio = fromIntegral fbWidth / fromIntegral fbHeight
frust = createFrustum fov near far ratio
cam' <- newTVarIO CameraState
{ _xAngle = pi/6
, _yAngle = pi/2
, _zDist = 10
, _frustum = frust
, _camObject = createFlatCam 25 25 curMap
}
game' <- newTVarIO GameState
{ _currentMap = curMap
}
glHud' <- initHud
let zDistClosest' = 2
zDistFarthest' = zDistClosest' + 10
--TODO: Move near/far/fov to state for runtime-changability & central storage
(guiMap, guiRoots) = createGUI
aks = ArrowKeyState {
_up = False
@@ -121,17 +133,11 @@ main =
, _height = fbHeight
, _shouldClose = False
}
, _camera = CameraState
{ _xAngle = pi/6
, _yAngle = pi/2
, _zDist = 10
, _frustum = frust
, _camObject = createFlatCam 25 25
}
, _io = IOState
{ _clock = now
, _tessClockFactor = 0
}
, _camera = cam'
, _mouse = MouseState
{ _isDragging = False
, _dragStartX = 0
@@ -152,9 +158,7 @@ main =
, _glRenderbuffer = renderBuffer
, _glFramebuffer = frameBuffer
}
, _game = GameState
{
}
, _game = game'
, _ui = UIState
{ _uiHasChanged = True
, _uiMap = guiMap
@@ -204,20 +208,26 @@ run = do
| otherwise = newYAngle'
newYAngle' = sodya + myrot/100
modify $ ((camera.xAngle) .~ newXAngle)
. ((camera.yAngle) .~ newYAngle)
liftIO $ atomically $ do
cam <- readTVar (state ^. camera)
cam' <- return $ (xAngle .~ newXAngle) . (yAngle .~ newYAngle) $ cam
writeTVar (state ^. camera) cam'
-- get cursor-keys - if pressed
--TODO: Add sin/cos from stateYAngle
(kxrot, kyrot) <- fmap (join (***) fromIntegral) getArrowMovement
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.camObject %~ (\c -> moveBy c (\(x,y) -> (modx x,mody y)))
liftIO $ atomically $ do
cam <- readTVar (state ^. camera)
game' <- readTVar (state ^. game)
let
multc = cos $ cam ^. yAngle
mults = sin $ cam ^. yAngle
modx x' = x' - 0.2 * kxrot * multc
- 0.2 * kyrot * mults
mody y' = y' + 0.2 * kxrot * mults
- 0.2 * kyrot * multc
cam' <- return $ camObject %~ (\c -> moveBy c (\(x,y) -> (modx x,mody y)) (game' ^. currentMap)) $ cam
writeTVar (state ^. camera) cam'
{-
--modify the state with all that happened in mt time.
@@ -233,7 +243,7 @@ run = do
targetFrametime = 1.0/targetFramerate
--targetFrametimeμs = targetFrametime * 1000000.0
now <- getCurrentTime
let diff = diffUTCTime now (state ^. io.clock) -- get time-diffs
let diff = max 0.1 $ diffUTCTime now (state ^. io.clock) -- get time-diffs
title = unwords ["Pioneers @ ",show ((round . double $ 1.0/diff)::Int),"fps"]
ddiff = double diff
SDL.setWindowTitle (env ^. windowObject) title
@@ -287,7 +297,10 @@ adjustWindow = do
ratio = fromIntegral fbWidth / fromIntegral fbHeight
frust = createFrustum fov near far ratio
liftIO $ glViewport 0 0 (fromIntegral fbWidth) (fromIntegral fbHeight)
modify $ camera.frustum .~ frust
liftIO $ atomically $ do
cam <- readTVar (state ^. camera)
cam' <- return $ frustum .~ frust $ cam
writeTVar (state ^. camera) cam'
rb <- liftIO $ do
-- bind ints to CInt for lateron.
let fbCWidth = (fromInteger.toInteger) fbWidth
@@ -305,6 +318,7 @@ adjustWindow = do
let hudtexid = state ^. gl.glHud.hudTexture
maptexid = state ^. gl.glMap.renderedMapTexture
smaptexid = state ^. gl.glMap.shadowMapTexture
allocaBytes (fbWidth*fbHeight*4) $ \ptr -> do
--default to ugly pink to see if
--somethings go wrong.
@@ -321,6 +335,13 @@ adjustWindow = do
textureFilter Texture2D GL.$= ((Linear', Nothing), Linear')
texImage2D Texture2D GL.NoProxy 0 RGBA8 (GL.TextureSize2D fbCWidth fbCHeight) 0
(GL.PixelData GL.RGBA GL.UnsignedByte ptr)
allocaBytes (2048*2048) $ \ptr -> do
let smapdata = genColorData (2048*2048) [0]
pokeArray ptr smapdata
textureBinding Texture2D GL.$= Just smaptexid
textureFilter Texture2D GL.$= ((Nearest,Nothing), Nearest)
texImage2D Texture2D GL.NoProxy 0 GL.DepthComponent16 (GL.TextureSize2D 2048 2048) 0
(GL.PixelData GL.DepthComponent GL.UnsignedByte ptr)
checkError "setting up HUD-Tex"
return renderBuffer
modify $ gl.glRenderbuffer .~ rb

54
src/Map/Creation.hs
View File

@@ -2,21 +2,13 @@ module Map.Creation
where
import Map.Types
import Map.StaticMaps
-- import Map.Map unused (for now)
import Data.Array
import System.Random
-- preliminary
infix 5 ->-
(->-) :: (PlayMap -> PlayMap) -> (PlayMap -> PlayMap) -> PlayMap -> PlayMap
f ->- g = g . f
-- also preliminary
infix 5 -<-
(-<-) :: (PlayMap -> PlayMap) -> (PlayMap -> PlayMap) -> PlayMap -> PlayMap
f -<- g = f . g
-- entirely empty map, only uses the minimal constructor
mapEmpty :: PlayMap
mapEmpty = array ((0,0), (199,199)) [((a,b), Node (a,b) (fromIntegral a, (if even b then (fromIntegral b) else(fromIntegral b) - 0.5), 1) Grass BNothing NoPlayer NoPath Plain []) | a <- [0..199], b <- [0..199]]
exportedMap :: IO PlayMap
exportedMap = do mounts <- mnt
@@ -52,18 +44,7 @@ gauss3Dgeneral :: Floating q =>
-> q -- ^ Coordinate in question on X
-> q -- ^ Coordinate in question on Z
-> q -- ^ elevation on coordinate in question
gauss3Dgeneral amp x0 z0 sX sZ x z = amp * exp(-(((x-x0)^(2 :: Integer)/(2 * sX^(2 :: Integer)))+((z-z0)^(2 :: Integer)/(2 * sZ^(2 :: Integer)))))
-- specialised 3D gaussian with an origin on 100/100, an amplitude of 15 and two sigmas of 15
gauss3D :: Floating q =>
q -- ^ X-Coordinate
-> q -- ^ Z-Coordinate
-> q -- ^ elevation on coordinate in quesion
gauss3D = gauss3Dgeneral 15 100.0 100.0 15.0 15.0
-- 2D Manhattan distance
mnh2D :: (Int,Int) -> (Int,Int) -> Int
mnh2D (a,b) (c,d) = abs (a-c) + abs (b-d)
gauss3Dgeneral amp x0 z0 sX sZ x z = amp * exp(-(((x-x0)^(2 :: Int)/(2 * sX^(2 :: Int)))+((z-z0)^(2 :: Int)/(2 * sZ^(2 :: Int)))))
-- | Basic Terrain-Generator. Will not implement "abnormal" Stuff for given Biome
-- (like Deserts on Grass-Islands or Grass on Deserts)
@@ -72,9 +53,9 @@ mnh2D (a,b) (c,d) = abs (a-c) + abs (b-d)
heightToTerrain :: MapType -> YCoord -> TileType
heightToTerrain GrassIslandMap y
| y < 0.1 = Ocean
| y < 1 = Beach
| y < 5 = Grass
| y < 10 = Hill
| y < 0.2 = Beach
| y < 1.5 = Grass
| y < 3 = Hill
| otherwise = Mountain
heightToTerrain _ _ = undefined
@@ -87,26 +68,23 @@ river = undefined
mnt :: IO [PlayMap -> PlayMap]
mnt = do g <- newStdGen
let seeds = take 10 $ randoms g
return $ map (gaussMountain) seeds
let seeds = take 50 $ randoms g
return $ map gaussMountain seeds
gaussMountain :: Int -> PlayMap -> PlayMap
gaussMountain seed mp = aplByPlace (liftUp c) (\(_,_) -> True) mp
where
g = mkStdGen seed
c = let ((a,b), (x,y)) = bounds mp in (head (randomRs (a,x) g), (head (randomRs (b,y) g)))
amp = head $ randomRs (5.0, 20.0) g
sig = head $ randomRs (5.0, 25.0) g
fi = fromIntegral
gs = map mkStdGen (map (*seed) [1..])
c = let ((a,b), (x,y)) = bounds mp in (head (randomRs (a,x) (gs !! 0)), (head (randomRs (b,y) (gs !! 1))))
amp = head $ randomRs ((2.0, 5.0) :: (Double, Double)) (gs !! 2)
sig = head $ randomRs ((2.0, 8.0) :: (Double, Double)) (gs !! 3)
htt = heightToTerrain
-- TODO: Fix Lambda to True with sensible function, maybe rework giveNeighbourhood in Map.Map
liftUp :: (Int, Int) -> Node -> Node
liftUp (gx,gz) (Full (x,z) y _ b pl pa r s) = let y_neu = max y e
in Full (x,z) y_neu (htt GrassIslandMap y_neu) b pl pa r s
where e = gauss3Dgeneral amp (fi gx) (fi gz) sig sig (fi x) (fi z)
liftUp (gx, gz) (Minimal (x,z)) = Full (x,z) e (htt GrassIslandMap e) BFlag NoPlayer NoPath Plain []
where e = gauss3Dgeneral amp (fi gx) (fi gz) sig sig (fi x) (fi z)
liftUp (gx,gz) (Node (x,z) (rx,rz,y) _ b pl pa r s) = let y_neu = max y e
in Node (x,z) (rx, rz, y_neu) (htt GrassIslandMap y_neu) b pl pa r s
where e = gauss3Dgeneral amp (fromIntegral gx) (fromIntegral gz) sig sig rx rz
-- | Makes sure the edges of the Map are mountain-free
makeIsland :: PlayMap -> PlayMap

18
src/Map/Graphics.hs
View File

@@ -30,9 +30,8 @@ import Linear
import Control.Arrow ((***))
import Map.Types
import Map.Creation
type Height = Float
type Height = Double
type MapEntry = (
Height,
@@ -50,16 +49,14 @@ stripify :: (Int,Int) -> (Int,Int)
stripify (x,z) = (if even z then 2*x else 2*x+1, z `div` 2)
strp :: Node -> Node
strp (Full xz y tt bi pli p ri si) = Full (stripify xz) y tt bi pli p ri si
strp (Minimal xz ) = Minimal (stripify xz)
strp (Node i (x,z,y) tt bi pli p ri si) = Node (stripify i) (x,z,y) tt bi pli p ri si
-- extract graphics information from Playmap
convertToGraphicsMap :: PlayMap -> GraphicsMap
convertToGraphicsMap mp = array (bounds mp) [(i, graphicsyfy (mp ! i))| i <- indices mp]
where
graphicsyfy :: Node -> MapEntry
graphicsyfy (Minimal _ ) = (1.0, Grass)
graphicsyfy (Full _ y t _ _ _ _ _ ) = (y, t)
graphicsyfy (Node _ (_,_,y) t _ _ _ _ _ ) = (y, t)
lineHeight :: GLfloat
lineHeight = 0.8660254
@@ -87,9 +84,8 @@ fgNormalIndex = (ToFloat, mapVertexArrayDescriptor 3 4) --normal after color
fgVertexIndex :: (IntegerHandling, VertexArrayDescriptor GLfloat)
fgVertexIndex = (ToFloat, mapVertexArrayDescriptor 3 7) --vertex after normal
getMapBufferObject :: IO (BufferObject, NumArrayIndices)
getMapBufferObject = do
eMap <- exportedMap
getMapBufferObject :: PlayMap -> IO (BufferObject, NumArrayIndices)
getMapBufferObject eMap = do
myMap' <- return $ convertToGraphicsMap $ convertToStripeMap eMap
! myMap <- return $ generateTriangles myMap'
len <- return $ fromIntegral $ P.length myMap `div` numComponents
@@ -203,8 +199,8 @@ colorLookup hs t = if inRange (bounds hs) t then c else (0.0, 0.0, 0.0)
Beach -> (0.90, 0.85, 0.70)
Desert -> (1.00, 0.87, 0.39)
Grass -> (0.30, 0.90, 0.10)
Hill -> (0.80, 0.80, 0.80)
Mountain -> (0.50, 0.50, 0.50)
Mountain -> (0.80, 0.80, 0.80)
Hill -> (0.50, 0.50, 0.50)
coordLookup :: (Int,Int) -> GLfloat -> V3 GLfloat
coordLookup (x,z) y =

55
src/Map/Map.hs
View File

@@ -2,8 +2,8 @@ module Map.Map where
import Map.Types
import Data.Array (bounds)
import Data.List (sort, group)
import Data.Array (bounds, (!))
import Data.List (sort, group)
-- WARNING: Does NOT Check for neighbours exceeding maximum map coordinates yet.
unsafeGiveNeighbours :: (Int, Int) -- ^ original coordinates
@@ -36,6 +36,57 @@ giveNeighbourhood _ 0 (a,b) = [(a,b)]
giveNeighbourhood mp n (a,b) = let ns = giveNeighbours mp (a,b) in
remdups . concat $ ns : map (giveNeighbourhood mp (n-1)) ns
-- | Calculates the height of any given point on the map.
-- Does not add camera distance to ground to that.
giveMapHeight :: PlayMap
-> (Double, Double)
-> Double
giveMapHeight mop (x, z)
| outsideMap (x,z') = 0.0
| otherwise = sum $ map (\(p,d) -> (hlu p) * (1 - (d / totald))) tups
where
z' = z * 2/(sqrt 3)
outsideMap :: (Double, Double) -> Bool
outsideMap (mx, mz) = let ((a,b),(c,d)) = bounds mop
fr = fromIntegral
in mx < (fr a) || mx > (fr c) || mz < (fr b) || mz > (fr d)
-- Height LookUp on PlayMap
hlu :: (Int, Int) -> Double
hlu (k,j) = let (Node _ (_,_,y) _ _ _ _ _ _) = mop ! (k,j) in y
-- reference Points
refs :: [(Int, Int)]
refs = remdups $ map clmp $ map (tadd (floor x, floor z')) mods
where
mods = [(-1,-1),(-1,2),(0,0),(0,1),(1,0),(1,1),(2,-1),(2,2)]
tadd (a,b) (c,d) = (a+b,c+d)
-- tupels with reference point and distance
tups = map (\t -> (t, dist (x,z') t)) refs
-- total distance of all for reference point from the point in question
totald = sum $ map (\(_,d) -> d) tups
-- clamp, as she is programmed
clamp :: (Ord a) => a -> a -> a -> a
clamp mn mx = max mn . min mx
-- clamp for tupels
clmp :: (Int, Int) -> (Int, Int)
clmp (a,b) = let ((xmin,zmin),(xmax,zmax)) = bounds mop
in ((clamp (xmin+2) (xmax-2) a),(clamp (zmin+2) (zmax-2) b))
-- Real distance on PlayMap
dist :: (Double, Double) -> (Int, Int) -> Double
dist (x1,z1) pmp = let xf = x1 - realx
zf = z1 - realz
in sqrt $ xf*xf + zf*zf
where
realx = (\(Node _ (nx,_,_) _ _ _ _ _ _) -> nx) (mop ! pmp)
realz = (\(Node _ (_,nz,_) _ _ _ _ _ _) -> nz) (mop ! pmp)
-- removing duplicates in O(n log n), losing order and adding Ord requirement
remdups :: Ord a => [a] -> [a]
remdups = map head . group . sort

49
src/Map/StaticMaps.hs
View File

@@ -1,49 +0,0 @@
module Map.StaticMaps
where
import Map.Types
import Data.Array
-- entirely empty map, only uses the minimal constructor
mapEmpty :: PlayMap
mapEmpty = array ((0,0), (199,199)) [((a,b), Minimal (a,b)) | a <- [0..199], b <- [0..199]]
--mapCenterMountain :: PlayMap
--mapCenterMountain = array ((0,0),(199,199)) nodes
-- where
-- nodes = water ++ beach ++ grass ++ hill ++ mountain
-- water = [((a,b), Full (a,b) 0.0 Ocean BNothing NoPlayer NoPath Plain []) | a <- [0..199], b <- [0..199], m2d (a,b) > 95]
-- beach = [((a,b), Full (a,b) (g2d a b) Beach BNothing NoPlayer NoPath Plain []) | a <- [0..199], b <- [0..199], m2d (a,b) <= 95, m2d (a,b) > 75]
-- grass = [((a,b), Full (a,b) (g2d a b) Grass BNothing NoPlayer NoPath Plain []) | a <- [0..199], b <- [0..199], m2d (a,b) <= 75, m2d (a,b) > 25]
-- hill = [((a,b), Full (a,b) (g2d a b) Hill BNothing NoPlayer NoPath Plain []) | a <- [0..199], b <- [0..199], m2d (a,b) <= 25, m2d (a,b) > 10]
-- mountain = [((a,b), Full (a,b) (g2d a b) Mountain BNothing NoPlayer NoPath Plain []) | a <- [0..199], b <- [0..199], m2d (a,b) <= 10]
-- g2d :: Int -> Int -> Float
-- g2d x y = gauss3D (fromIntegral x) (fromIntegral y)
-- m2d :: (Int,Int) -> Int
-- m2d (x,y) = mnh2D (x,y) (100,100)
-- small helper for some hills. Should be replaced by multi-layer perlin-noise
-- TODO: Replace as given in comment.
--_noisyMap :: (Floating q) => q -> q -> q
--_noisyMap x y = gauss3Dgeneral 15 100.0 100.0 15.0 15.0 x y
-- + gauss3Dgeneral 5 10.0 10.0 10.0 10.0 x y
-- + gauss3Dgeneral 5 150.0 120.0 10.0 10.0 x y
-- + gauss3Dgeneral 5 50.0 75.0 10.0 10.0 x y
-- generates a noisy map
-- TODO: add real noise to a simple pattern
--mapNoise :: PlayMap
--mapNoise = array ((0,0),(199,199)) nodes
-- where
-- nodes = [((a,b), Full (a,b)
-- (height a b)
-- (heightToTerrain GrassIslandMap $ height a b)
-- BNothing
-- NoPlayer
-- NoPath
-- Plain
-- []) | a <- [0..199], b <- [0..199]]
-- where
-- height a b = _noisyMap (fromIntegral a) (fromIntegral b)

78
src/Map/Types.hs
View File

@@ -1,15 +1,15 @@
module Map.Types
where
import Types
import Data.Array
type PlayMap = Array (XCoord, ZCoord) Node
type PlayMap = Array (Xindex, Zindex) Node
type XCoord = Int
type ZCoord = Int
type YCoord = Float
type Xindex = Int
type Zindex = Int
type XCoord = Double
type ZCoord = Double
type YCoord = Double
data MapType = GrassIslandMap
| DesertMap
@@ -66,7 +66,67 @@ data TileType = Ocean
| Mountain -- ^ Not accessible
deriving (Show, Eq)
-- TODO: Record Syntax
data Node = Full (XCoord, ZCoord) YCoord TileType BuildInfo PlayerInfo PathInfo ResInfo StorInfo
| Minimal (XCoord, ZCoord) -- defaults to empty green grass node on height 1
-- TODO: Record Syntax?
data Node = Node (Xindex, Zindex) (XCoord, ZCoord, YCoord) TileType BuildInfo PlayerInfo PathInfo ResInfo StorInfo
deriving (Show)
data Structure = Flag -- Flag
| Woodcutter -- Huts
| Forester
| Stonemason
| Fisher
| Hunter
| Barracks
| Guardhouse
| LookoutTower
| Well
| Sawmill -- Houses
| Slaughterhouse
| Mill
| Bakery
| IronSmelter
| Metalworks
| Armory
| Mint
| Shipyard
| Brewery
| Storehouse
| Watchtower
| Catapult
| GoldMine -- Mines
| IronMine
| GraniteMine
| CoalMine
| Farm -- Castles
| PigFarm
| DonkeyBreeder
| Harbor
| Fortress
deriving (Show, Eq)
data Amount = Infinite -- Neverending supply
| Finite Int -- Finite supply
-- Extremely preliminary, expand when needed
data Commodity = WoodPlank
| Sword
| Fish
deriving Eq
data Resource = Coal
| Iron
| Gold
| Granite
| Water
| Fishes
deriving (Show, Eq)
instance Show Amount where
show (Infinite) = "inexhaustable supply"
show (Finite n) = show n ++ " left"
instance Show Commodity where
show WoodPlank = "wooden plank"
show Sword = "sword"
show Fish = "fish"

14
src/Render/Misc.hs
View File

@@ -1,4 +1,3 @@
{-# LANGUAGE ForeignFunctionInterface #-}
module Render.Misc where
import Control.Monad
@@ -75,6 +74,16 @@ createFrustum fov n' f' rat =
(V4 0 0 (-((f+n)/(f-n))) (-((2*f*n)/(f-n))))
(V4 0 0 (-1) 0)
-- | Creates an orthogonal frustum with given width, height, near and far-plane
createFrustumOrtho :: Float -> Float -> Float -> Float -> M44 CFloat
createFrustumOrtho w' h' n' f' =
let [w,h,n,f] = map realToFrac [w',h',n',f']
in
V4 (V4 (0.5/w) 0 0 0)
(V4 0 (0.5/h) 0 0)
(V4 0 0 (-2/(f-n)) ((-f+n)/(f-n)))
(V4 0 0 0 1)
-- from vmath.h
lookAt :: V3 CFloat -> V3 CFloat -> V3 CFloat -> M44 CFloat
lookAt eye center up' =
@@ -128,5 +137,4 @@ tryWithTexture t f fail' =
genColorData :: Int -- ^ Amount
-> [Int8] -- ^ [r,g,b,a], [r,g,b] - whatever should be repeatet.
-> [Int8]
genColorData n c = take ((length c)*n) (cycle c)
genColorData n c = take (length c*n) (cycle c)

199
src/Render/Render.hs
View File

@@ -7,11 +7,13 @@ import Foreign.Storable
import Graphics.Rendering.OpenGL.GL
import Graphics.Rendering.OpenGL.Raw.Core31
import Graphics.Rendering.OpenGL.Raw.ARB.TessellationShader
import Graphics.GLUtil.BufferObjects (offset0)
import Graphics.GLUtil.BufferObjects
import qualified Linear as L
import Control.Lens ((^.))
import Control.Monad.RWS.Strict (liftIO)
import qualified Control.Monad.RWS.Strict as RWS (get)
import Control.Concurrent.STM.TVar (readTVarIO)
import Control.Concurrent.STM (atomically)
import Data.Distributive (distribute, collect)
-- FFI
import Foreign (Ptr, castPtr, with)
@@ -24,6 +26,7 @@ import Render.Types
import Graphics.GLUtil.BufferObjects (makeBuffer)
import Importer.IQM.Parser
import Importer.IQM.Types
import Map.Map (giveMapHeight)
mapVertexShaderFile :: String
mapVertexShaderFile = "shaders/map/vertex.shader"
@@ -33,6 +36,8 @@ mapTessEvalShaderFile :: String
mapTessEvalShaderFile = "shaders/map/tessEval.shader"
mapFragmentShaderFile :: String
mapFragmentShaderFile = "shaders/map/fragment.shader"
mapFragmentShaderShadowMapFile :: String
mapFragmentShaderShadowMapFile = "shaders/map/fragmentShadow.shader"
objectVertexShaderFile :: String
objectVertexShaderFile = "shaders/mapobjects/vertex.shader"
@@ -66,6 +71,7 @@ initMapShader tessFac (buf, vertDes) = do
! tessControlSource <- B.readFile mapTessControlShaderFile
! tessEvalSource <- B.readFile mapTessEvalShaderFile
! fragmentSource <- B.readFile mapFragmentShaderFile
! fragmentShadowSource <- B.readFile mapFragmentShaderShadowMapFile
vertexShader <- compileShaderSource VertexShader vertexSource
checkError "compile Vertex"
tessControlShader <- compileShaderSource TessControlShader tessControlSource
@@ -74,7 +80,10 @@ initMapShader tessFac (buf, vertDes) = do
checkError "compile TessEval"
fragmentShader <- compileShaderSource FragmentShader fragmentSource
checkError "compile Frag"
fragmentShadowShader <- compileShaderSource FragmentShader fragmentShadowSource
checkError "compile Frag"
program <- createProgramUsing [vertexShader, tessControlShader, tessEvalShader, fragmentShader]
shadowProgram <- createProgramUsing [vertexShader, tessControlShader, tessEvalShader, fragmentShadowShader]
checkError "compile Program"
currentProgram $= Just program
@@ -119,6 +128,8 @@ initMapShader tessFac (buf, vertDes) = do
overTex <- genObjectName
texts <- genObjectNames 6
smap <- genObjectName
testobj <- parseIQM "sample.iqm"
@@ -137,25 +148,31 @@ initMapShader tessFac (buf, vertDes) = do
currentProgram $= Just objProgram
checkError "initShader"
let sdata = MapShaderData
{ shdrVertexIndex = vertexIndex
, shdrColorIndex = colorIndex
, shdrNormalIndex = normalIndex
, shdrProjMatIndex = projectionMatrixIndex
, shdrViewMatIndex = viewMatrixIndex
, shdrModelMatIndex = modelMatrixIndex
, shdrNormalMatIndex = normalMatrixIndex
, shdrTessInnerIndex = tessLevelInner
, shdrTessOuterIndex = tessLevelOuter
}
return GLMapState
{ _mapProgram = program
, _shdrColorIndex = colorIndex
, _shdrNormalIndex = normalIndex
, _shdrVertexIndex = vertexIndex
, _shdrProjMatIndex = projectionMatrixIndex
, _shdrViewMatIndex = viewMatrixIndex
, _shdrModelMatIndex = modelMatrixIndex
, _shdrNormalMatIndex = normalMatrixIndex
, _shdrTessInnerIndex = tessLevelInner
, _shdrTessOuterIndex = tessLevelOuter
, _mapShaderData = sdata
, _renderedMapTexture = tex
, _stateTessellationFactor = tessFac
, _stateMap = buf
, _mapVert = vertDes
, _overviewTexture = overTex
, _mapTextures = texts
, _shadowMapTexture = smap
, _mapObjects = objs
, _objectProgram = objProgram
, _shadowMapProgram = shadowProgram
}
initHud :: IO GLHud
@@ -190,7 +207,7 @@ initHud = do
att <- get (activeAttribs program)
putStrLn $ unlines $ "Attributes: ":map show att
putStrLn $ unlines $ ["Indices: ", show (texIndex)]
putStrLn $ unlines $ ["Indices: ", show texIndex]
checkError "initHud"
return GLHud
@@ -299,38 +316,126 @@ renderObject :: MapObject -> IO ()
renderObject (MapObject model pos@(L.V3 x y z) _{-state-}) =
renderIQM model pos (L.V3 1 1 1)
drawMap :: Pioneers ()
drawMap = do
state <- RWS.get
let
d = state ^. gl.glMap.mapShaderData
vi = shdrVertexIndex d
ni = shdrNormalIndex d
ci = shdrColorIndex d
numVert = state ^. gl.glMap.mapVert
map' = state ^. gl.glMap.stateMap
tessFac = state ^. gl.glMap.stateTessellationFactor
(UniformLocation tli) = shdrTessInnerIndex d
(UniformLocation tlo) = shdrTessOuterIndex d
liftIO $ do
glUniform1f tli (fromIntegral tessFac)
glUniform1f tlo (fromIntegral tessFac)
bindBuffer ArrayBuffer $= Just map'
vertexAttribPointer ci $= fgColorIndex
vertexAttribArray ci $= Enabled
vertexAttribPointer ni $= fgNormalIndex
vertexAttribArray ni $= Enabled
vertexAttribPointer vi $= fgVertexIndex
vertexAttribArray vi $= Enabled
checkError "beforeDraw"
glPatchParameteri gl_PATCH_VERTICES 3
cullFace $= Just Front
glDrawArrays gl_PATCHES 0 (fromIntegral numVert)
checkError "draw map"
---- RENDER MAPOBJECTS --------------------------------------------
currentProgram $= Just (state ^. gl.glMap.objectProgram)
mapM_ renderObject (state ^. gl.glMap.mapObjects)
-- set sample 1 as target in renderbuffer
{-framebufferRenderbuffer
DrawFramebuffer --write-only
(ColorAttachment 1) --sample 1
Renderbuffer --const
rb --buffer-}
render :: Pioneers ()
render = do
state <- RWS.get
let xa = state ^. camera.xAngle
ya = state ^. camera.yAngle
(UniformLocation proj) = state ^. gl.glMap.shdrProjMatIndex
(UniformLocation nmat) = state ^. gl.glMap.shdrNormalMatIndex
(UniformLocation vmat) = state ^. gl.glMap.shdrViewMatIndex
(UniformLocation tli) = state ^. gl.glMap.shdrTessInnerIndex
(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.Types.frustum
camPos = state ^. camera.camObject
zDist' = state ^. camera.zDist
tessFac = state ^. gl.glMap.stateTessellationFactor
cam <- liftIO $ readTVarIO (state ^. camera)
let xa = cam ^. xAngle
ya = cam ^. yAngle
frust = cam ^. Types.frustum
camPos = cam ^. camObject
zDist' = cam ^. zDist
d = state ^. gl.glMap.mapShaderData
(UniformLocation proj) = shdrProjMatIndex d
(UniformLocation nmat) = shdrNormalMatIndex d
(UniformLocation vmat) = shdrViewMatIndex d
liftIO $ do
---- RENDER MAP IN TEXTURE ------------------------------------------
bindFramebuffer Framebuffer $= (state ^. gl.glFramebuffer)
bindRenderbuffer Renderbuffer $= (state ^. gl.glRenderbuffer)
{-bindRenderbuffer Renderbuffer $= (state ^. gl.glRenderbuffer)
framebufferRenderbuffer
Framebuffer
DepthAttachment
Renderbuffer
(state ^. gl.glRenderbuffer)
textureBinding Texture2D $= Just (state ^. gl.glMap.renderedMapTexture)
(state ^. gl.glRenderbuffer)-}
-- SHADOWMAP
textureBinding Texture2D $= Just (state ^. gl.glMap.shadowMapTexture)
framebufferTexture2D
Framebuffer
DepthAttachment
Texture2D
(state ^. gl.glMap.shadowMapTexture)
0
drawBuffer $= NoBuffers --color-buffer is not needed but must(?) be set up
checkError "setup Render-Target"
clear [DepthBuffer]
checkError "clearing shadowmap-buffer"
--TODO: simplified program for shadows?
currentProgram $= Just (state ^. gl.glMap.mapProgram)
checkError "setting up shadowmap-program"
--set up projection (= copy from state)
--TODO: Fix width/depth
with (distribute (createFrustumOrtho 20 20 0 100)) $ \ptr ->
glUniformMatrix4fv proj 1 0 (castPtr (ptr :: Ptr (L.M44 CFloat)))
checkError "copy shadowmap-projection"
--set up camera
--TODO: Fix magic constants... and camPos
let ! cam = getCam camPos 1 0.7 0
with (distribute cam) $ \ptr ->
glUniformMatrix4fv vmat 1 0 (castPtr (ptr :: Ptr (L.M44 CFloat)))
checkError "copy shadowmap-cam"
--set up normal--Mat transpose((model*camera)^-1)
--needed?
let normal' = (case L.inv33 (fmap (^. L._xyz) cam ^. L._xyz) of
(Just a) -> a
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 (L.M33 CFloat)))
checkError "nmat"
drawMap
liftIO $ do
checkError "draw ShadowMap"
-- COLORMAP
textureBinding Texture2D $= Just (state ^. gl.glMap.renderedMapTexture)
framebufferTexture2D
Framebuffer
(ColorAttachment 0)
@@ -371,38 +476,8 @@ render = do
checkError "nmat"
glUniform1f tli (fromIntegral tessFac)
glUniform1f tlo (fromIntegral tessFac)
bindBuffer ArrayBuffer $= Just map'
vertexAttribPointer ci $= fgColorIndex
vertexAttribArray ci $= Enabled
vertexAttribPointer ni $= fgNormalIndex
vertexAttribArray ni $= Enabled
vertexAttribPointer vi $= fgVertexIndex
vertexAttribArray vi $= Enabled
checkError "beforeDraw"
glPatchParameteri gl_PATCH_VERTICES 3
cullFace $= Just Front
glDrawArrays gl_PATCHES 0 (fromIntegral numVert)
checkError "draw map"
---- RENDER MAPOBJECTS --------------------------------------------
currentProgram $= Just (state ^. gl.glMap.objectProgram)
mapM_ renderObject (state ^. gl.glMap.mapObjects)
-- set sample 1 as target in renderbuffer
{-framebufferRenderbuffer
DrawFramebuffer --write-only
(ColorAttachment 1) --sample 1
Renderbuffer --const
rb --buffer-}
drawMap --draw map -> put to another function for readability
liftIO $ do
---- COMPOSE RENDERING --------------------------------------------
-- Render to BackBuffer (=Screen)

34
src/Render/Types.hs
View File

@@ -4,6 +4,10 @@ module Render.Types (createFlatCam, createSphereCam, Camera, GLCamera(..)) where
import Linear
import Foreign.C (CFloat)
import Render.Misc (lookAt)
import Map.Map (giveMapHeight)
import Map.Types (PlayMap)
import GHC.Float
import qualified Debug.Trace as D
type Distance = Double
type Pitch = Double
@@ -11,30 +15,32 @@ type Yaw = Double
class GLCamera a where
getCam :: a -> Distance -> Pitch -> Yaw -> M44 CFloat
moveBy :: a -> (Position -> Position) -> a
move :: a -> Position -> a
moveBy :: a -> (Position -> Position) -> PlayMap -> a
move :: a -> Position -> PlayMap -> a
type Position = (Double, Double)
type Radius = Double
data Camera = Flat Position
type Height = Double
data Camera = Flat Position Height
| Sphere Position Radius
-- | create a Flatcam-Camera starting at given x/z-Coordinates
createFlatCam :: Double -> Double -> Camera
createFlatCam x z = Flat (x,z)
createFlatCam :: Double -> Double -> PlayMap -> Camera
createFlatCam x z map' = Flat (x,z) (giveMapHeight map' (x, z))
-- | create a Flatcam-Camera starting at given pitch/azimuth/radius
createSphereCam :: Double -> Double -> Double -> Camera
createSphereCam p a r = Sphere (p,a) r
createSphereCam p a = Sphere (p,a)
instance GLCamera Camera where
getCam (Flat (x',z')) dist' xa' ya' =
getCam (Flat (x',z') y') dist' xa' ya' =
lookAt (cpos ^+^ at') at' up
where
at' = V3 x 0 z
at' = V3 x (y+2) z
cpos = crot !* (V3 0 0 (-dist))
crot = (
(fromQuaternion $ axisAngle upmap (xa::CFloat))
@@ -44,6 +50,7 @@ instance GLCamera Camera where
upmap = ((fromQuaternion $ axisAngle (V3 0 1 0) (ya::CFloat)) :: M33 CFloat)
!* (V3 1 0 0)
x = realToFrac x'
y = realToFrac y'
z = realToFrac z'
dist = realToFrac dist'
xa = realToFrac xa'
@@ -68,12 +75,15 @@ instance GLCamera Camera where
dist = realToFrac dist'
xa = realToFrac xa'
ya = realToFrac ya'
moveBy (Sphere (inc, az) r) f = undefined
moveBy (Flat (x', z')) f = Flat (f (x',z'))
move c (x', z') = moveBy c (\(x,z) -> (x+x',z+z'))
moveBy (Sphere (inc, az) r) f map = undefined
moveBy (Flat (x', z') y) f map = Flat (x,z) y
where
(x,z) = f (x', z')
y = giveMapHeight map (x,z)
move c (x', z') map = moveBy c (\(x,z) -> (x+x',z+z')) map
sphereToCart :: (Floating a) => a -> a -> a -> V3 a
sphereToCart r inc az = V3
(r * (sin inc) * (cos az))
(r * (sin inc) * (sin az))
(r * (cos inc))
(r * (cos inc))

103
src/Types.hs
View File

@@ -1,7 +1,7 @@
{-# LANGUAGE TemplateHaskell #-}
module Types where
import Control.Concurrent.STM (TQueue)
import Control.Concurrent.STM (TQueue, TVar, readTVar, writeTVar, atomically)
import qualified Graphics.Rendering.OpenGL.GL as GL
import Graphics.UI.SDL as SDL (Event, Window)
import Foreign.C (CFloat)
@@ -9,12 +9,14 @@ import qualified Data.HashMap.Strict as Map
import Data.Time (UTCTime)
import Linear.Matrix (M44)
import Linear (V3)
import Control.Monad.RWS.Strict (RWST)
import Control.Monad.RWS.Strict (RWST, liftIO, get)
import Control.Monad (when)
import Control.Lens
import Graphics.Rendering.OpenGL.GL.Texturing.Objects (TextureObject)
import Render.Types
import Importer.IQM.Types
import UI.UIBase
import Map.Types (PlayMap)
data Coord3D a = Coord3D a a a
@@ -56,7 +58,7 @@ data IOState = IOState
}
data GameState = GameState
{
{ _currentMap :: !PlayMap
}
data MouseState = MouseState
@@ -100,24 +102,30 @@ data KeyboardState = KeyboardState
data GLMapState = GLMapState
{ _shdrVertexIndex :: !GL.AttribLocation
, _shdrColorIndex :: !GL.AttribLocation
, _shdrNormalIndex :: !GL.AttribLocation
, _shdrProjMatIndex :: !GL.UniformLocation
, _shdrViewMatIndex :: !GL.UniformLocation
, _shdrModelMatIndex :: !GL.UniformLocation
, _shdrNormalMatIndex :: !GL.UniformLocation
, _shdrTessInnerIndex :: !GL.UniformLocation
, _shdrTessOuterIndex :: !GL.UniformLocation
{ _mapShaderData :: !MapShaderData
, _stateTessellationFactor :: !Int
, _stateMap :: !GL.BufferObject
, _mapVert :: !GL.NumArrayIndices
, _mapProgram :: !GL.Program
, _renderedMapTexture :: !TextureObject --TODO: Probably move to UI?
, _overviewTexture :: !TextureObject
, _shadowMapTexture :: !TextureObject
, _mapTextures :: ![TextureObject] --TODO: Fix size on list?
, _objectProgram :: !GL.Program
, _mapObjects :: ![MapObject]
, _shadowMapProgram :: !GL.Program
}
data MapShaderData = MapShaderData
{ shdrVertexIndex :: !GL.AttribLocation
, shdrColorIndex :: !GL.AttribLocation
, shdrNormalIndex :: !GL.AttribLocation
, shdrProjMatIndex :: !GL.UniformLocation
, shdrViewMatIndex :: !GL.UniformLocation
, shdrModelMatIndex :: !GL.UniformLocation
, shdrNormalMatIndex :: !GL.UniformLocation
, shdrTessInnerIndex :: !GL.UniformLocation
, shdrTessOuterIndex :: !GL.UniformLocation
}
data MapObject = MapObject !IQM !MapCoordinates !MapObjectState
@@ -153,12 +161,12 @@ data UIState = UIState
data State = State
{ _window :: !WindowState
, _camera :: !CameraState
, _camera :: TVar CameraState
, _io :: !IOState
, _mouse :: !MouseState
, _keyboard :: !KeyboardState
, _gl :: !GLState
, _game :: !GameState
, _game :: TVar GameState
, _ui :: !UIState
}
@@ -180,63 +188,18 @@ $(makeLenses ''Position)
$(makeLenses ''Env)
$(makeLenses ''UIState)
data Structure = Flag -- Flag
| Woodcutter -- Huts
| Forester
| Stonemason
| Fisher
| Hunter
| Barracks
| Guardhouse
| LookoutTower
| Well
| Sawmill -- Houses
| Slaughterhouse
| Mill
| Bakery
| IronSmelter
| Metalworks
| Armory
| Mint
| Shipyard
| Brewery
| Storehouse
| Watchtower
| Catapult
| GoldMine -- Mines
| IronMine
| GraniteMine
| CoalMine
| Farm -- Castles
| PigFarm
| DonkeyBreeder
| Harbor
| Fortress
deriving (Show, Eq)
-- helper-functions for types
data Amount = Infinite -- Neverending supply
| Finite Int -- Finite supply
-- | atomically change gamestate on condition
changeIfGamestate :: (GameState -> Bool) -> (GameState -> GameState) -> Pioneers ()
changeIfGamestate cond f = do
state <- get
liftIO $ atomically $ do
game' <- readTVar (state ^. game)
when (cond game') (writeTVar (state ^. game) (f game'))
-- Extremely preliminary, expand when needed
data Commodity = WoodPlank
| Sword
| Fish
deriving Eq
data Resource = Coal
| Iron
| Gold
| Granite
| Water
| Fishes
deriving (Show, Eq)
instance Show Amount where
show (Infinite) = "inexhaustable supply"
show (Finite n) = show n ++ " left"
instance Show Commodity where
show WoodPlank = "wooden plank"
show Sword = "sword"
show Fish = "fish"
-- | atomically change gamestate
changeGamestate :: (GameState -> GameState) -> Pioneers ()
changeGamestate = changeIfGamestate (const True)

14
src/UI/Callbacks.hs
View File

@@ -13,6 +13,8 @@ import Data.Maybe
import Foreign.Marshal.Array (pokeArray)
import Foreign.Marshal.Alloc (allocaBytes)
import qualified Graphics.UI.SDL as SDL
import Control.Concurrent.STM.TVar (readTVar, readTVarIO, writeTVar)
import Control.Concurrent.STM (atomically)
import Render.Misc (curb,genColorData)
@@ -102,6 +104,7 @@ eventCallback e = do
return ()
SDL.MouseMotion _ _ _ (SDL.Position x y) _ _ -> -- windowID mouseID motionState motionPosition xrel yrel
mouseMoveHandler (x, y)
SDL.MouseButton _ _ button state (SDL.Position x y) -> -- windowID mouseID button buttonState buttonAt
case state of
SDL.Pressed -> maybe (return ()) (`mousePressHandler` (x, y)) $ transformButton button
@@ -110,8 +113,13 @@ eventCallback e = do
SDL.MouseWheel _ _ _ vscroll -> -- windowID mouseID hScroll vScroll
do -- TODO: MouseWheelHandler
state <- get
let zDist' = (state ^. camera.zDist) + realToFrac (negate vscroll) in
modify $ camera.zDist .~ curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist'
liftIO $ atomically $ do
cam <- readTVar (state ^. camera)
let zDist' = (cam ^. zDist) + realToFrac (negate vscroll)
zDist'' = curb (env ^. zDistClosest) (env ^. zDistFarthest) zDist'
cam' <- return $ zDist .~ zDist'' $ cam
writeTVar (state ^. camera) cam'
-- there is more (joystic, touchInterface, ...), but currently ignored
SDL.Quit -> modify $ window.shouldClose .~ True
_ -> liftIO $ putStrLn $ unwords ["Not processing Event:", show e]
@@ -289,4 +297,4 @@ copyGUI tex (vX, vY) widget = do
mapM_ (copyGUI tex (vX+xoff, vY+yoff)) $ toGUIAnys hMap nextChildrenIds
--TODO: Add scroll-Handler, return (Pioneers Bool) to indicate event-bubbling etc.
--TODO: Maybe queues are better?
--TODO: Maybe queues are better?

8
src/UI/UIWidgets.hs
View File

@@ -2,9 +2,10 @@
module UI.UIWidgets (module UI.UIWidgets, module UI.UIBase) where
import Control.Concurrent.STM.TVar (readTVarIO)
import Control.Lens ((^.), (.~), (%~), (&))
import Control.Monad
-- import Control.Monad.IO.Class (liftIO)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.RWS.Strict (get, modify)
import Data.List
import Data.Maybe
@@ -57,11 +58,12 @@ createViewport btn bnd chld prio = Widget (rectangularBase bnd chld prio "VWP")
let press btn' (x, y) _ w =
do when (btn == btn') $ do
state <- get
cam <- liftIO $ readTVarIO (state ^. camera)
modify $ mouse %~ (isDragging .~ True)
. (dragStartX .~ fromIntegral x)
. (dragStartY .~ fromIntegral y)
. (dragStartXAngle .~ (state ^. camera.xAngle))
. (dragStartYAngle .~ (state ^. camera.yAngle))
. (dragStartXAngle .~ (cam ^. xAngle))
. (dragStartYAngle .~ (cam ^. yAngle))
. (mousePosition.Types._x .~ fromIntegral x)
. (mousePosition.Types._y .~ fromIntegral y)
return w