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

Cleanup

Browse Source
This commit is contained in:
justin
2023-04-15 10:55:59 +01:00
parent 44f64f4b47
commit 8ab75fb24a
11 changed files with 64 additions and 62 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/DisplayInventory.hs
+1
View File
@@ -1,4 +1,5 @@
{-# LANGUAGE TupleSections #-}
--{-# OPTIONS_GHC -fno-full-laziness #-}
module Dodge.DisplayInventory (
toggleCombineInv,
src/Dodge/Floor.hs
+5 -5
View File
@@ -20,11 +20,11 @@ initialRoomTree :: State (StdGen, Int) (MetaTree Room String)
initialRoomTree = annoToRoomTree initialAnoTree
--initialRoomTree = annoToRoomTree startWorldTreeTest
startWorldTreeTest :: Annotation
startWorldTreeTest =
OnwardList $
[ IntAnno $ AnTree . startRoom
]
--startWorldTreeTest :: Annotation
--startWorldTreeTest =
-- OnwardList $
-- [ IntAnno $ AnTree . startRoom
-- ]
initialAnoTree :: Annotation
initialAnoTree =
src/Dodge/Update.hs
-3
View File
@@ -341,9 +341,6 @@ zoneCreatures w =
w & crZoning
.~ foldl' (flip zoneCreature) mempty (w ^. cWorld . lWorld . creatures)
-- foldl' (flip $ updateZoning (\cr -> IM.insert (_crID cr) cr))
-- zn (_creatures w)
updateCreatureSoundPositions :: World -> World
updateCreatureSoundPositions w =
M.foldlWithKey' insertSound w
src/Dodge/Zoning/Base.hs
-5
View File
@@ -6,7 +6,6 @@ module Dodge.Zoning.Base
, zoneOfRect
, zoneMonoid
, deZoneIX
, zoneOfPoint''
, zoneOfCirc
, zonesAroundPoint
, xIntercepts
@@ -87,10 +86,6 @@ zoneMonoid (V2 x y) a = IM.insertWith f x $! IM.singleton y a
deZoneIX :: Int -> IM.IntMap (IM.IntMap IS.IntSet) -> Int2 -> IM.IntMap (IM.IntMap IS.IntSet)
deZoneIX i im (V2 x y) = im & ix x . ix y %~ IS.delete i
zoneOfPoint'' :: Float -> Point2 -> Int2
{-# INLINE zoneOfPoint'' #-}
zoneOfPoint'' s = fmap (divTo s)
zonesAroundPoint :: Float -> Point2 -> [Int2]
zonesAroundPoint s p = [V2 a b | a <- [x -1 .. x + 1], b <- [y -1 .. y + 1]]
where
src/Dodge/Zoning/Cloud.hs
+4 -4
View File
@@ -7,13 +7,13 @@ import qualified IntMapHelp as IM
import Dodge.Zoning.Common
clsNearPoint :: Point2 -> World -> [Cloud]
clsNearPoint = nearPoint' clZoneSize _clZoning
clsNearPoint = nearPoint clZoneSize _clZoning
clsNearSeg :: Point2 -> Point2 -> World -> [Cloud]
clsNearSeg = nearSeg' clZoneSize _clZoning
clsNearSeg = nearSeg clZoneSize _clZoning
clsNearRect :: Point2 -> Point2 -> World -> [Cloud]
clsNearRect = nearRect' clZoneSize _clZoning
clsNearRect = nearRect clZoneSize _clZoning
clsNearCirc :: Point2 -> Float -> World -> [Cloud]
clsNearCirc p r = clsNearRect (p +.+ V2 r r) (p -.- V2 r r)
@@ -22,7 +22,7 @@ clZoneSize :: Float
clZoneSize = 20
zoneOfCl :: Cloud -> Int2
zoneOfCl = zoneOfPoint'' clZoneSize . xyV3 . _clPos
zoneOfCl = zoneOfPoint clZoneSize . xyV3 . _clPos
zoneCloud :: Cloud -> IM.IntMap (IM.IntMap [Cloud]) -> IM.IntMap (IM.IntMap [Cloud])
zoneCloud cl = zoneMonoid (zoneOfCl cl) [cl]
src/Dodge/Zoning/Common.hs
+9 -9
View File
@@ -5,14 +5,14 @@ import Dodge.Zoning.Base
import Geometry
import qualified IntMapHelp as IM
nearPoint' :: Monoid m => Float -> (World -> IM.IntMap (IM.IntMap m)) -> Point2 -> World -> m
{-# INLINE nearPoint' #-}
nearPoint' size f p w = zoneExtract (zoneOfPoint size p) (f w)
nearPoint :: Monoid m => Float -> (World -> IM.IntMap (IM.IntMap m)) -> Point2 -> World -> m
{-# INLINE nearPoint #-}
nearPoint size f p = zoneExtract (zoneOfPoint size p) . f
nearSeg' :: Monoid m => Float -> (World -> IM.IntMap (IM.IntMap m)) -> Point2 -> Point2 -> World -> m
{-# INLINE nearSeg' #-}
nearSeg' size f sp ep w = zonesExtract (f w) (zoneOfSeg size sp ep)
nearSeg :: Monoid m => Float -> (World -> IM.IntMap (IM.IntMap m)) -> Point2 -> Point2 -> World -> m
{-# INLINE nearSeg #-}
nearSeg size f sp ep w = zonesExtract (f w) (zoneOfSeg size sp ep)
nearRect' :: Monoid m => Float -> (World -> IM.IntMap (IM.IntMap m)) -> Point2 -> Point2 -> World -> m
{-# INLINE nearRect' #-}
nearRect' size f sp ep w = zonesExtract (f w) (zoneOfRect size sp ep)
nearRect :: Monoid m => Float -> (World -> IM.IntMap (IM.IntMap m)) -> Point2 -> Point2 -> World -> m
{-# INLINE nearRect #-}
nearRect size f sp ep w = zonesExtract (f w) (zoneOfRect size sp ep)
src/Dodge/Zoning/Creature.hs
+4 -3
View File
@@ -12,7 +12,7 @@ import Dodge.Zoning.Common
crIXsNearPoint :: Point2 -> World -> IS.IntSet
--crIXsNearPoint p w = zoneExtract (zoneOfPoint crZoneSize p) (w ^. cWorld . lWorld . crZoning)
crIXsNearPoint = nearPoint' crZoneSize _crZoning
crIXsNearPoint = nearPoint crZoneSize _crZoning
crsNearPoint :: Point2 -> World -> [Creature]
crsNearPoint p w = mapMaybe (\cid -> w ^? cWorld . lWorld . creatures . ix cid) . IS.toList $ crIXsNearPoint p w
@@ -24,7 +24,7 @@ crsNearSeg sp ep w =
$ crixsNearSeg sp ep w
crixsNearSeg :: Point2 -> Point2 -> World -> IS.IntSet
crixsNearSeg = nearSeg' crZoneSize _crZoning
crixsNearSeg = nearSeg crZoneSize _crZoning
--crixsNearSeg sp ep w = zonesExtract (w ^. cWorld . lWorld . crZoning) (zoneOfSeg crZoneSize sp ep)
crIXsNearCirc :: Point2 -> Float -> World -> IS.IntSet
@@ -34,7 +34,7 @@ crsNearCirc :: Point2 -> Float -> World -> [Creature]
crsNearCirc p r w = mapMaybe (\cid -> w ^? cWorld . lWorld . creatures . ix cid) . IS.toList $ crIXsNearCirc p r w
crsNearRect :: Point2 -> Point2 -> World -> IS.IntSet
crsNearRect = nearRect' crZoneSize _crZoning
crsNearRect = nearRect crZoneSize _crZoning
crZoneSize :: Float
crZoneSize = 15
@@ -50,6 +50,7 @@ minCrIXOn f is w = fst <$> IS.foldl' g Nothing is
h cr = (cr, f cr)
zoneCreature :: Creature -> IM.IntMap (IM.IntMap IS.IntSet) -> IM.IntMap (IM.IntMap IS.IntSet)
{-# INLINE zoneCreature #-}
zoneCreature cr im = foldl' f im (zoneOfCr cr)
where
f im' i2 = zoneMonoid i2 (IS.singleton $ _crID cr) im'
src/Dodge/Zoning/Pathing.hs
+7 -7
View File
@@ -10,13 +10,13 @@ import qualified Data.Set as Set
import Dodge.Zoning.Common
pnsNearPoint :: Point2 -> World -> [(Int, Point2)]
pnsNearPoint = nearPoint' pnZoneSize _pnZoning
pnsNearPoint = nearPoint pnZoneSize _pnZoning
pnsNearSeg :: Point2 -> Point2 -> World -> [(Int, Point2)]
pnsNearSeg = nearSeg' pnZoneSize _pnZoning
pnsNearSeg = nearSeg pnZoneSize _pnZoning
pnsNearRect :: Point2 -> Point2 -> World -> [(Int, Point2)]
pnsNearRect = nearRect' pnZoneSize _pnZoning
pnsNearRect = nearRect pnZoneSize _pnZoning
pnsNearCirc :: Point2 -> Float -> World -> [(Int, Point2)]
pnsNearCirc p r = pnsNearRect (p +.+ V2 r r) (p -.- V2 r r)
@@ -25,20 +25,20 @@ pnZoneSize :: Float
pnZoneSize = 50
zoneOfPn :: (Int, Point2) -> Int2
zoneOfPn = zoneOfPoint'' pnZoneSize . snd
zoneOfPn = zoneOfPoint pnZoneSize . snd
zonePn :: (Int, Point2) -> IM.IntMap (IM.IntMap [(Int, Point2)]) -> IM.IntMap (IM.IntMap [(Int, Point2)])
zonePn pn = zoneMonoid (zoneOfPn pn) [pn]
pesNearPoint :: Point2 -> World -> Set PathEdgeNodes
pesNearPoint = nearPoint' peZoneSize _peZoning
pesNearPoint = nearPoint peZoneSize _peZoning
--pesNearPoint p w = zoneExtract (zoneOfPoint peZoneSize p) (w ^. cWorld . lWorld . peZoning)
pesNearSeg :: Point2 -> Point2 -> World -> Set PathEdgeNodes
pesNearSeg = nearSeg' peZoneSize _peZoning
pesNearSeg = nearSeg peZoneSize _peZoning
pesNearRect :: Point2 -> Point2 -> World -> Set PathEdgeNodes
pesNearRect = nearRect' peZoneSize _peZoning
pesNearRect = nearRect peZoneSize _peZoning
pesNearCirc :: Point2 -> Float -> World -> Set PathEdgeNodes
pesNearCirc p r = pesNearRect (p +.+ V2 r r) (p -.- V2 r r)
src/Dodge/Zoning/Wall.hs
+3 -3
View File
@@ -20,14 +20,14 @@ import qualified IntMapHelp as IM
import Dodge.Zoning.Common
wlIXsNearPoint :: Point2 -> World -> IS.IntSet
wlIXsNearPoint = nearPoint' wlZoneSize _wlZoning
wlIXsNearPoint = nearPoint wlZoneSize _wlZoning
wlIXsNearSeg :: Point2 -> Point2 -> World -> IS.IntSet
{-# INLINE wlIXsNearSeg #-}
wlIXsNearSeg = nearSeg' wlZoneSize _wlZoning
wlIXsNearSeg = nearSeg wlZoneSize _wlZoning
wlIXsNearRect :: Point2 -> Point2 -> World -> IS.IntSet
wlIXsNearRect = nearRect' wlZoneSize _wlZoning
wlIXsNearRect = nearRect wlZoneSize _wlZoning
wlIXsNearCirc :: Point2 -> Float -> World -> IS.IntSet
wlIXsNearCirc p r = wlIXsNearRect (p +.+ V2 r r) (p -.- V2 r r)
src/Render.hs
+1 -1
View File
@@ -150,7 +150,7 @@ renderShadows ::
RenderData ->
IO ()
renderShadows shadrendertype nWalls nSils nCaps positiontexture normaltexture lightPoints pdata = do
glBindFramebuffer GL_FRAMEBUFFER $ pdata ^. fboLighting . _1 . unFBO --(_unFBO (fst (_fboLighting pdata)))
glBindFramebuffer GL_FRAMEBUFFER $ pdata ^. fboLighting . _1 . unFBO
let llinesShad = _lightingLineShadowShader pdata
lcapShad = _lightingCapShader pdata
lwallShad = _lightingWallShadShader pdata
src/Shader/Poke.hs
+30 -22
View File
@@ -3,7 +3,6 @@ module Shader.Poke (
pokeLayVerxs,
pokeArrayOff,
pokeShape,
pokeShape',
pokeWallsWindows,
memoTopPrismEdgeIndices,
pokeFloors,
@@ -100,14 +99,14 @@ pokeW ptr i' ((V2 a b, V2 c d), V4 e f g h) = do
pokeElemOff ptr (i + 7) h
return $ i' + 1
pokeShape' ::
Ptr Float ->
Ptr GLushort ->
Ptr GLushort ->
(Int, Int, Int) ->
[Surface] ->
IO (Int, Int, Int)
pokeShape' = pokeShape $ const False
--pokeShape' ::
-- Ptr Float ->
-- Ptr GLushort ->
-- Ptr GLushort ->
-- (Int, Int, Int) ->
-- [Surface] ->
-- IO (Int, Int, Int)
--pokeShape' = pokeShape $ const False
pokeShape ::
(Surface -> Bool) ->
@@ -117,6 +116,7 @@ pokeShape ::
(Int, Int, Int) ->
[Surface] ->
IO (Int, Int, Int)
{-# INLINE pokeShape #-}
pokeShape shadowtest ptr iptr ieptr is =
VFSM.foldlM' (pokeShapeObj shadowtest ptr iptr ieptr) is
. VFSM.fromList
@@ -228,12 +228,15 @@ pokeBox ::
IO (Int, Int, Int)
{-# INLINE pokeBox #-}
pokeBox sfid col size ptr iptr ieptr (nv, nsi, nei) svs = do
nv' <- VFSM.foldM' (pokeBoxSurface xdata col ptr svsv) nv $ VFSM.fromList $ boxSurfaces size
nv' <- VFSM.foldM' (pokeBoxSurface xdata col ptr svsv) nv $ VFSM.fromList $ memoBoxSurfaces V.! size
-- nv' <- VFSM.foldM' (pokeBoxSurface xdata col ptr svsv) nv $ VFSM.fromList $ boxSurfaces size
nsi' <-
UV.foldM'
(pokeIndex nv iptr)
nsi
(memoFlatIndices V.! (size -3))
-- VFSM.foldM' (pokeIndex nv iptr) nsi
-- (VFSM.fromList . concatMap polyToTris $ boxSurfacesIndices size)
nei' <-
if sfid
then return nei
@@ -264,6 +267,7 @@ pokeBoxSurface xdata col ptr vs n is =
-- should probably memoize this
boxSurfaces :: Int -> [[Int]]
{-# INLINE boxSurfaces #-}
boxSurfaces size =
[0, 2 .. size * 2 -1] :
[1, 3 .. size * 2] :
@@ -271,7 +275,12 @@ boxSurfaces size =
where
f x = map (`mod` (size * 2)) [x, x + 1, x + 3, x + 2]
memoBoxSurfaces :: V.Vector [[Int]]
{-# INLINE memoBoxSurfaces #-}
memoBoxSurfaces = V.generate 10 $ boxSurfaces
boxSurfacesIndices :: Int -> [[Int]]
{-# INLINE boxSurfacesIndices #-}
boxSurfacesIndices n =
[0 .. n -1] :
reverse [n .. n * 2 -1] :
@@ -304,11 +313,13 @@ memoTopPrismIndices =
UV.fromList . topPrismIndices . (+ 3)
memoCylinderIndices :: V.Vector (UV.Vector Int)
{-# INLINE memoCylinderIndices #-}
memoCylinderIndices =
V.generate 10 $
UV.fromList . cylinderIndices . (+ 3)
memoTopPrismEdgeIndices :: V.Vector (UV.Vector Int)
{-# INLINE memoTopPrismEdgeIndices #-}
memoTopPrismEdgeIndices =
V.generate 10 $
UV.fromList . topPrismEdgeIndices . (+ 3)
@@ -317,28 +328,21 @@ topPrismEdgeIndices ::
-- | the number of vertices on the top surface, ie. half the total
Int ->
[Int]
{-# INLINE topPrismEdgeIndices #-}
topPrismEdgeIndices n = concatMap f [0 .. n -1]
where
f i =
map
g
[ 0
, 2
, 1
, 4
, 0
, 1
, -2
, 3
, 1
, 3
, -1
, 2
[ 0 , 2 , 1 , 4
, 0 , 1 , -2 , 3
, 1 , 3 , -1 , 2
]
where
g j = (2 * i + j) `mod` (2 * n)
memoBoxEdgeIndices :: V.Vector (UV.Vector Int)
{-# INLINE memoBoxEdgeIndices #-}
memoBoxEdgeIndices =
V.generate 10 $
UV.fromList . boxEdgeIndices . (+ 3)
@@ -347,6 +351,7 @@ boxEdgeIndices ::
-- | the number of vertices on the top surface, ie. half the total
Int ->
[Int]
{-# INLINE boxEdgeIndices #-}
boxEdgeIndices n = concatMap f [0 .. n -1]
where
f i =
@@ -367,12 +372,14 @@ boxEdgeIndices n = concatMap f [0 .. n -1]
g j = (i + j) `mod` n
cylinderIndices :: Int -> [Int]
{-# INLINE cylinderIndices #-}
cylinderIndices n =
cylinderRoundIndices n
++ polyToTris [2 * n, 2 * n + 2 .. 4 * n - 1]
++ polyToTris [2 * n + 1, 2 * n + 3 .. 4 * n - 1]
cylinderRoundIndices :: Int -> [Int]
{-# INLINE cylinderRoundIndices #-}
cylinderRoundIndices n =
[ 2 * n -2
, 2 * n -1
@@ -393,6 +400,7 @@ cylinderRoundIndices n =
]
topPrismIndices :: Int -> [Int]
{-# INLINE topPrismIndices #-}
topPrismIndices n =
concatMap f [1 .. n -2] -- triangles on top face
++ concatMap f' [1 .. n -2] -- triangles on bottom face