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

Merge branch 'master' into testing

Browse Source
This commit is contained in:
Ross
2021-04-01 23:00:14 +01:00
parent 5e885b879b cbcc0f700b
commit fdebeb9aba
20 changed files with 290 additions and 104 deletions
Download Patch File Download Diff File Expand all files Collapse all files
app/Main.hs
+3 -13
View File
@@ -10,7 +10,7 @@ import Dodge.Layout
import Dodge.LoadSound
import Dodge.Update
import Dodge.Event
import Dodge.Rendering
import Dodge.Render
import Dodge.Menu
import Dodge.Floor
import Dodge.LoadConfig
@@ -24,6 +24,7 @@ import Sound.Preload
import Control.Concurrent
import Control.Lens
import Foreign (Word32)
import Control.Monad (when)
@@ -52,18 +53,7 @@ main = do
(fmap (setWindowSize sizex sizey keyConfig) firstWorld)
( \preData w -> do
startTicks <- SDL.ticks
clear [ColorBuffer,DepthBuffer]
(lightTicks,timeSpentPoking) <- renderPicture' (_renderData preData)
(_cameraRot w) (_cameraZoom w)
(_cameraCenter w)
(_windowX w,_windowY w)
(wallsPointsAndCols w)
(wallsWindows w)
(lightsForGloom' w)
(_cameraViewFrom w)
(worldPictures w)
blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
renderFoldable (_renderData preData) (picToLTree Nothing $ fixedCoordPictures w)
doDrawing (_renderData preData) w
playSoundQueue (_soundData preData) (_soundQueue w)
newSoundData <- playAndUpdate (_sounds w) (_soundData preData)
bench/Bench.hs
+4
View File
@@ -0,0 +1,4 @@
import Criterion.Main
main :: IO ()
main = putStrLn "h"
package.yaml
+20
View File
@@ -79,3 +79,23 @@ tests:
- -with-rtsopts=-N
dependencies:
- loop
benchmarks:
loop-benchmarks:
dependencies:
- criterion
ghc-options:
- -threaded
- -O2
- -rtsopts
- -with-rtsopts=-N
- -flate-dmd-anal
- -fno-liberate-case
- -fno-state-hack
- -funfolding-use-threshold1000
- -funfolding-keeness-factor1000
- -fllvm
- -optlo-O3
main: Bench.hs
source-dirs: bench
src/Dodge/Base.hs
+6 -5
View File
@@ -280,6 +280,12 @@ zoneOfLine :: Point2 -> Point2 -> [(Int,Int)]
zoneOfLine (aa,ab) (ba,bb) = nub $ concatMap f
$ digitalLine (zoneOfPoint (aa,ab)) (zoneOfPoint (ba,bb))
where f (x,y) = [(p,r) | p <-[x-1,x,x+1] , r<-[y-1,y,y+1]]
zoneOfLine' :: Point2 -> Point2 -> IM.IntMap IS.IntSet
{-# INLINE zoneOfLine' #-}
zoneOfLine' a b = expandLine $ digitalLine (x-1,y-1) (x'-1,y'-1)
where (x,y) = zoneOfPoint a
(x',y') = zoneOfPoint b
--zoneOfLine (aa,ab) (ba,bb) = nub $ concatMap f
-- $ digitalLine (zoneOfPoint (aa-n,ab-n)) (zoneOfPoint (ba-n,bb-n))
-- where f (x,y) = [(p,r) | p <-[x,x+1] , r<-[y,y+1]]
@@ -294,11 +300,6 @@ expandLine xs = IM.map expandSet
--expandSet s = s
where mk = IS.findMax s
zoneOfLine' :: Point2 -> Point2 -> IM.IntMap IS.IntSet
{-# INLINE zoneOfLine' #-}
zoneOfLine' a b = expandLine $ digitalLine (x-1,y-1) (x'-1,y'-1)
where (x,y) = zoneOfPoint a
(x',y') = zoneOfPoint b
--zoneOfLine a b = concatMap zoneNearPoint $ divideLine (2 * zoneSize) a b
--zoneOfLine a b = concatMap zoneNearPoint $ divideLine zoneSize a b
src/Dodge/Creature.hs
+1
View File
@@ -254,6 +254,7 @@ startCr = defaultCreature
(
[pistol
,blinkGun
,spawnGun lamp
,flameGrenade
,teslaGrenade
,autoGun
src/Dodge/Creature/Inanimate.hs
+2 -1
View File
@@ -5,6 +5,7 @@ import Dodge.Base
import Dodge.Default
import Dodge.CreatureState
import Dodge.LightSources
import Dodge.WorldEvent.Flash
import Dodge.WorldEvent.Sound
@@ -34,7 +35,7 @@ updateLamp :: Int -> CRUpdate
updateLamp i = unrandUpdate handleLS internalUpdate
where
handleLS cr w
| _crHP cr < 0 = mkSoundBreakGlass w & lightSources %~ IM.delete i
| _crHP cr < 0 = explosionFlashAt (_crPos cr) $ mkSoundBreakGlass w & lightSources %~ IM.delete i
| otherwise = w & lightSources . ix i . lsPos .~ _crPos cr
internalUpdate cr
| _crHP cr < 0 = Nothing
src/Dodge/Item/Weapon.hs
+22 -1
View File
@@ -82,6 +82,7 @@ pistol = Weapon
, _itInvColor = white
}
defaultGun = pistol
defaultAutoGun = autoGun {_itScrollUp = const id
, _itScrollDown = const id, _itInvDisplay = basicWeaponDisplay}
effectGun :: String -> (Int -> World -> World) -> Item
@@ -900,13 +901,14 @@ aFlame a cid w
w
where
(a2,g) = randomR (-0.1,0.1) (_randGen w)
(t,_) = randomR (99,101) (_randGen w)
angle = min flamerAngle $ max (-flamerAngle) (a + a2)
cr = (_creatures w IM.! cid)
dir = _crDir cr + angle
pos = _crPos cr +.+ ((_crRad cr + 2.9) *.* unitVectorAtAngle (_crDir cr))
w1 = set randGen g w
vel = (_crPos cr -.- _crOldPos cr) +.+ 4 *.* unitVectorAtAngle dir
insertFlame = makeFlame pos vel (Just cid) -- . makeFlame pos2 vel (Just cid)
insertFlame = makeFlame t pos vel (Just cid) -- . makeFlame pos2 vel (Just cid)
resetAngle = set (creatures . ix cid . crInv . ix (_crInvSel cr) . wpFire)
(shoot $ aFlame angle)
@@ -1942,4 +1944,23 @@ makeLaserScope p ep d relFrac = Particle'
spawnGun :: Creature -> Item
spawnGun cr = defaultGun
{ _itName = "SPAWNER"
, _wpMaxAmmo = 1
, _wpLoadedAmmo = 1
, _wpReloadTime = 80
, _wpReloadState = 0
, _wpFireRate = 100
, _wpFire = spawnCrNextTo cr
}
spawnCrNextTo :: Creature -> Int -> World -> World
spawnCrNextTo cr i w = w & creatures %~ IM.insert k newCr
where
k = newKey $ _creatures w
sCr = _creatures w IM.! i
newCr = cr
& crID .~ k
& crPos .~ _crPos sCr +.+ unitVectorAtAngle (_crDir sCr)
& crOldPos .~ _crPos sCr +.+ unitVectorAtAngle (_crDir sCr)
src/Dodge/Render.hs
+122
View File
@@ -0,0 +1,122 @@
module Dodge.Render
( module Dodge.Render.Picture
, doDrawing
, doDrawing'
)
where
import Dodge.Data
import Dodge.Base
import Dodge.Render.HUD
import Dodge.Render.MenuScreen
import Dodge.Render.Picture
import Dodge.Render.PerspectiveMatrix
import Geometry
import Picture
import Shader
import Picture.Render
import Picture.Preload
import Data.Graph.Inductive.Query.DFS
import Data.Graph.Inductive.Graph
import Control.Monad.State
import Data.List
import Data.Bifunctor
import Foreign (Word32)
import Data.Function
import Control.Applicative
import Control.Lens
import Data.Maybe
import qualified Data.IntMap.Strict as IM
import qualified Data.Map as M
import qualified Data.Set as S
import Graphics.Rendering.OpenGL hiding (color,scale,translate,rotate)
import qualified SDL
doDrawing :: RenderData -> World -> IO (Word32)
doDrawing pdata w = do
sTicks <- SDL.ticks
clear [ColorBuffer,DepthBuffer]
let rot = _cameraRot w
zoom = _cameraZoom w
trans@(tranx,trany) = _cameraCenter w
wins@(winx,winy) = (_windowX w,_windowY w)
wallPointsCol = wallsPointsAndCols w
windowPoints = wallsWindows w
lightPoints = lightsForGloom' w
viewFroms@(viewFromx,viewFromy) = _cameraViewFrom w
pic = worldPictures w
wallPoints = map fst wallPointsCol
setCommonUniforms pdata rot zoom trans wins
depthFunc $= Just Less
pmat <- (newMatrix RowMajor $ perspectiveMatrix w) :: IO (GLmatrix GLfloat)
createLightMap pdata rot zoom trans wins wallPoints lightPoints viewFroms pmat
blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
-- clear [DepthBuffer]
depthFunc $= Just Always
renderBackground pdata rot zoom trans wins
depthFunc $= Just Lequal
renderWalls pdata wallPointsCol pmat
setWallDepth pdata wallPoints (viewFromx,viewFromy) pmat
-- depthFunc $= Just Lequal
renderFoldable pdata $ picToLTree (Just 0) pic
-- reset blend so that light map doesn't apply
-- blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
blendFuncSeparate $= ((SrcAlpha,OneMinusSrcAlpha) , (Zero,One))
-- blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
renderFoldable pdata $ picToLTree (Just 1) pic
-- set drawing for on top
blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
renderFoldable pdata $ picToLTree (Just 2) pic
depthMask $= Disabled
renderWalls pdata windowPoints pmat
depthMask $= Enabled
resetShaderUniforms (map extractProgAndUnis $ _listShaders pdata)
----------------------
blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
renderFoldable pdata (picToLTree Nothing $ fixedCoordPictures w)
eTicks <- SDL.ticks
return (eTicks - sTicks)
doDrawing' :: RenderData -> World -> IO (Word32)
doDrawing' pdata w = do
bindFramebuffer Framebuffer $= defaultFramebufferObject
sTicks <- SDL.ticks
clear [ColorBuffer,DepthBuffer]
let rot = _cameraRot w
zoom = _cameraZoom w
trans@(tranx,trany) = _cameraCenter w
wins@(winx,winy) = (_windowX w,_windowY w)
wallPointsCol = wallsPointsAndCols w
windowPoints = wallsWindows w
lightPoints = lightsForGloom' w
viewFroms@(viewFromx,viewFromy) = _cameraViewFrom w
pic = worldPictures w
wallPoints = map fst wallPointsCol
pmat <- (newMatrix RowMajor
$ perspectiveMatrix w) :: IO (GLmatrix GLfloat)
setCommonUniforms pdata rot zoom trans wins
depthMask $= Disabled
renderBackground pdata rot zoom trans wins
depthMask $= Enabled
blend $= Enabled
blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
-- not sure why renderWalls and setWallDepth aren't combined
renderWalls pdata wallPointsCol pmat
setWallDepth pdata wallPoints (viewFromx,viewFromy) pmat
depthFunc $= Just Lequal
renderFoldable pdata $ picToLTree (Just 0) pic
renderFoldable pdata $ picToLTree (Just 1) pic
renderFoldable pdata $ picToLTree (Just 2) pic
eTicks <- SDL.ticks
return (eTicks - sTicks)
src/Dodge/Rendering/HUD.hs → src/Dodge/Render/HUD.hs
+1 -1
View File
@@ -1,4 +1,4 @@
module Dodge.Rendering.HUD
module Dodge.Render.HUD
where
import Dodge.Data
src/Dodge/Rendering/MenuScreen.hs → src/Dodge/Render/MenuScreen.hs
+1 -1
View File
@@ -1,4 +1,4 @@
module Dodge.Rendering.MenuScreen
module Dodge.Render.MenuScreen
( menuScreen
)
where
src/Dodge/Render/PerspectiveMatrix.hs
+50
View File
@@ -0,0 +1,50 @@
module Dodge.Render.PerspectiveMatrix
where
import Dodge.Data
import Geometry
import Linear.Matrix
import Linear.V4
import Graphics.Rendering.OpenGL (GLfloat)
perspectiveMatrix :: World -> [GLfloat]
perspectiveMatrix w =
let rot = _cameraRot w
zoom = _cameraZoom w
(tranx,trany) = _cameraCenter w
(winx,winy) = (_windowX w,_windowY w)
(viewFromx,viewFromy) = _cameraViewFrom w
scalMat = Linear.Matrix.transpose $ V4
(V4 (2*zoom/winx) 0 0 (0::GLfloat))
(V4 0 (2*zoom/winy) 0 0)
(V4 0 0 0.5 0) --scaled to make walls shorter
(V4 0 0 0 1)
rotMat = Linear.Matrix.transpose $
V4 (V4 (cos rot) (sin (-rot)) 0 0)
(V4 (sin rot) (cos rot) 0 0)
(V4 0 0 1 0)
(V4 0 0 0 1)
tranMat3 = Linear.Matrix.transpose $
V4 (V4 1 0 0 0)
(V4 0 1 0 0)
(V4 0 0 1 0)
(V4 (-tranx) (-trany) 0 1)
tranMat2 = Linear.Matrix.transpose $
V4 (V4 1 0 0 0)
(V4 0 1 0 0)
(V4 0 0 1 0)
(V4 (viewFromx-tranx) (viewFromy-trany) 0 1)
perMat = Linear.Matrix.transpose $
V4 (V4 1 0 0 0)
(V4 0 1 0 0)
(V4 0 0 1 1)
(V4 0 0 0 1)
tranMat1 = Linear.Matrix.transpose $
V4 (V4 1 0 0 0)
(V4 0 1 0 0)
(V4 0 0 1 0)
(V4 (-viewFromx) (-viewFromy) 0 1)
wmat = scalMat !*! rotMat !*! tranMat2 !*! perMat !*! tranMat1
vToL (V4 a b c d) = [a,b,c,d]
in concatMap vToL $ vToL wmat
src/Dodge/Rendering.hs → src/Dodge/Render/Picture.hs
+4 -16
View File
@@ -1,29 +1,17 @@
module Dodge.Rendering where
-- imports {{{
module Dodge.Render.Picture
where
import Dodge.Data
import Dodge.Base
--import Dodge.Inventory
import Dodge.Rendering.HUD
import Dodge.Rendering.MenuScreen
import Dodge.Render.HUD
import Dodge.Render.MenuScreen
import Geometry
import Picture
import Data.Graph.Inductive.Query.DFS
import Data.Graph.Inductive.Graph
import Control.Monad.State
import Data.List
import Data.Bifunctor
import Data.Function
import Control.Applicative
import Control.Lens
import Data.Maybe
import qualified Data.IntMap.Strict as IM
import qualified Data.Map as M
import qualified Data.Set as S
worldPictures :: World -> Picture
worldPictures w = pictures $ concat
src/Dodge/Update.hs
+5 -2
View File
@@ -71,8 +71,11 @@ updateLightSources w = set tempLightSources (catMaybes tlss) w'
updateProjectiles w = IM.foldr' _pjUpdate w $ _projectiles w
updateParticles' :: World -> World
updateParticles' w = set particles' (catMaybes ps) w'
where (w',ps) = mapAccumR (\a b -> _ptUpdate' b a b) w $ _particles' w
updateParticles' w =
--set particles' [] w
set particles' (catMaybes ps) w'
where
(w',ps) = mapAccumR (\a b -> _ptUpdate' b a b) w $ _particles' w
updateCreatures :: World -> World
updateCreatures w = f $ set randGen newG $ set creatures (IM.mapMaybe id crs) w
src/Dodge/WallCreatureCollisions.hs
+3 -4
View File
@@ -40,18 +40,17 @@ wallBuffer = 3
-- the following tests whether or not a point is on a wall, and if so pushes it
-- out from the wall
-- If the resultant push out is itself on another wall, the original point is
-- returned
-- this is then repeated if the point ends up on a new wall
collideWalls :: Float -> Point2 -> [[Point2]] -> Point2 -> Point2
collideWalls rad cp1 walls cp2
= case (listToMaybe.mapMaybe (pushOutFromWall rad cp2)) walls of
Nothing -> cp2
Just cp3 -> case (listToMaybe.reverse.mapMaybe (pushOutFromWall rad cp3)) walls of
Nothing -> cp3
Just cp4 -> cp1
Just cp4 -> cp4
-- pushes a point out from a list of walls
-- if multiple new points occur, chooses the one closest to the orignal pointjk
-- if multiple new points occur, chooses the one closest to the orignal point
pushOutFromWalls :: Float -> [[Point2]] -> Point2 -> Point2
pushOutFromWalls rad walls p =
fromMaybe p
src/Dodge/WorldEvent/Flash.hs
+1 -1
View File
@@ -59,7 +59,7 @@ glareBetween t len wdth col a b w
lowLightPic :: Float -> Float -> Color -> (Point2, Point2) -> World -> Picture
lowLightPic len wdth col (a,b) w
= case thingsHitLongLine a b w of
= case thingsHit a b w of
((p, E3x2 wall):_)
-> setCol . lineOfThickness wdth $ [alongLineBy len p wa, alongLineBy len p wb]
where x = len *.* (normalizeV $ wa -.- wb)
src/Dodge/WorldEvent/SpawnParticle.hs
+3 -2
View File
@@ -37,8 +37,8 @@ aFlameParticle t pos vel maycid = Pt'
, _btHitEffect' = destroyOnImpact (doFlameDam 1) noEff noEff
}
makeFlame :: Point2 -> Point2 -> Maybe Int -> World -> World
makeFlame pos vel maycid = over particles' (aFlameParticle 100 pos vel maycid : )
makeFlame :: Int -> Point2 -> Point2 -> Maybe Int -> World -> World
makeFlame t pos vel maycid = over particles' (aFlameParticle t pos vel maycid : )
drawFlame :: Point2 -> Particle' -> Picture
drawFlame rotd pt = thePic
@@ -167,6 +167,7 @@ moveFlamelet w pt
& btPassThrough' .~ Nothing
& btVel' .~ 0.8 *.* vel
damcrs = foldr ($) w $ map dodam $ filter closeCrs $ IM.elems $ _creatures w
-- damcrs = w
closeCrs cr = dist ep (_crPos cr) < _crRad cr + size
dodam cr = over (creatures . ix (_crID cr) . crState . crDamage)
((:) $ Flaming 3 sp ep ep)
src/Dodge/WorldEvent/ThingsHit.hs
+1
View File
@@ -17,6 +17,7 @@ thingsHit sp ep w
where
hitCrs = IM.elems $ IM.filter (\cr -> circOnLine sp ep (_crPos cr) (_crRad cr))
$ _creatures w
-- $ creaturesAlongLine sp ep w
crPs = map (\cr -> ssaTriPoint ep (_crPos cr) sp (_crRad cr)) hitCrs
crs = zip crPs (map E3x1 hitCrs)
src/Geometry.hs
+1
View File
@@ -152,6 +152,7 @@ circOnLine' !p1 !p2 !c !rad = isJustTrue (fmap (\p -> magV (p -.- c) < rad) y)
-- this should probably be circOnSeg
circOnLine :: Point2 -> Point2 -> Point2 -> Float -> Bool
{-# INLINE circOnLine #-}
circOnLine !p1 !p2 !c !rad = magV (p1 -.- c) <= rad || magV (p2 -.- c) <= rad
|| isJustTrue (fmap (\p -> magV (p -.- c) < rad) y)
where
src/MatrixHelper.hs
+1 -1
View File
@@ -11,7 +11,7 @@ perspectiveMatrix rot zoom (tranx,trany) (winx,winy) (viewFromx,viewFromy) =
let scalMat = Linear.Matrix.transpose $ V4
(V4 (2*zoom/winx) 0 0 (0::GLfloat))
(V4 0 (2*zoom/winy) 0 0)
(V4 0 0 0.5 0) --scale to make walls shorter
(V4 0 0 0.5 0) --scaled to make walls shorter
(V4 0 0 0 1)
rotMat = Linear.Matrix.transpose $
V4 (V4 (cos rot) (sin (-rot)) 0 0)
src/Picture/Render.hs
+39 -56
View File
@@ -1,9 +1,9 @@
--{-# LANGUAGE Strict #-}
{-# LANGUAGE DeriveFoldable, StandaloneDeriving #-}
module Picture.Render
( renderPicture'
, renderFoldable
( module Picture.Render
, picToLTree
-- , perspectiveMatrix
)
where
@@ -33,25 +33,22 @@ import qualified SDL as SDL
renderPicture' :: RenderData -> Float -> Float -> Point2 -> Point2 ->
[((Point2,Point2),Point4)] -> [((Point2,Point2),Point4)] -> [Point4] ->
(Float,Float) -> Picture -> IO (Word32,Word32)
(Float,Float) -> Picture -> IO (Word32)
renderPicture' pdata rot zoom trans@(tranx,trany) wins@(winx,winy) wallPointsCol windowPoints lightPoints
viewFroms@(viewFromx,viewFromy) pic = do
let wallPoints = map fst wallPointsCol
startTicks <- SDL.ticks
let wallPoints = map fst wallPointsCol
setCommonUniforms pdata rot zoom trans wins
depthFunc $= Just Less
-- calculate perspective matrix
pmat <- (newMatrix RowMajor
$ perspectiveMatrix rot zoom (tranx,trany) (winx,winy) (viewFromx,viewFromy)
) :: IO (GLmatrix GLfloat)
createLightMap pdata rot zoom trans wins wallPoints lightPoints viewFroms pmat
ticksAfterLighting <- SDL.ticks
renderBackground pdata rot zoom trans wins
renderWalls pdata wallPointsCol pmat
@@ -65,6 +62,7 @@ renderPicture' pdata rot zoom trans@(tranx,trany) wins@(winx,winy) wallPointsCol
-- reset blend so that light map doesn't apply
-- blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
blendFuncSeparate $= ((SrcAlpha,OneMinusSrcAlpha) , (Zero,One))
-- blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
renderFoldable pdata $ picToLTree (Just 1) pic
-- set drawing for on top
@@ -78,7 +76,7 @@ renderPicture' pdata rot zoom trans@(tranx,trany) wins@(winx,winy) wallPointsCol
resetShaderUniforms (map extractProgAndUnis $ _listShaders pdata)
endTicks <- SDL.ticks
return (ticksAfterLighting, endTicks - startTicks)
return (endTicks - startTicks)
renderWalls :: RenderData -> [((Point2,Point2),Point4)] -> GLmatrix GLfloat -> IO ()
renderWalls pdata wps pmat = do
@@ -116,22 +114,23 @@ createLightMap pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints
(viewFromx,viewFromy) pmat = do
bindFramebuffer Framebuffer $= (_spareFBO pdata)
clearColor $= Color4 0 0.5 0 1
depthFunc $= Just Less
-- clear buffer to full alpha and furthest depth
clearColor $= Color4 0 0 0 1
clearDepth $= 1
clear [ColorBuffer,DepthBuffer]
depthFunc $= Just Less
-- store wall and light positions into buffer
nWallLights <- F.foldM (pokeShader $ _wallLightShader pdata) wallPoints
bindShaderBuffers [_wallLightShader pdata] [nWallLights]
nWalls <- F.foldM (pokeShader $ _wallShadowShader pdata) wallPoints
bindShaderBuffers [_wallShadowShader pdata] [nWalls]
-- set uniforms for shader that draws lights
currentProgram $= Just (_shaderProgram $ _wallLightShader pdata)
uniform ( (fromJust $ _shaderCustomUnis $ _wallLightShader pdata) !! 1)
$= pmat
nWalls <- F.foldM (pokeShader $ _wallShadowShader pdata) wallPoints
bindShaderBuffers [_wallShadowShader pdata] [nWalls]
-- draw walls from your point of view in order to set z buffer
colorMask $= (Color4 Disabled Disabled Disabled Disabled)
let (tx,ty) = (tranx,trany) -.- (viewFromx,viewFromy)
currentProgram $= Just (_shaderProgram $ _wallShadowShader pdata)
uniform (head $ fromJust $ _shaderCustomUnis $ _wallShadowShader pdata)
$= Vector2 viewFromx viewFromy
@@ -141,81 +140,65 @@ createLightMap pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints
$= (0 :: Float)
cullFace $= Just Back
drawShader (_wallShadowShader pdata) nWalls
-- for each of the lights:
-- stencil out the walls from this light's point of view
-- draw fading lightmap circles on the floor
-- draw fading lightmaps on the walls
depthMask $= Disabled
blendFunc $= (Zero, OneMinusSrcAlpha)
-- blendFuncSeparate $= ((Zero,Zero),(Zero, OneMinusSrcAlpha))
stencilTest $= Enabled
forM_ lightPoints $ \(x,y,r,lum) -> do
-- depthFunc $= Just Less
colorMask $= (Color4 Disabled Disabled Disabled Disabled)
clear [StencilBuffer]
cullFace $= Just Back
-- stencilOp $= (OpKeep,OpKeep,OpReplace)
stencilOp $= (OpKeep,OpKeep,OpIncr)
stencilFunc $= (Always, 0, 255)
-- currentProgram does get called twice: here and inside drawShader below
currentProgram $= Just (_shaderProgram $ _wallShadowShader pdata)
uniform (head $ fromJust $ _shaderCustomUnis $ _wallShadowShader pdata)
$= Vector2 x y
-- blendFunc $= (Zero,One)
drawShader (_wallShadowShader pdata) nWalls
cullFace $= Just Front
stencilOp $= (OpKeep,OpKeep,OpDecr)
drawShader (_wallShadowShader pdata) nWalls
cullFace $= Nothing
colorMask $= (Color4 Enabled Enabled Enabled Enabled)
-- bind buffer for floor light circle
let lightPtr = (\(_,ptr,_) -> ptr) $ head
$ _vaoBufferTargets $ _shaderVAO $ _lightSourceShader pdata
(x',y') = zTran $ rotateV (0 - rot) $ (x,y) -.- (tranx,trany)
zTran (a,b) = (a*2*zoom / winx, b*2*zoom / winy)
pokeFourOff lightPtr 0 (x',y',r,lum)
-- stencil out walls
colorMask $= (Color4 Disabled Disabled Disabled Disabled)
clear [StencilBuffer]
cullFace $= Just Back
stencilOp $= (OpKeep,OpKeep,OpIncr)
stencilFunc $= (Always, 0, 255)
currentProgram $= Just (_shaderProgram $ _wallShadowShader pdata)
uniform (head $ fromJust $ _shaderCustomUnis $ _wallShadowShader pdata)
$= Vector2 x y
drawShader (_wallShadowShader pdata) nWalls
cullFace $= Just Front
stencilOp $= (OpKeep,OpKeep,OpDecr)
drawShader (_wallShadowShader pdata) nWalls
-- draw floor light circles
cullFace $= Nothing
colorMask $= (Color4 Disabled Disabled Disabled Enabled)
bindShaderBuffers [_lightSourceShader pdata] [1]
stencilFunc $= (Equal, 0, 255)
drawShader (_lightSourceShader pdata) 1
-- draw wall light "circles"
currentProgram $= Just (_shaderProgram $ _wallLightShader pdata)
uniform (head $ fromJust $ _shaderCustomUnis $ _wallLightShader pdata)
$= Vector2 x y
uniform ( (fromJust $ _shaderCustomUnis $ _wallLightShader pdata) !! 2)
$= Vector2 r lum
drawShader (_wallLightShader pdata) nWallLights
depthMask $= Enabled
cullFace $= Nothing
stencilTest $= Disabled
blend $= Disabled
-- blendFunc $= (Zero,One)
bindFramebuffer Framebuffer $= defaultFramebufferObject
colorMask $= (Color4 Disabled Disabled Disabled Enabled)
--
-- blendFunc $= (SrcAlpha, OneMinusSrcAlpha)
bindShaderBuffers [_fullscreenShader pdata] [4]
textureBinding Texture2D $= Just (_fboTexture pdata)
-- blendFunc $= (One, Zero)
drawShader (_fullscreenShader pdata) 4
colorMask $= (Color4 Enabled Enabled Enabled Enabled)
blend $= Enabled
renderBackground :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) -> IO ()
renderBackground pdata rot zoom (tranx,trany) (winx,winy) = do
depthFunc $= Just Less
-- depthFunc $= Just Less
-- set drawing for on top
blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
clear [DepthBuffer]
--blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
-- draw background
bindArrayBuffers 1 $ _vaoBufferTargets $ _shaderVAO $ _backgroundShader pdata
currentProgram $= Just (_shaderProgram $ _backgroundShader pdata)
bindVertexArrayObject $= Just (_vao $ _shaderVAO $ _backgroundShader pdata)
let backPtr = (\(_,x,_) -> x) $ head $ _vaoBufferTargets $ _shaderVAO $ _backgroundShader pdata