Commit before placement refactor

This commit is contained in:
2021-09-28 14:55:22 +01:00
parent 751000636e
commit b8af2ce9d8
16 changed files with 134 additions and 331 deletions
+11 -9
View File
@@ -14,8 +14,9 @@ module Dodge.LevelGen.Data
, pwPoly
, pwWall
, unPutCrit
, groupPlacementID
, groupUpdate
-- , groupPlacementID
-- , groupUpdate
, idPlacement
) where
import Dodge.Data
import Picture
@@ -49,14 +50,15 @@ data PlacementSpot = PS
, _psType :: PSType
}
data Placement
= SinglePlacement {_placementSpot :: PlacementSpot }
| GroupedPlacement
{_groupPlacementID :: Int
,_groupUpdate :: World -> [Placement] -> World
,_placementSpot :: PlacementSpot
}
= SimplePlacement {_placementSpot :: PlacementSpot }
| IDPlacement {_placementSpot :: PlacementSpot, _idPlacement :: Int -> Placement }
-- | GroupedPlacement
-- {_groupPlacementID :: Int
-- ,_groupUpdate :: World -> [Placement] -> World
-- ,_placementSpot :: PlacementSpot
-- }
sPS :: Point2 -> Float -> PSType -> Placement
sPS p a = SinglePlacement . PS p a
sPS p a = SimplePlacement . PS p a
makeLenses ''PSType
makeLenses ''PlacementSpot
makeLenses ''Placement
+2 -80
View File
@@ -1,43 +1,11 @@
module Dodge.LevelGen.DoorPane
( linearPane
, mkDoubleDoor
, mkSingleDoor
, rectanglePairs
( rectanglePairs
) where
import Dodge.Data
import Dodge.LevelGen.MoveDoor
import Picture
import qualified DoubleStack as DS
--import Dodge.Data
import Geometry.Vector
import Geometry.Data
import Data.Bifunctor
-- | A door pane that moves linearly between open and closed positions using a
-- boolean trigger.
linearPane
:: Color
-> Bool -- ^ Pathable flag
-> (World -> Bool) -- ^ Opening condition
-> Float -- ^ speed
-> Int -- ^ Wall id
-> (Point2,Point2) -- ^ Closed position
-> (Point2,Point2) -- ^ Open position
-> Wall
linearPane c isPathable cond speed n closedPos openPos = Door
{ _wlLine = closedPos
, _wlID = n
, _doorMech = dm
, _wlColor = c
, _wlSeen = False
, _wlIsSeeThrough = False
, _doorPathable = isPathable
, _drPositions = DS.singleton closedPos
}
where
dm = doorMechan n (zoneps closedPos) openDoor closeDoor cond
openDoor = moveDoorToward speed openPos
closeDoor = moveDoorToward speed closedPos
rectanglePairs :: Float -> Point2 -> Point2 -> [(Point2,Point2)]
rectanglePairs wdth a b =
@@ -52,49 +20,3 @@ rectanglePairs wdth a b =
bu = b +.+ norm
bd = b -.- norm
norm = wdth *.* normalizeV ( vNormal (b -.- a))
mkSingleDoor :: Color -> Bool -> (World -> Bool) -> Point2 -> Point2 -> Float -> [Int] -> [Wall]
mkSingleDoor c isPathable cond hingep edgep speed is
= addSoundToDoor (head is) (fst $ head theDoor) (fst $ head shiftedDoor)
$ zipWith3 (linearPane c isPathable cond speed)
is
theDoor
shiftedDoor
where
theDoor = rectanglePairs 9 hingep edgep
shiftedDoor = map (bimap shiftLeft shiftLeft) theDoor
shiftLeft = (+.+ (hingep -.- edgep))
mkDoubleDoor :: Color -> Bool -> (World -> Bool) -> Point2 -> Point2 -> Float -> [Int] -> [Wall]
mkDoubleDoor c isPathable cond pl pr speed is
= addSoundToDoor (head is) (fst $ head leftDoor) (fst $ head shiftedDoor)
$ zipWith3 (linearPane c isPathable cond speed)
is
(leftDoor ++ rightDoor)
shiftedDoor
where
shiftedDoor = map shiftLeft leftDoor ++ map shiftRight rightDoor
leftDoor =
[ (pld +.+ perp,hwd)
, (hwd, hwu)
, (hwu, plu +.+ perp)
, (plu +.+ perp,pld +.+ perp)
]
rightDoor =
[ (pru -.- perp,hwu)
, (hwu, hwd)
, (hwd, prd -.- perp)
, (prd -.- perp,pru -.- perp)
]
shiftRight = h (+.+ (0.5 *.* (pr -.- pl)))
shiftLeft = h (+.+ (0.5 *.* (pl -.- pr)))
h func (x,y) = (func x,func y)
norm = 9 *.* normalizeV ( vNormal (pr -.- pl))
hw = 0.5 *.* (pl +.+ pr)
perp = 5 *.* normalizeV (pl -.- pr)
plu = pl +.+ norm
pld = pl -.- norm
pru = pr +.+ norm
prd = pr -.- norm
hwu = hw +.+ norm
hwd = hw -.- norm
+1 -33
View File
@@ -1,21 +1,15 @@
{-# LANGUAGE BangPatterns #-}
module Dodge.LevelGen.MoveDoor
( doorMechan
, zoneps
( zoneps
, moveDoorToward
, addSoundToDoor
, changeZonedWall
) where
import Dodge.Data
import Dodge.Data.SoundOrigin
import Dodge.Base
import Dodge.Zone
import Dodge.Zone.Data
import Dodge.SoundLogic
import Dodge.SoundLogic.LoadSound
import Geometry
import qualified Data.IntMap.Strict as IM
import Control.Lens
-- This deserves a clean up
@@ -38,20 +32,6 @@ zoneps (a,b)
= [zoneOfPoint $ pHalf a b]
| otherwise = map zoneOfPoint $ divideLine zoneSize a b
doorMechan
:: Int
-> [(Int,Int)]
-> (Wall -> Wall)
-> (Wall -> Wall)
-> (World -> Bool)
-> World
-> World
doorMechan n zonePs openEff closeEff cond w
| cond w = flip (foldr $ changeZonedWall openEff n) zonePs
$ over walls (IM.adjust openEff n) w
| otherwise = flip (foldr $ changeZonedWall closeEff n) zonePs
$ over walls (IM.adjust closeEff n) w
changeZonedWall
:: (Wall -> Wall)
-> Int
@@ -60,15 +40,3 @@ changeZonedWall
-> World
changeZonedWall eff n (x,y) = over (wallsZone . znObjects) $ adjustIMZone eff x y n
addSoundToDoor :: Int -> Point2 -> Point2 -> [Wall] -> [Wall]
addSoundToDoor _ _ _ [] = error "When creating door tried to add sound to nothing"
addSoundToDoor i pld hwd (x:ys) = f x : ys
where
f wl = over doorMech g wl
where
g dm w
| dist wp pld > 2 && dist wp hwd > 2
= soundContinue (WallSound i) wp slideDoorS (Just 1) $ dm w
| otherwise = dm w
where
wp = fst $ _wlLine (_walls w IM.! i)
+42 -42
View File
@@ -1,5 +1,5 @@
module Dodge.LevelGen.SwarmPlacement
( swarmPS
( --swarmPS
)
where
import Dodge.Data
@@ -14,44 +14,44 @@ import Data.List
import qualified Data.IntSet as IS
import Control.Lens
swarmPS :: Int -> Point2 -> Float -> Creature -> Placement
swarmPS i p a cr = GroupedPlacement
{ _groupPlacementID = i
, _groupUpdate = setSwarm
-- , _groupPlacementFunc = setSwarm i
, _placementSpot = PS p a $ PutCrit cr
}
setSwarm :: World -> [Placement] -> World
setSwarm w ps = updateCrs w' & creatureGroups %~ IM.insert gid theGroupParams
where
(w', crs) = mapAccumR updateCrit w ps
is = IS.fromList $ map _crID crs
cpos = centroid $ map _crPos crs
gid = IM.newKey (_creatureGroups w')
theGroupParams = CrGroupParams
{ _crGroupParamID = gid
, _crGroupIDs = is
, _crGroupCenter = cpos
, _crGroupUpdate = crGroupUpdateCenter
}
updateCrs w'' = IS.foldl' (\w''' cid -> w''' & creatures . ix cid %~ setSwarmStatus) w'' is
setSwarmStatus = crGroup .~ Swarm {_swarm = is, _crGroupID = gid}
crGroupUpdateCenter :: World -> CrGroupParams -> Maybe CrGroupParams
crGroupUpdateCenter w cgp
| IM.null crs = Nothing
| otherwise = Just $ cgp & crGroupCenter .~
centroid (IM.map _crPos crs)
where
crs = IM.restrictKeys (_creatures w) (_crGroupIDs cgp)
updateCrit :: World -> Placement -> (World, Creature)
updateCrit w pl = (w & creatures %~ IM.insert cid cr
, cr
)
where
p = _psPos $ _placementSpot pl
rot = _psRot $ _placementSpot pl
scr = _unPutCrit $ _psType $ _placementSpot pl
cid = IM.newKey (_creatures w)
cr = scr {_crPos = p,_crOldPos = p,_crDir = rot,_crID = cid}
--swarmPS :: Int -> Point2 -> Float -> Creature -> Placement
--swarmPS i p a cr = GroupedPlacement
-- { _groupPlacementID = i
-- , _groupUpdate = setSwarm
---- , _groupPlacementFunc = setSwarm i
-- , _placementSpot = PS p a $ PutCrit cr
-- }
--setSwarm :: World -> [Placement] -> World
--setSwarm w ps = updateCrs w' & creatureGroups %~ IM.insert gid theGroupParams
-- where
-- (w', crs) = mapAccumR updateCrit w ps
-- is = IS.fromList $ map _crID crs
-- cpos = centroid $ map _crPos crs
-- gid = IM.newKey (_creatureGroups w')
-- theGroupParams = CrGroupParams
-- { _crGroupParamID = gid
-- , _crGroupIDs = is
-- , _crGroupCenter = cpos
-- , _crGroupUpdate = crGroupUpdateCenter
-- }
-- updateCrs w'' = IS.foldl' (\w''' cid -> w''' & creatures . ix cid %~ setSwarmStatus) w'' is
-- setSwarmStatus = crGroup .~ Swarm {_swarm = is, _crGroupID = gid}
--
--crGroupUpdateCenter :: World -> CrGroupParams -> Maybe CrGroupParams
--crGroupUpdateCenter w cgp
-- | IM.null crs = Nothing
-- | otherwise = Just $ cgp & crGroupCenter .~
-- centroid (IM.map _crPos crs)
-- where
-- crs = IM.restrictKeys (_creatures w) (_crGroupIDs cgp)
--
--updateCrit :: World -> Placement -> (World, Creature)
--updateCrit w pl = (w & creatures %~ IM.insert cid cr
-- , cr
-- )
-- where
-- p = _psPos $ _placementSpot pl
-- rot = _psRot $ _placementSpot pl
-- scr = _unPutCrit $ _psType $ _placementSpot pl
-- cid = IM.newKey (_creatures w)
-- cr = scr {_crPos = p,_crOldPos = p,_crDir = rot,_crID = cid}
+1 -2
View File
@@ -25,7 +25,6 @@ makeButton col eff = Button
. soundFromGeneral (LeverSound 0) (btpos b) click1S Nothing $ w
, _btID = 0
, _btText = "Button"
--, _btText = "Button"
, _btState = BtOff
}
where
@@ -39,7 +38,7 @@ drawSwitch col1 col2 bt
where
flick a = ( mconcat
[ colorSH col1 . translateSHz 10 . upperPrismPoly 10 $ rectNSEW (-2) (-5) 10 (-10)
, colorSH col2 . translateSH (V3 0 (-2) 15) . rotateSH a . upperPrismPoly 2 $ rectNSEW 10 (0) 2 (-2)
, colorSH col2 . translateSH (V3 0 (-2) 15) . rotateSH a . upperPrismPoly 2 $ rectNSEW 10 0 2 (-2)
]
, mempty)
+20 -78
View File
@@ -14,7 +14,6 @@ import Dodge.LevelGen.MoveDoor
import Dodge.LevelGen.DoorPane
import Picture
import Geometry
import qualified DoubleStack as DS
import qualified IntMapHelp as IM
import Dodge.SoundLogic
import Dodge.SoundLogic.LoadSound
@@ -45,19 +44,6 @@ addButtonDoor c btp btr a b speed w
. over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w'
f (x,y) = (x,y,dist x y)
putDoor'
:: Color
-> (World -> Bool) -- ^ Opening condition
-> [(Point2,Point2)] -- ^ Door positions, closed to open.
-- Bumped out up and down by 9, not widened
-> World
-> World
putDoor' c cond pss = over walls triggerDoor
where
triggerDoor wls = IM.union wls $ IM.fromList $ zip is $ mkTriggerDoor c cond pss is
where
is = [IM.newKey wls..]
putDoor
:: Color
-> (World -> Bool) -- ^ Opening condition
@@ -78,8 +64,8 @@ putDoor col cond pss w = addWalls w
}
nsteps = length pss - 1
wlids = take 4 [IM.newKey $ _walls w ..]
wlps = uncurry (rectanglePairs 9) $ head pss
addWalls w' = foldl' addWall w' $ zip wlids wlps
wlps' = uncurry (rectanglePairs 9) $ head pss
addWalls w' = foldl' addWall w' $ zip wlids wlps'
addWall w' (wlid, wlps) = w' & walls %~ IM.insert wlid Wall
{ _wlLine = wlps
, _wlID = wlid
@@ -95,18 +81,21 @@ doorMechanismStepwise nsteps drid wlids pss dr w
| toOpen = case _drStatus dr of
DoorInt x | x == nsteps -> w
DoorInt x -> setWalls (x+1)
_ -> w
| otherwise = case _drStatus dr of
DoorInt 0 -> w
DoorInt x -> setWalls (x-1)
_ -> w
where
playSound = soundContinue (WallSound drid) (fst $ head pss) slideDoorS (Just 1)
toOpen = _drTrigger dr w
setWalls n = (playSound $ foldl' setWall w (zip wlids newps))
cpss = uncurry (rectanglePairs 9) (head pss)
setWalls n = (playSound $ foldl' setWall w (zip3 wlids newps cpss))
& doors . ix drid . drStatus .~ DoorInt n
where
newps = uncurry (rectanglePairs 9) (pss !! n)
setWall w' (wlid,ps) = w & walls . ix wlid . wlLine .~ ps
& (\w'' -> foldr (changeZonedWall (wlLine .~ ps) wlid) w'' (zoneps ps))
setWall w' (wlid,ps,cps) = w' & walls . ix wlid . wlLine .~ ps
& (\w'' -> foldr (changeZonedWall (wlLine .~ ps) wlid) w'' (zoneps cps))
-- it is not at all clear that the zoning selects the correct walls
@@ -120,26 +109,25 @@ putDoubleDoor isPathable col cond a b speed
-- TODO think about wall zoning, simplify!
doorMechanism :: Int -> Float -> [(Int,(Point2,Point2),(Point2,Point2))] -> Door' -> World -> World
doorMechanism drid speed wlidOpCps dr w
| toOpen && not (dstatus == DoorOpen) = playSound . setStatus $ foldl' doOpen w wlidOpCps
| not toOpen && not (dstatus == DoorClosed) = playSound . setStatus $ foldl' doClose w wlidOpCps
| toOpen && dstatus /= DoorOpen = moveUpdate $ foldl' doOpen w wlidOpCps
| not toOpen && dstatus /= DoorClosed = moveUpdate $ foldl' doClose w wlidOpCps
| otherwise = w
where
moveUpdate = playSound . setStatus
playSound = soundContinue (WallSound drid) (fst cpos) slideDoorS (Just 1)
setStatus
| isOpen = doors . ix drid . drStatus .~ DoorOpen
| isClosed = doors . ix drid . drStatus .~ DoorClosed
| otherwise = doors . ix drid . drStatus .~ DoorHalfway
| dist (fst wlpos) (fst opos) < 1 = doors . ix drid . drStatus .~ DoorOpen
| dist (fst wlpos) (fst cpos) < 1 = doors . ix drid . drStatus .~ DoorClosed
| otherwise = doors . ix drid . drStatus .~ DoorHalfway
(wlid',opos,cpos) = head wlidOpCps
wlpos = _wlLine $ _walls w IM.! wlid'
isOpen = dist (fst wlpos) (fst opos) < 1
isClosed = dist (fst wlpos) (fst cpos) < 1
toOpen = _drTrigger dr w
toOpen = _drTrigger dr w
dstatus = _drStatus dr
doOpen w' (wlid,openpos,cp) = w'
& walls . ix wlid %~ moveDoorToward speed openpos
& (\w'' -> foldr (changeZonedWall (moveDoorToward speed openpos) wlid) w'' (zoneps cp))
doClose w' (wlid,_,cp) = w' & walls . ix wlid %~ moveDoorToward speed cp
& (\w'' -> foldr (changeZonedWall (moveDoorToward speed cp) wlid) w'' (zoneps cp))
doOpen w' (wlid,openpos,cp) = mvDoorWithZone w' wlid openpos cp
doClose w' (wlid,_,cp) = mvDoorWithZone w' wlid cp cp
mvDoorWithZone w' wlid p zp = w'
& walls . ix wlid %~ moveDoorToward speed p
& (\w'' -> foldr (changeZonedWall (moveDoorToward speed p) wlid) w'' (zoneps zp))
putSingleDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World -> World
putSingleDoor isPathable col cond a b speed w = addWalls w
@@ -167,49 +155,3 @@ putSingleDoor isPathable col cond a b speed w = addWalls w
shiftLeft = (+.+ (a -.- b))
wlids = take 4 [IM.newKey $ _walls w ..]
mkTriggerDoor
:: Color
-> (World -> Bool) -- ^ Opening condition
-> [(Point2,Point2)] -- ^ List of wall position pairs, closed to open
-> [Int] -- ^ Wall ids
-> [Wall]
{-# INLINE mkTriggerDoor #-}
mkTriggerDoor c cond ppairs is = zipWith (triggerDoorPane c cond) is $
transpose $ map toPanePoints ppairs
toPanePoints :: (Point2,Point2) -> [(Point2,Point2)]
{-# INLINE toPanePoints #-}
toPanePoints (x,y) =
[ (y +.+ perp, y -.- perp)
, (y -.- perp, x -.- perp)
, (x -.- perp, x +.+ perp)
, (x +.+ perp, y +.+ perp)
]
where
perp = 9 *.* errorNormalizeV 49 ( vNormal (x -.- y))
{- |
Zoning might be an issue here.
It is necessary in the current version, but I am not sure of its behaviour. -}
triggerDoorPane
:: Color
-> (World -> Bool) -- ^ Opening condition
-> Int -- ^ Wall id
-> [(Point2,Point2)] -- ^ List of positions: closed to open
-> Wall
triggerDoorPane c cond n poss = Door
{ _wlLine = head poss
, _wlID = n
, _doorMech = dm
, _wlColor = c
, _wlSeen = False
, _wlIsSeeThrough = False
, _doorPathable = False
, _drPositions = DS.fromListL poss
}
where
dm = doorMechan n allZoneps openDoor closeDoor cond
openDoor = updatePos . (drPositions %~ DS.pushL)
closeDoor = updatePos . (drPositions %~ DS.pushR)
updatePos :: Wall -> Wall
updatePos d = d & wlLine %~ maybe id const (DS.head <$> (d ^? drPositions))
allZoneps = nub $ concatMap zoneps poss