justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Commit before introducing layers to pictures

Browse Source
This commit is contained in:
jgk
2021-02-23 22:18:35 +01:00
parent b9cba33b81
commit a853c2d946
5 changed files with 33 additions and 60 deletions
Download Patch File Download Diff File Expand all files Collapse all files
app/Main.hs
-1
View File
@@ -1,7 +1,6 @@
module Main where
import Loop
import EventHelper
import Shaders
import Shapes
src/Dodge/LoadSound.hs
-16
View File
@@ -102,22 +102,6 @@ loadSounds = do
, foamSpray'
]
-- updateSound :: World -> IO World
-- updateSound w
-- = do forM_ (_soundQueue w) (\n -> Mix.playOn (-1) 0 (_loadedSounds w IM.! n))
-- fmap (set soundQueue creatureSounds) $ stepSoundTimers $ w
-- -- = return $ set soundQueue creatureSounds w
-- -- = do forM_ (_soundQueue w) (\n -> Mix.playOn (-1) (_loadedSounds w IM.! n) 0)
-- -- fmap (set soundQueue creatureSounds) $ return w
-- where creatureSounds = []
--playSounds :: a -> World -> IO ()
--playSounds _ w = do
-- forM_ (_soundQueue w) (\n -> Mix.playOn (-1) 0 (_loadedSounds w IM.! n))
-- -- = return $ set soundQueue creatureSounds w
-- -- = do forM_ (_soundQueue w) (\n -> Mix.playOn (-1) (_loadedSounds w IM.! n) 0)
-- -- fmap (set soundQueue creatureSounds) $ return w
-- where creatureSounds = []
soundOnce :: Int -> World -> World
soundOnce i = over soundQueue ((:) i)
src/Dodge/Weapons.hs
+3 -2
View File
@@ -714,8 +714,9 @@ aTeslaArc cid w = aTeslaArc' cid
$ soundFrom (CrWeaponSound cid) 25 1 0 w
aTeslaArc' :: Int -> World -> World
aTeslaArc' cid w = over particles (IM.insert i (makeTeslaArcAt i pos dir))
$ flareAt' cyan 0.03 0.1 (pos +.+ 5 *.* unitVectorAtAngle dir)
aTeslaArc' cid w =
flareAt' cyan 0.03 0.1 (pos +.+ 5 *.* unitVectorAtAngle dir)
$ over particles (IM.insert i (makeTeslaArcAt i pos dir))
$ set randGen g w
where cr = (_creatures w IM.! cid)
i = newParticleKey w
src/EventHelper.hs
-11
View File
@@ -1,11 +0,0 @@
module EventHelper where
import SDL
stripTimestamp :: (world -> EventPayload -> Maybe world)
-> world -> Event -> Maybe world
stripTimestamp f w e = f w (eventPayload e)
test :: world -> EventPayload -> Maybe world
test w e = case e of
KeyboardEvent (KeyboardEventData _ Pressed _ (Keysym _ KeycodeReturn _)) -> Nothing
_ -> Just w
src/Picture/Render.hs
+30 -30
View File
@@ -30,14 +30,6 @@ import qualified Data.DList as DL
import Control.DeepSeq
concat34 :: (Point3,RGBA) -> [Float]
concat34 ((x,y,z),(r,g,b,a)) = [x,y,z,r,g,b,a]
toVec2 (x,y) = Vector2 x y
toVec3 (x,y,z) = Vector3 x y z
toVec4 (x,y,z,w) = Vector4 x y z w
polyToTris :: [s] -> [s]
{-# INLINE polyToTris #-}
polyToTris (a:b:c:as) = a : intercalate [a] (zipWith (\x y->[x,y]) (init (b:c:as)) (c:as))
@@ -247,11 +239,13 @@ threePtrsVAO :: VAO -> (Ptr Float, Ptr Float,Ptr Float)
threePtrsVAO vao = case (\(_,ps,_) -> ps) $ unzip3 $ _vaoBufferTargets vao of
(a:b:c:_) -> (a,b,c)
renderPicture' :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) ->
[(Point2,Point2,Point2,Point2)] -> [Point4] -> Picture -> IO ()
renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints pic = do
depthFunc $= Just Lequal
-- draw lightmap
bindVertexArrayObject $= Just (_vao $ _wallVAO pdata)
let wallPtr = (\(_,x,_) -> x) $ head $ _vaoBufferTargets $ _wallVAO pdata
wallPtr2 = (\(_,x,_) -> x) $ (_vaoBufferTargets $ _wallVAO pdata) !! 1
@@ -282,12 +276,12 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
blendFuncSeparate $= ((Zero,Zero),(Zero, OneMinusSrcAlpha))
drawArrays Points (fromIntegral 0) (fromIntegral 1)
-- draw picture
-- set drawing for on top
blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
clear [DepthBuffer]
let firstIndex = 0
-- poke necessary data
(nTriVs,nTextVs,numCircVs,nLineVs,nArcVs)
-- <- F.foldM (theFold (_ptrPosVBO pdata, _ptrColVBO pdata)
<- F.foldM (theFold (twoPtrsVAO $ _triVAO pdata)
@@ -308,27 +302,26 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
bindArrayBuffers 1 $ _vaoBufferTargets $ _backVAO pdata
textureBinding Texture2D $= Just (_textures pdata !! 1)
drawArrays Points (fromIntegral 0) (fromIntegral 1)
-- draw triangles
currentProgram $= Just (_basicShader pdata)
bindVertexArrayObject $= Just (_vao $ _triVAO pdata)
bindArrayBuffers nTriVs $ _vaoBufferTargets $ _triVAO pdata
drawArrays Triangles (fromIntegral firstIndex) (fromIntegral $ nTriVs)
drawArrays Triangles 0 (fromIntegral $ nTriVs)
-- draw circles
currentProgram $= Just (_circShader pdata)
uniform (_uniWinSize pdata) $= Vector2 winx winy
uniform (_csZoomUni pdata) $= zoom
bindVertexArrayObject $= Just (_vao $ _circVAO pdata)
bindArrayBuffers numCircVs $ _vaoBufferTargets $ _circVAO pdata
drawArrays Points (fromIntegral firstIndex) (fromIntegral $ numCircVs)
drawArrays Points 0 (fromIntegral $ numCircVs)
-- draw arcs
currentProgram $= Just (_arcShader pdata)
uniform (_asWinUni pdata) $= Vector2 winx winy
uniform (_asZoomUni pdata) $= zoom
bindVertexArrayObject $= Just (_vao $ _arcVAO pdata)
bindArrayBuffers nArcVs $ _vaoBufferTargets $ _arcVAO pdata
drawArrays Points (fromIntegral firstIndex) (fromIntegral $ nArcVs)
drawArrays Points 0 (fromIntegral $ nArcVs)
-- reset blend so that light map doesn't apply
blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
@@ -337,22 +330,26 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
currentProgram $= Just (_basicShader pdata)
bindVertexArrayObject $= Just (_vao $ _lineVAO pdata)
bindArrayBuffers nTriVs $ _vaoBufferTargets $ _lineVAO pdata
drawArrays Lines (fromIntegral firstIndex) (fromIntegral $ nLineVs)
drawArrays Lines 0 (fromIntegral $ nLineVs)
-- draw text
currentProgram $= Just (_textShader pdata)
bindVertexArrayObject $= Just (_vao $ _textVAO pdata)
bindArrayBuffers nTextVs $ _vaoBufferTargets $ _textVAO pdata
textureBinding Texture2D $= Just (_textures pdata !! 0)
drawArrays Points (fromIntegral firstIndex) (fromIntegral $ nTextVs)
drawArrays Points 0 (fromIntegral $ nTextVs)
bufferOffset :: Integral a => a -> Ptr b
bufferOffset = plusPtr nullPtr . fromIntegral
renderPicture :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) -> Picture -> IO ()
renderPicture pdata rot zoom (tranx,trany) (winx,winy) pic = do
let firstIndex = 0
-- the following code draws a picture
-- it does not set nor change the blend function or depth buffer
renderPicture :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float)
-> Picture -> IO ()
renderPicture pdata rot zoom (tranx,trany) (winx,winy) pic = do
-- poke necessary data
(nTriVs,nTextVs,numCircVs,nLineVs,nArcVs)
-- <- F.foldM (theFold (_ptrPosVBO pdata, _ptrColVBO pdata)
<- F.foldM (theFold (twoPtrsVAO $ _triVAO pdata)
@@ -363,7 +360,7 @@ renderPicture pdata rot zoom (tranx,trany) (winx,winy) pic = do
) $ picToFTree pic
depthFunc $= Just Less
currentProgram $= Just (_backShader pdata)
bindVertexArrayObject $= Just (_vao $ _backVAO pdata)
let backPtr = (\(_,x,_) -> x) $ head $ _vaoBufferTargets $ _backVAO pdata
@@ -373,35 +370,38 @@ renderPicture pdata rot zoom (tranx,trany) (winx,winy) pic = do
bindArrayBuffers 1 $ _vaoBufferTargets $ _backVAO pdata
textureBinding Texture2D $= Just (_textures pdata !! 1)
drawArrays Points (fromIntegral 0) (fromIntegral 1)
-- draw triangles
currentProgram $= Just (_basicShader pdata)
bindVertexArrayObject $= Just (_vao $ _triVAO pdata)
bindArrayBuffers nTriVs $ _vaoBufferTargets $ _triVAO pdata
drawArrays Triangles (fromIntegral firstIndex) (fromIntegral $ nTriVs)
-- draw lines, don't need to change the program or vaos, just need to bind the
-- vbos and draw
bindVertexArrayObject $= Just (_vao $ _lineVAO pdata)
bindArrayBuffers nTriVs $ _vaoBufferTargets $ _lineVAO pdata
drawArrays Lines (fromIntegral firstIndex) (fromIntegral $ nLineVs)
drawArrays Triangles 0 (fromIntegral $ nTriVs)
-- draw circles
currentProgram $= Just (_circShader pdata)
uniform (_uniWinSize pdata) $= Vector2 winx winy
uniform (_csZoomUni pdata) $= zoom
bindVertexArrayObject $= Just (_vao $ _circVAO pdata)
bindArrayBuffers numCircVs $ _vaoBufferTargets $ _circVAO pdata
drawArrays Points (fromIntegral firstIndex) (fromIntegral $ numCircVs)
drawArrays Points 0 (fromIntegral $ numCircVs)
-- draw arcs
currentProgram $= Just (_arcShader pdata)
uniform (_asWinUni pdata) $= Vector2 winx winy
uniform (_asZoomUni pdata) $= zoom
bindVertexArrayObject $= Just (_vao $ _arcVAO pdata)
bindArrayBuffers nArcVs $ _vaoBufferTargets $ _arcVAO pdata
drawArrays Points (fromIntegral firstIndex) (fromIntegral $ nArcVs)
drawArrays Points 0 (fromIntegral $ nArcVs)
-- reset blend so that light map doesn't apply
blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
-- draw lines
currentProgram $= Just (_basicShader pdata)
bindVertexArrayObject $= Just (_vao $ _lineVAO pdata)
bindArrayBuffers nTriVs $ _vaoBufferTargets $ _lineVAO pdata
drawArrays Lines 0 (fromIntegral $ nLineVs)
-- draw text
currentProgram $= Just (_textShader pdata)
bindVertexArrayObject $= Just (_vao $ _textVAO pdata)
bindArrayBuffers nTextVs $ _vaoBufferTargets $ _textVAO pdata
textureBinding Texture2D $= Just (_textures pdata !! 0)
drawArrays Points (fromIntegral firstIndex) (fromIntegral $ nTextVs)
drawArrays Points 0 (fromIntegral $ nTextVs)