Include tick counting code
This commit is contained in:
+13
-26
@@ -57,26 +57,20 @@ fixedCoordPictures w = pictures
|
||||
|
||||
worldPictures :: World -> Picture
|
||||
worldPictures w
|
||||
= pictures $ map screenShift $ concat
|
||||
[ decPicts
|
||||
, ppPicts
|
||||
, itFloorPicts
|
||||
, crPicts
|
||||
, clPicts
|
||||
, buttonPicts
|
||||
, ptPicts
|
||||
, ptPicts'
|
||||
, afterPtPicts'
|
||||
, wlPicts
|
||||
, wallShadows
|
||||
, smokeShadows
|
||||
]
|
||||
= pictures $ concat [ decPicts
|
||||
, ppPicts
|
||||
, itFloorPicts
|
||||
, crPicts
|
||||
, clPicts
|
||||
, buttonPicts
|
||||
, ptPicts
|
||||
, ptPicts'
|
||||
, afterPtPicts'
|
||||
, wlPicts
|
||||
, wallShadows
|
||||
, smokeShadows
|
||||
]
|
||||
where
|
||||
screenShift = id--scale zoomx zoomy . rotate (0 - (_cameraRot w) )
|
||||
-- . uncurry translate ((0,0) -.- _cameraPos w)
|
||||
zoomx = 2 * _cameraZoom w / _windowX w
|
||||
zoomy = 2 * _cameraZoom w / _windowY w
|
||||
scaler = scale (2 / _windowX w) (2 / _windowY w)
|
||||
decPicts = IM.elems $ _decorations w
|
||||
ptPicts = map _ptPict (IM.elems (_particles w))
|
||||
ptPicts' = map _ptPict' $ _particles' w
|
||||
@@ -565,13 +559,6 @@ displayHP n w = translate (halfWidth w-70) (halfHeight w-40) $
|
||||
|
||||
testPic w = blank
|
||||
|
||||
wallsForGloom :: World -> [(Point2,Point2)]
|
||||
wallsForGloom w = map (\(x:y:_) -> (screenShift x,screenShift y)) $
|
||||
map _wlLine $ filter (not . _wlIsSeeThrough)
|
||||
$ IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w
|
||||
where screenShift x = zoom *.* rotateV (0 - _cameraRot w) (x -.- _cameraPos w)
|
||||
zoom = _cameraZoom w
|
||||
|
||||
wallsForGloom' :: World -> [(Point2,Point2,Point2,Point2)]
|
||||
wallsForGloom' w = map (wallPairToFour . _wlLine) $ filter (not . _wlIsSeeThrough)
|
||||
$ IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w
|
||||
|
||||
+9
-12
@@ -14,7 +14,7 @@ import Geometry
|
||||
|
||||
import Preload
|
||||
|
||||
import Control.Lens ((.~),(&))
|
||||
import Control.Lens ((.~),(&),(+~))
|
||||
|
||||
winConfig x y = defaultWindow
|
||||
{ windowGraphicsContext
|
||||
@@ -80,6 +80,7 @@ doLoop setup window startWorld
|
||||
GL.clear [GL.ColorBuffer,GL.DepthBuffer]
|
||||
newParams <- worldSideEffects (setup & currentTime .~ startLoopTicks) startWorld
|
||||
glSwapWindow window
|
||||
endSideTicks <- ticks
|
||||
--worldSideEffects setup updatedWorld
|
||||
events <- pollEvents
|
||||
--let-- maybeUpdatedWorld :: Maybe (WorldView world0)
|
||||
@@ -91,12 +92,17 @@ doLoop setup window startWorld
|
||||
--worldSideEffects setup updatedWorld
|
||||
--glSwapWindow window
|
||||
--GL.flush
|
||||
endSimTicks <- ticks
|
||||
performGC
|
||||
endLoopTicks <- ticks -- it might be better to use System.Clock (monotonic)
|
||||
let delay = max 0 (10 + fromIntegral startLoopTicks - fromIntegral endLoopTicks)
|
||||
threadDelay (delay * 1000)
|
||||
doLoop newParams window updatedWorld worldSideEffects eventFn worldUpdate
|
||||
Nothing -> return ()
|
||||
endTime <- ticks
|
||||
let newNewParams = newParams & idleTime +~ (endTime - endLoopTicks)
|
||||
& gcTime +~ (endLoopTicks - endSimTicks)
|
||||
& simTime +~ (endSimTicks - endSideTicks)
|
||||
doLoop newNewParams window updatedWorld worldSideEffects eventFn worldUpdate
|
||||
Nothing -> showTiming setup
|
||||
|
||||
applyEvents :: (world0 -> Event -> Maybe world0)
|
||||
-> world0
|
||||
@@ -115,15 +121,6 @@ applyEvents eventFn startWorld events worldUpdate =
|
||||
WindowClosedEvent _ -> Nothing
|
||||
_ -> f w e
|
||||
|
||||
-- applyResizeExits :: (world -> Event -> Maybe world) -> (world -> Event -> Maybe world)
|
||||
-- applyResizeExits f w e
|
||||
-- = case eventPayload e of
|
||||
-- QuitEvent -> Nothing
|
||||
-- WindowClosedEvent _ -> Nothing
|
||||
-- WindowSizeChangedEvent
|
||||
-- (WindowSizeChangedEventData {windowSizeChangedEventWindow = V2 x y})
|
||||
-- -> GL.viewport
|
||||
-- _ -> f w e
|
||||
applyEventIO :: (world -> Event -> Maybe world) -> Maybe world -> Event -> IO (Maybe world)
|
||||
applyEventIO fn mw e = case eventPayload e of
|
||||
QuitEvent -> return Nothing
|
||||
|
||||
@@ -157,7 +157,7 @@ preloadRender = do
|
||||
circvao <- setupVAO [(posVBO,0,3),(colVBO,1,4),(texVBO,2,1)]
|
||||
arcvao <- setupVAO [(posVBO,0,3),(colVBO,1,4),(texVBO,2,4)]
|
||||
backgroundvao <- setupVAO [(posVBO,0,4),(colVBO,1,2)]
|
||||
wallvao <- setupVAO [(posVBO,0,4),(colVBO,1,4)]
|
||||
wallvao <- setupVAO [(posVBO,0,4)]--,(colVBO,1,4)]
|
||||
fadecircvao <- setupVAO [(posVBO,0,4)]
|
||||
|
||||
return $ RenderData
|
||||
|
||||
+20
-35
@@ -34,6 +34,8 @@ import qualified Data.IntMap as IM
|
||||
|
||||
import Control.DeepSeq
|
||||
|
||||
import qualified SDL as SDL
|
||||
|
||||
white = (1,1,1,1)
|
||||
black = (0,0,0,1)
|
||||
|
||||
@@ -130,25 +132,6 @@ picToList j (SetDepth a pic) = fmap (setDepthRen a) $ picToList j pic
|
||||
picToList j (Color c pic) = fmap (colorRen c) $ picToList j pic
|
||||
picToList j (Pictures pics) = concatMap (picToList j) pics
|
||||
|
||||
--picToFTree :: Picture -> IM.IntMap (FTree RenderType)
|
||||
--{-# INLINE picToFTree #-}
|
||||
--picToFTree (Polygon i ps) = IM.singleton i $ FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
|
||||
--picToFTree (PolygonCol i vs)
|
||||
-- = let (ps,cs) = unzip vs
|
||||
-- in IM.singleton i $ FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
|
||||
--picToFTree (Circle i r) = IM.singleton i $ FLeaf $ RenderCirc $ ((0,0,0),black,r)
|
||||
--picToFTree (ThickArc i startA endA rad wdth)
|
||||
-- = IM.singleton i $ FLeaf $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
|
||||
--picToFTree Blank = IM.singleton 0 $ FLeaf $ RenderBlank
|
||||
--picToFTree (Line i ps) = IM.singleton 0 $ FLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat black
|
||||
--picToFTree (Text i s) = IM.singleton i $ FLeaf $ RenderText $ stringToList s
|
||||
--picToFTree (Scale x y pic) = fmap (FBranch (scaleRen x y)) $ picToFTree pic
|
||||
--picToFTree (Translate x y pic) = fmap (FBranch (translateRen x y)) $ picToFTree pic
|
||||
--picToFTree (Rotate a pic) = fmap (FBranch (rotateRen a)) $ picToFTree pic
|
||||
--picToFTree (SetDepth a pic) = fmap (FBranch (setDepthRen a)) $ picToFTree pic
|
||||
--picToFTree (Color c pic) = fmap (FBranch (colorRen c)) $ picToFTree pic
|
||||
--picToFTree (Pictures pics) = fmap FBranches $ IM.unionsWith (++) $ map (fmap return . picToFTree) pics
|
||||
|
||||
picToFTree :: Int -> Picture -> FTree RenderType
|
||||
--{-# INLINE picToFTree #-}
|
||||
picToFTree x (Polygon i ps)
|
||||
@@ -314,10 +297,11 @@ threePtrsVAO vao = case (\(_,ps,_) -> ps) $ unzip3 $ _vaoBufferTargets vao of
|
||||
|
||||
|
||||
renderPicture' :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) ->
|
||||
[(Point2,Point2,Point2,Point2)] -> [Point4] -> Picture -> IO ()
|
||||
[(Point2,Point2,Point2,Point2)] -> [Point4] -> Picture -> IO (Word32,Word32)
|
||||
renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints pic = do
|
||||
depthFunc $= Just Lequal
|
||||
|
||||
aticks <- SDL.ticks
|
||||
-- calculate world transformation matrix
|
||||
let scalMat = Linear.Matrix.transpose $
|
||||
V4 (V4 (2*zoom/winx) 0 0 (0::GLfloat))
|
||||
@@ -348,23 +332,20 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
|
||||
,_wallShadowShader pdata
|
||||
] $ \shad -> do
|
||||
currentProgram $= Just (fst shad)
|
||||
uniform (snd shad !! 0) $= Vector2 winx winy
|
||||
uniform (snd shad !! 1) $= zoom
|
||||
uniform (snd shad !! 2) $= rot
|
||||
uniform (snd shad !! 3) $= Vector2 tranx trany
|
||||
|
||||
-- matrixMode $= Projection
|
||||
-- loadIdentity
|
||||
uniform (snd shad !! 0) $= Vector2 winx winy
|
||||
uniform (snd shad !! 1) $= zoom
|
||||
uniform (snd shad !! 2) $= rot
|
||||
uniform (snd shad !! 3) $= Vector2 tranx trany
|
||||
uniform (snd shad !! 4) $= wmata
|
||||
|
||||
bticks <- SDL.ticks
|
||||
|
||||
-- draw lightmap
|
||||
bindVertexArrayObject $= Just (_vao $ _wallVAO pdata)
|
||||
let wallPtr = (\(_,x,_) -> x) $ head $ _vaoBufferTargets $ _wallVAO pdata
|
||||
wallPtr2 = (\(_,x,_) -> x) $ (_vaoBufferTargets $ _wallVAO pdata) !! 1
|
||||
-- wallPtr2 = (\(_,x,_) -> x) $ (_vaoBufferTargets $ _wallVAO pdata) !! 1
|
||||
foldWalls n ((x,y),(z,w),(a,b),(c,d)) = do
|
||||
pokeFourOff wallPtr n (x,y,z,w)
|
||||
pokeFourOff wallPtr2 n (a,b,c,d)
|
||||
-- pokeFourOff wallPtr2 n (a,b,c,d)
|
||||
return $ n+1
|
||||
nWalls <- foldM foldWalls 0 wallPoints
|
||||
|
||||
@@ -385,18 +366,19 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
|
||||
bindArrayBuffers (1) $ _vaoBufferTargets $ _fadeCircVAO pdata
|
||||
blendFuncSeparate $= ((Zero,Zero),(Zero, OneMinusSrcAlpha))
|
||||
drawArrays Points (fromIntegral 0) (fromIntegral 1)
|
||||
ticksAfterL <- SDL.ticks
|
||||
-- draw picture
|
||||
-- set drawing for on top
|
||||
blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
|
||||
clear [DepthBuffer]
|
||||
-- draw layer 0
|
||||
renderTree pdata rot zoom (tranx,trany) (winx,winy) (picToFTree 0 pic)
|
||||
ticks2 <- renderTree pdata rot zoom (tranx,trany) (winx,winy) (picToFTree 0 pic)
|
||||
-- reset blend so that light map doesn't apply
|
||||
blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
|
||||
renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToFTree 1 pic
|
||||
ticks3 <- renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToFTree 1 pic
|
||||
-- set drawing for on top
|
||||
blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
|
||||
renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToFTree 2 pic
|
||||
ticks4 <- renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToFTree 2 pic
|
||||
-- reset uniforms (hacky for now)
|
||||
idmat <- (newMatrix RowMajor [1,0,0,0
|
||||
,0,1,0,0
|
||||
@@ -418,7 +400,7 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
|
||||
uniform (snd shad !! 2) $= (0::Float)
|
||||
uniform (snd shad !! 3) $= Vector2 (0::Float) 0
|
||||
uniform (snd shad !! 4) $= idmat
|
||||
|
||||
return (ticksAfterL, ticks2+ticks3+ticks4)
|
||||
|
||||
bufferOffset :: Integral a => a -> Ptr b
|
||||
bufferOffset = plusPtr nullPtr . fromIntegral
|
||||
@@ -428,9 +410,10 @@ bufferOffset = plusPtr nullPtr . fromIntegral
|
||||
-- it does not set nor change the blend function or depth buffer
|
||||
-- nor does it set uniforms
|
||||
renderTree :: Foldable f => RenderData -> Float -> Float -> (Float,Float) -> (Float,Float)
|
||||
-> f RenderType -> IO ()
|
||||
-> f RenderType -> IO Word32
|
||||
renderTree pdata rot zoom (tranx,trany) (winx,winy) tree = do
|
||||
|
||||
pokeStartTicks <- SDL.ticks
|
||||
-- poke necessary data
|
||||
(nTriVs,nTextVs,numCircVs,nLineVs,nArcVs)
|
||||
-- <- F.foldM (theFold (_ptrPosVBO pdata, _ptrColVBO pdata)
|
||||
@@ -440,6 +423,7 @@ renderTree pdata rot zoom (tranx,trany) (winx,winy) tree = do
|
||||
(twoPtrsVAO $ _lineVAO pdata)
|
||||
(threePtrsVAO $ _arcVAO pdata)
|
||||
) $ tree
|
||||
pokeEndTicks <-SDL.ticks
|
||||
|
||||
depthFunc $= Just Less
|
||||
|
||||
@@ -481,3 +465,4 @@ renderTree pdata rot zoom (tranx,trany) (winx,winy) tree = do
|
||||
bindArrayBuffers nTextVs $ _vaoBufferTargets $ _textVAO pdata
|
||||
textureBinding Texture2D $= Just (_textures pdata !! 0)
|
||||
drawArrays Points 0 (fromIntegral $ nTextVs)
|
||||
return (pokeEndTicks - pokeStartTicks)
|
||||
|
||||
Reference in New Issue
Block a user