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
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"