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