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

Merge branch 'master' of ssh://git.xkjq.uk:30001/justin/dodge

Browse Source
This commit is contained in:
Ross
2021-03-21 17:53:01 +00:00
parent 3cfbf3dacc 279f928375
commit b91f056d63
52 changed files with 350 additions and 394 deletions
Download Patch File Download Diff File Expand all files Collapse all files
moduleFlow.dia
BIN
View File
Binary file not shown.
shader/wall.frag → shader/Old/wall.frag
View File
shader/wall.geom → shader/Old/wall.geom
View File
shader/wall.vert → shader/Old/wall.vert
View File
shader/wallLight.frag → shader/Old/wallLight.frag
View File
shader/wallLight.geom → shader/Old/wallLight.geom
View File
shader/wallLight.vert → shader/Old/wallLight.vert
View File
shader/lighting/lightmapCircle.frag
+13
View File
@@ -0,0 +1,13 @@
#version 430 core
in vec2 cenPosT;
in float lum;
in vec2 dField;
out vec4 fColor;
void main()
{
float c = pow (1 - min(1, dot(dField,dField)) , 2) * lum ;
fColor = vec4(c,c,c,c);
}
shader/lightmapCircle.geom → shader/lighting/lightmapCircle.geom
+12 -7
View File
@@ -2,27 +2,32 @@
layout (points) in;
layout (triangle_strip, max_vertices = 4) out;
in vec2 vParams [];
out vec2 gParams;
out float lum;
out vec2 cenPosT;
out vec2 dField;
uniform vec2 winSize;
uniform float zoom;
void main()
{
lum = vParams[0].y;
vec3 cenPos = gl_in[0].gl_Position.xyz;
gParams = vec2( vParams[0].x * zoom * 2, vParams[0].y);
float gRad = gParams.x;
float gRad = vParams[0].x * zoom * 2;
cenPosT = vec2 ( (cenPos.x + 1) * 0.5 * winSize.x , (cenPos.y + 1) * 0.5 * winSize.y);
gl_Position = vec4 (cenPos.x + gRad/winSize.x, cenPos.y + gRad/winSize.y, -0.9 , 1);
dField = vec2 ( 1, 1);
gl_Position = vec4 (cenPos.x + gRad/winSize.x, cenPos.y + gRad/winSize.y, -0 , 1);
EmitVertex();
gl_Position = vec4 (cenPos.x - gRad/winSize.x, cenPos.y + gRad/winSize.y, -0.9 , 1);
dField = vec2 (-1, 1);
gl_Position = vec4 (cenPos.x - gRad/winSize.x, cenPos.y + gRad/winSize.y, -0 , 1);
EmitVertex();
gl_Position = vec4 (cenPos.x + gRad/winSize.x, cenPos.y - gRad/winSize.y, -0.9 , 1);
dField = vec2 ( 1,-1);
gl_Position = vec4 (cenPos.x + gRad/winSize.x, cenPos.y - gRad/winSize.y, -0 , 1);
EmitVertex();
gl_Position = vec4 (cenPos.x - gRad/winSize.x, cenPos.y - gRad/winSize.y, -0.9 , 1);
dField = vec2 (-1,-1);
gl_Position = vec4 (cenPos.x - gRad/winSize.x, cenPos.y - gRad/winSize.y, -0 , 1);
EmitVertex();
EndPrimitive();
shader/lightmapCircle.vert → shader/lighting/lightmapCircle.vert
View File
shader/lighting/lightmapWall.frag
+13
View File
@@ -0,0 +1,13 @@
#version 430 core
in vec2 cenPosT;
in float lum;
in vec3 dField;
out vec4 fColor;
void main()
{
float c = pow (1 - min(1, dot(dField,dField)) , 2) * lum ;
fColor = vec4(c,c,c,c);
}
shader/lighting/lightmapWall.geom
+86
View File
@@ -0,0 +1,86 @@
#version 430 core
layout (points) in;
layout (triangle_strip, max_vertices = 4) out;
out vec3 dField;
out float lum;
uniform vec2 lightPos;
uniform mat4 perpMat;
uniform vec2 radLum;
float isLHS (vec2 startV, vec2 testV)
{
return sign( -startV.x * testV.y + startV.y * testV.x);
}
vec4 shiftCloser (vec4 v)
{ return vec4 (v.xy , v.z-0.0001 , v.w) ; }
void main()
{
vec4 p1 = vec4 (gl_in[0].gl_Position.xy,0,1);
vec4 p2 = vec4 (gl_in[0].gl_Position.zw,0,1);
if (isLHS (p1.xy - lightPos, p2.xy - lightPos) < 0)
{
lum = radLum.y;
float rad = radLum.x;
vec4 p3 = vec4 (p1.xy,-0.2,1);
vec4 p4 = vec4 (p2.xy,-0.2,1);
vec2 d1 = p1.xy - lightPos;
vec2 d2 = p2.xy - lightPos;
vec4 a1 = shiftCloser( perpMat * p1 );
vec4 a2 = shiftCloser( perpMat * p2 );
vec4 a3 = shiftCloser( perpMat * p3 );
vec4 a4 = shiftCloser( perpMat * p4 );
dField = vec3( d1.x/rad, d1.y/rad, 0);
gl_Position = a1;
EmitVertex();
dField = vec3( d1.x/rad, d1.y/rad, 1);
gl_Position = a3;
EmitVertex();
dField = vec3( d2.x/rad, d2.y/rad, 0);
gl_Position = a2;
EmitVertex();
dField = vec3( d2.x/rad, d2.y/rad, 1);
gl_Position = a4;
EmitVertex();
EndPrimitive();
} else {}
}
// // void main()
// // {
// // vec4 frontL4 = worldMat * vec4(gl_in[0].gl_Position.xy, 0 ,1);
// // vec4 frontR4 = worldMat * vec4(gl_in[0].gl_Position.zw, 0 ,1);
// // vec2 frontL = frontL4.xy;
// // vec2 frontR = frontR4.xy;
// //
// // emitLine (frontR);
// // emitLine (frontL);
// // EndPrimitive();
// // }
// gl_Position = perspective * worldMat * p4; EmitVertex();
// gl_Position = perspective * worldMat * p3; EmitVertex();
// gl_Position = perspective * worldMat * p7; EmitVertex();
// gl_Position = perspective * worldMat * p8; EmitVertex();
// gl_Position = perspective * worldMat * p5; EmitVertex();
// gl_Position = perspective * worldMat * p3; EmitVertex();
// gl_Position = perspective * worldMat * p1; EmitVertex();
// gl_Position = perspective * worldMat * p4; EmitVertex();
// gl_Position = perspective * worldMat * p2; EmitVertex();
// gl_Position = perspective * worldMat * p7; EmitVertex();
// gl_Position = perspective * worldMat * p6; EmitVertex();
// gl_Position = perspective * worldMat * p5; EmitVertex();
//void emitLine (vec2 pa)
//{
// gl_Position = vec4 (pa, 0, 1);
// EmitVertex();
// gl_Position = shift (vec4 (pa,0,1)); //vec4 (pa + (200 * (pa - lightPosa)), 0 , 1);
// EmitVertex();
//}
shader/wallShadow.vert → shader/lighting/lightmapWall.vert
View File
shader/wallShadow.frag → shader/lighting/wallShadow.frag
View File
shader/wallShadow.geom → shader/lighting/wallShadow.geom
+11 -6
View File
@@ -5,23 +5,23 @@ layout (triangle_strip, max_vertices = 11) out;
uniform vec2 lightPos;
uniform mat4 perpMat;
uniform mat4 worldMat;
uniform float facesToDraw;
vec2 lightPosa = lightPos;
vec2 lightPosa = ( perpMat * vec4(lightPos,0,1) ).xy;
vec4 shift (vec4 p)
{ return vec4 (p.xy + (200 * (p.xy-lightPosa)), 0 , 1);
{ return vec4 (p.xy + (200 * (p.xy-lightPos)), 0 , 1);
}
float isLHS (vec2 startV, vec2 testV)
{
return sign( -startV.x * testV.y + startV.y * testV.x);
}
// construct a box with opening on bottom face
// construct a box with openings on bottom face and face away from wall
void main()
{
vec4 p1 = vec4 (gl_in[0].gl_Position.xy,0,1);
vec4 p2 = vec4 (gl_in[0].gl_Position.zw,0,1);
if (isLHS (p1.xy - lightPosa, p2.xy - lightPosa) < 0)
if (isLHS (p1.xy - lightPos, p2.xy - lightPos) < 0)
{
vec4 p3 = vec4 (p1.xy,-0.5,1);
vec4 p4 = vec4 (p2.xy,-0.5,1);
@@ -39,6 +39,11 @@ vec4 a6 = perpMat * p6;
vec4 a7 = perpMat * p7;
vec4 a8 = perpMat * p8;
// gl_Position = a1; EmitVertex();
// gl_Position = a5; EmitVertex();
// gl_Position = a2; EmitVertex();
// gl_Position = a6; EmitVertex();
gl_Position = a4; EmitVertex();
gl_Position = a3; EmitVertex();
gl_Position = a7; EmitVertex();
@@ -50,7 +55,7 @@ vec4 a8 = perpMat * p8;
gl_Position = a2; EmitVertex();
gl_Position = a7; EmitVertex();
gl_Position = a6; EmitVertex();
// gl_Position = a5; EmitVertex();
EndPrimitive();
} else {}
}
shader/lighting/wallShadow.vert
+7
View File
@@ -0,0 +1,7 @@
#version 430 core
layout (location = 0) in vec4 poss;
void main()
{
gl_Position = poss;
}
shader/lightmapCircle.frag
-12
View File
@@ -1,12 +0,0 @@
#version 430 core
in vec2 cenPosT;
in vec2 gParams;
out vec4 fColor;
void main()
{
vec2 pos = gl_FragCoord.xy;
float dist = min(1 , 2*distance(pos,cenPosT) / (gParams.x));
float c = gParams.y * pow(1-dist,2);
fColor = vec4(c,c,c,c);
}
shader/arc.frag → shader/twoD/arc.frag
View File
shader/arc.geom → shader/twoD/arc.geom
View File
shader/arc.vert → shader/twoD/arc.vert
View File
shader/basic.frag → shader/twoD/basic.frag
View File
shader/basic.vert → shader/twoD/basic.vert
View File
shader/bezierQuad.frag → shader/twoD/bezierQuad.frag
View File
shader/bezierQuad.geom → shader/twoD/bezierQuad.geom
View File
shader/bezierQuad.vert → shader/twoD/bezierQuad.vert
View File
shader/character.frag → shader/twoD/character.frag
View File
shader/character.geom → shader/twoD/character.geom
View File
shader/character.vert → shader/twoD/character.vert
View File
shader/ellipse.frag → shader/twoD/ellipse.frag
View File
shader/ellipse.geom → shader/twoD/ellipse.geom
View File
shader/ellipse.vert → shader/twoD/ellipse.vert
View File
src/Dodge/AIs.hs
+1 -17
View File
@@ -39,22 +39,6 @@ import Foreign.ForeignPtr
import Control.Concurrent
---}
--killCr :: World -> (World -> World) -> Creature -> ((World -> World,StdGen), Maybe Creature)
--killCr w f cr = ((g . f, _randGen w),Nothing)
-- where crBeforeDeath = colCrWall w $ cr
-- addCorpse = insertNewKey $ uncurry translate (_crPos crBeforeDeath)
-- $ rotate (radToDeg (_crDir cr))
-- (_crCorpse cr)
-- maybeIt = evalState (maybeTakeOne $ IM.elems (_crInv cr)) (_randGen w)
-- insertIt = case maybeIt of
-- Just it -> createItemAt (offset +.+ _crPos crBeforeDeath)
-- (FlIt {_flIt=it,_flItPos=(0,0),_flItRot=rot,_flItID=0})
-- Nothing -> id
-- offset = _crRad cr *.* unitVectorAtAngle rot
-- (rot,_) = randomR (-pi,pi) $ _randGen w
-- g = stopSoundFrom (CrWeaponSound (_crID cr)) . over decorations addCorpse . insertIt
factionIs :: Faction -> Creature -> Bool
factionIs f c = (_faction $ _crState $ c) == f
@@ -1888,7 +1872,7 @@ spCrRadFac = 8^2
yourControl :: World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature)
yourControl w (f,g) cr = ( (mouseActionsWorld (_mouseButtons w) . f, g)
, Just $ mouseActionsCr (_mouseButtons w) $ wasdWithAiming w speed strafeSpeed 0 cr
, Just . crAutoReload . mouseActionsCr (_mouseButtons w) $ wasdWithAiming w speed strafeSpeed 0 cr
)
where strafeSpeed = 8 * equipFactor * (fromMaybe 1 $ yourItem w ^? itAimingSpeed)
speed = 3 * equipFactor
src/Dodge/Base.hs
+1 -3
View File
@@ -386,9 +386,7 @@ collidePointWalkable p1 p2 ws = any (isJust
. ( \(x:y:_) -> intersectSegSeg' p1 p2 x y)
. _wlLine
) unwalkableWalls
where unwalkableWalls = IM.filter notDoor ws
notDoor (AutoDoor {}) = False
notDoor _ = True
where unwalkableWalls = IM.filter (fromMaybe True . (^? doorPathable)) ws
furthestPointWalkable :: Point2 -> Point2 -> IM.IntMap Wall -> Point2
furthestPointWalkable p1 p2 ws = head $ (sortBy (compare `on` dist p1) $ IM.elems
src/Dodge/CreatureAction.hs
+7 -1
View File
@@ -207,7 +207,13 @@ reloadWeapon cid w =
$ set ( itRef . wpReloadState) rT w
_ -> Nothing
crAutoReload :: Creature -> Creature
crAutoReload cr = case cr ^? crInv . ix (_crInvSel cr) . wpLoadedAmmo of
Just 0 -> cr & crInv . ix (_crInvSel cr) . wpReloadState %~ (`fromMaybe` reloadT)
& crInv . ix (_crInvSel cr) . wpLoadedAmmo %~ (`fromMaybe` maxA)
_ -> cr
where reloadT = cr ^? crInv . ix (_crInvSel cr) . wpReloadTime
maxA = cr ^? crInv . ix (_crInvSel cr) . wpMaxAmmo
createItemAt :: Point2 -> FloorItem -> World -> World
createItemAt p it w = over floorItems (IM.insert i (set flItPos p
src/Dodge/Data.hs
+2 -19
View File
@@ -547,15 +547,6 @@ data Wall
, _blHP :: Int
, _wlIsSeeThrough :: Bool
}
| AutoDoor
{ _wlLine :: [Point2] , _wlID :: Int
, _doorMech :: World -> World
, _wlColor :: Color
, _wlDraw :: Maybe (Wall -> Drawing)
, _wlSeen :: Bool
, _wlIsSeeThrough :: Bool
, _wlCastShadow :: Bool
}
| Door
{ _wlLine :: [Point2] , _wlID :: Int
, _doorMech :: World -> World
@@ -563,6 +554,7 @@ data Wall
, _wlDraw :: Maybe (Wall -> Drawing)
, _wlSeen :: Bool
, _wlIsSeeThrough :: Bool
, _doorPathable :: Bool
}
| Block
{ _wlLine :: [Point2]
@@ -574,17 +566,8 @@ data Wall
, _blHP :: Int
, _wlIsSeeThrough :: Bool
, _blVisible :: Bool
, _blShadows :: [Int]
, _blDegrades :: [Int]
, _wlCastShadow :: Bool
}
| MultiBlock
{ _wlLine :: [Point2]
, _wlID :: Int
, _wlColor :: Color
, _wlSeen :: Bool
, _wlIsSeeThrough :: Bool
, _subWalls :: [Wall]
, _blShadows :: [Int]
}
data ForceField = FF { _ffLine :: [Point2] , _ffID :: Int
src/Dodge/Floor.hs
+1 -1
View File
@@ -32,7 +32,7 @@ lev1 = do
(
[return $ return $ Right deadEndRoom
]
++ [slowDoorRoom]
++ [roomMiniIntro]
++ [return $ connectRoom corridor
,return $ connectRoom door]
++ firstWeapon
src/Dodge/Item/Weapon.hs
+25 -19
View File
@@ -62,6 +62,7 @@ pistol = Weapon
, _wpFireState = 0
, _wpFire = shootWithSound 0
. withRandomDir 0.1
. withMuzFlare
. withVelWthHiteff (30,0) 2
$ threeEff' bulHitCr' bulHitWall' bulHitFF'
, _wpSpread = 0.02
@@ -124,17 +125,19 @@ autoGun = defaultGun
, _itInvDisplay = displayAutoGun
}
autoFireMode = shootWithSound (fromIntegral autoGunSound)
$ withRecoil 40
$ torqueBefore 0.05
$ withRandomDir (autogunSpread/2)
$ withVelWthHiteff (50,0) 3
$ threeEff' bulHitCr' bulHitWall' bulHitFF'
. withRecoil 40
. torqueBefore 0.05
. withRandomDir (autogunSpread/2)
. withMuzFlare
. withVelWthHiteff (50,0) 3
$ threeEff' bulHitCr' bulHitWall' bulHitFF'
singleFireMode = shootWithSound (fromIntegral autoGunSound)
$ withRecoil 40
$ torqueAfter 0.03
$ withRandomDir (autogunSpread/2)
$ withVelWthHiteff (50,0) 3
$ threeEff' bulHitCr' bulHitWall' bulHitFF'
. withRecoil 40
. torqueAfter 0.03
. withRandomDir (autogunSpread/2)
. withMuzFlare
. withVelWthHiteff (50,0) 3
$ threeEff' bulHitCr' bulHitWall' bulHitFF'
incMode :: Int -> World -> World
incMode _ w
@@ -422,9 +425,10 @@ hvAutoGun = defaultAutoGun
, _itEquipPict = drawWeapon $ color orange $ polygon $ rectNESW 5 5 (-5) (-5)
}
where mkHvBul = withSound (fromIntegral longGunSound)
$ withThinSmoke
$ withVelWthHiteff (80,0) 6
$ threeEff'
. withThinSmoke
. withMuzFlare
. withVelWthHiteff (80,0) 6
$ threeEff'
hvBulHitCr' hvBulHitWall' bulHitFF'
ltAutoGun = defaultAutoGun
@@ -436,7 +440,8 @@ ltAutoGun = defaultAutoGun
, _wpReloadState = 0
, _wpFireRate = 4
, _wpFireState = 0
, _wpFire = shootWithSound 0 . withRandomDir 0.3 $ withVelWthHiteff (30,0) 2 bulletEffect'
, _wpFire = shootWithSound 0 . withRandomDir 0.3
. withMuzFlare $ withVelWthHiteff (30,0) 2 bulletEffect'
, _wpSpread = 0.5
, _wpRange = 20
, _itFloorPict = onLayer FlItLayer $ color green $ pictures [polygon $ rectNSWE 4 (-4) (-4) 0
@@ -463,6 +468,7 @@ miniGun = defaultAutoGun
, _wpFire = withWarmUp 50 . torqueBefore 0.03 . withSidePush 50 . withRecoil 15
. withRandomDir 0.1
. withRandomOffset 9
. withMuzFlare
$ withVelWthHiteff (30,0) 2 bulletEffect'
, _wpSpread = autogunSpread
, _wpRange = 20
@@ -555,11 +561,11 @@ longGun = defaultGun
, _wpFireRate = 100
, _wpFireState = 0
, _wpFire = shootWithSound (fromIntegral longGunSound)
$ withThickSmoke
$ torqueAfter 0.05
$ withVelWthHiteff (60,0) 6
$ threeEff'
hvBulHitCr' hvBulHitWall' bulHitFF'
. withThickSmoke
. torqueAfter 0.05
. withMuzFlare
. withVelWthHiteff (60,0) 6
$ threeEff' hvBulHitCr' hvBulHitWall' bulHitFF'
, _wpSpread = 0.0
, _wpRange = 200
src/Dodge/Item/Weapon/TriggerType.hs
+3 -3
View File
@@ -94,7 +94,7 @@ shoot f cid w | fireCondition = over (pointerToItem . wpLoadedAmmo) (\ammo -> am
reloadCondition = _wpLoadedAmmo item == 0
withMuzFlare :: (Int -> World -> World) -> Int -> World -> World
withMuzFlare f cid w = over tempLightSources (tLightAt 4 pos :)
withMuzFlare f cid w = over tempLightSources (tLightAt 3 pos :)
. lowLightAt pos2 $ f cid w
where cr = _creatures w IM.! cid
dir = _crDir cr
@@ -112,8 +112,8 @@ withRandomDir acc f cid w = over (creatures . ix cid . crDir) (\d -> d - a)
withVelWthHiteff :: Point2 -> Float -> HitEffect' -> Int -> World -> World
withVelWthHiteff vel width hiteff cid w
= over particles' ((:) newbul)
. over tempLightSources ((:) (tLightAt 4 pos))
. lowLightAt pos2
-- . over tempLightSources ((:) (tLightAt 4 pos))
-- . lowLightAt pos2
$ set randGen g
w
where cr = _creatures w IM.! cid
src/Dodge/LevelGen.hs
-1
View File
@@ -181,7 +181,6 @@ putWindowBlock a b w = removePathsCrossing a b $ foldr makeBlockAt w $ zip ps ns
, _blVisible = seen
, _blShadows = shadows
, _blDegrades = degradeHP
, _wlCastShadow = False
}
f = IM.insert k0 l . IM.insert k1 t . IM.insert k2 r . IM.insert k3 b
in over walls f w
src/Dodge/LevelGen/AutoDoor.hs
+4 -27
View File
@@ -24,15 +24,8 @@ autoDoorAt a b wls = IM.union wls $ IM.fromList $ zip is $ mkAutoDoor a b is
is = [i..]
mkAutoDoor :: Point2 -> Point2 -> [Int] -> [Wall]
mkAutoDoor pl pr xs = addSound $ zipWith4 (autoDoorPane [pl,pr])
mkAutoDoor pl pr xs = addSound $ zipWith3 (autoDoorPane [pl,pr])
xs
[ True
, False
, True
, True
, False
, True
]
[ [pld,hwd,hw,pl]
, [hwd,hwu]
, [hwu,plu,pl,hw]
@@ -68,24 +61,8 @@ mkAutoDoor pl pr xs = addSound $ zipWith4 (autoDoorPane [pl,pr])
| otherwise = dm w
where wp = (_wlLine $ _walls w IM.! (head xs)) !! 1
drawAutoDoor :: Wall -> Drawing
drawAutoDoor wl = onLayerL [levLayer WlLayer, layer2]
$ pictures [color c $ polygon [x,x +.+ n2,y +.+ n2, y]
,color (dark c) $ line [x,y]
]
where
(x:y:_) = _wlLine wl
c = _wlColor wl
nm = errorNormalizeV 543 (y -.- x)
t = 5 *.* nm
n = vNormal t
n2 = 3 *.* n
layer2 | _wlIsSeeThrough wl = 0
| isJust $ wl ^? doorMech = 1
| otherwise = 2
autoDoorPane :: [Point2] -> Int -> Bool -> [Point2] -> [Point2] -> Wall
autoDoorPane trigL n castShad closedPos openPos = AutoDoor
autoDoorPane :: [Point2] -> Int -> [Point2] -> [Point2] -> Wall
autoDoorPane trigL n closedPos openPos = Door
{ _wlLine = closedPos
, _wlID = n
, _doorMech = dm
@@ -93,7 +70,7 @@ autoDoorPane trigL n castShad closedPos openPos = AutoDoor
, _wlDraw = Nothing
, _wlSeen = False
, _wlIsSeeThrough = False
, _wlCastShadow = castShad
, _doorPathable = True
}
where
a = closedPos !! 0
src/Dodge/LevelGen/Block.hs
-2
View File
@@ -97,7 +97,6 @@ addBlockNoShadow (p:ps) hp col isSeeThrough degradability hasAllShadows w
, _blVisible = True
, _blShadows = []
, _blDegrades = degradability
, _wlCastShadow = bool
}
) is lines shadowList
wallInZone wl | dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize
@@ -131,7 +130,6 @@ addBlock (p:ps) hp col isSeeThrough degradability w
, _blVisible = True
, _blShadows = []
, _blDegrades = degradability
, _wlCastShadow = True
}
) is lines
wallInZone wl | dist (_wlLine wl !! 0) (_wlLine wl !! 1) <= 2*zoneSize
src/Dodge/LevelGen/TriggerDoor.hs
+1 -1
View File
@@ -116,7 +116,7 @@ triggerDoorPane c cond n closedPos openPos = Door
, _wlDraw = Nothing
, _wlSeen = False
, _wlIsSeeThrough = False
-- , _doorLine = [a,b,a',b']
, _doorPathable = False
}
where
a = closedPos !! 0
src/Dodge/Prototypes.hs
+3 -2
View File
@@ -29,14 +29,14 @@ basicWall = Wall { _wlLine = [(0,0),(50,0)]
, _wlSeen = False
, _wlIsSeeThrough = False
}
basicAutoDoor = AutoDoor { _wlLine = [(0,0),(50,0)]
basicAutoDoor = Door { _wlLine = [(0,0),(50,0)]
, _wlID = 0
, _doorMech = id
, _wlColor = light $ dim $ dim $ dim $ yellow
, _wlDraw = Nothing
, _wlSeen = False
, _wlIsSeeThrough = False
, _wlCastShadow = True
, _doorPathable = True
}
basicDoor = Door { _wlLine = [(0,0),(50,0)]
, _wlID = 0
@@ -45,6 +45,7 @@ basicDoor = Door { _wlLine = [(0,0),(50,0)]
, _wlDraw = Nothing
, _wlSeen = False
, _wlIsSeeThrough = False
, _doorPathable = False
}
basicCreature :: Creature
basicCreature = Creature
src/Dodge/Rendering.hs
+39 -106
View File
@@ -27,10 +27,8 @@ import qualified Data.Set as S
-- }}}
fixedCoordPictures :: World -> Picture
fixedCoordPictures w = pictures
-- [ scaler $ onLayer LabelLayer $ pictures [ppLabels, btLabels]
[ scaler $ hudDrawings w
, scaler $ onLayer MenuLayer menuScreen
--, onLayer InvLayer $ activeObjectText w
, onLayer InvLayer $ closeObjectTexts w
]
where scaler = scale (2 / _windowX w) (2 / _windowY w)
@@ -57,7 +55,6 @@ fixedCoordPictures w = pictures
]
where tst x y sc t = translate x y $ scale sc sc $ color white $ text t
worldPictures :: World -> Picture
worldPictures w
= pictures $ concat [ decPicts
@@ -70,9 +67,8 @@ worldPictures w
, ptPicts'
, afterPtPicts'
, wlPicts'
-- , wallShadows
, wlPicts
, smokeShadows
-- , itLabels
, ppLabels
, btLabels
, testPic w
@@ -86,11 +82,10 @@ worldPictures w
ppPicts = map ppDraw (IM.elems (_pressPlates w))
crPicts = map crDraw $ IM.elems $ _creatures w
clPicts = map clDraw $ IM.elems $ _clouds w
wallShadows = map (drawWallShadow w) $ wallShadowsToDraw w
smokeShadows = map (drawSmokeShadow w) $ _smoke w
wlPicts = map drawWall (wallsToDraw w)
wlPicts' = map (drawWall' w) (wallsToDraw w)
itFloorPicts = map (drawItem) (IM.elems (_floorItems w))
wlPicts = map drawWallFloor (wallFloorsToDraw w)
wlPicts' = map (drawWallFace w) (wallShadowsToDraw w)
itFloorPicts = map drawItem (IM.elems (_floorItems w))
yourPos = _crPos $ you w
yourRot = _crDir $ you w
yourRad = _crRad $ you w
@@ -122,8 +117,8 @@ worldPictures w
where tst x y sc t = translate x y $ scale sc sc $ color white $ text t
testPic :: World -> [Picture]
testPic w = --[blank]
[setLayer 1 $ onLayerL [99] $ bezierQuad white red 5 5 (00,00) (300,305) (50,000) ]
testPic w = [blank]
-- [setLayer 1 $ onLayerL [99] $ bezierQuad white red 5 5 (00,00) (300,305) (50,000) ]
-- $ uncurry translate (mouseWorldPos w)
@@ -198,8 +193,8 @@ mapWall wl =
(x:y:_) = _wlLine wl
c = _wlColor wl
wallsToDraw :: World -> [Wall]
wallsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w
wallFloorsToDraw :: World -> [Wall]
wallFloorsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w
where onScreen wall = lineOnScreen w (_wlLine wall)
isVisible wl | wl ^? blVisible == Just False = False
| otherwise = onScreen wl
@@ -244,23 +239,14 @@ drawSmokeShadow w sm@(Smoke {_smPos = p, _smRad = r', _smColor = c, _smPs = ps,
trap' p' = line [pa' p', pb' p', pbo' p', pao' p',pa' p']
semiCirc' p' = uncurry translate p' $ rotate (0 - (a p')) $ arcSolid 0 180 r'
drawWall :: Wall -> Drawing
drawWall (Wall {_wlIsSeeThrough = False, _wlLine = ps, _wlColor = c})
= onLayerL [levLayer WlLayer, 2] $ color c $ polygon $ ps
drawWall wl = case _wlDraw wl of
-- Nothing -> onLayerL [levLayer WlLayer, layer2] $ color c $ polygon $ _wlLine wl
Nothing -> onLayerL [levLayer WlLayer, layer2] $ color c $ polygon [x,x +.+ n2,y +.+ n2, y]
Just d -> d wl
drawWallFloor :: Wall -> Picture
drawWallFloor wl = if _wlIsSeeThrough wl
then onLayerL [levLayer WlLayer] $ color c $ polygon [x,x +.+ n2,y+.+n2, y]
else blank
where
(x:y:_) = _wlLine wl
c = _wlColor wl
t = 5 *.* errorNormalizeVDR (y -.- x)
n = vNormal t
n2 = 3 *.* n
layer2 | _wlIsSeeThrough wl = 0
| isJust $ wl ^? doorMech = 1
| otherwise = 2
-- wallOrdering wl = (not $ _wlIsSeeThrough wl, not $ isJust $ wl ^? doorMech)
n2 = 15 *.* (vNormal . errorNormalizeVDR $ y -.- x)
errorNormalizeVDR :: Point2 -> Point2
errorNormalizeVDR (0,0) = error $ "problem with function: errorNormalizeVDR in DodgeRendering"
@@ -311,67 +297,39 @@ lineOnScreen w (p1:p2:_) = errorPointInPolygon 8 p1 sp || errorPointInPolygon 9
where sp = screenPolygon w
sps = zip sp (tail sp ++ [head sp])
drawWall' :: World -> Wall -> Drawing
drawWall' w wall
drawWallFace :: World -> Wall -> Picture
drawWallFace w wall
| isRHS sightFrom x y = blank
| otherwise = colorAndLayer $ polygon $ points
where
colorAndLayer | _wlIsSeeThrough wall = setLayer 2
. onLayerL [levLayer ShadowLayer]
. color (withAlpha 0.2 $ _wlColor wall)
| otherwise = setLayer 2
. onLayerL [levLayer ShadowLayer,2]
. onLayerL [levLayer ShadowLayer,3]
. color (withAlpha 0.5 $ _wlColor wall)
| otherwise = setLayer 0
. onLayerL [levLayer ShadowLayer,l]
. color (_wlColor wall)
(x:y:_) = _wlLine wall
ps = linePointsBetween x y
ds = map (\p -> safeNormalizeV (p -.- sightFrom)) ps
p's = zipWith (\d x -> (15 *.* d) +.+ x) ds ps
points = extendConeToScreenEdge w sightFrom (x,y)
sightFrom = _cameraCenter w
corns = screenPolygon w
borders = filter g $ zip corns (tail corns ++ [head corns])
g (a,b) = isLHS a b sightFrom
borderps = mapMaybe f borders ++ mapMaybe f' borders ++ shadowedCorners
coneTop = nub $ concatMap (\(a,b) -> [a,b]) $ borders
shadowedCorners = filter isShadowed coneTop
isShadowed p = isLHS sightFrom x p && isRHS sightFrom y p
f (bpa,bpb) = intersectSegLineFrom' bpa bpb x (head p's)
f' (bpa,bpb) = intersectSegLineFrom' bpa bpb y (last p's)
points = orderPolygon (borderps ++ ps)
--points = orderPolygon (borderps ++ p's)
l = case wall of
Door {} -> 1
_ -> 2
drawWallShadow :: World -> Wall -> Drawing
drawWallShadow w wall
| isRHS sightFrom x y = blank
| otherwise = colorAndLayer $ polygon $ points
where
colorAndLayer | _wlIsSeeThrough wall = setLayer 2
. onLayerL [levLayer ShadowLayer]
. color (withAlpha 0.2 $ _wlColor wall)
| otherwise = setLayer 1
. onLayerL [levLayer ShadowLayer,2]
. color black
(x:y:_) = _wlLine wall
ps = linePointsBetween x y
ds = map (\p -> safeNormalizeV (p -.- sightFrom)) ps
p's = zipWith (\d x -> (15 *.* d) +.+ x) ds ps
sightFrom = _cameraCenter w
corns = screenPolygon w
borders = filter g $ zip corns (tail corns ++ [head corns])
g (a,b) = isLHS a b sightFrom
borderps = mapMaybe f borders ++ mapMaybe f' borders ++ shadowedCorners
coneTop = nub $ concatMap (\(a,b) -> [a,b]) $ borders
shadowedCorners = filter isShadowed coneTop
isShadowed p = isLHS sightFrom x p && isRHS sightFrom y p
f (bpa,bpb) = intersectSegLineFrom' bpa bpb x (head p's)
f' (bpa,bpb) = intersectSegLineFrom' bpa bpb y (last p's)
points = orderPolygon (borderps ++ p's)
-- the following assumes that the point a is inside the screen
-- it still works otherwise, but it might intersect two points:
-- it is not obvious which will be returned
intersectLinefromScreen :: World -> Point2 -> Point2 -> Maybe Point2
intersectLinefromScreen w a b = listToMaybe
. mapMaybe (\(x,y) -> intersectSegLineext x y a b)
. makeLoopPairs
$ screenPolygon w
linePointsBetween :: Point2 -> Point2 -> [Point2]
linePointsBetween p p' | d > 99 = map (\m -> p +.+ fromIntegral m *.* p'') [0..n-1] ++ [p']
| otherwise = [p,p']
where d = dist p p'
n = ceiling $ d / 50
p'' = (1/fromIntegral n) *.* (p' -.- p)
extendConeToScreenEdge :: World -> Point2 -> (Point2,Point2) -> [Point2]
extendConeToScreenEdge w c (x,y) = orderPolygon $ wallScreenIntersect ++ [x,y] ++ borderPs ++ cornerPs
where borderPs = mapMaybe (intersectLinefromScreen w c) [x,y]
cornerPs = filter (pointIsInCone c (x,y)) $ screenPolygon w
wallScreenIntersect = mapMaybe (uncurry $ intersectSegSeg' x y)
. makeLoopPairs $ screenPolygon w
displayInv :: Int -> World -> Picture
displayInv n w = pictures $ zipWith (translate (15-halfWidth w))
@@ -397,10 +355,6 @@ drawButText w bt | magV (_crPos (you w) -.- _btPos bt) < 100
&& hasLOS (_btPos bt) (_crPos (you w)) w
&& _btState bt /= BtNoLabel
= pictures
--[ scale (2/_windowX w) (2/_windowY w)
-- . t
-- . translate (-15) (-10*sqrt zoom - 5) $ dShadCol white
-- $ scale 0.1 0.1 $ text $ _btText bt
[ tranItPos' $ line [(-8,10),(-15,10),(-15,-10),(-8,-10)]
, tranItPos' $ line [( 8,10),( 15,10),( 15,-10),( 8,-10)]
]
@@ -429,10 +383,6 @@ drawItemName :: World -> FloorItem -> Picture
drawItemName w flIt | magV (_crPos (you w) -.- _flItPos flIt) < 100
&& hasLOS (_flItPos flIt) (_crPos (you w)) w
= pictures
--[ scale (2/_windowX w) (2/_windowY w)
-- . t
-- . translate (-15) (-10*sqrt zoom - 5) $ dShadCol white
-- $ scale 0.1 0.1 $ text $ nameOfItem
[ tranItPos' $ line [(-8,10),(-15,10),(-15,-10),(-8,-10)]
, tranItPos' $ line [( 8,10),( 15,10),( 15,-10),( 8,-10)]
]
@@ -444,11 +394,6 @@ drawItemName w flIt | magV (_crPos (you w) -.- _flItPos flIt) < 100
nameOfItem = _itName $ _flIt flIt
zoom = _cameraZoom w
ringPict :: Drawing
ringPict = onLayer LabelLayer $ dShadCol white $ pictures [line [(-8,10),(-15,10),(-15,-10),(-8,-10)]
,line [( 8,10),( 15,10),( 15,-10),( 8,-10)]
]
dShadCol :: Color -> Picture -> Picture
dShadCol c p = pictures $
[ color black $ uncurry translate (1.2,-1.2) p
@@ -496,22 +441,10 @@ displayHP n w = translate (halfWidth w-80) (halfHeight w-20) $
wallsForGloom :: World -> [(Point2,Point2)]
wallsForGloom w = map (linePairs . _wlLine) $ filter (not . _wlIsSeeThrough)
$ filter wallCastsShadow
$ IM.elems $ wallsNearZones (zoneOfDoubleScreen w) w
where linePairs (x:y:_) = (x,y)
wallCastsShadow wl = case wl ^? wlCastShadow of
Just b -> b
Nothing -> True
lightsForGloom' :: World -> [(Point4)]
lightsForGloom' w = map getLS (IM.elems $ _lightSources w) ++ map getTLS (_tempLightSources w)
where getLS ls = ( fst $ ssls ls, snd $ ssls ls, _lsRad ls , _lsIntensity ls)
getTLS ls = ( fst $ sstls ls,snd $ sstls ls, _tlsRad ls, _tlsIntensity ls)
ss' v = rotateV (0 - _cameraRot w) (v -.- _cameraPos w)
ss'' (a,b) = (a*2*zoom / _windowX w,b*2*zoom / _windowY w)
ss = ss'' . ss'
ssls = _lsPos
sstls = _tlsPos
-- ssls = ss . _lsPos
-- sstls = ss . _tlsPos
zoom = _cameraZoom w
where getLS ls = ( fst $ _lsPos ls, snd $ _lsPos ls, _lsRad ls , _lsIntensity ls)
getTLS ls = ( fst $ _tlsPos ls,snd $ _tlsPos ls, _tlsRad ls, _tlsIntensity ls)
src/Dodge/Update.hs
+1 -2
View File
@@ -4,7 +4,7 @@ import Dodge.Data
import Dodge.Base
import Dodge.WallCreatureCollisions
import Dodge.LevelGen.Block
import Dodge.Camera
import Dodge.Update.Camera
import Dodge.SoundLogic
import Dodge.Inventory
@@ -91,7 +91,6 @@ updateCreatures w = f $ set randGen newG $ set creatures (IM.mapMaybe id crs) w
wallEvents :: World -> World
wallEvents w = IM.foldr (_doorMech) w ( IM.filter (\d -> case d of
Door {} -> True
AutoDoor {} -> True
BlockAutoDoor {} -> True
_ -> False) ( _walls w))
src/Dodge/Camera.hs → src/Dodge/Update/Camera.hs
+13 -17
View File
@@ -1,4 +1,4 @@
module Dodge.Camera where
module Dodge.Update.Camera where
import Dodge.Data
import Dodge.Base
@@ -35,7 +35,6 @@ moveCamera w = w & cameraPos .~ idealPos
idealOffset = rotateV (_cameraRot w) (aimRangeFactor * aimingMult *.* _mousePos w)
currentOffset = currentPos -.- camCenter
idealPos = camCenter +.+ rotateV (_cameraRot w)
-- (aimRangeFactor * aimTimeFactor *.* _mousePos w)
(aimRangeFactor * aimingMult *.* _mousePos w)
currentPos = _cameraPos w
camCenter = ypos +.+ scope
@@ -45,9 +44,6 @@ moveCamera w = w & cameraPos .~ idealPos
sightFrom | isCam = camCenter
| otherwise = ypos
updateScopeZoom :: World -> World
updateScopeZoom w
| SDL.ButtonRight `S.member` _mouseButtons w = case w ^? scppoint of
@@ -99,7 +95,7 @@ zoomOutLongGun w | currentZoom > 0.5 = over (wpPointer . itAttachment . _Just .
Just currentZoom = wp ^? itAttachment . _Just . scopeZoom
currentCursorDisplacement = fromJust $ _itAttachment wp
rotCam = rotateCameraL . rotateCameraR . zoomCamIn . zoomCamOut . zoomCam
rotCam = rotateCameraL . rotateCameraR . zoomCamIn . zoomCamOut . autoZoomCam
rotateCameraL :: World -> World
rotateCameraL w | SDL.KeycodeQ `S.member` _keys w
@@ -122,16 +118,13 @@ zoomCamOut w | SDL.KeycodeK `S.member` _keys w
= w {_cameraZoom = max (_cameraZoom w - 0.01) 0.01}
| otherwise = w
-- the 395 here limits the max zoom out, is 25 less than the current screen
-- size, thus matches up with it
zoomCam :: World -> World
--zoomCam w = w
zoomCam w = over cameraZoom changeZoom w
autoZoomCam :: World -> World
autoZoomCam w = over cameraZoom changeZoom w
where maxViewDistance = 800
camPos = _cameraCenter w
camRot = _cameraRot w
wallZoom = min (halfWidth w / (horizontalMax+10) )
(halfHeight w / (verticalMax+10) )
wallZoom = min (halfWidth w / (horizontalMax+50) )
(halfHeight w / (verticalMax+50) )
idealZoom | SDL.ButtonRight `S.member` _mouseButtons w
= scZoom *
(
@@ -143,10 +136,13 @@ zoomCam w = over cameraZoom changeZoom w
= min (fromMaybe 20 $ yourItem w ^? itZoom . itZoomMax)
$ max (fromMaybe 0.2 (yourItem w ^? itZoom . itZoomMin))
(wallZoom * fromMaybe 1 (yourItem w ^? itZoom . itZoomFac))
changeZoom curZoom | curZoom > idealZoom + 0.01 = 0.05 * (19*curZoom + idealZoom)
| curZoom < idealZoom - 0.01 = 0.05 * (19*curZoom + idealZoom)
| otherwise = idealZoom
-- zs = take 20 [-maxViewDistance,0 - 0.9*maxViewDistance..]
changeZoom curZoom
| curZoom > idealZoom + 0.01 = ((zoomOutSpeed-1)*curZoom + idealZoom) / zoomOutSpeed
| curZoom < idealZoom - 0.01 = ((zoomInSpeed-1)*curZoom + idealZoom) / zoomInSpeed
| otherwise = idealZoom
-- these speeds are inverted, larger means slower
zoomInSpeed = 25
zoomOutSpeed = 15
zs = take 9 [-maxViewDistance,0 - 0.8*maxViewDistance..]
rRays = rotF [( maxViewDistance,y) | y <- zs]
lRays = rotF [(-maxViewDistance,y) | y <- zs]
src/Geometry.hs
+15 -1
View File
@@ -36,6 +36,7 @@ closestPointOnLineParam a b p
rectNESW :: Float -> Float -> Float -> Float -> [Point2]
rectNESW a b c d = [(b,a),(b,c),(d,c),(d,a)
]
rectNSEW :: Float -> Float -> Float -> Float -> [Point2]
rectNSEW n s e w = rectNESW n e s w
rectNSWE :: Float -> Float -> Float -> Float -> [Point2]
@@ -89,6 +90,7 @@ safeNormalizeV p = normalizeV p
-- this has been called somewhere with l1 == l2
isLHS :: Point2 -> Point2 -> Point2 -> Bool
{-# INLINE isLHS #-}
isLHS' :: (Float, Float) -> (Float, Float) -> Point2 -> Bool
isLHS' l1 l2 p | l1 == l2 = False
| otherwise = closestPointOnLineParam l1 (l1 +.+ vNormal (l2 -.- l1)) p < 0
@@ -138,6 +140,7 @@ circOnLine p1 p2 c rad = magV (p1 -.- c) <= rad || magV (p2 -.- c) <= rad
isJustTrue (Just True) = True
isJustTrue _ = False
difference :: (Ord a, Num a) => a -> a -> a
difference x y | x > y = x - y
| otherwise = y - x
@@ -145,6 +148,7 @@ reflectIn :: Point2 -> Point2 -> Point2
reflectIn line vec = let angle = 2 * angleBetween line vec
in rotateV angle vec
angleBetween :: Point2 -> Point2 -> Float
angleBetween v1 v2 = argV v1 - argV v2
doublePair :: (a,a) -> [(a,a)]
@@ -195,7 +199,7 @@ ssaTri :: Float -> Float -> Float -> Float
ssaTri ab bc a
| sin a == 0 = 0
| bc == 0 = ab
| otherwise = let c = asin ( (ab * (sin a))/bc)
| otherwise = let c = asin ( (ab * sin a)/bc)
b = pi - (a + c)
in sin b * bc / sin a
@@ -343,3 +347,13 @@ lineInPolygon a b ps = pointInPolygon a ps || pointInPolygon b ps
|| any (isJust . uncurry (intersectSegSeg' a b)) pss
where pss = zip ps (tail ps ++ [head ps])
makeLoopPairs :: [Point2] -> [(Point2,Point2)]
makeLoopPairs [] = error "tried to make loop with empty list of points"
makeLoopPairs (x:[]) = error "tried to make loop with singleton list of points"
makeLoopPairs (x:xs) = zip (x:xs) (xs ++ [x])
-- note the pair is ordered
-- doesn't work for obtuse angles
pointIsInCone :: Point2 -> (Point2,Point2) -> Point2 -> Bool
pointIsInCone c (rightp,leftp) p = isLHS c rightp p && isLHS leftp c p
src/Geometry/Intersect.hs
+15
View File
@@ -44,6 +44,21 @@ intersectSegLineFrom' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4)
u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3)
-- this is probably not correct...
intersectSegLineext :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
{-# INLINE intersectSegLineext #-}
intersectSegLineext (x1,y1) (x2,y2) (x3,y3) (x4,y4)
| den == 0 = Nothing
| den > 0 && ( t' < 0 || u' < den || t' > den )
= Nothing
| den < 0 && ( t' > 0 || u' > - den || t' < den )
= Nothing
| otherwise = Just (x1 + (x2-x1)*t'/den, y1 + (y2-y1)*t'/den)
where
den = (x1-x2)*(y3-y4) - (y1-y2)*(x3-x4)
t' = (x1-x3)*(y3-y4) - (y1-y3)*(x3-x4)
u' = (y1-y2)*(x1-x3) - (x1-x2)*(y1-y3)
intersectSegLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
{-# INLINE intersectSegLine' #-}
intersectSegLine' (x1,y1) (x2,y2) (x3,y3) (x4,y4)
src/Loop.hs
-1
View File
@@ -10,7 +10,6 @@ import qualified Graphics.Rendering.OpenGL as GL
import Control.Monad
import System.Mem
import Foreign.C
import Geometry
import Preload
src/Picture/Preload.hs
+36 -55
View File
@@ -1,5 +1,4 @@
{-# LANGUAGE TemplateHaskell #-}
--{-# LANGUAGE Strict #-}
module Picture.Preload
( RenderData (..)
, preloadRender
@@ -8,28 +7,24 @@ module Picture.Preload
where
import Picture.Data
import Shader
import Geometry (Point2,Point3,Point4)
import Graphics.Rendering.OpenGL hiding (Point (..),translate,scale,imageHeight,imageWidth)
import Control.Lens
import Foreign
import Shader
import Geometry (Point2,Point3,Point4)
import qualified Control.Foldl as F
data RenderData = RenderData
{ _lightSourceShader :: FullShader (Float,Float,Float,Float)
, _wallShadowShader :: FullShader (Point2,Point2)
, _wallLightShader :: FullShader (Point3)
, _wallLightShader :: FullShader (Point2,Point2)
, _wallFaceShader :: FullShader (Point2,Point2,Point4)
, _backgroundShader :: FullShader (Point2,Point2,Point2,Point2)
, _fullscreenShader :: FullShader ()
, _wallShader :: FullShader (Point3,Point4)
, _listShaders :: [FullShader RenderType]
, _dummyVBO :: BufferObject
, _dummyPtr :: Ptr Float
, _spareFBO :: FramebufferObject
, _fboTexture :: TextureObject
}
@@ -38,32 +33,27 @@ makeLenses ''RenderData
preloadRender :: IO RenderData
preloadRender = do
-- compile shader programs
lsShad <- makeShader "lightmapCircle" [vert,geom,frag] [(0,4)] Points (return . return . flat4)
-- fcs <- makeSourcedShader "lightmapCircle" [VertexShader,GeometryShader,FragmentShader]
-- lighting shaders
lsShad <- makeShader "lighting/lightmapCircle" [vert,geom,frag] [(0,4)] Points
(return . return . flat4)
wsShad <- makeShader "lighting/wallShadow" [vert,geom,frag] [(0,4)] Points pokeWPStrat
>>= addUniforms ["lightPos","perpMat","facesToDraw"]
wlLightShad
<- makeShader "lighting/lightmapWall" [vert,geom,frag] [(0,4)] Points pokeWPStrat
>>= addUniforms ["lightPos","perpMat","radLum"]
bgShad <- makeTextureShader "background" [vert,geom,frag] [(0,4),(1,2)] Points pokeBGStrat
"data/texture/smudgedDirt.png"
wsShad <- makeShaderCustomUnis "wallShadow" [vert,geom,frag] [(0,4)] Points pokeWPStrat
["lightPos","perpMat"]
wlLightShad <- makeShaderCustomUnis "wallLight" [vert,frag] [(0,3)] TriangleStrip pokeLightWallStrat
["lightPosRadLum"]
wlShad <- makeShader "wall" [vert,frag] [(0,3),(1,4)] TriangleStrip pokeWlStrat
bslist <- makeShader "basic" [vert,frag] [(0,3),(1,4)] Triangles pokeTriStrat
lslist <- makeShader "basic" [vert,frag] [(0,3),(1,4)] Lines pokeLineStrat
aslist <- makeShader "arc" [vert,geom,frag] [(0,3),(1,4),(2,4)] Points pokeArcStrat
eslist <- makeShader "ellipse" [vert,geom,frag] [(0,3),(1,4)] Triangles pokeEllStrat
cslist <- makeTextureShader "character" [vert,geom,frag]
-- 2D draw shaders
bslist <- makeShader "twoD/basic" [vert,frag] [(0,3),(1,4)] Triangles pokeTriStrat
lslist <- makeShader "twoD/basic" [vert,frag] [(0,3),(1,4)] Lines pokeLineStrat
aslist <- makeShader "twoD/arc" [vert,geom,frag] [(0,3),(1,4),(2,4)] Points pokeArcStrat
eslist <- makeShader "twoD/ellipse" [vert,geom,frag] [(0,3),(1,4)] Triangles pokeEllStrat
bezierQuadShader <- makeShader
"twoD/bezierQuad" [vert,frag] [(0,3),(1,4),(2,4)] TriangleStrip pokeBezQStrat
cslist <- makeShader "twoD/character" [vert,geom,frag]
[(0,3),(1,4),(2,3)] Points pokeCharStrat
"data/texture/charMap.png"
bezierQuadShader
<- makeShader "bezierQuad" [vert,frag] [(0,3),(1,4),(2,4)] TriangleStrip pokeBezQStrat
>>= addTexture "data/texture/charMap.png"
-- fullscreen shader
fsShad <- makeShader "fullscreen" [vert,frag] [(0,2),(1,2)] TriangleStrip
(const [[[-1, 1],[0,1]]
,[[ 1, 1],[1,1]]
@@ -71,32 +61,29 @@ preloadRender = do
,[[ 1,-1],[1,0]]
]
)
n <- F.foldM (pokeShader fsShad) [()]
putStrLn $ show n
n <- F.foldM (pokeShader fsShad) [()] -- fix fullscreen vertex positions now
--the following vbo is set up to contain one fixed vertex
dummyvbo <- genObjectName
dummyptr <- mallocArray numDrawableElements
pokeArray dummyptr [0..2000]
bindBuffer ArrayBuffer $= Just dummyvbo
bufferData ArrayBuffer $= (fromIntegral floatSize, dummyptr, StaticDraw)
-- background shader
bgShad <- makeShader "background" [vert,geom,frag] [(0,4),(1,2)] Points pokeBGStrat
>>= addTexture "data/texture/smudgedDirt.png"
-- input a list of (attribute location, attrib length) pairs
-- these will have buffers and pointers created
backgroundvao <- setupVAO [(0,4),(1,2)]
-- wallShader
wlShad <- makeShader "wallFace" [vert,geom,frag] [(0,4),(1,4)] Points pokeWPColStrat
>>= addTexture "data/texture/smudgedDirt.png"
>>= addUniforms ["perpMat"]
-- framebuffer for lighting
(fbo,fboTO) <- setupFramebuffer
-- reset to default framebuffer, ready for drawing direct to screen
bindFramebuffer Framebuffer $= defaultFramebufferObject
return $ RenderData
{ _listShaders = [bslist,lslist,cslist,aslist,eslist,bezierQuadShader]
, _dummyVBO = dummyvbo
, _dummyPtr = dummyptr
, _lightSourceShader = lsShad
, _wallShadowShader = wsShad
, _wallLightShader = wlLightShad
, _wallShader = wlShad
, _wallFaceShader = wlShad
, _backgroundShader = bgShad
, _fullscreenShader = fsShad
, _spareFBO = fbo
@@ -135,7 +122,7 @@ cleanUpRenderPreload pd = do
freeShaderPointers $ _lightSourceShader pd
freeShaderPointers $ _wallShadowShader pd
freeShaderPointers $ _backgroundShader pd
free $ _dummyPtr pd
freeShaderPointers $ _fullscreenShader pd
{-# INLINE pokeBezQStrat #-}
pokeBezQStrat :: RenderType -> [[[Float]]]
@@ -149,9 +136,6 @@ pokeTriStrat :: RenderType -> [[[Float]]]
pokeTriStrat (RenderPoly vs) = fmap (\((x,y,z),(r,g,b,a)) -> [[x,y,z],[r,g,b,a]]) vs
pokeTriStrat _ = []
pokeWlStrat :: (Point3,Point4) -> [[[Float]]]
pokeWlStrat ((x,y,z),(r,g,b,a)) = [[[x,y,z],[r,g,b,a]]]
pokeCharStrat (RenderText vs) = fmap (\(a,b,c) -> flat3 (flat3 a, flat4 b, flat3 c)) vs
pokeCharStrat _ = []
@@ -164,9 +148,6 @@ pokeLineStrat _ = []
pokeEllStrat (RenderEllipse vs) = fmap (\((x,y,z),(r,g,b,a)) -> [[x,y,z],[r,g,b,a]]) vs
pokeEllStrat _ = []
bufferOffset :: Integral a => a -> Ptr b
bufferOffset = plusPtr nullPtr . fromIntegral
vert = VertexShader
geom = GeometryShader
frag = FragmentShader
@@ -174,8 +155,8 @@ frag = FragmentShader
pokeWPStrat :: (Point2,Point2) -> [[[Float]]]
pokeWPStrat ((x,y),(z,w)) = [[[x,y,z,w]]]
pokeLightWallStrat :: Point3 -> [[[Float]]]
pokeLightWallStrat (x,y,z) = [[[x,y,z]]]
pokeWPColStrat :: (Point2,Point2,Point4) -> [[[Float]]]
pokeWPColStrat ((x,y),(z,w),(r,g,b,a)) = [[[x,y,z,w],[r,g,b,a]]]
pokeBGStrat :: a -> [[[Float]]]
pokeBGStrat = const []
src/Picture/Render.hs
+26 -51
View File
@@ -48,7 +48,6 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints
( (extractProgAndUnis $ _lightSourceShader pdata)
: (extractProgAndUnis $ _wallShadowShader pdata)
: (extractProgAndUnis $ _wallLightShader pdata)
: (extractProgAndUnis $ _wallShader pdata)
: (extractProgAndUnis $ _backgroundShader pdata)
: (map extractProgAndUnis $ _listShaders pdata)
)
@@ -61,30 +60,41 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints
clearDepth $= 1
clear [ColorBuffer,DepthBuffer]
nWalls <- F.foldM (pokeShader (_wallShadowShader pdata)) wallPoints
-- calculate perspective matrix
pmat <- (newMatrix RowMajor
$ perspectiveMatrix rot zoom (tranx,trany) (winx,winy) (viewFromx,viewFromy)
) :: IO (GLmatrix GLfloat)
nWallLights <- F.foldM (pokeShader $ _wallLightShader pdata) wallPoints
bindShaderBuffers [_wallLightShader pdata] [nWallLights]
currentProgram $= Just (_shaderProgram $ _wallLightShader pdata)
uniform ( (fromJust $ _shaderCustomUnis $ _wallLightShader pdata) !! 1)
$= pmat
nWalls <- F.foldM (pokeShader $ _wallShadowShader pdata) wallPoints
bindShaderBuffers [_wallShadowShader pdata] [nWalls]
let (tx,ty) = (tranx,trany) -.- (viewFromx,viewFromy)
currentProgram $= Just (_shaderProgram $ _wallShadowShader pdata)
uniform (head $ fromJust $ _shaderCustomUnis $ _wallShadowShader pdata)
$= Vector2 viewFromx viewFromy -- hopefully this draws as if from the center
-- it does, but this is not correct when
-- the camera center is not the player position
pmat <- (newMatrix RowMajor
$ perspectiveMatrix rot zoom (tranx,trany) (winx,winy) (viewFromx,viewFromy)
) :: IO (GLmatrix GLfloat)
$= Vector2 viewFromx viewFromy
uniform ( (fromJust $ _shaderCustomUnis $ _wallShadowShader pdata) !! 1)
$= pmat
uniform ( (fromJust $ _shaderCustomUnis $ _wallShadowShader pdata) !! 2)
$= (0 :: Float)
cullFace $= Just Back
cullFace $= Nothing
drawShader (_wallShadowShader pdata) nWalls
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)
@@ -103,6 +113,7 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints
cullFace $= Nothing
colorMask $= (Color4 Enabled Enabled Enabled Enabled)
let lightPtr = (\(_,ptr,_) -> ptr) $ head
$ _vaoBufferTargets $ _shaderVAO $ _lightSourceShader pdata
(x',y') = zTran $ rotateV (0 - rot) $ (x,y) -.- (tranx,trany)
@@ -111,14 +122,14 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints
bindShaderBuffers [_lightSourceShader pdata] [1]
stencilFunc $= (Equal, 0, 255)
drawShader (_lightSourceShader pdata) 1
-- currentProgram $= Just (_shaderProgram $ _wallLightShader pdata)
-- uniform (head $ fromJust $ _shaderCustomUnis $ _wallLightShader pdata)
-- $= Vector4 x y r lum
-- cullFace $= Just Front
-- depthFunc $= Just Lequal
-- drawShader (_wallLightShader pdata) nLightWalls
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
@@ -173,42 +184,6 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints
ticks4 <- renderFoldable pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree (Just 2) pic
bticks <- SDL.ticks
-- render walls
-- depthFunc $= Nothing
-- blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
-- -- poke data
-- cullFace $= Just Back
-- let lights = map (\(x,y,r,g) -> ((x,y),(r,g,0,0))) lightPoints
-- wallPairs = map (\(a,b,_,_) -> [(a,(1,1,1,1)),(b,(1,1,1,1))]) wallPoints
-- f (x,y) = [(x,y,0),(x,y,0),(x,y,-1)]
-- g (x,y) = [(x,y,0),(x,y,-1),(x,y,-1)]
-- wp = concatMap (\(a,b,_,_) -> f a ++ g b) wallPoints
-- h p = (p,(1,0,0,1))
-- wp2 = ((200,200),(-200,200),(0,0),(0,0))
-- wp3 = ((-200,200),(-200,-200),(0,0),(0,0))
-- i <- F.foldM (pokeShader (_wallShader pdata)) $ concat $ mkShadFromWall <$> [wp2,wp3] <*> [(300,50,200,0)]
--
-- -- bind buffers
-- bindShaderBuffers [_wallShader pdata] [i]
--
-- -- draw call
-- drawShaders [_wallShader pdata] [i]
-- depthFunc $= Just Lequal
------ blendFunc $= (One,Zero)
------ let f (x,y) = (x,y,0)
------ h (x,y) = (x,y,-1)
------ g (a,b) = [f a,f a,h a,f b,h b,h b]
------ wp = concatMap g [((200,200),(-200,200))]
------ nLightWalls <- F.foldM (pokeShader (_wallLightShader pdata)) wp
------ bindShaderBuffers [_wallLightShader pdata] [nLightWalls]
------ currentProgram $= Just (_shaderProgram $ _wallLightShader pdata)
------ uniform (head $ fromJust $ _shaderCustomUnis $ _wallLightShader pdata)
------ $= Vector4 (0::Float) 0 200 0.5
------ cullFace $= Just Front
------ depthFunc $= Just Lequal
------ drawShader (_wallLightShader pdata) nLightWalls
resetShaderUniforms (map extractProgAndUnis $ _listShaders pdata)
endWallTicks <- SDL.ticks
src/Shader.hs
+15 -40
View File
@@ -1,8 +1,8 @@
{-# LANGUAGE QuasiQuotes #-}
module Shader
( makeShader
, makeTextureShader
, makeShaderCustomUnis
, addTexture
, addUniforms
, pokeShaders
, pokeShader
, bindArrayBuffers
@@ -28,6 +28,9 @@ import Codec.Picture
import qualified Data.Vector.Storable as V
import Control.Monad (when, forM, zipWithM_, forM_, foldM)
import Control.Lens
import Data.Maybe (fromMaybe)
import qualified Control.Foldl as F
@@ -97,13 +100,10 @@ drawShader fs i = do
_ -> return ()
drawArrays (_shaderDrawPrimitive fs) 0 (fromIntegral i)
makeTextureShader :: String -> [ShaderType] -> [(GLuint,Int)]
-> PrimitiveMode -> (a -> [[[Float]]])
-> String
-> IO (FullShader a)
makeTextureShader s shaderlist alocs pm renStrat texturePath = do
(prog,unis) <- makeSourcedShader s shaderlist
-- I am not sure if this assumes that the shader is constructed directly before
-- the texture is added...
addTexture :: String -> FullShader a -> IO (FullShader a)
addTexture texturePath shad = do
Right cmap <- readImage texturePath
let tex = convertRGBA8 cmap
textureOb <- genObjectName
@@ -116,31 +116,7 @@ makeTextureShader s shaderlist alocs pm renStrat texturePath = do
(PixelData RGBA UnsignedByte ptr)
generateMipmap' Texture2D
textureFilter Texture2D $= ((Linear',Just Linear') , Nearest)
vao <- setupVAO alocs
return $ FullShader { _shaderProgram = prog
, _shaderUniforms = unis
, _shaderVAO = vao
, _shaderPokeStrategy = renStrat
, _shaderDrawPrimitive = pm
, _shaderTexture = Just $ ShaderTexture {_textureObject = textureOb}
, _shaderCustomUnis = Nothing
}
makeShaderCustomUnis :: String -> [ShaderType] -> [(GLuint,Int)] -> PrimitiveMode -> (a -> [[[Float]]])
-> [String] -> IO (FullShader a)
makeShaderCustomUnis s shaderlist alocs pm renStrat uniStrings = do
(prog,unis,unis') <- makeSourcedShaderCustomUnis s shaderlist uniStrings
vao <- setupVAO alocs
return $ FullShader { _shaderProgram = prog
, _shaderUniforms = unis
, _shaderVAO = vao
, _shaderPokeStrategy = renStrat
, _shaderDrawPrimitive = pm
, _shaderTexture = Nothing
, _shaderCustomUnis = Just unis'
}
return $ shad & shaderTexture .~ Just (ShaderTexture {_textureObject = textureOb})
makeShader :: String -> [ShaderType] -> [(GLuint,Int)] -> PrimitiveMode -> (a -> [[[Float]]]) -> IO (FullShader a)
makeShader s shaderlist alocs pm renStrat = do
@@ -203,12 +179,11 @@ makeSourcedShader s sts = do
$ \uniString -> uniformLocation prog uniString
return (prog,uniformLocations)
makeSourcedShaderCustomUnis :: String -> [ShaderType] -> [String]
-> IO (Program, [UniformLocation], [UniformLocation])
makeSourcedShaderCustomUnis s shadTypes uniStrings = do
(prog,unis0) <- makeSourcedShader s shadTypes
unis <- mapM (uniformLocation prog) uniStrings
return (prog,unis0,unis)
addUniforms :: [String] -> FullShader a -> IO (FullShader a)
addUniforms uniStrings shad = do
uniLocs <- mapM (uniformLocation $ _shaderProgram shad) uniStrings
return $ shad & shaderCustomUnis %~ Just . (++ uniLocs) . fromMaybe []
shaderTypeExt :: ShaderType -> String
shaderTypeExt VertexShader = ".vert"