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

More strictifiiiying

Browse Source
This commit is contained in:
jgk
2021-07-30 01:25:11 +02:00
parent 2d8b27746c
commit 7b7fd302d8
37 changed files with 459 additions and 448 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Creature.hs
+3 -3
View File
@@ -44,7 +44,7 @@ import Dodge.Creature.Rationality
--import Dodge.Item
import Dodge.Picture.Layer
import Picture
--import Geometry
import Geometry.Data
import qualified IntMapHelp as IM
--import Data.List
@@ -140,8 +140,8 @@ addArmour = over crInv insarmour
ID 0. -}
startCr :: Creature
startCr = defaultCreature
{ _crPos = (0,0)
, _crOldPos = (0,0)
{ _crPos = (V2 0 0)
, _crOldPos = (V2 0 0)
, _crDir = pi/2
, _crMvDir = pi/2
, _crID = 0
src/Dodge/Creature/Action.hs
+2 -2
View File
@@ -68,8 +68,8 @@ blinkAction cr w = soundOnce teleSound
where
distR = 120
distortionBulge =
[(p3,p3 +.+ (distR,0), p3 +.+ (0,distR),0.1)
,(cpos,cpos +.+ (distR,0), cpos +.+ (0,distR),1.9)
[(p3,p3 +.+ (V2 distR 0), p3 +.+ (V2 0 distR),0.1)
,(cpos,cpos +.+ (V2 distR 0), cpos +.+ (V2 0 distR),1.9)
]
cid = _crID cr
p1 = mouseWorldPos w
src/Dodge/Creature/Inanimate.hs
+5 -5
View File
@@ -17,7 +17,7 @@ import Dodge.WorldEvent.Sound
import Dodge.Creature.Update hiding (CRUpdate)
import Picture
import qualified IntMapHelp as IM
--import Geometry
import Geometry.Data
import Geometry.Vector3D
import Polyhedra
@@ -36,7 +36,7 @@ lamp h = defaultInanimate
}
lampPic :: Float -> Picture
lampPic h = pictures
[ setLayer 0 $ pictures . map (helpPoly3D . map ((, blue) . (-.-.- (2.5,2.5,0)))) $ boxXYZ 5 5 (h-1)
[ setLayer 0 $ pictures . map (helpPoly3D . map ((, blue) . (-.-.- (V3 2.5 2.5 0)))) $ boxXYZ 5 5 (h-1)
, setLayer 1 $ setDepth h $ color white $ circleSolid 3
]
@@ -44,8 +44,8 @@ initialiseLamp :: Float -> CRUpdate
initialiseLamp h w (f,g) cr = ( (addLS . f , g), Just $ cr & crUpdate .~ updateLamp h i)
where
i = IM.newKey $ _lightSources $ f w -- to give different lights different keys
addLS = over lightSources (IM.insert i (lightAt (x,y,h) i))
(x,y) = _crPos cr
addLS = over lightSources (IM.insert i (lightAt (V3 x y h) i))
(V2 x y) = _crPos cr
updateLamp :: Float -> Int -> CRUpdate
updateLamp h i = unrandUpdate handleLS internalUpdate
@@ -56,7 +56,7 @@ updateLamp h i = unrandUpdate handleLS internalUpdate
| otherwise = w & lightSources . ix i . lsPos .~ f cPos
where
cPos = _crPos cr
f (x,y) = (x,y,h)
f (V2 x y) = (V3 x y h)
internalUpdate cr
| _crHP cr < 0 = Nothing
| otherwise = Just $ doDamage cr
src/Dodge/Creature/LauncherCrit.hs
+2 -2
View File
@@ -16,7 +16,7 @@ import Dodge.Creature.State
--import Dodge.Creature.State.Data
import Dodge.Item.Weapon.Launcher
--import Dodge.Item.Consumable
--import Geometry
import Geometry.Data
import Picture
import qualified Data.IntMap.Strict as IM
@@ -37,7 +37,7 @@ launcherCrit = defaultCreature
>=> reloadOverrideR
>=> targetYouWhenCognizantR
>=> overrideInternalR
(onBoth (&&) crHasTarget (crStratConMatches (GetTo (0,0))))
(onBoth (&&) crHasTarget (crStratConMatches (GetTo (V2 0 0))))
(\ _ -> crActionPlan . crStrategy .~ WatchAndWait)
, _crActionPlan = ActionPlan
{ _crImpulse = []
src/Dodge/Creature/LtAutoCrit.hs
+3 -3
View File
@@ -45,7 +45,7 @@ ltAutoCrit = defaultCreature
>=> reloadOverrideR
>=> targetYouWhenCognizantR
>=> overrideInternalR
(onBoth (&&) crHasTarget (crStratConMatches (GetTo (0,0))))
(onBoth (&&) crHasTarget (crStratConMatches (GetTo (V2 0 0))))
(\ _ -> crActionPlan . crStrategy .~ WatchAndWait)
, _crActionPlan = ActionPlan
{ _crImpulse = []
@@ -64,9 +64,9 @@ chooseMovement cr w
| dist cpos p > 200 = DoImpulses [UseItem,TurnToward p 0.05 , MoveForward 3]
| dist cpos p < 80 = DoImpulses [UseItem,TurnToward p 0.05, MoveForward (-3) ]
| errorAngleVV 22 (p' -.- cpos) (unitVectorAtAngle (_crDir cr)) < 0.4
= DoImpulses [UseItem,TurnToward p' 0.01, Move (0,3)]
= DoImpulses [UseItem,TurnToward p' 0.01, Move (V2 0 3)]
| otherwise
= DoImpulses [UseItem,TurnToward p' 0.05, Move (0,3)]
= DoImpulses [UseItem,TurnToward p' 0.05, Move (V2 0 3)]
where
cpos = _crPos cr
tcr = _creatures w IM.! 0
src/Dodge/Creature/PistolCrit.hs
+5 -5
View File
@@ -39,7 +39,7 @@ pistolCrit = defaultCreature
>=> doStrategyActionsR
>=> reloadOverrideR
>=> targetYouWhenCognizantR
>=> overrideInternalR (onBoth (&&) crHasTarget (crStratConMatches (GetTo (0,0))))
>=> overrideInternalR (onBoth (&&) crHasTarget (crStratConMatches (GetTo (V2 0 0))))
( \ _ -> crActionPlan . crStrategy .~ WatchAndWait )
, _crActionPlan = ActionPlan
{ _crImpulse = []
@@ -81,19 +81,19 @@ chooseMovement' cr w = takeOneWeighted [chargeProb,retreatProb,strafeProb,strafe
`DoImpulsesAlongside`
3
`DoReplicate`
ImpulsesList (replicate 9 [Move (3,0)] ++ [[Move (3,0),UseItem]])
ImpulsesList (replicate 9 [Move (V2 3 0)] ++ [[Move (V2 3 0),UseItem]])
strafeLeftActions =
DoImpulses [TurnToward yposr (2*pi)]
`DoActionThen`
3
`DoReplicate`
ImpulsesList (replicate 9 [Move (0,3)] ++ [[Move (0,3),UseItem]])
ImpulsesList (replicate 9 [Move (V2 0 3)] ++ [[Move (V2 0 3),UseItem]])
strafeRightActions =
DoImpulses [TurnToward yposl (2*pi)]
`DoActionThen`
3
`DoReplicate`
ImpulsesList (replicate 9 [Move (0,-3)] ++ [[Move (0,-3),UseItem]])
ImpulsesList (replicate 9 [Move (V2 (0) (-3))] ++ [[Move (V2 (0) (-3)),UseItem]])
yposl = ypos -.- 100 *.* vNormal (normalizeV $ ypos -.- cpos)
yposr = ypos +.+ 100 *.* vNormal (normalizeV $ ypos -.- cpos)
@@ -103,7 +103,7 @@ retreatActions tcr cr =
`DoImpulsesAlongside`
3
`DoReplicate`
ImpulsesList (replicate 9 [Move (-3,0)] ++ [[UseItem]])
ImpulsesList (replicate 9 [Move (V2 (-3) (0))] ++ [[UseItem]])
where
cpos = _crPos cr
tpos = _crPos tcr
src/Dodge/Creature/SentinelAI.hs
+7 -7
View File
@@ -11,7 +11,7 @@ import Dodge.Creature.Rationality
import Dodge.Creature.AlertLevel
--import Dodge.Creature.State
--import Dodge.Creature.State.Data
--import Geometry
import Geometry.Data
--import Picture
--import Dodge.RandomHelp
@@ -39,7 +39,7 @@ sentinelAI = sentinelExtraWatchUpdate
DoImpulses [ChangeStrategy WatchAndWait]
, AimAtCloseSlow
{ _targetID = tcid
, _targetSeenAt = (0,0) -- hack
, _targetSeenAt = (V2 0 0) -- hack
, _aimSpeed = 0.2
, _slowAimSpeed = 0.01
, _slowAimAngle = pi/8
@@ -66,13 +66,13 @@ sentinelFireType f = performActionsR
>=> reloadOverrideR
>=> targetYouWhenCognizantR
>=> overrideInternalR
(onBoth (&&) crHasTarget (crStratConMatches (GetTo (0,0))))
(onBoth (&&) crHasTarget (crStratConMatches (GetTo (V2 0 0))))
(\ _ -> crActionPlan . crStrategy .~ WatchAndWait)
where
drawwp = DoActionIfElse NoAction crIsAiming (DoActionThen drawWeapon (WaitThen 50 NoAction))
aiming = AimAtCloseSlow
{ _targetID = 0
, _targetSeenAt = (0,0) -- hack
, _targetSeenAt = (V2 0 0) -- hack
, _aimSpeed = 0.2
, _slowAimSpeed = 0.01
, _slowAimAngle = pi/8
@@ -89,7 +89,7 @@ sentinelExtraWatchUpdate xs = performActionsR
>=> doStrategyActionsR
-- >=> reloadOverrideR
>=> targetYouWhenCognizantR
>=> overrideInternalR (onBoth (&&) crHasTarget (crStratConMatches (GetTo (0,0))))
>=> overrideInternalR (onBoth (&&) crHasTarget (crStratConMatches (GetTo (V2 0 0))))
(\ _ -> crActionPlan . crStrategy .~ WatchAndWait)
@@ -104,7 +104,7 @@ shootAtAdvance tcid =
DoImpulses [ChangeStrategy WatchAndWait]
, AimAtCloseSlow
{ _targetID = tcid
, _targetSeenAt = (0,0) -- hack
, _targetSeenAt = (V2 0 0) -- hack
, _aimSpeed = 0.2
, _slowAimSpeed = 0.01
, _slowAimAngle = pi/8
@@ -125,7 +125,7 @@ shootAtWhileContinueTime tcid _ _ = StrategyActions (ShootAt tcid)
DoImpulses [ChangeStrategy WatchAndWait]
, AimAtCloseSlow
{ _targetID = tcid
, _targetSeenAt = (0,0) -- hack
, _targetSeenAt = (V2 0 0) -- hack
, _aimSpeed = 0.2
, _slowAimSpeed = 0.01
, _slowAimAngle = pi/8
src/Dodge/Creature/SpreadGunCrit.hs
+1 -1
View File
@@ -44,7 +44,7 @@ spreadGunCrit = defaultCreature
>=> doStrategyActionsR
>=> reloadOverrideR
>=> targetYouWhenCognizantR
>=> overrideInternalR (onBoth (&&) crHasTarget (crStratConMatches (GetTo (0,0))))
>=> overrideInternalR (onBoth (&&) crHasTarget (crStratConMatches (GetTo (V2 0 0))))
(\ _ -> crActionPlan . crStrategy .~ WatchAndWait)
, _crActionPlan = ActionPlan
{ _crImpulse = []
src/Dodge/Creature/State.hs
+2 -2
View File
@@ -58,7 +58,7 @@ stateUpdate u w (f,g) cr =
. dropByState cr
--crBeforeDeath = colCrWall w cr
addCorpse = IM.insertNewKey
$ uncurry translate (_crOldPos cr)
$ uncurryV translate (_crOldPos cr)
$ rotate (_crDir cr)
(_crCorpse cr)
-- | Drop items according to the creature state.
@@ -78,7 +78,7 @@ Given a creature and a velocity, applies friction to that creature and evaluates
velocity to carry across frames.
-}
crFriction :: Creature -> Point2 -> Point2
crFriction _ _ = (0,0)
crFriction _ _ = (V2 0 0)
doDamage :: Creature -> Creature
doDamage cr = set (crState . crDamage) []
src/Dodge/Creature/YourControl.hs
+9 -9
View File
@@ -37,7 +37,7 @@ wasdWithAiming w speed i cr
| otherwise = theTurn $ theMovement cr
where
theMovement
| movDir == (0,0) = id
| movDir == (V2 0 0) = id
| otherwise = crMvAbsolute (speed *.* movAbs) . set crMvDir dir
theTurn cr' = creatureTurnTowardDir (_crMvDir cr') 0.2 cr'
movDir = wasdDir w
@@ -53,19 +53,19 @@ wasdWithAiming w speed i cr
wasdM :: World -> SDL.Scancode -> Point2
wasdM w scancode
| scancode == moveUpKey (_keyConfig w) = ( 0, 1)
| scancode == moveDownKey (_keyConfig w) = ( 0,-1)
| scancode == moveRightKey (_keyConfig w) = ( 1, 0)
| scancode == moveLeftKey (_keyConfig w) = (-1, 0)
wasdM _ _ = (0,0)
| scancode == moveUpKey (_keyConfig w) = ( V2 (0) ( 1))
| scancode == moveDownKey (_keyConfig w) = (V2 ( 0) (-1))
| scancode == moveRightKey (_keyConfig w) = (V2 ( 1) ( 0))
| scancode == moveLeftKey (_keyConfig w) = (V2 (-1) ( 0))
wasdM _ _ = (V2 0 0)
wasdDir :: World -> Point2
wasdDir w = foldr ((+.+) . wasdM w) (0,0) $ _keys w
wasdDir w = foldr ((+.+) . wasdM w) (V2 0 0) $ _keys w
wasdComp :: S.Set SDL.Scancode -> World -> (Point2,Maybe Float)
wasdComp ks w = f $ foldr ( (+.+) . wasdM w ) (0,0) ks
wasdComp ks w = f $ foldr ( (+.+) . wasdM w ) (V2 0 0) ks
where
f (0,0) = ((0,0), Nothing)
f (V2 0 0) = ((V2 0 0), Nothing)
f p = (errorNormalizeV 46 p, Just $ argV p)
{- | Set posture according to mouse presses. -}
src/Dodge/Default.hs
+11 -11
View File
@@ -22,9 +22,9 @@ import Data.List
defaultCreature :: Creature
defaultCreature = Creature
{ _crPos = (0,0)
, _crOldPos = (0,0)
, _crVel = (0,0)
{ _crPos = (V2 0 0)
, _crOldPos = (V2 0 0)
, _crVel = (V2 0 0)
, _crDir = 0
, _crMvDir = 0
, _crID = 1
@@ -67,7 +67,7 @@ defaultEquipment = Equipment
, _itName = "genericEquipment"
, _itMaxStack = 1
, _itAmount = 1
, _itFloorPict = setLayer 0 $ onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)]
, _itFloorPict = setLayer 0 $ onLayer FlItLayer $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)]
, _itEquipPict = \_ _ -> blank
, _itEffect = NoItEffect
, _itHammer = HammerUp
@@ -127,7 +127,7 @@ applyIndividualDamage (PushDam amount pback) cr
applyIndividualDamage dt cr
= ( id , over crHP (\hp -> hp - _dmAmount dt) cr )
defaultFlIt :: FloorItem
defaultFlIt = FlIt {_flItRot=0,_flIt = defaultIt, _flItPos = (0,0), _flItID = 0}
defaultFlIt = FlIt {_flItRot=0,_flIt = defaultIt, _flItPos = (V2 0 0), _flItID = 0}
defaultIt :: Item
defaultIt = Consumable
{ _itIdentity = Medkit25
@@ -135,7 +135,7 @@ defaultIt = Consumable
, _itMaxStack = 3
, _itAmount = 2
, _cnEffect = const return
, _itFloorPict = onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)]
, _itFloorPict = onLayer FlItLayer $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)]
, _itEquipPict = \_ _ -> blank
, _itID = Nothing
, _itInvDisplay = _itName
@@ -147,7 +147,7 @@ defaultIt = Consumable
defaultButton :: Button
defaultButton = Button
{ _btPict = onLayer WlLayer $ color red $ polygon $ rectNSEW 5 (-5) 10 (-10)
, _btPos = (0,0)
, _btPos = (V2 0 0)
, _btRot = 0
, _btEvent = \b w ->
set (buttons . ix (_btID b) . btPict) (onLayer WlLayer $ color red $ polygon $ rectNSEW (-4) (-5) 10 (-10))
@@ -159,9 +159,9 @@ defaultButton = Button
}
defaultPT :: Projectile
defaultPT = Projectile
{ _pjPos = (0,0)
, _pjStartPos = (0,0)
, _pjVel = (0,0)
{ _pjPos = (V2 0 0)
, _pjStartPos = (V2 0 0)
, _pjVel = (V2 0 0)
, _pjDraw = const blank
, _pjID = 0
, _pjUpdate = const id
@@ -169,7 +169,7 @@ defaultPT = Projectile
defaultPP :: PressPlate
defaultPP = PressPlate
{ _ppPict = onLayer PressPlateLayer $ color (dim $ dim $ bright blue) $ circleSolid 5
, _ppPos = (0,0)
, _ppPos = (V2 0 0)
, _ppRot = 0
, _ppEvent = const id
, _ppID = -1
src/Dodge/Item.hs
+5 -4
View File
@@ -6,6 +6,7 @@ import Dodge.Item.Data
import Dodge.Default
import Dodge.Picture
import Picture
import Geometry.Data
keyToken :: Int -> Item
keyToken n = defaultEquipment
@@ -27,8 +28,8 @@ keyToken n = defaultEquipment
keyPic :: Picture
keyPic = color green $
pictures [translate (-4) 0 $ thickCircle 4 2
,lineOfThickness 2 [(0,0),(8,0),(8,-4)]
,lineOfThickness 2 [(4,0),(4,-4)]
,lineOfThickness 2 $ map toV2 [(0,0),(8,0),(8,-4)]
,lineOfThickness 2 $ map toV2 [(4,0),(4,-4)]
]
latchkey :: Int -> Item
@@ -51,6 +52,6 @@ latchkey n = defaultEquipment
latchkeyPic :: Picture
latchkeyPic = color yellow $
pictures [translate (-4) 0 $ thickCircle 4 2
,lineOfThickness 2 [(0,0),(8,0),(8,-4)]
,lineOfThickness 2 [(4,0),(4,-4)]
,lineOfThickness 2 $ map toV2 [(0,0),(8,0),(8,-4)]
,lineOfThickness 2 $ map toV2 [(4,0),(4,-4)]
]
src/Dodge/Item/Equipment.hs
+3 -3
View File
@@ -13,7 +13,7 @@ magShield = defaultEquipment
, _itName = "MAGSHIELD"
, _itMaxStack = 1
, _itAmount = 1
, _itFloorPict = onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)]
, _itFloorPict = onLayer FlItLayer $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)]
, _itEquipPict = \_ _ -> blank
, _itID = Nothing
}
@@ -23,7 +23,7 @@ flameShield = defaultEquipment
, _itName = "FLAMESHIELD"
, _itMaxStack = 1
, _itAmount = 1
, _itFloorPict = onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)]
, _itFloorPict = onLayer FlItLayer $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)]
, _itEquipPict = \cr _ -> onLayer CrLayer $ pictures [color cyan $ circle (_crRad cr+2)]
, _itID = Nothing
}
@@ -52,7 +52,7 @@ jetPack = defaultEquipment
, _itName = "JETPACK"
, _itMaxStack = 1
, _itAmount = 1
, _itFloorPict = onLayer FlItLayer $ color yellow $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)]
, _itFloorPict = onLayer FlItLayer $ color yellow $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)]
, _itEquipPict = \_ _ -> onLayer CrLayer
$ pictures [color yellow $ polygon $ rectNSEW 5 (-5) (-3) (-11) ]
, _itEffect = NoItEffect
src/Dodge/Item/Weapon.hs
+33 -33
View File
@@ -188,7 +188,7 @@ forceFieldGun = defaultGun
, _itUse = undefined
, _wpSpread = 0.02
, _wpRange = 20
, _itFloorPict = onLayer FlItLayer $ polygon [(-4,-4),(-4,4),(4,4),(4,0),(0,0),(0,-4)]
, _itFloorPict = onLayer FlItLayer $ polygon $ map toV2 [(-4,-4),(-4,4),(4,4),(4,0),(0,0),(0,-4)]
, _itAimingSpeed = 0.4
, _itAimingRange = 0.5
}
@@ -253,7 +253,7 @@ remoteLauncher = defaultGun
, _itAimingSpeed = 0.2
, _itAimingRange = 0.5
, _itEquipPict = pictureWeaponOnAim $ color cyan $ polygon $ rectNESW 5 5 (-5) (-5)
, _itAttachment = Just $ ItScope (0,0) 0 1 True
, _itAttachment = Just $ ItScope (V2 0 0) 0 1 True
}
hvAutoGun :: Item
hvAutoGun = defaultAutoGun
@@ -292,7 +292,7 @@ ltAutoGun = defaultAutoGun
, _itUseRate = 3
, _itUseTime = 0
, _itUse = \_ -> shootWithSound 0 . withRandomDir 0.3 . withSidePush 50
. withMuzFlare $ withVelWthHiteff (30,0) 2 basicBulletEffect
. withMuzFlare $ withVelWthHiteff (V2 30 0) 2 basicBulletEffect
, _wpSpread = 0.5
, _wpRange = 20
, _itFloorPict = onLayer FlItLayer ltAutoGunPic
@@ -321,7 +321,7 @@ miniGun = defaultAutoGun
. withRandomDir 0.1
. withRandomOffset 9
. withMuzFlare
. withVelWthHiteff (30,0) 2
. withVelWthHiteff (V2 30 0) 2
$ destroyOnImpact bulBounceArmCr' bulHitWall' bulHitFF'
, _wpRange = 20
, _itFloorPict = onLayer FlItLayer miniGunPict
@@ -348,13 +348,13 @@ spreadGun = defaultGun
, _itUse = \_ -> shootWithSound (fromIntegral shotgunSound)
. withRecoil 100
. withMuzFlare
$ spreadNumVelWthHiteff spreadGunSpread 9 (30,0) 2 basicBulletEffect
$ spreadNumVelWthHiteff spreadGunSpread 9 (V2 30 0) 2 basicBulletEffect
, _wpSpread = spreadGunSpread
, _wpRange = 20
, _itFloorPict = onLayer FlItLayer $ color green $ pictures [ polygon [(-3,0),(3,6),(3,-6)] ]
, _itFloorPict = onLayer FlItLayer $ color green $ pictures [ polygon $ map toV2[(-3,0),(3,6),(3,-6)] ]
, _itAimingSpeed = 1
, _itAimingRange = 0
, _itEquipPict = pictureWeaponOnAim $ color green $ pictures [ polygon [(-3,0),(3,6),(3,-6)] ]
, _itEquipPict = pictureWeaponOnAim $ color green $ pictures [ polygon $ map toV2[(-3,0),(3,6),(3,-6)] ]
}
multGun :: Item
multGun = defaultGun
@@ -369,7 +369,7 @@ multGun = defaultGun
, _itUse = \_ -> shootWithSound (fromIntegral shotgunSound)
. withRecoil 200
. withMuzFlare
$ numVelWthHitEff 5 (50,0) 5 basicBulletEffect
$ numVelWthHitEff 5 (V2 50 0) 5 basicBulletEffect
, _wpSpread = spreadGunSpread
, _wpRange = 20
, _itFloorPict = onLayer FlItLayer multGunPic
@@ -388,7 +388,7 @@ multGunPic = color red $ pictures
, polygon $ rectNSEW 2 (-2) 2 (-2)
, polygon $ rectNSEW (-3) (-7) 2 (-2)
, polygon $ rectNSEW (-8) (-12) 2 (-2)
, polygon [(-1.5,12),(-2,12),(-2,-12),(-1.5,-12)]
, polygon $ map toV2 [(-1.5,12),(-2,12),(-2,-12),(-1.5,-12)]
]
]
longGun :: Item
@@ -414,7 +414,7 @@ longGun = defaultGun
, _itZoom = defaultItZoom {_itAimZoomMax = 0.5, _itAimZoomMin = 0.5}
, _itEquipPict = pictureWeaponOnAim longGunPic
, _itScroll = zoomLongGun
, _itAttachment = Just $ ItScope (0,0) 0 1 False
, _itAttachment = Just $ ItScope (V2 0 0) 0 1 False
, _itEffect = itemLaserScopeEffect
, _wpAmmo = hvBullet
, _itAimStance = TwoHandTwist
@@ -492,7 +492,7 @@ blinkGun = defaultGun
, _itLeftClickUse = Just $ hammerCheckL $ shootL aSelfL
, _wpSpread = 0.05
, _wpRange = 20
, _itFloorPict = onLayer FlItLayer $ polygon [(-2,-2),(-2,2),(2,2),(2,0),(0,0),(0,-2)]
, _itFloorPict = onLayer FlItLayer $ polygon $ map toV2[(-2,-2),(-2,2),(2,2),(2,0),(0,0),(0,-2)]
, _itAimingSpeed = 1
, _itAimingRange = 0
}
@@ -510,7 +510,7 @@ boosterGun = defaultGun
, _itLeftClickUse = Just $ boostSelfL 10
, _wpSpread = 0.05
, _wpRange = 20
, _itFloorPict = onLayer FlItLayer $ polygon [(-2,-2),(-2,2),(2,2),(2,0),(0,0),(0,-2)]
, _itFloorPict = onLayer FlItLayer $ polygon $ map toV2 [(-2,-2),(-2,2),(2,2),(2,0),(0,0),(0,-2)]
, _itAimingSpeed = 1
, _itAimingRange = 0
, _itEffect = resetAttachmentID
@@ -536,8 +536,8 @@ aTeslaArc' cr w
remoteShellPic' :: Projectile -> Picture
remoteShellPic' pj
| t > 40 = onLayerL [levLayer CrLayer - 2]
$ uncurry translate pos $ rotate dir $ remoteShellPic t
| otherwise = uncurry translate pos $ rotate dir $ remoteShellPic t
$ uncurryV translate pos $ rotate dir $ remoteShellPic t
| otherwise = uncurryV translate pos $ rotate dir $ remoteShellPic t
where
t = _pjTimer pj
pos = _pjPos pj
@@ -547,9 +547,9 @@ remoteShellPic
:: Int -- ^ Timer
-> Picture
remoteShellPic t
| rem (t+200) 20 < 9 = setDepth 20 $ polygon [(-6,4),(-6,-4),(6,-4),(8,0),(6,4)]
| rem (t+200) 20 < 9 = setDepth 20 $ polygon $ map toV2 [(-6,4),(-6,-4),(6,-4),(8,0),(6,4)]
| otherwise = pictures
[ setDepth 20 $ polygon [(-6,4),(-6,-4),(6,-4),(8,0),(6,4)]
[ setDepth 20 $ polygon $ map toV2 [(-6,4),(-6,-4),(6,-4),(8,0),(6,4)]
, setLayer 1 . setDepth 20.5 . color col $ circleSolid 3
]
where
@@ -594,7 +594,7 @@ pointToItem (OnFloor flid) = floorItems . ix flid . flIt
retireRemoteRocket :: Int -> Int -> Int -> World -> World
retireRemoteRocket itid 0 pjid w =
set (pointToItem (_itemPositions w IM.! itid) . itAttachment . _Just . scopePos) (0,0)
set (pointToItem (_itemPositions w IM.! itid) . itAttachment . _Just . scopePos) (V2 0 0)
$ set (pointToItem (_itemPositions w IM.! itid) . itUse) (\_ -> hammerCheck fireRemoteLauncher)
(w & projectiles %~ IM.delete pjid)
retireRemoteRocket itid t pjid w = setScope w
@@ -605,12 +605,12 @@ retireRemoteRocket itid t pjid w = setScope w
& creatures . ix cid . crInv . ix invid . itAttachment
. _Just . scopePos .~ (pos -.- _crPos (_creatures w' IM.! cid))
_ -> w'
pos = fromMaybe (0,0) $ w ^? projectiles . ix pjid . pjPos
pos = fromMaybe (V2 0 0) $ w ^? projectiles . ix pjid . pjPos
retireRemoteBomb :: Int -> Int -> Int -> World -> World
retireRemoteBomb itid 0 pjid w = w
& pointToItem (_itemPositions w IM.! itid) %~
( (itAttachment . _Just . scopePos .~ (0,0))
( (itAttachment . _Just . scopePos .~ (V2 0 0))
. (itZoom .~ defaultItZoom)
. (itUse .~ (\_ -> hammerCheck throwRemoteBomb))
)
@@ -623,7 +623,7 @@ retireRemoteBomb itid t pjid w = setScope w
& creatures . ix cid . crInv . ix invid . itAttachment
. _Just . scopePos .~ (pos -.- _crPos (_creatures w' IM.! cid))
_ -> w'
pos = fromMaybe (0,0) $ w ^? projectiles . ix pjid . pjPos
pos = fromMaybe (V2 0 0) $ w ^? projectiles . ix pjid . pjPos
moveRemoteBomb :: Int -> Int -> Int -> World -> World
moveRemoteBomb itid time pID w
@@ -657,7 +657,7 @@ moveRemoteBomb itid time pID w
| otherwise = x - 1
updatePicture =
set (projectiles . ix pID . pjDraw)
(\_ -> onLayer PtLayer $ uncurry translate newPos $ remoteBombPic time)
(\_ -> onLayer PtLayer $ uncurryV translate newPos $ remoteBombPic time)
. lowLightDirected
(withAlpha 0.1 red)
newPos
@@ -686,7 +686,7 @@ grenade = Throwable
, _itIdentity = Grenade
, _itMaxStack = 8
, _itAmount = 1
, _itFloorPict = onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)]
, _itFloorPict = onLayer FlItLayer $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)]
, _twMaxRange = 150
, _twAccuracy = 30
, _itUse = \_ -> useTimeCheck $ throwGrenade makeExplosionAt
@@ -736,11 +736,11 @@ remoteBomb = defaultThrowable
, _itIdentity = RemoteBomb
, _itMaxStack = 1
, _itAmount = 1
, _itFloorPict = onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)]
, _itFloorPict = onLayer FlItLayer $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)]
, _twMaxRange = 150
, _twAccuracy = 30
, _itUse = \_ -> hammerCheck throwRemoteBomb
, _itAttachment = Just $ ItScope (0,0) 0 1 True
, _itAttachment = Just $ ItScope (V2 0 0) 0 1 True
, _itEquipPict = pictureWeaponOnAim remoteBombUnarmedPic
}
@@ -754,15 +754,15 @@ fireRemoteLauncher cr w = setLocation
i = IM.newKey $ _projectiles w
cid = _crID cr
dir = _crDir cr
pos = _crPos cr +.+ rotateV dir (_crRad cr + 1,0)
pos = _crPos cr +.+ rotateV dir (V2 (_crRad cr + 1) (0))
remRocket = IM.insert i $ Shell
{ _pjPos = pos
, _pjStartPos = pos
, _pjVel = rotateV dir (1,0)
, _pjVel = rotateV dir (V2 1 0)
, _pjDraw = remoteShellPic'
, _pjID = i
, _pjUpdate = \pj -> decTimMvVel pj . setRemoteScope itid pj . moveRemoteShell cid itid pj
, _pjAcc = (0,0)
, _pjAcc = (V2 0 0)
, _pjDir = dir
, _pjSpin = 0
, _pjPayload = makeExplosionAt
@@ -814,7 +814,7 @@ moveRemoteShell cid itid pj w
&& w ^? creatures . ix cid . crInvSel == w ^? itemPositions . ix itid . itInvId
= _cameraRot w + argV (_mousePos w)
| otherwise = _pjDir pj
accel = rotateV newdir (2,0)
accel = rotateV newdir (V2 2 0)
(frict,g) = randomR (0.6,0.9) $ _randGen w
(sparkD,_) = randomR (-0.5,0.5) $ _randGen w
hitCr = fst <$> collideCircCrsPoint oldPos newPos 4 w
@@ -864,8 +864,8 @@ throwRemoteBomb cr w = setLocation
removePict = set (creatures . ix cid . crInv . ix j . itEquipPict) $ \ _ _ -> blank
resetFire = set (creatures . ix cid . crInv . ix j . itUse)
$ \_ -> hammerCheck $ explodeRemoteBomb itid i
p' = _crPos cr +.+ rotateV (_crDir cr) (_crRad cr,0)
p | circOnSomeWall p' 4 w = _crPos cr +.+ rotateV (_crDir cr) (_crRad cr-4,0)
p' = _crPos cr +.+ rotateV (_crDir cr) (V2 (_crRad cr) (0))
p | circOnSomeWall p' 4 w = _crPos cr +.+ rotateV (_crDir cr) (V2 (_crRad cr-4) (0))
| otherwise = p'
maybeitid = w ^? creatures . ix cid . crInv . ix j . itID . _Just
setLocation :: World -> World
@@ -912,7 +912,7 @@ pipe = Craftable
, _itName = "PIPE"
, _itMaxStack = 3
, _itAmount = 3
, _itFloorPict = onLayer FlItLayer $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)]
, _itFloorPict = onLayer FlItLayer $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)]
, _itEquipPict = \_ _ -> blank
, _itID = Nothing
, _itInvDisplay = _itName
@@ -972,7 +972,7 @@ autoSonar = defaultEquipment
, _itName = "AUTOSONAR"
, _itMaxStack = 1
, _itAmount = 1
, _itFloorPict = onLayer FlItLayer $ color yellow $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)]
, _itFloorPict = onLayer FlItLayer $ color yellow $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)]
, _itEquipPict = \_ _ -> blank
, _itEffect = autoSonarEffect
, _itID = Nothing
@@ -988,7 +988,7 @@ autoRadar = defaultEquipment
, _itName = "AUTORADAR"
, _itMaxStack = 1
, _itAmount = 1
, _itFloorPict = onLayer FlItLayer $ color yellow $ polygon [(-3,-3),(-3,3),(3,3),(3,-3)]
, _itFloorPict = onLayer FlItLayer $ color yellow $ polygon $ map toV2 [(-3,-3),(-3,3),(3,3),(3,-3)]
, _itEquipPict = \_ _ -> blank
, _itEffect = autoRadarEffect
, _itID = Nothing
src/Dodge/Item/Weapon/AutoGun.hs
+1 -1
View File
@@ -56,7 +56,7 @@ singleFireMode = hammerCheck $ shootWithSound (fromIntegral autoGunSound) autoGu
autoGunNonTwistEff = withRecoil 40
. withRandomDir (autogunSpread/2)
. withMuzFlare
. withVelWthHiteff (50,0) 3
. withVelWthHiteff (V2 50 0) 3
$ destroyOnImpact bulHitCr bulHitWall' bulHitFF'
autoGunPic :: Picture
src/Dodge/Item/Weapon/Bezier.hs
+1 -1
View File
@@ -59,7 +59,7 @@ shootBezier targetp cr w = w & particles %~ (theBullet :)
controlp = mouseWorldPos w
cid = _crID cr
dir = _crDir cr
startp = _crPos cr +.+ rotateV dir (_crRad cr + 1,0)
startp = _crPos cr +.+ rotateV dir (V2 (_crRad cr + 1) (0))
(randPos,randPos') = flip evalState (_randGen w) $ do
a <- randInCirc 10
b <- randInCirc 20
src/Dodge/Item/Weapon/Bullet.hs
+4 -2
View File
@@ -3,17 +3,19 @@ module Dodge.Item.Weapon.Bullet
import Dodge.Data
import Dodge.WorldEvent.HitEffect
import Dodge.Particle.Bullet.HitEffect
import Geometry.Data
basicBullet :: Ammo
basicBullet = BulletAmmo
{ _amString = "BULLET"
, _amBulEff = destroyOnImpact bulHitCr bulHitWall' bulHitFF'
, _amBulWth = 2
, _amBulVel = (30,0)
, _amBulVel = (V2 30 0)
}
hvBullet :: Ammo
hvBullet = BulletAmmo
{ _amString = "HVBULLET"
, _amBulEff = penWalls hvBulHitCr hvBulHitWall' bulHitFF'
, _amBulWth = 6
, _amBulVel = (80,0)
, _amBulVel = (V2 80 0)
}
src/Dodge/Item/Weapon/ExtraEffect.hs
+4 -3
View File
@@ -16,6 +16,7 @@ import Dodge.Picture.Layer
import Dodge.Creature.Test
import Picture
import Geometry.Vector
import Geometry.Data
import Data.Maybe
import Control.Lens
@@ -123,11 +124,11 @@ targetRBMousePos w = (f, \_ _ _ w' -> cursorPic w')
where
f _ = Just mwp
mwp = mouseWorldPos w
cursorPic w' = setLayer 1 $ onLayer InvLayer $ uncurry translate mwp
cursorPic w' = setLayer 1 $ onLayer InvLayer $ uncurryV translate mwp
$ rotate (_cameraRot w')
$ pictures
[line [( x,x), (-x,-x)]
,line [(-x,x), ( x,-x)]
[line [( V2 (x) (x)), (V2 (-x) (-x))]
,line [(V2 (-x) (x)), (V2 ( x) (-x))]
]
where
x = 5 / _cameraZoom w'
src/Dodge/Item/Weapon/Launcher.hs
+4 -4
View File
@@ -134,8 +134,8 @@ aRocketWithItemParams it cr w = over projectiles (IM.insert i theShell) w
theShell = defaultShell
{ _pjPos = pos
, _pjStartPos = pos
, _pjVel = rotateV dir (1,0)
, _pjAcc = rotateV dir (3,0)
, _pjVel = rotateV dir (V2 1 0)
, _pjAcc = rotateV dir (V2 3 0)
, _pjDraw = _amPjDraw am
, _pjID = i
, _pjUpdate = \pj -> ammoMvs pj . decTimMvVel pj . moveShell pj
@@ -173,9 +173,9 @@ reduceSpinBy :: Float -> Projectile -> World -> World
reduceSpinBy x pj = projectiles . ix (_pjID pj) . pjSpin *~ x
shellPic :: Projectile -> Picture
shellPic pj = setDepth 20 . uncurry translate pos $ rotate (argV accel) basePic
shellPic pj = setDepth 20 . uncurryV translate pos $ rotate (argV accel) basePic
where
basePic = color black $ polygon [(-6,4),(-6,-4),(6,-4),(8,0),(6,4)]
basePic = color black $ polygon $ map toV2 [(-6,4),(-6,-4),(6,-4),(8,0),(6,4)]
accel = _pjAcc pj
pos = _pjPos pj
src/Dodge/Item/Weapon/TriggerType.hs
+6 -5
View File
@@ -128,7 +128,7 @@ withRecoil
withRecoil recoilAmount eff cr = eff cr . over (creatures . ix cid) pushback
where
cid = _crID cr
pushback = over crPos (+.+ rotateV (_crDir cr) ((-recoilAmount) / _crMass cr ,0))
pushback = over crPos (+.+ rotateV (_crDir cr) (V2 ((-recoilAmount) / _crMass cr ) (0)))
{- | Pushes a creature sideways by a random amount.
Applied before the underlying effect. -}
withSidePush
@@ -140,8 +140,9 @@ withSidePush
withSidePush maxSide eff cr w = eff cr . over (creatures . ix cid) push $ w
where
cid = _crID cr
push = over crPos (+.+ rotateV (_crDir cr) (0,pushAmount / _crMass cr))
push = over crPos (+.+ rotateV (_crDir cr) (V2 (0) (pushAmount / _crMass cr)))
(pushAmount, _) = randomR (-maxSide,maxSide) $ _randGen w
-- consider unifying the pushes using a direction vector
{- | Pushes a creature sideways by a random amount.
Applied after the underlying effect. -}
withSidePushAfter
@@ -153,7 +154,7 @@ withSidePushAfter
withSidePushAfter maxSide eff cr w = over (creatures . ix cid) push . eff cr $ w
where
cid = _crID cr
push = over crPos (+.+ rotateV (_crDir cr) (0,pushAmount / _crMass cr))
push = over crPos (+.+ rotateV (_crDir cr) (V2 (0) (pushAmount / _crMass cr)))
(pushAmount, _) = randomR (-maxSide,maxSide) $ _randGen w
{- | Applies a world effect and sound effect after an ammo check. -}
shootWithSound
@@ -369,7 +370,7 @@ withRandomOffset
withRandomOffset offsetAmount f cr w = f (cr & crPos %~ (+.+ offV)) $ set randGen g w
where
(offsetVal , g) = randomR (-offsetAmount,offsetAmount) $ _randGen w
offV = rotateV (_crDir cr) (0,offsetVal)
offV = rotateV (_crDir cr) (V2 0 offsetVal)
-- | Rotates a creature with minimum rotation at least 0.1.
-- Rotates the player creature before applying the effect, other creatures after.
torqueBeforeForced
@@ -461,7 +462,7 @@ numVelWthHitEff num vel wth eff cr = over particles (newbuls ++)
d = _crDir cr
poss = map (+.+ pos) $ take num offsets
maxOffset = fromIntegral num * 2.5 - 2.5
offsets = map (\y -> rotateV d (0,y)) [-maxOffset,5-maxOffset..]
offsets = map (\y -> rotateV d (V2 0 y)) [-maxOffset,5-maxOffset..]
pos = _crPos cr +.+ _crRad cr *.* unitVectorAtAngle d
{- | Uses '_wpSpread' as a parameter for the current offset angle. -}
randWalkAngle
src/Dodge/Item/Weapon/UseEffect.hs
+2 -2
View File
@@ -42,7 +42,7 @@ mvBlip p col maxt t w pt =
& ptDraw .~ ( const
. setDepth (-0.5)
. setLayer 1
. uncurry translate p
. uncurryV translate p
. color (withAlpha (fromIntegral t / fromIntegral maxt) col)
$ circleSolid 2 )
)
@@ -64,7 +64,7 @@ mvSonar x p w pt = (w, Just $ pt {_ptDraw = const pic
crBlips = mapMaybe crBlip $ IM.elems $ _creatures w
crBlip cr | dist cpos p < r + crad && dist cpos p > r - (crad + 100)
= Just $ colHelper (0.5 * (1 - (r - dist cpos p) /100))
$ uncurry translate cpos $ circleSolid crad
$ uncurryV translate cpos $ circleSolid crad
| otherwise = Nothing
where crad = _crRad cr
cpos = _crPos cr
src/Dodge/Room.hs
+123 -121
View File
@@ -33,6 +33,7 @@ import Dodge.Room.Door
import Dodge.Room.Airlock
import Dodge.Room.LongDoor
import Geometry
import Geometry.Data
import Picture
import Tile
@@ -41,6 +42,7 @@ import Control.Monad.State
import Control.Monad.Loops
import System.Random
import Data.Tree
import Data.Bifunctor
--import qualified Data.Map as M
--import qualified Data.IntMap.Strict as IM
@@ -49,12 +51,12 @@ roomC x y = defaultRoom
{ _rmPolys = [rectNSWE y 0 0 x]
, _rmLinks = lnks
, _rmPath = []
, _rmPS = [windowLine (x/2,0) (x/2,y-60)
, _rmPS = [windowLine (V2 (x/2) (0)) (V2 (x/2) (y-60))
]
, _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)]
}
where
lnks =
lnks = map (first toV2)
[( (x-20, 0),pi)
,( ( 20, 0),pi)
,( ( 0, 20),pi/2)
@@ -63,17 +65,17 @@ roomC x y = defaultRoom
roomPadCut :: [Point2] -> Point2 -> Room
roomPadCut ps p = defaultRoom
{ _rmPolys = [ps]
, _rmLinks = [(p,0),((0,0),pi)]
, _rmPath = [((0,0),p)]
, _rmLinks = [(p,0),((V2 0 0),pi)]
, _rmPath = [((V2 0 0),p)]
, _rmPS = []
, _rmBound = []
}
roomPillars :: Room
roomPillars = over rmLinks init $ set rmPS plmnts $ roomRect 240 240 2 2
where
plmnts = sPS (120,120) 0 putLamp
: sPS (12,12) 0 putLamp
: sPS (228,228) 0 putLamp
plmnts = sPS (V2 120 120) 0 putLamp
: sPS (V2 12 12) 0 putLamp
: sPS (V2 228 228) 0 putLamp
: g 180 150 90 60
f a x b y = putBlockRect a x b y
g a b c d = f a b a b ++ f a b c d ++ f c d a b ++ f c d c d
@@ -88,15 +90,15 @@ glassSwitchBack = do
wllen <- state $ randomR (60,wth/2-40)
let hf = hgt/5
let plmnts =
[windowLine (wth-60, hf) (wllen,hf)
,windowLine (wth-wllen,2*hf) (60, 2*hf)
,windowLine (wth-60, 3*hf) (wllen,3*hf)
,windowLine (wth-wllen,4*hf) (60, 4*hf)
,blockLine ( 0, 1*hf) (wllen,1*hf)
,blockLine (wth-wllen, 2*hf) ( wth,2*hf)
,blockLine ( 0, 3*hf) (wllen,3*hf)
,blockLine (wth-wllen, 4*hf) ( wth,4*hf)
, sPS (wth/2,hgt/2) 0 putLamp
[windowLine (V2 (wth-60 ) ( hf)) (V2 (wllen) (hf) )
,windowLine (V2 (wth-wllen) (2*hf)) (V2 (60 ) (2*hf))
,windowLine (V2 (wth-60 ) (3*hf)) (V2 (wllen) (3*hf))
,windowLine (V2 (wth-wllen) (4*hf)) (V2 (60 ) (4*hf))
,blockLine (V2 ( 0) (1*hf)) (V2 (wllen) (1*hf))
,blockLine (V2 (wth-wllen) (2*hf)) (V2 ( wth) (2*hf))
,blockLine (V2 ( 0) (3*hf)) (V2 (wllen) (3*hf))
,blockLine (V2 (wth-wllen) (4*hf)) (V2 ( wth) (4*hf))
, sPS (V2 (wth/2) (hgt/2)) 0 putLamp
]
return $ set rmPS plmnts $ roomRect wth hgt 2 6
@@ -112,14 +114,14 @@ glassLesson = do
botRoom = set rmPS botplmnts $ roomRect 200 200 1 1
topRoom = set rmPS topplmnts $ roomRect 200 200 1 1
botplmnts =
[sPS (0,0) 0 $ PutWall (rectNSWE 200 0 90 110) defaultCrystalWall
,sPS (50,100) 0 $ PutCrit miniGunCrit
,sPS (50,50) 0 putLamp
[sPS (V2 0 0) 0 $ PutWall (rectNSWE 200 0 90 110) defaultCrystalWall
,sPS (V2 50 100) 0 $ PutCrit miniGunCrit
,sPS (V2 50 50) 0 putLamp
]
topplmnts =
[windowLine (100,200) (100,0)
,sPS (50,100) 0 $ PutCrit miniGunCrit
,sPS (50,50) 0 putLamp
[windowLine (V2 100 200) (V2 100 0)
,sPS (V2 50 100) 0 $ PutCrit miniGunCrit
,sPS (V2 50 50) 0 putLamp
]
miniRoom1 :: RandomGen g => State g Room
@@ -133,45 +135,45 @@ miniRoom1 = do
,50+4*hf,30+5*hf
]
crx <- state $ randomR (wllen,wth-(wllen+40))
let plmnts = [windowLine (wth-60, 40+hf) (wllen,40+hf)
,windowLine (wth-wllen,40+2*hf) (60,40+2*hf)
,windowLine (wth-60, 40+3*hf) (wllen,40+3*hf)
,windowLine (wth-wllen,40+4*hf) (60,40+4*hf)
,sPS (crx,cry) 0 $ PutCrit miniGunCrit
,sPS (wth-20,hgt/2+40) 0 randC1
,sPS (wth/2,hgt/2) 0 putLamp
,blockLine ( 0, 40+1*hf) (wllen,40+1*hf)
,blockLine (wth-wllen, 40+2*hf) ( wth,40+2*hf)
,blockLine ( 0, 40+3*hf) (wllen,40+3*hf)
,blockLine (wth-wllen, 40+4*hf) ( wth,40+4*hf)
let plmnts = [windowLine (V2 (wth-60) ( 40+hf)) (V2 (wllen) (40+hf))
,windowLine (V2 (wth-wllen) (40+2*hf)) (V2 (60) (40+2*hf))
,windowLine (V2 (wth-60) ( 40+3*hf)) (V2 (wllen) (40+3*hf))
,windowLine (V2 (wth-wllen) (40+4*hf)) (V2 (60) (40+4*hf))
,sPS (V2 crx cry) 0 $ PutCrit miniGunCrit
,sPS (V2 (wth-20) (hgt/2+40)) 0 randC1
,sPS (V2 (wth/2) (hgt/2)) 0 putLamp
,blockLine (V2 ( 0) ( 40+1*hf)) (V2 (wllen) (40+1*hf))
,blockLine (V2 (wth-wllen) ( 40+2*hf)) (V2 ( wth) (40+2*hf))
,blockLine (V2 ( 0) ( 40+3*hf)) (V2 (wllen) (40+3*hf))
,blockLine (V2 (wth-wllen) ( 40+4*hf)) (V2 ( wth) (40+4*hf))
]
return $ set rmPS plmnts $ shiftRoomBy ((0,40),0) $ roomRect wth hgt 2 4
return $ set rmPS plmnts $ shiftRoomBy ((V2 0 40),0) $ roomRect wth hgt 2 4
miniTree2 :: RandomGen g => State g (Tree (Either Room Room))
miniTree2 = miniRoom1
>>= randomiseOutLinks
>>= changeLinkTo (\p -> (snd . fst) p < 70)
>>= changeLinkTo (\p -> (sndV2 . fst) p < 70)
<&> flip branchWith (replicate 3 $ treeFromPost [door,corridor] critInDeadEnd)
miniRoom3 :: RandomGen g => State g (Tree (Either Room Room))
miniRoom3 = do
w <- state $ randomR (300,400)
h <- state $ randomR (300,400)
let cp = (0,h/2+40)
let b = PutBlock [5,20,20] (greyN 0.5) [(-10,-60)
let cp = (V2 (0) (h/2+40))
let b = PutBlock [5,20,20] (greyN 0.5) $ map toV2 [(-10,-60)
,( 10,-60)
,( 10,-80)
,(-10,-80)
]
let plmnts = [sPS cp 0 $ PutCrit miniGunCrit
,sPS cp 0 $ windowLineType (0,-40) (0,-80)
,sPS cp (1*pi/4) $ windowLineType (0,-40) (0,-80)
,sPS cp (2*pi/4) $ windowLineType (0,-40) (0,-80)
,sPS cp (3*pi/4) $ windowLineType (0,-40) (0,-80)
,sPS cp (4*pi/4) $ windowLineType (0,-40) (0,-80)
,sPS cp (5*pi/4) $ windowLineType (0,-40) (0,-80)
,sPS cp (6*pi/4) $ windowLineType (0,-40) (0,-80)
,sPS cp (7*pi/4) $ windowLineType (0,-40) (0,-80)
,sPS cp 0 $ windowLineType (V2 0 (-40)) (V2 0 (-80))
,sPS cp (1*pi/4) $ windowLineType (V2 0 (-40)) (V2 0 (-80))
,sPS cp (2*pi/4) $ windowLineType (V2 0 (-40)) (V2 0 (-80))
,sPS cp (3*pi/4) $ windowLineType (V2 0 (-40)) (V2 0 (-80))
,sPS cp (4*pi/4) $ windowLineType (V2 0 (-40)) (V2 0 (-80))
,sPS cp (5*pi/4) $ windowLineType (V2 0 (-40)) (V2 0 (-80))
,sPS cp (6*pi/4) $ windowLineType (V2 0 (-40)) (V2 0 (-80))
,sPS cp (7*pi/4) $ windowLineType (V2 0 (-40)) (V2 0 (-80))
,sPS cp (pi/8) b
,sPS cp (pi/8+1*pi/4) b
,sPS cp (pi/8+2*pi/4) b
@@ -180,7 +182,7 @@ miniRoom3 = do
,sPS cp (pi/8+5*pi/4) b
,sPS cp (pi/8+6*pi/4) b
,sPS cp (pi/8+7*pi/4) b
,sPS (w/2,h/2) 0 putLamp
,sPS (V2 (w/2) (h/2)) 0 putLamp
]
fmap connectRoom $ randomiseOutLinks $ set rmPS plmnts $ roomRectAutoLinks w h
@@ -203,14 +205,14 @@ roomMiniIntro = fmap (g . expandTreeBy f) $ sequence $ treeFromPost
g (Node y ys) = Node y $ map g ys
roomCenterPillar :: RandomGen g => State g Room
roomCenterPillar = changeLinkTo ((\p -> dist p (120,0) < 10) . fst)
roomCenterPillar = changeLinkTo ((\p -> dist p (V2 120 0) < 10) . fst)
$ set rmPS plmnts $ roomRect 240 240 2 2
where
plmnts =
[ blockLine (115,115) (115,125)
, blockLine (125,115) (125,125)
, sPS (40,120) 0 putLamp
, sPS (200,120) 0 putLamp
[ blockLine (V2 115 115) (V2 115 125)
, blockLine (V2 125 115) (V2 125 125)
, sPS (V2 40 120) 0 putLamp
, sPS (V2 200 120) 0 putLamp
]
roomOctogon :: Room
@@ -219,12 +221,12 @@ roomOctogon = defaultRoom
, _rmLinks = lnks
, _rmPath = allPairs $ map fst lnks
, _rmPS = []
, _rmBound = [[(-20,30),(20,30),(60,70),(60,110),(20,150),(-20,150),(-60,110),(-60,70)] ]
, _rmBound = [map toV2 [(-20,30),(20,30),(60,70),(60,110),(20,150),(-20,150),(-60,110),(-60,70)] ]
, _rmFloor = [oTile poly 7]
}
where
poly = [(-20,40),(20,40),(50,70),(50,110),(20,140),(-20,140),(-50,110),(-50,70)]
lnks =
poly = map toV2 [(-20,40),(20,40),(50,70),(50,110),(20,140),(-20,140),(-50,110),(-50,70)]
lnks = map (first toV2)
[((0,140),0)
,((35,125),negate $ pi/4)
,((-35,125),pi/4)
@@ -259,26 +261,26 @@ weaponEmptyRoom = do
w <- state $ randomR (220,300)
h <- state $ randomR (220,300)
let plmnts =
[sPS (w/2,h-40) 0 $ RandPS randFirstWeapon
,sPS (20,20) (pi/2) randC1
,sPS (w-20,20) (pi/2) randC1
,sPS (w/2,h/2) 0 putLamp
[sPS (V2 (w/2) (h-40)) 0 $ RandPS randFirstWeapon
,sPS (V2 20 20) (pi/2) randC1
,sPS (V2 (w-20) (20)) (pi/2) randC1
,sPS (V2 (w/2) (h/2)) 0 putLamp
]
(fmap connectRoom . randomiseOutLinks) =<<
changeLinkTo ((\p -> dist p (w/2,0) < 10) . fst) (set rmPS plmnts $ roomRect w h 2 2)
changeLinkTo ((\p -> dist p (V2 (w/2) (0)) < 10) . fst) (set rmPS plmnts $ roomRect w h 2 2)
weaponUnderCrits :: RandomGen g => State g (Tree (Either Room Room))
weaponUnderCrits = do
let plmnts =
[sPS (20,0) 0 $ RandPS randFirstWeapon
,sPS (20,0) (negate $ pi/2) randC1
,sPS (20,20) (negate $ pi/2) randC1
[sPS (V2 20 0) 0 $ RandPS randFirstWeapon
,sPS (V2 20 0) (negate $ pi/2) randC1
,sPS (V2 20 20) (negate $ pi/2) randC1
]
let continuationRoom = treeFromTrunk
[Left corridorN,Left corridorN]
(connectRoom (set rmPS plmnts corridorN))
rcp' <- roomCenterPillar
let rcp = over rmPS ( sPS (120,80) 0 putLamp : ) rcp'
let rcp = over rmPS ( sPS (V2 120 80) 0 putLamp : ) rcp'
deadEndRoom' <- takeOne [roomPillars,rcp]
junctionRoom <- takeOne [Left tEast,Left tWest]
return $ treeFromTrunk [Left corridorN,Left corridorN]
@@ -289,10 +291,10 @@ weaponUnderCrits = do
weaponBehindPillar :: RandomGen g => State g (Tree (Either Room Room))
weaponBehindPillar = do
cpos <- takeOne $ [(x,y) | x <- [20,220], y <- [20,220]] ++ [(120,160),(120,200)]
let d p = argV $ (120,80) -.- p
cpos <- takeOne $ [(V2 x y) | x <- [20,220], y <- [20,220]] ++ [(V2 120 160),(V2 120 200)]
let d p = argV $ (V2 120 80) -.- p
let plmnts1 =
[sPS (120,160) 0 $ RandPS randFirstWeapon
[sPS (V2 120 160) 0 $ RandPS randFirstWeapon
,sPS cpos (d cpos) randC1
]
rcp <- roomCenterPillar
@@ -300,15 +302,15 @@ weaponBehindPillar = do
[Left door
,Left $ over rmLinks tail $ over rmPS (++ plmnts1) rcp
]
(connectRoom $ set rmPS [sPS (20,60) (negate $ pi/2) randC1] corridorN)
(connectRoom $ set rmPS [sPS (V2 20 60) (negate $ pi/2) randC1] corridorN)
weaponBetweenPillars :: RandomGen g => State g (Tree (Either Room Room))
weaponBetweenPillars = do
wpPos <- takeOne [(x,y) | x <- [20,120,220], y <- [20,120,220]]
(ps,_) <- takeNMore 2 ([], [(x,y) | x <- [20,220], y <- [20,120,220]])
wpPos <- takeOne [(V2 x y) | x <- [20,120,220], y <- [20,120,220]]
(ps,_) <- takeNMore 2 ([], [(V2 x y) | x <- [20,220], y <- [20,120,220]])
let crPos1 = ps !! 0
crPos2 = ps !! 1
d p = argV $ (120,120) -.- p
d p = argV $ (V2 120 120) -.- p
plmnts =
[sPS wpPos 0 $ RandPS randFirstWeapon
,sPS crPos1 (d crPos1) randC1
@@ -325,8 +327,8 @@ weaponLongCorridor :: RandomGen g => State g (Tree (Either Room Room))
weaponLongCorridor = do
root <- takeOne [tEast, tWest]
connectingRoom <- takeOne
[tEast & rmPS .~ [sPS (-40,60) 0 putLamp]
,tWest & rmPS .~ [sPS ( 40,60) 0 putLamp]
[tEast & rmPS .~ [sPS (V2 (-40) (60)) 0 putLamp]
,tWest & rmPS .~ [sPS (V2 40 60) 0 putLamp]
]
i1 <- state $ randomR (2,5)
i2 <- state $ randomR (2,5)
@@ -334,11 +336,11 @@ weaponLongCorridor = do
let branch2 = treeFromTrunk (replicate i2 $ Left corridorN) (deadRoom $ putWp corridor)
return $ Node (Left root) [branch1,branch2]
where
putCrs = over rmPS (++ [sPS (10,40) (-pi/2) randC1 ,sPS (-10,40) (-pi/2) randC1 ])
putWp = set rmPS [sPS (20,40) 0 $ RandPS randFirstWeapon ,sPS (20,60) 0 putLamp ]
putCrs = over rmPS (++ [sPS (V2 10 40) (-pi/2) randC1 ,sPS (V2 (-10) (40)) (-pi/2) randC1 ])
putWp = set rmPS [sPS (V2 20 40) 0 $ RandPS randFirstWeapon ,sPS (V2 20 60) 0 putLamp ]
critInDeadEnd :: Room
critInDeadEnd = set rmPS [sPS (0,0) 0 randC1] deadEndRoom
critInDeadEnd = set rmPS [sPS (V2 0 0) 0 randC1] deadEndRoom
deadEndRoom :: Room
deadEndRoom = defaultRoom
@@ -346,11 +348,11 @@ deadEndRoom = defaultRoom
]
, _rmLinks = lnks
, _rmPath = []
, _rmPS = [sPS (0,-10) 0 putLamp]
, _rmPS = [sPS (V2 (0) (-10)) 0 putLamp]
, _rmBound = [rectNSWE 20 (-20) (-30) 30]
}
where
lnks = [((0,30) ,0) ]
lnks = [((V2 0 30) ,0) ]
{- A random Either tree with a weapon and melee monster challenge. -}
weaponRoom :: RandomGen g => State g (Tree (Either Room Room))
weaponRoom = join $ takeOne
@@ -365,8 +367,8 @@ roomCCrits :: RandomGen g => State g (Tree (Either Room Room))
roomCCrits = do
ps <- replicateM 20 $ randInCirc 9
let plmnts = map (\p -> sPS p 0 randC1)
$ zipWith (+.+) [(x,y) | x<-[110,130,150,170,190], y<- [70,90,110,130,150]] ps
lamps = [sPS (50,100) 0 putLamp , sPS (175,100) 0 putLamp]
$ zipWith (+.+) [(V2 x y) | x<-[110,130,150,170,190], y<- [70,90,110,130,150]] ps
lamps = [sPS (V2 50 100) 0 putLamp , sPS (V2 175 100) 0 putLamp]
return $ connectRoom $ over rmPS ((lamps ++) . (plmnts ++)) $ roomC 200 200
@@ -374,40 +376,40 @@ longRoom :: RandomGen g => State g Room
longRoom = do
h <- state $ randomR (1500,1500)
let w = 75
let cond x = (snd . fst) x < h - 40
let ws = map (\ps -> sPS (0,0) 0 $ PutWall ps defaultCrystalWall)
let cond x = (sndV2 . fst) x < h - 40
let ws = map (\ps -> sPS (V2 0 0) 0 $ PutWall ps defaultCrystalWall)
[rectNSWE (h-35) (h-135) (-10) 10
,rectNSWE (h-35) (h-135) 15 35
,rectNSWE (h-35) (h-135) 40 60
,rectNSWE (h-35) (h-135) 65 85
]
let wsDefense = map (\ps -> sPS (0,0) 0 $ PutWall ps defaultCrystalWall)
let wsDefense = map (\ps -> sPS (V2 0 0) 0 $ PutWall ps defaultCrystalWall)
[rectNSWE 95 70 0 25
,rectNSWE 95 70 50 75
]
brls <- fmap (map (\p -> sPS (p +.+ (10,200)) 0 $ PutCrit explosiveBarrel) )
brls <- fmap (map (\p -> sPS (p +.+ (V2 10 200)) 0 $ PutCrit explosiveBarrel) )
$ replicateM 5 $ randInRect (w-20) 900
let rm = roomRect w (h+70) 1 1 & rmPolys %~ ([rectNSWE h (h-165) (-45) (w+45)] ++)
changeLinkTo cond $ rm & rmPS .~ ws ++ brls ++ wsDefense ++
[sPS ( 12.5,h-25) 0 $ PutCrit longCrit
,sPS ( 37.5,h-25) 0 $ PutCrit longCrit
,sPS ( 62.5,h-25) 0 $ PutCrit longCrit
,sPS ( 25, 20) 0 putLamp
,sPS ( 25,h-10) 0 putLamp
[sPS (V2 12.5 (h-25)) 0 $ PutCrit longCrit
,sPS (V2 37.5 (h-25)) 0 $ PutCrit longCrit
,sPS (V2 62.5 (h-25)) 0 $ PutCrit longCrit
,sPS (V2 25 ( 20)) 0 putLamp
,sPS (V2 25 (h-10)) 0 putLamp
]
shooterRoom :: RandomGen g => State g Room
shooterRoom = do
h <- state $ randomR (200,300)
let cond x = (snd . fst) x < h - 40
let cond x = (sndV2 . fst) x < h - 40
changeLinkTo cond $ roomRect 100 h 1 1 & rmPS .~
[blockLine (50,50) (50,h)
,sPS ( 25,h-25) 0 $ PutCrit $ addArmour autoCrit
,sPS ( 75,h-30) 0 $ PutCrit explosiveBarrel
,sPS ( 75,h-60) 0 $ PutCrit explosiveBarrel
,sPS ( 85,h-10) 0 $ PutCrit explosiveBarrel
,sPS ( 85,h-45) 0 $ PutCrit explosiveBarrel
,sPS ( 75,h-80) 0 putLamp
[blockLine (V2 50 50) (V2 50 h)
,sPS (V2 25 (h-25)) 0 $ PutCrit $ addArmour autoCrit
,sPS (V2 75 (h-30)) 0 $ PutCrit explosiveBarrel
,sPS (V2 75 (h-60)) 0 $ PutCrit explosiveBarrel
,sPS (V2 85 (h-10)) 0 $ PutCrit explosiveBarrel
,sPS (V2 85 (h-45)) 0 $ PutCrit explosiveBarrel
,sPS (V2 75 (h-80)) 0 putLamp
]
shootersRoom1 :: RandomGen g => State g Room
@@ -426,7 +428,7 @@ shootersRoom1 = do
let blv x y = putBlockV (x+25) (x-25) (y+10) y
let plmnts = bln x1 y1 ++ bln x2 y2 ++ bln x3 y3 ++ blv x4 y4
++ [sPS p (-pi/2) $ PutCrit autoCrit
,sPS (w/2,200) 0 putLamp
,sPS (V2 (w/2) (200)) 0 putLamp
]
return $ set rmPS plmnts $ roomRectAutoLinks w 600
@@ -444,16 +446,16 @@ shootersRoom = do
let bln x y = putBlockN (x+25) (x-25) (y+10) y
let blv x y = putBlockV (x+25) (x-25) (y+10) y
let plmnts = bln x1 y1 ++ bln x2 y2 ++ bln x3 y3 ++ blv x4 y4
++ [sPS (x1,y1-10) (-pi/2) $ PutCrit autoCrit
,sPS (x2,y2-10) (-pi/2) $ PutCrit autoCrit
,sPS (x3,y3-10) (-pi/2) $ PutCrit autoCrit
,sPS (w/2,200) 0 putLamp
++ [sPS (V2 (x1) (y1-10)) (-pi/2) $ PutCrit autoCrit
,sPS (V2 (x2) (y2-10)) (-pi/2) $ PutCrit autoCrit
,sPS (V2 (x3) (y3-10)) (-pi/2) $ PutCrit autoCrit
,sPS (V2 (w/2) (200)) 0 putLamp
]
return $ set rmPS plmnts $ roomRectAutoLinks w 600
pistolerRoom :: RandomGen g => State g Room
pistolerRoom = do
let f2 x y = singleBlock (x,y)
let f2 x y = singleBlock (V2 x y)
--f3 x y = [blockLine (x-20,y) (x+20,y)
-- ,blockLine (x,y-20) (x,y+20) ]
--f4 x y = [blockLine (x-20,y-20) (x+20,y+20)
@@ -469,20 +471,20 @@ pistolerRoom = do
xs = take i [20+0.5*(w-40)/(j-1),20+1.5*(w-40)/(j-1)..]
ys = take i [20+0.5*(h-40)/(j-1),20+1.5*(h-40)/(j-1)..]
gap = 0.5 * h / j
ps <- takeN 3 $ zip (map (+gap) xs) ys
ps <- takeN 3 $ zipWith V2 (map (+gap) xs) ys
aa <- state $ randomR (0,2*pi)
ab <- state $ randomR (0,2*pi)
ac <- state $ randomR (0,2*pi)
let plmnts = [sPS (ps !! 0) aa $ PutCrit pistolCrit
,sPS (ps !! 1) ab $ PutCrit pistolCrit
,sPS (ps !! 2) ac $ PutCrit pistolCrit
,sPS (w/2,h-50) 0 putLamp
,sPS (w/2,50) 0 putLamp
,sPS (w-5,h-5) 0 putLamp
,sPS (5,h-5) 0 putLamp
,sPS (w-5,5) 0 putLamp
,sPS (5,5) 0 putLamp
,sPS (w/2,h/2) 0 putLamp
,sPS (V2 (w/2) (h-50)) 0 putLamp
,sPS (V2 (w/2) (50) ) 0 putLamp
,sPS (V2 (w-5) (h-5) ) 0 putLamp
,sPS (V2 ( 5) (h-5) ) 0 putLamp
,sPS (V2 (w-5) (5) ) 0 putLamp
,sPS (V2 ( 5) (5) ) 0 putLamp
,sPS (V2 (w/2) (h/2) ) 0 putLamp
]
++
concat [f x y | x<-xs,y<-ys]
@@ -491,16 +493,16 @@ pistolerRoom = do
shootingRange :: RandomGen g => State g (Tree (Either Room Room))
shootingRange = do
rm1 <- shootersRoom1 >>= changeLinkTo (\((_,y),_) -> y < 40)
>>= filterLinks (\((_,y),r) -> y > 200 && r /= 0)
rm2 <- shootersRoom >>= changeLinkTo (\((x,y),_) -> y < 10 && x > 20 && x < 180)
>>= filterLinks (\((_,y),r) -> y > 200 && r /= 0)
rm3 <- shootersRoom >>= changeLinkTo (\((x,y),_) -> y < 10 && x > 20 && x < 180)
rm1 <- shootersRoom1 >>= changeLinkTo (\((V2 _ y),_) -> y < 40)
>>= filterLinks (\((V2 _ y),r) -> y > 200 && r /= 0)
rm2 <- shootersRoom >>= changeLinkTo (\((V2 x y),_) -> y < 10 && x > 20 && x < 180)
>>= filterLinks (\((V2 _ y),r) -> y > 200 && r /= 0)
rm3 <- shootersRoom >>= changeLinkTo (\((V2 x y),_) -> y < 10 && x > 20 && x < 180)
>>= filterLinks (\(_,r) -> r == 0)
return $ treeFromPost [Left rm1
,Left $ roomPadCut (rectNSWE 20 (-20) (-80) 80) (0,20)
,Left $ roomPadCut (rectNSWE 20 (-20) (-80) 80) (V2 0 20)
,Left rm2
,Left $ roomPadCut (rectNSWE 20 (-20) (-80) 80) (0,20)
,Left $ roomPadCut (rectNSWE 20 (-20) (-80) 80) (V2 0 20)
]
(Right rm3)
@@ -508,13 +510,13 @@ spawnerRoom :: RandomGen g => State g (Tree (Either Room Room))
spawnerRoom = do
x <- state $ randomR (250,300)
y <- state $ randomR (300,400)
wl <- takeOne [sPS (0,0) 0 $ PutWall (rectNSWE (y-60) 0 (x/2-10) (x/2+10))
wl <- takeOne [sPS (V2 0 0) 0 $ PutWall (rectNSWE (y-60) 0 (x/2-10) (x/2+10))
defaultCrystalWall
,windowLine (x/2,0) (x/2,y-60)
,windowLine (V2 (x/2) (0)) (V2 (x/2) (y-60))
]
let plmnts = [sPS (x/4, y/4) (pi/2) $ PutCrit spawnerCrit
let plmnts = [sPS (V2 (x/4) ( y/4)) (pi/2) $ PutCrit spawnerCrit
,wl
,sPS (x/2, y-10) 0 putLamp
,sPS (V2 (x/2) ( y-10)) 0 putLamp
]
let f ((lx,_),_) = lx < x/2-5
roomWithSpawner <- (fmap connectRoom . randomiseOutLinks) =<< filterLinks f (set rmPS plmnts $ roomRect x y 2 2)
src/Dodge/Room/Airlock.hs
+32 -32
View File
@@ -23,16 +23,16 @@ airlockOneWay n = defaultRoom
{ _rmPolys = [rectNSWE 90 0 0 40]
, _rmLinks = lnks
, _rmPath = []
, _rmPS = [sPS (0,15) 0 $ PutDoubleDoor col (not . cond) (0,0) (0,40)
,sPS (0,75) 0 $ PutDoubleDoor col cond (0,0) (0,40)
,sPS (35,45) (pi/2) $ PutButton $ makeButton col (over worldState
, _rmPS = [sPS (V2 0 15) 0 $ PutDoubleDoor col (not . cond) (V2 0 0) (V2 0 40)
,sPS (V2 0 75) 0 $ PutDoubleDoor col cond (V2 0 0) (V2 0 40)
,sPS (V2 35 45) (pi/2) $ PutButton $ makeButton col (over worldState
(M.insert (DoorNumOpen n) True))
]
--, _rmBound = rectNSWE 90 30 (-30) 30
, _rmBound = [rectNSWE 75 15 0 40]
}
where lnks = [((0,85),0)
,((0, 5),pi)
where lnks = [((V2 0 85),0)
,((V2 0 5),pi)
]
cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
col = dim $ dim $ bright red
@@ -56,22 +56,22 @@ airlock0 n = defaultRoom
, rectNSWE 65 35 (-40) 20
]
, _rmLinks = lnks
, _rmPath = [((20,95),(20,45))
,((20,45),(20, 5))
, _rmPath = [((V2 20 95),(V2 20 45))
,((V2 20 45),(V2 20 5))
]
, _rmPS =
[sPS (0,20) 0 $ PutDoubleDoor col (not . cond) (1,0) (39,0)
,sPS (0,80) 0 $ PutDoubleDoor col cond (1,0) (39,0)
,sPS (35,50) (pi/2) $ PutButton $ makeSwitch col
[sPS (V2 0 20) 0 $ PutDoubleDoor col (not . cond) (V2 1 0) (V2 39 0)
,sPS (V2 0 80) 0 $ PutDoubleDoor col cond (V2 1 0) (V2 39 0)
,sPS (V2 35 50) (pi/2) $ PutButton $ makeSwitch col
(over worldState (M.insert (DoorNumOpen n) True))
(over worldState (M.insert (DoorNumOpen n) False))
,sPS (-25, 50) 0 putLamp
,sPS (V2 (-25) ( 50)) 0 putLamp
]
, _rmBound = [rectNSWE 75 15 0 40]
}
where
lnks = [((20,95),0)
,((20, 5),pi)
lnks = [((V2 20 95),0)
,((V2 20 5),pi)
]
cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
col = dim $ dim $ bright red
@@ -84,29 +84,29 @@ airlock90 n = defaultRoom
[ rectNSWE 100 10 10 100
, rectNSWE 20 0 20 60
, rectNSWE 20 60 20 0
, [ (10,100)
, map toV2 [ (10,100)
, (100,150)
, (150,100)
, (100,10)
]
]
, _rmLinks =
[((0,40),pi/2)
,((40, 0),pi)
[((V2 0 40),pi/2)
,((V2 40 0),pi)
]
, _rmPath =
[((0,40),(40,0))
,((40,0),(0,40))
[((V2 0 40),(V2 40 0))
,((V2 40 0),(V2 0 40))
]
, _rmPS =
[sPS (5,5) 0 $ PutDoor col (not . cond) pss
,sPS (120,120) (3* pi/4) $ PutButton $ makeSwitch col
[sPS (V2 5 5) 0 $ PutDoor col (not . cond) pss
,sPS (V2 120 120) (3* pi/4) $ PutButton $ makeSwitch col
(over worldState (M.insert (DoorNumOpen n) True))
(over worldState (M.insert (DoorNumOpen n) False))
,sPS (60, 60) 0 putLamp
,sPS (V2 60 60) 0 putLamp
]
, _rmBound =
[[ (10,10)
[map toV2 [ (10,10)
, (10,100)
, (100,150)
, (150,100)
@@ -116,7 +116,7 @@ airlock90 n = defaultRoom
where
cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
col = dim $ dim $ bright red
pss = ((0,0) ,) <$> arcStepwise 3 (negate $ pi/2) (0,0) (0,55)
pss = ((V2 0 0) ,) <$> arcStepwise 3 (negate $ pi/2) (V2 0 0) (V2 0 55)
airlockCrystal
:: Int -- ^ Door id
@@ -124,7 +124,7 @@ airlockCrystal
airlockCrystal n = defaultRoom
{ _rmPolys =
[ rectNSWE 140 0 0 40
, orderPolygon
, orderPolygon $ map toV2
[(39,20)
,(150,60)
,(150,80)
@@ -132,20 +132,20 @@ airlockCrystal n = defaultRoom
]
]
, _rmLinks =
[((20,130),0)
,((20, 0),pi)
[((V2 20 130),0)
,((V2 20 0),pi)
]
, _rmPath =
[
]
, _rmPS =
[sPS (0,0) 0 $ PutDoor col (not . cond) pss
,sPS (145,70) (pi/2) $ PutButton $ makeSwitch col
[sPS (V2 0 0) 0 $ PutDoor col (not . cond) pss
,sPS (V2 145 70) (pi/2) $ PutButton $ makeSwitch col
(over worldState (M.insert (DoorNumOpen n) True))
(over worldState (M.insert (DoorNumOpen n) False))
,crystalLine (0,70) (40,70)
,sPS (20, 40) 0 putLamp
,sPS (20, 100) 0 putLamp
,crystalLine (V2 0 70) (V2 40 70)
,sPS (V2 20 40) 0 putLamp
,sPS (V2 20 100) 0 putLamp
]
, _rmBound =
[ ]
@@ -154,5 +154,5 @@ airlockCrystal n = defaultRoom
cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
col = dim $ dim $ bright red
pss :: [(Point2,Point2)]
pss = reverse $ fmap ( (\x -> ((50,x),(50,x+50)) ) . fromIntegral)
pss = reverse $ fmap ( (\x -> ((V2 50 x),(V2 (50) (x+50))) ) . fromIntegral)
[20::Int,22..70]
src/Dodge/Room/Boss.hs
+35 -35
View File
@@ -29,21 +29,21 @@ roomGlassOctogon x = defaultRoom
,rectNSWE 0 (-(x + 40)) (-20) 20
]
, _rmLinks =
[((0,x),0)
,((0,-(x+40)),pi)
[((V2 0 x),0)
,((V2 (0) (-(x+40))),pi)
]
, _rmPath = [((0,x),(0,-(x+40)))
,((0,-(x+40)),(0,x))]
, _rmPath = [((V2 (0) (x)),(V2 (0) (-(x+40))))
,((V2 (0) (-(x+40))),(V2 (0) (x)))]
, _rmPS =
[sPS (fx,fx) 0 putLamp
,sPS (-fx,fx) 0 putLamp
,sPS (fx,-fx) 0 putLamp
,sPS (-fx,-fx) 0 putLamp
,crystalLine (-x,x/2) (negate (x/2), x)
,crystalLine (x,x/2) (x/2, x)
,crystalLine (x/2,-x) (x,negate (x/2))
,crystalLine (negate $ x/2,-x) (-x,negate (x/2))
,blockLine (-40,40-x) (40,40-x)
[sPS (V2 fx fx) 0 putLamp
,sPS (V2 (-fx) (fx)) 0 putLamp
,sPS (V2 (fx) (-fx)) 0 putLamp
,sPS (V2 (-fx) (-fx)) 0 putLamp
,crystalLine (V2 (-x) (x/2)) (V2 (negate (x/2)) ( x))
,crystalLine (V2 (x) (x/2)) (V2 (x/2) ( x))
,crystalLine (V2 (x/2) (-x)) (V2 (x) (negate (x/2)))
,crystalLine (V2 (negate $ x/2) (-x)) (V2 (-x) (negate (x/2)))
,blockLine (V2 (-40) (40-x)) (V2 (40) (40-x))
]
, _rmBound = [rectNSWE x (-x) (-x) x]
}
@@ -51,11 +51,11 @@ roomGlassOctogon x = defaultRoom
fx = 4 * x / 5
bossRoom :: RandomGen g => Creature -> State g Room
bossRoom cr = randomMediumRoom <&> rmPS %~ ( sPS (0,100) (negate $ pi/2) (PutCrit cr) :)
bossRoom cr = randomMediumRoom <&> rmPS %~ ( sPS (V2 0 100) (negate $ pi/2) (PutCrit cr) :)
armouredChasers :: RandomGen g => State g (Tree Room)
armouredChasers = do
ps <- takeN 5 [(x,y) | x <- [-100,-80 .. 100] ,y <- [-100,-80 .. 100] ]
ps <- takeN 5 [(V2 x y) | x <- [-100,-80 .. 100] ,y <- [-100,-80 .. 100] ]
as <- replicateM 5 . state $ randomR (0,2*pi)
let theCrits = zipWith3 (\p a c -> sPS p a (PutCrit c)) ps as cs
treeFromPost [corridor,corridor] <$> (randomMediumRoom <&> rmPS %~ (++ theCrits))
@@ -80,21 +80,21 @@ roomCross x y = defaultRoom
,rectNSWE (-x) x y (-y)
]
, _rmLinks =
[((x,y-20),negate $ pi/2)
,((x,20-y),negate $ pi/2)
,((20-y,x),0)
,((y-20,x),0)
,((-x,y-20),pi/2)
,((-x,20-y),pi/2)
,((20-y,-x),pi)
,((y-20,-x),pi)
[((V2 (x) (y-20)),negate $ pi/2)
,((V2 (x) (20-y)),negate $ pi/2)
,((V2 (20-y) (x)),0)
,((V2 (y-20) (x)),0)
,((V2 (-x) (y-20)),pi/2)
,((V2 (-x) (20-y)),pi/2)
,((V2 (20-y) (-x)),pi)
,((V2 (y-20) (-x)),pi)
]
, _rmPath = []
, _rmPS =
[sPS ( x, 0) 0 putLamp
,sPS (-x, 0) 0 putLamp
,sPS ( 0, x) 0 putLamp
,sPS ( 0,-x) 0 putLamp
[sPS (V2 ( x) ( 0)) 0 putLamp
,sPS (-V2 (x) ( 0)) 0 putLamp
,sPS (V2 ( 0) ( x)) 0 putLamp
,sPS (V2 ( 0) (-x)) 0 putLamp
]
, _rmBound =
[rectNSWE y (-y) (-x) x
@@ -107,7 +107,7 @@ roomShuriken
-> Float -- ^ Second width/2
-> Room
roomShuriken x y =
let ps = [
let ps = [ map toV2
[ (0,-20)
, (x,-20)
, (x,y)
@@ -115,12 +115,12 @@ roomShuriken x y =
] ]
corner = defaultRoom
{ _rmPolys = ps
, _rmLinks = [((x-1,y-20),negate $ pi/2)]
, _rmLinks = [((V2 (x-1) (y-20)),negate $ pi/2)]
, _rmPath = []
, _rmPS = [sPS (x/2,x/2) 0 putLamp]
, _rmPS = [sPS (V2 (x/2) (x/2)) 0 putLamp]
, _rmBound = ps
}
in foldr1 combineRooms $ map (\r -> shiftRoomBy ((0,0), r) corner) [0,pi/2,pi,3*pi/2]
in foldr1 combineRooms $ map (\r -> shiftRoomBy ((V2 0 0), r) corner) [0,pi/2,pi,3*pi/2]
{- | TODO: pathing
Precondition: first float is less than the second by at least 40. -}
roomTwistCross
@@ -129,7 +129,7 @@ roomTwistCross
-> Float -- ^ Third width, should be smallest, possibly negative
-> Room
roomTwistCross x y z =
let ps = [ [ (x,negate $ z+20)
let ps = [ map toV2 [ (x,negate $ z+20)
, (x,x)
, (z,y)
, (z-20,x)
@@ -139,9 +139,9 @@ roomTwistCross x y z =
]
corner = defaultRoom
{ _rmPolys = ps
, _rmLinks = [((z,y-20), pi/2)]
, _rmLinks = [((V2 (z) (y-20)), pi/2)]
, _rmPath = []
, _rmPS = [sPS (x/2,x/2) 0 putLamp]
, _rmPS = [sPS (V2 (x/2) (x/2)) 0 putLamp]
, _rmBound = ps
}
in foldr1 combineRooms $ map (\r -> shiftRoomBy ((0,0), r) corner) [0,pi/2,pi,3*pi/2]
in foldr1 combineRooms $ map (\r -> shiftRoomBy ((V2 0 0), r) corner) [0,pi/2,pi,3*pi/2]
src/Dodge/Room/LongDoor.hs
+22 -22
View File
@@ -33,18 +33,18 @@ twinSlowDoorRoom
twinSlowDoorRoom drID w h x = defaultRoom
{ _rmPolys = ps
, _rmLinks =
[ ((w,h/2) , negate $ pi/2)
, ((-w,h/2) , pi/2)
, ((0,-h), pi)
[ ((V2 (w) (h/2)) , negate $ pi/2)
, ((V2 (-w) (h/2)) , pi/2)
, ((V2 (0) (-h)), pi)
]
, _rmPath = []
, _rmPS =
[ sPS (0,h/2) 0 putLamp
, sPS (25,5) 0 putLamp
, sPS (negate 25,5) 0 putLamp
, sPS (0,0) 0 $ PutDoor col (not . cond) drL
, sPS (0,0) 0 $ PutDoor col (not . cond) drR
, sPS (0,h-5) pi $ PutButton $ makeButton col
[ sPS (V2 (0) (h/2)) 0 putLamp
, sPS (V2 (25) (5)) 0 putLamp
, sPS (V2 (negate 25) (5)) 0 putLamp
, sPS (V2 0 0) 0 $ PutDoor col (not . cond) drL
, sPS (V2 0 0) 0 $ PutDoor col (not . cond) drR
, sPS (V2 (0) (h-5)) pi $ PutButton $ makeButton col
(over worldState (M.insert (DoorNumOpen drID) True))
]
, _rmBound = ps
@@ -54,9 +54,9 @@ twinSlowDoorRoom drID w h x = defaultRoom
[rectNSWE h (-2) (-w) w
,rectNSWE 20 (-h) (negate x) x
]
drL = fmap ((\h' -> ((x,-h'),(x,h-h'))) . (* h) . (/ fromIntegral nDrp) . fromIntegral)
drL = fmap ((\h' -> ((V2 (x) (-h')),(V2 (x) (h-h')))) . (* h) . (/ fromIntegral nDrp) . fromIntegral)
[0..nDrp]
drR = fmap ((\h' -> ((-x,-h'),(-x,h-h'))) . (* h) . (/ fromIntegral nDrp) . fromIntegral)
drR = fmap ((\h' -> ((V2 (-x) (-h')),(V2 (-x) (h-h')))) . (* h) . (/ fromIntegral nDrp) . fromIntegral)
[0..nDrp]
nDrp = ceiling h :: Int
cond w' = or $ M.lookup (DoorNumOpen drID) (_worldState w')
@@ -67,8 +67,8 @@ twinSlowDoorChasers
=> Int -- ^ Door id
-> State g Room
twinSlowDoorChasers drid = do
let lps = (-65 ,) <$> [20,40 .. 180]
rps = (65 ,) <$> [20,40 .. 180]
let lps = (V2 (-65)) <$> [20,40 .. 180]
rps = (V2 65) <$> [20,40 .. 180]
ps <- takeN 4 $ lps ++ rps
let plmnts = map (\p -> sPS p 0 $ PutCrit chaseCrit) ps
return $ twinSlowDoorRoom drid 80 200 40 & rmPS %~ (plmnts ++)
@@ -79,19 +79,19 @@ slowDoorRoom = do
y <- state $ randomR (400,800)
h <- state $ randomR (200,min (y-100) 500)
(butPos,butRot) <- takeOne
[( (x/2-50,5),0)
,( (x/2+50,5),0)
[( (V2 (x/2-50) (5)),0)
,( (V2 (x/2+50) (5)),0)
]
let n = 25
xs <- replicateM n $ state $ randomR (10,x-10)
ys <- replicateM n $ state $ randomR (h+20,y)
rs <- replicateM n $ state $ randomR (0,2*pi)
let ps = zip xs ys
let ps = zipWith V2 xs ys
xs' <- replicateM 5 $ state $ randomR (10,x-10)
ys' <- replicateM 5 $ state $ randomR (h+20,y)
let crits = zipWith (\p r -> sPS p r randC1) ps rs
lsources = [sPS (x/2,30) 0 putLamp, sPS (x/2,y-30) 0 putLamp]
barrels = zipWith (\x' y' -> sPS (x',y') 0 $ PutCrit explosiveBarrel) xs' ys'
lsources = [sPS (V2 (x/2) (30)) 0 putLamp, sPS (V2 (x/2) (y-30)) 0 putLamp]
barrels = zipWith (\x' y' -> sPS (V2 x' y') 0 $ PutCrit explosiveBarrel) xs' ys'
pillarsa = []
pillarsb = putBlockRect (x/5-20) (x/5+20) (h/2-20) (h/2+20)
++ putBlockRect (2*x/5-20) (2*x/5+20) (h/2-20) (h/2+20)
@@ -100,15 +100,15 @@ slowDoorRoom = do
pillarsc = putBlockRect (x/3-20) (x/3+20) (h/2-20) (h/2+20)
++ putBlockRect (2*x/3-20) (2*x/3+20) (h/2-20) (h/2+20)
pillars <- takeOne [pillarsa, pillarsb, pillarsc]
let cond x' = (snd . fst) x' > h + 40
cond2 x' = (snd . fst) x' < h - 40
but <- takeOne [PutBtDoor (dim $ light red) butPos butRot (0,h) (x,h)
let cond x' = (sndV2 . fst) x' > h + 40
cond2 x' = (sndV2 . fst) x' < h - 40
but <- takeOne [PutBtDoor (dim $ light red) butPos butRot (V2 0 h) (V2 x h)
-- ,PutSwitchDoor (dim $ light red) butPos butRot (0,h) (x,h)
]
fmap connectRoom
(filterLinks cond =<<
changeLinkTo cond2
(set rmPS ([sPS (0,0) 0 but] ++ crits ++ pillars ++ barrels ++ lsources)
(set rmPS ([sPS (V2 0 0) 0 but] ++ crits ++ pillars ++ barrels ++ lsources)
$ roomRectAutoLinks x y
)
)
src/Dodge/Room/NoNeedWeapon.hs
+6 -5
View File
@@ -11,6 +11,7 @@ import Dodge.Room.Procedural
import Dodge.Room.Link
import Dodge.RandomHelp
import Dodge.LevelGen.Data
import Geometry.Data
import Control.Lens
--import Control.Monad
@@ -29,11 +30,11 @@ centerVaultExplosiveExit
centerVaultExplosiveExit drID = do
cr <- takeOne [miniGunCrit, autoCrit]
let extraPS =
[sPS (0,175) 0 $ PutCrit explosiveBarrel
,sPS (5,195) 0 $ PutCrit explosiveBarrel
,sPS (0,200) 0 $ PutCrit explosiveBarrel
,sPS (-4,195) 0 $ PutCrit explosiveBarrel
,sPS (0,0) 0 $ PutCrit (cr & crState . crDropsOnDeath .~ DropAll)
[sPS (V2 0 175) 0 $ PutCrit explosiveBarrel
,sPS (V2 5 195) 0 $ PutCrit explosiveBarrel
,sPS (V2 0 200) 0 $ PutCrit explosiveBarrel
,sPS (V2 (-4) (195)) 0 $ PutCrit explosiveBarrel
,sPS (V2 0 0) 0 $ PutCrit (cr & crState . crDropsOnDeath .~ DropAll)
]
r <- centerVaultRoom drID 200 200 50 <&> rmPS %~ (extraPS ++)
randomiseLinksBy shuffleTail r <&> rmLinks %~ take 2
src/Dodge/Room/Placement.hs
+18 -18
View File
@@ -28,7 +28,7 @@ Width 9, also extends out from each point by 9.
-}
blockLine :: Point2 -> Point2 -> Placement
blockLine a b = SinglePlacement $ PS
{ _psPos = (0,0)
{ _psPos = (V2 0 0)
, _psRot = 0
, _psType = PutLineBlock baseBlockPane 9 9 a b
}
@@ -39,7 +39,7 @@ Width 8, also extends out from each point by 8.
-}
windowLine :: Point2 -> Point2 -> Placement
windowLine a b = SinglePlacement $ PS
{ _psPos = (0,0)
{ _psPos = (V2 0 0)
, _psRot = 0
, _psType = PutLineBlock baseWindowPane 8 8 a b
}
@@ -50,7 +50,7 @@ Width 7, also extends out from each point by 7.
-}
crystalLine :: Point2 -> Point2 -> Placement
crystalLine a b = SinglePlacement $ PS
{ _psPos = (0,0)
{ _psPos = (V2 0 0)
, _psRot = 0
, _psType = PutWall ps defaultCrystalWall
}
@@ -68,7 +68,7 @@ Depth 15, does not extend wider than points.
-}
wallLine :: Point2 -> Point2 -> Placement
wallLine a b = SinglePlacement $ PS
{ _psPos = (0,0)
{ _psPos = (V2 0 0)
, _psRot = 0
, _psType = PutWall ps defaultWall
}
@@ -87,7 +87,7 @@ windowLineType = PutLineBlock baseWindowPane 8 8
baseBlockPane :: Wall
baseBlockPane = Block
{ _wlLine = ((0,0),(50,0))
{ _wlLine = ((V2 0 0),(V2 50 0))
, _wlID = 0
, _wlColor = greyN 0.5
, _wlSeen = False
@@ -100,7 +100,7 @@ baseBlockPane = Block
}
baseWindowPane :: Wall
baseWindowPane = Block
{ _wlLine = ((0,0),(50,0))
{ _wlLine = ((V2 0 0),(V2 50 0))
, _wlID = 0
, _wlColor = withAlpha 0.2 cyan
, _wlSeen = False
@@ -141,10 +141,10 @@ putBlockRect
-> Float
-> Float
-> [Placement]
putBlockRect a x b y = [ blockLine (a,b) (a,y)
, blockLine (a,y) (x,y)
, blockLine (x,y) (x,b)
, blockLine (x,b) (a,b)
putBlockRect a x b y = [ blockLine (V2 a b) (V2 a y)
, blockLine (V2 a y) (V2 x y)
, blockLine (V2 x y) (V2 x b)
, blockLine (V2 x b) (V2 a b)
]
putBlockV
:: Float
@@ -152,8 +152,8 @@ putBlockV
-> Float
-> Float
-> [Placement]
putBlockV a x b y = [ blockLine (a,b) (a,y)
, blockLine (x,b) (a,b)
putBlockV a x b y = [ blockLine (V2 a b) (V2 a y)
, blockLine (V2 x b) (V2 a b)
]
putBlockC
:: Float
@@ -161,9 +161,9 @@ putBlockC
-> Float
-> Float
-> [Placement]
putBlockC a x b y = [ blockLine (a,b) (a,y)
, blockLine (x,b) (a,b)
, blockLine (a,y) (x,y)
putBlockC a x b y = [ blockLine (V2 a b) (V2 a y)
, blockLine (V2 x b) (V2 a b)
, blockLine (V2 a y) (V2 x y)
]
putBlockN
:: Float
@@ -171,7 +171,7 @@ putBlockN
-> Float
-> Float
-> [Placement]
putBlockN a x b y = [ blockLine (a,b) (a,y)
, blockLine (x,b) (a,b)
, blockLine (x,y) (x,b)
putBlockN a x b y = [ blockLine (V2 a b) (V2 a y)
, blockLine (V2 x b) (V2 a b)
, blockLine (V2 x y) (V2 x b)
]
src/Dodge/Room/Procedural.hs
+65 -65
View File
@@ -46,25 +46,25 @@ roomRect x y xn yn = defaultRoom
{ _rmPolys = [rectNSWE y 0 0 x ]
, _rmLinks = lnks
, _rmPath = concatMap doublePair pth
, _rmPS = [sPS (x/2,y/2) 0 putLamp]
, _rmPS = [sPS (V2 (x/2) (y/2)) 0 putLamp]
, _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)]
, _rmFloor = [Tile
{ _tilePoly = rectNSWE y 0 0 x
, _tileCenter = (0,0)
, _tileX = (50,0)
, _tileY = (0,50)
, _tileCenter = (V2 0 0)
, _tileX = (V2 50 0)
, _tileY = (V2 0 50)
, _tileZ = 16
} ]
}
where
yd = (y - 40) / fromIntegral yn
xd = (x - 40) / fromIntegral xn
elnks = zip (translateS (0,20) $ gridPoints 0 1 yd (yn+1)) (repeat ( pi/2))
wlnks = zip (translateS (x,20) $ gridPoints 0 1 yd (yn+1)) (repeat (-pi/2))
nlnks = zip (translateS (20,y) $ gridPoints xd (xn+1) 0 1 ) (repeat 0 )
slnks = zip (translateS (20,0) $ gridPoints xd (xn+1) 0 1 ) (repeat pi )
elnks = zip (translateS (V2 0 20) $ gridPoints 0 1 yd (yn+1)) (repeat ( pi/2))
wlnks = zip (translateS (V2 x 20) $ gridPoints 0 1 yd (yn+1)) (repeat (-pi/2))
nlnks = zip (translateS (V2 20 y) $ gridPoints xd (xn+1) 0 1 ) (repeat 0 )
slnks = zip (translateS (V2 20 0) $ gridPoints xd (xn+1) 0 1 ) (repeat pi )
lnks = nlnks ++ elnks ++ wlnks ++ slnks
pth = linksAndPath lnks $ translateS (20,20) (makeGrid xd xn yd yn)
pth = linksAndPath lnks $ translateS (V2 20 20) (makeGrid xd xn yd yn)
{-
Creates a rectangular room, automatically creates links and pathfinding graph at a sensible size.
-}
@@ -79,12 +79,12 @@ makeGrid x nx y ny
$ gridPoints x nx y ny
gridPoints :: Float -> Int -> Float -> Int -> [Point2]
gridPoints x nx y ny = [(a,b) | a <- take nx $ scanl (+) 0 $ repeat x
gridPoints x nx y ny = [(V2 a b) | a <- take nx $ scanl (+) 0 $ repeat x
, b <- take ny $ scanl (+) 0 $ repeat y
]
makeRect :: Float -> Float -> [(Point2,Point2)]
makeRect x y = [((0,0),(x,0))
makeRect x y = map (bimap toV2 toV2) [((0,0),(x,0))
,((0,0),(0,y))
,((x,y),(x,0))
,((x,y),(0,y))
@@ -123,29 +123,29 @@ Add a light and a 'PutNothing' placement. -}
fourthWall :: RandomGen g => Float -> State g Room
fourthWall w = do
b <- takeOne
[ [ sPS (20-w,w-40) 0 putLamp
, sPS (0,40) 0 putLamp
, sPS (w-20,w-20) pi PutNothing
, blockLine (w/2,w/2) (w/2,w)
[ [ sPS (V2 (20-w) (w-40)) 0 putLamp
, sPS (V2 (0) (40)) 0 putLamp
, sPS (V2 (w-20) (w-20)) pi PutNothing
, blockLine (V2 (w/2) (w/2)) (V2 (w/2) (w))
]
, [ sPS (20-w,w-40) 0 putLamp
, sPS (0,40) 0 putLamp
, sPS (w-20,w-20) pi PutNothing
, blockLine (w/2,w/2) (negate $ w/2,w/2)
, [ sPS (V2 (20-w) (w-40)) 0 putLamp
, sPS (V2 0 40) 0 putLamp
, sPS (V2 (w-20) (w-20)) pi PutNothing
, blockLine (V2 (w/2) (w/2)) (V2 (negate $ w/2) (w/2))
]
, [ sPS (20-w,w-40) 0 putLamp
, sPS (0,20) 0 putLamp
, sPS (w-20,w-20) pi PutNothing
, blockLine (w/2,w/2) (0,w/2)
, blockLine (-29,w) (0,w/2)
, [ sPS (V2 (20-w) (w-40)) 0 putLamp
, sPS (V2 0 20) 0 putLamp
, sPS (V2 (w-20) (w-20)) pi PutNothing
, blockLine (V2 (w/2) (w/2)) (V2 (0) (w/2))
, blockLine (V2 (-29) (w)) (V2 (0) (w/2))
]
]
pure $ defaultRoom
{ _rmPolys = [ [(0,0),(w,w),(-w,w)] ]
, _rmLinks = [((0,w), 0)]
, _rmPath = [((0,w),(0,0)),((0,0),(0,w))]
{ _rmPolys = [ map toV2 [(0,0),(w,w),(-w,w)] ]
, _rmLinks = [((V2 0 w), 0)]
, _rmPath = [((V2 0 w),(V2 0 0)),((V2 0 0),(V2 0 w))]
, _rmPS = b
, _rmBound = [[(0,0),(w,w),(-w,w)]]
, _rmBound = [[(V2 0 0),(V2 w w),(V2 (-w) (w))]]
}
--fourthCorner :: Float -> Room
--fourthCorner w = Room
@@ -162,38 +162,38 @@ fourthWall w = do
fourthCornerWall :: RandomGen g => Float -> State g Room
fourthCornerWall w = do
b <- takeOne
[ [ sPS (10-w,w) 0 putLamp
, sPS (w-10,w) 0 putLamp
, sPS (0,10) 0 putLamp
, sPS (0,2*w-20) pi PutNothing
, blockLine (w/2,w/2) (0,w)
, blockLine (negate $ w/2,w/2) (0,w)
[ [ sPS (V2 (10-w) (w)) 0 putLamp
, sPS (V2 (w-10) (w)) 0 putLamp
, sPS (V2 0 10) 0 putLamp
, sPS (V2 (0) (2*w-20)) pi PutNothing
, blockLine (V2 (w/2) (w/2)) (V2 0 w)
, blockLine (V2 (negate $ w/2) (w/2)) (V2 0 w)
]
, [ sPS (0,3*w/2) 0 putLamp
, sPS (w-10,w) 0 putLamp
, sPS (10-w,w-20) 0 putLamp
, sPS (0,10) 0 putLamp
, sPS (0,2*w-20) pi PutNothing
, blockLine (w/2,w/2) (0,w)
, blockLine (negate w,w) (0,w)
, [ sPS (V2 (0) (3*w/2)) 0 putLamp
, sPS (V2 (w-10) (w)) 0 putLamp
, sPS (V2 (10-w) (w-20)) 0 putLamp
, sPS (V2 0 10) 0 putLamp
, sPS (V2 (0) (2*w-20)) pi PutNothing
, blockLine (V2 (w/2) (w/2)) (V2 0 w)
, blockLine (V2 (negate w) (w)) (V2 0 w)
]
, [ sPS (10-w,w) 0 putLamp
, sPS (w-10,w) 0 putLamp
, sPS (0,10) 0 putLamp
, sPS (20,2*w-40) pi PutNothing
, blockLine (w/2,w/2) (0,w)
, blockLine (0,w) (0,w*2)
, [ sPS (V2 (10-w) (w)) 0 putLamp
, sPS (V2 (w-10) (w)) 0 putLamp
, sPS (V2 0 10) 0 putLamp
, sPS (V2 (20) (2*w-40)) pi PutNothing
, blockLine (V2 (w/2) (w/2)) (V2 0 w)
, blockLine (V2 0 w) (V2 (0) (w*2))
]
]
pure $ defaultRoom
{ _rmPolys = [ [(0,0),(w,w),(0,2*w),(-w,w)] ]
{ _rmPolys = [ map toV2 [(0,0),(w,w),(0,2*w),(-w,w)] ]
, _rmLinks =
[((w/2,3*w/2), negate $ pi/4)
,((negate $ w/2,3*w/2), pi/4)
[((V2 (w/2) (3*w/2)), negate $ pi/4)
,((V2 (negate $ w/2) (3*w/2)), pi/4)
]
, _rmPath = [((0,w),(0,0)),((0,0),(0,w))]
, _rmPath = [((V2 0 w),(V2 0 0)),((V2 0 0),(V2 0 w))]
, _rmPS = b
, _rmBound = [[(w,w),(0,2*w),(-w,w)]]
, _rmBound = [map toV2 [(w,w),(0,2*w),(-w,w)]]
}
{- | Replace the first 'PutNothing' with a given 'PSType'. -}
fillNothingPlacement :: PSType -> Room -> Room
@@ -226,7 +226,7 @@ randomFourCornerRoom = do
randomiseAllLinks . fillNothingPlacements (crits ++ itms) =<<
( shufflePlacements
. foldr1 combineRooms
$ zipWith (\r a -> shiftRoomBy ((0,0),a) r) corners [0,pi/2,pi,3*pi/2]
$ zipWith (\r a -> shiftRoomBy ((V2 0 0),a) r) corners [0,pi/2,pi,3*pi/2]
)
{- | Creates room with a central vault with doors around it.
-}
@@ -246,28 +246,28 @@ centerVaultRoom n w h d = do
return $ defaultRoom
{ _rmPolys = polys
, _rmLinks =
[((0,h),0)
,((w,0),-pi/2)
,((-w,0),pi/2)
,((0,-h),pi)
[((V2 0 h),0)
,((V2 w 0),-pi/2)
,((V2 (-w) (0)),pi/2)
,((V2 (0) (-h)),pi)
]
, _rmPath = []
, _rmPS =
[sPS (d-25,d-25) 0 putLamp
,sPS (w-5,h-5) 0 putLamp
,sPS (w-5,5-h) 0 putLamp
,sPS (5-w,h-5) 0 putLamp
,sPS (5-w,5-h) 0 putLamp
[sPS (V2 (d-25) (d-25)) 0 putLamp
,sPS (V2 (w-5) (h-5)) 0 putLamp
,sPS (V2 (w-5) (5-h)) 0 putLamp
,sPS (V2 (5-w) (h-5)) 0 putLamp
,sPS (V2 (5-w) (5-h)) 0 putLamp
]
++ concat (zipWith (\i r -> map (shiftPSBy ((0,0),r)) $ theDoor i)
++ concat (zipWith (\i r -> map (shiftPSBy ((V2 0 0),r)) $ theDoor i)
[n, n+1, n+2, n+3] [0,pi/2,pi,3*pi/2])
, _rmBound = [rectNSWE h (-h) (-w) w]
}
where
col = dim $ dim $ bright red
theDoor i =
[ sPS (0,d-10) 0 $ PutDoubleDoor col (cond i) (-19,0) (19,0)
, sPS (35,d+4) 0 $ PutButton $ makeSwitch col
[ sPS (V2 (0) (d-10)) 0 $ PutDoubleDoor col (cond i) (V2 (-19) (0)) (V2 19 0)
, sPS (V2 (35) (d+4)) 0 $ PutButton $ makeSwitch col
(over worldState (M.insert (DoorNumOpen i) True))
(over worldState (M.insert (DoorNumOpen i) False))
]
src/Dodge/Room/RoadBlock.hs
+15 -15
View File
@@ -32,21 +32,21 @@ litCorridor90 = do
poly2 = rectNSWE (h-60) (h-100) (-60) 5
pure $ defaultRoom
{ _rmPolys = [poly,poly2]
, _rmLinks = [ ((40,h - 80), -pi/2)
, ((20, 0), pi)
, _rmLinks = [ ((V2 (40) (h - 80)), -pi/2)
, ((V2 (20) ( 0)), pi)
]
, _rmPath = concatMap doublePair
[((20,0),(20,h-40))
,(( 0,h-40),(20,h-40))
,((40,h-40),(20,h-40))
[((V2 20 0),(V2 (20) (h-40)))
,((V2 ( 0) (h-40)),(V2 (20) (h-40)))
,((V2 (40) (h-40)),(V2 (20) (h-40)))
]
, _rmPS =
[ sPS (20,h-5) 0 putLamp
, windowLine (0,h-20) (40,h-20)
, sPS (-50,h-85) 0 putLamp
, windowLine (-40,h-60) (-40,h-100)
, sPS ( 20,h-40) 0 $ PutID 0
, sPS (-20,h-80) 0 $ PutID 2
[ sPS (V2 (20) (h-5)) 0 putLamp
, windowLine (V2 (0) (h-20)) (V2 (40) (h-20))
, sPS (V2 (-50) (h-85)) 0 putLamp
, windowLine (V2 (-40) (h-60)) (V2 (-40) (h-100))
, sPS (V2 ( 20) (h-40)) 0 $ PutID 0
, sPS (V2 (-20) (h-80)) 0 $ PutID 2
]
, _rmBound = [poly]
}
@@ -60,9 +60,9 @@ longBlockedCorridor :: RandomGen g => State g (Tree (Either Room Room))
longBlockedCorridor = do
r <- state $ randomR (0,pi)
n <- state $ randomR (0,3)
let plmnts = [sPS (20,40) r $ PutBlock [5,5,5] (150/256, 75/256, 0, 250/256)
let plmnts = [sPS (V2 20 40) r $ PutBlock [5,5,5] (V4 (150/256) (75/256) (0) (250/256))
$ reverse $ rectNSWE 10 (-10) (-10) 10
,sPS (20,15) 0 putLamp
,sPS (V2 20 15) 0 putLamp
]
sequence $ treeFromPost (replicate n $ Left <$> randomiseOutLinks corridor)
$ return $ Right $ set rmPS plmnts corridor
@@ -71,8 +71,8 @@ longBlockedCorridor = do
blockedCorridor :: RandomGen g => State g (Tree (Either Room Room))
blockedCorridor = do
r <- state $ randomR (0,pi)
let plmnts = [sPS (20,40) r $ PutBlock [5,5,5] (150/256, 75/256, 0, 250/256)
let plmnts = [sPS (V2 20 40) r $ PutBlock [5,5,5] (V4 (150/256) ( 75/256) ( 0) ( 250/256))
$ reverse $ rectNSWE 10 (-10) (-10) 10
,sPS (20,15) 0 putLamp
,sPS (V2 20 15) 0 putLamp
]
sequence $ treeFromPost [] $ return $ Right $ set rmPS plmnts corridor
src/Dodge/Room/Start.hs
+7 -7
View File
@@ -8,7 +8,7 @@ import Dodge.Room.Foreground
import Dodge.Layout.Tree.Polymorphic
import Dodge.LevelGen.Data
--import Picture
--import Geometry
import Geometry.Data
import Data.Tree
import Control.Monad.State
@@ -16,20 +16,20 @@ import Control.Lens
import System.Random
rezBox :: Room
rezBox = shiftRoomBy ((-20,-10),0) $ roomRect 40 20 1 1 & rmPS .~ []
rezBox = shiftRoomBy ((V2 (-20) (-10)),0) $ roomRect 40 20 1 1 & rmPS .~ []
startRoom :: RandomGen g => State g (Tree (Either Room Room))
startRoom = do
w <- state $ randomR (100,400)
h <- state $ randomR (200,400)
let fground = sPS (0,0) 0 $ PutForeground $
highPipe 80 (0,h/3) (w, h/2)
++ highPipe 40 (0,h/2) (w, h/3)
++ highPipe 60 (w/3,0) (w/3, h)
let fground = sPS (V2 0 0) 0 $ PutForeground $
highPipe 80 (V2 (0) (h/3)) (V2 (w) ( h/2))
++ highPipe 40 (V2 (0) (h/2)) (V2 (w) ( h/3))
++ highPipe 60 (V2 (w/3) (0)) (V2 (w/3) ( h))
-- ++ highPipe 20 (0,2*h/3) (w, h/3)
-- , girderV cola 10 (0,3*h/4) (w, 3*h/4)
-- , girder colb 5 (0,5*h/8) (w, 5*h/8)
treeFromPost [Left rezBox, Left door] . Right <$> randomiseOutLinks (shiftRoomBy ((-20,-20),0) $ roomRectAutoLinks w h & rmPS %~ (fground :))
treeFromPost [Left rezBox, Left door] . Right <$> randomiseOutLinks (shiftRoomBy ((V2 (-20) (-20)),0) $ roomRectAutoLinks w h & rmPS %~ (fground :))
-- where
-- cola = dark . dark . light . light $ light red
-- colb = dark . dark . light . light $ light blue
src/Dodge/Room/Teleport.hs
+3 -3
View File
@@ -28,13 +28,13 @@ telRoomLev i = do
w <- state $ randomR (200,300)
h <- state $ randomR (200,300)
return $ roomRectAutoLinks w h & rmPS .~
[ sPS (w/2,h/2) 0 $ PutPressPlate telPP
, sPS (w/2,h/2+ 30) 0 putLamp
[ sPS (V2 (w/2) (h/2)) 0 $ PutPressPlate telPP
, sPS (V2 (w/2) (h/2+ 30)) 0 putLamp
]
where
telPP = PressPlate
{ _ppPict = setDepth 0.5 . color red $ polygon ppFootprint
, _ppPos = (0,0)
, _ppPos = (V2 0 0)
, _ppRot = 0
, _ppEvent = levelReset
, _ppID = 0
src/Dodge/Room/Treasure.hs
+10 -10
View File
@@ -26,21 +26,21 @@ triLootRoom w h = pure $ defaultRoom
{ _rmPolys = [ tri
, base
]
, _rmLinks = [((0,-80),pi)]
, _rmPath = doublePair ((0,-80),(0,h/2))
, _rmLinks = [((V2 (0) (-80)),pi)]
, _rmPath = doublePair ((V2 (0) (-80)),(V2 (0) (h/2)))
, _rmPS =
[sPS (15-w, 15) 0 $ PutID 0
,sPS (w-15, 15) pi $ PutID 0
,sPS ( 0,h-35) 0 $ PutID 2
,sPS ( -5,h-10) 0 putLamp
,sPS ( 5,h-10) 0 putLamp
,sPS ( 0,h-15) 0 putLamp
,sPS ( 0, -60) 0 putLamp
[sPS (V2 (15-w) ( 15)) 0 $ PutID 0
,sPS (V2 (w-15) ( 15)) pi $ PutID 0
,sPS (V2 ( 0) (h-35)) 0 $ PutID 2
,sPS (V2 ( -5) (h-10)) 0 putLamp
,sPS (V2 ( 5) (h-10)) 0 putLamp
,sPS (V2 ( 0) (h-15)) 0 putLamp
,sPS (V2 ( 0) ( -60)) 0 putLamp
]
, _rmBound = [tri , base]
}
where
tri =
tri = map toV2
[ ( -w,30)
, ( -w, 0)
, ( w, 0)
src/Dodge/Update.hs
+1 -1
View File
@@ -110,7 +110,7 @@ updateTriggers w
& creatures . ix 0 .~ cr
| otherwise = w
where
cr = _creatures w IM.! 0 & crPos .~ (0,0)
cr = _creatures w IM.! 0 & crPos .~ (V2 0 0)
updateSoundQueue :: World -> World
updateSoundQueue = set soundQueue [] . set sounds M.empty
src/Dodge/WorldEvent.hs
+2 -2
View File
@@ -36,7 +36,7 @@ createBarrelSpark pos dir maycid time colid w
spark = Bul'
{ _ptDraw = drawBul
, _ptUpdate' = mvGenBullet
, _btVel' = rotateV dir (5,0)
, _btVel' = rotateV dir (V2 5 0)
, _btColor' = numColor colid
, _btTrail' = [pos]
, _btPassThrough' = maycid
@@ -45,7 +45,7 @@ createBarrelSpark pos dir maycid time colid w
, _btHitEffect' = destroyOnImpact sparkEff noEff noEff
}
x = fst $ randomR (0,20) $ _randGen w
pos' = pos +.+ rotateV dir (x,0)
pos' = pos +.+ rotateV dir (V2 x 0)
sparkEff bt p cr = over (creatures . ix (_crID cr) . crState . crDamage)
((:) $ SparkDam 1 sp p ep)
where sp = head (_btTrail' bt)
src/Dodge/WorldEvent/Explosion.hs
+2 -2
View File
@@ -74,8 +74,8 @@ makeExplosionAt p w
where
fVs = replicateM 75 (randInCirc 1) & evalState $ _randGen w
fPs'' = replicateM 75 (fmap (15 *.*.*) randInHemisphere) & evalState $ _randGen w
(fPs',zs) = let (a,b,c) = unzip3 fPs''
in (zip a b, c)
(fPs',zs) = let (a,b,c) = unzip3 $ map fromV3 fPs''
in (zipWith V2 a b, c)
fPs = map (pushAgainstWalls . (+.+) p . (*.*) 0.5) fPs'
inversePushOut v = (15 - magV v) * 0.01 *.* v
fVs' = zipWith (+.+) fVs $ map inversePushOut fPs'
src/Dodge/WorldEvent/Shockwave.hs
+2 -2
View File
@@ -50,7 +50,7 @@ Shockwave picture.
drawShockwave :: Particle -> Picture
drawShockwave pt = pic
where
pic = setDepth 20 . uncurry translate p
pic = setDepth 20 . uncurryV translate p
$ color (_btColor' pt) $ thickCircle rad thickness
p = _btPos' pt
r = _btRad' pt
@@ -116,7 +116,7 @@ moveInverseShockWave t p r push pushexp w pt
= (dams w, Just $ newupdate $ newpic pt )
where
newupdate = set ptUpdate' $ moveInverseShockWave (t-1) p r push pushexp
newpic = set ptDraw (const $ onLayer PtLayer $ uncurry translate p
newpic = set ptDraw (const $ onLayer PtLayer $ uncurryV translate p
$ color cyan $ thickCircle rad thickness)
rad = r - (4/40) * r * fromIntegral (10 - t)
thickness = fromIntegral (10 - t) **2 * rad / 40
src/Geometry/Data.hs
+3
View File
@@ -8,6 +8,7 @@ module Geometry.Data
, toV2
, toV3
, toV4
, fromV3
, uncurryV
, fstV2
, sndV2
@@ -24,6 +25,8 @@ toV2 (a,b) = V2 a b
toV3 (a,b,c) = V3 a b c
toV4 (a,b,c,d) = V4 a b c d
fromV3 (V3 a b c) = (a,b,c)
uncurryV :: (a -> a -> b) -> V2 a -> b
uncurryV f (V2 x y) = f x y