From 88dcf7e6f1fccb0e6bd231943bb422dc61e5353a Mon Sep 17 00:00:00 2001 From: jgk Date: Sat, 27 Mar 2021 22:55:31 +0100 Subject: [PATCH 1/5] Fix bug where corridors blocked passage on 60 degree links --- src/Dodge/Creature.hs | 48 ++++++++++++++++++++----------------------- src/Dodge/Floor.hs | 2 +- src/Dodge/Rooms.hs | 4 ++-- 3 files changed, 25 insertions(+), 29 deletions(-) diff --git a/src/Dodge/Creature.hs b/src/Dodge/Creature.hs index 516414884..9a7ce956b 100644 --- a/src/Dodge/Creature.hs +++ b/src/Dodge/Creature.hs @@ -252,32 +252,28 @@ startCr = defaultCreature , _crHP = 10000 , _crMaxHP = 1500 , _crInv = IM.fromList (zip [0..20] - ( - [pistol,flameGrenade, teslaGrenade, autoGun,launcher,flameLauncher, poisonLauncher, teslaLauncher, lasGun,grenade - ,ltAutoGun,flamer,multGun,spreadGun,remoteLauncher - ,longGun - ,hvAutoGun - ,teslaGun - ,latchkey 0 - ,miniGun - ,medkit 50 - ,bezierGun - ,poisonSprayer - ,blinkGun - ] --- [pistol,autoGun,launcher,lasGun,grenade --- ,ltAutoGun,flamer,multGun,spreadGun,remoteLauncher --- ,longGun --- ,hvAutoGun --- ,teslaGun --- ,latchkey 0 --- ,miniGun --- ,medkit 50 --- ,bezierGun --- ,poisonSprayer --- ,blinkGun --- ,frontArmour --- ] + ( + [pistol + ,blinkGun + ,flameGrenade + ,teslaGrenade + ,autoGun + ,launcher + ,flameLauncher + ,poisonLauncher + ,teslaLauncher + ,lasGun + ,grenade + ,ltAutoGun,flamer,multGun,spreadGun,remoteLauncher + ,longGun + ,hvAutoGun + ,teslaGun + ,latchkey 0 + ,miniGun + ,medkit 50 + ,bezierGun + ,poisonSprayer + ] ++ repeat NoItem)) -- startInv -- ([pistol,flameGrenade, teslaGrenade, autoGun,launcher,flameLauncher, poisonLauncher, teslaLauncher, lasGun,grenade diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index f71ee3439..17c34ac08 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -43,7 +43,7 @@ lev1 = do ++ [roomCCrits] ++ [return $ connectRoom corridor ,return $ connectRoom door] - ++[roomMiniIntro] + ++[roomMiniIntro] ++ [longRoom >>= randomiseLinks] ++ [return $ connectRoom corridor ,return $ connectRoom door] diff --git a/src/Dodge/Rooms.hs b/src/Dodge/Rooms.hs index 09b46e2a1..d8b8f273e 100644 --- a/src/Dodge/Rooms.hs +++ b/src/Dodge/Rooms.hs @@ -90,8 +90,8 @@ corridor = Room , _rmBound = rectNSWE 50 30 0 40 } where lnks = [((20,70) ,0) - ,((20,80) +.+ rotateV (0-pi/3) (-20,0), pi/6) - ,((20,80) +.+ rotateV ( pi/3) ( 20,0),0-pi/6) + ,((20,80) +.+ rotateV (0-pi/3) (-10,0), pi/6) + ,((20,80) +.+ rotateV ( pi/3) ( 10,0),0-pi/6) ,((20,10) ,pi) ] corridorN :: Room From bacaded2a5dc46501c144d5bef449dba8a7c4831 Mon Sep 17 00:00:00 2001 From: jgk Date: Sat, 27 Mar 2021 23:36:39 +0100 Subject: [PATCH 2/5] Reorganise modules. Broken layout-- to be diagnosed --- src/Dodge/Creature.hs | 16 -- src/Dodge/Item/Weapon.hs | 249 ------------------- src/Dodge/Rooms.hs | 10 +- src/Dodge/WorldEvent.hs | 193 +-------------- src/Dodge/WorldEvent/Explosion.hs | 146 +++++++++++ src/Dodge/WorldEvent/HitEffect.hs | 8 + src/Dodge/WorldEvent/SpawnParticle.hs | 339 ++++++++++++++++++++++++++ 7 files changed, 502 insertions(+), 459 deletions(-) create mode 100644 src/Dodge/WorldEvent/Explosion.hs create mode 100644 src/Dodge/WorldEvent/SpawnParticle.hs diff --git a/src/Dodge/Creature.hs b/src/Dodge/Creature.hs index 9a7ce956b..8e516554e 100644 --- a/src/Dodge/Creature.hs +++ b/src/Dodge/Creature.hs @@ -245,7 +245,6 @@ startCr = defaultCreature , _crDir = 0 , _crID = 0 , _crPict = basicCrPict $ greyN 0.8 - , _crUpdate = stateUpdate yourControl , _crRad = 10 , _crMass = 10 @@ -275,21 +274,6 @@ startCr = defaultCreature ,poisonSprayer ] ++ repeat NoItem)) - -- startInv --- ([pistol,flameGrenade, teslaGrenade, autoGun,launcher,flameLauncher, poisonLauncher, teslaLauncher, lasGun,grenade --- ,ltAutoGun,flamer,multGun,spreadGun,remoteLauncher --- ,longGun --- ,hvAutoGun --- ,teslaGun --- ,latchkey 0 --- ,miniGun --- ,medkit 50 --- ,bezierGun --- ,poisonSprayer --- ,blinkGun --- ] --- ++ repeat NoItem)) --- -- startInv , _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ pictures [color (greyN 0.8) $ circleSolid 10, circLine 10] } diff --git a/src/Dodge/Item/Weapon.hs b/src/Dodge/Item/Weapon.hs index 12846e785..090f6489c 100644 --- a/src/Dodge/Item/Weapon.hs +++ b/src/Dodge/Item/Weapon.hs @@ -890,26 +890,6 @@ aGasCloud cid w vel = (_crPos cr -.- _crOldPos cr) +.+ 10 *.* unitVectorAtAngle dir insertCloud = makeGasCloud pos vel -- . makeFlame pos2 vel (Just cid) -makeGasCloud :: Point2 -> Point2 -> World -> World -makeGasCloud pos vel w = over clouds (IM.insert i theCloud) - $ set randGen g w - where i = newKey $ _clouds w - theCloud = Cloud { _clID = i - , _clPos = pos - , _clVel = vel - , _clPict = \_ -> onLayer CrLayer $ color (withAlpha 0.1 col) - $ circleSolid 20 - , _clRad = 20 - , _clTimer = 400 - , _clEffect = cloudPoisonDamage - } - (col, g) = runState (takeOne [green,yellow]) $ _randGen w - -cloudPoisonDamage :: Cloud -> World -> World -cloudPoisonDamage c w = w & creatures %~ flip (foldr (IM.adjust doDam)) damagedCrs - where damagedCrs = IM.keys $ IM.filter f $ creaturesNearPoint (_clPos c) w - f cr = dist (_crPos cr) (_clPos c) < _crRad cr + _clRad c - doDam cr = cr & crState . crDamage %~ (:) (PoisonDam 1) aFlame :: Float -> Int -> World -> World aFlame a cid w @@ -929,119 +909,7 @@ aFlame a cid w resetAngle = set (creatures . ix cid . crInv . ix (_crInvSel cr) . wpFire) (shoot $ aFlame angle) --- The following should be improved.... I've made a first pass -makePoisonExplosionAt :: Point2 -> World -> World -makePoisonExplosionAt p w = soundOnce grenadeBang $ foldr (makeGasCloud p) w vels - where - vels = evalState (sequence ( replicate 25 (randInCirc 2) )) (_randGen w) --- just change the number after replicate to get more or less clouds --- suggested change: use random positions, offset from p, rather than velocities --- so, p +.+ randomOffset --- currently the clouds push away from each other rather hard if they are close -makeTeslaExplosionAt :: Point2 -> World -> World -makeTeslaExplosionAt pos w = soundOnce grenadeBang $ foldr ($) w listOfFunctions -- a bit shorter - where - -- rad or 360? Radians (hopefully) everywhere - xs = randomRs (0, 2*pi) $ _randGen w - p = newProjectileKey w - pks = [p..] - listOfFunctions = map - (\i -> over projectiles (IM.insert (pks!!i) (makeTeslaArcAt (pks!!i) pos (xs!!i)))) - [1 .. 29] - --- slightly more work done on this one, want the flames to last for different --- times --- the new flames are directly added to the list of particles -makeFlameExplosionAt :: Point2 -> World -> World -makeFlameExplosionAt p w = soundOnce grenadeBang $ over particles' (newFlames ++ ) w - where - newFlames = zipWith makeFlameWithVelAndTime velocities timers - makeFlameWithVelAndTime vel time = aFlameParticle time p vel Nothing - velocities = evalState (sequence ( replicate 15 (randInCirc 1) )) (_randGen w) - timers = randomRs (80,100) $ _randGen w - -- the ( Nthing :: Maybe Int ) here is "maybe" a creature id that the - -- particle passes through for the first frame of its existence - --- take out the flame particle from makeFlame -aFlameParticle :: Int -> Point2 -> Point2 -> Maybe Int -> Particle' -aFlameParticle t pos vel maycid = Pt' - { _ptDraw = drawFlame vel - , _ptUpdate' = moveFlame vel - , _btVel' = vel - , _btColor' = red - , _btPos' = pos - , _btPassThrough' = maycid - , _btWidth' = 4 - , _btTimer' = t - , _btHitEffect' = destroyOnImpact (doFlameDam 1) noEff noEff - } - -makeFlame :: Point2 -> Point2 -> Maybe Int -> World -> World -makeFlame pos vel maycid = over particles' (aFlameParticle 100 pos vel maycid : ) - -drawFlame :: Point2 -> Particle' -> Picture -drawFlame rotd pt = thePic - where ep = _btPos' pt - thePic = pictures - [ glow - , aPic prot2 0.2998 (scaleChange + 1,2) red - , aPic prot 0.2996 (scaleChange + 0.5,1.5) orange - , aPic prot3 0.2994 (scaleChange,1) white - ] - aPic :: (Point2 -> Point2) -> Float -> Point2 -> Color -> Picture - aPic offset depth (scalex,scaley) col - = setLayer 1 - . setDepth depth - . uncurry translate (offset ep) - . rotate (pi * 0.5 + argV rotd) - . scale scalex scaley - . color col - $ circleSolid 5 - glow = setLayer 1 $ setDepth 0.3 $ uncurry translate ep - $ circleSolidCol (withAlpha 0 orange) (withAlpha 0.02 orange) 50 - time = _btTimer' pt - scaleChange | time < 80 = 3 - | otherwise = 3 - (fromIntegral time - 80) * 0.2 - prot p' = p' +.+ rotateV (fromIntegral time * 1) (0,1) - prot2 p' = p' +.+ rotateV (negate $ fromIntegral time * 1) (0,1) - prot3 p' = p' +.+ rotateV (2 + fromIntegral time * 0.1) (0,2) - -moveFlame :: Point2 -> World -> Particle' -> (World, Maybe Particle') -moveFlame rotd w pt - | time <= 0 = (smokeGen w, Nothing) - | otherwise = case thingsHitExceptCr (_btPassThrough' pt) sp ep w of - ((p,(E3x1 cr)):_) -> (soundAndGlare damcrs , mvPt') - (thing@(p,(E3x2 wl)):_) -> (fst $ hiteff [thing] damcrs , rfl wl p) - _ -> (soundAndGlare damcrs , mvPt) - where time = _btTimer' pt - soundAndGlare = soundFrom Flame fireSound 2 500 - . over worldEvents ((.) $ flameGlareAt ep) - sp = _btPos' pt - vel = _btVel' pt - ep = sp +.+ vel - mvPt = Just $ pt {_btTimer' = time - 1, _btPos' = ep - , _btPassThrough' = Nothing - ,_btVel' = 0.98 *.* vel} - mvPt' = Just $ pt {_btTimer' = time - 1, _btPos' = ep - , _btPassThrough' = Nothing - ,_btVel' = 0.7 *.* vel} - damcrs = foldr ($) w $ map (\cr -> fst . hiteff [(ep,E3x1 cr)]) $ filter closeCrs - $ IM.elems $ _creatures w - closeCrs cr = dist ep (_crPos cr) - < _crRad cr + 10 - min 9 (max 0 (fromIntegral time - 80)) - + 5 * angleCoeff (angleVV (ep -.- _crPos cr) rotd) - angleCoeff x = abs $ 1 - (abs $ (x * 2 - pi) / (pi)) - hiteff = _btHitEffect' pt pt - rfl wl p = Just $ pt {_btTimer' = time -1, _btPos' = pOut p - , _btVel' = reflV wl--, _ptDraw = const $ thepic $ pOut p - } - pOut p = p +.+ safeNormalizeV (sp -.- p) - reflV wall = (0.3 *.* reflectIn (_wlLine wall !! 1 -.- _wlLine wall !! 0) - vel ) - +.+ - (0.2 *.* vel) - smokeGen = makeFlamerSmokeAt ep flamerAngle = 0.3 @@ -1663,123 +1531,6 @@ remoteBombUnarmedPic :: Picture remoteBombUnarmedPic = color (dark $ dark orange) $ circleSolid 5 -makeTeslaArcAt :: Int -> Point2 -> Float -> Projectile -makeTeslaArcAt i pos dir = Projectile - { _ptPos = pos - , _ptStartPos = pos - , _ptVel = (0,0) - , _ptPict = onLayer PtLayer $ line [(0,0),(0,0)] - , _ptID = i - , _ptUpdate = moveTeslaArc pos dir i - } - -moveTeslaArc :: Point2 -> Float -> Int -> World -> World -moveTeslaArc p d i w = - set (projectiles . ix i . ptPict) pic - $ set (projectiles . ix i . ptUpdate) - (ptTimer 2 i) - $ set randGen g - $ createSpark 8 nc q2 (argV sv + d1) Nothing - $ foldr damCrs w hitCrs - where pic = setLayer 1 $ pictures - [ onLayer PtLayer $ color (f2 nc) $ line ps' - , onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 20 ps' - , onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 25 ps' - , onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 30 ps' - ] - ps' = lightningMids d pers ps - ps = take 15 $ p : map f (crsLightChain p d 0 w) - f (E3x1 cr) = _crPos cr - f (E3x2 p1) = p1 - f (E3x3 p1) = p1 - pers = evalState (sequence $ repeat $ randInCirc 5) $ _randGen w - (nc,g) = randomR (0::Int,11) $ _randGen w - f1 (E3x1 cr) = Just $ _crID cr - f1 _ = Nothing - hitCrs = mapMaybe f1 $ take 14 $ crsLightChain p d 0 w - damCrs i = over (creatures . ix i . crHP) (\hp -> hp - 5) - f2 0 = cyan - f2 1 = azure - f2 _ = white - sID = newProjectileKey w - q1 = last $ init ps' - q2 = last ps' - hitWall = collidePointWalls q1 ((2 *.* q2) -.- q1) $ wallsNearPoint q1 w - (d1,_) = randomR (-0.7,0.7) $ _randGen w - sv = fromMaybe (q2 -.- q1) $ fmap snd hitWall - -lightningMid :: Float -> Point2 -> Point2 -> Point2 -lightningMid d p1 p2 = (0.25 *.* (p1 +.+ p2)) +.+ 0.5 *.* p3 - where p3 = errorClosestPointOnLine 1 p1 (p1 +.+ unitVectorAtAngle d) p2 - -lightningMids :: Float -> [Point2] -> [Point2] -> [Point2] -lightningMids d1 (p:pers) (p1:p3:ps) - = let p2 = p +.+ lightningMid d1 p1 p3 - d2 = argV $ p3 -.- p2 - in p1 : p2 : lightningMids d2 pers (p3:ps) -lightningMids _ _ ps = ps - -crsLightChain' :: Point2 -> Float -> World -> [Either3 Creature Point2 Point2] -crsLightChain' p d w - = case crOrWall p d w of - E3x1 cr -> E3x1 cr : crsLightChain' (_crPos cr) (argV (_crPos cr -.- p)) w - E3x2 p1 -> [E3x2 p1] - E3x3 p1 -> E3x3 p1 : crsLightChain' p1 (dChange + argV (p1 -.- p)) (set randGen g w) - -- where (dChange, g) = (0, _randGen w) - where (dChange, g) = randomR (-0.05,0.05) $ _randGen w - -crsLightChain :: Point2 -> Float -> Float -> World -> [Either3 Creature Point2 Point2] -crsLightChain p d wlAttract w - = case crOrWallSensitive p d wlAttract w of - E3x1 cr -> E3x1 cr : crsLightChain (_crPos cr) (argV (_crPos cr -.- p)) - (min 1 (wlAttract + 0.3)) w - E3x2 p1 -> [E3x2 p1] - E3x3 p1 -> E3x3 p1 : crsLightChain p1 (dChange + argV (p1 -.- p)) (min 1 (wlAttract + 0.3)) (set randGen g w) - -- where (dChange, g) = (0, _randGen w) - where (dChange, g) = randomR (-0.05,0.05) $ _randGen w - -crOrWallSensitive :: Point2 -> Float -> Float -> World -> Either3 Creature Point2 Point2 -crOrWallSensitive p dir wlAttract w = fromMaybe (E3x3 $ p +.+ rotateV dir (arcLen,0)) - $ listToMaybe $ sortBy (compare `on` g) - $ catMaybes [cr,wlp] - where cr = fmap E3x1 $ nearestCrInFront p dir 100 w - wlp = fmap E3x2 $ listToMaybe - $ sortBy (compare `on` dist p) - $ mapMaybe - ( fmap fst - . (\p1 -> collidePointWalls p p1 $ wallsNearPoint p w) - . (+.+) p - . (\d -> rotateV d (100,0)) - . (+) dir - ) - (fmap (*wlAttract) [-(3*pi/8),-pi/4,-pi/8,0,pi/8,pi/4,3*pi/8]) - --[-pi/4,-pi/8,0,pi/8,pi/4] - g (E3x2 p1) = 100 + dist p p1 -- tweak makes it more likely to hit crs first - --g (E3x2 p1) = dist p p1 - 100 -- tweak makes it more likely to hit walls first - g (E3x1 cr1) = dist p $ _crPos cr1 - (arcLen,_) = randomR (25,50) $ _randGen w --- BUG: can hit crs through walls - -crOrWall :: Point2 -> Float -> World -> Either3 Creature Point2 Point2 -crOrWall p dir w = fromMaybe (E3x3 $ p +.+ rotateV dir (arcLen,0)) - $ listToMaybe $ sortBy (compare `on` g) - $ catMaybes [cr,wlp] - where cr = fmap E3x1 $ nearestCrInFront p dir 100 w - wlp = fmap E3x2 $ listToMaybe - $ sortBy (compare `on` dist p) - $ mapMaybe - ( fmap fst - . (\p1 -> collidePointWalls p p1 $ wallsNearPoint p w) - . (+.+) p - . (\d -> rotateV d (100,0)) - . (+) dir - ) - [-(3*pi/8),-pi/4,-pi/8,0,pi/8,pi/4,3*pi/8] - --[-pi/4,-pi/8,0,pi/8,pi/4] - g (E3x2 p1) = 100 + dist p p1 -- tweak makes it more likely to hit crs first - --g (E3x2 p1) = dist p p1 - 100 -- tweak makes it more likely to hit walls first - g (E3x1 cr1) = dist p $ _crPos cr1 - (arcLen,_) = randomR (25,50) $ _randGen w spreadGunSpread,autogunSpread :: Float spreadGunSpread = 0.5 diff --git a/src/Dodge/Rooms.hs b/src/Dodge/Rooms.hs index d8b8f273e..eae5c6180 100644 --- a/src/Dodge/Rooms.hs +++ b/src/Dodge/Rooms.hs @@ -256,7 +256,7 @@ glassSwitchBack = do ,blockLine (wth-wllen, 2*hf) ( wth,2*hf) ,blockLine ( 0, 3*hf) (wllen,3*hf) ,blockLine (wth-wllen, 4*hf) ( wth,4*hf) - , PS (wth/2,hgt/2) 0 $ PutCrit lamp + , PS (wth/2,hgt/2) 0 $ putLamp ] return $ set rmPS plmnts $ roomRect' wth hgt 2 6 @@ -494,14 +494,13 @@ weaponLongCorridor = do i2 <- state $ randomR (2,5) let branch1 = treeTrunk (replicate i1 $ Left corridor) (connectRoom $ putCrs connectingRoom) let branch2 = treeTrunk (replicate i2 $ Left corridor) (deadRoom $ putWp corridorN) - return $ Node (Left $ addLS root) [branch1,branch2] + return $ Node (Left root) [branch1,branch2] where putCrs = set rmPS [PS (10,40) (-pi/2) $ randC ,PS (-10,40) (-pi/2) $ randC ] putWp = set rmPS [PS (20,40) 0 $ RandPS randFirstWeapon ,PS (20,60) 0 $ putLamp ] - addLS = id -- set rmPS [PS (0,60) 0 $ putLamp] critInDeadEnd :: Room critInDeadEnd = set rmPS [PS (0,0) 0 $ randC] deadEndRoom @@ -531,10 +530,11 @@ weaponRoom = do roomCCrits :: RandomGen g => State g (Tree (Either Room Room)) roomCCrits = do - ps <- sequence $ replicate 25 $ randInCirc 9 + ps <- sequence $ replicate 20 $ randInCirc 9 let plmnts = map (\p -> PS p 0 $ randC) $ zipWith (+.+) [(x,y) | x<-[110,130,150,170,190], y<- [70,90,110,130,150]] ps - return $ connectRoom $ over rmPS (++plmnts) $ roomC 200 200 + lamps = [PS (50,100) 0 putLamp , PS (175,100) 0 putLamp] + return $ connectRoom $ over rmPS ((lamps ++) . (plmnts ++)) $ roomC 200 200 branchRectWith :: RandomGen g => State g (Tree (Either Room Room)) -> State g (Tree (Either Room Room)) branchRectWith t = do diff --git a/src/Dodge/WorldEvent.hs b/src/Dodge/WorldEvent.hs index e117c2040..a09ee41e0 100644 --- a/src/Dodge/WorldEvent.hs +++ b/src/Dodge/WorldEvent.hs @@ -6,6 +6,8 @@ module Dodge.WorldEvent , module Dodge.WorldEvent.HelperParticle , module Dodge.WorldEvent.Cloud , module Dodge.WorldEvent.HitEffect + , module Dodge.WorldEvent.Explosion + , module Dodge.WorldEvent.SpawnParticle ) where @@ -15,6 +17,8 @@ import Dodge.WorldEvent.ThingsHit import Dodge.WorldEvent.HelperParticle import Dodge.WorldEvent.Cloud import Dodge.WorldEvent.HitEffect +import Dodge.WorldEvent.Explosion +import Dodge.WorldEvent.SpawnParticle import Dodge.LightSources import Dodge.Data @@ -34,25 +38,6 @@ import Data.Function import Data.List import qualified Data.IntMap.Strict as IM -makeExplosionAt :: Point2 -> World -> World -makeExplosionAt p w = soundOnce grenadeBang - . addFlames - . explosionFlashAt p - $ makeShockwaveAt p 50 10 1 white - w - where fVs = fst $ runState ((sequence . take 75 . repeat . randInCirc) 1) $ _randGen w - fPs' = evalState ((sequence . take 75 . repeat . randInCirc) 15) $ _randGen w - fPs = map (pushAgainstWalls . (+.+) p . (*.*) 0.5) - fPs' - inversePushOut v = (15 - magV v) * 0.01 *.* v - fVs' = zipWith (+.+) fVs $ map inversePushOut fPs' - sizes = randomRs (2,6) $ _randGen w - times = randomRs (20,25) $ _randGen w - mF q v size time = makeFlameletTimed q v Nothing size time - newFs = zipWith4 mF fPs (fmap (3 *.*) fVs') sizes times - addFlames w = foldr ($) w newFs - pushAgainstWalls q = fromMaybe q $ fmap (\(x,y)-> x +.+ y) - $ collidePointWalls p q $ wallsNearPoint q w shockWaveDamage :: Point2 -> Float -> Int -> World -> World shockWaveDamage p rad amount w = flip (foldr damageBlocks) hitBlocks $ over creatures (IM.map f) w @@ -67,75 +52,6 @@ shockWaveDamage p rad amount w = flip (foldr damageBlocks) hitBlocks $ over crea (_blIDs wall) _ -> w -makeShockwaveAt :: Point2 -> Float -> Int -> Float -> Color - -> World -> World -makeShockwaveAt p rad dam push col = over particles' ((:) theShockwave) - where theShockwave = shockwaveAt p rad dam push col 10 - -shockwaveAt :: Point2 -> Float -> Int -> Float -> Color -> Int -> Particle' -shockwaveAt p rad dam push col maxtime - = Shockwave' - { _ptDraw = const blank - , _ptUpdate' = mvShockwave' - , _btColor' = col - , _btPos' = p - , _btRad' = rad - , _btDam' = dam - , _btPush' = push - , _btMaxTime' = maxtime - , _btTimer' = maxtime - } - -mvShockwave' :: World -> Particle' -> (World, Maybe Particle') -mvShockwave' w pt - | _btTimer' pt <= 0 = (w, Nothing) - | otherwise - = (dams w , Just $ set btTimer' (t - 1) $ set ptDraw (const pic) pt) - where r = _btRad' pt - p = _btPos' pt - push = _btPush' pt - dam = _btDam' pt - t = _btTimer' pt - tFraction = fromIntegral t / fromIntegral (_btMaxTime' pt) - pic = onLayer PtLayer $ uncurry translate p - $ color (_btColor' pt) $ thickCircle rad thickness - rad = r - (3/4) * r * tFraction - thickness = tFraction**2 * r - dams = over creatures (IM.map damCr) . flip (foldr damageBlocks) hitBlocks - hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w - damageBlocks wall w - = case wall ^? blHP of - Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 1)) - w - (_blIDs wall) - _ -> w - damCr cr | dist (_crPos cr) p < rad + _crRad cr - = over (crState . crDamage) - ((:) $ PushDam dam (25 * push *.* safeNormalizeV (_crPos cr -.- p))) - cr - | otherwise = cr -moveShockWave :: Int -> Point2 -> Float -> Float -> Float -> World -> Particle' -> (World, Maybe Particle') -moveShockWave 0 _ _ _ _ w _ = (w, Nothing) -moveShockWave t p r push pushexp w pt - = (dams w, Just $ newupdate $ newpic pt ) - where newupdate = set ptUpdate' $ moveShockWave (t-1) p r push pushexp - newpic = set ptDraw (const $ onLayer PtLayer $ uncurry translate p - $ color cyan $ thickCircle rad thickness) - rad = r - (3/40) * r * fromIntegral t - thickness = (fromIntegral t)**2 * rad / 40 - dams = over creatures (IM.map damCr) . flip (foldr damageBlocks) hitBlocks - hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w - damageBlocks wall w - = case wall ^? blHP of - Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 1)) - w - (_blIDs wall) - _ -> w - damCr cr | dist (_crPos cr) p < rad + _crRad cr - = over (crState . crDamage) - ((:) $ PushDam 1 (25 *.* safeNormalizeV (_crPos cr -.- p))) - cr - | otherwise = cr inverseShockwaveAt :: Point2 -> Float -> Int -> Float -> Float -> World -> World inverseShockwaveAt p rad dam push pushexp = over particles' ((:) theShockwave) @@ -167,33 +83,6 @@ moveInverseShockWave t p r push pushexp w pt cr | otherwise = cr --- if the spark is created by another Particle', it cannot be directly added to --- the list, hence the redirect through worldEvents -createSpark :: Int -> Int -> Point2 -> Float -> Maybe Int -> World -> World -createSpark time colid pos dir maycid w = over worldEvents - ((.) $ ( over particles' ((:) spark) --- . flareAt' white 0.02 0.05 pos') - . sparkFlashAt pos') - ) w - where spark = Bul' { _ptDraw = drawBul - , _ptUpdate' = mvGenBullet' - , _btVel' = rotateV dir (5,0) - , _btColor' = numColor colid - , _btTrail' = [pos] - , _btPassThrough' = maycid - , _btWidth' = 1 - , _btTimer' = time - , _btHitEffect' = destroyOnImpact sparkEff noEff noEff - } - x = fst $ randomR (0,20) $ _randGen w - pos' = pos +.+ rotateV dir (x,0) - sparkEff bt p cr = over (creatures . ix (_crID cr) . crState . crDamage) - ((:) $ SparkDam 1 sp p ep) - where sp = head (_btTrail' bt) - ep = sp +.+ _btVel' bt - -drawBul :: Particle' -> Picture -drawBul pt = setLayer 1 . color white $ thickLine (take 2 $ _btTrail' pt) (_btWidth' pt) createBarrelSpark :: Int -> Int -> Point2 -> Float -> Maybe Int -> World -> World createBarrelSpark time colid pos dir maycid w = over worldEvents @@ -217,83 +106,9 @@ createBarrelSpark time colid pos dir maycid w = over worldEvents where sp = head (_btTrail' bt) ep = sp +.+ _btVel' bt -noEff _ _ _ = id -makeFlameletTimed :: Point2 -> Point2 -> Maybe Int -> Float -> Int -> World -> World -makeFlameletTimed pos vel maycid size time w - = set randGen g $ over particles' ((:) theFlamelet) w - where theFlamelet = - Pt' { _ptDraw = drawFlamelet rot - , _ptUpdate' = moveFlamelet - , _btVel' = vel - , _btColor' = red - , _btPos' = pos - , _btPassThrough' = maycid - , _btWidth' = size - , _btTimer' = time - , _btHitEffect' = destroyOnImpact (doFlameDam 1) noEff noEff - } - (rot ,g) = randomR (0,3) $ _randGen w - -drawFlamelet :: Float -> Particle' -> Picture -drawFlamelet rot pt = setLayer 1 $ pictures [pic , piu , pi2 , glow] - where - sp = _btPos' pt - vel = _btVel' pt - ep = sp +.+ vel - size = _btWidth' pt - siz2 = size + 0.2 - time = _btTimer' pt - glow = setDepth 0.336 $ uncurry translate ep - $ circleSolidCol (withAlpha 0 red) (withAlpha 0.05 red) 30 - piu = setDepth 0.334 $ uncurry translate ep - $ color (dark red) $ rotate (0 - (rot - 0.1 * fromIntegral time)) - $ scale s1 s1 - $ polygon $ rectNSWE (siz2) (-siz2) (-siz2) (siz2) - pi2 = setDepth 0.332 $ uncurry translate ep - $ color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time) - orange (dark red) - ) - $ rotate (0 - (rot + 0.2 * fromIntegral time)) - $ scale s2 s2 - $ polygon $ rectNSWE (siz2) (-siz2) (-siz2) (siz2) - pic = setDepth 0.33 $ uncurry translate ep - $ color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time) - white (dark red) - ) - $ rotate (0 - ( 0.1 * fromIntegral time + rot)) - $ scale sc sc - $ polygon [(-size,-size),(size,-size),(size,size),(-size,size)] - sc = (*) 2 $ log $ 1 + fromIntegral time / 20 - s1 = (*) 2 $ log $ 2 + fromIntegral time / 40 - s2 = 0.5 * (sc + s1) - thepicture = pictures [pic , piu , pi2 , glow] - -moveFlamelet :: World -> Particle' -> (World, Maybe Particle') -moveFlamelet w pt - | _btTimer' pt <= 0 = ( w, Nothing) - | otherwise = (damcrs, mvPt) - where - sp = _btPos' pt - vel = _btVel' pt - ep = sp +.+ vel - size = _btWidth' pt - mvPt = Just $ pt & btTimer' -~ 1 - & btPos' .~ ep - & btPassThrough' .~ Nothing - & btVel' .~ 0.8 *.* vel - damcrs = foldr ($) w $ map dodam $ filter closeCrs $ IM.elems $ _creatures w - closeCrs cr = dist ep (_crPos cr) < _crRad cr + size - dodam cr = over (creatures . ix (_crID cr) . crState . crDamage) - ((:) $ Flaming 3 sp ep ep) -doFlameDam :: Int -> Particle' -> Point2 -> Creature -> World -> World -doFlameDam amount pt p cr = over (creatures . ix (_crID cr) . crState . crDamage) - ((:) $ Flaming amount sp p ep) - where sp = _btPos' pt - ep = sp +.+ _btVel' pt - damCrsOnLine :: Int -> Point2 -> Point2 -> World -> World damCrsOnLine dam p1 p2 = over creatures (IM.map damIfOnLine) where damIfOnLine cr | circOnLine p1 p2 (_crPos cr) (_crRad cr) diff --git a/src/Dodge/WorldEvent/Explosion.hs b/src/Dodge/WorldEvent/Explosion.hs new file mode 100644 index 000000000..6f0621907 --- /dev/null +++ b/src/Dodge/WorldEvent/Explosion.hs @@ -0,0 +1,146 @@ +module Dodge.WorldEvent.Explosion + where + +import Dodge.Data +import Dodge.Base +import Dodge.WorldEvent.SpawnParticle +import Dodge.WorldEvent.Flash +import Dodge.RandomHelp +import Dodge.SoundLogic + +import Geometry +import Picture + +import Control.Monad.State +import Data.List +import Data.Maybe +import System.Random +import qualified Data.IntMap.Strict as IM +import Control.Lens + +-- The following should be improved.... I've made a first pass +makePoisonExplosionAt :: Point2 -> World -> World +makePoisonExplosionAt p w = soundOnce grenadeBang $ foldr (makeGasCloud p) w vels + where + vels = evalState (sequence ( replicate 25 (randInCirc 2) )) (_randGen w) +-- just change the number after replicate to get more or less clouds +-- suggested change: use random positions, offset from p, rather than velocities +-- so, p +.+ randomOffset +-- currently the clouds push away from each other rather hard if they are close + +makeTeslaExplosionAt :: Point2 -> World -> World +makeTeslaExplosionAt pos w = soundOnce grenadeBang $ foldr ($) w listOfFunctions -- a bit shorter + where + -- rad or 360? Radians (hopefully) everywhere + xs = randomRs (0, 2*pi) $ _randGen w + p = newProjectileKey w + pks = [p..] + listOfFunctions = map + (\i -> over projectiles (IM.insert (pks!!i) (makeTeslaArcAt (pks!!i) pos (xs!!i)))) + [1 .. 29] + +-- slightly more work done on this one, want the flames to last for different +-- times +-- the new flames are directly added to the list of particles +makeFlameExplosionAt :: Point2 -> World -> World +makeFlameExplosionAt p w = soundOnce grenadeBang $ over particles' (newFlames ++ ) w + where + newFlames = zipWith makeFlameWithVelAndTime velocities timers + makeFlameWithVelAndTime vel time = aFlameParticle time p vel Nothing + velocities = evalState (sequence ( replicate 15 (randInCirc 1) )) (_randGen w) + timers = randomRs (80,100) $ _randGen w + -- the ( Nthing :: Maybe Int ) here is "maybe" a creature id that the + -- particle passes through for the first frame of its existence + + +makeExplosionAt :: Point2 -> World -> World +makeExplosionAt p w = soundOnce grenadeBang + . addFlames + . explosionFlashAt p + $ makeShockwaveAt p 50 10 1 white + w + where + fVs = fst $ runState ((sequence . take 75 . repeat . randInCirc) 1) $ _randGen w + fPs' = evalState ((sequence . take 75 . repeat . randInCirc) 15) $ _randGen w + fPs = map (pushAgainstWalls . (+.+) p . (*.*) 0.5) + fPs' + inversePushOut v = (15 - magV v) * 0.01 *.* v + fVs' = zipWith (+.+) fVs $ map inversePushOut fPs' + sizes = randomRs (2,6) $ _randGen w + times = randomRs (20,25) $ _randGen w + mF q v size time = makeFlameletTimed q v Nothing size time + newFs = zipWith4 mF fPs (fmap (3 *.*) fVs') sizes times + addFlames w = foldr ($) w newFs + pushAgainstWalls q = fromMaybe q $ fmap (\(x,y)-> x +.+ y) + $ collidePointWalls p q $ wallsNearPoint q w + +makeShockwaveAt :: Point2 -> Float -> Int -> Float -> Color + -> World -> World +makeShockwaveAt p rad dam push col = over particles' ((:) theShockwave) + where theShockwave = shockwaveAt p rad dam push col 10 + +shockwaveAt :: Point2 -> Float -> Int -> Float -> Color -> Int -> Particle' +shockwaveAt p rad dam push col maxtime + = Shockwave' + { _ptDraw = const blank + , _ptUpdate' = mvShockwave' + , _btColor' = col + , _btPos' = p + , _btRad' = rad + , _btDam' = dam + , _btPush' = push + , _btMaxTime' = maxtime + , _btTimer' = maxtime + } + +mvShockwave' :: World -> Particle' -> (World, Maybe Particle') +mvShockwave' w pt + | _btTimer' pt <= 0 = (w, Nothing) + | otherwise + = (dams w , Just $ set btTimer' (t - 1) $ set ptDraw (const pic) pt) + where + r = _btRad' pt + p = _btPos' pt + push = _btPush' pt + dam = _btDam' pt + t = _btTimer' pt + tFraction = fromIntegral t / fromIntegral (_btMaxTime' pt) + pic = onLayer PtLayer $ uncurry translate p + $ color (_btColor' pt) $ thickCircle rad thickness + rad = r - (3/4) * r * tFraction + thickness = tFraction**2 * r + dams = over creatures (IM.map damCr) . flip (foldr damageBlocks) hitBlocks + hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w + damageBlocks wall w + = case wall ^? blHP of + Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 1)) + w + (_blIDs wall) + _ -> w + damCr cr | dist (_crPos cr) p < rad + _crRad cr + = over (crState . crDamage) + ((:) $ PushDam dam (25 * push *.* safeNormalizeV (_crPos cr -.- p))) + cr + | otherwise = cr +moveShockWave :: Int -> Point2 -> Float -> Float -> Float -> World -> Particle' -> (World, Maybe Particle') +moveShockWave 0 _ _ _ _ w _ = (w, Nothing) +moveShockWave t p r push pushexp w pt + = (dams w, Just $ newupdate $ newpic pt ) + where newupdate = set ptUpdate' $ moveShockWave (t-1) p r push pushexp + newpic = set ptDraw (const $ onLayer PtLayer $ uncurry translate p + $ color cyan $ thickCircle rad thickness) + rad = r - (3/40) * r * fromIntegral t + thickness = (fromIntegral t)**2 * rad / 40 + dams = over creatures (IM.map damCr) . flip (foldr damageBlocks) hitBlocks + hitBlocks = wallsOnCirc p rad $ wallsNearPoint p w + damageBlocks wall w + = case wall ^? blHP of + Just hp -> foldr (\j -> over (walls . ix j . blHP) (\y -> y - 1)) + w + (_blIDs wall) + _ -> w + damCr cr | dist (_crPos cr) p < rad + _crRad cr + = over (crState . crDamage) + ((:) $ PushDam 1 (25 *.* safeNormalizeV (_crPos cr -.- p))) + cr + | otherwise = cr diff --git a/src/Dodge/WorldEvent/HitEffect.hs b/src/Dodge/WorldEvent/HitEffect.hs index ddcd9988d..498cadea0 100644 --- a/src/Dodge/WorldEvent/HitEffect.hs +++ b/src/Dodge/WorldEvent/HitEffect.hs @@ -56,3 +56,11 @@ penWalls crEff wlEff ffEff pt hitThings w = case hitThings of trl = _btTrail' pt wth = _btWidth' pt newP = head trl +.+ _btVel' pt + +doFlameDam :: Int -> Particle' -> Point2 -> Creature -> World -> World +doFlameDam amount pt p cr = over (creatures . ix (_crID cr) . crState . crDamage) + ((:) $ Flaming amount sp p ep) + where sp = _btPos' pt + ep = sp +.+ _btVel' pt + +noEff _ _ _ = id diff --git a/src/Dodge/WorldEvent/SpawnParticle.hs b/src/Dodge/WorldEvent/SpawnParticle.hs new file mode 100644 index 000000000..7de8c174e --- /dev/null +++ b/src/Dodge/WorldEvent/SpawnParticle.hs @@ -0,0 +1,339 @@ +module Dodge.WorldEvent.SpawnParticle + where +import Dodge.Data +import Dodge.Base +import Dodge.WorldEvent.HitEffect +import Dodge.WorldEvent.ThingsHit +import Dodge.WorldEvent.Cloud +import Dodge.WorldEvent.Flash +import Dodge.WorldEvent.HelperParticle +import Dodge.WorldEvent.Bullet +import Dodge.SoundLogic +import Dodge.RandomHelp +import Dodge.Debug + +import Picture +import Geometry + +import Control.Lens +import qualified Data.IntMap.Strict as IM +import System.Random +import Control.Monad.State +import Data.Function (on) +import Data.List +import Data.Maybe + +-- take out the flame particle from makeFlame +aFlameParticle :: Int -> Point2 -> Point2 -> Maybe Int -> Particle' +aFlameParticle t pos vel maycid = Pt' + { _ptDraw = drawFlame vel + , _ptUpdate' = moveFlame vel + , _btVel' = vel + , _btColor' = red + , _btPos' = pos + , _btPassThrough' = maycid + , _btWidth' = 4 + , _btTimer' = t + , _btHitEffect' = destroyOnImpact (doFlameDam 1) noEff noEff + } + +makeFlame :: Point2 -> Point2 -> Maybe Int -> World -> World +makeFlame pos vel maycid = over particles' (aFlameParticle 100 pos vel maycid : ) + +drawFlame :: Point2 -> Particle' -> Picture +drawFlame rotd pt = thePic + where ep = _btPos' pt + thePic = pictures + [ glow + , aPic prot2 0.2998 (scaleChange + 1,2) red + , aPic prot 0.2996 (scaleChange + 0.5,1.5) orange + , aPic prot3 0.2994 (scaleChange,1) white + ] + aPic :: (Point2 -> Point2) -> Float -> Point2 -> Color -> Picture + aPic offset depth (scalex,scaley) col + = setLayer 1 + . setDepth depth + . uncurry translate (offset ep) + . rotate (pi * 0.5 + argV rotd) + . scale scalex scaley + . color col + $ circleSolid 5 + glow = setLayer 1 $ setDepth 0.3 $ uncurry translate ep + $ circleSolidCol (withAlpha 0 orange) (withAlpha 0.02 orange) 50 + time = _btTimer' pt + scaleChange | time < 80 = 3 + | otherwise = 3 - (fromIntegral time - 80) * 0.2 + prot p' = p' +.+ rotateV (fromIntegral time * 1) (0,1) + prot2 p' = p' +.+ rotateV (negate $ fromIntegral time * 1) (0,1) + prot3 p' = p' +.+ rotateV (2 + fromIntegral time * 0.1) (0,2) + +moveFlame :: Point2 -> World -> Particle' -> (World, Maybe Particle') +moveFlame rotd w pt + | time <= 0 = (smokeGen w, Nothing) + | otherwise = case thingsHitExceptCr (_btPassThrough' pt) sp ep w of + ((p,(E3x1 cr)):_) -> (soundAndGlare damcrs , mvPt') + (thing@(p,(E3x2 wl)):_) -> (fst $ hiteff [thing] damcrs , rfl wl p) + _ -> (soundAndGlare damcrs , mvPt) + where time = _btTimer' pt + soundAndGlare = soundFrom Flame fireSound 2 500 + . over worldEvents ((.) $ flameGlareAt ep) + sp = _btPos' pt + vel = _btVel' pt + ep = sp +.+ vel + mvPt = Just $ pt {_btTimer' = time - 1, _btPos' = ep + , _btPassThrough' = Nothing + ,_btVel' = 0.98 *.* vel} + mvPt' = Just $ pt {_btTimer' = time - 1, _btPos' = ep + , _btPassThrough' = Nothing + ,_btVel' = 0.7 *.* vel} + damcrs = foldr ($) w $ map (\cr -> fst . hiteff [(ep,E3x1 cr)]) $ filter closeCrs + $ IM.elems $ _creatures w + closeCrs cr = dist ep (_crPos cr) + < _crRad cr + 10 - min 9 (max 0 (fromIntegral time - 80)) + + 5 * angleCoeff (angleVV (ep -.- _crPos cr) rotd) + angleCoeff x = abs $ 1 - (abs $ (x * 2 - pi) / (pi)) + hiteff = _btHitEffect' pt pt + rfl wl p = Just $ pt {_btTimer' = time -1, _btPos' = pOut p + , _btVel' = reflV wl--, _ptDraw = const $ thepic $ pOut p + } + pOut p = p +.+ safeNormalizeV (sp -.- p) + reflV wall = (0.3 *.* reflectIn (_wlLine wall !! 1 -.- _wlLine wall !! 0) + vel ) + +.+ + (0.2 *.* vel) + smokeGen = makeFlamerSmokeAt ep + +makeFlameletTimed :: Point2 -> Point2 -> Maybe Int -> Float -> Int -> World -> World +makeFlameletTimed pos vel maycid size time w + = set randGen g $ over particles' ((:) theFlamelet) w + where theFlamelet = + Pt' { _ptDraw = drawFlamelet rot + , _ptUpdate' = moveFlamelet + , _btVel' = vel + , _btColor' = red + , _btPos' = pos + , _btPassThrough' = maycid + , _btWidth' = size + , _btTimer' = time + , _btHitEffect' = destroyOnImpact (doFlameDam 1) noEff noEff + } + (rot ,g) = randomR (0,3) $ _randGen w + +drawFlamelet :: Float -> Particle' -> Picture +drawFlamelet rot pt = setLayer 1 $ pictures [pic , piu , pi2 , glow] + where + sp = _btPos' pt + vel = _btVel' pt + ep = sp +.+ vel + size = _btWidth' pt + siz2 = size + 0.2 + time = _btTimer' pt + glow = setDepth 0.336 $ uncurry translate ep + $ circleSolidCol (withAlpha 0 red) (withAlpha 0.05 red) 30 + piu = setDepth 0.334 $ uncurry translate ep + $ color (dark red) $ rotate (0 - (rot - 0.1 * fromIntegral time)) + $ scale s1 s1 + $ polygon $ rectNSWE (siz2) (-siz2) (-siz2) (siz2) + pi2 = setDepth 0.332 $ uncurry translate ep + $ color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time) + orange (dark red) + ) + $ rotate (0 - (rot + 0.2 * fromIntegral time)) + $ scale s2 s2 + $ polygon $ rectNSWE (siz2) (-siz2) (-siz2) (siz2) + pic = setDepth 0.33 $ uncurry translate ep + $ color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time) + white (dark red) + ) + $ rotate (0 - ( 0.1 * fromIntegral time + rot)) + $ scale sc sc + $ polygon [(-size,-size),(size,-size),(size,size),(-size,size)] + sc = (*) 2 $ log $ 1 + fromIntegral time / 20 + s1 = (*) 2 $ log $ 2 + fromIntegral time / 40 + s2 = 0.5 * (sc + s1) + thepicture = pictures [pic , piu , pi2 , glow] + +moveFlamelet :: World -> Particle' -> (World, Maybe Particle') +moveFlamelet w pt + | _btTimer' pt <= 0 = ( w, Nothing) + | otherwise = (damcrs, mvPt) + where + sp = _btPos' pt + vel = _btVel' pt + ep = sp +.+ vel + size = _btWidth' pt + mvPt = Just $ pt & btTimer' -~ 1 + & btPos' .~ ep + & btPassThrough' .~ Nothing + & btVel' .~ 0.8 *.* vel + damcrs = foldr ($) w $ map dodam $ filter closeCrs $ IM.elems $ _creatures w + closeCrs cr = dist ep (_crPos cr) < _crRad cr + size + dodam cr = over (creatures . ix (_crID cr) . crState . crDamage) + ((:) $ Flaming 3 sp ep ep) + +makeGasCloud :: Point2 -> Point2 -> World -> World +makeGasCloud pos vel w = over clouds (IM.insert i theCloud) + $ set randGen g w + where i = newKey $ _clouds w + theCloud = Cloud { _clID = i + , _clPos = pos + , _clVel = vel + , _clPict = \_ -> onLayer CrLayer $ color (withAlpha 0.1 col) + $ circleSolid 20 + , _clRad = 20 + , _clTimer = 400 + , _clEffect = cloudPoisonDamage + } + (col, g) = runState (takeOne [green,yellow]) $ _randGen w + +cloudPoisonDamage :: Cloud -> World -> World +cloudPoisonDamage c w = w & creatures %~ flip (foldr (IM.adjust doDam)) damagedCrs + where damagedCrs = IM.keys $ IM.filter f $ creaturesNearPoint (_clPos c) w + f cr = dist (_crPos cr) (_clPos c) < _crRad cr + _clRad c + doDam cr = cr & crState . crDamage %~ (:) (PoisonDam 1) + +makeTeslaArcAt :: Int -> Point2 -> Float -> Projectile +makeTeslaArcAt i pos dir = Projectile + { _ptPos = pos + , _ptStartPos = pos + , _ptVel = (0,0) + , _ptPict = onLayer PtLayer $ line [(0,0),(0,0)] + , _ptID = i + , _ptUpdate = moveTeslaArc pos dir i + } + +moveTeslaArc :: Point2 -> Float -> Int -> World -> World +moveTeslaArc p d i w = + set (projectiles . ix i . ptPict) pic + $ set (projectiles . ix i . ptUpdate) + (ptTimer 2 i) + $ set randGen g + $ createSpark 8 nc q2 (argV sv + d1) Nothing + $ foldr damCrs w hitCrs + where pic = setLayer 1 $ pictures + [ onLayer PtLayer $ color (f2 nc) $ line ps' + , onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 20 ps' + , onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 25 ps' + , onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 30 ps' + ] + ps' = lightningMids d pers ps + ps = take 15 $ p : map f (crsLightChain p d 0 w) + f (E3x1 cr) = _crPos cr + f (E3x2 p1) = p1 + f (E3x3 p1) = p1 + pers = evalState (sequence $ repeat $ randInCirc 5) $ _randGen w + (nc,g) = randomR (0::Int,11) $ _randGen w + f1 (E3x1 cr) = Just $ _crID cr + f1 _ = Nothing + hitCrs = mapMaybe f1 $ take 14 $ crsLightChain p d 0 w + damCrs i = over (creatures . ix i . crHP) (\hp -> hp - 5) + f2 0 = cyan + f2 1 = azure + f2 _ = white + sID = newProjectileKey w + q1 = last $ init ps' + q2 = last ps' + hitWall = collidePointWalls q1 ((2 *.* q2) -.- q1) $ wallsNearPoint q1 w + (d1,_) = randomR (-0.7,0.7) $ _randGen w + sv = fromMaybe (q2 -.- q1) $ fmap snd hitWall + +lightningMid :: Float -> Point2 -> Point2 -> Point2 +lightningMid d p1 p2 = (0.25 *.* (p1 +.+ p2)) +.+ 0.5 *.* p3 + where p3 = errorClosestPointOnLine 1 p1 (p1 +.+ unitVectorAtAngle d) p2 + +lightningMids :: Float -> [Point2] -> [Point2] -> [Point2] +lightningMids d1 (p:pers) (p1:p3:ps) + = let p2 = p +.+ lightningMid d1 p1 p3 + d2 = argV $ p3 -.- p2 + in p1 : p2 : lightningMids d2 pers (p3:ps) +lightningMids _ _ ps = ps + +crsLightChain' :: Point2 -> Float -> World -> [Either3 Creature Point2 Point2] +crsLightChain' p d w + = case crOrWall p d w of + E3x1 cr -> E3x1 cr : crsLightChain' (_crPos cr) (argV (_crPos cr -.- p)) w + E3x2 p1 -> [E3x2 p1] + E3x3 p1 -> E3x3 p1 : crsLightChain' p1 (dChange + argV (p1 -.- p)) (set randGen g w) + -- where (dChange, g) = (0, _randGen w) + where (dChange, g) = randomR (-0.05,0.05) $ _randGen w + +crsLightChain :: Point2 -> Float -> Float -> World -> [Either3 Creature Point2 Point2] +crsLightChain p d wlAttract w + = case crOrWallSensitive p d wlAttract w of + E3x1 cr -> E3x1 cr : crsLightChain (_crPos cr) (argV (_crPos cr -.- p)) + (min 1 (wlAttract + 0.3)) w + E3x2 p1 -> [E3x2 p1] + E3x3 p1 -> E3x3 p1 : crsLightChain p1 (dChange + argV (p1 -.- p)) (min 1 (wlAttract + 0.3)) (set randGen g w) + -- where (dChange, g) = (0, _randGen w) + where (dChange, g) = randomR (-0.05,0.05) $ _randGen w + +crOrWallSensitive :: Point2 -> Float -> Float -> World -> Either3 Creature Point2 Point2 +crOrWallSensitive p dir wlAttract w = fromMaybe (E3x3 $ p +.+ rotateV dir (arcLen,0)) + $ listToMaybe $ sortBy (compare `on` g) + $ catMaybes [cr,wlp] + where cr = fmap E3x1 $ nearestCrInFront p dir 100 w + wlp = fmap E3x2 $ listToMaybe + $ sortBy (compare `on` dist p) + $ mapMaybe + ( fmap fst + . (\p1 -> collidePointWalls p p1 $ wallsNearPoint p w) + . (+.+) p + . (\d -> rotateV d (100,0)) + . (+) dir + ) + (fmap (*wlAttract) [-(3*pi/8),-pi/4,-pi/8,0,pi/8,pi/4,3*pi/8]) + --[-pi/4,-pi/8,0,pi/8,pi/4] + g (E3x2 p1) = 100 + dist p p1 -- tweak makes it more likely to hit crs first + --g (E3x2 p1) = dist p p1 - 100 -- tweak makes it more likely to hit walls first + g (E3x1 cr1) = dist p $ _crPos cr1 + (arcLen,_) = randomR (25,50) $ _randGen w +-- BUG: can hit crs through walls + +crOrWall :: Point2 -> Float -> World -> Either3 Creature Point2 Point2 +crOrWall p dir w = fromMaybe (E3x3 $ p +.+ rotateV dir (arcLen,0)) + $ listToMaybe $ sortBy (compare `on` g) + $ catMaybes [cr,wlp] + where cr = fmap E3x1 $ nearestCrInFront p dir 100 w + wlp = fmap E3x2 $ listToMaybe + $ sortBy (compare `on` dist p) + $ mapMaybe + ( fmap fst + . (\p1 -> collidePointWalls p p1 $ wallsNearPoint p w) + . (+.+) p + . (\d -> rotateV d (100,0)) + . (+) dir + ) + [-(3*pi/8),-pi/4,-pi/8,0,pi/8,pi/4,3*pi/8] + --[-pi/4,-pi/8,0,pi/8,pi/4] + g (E3x2 p1) = 100 + dist p p1 -- tweak makes it more likely to hit crs first + --g (E3x2 p1) = dist p p1 - 100 -- tweak makes it more likely to hit walls first + g (E3x1 cr1) = dist p $ _crPos cr1 + (arcLen,_) = randomR (25,50) $ _randGen w + +-- if the spark is created by another Particle', it cannot be directly added to +-- the list, hence the redirect through worldEvents +createSpark :: Int -> Int -> Point2 -> Float -> Maybe Int -> World -> World +createSpark time colid pos dir maycid w = over worldEvents + ((.) $ ( over particles' ((:) spark) +-- . flareAt' white 0.02 0.05 pos') + . sparkFlashAt pos') + ) w + where spark = Bul' { _ptDraw = drawBul + , _ptUpdate' = mvGenBullet' + , _btVel' = rotateV dir (5,0) + , _btColor' = numColor colid + , _btTrail' = [pos] + , _btPassThrough' = maycid + , _btWidth' = 1 + , _btTimer' = time + , _btHitEffect' = destroyOnImpact sparkEff noEff noEff + } + x = fst $ randomR (0,20) $ _randGen w + pos' = pos +.+ rotateV dir (x,0) + sparkEff bt p cr = over (creatures . ix (_crID cr) . crState . crDamage) + ((:) $ SparkDam 1 sp p ep) + where sp = head (_btTrail' bt) + ep = sp +.+ _btVel' bt + +drawBul :: Particle' -> Picture +drawBul pt = setLayer 1 . color white $ thickLine (take 2 $ _btTrail' pt) (_btWidth' pt) From 1c11d82878f6b97eea103ce1205292206f0ba95a Mon Sep 17 00:00:00 2001 From: jgk Date: Sun, 28 Mar 2021 18:51:39 +0200 Subject: [PATCH 3/5] Fix---at least partially---level generation bug --- src/Dodge/Data.hs | 10 ---- src/Dodge/Event/Keyboard.hs | 4 +- src/Dodge/Event/Test.hs | 98 +++++++++++++++++++++++++++++++ src/Dodge/Floor.hs | 75 +++++++++++------------ src/Dodge/Layout.hs | 1 + src/Dodge/LevelGen.hs | 3 +- src/Dodge/LevelGen/StaticWalls.hs | 69 +++++++++++++++------- src/Dodge/Rendering/HUD.hs | 1 + src/Dodge/Room/Data.hs | 18 ++++++ src/Dodge/Rooms.hs | 7 ++- 10 files changed, 214 insertions(+), 72 deletions(-) create mode 100644 src/Dodge/Event/Test.hs create mode 100644 src/Dodge/Room/Data.hs diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index ed93e5393..4269e558f 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -613,19 +613,10 @@ data PlacementSpot = PS , _psRot :: Float , _psType :: PSType } -data Room = Room - { _rmPolys :: [Poly] - , _rmLinks :: [(Point2,Float)] - , _rmPath :: [(Point2, Point2)] - , _rmPS :: [PlacementSpot] - , _rmBound :: Poly - } data SubNode a = SN a | InLink | OutLink -data RoomLink = RL {_rlPos :: Point2, _rlRot :: Float} -makeLenses ''RoomLink makeLenses ''World makeLenses ''Cloud makeLenses ''Creature @@ -652,7 +643,6 @@ makeLenses ''PressPlate makeLenses ''Button makeLenses ''PSType makeLenses ''PlacementSpot -makeLenses ''Room numColor :: Int -> Color numColor 0 = (1,0,0,1) diff --git a/src/Dodge/Event/Keyboard.hs b/src/Dodge/Event/Keyboard.hs index 2fe3f6133..8c3df61de 100644 --- a/src/Dodge/Event/Keyboard.hs +++ b/src/Dodge/Event/Keyboard.hs @@ -6,6 +6,7 @@ import Dodge.Data import Dodge.Base import Dodge.CreatureAction import Dodge.LoadConfig +import Dodge.Event.Test import SDL import Data.Maybe @@ -46,9 +47,6 @@ spaceAction w = case listToMaybe $ _closeActiveObjects w of Just (Right but) -> _btEvent but but w Nothing -> w -testEvent :: World -> World -testEvent w = w - pauseGame :: World -> World pauseGame w = w {_menuState = PauseMenu} diff --git a/src/Dodge/Event/Test.hs b/src/Dodge/Event/Test.hs new file mode 100644 index 000000000..251d19fb6 --- /dev/null +++ b/src/Dodge/Event/Test.hs @@ -0,0 +1,98 @@ +module Dodge.Event.Test + ( testEvent + ) + where +import Dodge.Data +import Dodge.Base +import Dodge.Default + +import Picture +import Geometry + +import qualified Data.IntMap as IM +import Control.Lens + +testEvent :: World -> World +testEvent w = over walls (IM.union testWalls) w + where + k = newKey $ _walls w + setKeys = zipWith (\i wl -> wl & wlID .~ i) [k..] + + testWalls = IM.fromList $ zip [k..] $ setKeys (startWalls ++ errorWalls ++ (errorWall : polyWalls) ++ endWalls) + + polyPairs = makeLoopPairs + $ reverse [(-340.0,59.999996),(-374.64102,79.99999),(-340.0,100.0)] +-- [(4172.5835,2597.1892),(3855.1414,2597.1895),(3855.141,2324.7563),(4172.5835,2324.756)] + polyWalls = map (wallWithCol red . flat2) polyPairs + + errorWallPair = + (9,[(-340.0,60.0),(-320.0,60.0)]) +-- (48,[(3855.1414,2587.1892),(3855.141,2324.7563)]) + errorWall = wallWithCol green $ snd errorWallPair + + errorWallPairs = + [(1,[(-400.0,59.999996),(-340.0,60.0)]) + ,(12,[(-340.0,60.0),(-340.0,59.999996)]) + ] +-- [(43,[(3855.1414,2598.1895),(3855.1414,2587.1892)]) +-- ,(49,[(3855.1414,2597.1895),(3855.1414,2587.1892)]) +-- ] + errorWalls = map (wallWithCol blue . snd) errorWallPairs + + startWallPairs = + [(0,[(-320.0,60.0),(-320.0,100.0)]) + ,(1,[(-400.0,59.999996),(-320.0,60.0)]) + ,(2,[(-400.0,100.0),(-400.0,59.999996)]) + ,(3,[(-320.0,100.0),(-400.0,100.0)]) + ,(4,[(-260.0,60.0),(-225.35898,80.0)]) + ,(5,[(-260.0,100.0),(-260.0,60.0)]) + ,(6,[(-225.35898,80.0),(-260.0,100.0)]) + ] +-- [(5,[(3875.1414,2761.8303),(3855.1414,2727.1892)]) +-- ,(16,[(3895.1414,2727.1892),(3875.1414,2761.8303)]) +-- ,(18,[(3855.1414,2727.1892),(3855.1414,2667.1892)]) +-- ,(19,[(3875.1414,2552.548),(3895.1414,2587.1892)]) +-- ,(32,[(3855.1414,2587.1892),(3875.1414,2552.548)]) +-- ,(36,[(3895.1414,2667.1892),(3895.1414,2727.1892)]) +-- ,(37,[(3895.1414,2587.1892),(3895.1414,2647.1892)]) +-- ,(38,[(3855.1414,2647.1892),(3855.1414,2587.1892)]) +-- ,(39,[(3855.1414,2667.1892),(3855.1414,2647.1892)]) +-- ,(40,[(3895.1414,2647.1892),(3895.1414,2667.1892)]) +-- ] + startWalls = map (wallWithCol yellow . snd) startWallPairs + + endWalls = map (wallWithCol (withAlpha 0.2 orange) . snd) endWallPairs + endWallPairs = + [(0,[(-320.0,60.0),(-320.0,100.0)]) + ,(1,[(-400.0,59.999996),(-340.0,60.0)]) + ,(2,[(-400.0,100.0),(-400.0,59.999996)]) + ,(3,[(-320.0,100.0),(-340.0,100.0)]) + ,(4,[(-260.0,60.0),(-225.35898,80.0)]) + ,(5,[(-260.0,100.0),(-260.0,60.0)]) + ,(6,[(-225.35898,80.0),(-260.0,100.0)]) + ,(9,[(-340.0,60.0),(-320.0,60.0)]) + ,(11,[(-340.0,100.0),(-400.0,100.0)]) + ,(12,[(-340.0,60.0),(-340.0,59.999996)]) + ] +-- [(5,[(3875.1414,2761.8303),(3855.1414,2727.1892)]) +-- ,(16,[(3895.1414,2727.1892),(3875.1414,2761.8303)]) +-- ,(18,[(3855.1414,2727.1892),(3855.1414,2667.1892)]) +-- ,(36,[(3895.1414,2667.1892),(3895.1414,2727.1892)]) +-- ,(38,[(3855.1414,2647.1892),(3855.1414,2598.1895)]) +-- ,(39,[(3855.1414,2667.1892),(3855.1414,2647.1892)]) +-- ,(40,[(3895.1414,2647.1892),(3895.1414,2667.1892)]) +-- ,(43,[(3855.1414,2598.1895),(3855.1414,2587.1892)]) +-- ,(45,[(3895.1414,2597.1895),(3895.1414,2647.1892)]) +-- ,(46,[(4172.5835,2324.756),(4172.5835,2597.1892)]) +-- ,(47,[(3855.141,2324.7563),(4172.5835,2324.756)]) +-- ,(48,[(3855.1414,2587.1892),(3855.141,2324.7563)]) +-- ,(49,[(3855.1414,2597.1895),(3855.1414,2587.1892)]) +-- ,(50,[(3855.1414,2598.1895),(3855.1414,2597.1895)]) +-- ,(51,[(4172.5835,2597.1892),(3895.1414,2597.1895)]) +-- ] + +--flat2 :: (a,a) -> [a] +--flat2 (x,y) = [x,y] + +wallWithCol :: Color -> [Point2] -> Wall +wallWithCol col ps = defaultWall & wlLine .~ ps & wlColor .~ col & wlSeen .~ True diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 17c34ac08..920bcd929 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -8,6 +8,7 @@ import Picture import Dodge.Data import Dodge.Rooms +import Dodge.Room.Data import Dodge.Base import Dodge.Layout import Dodge.Creature @@ -32,44 +33,44 @@ lev1 = do ( [return $ return $ Right deadEndRoom ] - ++ [return $ connectRoom corridor - ,return $ connectRoom door - ,glassSwitchBack >>= randomiseLinks] - ++ [return $ connectRoom corridor - ,return $ connectRoom door] - ++ [miniRoom3] - ++ [return $ connectRoom corridor - ,return $ connectRoom door] - ++ [roomCCrits] - ++ [return $ connectRoom corridor - ,return $ connectRoom door] - ++[roomMiniIntro] - ++ [longRoom >>= randomiseLinks] - ++ [return $ connectRoom corridor - ,return $ connectRoom door] +-- ++ [return $ connectRoom corridor +-- ,return $ connectRoom door +-- ,glassSwitchBack >>= randomiseLinks] +-- ++ [return $ connectRoom corridor +-- ,return $ connectRoom door] +-- ++ [miniRoom3] +-- ++ [return $ connectRoom corridor +-- ,return $ connectRoom door] +-- ++ [roomCCrits] +-- ++ [return $ connectRoom corridor +-- ,return $ connectRoom door] +-- ++[roomMiniIntro] +-- ++ [longRoom >>= randomiseLinks] +-- ++ [return $ connectRoom corridor +-- ,return $ connectRoom door] ++ firstWeapon - ++ [return $ connectRoom corridor - ,return $ connectRoom door] - ++ [randomiseLinks =<< pistolerRoom] - ++ [return $ connectRoom door] - ++ [randomiseLinks =<< shooterRoom] - ++ (replicate 3 $ randomiseLinks corridor) - ++ [return $ connectRoom (set rmPS [PS (20,40) 0 basicLS] corridor)] - ++ [return $ connectRoom corridor] - ++ (replicate 3 $ randomiseLinks corridor) - ++ [return $ connectRoom corridor] - ++[return $ connectRoom corridor,return $ connectRoom door] - ++ [shootingRange] - ++ (replicate 3 $ randomiseLinks corridor) - ++[roomMiniIntro] - ++ (replicate 3 $ randomiseLinks corridor) - ++ [return $ connectRoom corridor - ,return $ connectRoom door - ,slowDoorRoom] - ++ [return $ connectRoom corridor - ,spawnerRoom - ,return $ connectRoom corridor - ] +-- ++ [return $ connectRoom corridor +-- ,return $ connectRoom door] +-- ++ [randomiseLinks =<< pistolerRoom] +-- ++ [return $ connectRoom door] +-- ++ [randomiseLinks =<< shooterRoom] +-- ++ (replicate 3 $ randomiseLinks corridor) +-- ++ [return $ connectRoom (set rmPS [PS (20,40) 0 basicLS] corridor)] +-- ++ [return $ connectRoom corridor] +-- ++ (replicate 3 $ randomiseLinks corridor) +-- ++ [return $ connectRoom corridor] +-- ++[return $ connectRoom corridor,return $ connectRoom door] +-- ++ [shootingRange] +-- ++ (replicate 3 $ randomiseLinks corridor) +-- ++[roomMiniIntro] +-- ++ (replicate 3 $ randomiseLinks corridor) +-- ++ [return $ connectRoom corridor +-- ,return $ connectRoom door +-- ,slowDoorRoom] +-- ++ [return $ connectRoom corridor +-- ,spawnerRoom +-- ,return $ connectRoom corridor +-- ] ) $ randomiseLinks corridor diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index 997ad5613..e80e45f6d 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -10,6 +10,7 @@ import Dodge.Base import Dodge.RandomHelp import Dodge.Path import Dodge.Layout.Tree +import Dodge.Room.Data import Geometry diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index 12d0347a0..259f581fb 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -4,7 +4,7 @@ module Dodge.LevelGen ( module Dodge.LevelGen , cutWalls , createInnerWalls - , checkWalls +-- , checkWalls , nubWalls , pairsToGraph , makeButton @@ -14,6 +14,7 @@ module Dodge.LevelGen import Dodge.Data import Dodge.Base +import Dodge.Room.Data import Dodge.LevelGen.Block import Dodge.LevelGen.LineBlock diff --git a/src/Dodge/LevelGen/StaticWalls.hs b/src/Dodge/LevelGen/StaticWalls.hs index 4d2594ce7..c46ed66b1 100644 --- a/src/Dodge/LevelGen/StaticWalls.hs +++ b/src/Dodge/LevelGen/StaticWalls.hs @@ -18,14 +18,18 @@ import qualified Data.Set as S -- given a polygon of points and collection of walls, cuts out the polygon -- ie returns a new set of walls with a hole determined by anticlockwise ordering of the points -cutWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall -cutWalls qs walls = createPolyWalls rs - . IM.filter (not.wallIsZeroLength) - . removeWallsInPolygon ps - $ fuseWallsWith zs cwals - where (zs,cwals) = cutWallsWithPoints ps walls - ps = orderPolygon qs - rs = orderPolygon $ nub $ zs ++ qs +cutWalls' :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall +cutWalls' qs walls = + IM.filter (not.wallIsZeroLength) + . fuseWallsWith zs + .createPolyWalls rs + . IM.filter (not.wallIsZeroLength) + . removeWallsInPolygon ps + $ fuseWallsWith zs cwals + where + (zs,cwals) = cutWallsWithPoints ps walls + ps = orderPolygon qs + rs = orderPolygon $ nub $ zs ++ qs -- the overall procedure is: -- split walls that intersect with the polygon into two -- (possibly three if the wall extends across the polygon) @@ -34,6 +38,30 @@ cutWalls qs walls = createPolyWalls rs -- also remove any walls that ended up zero length -- draw the required new walls along the polygon boundary +cutWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall +cutWalls ps wls = case mapMaybe (flip checkWallRight newWalls) newWallsList of + [] -> newWalls + errs -> error $ "cutWalls: when cutting poly:\n" ++ show ps ++ "\nRight corner errors:\n" + ++ unlines (map (show . f) errs) + ++ "\nStart walls:\n" + ++ unlines (map (show . g) (IM.elems wls)) + ++ "\nEnd walls:\n" + ++ unlines (map (show . g) (IM.elems newWalls)) + where + newWalls = cutWalls' ps wls + newWallsList = IM.elems newWalls + g v = (_wlID v, _wlLine v) + f (v,vs) = (g v, map g vs) + +checkWallRight :: Wall -> IM.IntMap Wall -> Maybe (Wall,[Wall]) +checkWallRight wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsRight (_wlLine wl !! 0) wls of + [w] -> Nothing + wls -> Just (wl, wls) +checkWallLeft :: Wall -> IM.IntMap Wall -> Maybe (Wall,[Wall]) +checkWallLeft wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsLeft (_wlLine wl !! 1) wls of + [w] -> Nothing + wls -> Just (wl,wls) + createPolyWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall createPolyWalls (q:qs) walls = foldr createPolyWall walls (zip (q:qs) (qs++[q])) @@ -154,21 +182,20 @@ finalFuse = IM.filter (not.wallIsZeroLength) . fuseWallsWith [] nubWalls :: IM.IntMap Wall -> IM.IntMap Wall nubWalls wls = IM.fromList $ nubBy ((==) `on` _wlLine . snd) $ IM.assocs wls -checkWalls' :: IM.IntMap Wall -> IM.IntMap Wall -checkWalls' wls = case find (\wl -> dist (_wlLine wl !! 0) (_wlLine wl !! 1) < 1) wls of - Just wl -> error $ show $ _wlLine wl - _ -> wls - -checkWalls wls | (nub $ map _wlLine $ IM.elems wls) - == (map _wlLine $ IM.elems wls) = wls - | otherwise = error "hasdup" +--checkWalls' :: IM.IntMap Wall -> IM.IntMap Wall +--checkWalls' wls = case find (\wl -> dist (_wlLine wl !! 0) (_wlLine wl !! 1) < 1) wls of +-- Just wl -> error $ show $ _wlLine wl +-- _ -> wls +-- +--checkWalls wls | (nub $ map _wlLine $ IM.elems wls) +-- == (map _wlLine $ IM.elems wls) = wls +-- | otherwise = error "hasdup" -- idea: create inner walls to draw and to cast shadows createInnerWalls :: IM.IntMap Wall -> IM.IntMap Wall createInnerWalls wls = IM.map (createInnerWall wls) wls createInnerWall :: IM.IntMap Wall -> Wall -> Wall ---createInnerWall walls wl = wl & wlLine %~ (++) [(0,0)] createInnerWall walls wl = wl & wlLine %~ \l -> l ++ [wlL,wlR] where wl0 = _wlLine wl !! 0 wl1 = _wlLine wl !! 1 @@ -183,14 +210,16 @@ createInnerWall walls wl = wl & wlLine %~ \l -> l ++ [wlL,wlR] findWallLeft :: Wall -> IM.IntMap Wall -> Wall findWallLeft wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsLeft (_wlLine wl !! 1) wls of [w] -> w - wls -> error $ "findWallLeft: is there a standalone wall? wlIDs: " ++ show (map _wlID wls) + wls -> error $ "findWallLeft: " ++ show (map _wlID wls) ++ " wlLines: "++ show (map _wlLine wls) findWallRight :: Wall -> IM.IntMap Wall -> Wall findWallRight wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsRight (_wlLine wl !! 0) wls of [w] -> w - wls -> error $ "findWallRight: is there a standalone wall? wlIDs: " ++ show (map _wlID wls) - ++ " wlLines: "++ show (map _wlLine wls) + wls -> error $ "findWallRight: wall with ID " ++ show (_wlID wl) ++ " and points " ++ + show (_wlLine wl) ++ "\nhas a right corner with and only with the walls " + ++ show (map _wlID wls) ++ "\nwlLines "++ show (map _wlLine wls) + ++ "\nUnless a wall has a corner with exactly one other wall, there is a problem" findWallsLeft :: Point2 -> IM.IntMap Wall -> IM.IntMap Wall findWallsLeft x wls = IM.filter (\wl -> dist x (_wlLine wl !! 0) < 1) wls diff --git a/src/Dodge/Rendering/HUD.hs b/src/Dodge/Rendering/HUD.hs index 0b70a324f..3ec96ef85 100644 --- a/src/Dodge/Rendering/HUD.hs +++ b/src/Dodge/Rendering/HUD.hs @@ -102,6 +102,7 @@ mapWall w wl = else Nothing where t = normalizeV (y -.- x) +-- n2 = 2 *.* vNormal t n2 = 20 *.* vNormal t (x:y:_) = (_wlLine wl) c = _wlColor wl diff --git a/src/Dodge/Room/Data.hs b/src/Dodge/Room/Data.hs new file mode 100644 index 000000000..17aa51aeb --- /dev/null +++ b/src/Dodge/Room/Data.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE TemplateHaskell #-} +module Dodge.Room.Data + where + +import Dodge.Data +import Control.Lens + +data Room = Room + { _rmPolys :: [Poly] + , _rmLinks :: [(Point2,Float)] + , _rmPath :: [(Point2, Point2)] + , _rmPS :: [PlacementSpot] + , _rmBound :: Poly + } +data RoomLink = RL {_rlPos :: Point2, _rlRot :: Float} + +makeLenses ''Room +makeLenses ''RoomLink diff --git a/src/Dodge/Rooms.hs b/src/Dodge/Rooms.hs index eae5c6180..a9ca27ae9 100644 --- a/src/Dodge/Rooms.hs +++ b/src/Dodge/Rooms.hs @@ -1,4 +1,8 @@ -module Dodge.Rooms where +module Dodge.Rooms +-- ( module Dodge.Rooms +-- , module Dodge.Rooms.Data +-- ) + where -- imports {{{ import Dodge.Data import Dodge.Item.Weapon @@ -12,6 +16,7 @@ import Dodge.Path import Dodge.Layout import Dodge.LightSources import Dodge.SoundLogic +import Dodge.Room.Data import Dodge.Room.Placement From 34ddd018252327a37f2d318a721c28f7abf87606 Mon Sep 17 00:00:00 2001 From: jgk Date: Sun, 28 Mar 2021 20:44:09 +0200 Subject: [PATCH 4/5] Broken level generation with error message on run --- src/Dodge/Floor.hs | 74 +++++++++++++++---------------- src/Dodge/LevelGen/StaticWalls.hs | 15 ++++--- 2 files changed, 47 insertions(+), 42 deletions(-) diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 920bcd929..60008b30a 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -33,44 +33,44 @@ lev1 = do ( [return $ return $ Right deadEndRoom ] --- ++ [return $ connectRoom corridor --- ,return $ connectRoom door --- ,glassSwitchBack >>= randomiseLinks] --- ++ [return $ connectRoom corridor --- ,return $ connectRoom door] --- ++ [miniRoom3] --- ++ [return $ connectRoom corridor --- ,return $ connectRoom door] --- ++ [roomCCrits] --- ++ [return $ connectRoom corridor --- ,return $ connectRoom door] --- ++[roomMiniIntro] --- ++ [longRoom >>= randomiseLinks] --- ++ [return $ connectRoom corridor --- ,return $ connectRoom door] + ++ [return $ connectRoom corridor + ,return $ connectRoom door + ,glassSwitchBack >>= randomiseLinks] + ++ [return $ connectRoom corridor + ,return $ connectRoom door] + ++ [miniRoom3] + ++ [return $ connectRoom corridor + ,return $ connectRoom door] + ++ [roomCCrits] + ++ [return $ connectRoom corridor + ,return $ connectRoom door] + ++[roomMiniIntro] + ++ [longRoom >>= randomiseLinks] + ++ [return $ connectRoom corridor + ,return $ connectRoom door] ++ firstWeapon --- ++ [return $ connectRoom corridor --- ,return $ connectRoom door] --- ++ [randomiseLinks =<< pistolerRoom] --- ++ [return $ connectRoom door] --- ++ [randomiseLinks =<< shooterRoom] --- ++ (replicate 3 $ randomiseLinks corridor) --- ++ [return $ connectRoom (set rmPS [PS (20,40) 0 basicLS] corridor)] --- ++ [return $ connectRoom corridor] --- ++ (replicate 3 $ randomiseLinks corridor) --- ++ [return $ connectRoom corridor] --- ++[return $ connectRoom corridor,return $ connectRoom door] --- ++ [shootingRange] --- ++ (replicate 3 $ randomiseLinks corridor) --- ++[roomMiniIntro] --- ++ (replicate 3 $ randomiseLinks corridor) --- ++ [return $ connectRoom corridor --- ,return $ connectRoom door --- ,slowDoorRoom] --- ++ [return $ connectRoom corridor --- ,spawnerRoom --- ,return $ connectRoom corridor --- ] + ++ [return $ connectRoom corridor + ,return $ connectRoom door] + ++ [randomiseLinks =<< pistolerRoom] + ++ [return $ connectRoom door] + ++ [randomiseLinks =<< shooterRoom] + ++ (replicate 3 $ randomiseLinks corridor) + ++ [return $ connectRoom (set rmPS [PS (20,40) 0 basicLS] corridor)] + ++ [return $ connectRoom corridor] + ++ (replicate 3 $ randomiseLinks corridor) + ++ [return $ connectRoom corridor] + ++[return $ connectRoom corridor,return $ connectRoom door] + ++ [shootingRange] + ++ (replicate 3 $ randomiseLinks corridor) + ++[roomMiniIntro] + ++ (replicate 3 $ randomiseLinks corridor) + ++ [return $ connectRoom corridor + ,return $ connectRoom door + ,slowDoorRoom] + ++ [return $ connectRoom corridor + ,spawnerRoom + ,return $ connectRoom corridor + ] ) $ randomiseLinks corridor diff --git a/src/Dodge/LevelGen/StaticWalls.hs b/src/Dodge/LevelGen/StaticWalls.hs index c46ed66b1..95f4010ac 100644 --- a/src/Dodge/LevelGen/StaticWalls.hs +++ b/src/Dodge/LevelGen/StaticWalls.hs @@ -20,12 +20,16 @@ import qualified Data.Set as S -- ie returns a new set of walls with a hole determined by anticlockwise ordering of the points cutWalls' :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall cutWalls' qs walls = - IM.filter (not.wallIsZeroLength) - . fuseWallsWith zs - .createPolyWalls rs + nubWalls . IM.filter (not.wallIsZeroLength) - . removeWallsInPolygon ps - $ fuseWallsWith zs cwals + . fuseWallsWith zs + . createPolyWalls rs + . IM.filter (not.wallIsZeroLength) +-- . removeWallsInPolygon ps +-- $ fuseWallsWith zs cwals + . fuseWallsWith zs + $ removeWallsInPolygon ps + cwals where (zs,cwals) = cutWallsWithPoints ps walls ps = orderPolygon qs @@ -38,6 +42,7 @@ cutWalls' qs walls = -- also remove any walls that ended up zero length -- draw the required new walls along the polygon boundary +-- the following checks one of the corners of cut walls at each step cutWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall cutWalls ps wls = case mapMaybe (flip checkWallRight newWalls) newWallsList of [] -> newWalls From 96086559474f93f5915d3b8d99075431b5b59756 Mon Sep 17 00:00:00 2001 From: jgk Date: Mon, 29 Mar 2021 02:12:14 +0200 Subject: [PATCH 5/5] Generate walls using points, fix at least some potential errors --- src/Dodge/Layout.hs | 14 +- src/Dodge/LevelGen.hs | 2 - src/Dodge/LevelGen/StaticWalls.hs | 225 +++++++++++++----------------- 3 files changed, 112 insertions(+), 129 deletions(-) diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index e80e45f6d..26e3a6174 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -11,6 +11,7 @@ import Dodge.RandomHelp import Dodge.Path import Dodge.Layout.Tree import Dodge.Room.Data +import Dodge.Default import Geometry @@ -60,8 +61,19 @@ generateFromTree t w = zoning $ placeSpots plmnts makePath :: Tree Room -> [(Point2,Point2)] makePath = concat . map _rmPath . flatten +-- consider nubbing walls after dividing them wallsFromTree :: Tree Room -> IM.IntMap Wall -wallsFromTree t = createInnerWalls $ nubWalls $ divideWalls $ foldr cutWalls IM.empty (concatMap _rmPolys $ flatten t) +wallsFromTree t = + createInnerWalls + . divideWalls + . assignKeys + . foldr cutWalls [] -- $ map (map (g . roundPoint2)) + . map (map roundPoint2) + $ (concatMap _rmPolys $ flatten t) + where + assignKeys = IM.fromList . zip [0..] . zipWith f [0..] + f i (x,y) = defaultWall {_wlLine = [x,y] , _wlID = i} + g (x,y) = (x-3855,y - 2613) divideWall :: Wall -> [Wall] divideWall wl diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index 259f581fb..05bdeecd6 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -4,8 +4,6 @@ module Dodge.LevelGen ( module Dodge.LevelGen , cutWalls , createInnerWalls --- , checkWalls - , nubWalls , pairsToGraph , makeButton , makeSwitch diff --git a/src/Dodge/LevelGen/StaticWalls.hs b/src/Dodge/LevelGen/StaticWalls.hs index 95f4010ac..e68aba06b 100644 --- a/src/Dodge/LevelGen/StaticWalls.hs +++ b/src/Dodge/LevelGen/StaticWalls.hs @@ -16,18 +16,45 @@ import qualified Data.IntMap as IM import qualified Data.Set as S +type WallP = (Point2,Point2) + +-- the following checks one of the corners of cut walls at each step +cutWalls :: [Point2] -> [WallP] -> [WallP] +cutWalls ps wls = case mapMaybe (flip checkWallRight newWalls) newWalls of + [] -> newWalls + errs -> error $ "cutWalls: when cutting poly:\n" ++ show ps + ++ "\nRight corner errors:\n" + ++ unlines (map show errs) + ++ "\nStart walls:\n" + ++ unlines (map show wls) + ++ "\nEnd walls:\n" + ++ unlines (map show newWalls) + ++ "\nLeft corner errors:\n" + ++ unlines (map show errsL) + where + newWalls = cutWalls' ps wls + errsL = mapMaybe (flip checkWallLeft newWalls) newWalls + +checkWallRight :: WallP -> [WallP] -> Maybe (WallP,[WallP]) +checkWallRight (x,y) wls = case filter (\(a,b) -> a == y ) wls of + [w] -> Nothing + wls -> Just ((x,y), wls) +checkWallLeft :: WallP -> [WallP] -> Maybe (WallP,[WallP]) +checkWallLeft (x,y) wls = case filter (\(a,b) -> b == x ) wls of + [w] -> Nothing + wls -> Just ((x,y),wls) + -- given a polygon of points and collection of walls, cuts out the polygon -- ie returns a new set of walls with a hole determined by anticlockwise ordering of the points -cutWalls' :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall +cutWalls' :: [Point2] -> [WallP] -> [WallP] cutWalls' qs walls = - nubWalls - . IM.filter (not.wallIsZeroLength) + nub + . filter (not.wallIsZeroLength) . fuseWallsWith zs . createPolyWalls rs - . IM.filter (not.wallIsZeroLength) -- . removeWallsInPolygon ps --- $ fuseWallsWith zs cwals - . fuseWallsWith zs +-- . filter (not.wallIsZeroLength) +-- . fuseWallsWith zs $ removeWallsInPolygon ps cwals where @@ -37,96 +64,66 @@ cutWalls' qs walls = -- the overall procedure is: -- split walls that intersect with the polygon into two -- (possibly three if the wall extends across the polygon) --- fuse wall endpoints that end up close to each or to polygon intersection points --- remove the created walls that are inside the polygon --- also remove any walls that ended up zero length +-- remove any created walls that are inside the polygon -- draw the required new walls along the polygon boundary - --- the following checks one of the corners of cut walls at each step -cutWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall -cutWalls ps wls = case mapMaybe (flip checkWallRight newWalls) newWallsList of - [] -> newWalls - errs -> error $ "cutWalls: when cutting poly:\n" ++ show ps ++ "\nRight corner errors:\n" - ++ unlines (map (show . f) errs) - ++ "\nStart walls:\n" - ++ unlines (map (show . g) (IM.elems wls)) - ++ "\nEnd walls:\n" - ++ unlines (map (show . g) (IM.elems newWalls)) - where - newWalls = cutWalls' ps wls - newWallsList = IM.elems newWalls - g v = (_wlID v, _wlLine v) - f (v,vs) = (g v, map g vs) - -checkWallRight :: Wall -> IM.IntMap Wall -> Maybe (Wall,[Wall]) -checkWallRight wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsRight (_wlLine wl !! 0) wls of - [w] -> Nothing - wls -> Just (wl, wls) -checkWallLeft :: Wall -> IM.IntMap Wall -> Maybe (Wall,[Wall]) -checkWallLeft wl wls = case filter (\w -> _wlID w /= _wlID wl) $ IM.elems $ findWallsLeft (_wlLine wl !! 1) wls of - [w] -> Nothing - wls -> Just (wl,wls) - -createPolyWalls :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall -createPolyWalls (q:qs) walls = foldr createPolyWall walls (zip (q:qs) (qs++[q])) - --- creates a wall if there is not already a wall on the clockwise normal to this wall --- such that this existing wall faces towards the new wall -createPolyWall :: (Point2, Point2) -> IM.IntMap Wall -> IM.IntMap Wall -createPolyWall (p1,p2) walls = - case maybeW of Just w -> if isLHS (_wlLine w !! 0) (_wlLine w !! 1) p3 - then walls - else IM.insert k newWall walls - Nothing -> IM.insert k newWall walls - where p3 = 0.5 *.* (p1 +.+ p2) - p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1) - maybeW = wallOnLine p3 p4 walls - k = newKey walls - newWall = defaultWall {_wlLine = [p1,p2], _wlID = k} - --- given a segment and a wall, adds a cut point to the wall if it intersects the --- segment -cutWall :: Point2 -> Point2 -> Wall -> Wall -cutWall p1 p2 wall = case maybeCP of - Nothing -> wall - Just cp -> wall {_wlLine = [cp,w0,w1]} - where wl = _wlLine wall - w0 = wl !! 0 - w1 = wl !! 1 - maybeCP = intersectExtendedSegSeg p1 p2 w0 w1 - --- intersects two segments, each extended by one unit in both directions -intersectExtendedSegSeg p1 p2 a1 a2 = myIntersectSegSeg p1' p2' a1' a2' - where p1' = p1 +.+ normalizeV (p1 -.- p2) - p2' = p2 +.+ normalizeV (p2 -.- p1) - a1' = a1 +.+ normalizeV (a1 -.- a2) - a2' = a2 +.+ normalizeV (a2 -.- a1) - --- given a segment and a collection of walls, cuts each wall where it intersects --- with the segment, adds the two cut walls -addCutWalls :: Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall -addCutWalls p1 p2 ws = foldr addTwoWallsIfCut ws $ IM.map (cutWall p1 p2) ws - where addTwoWallsIfCut w ws - = case _wlLine w of - (cp:w0:w1:[]) -> IM.insert (newKey ws) (w {_wlLine = [cp,w1] - ,_wlID = newKey ws}) - $ IM.insert (_wlID w) (w {_wlLine = [w0,cp]}) ws - (x:y:[]) -> ws - --- lists the points of intersection between a segment and collection of walls -cutWallsPoints :: Point2 -> Point2 -> IM.IntMap Wall -> [Point2] -cutWallsPoints p1 p2 ws = mapMaybe (\(x:y:_) -> intersectExtendedSegSeg p1 p2 x y) - $ map _wlLine $ IM.elems ws +-- fuse wall endpoints that end up close to each or to polygon intersection points +-- remove any walls that ended up zero length after fusing +-- remove any duplicate walls -- given a polygon expressed as a list of points and a collection of walls, -- returns: fst: points of the polygon's intersection with walls -- snd: the collection of walls after cutting by the polygon -cutWallsWithPoints :: [Point2] -> IM.IntMap Wall -> ([Point2], IM.IntMap Wall) +cutWallsWithPoints :: [Point2] -> [WallP] -> ([Point2], [WallP] ) cutWallsWithPoints (p:ps) ws = foldr f ([],ws) (zip (p:ps) (ps++[p])) - where f (p1,p2) (as,ws') = ( as ++ cutWallsPoints p1 p2 ws' - , addCutWalls p1 p2 ws' - ) + where + f (p1,p2) (as,ws') = + ( as ++ cutWallsPoints p1 p2 ws' + , concatMap (cutWall p1 p2) ws' + ) +-- lists the points of intersection between a segment and collection of walls +cutWallsPoints :: Point2 -> Point2 -> [WallP] -> [Point2] +--cutWallsPoints p1 p2 ws = mapMaybe (\(x:y:_) -> intersectExtendedSegSeg p1 p2 x y) +cutWallsPoints p1 p2 ws = mapMaybe (uncurry $ myIntersectSegSeg p1 p2) ws + +-- given a segment and a wall, adds a cut point to the wall if it intersects the +-- segment +cutWall :: Point2 -> Point2 -> WallP -> [WallP] +cutWall p1 p2 (x,y) = case myIntersectSegSeg p1 p2 x y of + Nothing -> [(x,y)] + Just cp -> [(x,cp),(cp,y)] + +createPolyWalls :: [Point2] -> [WallP] -> [WallP] +createPolyWalls (q:qs) walls = foldr createPolyWall walls (zip (q:qs) (qs++[q])) + +-- adds a wall if there is not already a wall on the clockwise normal to this wall +-- such that this existing wall faces towards the new wall +createPolyWall :: WallP -> [WallP] -> [WallP] +createPolyWall (p1,p2) walls = + case maybeW of Just (x,y) -> if isLHS x y p3 + then walls + else (p1,p2) : walls + Nothing -> ((p1,p2) : walls) + where + p3 = 0.5 *.* (p1 +.+ p2) + p4 = p3 +.+ 10000 *.* vNormal (p2 -.- p1) + maybeW = listToMaybe + . fst + . unzip + . sortBy (compare `on` (dist p3 . snd)) + . catMaybes + $ zipWith f walls maybes + f a (Just b) = Just (a,b) + f _ Nothing = Nothing + maybes = map (uncurry $ myIntersectSegSeg p3 p4) walls + +-- intersects two segments, each extended by one unit in both directions +intersectExtendedSegSeg p1 p2 a1 a2 = myIntersectSegSeg p1' p2' a1' a2' + where + p1' = p1 +.+ normalizeV (p1 -.- p2) + p2' = p2 +.+ normalizeV (p2 -.- p1) + a1' = a1 +.+ normalizeV (a1 -.- a2) + a2' = a2 +.+ normalizeV (a2 -.- a1) -- given a list of points and a point, returns a point in the list if any is close -- enough to the point @@ -145,32 +142,24 @@ fusePoint ps p = fromMaybe p $ findClosePoint ps p -- given a list of points and wall, moves the wall to be on the points if it is -- close to any of the points -- if either wall point is not moved, this point gets added to the list -fuseWall :: ([Point2], Wall) -> ([Point2], Wall) -fuseWall (ps, w) = ( rs - , w Control.Lens.& wlLine .~ [w0,w1] - ) - where qs = catMaybes [pointIfNotClose ps (_wlLine w !! 0)] ++ ps - rs = catMaybes [pointIfNotClose qs (_wlLine w !! 1)] ++ qs - w0 = fusePoint ps (_wlLine w !! 0) - w1 = fusePoint qs (_wlLine w !! 1) +fuseWall :: ([Point2], WallP) -> ([Point2], WallP) +fuseWall (ps, (x,y)) = ( nub (x':y':ps) , (x',y') ) + where x' = fusePoint ps x + y' = fusePoint (x':ps) y -- given list of points and collection of walls, fuses the wall ends if -- they are close to the list of points or each other -fuseWallsWith :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall -fuseWallsWith zs ws = snd $ IM.foldr fuseWalls' (zs, IM.empty) ws +fuseWallsWith :: [Point2] -> [WallP] -> [WallP] +fuseWallsWith zs ws = snd $ foldr fuseWalls' (zs, []) ws where fuseWalls' w (ps, ws) = let (qs, w') = fuseWall (ps, w) - in (qs, IM.insert (_wlID w') w' ws) + in (qs, w' : ws) -wallIsZeroLength w = l !! 0 == l !! 1 - where l = _wlLine w +wallIsZeroLength (x,y) = x == y -wallLengthGT x w = dist (l !! 0) (l !! 1) > x - where l = _wlLine w - -removeWallsInPolygon :: [Point2] -> IM.IntMap Wall -> IM.IntMap Wall -removeWallsInPolygon ps walls = IM.filter (not . cond) walls - where cond wall = pointInsidePolygon (_wlLine wall !! 0) ps - && pointInsidePolygon (_wlLine wall !! 1) ps +removeWallsInPolygon :: [Point2] -> [WallP] -> [WallP] +removeWallsInPolygon ps walls = filter (not . cond) walls + where cond wall = pointInsidePolygon (fst wall) ps + && pointInsidePolygon (snd wall) ps pointInsidePolygon :: Point2 -> [Point2] -> Bool pointInsidePolygon p (x:xs) = all (\l -> not (uncurry isRHS l (p +.+ normalizeV s))) pairs @@ -178,24 +167,8 @@ pointInsidePolygon p (x:xs) = all (\l -> not (uncurry isRHS l (p +.+ normalizeV where pairs = zip (x:xs) (xs ++ [x]) s = ((1/fromIntegral (length (x:xs))) *.* (foldr1 (+.+) (x:xs))) -.- p ------------------------------------------------------- -finalFuse :: IM.IntMap Wall -> IM.IntMap Wall -finalFuse = IM.filter (not.wallIsZeroLength) . fuseWallsWith [] - ------------------------------------------------------- - -nubWalls :: IM.IntMap Wall -> IM.IntMap Wall -nubWalls wls = IM.fromList $ nubBy ((==) `on` _wlLine . snd) $ IM.assocs wls - ---checkWalls' :: IM.IntMap Wall -> IM.IntMap Wall ---checkWalls' wls = case find (\wl -> dist (_wlLine wl !! 0) (_wlLine wl !! 1) < 1) wls of --- Just wl -> error $ show $ _wlLine wl --- _ -> wls --- ---checkWalls wls | (nub $ map _wlLine $ IM.elems wls) --- == (map _wlLine $ IM.elems wls) = wls --- | otherwise = error "hasdup" +------------------------------------------------------------------------------------ -- idea: create inner walls to draw and to cast shadows createInnerWalls :: IM.IntMap Wall -> IM.IntMap Wall createInnerWalls wls = IM.map (createInnerWall wls) wls