From 160560af5f53616db589aea9d15d66b24944a299 Mon Sep 17 00:00:00 2001 From: justin Date: Thu, 28 Jul 2022 00:59:56 +0100 Subject: [PATCH] Refactor, try to limit dependencies --- appDodge/Main.hs | 4 - src/Dodge/Annotation.hs | 2 +- src/Dodge/Annotation/Data.hs | 4 +- src/Dodge/ArcStep.hs | 5 +- src/Dodge/Barreloid.hs | 66 +- src/Dodge/Base/CardinalPoint.hs | 13 +- src/Dodge/Base/Collide.hs | 308 +++--- src/Dodge/Base/Coordinate.hs | 56 +- src/Dodge/Base/Item.hs | 27 - src/Dodge/Base/Wall.hs | 3 +- src/Dodge/Base/Window.hs | 75 +- src/Dodge/Base/You.hs | 5 +- src/Dodge/Beam.hs | 86 +- src/Dodge/Beam/Draw.hs | 11 +- src/Dodge/Block.hs | 96 +- src/Dodge/Block/Debris.hs | 236 +++-- src/Dodge/Bullet.hs | 2 +- src/Dodge/Bullet/Draw.hs | 19 +- src/Dodge/Button/Draw.hs | 30 +- src/Dodge/Button/Event.hs | 32 +- src/Dodge/ChainEffect.hs | 2 +- src/Dodge/Cleat.hs | 2 +- src/Dodge/Clock.hs | 2 +- src/Dodge/Combine.hs | 112 +-- src/Dodge/Combine/Combinations.hs | 43 +- src/Dodge/Combine/Graph.hs | 2 +- src/Dodge/Combine/Module.hs | 69 +- src/Dodge/Combine/Trie.hs | 23 +- src/Dodge/Config/KeyConfig.hs | 61 -- src/Dodge/CrGroupUpdate.hs | 2 +- src/Dodge/Creature.hs | 30 +- src/Dodge/Creature.hs.orig | 2 +- src/Dodge/Creature/Action.hs | 3 +- src/Dodge/Creature/ArmourChase.hs | 80 +- src/Dodge/Creature/AutoCrit.hs | 33 +- src/Dodge/Creature/Boid.hs | 301 +++--- src/Dodge/Creature/ChainUpdates.hs | 10 +- src/Dodge/Creature/ChaseCrit.hs | 88 +- src/Dodge/Creature/ChooseTarget.hs | 16 +- src/Dodge/Creature/Damage.hs | 53 +- src/Dodge/Creature/HandPos.hs | 96 +- src/Dodge/Creature/Impulse.hs | 142 +-- src/Dodge/Creature/Impulse/Flee.hs | 23 +- src/Dodge/Creature/Impulse/Movement.hs | 93 +- src/Dodge/Creature/Impulse/UseItem.hs | 17 +- src/Dodge/Creature/Inanimate.hs | 47 +- src/Dodge/Creature/Lamp.hs | 34 +- src/Dodge/Creature/LauncherCrit.hs | 37 +- src/Dodge/Creature/LtAutoCrit.hs | 32 +- src/Dodge/Creature/Perception.hs | 205 ++-- src/Dodge/Creature/Picture.hs | 220 +++-- src/Dodge/Creature/Picture/Awareness.hs | 45 +- src/Dodge/Creature/PistolCrit.hs | 34 +- src/Dodge/Creature/ReaderUpdate.hs | 204 ++-- src/Dodge/Creature/SentinelAI.hs | 159 ++-- src/Dodge/Creature/SetTarget.hs | 20 +- src/Dodge/Creature/SpreadGunCrit.hs | 32 +- src/Dodge/Creature/State.hs | 334 ++++--- src/Dodge/Creature/State/WalkCycle.hs | 17 +- src/Dodge/Creature/Statistics.hs | 5 +- src/Dodge/Creature/Strategy.hs | 32 +- src/Dodge/Creature/SwarmCrit.hs | 39 +- src/Dodge/Creature/Test.hs | 77 +- src/Dodge/Creature/Update.hs | 35 +- src/Dodge/Creature/Vocalization.hs | 8 +- src/Dodge/Creature/Volition.hs | 37 +- src/Dodge/Creature/YourControl.hs | 80 +- src/Dodge/CreatureEffect.hs | 61 +- src/Dodge/CullBox.hs | 32 +- src/Dodge/Cuse.hs | 2 +- src/Dodge/Damage.hs | 10 +- src/Dodge/DamageCircle.hs | 40 +- src/Dodge/Data.hs | 275 +----- src/Dodge/Data.hs.orig | 2 +- src/Dodge/Data/ArcStep.hs | 19 +- src/Dodge/Data/Beam.hs | 64 +- src/Dodge/Data/Block.hs | 73 +- src/Dodge/Data/Bounds.hs | 25 +- src/Dodge/Data/Bullet.hs | 6 +- src/Dodge/Data/Button.hs | 102 +- src/Dodge/Data/CamouflageStatus.hs | 15 +- src/Dodge/Data/Cloud.hs | 36 +- src/Dodge/Data/Config.hs | 50 +- src/Dodge/Data/Corpse.hs | 29 +- src/Dodge/Data/CrGroupParams.hs | 39 +- src/Dodge/Data/Creature.hs | 33 +- src/Dodge/Data/Creature/Memory.hs | 24 +- src/Dodge/Data/Creature/Misc.hs | 123 +-- src/Dodge/Data/Creature/Perception.hs | 105 +- src/Dodge/Data/Creature/Stance.hs | 59 +- src/Dodge/Data/Creature/State.hs | 43 +- src/Dodge/Data/Damage.hs | 51 +- src/Dodge/Data/Damage/Type.hs | 36 +- src/Dodge/Data/Distortion.hs | 1 - src/Dodge/Data/Door.hs | 71 +- src/Dodge/Data/EnergyBall.hs | 29 +- src/Dodge/Data/Equipment/Misc.hs | 26 +- src/Dodge/Data/Flame.hs | 33 +- src/Dodge/Data/Flare.hs | 39 +- src/Dodge/Data/FloatFunction.hs | 18 +- src/Dodge/Data/FloorItem.hs | 24 +- src/Dodge/Data/ForegroundShape.hs | 19 +- src/Dodge/Data/GenParams.hs | 31 +- src/Dodge/Data/GenWorld.hs | 143 +++ src/Dodge/Data/Gust.hs | 24 +- src/Dodge/Data/HUD.hs | 27 +- src/Dodge/Data/Hammer.hs | 24 +- src/Dodge/Data/Item.hs | 3 + src/Dodge/Data/Item/Combine.hs | 3 +- src/Dodge/Data/Item/CurseStatus.hs | 24 +- src/Dodge/Data/Item/HeldDelay.hs | 29 + src/Dodge/Data/Item/Use.hs | 27 +- src/Dodge/Data/Item/Use/Consumption/Ammo.hs | 7 +- src/Dodge/Data/Item/Use/Equipment.hs | 53 +- src/Dodge/Data/Item/UseDelay.hs | 28 - src/Dodge/Data/Laser.hs | 45 +- src/Dodge/Data/LightSource.hs | 83 +- src/Dodge/Data/LinearShockwave.hs | 21 +- src/Dodge/Data/Machine.hs | 3 + src/Dodge/Data/Material.hs | 18 +- src/Dodge/Data/Modification.hs | 31 +- src/Dodge/Data/PosEvent.hs | 32 +- src/Dodge/Data/PressPlate.hs | 32 +- src/Dodge/Data/Projectile.hs | 23 +- src/Dodge/Data/RadarBlip.hs | 29 +- src/Dodge/Data/RightButtonOptions.hs | 27 +- src/Dodge/Data/Room.hs | 58 +- src/Dodge/Data/Shockwave.hs | 45 +- src/Dodge/Data/Spark.hs | 29 +- src/Dodge/Data/Terminal.hs | 99 +- src/Dodge/Data/TeslaArc.hs | 19 +- src/Dodge/Data/TractorBeam.hs | 19 +- src/Dodge/Data/Universe.hs | 85 ++ src/Dodge/Data/Wall.hs | 99 +- src/Dodge/Data/World.hs | 61 ++ src/Dodge/Data/WorldEffect.hs | 69 +- src/Dodge/Data/Zoning.hs | 17 +- src/Dodge/Debug/LinkDecoration.hs | 38 +- src/Dodge/Debug/Picture.hs | 83 +- src/Dodge/Debug/Terminal.hs | 133 +-- src/Dodge/Default.hs | 11 +- src/Dodge/Default/AimParams.hs | 12 - src/Dodge/Default/Block.hs | 2 +- src/Dodge/Default/Block.hs.orig | 39 +- src/Dodge/Default/Creature.hs | 201 ++-- src/Dodge/Default/Door.hs | 68 +- .../{Foreground.hs => ForegroundShape.hs} | 5 +- src/Dodge/Default/Item.hs | 71 +- src/Dodge/Default/Item/Effect.hs | 13 + src/Dodge/Default/Item/Use.hs | 36 + src/Dodge/Default/Item/Use/AimParams.hs | 14 + src/Dodge/Default/Item/Use/Consumption.hs | 22 + src/Dodge/Default/Item/Use/Equipment.hs | 15 + src/Dodge/Default/LightSource.hs | 42 +- src/Dodge/Default/Prop.hs | 21 +- src/Dodge/Default/Room.hs | 64 +- src/Dodge/Default/Shell.hs | 38 +- src/Dodge/Default/Terminal.hs | 61 +- src/Dodge/Default/Wall.hs | 136 +-- src/Dodge/Default/Weapon.hs | 190 ++-- src/Dodge/Default/World.hs | 245 ++--- src/Dodge/Default/World.hs.orig | 2 +- src/Dodge/Distortion.hs | 12 +- src/Dodge/DrWdWd.hs | 61 +- src/Dodge/EnergyBall.hs | 99 +- src/Dodge/EnergyBall/Draw.hs | 97 +- src/Dodge/Equipment.hs | 3 +- src/Dodge/Euse.hs | 12 +- src/Dodge/Event.hs | 2 +- src/Dodge/Event/Keyboard.hs | 162 ++-- src/Dodge/Event/Menu.hs | 93 +- src/Dodge/Event/Test.hs | 34 +- src/Dodge/Flame.hs | 168 ++-- src/Dodge/Flame/Draw.hs | 51 +- src/Dodge/Flare.hs | 16 +- src/Dodge/FloatFunction.hs | 13 +- src/Dodge/Floor.hs | 212 ++--- src/Dodge/FloorItem.hs | 72 +- src/Dodge/ForceField.hs | 8 + src/Dodge/Gas.hs | 15 +- src/Dodge/Hammer.hs | 6 +- src/Dodge/HeldScroll.hs | 20 +- src/Dodge/HeldUse.hs | 224 +++-- src/Dodge/Humanoid.hs | 448 +++++---- src/Dodge/Initialisation.hs | 22 +- src/Dodge/InputFocus.hs | 4 +- src/Dodge/Inventory.hs | 383 ++++---- src/Dodge/Inventory/Add.hs | 52 +- src/Dodge/Inventory/CheckSlots.hs | 2 +- src/Dodge/Inventory/CloseObject.hs | 10 +- src/Dodge/Inventory/ItemSpace.hs | 13 +- src/Dodge/Inventory/Lock.hs | 7 +- src/Dodge/ItEffect.hs | 29 +- src/Dodge/Item.hs | 53 +- src/Dodge/Item/Amount.hs | 5 +- src/Dodge/Item/Consumable.hs | 27 +- src/Dodge/Item/Craftable.hs | 68 +- src/Dodge/Item/Display.hs | 15 +- src/Dodge/Item/Draw.hs | 115 +-- src/Dodge/Item/Draw/SPic.hs | 372 ++++---- src/Dodge/Item/Equipment.hs | 42 +- src/Dodge/Item/Equipment/Booster.hs | 12 +- src/Dodge/Item/Equipment/Shape.hs | 15 +- src/Dodge/Item/Held.hs | 93 +- src/Dodge/Item/Held/BatteryGuns.hs | 170 ++++ src/Dodge/Item/Held/BulletGun.hs | 3 + .../Item/{Weapon/BulletGun => Held}/Cane.hs | 78 +- src/Dodge/Item/Held/Cone.hs | 52 + src/Dodge/Item/Held/Launcher.hs | 94 ++ src/Dodge/Item/Held/Rod.hs | 93 ++ src/Dodge/Item/{Weapon => Held}/SprayGuns.hs | 34 +- src/Dodge/Item/Held/Stick.hs | 110 +++ src/Dodge/Item/Held/Utility.hs | 68 ++ src/Dodge/Item/Held/Weapons.hs | 14 + src/Dodge/Item/HeldOffset.hs | 61 +- src/Dodge/Item/Left.hs | 3 + src/Dodge/Item/Location.hs | 27 +- src/Dodge/Item/PassKey.hs | 13 - src/Dodge/Item/Random.hs | 6 +- src/Dodge/Item/Targeting.hs | 37 + src/Dodge/Item/Weapon.hs | 49 +- src/Dodge/Item/Weapon/BatteryGuns.hs | 281 ++---- src/Dodge/Item/Weapon/Bullet.hs | 73 +- src/Dodge/Item/Weapon/BulletGun/Rod.hs | 83 -- src/Dodge/Item/Weapon/BulletGun/Stick.hs | 93 -- src/Dodge/Item/Weapon/BulletGuns.hs | 110 --- src/Dodge/Item/Weapon/Drone.hs | 53 +- src/Dodge/Item/Weapon/ExtraEffect.hs | 211 ++-- src/Dodge/Item/Weapon/FractionLoaded.hs | 2 +- src/Dodge/Item/Weapon/LaserPath.hs | 74 +- src/Dodge/Item/Weapon/Launcher.hs | 98 +- src/Dodge/Item/Weapon/Radar.hs | 37 +- src/Dodge/Item/Weapon/Remote.hs | 38 +- src/Dodge/Item/Weapon/Shatter.hs | 44 +- src/Dodge/Item/Weapon/Shell.hs | 28 +- src/Dodge/Item/Weapon/Spawn.hs | 49 +- src/Dodge/Item/Weapon/Targeting.hs | 24 +- src/Dodge/Item/Weapon/TriggerType.hs | 899 ++++++++++-------- src/Dodge/Item/Weapon/Utility.hs | 46 +- src/Dodge/Item/Weapon/ZoomScope.hs | 7 +- src/Dodge/Lampoid.hs | 39 +- src/Dodge/Laser/Draw.hs | 26 +- src/Dodge/Laser/Update.hs | 16 +- src/Dodge/Layout.hs | 243 ++--- src/Dodge/Layout.hs.orig | 4 +- src/Dodge/LevelGen.hs | 65 +- src/Dodge/LevelGen/Data.hs | 36 +- src/Dodge/LevelGen/LevelStructure.hs | 44 +- src/Dodge/LevelGen/Switch.hs | 3 +- src/Dodge/LightSource.hs | 130 +-- src/Dodge/LightSource/Draw.hs | 4 +- src/Dodge/LightSource/Torch.hs | 16 +- src/Dodge/LightSource/Update.hs | 9 +- src/Dodge/LinearShockwave/Draw.hs | 48 +- src/Dodge/LinearShockwave/Update.hs | 2 +- src/Dodge/LockAndKey.hs | 201 ++-- src/Dodge/Luse.hs | 3 +- src/Dodge/Machine.hs | 57 +- src/Dodge/Machine/Damage.hs | 7 +- src/Dodge/Machine/Destroy.hs | 28 +- src/Dodge/Machine/Update.hs | 6 +- src/Dodge/Magnet.hs | 18 +- src/Dodge/Magnet/Update.hs | 10 +- src/Dodge/Material/Damage.hs | 51 +- src/Dodge/Material/Sound.hs | 33 +- src/Dodge/Menu.hs | 8 +- src/Dodge/Menu/OptionType.hs | 23 +- src/Dodge/Menu/PushPop.hs | 6 +- src/Dodge/Module.hs | 61 +- src/Dodge/Particle/Damage.hs | 29 +- src/Dodge/Particle/Draw.hs | 57 +- src/Dodge/Path.hs | 121 +-- src/Dodge/Payload.hs | 5 +- src/Dodge/Picture/SizeInvariant.hs | 100 +- src/Dodge/Placement/Instance/Analyser.hs | 84 +- src/Dodge/Placement/Instance/Block.hs | 36 +- src/Dodge/Placement/Instance/Button.hs | 140 ++- src/Dodge/Placement/Instance/Creature.hs | 6 +- src/Dodge/Placement/Instance/Door.hs | 130 ++- src/Dodge/Placement/Instance/LightSource.hs | 163 ++-- .../Placement/Instance/LightSource/Cover.hs | 58 +- .../Placement/Instance/LightSource/Flicker.hs | 45 +- src/Dodge/Placement/Instance/Sensor.hs | 81 +- src/Dodge/Placement/Instance/Tank.hs | 49 +- src/Dodge/Placement/Instance/Terminal.hs | 95 +- src/Dodge/Placement/Instance/Turret.hs | 149 +-- src/Dodge/Placement/Instance/Wall.hs | 146 +-- src/Dodge/Placement/PlaceSpot.hs | 232 ++--- src/Dodge/Placement/PlaceSpot/Block.hs | 172 ++-- src/Dodge/Placement/PlaceSpot/Block.hs.orig | 5 +- src/Dodge/Placement/PlaceSpot/TriggerDoor.hs | 162 ++-- src/Dodge/Placement/Random.hs | 16 +- src/Dodge/Placement/Shift.hs | 44 +- src/Dodge/Placement/TopDecoration.hs | 81 +- src/Dodge/PlacementSpot.hs | 4 +- src/Dodge/PosEvent.hs | 18 +- src/Dodge/PrWdLsLs.hs | 16 +- src/Dodge/PreloadData.hs | 19 +- src/Dodge/PressPlate.hs | 13 +- src/Dodge/Projectile/Create.hs | 2 +- src/Dodge/Projectile/Draw.hs | 30 +- src/Dodge/Projectile/Update.hs | 8 +- src/Dodge/Prop/Draw.hs | 93 +- src/Dodge/Prop/Gib.hs | 179 ++-- src/Dodge/Prop/Moving.hs | 67 +- src/Dodge/Prop/Update.hs | 39 +- src/Dodge/RadarBlip.hs | 18 +- src/Dodge/RadarSweep.hs | 73 +- src/Dodge/RandImpulse.hs | 5 +- src/Dodge/Randify.hs | 12 +- src/Dodge/Reloading.hs | 79 +- src/Dodge/Reloading/Action.hs | 3 +- src/Dodge/Render.hs | 247 ++--- src/Dodge/Render/HUD.hs | 437 +++++---- src/Dodge/Render/InfoBox.hs | 31 +- src/Dodge/Render/Lights.hs | 28 +- src/Dodge/Render/List.hs | 82 +- src/Dodge/Render/MenuScreen.hs | 127 +-- src/Dodge/Render/Picture.hs | 35 +- src/Dodge/Render/ShapePicture.hs | 2 +- src/Dodge/Render/ShapePicture.hs.orig | 6 +- src/Dodge/Render/Walls.hs | 49 +- src/Dodge/Room.hs | 95 +- src/Dodge/Room/Airlock.hs | 278 +++--- src/Dodge/Room/BlinkAcross.hs | 52 +- src/Dodge/Room/Boss.hs | 290 +++--- src/Dodge/Room/Branch.hs | 28 +- src/Dodge/Room/Breather.hs | 2 +- src/Dodge/Room/CheckConsistency.hs | 7 +- src/Dodge/Room/Containing.hs | 63 +- src/Dodge/Room/Corridor.hs | 191 ++-- src/Dodge/Room/Door.hs | 66 +- src/Dodge/Room/Foreground.hs | 266 +++--- src/Dodge/Room/Girder.hs | 13 +- src/Dodge/Room/GlassLesson.hs | 102 +- src/Dodge/Room/LasTurret.hs | 211 ++-- src/Dodge/Room/Link.hs | 130 +-- src/Dodge/Room/LongDoor.hs | 213 +++-- src/Dodge/Room/LongRoom.hs | 91 +- src/Dodge/Room/Modify/Girder.hs | 224 +++-- src/Dodge/Room/Ngon.hs | 54 +- src/Dodge/Room/NoNeedWeapon.hs | 46 +- src/Dodge/Room/Path.hs | 79 +- src/Dodge/Room/Pillar.hs | 135 +-- src/Dodge/Room/Procedural.hs | 499 +++++----- src/Dodge/Room/RezBox.hs | 171 ++-- src/Dodge/Room/RoadBlock.hs | 122 +-- src/Dodge/Room/Room.hs | 515 +++++----- src/Dodge/Room/RunPast.hs | 69 +- src/Dodge/Room/SensorDoor.hs | 81 +- src/Dodge/Room/Start.hs | 125 +-- src/Dodge/Room/Tanks.hs | 149 +-- src/Dodge/Room/Teleport.hs | 55 +- src/Dodge/Room/Treasure.hs | 87 +- src/Dodge/Room/Warning.hs | 68 +- src/Dodge/RoomLink.hs | 142 +-- src/Dodge/RoomPos.hs | 8 +- src/Dodge/Save.hs | 59 +- src/Dodge/Shockwave/Draw.hs | 23 +- src/Dodge/Shockwave/Update.hs | 105 +- src/Dodge/SoundLogic.hs | 301 +++--- src/Dodge/Spark.hs | 143 +-- src/Dodge/Spark/Draw.hs | 10 +- src/Dodge/StartNewGame.hs | 21 +- src/Dodge/Targeting.hs | 7 +- src/Dodge/Targeting/Draw.hs | 69 +- src/Dodge/Terminal.hs | 283 +++--- src/Dodge/Terminal/LeftButton.hs | 46 +- src/Dodge/Tesla/Arc.hs | 170 ++-- src/Dodge/Tesla/Arc/Default.hs | 56 +- src/Dodge/Tesla/Arc/Draw.hs | 13 +- src/Dodge/Tesla/Ball.hs | 3 +- src/Dodge/Tesla/ItemParams.hs | 19 +- src/Dodge/TestString.hs | 5 +- src/Dodge/TmTm.hs | 8 +- src/Dodge/TractorBeam/Draw.hs | 22 +- src/Dodge/TractorBeam/Update.hs | 39 +- src/Dodge/Tree/Compose.hs | 119 +-- src/Dodge/Tree/Shift.hs | 200 ++-- src/Dodge/Turretoid.hs | 5 +- src/Dodge/Tweak.hs | 4 +- src/Dodge/Tweak/Show.hs | 4 +- src/Dodge/Update.hs | 3 +- src/Dodge/Update/Camera.hs | 244 ++--- src/Dodge/Update/Cloud.hs | 13 +- src/Dodge/Update/UsingInput.hs | 107 +-- src/Dodge/Update/WallDamage.hs | 13 +- src/Dodge/Wall/Create.hs | 14 +- src/Dodge/Wall/Damage.hs | 39 +- src/Dodge/Wall/DamageEffect.hs | 156 +-- src/Dodge/Wall/Delete.hs | 24 +- src/Dodge/Wall/Draw.hs | 10 +- src/Dodge/Wall/Dust.hs | 17 +- src/Dodge/Wall/ForceField.hs | 29 +- src/Dodge/Wall/Move.hs | 58 +- src/Dodge/Wall/Zone.hs | 9 +- src/Dodge/WallCreatureCollisions.hs | 106 ++- src/Dodge/WdP2f.hs | 21 +- src/Dodge/Wire.hs | 44 +- src/Dodge/WorldBool.hs | 18 +- src/Dodge/WorldEffect.hs | 2 +- src/Dodge/WorldEvent/Cloud.hs | 95 +- src/Dodge/WorldEvent/Damage.hs | 29 +- src/Dodge/WorldEvent/Explosion.hs | 128 +-- src/Dodge/WorldEvent/Flash.hs | 58 +- src/Dodge/WorldEvent/Shockwave.hs | 100 +- src/Dodge/WorldEvent/Sound.hs | 23 +- src/Dodge/WorldEvent/SpawnParticle.hs | 145 +-- src/Dodge/WorldEvent/ThingsHit.hs | 130 +-- src/Dodge/WorldPos.hs | 3 +- src/Dodge/Zone/Object.hs | 8 +- src/Dodge/Zone/Update.hs | 26 +- src/Dodge/Zoning/Cloud.hs | 10 +- src/Dodge/Zoning/Creature.hs | 16 +- src/Dodge/Zoning/Pathing.hs | 40 +- src/Dodge/Zoning/Wall.hs | 14 +- src/Dodge/Zoning/World.hs | 13 +- src/Picture/Data.hs | 107 ++- 418 files changed, 15105 insertions(+), 13343 deletions(-) delete mode 100644 src/Dodge/Base/Item.hs delete mode 100644 src/Dodge/Config/KeyConfig.hs create mode 100644 src/Dodge/Data/GenWorld.hs create mode 100644 src/Dodge/Data/Item/HeldDelay.hs delete mode 100644 src/Dodge/Data/Item/UseDelay.hs create mode 100644 src/Dodge/Data/Universe.hs create mode 100644 src/Dodge/Data/World.hs delete mode 100644 src/Dodge/Default/AimParams.hs rename src/Dodge/Default/{Foreground.hs => ForegroundShape.hs} (53%) create mode 100644 src/Dodge/Default/Item/Effect.hs create mode 100644 src/Dodge/Default/Item/Use.hs create mode 100644 src/Dodge/Default/Item/Use/AimParams.hs create mode 100644 src/Dodge/Default/Item/Use/Consumption.hs create mode 100644 src/Dodge/Default/Item/Use/Equipment.hs create mode 100644 src/Dodge/ForceField.hs create mode 100644 src/Dodge/Item/Held/BatteryGuns.hs create mode 100644 src/Dodge/Item/Held/BulletGun.hs rename src/Dodge/Item/{Weapon/BulletGun => Held}/Cane.hs (70%) create mode 100644 src/Dodge/Item/Held/Cone.hs create mode 100644 src/Dodge/Item/Held/Launcher.hs create mode 100644 src/Dodge/Item/Held/Rod.hs rename src/Dodge/Item/{Weapon => Held}/SprayGuns.hs (76%) create mode 100644 src/Dodge/Item/Held/Stick.hs create mode 100644 src/Dodge/Item/Held/Utility.hs create mode 100644 src/Dodge/Item/Held/Weapons.hs create mode 100644 src/Dodge/Item/Left.hs delete mode 100644 src/Dodge/Item/PassKey.hs create mode 100644 src/Dodge/Item/Targeting.hs delete mode 100644 src/Dodge/Item/Weapon/BulletGun/Rod.hs delete mode 100644 src/Dodge/Item/Weapon/BulletGun/Stick.hs delete mode 100644 src/Dodge/Item/Weapon/BulletGuns.hs diff --git a/appDodge/Main.hs b/appDodge/Main.hs index cb8c7d0ca..8798d18f1 100644 --- a/appDodge/Main.hs +++ b/appDodge/Main.hs @@ -10,7 +10,6 @@ import Dodge.Initialisation import Dodge.Update import Dodge.Event import Dodge.Render -import Dodge.Config.KeyConfig import Dodge.Config.Load import Dodge.Config.Update import Dodge.SoundLogic.LoadSound @@ -20,7 +19,6 @@ import Preload.Render import Sound import Preload import Music -import Data.Preload import Data.Preload.Render import Control.Lens @@ -73,7 +71,6 @@ theCleanup uv = SDL.cursorVisible $= True >> cleanUpPreload (_preloadData uv) firstWorldLoad :: Configuration -> IO Universe firstWorldLoad theConfig = do SDL.cursorVisible $= False - theKeyConfig <- loadKeyConfig pdata <- doPreload >>= applyWorldConfig theConfig return $ startNewGame $ Universe {_uvWorld = initialWorld @@ -81,7 +78,6 @@ firstWorldLoad theConfig = do ,_preloadData = pdata ,_menuLayers = [] ,_savedWorlds = M.empty - ,_keyConfig = theKeyConfig , _uvIOEffects = return , _uvTestString = testStringInit } diff --git a/src/Dodge/Annotation.hs b/src/Dodge/Annotation.hs index cb51a115a..2b569becd 100644 --- a/src/Dodge/Annotation.hs +++ b/src/Dodge/Annotation.hs @@ -7,7 +7,7 @@ module Dodge.Annotation import Dodge.Cleat import RandomHelp import Dodge.Tree -import Dodge.Data +import Dodge.Data.GenWorld import Dodge.Annotation.Data import LensHelp diff --git a/src/Dodge/Annotation/Data.hs b/src/Dodge/Annotation/Data.hs index 53b2a71c4..626141590 100644 --- a/src/Dodge/Annotation/Data.hs +++ b/src/Dodge/Annotation/Data.hs @@ -1,9 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} module Dodge.Annotation.Data where -import Dodge.Data ---import Dodge.Room ---import TreeHelp +import Dodge.Data.GenWorld import Dodge.Tree.Compose.Data import Control.Monad.State diff --git a/src/Dodge/ArcStep.hs b/src/Dodge/ArcStep.hs index d70ae0e64..4a88b7d89 100644 --- a/src/Dodge/ArcStep.hs +++ b/src/Dodge/ArcStep.hs @@ -1,8 +1,9 @@ module Dodge.ArcStep where -import Dodge.Data -import Dodge.Tesla.Arc.Default import Control.Monad.State +import Dodge.Data.ArcStep +import Dodge.Data.World +import Dodge.Tesla.Arc.Default import System.Random doStep :: NextArcStep -> ItemParams -> World -> ArcStep -> State StdGen (Maybe ArcStep) diff --git a/src/Dodge/Barreloid.hs b/src/Dodge/Barreloid.hs index e7f794a36..6af720c0d 100644 --- a/src/Dodge/Barreloid.hs +++ b/src/Dodge/Barreloid.hs @@ -1,14 +1,14 @@ module Dodge.Barreloid where -import Dodge.Data -import Dodge.WorldEvent.Explosion -import Dodge.Spark -import Dodge.Creature.State -import Geometry -import Dodge.SoundLogic -import LensHelp -import System.Random import Data.List +import Dodge.Creature.State +import Dodge.Data.World +import Dodge.SoundLogic +import Dodge.Spark +import Dodge.WorldEvent.Explosion +import Geometry +import LensHelp +import System.Random updateBarreloid :: Creature -> World -> World updateBarreloid cr = case cr ^?! crType . barrelType of @@ -17,46 +17,52 @@ updateBarreloid cr = case cr ^?! crType . barrelType of -- should generate the sparks externally using new random generators updateExpBarrel :: Creature -> World -> World -updateExpBarrel cr w +updateExpBarrel cr w | _crHP cr > 0 = foldr ($) (hiss w & cWorld . creatures . at (_crID cr) .~ newCr) pierceSparks - | otherwise = makeExplosionAt (_crPos cr) $ stopSounds w & cWorld . creatures . at (_crID cr) .~ Nothing - where + | otherwise = makeExplosionAt (_crPos cr) $ stopSounds w & cWorld . creatures . at (_crID cr) .~ Nothing + where g = _randGen w damages = _csDamage $ _crState cr pierceSparks :: [World -> World] - pierceSparks - = zipWith3 (\p a -> createBarrelSpark (_crPos cr +.+ p) (a + argV p)) - poss as colids - as = randomRs (-0.7,0.7) g - colids = randomRs (0,11) g + pierceSparks = + zipWith3 + (\p a -> createBarrelSpark (_crPos cr +.+ p) (a + argV p)) + poss + as + colids + as = randomRs (-0.7, 0.7) g + colids = randomRs (0, 11) g poss = _piercedPoints $ _csSpState $ _crState cr newCr = Just $ applyFuseDamage $ set (crState . csDamage) [] $ damToExpBarrel damages cr - applyFuseDamage cr' = cr' & crHP %~ - subtract (length . _piercedPoints . _csSpState $ _crState cr') - hiss | null poss = id - | otherwise = soundMultiFrom [BarrelHiss 0,BarrelHiss 1] (_crPos cr) foamSprayLoopS (Just 1) + applyFuseDamage cr' = + cr' & crHP + %~ subtract (length . _piercedPoints . _csSpState $ _crState cr') + hiss + | null poss = id + | otherwise = soundMultiFrom [BarrelHiss 0, BarrelHiss 1] (_crPos cr) foamSprayLoopS (Just 1) stopSounds = stopSoundFrom (BarrelHiss 0) . stopSoundFrom (BarrelHiss 1) updateBarrel :: Creature -> World -> World updateBarrel cr | _crHP cr > 0 = doDamage cr - | otherwise = cWorld . creatures . at (_crID cr) .~ Nothing + | otherwise = cWorld . creatures . at (_crID cr) .~ Nothing damToExpBarrel :: [Damage] -> Creature -> Creature damToExpBarrel ds cr = foldr damToExpBarrel' (foldr damToExpBarrel' cr pierceDam) otherDam - where - (pierceDam,otherDam) = partition isPierce ds + where + (pierceDam, otherDam) = partition isPierce ds isPierce Damage{_dmType = PIERCING{}} = True - isPierce _ = False + isPierce _ = False damToExpBarrel' :: Damage -> Creature -> Creature damToExpBarrel' dm cr = case _dmType dm of - PIERCING -> over (crState . csSpState . piercedPoints) ((:) $ int -.- _crPos cr) - $ cr & crHP -~ div amount 200 - POISONDAM -> cr - SPARKING -> cr --- PUSHDAM -> cr LensHelp.& crPos .+.+~ (1 / _crMass cr *.* _dePushBack (_dmEffect dm)) - _ -> cr LensHelp.& crHP -~ amount + PIERCING -> + over (crState . csSpState . piercedPoints) ((:) $ int -.- _crPos cr) $ + cr & crHP -~ div amount 200 + POISONDAM -> cr + SPARKING -> cr + -- PUSHDAM -> cr LensHelp.& crPos .+.+~ (1 / _crMass cr *.* _dePushBack (_dmEffect dm)) + _ -> cr LensHelp.& crHP -~ amount where amount = _dmAmount dm int = _dmAt dm diff --git a/src/Dodge/Base/CardinalPoint.hs b/src/Dodge/Base/CardinalPoint.hs index 68bac1871..8f6d4e6b2 100644 --- a/src/Dodge/Base/CardinalPoint.hs +++ b/src/Dodge/Base/CardinalPoint.hs @@ -1,15 +1,14 @@ module Dodge.Base.CardinalPoint where + import Dodge.Data.Room import Geometry cardList :: [CardinalPoint] -cardList = [North,East,South,West] +cardList = [North, East, South, West] cardVec :: CardinalPoint -> Point2 cardVec cp = case cp of - North -> V2 0 1 - South -> V2 0 (-1) - East -> V2 1 0 - West -> V2 (-1) 0 - - + North -> V2 0 1 + South -> V2 0 (-1) + East -> V2 1 0 + West -> V2 (-1) 0 diff --git a/src/Dodge/Base/Collide.hs b/src/Dodge/Base/Collide.hs index 985e10ee8..6a1ab771f 100644 --- a/src/Dodge/Base/Collide.hs +++ b/src/Dodge/Base/Collide.hs @@ -1,58 +1,58 @@ {-# LANGUAGE TupleSections #-} + {- | Basic collision detection for a moving point. - Conventions: input is typically a stream of walls. - Collide returns an endpoint and maybe a collided with - object (wall). - Reflect maybe gives a slightly pushed out point from a collision and a - - relection velocity. + - relection velocity. - Overlap returns a stream of walls. - A point will typically be moving. - A ball refers to a moving circle, i.e. a point with a radius. - - -} -module Dodge.Base.Collide - ( collidePoint - , collideSegCrs - , collidePointWallsFilterStream - , collidePointTestFilter - , overlapSegWalls - , overlapSegCrs - , overlap1SegCrs - , bounceBall - , bouncePoint - , sortStreamOn - , minStreamOn - , collideCircWallsStream - , circOnSomeWall - , circOnAnyCr - , overlapCircWalls - , overlapCircWallsClosest - , crsNearPoint - , allVisibleWalls - - , hasLOS - , hasLOSIndirect - , hasButtonLOS - , canSee - , canSeeIndirect - , isWalkable - - , anythingHitCirc - ) where -import Dodge.Data -import Dodge.Zoning -import Dodge.Base.Wall -import Geometry -import FoldableHelp + - +-} +module Dodge.Base.Collide ( + collidePoint, + collideSegCrs, + collidePointWallsFilterStream, + collidePointTestFilter, + overlapSegWalls, + overlapSegCrs, + overlap1SegCrs, + bounceBall, + bouncePoint, + sortStreamOn, + minStreamOn, + collideCircWallsStream, + circOnSomeWall, + circOnAnyCr, + overlapCircWalls, + overlapCircWallsClosest, + crsNearPoint, + allVisibleWalls, + hasLOS, + hasLOSIndirect, + hasButtonLOS, + canSee, + canSeeIndirect, + isWalkable, + anythingHitCirc, +) where +import Control.Lens +import qualified Data.IntSet as IS import Data.List (sortOn) import Data.Maybe +import Dodge.Base.Wall +import Dodge.Data.World +import Dodge.Zoning +import FoldableHelp +import Geometry import qualified IntMapHelp as IM -import Control.Lens -import StreamingHelp import qualified Streaming.Prelude as S -import qualified Data.IntSet as IS +import StreamingHelp ---collidePoint :: Point2 -> Point2 +--collidePoint :: Point2 -> Point2 -- -> StreamOf Wall -- -> (Point2, Maybe Wall) --{-# INLINE collidePoint #-} @@ -60,54 +60,69 @@ import qualified Data.IntSet as IS -- where -- findPoint (p,mwl) wl = maybe (p,mwl) (,Just wl) . uncurry (intersectSegSeg sp p) . _wlLine $ wl -collidePoint :: Point2 -> Point2 - -> [Wall] - -> (Point2, Maybe Wall) +collidePoint :: + Point2 -> + Point2 -> + [Wall] -> + (Point2, Maybe Wall) {-# INLINE collidePoint #-} collidePoint sp ep = foldl' findPoint (ep, Nothing) where - findPoint (p,mwl) wl = maybe (p,mwl) (,Just wl) . uncurry (intersectSegSeg sp p) . _wlLine $ wl + findPoint (p, mwl) wl = maybe (p, mwl) (,Just wl) . uncurry (intersectSegSeg sp p) . _wlLine $ wl -overlap1SegCrs :: Point2 -> Point2 - -> [Creature] - -> [(Point2, Creature)] +overlap1SegCrs :: + Point2 -> + Point2 -> + [Creature] -> + [(Point2, Creature)] {-# INLINE overlap1SegCrs #-} -overlap1SegCrs sp ep = mapMaybe - (\cr -> (,cr) <$> listToMaybe (intersectCircSeg (_crPos cr) (_crRad cr) sp ep )) +overlap1SegCrs sp ep = + mapMaybe + (\cr -> (,cr) <$> listToMaybe (intersectCircSeg (_crPos cr) (_crRad cr) sp ep)) -overlapSegCrs :: Point2 -> Point2 - -> StreamOf Creature - -> StreamOf ([Point2], Creature) +overlapSegCrs :: + Point2 -> + Point2 -> + StreamOf Creature -> + StreamOf ([Point2], Creature) {-# INLINE overlapSegCrs #-} -overlapSegCrs sp ep = S.mapMaybe - (\cr -> f cr $ intersectCircSeg (_crPos cr) (_crRad cr) sp ep ) +overlapSegCrs sp ep = + S.mapMaybe + (\cr -> f cr $ intersectCircSeg (_crPos cr) (_crRad cr) sp ep) where - f _ [] = Nothing - f cr ps = Just (ps,cr) + f _ [] = Nothing + f cr ps = Just (ps, cr) -collideSegCrs :: Point2 -> Point2 - -> StreamOf Creature - -> (Point2, Maybe Creature) +collideSegCrs :: + Point2 -> + Point2 -> + StreamOf Creature -> + (Point2, Maybe Creature) {-# INLINE collideSegCrs #-} collideSegCrs sp ep = runIdentity . S.fold_ findPoint (ep, Nothing) id where - findPoint (p,mcr) cr - = maybe (p,mcr) (,Just cr) $ listToMaybe (intersectCircSeg (_crPos cr) (_crRad cr) sp p) + findPoint (p, mcr) cr = + maybe (p, mcr) (,Just cr) $ listToMaybe (intersectCircSeg (_crPos cr) (_crRad cr) sp p) doBounce :: Float -> Point2 -> Point2 -> (Point2, Maybe Wall) -> Maybe (Point2, Point2) {-# INLINE doBounce #-} -doBounce x sp ep (p, mwl) = mwl <&> \wl -> - ( p +.+ normalizeV (vNormal (uncurry (-.-) (_wlLine wl))) - , reflVelWallDamp x wl (ep -.- sp) - ) +doBounce x sp ep (p, mwl) = + mwl <&> \wl -> + ( p +.+ normalizeV (vNormal (uncurry (-.-) (_wlLine wl))) + , reflVelWallDamp x wl (ep -.- sp) + ) -bounceBall :: Float -> Point2 -> Point2 -> Float - -> [Wall] - -> Maybe (Point2,Point2) +bounceBall :: + Float -> + Point2 -> + Point2 -> + Float -> + [Wall] -> + Maybe (Point2, Point2) {-# INLINE bounceBall #-} bounceBall x sp ep r = doBounce x sp ep . collideCircWalls sp ep r -bouncePoint :: (Wall -> Bool) -> Float -> Point2 -> Point2 -> World -> Maybe (Point2,Point2) +bouncePoint :: (Wall -> Bool) -> Float -> Point2 -> Point2 -> World -> Maybe (Point2, Point2) {-# INLINE bouncePoint #-} bouncePoint t x sp ep = doBounce x sp ep . collidePointWallsFilterStream t sp ep @@ -115,39 +130,41 @@ bouncePoint t x sp ep = doBounce x sp ep . collidePointWallsFilterStream t sp ep -- whether this is actually faster collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> [Wall] -> Bool {-# INLINE collidePointTestFilter #-} -collidePointTestFilter t sp ep - = any (isJust . uncurry (intersectSegSeg sp ep) . _wlLine) - . filter t +collidePointTestFilter t sp ep = + any (isJust . uncurry (intersectSegSeg sp ep) . _wlLine) + . filter t ---- this COULD be written in terms of collidePointWallsFilterStream, TODO test ---- whether this is actually faster --collidePointTestFilter :: (Wall -> Bool) -> Point2 -> Point2 -> StreamOf Wall -> Bool --{-# INLINE collidePointTestFilter #-} ---collidePointTestFilter t sp ep = runIdentity +--collidePointTestFilter t sp ep = runIdentity -- . S.any_ (isJust . uncurry (intersectSegSeg sp ep) . _wlLine) -- . S.filter t collidePointWallsFilterStream :: (Wall -> Bool) -> Point2 -> Point2 -> World -> (Point2, Maybe Wall) {-# INLINE collidePointWallsFilterStream #-} -collidePointWallsFilterStream t sp ep = collidePoint sp ep - . filter t - . wlsNearSeg sp ep +collidePointWallsFilterStream t sp ep = + collidePoint sp ep + . filter t + . wlsNearSeg sp ep --overlapSegWalls :: Point2 -> Point2 -> StreamOf Wall -- -> StreamOf (Point2,Wall) --{-# INLINE overlapSegWalls #-} --overlapSegWalls sp ep = S.mapMaybe $ \wl -> uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl) -overlapSegWalls :: Point2 -> Point2 -> [Wall] -> [(Point2,Wall)] +overlapSegWalls :: Point2 -> Point2 -> [Wall] -> [(Point2, Wall)] {-# INLINE overlapSegWalls #-} overlapSegWalls sp ep = mapMaybe $ \wl -> uncurry (intersectSegSeg sp ep) (_wlLine wl) <&> (,wl) -visibleWalls :: Point2 -> Point2 -> World -> [(Point2,Wall)] +visibleWalls :: Point2 -> Point2 -> World -> [(Point2, Wall)] {-# INLINE visibleWalls #-} -visibleWalls sp ep = takeUntil (not . wlIsOpaque . snd) - . sortOn (dist sp . fst) - . overlapSegWalls sp ep - . wlsNearSeg sp ep +visibleWalls sp ep = + takeUntil (not . wlIsOpaque . snd) + . sortOn (dist sp . fst) + . overlapSegWalls sp ep + . wlsNearSeg sp ep --visibleWalls :: Point2 -> Point2 -> World -> StreamOf (Point2,Wall) --{-# INLINE visibleWalls #-} @@ -157,7 +174,7 @@ visibleWalls sp ep = takeUntil (not . wlIsOpaque . snd) -- . overlapSegWalls sp ep -- . wlsNearSeg sp ep ) -allVisibleWalls :: World -> [(Point2,Wall)] +allVisibleWalls :: World -> [(Point2, Wall)] {-# INLINE allVisibleWalls #-} allVisibleWalls w = concatMap (flip (visibleWalls vPos) w . (+.+ vPos)) $ nRays 20 where @@ -168,7 +185,7 @@ allVisibleWalls w = concatMap (flip (visibleWalls vPos) w . (+.+ vPos)) $ nRays --allVisibleWalls w = concats $ S.subst (flip (visibleWalls vPos) w . (+.+ vPos)) $ S.each (nRays 20) -- where -- vPos = _cameraViewFrom w - + --overlapCircWalls :: Point2 -> Float -> StreamOf Wall -- -> StreamOf (Point2,Wall) --{-# INLINE overlapCircWalls #-} @@ -177,61 +194,81 @@ allVisibleWalls w = concatMap (flip (visibleWalls vPos) w . (+.+ vPos)) $ nRays -- dointersect wl = f (_wlLine wl) <&> (,wl) -- f (a,b) = intersectSegSeg p (p +.+ r *.* normalizeV ((0.5 *.* (a +.+ b)) -.- p)) a b -overlapCircWalls :: Point2 -> Float -> [Wall] - -> [(Point2,Wall)] +overlapCircWalls :: + Point2 -> + Float -> + [Wall] -> + [(Point2, Wall)] {-# INLINE overlapCircWalls #-} overlapCircWalls p r = mapMaybe dointersect where dointersect wl = f (_wlLine wl) <&> (,wl) - f (a,b) = intersectSegSeg p (p +.+ r *.* normalizeV ((0.5 *.* (a +.+ b)) -.- p)) a b + f (a, b) = intersectSegSeg p (p +.+ r *.* normalizeV ((0.5 *.* (a +.+ b)) -.- p)) a b -- | note that this does not push the circle away from the wall at all collideCircWalls :: Point2 -> Point2 -> Float -> [Wall] -> (Point2, Maybe Wall) {-# INLINE collideCircWalls #-} collideCircWalls sp ep rad = foldl' findPoint (ep, Nothing) where - findPoint (p,mwl) wl = maybe (p,mwl) (,Just wl) . uncurry (intersectSegSeg sp p) - . shiftbyrad - . _wlLine $ wl - shiftbyrad (a,b) = bimap f f - (a +.+ rad *.* normalizeV (a -.-b) - ,b +.+ rad *.* normalizeV (b -.-a) - ) + findPoint (p, mwl) wl = + maybe (p, mwl) (,Just wl) . uncurry (intersectSegSeg sp p) + . shiftbyrad + . _wlLine + $ wl + shiftbyrad (a, b) = + bimap + f + f + ( a +.+ rad *.* normalizeV (a -.- b) + , b +.+ rad *.* normalizeV (b -.- a) + ) where f = (+.+) (rad *.* normalizeV (vNormal $ a -.- b)) -- | note that this does not push the circle away from the wall at all -collideCircWallsStream :: Point2 -> Point2 -> Float -> StreamOf Wall - -> (Point2, Maybe Wall) +collideCircWallsStream :: + Point2 -> + Point2 -> + Float -> + StreamOf Wall -> + (Point2, Maybe Wall) {-# INLINE collideCircWallsStream #-} collideCircWallsStream sp ep rad = runIdentity . S.fold_ findPoint (ep, Nothing) id where - findPoint (p,mwl) wl = maybe (p,mwl) (,Just wl) . uncurry (intersectSegSeg sp p) - . shiftbyrad - . _wlLine $ wl - shiftbyrad (a,b) = bimap f f - (a +.+ rad *.* normalizeV (a -.-b) - ,b +.+ rad *.* normalizeV (b -.-a) - ) + findPoint (p, mwl) wl = + maybe (p, mwl) (,Just wl) . uncurry (intersectSegSeg sp p) + . shiftbyrad + . _wlLine + $ wl + shiftbyrad (a, b) = + bimap + f + f + ( a +.+ rad *.* normalizeV (a -.- b) + , b +.+ rad *.* normalizeV (b -.- a) + ) where f = (+.+) (rad *.* normalizeV (vNormal $ a -.- b)) -overlapCircWallsClosest :: Point2 -> Float -> [Wall] -> Maybe (Point2,Wall) +overlapCircWallsClosest :: Point2 -> Float -> [Wall] -> Maybe (Point2, Wall) {-# INLINE overlapCircWallsClosest #-} -overlapCircWallsClosest p r = safeMinimumOn (dist p . fst) - . overlapCircWalls p r +overlapCircWallsClosest p r = + safeMinimumOn (dist p . fst) + . overlapCircWalls p r --overlapCircWallsClosest :: Point2 -> Float -> StreamOf Wall -> Maybe (Point2,Wall) --{-# INLINE overlapCircWallsClosest #-} --overlapCircWallsClosest p r = minStreamOn (dist p . fst) -- . overlapCircWalls p r -{- | Test if a circle collides with any wall. - - Note no check on whether the wall is walkable. -} +{- | Test if a circle collides with any wall. + - Note no check on whether the wall is walkable. +-} circOnSomeWall :: Point2 -> Float -> World -> Bool {-# INLINE circOnSomeWall #-} -circOnSomeWall p rad = any (uncurry (circOnSeg p rad) . _wlLine) - . wlsNearPoint p +circOnSomeWall p rad = + any (uncurry (circOnSeg p rad) . _wlLine) + . wlsNearPoint p --circOnSomeWall :: Point2 -> Float -> World -> Bool --{-# INLINE circOnSomeWall #-} @@ -244,53 +281,60 @@ circOnAnyCr p r w = IS.foldr f False $ crIXsNearPoint p w where f cid bl = maybe False (\cr -> dist p (_crPos cr) < r + _crRad cr) (w ^? cWorld . creatures . ix cid) || bl -{- | More general collision tests follow -} - +-- | More general collision tests follow hasLOS :: Point2 -> Point2 -> World -> Bool {-# INLINE hasLOS #-} -hasLOS p1 p2 = not - . collidePointTestFilter (const True) p1 p2 - . wlsNearSeg p1 p2 +hasLOS p1 p2 = + not + . collidePointTestFilter (const True) p1 p2 + . wlsNearSeg p1 p2 hasButtonLOS :: Point2 -> Point2 -> World -> Bool {-# INLINE hasButtonLOS #-} -hasButtonLOS p1 p2 = not - . collidePointTestFilter (not . _wlTouchThrough) p1 p2 - . wlsNearSeg p1 p2 +hasButtonLOS p1 p2 = + not + . collidePointTestFilter (not . _wlTouchThrough) p1 p2 + . wlsNearSeg p1 p2 hasLOSIndirect :: Point2 -> Point2 -> World -> Bool {-# INLINE hasLOSIndirect #-} -hasLOSIndirect p1 p2 = not - . collidePointTestFilter wlIsOpaque p1 p2 - . wlsNearSeg p1 p2 +hasLOSIndirect p1 p2 = + not + . collidePointTestFilter wlIsOpaque p1 p2 + . wlsNearSeg p1 p2 isWalkable :: Point2 -> Point2 -> World -> Bool {-# INLINE isWalkable #-} -isWalkable p1 p2 = not - . collidePointTestFilter (not . (^?! wlPathable)) p1 p2 - . wlsNearSeg p1 p2 +isWalkable p1 p2 = + not + . collidePointTestFilter (not . (^?! wlPathable)) p1 p2 + . wlsNearSeg p1 p2 canSee :: Int -> Int -> World -> Bool {-# INLINE canSee #-} canSee i j w = hasLOS p1 p2 w - where + where p1 = _crPos (_creatures (_cWorld w) IM.! i) - p2 = _crPos (_creatures (_cWorld w) IM.! j) -- unsafe + p2 = _crPos (_creatures (_cWorld w) IM.! j) -- unsafe canSeeIndirect :: Int -> Int -> World -> Bool {-# INLINE canSeeIndirect #-} canSeeIndirect i j w = hasLOSIndirect ipos jpos w - where + where ipos = _crPos (_creatures (_cWorld w) IM.! i) jpos = _crPos (_creatures (_cWorld w) IM.! j) anythingHitCirc :: Float -> Point2 -> Point2 -> World -> Bool anythingHitCirc rad sp ep w = hitCr || isJust (sequence hitWl) where - hitCr = IS.foldr f False $ crsNearSeg sp ep w - f cid bl = maybe False (\cr -> null $ intersectCircSeg (_crPos cr) (rad + _crRad cr) sp ep) + hitCr = IS.foldr f False $ crsNearSeg sp ep w + f cid bl = + maybe + False + (\cr -> null $ intersectCircSeg (_crPos cr) (rad + _crRad cr) sp ep) (w ^? cWorld . creatures . ix cid) - || bl + || bl - hitWl = collideCircWalls sp ep rad $ wlsNearPoint ep w - -- this should probably be wallsOnLine or something + hitWl = collideCircWalls sp ep rad $ wlsNearPoint ep w + +-- this should probably be wallsOnLine or something diff --git a/src/Dodge/Base/Coordinate.hs b/src/Dodge/Base/Coordinate.hs index 6476d85bc..b6c5014f0 100644 --- a/src/Dodge/Base/Coordinate.hs +++ b/src/Dodge/Base/Coordinate.hs @@ -1,38 +1,48 @@ module Dodge.Base.Coordinate where -import Dodge.Data -import Dodge.Base.WinScale +import Dodge.Base.WinScale +import Dodge.Data.Universe import Geometry -{- | Transform coordinates from world position to screen coordinates. -} + +-- | Transform coordinates from world position to screen coordinates. worldPosToScreenNorm :: Configuration -> World -> Point2 -> Point2 worldPosToScreenNorm cfig w = doWindowScale cfig . doRotate . doZoom . doTranslate where doTranslate p = p -.- _cameraCenter (_cWorld w) - doZoom p = _cameraZoom (_cWorld w) *.* p - doRotate p = rotateV (negate $ _cameraRot (_cWorld w)) p -{- | Transform world coordinates to scaled screen coordinates. + doZoom p = _cameraZoom (_cWorld w) *.* p + doRotate p = rotateV (negate $ _cameraRot (_cWorld w)) p + +{- | Transform world coordinates to scaled screen coordinates. - These have to be scaled according to the size of the window to get actual screen positions. - - This allows for line thicknesses etc to correspond to pixel sizes.-} + - This allows for line thicknesses etc to correspond to pixel sizes. +-} worldPosToScreen :: World -> Point2 -> Point2 -worldPosToScreen w - = rotateV (negate $ _cameraRot (_cWorld w)) - . (_cameraZoom (_cWorld w) *.*) - . (-.- _cameraCenter (_cWorld w)) +worldPosToScreen w = + rotateV (negate $ _cameraRot (_cWorld w)) + . (_cameraZoom (_cWorld w) *.*) + . (-.- _cameraCenter (_cWorld w)) + {- | Transform coordinates from the map position to screen -coordinates. -} +coordinates. +-} cartePosToScreen :: Configuration -> World -> Point2 -> Point2 cartePosToScreen cfig w = doWindowScale cfig . doRotate . doZoom . doTranslate where - doTranslate p = p -.- _carteCenter (_hud (_cWorld w)) - doZoom p = _carteZoom (_hud (_cWorld w)) *.* p - doRotate p = rotateV (negate $ _carteRot (_hud (_cWorld w))) p -crToMousePosOffset :: Creature -> World -> (Point2,Float) -crToMousePosOffset cr w = (mouseWorldPos w -.- _crPos cr,0) -{- | The mouse position in world coordinates. -} + doTranslate p = p -.- _carteCenter (_hud (_cWorld w)) + doZoom p = _carteZoom (_hud (_cWorld w)) *.* p + doRotate p = rotateV (negate $ _carteRot (_hud (_cWorld w))) p + +crToMousePosOffset :: Creature -> World -> (Point2, Float) +crToMousePosOffset cr w = (mouseWorldPos w -.- _crPos cr, 0) + +-- | The mouse position in world coordinates. mouseWorldPos :: World -> Point2 -mouseWorldPos w = _cameraCenter (_cWorld w) +.+ - (1/_cameraZoom (_cWorld w)) *.* rotateV (_cameraRot (_cWorld w)) (_mousePos w) -{- | The mouse position in map coordinates -} +mouseWorldPos w = + _cameraCenter (_cWorld w) + +.+ (1 / _cameraZoom (_cWorld w)) *.* rotateV (_cameraRot (_cWorld w)) (_mousePos w) + +-- | The mouse position in map coordinates mouseCartePos :: World -> Point2 -mouseCartePos w = _carteCenter (_hud (_cWorld w)) +.+ - (1/_carteZoom (_hud (_cWorld w))) *.* rotateV (_carteRot (_hud (_cWorld w))) (_mousePos w) +mouseCartePos w = + _carteCenter (_hud (_cWorld w)) + +.+ (1 / _carteZoom (_hud (_cWorld w))) *.* rotateV (_carteRot (_hud (_cWorld w))) (_mousePos w) diff --git a/src/Dodge/Base/Item.hs b/src/Dodge/Base/Item.hs deleted file mode 100644 index 819d726f8..000000000 --- a/src/Dodge/Base/Item.hs +++ /dev/null @@ -1,27 +0,0 @@ -module Dodge.Base.Item - ( - ) where ---import Dodge.Data ---import Dodge.Base.You ---import LensHelp --- ---import qualified IntMapHelp as IM - ---selectedObject :: World -> Maybe (Either FloorItem Button) ---selectedObject w = lookup (_crInvSel ycr) $ zip [n..] $ _closeObjects w --- where --- ycr = you w --- n = length $ _crInv ycr --- ---crItem :: World -> Int -> Item ---crItem w cid = _crInv cr IM.! _crInvSel cr --- where --- cr = _creatures w IM.! cid --- ---yourItemRef --- :: Applicative f --- => World --- -> (Item -> f Item) --- -> World --- -> f World ---yourItemRef w = creatures . ix (_yourID w) . crInv . ix (_crInvSel (you w)) diff --git a/src/Dodge/Base/Wall.hs b/src/Dodge/Base/Wall.hs index c48d9bdd6..0d7443388 100644 --- a/src/Dodge/Base/Wall.hs +++ b/src/Dodge/Base/Wall.hs @@ -1,5 +1,6 @@ module Dodge.Base.Wall where -import Dodge.Data + +import Dodge.Data.Wall import Geometry wlIsOpaque :: Wall -> Bool diff --git a/src/Dodge/Base/Window.hs b/src/Dodge/Base/Window.hs index 4669a1108..491575fe2 100644 --- a/src/Dodge/Base/Window.hs +++ b/src/Dodge/Base/Window.hs @@ -1,54 +1,61 @@ -{- | Getting the window size geometry. -} -module Dodge.Base.Window - ( halfWidth - , halfHeight - , screenPolygon - , screenPolygonBord - , screenBox - ) - where -import Dodge.Data +-- | Getting the window size geometry. +module Dodge.Base.Window ( + halfWidth, + halfHeight, + screenPolygon, + screenPolygonBord, + screenBox, +) where + +import Dodge.Data.Universe import Geometry -- | A box covering the screen in world coordinates screenPolygon :: Configuration -> World -> [Point2] screenPolygon cfig w = map (scTran . scRot . scZoom) $ screenBox cfig --- [tr,tl,bl,br] - where - scRot = rotateV (_cameraRot (_cWorld w)) - scZoom p | _cameraZoom (_cWorld w) /= 0 = (1/_cameraZoom (_cWorld w)) *.* p - | otherwise = p + where + -- [tr,tl,bl,br] + + scRot = rotateV (_cameraRot (_cWorld w)) + scZoom p + | _cameraZoom (_cWorld w) /= 0 = (1 / _cameraZoom (_cWorld w)) *.* p + | otherwise = p scTran p = p +.+ _cameraCenter (_cWorld w) --- tr = scTran $ scRot $ scZoom (V2 ( halfWidth w) ( halfHeight w)) --- tl = scTran $ scRot $ scZoom (V2 (-halfWidth w) ( halfHeight w)) + +-- tr = scTran $ scRot $ scZoom (V2 ( halfWidth w) ( halfHeight w)) +-- tl = scTran $ scRot $ scZoom (V2 (-halfWidth w) ( halfHeight w)) -- br = scTran $ scRot $ scZoom (V2 ( halfWidth w) (-halfHeight w)) -- bl = scTran $ scRot $ scZoom (V2 (-halfWidth w) (-halfHeight w)) -- | A box covering the screen in world coordinates, with a x and y border -screenPolygonBord - :: Float -- ^ X border - -> Float -- ^ Y border - -> Configuration - -> World - -> [Point2] -screenPolygonBord xbord ybord cfig w = [tr,tl,bl,br] - where - hw = halfWidth cfig - xbord +screenPolygonBord :: + -- | X border + Float -> + -- | Y border + Float -> + Configuration -> + World -> + [Point2] +screenPolygonBord xbord ybord cfig w = [tr, tl, bl, br] + where + hw = halfWidth cfig - xbord hh = halfHeight cfig - ybord - scZoom p | _cameraZoom (_cWorld w) /= 0 = (1/_cameraZoom (_cWorld w)) *.* p - | otherwise = p + scZoom p + | _cameraZoom (_cWorld w) /= 0 = (1 / _cameraZoom (_cWorld w)) *.* p + | otherwise = p theTransform = (+.+ _cameraCenter (_cWorld w)) . rotateV (_cameraRot (_cWorld w)) . scZoom - tr = theTransform (V2 hw hh ) - tl = theTransform (V2 (-hw) hh ) - br = theTransform (V2 hw (-hh)) - bl = theTransform (V2 (-hw) (-hh)) + tr = theTransform (V2 hw hh) + tl = theTransform (V2 (- hw) hh) + br = theTransform (V2 hw (- hh)) + bl = theTransform (V2 (- hw) (- hh)) -halfWidth,halfHeight :: Configuration -> Float +halfWidth, halfHeight :: Configuration -> Float halfWidth w = _windowX w / 2 halfHeight w = _windowY w / 2 + -- | A box of the size of the screen in screen centered coordinates screenBox :: Configuration -> [Point2] -screenBox w = rectNSWE hh (-hh) (-hw) hw +screenBox w = rectNSWE hh (- hh) (- hw) hw where hw = halfWidth w hh = halfHeight w diff --git a/src/Dodge/Base/You.hs b/src/Dodge/Base/You.hs index d3eceb184..b44e1a944 100644 --- a/src/Dodge/Base/You.hs +++ b/src/Dodge/Base/You.hs @@ -1,8 +1,7 @@ module Dodge.Base.You where -import Dodge.Data ---import Picture + +import Dodge.Data.World import qualified IntMapHelp as IM ---import Control.Lens you :: World -> Creature you w = _creatures (_cWorld w) IM.! _yourID (_cWorld w) diff --git a/src/Dodge/Beam.hs b/src/Dodge/Beam.hs index f82cabc27..7d4524d48 100644 --- a/src/Dodge/Beam.hs +++ b/src/Dodge/Beam.hs @@ -1,59 +1,71 @@ module Dodge.Beam where -import Dodge.Data + +import Data.Maybe +import Dodge.Data.World import Dodge.Flame -import Dodge.Tesla.Arc import Dodge.Item.Location +import Dodge.Tesla.Arc import Geometry +import qualified IntMapHelp as IM import LensHelp import Picture -import Data.Maybe -import qualified IntMapHelp as IM - -doBeamCombine :: BeamCombineType - -> (Point2,(Point2,Point2,Beam),(Point2,Point2,Beam)) - -> World - -> World +doBeamCombine :: + BeamCombineType -> + (Point2, (Point2, Point2, Beam), (Point2, Point2, Beam)) -> + World -> + World doBeamCombine bct = case bct of FlameBeamCombine -> flameBeamCombine - LasBeamCombine -> lasBeamCombine + LasBeamCombine -> lasBeamCombine TeslaBeamCombine -> teslaBeamCombine SplitBeamCombine -> splitBeamCombine NoBeamCombine -> const id -flameBeamCombine :: (Point2,(Point2,Point2,Beam),(Point2,Point2,Beam)) - -> World -> World -flameBeamCombine (p,(a,b,_),(x,y,_)) - = makeFlame p (2 *.* normalizeV (normalizeV (b-.-a)+.+normalizeV (y-.-x))) -lasBeamCombine :: (Point2,(Point2,Point2,Beam),(Point2,Point2,Beam)) - -> World -> World -lasBeamCombine (p,(a,b,_),(x,y,_)) - = cWorld . lasers .:~ lasRayAt yellow 11 1 p (argV (normalizeV (b-.-a)+.+normalizeV (y-.-x))) -splitBeamCombine :: (Point2,(Point2,Point2,Beam),(Point2,Point2,Beam)) - -> World -> World -splitBeamCombine (p,(a,b,_),(x,y,_)) - = (cWorld . lasers .:~ lasRayAt yellow 11 1 p (dir+0.5*pi)) - . (cWorld . lasers .:~ lasRayAt yellow 11 1 p (dir-0.5*pi)) +flameBeamCombine :: + (Point2, (Point2, Point2, Beam), (Point2, Point2, Beam)) -> + World -> + World +flameBeamCombine (p, (a, b, _), (x, y, _)) = + makeFlame p (2 *.* normalizeV (normalizeV (b -.- a) +.+ normalizeV (y -.- x))) + +lasBeamCombine :: + (Point2, (Point2, Point2, Beam), (Point2, Point2, Beam)) -> + World -> + World +lasBeamCombine (p, (a, b, _), (x, y, _)) = + cWorld . lasers .:~ lasRayAt yellow 11 1 p (argV (normalizeV (b -.- a) +.+ normalizeV (y -.- x))) + +splitBeamCombine :: + (Point2, (Point2, Point2, Beam), (Point2, Point2, Beam)) -> + World -> + World +splitBeamCombine (p, (a, b, _), (x, y, _)) = + (cWorld . lasers .:~ lasRayAt yellow 11 1 p (dir + 0.5 * pi)) + . (cWorld . lasers .:~ lasRayAt yellow 11 1 p (dir -0.5 * pi)) where - dir = argV (normalizeV (b-.-a)+.+normalizeV (y-.-x)) + dir = argV (normalizeV (b -.- a) +.+ normalizeV (y -.- x)) -teslaBeamCombine :: (Point2,(Point2,Point2,Beam),(Point2,Point2,Beam)) - -> World -> World -teslaBeamCombine (p,(a,b,bm),(x,y,_)) w - = w' & pointerToItemLocation (_itemLocations (_cWorld w) IM.! itid) . itParams . subParams ?~ ip +teslaBeamCombine :: + (Point2, (Point2, Point2, Beam), (Point2, Point2, Beam)) -> + World -> + World +teslaBeamCombine (p, (a, b, bm), (x, y, _)) w = + w' & pointerToItemLocation (_itemLocations (_cWorld w) IM.! itid) . itParams . subParams ?~ ip where itid = fromJust $ _bmOrigin bm - dir = argV (normalizeV (b-.-a)+.+normalizeV (y-.-x)) - (w',ip) = shootTeslaArc' (fromJust . _subParams $ _itParams it) p dir w + dir = argV (normalizeV (b -.- a) +.+ normalizeV (y -.- x)) + (w', ip) = shootTeslaArc' (fromJust . _subParams $ _itParams it) p dir w it = case getItem itid w of Nothing -> error "tried to get item use teslaBeamCombine that doesn't exist" Just itm -> itm lasRayAt :: Color -> Int -> Float -> Point2 -> Float -> LaserStart -lasRayAt col dam phasev pos dir = LaserStart - { _lpType = DamageLaser dam - , _lpPhaseV = phasev - , _lpPos = pos - , _lpDir = dir - , _lpColor = col - } +lasRayAt col dam phasev pos dir = + LaserStart + { _lpType = DamageLaser dam + , _lpPhaseV = phasev + , _lpPos = pos + , _lpDir = dir + , _lpColor = col + } diff --git a/src/Dodge/Beam/Draw.hs b/src/Dodge/Beam/Draw.hs index a27a6e9d1..e70ae6c25 100644 --- a/src/Dodge/Beam/Draw.hs +++ b/src/Dodge/Beam/Draw.hs @@ -1,4 +1,5 @@ module Dodge.Beam.Draw where + import Dodge.Data.Beam import Picture @@ -8,10 +9,12 @@ drawBeam bd = case bd of BeamDrawColor _ -> basicDrawBeam basicDrawBeam :: Beam -> Picture -basicDrawBeam bm = setLayer BloomNoZWrite $ pictures - [ setDepth 19 . color (brightX 0 0.5 col) $ thickLine 20 ps - , setDepth 19.5 . color (brightX 10 1 col) $ thickLine 3 ps - ] +basicDrawBeam bm = + setLayer BloomNoZWrite $ + pictures + [ setDepth 19 . color (brightX 0 0.5 col) $ thickLine 20 ps + , setDepth 19.5 . color (brightX 10 1 col) $ thickLine 3 ps + ] where col = _bmColor bm ps = _bmFirstPoints bm diff --git a/src/Dodge/Block.hs b/src/Dodge/Block.hs index bdbc2640a..3b6efbe41 100644 --- a/src/Dodge/Block.hs +++ b/src/Dodge/Block.hs @@ -1,42 +1,45 @@ module Dodge.Block where -import Dodge.DrWdWd -import Dodge.Zoning.Wall -import Dodge.Data + +import Dodge.Data.MountedObject +import Control.Lens +import Data.Foldable +import qualified Data.Graph.Inductive as FGL +import qualified Data.IntSet as IS +import Data.Maybe import Dodge.Base.Collide -import Dodge.Material.Sound import Dodge.Block.Debris +import Dodge.Data.World +import Dodge.DrWdWd import Dodge.LightSource -import Dodge.Wall.Zone -import Dodge.WorldEvent.Sound +import Dodge.Material.Sound import Dodge.Wall.Delete import Dodge.Wall.Dust -import RandomHelp +import Dodge.Wall.Zone +import Dodge.WorldEvent.Sound +import Dodge.Zoning.Wall import Geometry ---import Geometry.ConvexPoly - -import Data.Foldable -import Data.Function -import Data.Maybe -import qualified Data.IntSet as IS import qualified IntMapHelp as IM -import Control.Lens -import qualified Data.Graph.Inductive as FGL +import RandomHelp splinterBlock :: Block -> World -> World -splinterBlock bl w = foldr unshadowBlock w (_blShadows bl) -- foldr shiftTowardCen w (_blWallIDs bl) - & originsIDsAt [MaterialSound bm 0,MaterialSound bm 1,MaterialSound bm 2] - (weakenMatS bm) (_blPos bl) +splinterBlock bl w = + foldr unshadowBlock w (_blShadows bl) -- foldr shiftTowardCen w (_blWallIDs bl) + & originsIDsAt + [MaterialSound bm 0, MaterialSound bm 1, MaterialSound bm 2] + (weakenMatS bm) + (_blPos bl) where bm = fromMaybe Stone $ do wlids <- w ^? cWorld . blocks . ix (_blID bl) . blWallIDs - (wlid,_) <- IS.minView wlids + (wlid, _) <- IS.minView wlids w ^? cWorld . walls . ix wlid . wlMaterial unshadowBlock :: Int -> World -> World unshadowBlock wlid w = case w ^? cWorld . walls . ix wlid of - Just wl -> w - & cWorld . walls . ix wlid . wlUnshadowed .~ True - & insertWallInZones (wl & wlUnshadowed .~ True) + Just wl -> + w + & cWorld . walls . ix wlid . wlUnshadowed .~ True + & insertWallInZones (wl & wlUnshadowed .~ True) Nothing -> w checkBlockHP :: Block -> World -> World @@ -45,14 +48,15 @@ checkBlockHP bl | otherwise = id destroyBlock :: Block -> World -> World -destroyBlock bl w = w - & flip (foldr unshadowBlock) (_blShadows bl) - & makeBlockDebris bl - & deleteWallIDs wlids - & maybeClearPaths (_blObstructs bl) -- must happen after the walls are deleted - & cWorld . blocks %~ IM.delete (_blID bl) --- & matDesSound (_blMaterial bl) pos - & flip (foldr (wlDustAt awl)) (map (pos +.+) ps) +destroyBlock bl w = + w + & flip (foldr unshadowBlock) (_blShadows bl) + & makeBlockDebris bl + & deleteWallIDs wlids + & maybeClearPaths (_blObstructs bl) -- must happen after the walls are deleted + & cWorld . blocks %~ IM.delete (_blID bl) + -- & matDesSound (_blMaterial bl) pos + & flip (foldr (wlDustAt awl)) (map (pos +.+) ps) where wlids = _blWallIDs bl awl = _walls (_cWorld w) IM.! IS.findMin wlids @@ -60,23 +64,24 @@ destroyBlock bl w = w ps = replicateM 25 (randInCirc 20) & evalState $ _randGen w -- this does not handle eg doors blocking the path as well -maybeClearPaths :: [(Int,Int,PathEdge)] -> World -> World +maybeClearPaths :: [(Int, Int, PathEdge)] -> World -> World maybeClearPaths ps w = foldl' maybeClearPath w ps -maybeClearPath :: World -> (Int,Int,PathEdge) -> World -maybeClearPath w (x,y,pe) - | not . null $ overlapSegWalls (_peStart pe) (_peEnd pe) $ wlsNearSeg (_peStart pe) (_peEnd pe) w - = w - | otherwise = w & cWorld . pathGraph %~ FGL.insEdge (x,y,pe & peObstacles .~ mempty) . FGL.delEdge (x,y) +maybeClearPath :: World -> (Int, Int, PathEdge) -> World +maybeClearPath w (x, y, pe) + | not . null $ overlapSegWalls (_peStart pe) (_peEnd pe) $ wlsNearSeg (_peStart pe) (_peEnd pe) w = + w + | otherwise = w & cWorld . pathGraph %~ FGL.insEdge (x, y, pe & peObstacles .~ mempty) . FGL.delEdge (x, y) destroyDoor :: Door -> World -> World -destroyDoor dr w = w - & doDrWdWd (_drDeath dr) dr - & deleteWallIDs wlids - & cWorld . doors %~ IM.delete (_drID dr) - & flip (foldr (wlDustAt awl)) (map (pos +.+) ps) - & stopPushing (_drPushes dr) - & destroyMounts (_drMounts dr) +destroyDoor dr w = + w + & doDrWdWd (_drDeath dr) dr + & deleteWallIDs wlids + & cWorld . doors %~ IM.delete (_drID dr) + & flip (foldr (wlDustAt awl)) (map (pos +.+) ps) + & stopPushing (_drPushes dr) + & destroyMounts (_drMounts dr) where wlids = _drWallIDs dr awl = _walls (_cWorld w) IM.! IS.findMin wlids @@ -95,5 +100,6 @@ stopPushing :: Maybe Int -> World -> World stopPushing mdrid w = fromMaybe w $ do drid <- mdrid dr <- w ^? cWorld . doors . ix drid - return $ w & cWorld . doors . ix drid . drMech .~ DrWdId - & stopPushing (_drPushes dr) + return $ + w & cWorld . doors . ix drid . drMech .~ DrWdId + & stopPushing (_drPushes dr) diff --git a/src/Dodge/Block/Debris.hs b/src/Dodge/Block/Debris.hs index 8176783de..548e71242 100644 --- a/src/Dodge/Block/Debris.hs +++ b/src/Dodge/Block/Debris.hs @@ -1,171 +1,197 @@ module Dodge.Block.Debris where -import Dodge.Material.Sound -import Dodge.WorldEvent.Sound -import Dodge.Base -import Dodge.Data -import Shape -import Geometry -import Color -import LensHelp -import RandomHelp -import Grid -import qualified Quaternion as Q +import Color +import Data.Foldable import qualified Data.IntSet as IS import Data.Maybe -import Data.Foldable +import Dodge.Base +import Dodge.Data.World +import Dodge.Material.Sound +import Dodge.WorldEvent.Sound +import Geometry +import Grid +import LensHelp +import qualified Quaternion as Q +import RandomHelp +import Shape makeDoorDebris :: Door -> World -> World makeDoorDebris dr w = w & makeDebris mt col p where p = uncurry midPoint (_drPos dr) - (mt,col) = fromMaybe (Stone,greyN 0.5) $ do + (mt, col) = fromMaybe (Stone, greyN 0.5) $ do wlids <- w ^? cWorld . doors . ix (_drID dr) . drWallIDs - (wlid,_) <- IS.minView wlids + (wlid, _) <- IS.minView wlids wl <- w ^? cWorld . walls . ix wlid - return (_wlMaterial wl,_wlColor wl) + return (_wlMaterial wl, _wlColor wl) makeBlockDebris :: Block -> World -> World ---makeBlockDebris bl w = w & makeDebris mt col (_blPos bl) -makeBlockDebris bl w = foldr (makeDebris mt col) w ps +makeBlockDebris bl w = foldr (makeDebris mt col) w ps where dsize = debrisSize mt ps = gridInPolygon dsize $ shrinkPolyOnEdges dsize $ reverse (_blFootprint bl) - (mt,col) = fromMaybe (Stone,greyN 0.5) $ do + (mt, col) = fromMaybe (Stone, greyN 0.5) $ do wlids <- w ^? cWorld . blocks . ix (_blID bl) . blWallIDs - (wlid,_) <- IS.minView wlids + (wlid, _) <- IS.minView wlids wl <- w ^? cWorld . walls . ix wlid - return (_wlMaterial wl,_wlColor wl) + return (_wlMaterial wl, _wlColor wl) makeDebrisToHeight :: Float -> Material -> Color -> Point2 -> World -> World -makeDebrisToHeight = makeDebrisDirectedHeight 1 2 (2*pi) 0 +makeDebrisToHeight = makeDebrisDirectedHeight 1 2 (2 * pi) 0 makeDebris :: Material -> Color -> Point2 -> World -> World -makeDebris = makeDebrisDirected 1 2 (2*pi) 0 +makeDebris = makeDebrisDirected 1 2 (2 * pi) 0 -makeDebrisDirectedHeight :: Float -> Float -> Float -> Float -> Float -> Material - -> Color -> Point2 -> World -> World -makeDebrisDirectedHeight mindist maxdist arcrad dir maxh bm col p w = w +makeDebrisDirectedHeight :: + Float -> + Float -> + Float -> + Float -> + Float -> + Material -> + Color -> + Point2 -> + World -> + World +makeDebrisDirectedHeight mindist maxdist arcrad dir maxh bm col p w = + w & flip (foldl' (flip $ plNew (cWorld . props) prID)) thedebris & randGen .~ newg - & originsIDsAt [MaterialSound bm i | i <- [0,1,2]] (destroyMatS bm) p + & originsIDsAt [MaterialSound bm i | i <- [0, 1, 2]] (destroyMatS bm) p where dsize = debrisSize bm - (thedebris,newg) = mapM f [10,10 + dsize ..maxh+5] & runState $ _randGen w + (thedebris, newg) = mapM f [10, 10 + dsize .. maxh + 5] & runState $ _randGen w f h = do - v <- rotateV (dir - arcrad/2) <$> randInArcStrip mindist maxdist arcrad + v <- rotateV (dir - arcrad / 2) <$> randInArcStrip mindist maxdist arcrad q <- Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere - spinspeed <- randomR (-0.2,-0.1) & state + spinspeed <- randomR (-0.2, -0.1) & state basedebris <- baseDebris bm - return $ basedebris - & prColor .~ col - & prPos .~ p - & prVel .~ v - & prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) spinspeed - & prQuat .~ q - & prVelZ .~ 0 - & prPosZ .~ h + return $ + basedebris + & prColor .~ col + & prPos .~ p + & prVel .~ v + & prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) spinspeed + & prQuat .~ q + & prVelZ .~ 0 + & prPosZ .~ h -makeDebrisDirected :: Float - -> Float - -> Float - -> Float - -> Material - -> Color - -> Point2 - -> World -> World -makeDebrisDirected mindist maxdist arcrad dir bm col p w = w +makeDebrisDirected :: + Float -> + Float -> + Float -> + Float -> + Material -> + Color -> + Point2 -> + World -> + World +makeDebrisDirected mindist maxdist arcrad dir bm col p w = + w & flip (foldl' (flip $ plNew (cWorld . props) prID)) thedebris & randGen .~ newg - & originsIDsAt [MaterialSound bm i | i <- [0,1,2]] (destroyMatS bm) p + & originsIDsAt [MaterialSound bm i | i <- [0, 1, 2]] (destroyMatS bm) p where - (thedebris,newg) = mapM f [35,55..95] & runState $ _randGen w + (thedebris, newg) = mapM f [35, 55 .. 95] & runState $ _randGen w f h = do - v <- rotateV (dir - arcrad/2) <$> randInArcStrip mindist maxdist arcrad + v <- rotateV (dir - arcrad / 2) <$> randInArcStrip mindist maxdist arcrad q <- Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere - spinspeed <- randomR (-0.2,-0.1) & state + spinspeed <- randomR (-0.2, -0.1) & state basedebris <- baseDebris bm - return $ basedebris - & prColor .~ col - & prPos .~ p - & prVel .~ v - & prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) spinspeed - & prQuat .~ q - & prVelZ .~ 0 - & prPosZ .~ h + return $ + basedebris + & prColor .~ col + & prPos .~ p + & prVel .~ v + & prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) spinspeed + & prQuat .~ q + & prVelZ .~ 0 + & prPosZ .~ h debrisSize :: Material -> Float debrisSize mt = case mt of - Stone -> 20 - Glass -> 10 + Stone -> 20 + Glass -> 10 Crystal -> 10 - Dirt -> 20 - Wood -> 10 - Metal -> 10 + Dirt -> 20 + Wood -> 10 + Metal -> 10 Electronics -> 10 Flesh -> 10 baseDebris :: Material -> State StdGen Prop baseDebris mt = case mt of - Stone -> return stoneDebris - Glass -> return glassDebris + Stone -> return stoneDebris + Glass -> return glassDebris Crystal -> return crystalDebris - Dirt -> return dirtDebris - Wood -> return stoneDebris - Metal -> do + Dirt -> return dirtDebris + Wood -> return stoneDebris + Metal -> do sh <- jaggedShape - return $ metalDebris - & prDraw .~ PropDrawMovingShapeCol sh + return $ + metalDebris + & prDraw .~ PropDrawMovingShapeCol sh Electronics -> baseDebris Metal - Flesh -> baseDebris Dirt <&> prColor .~ red + Flesh -> baseDebris Dirt <&> prColor .~ red stoneDebris :: Prop -stoneDebris = PropZ - {_prPos = 0 - ,_prStartPos = 0 - ,_prVel = 0 - ,_prDraw = PropDrawMovingShapeCol (cubeShape 4) - ,_prID = 0 - ,_prUpdate = PropFallSmallBounceDamage - ,_prPosZ = 10 - ,_prVelZ = 5 - ,_prTimer = 20 - ,_prQuat = Q.axisAngle (V3 1 0 0) 0 - ,_prQuatSpin = Q.axisAngle (V3 1 1 0) 0.1 - ,_prColor = greyN 0.5 - } +stoneDebris = + PropZ + { _prPos = 0 + , _prStartPos = 0 + , _prVel = 0 + , _prDraw = PropDrawMovingShapeCol (cubeShape 4) + , _prID = 0 + , _prUpdate = PropFallSmallBounceDamage + , _prPosZ = 10 + , _prVelZ = 5 + , _prTimer = 20 + , _prQuat = Q.axisAngle (V3 1 0 0) 0 + , _prQuatSpin = Q.axisAngle (V3 1 1 0) 0.1 + , _prColor = greyN 0.5 + } + dirtDebris :: Prop -dirtDebris = stoneDebris - & prColor .~ dirtColor - & prUpdate .~ PropFallSmallBounce +dirtDebris = + stoneDebris + & prColor .~ dirtColor + & prUpdate .~ PropFallSmallBounce + dirtColor :: Color -dirtColor = V4 (150/256) ( 75/256) 0 ( 250/256) +dirtColor = V4 (150 / 256) (75 / 256) 0 (250 / 256) metalDebris :: Prop -metalDebris = stoneDebris - & prDraw .~ PropDrawMovingShapeCol (shardShape 4) - & prUpdate .~ PropFallSmallBounceDamage +metalDebris = + stoneDebris + & prDraw .~ PropDrawMovingShapeCol (shardShape 4) + & prUpdate .~ PropFallSmallBounceDamage glassDebris :: Prop -glassDebris = stoneDebris - & prDraw .~ PropDrawMovingShapeCol (shardShape 4) - & prUpdate .~ PropFallSmallBounce - & prColor .~ withAlpha 0.5 cyan +glassDebris = + stoneDebris + & prDraw .~ PropDrawMovingShapeCol (shardShape 4) + & prUpdate .~ PropFallSmallBounce + & prColor .~ withAlpha 0.5 cyan + crystalDebris :: Prop -crystalDebris = glassDebris - & prColor .~ withAlpha 0.5 aquamarine +crystalDebris = + glassDebris + & prColor .~ withAlpha 0.5 aquamarine shardShape :: Float -> Shape -shardShape size = translateSHz (-size) $ upperPrismPoly size - [V2 size 0 - ,V2 (-size) 1 - ,V2 (-size) (-1) - ] +shardShape size = + translateSHz (- size) $ + upperPrismPoly + size + [ V2 size 0 + , V2 (- size) 1 + , V2 (- size) (-1) + ] jaggedShape :: State StdGen Shape jaggedShape = do - s <- randomR (4,10) & state + s <- randomR (4, 10) & state return $ shardShape s cubeShape :: Float -> Shape -cubeShape size = translateSHz (-size) $ upperPrismPoly (2*size) $ square size +cubeShape size = translateSHz (- size) $ upperPrismPoly (2 * size) $ square size diff --git a/src/Dodge/Bullet.hs b/src/Dodge/Bullet.hs index a31a14af2..6178d204d 100644 --- a/src/Dodge/Bullet.hs +++ b/src/Dodge/Bullet.hs @@ -7,7 +7,7 @@ import Data.Maybe import Dodge.Base.Coordinate import Dodge.Creature.HandPos import Dodge.Creature.Test -import Dodge.Data +import Dodge.Data.World import Dodge.EnergyBall import Dodge.MagnetBuBu import Dodge.Movement.Turn diff --git a/src/Dodge/Bullet/Draw.hs b/src/Dodge/Bullet/Draw.hs index 909c183a1..e0b5f8bf8 100644 --- a/src/Dodge/Bullet/Draw.hs +++ b/src/Dodge/Bullet/Draw.hs @@ -1,11 +1,14 @@ -module Dodge.Bullet.Draw - ( drawBul - ) where +module Dodge.Bullet.Draw ( + drawBul, +) where + import Dodge.Data.Bullet -import Picture import Linear +import Picture + drawBul :: Bullet -> Picture -drawBul pt = setLayer BloomNoZWrite - . setDepth 20 - . color (V4 200 200 200 2) - $ thickLine (_buWidth pt) [_buOldPos pt, _buPos pt] +drawBul pt = + setLayer BloomNoZWrite + . setDepth 20 + . color (V4 200 200 200 2) + $ thickLine (_buWidth pt) [_buOldPos pt, _buPos pt] diff --git a/src/Dodge/Button/Draw.hs b/src/Dodge/Button/Draw.hs index d97ba82e8..ad5e5308b 100644 --- a/src/Dodge/Button/Draw.hs +++ b/src/Dodge/Button/Draw.hs @@ -1,9 +1,10 @@ module Dodge.Button.Draw where + +import Color import Dodge.Data.Button import Geometry -import Color -import ShapePicture import Shape +import ShapePicture drawButton :: ButtonDraw -> Button -> SPic drawButton bd = case bd of @@ -13,16 +14,19 @@ drawButton bd = case bd of drawSwitch :: Color -> Color -> Button -> SPic drawSwitch col1 col2 bt - | _btState bt == BtOff - = flick $ pi/4 - | otherwise = flick (negate (pi/4)) + | _btState bt == BtOff = + flick $ pi / 4 + | otherwise = flick (negate (pi / 4)) where - flick a = ( mconcat - [ colorSH col1 . upperPrismPoly 20 $ reverse $ rectNSWE (-2) (-5) (-10) 10 - , colorSH col2 . translateSH (V3 0 (-2) 20) . rotateSH a . upperPrismPoly 2 $ reverse - $ rectNSWE 10 0 (-2) 2 - ] - , mempty) + flick a = + ( mconcat + [ colorSH col1 . upperPrismPoly 20 $ reverse $ rectNSWE (-2) (-5) (-10) 10 + , colorSH col2 . translateSH (V3 0 (-2) 20) . rotateSH a . upperPrismPoly 2 $ + reverse $ + rectNSWE 10 0 (-2) 2 + ] + , mempty + ) defaultDrawButton :: Color -> Button -> SPic defaultDrawButton col bt = @@ -31,6 +35,6 @@ defaultDrawButton col bt = ) where buttonGeometry - | _btState bt == BtOff = reverse $ rectNSWE 10 (-1) (-width) width - | otherwise = reverse $ rectNSWE 2 (-1) (-width) width + | _btState bt == BtOff = reverse $ rectNSWE 10 (-1) (- width) width + | otherwise = reverse $ rectNSWE 2 (-1) (- width) width width = 8 diff --git a/src/Dodge/Button/Event.hs b/src/Dodge/Button/Event.hs index 5e3253705..421f83739 100644 --- a/src/Dodge/Button/Event.hs +++ b/src/Dodge/Button/Event.hs @@ -1,31 +1,35 @@ module Dodge.Button.Event where -import Dodge.Data -import Dodge.SoundLogic -import Dodge.WorldEffect import Control.Lens +import Dodge.Data.World +import Dodge.SoundLogic +import Dodge.WorldEffect doButtonEvent :: ButtonEvent -> Button -> World -> World doButtonEvent be = case be of ButtonDoNothing -> const id - ButtonPress newstate newevent thesound f -> \b -> doWdWd f - . set (cWorld . buttons . ix (_btID b) . btState) newstate - . set (cWorld . buttons . ix (_btID b) . btEvent) newevent - . soundStart (LeverSound 0) (_btPos b) thesound Nothing + ButtonPress newstate newevent thesound f -> \b -> + doWdWd f + . set (cWorld . buttons . ix (_btID b) . btState) newstate + . set (cWorld . buttons . ix (_btID b) . btEvent) newevent + . soundStart (LeverSound 0) (_btPos b) thesound Nothing --ButtonSwitch onstate onevent onsound oneff offstate offevent offsound offeff -> undefined ButtonSimpleSwith oneff offeff -> flipSwitch oneff offeff ButtonAccessTerminal -> accessTerminal . _btTermMID flipSwitch :: WdWd -> WdWd -> Button -> World -> World -flipSwitch oneff offeff bt - | _btState bt == BtOff = doWdWd oneff . dosound - . over (cWorld . buttons . ix (_btID bt)) turnon - | otherwise = doWdWd offeff . dosound - . over (cWorld . buttons . ix (_btID bt)) turnoff +flipSwitch oneff offeff bt + | _btState bt == BtOff = + doWdWd oneff . dosound + . over (cWorld . buttons . ix (_btID bt)) turnon + | otherwise = + doWdWd offeff . dosound + . over (cWorld . buttons . ix (_btID bt)) turnoff where - turnon = (btState .~ BtOn ) . (btText .~ "SWITCH\\") - turnoff = (btState .~ BtOff) . (btText .~ "SWITCH/") + turnon = (btState .~ BtOn) . (btText .~ "SWITCH\\") + turnoff = (btState .~ BtOff) . (btText .~ "SWITCH/") dosound = soundFromGeneral (LeverSound 0) (const $ _btPos bt) click1S Nothing + -- switchEffect b = case _btState b of -- BtOff -> effOn . (buttons . ix (_btID b) %~ turnOn ) -- BtOn -> effOff . (buttons . ix (_btID b) %~ turnOff) diff --git a/src/Dodge/ChainEffect.hs b/src/Dodge/ChainEffect.hs index 35ec8a3e9..8866c29b3 100644 --- a/src/Dodge/ChainEffect.hs +++ b/src/Dodge/ChainEffect.hs @@ -1,5 +1,5 @@ module Dodge.ChainEffect where -import Dodge.Data +import Dodge.Data.World type ChainEffect = (Item -> Creature -> World -> World) diff --git a/src/Dodge/Cleat.hs b/src/Dodge/Cleat.hs index 08b4befc3..05498b623 100644 --- a/src/Dodge/Cleat.hs +++ b/src/Dodge/Cleat.hs @@ -6,7 +6,7 @@ module Dodge.Cleat , rToOnward , cleatLabel ) where -import Dodge.Data +import Dodge.Data.GenWorld import Dodge.Tree.Compose import Data.Tree diff --git a/src/Dodge/Clock.hs b/src/Dodge/Clock.hs index 23efdefe8..b83aa5ae9 100644 --- a/src/Dodge/Clock.hs +++ b/src/Dodge/Clock.hs @@ -1,7 +1,7 @@ module Dodge.Clock ( clockCycle ) where -import Dodge.Data +import Dodge.Data.World import qualified Data.Vector as V clockCycle :: Int -> V.Vector a -> World -> a diff --git a/src/Dodge/Combine.hs b/src/Dodge/Combine.hs index 02aa665b6..16980efb2 100644 --- a/src/Dodge/Combine.hs +++ b/src/Dodge/Combine.hs @@ -1,85 +1,85 @@ --{-# LANGUAGE TupleSections #-} -module Dodge.Combine - ( combinePoss - , combineSizes - , combineItemListYou - , combineListInfo - , toggleCombineInv - , enterCombineInv - ) where -import Dodge.Combine.Trie +module Dodge.Combine ( + combinePoss, + combineSizes, + combineItemListYou, + combineListInfo, + toggleCombineInv, + enterCombineInv, +) where + +import Control.Lens +import Control.Monad +import Data.Bifunctor +import Data.List (scanl', sortOn) +import Data.Map.Merge.Strict +import qualified Data.Map.Strict as M +import Data.Maybe import Dodge.Base.You -import Dodge.Data -import Dodge.Item.Amount +import Dodge.Combine.Trie +import Dodge.Data.World import Dodge.Inventory.ItemSpace ---import Dodge.Combine.Module +import Dodge.Item.Amount import Dodge.Module ---import Dodge.Combine.Data ---import Multiset +import qualified IntMapHelp as IM import SimpleTrie -import Data.Map.Merge.Strict -import Control.Monad -import Control.Lens -import Data.Bifunctor -import qualified IntMapHelp as IM ---import qualified Data.IntSet as IS -import qualified Data.Map.Strict as M ---import Data.Map.Merge.Strict -import Data.Maybe -import Data.List (scanl',sortOn) +invertInventory :: IM.IntMap Item -> [(ItemBaseType, ItAmount, Int)] +invertInventory = + IM.foldrWithKey + (\k it -> ((_iyBase $ _itType it, itStackAmount it, k) :)) + [] -invertInventory :: IM.IntMap Item -> [(ItemBaseType,ItAmount,Int)] -invertInventory = IM.foldrWithKey - (\k it -> ((_iyBase $ _itType it, itStackAmount it,k) :) ) - [] - -splitItAmounts :: [(ItemBaseType,ItAmount,Int)] -> [((ItAmount,ItemBaseType),(ItAmount,Int))] +splitItAmounts :: [(ItemBaseType, ItAmount, Int)] -> [((ItAmount, ItemBaseType), (ItAmount, Int))] splitItAmounts = concatMap f where - f (x,n,y) = [((i,x),(i,y)) | i <- [1..n]] + f (x, n, y) = [((i, x), (i, y)) | i <- [1 .. n]] -lookupItems :: IM.IntMap Item -> [([(ItAmount,Int)],Item)] +lookupItems :: IM.IntMap Item -> [([(ItAmount, Int)], Item)] lookupItems = flip multiLookupTrieI combinationsTrie . sortOn fst . splitItAmounts . invertInventory -combineItemListYouX :: World -> [([Int],Item)] +combineItemListYouX :: World -> [([Int], Item)] combineItemListYouX = map (first $ concatMap g) . lookupItems . yourInv where - g (amount,i) = replicate (_getItAmount amount) i + g (amount, i) = replicate (_getItAmount amount) i -combineListInfo :: World -> [([Int],([String],Item))] +combineListInfo :: World -> [([Int], ([String], Item))] combineListInfo w = filter (f . snd . snd) . map (cmm inv) $ combineItemListYouX w where inv = yourInv w f itm = _itType itm `notElem` fmap _itType inv -combineItemListYou :: World -> [([Int],Item)] +combineItemListYou :: World -> [([Int], Item)] combineItemListYou = map (second snd) . combineListInfo -cmm :: IM.IntMap Item -> ([Int],Item) -> ([Int],([String],Item)) -cmm inv (is,itm) = (is,itm & itType . iyModules %%~ flip combineModuleMaps mms) +cmm :: IM.IntMap Item -> ([Int], Item) -> ([Int], ([String], Item)) +cmm inv (is, itm) = (is, itm & itType . iyModules %%~ flip combineModuleMaps mms) where mms = map (_iyModules . _itType . (inv IM.!)) is - -combineModuleMaps :: M.Map ModuleSlot ItemModuleType - -> [M.Map ModuleSlot ItemModuleType] - -> ([String],M.Map ModuleSlot ItemModuleType) + +combineModuleMaps :: + M.Map ModuleSlot ItemModuleType -> + [M.Map ModuleSlot ItemModuleType] -> + ([String], M.Map ModuleSlot ItemModuleType) combineModuleMaps = foldM combineTwoModuleMaps -combineTwoModuleMaps :: M.Map ModuleSlot ItemModuleType - -> M.Map ModuleSlot ItemModuleType - -> ([String],M.Map ModuleSlot ItemModuleType) -combineTwoModuleMaps = mergeA - preserveMissing - (filterAMissing f) - (zipWithAMatched g) +combineTwoModuleMaps :: + M.Map ModuleSlot ItemModuleType -> + M.Map ModuleSlot ItemModuleType -> + ([String], M.Map ModuleSlot ItemModuleType) +combineTwoModuleMaps = + mergeA + preserveMissing + (filterAMissing f) + (zipWithAMatched g) where - f _ EMPTYMODULE = ([],False) - f _ md = ([rm "REMOVES" md],False) - g _ EMPTYMODULE md = ([],md) - g _ md EMPTYMODULE = ([],md) - g _ md2 md1 = ([rm "REPLACES" md1 ++ rm " WITH" md2],md2) - rm str md = str ++ " "++fullModuleName md + f _ EMPTYMODULE = ([], False) + f _ md = ([rm "REMOVES" md], False) + g _ EMPTYMODULE md = ([], md) + g _ md EMPTYMODULE = ([], md) + g _ md2 md1 = ([rm "REPLACES" md1 ++ rm " WITH" md2], md2) + rm str md = str ++ " " ++ fullModuleName md + -- g above could be a monoid of some description... fullModuleName :: ItemModuleType -> String @@ -87,7 +87,7 @@ fullModuleName = fromMaybe "EMPTYMODULE" . moduleName toggleCombineInv :: World -> World toggleCombineInv w = case _hudElement (_hud (_cWorld w)) of - DisplayInventory CombineInventory {} -> w & cWorld . hud . hudElement .~ DisplayInventory NoSubInventory + DisplayInventory CombineInventory{} -> w & cWorld . hud . hudElement .~ DisplayInventory NoSubInventory _ -> w & enterCombineInv enterCombineInv :: World -> World diff --git a/src/Dodge/Combine/Combinations.hs b/src/Dodge/Combine/Combinations.hs index 89be23b26..eff4e4490 100644 --- a/src/Dodge/Combine/Combinations.hs +++ b/src/Dodge/Combine/Combinations.hs @@ -18,29 +18,21 @@ itemCombinations = , po [cr CAN, cr HARDWARE] bangCone , po [HELD BANGCONE, cr PLANK] blunderbuss , po [HELD BLUNDERBUSS, cr DRUM] (grapeCannon 1) - , -- , po [BANGCONE,PUMP,HARDWARE] $ grenadeLauncher 1 - -- , po [GRENADELAUNCHER 1,MOTOR,DRUM] $ grenadeLauncher 2 - - -- , po [cr PIPE, cr HARDWARE] (volleyGun 1) - po [HELD (BANGSTICK 1), cr PLANK] rifle + , po [HELD (BANGSTICK 1), cr PLANK] rifle , po [HELD (BANGSTICK 1), HELD (BANGSTICK 1), HELD (BANGSTICK 1)] (volleyGun 3) , po [HELD RIFLE, cr TIN] repeater , po [HELD REPEATER, cr SPRING] autoRifle , po [HELD REPEATER, cr CAN] burstRifle - -- , po [BURSTRIFLE,cr SPRING,cr HARDWARE] fastBurstRifle - -- , po [FASTBURSTRIFLE,cr SPRING,cr HARDWARE] completeBurstRifle ] ++ [ po [cr MOTOR, HELD (VOLLEYGUN i)] $ miniGunX i | i <- [3 .. 10] ] - ++ - -- , po [BANGSTICK 1,cr TUBE] elephantGun - [ po [HELD AMR, cr PIPE] sniperRifle - , po [HELD RIFLE, cr PIPE] amr - , po [HELD AMR, cr SPRING] autoAmr - , po [HELD AMR, cr MOTOR] machineGun - , p [p 2 $ cr TUBE, o $ cr HARDWARE] launcher - , p [p 2 $ cr TUBE, o $ HELD LAUNCHER] (launcherX 2) - ] + ++ [ po [HELD AMR, cr PIPE] sniperRifle + , po [HELD RIFLE, cr PIPE] amr + , po [HELD AMR, cr SPRING] autoAmr + , po [HELD AMR, cr MOTOR] machineGun + , p [p 2 $ cr TUBE, o $ cr HARDWARE] launcher + , p [p 2 $ cr TUBE, o $ HELD LAUNCHER] (launcherX 2) + ] ++ [p [p 2 $ cr TUBE, o $ HELD (LAUNCHERX i)] (launcherX (i + 1)) | i <- [2 .. 9]] ++ [ po [cr LIGHTER, cr PUMP, cr CAN] flameSpitter , po [HELD FLAMESPITTER, cr CAN, cr PUMP] blowTorch @@ -48,12 +40,8 @@ itemCombinations = , po [HELD FLAMETHROWER, cr DRUM] flameWall , po [HELD FLAMETHROWER, cr PUMP] flameTorrent , p [o $ cr PRISM, o $ cr TRANSFORMER, o $ cr PIPE] lasGun - , -- , p [o LASGUN,o $ cr PRISM] lasSway - -- , p [o LASGUN,o $ cr HARDWARE] lasSwing - -- , p [o LASGUN,o PIPE] lasGunPulse - po [HELD LASGUN, HELD LASGUN, cr HARDWARE] dualBeam - , -- , p [o LASGUN,o $ cr PIPE, o $ cr PRISM] lasWidePulse - po [HELD LASGUN, cr TRANSFORMER] (lasWide 2) + , po [HELD LASGUN, HELD LASGUN, cr HARDWARE] dualBeam + , po [HELD LASGUN, cr TRANSFORMER] (lasWide 2) , po [HELD LASGUN, HELD LASGUN, HELD LASGUN, cr HARDWARE] lasCircle , p [o $ cr TRANSFORMER, p 2 $ cr CAN] sparkGun , p [o (HELD SPARKGUN), p 2 $ cr PIPE] teslaGun @@ -77,7 +65,6 @@ itemCombinations = , po [cr TRANSFORMER, cr BATTERY, cr MICROCHIP] (makeTypeCraft STATICMODULE) ] ++ map (\i -> po [HELD (LASWIDE i), cr TRANSFORMER] $ lasWide (i + 1)) [2 .. 9] - -- ++ map (\i -> po [LASGUNWIDE i,cr HARDWARE] $ lasFocus i) [2..10] ++ map (\i -> po [cr PIPE, HELD (BANGSTICK i)] $ bangStick (i + 1)) [1 .. 8] ++ map (\i -> po [hd (REVOLVERX i), cr CAN] $ revolverX (i + 1)) [1 .. 5] ++ map (\i -> po [hd (VOLLEYGUN i), HELD (BANGSTICK 1)] $ volleyGun (i + 1)) [3 .. 5] @@ -107,7 +94,6 @@ moduleCombinations = [ repeater , autoRifle , burstRifle - -- ,fastBurstRifle ] , [ amod [cr DRUM, cr HARDWARE] DRUMMAG @@ -214,15 +200,10 @@ batteryGuns = [ teslaGun , sparkGun , lasGun - -- , lasSway - -- , lasSwing ] ++ [ lasWide i | i <- [2 .. 10] ] --- ++ --- [ lasFocus i | i <- [1..10]] - teleportableWeapons :: [Item] teleportableWeapons = bulletWeapons ++ batteryGuns ++ homingLaunchers @@ -242,9 +223,7 @@ bulletWeapons = , repeater , autoRifle , burstRifle - , -- ,fastBurstRifle - -- ,completeBurstRifle - bangCone + , bangCone , blunderbuss , machineGun , elephantGun diff --git a/src/Dodge/Combine/Graph.hs b/src/Dodge/Combine/Graph.hs index 04680ac07..cf86ace0d 100644 --- a/src/Dodge/Combine/Graph.hs +++ b/src/Dodge/Combine/Graph.hs @@ -1,7 +1,7 @@ --{-# LANGUAGE TypeSynonymInstances #-} --{-# LANGUAGE FlexibleInstances #-} module Dodge.Combine.Graph where -import Dodge.Data hiding (East,West,North,South) +import Dodge.Data.Item import Dodge.Combine.Combinations import LensHelp import GraphHelp diff --git a/src/Dodge/Combine/Module.hs b/src/Dodge/Combine/Module.hs index ac1a3ae5f..55f53feab 100644 --- a/src/Dodge/Combine/Module.hs +++ b/src/Dodge/Combine/Module.hs @@ -1,43 +1,50 @@ module Dodge.Combine.Module where -import Dodge.Data + +import Dodge.Item.Targeting +import Dodge.Data.Beam +import Dodge.Data.Item +--import Dodge.Item.Weapon.ExtraEffect import Dodge.Tesla -import Dodge.Item.Weapon.ExtraEffect -import LensHelp import Geometry +import LensHelp moduleModification :: ItemModuleType -> Item -> Item moduleModification imt = case imt of EMPTYMODULE -> id - DRUMMAG -> itUse . heldConsumption . laMax .~ 45 - BELTMAG -> itUse . heldConsumption . laMax .~ 150 - MAGNETMAG -> itUse . useDelay . rateMax .~ 4 - INCENDBUL -> itUse . heldConsumption . laAmmoType . amBullet . buSpawn .~ BulBall IncBall - BOUNCEBUL -> itUse . heldConsumption . laAmmoType . amBullet . buEffect .~ BounceBullet - PENBUL -> itUse . heldConsumption . laAmmoType . amBullet . buEffect .~ PenetrateBullet - STATICBUL -> itUse . heldConsumption . laAmmoType . amBullet . buSpawn .~ BulBall TeslaBall - CONCUSBUL -> itUse . heldConsumption . laAmmoType . amBullet . buSpawn .~ BulBall ConcBall - TARGCR -> itTargeting .~ targetRBCreature - TARGLAS -> itTargeting .~ targetLaser - TARGPOS -> itTargeting .~ targetRBPress - MAGNETTRAJ -> (itUse . heldConsumption . laAmmoType . amBullet . buTrajectory .~ MagnetTrajectory 0) - . (itUse . heldConsumption . laAmmoType . amBullet . buVel .~ V2 10 0) - FLECHETRAJ -> itUse . heldConsumption . laAmmoType . amBullet . buTrajectory .~ FlechetteTrajectory 0 - BEZIERTRAJ -> itUse . heldConsumption . laAmmoType . amBullet . buTrajectory .~ BezierTrajectory 0 0 0 - INCENDLAS -> itParams . lasBeam .~ BeamCombine FlameBeamCombine - SPLITLAS -> itParams . lasBeam .~ BeamCombine SplitBeamCombine - STATICLAS -> (itParams . lasBeam .~ BeamCombine TeslaBeamCombine) - . (itParams . subParams ?~ teslaParams) - WEPTELE -> makeDirectedTele - LAUNCHHOME -> itUse . heldConsumption . laAmmoType . amPjCreation .~ CreateTrackingShell + DRUMMAG -> itUse . heldConsumption . laMax .~ 45 + BELTMAG -> itUse . heldConsumption . laMax .~ 150 + MAGNETMAG -> itUse . heldDelay . rateMax .~ 4 + INCENDBUL -> itUse . heldConsumption . laAmmoType . amBullet . buSpawn .~ BulBall IncBall + BOUNCEBUL -> itUse . heldConsumption . laAmmoType . amBullet . buEffect .~ BounceBullet + PENBUL -> itUse . heldConsumption . laAmmoType . amBullet . buEffect .~ PenetrateBullet + STATICBUL -> itUse . heldConsumption . laAmmoType . amBullet . buSpawn .~ BulBall TeslaBall + CONCUSBUL -> itUse . heldConsumption . laAmmoType . amBullet . buSpawn .~ BulBall ConcBall + TARGCR -> itTargeting .~ targetRBCreature + TARGLAS -> itTargeting .~ targetLaser + TARGPOS -> itTargeting .~ targetRBPress + MAGNETTRAJ -> + (itUse . heldConsumption . laAmmoType . amBullet . buTrajectory .~ MagnetTrajectory 0) + . (itUse . heldConsumption . laAmmoType . amBullet . buVel .~ V2 10 0) + FLECHETRAJ -> itUse . heldConsumption . laAmmoType . amBullet . buTrajectory .~ FlechetteTrajectory 0 + BEZIERTRAJ -> itUse . heldConsumption . laAmmoType . amBullet . buTrajectory .~ BezierTrajectory 0 0 0 + INCENDLAS -> itParams . lasBeam .~ BeamCombine FlameBeamCombine + SPLITLAS -> itParams . lasBeam .~ BeamCombine SplitBeamCombine + STATICLAS -> + (itParams . lasBeam .~ BeamCombine TeslaBeamCombine) + . (itParams . subParams ?~ teslaParams) + WEPTELE -> makeDirectedTele + LAUNCHHOME -> itUse . heldConsumption . laAmmoType . amPjCreation .~ CreateTrackingShell EXTRABATTERY -> itUse . heldConsumption . laMax +~ 1000 - ATTACHTORCH -> id + ATTACHTORCH -> id where - makeDirectedTele it = it - & itTargeting .~ targetRBPress - & itUse . useMods %~ ModWithDirectedTeleport -- .:~ withPosDirWallCheck directedTelPos --- for the camera: the simplest option is to remove all zoom/offset - & itUse . useAim . aimZoom . itZoomFac .~ 1 - & itUse . useAim . aimRange .~ 0 + makeDirectedTele it = + it + & itTargeting .~ targetRBPress + & itUse . heldMods %~ ModWithDirectedTeleport -- .:~ withPosDirWallCheck directedTelPos + -- for the camera: the simplest option is to remove all zoom/offset + & itUse . heldAim . aimZoom . itZoomFac .~ 1 + & itUse . heldAim . aimRange .~ 0 + -- a better option would be to involve a "scope" centered on the firing -- position -- directedTelPos it cr w = (p,a) diff --git a/src/Dodge/Combine/Trie.hs b/src/Dodge/Combine/Trie.hs index 55b996131..88fe5b624 100644 --- a/src/Dodge/Combine/Trie.hs +++ b/src/Dodge/Combine/Trie.hs @@ -1,19 +1,16 @@ module Dodge.Combine.Trie where -import Dodge.Combine.Combinations -import Dodge.Data ---import Dodge.Combine.Module ---import Dodge.Combine.Data ---import Multiset -import SimpleTrie import Data.Bifunctor ---import qualified Data.IntSet as IS ---import Data.Map.Merge.Strict import Data.List (sort) +import Dodge.Combine.Combinations +import Dodge.Data.Item +import SimpleTrie +import Data.Foldable -combinationsTrie :: Trie (ItAmount,ItemBaseType) Item +combinationsTrie :: Trie (ItAmount, ItemBaseType) Item {-# INLINE combinationsTrie #-} -combinationsTrie = foldr - (uncurry insertInTrie . first sort) - emptyTrie - itemCombinations +combinationsTrie = + foldl' + (flip $ uncurry insertInTrie . first sort) + emptyTrie + itemCombinations diff --git a/src/Dodge/Config/KeyConfig.hs b/src/Dodge/Config/KeyConfig.hs deleted file mode 100644 index 6687c1df3..000000000 --- a/src/Dodge/Config/KeyConfig.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} ---{-# LANGUAGE OverloadedStrings #-} -module Dodge.Config.KeyConfig - ( KeyConfigSDL (..) - , defaultKeyConfigSDL - , loadKeyConfig - ) - where ---import Data.Aeson ---import Foreign.C.Types -import GHC.Generics ---import qualified GHC.Int -import qualified SDL ---import qualified SDL.Internal.Numbered ---import System.Directory - -data KeyConfigSDL = KeyConfigSDL - { moveUpKey :: SDL.Scancode - , moveDownKey :: SDL.Scancode - , moveLeftKey :: SDL.Scancode - , moveRightKey :: SDL.Scancode - , pauseKey :: SDL.Scancode - , escapeKey :: SDL.Scancode - , dropItemKey :: SDL.Scancode - , toggleMapKey :: SDL.Scancode - , reloadKey :: SDL.Scancode - , testEventKey :: SDL.Scancode - , spaceActionKey :: SDL.Scancode - , rotateCameraPlusKey :: SDL.Scancode - , rotateCameraMinusKey :: SDL.Scancode - , zoomInKey :: SDL.Scancode - , zoomOutKey :: SDL.Scancode - , newMapKey :: SDL.Scancode - , modifierKey :: SDL.Scancode - } - deriving (Generic, Show) - -defaultKeyConfigSDL :: KeyConfigSDL -defaultKeyConfigSDL = - KeyConfigSDL - { moveUpKey = SDL.ScancodeW - , moveDownKey = SDL.ScancodeS - , moveLeftKey = SDL.ScancodeA - , moveRightKey = SDL.ScancodeD - , pauseKey = SDL.ScancodeP - , escapeKey = SDL.ScancodeEscape - , dropItemKey = SDL.ScancodeF - , toggleMapKey = SDL.ScancodeM - , reloadKey = SDL.ScancodeR - , testEventKey = SDL.ScancodeT - , spaceActionKey = SDL.ScancodeSpace - , rotateCameraPlusKey = SDL.ScancodeQ - , rotateCameraMinusKey = SDL.ScancodeE - , zoomInKey = SDL.ScancodeJ - , zoomOutKey = SDL.ScancodeK - , newMapKey = SDL.ScancodeN - , modifierKey = SDL.ScancodeCapsLock - } - -loadKeyConfig :: IO KeyConfigSDL -loadKeyConfig = return defaultKeyConfigSDL diff --git a/src/Dodge/CrGroupUpdate.hs b/src/Dodge/CrGroupUpdate.hs index 67ed6e4b0..7610c40d6 100644 --- a/src/Dodge/CrGroupUpdate.hs +++ b/src/Dodge/CrGroupUpdate.hs @@ -1,6 +1,6 @@ module Dodge.CrGroupUpdate where -import Dodge.Data +import Dodge.Data.World doCrGroupUpdate :: CrGroupUpdate -> World -> CrGroupParams -> Maybe CrGroupParams doCrGroupUpdate cgu = case cgu of diff --git a/src/Dodge/Creature.hs b/src/Dodge/Creature.hs index 6d9c9a2b7..fd7f95a58 100644 --- a/src/Dodge/Creature.hs +++ b/src/Dodge/Creature.hs @@ -8,18 +8,42 @@ module Dodge.Creature ( spreadGunCrit, autoCrit, armourChaseCrit, + module Dodge.Creature.Action, + module Dodge.Creature.Boid, + module Dodge.Creature.ChainUpdates, + module Dodge.Creature.Impulse, + module Dodge.Creature.Perception, + module Dodge.Creature.ReaderUpdate, + module Dodge.Creature.SentinelAI, + module Dodge.Creature.State, + module Dodge.Creature.Strategy, + module Dodge.Creature.Test, + module Dodge.Creature.Volition, + module Dodge.Creature.YourControl, ) where import Control.Lens +import Dodge.Creature.Action import Dodge.Creature.ArmourChase import Dodge.Creature.AutoCrit +import Dodge.Creature.Boid +import Dodge.Creature.ChainUpdates import Dodge.Creature.ChaseCrit +import Dodge.Creature.Impulse import Dodge.Creature.Inanimate import Dodge.Creature.LauncherCrit import Dodge.Creature.LtAutoCrit +import Dodge.Creature.Perception import Dodge.Creature.PistolCrit +import Dodge.Creature.ReaderUpdate +import Dodge.Creature.SentinelAI import Dodge.Creature.SpreadGunCrit -import Dodge.Data +import Dodge.Creature.State +import Dodge.Creature.Strategy +import Dodge.Creature.Test +import Dodge.Creature.Volition +import Dodge.Creature.YourControl +import Dodge.Data.Creature import Dodge.Default import Dodge.Item import Geometry.Data @@ -43,8 +67,8 @@ miniGunCrit = longCrit :: Creature longCrit = defaultCreature - & crActionPlan .~ - ActionPlan + & crActionPlan + .~ ActionPlan { _apImpulse = [] , _apAction = [] , _apStrategy = StrategyActions WatchAndWait [StartSentinelPost] diff --git a/src/Dodge/Creature.hs.orig b/src/Dodge/Creature.hs.orig index 01bf918aa..faa64db2e 100644 --- a/src/Dodge/Creature.hs.orig +++ b/src/Dodge/Creature.hs.orig @@ -4,7 +4,7 @@ module Dodge.Creature ) where -- imports {{{ -import Dodge.Data +import Dodge.Data.Creature import Dodge.AIs import Dodge.CreatureState import Dodge.Default diff --git a/src/Dodge/Creature/Action.hs b/src/Dodge/Creature/Action.hs index 3e5b8f304..0dfd89717 100644 --- a/src/Dodge/Creature/Action.hs +++ b/src/Dodge/Creature/Action.hs @@ -17,12 +17,13 @@ module Dodge.Creature.Action ( pickUpItem, pickUpItemID, ) where + import Data.Bifunctor import Data.List (findIndex) import Data.Maybe import Dodge.Base import Dodge.CreatureEffect -import Dodge.Data +import Dodge.Data.World import Dodge.Default import Dodge.FloatFunction import Dodge.FloorItem diff --git a/src/Dodge/Creature/ArmourChase.hs b/src/Dodge/Creature/ArmourChase.hs index c88dd55e5..4371a43df 100644 --- a/src/Dodge/Creature/ArmourChase.hs +++ b/src/Dodge/Creature/ArmourChase.hs @@ -1,45 +1,51 @@ -module Dodge.Creature.ArmourChase - ( armourChaseCrit - , flockArmourChaseCrit - ) where -import Dodge.Data +module Dodge.Creature.ArmourChase ( + armourChaseCrit, + flockArmourChaseCrit, +) where + +import Control.Lens +import Dodge.Creature.ChaseCrit +import Dodge.Data.Creature import Dodge.Data.FloatFunction import Dodge.Default -import Dodge.Creature.ChaseCrit -import Dodge.Item.Equipment import Dodge.Item.Consumable - +import Dodge.Item.Equipment import qualified IntMapHelp as IM -import Control.Lens flockArmourChaseCrit :: Creature -flockArmourChaseCrit = defaultCreature - { _crName = "armourChaseCrit" - , _crHP = 300 - , _crInv = IM.fromList - [(0,frontArmour) - ,(1,medkit 200) - ] - , _crActionPlan = ActionPlan - {_apImpulse = [] - ,_apAction = [] - ,_apStrategy = FollowImpulses - ,_apGoal = [Kill 0] +flockArmourChaseCrit = + defaultCreature + { _crName = "armourChaseCrit" + , _crHP = 300 + , _crInv = + IM.fromList + [ (0, frontArmour) + , (1, medkit 200) + ] + , _crActionPlan = + ActionPlan + { _apImpulse = [] + , _apAction = [] + , _apStrategy = FollowImpulses + , _apGoal = [Kill 0] + } + , _crMeleeCooldown = 0 + , _crGroup = ShieldGroup + , _crMvType = defaultChaseMvType } - , _crMeleeCooldown = 0 - , _crGroup = ShieldGroup - , _crMvType = defaultChaseMvType - } - & crType . humanoidAI .~ FlockArmourChaseAI + & crType . humanoidAI .~ FlockArmourChaseAI + armourChaseCrit :: Creature -armourChaseCrit = chaseCrit - { _crName = "armourChaseCrit" - --, _crUpdate = defaultImpulsive [] - , _crInv = IM.fromList - [(0,frontArmour) - ,(1,medkit 200) - ] - , _crMvType = defaultChaseMvType {_mvTurnRad = FloatConst 0.05} - } - & crEquipment . at OnChest ?~ 0 - & crInvEquipped . at 0 ?~ OnChest +armourChaseCrit = + chaseCrit + { _crName = "armourChaseCrit" + , --, _crUpdate = defaultImpulsive [] + _crInv = + IM.fromList + [ (0, frontArmour) + , (1, medkit 200) + ] + , _crMvType = defaultChaseMvType{_mvTurnRad = FloatConst 0.05} + } + & crEquipment . at OnChest ?~ 0 + & crInvEquipped . at 0 ?~ OnChest diff --git a/src/Dodge/Creature/AutoCrit.hs b/src/Dodge/Creature/AutoCrit.hs index 45567530d..a1a40aa85 100644 --- a/src/Dodge/Creature/AutoCrit.hs +++ b/src/Dodge/Creature/AutoCrit.hs @@ -1,21 +1,22 @@ -module Dodge.Creature.AutoCrit - ( autoCrit - ) where -import Dodge.Data +module Dodge.Creature.AutoCrit ( + autoCrit, +) where + +import Dodge.Item.Held.Cane +import Control.Lens +import Dodge.Data.Creature import Dodge.Default -import Dodge.Item.Weapon.BulletGuns import Dodge.Item.Consumable +import qualified IntMapHelp as IM import Picture -import qualified IntMapHelp as IM -import Control.Lens - autoCrit :: Creature -autoCrit = defaultCreature - { _crInv = IM.fromList [(0,autoRifle),(1,medkit 100)] - , _crRad = 10 - , _crHP = 300 - , _crMvType = defaultAimMvType - } - & crType . skinUpper .~ light4 red - & crType . humanoidAI .~ AutoAI +autoCrit = + defaultCreature + { _crInv = IM.fromList [(0, autoRifle), (1, medkit 100)] + , _crRad = 10 + , _crHP = 300 + , _crMvType = defaultAimMvType + } + & crType . skinUpper .~ light4 red + & crType . humanoidAI .~ AutoAI diff --git a/src/Dodge/Creature/Boid.hs b/src/Dodge/Creature/Boid.hs index d0aafc863..9661f5e54 100644 --- a/src/Dodge/Creature/Boid.hs +++ b/src/Dodge/Creature/Boid.hs @@ -1,50 +1,50 @@ -module Dodge.Creature.Boid - where -import Dodge.Data -import Dodge.Base -import Geometry ---import Geometry.ConvexPoly +module Dodge.Creature.Boid where -import Control.Monad.Reader import Control.Lens +import Control.Monad.Reader +import Dodge.Base +import Dodge.Data.World +import Geometry import qualified IntMapHelp as IM interpWith :: Float -> Point2 -> Point2 -> Point2 interpWith x a b = x *.* a +.+ (1 - x) *.* b invertEncircleDistP :: Float -> Creature -> Point2 -> Creature -> Point2 -invertEncircleDistP d tcr cenp cr = ypos +.+ - d *.* reflectIn (cenp -.- ypos) (squashNormalizeV (cpos -.- cenp)) - where +invertEncircleDistP d tcr cenp cr = + ypos + +.+ d *.* reflectIn (cenp -.- ypos) (squashNormalizeV (cpos -.- cenp)) + where cpos = _crPos cr ypos = _crPos tcr encircleDistP :: Float -> Creature -> Point2 -> Creature -> Point2 encircleDistP d tcr cenp cr = ypos +.+ d *.* squashNormalizeV (cpos -.- cenp) - where + where cpos = _crPos cr ypos = _crPos tcr encircleP :: Creature -> Point2 -> Creature -> Point2 encircleP tcr cenp cr = ypos +.+ 50 *.* squashNormalizeV (cpos -.- cenp) - where + where cpos = _crPos cr ypos = _crPos tcr - --f x = 150 * sigmoid (x-10) + +--f x = 150 * sigmoid (x-10) encircleCloseP :: Creature -> Point2 -> Creature -> Point2 -encircleCloseP tcr cenp cr = ypos +.+ f (max 0 (magV (ypos -.- cenp) - 80) ) *.* squashNormalizeV (cpos -.- cenp) - where +encircleCloseP tcr cenp cr = ypos +.+ f (max 0 (magV (ypos -.- cenp) - 80)) *.* squashNormalizeV (cpos -.- cenp) + where cpos = _crPos cr ypos = _crPos tcr - f x = 150 * sigmoid (x-10) + f x = 150 * sigmoid (x -10) -forbidFlee - :: (Creature -> Point2 -> Creature -> Point2) - -> Creature - -> Point2 - -> Creature - -> Point2 +forbidFlee :: + (Creature -> Point2 -> Creature -> Point2) -> + Creature -> + Point2 -> + Creature -> + Point2 forbidFlee f tcr cenp cr | ptargTest = tpos | otherwise = ptarg @@ -52,83 +52,85 @@ forbidFlee f tcr cenp cr cpos = _crPos cr tpos = _crPos tcr ptarg = f tcr cenp cr - ptargTest = isLHS cpos (cpos +.+ rotateV (negate (pi/2)) (cpos -.- tpos)) ptarg - -- && isRHS cpos (cpos +.+ rotateV (pi/3) (cpos -.- tpos)) ptarg - --targBehindCrit = isLHS cpos (vNormal $ cpos +.+ unitVectorAtAngle (_crDir cr)) ptarg + ptargTest = isLHS cpos (cpos +.+ rotateV (negate (pi / 2)) (cpos -.- tpos)) ptarg + +-- && isRHS cpos (cpos +.+ rotateV (pi/3) (cpos -.- tpos)) ptarg +--targBehindCrit = isLHS cpos (vNormal $ cpos +.+ unitVectorAtAngle (_crDir cr)) ptarg pincerP :: Creature -> Point2 -> Creature -> Point2 pincerP tcr cenp cr = tpos +.+ splitp -- +.+ 25 *.* (normalizeV $ tpos -.- cenp) - where + where cpos = _crPos cr tpos = _crPos tcr - splitp - | isLHS cenp cpos tpos - = 150 *.* orthCenpTpos - | otherwise - = negate 150 *.* orthCenpTpos + splitp + | isLHS cenp cpos tpos = + 150 *.* orthCenpTpos + | otherwise = + negate 150 *.* orthCenpTpos --d = min 150 (dist cpos tpos) --orthCenpTpos = safeNormalizeV (vNormal $ tpos -.- cpos) orthCenpTpos = squashNormalizeV (vNormal $ tpos -.- cenp) pincerP''' :: Creature -> Point2 -> Creature -> Point2 pincerP''' tcr cenp cr = interpWith (sigmoid $ 0.05 * dtcen) cenawayp cenclosep - where + where cpos = _crPos cr tpos = _crPos tcr dtcen = dist tpos cenp - f x = 150 * sigmoid (x-10) - cenawayp + f x = 150 * sigmoid (x -10) + cenawayp | dist cenp tpos < dist cpos tpos = tpos +.+ splitp | otherwise = cenp +.+ splitp - splitp - | isLHS cenp cpos tpos - = f (max 0 (magV (tpos -.- cenp) - 80) ) *.* orthCenpTpos - | otherwise - = negate ( f $ max 0 $ magV (tpos -.- cenp) - 80) *.* orthCenpTpos + splitp + | isLHS cenp cpos tpos = + f (max 0 (magV (tpos -.- cenp) - 80)) *.* orthCenpTpos + | otherwise = + negate (f $ max 0 $ magV (tpos -.- cenp) - 80) *.* orthCenpTpos orthCenpTpos = squashNormalizeV (vNormal $ tpos -.- cenp) - cenclosep - = tpos +.+ f (max 0 (magV (tpos -.- cenp) - 80) ) *.* squashNormalizeV (cpos -.- cenp) + cenclosep = + tpos +.+ f (max 0 (magV (tpos -.- cenp) - 80)) *.* squashNormalizeV (cpos -.- cenp) pincerP' :: Creature -> Point2 -> Creature -> Point2 -pincerP' tcr cenp cr - | dist cenp tpos > dist cpos tpos - = cenp +.+ f (max 0 (magV (tpos -.- cenp) - 80) ) *.* squashNormalizeV (cpos -.- cenp) - | otherwise = tpos +.+ f (max 0 (magV (tpos -.- cenp) - 80) ) *.* squashNormalizeV (cpos -.- cenp) - where +pincerP' tcr cenp cr + | dist cenp tpos > dist cpos tpos = + cenp +.+ f (max 0 (magV (tpos -.- cenp) - 80)) *.* squashNormalizeV (cpos -.- cenp) + | otherwise = tpos +.+ f (max 0 (magV (tpos -.- cenp) - 80)) *.* squashNormalizeV (cpos -.- cenp) + where cpos = _crPos cr tpos = _crPos tcr - f x = 150 * sigmoid (x-10) + f x = 150 * sigmoid (x -10) pincerP'' :: Creature -> Point2 -> Creature -> Point2 -pincerP'' tcr cenp cr - | dist cenp tpos > dist cpos tpos && isLHS cenp cpos tpos - = cenp +.+ f (max 0 (magV (tpos -.- cenp) - 80) ) *.* squashNormalizeV (vNormal $ tpos -.- cenp) - | dist cenp tpos > dist cpos tpos - = cenp +.+ f (max 0 (magV (tpos -.- cenp) - 80) ) *.* squashNormalizeV (vNormal $ cenp -.- tpos) - | otherwise = tpos +.+ f (max 0 (magV (tpos -.- cenp) - 80) ) *.* squashNormalizeV (cpos -.- cenp) - where +pincerP'' tcr cenp cr + | dist cenp tpos > dist cpos tpos && isLHS cenp cpos tpos = + cenp +.+ f (max 0 (magV (tpos -.- cenp) - 80)) *.* squashNormalizeV (vNormal $ tpos -.- cenp) + | dist cenp tpos > dist cpos tpos = + cenp +.+ f (max 0 (magV (tpos -.- cenp) - 80)) *.* squashNormalizeV (vNormal $ cenp -.- tpos) + | otherwise = tpos +.+ f (max 0 (magV (tpos -.- cenp) - 80)) *.* squashNormalizeV (cpos -.- cenp) + where cpos = _crPos cr tpos = _crPos tcr - f x = 150 * sigmoid (x-10) + f x = 150 * sigmoid (x -10) encircle :: Creature -> IM.IntMap Creature -> Creature -> Point2 -encircle tcr crs cr +encircle tcr crs cr | length crs <= 1 = ypos - | otherwise = ypos +.+ f (max 0 (magV (ypos -.- cenp) - 80) ) *.* squashNormalizeV (cpos -.- cenp) - where + | otherwise = ypos +.+ f (max 0 (magV (ypos -.- cenp) - 80)) *.* squashNormalizeV (cpos -.- cenp) + where cpos = _crPos cr ypos = _crPos tcr - f x = 150 * sigmoid (x-10) + f x = 150 * sigmoid (x -10) cenp = centroid (map _crPos $ IM.elems crs) lineOrth :: Creature -> IM.IntMap Creature -> Creature -> Point2 lineOrth tcr crs cr = p - where + where ypos = _crPos tcr cpos = _crPos cr - ps = map _crPos $ IM.elems crs + ps = map _crPos $ IM.elems crs cen = (1 / fromIntegral (length ps)) *.* foldr1 (+.+) ps - p | dist cen ypos < 20 = ypos + p + | dist cen ypos < 20 = ypos | otherwise = errorClosestPointOnLine 500 ypos (ypos +.+ vNormal (cen -.- ypos)) cpos holdForm :: Creature -> IM.IntMap Creature -> Creature -> Point2 @@ -136,9 +138,10 @@ holdForm ycr crs cr = p where ypos = _crPos ycr cpos = _crPos cr - ps = map _crPos $ IM.elems crs + ps = map _crPos $ IM.elems crs cen = (1 / fromIntegral (length ps)) *.* foldr1 (+.+) ps - p | dist cen ypos < 20 = ypos + p + | dist cen ypos < 20 = ypos | otherwise = ypos +.+ cpos -.- cen lineUp :: Creature -> IM.IntMap Creature -> Creature -> Point2 @@ -146,7 +149,7 @@ lineUp ycr crs cr = p where ypos = _crPos ycr cpos = _crPos cr - ps = map _crPos $ IM.elems crs + ps = map _crPos $ IM.elems crs cen = (1 / fromIntegral (length ps)) *.* foldr1 (+.+) ps p = (0.05 *.* ypos) +.+ (0.95 *.* errorClosestPointOnLine 500 cen ypos cpos) @@ -156,20 +159,21 @@ spreadOut ycr crs cr = p where ypos = _crPos ycr cpos = _crPos cr - ps = map _crPos $ IM.elems crs + ps = map _crPos $ IM.elems crs cen = (1 / fromIntegral (length ps)) *.* foldr1 (+.+) ps - p | dist cen ypos < 30 = ypos + p + | dist cen ypos < 30 = ypos | otherwise = ypos +.+ (spreadFactor *.* cpos -.- cen) - spreadFactor + spreadFactor | dist ypos cpos > 90 = 1 | otherwise = 1.5 -swarmUsingCenter - :: (Creature -> Point2 -> Creature -> Creature) - -> (Point2 -> Creature -> Creature) - -> World - -> Creature - -> Creature +swarmUsingCenter :: + (Creature -> Point2 -> Creature -> Creature) -> + (Point2 -> Creature -> Creature) -> + World -> + Creature -> + Creature swarmUsingCenter updT upd w cr = case _targetCr $ _crIntention cr of Nothing -> upd cenp cr Just tcr -> updT tcr cenp cr @@ -177,12 +181,14 @@ swarmUsingCenter updT upd w cr = case _targetCr $ _crIntention cr of cid = _crID cr cenp = _crGroupCenter $ _creatureGroups (_cWorld w) IM.! _crGroupID (_crGroup $ _creatures (_cWorld w) IM.! cid) -flockChaseTarget - :: (Creature -> IM.IntMap Creature -> Creature -> Creature) -- ^ Update with target - -> (IM.IntMap Creature -> Creature -> Creature) -- ^ Update without target - -> World - -> Creature - -> Creature +flockChaseTarget :: + -- | Update with target + (Creature -> IM.IntMap Creature -> Creature -> Creature) -> + -- | Update without target + (IM.IntMap Creature -> Creature -> Creature) -> + World -> + Creature -> + Creature flockChaseTarget updT upd w cr = case _targetCr $ _crIntention cr of Nothing -> upd crs cr Just tcr -> updT tcr crs cr @@ -190,12 +196,13 @@ flockChaseTarget updT upd w cr = case _targetCr $ _crIntention cr of is = _swarm $ _crGroup cr crs = IM.restrictKeys (_creatures (_cWorld w)) is -flockPointTarget - :: (Creature -> IM.IntMap Creature -> Creature -> Point2) - -> (Creature -> World -> Maybe Creature) -- ^ Function for determining target - -> World - -> Creature - -> Creature +flockPointTarget :: + (Creature -> IM.IntMap Creature -> Creature -> Point2) -> + -- | Function for determining target + (Creature -> World -> Maybe Creature) -> + World -> + Creature -> + Creature flockPointTarget f targFunc w cr = case targFunc cr w of Nothing -> cr Just crTarg -> cr & crActionPlan . apImpulse .~ mvPointMeleeTarg p cr crTarg @@ -204,23 +211,24 @@ flockPointTarget f targFunc w cr = case targFunc cr w of crs = IM.restrictKeys (_creatures (_cWorld w)) is p = f crTarg crs cr -flockToPointUsing - :: (Creature -> Point2 -> Creature -> Point2) - -> (Point2 -> Creature -> Creature -> [Impulse]) - -> Creature - -> Reader World Creature +flockToPointUsing :: + (Creature -> Point2 -> Creature -> Point2) -> + (Point2 -> Creature -> Creature -> [Impulse]) -> + Creature -> + Reader World Creature flockToPointUsing pf mvf cr = reader $ \w -> case _targetCr $ _crIntention cr of Nothing -> cr Just tcr -> cr & crActionPlan . apImpulse .~ mvf ptarg cr tcr where cenp = _crGroupCenter $ _creatureGroups (_cWorld w) IM.! _crGroupID (_crGroup cr) ptarg = pf tcr cenp cr -flockToPointUsing' - :: (Creature -> Point2 -> Creature -> Point2) - -> (Point2 -> Creature -> Creature -> [Impulse]) - -> World - -> Creature - -> Creature + +flockToPointUsing' :: + (Creature -> Point2 -> Creature -> Point2) -> + (Point2 -> Creature -> Creature -> [Impulse]) -> + World -> + Creature -> + Creature flockToPointUsing' pf mvf w cr = case _targetCr $ _crIntention cr of Nothing -> cr Just tcr -> cr & crActionPlan . apImpulse .~ mvf ptarg cr tcr @@ -228,11 +236,12 @@ flockToPointUsing' pf mvf w cr = case _targetCr $ _crIntention cr of cenp = _crGroupCenter $ _creatureGroups (_cWorld w) IM.! _crGroupID (_crGroup cr) ptarg = pf tcr cenp cr -flockFunc - :: (Creature -> Point2 -> Creature -> Point2) - -> (Creature -> World -> Maybe Creature) -- ^ Function for determining target - -> Creature - -> Reader World Creature +flockFunc :: + (Creature -> Point2 -> Creature -> Point2) -> + -- | Function for determining target + (Creature -> World -> Maybe Creature) -> + Creature -> + Reader World Creature flockFunc f targFunc cr = reader $ \w -> case targFunc cr w of Nothing -> cr Just crTarg -> cr & crActionPlan . apImpulse .~ mvPointMeleeTarg p cr crTarg @@ -240,11 +249,12 @@ flockFunc f targFunc cr = reader $ \w -> case targFunc cr w of cenp = _crGroupCenter $ _creatureGroups (_cWorld w) IM.! _crGroupID (_crGroup cr) p = f crTarg cenp cr -flockCenterFunc - :: (Creature -> Point2 -> Creature -> Point2) - -> (Creature -> World -> Maybe Creature) -- ^ Function for determining target - -> Creature - -> Reader World Creature +flockCenterFunc :: + (Creature -> Point2 -> Creature -> Point2) -> + -- | Function for determining target + (Creature -> World -> Maybe Creature) -> + Creature -> + Reader World Creature flockCenterFunc f targFunc cr = reader $ \w -> case targFunc cr w of Nothing -> cr Just crTarg -> cr & crActionPlan . apImpulse .~ mvPointMeleeTarg p cr crTarg @@ -252,11 +262,12 @@ flockCenterFunc f targFunc cr = reader $ \w -> case targFunc cr w of cenp = _crGroupCenter $ _creatureGroups (_cWorld w) IM.! _crGroupID (_crGroup cr) p = f crTarg cenp cr -flockPointTargetR - :: (Creature -> IM.IntMap Creature -> Creature -> Point2) - -> (Creature -> World -> Maybe Creature) -- ^ Function for determining target - -> Creature - -> Reader World Creature +flockPointTargetR :: + (Creature -> IM.IntMap Creature -> Creature -> Point2) -> + -- | Function for determining target + (Creature -> World -> Maybe Creature) -> + Creature -> + Reader World Creature flockPointTargetR f targFunc cr = reader $ \w -> case targFunc cr w of Nothing -> cr Just crTarg -> cr & crActionPlan . apImpulse .~ mvPointMeleeTarg p cr crTarg @@ -265,44 +276,50 @@ flockPointTargetR f targFunc cr = reader $ \w -> case targFunc cr w of crs = IM.restrictKeys (_creatures (_cWorld w)) is p = f crTarg crs cr -meleeHeadingMove - :: Float -- ^ max turn speed - -> Float -- ^ min turn speed - -> Float -- ^ turn speed cutoff angle - -> Float -- ^ move speed - -> Point2 -- ^ target point - -> Creature -- ^ start creature - -> Creature -- ^ target creature - -> [Impulse] +meleeHeadingMove :: + -- | max turn speed + Float -> + -- | min turn speed + Float -> + -- | turn speed cutoff angle + Float -> + -- | move speed + Float -> + -- | target point + Point2 -> + -- | start creature + Creature -> + -- | target creature + Creature -> + [Impulse] meleeHeadingMove maxta minta tacutoff speed tp cr tcr - | dist tpos cpos < combinedRad + 5 - && abs (_crDir cr - argV (tpos -.- cpos)) < tacutoff - && _crMeleeCooldown cr == 0 - = [Melee (_crID tcr), Turn pi] - | dist tpos cpos < combinedRad + 5 - && abs (_crDir cr - argV (tpos -.- cpos)) < tacutoff - = [ TurnToward tpos minta ] - | abs (_crDir cr - argV (tp -.- cpos)) < tacutoff - = [MoveForward speed , TurnToward tp maxta , RandomTurn maxta ] - | otherwise = [MoveForward speed , TurnToward tp minta, RandomTurn maxta ] + | dist tpos cpos < combinedRad + 5 + && abs (_crDir cr - argV (tpos -.- cpos)) < tacutoff + && _crMeleeCooldown cr == 0 = + [Melee (_crID tcr), Turn pi] + | dist tpos cpos < combinedRad + 5 + && abs (_crDir cr - argV (tpos -.- cpos)) < tacutoff = + [TurnToward tpos minta] + | abs (_crDir cr - argV (tp -.- cpos)) < tacutoff = + [MoveForward speed, TurnToward tp maxta, RandomTurn maxta] + | otherwise = [MoveForward speed, TurnToward tp minta, RandomTurn maxta] where cpos = _crPos cr tpos = _crPos tcr combinedRad = _crRad cr + _crRad tcr - mvPointMeleeTarg :: Point2 -> Creature -> Creature -> [Impulse] mvPointMeleeTarg p cr crT - | dist tpos cpos < combinedRad + 5 - && abs (_crDir cr - argV (tpos -.- cpos)) < pi/4 - && _crMeleeCooldown cr == 0 - = [Melee (_crID crT)] - | dist tpos cpos < combinedRad + 5 - && abs (_crDir cr - argV (tpos -.- cpos)) < pi/4 - = [ TurnToward tpos 0.05 ] - | abs (_crDir cr - argV (p -.- cpos)) < pi/4 - = [MoveForward 3 , TurnToward p 0.2 , RandomTurn 0.2 ] - | otherwise = [MoveForward 3 , TurnToward p 0.05, RandomTurn 0.2 ] + | dist tpos cpos < combinedRad + 5 + && abs (_crDir cr - argV (tpos -.- cpos)) < pi / 4 + && _crMeleeCooldown cr == 0 = + [Melee (_crID crT)] + | dist tpos cpos < combinedRad + 5 + && abs (_crDir cr - argV (tpos -.- cpos)) < pi / 4 = + [TurnToward tpos 0.05] + | abs (_crDir cr - argV (p -.- cpos)) < pi / 4 = + [MoveForward 3, TurnToward p 0.2, RandomTurn 0.2] + | otherwise = [MoveForward 3, TurnToward p 0.05, RandomTurn 0.2] where cpos = _crPos cr tpos = _crPos crT diff --git a/src/Dodge/Creature/ChainUpdates.hs b/src/Dodge/Creature/ChainUpdates.hs index 2ac9d595b..8e487ade5 100644 --- a/src/Dodge/Creature/ChainUpdates.hs +++ b/src/Dodge/Creature/ChainUpdates.hs @@ -1,11 +1,13 @@ module Dodge.Creature.ChainUpdates where -import Dodge.Data import Data.Foldable +import Dodge.Data.World -chainCreatureUpdates - :: [World -> Creature -> Creature] - -> World -> Creature -> Creature +chainCreatureUpdates :: + [World -> Creature -> Creature] -> + World -> + Creature -> + Creature chainCreatureUpdates ls w cr = foldl' unf cr ls where unf cr' g = g w cr' diff --git a/src/Dodge/Creature/ChaseCrit.hs b/src/Dodge/Creature/ChaseCrit.hs index 5d75423b8..6afc107a9 100644 --- a/src/Dodge/Creature/ChaseCrit.hs +++ b/src/Dodge/Creature/ChaseCrit.hs @@ -1,49 +1,57 @@ -module Dodge.Creature.ChaseCrit - (smallChaseCrit - ,invisibleChaseCrit - ,chaseCrit - ) where -import Dodge.Data +module Dodge.Creature.ChaseCrit ( + smallChaseCrit, + invisibleChaseCrit, + chaseCrit, +) where + +import Control.Lens +import Dodge.Data.Creature import Dodge.Default import Dodge.Item.Consumable import Dodge.Item.Equipment import Dodge.SoundLogic +import qualified IntMapHelp as IM import Picture -import qualified IntMapHelp as IM -import Control.Lens ---import System.Random - smallChaseCrit :: Creature -smallChaseCrit = chaseCrit - { _crHP = 1 - , _crRad = 4 - , _crInv = IM.fromList [(0,medkit 200)] - , _crCorpse = MakeDefaultCorpse - } +smallChaseCrit = + chaseCrit + { _crHP = 1 + , _crRad = 4 + , _crInv = IM.fromList [(0, medkit 200)] + , _crCorpse = MakeDefaultCorpse + } + invisibleChaseCrit :: Creature -invisibleChaseCrit = chaseCrit - & crCamouflage .~ Invisible - & crInv . at 0 ?~ wristInvisibility - & crEquipment . at OnLeftWrist ?~ 0 - & crInvEquipped . at 0 ?~ OnLeftWrist +invisibleChaseCrit = + chaseCrit + & crCamouflage .~ Invisible + & crInv . at 0 ?~ wristInvisibility + & crEquipment . at OnLeftWrist ?~ 0 + & crInvEquipped . at 0 ?~ OnLeftWrist + chaseCrit :: Creature -chaseCrit = defaultCreature - { _crName = "chaseCrit" - , _crHP = 150 - , _crInv = IM.fromList [(0,medkit 200)] - , _crMeleeCooldown = 0 - , _crFaction = ColorFaction green - , _crVocalization = Vocalization seagullChatterS - [seagullBarkS - ,seagullChatterS - ,seagullChatter1S - ,seagullWhistleS - ,seagullWhistle1S - ,seagullCryS - ,seagullCry1S - ,seagullCry2S - ] 50 0 - , _crMvType = defaultChaseMvType - } - & crType . humanoidAI .~ ChaseAI +chaseCrit = + defaultCreature + { _crName = "chaseCrit" + , _crHP = 150 + , _crInv = IM.fromList [(0, medkit 200)] + , _crMeleeCooldown = 0 + , _crFaction = ColorFaction green + , _crVocalization = + Vocalization + seagullChatterS + [ seagullBarkS + , seagullChatterS + , seagullChatter1S + , seagullWhistleS + , seagullWhistle1S + , seagullCryS + , seagullCry1S + , seagullCry2S + ] + 50 + 0 + , _crMvType = defaultChaseMvType + } + & crType . humanoidAI .~ ChaseAI diff --git a/src/Dodge/Creature/ChooseTarget.hs b/src/Dodge/Creature/ChooseTarget.hs index 212f20344..067be5a6c 100644 --- a/src/Dodge/Creature/ChooseTarget.hs +++ b/src/Dodge/Creature/ChooseTarget.hs @@ -1,22 +1,20 @@ -module Dodge.Creature.ChooseTarget - where -import Dodge.Data -import Dodge.Base +module Dodge.Creature.ChooseTarget where import Control.Lens ---import qualified IntMapHelp as IM +import Dodge.Base +import Dodge.Data.World targetYouLOS :: Creature -> World -> Maybe Creature {-# INLINE targetYouLOS #-} -targetYouLOS cr w +targetYouLOS cr w | hasLOS (_crPos cr) (_crPos $ you w) w = Just $ you w | otherwise = Nothing targetYouCognizant :: Creature -> World -> Maybe Creature -targetYouCognizant cr w +targetYouCognizant cr w | hasLOS (_crPos cr) (_crPos $ you w) w - && isCog (cr ^? crPerception . cpAwareness . ix 0) - = Just $ you w + && isCog (cr ^? crPerception . cpAwareness . ix 0) = + Just $ you w | otherwise = Nothing where isCog x = case x of diff --git a/src/Dodge/Creature/Damage.hs b/src/Dodge/Creature/Damage.hs index f7222a580..c686e97ff 100644 --- a/src/Dodge/Creature/Damage.hs +++ b/src/Dodge/Creature/Damage.hs @@ -1,14 +1,13 @@ module Dodge.Creature.Damage where -import Dodge.Data -import Dodge.Creature.Test -import Dodge.Spark ---import Dodge.Bullet + import Color +import Data.List +import Dodge.Creature.Test +import Dodge.Data.World +import Dodge.Spark import Geometry import LensHelp -import Data.List - applyNoDamage :: [Damage] -> Creature -> World -> World applyNoDamage _ _ = id @@ -16,34 +15,39 @@ applyCreatureDamage :: [Damage] -> Creature -> World -> World applyCreatureDamage dms cr = case _crMaterial cr of Flesh -> defaultApplyDamage dms cr Crystal -> id - _-> defaultApplyDamage dms cr + _ -> defaultApplyDamage dms cr defaultApplyDamage :: [Damage] -> Creature -> World -> World -defaultApplyDamage ds cr w = foldl' (applyIndividualDamage cr) w ds' - & cWorld . creatures . ix (_crID cr) %~ doPoisonDam - where - (ps,ds') = partition isPoison ds - isPoison Damage{_dmType=POISONDAM} = True +defaultApplyDamage ds cr w = + foldl' (applyIndividualDamage cr) w ds' + & cWorld . creatures . ix (_crID cr) %~ doPoisonDam + where + (ps, ds') = partition isPoison ds + isPoison Damage{_dmType = POISONDAM} = True isPoison _ = False poisonDam = quot (max 0 (sum (map _dmAmount ps))) 10 doPoisonDam = crHP -~ poisonDam applyDamageEffect :: Damage -> DamageEffect -> Creature -> World -> World applyDamageEffect dm de cr w = case de of - PushDamage push pushexp pushRad -> w - & cWorld . creatures . ix (_crID cr) . crPos .+.+~ pushAmount *.* squashNormalizeV (_crPos cr -.- fromDir) + PushDamage push pushexp pushRad -> + w + & cWorld . creatures . ix (_crID cr) . crPos .+.+~ pushAmount *.* squashNormalizeV (_crPos cr -.- fromDir) where pushAmount | dist (_crPos cr) fromDir == 0 = 0 - | otherwise = min 5 $ (push*5*pushRad / (dist (_crPos cr) fromDir * _crMass cr))**pushexp - PushBackDamage pback -> w - & cWorld . creatures . ix (_crID cr) . crPos .+.+~ (pback/_crMass cr) *.* (_dmTo dm -.- fromDir) - TorqueDamage rot -> w - & cWorld . creatures . ix (_crID cr) . crDir +~ rot + | otherwise = min 5 $ (push * 5 * pushRad / (dist (_crPos cr) fromDir * _crMass cr)) ** pushexp + PushBackDamage pback -> + w + & cWorld . creatures . ix (_crID cr) . crPos .+.+~ (pback / _crMass cr) *.* (_dmTo dm -.- fromDir) + TorqueDamage rot -> + w + & cWorld . creatures . ix (_crID cr) . crDir +~ rot NoDamageEffect -> w where fromDir = _dmFrom dm - --p = _dmAt dm + +--p = _dmAt dm applyIndividualDamage :: Creature -> World -> Damage -> World applyIndividualDamage cr w dm = applyDamageEffect dm (_dmEffect dm) cr $ applyIndividualDamage' cr w dm @@ -62,7 +66,8 @@ applyPiercingDamage cr dm p1 = p +.+ 2 *.* squashNormalizeV (p -.- _crPos cr) damageHP :: Creature -> Int -> World -> World -damageHP cr x = cWorld . creatures . ix (_crID cr) %~ - ( (crHP -~ x) - . (crPastDamage +~ x) - ) +damageHP cr x = + cWorld . creatures . ix (_crID cr) + %~ ( (crHP -~ x) + . (crPastDamage +~ x) + ) diff --git a/src/Dodge/Creature/HandPos.hs b/src/Dodge/Creature/HandPos.hs index f20e2065c..56cf5ac7d 100644 --- a/src/Dodge/Creature/HandPos.hs +++ b/src/Dodge/Creature/HandPos.hs @@ -1,33 +1,36 @@ module Dodge.Creature.HandPos where -import Dodge.Data -import Dodge.Creature.Test ---import Shape -import ShapePicture -import Geometry import Control.Lens import Data.Maybe +import Dodge.Creature.Test +import Dodge.Data.Creature +import Geometry +import ShapePicture -- the position of a weapon handle aimingWeaponHandlePos :: Creature -> Item -> Float -aimingWeaponHandlePos cr it = case it ^? itUse. useAim . aimStance of - Just TwoHandTwist -> -5 - Just OneHand -> 14 - Just TwoHandFlat -> 1.2 * _crRad cr +aimingWeaponHandlePos cr it = case it ^? itUse . heldAim . aimStance of + Just TwoHandTwist -> -5 + Just OneHand -> 14 + Just TwoHandFlat -> 1.2 * _crRad cr Just LeaveHolstered -> 0 - Nothing -> 0 + Nothing -> 0 + aimingWeaponZeroPos :: Creature -> Item -> Float -aimingWeaponZeroPos cr it = aimingWeaponHandlePos cr it - - fromMaybe 0 (it ^? itUse . useAim . aimHandlePos) +aimingWeaponZeroPos cr it = + aimingWeaponHandlePos cr it + - fromMaybe 0 (it ^? itUse . heldAim . aimHandlePos) + aimingMuzzlePos :: Creature -> Item -> Float -aimingMuzzlePos cr it = aimingWeaponZeroPos cr it - + fromMaybe 0 (it ^? itUse . useAim . aimMuzPos) +aimingMuzzlePos cr it = + aimingWeaponZeroPos cr it + + fromMaybe 0 (it ^? itUse . heldAim . aimMuzPos) translatePointToRightHand :: Creature -> Point3 -> Point3 translatePointToRightHand cr = translatePointToRightHand' cr . mirrorV3xz mirrorV3xz :: Point3 -> Point3 -mirrorV3xz (V3 x y z) = V3 x (-y) z +mirrorV3xz (V3 x y z) = V3 x (- y) z translatePointToRightHand' :: Creature -> Point3 -> Point3 translatePointToRightHand' cr @@ -35,8 +38,8 @@ translatePointToRightHand' cr | twists cr = (+.+.+ V3 0 5 20) . rotate3 (-1) . (+.+.+ V3 4 (-10) 0) | twoFlat cr = (+.+.+ V3 4 (-8) 10) | otherwise = case cr ^? crStance . carriage of - Just (Walking sa LeftForward) -> (+.+.+ V3 (-f sa) (-off) 10) - _ -> (+.+.+ V3 0 (-off) 10) + Just (Walking sa LeftForward) -> (+.+.+ V3 (- f sa) (- off) 10) + _ -> (+.+.+ V3 0 (- off) 10) where off = 8 sLen = _strideLength $ _crStance cr @@ -47,12 +50,12 @@ translateToRightHand cr = translateToRightHand' cr . mirrorSPxz translateToRightHand' :: Creature -> SPic -> SPic translateToRightHand' cr - | oneH cr = shoulderSP . translateSPf 11 (-3) . rotateSP (-0.5)-- . scaleSH (V3 1 1.5 1) + | oneH cr = shoulderSP . translateSPf 11 (-3) . rotateSP (-0.5) -- . scaleSH (V3 1 1.5 1) | twists cr = shoulderSP . translateSPf 0 5 . rotateSP (-1) . translateSPf 4 (-10) | twoFlat cr = waistSP . translateSPf 4 (-8) | otherwise = case cr ^? crStance . carriage of - Just (Walking sa LeftForward) -> waistSP . translateSPf (-f sa) (-off) - _ -> waistSP . translateSPf 0 (-off) + Just (Walking sa LeftForward) -> waistSP . translateSPf (- f sa) (- off) + _ -> waistSP . translateSPf 0 (- off) where off = 8 sLen = _strideLength $ _crStance cr @@ -63,12 +66,12 @@ translateToRightWrist cr = translateToRightWrist' cr . mirrorSPxz translateToRightWrist' :: Creature -> SPic -> SPic translateToRightWrist' cr - | oneH cr = shoulderSP . translateSPf 11 (-3) . rotateSP (-0.5) . offTrans-- . scaleSH (V3 1 1.5 1) + | oneH cr = shoulderSP . translateSPf 11 (-3) . rotateSP (-0.5) . offTrans -- . scaleSH (V3 1 1.5 1) | twists cr = shoulderSP . translateSPf 0 5 . rotateSP (-1) . translateSPf 4 (-10) . offTrans | twoFlat cr = waistSP . translateSPf 4 (-8) . offTrans | otherwise = case cr ^? crStance . carriage of - Just (Walking sa LeftForward) -> waistSP . translateSPf (-f sa) (-off) . offTrans - _ -> waistSP . translateSPf 0 (-off) . offTrans + Just (Walking sa LeftForward) -> waistSP . translateSPf (- f sa) (- off) . offTrans + _ -> waistSP . translateSPf 0 (- off) . offTrans where offTrans = translateSP (V3 0 4 (-4)) off = 8 @@ -81,7 +84,7 @@ translatePointToLeftHand cr | twists cr = (+.+.+ V3 0 5 20) . rotate3 (-1) . (+.+.+ V3 12 4 0) . rotate3 0.4 | twoFlat cr = (+.+.+ V3 4 8 10) | otherwise = case cr ^? crStance . carriage of - Just (Walking sa RightForward) -> (+.+.+ V3 (-f sa) off 10) + Just (Walking sa RightForward) -> (+.+.+ V3 (- f sa) off 10) _ -> (+.+.+ V3 0 off 10) where off = 8 @@ -94,7 +97,7 @@ translateToLeftHand cr | twists cr = shoulderSP . translateSPf 0 5 . rotateSP (-1) . translateSPf 12 4 | twoFlat cr = waistSP . translateSPf 4 8 | otherwise = case cr ^? crStance . carriage of - Just (Walking sa RightForward) -> waistSP . translateSPf (-f sa) off + Just (Walking sa RightForward) -> waistSP . translateSPf (- f sa) off _ -> waistSP . translateSPf 0 off where off = 8 @@ -107,7 +110,7 @@ translateToLeftWrist cr | twists cr = shoulderSP . translateSPf 0 5 . rotateSP (-1) . translateSPf 12 4 . offTrans | twoFlat cr = waistSP . translateSPf 4 8 . offTrans | otherwise = case cr ^? crStance . carriage of - Just (Walking sa RightForward) -> waistSP . translateSPf (-f sa) off . offTrans + Just (Walking sa RightForward) -> waistSP . translateSPf (- f sa) off . offTrans _ -> waistSP . translateSPf 0 off . offTrans where offTrans = translateSP (V3 0 4 (-4)) @@ -116,20 +119,22 @@ translateToLeftWrist cr f i = negate 2 + negate 6 * fromIntegral (sLen - i) / fromIntegral sLen translateToLeftLeg :: Creature -> SPic -> SPic -translateToLeftLeg cr = rotateSP (_crMvDir cr - _crDir cr) . case cr ^? crStance . carriage of - Just (Walking sa LeftForward) -> translateSPf ( f sa) off - Just (Walking sa RightForward) -> translateSPf (-f sa) off - _ -> translateSPf 0 off +translateToLeftLeg cr = + rotateSP (_crMvDir cr - _crDir cr) . case cr ^? crStance . carriage of + Just (Walking sa LeftForward) -> translateSPf (f sa) off + Just (Walking sa RightForward) -> translateSPf (- f sa) off + _ -> translateSPf 0 off where off = 5 sLen = _strideLength $ _crStance cr f i = 6 * fromIntegral (sLen - i) / fromIntegral sLen translateToRightLeg :: Creature -> SPic -> SPic -translateToRightLeg cr = rotateSP (_crMvDir cr - _crDir cr) . case cr ^? crStance . carriage of - Just (Walking sa LeftForward) -> translateSPf (-f sa) (-off) - Just (Walking sa RightForward) -> translateSPf ( f sa) (-off) - _ -> translateSPf 0 (-off) +translateToRightLeg cr = + rotateSP (_crMvDir cr - _crDir cr) . case cr ^? crStance . carriage of + Just (Walking sa LeftForward) -> translateSPf (- f sa) (- off) + Just (Walking sa RightForward) -> translateSPf (f sa) (- off) + _ -> translateSPf 0 (- off) where off = 5 sLen = _strideLength $ _crStance cr @@ -137,35 +142,40 @@ translateToRightLeg cr = rotateSP (_crMvDir cr - _crDir cr) . case cr ^? crStanc translateToHead :: Creature -> SPic -> SPic translateToHead cr - | twists cr = translateSPz 20 . translateSPf 0 5 . rotateSP (-1) . translateSPf (negate 2.5) 0.25 + | twists cr = + translateSPz 20 . translateSPf 0 5 . rotateSP (-1) . translateSPf (negate 2.5) 0.25 . rotateSP 1 - | oneH cr = translateSPz 20 . rotateSP 0.5 . translateSPf 2.5 0 + | oneH cr = + translateSPz 20 . rotateSP 0.5 . translateSPf 2.5 0 . rotateSP (negate 0.5) - | otherwise = translateSPz 20 . translateSPf 2.5 0 + | otherwise = translateSPz 20 . translateSPf 2.5 0 translatePointToHead :: Creature -> Point3 -> Point3 translatePointToHead cr - | twists cr = (+.+.+ V3 0 5 20) . rotate3 (-1) . (+.+.+ V3 (negate 2.5) 0.25 0) + | twists cr = + (+.+.+ V3 0 5 20) . rotate3 (-1) . (+.+.+ V3 (negate 2.5) 0.25 0) . rotate3 1 - | oneH cr = (+.+.+ V3 0 0 20) . rotate3 0.5 . (+.+.+ V3 2.5 0 0) + | oneH cr = + (+.+.+ V3 0 0 20) . rotate3 0.5 . (+.+.+ V3 2.5 0 0) . rotate3 (negate 0.5) | otherwise = (+.+.+ V3 2.5 0 20) translateToChest :: Creature -> SPic -> SPic translateToChest cr - | oneH cr = rotateSP 0.5 --- | twists cr = translateSPf 0 5 . rotateSP (-1) + | oneH cr = rotateSP 0.5 + -- | twists cr = translateSPf 0 5 . rotateSP (-1) | twists cr = rotateSP (-1) | otherwise = id translateToBack :: Creature -> SPic -> SPic translateToBack cr - | oneH cr = rotateSP 0.5 --- | twists cr = translateSPf 0 5 . rotateSP (-1) + | oneH cr = rotateSP 0.5 + -- | twists cr = translateSPf 0 5 . rotateSP (-1) | twists cr = rotateSP (-1) | otherwise = id shoulderSP :: SPic -> SPic shoulderSP = translateSPz 20 + waistSP :: SPic -> SPic waistSP = translateSPz 10 diff --git a/src/Dodge/Creature/Impulse.hs b/src/Dodge/Creature/Impulse.hs index ca319989f..6aa55b12d 100644 --- a/src/Dodge/Creature/Impulse.hs +++ b/src/Dodge/Creature/Impulse.hs @@ -1,91 +1,98 @@ {-# LANGUAGE TupleSections #-} -module Dodge.Creature.Impulse - ( impulsiveAIBefore - , followThenClearImpulses - ) where -import Dodge.Data -import Dodge.FloatFunction -import Dodge.RandImpulse -import Dodge.CreatureEffect -import Dodge.Creature.Vocalization -import Dodge.Creature.Impulse.Movement -import Dodge.Creature.Impulse.UseItem -import Dodge.SoundLogic -import Geometry -import LensHelp -import qualified IntMapHelp as IM -import System.Random +module Dodge.Creature.Impulse ( + impulsiveAIBefore, + followThenClearImpulses, +) where + import Control.Monad.State import Data.Bifunctor ---import Data.Maybe --- -impulsiveAIBeforeAfter - :: (World -> Creature -> Creature) - -> (World -> Creature -> Creature) - -> Creature -> World -> World +import Dodge.Creature.Impulse.Movement +import Dodge.Creature.Impulse.UseItem +import Dodge.Creature.Vocalization +import Dodge.CreatureEffect +import Dodge.Data.World +import Dodge.FloatFunction +import Dodge.RandImpulse +import Dodge.SoundLogic +import Geometry +import qualified IntMapHelp as IM +import LensHelp +import System.Random + +impulsiveAIBeforeAfter :: + (World -> Creature -> Creature) -> + (World -> Creature -> Creature) -> + Creature -> + World -> + World impulsiveAIBeforeAfter startup endup cr w = w' & cWorld . creatures . ix (_crID cr) .~ endup w' cr' where w' = g w - (g,cr') = impulsiveAI startup cr w + (g, cr') = impulsiveAI startup cr w -impulsiveAIBefore :: (World -> Creature -> Creature) - -> Creature -> World -> World +impulsiveAIBefore :: + (World -> Creature -> Creature) -> + Creature -> + World -> + World impulsiveAIBefore f cr w = g w & cWorld . creatures . ix (_crID cr) .~ cr' where - (g,cr') = impulsiveAI f cr w + (g, cr') = impulsiveAI f cr w -impulsiveAI - :: (World -> Creature -> Creature) -- | internal creature update - -> Creature - -> World - -> (World -> World , Creature) +impulsiveAI :: + (World -> Creature -> Creature) -> + Creature -> + World -> + (World -> World, Creature) impulsiveAI f cr w = followImpulses w $ f w cr - followThenClearImpulses :: Creature -> World -> World followThenClearImpulses = impulsiveAIBeforeAfter (const id) (const $ crActionPlan . apImpulse .~ []) followImpulses :: World -> Creature -> (World -> World, Creature) followImpulses w cr = foldr f (id, cr) (_apImpulse $ _crActionPlan cr) where - f imp (theupdate,cr') = first (. theupdate) $ followImpulse cr' w imp + f imp (theupdate, cr') = first (. theupdate) $ followImpulse cr' w imp -followImpulse :: Creature -> World -> Impulse -> (World -> World , Creature) +followImpulse :: Creature -> World -> Impulse -> (World -> World, Creature) followImpulse cr w imp = case imp of - ImpulseNothing -> (id,cr) - RandomImpulse rimp -> - let (newimp,newgen) = runState (doRandImpulse rimp) (_randGen w) - in first ((randGen .~ newgen) .) $ followImpulse cr w newimp - Bark sid -> (soundStart (CrMouth cid) cpos sid Nothing, resetCrVocCoolDown cr) - Move p -> crup $ crMvBy p cr - MoveForward x -> crup $ crMvForward x cr - Turn a -> crup $ creatureTurn a cr - TurnToward p a -> crup $ creatureTurnToward p a cr - TurnTo p -> crup $ creatureTurnTo p cr - ChangePosture post -> crup $ cr & crStance . posture .~ post - UseItem -> (useItem cr, cr) - SwitchToItem i -> crup $ cr & crInvSel .~ InvSel i NoInvSelAction - Melee cid' -> (hitCr cid' - , crMvBy (10 *.* normalizeV (posFromID cid' -.- cpos)) $ cr & crMeleeCooldown .~ 20) - RandomTurn a -> (randGen .~ snd (rr a), creatureTurn (fst $ rr a) cr) - MakeSound sid -> ( soundStart (CrSound (_crID cr)) (_crPos cr) sid Nothing , cr ) - DropItem -> undefined - ChangeStrategy strat -> crup $ cr & crActionPlan . apStrategy .~ strat - AddGoal gl -> crup $ cr & crActionPlan . apGoal .:~ gl - ArbitraryImpulseFunction f -> crup $ doWdCrCr f w cr - ArbitraryImpulse f -> followImpulse cr w (doCrWdImp f cr w) + ImpulseNothing -> (id, cr) + RandomImpulse rimp -> + let (newimp, newgen) = runState (doRandImpulse rimp) (_randGen w) + in first ((randGen .~ newgen) .) $ followImpulse cr w newimp + Bark sid -> (soundStart (CrMouth cid) cpos sid Nothing, resetCrVocCoolDown cr) + Move p -> crup $ crMvBy p cr + MoveForward x -> crup $ crMvForward x cr + Turn a -> crup $ creatureTurn a cr + TurnToward p a -> crup $ creatureTurnToward p a cr + TurnTo p -> crup $ creatureTurnTo p cr + ChangePosture post -> crup $ cr & crStance . posture .~ post + UseItem -> (useItem cr, cr) + SwitchToItem i -> crup $ cr & crInvSel .~ InvSel i NoInvSelAction + Melee cid' -> + ( hitCr cid' + , crMvBy (10 *.* normalizeV (posFromID cid' -.- cpos)) $ cr & crMeleeCooldown .~ 20 + ) + RandomTurn a -> (randGen .~ snd (rr a), creatureTurn (fst $ rr a) cr) + MakeSound sid -> (soundStart (CrSound (_crID cr)) (_crPos cr) sid Nothing, cr) + DropItem -> undefined + ChangeStrategy strat -> crup $ cr & crActionPlan . apStrategy .~ strat + AddGoal gl -> crup $ cr & crActionPlan . apGoal .:~ gl + ArbitraryImpulseFunction f -> crup $ doWdCrCr f w cr + ArbitraryImpulse f -> followImpulse cr w (doCrWdImp f cr w) ArbitraryImpulseEffect f -> (doCrWdWd f cr, cr) - ImpulseUseTargetCID f -> case cr ^? crIntention . targetCr . _Just of + ImpulseUseTargetCID f -> case cr ^? crIntention . targetCr . _Just of Just tcr -> followImpulse cr w (doIntImp f $ _crID tcr) - _ -> crup cr + _ -> crup cr ImpulseUseTarget f -> case cr ^? crIntention . targetCr . _Just of Just tcr -> followImpulse cr w (doCrImp f tcr) - _ -> crup cr + _ -> crup cr ImpulseUseAheadPos f -> followImpulse cr w (doP2Imp f (_crPos cr +.+ 20 *.* unitVectorAtAngle (_crDir cr))) - MvForward -> crup $ crMvForward speed cr - MvTurnToward p -> crup - $ creatureTurnToward p (turnRad $ safeAngleVV (p -.- cpos) (unitVectorAtAngle cdir)) cr + MvForward -> crup $ crMvForward speed cr + MvTurnToward p -> + crup $ + creatureTurnToward p (turnRad $ safeAngleVV (p -.- cpos) (unitVectorAtAngle cdir)) cr where crup = (id,) mvType = _crMvType cr @@ -93,10 +100,11 @@ followImpulse cr w imp = case imp of turnRad = doFloatFloat $ _mvTurnRad mvType cpos = _crPos cr cdir = _crDir cr - cid = _crID cr + cid = _crID cr posFromID cid' = _crPos $ _creatures (_cWorld w) IM.! cid' - rr a = randomR (-a,a) $ _randGen w - hitCr i = (cWorld . creatures . ix i . crState . csDamage - .:~ Damage BLUNT 100 cpos (posFromID i) (posFromID i) NoDamageEffect + rr a = randomR (- a, a) $ _randGen w + hitCr i = + ( cWorld . creatures . ix i . crState . csDamage + .:~ Damage BLUNT 100 cpos (posFromID i) (posFromID i) NoDamageEffect ) - . soundStart (CrSound cid) cpos hitS Nothing + . soundStart (CrSound cid) cpos hitS Nothing diff --git a/src/Dodge/Creature/Impulse/Flee.hs b/src/Dodge/Creature/Impulse/Flee.hs index 2161c916a..e962b85b6 100644 --- a/src/Dodge/Creature/Impulse/Flee.hs +++ b/src/Dodge/Creature/Impulse/Flee.hs @@ -1,16 +1,17 @@ -module Dodge.Creature.Impulse.Flee - where -import Dodge.Data -import Geometry -import FoldableHelp +module Dodge.Creature.Impulse.Flee where -retreatPointForFrom - :: Float -> World -> Creature -> Point2 -> Maybe Point2 -retreatPointForFrom d _ cr p - = safeMinimumOn (dist cpos) - $ divideCircle 10 p d +import Dodge.Data.World +import FoldableHelp +import Geometry + +retreatPointForFrom :: + Float -> World -> Creature -> Point2 -> Maybe Point2 +retreatPointForFrom d _ cr p = + safeMinimumOn (dist cpos) $ + divideCircle 10 p d where cpos = _crPos cr + -- = head $ sortBy (compare `on` (\p -> dist p ypos < 300)) $ retreatP'' : retreatPs -- where -- retreatPs = sortBy (compare `on` dist cpos) $ map f $ nRaysRad 8 400 @@ -18,5 +19,5 @@ retreatPointForFrom d _ cr p -- $ reflectPointWalls ypos (ypos +.+ p) (wallsAlongLine ypos (ypos +.+ p) w) -- retreatP' = cpos +.+ 300 *.* (cpos -.- ypos) -- retreatP'' = fromMaybe retreatP' $ fmap fst --- $ reflectPointWalls ypos retreatP' +-- $ reflectPointWalls ypos retreatP' -- $ wallsAlongLine ypos retreatP' w diff --git a/src/Dodge/Creature/Impulse/Movement.hs b/src/Dodge/Creature/Impulse/Movement.hs index 694adabdf..061efa8e4 100644 --- a/src/Dodge/Creature/Impulse/Movement.hs +++ b/src/Dodge/Creature/Impulse/Movement.hs @@ -1,26 +1,31 @@ module Dodge.Creature.Impulse.Movement where -import Dodge.Data + +import Control.Lens import Dodge.Creature.Statistics +import Dodge.Data.World import Geometry ---import Data.Maybe ---import qualified IntMapHelp as IM -import Control.Lens {- | Creature attempts to moves under its own steam. -The idea is that this may or may not work, depending on the status of the creature. -For now, though, this cannot fail. -} -crMvBy :: Point2 -- ^ Movement translation vector, will be made relative to creature direction - -> Creature -> Creature +The idea is that this may or may not work, depending on the status of the creature. +For now, though, this cannot fail. +-} +crMvBy :: + -- | Movement translation vector, will be made relative to creature direction + Point2 -> + Creature -> + Creature crMvBy p cr = crMvAbsolute (rotateV (_crDir cr) p) cr -crMvAbsolute - :: Point2 -- ^ Movement translation vector - -> Creature - -> Creature -crMvAbsolute p' cr = advanceStepCounter (magV p) cr - & crPos %~ (+.+ p) - & crMvDir .~ argV p - where +crMvAbsolute :: + -- | Movement translation vector + Point2 -> + Creature -> + Creature +crMvAbsolute p' cr = + advanceStepCounter (magV p) cr + & crPos %~ (+.+ p) + & crMvDir .~ argV p + where p = strengthFactor (getCrStrength cr) *.* p' strengthFactor :: Int -> Float @@ -29,18 +34,20 @@ strengthFactor i | i < 1 = 0 | otherwise = 0.1 * fromIntegral i -crMvForward - :: Float -- ^ Speed - -> Creature - -> Creature +crMvForward :: + -- | Speed + Float -> + Creature -> + Creature crMvForward speed = crMvBy (V2 speed 0) -advanceStepCounter - :: Float -- ^ Speed - -> Creature - -> Creature +advanceStepCounter :: + -- | Speed + Float -> + Creature -> + Creature advanceStepCounter speed = crStance . carriage %~ f - where + where f car = case car of Standing -> f (Walking 0 RightForward) Walking i ff -> Walking (i + ceiling speed) ff @@ -50,25 +57,27 @@ creatureTurn :: Float -> Creature -> Creature creatureTurn a = crDir +~ a creatureTurnTo :: Point2 -> Creature -> Creature -creatureTurnTo p cr +creatureTurnTo p cr | vToTarg == V2 0 0 = cr -- this should deal with the angleVV error - | otherwise = cr & crDir .~ dirToTarget + | otherwise = cr & crDir .~ dirToTarget where vToTarg = p -.- _crPos cr dirToTarget = argV vToTarg -- the following is perhaps not ideal because it mixes normalizeAngle with -- angleVV, but it seems to work -creatureTurnTowardDir - :: Float -- ^ Angle - -> Float -- ^ Turn speed - -> Creature - -> Creature -creatureTurnTowardDir a turnSpeed cr - | normalizeAngle (abs (a - cdir)) <= turnSpeed - = cr & crDir .~ dirToTarget - | isLeftOfA (normalizeAngle dirToTarget) (normalizeAngle $ _crDir cr) - = cr & crDir +~ turnSpeed +creatureTurnTowardDir :: + -- | Angle + Float -> + -- | Turn speed + Float -> + Creature -> + Creature +creatureTurnTowardDir a turnSpeed cr + | normalizeAngle (abs (a - cdir)) <= turnSpeed = + cr & crDir .~ dirToTarget + | isLeftOfA (normalizeAngle dirToTarget) (normalizeAngle $ _crDir cr) = + cr & crDir +~ turnSpeed | otherwise = cr & crDir -~ turnSpeed where cdir = _crDir cr @@ -76,16 +85,16 @@ creatureTurnTowardDir a turnSpeed cr dirToTarget = argV vToTarg creatureTurnToward :: Point2 -> Float -> Creature -> Creature -creatureTurnToward p turnSpeed cr +creatureTurnToward p turnSpeed cr | vToTarg == V2 0 0 = cr -- this should deal with the angleVV error - | errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed - = cr & crDir .~ dirToTarget + | errorAngleVV 3 vToTarg (unitVectorAtAngle (_crDir cr)) <= turnSpeed = + cr & crDir .~ dirToTarget | isLeftOfA (normalizeAngle dirToTarget) (normalizeAngle $ _crDir cr) = cr & crDir +~ turnSpeed - | otherwise = cr & crDir -~ turnSpeed + | otherwise = cr & crDir -~ turnSpeed where vToTarg = p -.- _crPos cr dirToTarget = argV vToTarg -{- | Speed modifier of an item when not aiming. -} +-- | Speed modifier of an item when not aiming. equipSpeed :: Item -> Float equipSpeed _ = 1 diff --git a/src/Dodge/Creature/Impulse/UseItem.hs b/src/Dodge/Creature/Impulse/UseItem.hs index d39ba3699..a86e2e5e5 100644 --- a/src/Dodge/Creature/Impulse/UseItem.hs +++ b/src/Dodge/Creature/Impulse/UseItem.hs @@ -4,12 +4,11 @@ module Dodge.Creature.Impulse.UseItem ( itemEffect, ) where ---import qualified Data.IntSet as IS import Control.Lens import qualified Data.Map.Strict as M import Data.Maybe import Dodge.Cuse -import Dodge.Data +import Dodge.Data.World import Dodge.Euse import Dodge.HeldUse import Dodge.Inventory @@ -29,7 +28,7 @@ useItem cr' w = fromMaybe (f w) $ do itemEffect :: Creature -> Item -> World -> World itemEffect cr it w = case it ^. itUse of - RightUse{_rUse = eff, _useMods = usemods} -> + HeldUse{_heldUse = eff, _heldMods = usemods} -> hammerTest $ tryReload cr it w $ foldr ($) (useHeld eff) (useMod usemods) it cr LeftUse{} -> doequipmentchange EquipUse{} -> doequipmentchange @@ -53,7 +52,7 @@ tryReload cr it w f | _crID cr == _yourID (_cWorld w) && itNeedsLoading it && _mouseButtons w M.!? SDL.ButtonLeft == Just False = crToggleReloading cr | otherwise = - (runIdentity . pointerToItemLocation (_itLocation it) (return . (itUse . useHammer .~ HammerDown))) + (runIdentity . pointerToItemLocation (_itLocation it) (return . (itUse . heldHammer .~ HammerDown))) . f itNeedsLoading :: Item -> Bool @@ -104,8 +103,8 @@ toggleEquipmentAt rbops invid cr w = case rbops ^? opAllocateEquipment of crpoint = cWorld . creatures . ix (_crID cr) itmat i = _crInv cr IM.! i itm = itmat (crSel cr) - onequip itm' = useE ((_eqOnEquip . _eqEq . _itUse) itm') itm' - onremove itm' = useE ((_eqOnRemove . _eqEq . _itUse) itm') itm' + onequip itm' = useE ((_eeOnEquip . _equipEffect . _itUse) itm') itm' + onremove itm' = useE ((_eeOnRemove . _equipEffect . _itUse) itm') itm' useLeftItem :: Int -> World -> World useLeftItem cid w @@ -114,16 +113,16 @@ useLeftItem cid w | otherwise = fromMaybe w $ do invid <- _crLeftInvSel cr itm <- cr ^? crInv . ix invid - f <- cr ^? crInv . ix invid . itUse . lUse + f <- cr ^? crInv . ix invid . itUse . leftUse return - . (runIdentity . pointerToItemLocation (_itLocation itm) (return . (itUse . useHammer .~ HammerDown))) + . (runIdentity . pointerToItemLocation (_itLocation itm) (return . (itUse . leftHammer .~ HammerDown))) . useL f itm cr $ w where cr = _creatures (_cWorld w) IM.! cid itmShouldBeUsed = isJust (cr ^? crInv . ix (crSel cr) . itUse . cUse) - || ( isJust (cr ^? crInv . ix (crSel cr) . itUse . eqEq . eqUse) + || ( isJust (cr ^? crInv . ix (crSel cr) . itUse . equipEffect . eeUse) && _crLeftInvSel cr /= Just (crSel cr) ) diff --git a/src/Dodge/Creature/Inanimate.hs b/src/Dodge/Creature/Inanimate.hs index 66549dc16..18ce6a132 100644 --- a/src/Dodge/Creature/Inanimate.hs +++ b/src/Dodge/Creature/Inanimate.hs @@ -2,34 +2,39 @@ {- Inanimate objects such as lamps, barrels, etc -} -module Dodge.Creature.Inanimate - ( barrel - , explosiveBarrel - , module Dodge.Creature.Lamp - ) where -import Dodge.Data +module Dodge.Creature.Inanimate ( + barrel, + explosiveBarrel, + module Dodge.Creature.Lamp, +) where + import Dodge.Creature.Lamp +import Dodge.Data.Creature import Dodge.Default import qualified IntMapHelp as IM import LensHelp barrel :: Creature -barrel = defaultInanimate - { _crHP = 500 - , _crType = Barreloid PlainBarrel - , _crState = defaultState - {_csSpState = Barrel [] +barrel = + defaultInanimate + { _crHP = 500 + , _crType = Barreloid PlainBarrel + , _crState = + defaultState + { _csSpState = Barrel [] + } + , _crInv = IM.empty -- IM.fromList [(0,frontArmour)] } - , _crInv = IM.empty -- IM.fromList [(0,frontArmour)] - } explosiveBarrel :: Creature -explosiveBarrel = defaultInanimate - { _crHP = 400 - , _crType = Barreloid ExplosiveBarrel - , _crState = defaultState - {_csSpState = Barrel [] +explosiveBarrel = + defaultInanimate + { _crHP = 400 + , _crType = Barreloid ExplosiveBarrel + , _crState = + defaultState + { _csSpState = Barrel [] + } + , _crInv = IM.empty -- IM.fromList [(0,frontArmour)] } - , _crInv = IM.empty -- IM.fromList [(0,frontArmour)] - } - & crMaterial .~ Crystal + & crMaterial .~ Crystal diff --git a/src/Dodge/Creature/Lamp.hs b/src/Dodge/Creature/Lamp.hs index 1c887e767..cc4ca5f13 100644 --- a/src/Dodge/Creature/Lamp.hs +++ b/src/Dodge/Creature/Lamp.hs @@ -1,19 +1,23 @@ -module Dodge.Creature.Lamp - ( lamp - , colorLamp - ) where -import Dodge.Data +module Dodge.Creature.Lamp ( + lamp, + colorLamp, +) where + +import Dodge.Data.Creature import Dodge.Default import Geometry.Data -colorLamp - :: Point3 -- color of lamp - -> Float -- height of lamp - -> Creature -colorLamp col h = defaultInanimate - { _crHP = 100 - , _crType = Lampoid h col Nothing - , _crRad = 3 - , _crMass = 3 - } + +colorLamp :: + Point3 -> -- color of lamp + Float -> -- height of lamp + Creature +colorLamp col h = + defaultInanimate + { _crHP = 100 + , _crType = Lampoid h col Nothing + , _crRad = 3 + , _crMass = 3 + } + lamp :: Float -> Creature lamp = colorLamp 0.75 diff --git a/src/Dodge/Creature/LauncherCrit.hs b/src/Dodge/Creature/LauncherCrit.hs index 23bc2d5cb..605ccb711 100644 --- a/src/Dodge/Creature/LauncherCrit.hs +++ b/src/Dodge/Creature/LauncherCrit.hs @@ -1,24 +1,21 @@ -module Dodge.Creature.LauncherCrit - ( launcherCrit - ) - where -import Dodge.Data +module Dodge.Creature.LauncherCrit ( + launcherCrit, +) where + +import Dodge.Item.Held.Launcher +import Control.Lens +import Dodge.Data.Creature import Dodge.Default -import Dodge.Item.Weapon.Launcher +import qualified IntMapHelp as IM import Picture -import qualified IntMapHelp as IM -import Control.Lens - launcherCrit :: Creature -launcherCrit = defaultCreature - { _crInv = IM.fromList [(0,launcher)] - , _crRad = 10 - , _crState = defaultState - , _crHP = 300 - } - & crType . skinUpper .~ light4 red - & crType . humanoidAI .~ LauncherAI - - - +launcherCrit = + defaultCreature + { _crInv = IM.fromList [(0, launcher)] + , _crRad = 10 + , _crState = defaultState + , _crHP = 300 + } + & crType . skinUpper .~ light4 red + & crType . humanoidAI .~ LauncherAI diff --git a/src/Dodge/Creature/LtAutoCrit.hs b/src/Dodge/Creature/LtAutoCrit.hs index 995fe71a9..167aff4ed 100644 --- a/src/Dodge/Creature/LtAutoCrit.hs +++ b/src/Dodge/Creature/LtAutoCrit.hs @@ -1,21 +1,21 @@ -module Dodge.Creature.LtAutoCrit - ( ltAutoCrit - ) where -import Dodge.Data +module Dodge.Creature.LtAutoCrit ( + ltAutoCrit, +) where + +import Control.Lens +import Dodge.Data.Creature import Dodge.Default -import Dodge.Item.Weapon.BulletGuns import Dodge.Item.Consumable +import Dodge.Item.Held.Stick +import qualified IntMapHelp as IM import Picture -import qualified IntMapHelp as IM -import Control.Lens - ltAutoCrit :: Creature -ltAutoCrit = defaultCreature - { _crInv = IM.fromList [(0,autoPistol),(1,medkit 100)] - , _crRad = 10 - , _crHP = 500 - } - & crType . humanoidAI .~ LtAutoAI - & crType . skinUpper .~ light4 red - +ltAutoCrit = + defaultCreature + { _crInv = IM.fromList [(0, autoPistol), (1, medkit 100)] + , _crRad = 10 + , _crHP = 500 + } + & crType . humanoidAI .~ LtAutoAI + & crType . skinUpper .~ light4 red diff --git a/src/Dodge/Creature/Perception.hs b/src/Dodge/Creature/Perception.hs index cc61014c4..8232c2378 100644 --- a/src/Dodge/Creature/Perception.hs +++ b/src/Dodge/Creature/Perception.hs @@ -1,98 +1,106 @@ --{-# LANGUAGE TupleSections #-} -module Dodge.Creature.Perception - ( perceptionUpdate - , chaseCritPerceptionUpdate --- , newSounds - ) where -import Dodge.Data -import Dodge.FloatFunction -import Dodge.Creature.Vocalization -import Dodge.Base.Collide -import RandomHelp ---import Dodge.SoundLogic -import Geometry.Vector ---import Geometry.Data -import Geometry.Data -import Sound.Data ---import StrictHelp +module Dodge.Creature.Perception ( + perceptionUpdate, + chaseCritPerceptionUpdate, +) where -import Data.Maybe import Control.Lens -import qualified IntMapHelp as IM import qualified Data.Map.Strict as M +import Data.Maybe +import Dodge.Base.Collide +import Dodge.Creature.Vocalization +import Dodge.Data.World +import Dodge.FloatFunction +import Geometry.Data +import Geometry.Vector +import qualified IntMapHelp as IM +import RandomHelp +import Sound.Data -perceptionUpdate - :: [Int] -- ^ List of creature ids that may direct attention and awareness - -> World - -> Creature - -> Creature +perceptionUpdate :: + -- | List of creature ids that may direct attention and awareness + [Int] -> + World -> + Creature -> + Creature perceptionUpdate is w = rememberSounds w . basicAwarenessUpdate . basicAttentionUpdate is w chaseCritPerceptionUpdate :: [Int] -> World -> Creature -> Creature -chaseCritPerceptionUpdate is w = +chaseCritPerceptionUpdate is w = rememberSounds w . chaseCritAwarenessUpdate w . basicAttentionUpdate is w {- | Update a creatures awareness based upon the creatures' current direction - of attention -} -- TODO delete? + of attention +-} -- TODO delete? basicAwarenessUpdate :: Creature -> Creature basicAwarenessUpdate cr = case _cpAttention $ _crPerception cr of - Fixated i -> cr & crPerception . cpAwareness - %~ (IM.insert i (Cognizant 10000) . IM.mapMaybe decreaseAwareness) - AttentiveTo is -> cr - & crPerception . cpAwareness - %~ (IM.mapMaybe decreaseAwareness . IM.unionWith combineAwareness is) - & maybeBark + Fixated i -> + cr & crPerception . cpAwareness + %~ (IM.insert i (Cognizant 10000) . IM.mapMaybe decreaseAwareness) + AttentiveTo is -> + cr + & crPerception . cpAwareness + %~ (IM.mapMaybe decreaseAwareness . IM.unionWith combineAwareness is) + & maybeBark where oldAwareness = _cpAwareness $ _crPerception cr newAwareness = (IM.mapMaybe decreaseAwareness . IM.unionWith combineAwareness is) oldAwareness becomesCognizant = any isCognizant $ IM.unionWith cogRaised oldAwareness newAwareness - thejitter = RandImpulseCircMove 1 - --do - --p <- randInCirc 1 - --return $ Move p + thejitter = RandImpulseCircMove 1 + --do + --p <- randInCirc 1 + --return $ Move p maybeBark | becomesCognizant = case vocalizationTest cr of - Just sid -> crActionPlan . apAction .~ - [ImpulsesList - [[Bark sid] - ,[RandomImpulse thejitter] - ,[RandomImpulse thejitter] - ,[RandomImpulse thejitter] - ,[RandomImpulse thejitter] - ,[RandomImpulse thejitter] - ] - ] + Just sid -> + crActionPlan . apAction + .~ [ ImpulsesList + [ [Bark sid] + , [RandomImpulse thejitter] + , [RandomImpulse thejitter] + , [RandomImpulse thejitter] + , [RandomImpulse thejitter] + , [RandomImpulse thejitter] + ] + ] Nothing -> id | otherwise = id -- TODO fold in randgen update, requires that this is a world to world function chaseCritAwarenessUpdate :: World -> Creature -> Creature chaseCritAwarenessUpdate w cr = case _cpAttention $ _crPerception cr of - Fixated i -> cr & crPerception . cpAwareness - %~ (IM.insert i (Cognizant 10000) . IM.mapMaybe decreaseAwareness) - AttentiveTo is -> cr - & crPerception . cpAwareness - %~ (IM.mapMaybe decreaseAwareness . IM.unionWith combineAwareness is) - & maybeBark + Fixated i -> + cr & crPerception . cpAwareness + %~ (IM.insert i (Cognizant 10000) . IM.mapMaybe decreaseAwareness) + AttentiveTo is -> + cr + & crPerception . cpAwareness + %~ (IM.mapMaybe decreaseAwareness . IM.unionWith combineAwareness is) + & maybeBark where oldAwareness = _cpAwareness $ _crPerception cr newAwareness = (IM.mapMaybe decreaseAwareness . IM.unionWith combineAwareness is) oldAwareness becomesCognizant = any isCognizant $ IM.unionWith cogRaised oldAwareness newAwareness --randBool = takeOne [False,True] & evalState $ _randGen w - thejitter = RandImpulseCircMove 2 + thejitter = RandImpulseCircMove 2 -- do -- p <- randInCirc 2 -- return $ Move p maybeBark - | becomesCognizant -- && randBool - && cr ^? crVocalization . vcCoolDown == Just 0 - = let soundid = evalState (takeOne (_vcWarnings (_crVocalization cr))) (_randGen w) - numjits = fst $ randomR (15,25) (_randGen w) - in crActionPlan . apStrategy .~ StrategyActions WarningCry - [ImpulsesList ([Bark soundid]: replicate numjits [RandomImpulse thejitter]++ - [[ChangeStrategy $ CloseToMelee 0] ]) - , AimAt 0 (_crPos $ _creatures (_cWorld w) IM.! 0) - ] + | becomesCognizant -- && randBool + && cr ^? crVocalization . vcCoolDown == Just 0 = + let soundid = evalState (takeOne (_vcWarnings (_crVocalization cr))) (_randGen w) + numjits = fst $ randomR (15, 25) (_randGen w) + in crActionPlan . apStrategy + .~ StrategyActions + WarningCry + [ ImpulsesList + ( [Bark soundid] : + replicate numjits [RandomImpulse thejitter] + ++ [[ChangeStrategy $ CloseToMelee 0]] + ) + , AimAt 0 (_crPos $ _creatures (_cWorld w) IM.! 0) + ] | otherwise = id cogRaised :: Awareness -> Awareness -> Awareness @@ -100,19 +108,18 @@ cogRaised Suspicious{} Cognizant{} = Cognizant 100 cogRaised _ _ = Suspicious 0 isCognizant :: Awareness -> Bool -isCognizant Cognizant {} = True +isCognizant Cognizant{} = True isCognizant _ = False combineAwareness :: Awareness -> Awareness -> Awareness -combineAwareness (Suspicious x) (Suspicious y) +combineAwareness (Suspicious x) (Suspicious y) | x + y < 5000 = Suspicious $ x + y - | otherwise = Cognizant 1000 + | otherwise = Cognizant 1000 combineAwareness (Suspicious x) (Cognizant y) = Cognizant $ min 10000 $ x + y combineAwareness (Cognizant x) (Suspicious y) = Cognizant $ min 10000 $ x + y -combineAwareness (Cognizant x) (Cognizant y) = Cognizant $ min 10000 $ x + y +combineAwareness (Cognizant x) (Cognizant y) = Cognizant $ min 10000 $ x + y -{- | Decrease awareness level. Returns 'Maybe' value for use with 'IM.mapMaybe' - -} +-- | Decrease awareness level. Returns 'Maybe' value for use with 'IM.mapMaybe' decreaseAwareness :: Awareness -> Maybe Awareness decreaseAwareness (Suspicious 0) = Nothing decreaseAwareness (Suspicious x) = Just $ Suspicious (x - 50) @@ -120,20 +127,25 @@ decreaseAwareness (Cognizant 0) = Just $ Suspicious 1000 decreaseAwareness (Cognizant x) = Just $ Cognizant $ x - 50 {- | Given a fixed group of creatures, direct attention to those of them that - - are in view. -} -basicAttentionUpdate - :: [Int] -- ^ Creatures that may attract this creature's attention - -> World - -> Creature - -> Creature -basicAttentionUpdate cids w cr = cr & crPerception . cpAttention .~ - AttentiveTo (IM.mapMaybe (newExtraAwareness cr w) $ IM.fromList $ zip cids cids) + - are in view. +-} +basicAttentionUpdate :: + -- | Creatures that may attract this creature's attention + [Int] -> + World -> + Creature -> + Creature +basicAttentionUpdate cids w cr = + cr & crPerception . cpAttention + .~ AttentiveTo (IM.mapMaybe (newExtraAwareness cr w) $ IM.fromList $ zip cids cids) -newExtraAwareness - :: Creature -- ^ source creature - -> World - -> Int -- ^ target creature id - -> Maybe Awareness +newExtraAwareness :: + -- | source creature + Creature -> + World -> + -- | target creature id + Int -> + Maybe Awareness newExtraAwareness cr w cid | not $ canSeeIndirect (_crID cr) cid w = Nothing | otherwise = Just . Suspicious $ doFloatFloat (_viFOV vi) ang * doFloatFloat (_viDist vi) d * awakeLevelPerception cr @@ -141,18 +153,18 @@ newExtraAwareness cr w cid vi = _cpVision $ _crPerception cr tpos = _crPos $ _creatures (_cWorld w) IM.! cid cpos = _crPos cr - ang = angleVV (unitVectorAtAngle (_crDir cr)) (tpos - cpos) + ang = angleVV (unitVectorAtAngle (_crDir cr)) (tpos - cpos) d = dist tpos cpos awakeLevelPerception :: Creature -> Float awakeLevelPerception cr = case _cpVigilance $ _crPerception cr of - Comatose -> 0 - Asleep -> 10 - Lethargic -> 200 - Vigilant -> 500 - Overstrung -> 10000 + Comatose -> 0 + Asleep -> 10 + Lethargic -> 200 + Vigilant -> 500 + Overstrung -> 10000 -newSounds :: World -> [(Point2,Float)] +newSounds :: World -> [(Point2, Float)] newSounds = mapMaybe f . M.elems . _playingSounds where f s = case _playStatus $ _soundStatus s of @@ -160,18 +172,21 @@ newSounds = mapMaybe f . M.elems . _playingSounds _ -> Nothing rememberSounds :: World -> Creature -> Creature -rememberSounds w cr = cr - & crMemory . soundsToInvestigate .~ closesounds - & awakeupdate +rememberSounds w cr = + cr + & crMemory . soundsToInvestigate .~ closesounds + & awakeupdate where - awakeupdate | null closesounds = id + awakeupdate + | null closesounds = id | otherwise = crPerception . cpVigilance .~ Vigilant closesounds = map fst (filter (soundIsClose w cr) (newSounds w)) -- TODO work out correct form for sounds passing through walls -soundIsClose :: World -> Creature -> (Point2,Float) -> Bool -soundIsClose w cr (pos,vol) = dist cpos pos < 2000 - && vol > doFloatFloat (_auDist . _cpAudition $ _crPerception cr) (dist pos cpos) - && hasLOS cpos pos w +soundIsClose :: World -> Creature -> (Point2, Float) -> Bool +soundIsClose w cr (pos, vol) = + dist cpos pos < 2000 + && vol > doFloatFloat (_auDist . _cpAudition $ _crPerception cr) (dist pos cpos) + && hasLOS cpos pos w where cpos = _crPos cr diff --git a/src/Dodge/Creature/Picture.hs b/src/Dodge/Creature/Picture.hs index b696ba8bb..4a64466ef 100644 --- a/src/Dodge/Creature/Picture.hs +++ b/src/Dodge/Creature/Picture.hs @@ -1,56 +1,59 @@ --{-# LANGUAGE TupleSections #-} + {- | -Drawing of creatures. -Takes into account damage etc. -} -module Dodge.Creature.Picture - ( basicCrPict - , drawCrEquipment - , circLine - , picAtCrPos - , shapeAtCrPos - , picAtCrPosNoRot --- , basicCrCorpse - , deadScalp - , deadUpperBody - , deadFeet - ) where -import Dodge.Data -import Dodge.Creature.HandPos (translateToRightHand,translateToLeftHand) -import Dodge.Creature.Test -import Dodge.Damage -import Dodge.Item.Draw -import Picture -import Geometry -import Shape -import ShapePicture -import qualified Quaternion as Q +Drawing of creatures. +Takes into account damage etc. +-} +module Dodge.Creature.Picture ( + basicCrPict, + drawCrEquipment, + circLine, + picAtCrPos, + shapeAtCrPos, + picAtCrPosNoRot, + deadScalp, + deadUpperBody, + deadFeet, +) where import Control.Lens +import Dodge.Creature.HandPos (translateToLeftHand, translateToRightHand) +import Dodge.Creature.Test +import Dodge.Damage +import Dodge.Data.Creature +import Dodge.Item.Draw +import Geometry +import Picture +import qualified Quaternion as Q +import Shape +import ShapePicture basicCrPict :: Creature -> SPic -basicCrPict cr = drawCrEquipment cr <> (basicCrShape cr , mempty) +basicCrPict cr = drawCrEquipment cr <> (basicCrShape cr, mempty) drawCrEquipment :: Creature -> SPic drawCrEquipment cr = uncurryV translateSPf (_crPos cr) (rotateSP (_crDir cr) $ drawEquipment cr) shapeAtCrPos :: Shape -> Creature -> SPic -shapeAtCrPos sh cr = +shapeAtCrPos sh cr = ( uncurryV translateSHf (_crPos cr) $ rotateSH (_crDir cr) sh , mempty ) -basicCrShape - :: Creature - -> Shape -basicCrShape cr +basicCrShape :: + Creature -> + Shape +basicCrShape cr | _crCamouflage cr == Invisible = mempty - | otherwise = tr . scaleSH (V3 crsize crsize crsize) $ mconcat - [ --rotdir . _spShape $ drawEquipment cr - rotdir . colorSH (_skinHead cskin) . translateSHz 20 $ scalp cr - , rotdir $ colorSH (_skinUpper cskin) $ upperBody cr - , rotmdir $ colorSH (_skinLower cskin) $ feet cr - ] - where + | otherwise = + tr . scaleSH (V3 crsize crsize crsize) $ + mconcat + [ --rotdir . _spShape $ drawEquipment cr + rotdir . colorSH (_skinHead cskin) . translateSHz 20 $ scalp cr + , rotdir $ colorSH (_skinUpper cskin) $ upperBody cr + , rotmdir $ colorSH (_skinLower cskin) $ feet cr + ] + where cskin = _crType cr crsize = 0.1 * _crRad cr tr = uncurryV translateSHf (_crPos cr) @@ -79,18 +82,21 @@ basicCrShape cr feet :: Creature -> Shape {-# INLINE feet #-} feet cr = case cr ^? crStance . carriage of - Just (Walking sa LeftForward) -> mconcat - [ translateSHf ( f sa) off aFoot - , translateSHf (-f sa) (-off) aFoot - ] - Just (Walking sa RightForward) -> mconcat - [ translateSHf (-f sa) off aFoot - , translateSHf ( f sa) (-off) aFoot - ] - _ -> mconcat - [ translateSHf 0 off aFoot - , translateSHf 0 (-off) aFoot - ] + Just (Walking sa LeftForward) -> + mconcat + [ translateSHf (f sa) off aFoot + , translateSHf (- f sa) (- off) aFoot + ] + Just (Walking sa RightForward) -> + mconcat + [ translateSHf (- f sa) off aFoot + , translateSHf (f sa) (- off) aFoot + ] + _ -> + mconcat + [ translateSHf 0 off aFoot + , translateSHf 0 (- off) aFoot + ] where aFoot :: Shape aFoot = upperPrismPoly 10 $ polyCirc 3 4 @@ -101,18 +107,21 @@ feet cr = case cr ^? crStance . carriage of deadFeet :: Creature -> Shape {-# INLINE deadFeet #-} deadFeet cr = case cr ^? crStance . carriage of - Just (Walking sa LeftForward) -> mconcat - [ translateSHf ( f sa) off aFoot - , translateSHf (-f sa) (-off) aFoot - ] - Just (Walking sa RightForward) -> mconcat - [ translateSHf (-f sa) off aFoot - , translateSHf ( f sa) (-off) aFoot - ] - _ -> mconcat - [ translateSHf 0 off aFoot - , translateSHf 0 (-off) aFoot - ] + Just (Walking sa LeftForward) -> + mconcat + [ translateSHf (f sa) off aFoot + , translateSHf (- f sa) (- off) aFoot + ] + Just (Walking sa RightForward) -> + mconcat + [ translateSHf (- f sa) off aFoot + , translateSHf (f sa) (- off) aFoot + ] + _ -> + mconcat + [ translateSHf 0 off aFoot + , translateSHf 0 (- off) aFoot + ] where aFoot :: Shape aFoot = upperPrismPoly 3 $ polyCirc 3 4 @@ -122,23 +131,27 @@ deadFeet cr = case cr ^? crStance . carriage of arms :: Creature -> Shape {-# INLINE arms #-} -arms cr = fst $ translateToRightHand cr aHand - <> translateToLeftHand cr aHand ---arms cr --- | oneH cr = shoulderSH . translateSHf 11 (-3) . rotateSH (-0.5) $ scaleSH (V3 1 1.5 1) aHand --- | twists cr = shoulderSH . translateSHf 0 5 . rotateSH (-1) $ mconcat --- [ translateSHf 12 4 aHand --- , translateSHf 4 (-10) aHand --- ] --- | twoFlat cr = waistSH $ translateSHf 4 8 aHand --- <> translateSHf 4 (-8) aHand --- | otherwise = case cr ^? crStance . carriage of --- Just (Walking sa LeftForward) -> waistSH $ translateSHf (-f sa) (-off) aHand --- Just (Walking sa RightForward) -> waistSH $ translateSHf (-f sa) off aHand --- _ -> emptySH +arms cr = + fst $ + translateToRightHand cr aHand + <> translateToLeftHand cr aHand where + --arms cr + -- | oneH cr = shoulderSH . translateSHf 11 (-3) . rotateSH (-0.5) $ scaleSH (V3 1 1.5 1) aHand + -- | twists cr = shoulderSH . translateSHf 0 5 . rotateSH (-1) $ mconcat + -- [ translateSHf 12 4 aHand + -- , translateSHf 4 (-10) aHand + -- ] + -- | twoFlat cr = waistSH $ translateSHf 4 8 aHand + -- <> translateSHf 4 (-8) aHand + -- | otherwise = case cr ^? crStance . carriage of + -- Just (Walking sa LeftForward) -> waistSH $ translateSHf (-f sa) (-off) aHand + -- Just (Walking sa RightForward) -> waistSH $ translateSHf (-f sa) off aHand + -- _ -> emptySH + aHand :: SPic aHand = noPic $ translateSHz (-4) . upperPrismPolyHalf 4 $ polyCirc 3 4 + -- off = 8 -- sLen = _strideLength $ _crStance cr -- f i = negate 2 + negate 6 * fromIntegral (sLen - i) / fromIntegral sLen @@ -149,14 +162,17 @@ deadScalp cr = deadRot cr . translateSHz 10 . scalp $ cr deadRot :: Creature -> Shape -> Shape deadRot cr = overPosSH (Q.rotateToZ d) where - d = maybe (V3 1 0 0) (addZ 0 . unitVectorAtAngle . subtract (_crDir cr+pi)) - (damageDirection . _csDamage $ _crState cr) + d = + maybe + (V3 1 0 0) + (addZ 0 . unitVectorAtAngle . subtract (_crDir cr + pi)) + (damageDirection . _csDamage $ _crState cr) scalp :: Creature -> Shape {-# INLINE scalp #-} scalp cr | twists cr = translateSHf 0 5 . rotateSH (-1) $ translateSHf (negate 2.5) 0.25 fhead - | oneH cr = rotateSH 0.5 $ translateSHf 2.5 0 fhead + | oneH cr = rotateSH 0.5 $ translateSHf 2.5 0 fhead | otherwise = translateSHf 2.5 0 fhead where fhead = colorSH (greyN 0.9) . upperPrismPolyHalf 5 $ polyCirc 4 5 @@ -168,19 +184,24 @@ scalp cr torso :: Creature -> Shape {-# INLINE torso #-} -torso cr - | oneH cr = rotateSH 0.5 $ mconcat - [ translateSHf 0 3 . rotateSH (negate 0.2) $ aShoulder - , translateSHf 0 (negate 3) . rotateSH 0.2 $ aShoulder - ] - | twists cr = translateSHf 0 5 . rotateSH (-1) $ mconcat - [ rotateSH (negate 0.2) . translateSHf 2 3 . rotateSH (negate 0.4) $ aShoulder - , rotateSH (negate 0.2) . translateSHf 0 (negate 3) . rotateSH 0.2 $ aShoulder - ] - | otherwise = mconcat - [ translateSHf 0 3 . rotateSH (negate 0.2) $ aShoulder - , translateSHf 0 (negate 3) . rotateSH 0.2 $ aShoulder - ] +torso cr + | oneH cr = + rotateSH 0.5 $ + mconcat + [ translateSHf 0 3 . rotateSH (negate 0.2) $ aShoulder + , translateSHf 0 (negate 3) . rotateSH 0.2 $ aShoulder + ] + | twists cr = + translateSHf 0 5 . rotateSH (-1) $ + mconcat + [ rotateSH (negate 0.2) . translateSHf 2 3 . rotateSH (negate 0.4) $ aShoulder + , rotateSH (negate 0.2) . translateSHf 0 (negate 3) . rotateSH 0.2 $ aShoulder + ] + | otherwise = + mconcat + [ translateSHf 0 3 . rotateSH (negate 0.2) $ aShoulder + , translateSHf 0 (negate 3) . rotateSH 0.2 $ aShoulder + ] where --aShoulder = translateSHz (-10) . scaleSH (V3 0.5 1 1) . upperPrismPoly 10 $ polyCirc 3 crad aShoulder = scaleSH (V3 10 10 1) baseShoulder @@ -195,17 +216,18 @@ baseShoulder = translateSHz (-10) . scaleSH (V3 0.5 1 1) . upperPrismPolyHalf 10 upperBody :: Creature -> Shape {-# INLINE upperBody #-} --upperBody col cr = colorSH (light4 col) $ mconcat -upperBody cr = mconcat - [ arms cr - , shoulderSH $ torso cr - ] +upperBody cr = + mconcat + [ arms cr + , shoulderSH $ torso cr + ] shoulderSH :: Shape -> Shape shoulderSH = translateSHz 20 + --waistSH :: Shape -> Shape --waistSH = translateSHz 10 - --drawAwakeLevel -- :: Creature -- -> Picture @@ -218,12 +240,13 @@ shoulderSH = translateSHz 20 drawEquipment :: Creature -> SPic {-# INLINE drawEquipment #-} drawEquipment cr = foldMap (itemEquipPict cr) (_crInv cr) + --drawEquipment cr = foldMap f (_crInv cr) --- where +-- where -- f itm = _itEquipPict itm cr itm circLine :: Float -> Picture -circLine x = line [V2 0 0,V2 x 0] +circLine x = line [V2 0 0, V2 x 0] picAtCrPos :: Picture -> Creature -> SPic --{-# INLINE picAtCrPos #-} @@ -232,4 +255,3 @@ picAtCrPos thePic cr = (,) emptySH $ tranRot (_crPos cr) (_crDir cr) thePic picAtCrPosNoRot :: Picture -> Creature -> SPic --{-# INLINE picAtCrPos #-} picAtCrPosNoRot thePic cr = (,) emptySH $ uncurryV translate (_crPos cr) thePic - diff --git a/src/Dodge/Creature/Picture/Awareness.hs b/src/Dodge/Creature/Picture/Awareness.hs index 6c414dfea..293f30edf 100644 --- a/src/Dodge/Creature/Picture/Awareness.hs +++ b/src/Dodge/Creature/Picture/Awareness.hs @@ -1,25 +1,30 @@ module Dodge.Creature.Picture.Awareness where -import Dodge.Data -import Dodge.Clock -import Picture -import Geometry import qualified Data.Vector as V +import Dodge.Clock +import Dodge.Data.World +import Geometry +import Picture creatureDisplayText :: World -> Creature -> Picture -creatureDisplayText w cr = setLayer DebugLayer - . setDepth 20 - . translate x y - . color white - . rotate (0.5 * pi) --- . rotate (argV v - 0.5 * pi) - . scale theScale theScale - . stackText - $ clockCycle 25 (V.fromList - [ \cr' -> [crDisplayVigilance cr'] - , \cr' -> [crDisplayAwareness cr'] - ] - ) w cr +creatureDisplayText w cr = + setLayer DebugLayer + . setDepth 20 + . translate x y + . color white + . rotate (0.5 * pi) + -- . rotate (argV v - 0.5 * pi) + . scale theScale theScale + . stackText + $ clockCycle + 25 + ( V.fromList + [ \cr' -> [crDisplayVigilance cr'] + , \cr' -> [crDisplayAwareness cr'] + ] + ) + w + cr where campos = _cameraViewFrom (_cWorld w) theScale = 0.15 / _cameraZoom (_cWorld w) @@ -30,12 +35,12 @@ creatureDisplayText w cr = setLayer DebugLayer crDisplayAwareness :: Creature -> String crDisplayAwareness cr | isSuspicious = "?" - | isCognizant = "!" - | otherwise = "." + | isCognizant = "!" + | otherwise = "." where imAwarenesses = _cpAwareness (_crPerception cr) isSuspicious = any f imAwarenesses && not (null imAwarenesses) - isCognizant = any g imAwarenesses && not (null imAwarenesses) + isCognizant = any g imAwarenesses && not (null imAwarenesses) f (Suspicious _) = True f _ = False g (Cognizant _) = True diff --git a/src/Dodge/Creature/PistolCrit.hs b/src/Dodge/Creature/PistolCrit.hs index c752183b3..9aa8c25b0 100644 --- a/src/Dodge/Creature/PistolCrit.hs +++ b/src/Dodge/Creature/PistolCrit.hs @@ -1,23 +1,21 @@ -module Dodge.Creature.PistolCrit - ( pistolCrit - ) where -import Dodge.Data +module Dodge.Creature.PistolCrit ( + pistolCrit, +) where + +import Control.Lens +import Dodge.Data.Creature import Dodge.Default -import Dodge.Item.Weapon.BulletGuns import Dodge.Item.Consumable +import Dodge.Item.Held.Stick +import qualified IntMapHelp as IM import Picture -import qualified IntMapHelp as IM -import Control.Lens - pistolCrit :: Creature -pistolCrit = defaultCreature - { _crInv = IM.fromList [(0,pistol),(1,medkit 100)] - , _crRad = 10 - , _crHP = 500 - } - & crType . humanoidAI .~ PistolAI - & crType . skinUpper .~ light4 red - - - +pistolCrit = + defaultCreature + { _crInv = IM.fromList [(0, pistol), (1, medkit 100)] + , _crRad = 10 + , _crHP = 500 + } + & crType . humanoidAI .~ PistolAI + & crType . skinUpper .~ light4 red diff --git a/src/Dodge/Creature/ReaderUpdate.hs b/src/Dodge/Creature/ReaderUpdate.hs index ee866d016..512f0b01c 100644 --- a/src/Dodge/Creature/ReaderUpdate.hs +++ b/src/Dodge/Creature/ReaderUpdate.hs @@ -1,31 +1,32 @@ -{- | Functions updating a creature in a Reader World environment -} -module Dodge.Creature.ReaderUpdate - ( doStrategyActions - , setTargetMv - , targetYouWhenCognizant - , overrideMeleeCloseTarget - , watchUpdateStrat - , reloadOverride - , overrideInternal - , searchIfDamaged - , goToTarget - , flockACC - , chaseCritMv - , setMvPos - , setViewPos - ) where +-- | Functions updating a creature in a Reader World environment +module Dodge.Creature.ReaderUpdate ( + doStrategyActions, + setTargetMv, + targetYouWhenCognizant, + overrideMeleeCloseTarget, + watchUpdateStrat, + reloadOverride, + overrideInternal, + searchIfDamaged, + goToTarget, + flockACC, + chaseCritMv, + setMvPos, + setViewPos, +) where + +import Control.Applicative +import Control.Lens +import Data.Bifunctor +import Data.Maybe +import Dodge.Base +import Dodge.Creature.Volition +import Dodge.Data.CreatureEffect +import Dodge.Data.World import Dodge.Zoning.Creature import FoldableHelp -import Dodge.Data -import Dodge.Creature.Volition -import Dodge.Base import Geometry - import qualified IntMapHelp as IM -import Control.Lens -import Control.Applicative -import Data.Maybe -import Data.Bifunctor overrideMeleeCloseTarget :: Creature -> Creature overrideMeleeCloseTarget cr = maybe cr (tryMeleeAttack cr) (_targetCr $ _crIntention cr) @@ -33,9 +34,9 @@ overrideMeleeCloseTarget cr = maybe cr (tryMeleeAttack cr) (_targetCr $ _crInten tryMeleeAttack :: Creature -> Creature -> Creature tryMeleeAttack cr tcr | _crMeleeCooldown cr == 0 - && dist (_crPos tcr) cpos < _crRad cr + _crRad tcr + 5 - && abs (_crDir cr - argV (_crPos tcr -.- cpos)) < pi/4 - = cr & crActionPlan . apImpulse .~ [Melee $ _crID tcr] + && dist (_crPos tcr) cpos < _crRad cr + _crRad tcr + 5 + && abs (_crDir cr - argV (_crPos tcr -.- cpos)) < pi / 4 = + cr & crActionPlan . apImpulse .~ [Melee $ _crID tcr] | otherwise = cr where cpos = _crPos cr @@ -49,8 +50,10 @@ setMvPos w cr = cr & crIntention . mvToPoint .~ mpos if hasLOSIndirect (_crPos cr) tpos w then Just tpos else Nothing - mpos = mtpos - <|> _mvToPoint int + mpos = + mtpos + <|> _mvToPoint int + -- <|> listToMaybe (_soundsToInvestigate $ _crMemory cr) setViewPos :: Creature -> Creature @@ -58,44 +61,54 @@ setViewPos cr = cr & crIntention . viewPoint %~ (<|> mpos) where mpos = listToMaybe (_soundsToInvestigate $ _crMemory cr) -setTargetMv :: (World -> Creature -> Maybe Creature) -- ^ Function for determining target - -> World -> Creature -> Creature -setTargetMv targFunc w cr = maybe - cr - (\ctarg -> cr & crIntention . mvToPoint ?~ _crPos ctarg) - (targFunc w cr) +setTargetMv :: + -- | Function for determining target + (World -> Creature -> Maybe Creature) -> + World -> + Creature -> + Creature +setTargetMv targFunc w cr = + maybe + cr + (\ctarg -> cr & crIntention . mvToPoint ?~ _crPos ctarg) + (targFunc w cr) -- ugly flockACC :: World -> Creature -> Creature flockACC w cr = case cr ^? crIntention . targetCr . _Just of Nothing -> cr - Just tcr -> + Just tcr -> let tpos = _crPos tcr cpos = _crPos cr - isFarACC cr' = _crGroup cr' == _crGroup cr - && _crID cr' /= _crID cr - && dist (_crPos cr') tpos > dist cpos tpos - macr = safeMinimumOn (dist cpos . _crPos) - . filter isFarACC - $ crsNearCirc cpos 50 w - in case macr of - Nothing -> cr + isFarACC cr' = + _crGroup cr' == _crGroup cr + && _crID cr' /= _crID cr + && dist (_crPos cr') tpos > dist cpos tpos + macr = + safeMinimumOn (dist cpos . _crPos) + . filter isFarACC + $ crsNearCirc cpos 50 w + in case macr of + Nothing -> cr Just acr -> let r = _crRad acr + _crRad cr + 10 horDir = normalizeV (vNormal (cpos -.- tpos)) - horShift = if isLHS tpos cpos (_crPos acr) - then r *.* horDir - else negate r *.* horDir - in cr & crIntention . mvToPoint ?~ tpos +.+ horShift + horShift = + if isLHS tpos cpos (_crPos acr) + then r *.* horDir + else negate r *.* horDir + in cr & crIntention . mvToPoint ?~ tpos +.+ horShift chaseCritMv :: World -> Creature -> Creature chaseCritMv w cr = case _apStrategy (_crActionPlan cr) of StrategyActions _ _ -> cr WarningCry -> cr _ -> case cr ^? crIntention . mvToPoint . _Just of - Just p | dist (_crPos cr) p > _crRad cr -> cr & crActionPlan . apAction .~ [PathTo p] - | otherwise -> cr & crActionPlan . apAction .~ [bfsThenReturn 500] - & crIntention . mvToPoint .~ Nothing + Just p + | dist (_crPos cr) p > _crRad cr -> cr & crActionPlan . apAction .~ [PathTo p] + | otherwise -> + cr & crActionPlan . apAction .~ [bfsThenReturn 500] + & crIntention . mvToPoint .~ Nothing _ -> viewTarget w cr goToTarget :: World -> Creature -> Creature @@ -105,45 +118,51 @@ goToTarget w cr = _ -> viewTarget w cr lookAroundSelf :: Action -lookAroundSelf = UseSelf CrTurnAround -- $ \cr -> TurnToPoint (_crPos cr -.- 10 *.* unitVectorAtAngle (_crDir cr)) +lookAroundSelf = UseSelf CrTurnAround viewTarget :: World -> Creature -> Creature viewTarget w cr = do case cr ^? crIntention . viewPoint . _Just of - Just p | hasLOSIndirect p (_crPos cr) w -> cr' - & crActionPlan . apAction %~ replaceNullWith - (TurnToPoint p - `DoActionThen` 40 `WaitThen` lookAroundSelf - `DoActionThen` 20 `WaitThen` lookAroundSelf - ) + Just p + | hasLOSIndirect p (_crPos cr) w -> + cr' + & crActionPlan . apAction + %~ replaceNullWith + ( TurnToPoint p + `DoActionThen` 40 `WaitThen` lookAroundSelf + `DoActionThen` 20 `WaitThen` lookAroundSelf + ) & crIntention . viewPoint .~ Nothing - | otherwise -> cr' & crActionPlan . apAction %~ replaceNullWith (PathTo p) - Nothing -> cr-- & crPerception . crAwakeLevel .~ Lethargic + | otherwise -> cr' & crActionPlan . apAction %~ replaceNullWith (PathTo p) + Nothing -> cr -- & crPerception . crAwakeLevel .~ Lethargic where cr' = cr & crPerception . cpVigilance .~ Vigilant replaceNullWith :: a -> [a] -> [a] replaceNullWith x [] = [x] replaceNullWith _ xs = xs - + doStrategyActions :: Creature -> Creature doStrategyActions cr = case cr ^? crActionPlan . apStrategy of - Just (StrategyActions strat acs) -> cr - & crActionPlan . apAction .~ acs - & crActionPlan . apStrategy .~ strat + Just (StrategyActions strat acs) -> + cr + & crActionPlan . apAction .~ acs + & crActionPlan . apStrategy .~ strat _ -> cr reloadOverride :: Creature -> Creature reloadOverride cr - | cr ^? crInv . ix (crSel cr) . itUse . heldConsumption . laLoaded == Just 0 - && cr ^. crStance . posture == Aiming - = cr & crActionPlan . apStrategy .~ StrategyActions Reload reloadActions + | cr ^? crInv . ix (crSel cr) . itUse . heldConsumption . laLoaded == Just 0 + && cr ^. crStance . posture == Aiming = + cr & crActionPlan . apStrategy .~ StrategyActions Reload reloadActions | otherwise = cr where - reloadActions = + reloadActions = [ holsterWeapon - , 1 `WaitThen` - DoActionWhileInterrupt NoAction (WdCrBlfromCrBl CrIsReloading) + , 1 + `WaitThen` DoActionWhileInterrupt + NoAction + (WdCrBlfromCrBl CrIsReloading) (DoImpulses [ChangeStrategy WatchAndWait]) ] @@ -152,42 +171,47 @@ overrideInternal test update cr | test cr = update cr | otherwise = cr -watchUpdateStrat - :: [ (World -> Creature -> Bool, World -> Creature -> Strategy) ] - -> World - -> Creature - -> Creature +watchUpdateStrat :: + [(World -> Creature -> Bool, World -> Creature -> Strategy)] -> + World -> + Creature -> + Creature watchUpdateStrat fs w cr = case cr ^? crActionPlan . apStrategy of - Just WatchAndWait -> cr - & crActionPlan . apStrategy .~ listGuard (map (first uncurry) fs, \_ _ -> WatchAndWait) (w, cr) w cr + Just WatchAndWait -> + cr + & crActionPlan . apStrategy .~ listGuard (map (first uncurry) fs, \_ _ -> WatchAndWait) (w, cr) w cr _ -> cr -listGuard :: ([(a -> Bool, b)] , b) -> a -> b -listGuard ( (test,y):ps, z ) x +listGuard :: ([(a -> Bool, b)], b) -> a -> b +listGuard ((test, y) : ps, z) x | test x = y | otherwise = listGuard (ps, z) x -listGuard (_,z) _ = z +listGuard (_, z) _ = z targetYouWhenCognizant :: World -> Creature -> Creature targetYouWhenCognizant w cr = case cr ^? crPerception . cpAwareness . ix 0 of --- so this caused a space leak: be careful with ?~ --- consider changing targeted creature to be just an index - Just (Cognizant _) -> _creatures (_cWorld w) IM.! 0 `seq` cr & crIntention . targetCr ?~ _creatures (_cWorld w) IM.! 0 - _ -> cr & crIntention . targetCr .~ Nothing + -- so this caused a space leak: be careful with ?~ + -- consider changing targeted creature to be just an index + Just (Cognizant _) -> _creatures (_cWorld w) IM.! 0 `seq` cr & crIntention . targetCr ?~ _creatures (_cWorld w) IM.! 0 + _ -> cr & crIntention . targetCr .~ Nothing searchIfDamaged :: Creature -> Creature searchIfDamaged cr | _crPastDamage cr > 0 = case _apStrategy (_crActionPlan cr) of - WatchAndWait -> cr & crPerception . cpVigilance .~ Vigilant - & crActionPlan . apStrategy .~ StrategyActions LookAround - [TurnToPoint (_crPos cr -.- unitVectorAtAngle (_crDir cr)) - `DoActionThen` 40 `WaitThen` bfsThenReturn 500 - ] + WatchAndWait -> + cr & crPerception . cpVigilance .~ Vigilant + & crActionPlan . apStrategy + .~ StrategyActions + LookAround + [ TurnToPoint (_crPos cr -.- unitVectorAtAngle (_crDir cr)) + `DoActionThen` 40 `WaitThen` bfsThenReturn 500 + ] _ -> cr | otherwise = cr bfsThenReturn :: Int -> Action bfsThenReturn t = ArbitraryAction (CrWdBFSThenReturn t) + -- theaction -- where -- theaction cr w = fromMaybe NoAction $ do @@ -195,5 +219,3 @@ bfsThenReturn t = ArbitraryAction (CrWdBFSThenReturn t) -- let as = take 20 $ map PathTo $ bfsNodePoints n w -- return $ DoReplicate t $ -- foldr DoActionThen NoAction as - - diff --git a/src/Dodge/Creature/SentinelAI.hs b/src/Dodge/Creature/SentinelAI.hs index 9fb3c8393..130b4f359 100644 --- a/src/Dodge/Creature/SentinelAI.hs +++ b/src/Dodge/Creature/SentinelAI.hs @@ -1,39 +1,44 @@ -module Dodge.Creature.SentinelAI - ( sentinelAI - , sentinelFireType - , sentinelExtraWatchUpdate - ) where -import Dodge.Data +module Dodge.Creature.SentinelAI ( + sentinelAI, + sentinelFireType, + sentinelExtraWatchUpdate, +) where + +import Control.Lens +import Data.Maybe +import Dodge.Creature.Action import Dodge.Creature.ChainUpdates -import Dodge.Creature.Test -import Dodge.Creature.Volition +import Dodge.Creature.Perception import Dodge.Creature.ReaderUpdate import Dodge.Creature.Strategy -import Dodge.Creature.Action -import Dodge.Creature.Perception +import Dodge.Creature.Test +import Dodge.Creature.Volition +import Dodge.Data.CreatureEffect +import Dodge.Data.World import Geometry.Data -import Data.Maybe -import Control.Lens - sentinelAI :: World -> Creature -> Creature -sentinelAI w = reloadOverride . - sentinelExtraWatchUpdate - [ (crHasTargetLOS - , \ _ cr -> StrategyActions (ShootAt (fromJust $ tcid cr)) - [ DoActionIf - (WdCrNegate $ WdCrBlfromCrBl CrIsAiming) - (drawWeapon `DoActionThen` (50 `WaitThen` NoAction)) - `DoActionThen` lostest - `DoActionWhile` advanceShoot - `DoActionThen` 75 - `DoReplicate` advanceShoot - `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait] - , AimAt { _targetID = fromJust $ tcid cr , _targetSeenAt = V2 0 0 } - ] - ) - ] - w +sentinelAI w = + reloadOverride + . sentinelExtraWatchUpdate + [ + ( crHasTargetLOS + , \_ cr -> + StrategyActions + (ShootAt (fromJust $ tcid cr)) + [ DoActionIf + (WdCrNegate $ WdCrBlfromCrBl CrIsAiming) + (drawWeapon `DoActionThen` (50 `WaitThen` NoAction)) + `DoActionThen` lostest + `DoActionWhile` advanceShoot + `DoActionThen` 75 + `DoReplicate` advanceShoot + `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait] + , AimAt{_targetID = fromJust $ tcid cr, _targetSeenAt = V2 0 0} + ] + ) + ] + w where advanceShoot = DoImpulses [UseItem, MoveForward 3] tcid cr = _crID <$> _targetCr (_crIntention cr) @@ -42,50 +47,58 @@ sentinelAI w = reloadOverride . --chainCreatureUpdates :: [World -> Creature -> Creature] -> World -> Creature -> Creature --chainCreatureUpdates ls w cr = foldr (\f -> f w) cr ls - sentinelFireType :: (Int -> Action) -> World -> Creature -> Creature -sentinelFireType f = chainCreatureUpdates - [ performActions - , watchUpdateStrat - [ (crHasTargetLOS, \_ _ -> StrategyActions (ShootAt 0) - [ drawwp `DoActionThen` f 0 `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait] - , aiming +sentinelFireType f = + chainCreatureUpdates + [ performActions + , watchUpdateStrat + [ + ( crHasTargetLOS + , \_ _ -> + StrategyActions + (ShootAt 0) + [ drawwp `DoActionThen` f 0 `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait] + , aiming + ] + ) + , (const crAwayFromPost, const goToPostStrat) ] - ) - , (const crAwayFromPost, const goToPostStrat) - ] - , perceptionUpdate [0] --- , Left $ perceptionUp 0 - , const doStrategyActions - , const reloadOverride - , targetYouWhenCognizant - , const $ overrideInternal - (\cr -> crHasTarget cr && crStratConMatches (GetTo (V2 0 0)) cr) - (crActionPlan . apStrategy .~ WatchAndWait) - ] + , perceptionUpdate [0] + , -- , Left $ perceptionUp 0 + const doStrategyActions + , const reloadOverride + , targetYouWhenCognizant + , const $ + overrideInternal + (\cr -> crHasTarget cr && crStratConMatches (GetTo (V2 0 0)) cr) + (crActionPlan . apStrategy .~ WatchAndWait) + ] where drawwp = DoActionIfElse NoAction (WdCrBlfromCrBl CrIsAiming) (DoActionThen drawWeapon (WaitThen 50 NoAction)) - aiming = AimAt - { _targetID = 0 - , _targetSeenAt = V2 0 0 -- hack - } + aiming = + AimAt + { _targetID = 0 + , _targetSeenAt = V2 0 0 -- hack + } -sentinelExtraWatchUpdate - :: [(World -> Creature -> Bool , World -> Creature -> Strategy)] - -> World - -> Creature - -> Creature -sentinelExtraWatchUpdate xs = chainCreatureUpdates - [ performActions - , watchUpdateStrat - ( xs ++ [(const crAwayFromPost, const goToPostStrat)] ) - , perceptionUpdate [0] - , const doStrategyActions - , targetYouWhenCognizant - , const $ overrideInternal - (\cr -> crHasTarget cr && crStratConMatches (GetTo (V2 0 0)) cr) - (crActionPlan . apStrategy .~ WatchAndWait) - ] +sentinelExtraWatchUpdate :: + [(World -> Creature -> Bool, World -> Creature -> Strategy)] -> + World -> + Creature -> + Creature +sentinelExtraWatchUpdate xs = + chainCreatureUpdates + [ performActions + , watchUpdateStrat + (xs ++ [(const crAwayFromPost, const goToPostStrat)]) + , perceptionUpdate [0] + , const doStrategyActions + , targetYouWhenCognizant + , const $ + overrideInternal + (\cr -> crHasTarget cr && crStratConMatches (GetTo (V2 0 0)) cr) + (crActionPlan . apStrategy .~ WatchAndWait) + ] --shootAtAdvance :: Int -> [Action] --shootAtAdvance tcid = @@ -93,7 +106,7 @@ sentinelExtraWatchUpdate xs = chainCreatureUpdates -- `DoActionThen` -- lostest `DoActionWhile` -- advanceShoot `DoActionThen` --- 75 `DoReplicate` +-- 75 `DoReplicate` -- advanceShoot `DoActionThen` -- DoImpulses [ChangeStrategy WatchAndWait] -- , AimAt @@ -102,7 +115,7 @@ sentinelExtraWatchUpdate xs = chainCreatureUpdates -- } -- ] -- where --- lostest (w,cr') = canSee (_crID cr') tcid w +-- lostest (w,cr') = canSee (_crID cr') tcid w -- advanceShoot = ImpulsesList [[UseItem, MoveForward 3]] -- --shootAtWhileContinueTime :: Int -> World -> Creature -> Strategy @@ -111,7 +124,7 @@ sentinelExtraWatchUpdate xs = chainCreatureUpdates -- `DoActionThen` -- lostest `DoActionWhile` -- advanceShoot `DoActionThen` --- 75 `DoReplicate` +-- 75 `DoReplicate` -- advanceShoot `DoActionThen` -- DoImpulses [ChangeStrategy WatchAndWait] -- , AimAt @@ -120,5 +133,5 @@ sentinelExtraWatchUpdate xs = chainCreatureUpdates -- } -- ] -- where --- lostest (w,cr') = canSee (_crID cr') tcid w +-- lostest (w,cr') = canSee (_crID cr') tcid w -- advanceShoot = ImpulsesList [[UseItem, MoveForward 3]] diff --git a/src/Dodge/Creature/SetTarget.hs b/src/Dodge/Creature/SetTarget.hs index efb4d933d..a2ffe4344 100644 --- a/src/Dodge/Creature/SetTarget.hs +++ b/src/Dodge/Creature/SetTarget.hs @@ -1,15 +1,15 @@ -{- | Deals with setting a target for creatures -} +-- | Deals with setting a target for creatures module Dodge.Creature.SetTarget where -import Dodge.Data import Control.Lens +import Dodge.Data.World import qualified IntMapHelp as IM -{- | Assumes that you are id 0: if creature is cognizant of you, sets you as target -} -targetYouWhenCognizant - :: World - -> Creature - -> Creature -targetYouWhenCognizant w cr = case cr ^? crPerception . cpAwareness . ix 0 of - Just (Cognizant _) -> cr & crIntention . targetCr ?~ _creatures (_cWorld w) IM.! 0 - _ -> cr & crIntention . targetCr .~ Nothing +-- | Assumes that you are id 0: if creature is cognizant of you, sets you as target +targetYouWhenCognizant :: + World -> + Creature -> + Creature +targetYouWhenCognizant w cr = case cr ^? crPerception . cpAwareness . ix 0 of + Just (Cognizant _) -> cr & crIntention . targetCr ?~ _creatures (_cWorld w) IM.! 0 + _ -> cr & crIntention . targetCr .~ Nothing diff --git a/src/Dodge/Creature/SpreadGunCrit.hs b/src/Dodge/Creature/SpreadGunCrit.hs index 0cf0479d0..113924e8f 100644 --- a/src/Dodge/Creature/SpreadGunCrit.hs +++ b/src/Dodge/Creature/SpreadGunCrit.hs @@ -1,21 +1,21 @@ -module Dodge.Creature.SpreadGunCrit - ( spreadGunCrit - ) where -import Dodge.Data +module Dodge.Creature.SpreadGunCrit ( + spreadGunCrit, +) where + +import Control.Lens +import Dodge.Data.Creature import Dodge.Default -import Dodge.Item.Weapon.BulletGuns import Dodge.Item.Consumable +import Dodge.Item.Held.Stick +import qualified IntMapHelp as IM import Picture -import qualified IntMapHelp as IM -import Control.Lens - spreadGunCrit :: Creature -spreadGunCrit = defaultCreature - { _crInv = IM.fromList [(0,bangStick 6),(1,medkit 100)] - , _crRad = 10 - , _crHP = 500 - } - & crType . humanoidAI .~ SpreadGunAI - & crType . skinUpper .~ light4 red - +spreadGunCrit = + defaultCreature + { _crInv = IM.fromList [(0, bangStick 6), (1, medkit 100)] + , _crRad = 10 + , _crHP = 500 + } + & crType . humanoidAI .~ SpreadGunAI + & crType . skinUpper .~ light4 red diff --git a/src/Dodge/Creature/State.hs b/src/Dodge/Creature/State.hs index 662e9e0cd..cd7615e50 100644 --- a/src/Dodge/Creature/State.hs +++ b/src/Dodge/Creature/State.hs @@ -1,124 +1,143 @@ -module Dodge.Creature.State - ( stateUpdate - , doDamage - ) where -import Dodge.Corpse.Make -import Dodge.Data -import Dodge.Targeting -import Dodge.ItEffect -import Dodge.Euse -import Dodge.EnergyBall -import Dodge.Damage -import Dodge.Hammer -import Dodge.Reloading -import Dodge.Prop.Gib +module Dodge.Creature.State ( + stateUpdate, + doDamage, +) where + import Dodge.Base -import Dodge.Creature.State.WalkCycle -import Dodge.Creature.Impulse.Movement -import Dodge.Creature.Damage -import Dodge.LightSource.Torch -import Dodge.SoundLogic -import RandomHelp +import Dodge.Corpse.Make import Dodge.Creature.Action +import Dodge.Creature.Damage +import Dodge.Creature.Impulse.Movement +import Dodge.Creature.State.WalkCycle +import Dodge.Damage +import Dodge.Data.World +import Dodge.EnergyBall +import Dodge.Euse +import Dodge.Hammer +import Dodge.ItEffect +import Dodge.LightSource.Torch +import Dodge.Prop.Gib +import Dodge.Reloading +import Dodge.SoundLogic +import Dodge.Targeting import Geometry -import Picture -import Shape -import ShapePicture import qualified IntMapHelp as IM import LensHelp +import Picture +import RandomHelp +import Shape +import ShapePicture -foldCr :: [Creature -> World -> World] - -> Creature -> World -> World +foldCr :: + [Creature -> World -> World] -> + Creature -> + World -> + World --foldCr xs cr w = foldr ($ cr) w xs foldCr xs cr w = foldr f w xs where f g w' = case w' ^? cWorld . creatures . ix (_crID cr) of Just cr' -> g cr' w' - Nothing -> w' + Nothing -> w' --- | this seems to work, but I am not sure about the ordering: --- previously, the movement was updated before the ai in order to correctly set the oldpos. --- This should be made more sensible: should the movement side effects apply to --- the creature before or after it has moved? --- at what point invSideEffects is applied wrt to when the creature moves --- may affect whether the shield moves correctly +{- | this seems to work, but I am not sure about the ordering: + previously, the movement was updated before the ai in order to correctly set the oldpos. + This should be made more sensible: should the movement side effects apply to + the creature before or after it has moved? + at what point invSideEffects is applied wrt to when the creature moves + may affect whether the shield moves correctly +-} stateUpdate :: (Creature -> World -> World) -> Creature -> World -> World -stateUpdate f = foldCr - [ equipmentEffects - , invSideEff - , upInv -- upInv must be called before invSideEff 22.05.23 - , movementSideEff - , f - , internalUpdate - , clearDamage -- these three - , checkDeath -- must be in - , doDamage -- this order 22/06/05 - ] +stateUpdate f = + foldCr + [ equipmentEffects + , invSideEff + , upInv -- upInv must be called before invSideEff 22.05.23 + , movementSideEff + , f + , internalUpdate + , clearDamage -- these three + , checkDeath -- must be in + , doDamage -- this order 22/06/05 + ] checkDeath :: Creature -> World -> World checkDeath cr w | _crHP cr > 0 = w - | otherwise = w --- & creatures . at (_crID cr) .~ Nothing - & dropByState cr - & removecr - & stopSoundFrom (CrWeaponSound (_crID cr) 0) - & corpseOrGib cr + | otherwise = + w + -- & creatures . at (_crID cr) .~ Nothing + & dropByState cr + & removecr + & stopSoundFrom (CrWeaponSound (_crID cr) 0) + & corpseOrGib cr where removecr - | _crID cr == 0 = (cWorld . creatures . ix (_crID cr) . crType .~ NonDrawnCreature) - . (cWorld . creatures . ix (_crID cr) . crHP .~ 0) - -- hack to get around player creature being killed but left with more than 0 hp - | otherwise = cWorld . creatures . at (_crID cr) .~ Nothing + | _crID cr == 0 = + (cWorld . creatures . ix (_crID cr) . crType .~ NonDrawnCreature) + . (cWorld . creatures . ix (_crID cr) . crHP .~ 0) + -- hack to get around player creature being killed but left with more than 0 hp + | otherwise = cWorld . creatures . at (_crID cr) .~ Nothing + corpseOrGib :: Creature -> World -> World corpseOrGib cr w = case maxDamageType (_csDamage (_crState cr)) of - Just (FLAMING,_) -> w & plNew (cWorld . corpses) cpID (thecorpse & cpSPic %~ scorchSPic) - Just (ELECTRICAL,_) -> w & plNew (cWorld . corpses) cpID thecorpse - Just (POISONDAM,_) -> w & plNew (cWorld . corpses) cpID (thecorpse & cpSPic %~ poisonSPic) - _ | _crPastDamage cr > 200 -> w & addCrGibs cr - & bloodPuddleAt cpos - & bloodPuddleAt cpos - & bloodPuddleAt cpos - _ -> w - & bloodPuddleAt cpos - & bloodPuddleAt cpos - & plNew (cWorld . corpses) cpID thecorpse + Just (FLAMING, _) -> w & plNew (cWorld . corpses) cpID (thecorpse & cpSPic %~ scorchSPic) + Just (ELECTRICAL, _) -> w & plNew (cWorld . corpses) cpID thecorpse + Just (POISONDAM, _) -> w & plNew (cWorld . corpses) cpID (thecorpse & cpSPic %~ poisonSPic) + _ + | _crPastDamage cr > 200 -> + w & addCrGibs cr + & bloodPuddleAt cpos + & bloodPuddleAt cpos + & bloodPuddleAt cpos + _ -> + w + & bloodPuddleAt cpos + & bloodPuddleAt cpos + & plNew (cWorld . corpses) cpID thecorpse where cpos = _crPos cr thecorpse = makeDefaultCorpse cr scorchSPic :: SPic -> SPic -scorchSPic = over _1 $ - overColSH (mixColors 0.9 0.1 black . normalizeColor) +scorchSPic = + over _1 $ + overColSH (mixColors 0.9 0.1 black . normalizeColor) poisonSPic :: SPic -> SPic -poisonSPic = over _1 $ - overColSH (mixColors 0.5 0.5 green . normalizeColor) +poisonSPic = + over _1 $ + overColSH (mixColors 0.5 0.5 green . normalizeColor) --scorchSPic :: World -> SPic -> SPic --scorchSPic w sp = evalState (scorchSPic' sp) (_randGen w) -- --scorchSPic' :: SPic -> State StdGen SPic --scorchSPic' = _1 $ overColSHM $ \col -> takeOne [col,black] ----- (return . mixColorsLinear 0.9 0.1 black) +---- (return . mixColorsLinear 0.9 0.1 black) bloodPuddleAt :: Point2 -> World -> World -bloodPuddleAt p w = w - & snd . plNewID (cWorld . decorations) - (color (dark $ dark red) . setDepth 01 . uncurryV translate (p +.+ q) $ circleSolid 10) - & randGen .~ g +bloodPuddleAt p w = + w + & snd + . plNewID + (cWorld . decorations) + (color (dark $ dark red) . setDepth 01 . uncurryV translate (p +.+ q) $ circleSolid 10) + & randGen .~ g where - (q,g) = randInCirc 10 & runState $ _randGen w + (q, g) = randInCirc 10 & runState $ _randGen w internalUpdate :: Creature -> World -> World -internalUpdate cr = cWorld . creatures . ix (_crID cr) %~ - ( (crHammerPosition %~ moveHammerUp) - . stepReloading - . updateMovement - ) +internalUpdate cr = + cWorld . creatures . ix (_crID cr) + %~ ( (crHammerPosition %~ moveHammerUp) + . stepReloading + . updateMovement + ) --- | Drop items according to the creature state. --- TODO make sure this doesn't mess up any ItemPosition +{- | Drop items according to the creature state. + TODO make sure this doesn't mess up any ItemPosition +-} dropByState :: Creature -> World -> World dropByState cr w = foldr (dropItem cr) w $ case cr ^. crState . csDropsOnDeath of DropAll -> IM.keys $ _crInv cr @@ -126,79 +145,91 @@ dropByState cr w = foldr (dropItem cr) w $ case cr ^. crState . csDropsOnDeath o DropAmount n -> take n $ evalState (shuffle $ IM.keys $ _crInv cr) (_randGen w) clearDamage :: Creature -> World -> World -clearDamage cr w = w - & cWorld . creatures . ix (_crID cr) . crState . csDamage .~ [] +clearDamage cr w = + w + & cWorld . creatures . ix (_crID cr) . crState . csDamage .~ [] doDamage :: Creature -> World -> World -doDamage cr w = w - & applyPastDamages cr - & applyCreatureDamage dams cr - where +doDamage cr w = + w + & applyPastDamages cr + & applyCreatureDamage dams cr + where dams = _csDamage $ _crState cr -- TODO generalise shake to arbitrary damage amounts applyPastDamages :: Creature -> World -> World applyPastDamages cr w - | _crPastDamage cr > 200 = let (p,g) = runState (randInCirc 3) (_randGen w) - in w & cWorld . creatures . ix (_crID cr) %~ (crMvBy p . (crPastDamage -~ 100)) - & randGen .~ g - | _crPastDamage cr > 20 = let (p,g) = runState (randInCirc 2) (_randGen w) - in w & cWorld . creatures . ix (_crID cr) %~ (crMvBy p . (crPastDamage -~ 10)) - & randGen .~ g - | _crPastDamage cr > 0 = let (p,g) = runState (randInCirc 1) (_randGen w) - in w & cWorld . creatures . ix (_crID cr) %~ (crMvBy p . (crPastDamage -~ 1)) - & randGen .~ g + | _crPastDamage cr > 200 = + let (p, g) = runState (randInCirc 3) (_randGen w) + in w & cWorld . creatures . ix (_crID cr) %~ (crMvBy p . (crPastDamage -~ 100)) + & randGen .~ g + | _crPastDamage cr > 20 = + let (p, g) = runState (randInCirc 2) (_randGen w) + in w & cWorld . creatures . ix (_crID cr) %~ (crMvBy p . (crPastDamage -~ 10)) + & randGen .~ g + | _crPastDamage cr > 0 = + let (p, g) = runState (randInCirc 1) (_randGen w) + in w & cWorld . creatures . ix (_crID cr) %~ (crMvBy p . (crPastDamage -~ 1)) + & randGen .~ g | otherwise = w movementSideEff :: Creature -> World -> World movementSideEff cr w | hasJetPack = case cr ^? crStance . carriage of - Just (Boosting v) -> w - & randGen .~ g - & makeFlamelet - (oldPos +.+ (_crRad cr + 3) *.* unitVectorAtAngle (_crDir cr + pi)) - 20 - (momentum +.+ 1 *.* rotateV randDir (vInverse v)) - 1 - 20 - _ -> w + Just (Boosting v) -> + w + & randGen .~ g + & makeFlamelet + (oldPos +.+ (_crRad cr + 3) *.* unitVectorAtAngle (_crDir cr + pi)) + 20 + (momentum +.+ 1 *.* rotateV randDir (vInverse v)) + 1 + 20 + _ -> w | otherwise = footstepSideEffect cr w - where + where hasJetPack = any (\it -> it ^? itType . iyBase == Just (EQUIP JETPACK)) $ _crInv cr oldPos = _crOldPos cr momentum' = 0.97 *.* (_crPos cr -.- _crOldPos cr) - momentum'' | magV momentum' > 3 = 3 *.* normalizeV momentum' - | otherwise = momentum' + momentum'' + | magV momentum' > 3 = 3 *.* normalizeV momentum' + | otherwise = momentum' momentum = momentum'' +.+ 0.01 *.* unitVectorAtAngle randAng - (randDir,g) = randomR (-0.5,0.5) $ _randGen w - (randAng,_) = randomR (0,2*pi) $ _randGen w + (randDir, g) = randomR (-0.5, 0.5) $ _randGen w + (randAng, _) = randomR (0, 2 * pi) $ _randGen w useUpdate :: ItemUse -> ItemUse -useUpdate = (useHammer %~ moveHammerUp) - . (useDelay . warmTime %~ decreaseToZero) - . (useDelay . rateTime %~ decreaseToZero) +useUpdate = + (heldHammer %~ moveHammerUp) + . (heldDelay . warmTime %~ decreaseToZero) + . (heldDelay . rateTime %~ decreaseToZero) useEquipment :: Creature -> Int -> World -> World -useEquipment cr i = useE (_eqUse (_eqEq $ _itUse itm)) itm cr +useEquipment cr i = useE (_eeUse (_equipEffect $ _itUse itm)) itm cr where itm = _crInv cr IM.! i + -- a map updating all inventory items upInv :: Creature -> World -> World upInv cr = cWorld . creatures . ix (_crID cr) . crInv %~ IM.mapWithKey (itemUpdate cr) + -- a loop going over equipped items equipmentEffects :: Creature -> World -> World equipmentEffects cr = flip (foldr $ useEquipment cr) (IM.keys $ _crInvEquipped cr) + -- a loop going over all inventory items invSideEff :: Creature -> World -> World invSideEff cr w = weaponReloadSounds cr $ IM.foldrWithKey f w (_crInv cr) - where - f i it w' = itemInvSideEffect cr it - $ doItemTargeting i cr w' & maybe id (\g -> doInvEffect g it cr) (it ^? itEffect . ieInv) + where + f i it w' = + itemInvSideEffect cr it $ + doItemTargeting i cr w' & maybe id (\g -> doInvEffect g it cr) (it ^? itEffect . ieInv) itemInvSideEffect :: Creature -> Item -> World -> World itemInvSideEffect cr it | hastorchattach = createAttachLight cr it - | otherwise = id + | otherwise = id where hastorchattach = it ^? itType . iyModules . ix ModHeldAttach == Just ATTACHTORCH && _itIsHeld it @@ -210,57 +241,68 @@ createAttachLight cr it = createTorchLightOffset cr it attachoff itemUpdate :: Creature -> Int -> Item -> Item itemUpdate cr i | i == crSel cr = baseupdate True - | otherwise = baseupdate False + | otherwise = baseupdate False where - baseupdate bool = updateAutoRecharge . (itUse %~ useUpdate) - . (itLocation .~ InInv (_crID cr) i) - . (itIsHeld .~ bool) + baseupdate bool = + updateAutoRecharge . (itUse %~ useUpdate) + . (itLocation .~ InInv (_crID cr) i) + . (itIsHeld .~ bool) + updateAutoRecharge :: Item -> Item updateAutoRecharge it = case it ^? itUse . leftConsumption of Just (AutoRecharging l m t p) - | l < m && p <= 0 -> it & itUse . leftConsumption .~ AutoRecharging (l+1) m t t + | l < m && p <= 0 -> it & itUse . leftConsumption .~ AutoRecharging (l + 1) m t t | l < m -> it & itUse . leftConsumption . arProgress -~ 1 _ -> it + doItemTargeting :: Int -> Creature -> World -> World doItemTargeting invid cr w = case cr ^? crInv . ix invid . itTargeting of Nothing -> w Just NoTargeting -> w - Just t -> let (w',t') = updateTargeting (_tgUpdate t) (_crInv cr IM.! invid) cr w t - in w' & cWorld . creatures . ix (_crID cr) . crInv . ix invid . itTargeting .~ t' + Just t -> + let (w', t') = updateTargeting (_tgUpdate t) (_crInv cr IM.! invid) cr w t + in w' & cWorld . creatures . ix (_crID cr) . crInv . ix invid . itTargeting .~ t' weaponReloadSounds :: Creature -> World -> World weaponReloadSounds cr w = case cr ^? crInvSel . iselAction of - Just ReloadAction{_reloadAction = la} -> soundContinue - (CrReloadSound cid) (_crPos cr) (_actionSound la) (Just 1) w + Just ReloadAction{_reloadAction = la} -> + soundContinue + (CrReloadSound cid) + (_crPos cr) + (_actionSound la) + (Just 1) + w _ -> w --- PassiveReload stype | Just (_laReloadTime am) == am ^? laTransfer . transferTime --- -> soundContinue (CrReloadSound 0) (_crPos cr) stype Nothing w --- PassiveReload _ -> w --- ActiveClear | am ^? laTransfer . transferTime == Just 0 -> stopSoundFrom (CrReloadSound cid) w --- ActiveClear | _laTransfer am == NoTransfer -> w --- ActiveClear -> soundContinue (CrReloadSound cid) (_crPos cr) reloadS (Just 1) w --- ActivePartial{} | am ^? laTransfer . transferTime == Just 0 -> stopSoundFrom (CrReloadSound cid) w --- ActivePartial{} | _laTransfer am == NoTransfer -> w --- ActivePartial{} -> soundContinue (CrReloadSound cid) (_crPos cr) reloadS (Just 1) w --- Just ChargeableAmmo {} -> w --- Just NoConsumption {} -> w --- Just ItemItselfConsumable {} -> w --- Nothing -> w - where + where + -- PassiveReload stype | Just (_laReloadTime am) == am ^? laTransfer . transferTime + -- -> soundContinue (CrReloadSound 0) (_crPos cr) stype Nothing w + -- PassiveReload _ -> w + -- ActiveClear | am ^? laTransfer . transferTime == Just 0 -> stopSoundFrom (CrReloadSound cid) w + -- ActiveClear | _laTransfer am == NoTransfer -> w + -- ActiveClear -> soundContinue (CrReloadSound cid) (_crPos cr) reloadS (Just 1) w + -- ActivePartial{} | am ^? laTransfer . transferTime == Just 0 -> stopSoundFrom (CrReloadSound cid) w + -- ActivePartial{} | _laTransfer am == NoTransfer -> w + -- ActivePartial{} -> soundContinue (CrReloadSound cid) (_crPos cr) reloadS (Just 1) w + -- Just ChargeableAmmo {} -> w + -- Just NoConsumption {} -> w + -- Just ItemItselfConsumable {} -> w + -- Nothing -> w + cid = _crID cr updateMovement :: Creature -> Creature -updateMovement cr +updateMovement cr | isFrictionless cr = over crPos (+.+ momentum) cr | otherwise = updateWalkCycle cr where momentum' = 0.98 *.* (_crPos cr -.- _crOldPos cr) - momentum'' | magV momentum' > 1 = 1 *.* normalizeV momentum' - | otherwise = momentum' + momentum'' + | magV momentum' > 1 = 1 *.* normalizeV momentum' + | otherwise = momentum' momentum = momentum'' isFrictionless :: Creature -> Bool isFrictionless cr = case cr ^? crStance . carriage of Just (Boosting _) -> True - Just Floating -> True - _ -> False + Just Floating -> True + _ -> False diff --git a/src/Dodge/Creature/State/WalkCycle.hs b/src/Dodge/Creature/State/WalkCycle.hs index b078d99a8..b94d4cc16 100644 --- a/src/Dodge/Creature/State/WalkCycle.hs +++ b/src/Dodge/Creature/State/WalkCycle.hs @@ -1,15 +1,14 @@ -module Dodge.Creature.State.WalkCycle - ( updateWalkCycle - , footstepSideEffect - ) - where -import Dodge.Data +module Dodge.Creature.State.WalkCycle ( + updateWalkCycle, + footstepSideEffect, +) where + +import Control.Lens +import Dodge.Data.World import Dodge.SoundLogic import Geometry.Data import Sound.Data -import Control.Lens - updateWalkCycle :: Creature -> Creature updateWalkCycle cr = case cr ^? crStance . carriage of Just (Walking x ff) | x > maxStride -> cr & crStance . carriage .~ Walking 0 (normalGait ff) @@ -35,7 +34,7 @@ makeFootstepSound currentStride maxStride ff p | currentStride > maxStride = soundMultiFrom footor p (chooseFootSound ff) Nothing | otherwise = id where - footor = [FootstepSound 0,FootstepSound 1] + footor = [FootstepSound 0, FootstepSound 1] chooseFootSound :: FootForward -> SoundID chooseFootSound LeftForward = foot1S diff --git a/src/Dodge/Creature/Statistics.hs b/src/Dodge/Creature/Statistics.hs index de1cd82b8..aca7e130f 100644 --- a/src/Dodge/Creature/Statistics.hs +++ b/src/Dodge/Creature/Statistics.hs @@ -3,11 +3,10 @@ module Dodge.Creature.Statistics ( getCrDexterity, ) where ---import Data.Strict.IntMap.Autogen.Merge.Strict import Data.IntMap.Merge.Strict import Data.Maybe import Dodge.Creature.Test -import Dodge.Data +import Dodge.Data.Creature import qualified IntMapHelp as IM import LensHelp @@ -38,5 +37,5 @@ crCurrentEquipment cr = strFromHeldItem :: Creature -> Int strFromHeldItem cr | _posture (_crStance cr) == Aiming || crIsReloading cr = - negate $ fromMaybe 0 $ cr ^? crInv . ix (crSel cr) . itUse . useAim . aimWeight + negate $ fromMaybe 0 $ cr ^? crInv . ix (crSel cr) . itUse . heldAim . aimWeight | otherwise = 0 diff --git a/src/Dodge/Creature/Strategy.hs b/src/Dodge/Creature/Strategy.hs index 846a638db..448067452 100644 --- a/src/Dodge/Creature/Strategy.hs +++ b/src/Dodge/Creature/Strategy.hs @@ -1,25 +1,27 @@ -module Dodge.Creature.Strategy - ( goToPostStrat - ) - where -import Dodge.Data -import Dodge.Creature.Test -import Dodge.Creature.Volition +module Dodge.Creature.Strategy ( + goToPostStrat, +) where import Data.List +import Dodge.Creature.Test +import Dodge.Creature.Volition +import Dodge.Data.Creature goToPostStrat :: Creature -> Strategy goToPostStrat cr = case find sentinelGoal $ _apGoal $ _crActionPlan cr of - Just (SentinelAt p _) -> StrategyActions (GetTo p) - [DoActionThen (WaitThen 150 holsterIfAiming) - $ DoActionThen (PathTo p) - NoAction - -- $ DoImpulses [ChangeStrategy WatchAndWait] - ] + Just (SentinelAt p _) -> + StrategyActions + (GetTo p) + [ DoActionThen (WaitThen 150 holsterIfAiming) $ + DoActionThen + (PathTo p) + NoAction + -- $ DoImpulses [ChangeStrategy WatchAndWait] + ] _ -> WatchAndWait where sentinelGoal (SentinelAt _ _) = True sentinelGoal _ = False - holsterIfAiming + holsterIfAiming | crIsAiming cr = holsterWeapon - | otherwise = NoAction + | otherwise = NoAction diff --git a/src/Dodge/Creature/SwarmCrit.hs b/src/Dodge/Creature/SwarmCrit.hs index 4de2158a0..8175c5d1a 100644 --- a/src/Dodge/Creature/SwarmCrit.hs +++ b/src/Dodge/Creature/SwarmCrit.hs @@ -1,29 +1,28 @@ -module Dodge.Creature.SwarmCrit - ( swarmCrit - ) where -import Dodge.Data +module Dodge.Creature.SwarmCrit ( + swarmCrit, +) where + +import Control.Lens +import Dodge.Data.Creature import Dodge.Default import Picture -import Control.Lens - swarmCrit :: Creature -swarmCrit = defaultCreature - { _crHP = 1 - , _crRad = 2 - , _crMass = 2 - , _crCorpse = MakeDefaultCorpse - , _crFaction = ColorFaction yellow - , _crMeleeCooldown = 0 - } - & crType . skinUpper .~ light4 yellow - & crType . humanoidAI .~ SwarmAI +swarmCrit = + defaultCreature + { _crHP = 1 + , _crRad = 2 + , _crMass = 2 + , _crCorpse = MakeDefaultCorpse + , _crFaction = ColorFaction yellow + , _crMeleeCooldown = 0 + } + & crType . skinUpper .~ light4 yellow + & crType . humanoidAI .~ SwarmAI --swarmCritMoveFunc :: Creature -> Point2 -> Creature -> Point2 ---swarmCritMoveFunc tcr cenp cr --- | targBehindCrit +--swarmCritMoveFunc tcr cenp cr +-- | targBehindCrit -- where -- cpos = _crPos cr -- ypos = _crPos tcr - - diff --git a/src/Dodge/Creature/Test.hs b/src/Dodge/Creature/Test.hs index 67ecc5cec..132194082 100644 --- a/src/Dodge/Creature/Test.hs +++ b/src/Dodge/Creature/Test.hs @@ -1,42 +1,39 @@ {- | Module testing for properties of creatures, whether they are reloading, etc. Each function takes a creature, and possibly other parameters, and returns a bool. -Note that if there is a world parameter, -the creature NEED NOT be the same as the creature with that id in the world, +Note that if there is a world parameter, +the creature NEED NOT be the same as the creature with that id in the world, in fact a creature with that id need not exist. -} -module Dodge.Creature.Test - ( crIsAiming - , crIsReloading - , crIsArmouredFrom - , oneH - , twists - , twoFlat - , crWeaponReady - , crInAimStance - , crNearPoint - , isAnimate - , crCanShoot - , crHasTargetLOS - , crAwayFromPost - , crHasTarget - , crStratConMatches - , crSafeDistFromTarg - ) - where -import Dodge.Data -import Dodge.Base.Collide -import Geometry ---import SameConstr +module Dodge.Creature.Test ( + crIsAiming, + crIsReloading, + crIsArmouredFrom, + oneH, + twists, + twoFlat, + crWeaponReady, + crInAimStance, + crNearPoint, + isAnimate, + crCanShoot, + crHasTargetLOS, + crAwayFromPost, + crHasTarget, + crStratConMatches, + crSafeDistFromTarg, +) where +import Control.Lens import Data.List (find) import Data.Maybe ---import qualified IntMapHelp as IM -import Control.Lens +import Dodge.Base.Collide +import Dodge.Data.World +import Geometry crIsReloading :: Creature -> Bool crIsReloading cr = case cr ^? crInvSel . iselAction of - Just ReloadAction {} -> True + Just ReloadAction{} -> True _ -> False crWeaponReady :: Creature -> Bool @@ -45,7 +42,7 @@ crWeaponReady cr = fromMaybe False $ do return (_laLoaded ic > 0 && _laPrimed ic) crCanSeeCr :: Creature -> (World, Creature) -> Bool -crCanSeeCr tcr (w,cr) = hasLOS (_crPos cr) (_crPos tcr) w +crCanSeeCr tcr (w, cr) = hasLOS (_crPos cr) (_crPos tcr) w crIsAiming :: Creature -> Bool crIsAiming cr = _posture (_crStance cr) == Aiming @@ -55,7 +52,7 @@ crHasTarget cr = isJust $ cr ^? crIntention . targetCr . _Just crHasTargetLOS :: World -> Creature -> Bool crHasTargetLOS w cr = case cr ^? crIntention . targetCr . _Just of - Just i -> crCanSeeCr i (w,cr) + Just i -> crCanSeeCr i (w, cr) Nothing -> False crSafeDistFromTarg :: Float -> Creature -> Bool @@ -65,7 +62,8 @@ crSafeDistFromTarg d cr = case cr ^? crIntention . targetCr . _Just of crStratConMatches :: Strategy -> Creature -> Bool crStratConMatches strat cr = strat == _apStrategy (_crActionPlan cr) - -- this equality check might be slow... + +-- this equality check might be slow... crAwayFromPost :: Creature -> Bool crAwayFromPost cr = case find sentinelGoal . _apGoal $ _crActionPlan cr of @@ -79,8 +77,9 @@ crCanShoot :: Creature -> Bool crCanShoot cr = crIsAiming cr && crWeaponReady cr crInAimStance :: AimStance -> Creature -> Bool -crInAimStance as cr = crIsAiming cr - && cr ^? crInv . ix (crSel cr) . itUse . useAim . aimStance == Just as +crInAimStance as cr = + crIsAiming cr + && cr ^? crInv . ix (crSel cr) . itUse . heldAim . aimStance == Just as oneH :: Creature -> Bool oneH = crInAimStance OneHand @@ -101,11 +100,13 @@ hasFrontArmour :: Point2 -> Creature -> Bool hasFrontArmour p cr = fromMaybe False $ do invid <- cr ^? crEquipment . ix OnChest ittype <- cr ^? crInv . ix invid . itType . iyBase - return $ EQUIP FRONTARMOUR == ittype - && p /= _crOldPos cr - && angleVV (unitVectorAtAngle (_crDir cr + frontarmdirection)) (p -.- _crOldPos cr) < pi/2 --- even though angleVV can generate NaN, the comparison seems to deal with it + return $ + EQUIP FRONTARMOUR == ittype + && p /= _crOldPos cr + && angleVV (unitVectorAtAngle (_crDir cr + frontarmdirection)) (p -.- _crOldPos cr) < pi / 2 where + -- even though angleVV can generate NaN, the comparison seems to deal with it + frontarmdirection | crInAimStance OneHand cr = 0.5 | crInAimStance TwoHandTwist cr = negate 1 @@ -124,4 +125,4 @@ isAnimate :: Creature -> Bool {-# INLINE isAnimate #-} isAnimate cr = case _crActionPlan cr of Inanimate -> False - _ -> True + _ -> True diff --git a/src/Dodge/Creature/Update.hs b/src/Dodge/Creature/Update.hs index 2f4314e19..bcd329ef6 100644 --- a/src/Dodge/Creature/Update.hs +++ b/src/Dodge/Creature/Update.hs @@ -1,29 +1,32 @@ module Dodge.Creature.Update where -import Dodge.Data -import Dodge.Creature.State -import Dodge.Creature.Impulse -import Dodge.Creature.ChainUpdates -import Dodge.Lampoid -import Dodge.Humanoid -import Dodge.Turretoid -import Dodge.Barreloid -import LensHelp +import Dodge.Barreloid +import Dodge.Creature.ChainUpdates +import Dodge.Creature.Impulse +import Dodge.Creature.State +import Dodge.Data.World +import Dodge.Humanoid +import Dodge.Lampoid +import Dodge.Turretoid +import LensHelp import System.Random updateCreature :: Creature -> World -> World updateCreature cr = case _crType cr of - Lampoid{} -> updateLampoid cr - Humanoid{} -> updateHumanoid cr + Lampoid{} -> updateLampoid cr + Humanoid{} -> updateHumanoid cr Turretoid{} -> updateTurretoid cr Barreloid{} -> updateBarreloid cr NonDrawnCreature -> id - -- bit of a hack to get new random generators after each creature's update -defaultImpulsive :: [World -> Creature -> Creature] - -> Creature -> World -> World +defaultImpulsive :: + [World -> Creature -> Creature] -> + Creature -> + World -> + World defaultImpulsive = fmap (fmap updateRandGen) . stateUpdate . impulsiveAIBefore . chainCreatureUpdates where - updateRandGen w = let (_,g) = randomR (0,1::Int) (_randGen w) - in w & randGen .~ g + updateRandGen w = + let (_, g) = randomR (0, 1 :: Int) (_randGen w) + in w & randGen .~ g diff --git a/src/Dodge/Creature/Vocalization.hs b/src/Dodge/Creature/Vocalization.hs index 3bbede8b2..1ed0a015a 100644 --- a/src/Dodge/Creature/Vocalization.hs +++ b/src/Dodge/Creature/Vocalization.hs @@ -1,15 +1,15 @@ module Dodge.Creature.Vocalization where -import Dodge.Data -import Sound.Data import Control.Lens +import Dodge.Data.Creature +import Sound.Data vocalizationTest :: Creature -> Maybe SoundID vocalizationTest cr = case cr ^? crVocalization . vcCoolDown of Just 0 -> Just $ _vcSound $ _crVocalization cr - _ -> Nothing + _ -> Nothing resetCrVocCoolDown :: Creature -> Creature resetCrVocCoolDown cr = case cr ^? crVocalization . vcMaxCoolDown of - Just i -> cr & crVocalization . vcCoolDown .~ i + Just i -> cr & crVocalization . vcCoolDown .~ i Nothing -> cr diff --git a/src/Dodge/Creature/Volition.hs b/src/Dodge/Creature/Volition.hs index 7c2155e94..302b6df9a 100644 --- a/src/Dodge/Creature/Volition.hs +++ b/src/Dodge/Creature/Volition.hs @@ -1,12 +1,13 @@ -{- | Not a good name, perhaps: internal creature actions. -} -module Dodge.Creature.Volition - ( holsterWeapon - , drawWeapon - , shootTillEmpty --- , fleeFrom - , shootFirstMiss - ) where -import Dodge.Data +-- | Not a good name, perhaps: internal creature actions. +module Dodge.Creature.Volition ( + holsterWeapon, + drawWeapon, + shootTillEmpty, + shootFirstMiss, +) where + +import Dodge.Data.Creature +import Dodge.Data.CreatureEffect import Dodge.SoundLogic.LoadSound import Geometry @@ -14,24 +15,24 @@ holsterWeapon, drawWeapon :: Action holsterWeapon = DoImpulses [ChangePosture AtEase, MakeSound whiteNoiseFadeOutS] drawWeapon = DoImpulses [ChangePosture Aiming, MakeSound whiteNoiseFadeInS] - shootTillEmpty :: Action --shootTillEmpty = (crCanShoot `DoActionWhile` DoImpulses [UseItem]) -shootTillEmpty = (WdCrBlfromCrBl CrCanShoot `DoActionWhile` DoImpulses [UseItem]) - `DoActionThen` 20 `WaitThen` holsterWeapon +shootTillEmpty = + (WdCrBlfromCrBl CrCanShoot `DoActionWhile` DoImpulses [UseItem]) + `DoActionThen` 20 `WaitThen` holsterWeapon --advanceShoot :: Int -> Action --advanceShoot tcid = lostest `DoActionWhile` -- advanceShoot' `DoActionThen` --- 75 `DoReplicate` +-- 75 `DoReplicate` -- advanceShoot' -- where --- lostest (w,cr) = canSee (_crID cr) tcid w +-- lostest (w,cr) = canSee (_crID cr) tcid w -- advanceShoot' = ImpulsesList [[UseItem, MoveForward 3]] shootFirstMiss :: Action shootFirstMiss = - LeadTarget (V2 30 50) `DoActionThen` - DoImpulses [UseItem] `DoActionThen` - (WdCrBlfromCrBl CrCanShoot `DoActionWhile` DoActions [LeadTarget (V2 0 0),DoImpulses [UseItem]]) - `DoActionThen` 20 `WaitThen` holsterWeapon + LeadTarget (V2 30 50) + `DoActionThen` DoImpulses [UseItem] + `DoActionThen` (WdCrBlfromCrBl CrCanShoot `DoActionWhile` DoActions [LeadTarget (V2 0 0), DoImpulses [UseItem]]) + `DoActionThen` 20 `WaitThen` holsterWeapon diff --git a/src/Dodge/Creature/YourControl.hs b/src/Dodge/Creature/YourControl.hs index 2433443c0..6d0ba61a1 100644 --- a/src/Dodge/Creature/YourControl.hs +++ b/src/Dodge/Creature/YourControl.hs @@ -1,49 +1,53 @@ -module Dodge.Creature.YourControl - ( yourControl - ) where -import Dodge.Data -import Dodge.LightSource +module Dodge.Creature.YourControl ( + yourControl, +) where + +import qualified Data.Map.Strict as M import Dodge.Base.Coordinate import Dodge.Creature.Impulse.Movement import Dodge.Creature.Test -import Dodge.Update.UsingInput +import Dodge.Data.World import Dodge.InputFocus +import Dodge.LightSource +import Dodge.Update.UsingInput import Geometry import LensHelp - import qualified SDL -import qualified Data.Map.Strict as M -{- | The AI equivalent for your control. -} + +-- | The AI equivalent for your control. yourControl :: Creature -> World -> World -yourControl cr w +yourControl cr w | inTermFocus w = dimCreatureLight cr w & updateUsingInput - | otherwise = dimCreatureLight cr w - & cWorld . creatures . ix (_crID cr) %~ - (wasdWithAiming w (_mvSpeed $ _crMvType cr) . mouseActionsCr (_mouseButtons w)) - & updateUsingInput + | otherwise = + dimCreatureLight cr w + & cWorld . creatures . ix (_crID cr) + %~ (wasdWithAiming w (_mvSpeed $ _crMvType cr) . mouseActionsCr (_mouseButtons w)) + & updateUsingInput dimCreatureLight :: Creature -> World -> World dimCreatureLight cr = cWorld . tempLightSources .:~ tlsTimeRadColPos 1 300 0.1 (addZ 100 $ _crPos cr) -- note the order of operation, setting the posture first--this prevents the twist fire bug -{- | Turn key presses into creature movement. -} -wasdWithAiming - :: World - -> Float -- ^ Base speed - -> Creature - -> Creature +-- | Turn key presses into creature movement. +wasdWithAiming :: + World -> + -- | Base speed + Float -> + Creature -> + Creature wasdWithAiming w speed cr - | isAiming = addAnyTwist $ set crDir mouseDir $ theMovement cr - | crIsReloading cr && SDL.ButtonRight `M.member` _mouseButtons w - = addAnyTwist $ set crDir (mouseDir + anytwist) $ theMovement cr + | isAiming = addAnyTwist $ set crDir mouseDir $ theMovement cr + | crIsReloading cr && SDL.ButtonRight `M.member` _mouseButtons w = + addAnyTwist $ set crDir (mouseDir + anytwist) $ theMovement cr | otherwise = theMovement $ theTurn $ removeTwist cr - where + where twistamount = 1.6 - removeTwist cr' = cr' - & crDir +~ _crTwist cr' - & crTwist .~ 0 - anytwist = case cr ^? crInv . ix (crSel cr) . itUse . useAim . aimStance of + removeTwist cr' = + cr' + & crDir +~ _crTwist cr' + & crTwist .~ 0 + anytwist = case cr ^? crInv . ix (crSel cr) . itUse . heldAim . aimStance of Just TwoHandTwist -> twistamount * pi _ -> 0 addAnyTwist = crTwist .~ anytwist @@ -53,7 +57,7 @@ wasdWithAiming w speed cr theTurn cr' = creatureTurnTowardDir (_crMvDir cr') 0.2 cr' movDir = wasdDir w dir = _cameraRot (_cWorld w) + argV movDir - movAbs = rotateV (_cameraRot (_cWorld w)) $ normalizeV movDir + movAbs = rotateV (_cameraRot (_cWorld w)) $ normalizeV movDir isAiming = _posture (_crStance cr) == Aiming mouseDir = case cr ^? crInv . ix (crSel cr) . itScope . scopePos of Just _ -> argV $ mouseWorldPos w -.- _crPos cr @@ -61,20 +65,20 @@ wasdWithAiming w speed cr wasdM :: SDL.Scancode -> Point2 wasdM scancode = case scancode of - SDL.ScancodeW -> V2 0 1 - SDL.ScancodeS -> V2 0 (-1) - SDL.ScancodeD -> V2 1 0 - SDL.ScancodeA -> V2 (-1) 0 - _ -> V2 0 0 + SDL.ScancodeW -> V2 0 1 + SDL.ScancodeS -> V2 0 (-1) + SDL.ScancodeD -> V2 1 0 + SDL.ScancodeA -> V2 (-1) 0 + _ -> V2 0 0 wasdDir :: World -> Point2 wasdDir = foldr ((+.+) . wasdM) (V2 0 0) . _keys -{- | Set posture according to mouse presses. -} +-- | Set posture according to mouse presses. mouseActionsCr :: M.Map SDL.MouseButton Bool -> Creature -> Creature mouseActionsCr pkeys cr - | rbPressed && cr ^?! crInvSel . iselAction == NoInvSelAction - = cr & crStance . posture .~ Aiming + | rbPressed && cr ^?! crInvSel . iselAction == NoInvSelAction = + cr & crStance . posture .~ Aiming | otherwise = cr & crStance . posture .~ AtEase - where + where rbPressed = SDL.ButtonRight `M.member` pkeys diff --git a/src/Dodge/CreatureEffect.hs b/src/Dodge/CreatureEffect.hs index aafb3ce98..afab01b80 100644 --- a/src/Dodge/CreatureEffect.hs +++ b/src/Dodge/CreatureEffect.hs @@ -1,12 +1,13 @@ module Dodge.CreatureEffect where -import Dodge.Creature.Test -import Dodge.Data -import Geometry -import Dodge.Base.Collide -import Dodge.Path -import qualified IntMapHelp as IM import Data.Maybe +import Dodge.Base.Collide +import Dodge.Creature.Test +import Dodge.Data.CreatureEffect +import Dodge.Data.World +import Dodge.Path +import Geometry +import qualified IntMapHelp as IM doWdCrCr :: WdCrCr -> World -> Creature -> Creature doWdCrCr ce = case ce of @@ -38,8 +39,11 @@ doWdCrBl wcb = case wcb of WdCrTrue -> const $ const True WdCrBlfromCrBl cb -> \_ cr -> doCrBl cb cr WdCrNegate wcb' -> \w -> not . doWdCrBl wcb' w - WdCrLOSTarget -> \w cr -> maybe False (\cid -> canSee (_crID cr) cid w) - (_crID <$> _targetCr (_crIntention cr)) + WdCrLOSTarget -> \w cr -> + maybe + False + (\cid -> canSee (_crID cr) cid w) + (_crID <$> _targetCr (_crIntention cr)) WdCrSafeDistFromTarget x -> \_ -> crSafeDistFromTarg x -- currently ignores walls etc doCrBl :: CrBl -> Creature -> Bool @@ -74,21 +78,22 @@ doCrWdAc cw = case cw of CrWdBFSThenReturn t -> \cr w -> fromMaybe NoAction $ do n <- walkableNodeNear w (_crPos cr) let as = take 20 $ map PathTo $ bfsNodePoints n w - return $ DoReplicate t $ - foldr DoActionThen NoAction as + return $ + DoReplicate t $ + foldr DoActionThen NoAction as ChooseMovementSpreadGun -> chooseMovementSpreadGun - ChooseMovementLtAuto -> chooseMovementLtAuto + ChooseMovementLtAuto -> chooseMovementLtAuto chooseMovementSpreadGun :: Creature -> World -> Action -chooseMovementSpreadGun cr w - | dist cpos p < 30 && safeAngleVV (p -.- cpos) (unitVectorAtAngle (_crDir cr)) > pi - = DoImpulses [UseItem, MoveForward (-3)] - | d < 30 = DoImpulses [UseItem,TurnToward p 0.06] - | d < 60 = DoImpulses [UseItem,TurnToward p 0.06,MoveForward 3] - | d < 100 = DoImpulses [TurnToward p 0.06, MoveForward 3 ] - | d < 200 = DoImpulses [TurnToward p (0.06 + 0.002 *(d-100)), MoveForward 3 ] - | otherwise - = DoImpulses [TurnToward p 0.26, MoveForward 3] +chooseMovementSpreadGun cr w + | dist cpos p < 30 && safeAngleVV (p -.- cpos) (unitVectorAtAngle (_crDir cr)) > pi = + DoImpulses [UseItem, MoveForward (-3)] + | d < 30 = DoImpulses [UseItem, TurnToward p 0.06] + | d < 60 = DoImpulses [UseItem, TurnToward p 0.06, MoveForward 3] + | d < 100 = DoImpulses [TurnToward p 0.06, MoveForward 3] + | d < 200 = DoImpulses [TurnToward p (0.06 + 0.002 * (d -100)), MoveForward 3] + | otherwise = + DoImpulses [TurnToward p 0.26, MoveForward 3] where d = dist cpos p cpos = _crPos cr @@ -96,13 +101,13 @@ chooseMovementSpreadGun cr w p = _crPos tcr chooseMovementLtAuto :: Creature -> World -> Action -chooseMovementLtAuto cr w - | dist cpos p > 200 = DoImpulses [UseItem,TurnToward p 0.05 , MoveForward 3] - | dist cpos p < 80 = DoImpulses [UseItem,TurnToward p 0.05, MoveForward (-3) ] - | errorAngleVV 22 (p' -.- cpos) (unitVectorAtAngle (_crDir cr)) < 0.4 - = DoImpulses [UseItem,TurnToward p' 0.01, Move (V2 0 3)] - | otherwise - = DoImpulses [UseItem,TurnToward p' 0.05, Move (V2 0 3)] +chooseMovementLtAuto cr w + | dist cpos p > 200 = DoImpulses [UseItem, TurnToward p 0.05, MoveForward 3] + | dist cpos p < 80 = DoImpulses [UseItem, TurnToward p 0.05, MoveForward (-3)] + | errorAngleVV 22 (p' -.- cpos) (unitVectorAtAngle (_crDir cr)) < 0.4 = + DoImpulses [UseItem, TurnToward p' 0.01, Move (V2 0 3)] + | otherwise = + DoImpulses [UseItem, TurnToward p' 0.05, Move (V2 0 3)] where cpos = _crPos cr tcr = _creatures (_cWorld w) IM.! 0 @@ -112,5 +117,5 @@ chooseMovementLtAuto cr w fleeFrom :: Creature -> Maybe Creature -> Action fleeFrom cr mtcr = case mtcr of - Just tcr -> DoImpulses [MoveForward 3, TurnToward ((2 *.* _crPos cr) -.- _crPos tcr) (pi/4)] + Just tcr -> DoImpulses [MoveForward 3, TurnToward ((2 *.* _crPos cr) -.- _crPos tcr) (pi / 4)] Nothing -> NoAction diff --git a/src/Dodge/CullBox.hs b/src/Dodge/CullBox.hs index 74a6a8234..0e78cde55 100644 --- a/src/Dodge/CullBox.hs +++ b/src/Dodge/CullBox.hs @@ -1,28 +1,28 @@ -module Dodge.CullBox - ( updateBounds - ) - where -import Dodge.Data -import Dodge.Base.Window -import Geometry -import Dodge.Update.Camera +module Dodge.CullBox ( + updateBounds, +) where -import Data.Maybe import Control.Lens +import Data.Maybe +import Dodge.Base.Window +import Dodge.Data.Universe +import Dodge.Update.Camera +import Geometry -findBoundDists :: Configuration -> World -> (Float,Float,Float,Float) +findBoundDists :: Configuration -> World -> (Float, Float, Float, Float) findBoundDists cfig w - | debugOn Bound_box_screen cfig = (hh,-hh,hw,-hw) - | otherwise = fromMaybe (0,0,0,0) $ farWallDistDirection (_cameraCenter (_cWorld w)) w + | debugOn Bound_box_screen cfig = (hh, - hh, hw, - hw) + | otherwise = fromMaybe (0, 0, 0, 0) $ farWallDistDirection (_cameraCenter (_cWorld w)) w where hw = halfWidth cfig hh = halfHeight cfig updateBounds :: Universe -> Universe -updateBounds uv = uv - & uvWorld . cWorld . boundDist .~ bdists - & uvWorld . cWorld . boundBox .~ map ( (+.+ _cameraCenter (_cWorld w)) . rotateV (_cameraRot (_cWorld w)) ) (rectNSWE n s w' e) +updateBounds uv = + uv + & uvWorld . cWorld . boundDist .~ bdists + & uvWorld . cWorld . boundBox .~ map ((+.+ _cameraCenter (_cWorld w)) . rotateV (_cameraRot (_cWorld w))) (rectNSWE n s w' e) where w = _uvWorld uv cfig = _uvConfig uv - bdists@(n,s,e,w') = findBoundDists cfig w + bdists@(n, s, e, w') = findBoundDists cfig w diff --git a/src/Dodge/Cuse.hs b/src/Dodge/Cuse.hs index e385b8887..8fe71ba74 100644 --- a/src/Dodge/Cuse.hs +++ b/src/Dodge/Cuse.hs @@ -1,7 +1,7 @@ module Dodge.Cuse where -import Dodge.Data import Control.Lens +import Dodge.Data.World useC :: Cuse -> Item -> Creature -> World -> World useC cu = case cu of diff --git a/src/Dodge/Damage.hs b/src/Dodge/Damage.hs index 575c4fbd3..63368801d 100644 --- a/src/Dodge/Damage.hs +++ b/src/Dodge/Damage.hs @@ -1,15 +1,17 @@ module Dodge.Damage where -import Dodge.Data + +import qualified Data.Map.Strict as M +import Dodge.Data.CrWlID +import Dodge.Data.World import Dodge.Wall.Damage import FoldableHelp import Geometry.Vector import LensHelp -import qualified Data.Map.Strict as M damageCrWlID :: Damage -> CrWlID -> World -> World damageCrWlID dam crwl = case crwl of NothingID -> id - CrID cid -> cWorld . creatures . ix cid . crState . csDamage .:~ dam + CrID cid -> cWorld . creatures . ix cid . crState . csDamage .:~ dam WlID wlid -> cWorld . wallDamages . ix wlid .:~ dam damageCrWall :: Damage -> Either Creature Wall -> World -> World @@ -26,5 +28,5 @@ collectDamageTypes = foldr f M.empty where f dm = M.insertWith (+) (_dmType dm) (_dmAmount dm) -maxDamageType :: [Damage] -> Maybe (DamageType,Int) +maxDamageType :: [Damage] -> Maybe (DamageType, Int) maxDamageType = safeMinimumOn (negate . snd) . M.assocs . collectDamageTypes diff --git a/src/Dodge/DamageCircle.hs b/src/Dodge/DamageCircle.hs index 147ecd2e0..e4e9734d5 100644 --- a/src/Dodge/DamageCircle.hs +++ b/src/Dodge/DamageCircle.hs @@ -1,17 +1,19 @@ -module Dodge.DamageCircle - ( damageCircle - ) where -import Dodge.Data -import Dodge.WorldEvent.ThingsHit -import Geometry -import LensHelp +module Dodge.DamageCircle ( + damageCircle, +) where import Data.Foldable +import Dodge.Data.World +import Dodge.WorldEvent.ThingsHit +import Geometry import qualified IntMapHelp as IM +import LensHelp + damageCircle :: Float -> Point2 -> DamageType -> Int -> World -> World -damageCircle r sp dt da w = w - & cWorld . wallDamages %~ addwalldamages - & cWorld . creatures %~ addcreaturedamages +damageCircle r sp dt da w = + w + & cWorld . wallDamages %~ addwalldamages + & cWorld . creatures %~ addcreaturedamages where --addwalldamages wlds = runIdentity $ S.fold_ (damageWlCircle wldam) wlds id wlstodam addwalldamages wlds = foldl' (damageWlCircle wldam) wlds wlstodam @@ -21,10 +23,16 @@ damageCircle r sp dt da w = w crdam p cr = Damage dt da sp p (_crPos cr) NoDamageEffect crstodam = crsHitRadial sp r w -damageWlCircle :: (Point2 -> Damage) - -> IM.IntMap [Damage] -> (Point2,Wall) -> IM.IntMap [Damage] -damageWlCircle f wldams (p,wl) = IM.insertWith (++) (_wlID wl) [f p] wldams +damageWlCircle :: + (Point2 -> Damage) -> + IM.IntMap [Damage] -> + (Point2, Wall) -> + IM.IntMap [Damage] +damageWlCircle f wldams (p, wl) = IM.insertWith (++) (_wlID wl) [f p] wldams -damageCrCircle :: (Point2 -> Creature -> Damage) - -> IM.IntMap Creature -> (Point2,Creature) -> IM.IntMap Creature -damageCrCircle crdam crs (p,cr) = crs & ix (_crID cr) . crState . csDamage .:~ crdam p cr +damageCrCircle :: + (Point2 -> Creature -> Damage) -> + IM.IntMap Creature -> + (Point2, Creature) -> + IM.IntMap Creature +damageCrCircle crdam crs (p, cr) = crs & ix (_crID cr) . crState . csDamage .:~ crdam p cr diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 9ec80de6d..1c6aa0696 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -1,27 +1,22 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} {- | Contains base datatypes that cannot be seperated into different modules because they are interdependent; circular imports are probably not a good idea. - -WARNING: orphan instances concerning Aeson classes and SDL datatypes have been introduced. -The warnings have been disabled. -} module Dodge.Data ( - module Dodge.Data, + module Dodge.Data.World, + module Dodge.Data.WorldEffect, module Dodge.Data.ArcStep, + module Dodge.Data.Config, module Dodge.Data.Zoning, module Dodge.Data.Distortion, module Dodge.Data.Material, - module Dodge.Data.SoundOrigin, + module Dodge.Data.GenWorld, + module Dodge.Data.Universe, module Dodge.Data.Hammer, - module Dodge.Data.RightButtonOptions, - module Dodge.Data.Config, module MaybeHelp, module Dodge.Data.RoomCluster, module Dodge.Data.Room, @@ -32,272 +27,22 @@ module Dodge.Data ( module Dodge.Data.MountedObject, ) where -import Color -import Control.Lens -import Control.Monad.State -import qualified Data.Map.Strict as M -import Data.Preload -import qualified Data.Set as S -import qualified Data.Text as T -import Data.Tile -import Dodge.Config.KeyConfig +import Dodge.Data.Config +import Dodge.Data.WorldEffect import Dodge.Data.ActionPlan import Dodge.Data.ArcStep import Dodge.Data.CWorld -import Dodge.Data.Config import Dodge.Data.CrWlID import Dodge.Data.CreatureEffect import Dodge.Data.Distortion +import Dodge.Data.GenWorld import Dodge.Data.Hammer import Dodge.Data.Material import Dodge.Data.MountedObject import Dodge.Data.ObjectType -import Dodge.Data.RightButtonOptions import Dodge.Data.Room import Dodge.Data.RoomCluster -import Dodge.Data.SoundOrigin +import Dodge.Data.Universe +import Dodge.Data.World import Dodge.Data.Zoning -import Geometry.Data -import qualified IntMapHelp as IM import MaybeHelp -import Picture.Data -import SDL (MouseButton, Scancode) -import Sound.Data -import Streaming -import System.Random - -type CRUpdate' = Creature -> World -> (World -> World, Creature) - -data Universe = Universe - { _uvWorld :: World - , _preloadData :: PreloadData - , _menuLayers :: [ScreenLayer] - , _savedWorlds :: M.Map SaveSlot World - , _keyConfig :: KeyConfigSDL - , _uvIOEffects :: Universe -> IO Universe - , _uvConfig :: Configuration - , _uvTestString :: Universe -> [String] - } - -data GenWorld = GenWorld - { _gwWorld :: World - , _genPlacements :: IM.IntMap [(Placement, Int)] - , _genRooms :: IM.IntMap Room - } - -data World = World - { _cWorld :: CWorld - , _randGen :: StdGen - , _toPlaySounds :: M.Map SoundOrigin Sound - , _playingSounds :: M.Map SoundOrigin Sound - , _mousePos :: Point2 - , _keys :: S.Set Scancode - , _mouseButtons :: M.Map MouseButton Bool - , _hammers :: M.Map WorldHammer HammerPosition - , _testFloat :: Float - , _lLine :: (Point2, Point2) - , _rLine :: (Point2, Point2) - , _lSelect :: Point2 - , _rSelect :: Point2 - , _backspaceTimer :: Int - , _timeFlow :: TimeFlowStatus - , _rbOptions :: RightButtonOptions - } - -data TimeFlowStatus - = RewindingNow - | RewindingLastFrame - | NormalTimeFlow - deriving (Eq, Ord, Show, Read) - -data WorldHammer - = SubInvHam - | DoubleMouseHam - deriving (Eq, Ord, Show, Read, Enum, Bounded) - -data SaveSlot - = QuicksaveSlot - | LevelStartSlot - | SaveSlotNum Int - deriving (Eq, Ord, Show, Read) - -data OptionScreenFlag = NormalOptions | GameOverOptions - deriving (Eq, Ord, Show, Read) - -data ScreenLayer - = OptionScreen - { _scTitle :: Universe -> String - , _scOptions :: [MenuOption] - , _scDefaultEff :: Universe -> IO (Maybe Universe) - , _scOptionFlag :: OptionScreenFlag - , _scOptionsOffset :: Int - } - | ColumnsScreen - { _scTitle :: Universe -> String - , _scColumns :: [(String, String)] - } - | InputScreen - { _scInput :: T.Text - , _scFooter :: String - } - | WaitScreen - { _scWaitMessage :: Universe -> String - , _scWaitTime :: Int - } - | DisplayScreen - { _scDisplay :: Universe -> Picture - } - -data MenuOption - = Toggle - { _moEff :: Universe -> IO (Maybe Universe) - , _moString :: Universe -> Either String (String, String) - , _moKey :: Scancode - } - | Toggle2 - { _moKey1 :: Scancode - , _moEff1 :: Universe -> IO (Maybe Universe) - , _moKey2 :: Scancode - , _moEff2 :: Universe -> IO (Maybe Universe) - , _moString :: Universe -> Either String (String, String) - } - | InvisibleToggle - { _moKey :: Scancode - , _moEff :: Universe -> IO (Maybe Universe) - } - -data IntID a = IntID Int a - -type HitEffect' = - Flame -> - Stream (Of (Point2, Either Creature Wall)) Identity () -> - World -> - (World, Maybe Flame) - ----- ROOM DATATYPES -data PSType - = PutCrit {_unPutCrit :: Creature} - | PutMachine {_putMachinePoly :: [Point2], _putMachineMachine :: Machine, _putMachineWall :: Wall} - | PutLS LightSource - | PutButton {_putButton :: Button} - | PutProp Prop - | PutTerminal {_unputTerminal :: Terminal} - | PutFlIt {_putItem :: Item} - | PutPPlate PressPlate - | PutBlock {_putBlock :: Block, _putWall :: Wall, _putPoly :: [Point2]} - | PutCoord Point2 - | PutMod Modification - | PutTrigger Bool - | PutLineBlock - { _putWall :: Wall - , _putWidth :: Float - , _putStartPoint :: Point2 - , _putEndPoint :: Point2 - } - | PutWall {_pwPoly :: [Point2], _pwWall :: Wall} - | PutSlideDr Door Wall EdgeObstacle Float Point2 Point2 - | PutDoor Color EdgeObstacle WdBl [(Point2, Point2)] - | RandPS (State StdGen PSType) - | PutForeground ForegroundShape - | PutDecoration Picture - | PutWorldUpdate (PlacementSpot -> World -> World) - | PutNothing - | PutUsingGenParams (World -> (World, PSType)) - | PutID {_putID :: Int} - --- maybe there is a monadic implementation of this? --- add room effect for any placement spot? -data PlacementSpot - = PS {_psPos :: Point2, _psRot :: Float} - | PSNoShiftCont {_psPos :: Point2, _psRot :: Float} - | PSPos - { _psSelect :: RoomPos -> Room -> Maybe (PlacementSpot, RoomPos) - , _psRoomEff :: RoomPos -> Room -> Room - , _psFallback :: Maybe Placement - } - | PSRoomRand - { _psRoomRandPointNum :: Int - , _psRandShift :: (Point2, Float) -> PlacementSpot - } - --- TODO attempt to unify/simplify this union type -data Placement - = Placement - { _plOrder :: Int - , _plSpot :: PlacementSpot - , _plType :: PSType - , _plMID :: Maybe Int - , _plIDCont :: World -> Placement -> Maybe Placement - } - | PlacementUsingPos Point3 (Point3 -> Placement) -- allows a placement to use a shifted position - | RandomPlacement {_unRandomPlacement :: State StdGen Placement} - | PickOnePlacement Int Placement - -{- The '_rmPolys' lists which polygons should be cut out to form the indestructible walls of the room. -Link pairs contain a position and rotation to attach to another room; -0 is for links going to another room to the north, pi/2 for links going to a room to the west, etc. -TODO : Explain path, does it need both directions? -Placement spots allow things to be put in the room during level generation. -Room bounds between a new room and previously placed rooms are checked during level generation, -assigning no bounds will allow rooms to overlap. -} -data Room = Room - { _rmPolys :: [[Point2]] - , _rmLinks :: [RoomLink] - , -- the Int is the number of previous outlinks that have been assigned - _rmLinkEff :: - RoomLink -> -- child link - Room -> -- child room - Int -> -- child number - RoomLink -> -- parent link - Room -> -- parent room - Room - , _rmPos :: [RoomPos] - , _rmPath :: S.Set (Point2, Point2) - , _rmPmnts :: [Placement] - , _rmInPmnt :: [InPlacement] - , _rmOutPmnt :: [OutPlacement] - , _rmBound :: [[Point2]] - , _rmFloor :: Floor - , _rmName :: String - , _rmShift :: (Point2, Float) - , _rmViewpoints :: [Point2] - , _rmRandPSs :: [State StdGen (Point2, Float)] - , _rmStartWires :: IM.IntMap RoomWire - , _rmEndWires :: IM.IntMap RoomWire - , _rmConnectsTo :: S.Set RoomLinkType -> Bool - , _rmMID :: Maybe Int - , _rmMParent :: Maybe Int - , _rmChildren :: [Int] - , _rmType :: RoomType - , _rmClusterStatus :: ClusterStatus - } - -data OutPlacement = OutPlacement - { _opPlacement :: Placement - , _opPlacementID :: Int - } - -data InPlacement = InPlacement - { _ipPlacement :: [Placement] -> Placement - , _ipPlacementID :: Int - } - -makeLenses ''World - -makeLenses ''Universe -makeLenses ''ScreenLayer -makeLenses ''GenWorld - ------ ROOM LENSES - -makeLenses ''Room -makeLenses ''RoomType -makeLenses ''PSType -makeLenses ''PlacementSpot -makeLenses ''Placement - -_itUseAimStance :: Item -> AimStance -_itUseAimStance = _aimStance . _useAim . _itUse - -crSel :: Creature -> Int -crSel = _iselPos . _crInvSel diff --git a/src/Dodge/Data.hs.orig b/src/Dodge/Data.hs.orig index 1d8e2f848..0836838b7 100644 --- a/src/Dodge/Data.hs.orig +++ b/src/Dodge/Data.hs.orig @@ -1,5 +1,5 @@ {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE FlexibleInstances #-} +--{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE StrictData #-} module Dodge.Data ( module Dodge.Data diff --git a/src/Dodge/Data/ArcStep.hs b/src/Dodge/Data/ArcStep.hs index de8fed610..274b17254 100644 --- a/src/Dodge/Data/ArcStep.hs +++ b/src/Dodge/Data/ArcStep.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} @@ -6,8 +5,8 @@ module Dodge.Data.ArcStep where import Control.Lens import Data.Aeson +import Data.Aeson.TH import Dodge.Data.CrWlID -import GHC.Generics import Geometry.Data data ArcStep = ArcStep @@ -15,21 +14,13 @@ data ArcStep = ArcStep , _asDir :: Float , _asObject :: CrWlID --Maybe (Either Creature Wall) } - deriving (Eq, Ord, Show, Read, Generic) - -instance ToJSON ArcStep where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON ArcStep + deriving (Eq, Ord, Show, Read) data NextArcStep = EndArc | DefaultArcStep - deriving (Eq, Ord, Show, Read, Generic) - -instance ToJSON NextArcStep where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON NextArcStep + deriving (Eq, Ord, Show, Read) makeLenses ''ArcStep +deriveJSON defaultOptions ''ArcStep +deriveJSON defaultOptions ''NextArcStep diff --git a/src/Dodge/Data/Beam.hs b/src/Dodge/Data/Beam.hs index d40c891bf..2c09550b7 100644 --- a/src/Dodge/Data/Beam.hs +++ b/src/Dodge/Data/Beam.hs @@ -1,56 +1,56 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + module Dodge.Data.Beam where -import GHC.Generics -import Data.Aeson -import Geometry.Data + import Color import Control.Lens +import Data.Aeson +import Data.Aeson.TH +import Geometry.Data + {- | Linear beams. Last only one frame. - Can interact with one another in a limited manner - can probably be moved to a separate file - -} +-} data Beam = Beam - { _bmDraw :: BeamDraw -- Beam -> Picture - , _bmPos :: Point2 - , _bmDir :: Float + { _bmDraw :: BeamDraw -- Beam -> Picture + , _bmPos :: Point2 + , _bmDir :: Float , _bmDamage :: Int - , _bmColor :: Color + , _bmColor :: Color , _bmPoints :: [Point2] , _bmFirstPoints :: [Point2] - , _bmRange :: Float + , _bmRange :: Float , _bmPhaseV :: Float , _bmOrigin :: Maybe Int - , _bmType :: BeamType + , _bmType :: BeamType } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Beam where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Beam -data BeamDraw = BasicBeamDraw + deriving (Eq, Ord, Show, Read) + +data BeamDraw + = BasicBeamDraw | BeamDrawColor Color - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON BeamDraw where - toEncoding = genericToEncoding defaultOptions -instance FromJSON BeamDraw -data BeamCombineType = FlameBeamCombine + deriving (Eq, Ord, Show, Read) + +data BeamCombineType + = FlameBeamCombine | LasBeamCombine | TeslaBeamCombine | SplitBeamCombine | NoBeamCombine - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON BeamCombineType where - toEncoding = genericToEncoding defaultOptions -instance FromJSON BeamCombineType -data BeamType - = BeamCombine + deriving (Eq, Ord, Show, Read) + +data BeamType + = BeamCombine { _beamCombine :: BeamCombineType -- (Point2 , (Point2,Point2,Beam) , (Point2,Point2,Beam)) -> World -> World } | BeamSimple - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON BeamType where - toEncoding = genericToEncoding defaultOptions -instance FromJSON BeamType + deriving (Eq, Ord, Show, Read) + makeLenses ''BeamType makeLenses ''Beam +deriveJSON defaultOptions ''BeamType +deriveJSON defaultOptions ''Beam +deriveJSON defaultOptions ''BeamDraw +deriveJSON defaultOptions ''BeamCombineType diff --git a/src/Dodge/Data/Block.hs b/src/Dodge/Data/Block.hs index 58659dbe1..9a46a28b4 100644 --- a/src/Dodge/Data/Block.hs +++ b/src/Dodge/Data/Block.hs @@ -1,45 +1,50 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} -module Dodge.Data.Block where -import GHC.Generics -import Data.Aeson -import Shape.Data +{-# LANGUAGE TemplateHaskell #-} + +module Dodge.Data.Block ( + module Dodge.Data.Block, + module Dodge.Data.Material, + module Dodge.Data.PathGraph, +) where + import Color +import Control.Lens +import Data.Aeson +import Data.Aeson.TH +import qualified Data.IntSet as IS import Dodge.Data.Material import Dodge.Data.PathGraph import Geometry -import Control.Lens -import qualified Data.IntSet as IS +import Shape.Data + data Block = Block - { _blID :: Int - , _blWallIDs :: IS.IntSet - , _blHP :: Int - , _blShadows :: [Int] -- a list of blocks/walls? that are not shown when this block exists - , _blFootprint :: [Point2] - , _blPos :: Point2 - , _blDir :: Float - , _blHeight :: Float - , _blMaterial :: Material - , _blDraw :: BlockDraw --Block -> SPic - , _blObstructs :: [(Int,Int,PathEdge)] + { _blID :: Int + , _blWallIDs :: IS.IntSet + , _blHP :: Int + , _blShadows :: [Int] -- a list of blocks/walls? that are not shown when this block exists + , _blFootprint :: [Point2] + , _blPos :: Point2 + , _blDir :: Float + , _blHeight :: Float + , _blMaterial :: Material + , _blDraw :: BlockDraw --Block -> SPic + , _blObstructs :: [(Int, Int, PathEdge)] } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Block where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Block -data BlockDraw = BlockDrawMempty + deriving (Eq, Ord, Show, Read) + +data BlockDraw + = BlockDrawMempty | BlockDrawBlSh BlSh | BlockDraws [BlockDraw] - | BlockDrawColHeightPoss Color Float [Point2] - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON BlockDraw where - toEncoding = genericToEncoding defaultOptions -instance FromJSON BlockDraw -data BlSh = BlShMempty + | BlockDrawColHeightPoss Color Float [Point2] + deriving (Eq, Ord, Show, Read) + +data BlSh + = BlShMempty | BlShConst Shape - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON BlSh where - toEncoding = genericToEncoding defaultOptions -instance FromJSON BlSh + deriving (Eq, Ord, Show, Read) + makeLenses ''Block +deriveJSON defaultOptions ''Block +deriveJSON defaultOptions ''BlockDraw +deriveJSON defaultOptions ''BlSh diff --git a/src/Dodge/Data/Bounds.hs b/src/Dodge/Data/Bounds.hs index 18bc6b3c0..34a4fe18d 100644 --- a/src/Dodge/Data/Bounds.hs +++ b/src/Dodge/Data/Bounds.hs @@ -1,23 +1,22 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} -module Dodge.Data.Bounds - where +{-# LANGUAGE TemplateHaskell #-} + +module Dodge.Data.Bounds where + import Control.Lens -import GHC.Generics import Data.Aeson +import Data.Aeson.TH data Bounds = Bounds - { _bdMinX :: Float - , _bdMaxX :: Float - , _bdMinY :: Float - , _bdMaxY :: Float + { _bdMinX :: Float + , _bdMaxX :: Float + , _bdMinY :: Float + , _bdMaxY :: Float } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Bounds where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Bounds + deriving (Eq, Ord, Show, Read) + defaultBounds :: Bounds defaultBounds = Bounds 0 0 0 0 makeLenses ''Bounds +deriveJSON defaultOptions ''Bounds diff --git a/src/Dodge/Data/Bullet.hs b/src/Dodge/Data/Bullet.hs index 8c3f5ba35..76504a5a2 100644 --- a/src/Dodge/Data/Bullet.hs +++ b/src/Dodge/Data/Bullet.hs @@ -1,8 +1,10 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} -module Dodge.Data.Bullet where +module Dodge.Data.Bullet + ( module Dodge.Data.Bullet + , module Dodge.Data.Damage + )where import Control.Lens import Data.Aeson diff --git a/src/Dodge/Data/Button.hs b/src/Dodge/Data/Button.hs index fb2312d42..8aeb9a4ed 100644 --- a/src/Dodge/Data/Button.hs +++ b/src/Dodge/Data/Button.hs @@ -1,67 +1,67 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + module Dodge.Data.Button where -import GHC.Generics -import Data.Aeson -import Dodge.Data.WorldEffect + +import Color import Control.Lens +import Data.Aeson +import Data.Aeson.TH +import Dodge.Data.WorldEffect import Geometry.Data import Sound.Data -import Color -data ButtonDraw = DefaultDrawButton Color + +data ButtonDraw + = DefaultDrawButton Color | DefaultDrawSwitch Color Color | DrawNoButton - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON ButtonDraw where - toEncoding = genericToEncoding defaultOptions -instance FromJSON ButtonDraw -data ButtonEvent = ButtonDoNothing + deriving (Eq, Ord, Show, Read) + +data ButtonEvent + = ButtonDoNothing | ButtonPress - {_bpState :: ButtonState - ,_bpEvent :: ButtonEvent - ,_bpSound :: SoundID - ,_bpEff :: WdWd + { _bpState :: ButtonState + , _bpEvent :: ButtonEvent + , _bpSound :: SoundID + , _bpEff :: WdWd } --- | ButtonSwitch --- {_bonState :: ButtonState --- ,_bonEvent :: ButtonEvent --- ,_bonSound :: SoundID --- ,_bonEff :: WorldEffect --- ,_boffState :: ButtonState --- ,_boffEvent :: ButtonEvent --- ,_boffSound :: SoundID --- ,_boffEff :: WorldEffect --- } - | ButtonSimpleSwith - {_bonEff :: WdWd - ,_boffEff :: WdWd + | -- | ButtonSwitch + -- {_bonState :: ButtonState + -- ,_bonEvent :: ButtonEvent + -- ,_bonSound :: SoundID + -- ,_bonEff :: WorldEffect + -- ,_boffState :: ButtonState + -- ,_boffEvent :: ButtonEvent + -- ,_boffSound :: SoundID + -- ,_boffEff :: WorldEffect + -- } + ButtonSimpleSwith + { _bonEff :: WdWd + , _boffEff :: WdWd } | ButtonAccessTerminal - deriving (Eq,Show,Read,Generic) -instance ToJSON ButtonEvent where - toEncoding = genericToEncoding defaultOptions -instance FromJSON ButtonEvent -data Button = Button - { _btPict :: ButtonDraw --Button -> SPic - , _btPos :: Point2 - , _btRot :: Float - , _btEvent :: ButtonEvent --Button -> World -> World - , _btID :: Int - , _btText :: String - , _btState :: ButtonState + deriving (Eq, Show, Read) + +data Button = Button + { _btPict :: ButtonDraw --Button -> SPic + , _btPos :: Point2 + , _btRot :: Float + , _btEvent :: ButtonEvent --Button -> World -> World + , _btID :: Int + , _btText :: String + , _btState :: ButtonState , _btTermMID :: Maybe Int - , _btName :: String - , _btColor :: Color + , _btName :: String + , _btColor :: Color } - deriving (Eq,Show,Read,Generic) -instance ToJSON Button where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Button + deriving (Eq, Show, Read) + data ButtonState = BtOn | BtOff | BtNoLabel - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON ButtonState where - toEncoding = genericToEncoding defaultOptions -instance FromJSON ButtonState + deriving (Eq, Ord, Show, Read) + makeLenses ''Button makeLenses ''ButtonEvent +deriveJSON defaultOptions ''ButtonDraw +deriveJSON defaultOptions ''ButtonEvent +deriveJSON defaultOptions ''Button +deriveJSON defaultOptions ''ButtonState diff --git a/src/Dodge/Data/CamouflageStatus.hs b/src/Dodge/Data/CamouflageStatus.hs index f0243ed8e..d14958225 100644 --- a/src/Dodge/Data/CamouflageStatus.hs +++ b/src/Dodge/Data/CamouflageStatus.hs @@ -1,11 +1,14 @@ -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + module Dodge.Data.CamouflageStatus where -import GHC.Generics + import Data.Aeson +import Data.Aeson.TH + data CamouflageStatus = FullyVisible | Invisible - deriving (Eq,Ord,Enum,Read,Show,Bounded,Generic) -instance ToJSON CamouflageStatus where - toEncoding = genericToEncoding defaultOptions -instance FromJSON CamouflageStatus + deriving (Eq, Ord, Enum, Read, Show, Bounded) + +deriveJSON defaultOptions ''CamouflageStatus diff --git a/src/Dodge/Data/Cloud.hs b/src/Dodge/Data/Cloud.hs index 5acaa1ac6..b372a2227 100644 --- a/src/Dodge/Data/Cloud.hs +++ b/src/Dodge/Data/Cloud.hs @@ -1,18 +1,19 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + module Dodge.Data.Cloud where -import GHC.Generics -import Data.Aeson -import Geometry + import Color import Control.Lens -data CloudDraw = CloudColor Float Float Color -- radius-multiply fade-time color +import Data.Aeson +import Data.Aeson.TH +import Geometry + +data CloudDraw + = CloudColor Float Float Color -- radius-multiply fade-time color | DrawGasCloud Color - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON CloudDraw where - toEncoding = genericToEncoding defaultOptions -instance FromJSON CloudDraw + deriving (Eq, Ord, Show, Read) + data Cloud = Cloud { _clPos :: Point3 , _clVel :: Point3 @@ -22,15 +23,14 @@ data Cloud = Cloud , _clTimer :: Int , _clType :: CloudType } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Cloud where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Cloud + deriving (Eq, Ord, Show, Read) + data CloudType = SmokeCloud | GasCloud - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON CloudType where - toEncoding = genericToEncoding defaultOptions -instance FromJSON CloudType + deriving (Eq, Ord, Show, Read) + makeLenses ''Cloud +deriveJSON defaultOptions ''CloudDraw +deriveJSON defaultOptions ''Cloud +deriveJSON defaultOptions ''CloudType diff --git a/src/Dodge/Data/Config.hs b/src/Dodge/Data/Config.hs index 4a333b7da..a0c75ff48 100644 --- a/src/Dodge/Data/Config.hs +++ b/src/Dodge/Data/Config.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} @@ -6,8 +5,8 @@ module Dodge.Data.Config where import Control.Lens import Data.Aeson +import Data.Aeson.TH import qualified Data.Set as S -import GHC.Generics {-# ANN module "HLint: ignore Use camelCase" #-} @@ -27,7 +26,7 @@ data Configuration = Configuration , _debug_view_clip_bounds :: RoomClipping , _debug_booleans :: S.Set DebugBool -- consider using Data.BitSet } - deriving (Generic, Show) + deriving (Show) data DebugBool = Show_ms_frame @@ -52,23 +51,13 @@ data DebugBool | Inspect_wall | Show_nodes_near_select | Show_path_between - deriving (Generic, Eq, Ord, Bounded, Enum, Show) + deriving (Eq, Ord, Bounded, Enum, Show) data ResFactor = FullRes | HalfRes | QuarterRes - deriving (Generic, Show, Eq, Ord, Enum, Bounded) - -instance ToJSON ResFactor where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON ResFactor + deriving (Show, Eq, Ord, Enum, Bounded) data RoomClipping = NoRoomClipBoundaries | AllRoomClipBoundaries | IntersectingRoomClipBoundaries - deriving (Generic, Show, Eq, Ord, Enum, Bounded) - -instance ToJSON RoomClipping where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON RoomClipping + deriving (Show, Eq, Ord, Enum, Bounded) resFactorNum :: ResFactor -> Int resFactorNum rf = case rf of @@ -76,18 +65,6 @@ resFactorNum rf = case rf of HalfRes -> 2 QuarterRes -> 4 -makeLenses ''Configuration - -instance ToJSON DebugBool where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON DebugBool - -instance ToJSON Configuration where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON Configuration - defaultConfig :: Configuration defaultConfig = Configuration @@ -105,18 +82,13 @@ defaultConfig = , _gameplay_rotate_to_wall = True , _debug_booleans = S.singleton Show_ms_frame , _debug_view_clip_bounds = NoRoomClipBoundaries - -- , _debug_show_sound = False - -- , _debug_seconds_frame = True - -- , _debug_noclip = False - -- , _debug_mouse_position = False - -- , _debug_cr_status = False - -- , _debug_cr_awareness = False - -- , _debug_view_boundaries = False - -- , _debug_pathing = False - -- , _debug_walls = False - -- , _debug_remove_LOS = False - -- , _debug_cull_more_lights = False } debugOn :: DebugBool -> Configuration -> Bool debugOn db = S.member db . _debug_booleans + +makeLenses ''Configuration +deriveJSON defaultOptions ''ResFactor +deriveJSON defaultOptions ''RoomClipping +deriveJSON defaultOptions ''DebugBool +deriveJSON defaultOptions ''Configuration diff --git a/src/Dodge/Data/Corpse.hs b/src/Dodge/Data/Corpse.hs index fbfade840..da9b39b09 100644 --- a/src/Dodge/Data/Corpse.hs +++ b/src/Dodge/Data/Corpse.hs @@ -1,27 +1,26 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + module Dodge.Data.Corpse where -import GHC.Generics -import Data.Aeson -import ShapePicture.Data -import Geometry.Data import Control.Lens +import Data.Aeson +import Data.Aeson.TH +import Geometry.Data +import ShapePicture.Data + data CorpseResurrection = NoResurrection - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON CorpseResurrection where - toEncoding = genericToEncoding defaultOptions -instance FromJSON CorpseResurrection + deriving (Eq, Ord, Show, Read) + data Corpse = Corpse - { _cpID :: Int + { _cpID :: Int , _cpPos :: Point2 , _cpDir :: Float , _cpSPic :: SPic , _cpRes :: CorpseResurrection } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Corpse where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Corpse + deriving (Eq, Ord, Show, Read) + makeLenses ''Corpse +deriveJSON defaultOptions ''CorpseResurrection +deriveJSON defaultOptions ''Corpse diff --git a/src/Dodge/Data/CrGroupParams.hs b/src/Dodge/Data/CrGroupParams.hs index 23cf7f0ab..730fa452d 100644 --- a/src/Dodge/Data/CrGroupParams.hs +++ b/src/Dodge/Data/CrGroupParams.hs @@ -1,26 +1,25 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} -module Dodge.Data.CrGroupParams - where -import GHC.Generics -import Data.Aeson -import Geometry.Data -import qualified Data.IntSet as IS +{-# LANGUAGE TemplateHaskell #-} + +module Dodge.Data.CrGroupParams where + import Control.Lens +import Data.Aeson +import Data.Aeson.TH +import qualified Data.IntSet as IS +import Geometry.Data + data CrGroupParams = CrGroupParams - { _crGroupParamID :: Int - , _crGroupIDs :: IS.IntSet - , _crGroupCenter :: Point2 - , _crGroupUpdate :: CrGroupUpdate --World -> CrGroupParams -> Maybe CrGroupParams + { _crGroupParamID :: Int + , _crGroupIDs :: IS.IntSet + , _crGroupCenter :: Point2 + , _crGroupUpdate :: CrGroupUpdate --World -> CrGroupParams -> Maybe CrGroupParams } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON CrGroupParams where - toEncoding = genericToEncoding defaultOptions -instance FromJSON CrGroupParams + deriving (Eq, Ord, Show, Read) + data CrGroupUpdate = DefaultCrGroupUpdate - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON CrGroupUpdate where - toEncoding = genericToEncoding defaultOptions -instance FromJSON CrGroupUpdate + deriving (Eq, Ord, Show, Read) + makeLenses ''CrGroupParams +deriveJSON defaultOptions ''CrGroupParams +deriveJSON defaultOptions ''CrGroupUpdate diff --git a/src/Dodge/Data/Creature.hs b/src/Dodge/Data/Creature.hs index be59e602b..e48dc3d90 100644 --- a/src/Dodge/Data/Creature.hs +++ b/src/Dodge/Data/Creature.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} @@ -9,11 +8,15 @@ module Dodge.Data.Creature ( module Dodge.Data.Creature.Perception, module Dodge.Data.Creature.Memory, module Dodge.Data.Creature.Stance, - module Dodge.Data.ActionPlan + module Dodge.Data.ActionPlan, + module Dodge.Data.Item, + module Dodge.Data.Material, + module Dodge.Data.Hammer, ) where import Control.Lens import Data.Aeson +import Data.Aeson.TH import qualified Data.Map.Strict as M import Dodge.Data.ActionPlan import Dodge.Data.Creature.Memory @@ -24,7 +27,6 @@ import Dodge.Data.Creature.State import Dodge.Data.Hammer import Dodge.Data.Item import Dodge.Data.Material -import GHC.Generics import Geometry.Data import qualified IntMapHelp as IM @@ -68,32 +70,23 @@ data Creature = Creature , _crStatistics :: CreatureStatistics , _crCamouflage :: CamouflageStatus } - deriving (Eq, Show, Read, Generic) - -instance ToJSON Creature where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON Creature + deriving (Eq, Show, Read) data CreatureCorpse = MakeDefaultCorpse - deriving (Eq, Ord, Show, Read, Generic) - -instance ToJSON CreatureCorpse where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON CreatureCorpse + deriving (Eq, Ord, Show, Read) data Intention = Intention { _targetCr :: Maybe Creature , _mvToPoint :: Maybe Point2 , _viewPoint :: Maybe Point2 } - deriving (Eq, Show, Read, Generic) + deriving (Eq, Show, Read) -instance ToJSON Intention where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON Intention +crSel :: Creature -> Int +crSel = _iselPos . _crInvSel makeLenses ''Creature makeLenses ''Intention +deriveJSON defaultOptions ''Creature +deriveJSON defaultOptions ''CreatureCorpse +deriveJSON defaultOptions ''Intention diff --git a/src/Dodge/Data/Creature/Memory.hs b/src/Dodge/Data/Creature/Memory.hs index fa4d0045b..926b54454 100644 --- a/src/Dodge/Data/Creature/Memory.hs +++ b/src/Dodge/Data/Creature/Memory.hs @@ -1,18 +1,18 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} -module Dodge.Data.Creature.Memory - where -import GHC.Generics -import Data.Aeson -import Geometry.Data +{-# LANGUAGE TemplateHaskell #-} + +module Dodge.Data.Creature.Memory where + import Control.Lens +import Data.Aeson +import Data.Aeson.TH +import Geometry.Data + data Memory = Memory { _soundsToInvestigate :: [Point2] - , _nodesSearched :: [Int] + , _nodesSearched :: [Int] } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Memory where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Memory + deriving (Eq, Ord, Show, Read) + makeLenses ''Memory +deriveJSON defaultOptions ''Memory diff --git a/src/Dodge/Data/Creature/Misc.hs b/src/Dodge/Data/Creature/Misc.hs index 5d96ae1e5..2f073da44 100644 --- a/src/Dodge/Data/Creature/Misc.hs +++ b/src/Dodge/Data/Creature/Misc.hs @@ -1,80 +1,87 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} -module Dodge.Data.Creature.Misc - ( module Dodge.Data.Creature.Misc - , module Dodge.Data.CamouflageStatus - ) where -import GHC.Generics -import Data.Aeson -import Dodge.Data.FloatFunction -import Dodge.Data.CamouflageStatus -import Sound.Data -import Geometry.Data +{-# LANGUAGE TemplateHaskell #-} + +module Dodge.Data.Creature.Misc ( + module Dodge.Data.Creature.Misc, + module Dodge.Data.CamouflageStatus, +) where + import Color import Control.Lens +import Data.Aeson +import Data.Aeson.TH +import Dodge.Data.CamouflageStatus +import Dodge.Data.FloatFunction +import Geometry.Data +import Sound.Data + data CreatureStatistics = CreatureStatistics - { _strength :: Int - , _dexterity :: Int - , _intelligence :: Int + { _strength :: Int + , _dexterity :: Int + , _intelligence :: Int } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON CreatureStatistics where - toEncoding = genericToEncoding defaultOptions -instance FromJSON CreatureStatistics -data Vocalization + deriving (Eq, Ord, Show, Read) + +data Vocalization = Mute | Vocalization - {_vcSound :: SoundID - ,_vcWarnings :: [SoundID] - ,_vcMaxCoolDown :: Int - ,_vcCoolDown :: Int + { _vcSound :: SoundID + , _vcWarnings :: [SoundID] + , _vcMaxCoolDown :: Int + , _vcCoolDown :: Int } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Vocalization where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Vocalization -data CrMvType + deriving (Eq, Ord, Show, Read) + +data CrMvType = NoMvType - | MvWalking { _mvSpeed :: Float } + | MvWalking {_mvSpeed :: Float} | CrMvType - { _mvSpeed :: Float - , _mvTurnRad :: FloatFloat - , _mvTurnJit :: Float - , _mvAimSpeed :: FloatFloat + { _mvSpeed :: Float + , _mvTurnRad :: FloatFloat + , _mvTurnJit :: Float + , _mvAimSpeed :: FloatFloat } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON CrMvType where - toEncoding = genericToEncoding defaultOptions -instance FromJSON CrMvType -data HumanoidAI = YourAI | ChaseAI | InanimateAI | SpreadGunAI | PistolAI - | LtAutoAI | LauncherAI | SwarmAI | AutoAI | FlockArmourChaseAI | MiniGunAI - | LongAI | MultGunAI - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON HumanoidAI where - toEncoding = genericToEncoding defaultOptions -instance FromJSON HumanoidAI + deriving (Eq, Ord, Show, Read) + +data HumanoidAI + = YourAI + | ChaseAI + | InanimateAI + | SpreadGunAI + | PistolAI + | LtAutoAI + | LauncherAI + | SwarmAI + | AutoAI + | FlockArmourChaseAI + | MiniGunAI + | LongAI + | MultGunAI + deriving (Eq, Ord, Show, Read) + data CreatureType = Humanoid - { _skinHead :: Color - , _skinUpper :: Color - , _skinLower :: Color - , _humanoidAI :: HumanoidAI + { _skinHead :: Color + , _skinUpper :: Color + , _skinLower :: Color + , _humanoidAI :: HumanoidAI } | Barreloid {_barrelType :: BarrelType} | Lampoid {_lampHeight :: Float, _lampColor :: Point3, _lampLSID :: Maybe Int} | Turretoid | NonDrawnCreature - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON CreatureType where - toEncoding = genericToEncoding defaultOptions -instance FromJSON CreatureType + deriving (Eq, Ord, Show, Read) + data BarrelType = PlainBarrel | ExplosiveBarrel - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON BarrelType where - toEncoding = genericToEncoding defaultOptions -instance FromJSON BarrelType + deriving (Eq, Ord, Show, Read) + makeLenses ''CreatureStatistics makeLenses ''Vocalization -makeLenses ''CrMvType +makeLenses ''CrMvType makeLenses ''CreatureType +deriveJSON defaultOptions ''CreatureStatistics +deriveJSON defaultOptions ''Vocalization +deriveJSON defaultOptions ''CrMvType +deriveJSON defaultOptions ''HumanoidAI +deriveJSON defaultOptions ''CreatureType +deriveJSON defaultOptions ''BarrelType diff --git a/src/Dodge/Data/Creature/Perception.hs b/src/Dodge/Data/Creature/Perception.hs index 44bbfeca7..4f51b5876 100644 --- a/src/Dodge/Data/Creature/Perception.hs +++ b/src/Dodge/Data/Creature/Perception.hs @@ -1,82 +1,77 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} -module Dodge.Data.Creature.Perception - ( Perception (..) - , Vigilance (..) - , Attention (..) - , Awareness (..) - , Vision (..) - , Audition (..) +{-# LANGUAGE TemplateHaskell #-} + +module Dodge.Data.Creature.Perception ( + Perception (..), + Vigilance (..), + Attention (..), + Awareness (..), + Vision (..), + Audition (..), -- lenses - , getAttentiveTo - , getFixated - , cpAttention - , cpVigilance - , cpAwareness - , cpVision - , cpAudition - , viFOV - , viDist - , auDist - ) - where -import GHC.Generics -import Data.Aeson + getAttentiveTo, + getFixated, + cpAttention, + cpVigilance, + cpAwareness, + cpVision, + cpAudition, + viFOV, + viDist, + auDist, +) where + import Control.Lens +import Data.Aeson +import Data.Aeson.TH import Dodge.Data.FloatFunction import qualified IntMapHelp as IM + data Perception = Perception - { _cpVigilance :: Vigilance - , _cpAttention :: Attention - , _cpAwareness :: IM.IntMap Awareness - , _cpVision :: Vision - , _cpAudition :: Audition + { _cpVigilance :: Vigilance + , _cpAttention :: Attention + , _cpAwareness :: IM.IntMap Awareness + , _cpVision :: Vision + , _cpAudition :: Audition } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Perception where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Perception + deriving (Eq, Ord, Show, Read) + data Vision = Eyes - { _viFOV :: FloatFloat + { _viFOV :: FloatFloat , _viDist :: FloatFloat } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Vision where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Vision + deriving (Eq, Ord, Show, Read) + newtype Audition = Ears { _auDist :: FloatFloat } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Audition where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Audition + deriving (Eq, Ord, Show, Read) + data Vigilance = Comatose | Asleep | Lethargic | Vigilant | Overstrung - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Vigilance where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Vigilance + deriving (Eq, Ord, Show, Read) + data Attention - = AttentiveTo {_getAttentiveTo :: IM.IntMap Awareness } - | Fixated {_getFixated :: Int } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Attention where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Attention + = AttentiveTo {_getAttentiveTo :: IM.IntMap Awareness} + | Fixated {_getFixated :: Int} + deriving (Eq, Ord, Show, Read) + data Awareness = Suspicious Float | Cognizant Float - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Awareness where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Awareness + deriving (Eq, Ord, Show, Read) + makeLenses ''Perception makeLenses ''Vision makeLenses ''Audition makeLenses ''Attention +deriveJSON defaultOptions ''Perception +deriveJSON defaultOptions ''Vision +deriveJSON defaultOptions ''Audition +deriveJSON defaultOptions ''Vigilance +deriveJSON defaultOptions ''Attention +deriveJSON defaultOptions ''Awareness diff --git a/src/Dodge/Data/Creature/Stance.hs b/src/Dodge/Data/Creature/Stance.hs index 302720b08..81e4f7966 100644 --- a/src/Dodge/Data/Creature/Stance.hs +++ b/src/Dodge/Data/Creature/Stance.hs @@ -1,50 +1,47 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} -module Dodge.Data.Creature.Stance - where -import GHC.Generics -import Data.Aeson -import Geometry.Data +{-# LANGUAGE TemplateHaskell #-} + +module Dodge.Data.Creature.Stance where import Control.Lens -data Stance = Stance - {_carriage :: Carriage - ,_posture :: Posture - ,_strideLength :: Int +import Data.Aeson +import Data.Aeson.TH +import Geometry.Data + +data Stance = Stance + { _carriage :: Carriage + , _posture :: Posture + , _strideLength :: Int } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Stance where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Stance -data Carriage - = Walking - { _strideAmount :: Int + deriving (Eq, Ord, Show, Read) + +data Carriage + = Walking + { _strideAmount :: Int , _currentFoot :: FootForward } | Standing | Floating | Flying | Boosting Point2 - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Carriage where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Carriage + deriving (Eq, Ord, Show, Read) + data FootForward = LeftForward | RightForward | WasLeftForward | WasRightForward - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON FootForward where - toEncoding = genericToEncoding defaultOptions -instance FromJSON FootForward -data Posture = Aiming + deriving (Eq, Ord, Show, Read) + +data Posture + = Aiming | AtEase - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Posture where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Posture + deriving (Eq, Ord, Show, Read) + makeLenses ''Stance makeLenses ''Carriage makeLenses ''Posture +deriveJSON defaultOptions ''Stance +deriveJSON defaultOptions ''Carriage +deriveJSON defaultOptions ''FootForward +deriveJSON defaultOptions ''Posture diff --git a/src/Dodge/Data/Creature/State.hs b/src/Dodge/Data/Creature/State.hs index 97cfcb275..c7e31c0f2 100644 --- a/src/Dodge/Data/Creature/State.hs +++ b/src/Dodge/Data/Creature/State.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} @@ -7,9 +6,9 @@ module Dodge.Data.Creature.State where import Color import Control.Lens import Data.Aeson +import Data.Aeson.TH import qualified Data.IntSet as IS import Dodge.Data.Damage -import GHC.Generics import Geometry.Data data CreatureState = CrSt @@ -17,33 +16,18 @@ data CreatureState = CrSt , _csSpState :: CrSpState , _csDropsOnDeath :: CreatureDropType } - deriving (Eq, Ord, Show, Read, Generic) - -instance ToJSON CreatureState where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON CreatureState + deriving (Eq, Ord, Show, Read) data CreatureDropType = DropAll | DropAmount Int | DropSpecific [Int] - deriving (Eq, Ord, Show, Read, Generic) - -instance ToJSON CreatureDropType where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON CreatureDropType + deriving (Eq, Ord, Show, Read) data CrSpState = Barrel {_piercedPoints :: [Point2]} | GenCr - deriving (Eq, Ord, Show, Read, Generic) - -instance ToJSON CrSpState where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON CrSpState + deriving (Eq, Ord, Show, Read) data Faction = GenericFaction Int @@ -54,12 +38,7 @@ data Faction | NoFaction | ColorFaction Color | PlayerFaction - deriving (Eq, Ord, Show, Read, Generic) - -instance ToJSON Faction where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON Faction + deriving (Eq, Ord, Show, Read) data CrGroup = LoneWolf @@ -69,13 +48,13 @@ data CrGroup } | CrGroupID {_crGroupID :: Int} | ShieldGroup - deriving (Eq, Ord, Show, Read, Generic) - -instance ToJSON CrGroup where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON CrGroup + deriving (Eq, Ord, Show, Read) makeLenses ''CreatureState makeLenses ''CrSpState makeLenses ''CrGroup +deriveJSON defaultOptions ''CreatureState +deriveJSON defaultOptions ''CreatureDropType +deriveJSON defaultOptions ''CrSpState +deriveJSON defaultOptions ''Faction +deriveJSON defaultOptions ''CrGroup diff --git a/src/Dodge/Data/Damage.hs b/src/Dodge/Data/Damage.hs index 93d8fe312..4b9188f4e 100644 --- a/src/Dodge/Data/Damage.hs +++ b/src/Dodge/Data/Damage.hs @@ -1,49 +1,54 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} -{- +{-# LANGUAGE TemplateHaskell #-} + +{- Datatypes describing the type of damage effects that are to be applied to creatures. -} -module Dodge.Data.Damage - ( module Dodge.Data.Damage - , module Dodge.Data.Damage.Type - ) where -import GHC.Generics +module Dodge.Data.Damage ( + module Dodge.Data.Damage, + module Dodge.Data.Damage.Type, +) where + +import Control.Lens import Data.Aeson +import Data.Aeson.TH import Dodge.Data.Damage.Type import Geometry.Data -import Control.Lens + data DamageEffect - = PushDamage - { _dePush :: Float + = PushDamage + { _dePush :: Float , _dePushExp :: Float , _dePushRadius :: Float } - | TorqueDamage { _deTorque :: Float } - | PushBackDamage {_dePushBack :: Float } + | TorqueDamage {_deTorque :: Float} + | PushBackDamage {_dePushBack :: Float} | NoDamageEffect - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON DamageEffect where - toEncoding = genericToEncoding defaultOptions -instance FromJSON DamageEffect -data Damage = Damage + deriving (Eq, Ord, Show, Read) + +data Damage = Damage { _dmType :: DamageType - , _dmAmount :: Int , _dmFrom :: Point2 , _dmAt :: Point2 , _dmTo :: Point2 + , _dmAmount :: Int + , _dmFrom :: Point2 + , _dmAt :: Point2 + , _dmTo :: Point2 , _dmEffect :: DamageEffect } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Damage where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Damage + deriving (Eq, Ord, Show, Read) + isElectrical :: Damage -> Bool isElectrical dm = case _dmType dm of ELECTRICAL -> True _ -> False + isMovementDam :: Damage -> Bool isMovementDam dm = case _dmType dm of TORQUEDAM -> True PUSHDAM -> True _ -> False + makeLenses ''Damage makeLenses ''DamageEffect +deriveJSON defaultOptions ''DamageEffect +deriveJSON defaultOptions ''Damage diff --git a/src/Dodge/Data/Damage/Type.hs b/src/Dodge/Data/Damage/Type.hs index 60babb148..743da95ed 100644 --- a/src/Dodge/Data/Damage/Type.hs +++ b/src/Dodge/Data/Damage/Type.hs @@ -1,27 +1,31 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + module Dodge.Data.Damage.Type where -import GHC.Generics + import Data.Aeson -data DamageType - = PIERCING - | BLUNT - | CUTTING +import Data.Aeson.TH + +data DamageType + = PIERCING + | BLUNT + | CUTTING | SPARKING | CRUSHING | SHATTERING - | FLAMING - | LASERING + | FLAMING + | LASERING | ELECTRICAL | EXPLOSIVE | CONCUSSIVE - | TORQUEDAM - | PUSHDAM - | POISONDAM + | TORQUEDAM + | PUSHDAM + | POISONDAM | ENTERREMENT - deriving (Eq,Ord,Show,Read,Enum,Bounded,Generic) -instance ToJSON DamageType where - toEncoding = genericToEncoding defaultOptions -instance FromJSON DamageType + deriving (Eq, Ord, Show, Read, Enum, Bounded) + instance ToJSONKey DamageType -instance FromJSONKey DamageType + +instance FromJSONKey DamageType + +deriveJSON defaultOptions ''DamageType diff --git a/src/Dodge/Data/Distortion.hs b/src/Dodge/Data/Distortion.hs index 797cc154e..1afe9e04a 100644 --- a/src/Dodge/Data/Distortion.hs +++ b/src/Dodge/Data/Distortion.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} module Dodge.Data.Distortion where diff --git a/src/Dodge/Data/Door.hs b/src/Dodge/Data/Door.hs index f5b13c831..9397ac414 100644 --- a/src/Dodge/Data/Door.hs +++ b/src/Dodge/Data/Door.hs @@ -1,47 +1,52 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} -module Dodge.Data.Door where -import GHC.Generics -import Data.Aeson -import Dodge.Data.PathGraph -import Dodge.Data.MountedObject -import Geometry.Data -import Dodge.Data.WorldEffect -import qualified Data.IntSet as IS +{-# LANGUAGE TemplateHaskell #-} + +module Dodge.Data.Door ( + module Dodge.Data.Door, + module Dodge.Data.MountedObject, + module Dodge.Data.PathGraph, + module Dodge.Data.WorldEffect, +) where + import Control.Lens +import Data.Aeson +import Data.Aeson.TH +import qualified Data.IntSet as IS +import Dodge.Data.MountedObject +import Dodge.Data.PathGraph +import Dodge.Data.WorldEffect +import Geometry.Data + data DoorStatus = DoorOpen | DoorClosed | DoorHalfway | DoorInt Int - deriving (Eq, Ord, Show,Read,Generic) -instance ToJSON DoorStatus where - toEncoding = genericToEncoding defaultOptions -instance FromJSON DoorStatus -data PushSource = PushesItself + deriving (Eq, Ord, Show, Read) + +data PushSource + = PushesItself | PushedBy Int | NotPushed - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON PushSource where - toEncoding = genericToEncoding defaultOptions -instance FromJSON PushSource + deriving (Eq, Ord, Show, Read) + data Door = Door { _drID :: Int , _drWallIDs :: IS.IntSet - , _drStatus :: DoorStatus + , _drStatus :: DoorStatus , _drTrigger :: WdBl - , _drMech :: DrWdWd - , _drPos :: (Point2,Point2) - , _drOpenPos :: (Point2,Point2) - , _drClosePos :: (Point2,Point2) - , _drHP :: Int - , _drDeath :: DrWdWd - , _drSpeed :: Float + , _drMech :: DrWdWd + , _drPos :: (Point2, Point2) + , _drOpenPos :: (Point2, Point2) + , _drClosePos :: (Point2, Point2) + , _drHP :: Int + , _drDeath :: DrWdWd + , _drSpeed :: Float , _drPushedBy :: PushSource , _drPushes :: Maybe Int , _drMounts :: [MountedObject] - , _drObstructs :: [(Int,Int,PathEdge)] - , _drObstacleType :: EdgeObstacle + , _drObstructs :: [(Int, Int, PathEdge)] + , _drObstacleType :: EdgeObstacle } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Door where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Door + deriving (Eq, Ord, Show, Read) + makeLenses ''Door +deriveJSON defaultOptions ''DoorStatus +deriveJSON defaultOptions ''PushSource +deriveJSON defaultOptions ''Door diff --git a/src/Dodge/Data/EnergyBall.hs b/src/Dodge/Data/EnergyBall.hs index a92291a37..73a529607 100644 --- a/src/Dodge/Data/EnergyBall.hs +++ b/src/Dodge/Data/EnergyBall.hs @@ -1,25 +1,26 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + module Dodge.Data.EnergyBall where -import GHC.Generics -import Data.Aeson -import Geometry.Data + import Color -import Dodge.Data.Damage.Type import Control.Lens +import Data.Aeson +import Data.Aeson.TH +import Dodge.Data.Damage.Type +import Geometry.Data + data EnergyBall = EnergyBall - { _ebVel :: Point2 - , _ebColor :: Color + { _ebVel :: Point2 + , _ebColor :: Color , _ebPos :: Point2 - , _ebWidth :: Float + , _ebWidth :: Float , _ebTimer :: Int - , _ebEff :: (DamageType,Int) + , _ebEff :: (DamageType, Int) , _ebZ :: Float , _ebRot :: Float } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON EnergyBall where - toEncoding = genericToEncoding defaultOptions -instance FromJSON EnergyBall + deriving (Eq, Ord, Show, Read) + makeLenses ''EnergyBall +deriveJSON defaultOptions ''EnergyBall diff --git a/src/Dodge/Data/Equipment/Misc.hs b/src/Dodge/Data/Equipment/Misc.hs index b3a14e3c0..20080fe20 100644 --- a/src/Dodge/Data/Equipment/Misc.hs +++ b/src/Dodge/Data/Equipment/Misc.hs @@ -1,9 +1,11 @@ {-# LANGUAGE StrictData #-} -{-# LANGUAGE DeriveGeneric #-} -module Dodge.Data.Equipment.Misc - where -import GHC.Generics +{-# LANGUAGE TemplateHaskell #-} + +module Dodge.Data.Equipment.Misc where + import Data.Aeson +import Data.Aeson.TH + data EquipSite = GoesOnHead | GoesOnChest @@ -11,10 +13,8 @@ data EquipSite | GoesOnWrist | GoesOnLegs | GoesOnSpecial - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON EquipSite where - toEncoding = genericToEncoding defaultOptions -instance FromJSON EquipSite + deriving (Eq, Ord, Show, Read) + data EquipPosition = OnHead | OnChest @@ -23,9 +23,11 @@ data EquipPosition | OnRightWrist | OnLegs | OnSpecial - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON EquipPosition where - toEncoding = genericToEncoding defaultOptions -instance FromJSON EquipPosition + deriving (Eq, Ord, Show, Read) + instance ToJSONKey EquipPosition + instance FromJSONKey EquipPosition + +deriveJSON defaultOptions ''EquipSite +deriveJSON defaultOptions ''EquipPosition diff --git a/src/Dodge/Data/Flame.hs b/src/Dodge/Data/Flame.hs index 4a0098734..e12a8787a 100644 --- a/src/Dodge/Data/Flame.hs +++ b/src/Dodge/Data/Flame.hs @@ -1,23 +1,24 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + module Dodge.Data.Flame where -import GHC.Generics -import Data.Aeson -import Control.Lens -import Geometry.Data + import Color +import Control.Lens +import Data.Aeson +import Data.Aeson.TH +import Geometry.Data + data Flame = Flame - { _flVel :: Point2 - , _flColor :: Color - , _flPos :: Point2 - , _flWidth :: Float - , _flTimer :: Int - , _flZ :: Float + { _flVel :: Point2 + , _flColor :: Color + , _flPos :: Point2 + , _flWidth :: Float + , _flTimer :: Int + , _flZ :: Float , _flOriginalVel :: Point2 } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Flame where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Flame + deriving (Eq, Ord, Show, Read) + makeLenses ''Flame +deriveJSON defaultOptions ''Flame diff --git a/src/Dodge/Data/Flare.hs b/src/Dodge/Data/Flare.hs index d30567e44..140f25583 100644 --- a/src/Dodge/Data/Flare.hs +++ b/src/Dodge/Data/Flare.hs @@ -1,27 +1,28 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + module Dodge.Data.Flare where -import GHC.Generics -import Data.Aeson + import Color -import Geometry import Control.Lens +import Data.Aeson +import Data.Aeson.TH +import Geometry + data Flare - = MuzFlare - { _flarePoly :: [Point2] - , _flareColor :: Color - , _flareTran3 :: Point3 - , _flareTime :: Int + = MuzFlare + { _flarePoly :: [Point2] + , _flareColor :: Color + , _flareTran3 :: Point3 + , _flareTime :: Int } - | CircFlare - { _flareColor :: Color - , _flareAlpha :: Float - , _flareTran3 :: Point3 - , _flareTime :: Int + | CircFlare + { _flareColor :: Color + , _flareAlpha :: Float + , _flareTran3 :: Point3 + , _flareTime :: Int } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Flare where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Flare + deriving (Eq, Ord, Show, Read) + makeLenses ''Flare +deriveJSON defaultOptions ''Flare diff --git a/src/Dodge/Data/FloatFunction.hs b/src/Dodge/Data/FloatFunction.hs index 8d5e0b98f..e04b7baaa 100644 --- a/src/Dodge/Data/FloatFunction.hs +++ b/src/Dodge/Data/FloatFunction.hs @@ -1,13 +1,17 @@ -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + module Dodge.Data.FloatFunction where -import GHC.Generics + import Data.Aeson -data FloatFloat = FloatID +import Data.Aeson.TH + +data FloatFloat + = FloatID | FloatFOV Float | FloatLessCheck Float | FloatAbsCheckGreaterLess Float Float Float | FloatConst Float - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON FloatFloat where - toEncoding = genericToEncoding defaultOptions -instance FromJSON FloatFloat + deriving (Eq, Ord, Show, Read) + +deriveJSON defaultOptions ''FloatFloat diff --git a/src/Dodge/Data/FloorItem.hs b/src/Dodge/Data/FloorItem.hs index 41a0d1526..b4341aeb6 100644 --- a/src/Dodge/Data/FloorItem.hs +++ b/src/Dodge/Data/FloorItem.hs @@ -1,16 +1,16 @@ -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} -{-# LANGUAGE DeriveGeneric #-} -module Dodge.Data.FloorItem - where +{-# LANGUAGE TemplateHaskell #-} + +module Dodge.Data.FloorItem where + +import Control.Lens +import Data.Aeson +import Data.Aeson.TH import Dodge.Data.Item import Geometry.Data -import GHC.Generics -import Data.Aeson -import Control.Lens -data FloorItem = FlIt { _flIt :: Item , _flItPos :: Point2 , _flItRot :: Float, _flItID :: Int} - deriving (Eq,Show,Read,Generic) -instance ToJSON FloorItem where - toEncoding = genericToEncoding defaultOptions -instance FromJSON FloorItem + +data FloorItem = FlIt {_flIt :: Item, _flItPos :: Point2, _flItRot :: Float, _flItID :: Int} + deriving (Eq, Show, Read) + makeLenses ''FloorItem +deriveJSON defaultOptions ''FloorItem diff --git a/src/Dodge/Data/ForegroundShape.hs b/src/Dodge/Data/ForegroundShape.hs index de7d2990e..1e21cb29c 100644 --- a/src/Dodge/Data/ForegroundShape.hs +++ b/src/Dodge/Data/ForegroundShape.hs @@ -1,21 +1,22 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + module Dodge.Data.ForegroundShape where -import GHC.Generics + +import Control.Lens import Data.Aeson +import Data.Aeson.TH import Geometry import ShapePicture -import Control.Lens + data ForegroundShape = ForegroundShape { _fsID :: Int , _fsPos :: Point2 , _fsDir :: Float - , _fsRad :: Float -- This should probably be a bounding box + , _fsRad :: Float -- This should probably be a bounding box , _fsSPic :: SPic } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON ForegroundShape where - toEncoding = genericToEncoding defaultOptions -instance FromJSON ForegroundShape + deriving (Eq, Ord, Show, Read) + makeLenses ''ForegroundShape +deriveJSON defaultOptions ''ForegroundShape diff --git a/src/Dodge/Data/GenParams.hs b/src/Dodge/Data/GenParams.hs index e42a5bd16..195b641f9 100644 --- a/src/Dodge/Data/GenParams.hs +++ b/src/Dodge/Data/GenParams.hs @@ -1,24 +1,23 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} -module Dodge.Data.GenParams - where -import GHC.Generics -import Data.Aeson +{-# LANGUAGE TemplateHaskell #-} + +module Dodge.Data.GenParams where + import Color -import Dodge.Data.Damage.Type import Control.Lens +import Data.Aeson +import Data.Aeson.TH import qualified Data.Map.Strict as M +import Dodge.Data.Damage.Type + newtype GenParams = GenParams - { _sensorCoding :: M.Map DamageType (PaletteColor,DecorationShape) + { _sensorCoding :: M.Map DamageType (PaletteColor, DecorationShape) } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON GenParams where - toEncoding = genericToEncoding defaultOptions -instance FromJSON GenParams + deriving (Eq, Ord, Show, Read) + data DecorationShape = PLUS | SQUARE | CIRCLE | THREELINES - deriving (Eq,Ord,Enum,Show,Read,Generic) -instance ToJSON DecorationShape where - toEncoding = genericToEncoding defaultOptions -instance FromJSON DecorationShape + deriving (Eq, Ord, Enum, Show, Read) + makeLenses ''GenParams +deriveJSON defaultOptions ''GenParams +deriveJSON defaultOptions ''DecorationShape diff --git a/src/Dodge/Data/GenWorld.hs b/src/Dodge/Data/GenWorld.hs new file mode 100644 index 000000000..8354fd851 --- /dev/null +++ b/src/Dodge/Data/GenWorld.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + +module Dodge.Data.GenWorld ( + module Dodge.Data.GenWorld, + module Dodge.Data.Room, + module Dodge.Data.RoomCluster, + module Dodge.Data.World, +) where + +import Color +import Control.Lens +import Control.Monad.State +import qualified Data.Set as S +import Data.Tile +import Dodge.Data.Room +import Dodge.Data.RoomCluster +import Dodge.Data.World +import Geometry.Data +import qualified IntMapHelp as IM +import Picture.Data +import System.Random + +data GenWorld = GenWorld + { _gwWorld :: World + , _genPlacements :: IM.IntMap [(Placement, Int)] + , _genRooms :: IM.IntMap Room + } + +---- ROOM DATATYPES +data PSType + = PutCrit {_unPutCrit :: Creature} + | PutMachine {_putMachinePoly :: [Point2], _putMachineMachine :: Machine, _putMachineWall :: Wall} + | PutLS LightSource + | PutButton {_putButton :: Button} + | PutProp Prop + | PutTerminal {_unputTerminal :: Terminal} + | PutFlIt {_putItem :: Item} + | PutPPlate PressPlate + | PutBlock {_putBlock :: Block, _putWall :: Wall, _putPoly :: [Point2]} + | PutCoord Point2 + | PutMod Modification + | PutTrigger Bool + | PutLineBlock + { _putWall :: Wall + , _putWidth :: Float + , _putStartPoint :: Point2 + , _putEndPoint :: Point2 + } + | PutWall {_pwPoly :: [Point2], _pwWall :: Wall} + | PutSlideDr Door Wall EdgeObstacle Float Point2 Point2 + | PutDoor Color EdgeObstacle WdBl [(Point2, Point2)] + | RandPS (State StdGen PSType) + | PutForeground ForegroundShape + | PutDecoration Picture + | PutWorldUpdate (PlacementSpot -> World -> World) + | PutNothing + | PutUsingGenParams (World -> (World, PSType)) + | PutID {_putID :: Int} + +-- maybe there is a monadic implementation of this? +-- add room effect for any placement spot? +data PlacementSpot + = PS {_psPos :: Point2, _psRot :: Float} + | PSNoShiftCont {_psPos :: Point2, _psRot :: Float} + | PSPos + { _psSelect :: RoomPos -> Room -> Maybe (PlacementSpot, RoomPos) + , _psRoomEff :: RoomPos -> Room -> Room + , _psFallback :: Maybe Placement + } + | PSRoomRand + { _psRoomRandPointNum :: Int + , _psRandShift :: (Point2, Float) -> PlacementSpot + } + +-- TODO attempt to unify/simplify this union type +data Placement + = Placement + { _plOrder :: Int + , _plSpot :: PlacementSpot + , _plType :: PSType + , _plMID :: Maybe Int + , _plIDCont :: World -> Placement -> Maybe Placement + } + | PlacementUsingPos Point3 (Point3 -> Placement) -- allows a placement to use a shifted position + | RandomPlacement {_unRandomPlacement :: State StdGen Placement} + | PickOnePlacement Int Placement + +{- The '_rmPolys' lists which polygons should be cut out to form the indestructible walls of the room. +Link pairs contain a position and rotation to attach to another room; +0 is for links going to another room to the north, pi/2 for links going to a room to the west, etc. +TODO : Explain path, does it need both directions? +Placement spots allow things to be put in the room during level generation. +Room bounds between a new room and previously placed rooms are checked during level generation, +assigning no bounds will allow rooms to overlap. -} +data Room = Room + { _rmPolys :: [[Point2]] + , _rmLinks :: [RoomLink] + , -- the Int is the number of previous outlinks that have been assigned + _rmLinkEff :: + RoomLink -> -- child link + Room -> -- child room + Int -> -- child number + RoomLink -> -- parent link + Room -> -- parent room + Room + , _rmPos :: [RoomPos] + , _rmPath :: S.Set (Point2, Point2) + , _rmPmnts :: [Placement] + , _rmInPmnt :: [InPlacement] + , _rmOutPmnt :: [OutPlacement] + , _rmBound :: [[Point2]] + , _rmFloor :: Floor + , _rmName :: String + , _rmShift :: (Point2, Float) + , _rmViewpoints :: [Point2] + , _rmRandPSs :: [State StdGen (Point2, Float)] + , _rmStartWires :: IM.IntMap RoomWire + , _rmEndWires :: IM.IntMap RoomWire + , _rmConnectsTo :: S.Set RoomLinkType -> Bool + , _rmMID :: Maybe Int + , _rmMParent :: Maybe Int + , _rmChildren :: [Int] + , _rmType :: RoomType + , _rmClusterStatus :: ClusterStatus + } + +data OutPlacement = OutPlacement + { _opPlacement :: Placement + , _opPlacementID :: Int + } + +data InPlacement = InPlacement + { _ipPlacement :: [Placement] -> Placement + , _ipPlacementID :: Int + } + +makeLenses ''GenWorld +makeLenses ''Room +makeLenses ''RoomType +makeLenses ''PSType +makeLenses ''PlacementSpot +makeLenses ''Placement diff --git a/src/Dodge/Data/Gust.hs b/src/Dodge/Data/Gust.hs index 5aaf1d62f..c9b61aed6 100644 --- a/src/Dodge/Data/Gust.hs +++ b/src/Dodge/Data/Gust.hs @@ -1,20 +1,20 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} -module Dodge.Data.Gust - where -import GHC.Generics -import Data.Aeson -import Geometry.Data +{-# LANGUAGE TemplateHaskell #-} + +module Dodge.Data.Gust where + import Control.Lens +import Data.Aeson +import Data.Aeson.TH +import Geometry.Data + data Gust = Gust - { _guID :: Int + { _guID :: Int , _guPos :: Point2 , _guVel :: Point2 , _guTime :: Int } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Gust where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Gust + deriving (Eq, Ord, Show, Read) + makeLenses ''Gust +deriveJSON defaultOptions ''Gust diff --git a/src/Dodge/Data/HUD.hs b/src/Dodge/Data/HUD.hs index c71529f75..d1aacde53 100644 --- a/src/Dodge/Data/HUD.hs +++ b/src/Dodge/Data/HUD.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} @@ -6,18 +5,13 @@ module Dodge.Data.HUD where import Control.Lens import Data.Aeson -import GHC.Generics +import Data.Aeson.TH import Geometry.Data data HUDElement = DisplayInventory {_subInventory :: SubInventory} | DisplayCarte - deriving (Eq, Ord, Show, Read, Generic) - -instance ToJSON HUDElement where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON HUDElement + deriving (Eq, Ord, Show, Read) data SubInventory = NoSubInventory @@ -26,12 +20,7 @@ data SubInventory | InspectInventory | LockedInventory | DisplayTerminal {_termID :: Int} - deriving (Eq, Ord, Show, Read, Generic) - -instance ToJSON SubInventory where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON SubInventory + deriving (Eq, Ord, Show, Read) data HUD = HUD { _hudElement :: HUDElement @@ -39,13 +28,11 @@ data HUD = HUD , _carteZoom :: Float , _carteRot :: Float } - deriving (Eq, Ord, Show, Read, Generic) - -instance ToJSON HUD where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON HUD + deriving (Eq, Ord, Show, Read) makeLenses ''HUD makeLenses ''HUDElement makeLenses ''SubInventory +deriveJSON defaultOptions ''HUDElement +deriveJSON defaultOptions ''SubInventory +deriveJSON defaultOptions ''HUD diff --git a/src/Dodge/Data/Hammer.hs b/src/Dodge/Data/Hammer.hs index dc71e24aa..e4603a643 100644 --- a/src/Dodge/Data/Hammer.hs +++ b/src/Dodge/Data/Hammer.hs @@ -1,23 +1,23 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} + module Dodge.Data.Hammer where -import GHC.Generics -import Data.Aeson + import Control.Lens +import Data.Aeson +import Data.Aeson.TH + data HammerType = NoHammer | HasHammer {_hammerPosition :: HammerPosition} - deriving (Eq, Ord, Show,Read,Generic) -instance ToJSON HammerType where - toEncoding = genericToEncoding defaultOptions -instance FromJSON HammerType -data HammerPosition + deriving (Eq, Ord, Show, Read) + +data HammerPosition = HammerDown | HammerReleased | HammerUp - deriving (Eq, Ord, Show,Read,Generic) -instance ToJSON HammerPosition where - toEncoding = genericToEncoding defaultOptions -instance FromJSON HammerPosition + deriving (Eq, Ord, Show, Read) + makeLenses ''HammerType +deriveJSON defaultOptions ''HammerType +deriveJSON defaultOptions ''HammerPosition diff --git a/src/Dodge/Data/Item.hs b/src/Dodge/Data/Item.hs index 39635e7e3..8b8c0aa2c 100644 --- a/src/Dodge/Data/Item.hs +++ b/src/Dodge/Data/Item.hs @@ -47,5 +47,8 @@ data Item = Item } deriving (Eq, Show, Read) +_itUseAimStance :: Item -> AimStance +_itUseAimStance = _aimStance . _heldAim . _itUse + makeLenses ''Item deriveJSON defaultOptions ''Item diff --git a/src/Dodge/Data/Item/Combine.hs b/src/Dodge/Data/Item/Combine.hs index e9a475a83..4c748f570 100644 --- a/src/Dodge/Data/Item/Combine.hs +++ b/src/Dodge/Data/Item/Combine.hs @@ -70,7 +70,8 @@ data CraftType deriving (Eq, Ord, Show, Enum, Read) data ItemBaseType - = HELD {_ibtHeld :: HeldItemType} + = NoItemType + | HELD {_ibtHeld :: HeldItemType} | LEFT {_ibtLeft :: LeftItemType} | EQUIP {_ibtEquip :: EquipItemType} | Consumable {_ibtConsumable :: ConsumableItemType} diff --git a/src/Dodge/Data/Item/CurseStatus.hs b/src/Dodge/Data/Item/CurseStatus.hs index ac2d2e016..5e42556f5 100644 --- a/src/Dodge/Data/Item/CurseStatus.hs +++ b/src/Dodge/Data/Item/CurseStatus.hs @@ -1,15 +1,15 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE StrictData #-} ---{-# LANGUAGE TemplateHaskell #-} -module Dodge.Data.Item.CurseStatus - where -import GHC.Generics +{-# LANGUAGE TemplateHaskell #-} + +module Dodge.Data.Item.CurseStatus where + import Data.Aeson -data CurseStatus - = Uncursed - | UndroppableIdentified +import Data.Aeson.TH + +data CurseStatus + = Uncursed + | UndroppableIdentified | UndroppableUnidentified - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON CurseStatus where - toEncoding = genericToEncoding defaultOptions -instance FromJSON CurseStatus + deriving (Eq, Ord, Show, Read) + +deriveJSON defaultOptions ''CurseStatus diff --git a/src/Dodge/Data/Item/HeldDelay.hs b/src/Dodge/Data/Item/HeldDelay.hs new file mode 100644 index 000000000..ab1b8ff12 --- /dev/null +++ b/src/Dodge/Data/Item/HeldDelay.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + +module Dodge.Data.Item.HeldDelay where + +import Control.Lens +import Data.Aeson +import Data.Aeson.TH + +data UseDelay -- should just be Delay + = NoDelay + | FixedRate + { _rateMax :: Int + , _rateTime :: Int + } + | VariableRate + { _rateMax :: Int + , _rateTime :: Int + , _rateMaxMax :: Int + , _rateMinMax :: Int + } + | WarmUpNoDelay + { _warmTime :: Int + , _warmMax :: Int + } + deriving (Eq, Ord, Show, Read) + +makeLenses ''UseDelay +deriveJSON defaultOptions ''UseDelay diff --git a/src/Dodge/Data/Item/Use.hs b/src/Dodge/Data/Item/Use.hs index 1a399f6a0..26361cc3b 100644 --- a/src/Dodge/Data/Item/Use.hs +++ b/src/Dodge/Data/Item/Use.hs @@ -6,8 +6,9 @@ module Dodge.Data.Item.Use ( module Dodge.Data.Item.Use.Equipment, module Dodge.Data.Item.HeldUse, module Dodge.Data.Item.HeldScroll, - module Dodge.Data.Item.UseDelay, + module Dodge.Data.Item.HeldDelay, module Dodge.Data.Item.Use.Consumption, + module Dodge.Data.Hammer, ) where import Control.Lens @@ -18,23 +19,23 @@ import Dodge.Data.Item.HeldScroll import Dodge.Data.Item.HeldUse import Dodge.Data.Item.Use.Consumption import Dodge.Data.Item.Use.Equipment -import Dodge.Data.Item.UseDelay +import Dodge.Data.Item.HeldDelay data ItemUse - = RightUse - { _rUse :: HeldUse - , _useDelay :: UseDelay - , _useMods :: HeldMod - , _useHammer :: HammerPosition - , _useAim :: AimParams + = HeldUse + { _heldUse :: HeldUse + , _heldDelay :: UseDelay + , _heldMods :: HeldMod + , _heldHammer :: HammerPosition + , _heldAim :: AimParams , _heldScroll :: HeldScroll , _heldConsumption :: HeldConsumption } | LeftUse - { _lUse :: Luse - , _useDelay :: UseDelay - , _useHammer :: HammerPosition - , _eqEq :: Equipment + { _leftUse :: Luse + , _leftDelay :: UseDelay + , _leftHammer :: HammerPosition + , _equipEffect :: EquipEffect , _leftConsumption :: LeftConsumption } | ConsumeUse @@ -42,7 +43,7 @@ data ItemUse , _useAmount :: ItAmount } | EquipUse - { _eqEq :: Equipment + { _equipEffect :: EquipEffect } | CraftUse {_useAmount :: ItAmount} diff --git a/src/Dodge/Data/Item/Use/Consumption/Ammo.hs b/src/Dodge/Data/Item/Use/Consumption/Ammo.hs index b59805284..431411fca 100644 --- a/src/Dodge/Data/Item/Use/Consumption/Ammo.hs +++ b/src/Dodge/Data/Item/Use/Consumption/Ammo.hs @@ -12,7 +12,6 @@ import Data.Aeson import Data.Aeson.TH import Dodge.Data.Bullet import Dodge.Data.Payload -import Dodge.Data.Wall data ProjectileDraw = DrawShell | DrawRemoteShell | DrawDrone | DrawBlankProjectile deriving (Show, Read, Eq, Ord, Enum, Bounded) @@ -48,11 +47,14 @@ data AmmoType , _amCreateGas :: GasCreate } | ForceFieldAmmo - { _amForceFieldType :: Wall + { _amForceFieldType :: ForceFieldType } | GenericAmmo deriving (Eq, Ord, Show, Read) +data ForceFieldType = DefaultForceField + deriving (Eq, Ord, Show, Read) + data GasCreate = CreatePoisonGas | CreateFlame deriving (Eq, Ord, Show, Enum, Bounded, Read) @@ -63,3 +65,4 @@ deriveJSON defaultOptions ''ProjectileCreate deriveJSON defaultOptions ''ProjectileUpdate deriveJSON defaultOptions ''AmmoType deriveJSON defaultOptions ''GasCreate +deriveJSON defaultOptions ''ForceFieldType diff --git a/src/Dodge/Data/Item/Use/Equipment.hs b/src/Dodge/Data/Item/Use/Equipment.hs index 0da183070..9b5bcd9b1 100644 --- a/src/Dodge/Data/Item/Use/Equipment.hs +++ b/src/Dodge/Data/Item/Use/Equipment.hs @@ -1,35 +1,34 @@ -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} -{-# LANGUAGE DeriveGeneric #-} -module Dodge.Data.Item.Use.Equipment - ( module Dodge.Data.Equipment.Misc - , module Dodge.Data.Item.Use.Equipment - ) - where -import Dodge.Data.Item.HeldUse -import Dodge.Data.Equipment.Misc -import GHC.Generics -import Data.Aeson +{-# LANGUAGE TemplateHaskell #-} + +module Dodge.Data.Item.Use.Equipment ( + module Dodge.Data.Equipment.Misc, + module Dodge.Data.Item.Use.Equipment, +) where + import Control.Lens -data Equipment = Equipment - { _eqUse :: Euse --Item -> Creature -> World -> World - , _eqOnEquip :: Euse --Item -> Creature -> World -> World - , _eqOnRemove :: Euse --Item -> Creature -> World -> World - , _eqSite :: EquipSite - , _eqParams :: EquipParams - , _eqViewDist :: Maybe Float +import Data.Aeson +import Data.Aeson.TH +import Dodge.Data.Equipment.Misc +import Dodge.Data.Item.HeldUse + +data EquipEffect = EquipEffect + { _eeUse :: Euse --Item -> Creature -> World -> World + , _eeOnEquip :: Euse --Item -> Creature -> World -> World + , _eeOnRemove :: Euse --Item -> Creature -> World -> World + , _eeSite :: EquipSite + , _eeParams :: EquipParams + , _eeViewDist :: Maybe Float } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Equipment where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Equipment + deriving (Eq, Ord, Show, Read) + data EquipParams = NoEquipParams | EquipID {_eparamID :: Int} | EquipCounter {_eparamInt :: Int} - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON EquipParams where - toEncoding = genericToEncoding defaultOptions -instance FromJSON EquipParams -makeLenses ''Equipment + deriving (Eq, Ord, Show, Read) + +makeLenses ''EquipEffect makeLenses ''EquipParams +deriveJSON defaultOptions ''EquipEffect +deriveJSON defaultOptions ''EquipParams diff --git a/src/Dodge/Data/Item/UseDelay.hs b/src/Dodge/Data/Item/UseDelay.hs deleted file mode 100644 index da53dacbd..000000000 --- a/src/Dodge/Data/Item/UseDelay.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE StrictData #-} -{-# LANGUAGE TemplateHaskell #-} -module Dodge.Data.Item.UseDelay where -import GHC.Generics -import Data.Aeson -import Control.Lens -data UseDelay -- should just be Delay - = NoDelay - | FixedRate - {_rateMax :: Int - ,_rateTime :: Int - } - | VariableRate - {_rateMax :: Int - ,_rateTime :: Int - ,_rateMaxMax :: Int - ,_rateMinMax :: Int - } - | WarmUpNoDelay - {_warmTime :: Int - ,_warmMax :: Int - } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON UseDelay where - toEncoding = genericToEncoding defaultOptions -instance FromJSON UseDelay -makeLenses ''UseDelay diff --git a/src/Dodge/Data/Laser.hs b/src/Dodge/Data/Laser.hs index 38e2346ce..b0197100b 100644 --- a/src/Dodge/Data/Laser.hs +++ b/src/Dodge/Data/Laser.hs @@ -1,39 +1,38 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} -module Dodge.Data.Laser - where -import GHC.Generics -import Data.Aeson +{-# LANGUAGE TemplateHaskell #-} + +module Dodge.Data.Laser where + import Color -import Geometry.Data import Control.Lens -data LaserType = DamageLaser {_laserTypeDamage :: Int} +import Data.Aeson +import Data.Aeson.TH +import Geometry.Data + +data LaserType + = DamageLaser {_laserTypeDamage :: Int} | TargetLaser - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON LaserType where - toEncoding = genericToEncoding defaultOptions -instance FromJSON LaserType + deriving (Eq, Ord, Show, Read) + data LaserStart = LaserStart { _lpPhaseV :: Float , _lpPos :: Point2 , _lpDir :: Float , _lpColor :: Color - , _lpType :: LaserType + , _lpType :: LaserType } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON LaserStart where - toEncoding = genericToEncoding defaultOptions -instance FromJSON LaserStart + deriving (Eq, Ord, Show, Read) + data Laser = Laser - { _laColor :: Color + { _laColor :: Color , _laPoints :: [Point2] - , _laType :: LaserType + , _laType :: LaserType } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Laser where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Laser + deriving (Eq, Ord, Show, Read) + makeLenses ''Laser makeLenses ''LaserStart makeLenses ''LaserType +deriveJSON defaultOptions ''LaserType +deriveJSON defaultOptions ''LaserStart +deriveJSON defaultOptions ''Laser diff --git a/src/Dodge/Data/LightSource.hs b/src/Dodge/Data/LightSource.hs index b977dfc55..3e624f746 100644 --- a/src/Dodge/Data/LightSource.hs +++ b/src/Dodge/Data/LightSource.hs @@ -1,58 +1,55 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + module Dodge.Data.LightSource where -import GHC.Generics -import Data.Aeson -import Geometry + import Control.Lens +import Data.Aeson +import Data.Aeson.TH +import Geometry data LightSourceDraw = DefaultLightSourceDraw - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON LightSourceDraw where - toEncoding = genericToEncoding defaultOptions -instance FromJSON LightSourceDraw -data TLSIntensity = ConstantIntensity + deriving (Eq, Ord, Show, Read) + +data TLSIntensity + = ConstantIntensity | TLSFade Point3 Int - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON TLSIntensity where - toEncoding = genericToEncoding defaultOptions -instance FromJSON TLSIntensity -data TLSUpdate = DestroyTLS + deriving (Eq, Ord, Show, Read) + +data TLSUpdate + = DestroyTLS | TimerTLS | IntensityTLS TLSIntensity - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON TLSUpdate where - toEncoding = genericToEncoding defaultOptions -instance FromJSON TLSUpdate + deriving (Eq, Ord, Show, Read) + data LSParam = LSParam - { _lsPos :: !Point3 - , _lsRad :: !Float - , _lsCol :: !Point3 + { _lsPos :: !Point3 + , _lsRad :: !Float + , _lsCol :: !Point3 } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON LSParam where - toEncoding = genericToEncoding defaultOptions -instance FromJSON LSParam -data LightSource = LS - { _lsID :: Int - , _lsParam :: LSParam - , _lsDir :: Float - , _lsPict :: LightSourceDraw --LightSource -> Picture + deriving (Eq, Ord, Show, Read) + +data LightSource = LS + { _lsID :: Int + , _lsParam :: LSParam + , _lsDir :: Float + , _lsPict :: LightSourceDraw --LightSource -> Picture } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON LightSource where - toEncoding = genericToEncoding defaultOptions -instance FromJSON LightSource -data TempLightSource = TLS - { _tlsParam :: LSParam - , _tlsUpdate :: TLSUpdate --TempLightSource -> Maybe TempLightSource - , _tlsTime :: Int + deriving (Eq, Ord, Show, Read) + +data TempLightSource = TLS + { _tlsParam :: LSParam + , _tlsUpdate :: TLSUpdate --TempLightSource -> Maybe TempLightSource + , _tlsTime :: Int } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON TempLightSource where - toEncoding = genericToEncoding defaultOptions -instance FromJSON TempLightSource + deriving (Eq, Ord, Show, Read) + makeLenses ''LSParam makeLenses ''LightSource makeLenses ''TempLightSource +deriveJSON defaultOptions ''LightSourceDraw +deriveJSON defaultOptions ''TLSIntensity +deriveJSON defaultOptions ''TLSUpdate +deriveJSON defaultOptions ''LSParam +deriveJSON defaultOptions ''LightSource +deriveJSON defaultOptions ''TempLightSource diff --git a/src/Dodge/Data/LinearShockwave.hs b/src/Dodge/Data/LinearShockwave.hs index f76170506..9dc3a1d16 100644 --- a/src/Dodge/Data/LinearShockwave.hs +++ b/src/Dodge/Data/LinearShockwave.hs @@ -1,19 +1,20 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + module Dodge.Data.LinearShockwave where -import GHC.Generics -import Data.Aeson -import Geometry.Data + import Control.Lens +import Data.Aeson +import Data.Aeson.TH +import Geometry.Data + data LinearShockwave = LinearShockwave { _lwPos :: Point2 , _lwID :: Int - , _lwPoints :: [(Point2,Point2)] + , _lwPoints :: [(Point2, Point2)] , _lwTimer :: Int } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON LinearShockwave where - toEncoding = genericToEncoding defaultOptions -instance FromJSON LinearShockwave + deriving (Eq, Ord, Show, Read) + makeLenses ''LinearShockwave +deriveJSON defaultOptions ''LinearShockwave diff --git a/src/Dodge/Data/Machine.hs b/src/Dodge/Data/Machine.hs index 670d6e53a..8b29d62fc 100644 --- a/src/Dodge/Data/Machine.hs +++ b/src/Dodge/Data/Machine.hs @@ -6,6 +6,9 @@ module Dodge.Data.Machine ( module Dodge.Data.Machine.Sensor, module Dodge.Data.Material, module Dodge.Data.ObjectType, + module Dodge.Data.Item, + module Dodge.Data.Damage, + module Dodge.Data.GenParams, ) where import Color diff --git a/src/Dodge/Data/Material.hs b/src/Dodge/Data/Material.hs index 0a2564df9..8dae6b7d5 100644 --- a/src/Dodge/Data/Material.hs +++ b/src/Dodge/Data/Material.hs @@ -1,12 +1,14 @@ ---{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TemplateHaskell #-} + +--{-# LANGUAGE FlexibleInstances #-} +--{-# LANGUAGE DeriveGeneric #-} module Dodge.Data.Material where -import GHC.Generics + import Data.Aeson +import Data.Aeson.TH + data Material = Wood | Dirt | Stone | Glass | Metal | Crystal | Flesh | Electronics - deriving (Eq,Ord,Show,Bounded,Enum,Read,Generic) -instance ToJSON Material where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Material + deriving (Eq, Ord, Show, Bounded, Enum, Read) + +deriveJSON defaultOptions ''Material diff --git a/src/Dodge/Data/Modification.hs b/src/Dodge/Data/Modification.hs index 55875d076..70ab3fe20 100644 --- a/src/Dodge/Data/Modification.hs +++ b/src/Dodge/Data/Modification.hs @@ -1,31 +1,30 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} -module Dodge.Data.Modification - where --- this naming is not good, parameterized world effect? +{-# LANGUAGE TemplateHaskell #-} + +module Dodge.Data.Modification where + +import Control.Lens +import Data.Aeson +import Data.Aeson.TH import Dodge.Data.WorldEffect import Geometry.Data -import Control.Lens -import GHC.Generics -import Data.Aeson + data Modification = ModIDTimerPoint3Bool - { _mdID :: Int + { _mdID :: Int , _mdExternalID :: Int , _mdUpdate :: MdWdWd - , _mdTimer :: Int + , _mdTimer :: Int , _mdPoint3 :: Point3 - , _mdBool :: Bool + , _mdBool :: Bool } | ModIDID - { _mdID :: Int + { _mdID :: Int , _mdExternalID1 :: Int , _mdExternalID2 :: Int , _mdUpdate :: MdWdWd } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Modification where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Modification + deriving (Eq, Ord, Show, Read) + makeLenses ''Modification +deriveJSON defaultOptions ''Modification diff --git a/src/Dodge/Data/PosEvent.hs b/src/Dodge/Data/PosEvent.hs index 371a3552a..7d0dc70b1 100644 --- a/src/Dodge/Data/PosEvent.hs +++ b/src/Dodge/Data/PosEvent.hs @@ -1,23 +1,23 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + module Dodge.Data.PosEvent where -import GHC.Generics -import Data.Aeson -import Geometry.Data + import Control.Lens +import Data.Aeson +import Data.Aeson.TH +import Geometry.Data + data PosEventType = SparkSpawner - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON PosEventType where - toEncoding = genericToEncoding defaultOptions -instance FromJSON PosEventType + deriving (Eq, Ord, Show, Read) + data PosEvent = PosEvent - { _pvType :: PosEventType - , _pvTimer :: Int - , _pvPos :: Point2 + { _pvType :: PosEventType + , _pvTimer :: Int + , _pvPos :: Point2 } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON PosEvent where - toEncoding = genericToEncoding defaultOptions -instance FromJSON PosEvent + deriving (Eq, Ord, Show, Read) + makeLenses ''PosEvent +deriveJSON defaultOptions ''PosEventType +deriveJSON defaultOptions ''PosEvent diff --git a/src/Dodge/Data/PressPlate.hs b/src/Dodge/Data/PressPlate.hs index 7b449c853..53ecb257b 100644 --- a/src/Dodge/Data/PressPlate.hs +++ b/src/Dodge/Data/PressPlate.hs @@ -1,20 +1,20 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} -module Dodge.Data.PressPlate - where -import GHC.Generics +{-# LANGUAGE TemplateHaskell #-} + +module Dodge.Data.PressPlate where + +import Control.Lens import Data.Aeson +import Data.Aeson.TH import Geometry.Data import Picture -import Control.Lens -data PressPlateEvent = PressPlateId + +data PressPlateEvent + = PressPlateId | PPLevelReset - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON PressPlateEvent where - toEncoding = genericToEncoding defaultOptions -instance FromJSON PressPlateEvent -data PressPlate = PressPlate + deriving (Eq, Ord, Show, Read) + +data PressPlate = PressPlate { _ppPict :: Picture , _ppPos :: Point2 , _ppRot :: Float @@ -22,8 +22,8 @@ data PressPlate = PressPlate , _ppID :: Int , _ppText :: String } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON PressPlate where - toEncoding = genericToEncoding defaultOptions -instance FromJSON PressPlate + deriving (Eq, Ord, Show, Read) + makeLenses ''PressPlate +deriveJSON defaultOptions ''PressPlateEvent +deriveJSON defaultOptions ''PressPlate diff --git a/src/Dodge/Data/Projectile.hs b/src/Dodge/Data/Projectile.hs index 5783bfc1f..3c4e39302 100644 --- a/src/Dodge/Data/Projectile.hs +++ b/src/Dodge/Data/Projectile.hs @@ -1,16 +1,16 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + module Dodge.Data.Projectile where -import GHC.Generics + +import Control.Lens import Data.Aeson -import Dodge.Data.Payload +import Data.Aeson.TH import Dodge.Data.Item.Use.Consumption.Ammo import Geometry.Data -import Control.Lens ---data ProjectileType = ShellType + data Proj - = RemoteShell + = RemoteShell { _prjPos :: Point2 , _prjStartPos :: Point2 , _prjVel :: Point2 @@ -19,7 +19,7 @@ data Proj , _prjPayload :: Payload , _prjMITID :: Maybe Int } - | Shell + | Shell { _prjPos :: Point2 , _prjStartPos :: Point2 , _prjVel :: Point2 @@ -34,8 +34,7 @@ data Proj , _prjUpdates :: [ProjectileUpdate] , _prjMITID :: Maybe Int } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Proj where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Proj + deriving (Eq, Ord, Show, Read) + makeLenses ''Proj +deriveJSON defaultOptions ''Proj diff --git a/src/Dodge/Data/RadarBlip.hs b/src/Dodge/Data/RadarBlip.hs index 7c3ed2219..7a8fbaa51 100644 --- a/src/Dodge/Data/RadarBlip.hs +++ b/src/Dodge/Data/RadarBlip.hs @@ -1,21 +1,22 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + module Dodge.Data.RadarBlip where -import GHC.Generics -import Data.Aeson + import Color -import Geometry import Control.Lens +import Data.Aeson +import Data.Aeson.TH +import Geometry + data RadarBlip = RadarBlip - { _rbColor :: Color - , _rbTime :: Int - , _rbMaxTime :: Int - , _rbRad :: Float - , _rbPos :: Point2 + { _rbColor :: Color + , _rbTime :: Int + , _rbMaxTime :: Int + , _rbRad :: Float + , _rbPos :: Point2 } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON RadarBlip where - toEncoding = genericToEncoding defaultOptions -instance FromJSON RadarBlip + deriving (Eq, Ord, Show, Read) + makeLenses ''RadarBlip +deriveJSON defaultOptions ''RadarBlip diff --git a/src/Dodge/Data/RightButtonOptions.hs b/src/Dodge/Data/RightButtonOptions.hs index 7571c8c42..e73a77a67 100644 --- a/src/Dodge/Data/RightButtonOptions.hs +++ b/src/Dodge/Data/RightButtonOptions.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} @@ -6,8 +5,8 @@ module Dodge.Data.RightButtonOptions where import Control.Lens import Data.Aeson +import Data.Aeson.TH import Dodge.Data.Equipment.Misc -import GHC.Generics data RightButtonOptions = NoRightButtonOptions @@ -18,24 +17,14 @@ data RightButtonOptions , _opAllocateEquipment :: AllocateEquipment , _opActivateEquipment :: ActivateEquipment } - deriving (Eq, Ord, Show, Read, Generic) - -instance ToJSON RightButtonOptions where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON RightButtonOptions + deriving (Eq, Ord, Show, Read) data ActivateEquipment = ActivateEquipment {_activateEquipment :: Int} | DeactivateEquipment {_deactivateEquipment :: Int} | ActivateDeactivateEquipment {_activateEquipment :: Int, _deactivateEquipment :: Int} | NoChangeActivateEquipment - deriving (Eq, Ord, Show, Read, Generic) - -instance ToJSON ActivateEquipment where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON ActivateEquipment + deriving (Eq, Ord, Show, Read) data AllocateEquipment = DoNotMoveEquipment @@ -58,13 +47,11 @@ data AllocateEquipment | RemoveEquipment { _allocOldPos :: EquipPosition } - deriving (Eq, Ord, Show, Read, Generic) - -instance ToJSON AllocateEquipment where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON AllocateEquipment + deriving (Eq, Ord, Show, Read) makeLenses ''RightButtonOptions makeLenses ''AllocateEquipment makeLenses ''ActivateEquipment +deriveJSON defaultOptions ''RightButtonOptions +deriveJSON defaultOptions ''ActivateEquipment +deriveJSON defaultOptions ''AllocateEquipment diff --git a/src/Dodge/Data/Room.hs b/src/Dodge/Data/Room.hs index fa0296f62..e2c8e8922 100644 --- a/src/Dodge/Data/Room.hs +++ b/src/Dodge/Data/Room.hs @@ -1,26 +1,30 @@ -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + module Dodge.Data.Room where + +import Control.Lens +import qualified Data.Set as S import Geometry -import qualified Data.Set as S -import Control.Lens - data RoomPos = RoomPos - { _rpPos :: Point2 + { _rpPos :: Point2 , _rpDir :: Float , _rpType :: S.Set RoomPosType , _rpLinkStatus :: RPLinkStatus , _rpPlacementUse :: Int } - deriving (Eq,Ord,Show) + deriving (Eq, Ord, Show) data RoomLink = RoomLink - { _rlType :: S.Set RoomLinkType - , _rlPos :: Point2 - , _rlDir :: Float - } deriving (Eq,Ord) -data RoomType = DefaultRoomType + { _rlType :: S.Set RoomLinkType + , _rlPos :: Point2 + , _rlDir :: Float + } + deriving (Eq, Ord) + +data RoomType + = DefaultRoomType | RectRoomType { _numLinkEW :: Int , _numLinkNS :: Int @@ -29,7 +33,8 @@ data RoomType = DefaultRoomType , _rmWidth :: Float , _rmHeight :: Float } - deriving (Eq,Ord) + deriving (Eq, Ord) + data RoomLinkType = OutLink | InLink @@ -37,39 +42,42 @@ data RoomLinkType | OnEdge CardinalPoint | FromEdge CardinalPoint Int | BlockedLink - deriving (Eq,Ord,Show) + deriving (Eq, Ord, Show) + data CardinalPoint = North | East | South | West - deriving (Eq,Ord,Show) + deriving (Eq, Ord, Show) + data RoomWire = --RoomWire Point2 Float - WallWire Point2 Float Float + WallWire Point2 Float Float data RPLinkStatus - = UsedOutLink - { _rplsType :: S.Set RoomLinkType + = UsedOutLink + { _rplsType :: S.Set RoomLinkType , _rplsChildNum :: Int , _rplsOutRoomID :: Int } - | UsedInLink - { _rplsType :: S.Set RoomLinkType + | UsedInLink + { _rplsType :: S.Set RoomLinkType , _rplsInRoomID :: Int } - | UnusedLink { _rplsType :: S.Set RoomLinkType } + | UnusedLink {_rplsType :: S.Set RoomLinkType} | NotLink - deriving (Eq,Ord,Show) -data PathFromEdge = PathFromEdge CardinalPoint Int - deriving (Eq,Ord,Show) + deriving (Eq, Ord, Show) -data RoomPosType +data PathFromEdge = PathFromEdge CardinalPoint Int + deriving (Eq, Ord, Show) + +data RoomPosType = RoomPosOnPath {_onPathFromEdges :: S.Set PathFromEdge} | RoomPosOffPath {_offPathFromEdges :: S.Set PathFromEdge} | RoomPosExLink | RoomPosLab Int - deriving (Eq,Ord,Show) + deriving (Eq, Ord, Show) makeLenses ''RoomLink makeLenses ''RoomPos diff --git a/src/Dodge/Data/Shockwave.hs b/src/Dodge/Data/Shockwave.hs index 602835dcc..bd412929f 100644 --- a/src/Dodge/Data/Shockwave.hs +++ b/src/Dodge/Data/Shockwave.hs @@ -1,31 +1,30 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} -module Dodge.Data.Shockwave - where -import GHC.Generics -import Data.Aeson +{-# LANGUAGE TemplateHaskell #-} + +module Dodge.Data.Shockwave where + import Color -import Geometry.Data import Control.Lens +import Data.Aeson +import Data.Aeson.TH +import Geometry.Data + data ShockwaveDirection = OutwardShockwave | InwardShockwave - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON ShockwaveDirection where - toEncoding = genericToEncoding defaultOptions -instance FromJSON ShockwaveDirection + deriving (Eq, Ord, Show, Read) + data Shockwave = Shockwave - { _swColor :: Color - , _swDirection :: ShockwaveDirection + { _swColor :: Color + , _swDirection :: ShockwaveDirection , _swInvulnerableCrs :: [Int] - , _swPos :: Point2 - , _swRad :: Float - , _swDam :: Int - , _swPush :: Float - , _swMaxTime :: Int - , _swTimer :: Int + , _swPos :: Point2 + , _swRad :: Float + , _swDam :: Int + , _swPush :: Float + , _swMaxTime :: Int + , _swTimer :: Int } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Shockwave where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Shockwave + deriving (Eq, Ord, Show, Read) + makeLenses ''Shockwave +deriveJSON defaultOptions ''ShockwaveDirection +deriveJSON defaultOptions ''Shockwave diff --git a/src/Dodge/Data/Spark.hs b/src/Dodge/Data/Spark.hs index e74c6d2f7..85831d84d 100644 --- a/src/Dodge/Data/Spark.hs +++ b/src/Dodge/Data/Spark.hs @@ -1,23 +1,24 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + module Dodge.Data.Spark where -import GHC.Generics -import Data.Aeson -import Dodge.Data.Damage.Type -import Geometry.Data + import Color import Control.Lens +import Data.Aeson +import Data.Aeson.TH +import Dodge.Data.Damage.Type +import Geometry.Data + data Spark = Spark - { _skVel :: Point2 - , _skColor :: Color - , _skPos :: Point2 + { _skVel :: Point2 + , _skColor :: Color + , _skPos :: Point2 , _skOldPos :: Point2 - , _skWidth :: Float + , _skWidth :: Float , _skDamageType :: DamageType } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Spark where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Spark + deriving (Eq, Ord, Show, Read) + makeLenses ''Spark +deriveJSON defaultOptions ''Spark diff --git a/src/Dodge/Data/Terminal.hs b/src/Dodge/Data/Terminal.hs index 1b0d869d4..c6b4393cf 100644 --- a/src/Dodge/Data/Terminal.hs +++ b/src/Dodge/Data/Terminal.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} @@ -7,40 +6,25 @@ module Dodge.Data.Terminal where import Color import Control.Lens import Data.Aeson +import Data.Aeson.TH import qualified Data.Map.Strict as M import qualified Data.Text as T import Dodge.Data.WorldEffect -import GHC.Generics data TerminalStatus = TerminalOff | TerminalBusy | TerminalReady - deriving (Eq, Ord, Show, Read, Generic) - -instance ToJSON TerminalStatus where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON TerminalStatus + deriving (Eq, Ord, Show, Read) data TerminalInput = TerminalInput { _tiText :: T.Text , _tiFocus :: Bool , _tiSel :: (Int, Int) } - deriving (Eq, Ord, Show, Read, Generic) - -instance ToJSON TerminalInput where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON TerminalInput + deriving (Eq, Ord, Show, Read) data TerminalBootProgram = TerminalBootMempty | TerminalBootLines [TerminalLine] - deriving (Eq, Show, Read, Generic) - -instance ToJSON TerminalBootProgram where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON TerminalBootProgram + deriving (Eq, Show, Read) data Terminal = Terminal { _tmID :: Int @@ -60,31 +44,16 @@ data Terminal = Terminal , _tmCommandHistory :: [String] , _tmToggles :: M.Map String TerminalToggle } - deriving (Eq, Show, Read, Generic) - -instance ToJSON Terminal where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON Terminal + deriving (Eq, Show, Read) data TerminalLineString = TerminalLineConst String Color - deriving (Eq, Ord, Show, Read, Generic) - -instance ToJSON TerminalLineString where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON TerminalLineString + deriving (Eq, Ord, Show, Read) data TmTm = TmId | TmTmClearDisplayedLines | TmTmSetStatus TerminalStatus - deriving (Eq, Ord, Show, Read, Generic) - -instance ToJSON TmTm where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON TmTm + deriving (Eq, Ord, Show, Read) data TerminalLine = TerminalLineDisplay @@ -99,34 +68,19 @@ data TerminalLine { _tlPause :: Int , _tlEffect :: TmWdWd --Terminal -> World -> World } - deriving (Eq, Show, Read, Generic) - -instance ToJSON TerminalLine where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON TerminalLine + deriving (Eq, Show, Read) data TerminalToggle = TerminalToggle { _ttTriggerID :: Int , _ttDeathEffect :: BlBl } - deriving (Eq, Ord, Show, Read, Generic) - -instance ToJSON TerminalToggle where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON TerminalToggle + deriving (Eq, Ord, Show, Read) data BlBl = BlNegate | BlConst Bool | BlId - deriving (Eq, Ord, Show, Read, Generic) - -instance ToJSON BlBl where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON BlBl + deriving (Eq, Ord, Show, Read) data EffectArguments = NoArguments {_cmdEffect :: [TerminalLine]} @@ -134,12 +88,7 @@ data EffectArguments { _argType :: String , _argList :: M.Map String [TerminalLine] } - deriving (Eq, Show, Read, Generic) - -instance ToJSON EffectArguments where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON EffectArguments + deriving (Eq, Show, Read) data TerminalCommandEffect = TerminalCommandArguments EffectArguments @@ -151,12 +100,7 @@ data TerminalCommandEffect | TerminalCommandEffectCommands | TerminalCommandEffectSingleCommand WdWd [String] | TerminalCommandEffectNone - deriving (Eq, Show, Read, Generic) - -instance ToJSON TerminalCommandEffect where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON TerminalCommandEffect + deriving (Eq, Show, Read) data TerminalCommand = TerminalCommand { _tcString :: String @@ -164,12 +108,7 @@ data TerminalCommand = TerminalCommand , _tcHelp :: String , _tcEffect :: TerminalCommandEffect -- Terminal -> World -> EffectArguments } - deriving (Eq, Show, Read, Generic) - -instance ToJSON TerminalCommand where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON TerminalCommand + deriving (Eq, Show, Read) makeLenses ''TerminalInput makeLenses ''Terminal @@ -177,3 +116,15 @@ makeLenses ''TerminalLine makeLenses ''TerminalToggle makeLenses ''EffectArguments makeLenses ''TerminalCommand +deriveJSON defaultOptions ''TerminalStatus +deriveJSON defaultOptions ''TerminalInput +deriveJSON defaultOptions ''TerminalBootProgram +deriveJSON defaultOptions ''Terminal +deriveJSON defaultOptions ''TerminalLineString +deriveJSON defaultOptions ''TmTm +deriveJSON defaultOptions ''TerminalLine +deriveJSON defaultOptions ''TerminalToggle +deriveJSON defaultOptions ''BlBl +deriveJSON defaultOptions ''EffectArguments +deriveJSON defaultOptions ''TerminalCommandEffect +deriveJSON defaultOptions ''TerminalCommand diff --git a/src/Dodge/Data/TeslaArc.hs b/src/Dodge/Data/TeslaArc.hs index 1a672739d..6834424f6 100644 --- a/src/Dodge/Data/TeslaArc.hs +++ b/src/Dodge/Data/TeslaArc.hs @@ -1,21 +1,22 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + module Dodge.Data.TeslaArc where -import GHC.Generics -import Data.Aeson -import Geometry.Data + import Color import Control.Lens +import Data.Aeson +import Data.Aeson.TH import Dodge.Data.ArcStep +import Geometry.Data + data TeslaArc = TeslaArc { _taPoints :: [Point2] , _taTimer :: Int , _taArcSteps :: [ArcStep] , _taColor :: Color } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON TeslaArc where - toEncoding = genericToEncoding defaultOptions -instance FromJSON TeslaArc + deriving (Eq, Ord, Show, Read) + makeLenses ''TeslaArc +deriveJSON defaultOptions ''TeslaArc diff --git a/src/Dodge/Data/TractorBeam.hs b/src/Dodge/Data/TractorBeam.hs index 07a569c8c..3e4a8a9da 100644 --- a/src/Dodge/Data/TractorBeam.hs +++ b/src/Dodge/Data/TractorBeam.hs @@ -1,19 +1,20 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + module Dodge.Data.TractorBeam where -import GHC.Generics -import Data.Aeson -import Geometry.Data + import Control.Lens +import Data.Aeson +import Data.Aeson.TH +import Geometry.Data + data TractorBeam = TractorBeam { _tbPos :: Point2 , _tbStartPos :: Point2 , _tbVel :: Point2 , _tbTime :: Int } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON TractorBeam where - toEncoding = genericToEncoding defaultOptions -instance FromJSON TractorBeam + deriving (Eq, Ord, Show, Read) + makeLenses ''TractorBeam +deriveJSON defaultOptions ''TractorBeam diff --git a/src/Dodge/Data/Universe.hs b/src/Dodge/Data/Universe.hs new file mode 100644 index 000000000..7077b5e96 --- /dev/null +++ b/src/Dodge/Data/Universe.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + +module Dodge.Data.Universe ( + module Dodge.Data.Universe, + module Dodge.Data.Config, + module Dodge.Data.World, + module Data.Preload, + module Picture.Data, +) where + +import Control.Lens +import qualified Data.Map.Strict as M +import Data.Preload +import qualified Data.Text as T +import Dodge.Data.Config +import Dodge.Data.World +import Picture.Data +import SDL (Scancode) + +data Universe = Universe + { _uvWorld :: World + , _preloadData :: PreloadData + , _menuLayers :: [ScreenLayer] + , _savedWorlds :: M.Map SaveSlot World + , _uvIOEffects :: Universe -> IO Universe + , _uvConfig :: Configuration + , _uvTestString :: Universe -> [String] + } + +data SaveSlot + = QuicksaveSlot + | LevelStartSlot + | SaveSlotNum Int + deriving (Eq, Ord, Show, Read) + +data OptionScreenFlag = NormalOptions | GameOverOptions + deriving (Eq, Ord, Show, Read) + +data ScreenLayer + = OptionScreen + { _scTitle :: Universe -> String + , _scOptions :: [MenuOption] + , _scDefaultEff :: Universe -> IO (Maybe Universe) + , _scOptionFlag :: OptionScreenFlag + , _scOptionsOffset :: Int + } + | ColumnsScreen + { _scTitle :: Universe -> String + , _scColumns :: [(String, String)] + } + | InputScreen + { _scInput :: T.Text + , _scFooter :: String + } + | WaitScreen + { _scWaitMessage :: Universe -> String + , _scWaitTime :: Int + } + | DisplayScreen + { _scDisplay :: Universe -> Picture + } + +data MenuOption + = Toggle + { _moEff :: Universe -> IO (Maybe Universe) + , _moString :: Universe -> Either String (String, String) + , _moKey :: Scancode + } + | Toggle2 + { _moKey1 :: Scancode + , _moEff1 :: Universe -> IO (Maybe Universe) + , _moKey2 :: Scancode + , _moEff2 :: Universe -> IO (Maybe Universe) + , _moString :: Universe -> Either String (String, String) + } + | InvisibleToggle + { _moKey :: Scancode + , _moEff :: Universe -> IO (Maybe Universe) + } + +data IntID a = IntID Int a + +makeLenses ''Universe +makeLenses ''ScreenLayer diff --git a/src/Dodge/Data/Wall.hs b/src/Dodge/Data/Wall.hs index 4c4674a38..fb3a15723 100644 --- a/src/Dodge/Data/Wall.hs +++ b/src/Dodge/Data/Wall.hs @@ -1,64 +1,63 @@ -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE DeriveGeneric #-} -module Dodge.Data.Wall where -import GHC.Generics -import Data.Aeson -import Dodge.Data.Material -import Geometry +{-# LANGUAGE TemplateHaskell #-} + +module Dodge.Data.Wall ( + module Dodge.Data.Wall, + module Dodge.Data.Material, +) where + import Color import Control.Lens -data Wall = Wall - { _wlLine :: (Point2,Point2) - , _wlID :: Int - , _wlColor :: Color - , _wlSeen :: Bool - , _wlOpacity :: Opacity - , _wlPathable :: Bool - , _wlPenetrable :: Bool - , _wlBouncy :: Bool - , _wlWalkable :: Bool - , _wlTouchThrough :: Bool - , _wlFireThrough :: Bool - , _wlReflect :: Bool - , _wlUnshadowed :: Bool - , _wlRotateTo :: Bool - , _wlStructure :: WallStructure - , _wlHeight :: Float - , _wlMaterial :: Material +import Data.Aeson +import Data.Aeson.TH +import Dodge.Data.Material +import Geometry + +data Wall = Wall + { _wlLine :: (Point2, Point2) + , _wlID :: Int + , _wlColor :: Color + , _wlSeen :: Bool + , _wlOpacity :: Opacity + , _wlPathable :: Bool + , _wlPenetrable :: Bool + , _wlBouncy :: Bool + , _wlWalkable :: Bool + , _wlTouchThrough :: Bool + , _wlFireThrough :: Bool + , _wlReflect :: Bool + , _wlUnshadowed :: Bool + , _wlRotateTo :: Bool + , _wlStructure :: WallStructure + , _wlHeight :: Float + , _wlMaterial :: Material } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Wall where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Wall + deriving (Eq, Ord, Show, Read) + data Opacity = SeeThrough | SeeAbove - | DrawnWall {_opDraw :: WallDraw } -- Wall -> SPic + | DrawnWall {_opDraw :: WallDraw} -- Wall -> SPic | Opaque - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Opacity where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Opacity + deriving (Eq, Ord, Show, Read) + data WallDraw = DrawForceField - deriving (Eq,Ord,Show,Read,Enum,Bounded,Generic) -instance ToJSON WallDraw where - toEncoding = genericToEncoding defaultOptions -instance FromJSON WallDraw -data WallStructure + deriving (Eq, Ord, Show, Read, Enum, Bounded) + +data WallStructure = StandaloneWall - | DoorPart { _wsDoor :: Int } - | MachinePart { _wsMachine :: Int } - | BlockPart { _wsBlock :: Int } - | CreaturePart - { _wlStCreature :: Int --- , _wlStDamCreature :: Damage -> Wall -> Int -> World -> World + | DoorPart {_wsDoor :: Int} + | MachinePart {_wsMachine :: Int} + | BlockPart {_wsBlock :: Int} + | CreaturePart + { _wlStCreature :: Int } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON WallStructure where - toEncoding = genericToEncoding defaultOptions -instance FromJSON WallStructure + deriving (Eq, Ord, Show, Read) + makeLenses ''Wall makeLenses ''Opacity makeLenses ''WallStructure +deriveJSON defaultOptions ''Wall +deriveJSON defaultOptions ''Opacity +deriveJSON defaultOptions ''WallDraw +deriveJSON defaultOptions ''WallStructure diff --git a/src/Dodge/Data/World.hs b/src/Dodge/Data/World.hs new file mode 100644 index 000000000..a488312a2 --- /dev/null +++ b/src/Dodge/Data/World.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + +module Dodge.Data.World ( + module Dodge.Data.World, + module Dodge.Data.CWorld, + module Dodge.Data.RightButtonOptions, + module Dodge.Data.SoundOrigin, + module Dodge.Data.Hammer, +) where + +import Control.Lens +import qualified Data.Map.Strict as M +import qualified Data.Set as S +import Dodge.Data.CWorld +import Dodge.Data.Hammer +import Dodge.Data.RightButtonOptions +import Dodge.Data.SoundOrigin +import Geometry.Data +import SDL (MouseButton, Scancode) +import Sound.Data +import StreamingHelp +import System.Random + +data World = World + { _cWorld :: CWorld + , _randGen :: StdGen + , _toPlaySounds :: M.Map SoundOrigin Sound + , _playingSounds :: M.Map SoundOrigin Sound + , _mousePos :: Point2 + , _keys :: S.Set Scancode + , _mouseButtons :: M.Map MouseButton Bool + , _hammers :: M.Map WorldHammer HammerPosition + , _testFloat :: Float + , _lLine :: (Point2, Point2) + , _rLine :: (Point2, Point2) + , _lSelect :: Point2 + , _rSelect :: Point2 + , _backspaceTimer :: Int + , _timeFlow :: TimeFlowStatus + , _rbOptions :: RightButtonOptions + } + +data TimeFlowStatus + = RewindingNow + | RewindingLastFrame + | NormalTimeFlow + deriving (Eq, Ord, Show, Read) + +data WorldHammer + = SubInvHam + | DoubleMouseHam + deriving (Eq, Ord, Show, Read, Enum, Bounded) + +type HitEffect' = + Flame -> + StreamOf (Point2, Either Creature Wall) -> + World -> + (World, Maybe Flame) + +makeLenses ''World diff --git a/src/Dodge/Data/WorldEffect.hs b/src/Dodge/Data/WorldEffect.hs index 168763aea..dbc6f00ab 100644 --- a/src/Dodge/Data/WorldEffect.hs +++ b/src/Dodge/Data/WorldEffect.hs @@ -1,27 +1,20 @@ -{-# LANGUAGE DeriveGeneric #-} ---{-# LANGUAGE DeriveGeneric #-} ---{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} module Dodge.Data.WorldEffect where import Data.Aeson +import Data.Aeson.TH import Dodge.Data.CreatureEffect import Dodge.Data.Item import Dodge.Data.SoundOrigin -import GHC.Generics import Geometry.Data import Sound.Data data ItCrWdWd = ItCrWdId | ItCrWdItemEffect - deriving (Eq, Ord, Show, Read, Generic) - -instance ToJSON ItCrWdWd where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON ItCrWdWd + deriving (Eq, Ord, Show, Read) data WdWd = NoWorldEffect @@ -36,34 +29,19 @@ data WdWd | WdWdNegateTrig Int | WdWdFromItixCrixWdWd Int Int ItCrWdWd | WdWdFromItCrixWdWd Item Int ItCrWdWd - deriving (Eq, Show, Read, Generic) - -instance ToJSON WdWd where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON WdWd + deriving (Eq, Show, Read) data WdP2 = WdP2Const Point2 | WdYouPos - deriving (Eq, Ord, Show, Read, Generic) - -instance ToJSON WdP2 where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON WdP2 + deriving (Eq, Ord, Show, Read) data MdWdWd = MdWdId | MdTrigIf MdWdWd MdWdWd | MdSetLSCol Point3 | MdFlickerUpdate - deriving (Eq, Ord, Show, Read, Generic) - -instance ToJSON MdWdWd where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON MdWdWd + deriving (Eq, Ord, Show, Read) data WdBl = WdTrig Int @@ -73,34 +51,19 @@ data WdBl | WdBlCrFilterNearPoint Float Point2 CrBl | WdBlBtOn Int | WdBlBtNotOff Int - deriving (Eq, Ord, Show, Read, Generic) - -instance ToJSON WdBl where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON WdBl + deriving (Eq, Ord, Show, Read) data WdP2f = WdP2f0 | WdP2fDoorPosition Int - deriving (Eq, Ord, Show, Read, Generic) - -instance ToJSON WdP2f where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON WdP2f + deriving (Eq, Ord, Show, Read) data DrWdWd = DrWdId | DrWdMakeDoorDebris | DrWdMechanismStepwise Int [Int] [(Point2, Point2)] | DoorMechanism - deriving (Eq, Ord, Show, Read, Generic) - -instance ToJSON DrWdWd where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON DrWdWd + deriving (Eq, Ord, Show, Read) data TmWdWd = TmWdId @@ -108,9 +71,13 @@ data TmWdWd | TmWdWdfromWdWd WdWd | TmWdWdTermSound SoundID | TmWdWdDoDeathTriggers - deriving (Eq, Show, Read, Generic) + deriving (Eq, Show, Read) -instance ToJSON TmWdWd where - toEncoding = genericToEncoding defaultOptions - -instance FromJSON TmWdWd +deriveJSON defaultOptions ''ItCrWdWd +deriveJSON defaultOptions ''WdWd +deriveJSON defaultOptions ''WdP2 +deriveJSON defaultOptions ''MdWdWd +deriveJSON defaultOptions ''WdBl +deriveJSON defaultOptions ''WdP2f +deriveJSON defaultOptions ''DrWdWd +deriveJSON defaultOptions ''TmWdWd diff --git a/src/Dodge/Data/Zoning.hs b/src/Dodge/Data/Zoning.hs index ff01d1c9e..74158a76b 100644 --- a/src/Dodge/Data/Zoning.hs +++ b/src/Dodge/Data/Zoning.hs @@ -1,18 +1,21 @@ -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + module Dodge.Data.Zoning where -import Geometry.Data + import Control.Lens -import qualified IntMapHelp as IM import qualified Data.IntSet as IS +import Geometry.Data +import qualified IntMapHelp as IM import StreamingHelp data Zoning t a = Zoning - { _znObjects :: IM.IntMap (IM.IntMap (t a)) - , _znSize :: Float - , _znFunc :: Float -> a -> StreamOf Int2 --- , _znInsert :: a -> t a -> t a + { _znObjects :: IM.IntMap (IM.IntMap (t a)) + , _znSize :: Float + , _znFunc :: Float -> a -> StreamOf Int2 + -- , _znInsert :: a -> t a -> t a } + newtype CrZoning = CrZoning {_getCrZoning :: IM.IntMap (IM.IntMap IS.IntSet)} makeLenses ''Zoning diff --git a/src/Dodge/Debug/LinkDecoration.hs b/src/Dodge/Debug/LinkDecoration.hs index e4a1edec0..d8be82c48 100644 --- a/src/Dodge/Debug/LinkDecoration.hs +++ b/src/Dodge/Debug/LinkDecoration.hs @@ -1,35 +1,35 @@ -module Dodge.Debug.LinkDecoration - ( addRoomLinkDecorations - , addRoomPolyDecorations - ) where -import Dodge.Data -import Dodge.RoomLink ---import Dodge.Base ---import Dodge.LevelGen.Data -import Picture -import qualified IntMapHelp as IM -import Geometry.Data -import Geometry.Vector +module Dodge.Debug.LinkDecoration ( + addRoomLinkDecorations, + addRoomPolyDecorations, +) where import Control.Lens +import Dodge.Data.GenWorld +import Dodge.RoomLink +import Geometry.Data +import Geometry.Vector +import qualified IntMapHelp as IM +import Picture addRoomPolyDecorations :: [Room] -> World -> World -addRoomPolyDecorations rms w = w & cWorld . decorations %~ - IM.insertWithNewKeys (map roomPolyDecorations rms) +addRoomPolyDecorations rms w = + w & cWorld . decorations + %~ IM.insertWithNewKeys (map roomPolyDecorations rms) addRoomLinkDecorations :: [Room] -> World -> World -addRoomLinkDecorations rms w = w & cWorld . decorations %~ - IM.insertWithNewKeys (map roomLinkDecorations rms) +addRoomLinkDecorations rms w = + w & cWorld . decorations + %~ IM.insertWithNewKeys (map roomLinkDecorations rms) roomLinkDecorations :: Room -> Picture roomLinkDecorations rm = pictures . map (linkDecoration . lnkPosDir) $ _rmLinks rm -linkDecoration :: (Point2,Float) -> Picture -linkDecoration (p,a) = setLayer DebugLayer . color red $ line [p, p +.+ 20 *.* unitVectorAtAngle (a - pi/2)] +linkDecoration :: (Point2, Float) -> Picture +linkDecoration (p, a) = setLayer DebugLayer . color red $ line [p, p +.+ 20 *.* unitVectorAtAngle (a - pi / 2)] roomPolyDecorations :: Room -> Picture roomPolyDecorations rm = pictures . map polyWireFrame $ _rmPolys rm polyWireFrame :: [Point2] -> Picture -polyWireFrame (x:xs) = setLayer DebugLayer . setDepth 50 . color green $ line $ (x:xs) ++ [x] +polyWireFrame (x : xs) = setLayer DebugLayer . setDepth 50 . color green $ line $ (x : xs) ++ [x] polyWireFrame _ = undefined diff --git a/src/Dodge/Debug/Picture.hs b/src/Dodge/Debug/Picture.hs index c270ea844..938c0a2d4 100644 --- a/src/Dodge/Debug/Picture.hs +++ b/src/Dodge/Debug/Picture.hs @@ -1,45 +1,48 @@ module Dodge.Debug.Picture where -import Dodge.Data -import Dodge.Base.Window + +import Data.Maybe import Dodge.Base.Wall +import Dodge.Base.Window +import Dodge.Data.Universe import Geometry import Picture -import Data.Maybe ---import Color - printPoint :: Point2 -> Picture -printPoint p = color white $ uncurryV translate p $ pictures [circle 3 ,scale 0.05 0.05 $ text (show p)] +printPoint p = color white $ uncurryV translate p $ pictures [circle 3, scale 0.05 0.05 $ text (show p)] printRotPoint :: Float -> Point2 -> Picture -printRotPoint r p = color white - . uncurryV translate p - $ pictures [circle 3 , rotate (negate r) $ scale 0.1 0.1 $ text (show p)] +printRotPoint r p = + color white + . uncurryV translate p + $ pictures [circle 3, rotate (negate r) $ scale 0.1 0.1 $ text (show p)] outsideScreenPolygon :: Configuration -> World -> [Point2] -outsideScreenPolygon cfig w = [tr,tl,bl,br] - where - scRot = rotateV (_cameraRot (_cWorld w)) - scZoom p | _cameraZoom (_cWorld w) /= 0 = (1/_cameraZoom (_cWorld w)) *.* p - | otherwise = error "Trying to set screen zoom to zero" +outsideScreenPolygon cfig w = [tr, tl, bl, br] + where + scRot = rotateV (_cameraRot (_cWorld w)) + scZoom p + | _cameraZoom (_cWorld w) /= 0 = (1 / _cameraZoom (_cWorld w)) *.* p + | otherwise = error "Trying to set screen zoom to zero" scTran p = p +.+ _cameraCenter (_cWorld w) - tr = f 3 3 - tl = f (-3) 3 - br = f 3 (-3) + tr = f 3 3 + tl = f (-3) 3 + br = f 3 (-3) bl = f (-3) (-3) - f a b = scTran $ scRot $ scZoom $ V2 (a*halfWidth cfig) (b* halfHeight cfig) + f a b = scTran $ scRot $ scZoom $ V2 (a * halfWidth cfig) (b * halfHeight cfig) -- cannot only test if walls are on screen, but also if they are on the cone -- towards the center of sight lineOnScreenCone :: Configuration -> World -> Point2 -> Point2 -> Bool -lineOnScreenCone cfig w p1 p2 = pointInPolygon p1 sp - || pointInPolygon p2 sp - || any (isJust . uncurry (intersectSegSeg p1 p2)) sps - where +lineOnScreenCone cfig w p1 p2 = + pointInPolygon p1 sp + || pointInPolygon p2 sp + || any (isJust . uncurry (intersectSegSeg p1 p2)) sps + where sp' = screenPolygon cfig w vp = _cameraViewFrom (_cWorld w) - sp | pointInPolygon vp sp' = sp' - | otherwise = orderPolygon (_cameraViewFrom (_cWorld w) : sp') + sp + | pointInPolygon vp sp' = sp' + | otherwise = orderPolygon (_cameraViewFrom (_cWorld w) : sp') sps = zip sp (tail sp ++ [head sp]) pointOnScreen :: Configuration -> World -> Point2 -> Bool @@ -49,26 +52,28 @@ drawWallFace :: Configuration -> World -> Wall -> Picture drawWallFace cfig w wall | isRHS sightFrom x y || not (wlIsOpaque wall) = blank | otherwise = setDepth (-1) . color (withAlpha 0 black) . polygon $ points - where - (x,y) = _wlLine wall - points = extendConeToScreenEdge cfig w sightFrom (x,y) + where + (x, y) = _wlLine wall + points = extendConeToScreenEdge cfig w sightFrom (x, y) sightFrom = _cameraViewFrom (_cWorld w) -extendConeToScreenEdge :: Configuration -> World -> Point2 -> (Point2,Point2) -> [Point2] -extendConeToScreenEdge cfig w c (x,y) = orderPolygon $ wallScreenIntersect ++ [x,y] ++ borderPs ++ cornerPs - where - borderPs = mapMaybe (intersectLinefromScreen cfig w c) [x,y] +extendConeToScreenEdge :: Configuration -> World -> Point2 -> (Point2, Point2) -> [Point2] +extendConeToScreenEdge cfig w c (x, y) = orderPolygon $ wallScreenIntersect ++ [x, y] ++ borderPs ++ cornerPs + where + borderPs = mapMaybe (intersectLinefromScreen cfig w c) [x, y] scpoly = reverse $ screenPolygon cfig w - cornerPs = filter (pointIsInCone c (x,y)) scpoly - wallScreenIntersect = mapMaybe (uncurry $ intersectSegSeg y ((2*.*y) -.- x)) - . loopPairs $ scpoly + cornerPs = filter (pointIsInCone c (x, y)) scpoly + wallScreenIntersect = + mapMaybe (uncurry $ intersectSegSeg y ((2 *.* y) -.- x)) + . loopPairs + $ scpoly -- the following assumes that the point a is inside the screen -- it still works otherwise, but it might intersect two points: -- it is not obvious which will be returned intersectLinefromScreen :: Configuration -> World -> Point2 -> Point2 -> Maybe Point2 -intersectLinefromScreen cfig w a b = listToMaybe - . mapMaybe (\(x,y) -> intersectSegLineFrom x y b (b +.+ b -.- a)) - . loopPairs - $ screenPolygon cfig w - +intersectLinefromScreen cfig w a b = + listToMaybe + . mapMaybe (\(x, y) -> intersectSegLineFrom x y b (b +.+ b -.- a)) + . loopPairs + $ screenPolygon cfig w diff --git a/src/Dodge/Debug/Terminal.hs b/src/Dodge/Debug/Terminal.hs index d3b64ce6e..c48c040eb 100644 --- a/src/Dodge/Debug/Terminal.hs +++ b/src/Dodge/Debug/Terminal.hs @@ -1,47 +1,47 @@ {-# LANGUAGE TupleSections #-} -module Dodge.Debug.Terminal - where -import MaybeHelp -import Dodge.Inventory.Add -import Dodge.Creature -import Dodge.Data -import Dodge.Menu.PushPop -import Dodge.Item -import Control.Monad ---import Dodge.Base -import Control.Lens -import Text.Read (readMaybe) -import Data.List --(isPrefixOf, isInfixOf, intercalate) -import Data.Maybe +module Dodge.Debug.Terminal where + import Control.Applicative -import LensHelp +import Control.Lens +import Control.Monad +import Data.List +import Data.Maybe import qualified Data.Text as T +import Dodge.Creature +import Dodge.Data.Universe +import Dodge.Inventory.Add +import Dodge.Item +import Dodge.Menu.PushPop import qualified IntMapHelp as IM ---import qualified Debug.Trace ---import Graphics.Rendering.OpenGL.GL.Shaders (validateProgram) ---import Dodge.Data (Universe(Universe)) +import LensHelp +import MaybeHelp +import Text.Read (readMaybe) applyTerminalString :: [String] -> Universe -> Universe applyTerminalString ss = case ss of [] -> id [s] -> applyTerminalCommand s - (s:ss') -> applyTerminalCommandArguments s ss' + (s : ss') -> applyTerminalCommandArguments s ss' applyTerminalCommand :: String -> Universe -> Universe applyTerminalCommand s = case s of "NOCLIP" -> uvConfig . debug_booleans . at Noclip %~ toggleJust - "LOADME" -> (uvWorld . cWorld . creatures . ix 0 . crInv .~ stackedInventory) - . (uvWorld . cWorld . creatures . ix 0 . crInvCapacity .~ 50) - "LM" -> applyTerminalCommand "LOADME" - "LT" -> applyTerminalCommand "LOADTEST" - ['L',x] -> (uvWorld . cWorld . creatures . ix 0 . crInv .~ IM.fromList (zip [0..] $ inventoryX x)) - . (uvWorld . cWorld . creatures . ix 0 . crInvCapacity .~ 50) - "GODON" -> uvWorld . cWorld . creatures . ix 0 . crMaterial .~ Crystal - "GODOFF" -> uvWorld . cWorld . creatures . ix 0 . crMaterial .~ Flesh - "LOADTEST" -> (uvWorld . cWorld . creatures . ix 0 . crInv .~ testInventory) - . (uvWorld . cWorld . creatures . ix 0 . crInvCapacity .~ 50) + "LOADME" -> + (uvWorld . cWorld . creatures . ix 0 . crInv .~ stackedInventory) + . (uvWorld . cWorld . creatures . ix 0 . crInvCapacity .~ 50) + "LM" -> applyTerminalCommand "LOADME" + "LT" -> applyTerminalCommand "LOADTEST" + ['L', x] -> + (uvWorld . cWorld . creatures . ix 0 . crInv .~ IM.fromList (zip [0 ..] $ inventoryX x)) + . (uvWorld . cWorld . creatures . ix 0 . crInvCapacity .~ 50) + "GODON" -> uvWorld . cWorld . creatures . ix 0 . crMaterial .~ Crystal + "GODOFF" -> uvWorld . cWorld . creatures . ix 0 . crMaterial .~ Flesh + "LOADTEST" -> + (uvWorld . cWorld . creatures . ix 0 . crInv .~ testInventory) + . (uvWorld . cWorld . creatures . ix 0 . crInvCapacity .~ 50) _ -> id + --applyTerminalString' ('s': 'e': 't': '_': 'h': 'p': ' ': hp) -- | isNothing (readMaybe hp :: Maybe Int) = id -- | otherwise = uvWorld . creatures . ix 0 . crHP .~ read hp @@ -59,20 +59,20 @@ applyTerminalCommand s = case s of applyTerminalCommandArguments :: String -> [String] -> Universe -> Universe applyTerminalCommandArguments command args u = case command of "ITEM" -> fromMaybe u $ do - (ibt,n) <- parseItem args + (ibt, n) <- parseItem args return $ u & uvWorld %~ flip (foldr ($)) (replicate n (snd . createPutItem (itemFromBase ibt))) _ -> u -parseItem :: [String] -> Maybe (ItemBaseType,Int) -parseItem (x:xs) - = (readMaybe (x++" {_xNum=" ++ show (parseNum xs)++"}") <&> (,1)) - <|> (readMaybe x <&> (,parseNum xs) ) - <|> (readMaybe ("CRAFT "++x) <&> (,parseNum xs)) - <|> (readMaybe ("HELD {_ibtHeld="++x++"}") <&> (,parseNum xs)) - <|> (readMaybe ("EQUIP {_ibtEquip="++x++"}") <&> (,parseNum xs)) - <|> (readMaybe ("LEFT {_ibtLEFT="++x++"}") <&> (,parseNum xs)) - <|> (readMaybe ("HELD ("++x++" {_xNum=" ++ show (parseNum xs)++"}") <&> (,1)) - <|> parseItem (xs & ix 0 .++~ (x ++ " ")) +parseItem :: [String] -> Maybe (ItemBaseType, Int) +parseItem (x : xs) = + (readMaybe (x ++ " {_xNum=" ++ show (parseNum xs) ++ "}") <&> (,1)) + <|> (readMaybe x <&> (,parseNum xs)) + <|> (readMaybe ("CRAFT " ++ x) <&> (,parseNum xs)) + <|> (readMaybe ("HELD {_ibtHeld=" ++ x ++ "}") <&> (,parseNum xs)) + <|> (readMaybe ("EQUIP {_ibtEquip=" ++ x ++ "}") <&> (,parseNum xs)) + <|> (readMaybe ("LEFT {_ibtLEFT=" ++ x ++ "}") <&> (,parseNum xs)) + <|> (readMaybe ("HELD (" ++ x ++ " {_xNum=" ++ show (parseNum xs) ++ "}") <&> (,1)) + <|> parseItem (xs & ix 0 .++~ (x ++ " ")) parseItem [] = Nothing parseNum :: [String] -> Int @@ -84,20 +84,21 @@ showTerminalError cmd s = menuLayers .:~ InputScreen (T.pack cmd) s applySetTerminalString :: String -> Universe -> Universe applySetTerminalString [] = id applySetTerminalString var = case key' of - "" -> showTerminalError ("set "++var) ("Unable to read as argument as float: " ++ val) + "" -> showTerminalError ("set " ++ var) ("Unable to read as argument as float: " ++ val) "hp" -> uvWorld . cWorld . creatures . ix 0 . crHP .~ round (fromJust val') "invcap" -> uvWorld . cWorld . creatures . ix 0 . crInvCapacity .~ round (fromJust val') "mass" -> uvWorld . cWorld . creatures . ix 0 . crMass .~ fromJust val' - "mvspeed" -> uvWorld . cWorld . creatures . ix 0 . crMvType .mvSpeed .~ fromJust val' - _ -> showTerminalError ("set "++var) ("Invalid set command: " ++ key) -- never reached? - where - (key, val) = getSplitString var - val' = readMaybe val :: Maybe Float - key' = if isNothing val' then "" else key + "mvspeed" -> uvWorld . cWorld . creatures . ix 0 . crMvType . mvSpeed .~ fromJust val' + _ -> showTerminalError ("set " ++ var) ("Invalid set command: " ++ key) -- never reached? + where + (key, val) = getSplitString var + val' = readMaybe val :: Maybe Float + key' = if isNothing val' then "" else key autoCompleteTerminal :: String -> String -> Universe -> IO (Maybe Universe) -autoCompleteTerminal s _ = return . - (popScreen' >=> pushScreen' (InputScreen (T.pack input_str) valid_commands)) +autoCompleteTerminal s _ = + return + . (popScreen' >=> pushScreen' (InputScreen (T.pack input_str) valid_commands)) where (key, val) = getSplitString $ tail s command_options = case val of @@ -105,24 +106,28 @@ autoCompleteTerminal s _ = return . _ -> filter (isInfixOf val) (validTerminalCommands key) -- basic autocomplete if single option available (or as far as possible) input_str = case (key, val) of - (_, "") -> if length command_options == 1 - then ">" ++ head command_options ++ " " - else ">" ++ longestCommonPrefix command_options - _ -> if length command_options == 1 - then ">" ++ key ++ " " ++ head command_options ++ " " - else if null command_options - then s - else ">" ++ key ++ " " ++ longestCommonPrefix command_options - command_options' = if not (null command_options) && head command_options == key - then validTerminalCommands key - else command_options + (_, "") -> + if length command_options == 1 + then ">" ++ head command_options ++ " " + else ">" ++ longestCommonPrefix command_options + _ -> + if length command_options == 1 + then ">" ++ key ++ " " ++ head command_options ++ " " + else + if null command_options + then s + else ">" ++ key ++ " " ++ longestCommonPrefix command_options + command_options' = + if not (null command_options) && head command_options == key + then validTerminalCommands key + else command_options --val' = Debug.Trace.trace key tail val valid_commands = "Options: " ++ intercalate ", " command_options' getSplitString :: [Char] -> ([Char], [Char]) -getSplitString str = case break (==' ') str of - (a, _:b) -> (a, b) +getSplitString str = case break (== ' ') str of + (a, _ : b) -> (a, b) (a, _) -> (a, "") isValidCommand :: String -> String -> Bool @@ -141,6 +146,6 @@ longestCommonPrefix [] = [] longestCommonPrefix lists = foldr1 commonPrefix lists commonPrefix :: Eq a => [a] -> [a] -> [a] -commonPrefix (x:xs) (y:ys) - | x == y = x : commonPrefix xs ys +commonPrefix (x : xs) (y : ys) + | x == y = x : commonPrefix xs ys commonPrefix _ _ = [] diff --git a/src/Dodge/Default.hs b/src/Dodge/Default.hs index 9e5dd5c7f..36e1812bf 100644 --- a/src/Dodge/Default.hs +++ b/src/Dodge/Default.hs @@ -8,20 +8,18 @@ module Dodge.Default ( module Dodge.Default, module Dodge.Default.Item, module Dodge.Default.LightSource, - module Dodge.Default.Weapon, module Dodge.Default.Wall, module Dodge.Default.Creature, module Dodge.Default.Terminal, ) where import Control.Lens -import Dodge.Data +import Dodge.Data.World import Dodge.Default.Creature import Dodge.Default.Item import Dodge.Default.LightSource import Dodge.Default.Terminal import Dodge.Default.Wall -import Dodge.Default.Weapon import Dodge.SoundLogic import Geometry import Picture @@ -32,14 +30,7 @@ defaultEquipment = & itInvColor .~ yellow & itUse .~ EquipUse defaultEquip -defaultItZoom :: ItZoom -defaultItZoom = ItZoom 20 0.2 1 -defaultConsumable :: Item -defaultConsumable = - defaultItem - & itUse .~ ConsumeUse CDoNothing 1 - & itInvColor .~ blue defaultFlIt :: FloorItem defaultFlIt = FlIt{_flItRot = 0, _flIt = defaultConsumable, _flItPos = V2 0 0, _flItID = 0} diff --git a/src/Dodge/Default/AimParams.hs b/src/Dodge/Default/AimParams.hs deleted file mode 100644 index f0cf3c3ee..000000000 --- a/src/Dodge/Default/AimParams.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Dodge.Default.AimParams where -import Dodge.Data.Item.Use - -defaultAimParams :: AimParams -defaultAimParams = AimParams - { _aimWeight = 0 - , _aimRange = 0 - , _aimZoom = ItZoom 20 0.2 1 - , _aimStance = OneHand - , _aimHandlePos = 10 - , _aimMuzPos = 20 - } diff --git a/src/Dodge/Default/Block.hs b/src/Dodge/Default/Block.hs index 3ecf670ed..4e84d1e69 100644 --- a/src/Dodge/Default/Block.hs +++ b/src/Dodge/Default/Block.hs @@ -1,5 +1,5 @@ module Dodge.Default.Block where -import Dodge.Data +import Dodge.Data.Block import LensHelp defaultBlock :: Block diff --git a/src/Dodge/Default/Block.hs.orig b/src/Dodge/Default/Block.hs.orig index c878ea277..7ac996020 100644 --- a/src/Dodge/Default/Block.hs.orig +++ b/src/Dodge/Default/Block.hs.orig @@ -1,24 +1,29 @@ module Dodge.Default.Block where -import Dodge.Data + import Dodge.Block.Debris +import Dodge.Data.Block import LensHelp defaultBlock :: Block -defaultBlock = Block - { _blID = 0 - , _blWallIDs = mempty - , _blHP = 1000 - , _blShadows = [] - , _blFootprint = [] - , _blPos = 0 - , _blDir = 0 - , _blDraw = const mempty - , _blDeath = makeBlockDebris - , _blObstructs = [] -<<<<<<< HEAD -======= - , _blPaths = [] ->>>>>>> efficientRuntime - } +defaultBlock = + Block + { _blID = 0 + , _blWallIDs = mempty + , _blHP = 1000 + , _blShadows = [] + , _blFootprint = [] + , _blPos = 0 + , _blDir = 0 + , _blDraw = const mempty + , _blDeath = makeBlockDebris + , _blObstructs = + [] + <<<<<<< HEAD + ======= + , _blPaths = + [] + >>>>>>> efficientRuntime + } + defaultDirtBlock :: Block defaultDirtBlock = defaultBlock & blHP .~ 50 diff --git a/src/Dodge/Default/Creature.hs b/src/Dodge/Default/Creature.hs index b298e9563..9960fce97 100644 --- a/src/Dodge/Default/Creature.hs +++ b/src/Dodge/Default/Creature.hs @@ -1,58 +1,61 @@ module Dodge.Default.Creature where -import Dodge.Data -import Dodge.Data.FloatFunction -import Geometry.Data -import Picture - -import qualified IntMapHelp as IM -import qualified Data.Map.Strict as M import Control.Lens +import qualified Data.Map.Strict as M +import Dodge.Data.Creature +import Dodge.Data.FloatFunction +import Geometry.Data +import qualified IntMapHelp as IM +import Picture + defaultCreature :: Creature -defaultCreature = Creature - { _crPos = V2 0 0 - , _crOldPos = V2 0 0 - , _crVel = V2 0 0 - , _crDir = 0 - , _crOldDir = 0 - , _crMvDir = 0 - , _crTwist = 0 - , _crID = 1 - , _crType = defaultCreatureSkin - , _crRad = 10 - , _crMass = 10 - , _crHP = 100 - , _crMaxHP = 150 - , _crInv = IM.empty - , _crInvSel = InvSel 0 NoInvSelAction - , _crInvCapacity = 25 - , _crInvLock = False - , _crInvEquipped = mempty - , _crLeftInvSel = Nothing - , _crState = defaultState - , _crCorpse = MakeDefaultCorpse - , _crMaterial = Flesh - , _crPastDamage = 0 - , _crEquipment = M.empty - , _crStance = Stance - {_carriage=Walking 0 WasLeftForward - ,_posture=AtEase - ,_strideLength = yourDefaultStrideLength +defaultCreature = + Creature + { _crPos = V2 0 0 + , _crOldPos = V2 0 0 + , _crVel = V2 0 0 + , _crDir = 0 + , _crOldDir = 0 + , _crMvDir = 0 + , _crTwist = 0 + , _crID = 1 + , _crType = defaultCreatureSkin + , _crRad = 10 + , _crMass = 10 + , _crHP = 100 + , _crMaxHP = 150 + , _crInv = IM.empty + , _crInvSel = InvSel 0 NoInvSelAction + , _crInvCapacity = 25 + , _crInvLock = False + , _crInvEquipped = mempty + , _crLeftInvSel = Nothing + , _crState = defaultState + , _crCorpse = MakeDefaultCorpse + , _crMaterial = Flesh + , _crPastDamage = 0 + , _crEquipment = M.empty + , _crStance = + Stance + { _carriage = Walking 0 WasLeftForward + , _posture = AtEase + , _strideLength = yourDefaultStrideLength + } + , _crVocalization = Mute + , _crActionPlan = ActionPlan [] [] (StrategyActions WatchAndWait [StartSentinelPost]) [LiveLongAndProsper] + , _crPerception = defaultPerceptionState + , _crMemory = defaultCreatureMemory + , _crMeleeCooldown = 0 + , _crFaction = NoFaction + , _crIntention = defaultIntention + , _crGroup = LoneWolf + , _crMvType = defaultAimMvType + , _crHammerPosition = HammerUp + , _crName = "DEFAULTCRNAME" + , _crStatistics = CreatureStatistics 10 10 10 + , _crCamouflage = FullyVisible } - , _crVocalization = Mute - , _crActionPlan = ActionPlan [] [] (StrategyActions WatchAndWait [StartSentinelPost]) [LiveLongAndProsper] - , _crPerception = defaultPerceptionState - , _crMemory = defaultCreatureMemory - , _crMeleeCooldown = 0 - , _crFaction = NoFaction - , _crIntention = defaultIntention - , _crGroup = LoneWolf - , _crMvType = defaultAimMvType - , _crHammerPosition = HammerUp - , _crName = "DEFAULTCRNAME" - , _crStatistics = CreatureStatistics 10 10 10 - , _crCamouflage = FullyVisible - } + defaultCreatureSkin :: CreatureType defaultCreatureSkin = Humanoid (greyN 0.9) (light4 green) (greyN 0.3) InanimateAI @@ -60,53 +63,66 @@ defaultInanimate :: Creature defaultInanimate = defaultCreature & crActionPlan .~ Inanimate defaultCreatureMemory :: Memory -defaultCreatureMemory = Memory - { _soundsToInvestigate = [] - , _nodesSearched = [] - } +defaultCreatureMemory = + Memory + { _soundsToInvestigate = [] + , _nodesSearched = [] + } defaultInvSize :: Int defaultInvSize = 20 defaultPerceptionState :: Perception -defaultPerceptionState = Perception - { _cpVigilance = Lethargic - , _cpAttention = AttentiveTo mempty - , _cpAwareness = mempty - , _cpVision = defaultVision - , _cpAudition = defaultAudition - } +defaultPerceptionState = + Perception + { _cpVigilance = Lethargic + , _cpAttention = AttentiveTo mempty + , _cpAwareness = mempty + , _cpVision = defaultVision + , _cpAudition = defaultAudition + } + defaultVision :: Vision -defaultVision = Eyes - { _viFOV = FloatFOV 0.5 - , _viDist = FloatLessCheck 500 - } +defaultVision = + Eyes + { _viFOV = FloatFOV 0.5 + , _viDist = FloatLessCheck 500 + } + defaultAudition :: Audition -defaultAudition = Ears - { _auDist = FloatID - } +defaultAudition = + Ears + { _auDist = FloatID + } + defaultIntention :: Intention -defaultIntention = Intention - { _targetCr = Nothing - , _mvToPoint = Nothing - , _viewPoint = Nothing - } +defaultIntention = + Intention + { _targetCr = Nothing + , _mvToPoint = Nothing + , _viewPoint = Nothing + } + defaultChaseMvType :: CrMvType -defaultChaseMvType = CrMvType - { _mvSpeed = 2 - , _mvTurnRad = FloatAbsCheckGreaterLess (pi/4) 0.2 0.05--f - , _mvTurnJit = 0.2 - , _mvAimSpeed = FloatAbsCheckGreaterLess (pi/8) 0.2 0.01 - } +defaultChaseMvType = + CrMvType + { _mvSpeed = 2 + , _mvTurnRad = FloatAbsCheckGreaterLess (pi / 4) 0.2 0.05 --f + , _mvTurnJit = 0.2 + , _mvAimSpeed = FloatAbsCheckGreaterLess (pi / 8) 0.2 0.01 + } + defaultAimMvType :: CrMvType -defaultAimMvType = CrMvType - { _mvSpeed = 3 - , _mvTurnRad = FloatConst 0.2 - , _mvTurnJit = 0.05 - , _mvAimSpeed = FloatAbsCheckGreaterLess (pi/8) 0.2 0.01 - } +defaultAimMvType = + CrMvType + { _mvSpeed = 3 + , _mvTurnRad = FloatConst 0.2 + , _mvTurnJit = 0.05 + , _mvAimSpeed = FloatAbsCheckGreaterLess (pi / 8) 0.2 0.01 + } + defaultAimingCrit :: Creature -defaultAimingCrit = defaultCreature { _crMvType = defaultAimMvType } +defaultAimingCrit = defaultCreature{_crMvType = defaultAimMvType} yourDefaultSpeed :: Float yourDefaultSpeed = 3 @@ -115,9 +131,10 @@ yourDefaultStrideLength :: Int yourDefaultStrideLength = 40 defaultState :: CreatureState -defaultState = CrSt - { _csDamage = [] --- , _crPastDamage = V.fromList $ replicate 20 [] - , _csSpState = GenCr - , _csDropsOnDeath = DropAll - } +defaultState = + CrSt + { _csDamage = [] + , -- , _crPastDamage = V.fromList $ replicate 20 [] + _csSpState = GenCr + , _csDropsOnDeath = DropAll + } diff --git a/src/Dodge/Default/Door.hs b/src/Dodge/Default/Door.hs index 614379ae0..4310ba29f 100644 --- a/src/Dodge/Default/Door.hs +++ b/src/Dodge/Default/Door.hs @@ -1,42 +1,46 @@ -module Dodge.Default.Door - ( module Dodge.Default.Door - , module Dodge.Default.Wall - ) where -import Dodge.Data -import Dodge.Default.Wall -import Color +module Dodge.Default.Door ( + module Dodge.Default.Door, + module Dodge.Default.Wall, +) where +import Color import Control.Lens +import Dodge.Data.Door +import Dodge.Data.Wall +import Dodge.Default.Wall switchWallCol :: Color -> Wall switchWallCol col = defaultSwitchWall & wlColor .~ col defaultAutoWall :: Wall -defaultAutoWall = defaultDoorWall' - & wlColor .~ dim yellow - & wlPathable .~ True +defaultAutoWall = + defaultDoorWall' + & wlColor .~ dim yellow + & wlPathable .~ True + defaultSwitchWall :: Wall -defaultSwitchWall = defaultDoorWall' - & wlColor .~ red - & wlPathable .~ False +defaultSwitchWall = + defaultDoorWall' + & wlColor .~ red + & wlPathable .~ False defaultDoor :: Door -defaultDoor = Door - { _drID = 0 - , _drWallIDs = mempty - , _drStatus = DoorClosed - , _drTrigger = WdBlConst False - , _drMech = DrWdId - , _drPos = (0,0) - , _drOpenPos = (0,0) - , _drClosePos = (0,0) - , _drHP = 10000 - , _drDeath = DrWdMakeDoorDebris - , _drSpeed = 1 - , _drPushedBy = PushesItself - , _drPushes = Nothing - , _drMounts = mempty - , _drObstructs = mempty - , _drObstacleType = DoorObstacle - } - +defaultDoor = + Door + { _drID = 0 + , _drWallIDs = mempty + , _drStatus = DoorClosed + , _drTrigger = WdBlConst False + , _drMech = DrWdId + , _drPos = (0, 0) + , _drOpenPos = (0, 0) + , _drClosePos = (0, 0) + , _drHP = 10000 + , _drDeath = DrWdMakeDoorDebris + , _drSpeed = 1 + , _drPushedBy = PushesItself + , _drPushes = Nothing + , _drMounts = mempty + , _drObstructs = mempty + , _drObstacleType = DoorObstacle + } diff --git a/src/Dodge/Default/Foreground.hs b/src/Dodge/Default/ForegroundShape.hs similarity index 53% rename from src/Dodge/Default/Foreground.hs rename to src/Dodge/Default/ForegroundShape.hs index 8930f44e9..3b359daac 100644 --- a/src/Dodge/Default/Foreground.hs +++ b/src/Dodge/Default/ForegroundShape.hs @@ -1,5 +1,6 @@ -module Dodge.Default.Foreground where -import Dodge.Data +module Dodge.Default.ForegroundShape where + +import Dodge.Data.ForegroundShape defaultForeground :: ForegroundShape defaultForeground = ForegroundShape 0 0 0 0 mempty diff --git a/src/Dodge/Default/Item.hs b/src/Dodge/Default/Item.hs index 7f1f891de..57d9988c3 100644 --- a/src/Dodge/Default/Item.hs +++ b/src/Dodge/Default/Item.hs @@ -1,19 +1,23 @@ module Dodge.Default.Item ( - defaultItem, - defaultItEffect, + module Dodge.Default.Item, + module Dodge.Default.Item.Use, + module Dodge.Default.Item.Effect, ) where +import Color +import Control.Lens +import qualified Data.Map.Strict as M import Dodge.Data.Item +import Dodge.Default.Item.Effect +import Dodge.Default.Item.Use import Geometry.Data -import Picture defaultItem :: Item defaultItem = Item { _itCurseStatus = Uncursed , _itType = defaultItemType - , -- , _itEquipPict = \_ _ -> (,) emptySH blank - _itEffect = defaultItEffect + , _itEffect = defaultItEffect , _itID = Nothing , _itIsHeld = False , _itInvColor = yellow @@ -28,15 +32,52 @@ defaultItem = , _itValue = ItemValue 0 MundaneItem } -defaultItEffect :: ItEffect -defaultItEffect = - ItEffect - { _ieInv = NoInvEffect - , _ieOnInsert = NoInvEffect - , _ieOnDrop = NoInvEffect - , _ieOnHeld = NoInvEffect - , _ieOnStash = NoInvEffect - } +defaultLeftItem :: Item +defaultLeftItem = + defaultItem + & itUse .~ defaultLeftUse + & itInvColor .~ cyan + +defaultHeldItem :: Item +defaultHeldItem = + defaultItem + & itInvColor .~ white + & itUse .~ defaultHeldUse + +defaultCraftItem :: Item +defaultCraftItem = + defaultItem + & itUse .~ CraftUse 1 + & itInvColor .~ green defaultItemType :: ItemType -defaultItemType = ItemType (error "defaultItemType not initialized") mempty NoStack +defaultItemType = ItemType NoItemType mempty NoStack + +defaultBulletWeapon :: Item +defaultBulletWeapon = + defaultWeapon + & itUse . heldConsumption .~ defaultBulletLoadable + & itUse . heldUse .~ HeldUseAmmoParams -- useAmmoParams + & itType . iyModules . at ModBullet ?~ EMPTYMODULE + & itType . iyModules . at ModBulletSpawn ?~ EMPTYMODULE + & itType . iyModules . at ModBulletTrajectory ?~ EMPTYMODULE + +defaultWeapon :: Item +defaultWeapon = + defaultHeldItem + & itUse .~ defaultHeldUse + & itInvColor .~ white + & itType . iyModules + .~ M.fromList + [ (ModTarget, EMPTYMODULE) + , (ModTeleport, EMPTYMODULE) + ] + +defaultConsumable :: Item +defaultConsumable = + defaultItem + & itUse .~ ConsumeUse CDoNothing 1 + & itInvColor .~ blue + +defaultItZoom :: ItZoom +defaultItZoom = ItZoom 20 0.2 1 diff --git a/src/Dodge/Default/Item/Effect.hs b/src/Dodge/Default/Item/Effect.hs new file mode 100644 index 000000000..194223740 --- /dev/null +++ b/src/Dodge/Default/Item/Effect.hs @@ -0,0 +1,13 @@ +module Dodge.Default.Item.Effect + where +import Dodge.Data.Item.Effect + +defaultItEffect :: ItEffect +defaultItEffect = + ItEffect + { _ieInv = NoInvEffect + , _ieOnInsert = NoInvEffect + , _ieOnDrop = NoInvEffect + , _ieOnHeld = NoInvEffect + , _ieOnStash = NoInvEffect + } diff --git a/src/Dodge/Default/Item/Use.hs b/src/Dodge/Default/Item/Use.hs new file mode 100644 index 000000000..c77a66b0c --- /dev/null +++ b/src/Dodge/Default/Item/Use.hs @@ -0,0 +1,36 @@ +module Dodge.Default.Item.Use ( + module Dodge.Default.Item.Use, + module Dodge.Default.Item.Use.AimParams, + module Dodge.Default.Item.Use.Consumption, + module Dodge.Default.Item.Use.Equipment, +) where + +import Dodge.Data.Item.Use +import Dodge.Default.Item.Use.AimParams +import Dodge.Default.Item.Use.Consumption +import Dodge.Default.Item.Use.Equipment + +defaultLeftUse :: ItemUse +defaultLeftUse = + LeftUse + { _leftUse = LDoNothing + , _leftDelay = FixedRate{_rateMax = 8, _rateTime = 0} + , _leftHammer = HammerUp + , _equipEffect = defaultEquip + , _leftConsumption = defaultLeftLoadable + } + +defaultEquipUse :: ItemUse +defaultEquipUse = EquipUse{_equipEffect = defaultEquip} + +defaultHeldUse :: ItemUse +defaultHeldUse = + HeldUse + { _heldUse = HeldDoNothing + , _heldDelay = FixedRate{_rateMax = 8, _rateTime = 0} + , _heldMods = HeldModNothing + , _heldHammer = HammerUp + , _heldAim = defaultAimParams + , _heldScroll = HeldScrollDoNothing + , _heldConsumption = defaultLoadable + } diff --git a/src/Dodge/Default/Item/Use/AimParams.hs b/src/Dodge/Default/Item/Use/AimParams.hs new file mode 100644 index 000000000..45d522d0f --- /dev/null +++ b/src/Dodge/Default/Item/Use/AimParams.hs @@ -0,0 +1,14 @@ +module Dodge.Default.Item.Use.AimParams where + +import Dodge.Data.Item.Use + +defaultAimParams :: AimParams +defaultAimParams = + AimParams + { _aimWeight = 0 + , _aimRange = 0 + , _aimZoom = ItZoom 20 0.2 1 + , _aimStance = OneHand + , _aimHandlePos = 10 + , _aimMuzPos = 20 + } diff --git a/src/Dodge/Default/Item/Use/Consumption.hs b/src/Dodge/Default/Item/Use/Consumption.hs new file mode 100644 index 000000000..463f5b9c2 --- /dev/null +++ b/src/Dodge/Default/Item/Use/Consumption.hs @@ -0,0 +1,22 @@ +module Dodge.Default.Item.Use.Consumption where +import Dodge.Item.Weapon.Bullet +import Dodge.Reloading.Action +import Dodge.Data.Item.Use.Consumption +import Control.Lens + +defaultLoadable :: HeldConsumption +defaultLoadable = + LoadableAmmo + { _laAmmoType = GenericAmmo + , _laMax = 15 + , _laLoaded = 0 + , _laPrimed = True + , _laCycle = [loadEject 10, loadInsert 10, loadPrime 10] + , _laProgress = Nothing + } + +defaultBulletLoadable :: HeldConsumption +defaultBulletLoadable = defaultLoadable & laAmmoType .~ basicBullet + +defaultLeftLoadable :: LeftConsumption +defaultLeftLoadable = AutoRecharging 10 10 100 100 diff --git a/src/Dodge/Default/Item/Use/Equipment.hs b/src/Dodge/Default/Item/Use/Equipment.hs new file mode 100644 index 000000000..4614543be --- /dev/null +++ b/src/Dodge/Default/Item/Use/Equipment.hs @@ -0,0 +1,15 @@ +module Dodge.Default.Item.Use.Equipment where + +import Dodge.Data.Item.HeldUse +import Dodge.Data.Item.Use.Equipment + +defaultEquip :: EquipEffect +defaultEquip = + EquipEffect + { _eeSite = GoesOnSpecial + , _eeUse = EDoNothing + , _eeOnEquip = EDoNothing + , _eeOnRemove = EDoNothing + , _eeParams = NoEquipParams + , _eeViewDist = Nothing + } diff --git a/src/Dodge/Default/LightSource.hs b/src/Dodge/Default/LightSource.hs index e15c93e5a..fb6e1adf6 100644 --- a/src/Dodge/Default/LightSource.hs +++ b/src/Dodge/Default/LightSource.hs @@ -1,25 +1,31 @@ module Dodge.Default.LightSource where -import Dodge.Data + +import Dodge.Data.LightSource import Geometry defaultLS :: LightSource -defaultLS = LS - { _lsID = 0 - , _lsParam = LSParam - { _lsPos = V3 0 0 50 - , _lsRad = 700 - , _lsCol = 0.6 +defaultLS = + LS + { _lsID = 0 + , _lsParam = + LSParam + { _lsPos = V3 0 0 50 + , _lsRad = 700 + , _lsCol = 0.6 + } + , _lsDir = 0 + , _lsPict = DefaultLightSourceDraw --defLSPic } - , _lsDir = 0 - , _lsPict = DefaultLightSourceDraw --defLSPic - } + defaultTLS :: TempLightSource -defaultTLS = TLS - { _tlsParam = LSParam - { _lsPos = 0 - , _lsRad = 0 - , _lsCol = 0.5 +defaultTLS = + TLS + { _tlsParam = + LSParam + { _lsPos = 0 + , _lsRad = 0 + , _lsCol = 0.5 + } + , _tlsUpdate = TimerTLS + , _tlsTime = 1 } - , _tlsUpdate = TimerTLS - , _tlsTime = 1 - } diff --git a/src/Dodge/Default/Prop.hs b/src/Dodge/Default/Prop.hs index 050de716b..80f887b4d 100644 --- a/src/Dodge/Default/Prop.hs +++ b/src/Dodge/Default/Prop.hs @@ -1,12 +1,15 @@ module Dodge.Default.Prop where -import Dodge.Data + +import Dodge.Data.Prop import Geometry + defaultProp :: Prop -defaultProp = ShapeProp - { _prPos = V2 0 0 - , _prDraw = PropDrawSPic mempty - , _prID = 0 - , _prUpdate = PropUpdateId - , _prToggle = True - , _prRot = 0 - } +defaultProp = + ShapeProp + { _prPos = V2 0 0 + , _prDraw = PropDrawSPic mempty + , _prID = 0 + , _prUpdate = PropUpdateId + , _prToggle = True + , _prRot = 0 + } diff --git a/src/Dodge/Default/Room.hs b/src/Dodge/Default/Room.hs index d07eb10d7..4e94dd725 100644 --- a/src/Dodge/Default/Room.hs +++ b/src/Dodge/Default/Room.hs @@ -1,37 +1,39 @@ module Dodge.Default.Room where -import Data.Tile -import Geometry.Data ---import Dodge.LevelGen.Data -import Dodge.Data -import qualified IntMapHelp as IM + import qualified Data.Set as S +import Data.Tile +import Dodge.Data.GenWorld +import Geometry.Data +import qualified IntMapHelp as IM defaultRoom :: Room -defaultRoom = Room - { _rmPolys = mempty - , _rmLinks = mempty - , _rmLinkEff = const . const . const . const id - , _rmPos = mempty - , _rmPath = mempty - , _rmPmnts = mempty - , _rmInPmnt = mempty - , _rmOutPmnt = mempty - , _rmBound = mempty - , _rmFloor = InheritFloor - , _rmName = "defaultRoom" - , _rmShift = (V2 0 0 , 0) - , _rmViewpoints = mempty - , _rmRandPSs = mempty --- , _rmLabel = Nothing --- , _rmTakeFrom = Nothing - , _rmStartWires = IM.empty - , _rmEndWires = IM.empty - , _rmConnectsTo = S.member OutLink - , _rmMID = Nothing - , _rmMParent = Nothing - , _rmChildren = [] - , _rmType = DefaultRoomType - , _rmClusterStatus = defaultClusterStatus - } +defaultRoom = + Room + { _rmPolys = mempty + , _rmLinks = mempty + , _rmLinkEff = const . const . const . const id + , _rmPos = mempty + , _rmPath = mempty + , _rmPmnts = mempty + , _rmInPmnt = mempty + , _rmOutPmnt = mempty + , _rmBound = mempty + , _rmFloor = InheritFloor + , _rmName = "defaultRoom" + , _rmShift = (V2 0 0, 0) + , _rmViewpoints = mempty + , _rmRandPSs = mempty + , -- , _rmLabel = Nothing + -- , _rmTakeFrom = Nothing + _rmStartWires = IM.empty + , _rmEndWires = IM.empty + , _rmConnectsTo = S.member OutLink + , _rmMID = Nothing + , _rmMParent = Nothing + , _rmChildren = [] + , _rmType = DefaultRoomType + , _rmClusterStatus = defaultClusterStatus + } + defaultClusterStatus :: ClusterStatus defaultClusterStatus = ClusterStatus "defRoomClust" S.empty diff --git a/src/Dodge/Default/Shell.hs b/src/Dodge/Default/Shell.hs index 5a2adf824..b5a7f5330 100644 --- a/src/Dodge/Default/Shell.hs +++ b/src/Dodge/Default/Shell.hs @@ -1,21 +1,23 @@ -module Dodge.Default.Shell - where -import Dodge.Data +module Dodge.Default.Shell where + +import Dodge.Data.Item.Use.Consumption.Ammo +import Dodge.Data.Projectile import Geometry.Data defaultShell :: Proj -defaultShell = Shell - { _prjPos = V2 0 0 - , _prjZ = 20 - , _prjStartPos = V2 0 0 - , _prjVel = V2 0 0 - , _prjAcc = V2 0 0 - , _prjDir = 0 - , _prjSpin = 0 - , _prjDraw = DrawShell - , _prjID = 0 - , _prjTimer = 0 - , _prjPayload = ExplosionPayload - , _prjUpdates = [] - , _prjMITID = Nothing - } +defaultShell = + Shell + { _prjPos = V2 0 0 + , _prjZ = 20 + , _prjStartPos = V2 0 0 + , _prjVel = V2 0 0 + , _prjAcc = V2 0 0 + , _prjDir = 0 + , _prjSpin = 0 + , _prjDraw = DrawShell + , _prjID = 0 + , _prjTimer = 0 + , _prjPayload = ExplosionPayload + , _prjUpdates = [] + , _prjMITID = Nothing + } diff --git a/src/Dodge/Default/Terminal.hs b/src/Dodge/Default/Terminal.hs index cf917124d..746bd5bd1 100644 --- a/src/Dodge/Default/Terminal.hs +++ b/src/Dodge/Default/Terminal.hs @@ -1,32 +1,35 @@ -module Dodge.Default.Terminal - where -import Dodge.Data.WorldEffect -import Dodge.Data.Terminal +module Dodge.Default.Terminal where + import qualified Data.Map.Strict as M import qualified Data.Text as T -defaultTerminal :: Terminal -defaultTerminal = Terminal - { _tmID = 0 - , _tmBootProgram = TerminalBootMempty - , _tmButtonID = 0 - , _tmMachineID = 0 - , _tmName = "TESTTERMINAL" - , _tmDisplayedLines = [] - , _tmFutureLines = [] - , _tmMaxLines = 14 - , _tmTitle = "TERMINAL IN LOCATION" - , _tmInput = defaultTerminalInput - , _tmScrollCommands = [] - , _tmWriteCommands = [] - , _tmDeathEffect = TmWdId - , _tmStatus = TerminalOff - , _tmCommandHistory = [] - , _tmToggles = M.empty - } -defaultTerminalInput :: TerminalInput -defaultTerminalInput = TerminalInput - { _tiText = T.pack "" - , _tiFocus = True - , _tiSel = (0,0) - } +import Dodge.Data.Terminal +import Dodge.Data.WorldEffect +defaultTerminal :: Terminal +defaultTerminal = + Terminal + { _tmID = 0 + , _tmBootProgram = TerminalBootMempty + , _tmButtonID = 0 + , _tmMachineID = 0 + , _tmName = "TESTTERMINAL" + , _tmDisplayedLines = [] + , _tmFutureLines = [] + , _tmMaxLines = 14 + , _tmTitle = "TERMINAL IN LOCATION" + , _tmInput = defaultTerminalInput + , _tmScrollCommands = [] + , _tmWriteCommands = [] + , _tmDeathEffect = TmWdId + , _tmStatus = TerminalOff + , _tmCommandHistory = [] + , _tmToggles = M.empty + } + +defaultTerminalInput :: TerminalInput +defaultTerminalInput = + TerminalInput + { _tiText = T.pack "" + , _tiFocus = True + , _tiSel = (0, 0) + } diff --git a/src/Dodge/Default/Wall.hs b/src/Dodge/Default/Wall.hs index 40b66be1e..f3ccc6cf3 100644 --- a/src/Dodge/Default/Wall.hs +++ b/src/Dodge/Default/Wall.hs @@ -1,74 +1,86 @@ -module Dodge.Default.Wall - where -import Dodge.Data -import Dodge.Block.Debris -- this dependency is (directly) for dirtColor -import Picture -import Geometry.Data +module Dodge.Default.Wall where import Control.Lens +import Dodge.Block.Debris +import Dodge.Data.Wall +import Geometry.Data +import Picture + {- Indestructible wall. -} defaultWall :: Wall -defaultWall = Wall - { _wlLine = (V2 0 0,V2 50 0) - , _wlID = 0 - , _wlColor = greyN 0.6 - , _wlSeen = False - , _wlOpacity = Opaque - , _wlPathable = False - , _wlPenetrable = False - , _wlFireThrough = False - , _wlTouchThrough = False - , _wlReflect = False - , _wlUnshadowed = True - , _wlRotateTo = True - , _wlStructure = StandaloneWall - , _wlWalkable = False - , _wlHeight = 100 - , _wlMaterial = Stone - , _wlBouncy = True - } +defaultWall = + Wall + { _wlLine = (V2 0 0, V2 50 0) + , _wlID = 0 + , _wlColor = greyN 0.6 + , _wlSeen = False + , _wlOpacity = Opaque + , _wlPathable = False + , _wlPenetrable = False + , _wlFireThrough = False + , _wlTouchThrough = False + , _wlReflect = False + , _wlUnshadowed = True + , _wlRotateTo = True + , _wlStructure = StandaloneWall + , _wlWalkable = False + , _wlHeight = 100 + , _wlMaterial = Stone + , _wlBouncy = True + } + defaultDoorWall' :: Wall -defaultDoorWall' = defaultWall - { _wlPathable = True - , _wlMaterial = Metal - } +defaultDoorWall' = + defaultWall + { _wlPathable = True + , _wlMaterial = Metal + } + {- Indestructible see-through wall. -} defaultCrystalWall :: Wall -defaultCrystalWall = defaultWall - { _wlColor = withAlpha 0.5 aquamarine - , _wlOpacity = SeeThrough - , _wlMaterial = Crystal - } +defaultCrystalWall = + defaultWall + { _wlColor = withAlpha 0.5 aquamarine + , _wlOpacity = SeeThrough + , _wlMaterial = Crystal + } + defaultMachineWall :: Wall -defaultMachineWall = defaultWall - { _wlOpacity = SeeAbove - , _wlRotateTo = False - , _wlStructure = MachinePart 0 - , _wlMaterial = Metal - , _wlPenetrable = True - } +defaultMachineWall = + defaultWall + { _wlOpacity = SeeAbove + , _wlRotateTo = False + , _wlStructure = MachinePart 0 + , _wlMaterial = Metal + , _wlPenetrable = True + } + defaultSensorWall :: Wall defaultSensorWall = defaultMachineWall & wlBouncy .~ False + defaultDirtWall :: Wall -defaultDirtWall = defaultWall - { _wlLine = (V2 0 0,V2 50 0) - , _wlID = 0 - , _wlColor = dirtColor - , _wlSeen = False - , _wlOpacity = Opaque - , _wlRotateTo = False - , _wlFireThrough = True - , _wlPenetrable = True - , _wlMaterial = Dirt - } +defaultDirtWall = + defaultWall + { _wlLine = (V2 0 0, V2 50 0) + , _wlID = 0 + , _wlColor = dirtColor + , _wlSeen = False + , _wlOpacity = Opaque + , _wlRotateTo = False + , _wlFireThrough = True + , _wlPenetrable = True + , _wlMaterial = Dirt + } + defaultWindow :: Wall -defaultWindow = defaultWall - { _wlLine = (V2 0 0,V2 50 0) - , _wlID = 0 - , _wlColor = withAlpha 0.5 cyan - , _wlSeen = False - , _wlOpacity = SeeThrough - , _wlFireThrough = True - , _wlMaterial = Glass - , _wlPenetrable = True - } +defaultWindow = + defaultWall + { _wlLine = (V2 0 0, V2 50 0) + , _wlID = 0 + , _wlColor = withAlpha 0.5 cyan + , _wlSeen = False + , _wlOpacity = SeeThrough + , _wlFireThrough = True + , _wlMaterial = Glass + , _wlPenetrable = True + } diff --git a/src/Dodge/Default/Weapon.hs b/src/Dodge/Default/Weapon.hs index b58e6efac..0db21b0f5 100644 --- a/src/Dodge/Default/Weapon.hs +++ b/src/Dodge/Default/Weapon.hs @@ -1,122 +1,82 @@ module Dodge.Default.Weapon where -import Control.Lens -import qualified Data.Map.Strict as M -import Dodge.Data.Hammer -import Dodge.Data.Item -import Dodge.Default.AimParams -import Dodge.Default.Item -import Dodge.Item.Weapon.Bullet -import Dodge.Reloading.Action -import Picture +--import Control.Lens +--import qualified Data.Map.Strict as M +--import Dodge.Data.Hammer +--import Dodge.Data.Item +--import Dodge.Default.Item +--import Dodge.Item.Weapon.Bullet +--import Dodge.Reloading.Action +--import Picture -defaultLeftLoadable :: LeftConsumption -defaultLeftLoadable = AutoRecharging 10 10 100 100 +-- +--defaultLoadable :: HeldConsumption +--defaultLoadable = +-- LoadableAmmo +-- { _laAmmoType = GenericAmmo +-- , _laMax = 15 +-- , _laLoaded = 0 +-- , _laPrimed = True +-- , _laCycle = [loadEject 10, loadInsert 10, loadPrime 10] +-- , _laProgress = Nothing +-- } +-- +----defaultBulletLoadable :: HeldConsumption +----defaultBulletLoadable = defaultLoadable & laAmmoType .~ basicBullet +-- +--defaultChargeable :: LeftConsumption +--defaultChargeable = ChargeableAmmo 100 100 -defaultLoadable :: HeldConsumption -defaultLoadable = - LoadableAmmo - { _laAmmoType = GenericAmmo - , _laMax = 15 - , _laLoaded = 0 - , _laPrimed = True - , _laCycle = [loadEject 10, loadInsert 10, loadPrime 10] - , _laProgress = Nothing - } +--defaultrUse :: ItemUse +--defaultrUse = +-- RightUse +-- { _rUse = HeldDoNothing +-- , _useDelay = FixedRate{_rateMax = 8, _rateTime = 0} +-- , _useMods = HeldModNothing +-- , _useHammer = HammerUp +-- , _useAim = defaultAimParams +-- , _heldScroll = HeldScrollDoNothing +-- , _heldConsumption = defaultLoadable +-- } -defaultBulletLoadable :: HeldConsumption -defaultBulletLoadable = defaultLoadable & laAmmoType .~ basicBullet +-- +-- +--luseInstantNoH :: Luse -> ItemUse +--luseInstantNoH f = +-- defaultlUse +-- & lUse .~ f +-- & useDelay .~ NoDelay -defaultChargeable :: LeftConsumption -defaultChargeable = ChargeableAmmo 100 100 +---- TODO change this +--defaultLeftItem :: Item +--defaultLeftItem = +-- defaultWeapon +-- & itUse .~ defaultlUse -defaultrUse :: ItemUse -defaultrUse = - RightUse - { _rUse = HeldDoNothing - , _useDelay = FixedRate{_rateMax = 8, _rateTime = 0} - , _useMods = HeldModNothing - , _useHammer = HammerUp - , _useAim = defaultAimParams - , _heldScroll = HeldScrollDoNothing - , _heldConsumption = defaultLoadable - } - -defaultlUse :: ItemUse -defaultlUse = - LeftUse - { _lUse = LDoNothing - , _useDelay = FixedRate{_rateMax = 8, _rateTime = 0} - , _useHammer = HammerUp - , _eqEq = defaultEquip - , _leftConsumption = defaultLeftLoadable - } - -defaultEquip :: Equipment -defaultEquip = - Equipment - { _eqSite = GoesOnSpecial - , _eqUse = EDoNothing - , _eqOnEquip = EDoNothing - , _eqOnRemove = EDoNothing - , _eqParams = NoEquipParams - , _eqViewDist = Nothing - } - -luseInstantNoH :: Luse -> ItemUse -luseInstantNoH f = - defaultlUse - & lUse .~ f - & useDelay .~ NoDelay - --- TODO change this -defaultLeftItem :: Item -defaultLeftItem = - defaultWeapon - & itUse .~ defaultlUse - -defaultWeapon :: Item -defaultWeapon = - defaultItem - & itUse .~ defaultrUse - & itInvColor .~ white - & itType . iyModules - .~ M.fromList - [ (ModTarget, EMPTYMODULE) - , (ModTeleport, EMPTYMODULE) - ] - -defaultBulletWeapon :: Item -defaultBulletWeapon = - defaultWeapon - & itUse . heldConsumption .~ defaultBulletLoadable - & itUse . rUse .~ HeldUseAmmoParams -- useAmmoParams - & itType . iyModules . at ModBullet ?~ EMPTYMODULE - & itType . iyModules . at ModBulletSpawn ?~ EMPTYMODULE - & itType . iyModules . at ModBulletTrajectory ?~ EMPTYMODULE - -defaultItemValue :: ItemValue -defaultItemValue = ItemValue 10 MundaneItem - -defaultCraftable :: Item -defaultCraftable = - defaultItem - { _itInvColor = green - } - -defBulletShooter :: ItemParams -defBulletShooter = - BulletShooter - { _muzVel = 1 - , _rifling = 0.8 - , _bore = 2 - , _gunBarrels = SingleBarrel 0 - , _recoil = 0 - , _torqueAfter = 0 - , _randomOffset = 0 - } - -defaultAutoGun :: Item -defaultAutoGun = - defaultBulletWeapon - & itUse . useAim . aimStance .~ TwoHandTwist +-- +-- +--defaultItemValue :: ItemValue +--defaultItemValue = ItemValue 10 MundaneItem +-- +--defaultCraftable :: Item +--defaultCraftable = +-- defaultItem +-- { _itInvColor = green +-- } +-- +--defBulletShooter :: ItemParams +--defBulletShooter = +-- BulletShooter +-- { _muzVel = 1 +-- , _rifling = 0.8 +-- , _bore = 2 +-- , _gunBarrels = SingleBarrel 0 +-- , _recoil = 0 +-- , _torqueAfter = 0 +-- , _randomOffset = 0 +-- } +-- +----defaultAutoGun :: Item +----defaultAutoGun = +---- defaultBulletWeapon +---- & itUse . useAim . aimStance .~ TwoHandTwist diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs index d3614d184..b3ab4a43c 100644 --- a/src/Dodge/Default/World.hs +++ b/src/Dodge/Default/World.hs @@ -1,133 +1,140 @@ module Dodge.Default.World where -import Dodge.Data.Hammer -import Dodge.Data -import Geometry.Data -import Geometry.Polygon -import System.Random -import qualified IntMapHelp as IM +import MaybeHelp +import Data.Graph.Inductive.Graph hiding ((&)) import qualified Data.Map as M import qualified Data.Set as S -import Data.Graph.Inductive.Graph hiding ((&)) +import Dodge.Data.World +import Geometry.Data +import Geometry.Polygon +import qualified IntMapHelp as IM +import System.Random + --import Data.Graph.Inductive.NodeMap defaultWorld :: World -defaultWorld = World - { _cWorld = defaultCWorld - , _toPlaySounds = M.empty - , _playingSounds = M.empty - , _randGen = mkStdGen 2 - , _keys = S.empty - , _mouseButtons = mempty - , _mousePos = V2 0 0 - , _hammers = defaultWorldHammers - , _testFloat = 0 - , _lLine = (0,0) - , _rLine = (0,0) - , _lSelect = 0 - , _rSelect = 0 - , _backspaceTimer = 0 - , _timeFlow = NormalTimeFlow - , _rbOptions = NoRightButtonOptions - } +defaultWorld = + World + { _cWorld = defaultCWorld + , _toPlaySounds = M.empty + , _playingSounds = M.empty + , _randGen = mkStdGen 2 + , _keys = S.empty + , _mouseButtons = mempty + , _mousePos = V2 0 0 + , _hammers = defaultWorldHammers + , _testFloat = 0 + , _lLine = (0, 0) + , _rLine = (0, 0) + , _lSelect = 0 + , _rSelect = 0 + , _backspaceTimer = 0 + , _timeFlow = NormalTimeFlow + , _rbOptions = NoRightButtonOptions + } defaultCWorld :: CWorld -defaultCWorld = CWorld - { _cameraCenter = V2 0 0 - , _cameraRot = 0 - , _cameraZoom = 1 - , _magnets = IM.empty - , _itemZoom = 1 - , _defaultZoom = 1 - , _cameraViewFrom = V2 0 0 - , _viewDistance = 1000 - , _modifications = IM.empty - , _creatures = IM.empty - , _crZoning = mempty --Zoning IM.empty crZoneSize zoneOfCreature - , _creatureGroups = IM.empty - , _clouds = mempty - , _clZoning = mempty - , _gusts = IM.empty - , _gsZoning = mempty --Zoning IM.empty clZoneSize (zonePos _guPos) - , _itemLocations = IM.empty - , _props = IM.empty - , _projectiles = IM.empty - , _instantBullets = [] - , _bullets = [] --- , _instantParticles = [] --- , _particles = [] - , _flames = [] - , _radarSweeps = [] - , _sparks = [] - , _posEvents = [] - , _energyBalls = [] - , _radarBlips = [] - , _flares = [] - , _newBeams = WorldBeams [] [] [] [] - , _beams = WorldBeams [] [] [] [] - , _teslaArcs = [] - , _shockwaves = [] - , _lasers = [] - , _lasersToDraw = [] - , _tractorBeams = mempty - , _linearShockwaves = mempty - , _walls = IM.empty - , _wallDamages = IM.empty - , _blocks = IM.empty - , _machines = IM.empty - , _terminals = IM.empty - , _doors = IM.empty - , _coordinates = IM.empty - , _triggers = IM.empty - , _wlZoning = IM.empty --Zoning IM.empty wlZoneSize zoneOfWall - , _floorItems = IM.empty - , _floorTiles = [] - , _yourID = 0 - , _worldEvents = [] - , _delayedEvents = [] - , _pressPlates = IM.empty - , _buttons = IM.empty - , _corpses = IM.empty - , _decorations = IM.empty - --, _savedWorlds = M.empty --- , _menuLayers = [] - , _clickMousePos = V2 0 0 - , _pathGraph = Data.Graph.Inductive.Graph.empty --- , _pathGraphP = mempty - , _pnZoning = mempty - , _peZoning = mempty - , _hud = HUD - { _hudElement = DisplayInventory NoSubInventory - , _carteCenter = V2 0 0 - , _carteZoom = 0.5 - , _carteRot = 0 +defaultCWorld = + CWorld + { _cameraCenter = V2 0 0 + , _cameraRot = 0 + , _cameraZoom = 1 + , _magnets = IM.empty + , _itemZoom = 1 + , _defaultZoom = 1 + , _cameraViewFrom = V2 0 0 + , _viewDistance = 1000 + , _modifications = IM.empty + , _creatures = IM.empty + , _crZoning = mempty --Zoning IM.empty crZoneSize zoneOfCreature + , _creatureGroups = IM.empty + , _clouds = mempty + , _clZoning = mempty + , _gusts = IM.empty + , _gsZoning = mempty --Zoning IM.empty clZoneSize (zonePos _guPos) + , _itemLocations = IM.empty + , _props = IM.empty + , _projectiles = IM.empty + , _instantBullets = [] + , _bullets = [] + , -- , _instantParticles = [] + -- , _particles = [] + _flames = [] + , _radarSweeps = [] + , _sparks = [] + , _posEvents = [] + , _energyBalls = [] + , _radarBlips = [] + , _flares = [] + , _newBeams = WorldBeams [] [] [] [] + , _beams = WorldBeams [] [] [] [] + , _teslaArcs = [] + , _shockwaves = [] + , _lasers = [] + , _lasersToDraw = [] + , _tractorBeams = mempty + , _linearShockwaves = mempty + , _walls = IM.empty + , _wallDamages = IM.empty + , _blocks = IM.empty + , _machines = IM.empty + , _terminals = IM.empty + , _doors = IM.empty + , _coordinates = IM.empty + , _triggers = IM.empty + , _wlZoning = IM.empty --Zoning IM.empty wlZoneSize zoneOfWall + , _floorItems = IM.empty + , _floorTiles = [] + , _yourID = 0 + , _worldEvents = [] + , _delayedEvents = [] + , _pressPlates = IM.empty + , _buttons = IM.empty + , _corpses = IM.empty + , _decorations = IM.empty + , --, _savedWorlds = M.empty + -- , _menuLayers = [] + _clickMousePos = V2 0 0 + , _pathGraph = Data.Graph.Inductive.Graph.empty + , -- , _pathGraphP = mempty + _pnZoning = mempty + , _peZoning = mempty + , _hud = + HUD + { _hudElement = DisplayInventory NoSubInventory + , _carteCenter = V2 0 0 + , _carteZoom = 0.5 + , _carteRot = 0 + } + , _lightSources = IM.empty + , _tempLightSources = [] + , _closeObjects = [] + , _seenLocations = + IM.fromList + [ (0, (WdYouPos, "CURRENT POSITION")) + , (1, (WdP2Const (V2 0 0), "START POSITION")) + ] + , _selLocation = 0 + , _foregroundShapes = mempty + , _distortions = [] + , _gameRooms = [] + , _roomClipping = [] + , _worldClock = 0 + , _worldBounds = defaultBounds + , _maybeWorld = Nothing' + , _rewindWorlds = [] + , _genParams = GenParams M.empty + , -- , _genPlacements = IM.empty + -- , _genRooms = IM.empty + _deathDelay = Nothing + , _boundBox = square 100 + , _boundDist = (100, -100, 100, -100) } - , _lightSources = IM.empty - , _tempLightSources = [] - , _closeObjects = [] - , _seenLocations = IM.fromList - [(0, (WdYouPos, "CURRENT POSITION")) - ,(1, (WdP2Const (V2 0 0) , "START POSITION")) - ] - , _selLocation = 0 - , _foregroundShapes = mempty - , _distortions = [] - , _gameRooms = [] - , _roomClipping = [] - , _worldClock = 0 - , _worldBounds = defaultBounds - , _maybeWorld = Nothing' - , _rewindWorlds = [] - , _genParams = GenParams M.empty --- , _genPlacements = IM.empty --- , _genRooms = IM.empty - , _deathDelay = Nothing - , _boundBox = square 100 - , _boundDist = (100,-100,100,-100) - } + defaultWorldHammers :: M.Map WorldHammer HammerPosition -defaultWorldHammers = M.fromSet (const HammerUp) $ S.fromList [minBound.. maxBound] +defaultWorldHammers = M.fromSet (const HammerUp) $ S.fromList [minBound .. maxBound] + --youLight :: TempLightSource ---youLight = TLS +--youLight = TLS -- { _tlsParam = LSParam -- {_lsPos = V3 0 0 0 -- ,_lsRad = 300 diff --git a/src/Dodge/Default/World.hs.orig b/src/Dodge/Default/World.hs.orig index 865a0bffc..40b0b94de 100644 --- a/src/Dodge/Default/World.hs.orig +++ b/src/Dodge/Default/World.hs.orig @@ -1,5 +1,5 @@ module Dodge.Default.World where -import Dodge.Data +import Dodge.Data.World import Dodge.Zone.Size import Dodge.Zone.Object import Dodge.Base diff --git a/src/Dodge/Distortion.hs b/src/Dodge/Distortion.hs index 7414babbf..6ced06bef 100644 --- a/src/Dodge/Distortion.hs +++ b/src/Dodge/Distortion.hs @@ -1,10 +1,10 @@ module Dodge.Distortion where + import Dodge.Data.Distortion updateDistortion :: Distortion -> Maybe Distortion -updateDistortion dt = case dt of - RadialDistortion a b c v - | v > 1 -> Just $ RadialDistortion a b c $ max 1 (v - 0.05) - | v < 1 -> Just $ RadialDistortion a b c $ min 1 (v + 0.05) - | otherwise -> Nothing - +updateDistortion dt = case dt of + RadialDistortion a b c v + | v > 1 -> Just $ RadialDistortion a b c $ max 1 (v - 0.05) + | v < 1 -> Just $ RadialDistortion a b c $ min 1 (v + 0.05) + | otherwise -> Nothing diff --git a/src/Dodge/DrWdWd.hs b/src/Dodge/DrWdWd.hs index 2cf2b3049..46f5238bb 100644 --- a/src/Dodge/DrWdWd.hs +++ b/src/Dodge/DrWdWd.hs @@ -1,18 +1,18 @@ -module Dodge.DrWdWd - where -import Dodge.LevelGen.DoorPane -import Dodge.SoundLogic -import Dodge.Base -import Dodge.WorldBool -import Dodge.Placement.PlaceSpot.TriggerDoor -import Dodge.Wall.Move -import Geometry -import Dodge.Block.Debris -import Dodge.Data +module Dodge.DrWdWd where -import qualified Data.IntSet as IS -import Data.Foldable import Control.Lens +import Data.Foldable +import qualified Data.IntSet as IS +import Dodge.Base +import Dodge.Block.Debris +import Dodge.Data.World +import Dodge.LevelGen.DoorPane +import Dodge.Placement.PlaceSpot.TriggerDoor +import Dodge.SoundLogic +import Dodge.Wall.Move +import Dodge.WorldBool +import Geometry + doDrWdWd :: DrWdWd -> Door -> World -> World doDrWdWd dww = case dww of DrWdId -> const id @@ -23,23 +23,24 @@ doDrWdWd dww = case dww of -- TODO sort out why DoorClosed status does not update correctly 22/06/23 doorMechanism :: Door -> World -> World doorMechanism dr w = case mvDir of - Just d -> w - & flip (IS.foldl' (flip (`translateWallID` d))) (_drWallIDs dr) - & moveUpdate - & cWorld . doors . ix drid . drPos . each %~ (+.+ d) - & maybeClearDoorPaths (_drObstacleType dr) (_drObstructs dr) + Just d -> + w + & flip (IS.foldl' (flip (`translateWallID` d))) (_drWallIDs dr) + & moveUpdate + & cWorld . doors . ix drid . drPos . each %~ (+.+ d) + & maybeClearDoorPaths (_drObstacleType dr) (_drObstructs dr) Nothing -> w where toOpen = doWdBl (_drTrigger dr) w mvDir | toOpen && _drStatus dr == DoorOpen = Nothing -- Not sure why necessary | toOpen && dist dpos dop > 0.5 = Just $ vecBetweenSpeed speed dpos dop - | dist dpos dcp > 0.5 = Just $ vecBetweenSpeed speed dpos dcp + | dist dpos dcp > 0.5 = Just $ vecBetweenSpeed speed dpos dcp | otherwise = Nothing speed = _drSpeed dr drid = _drID dr moveUpdate = playSound . setStatus - playSound + playSound | _drPushedBy dr == PushesItself = soundContinue (WallSound drid) dpos slideDoorS (Just 1) | otherwise = id dpos = snd $ _drPos dr @@ -48,29 +49,31 @@ doorMechanism dr w = case mvDir of setStatus | dist dpos dop < 1 = cWorld . doors . ix drid . drStatus .~ DoorOpen | dist dpos dcp < 1 = cWorld . doors . ix drid . drStatus .~ DoorClosed - | otherwise = cWorld . doors . ix drid . drStatus .~ DoorHalfway + | otherwise = cWorld . doors . ix drid . drStatus .~ DoorHalfway -- TODO use vector instead of list, perhaps also memoisation of rectanglePairs -- TODO update _drPos -- perhaps also remove use of DoorInt in favour of DoorOpen/DoorClosed -- perhaps only store intermediate door pos pairs, calculate all wall positions -- on the fly -doorMechanismStepwise :: Int -> [Int] -> [(Point2,Point2)] -> Door -> World -> World -doorMechanismStepwise nsteps wlids pss dr w +doorMechanismStepwise :: Int -> [Int] -> [(Point2, Point2)] -> Door -> World -> World +doorMechanismStepwise nsteps wlids pss dr w | toOpen = case _drStatus dr of DoorInt x | x == nsteps -> w - DoorInt x -> setWalls (x+1) - _ -> w + DoorInt x -> setWalls (x + 1) + _ -> w | otherwise = case _drStatus dr of DoorInt 0 -> w - DoorInt x -> setWalls (x-1) - _ -> w + DoorInt x -> setWalls (x -1) + _ -> w where drid = _drID dr playSound = soundContinue (WallSound drid) (fst $ head pss) slideDoorS (Just 1) toOpen = doWdBl (_drTrigger dr) w - setWalls n = playSound (foldl' (&) w (zipWith moveWallID wlids newps)) - & cWorld . doors . ix drid . drStatus .~ DoorInt n + setWalls n = + playSound (foldl' (&) w (zipWith moveWallID wlids newps)) + & cWorld . doors . ix drid . drStatus .~ DoorInt n where newps = uncurry (rectanglePairs 9) (pss !! n) + -- it is not at all clear that the zoning selects the correct walls diff --git a/src/Dodge/EnergyBall.hs b/src/Dodge/EnergyBall.hs index da68b4229..f54b3d349 100644 --- a/src/Dodge/EnergyBall.hs +++ b/src/Dodge/EnergyBall.hs @@ -1,63 +1,74 @@ module Dodge.EnergyBall where -import Dodge.Data + import Dodge.DamageCircle +import Dodge.Data.World import Dodge.LightSource import Geometry -import Picture import LensHelp +import Picture import RandomHelp -makeFlamelet - :: Point2 -- ^ Position - -> Float -- ^ z position - -> Point2 -- ^ Velocity - -> Float -- ^ Size - -> Int -- ^ Timer - -> World - -> World -makeFlamelet (V2 x y) z vel size time w = w - & randGen .~ g - & cWorld . energyBalls .:~ EnergyBall - { _ebVel = vel - , _ebColor = red - , _ebPos = V2 x y - , _ebWidth = size - , _ebTimer = time - , _ebEff = (FLAMING,1) - , _ebZ = z - , _ebRot = rot - } +makeFlamelet :: + -- | Position + Point2 -> + -- | z position + Float -> + -- | Velocity + Point2 -> + -- | Size + Float -> + -- | Timer + Int -> + World -> + World +makeFlamelet (V2 x y) z vel size time w = + w + & randGen .~ g + & cWorld . energyBalls + .:~ EnergyBall + { _ebVel = vel + , _ebColor = red + , _ebPos = V2 x y + , _ebWidth = size + , _ebTimer = time + , _ebEff = (FLAMING, 1) + , _ebZ = z + , _ebRot = rot + } where - (rot ,g) = randomR (0,3) $ _randGen w + (rot, g) = randomR (0, 3) $ _randGen w + moveEnergyBall :: World -> EnergyBall -> (World, Maybe EnergyBall) -moveEnergyBall w eb - | _ebTimer eb <= 0 = ( w, Nothing) - | otherwise = +moveEnergyBall w eb + | _ebTimer eb <= 0 = (w, Nothing) + | otherwise = ( ebFlicker eb $ uncurry (damageCircle 5 (_ebPos eb)) (_ebEff eb) w , Just $ eb & ebTimer -~ 1 & ebPos .+.+~ _ebVel eb & ebVel .*.*~ 0.9 ) - incBallAt :: Point2 -> World -> World -incBallAt p w = w & cWorld . energyBalls .:~ theincball - & randGen .~ g +incBallAt p w = + w & cWorld . energyBalls .:~ theincball + & randGen .~ g where - (theincball,g) = runState thestate (_randGen w) + (theincball, g) = runState thestate (_randGen w) thestate = do - rot <- state $ randomR (0,3) - return EnergyBall - { _ebVel = 0 - , _ebColor = red - , _ebPos = p - , _ebWidth = 3 - , _ebTimer = 20 - , _ebEff = (FLAMING,1) - , _ebZ = 20 - , _ebRot = rot - } + rot <- state $ randomR (0, 3) + return + EnergyBall + { _ebVel = 0 + , _ebColor = red + , _ebPos = p + , _ebWidth = 3 + , _ebTimer = 20 + , _ebEff = (FLAMING, 1) + , _ebZ = 20 + , _ebRot = rot + } ebFlicker :: EnergyBall -> World -> World -ebFlicker pt - | _ebTimer pt `mod` 7 == 0 = cWorld . tempLightSources - .:~ tlsTimeRadColPos 1 70 (0.5 *.*.* xyzV4 (_ebColor pt)) (addZ 20 $ _ebPos pt) +ebFlicker pt + | _ebTimer pt `mod` 7 == 0 = + cWorld . tempLightSources + .:~ tlsTimeRadColPos 1 70 (0.5 *.*.* xyzV4 (_ebColor pt)) (addZ 20 $ _ebPos pt) | otherwise = id diff --git a/src/Dodge/EnergyBall/Draw.hs b/src/Dodge/EnergyBall/Draw.hs index 17196f110..cc561abc9 100644 --- a/src/Dodge/EnergyBall/Draw.hs +++ b/src/Dodge/EnergyBall/Draw.hs @@ -1,29 +1,32 @@ module Dodge.EnergyBall.Draw where -import Dodge.Data + +import Dodge.Data.Damage.Type +import Dodge.Data.EnergyBall import Geometry import Picture - drawEnergyBall :: EnergyBall -> Picture drawEnergyBall eb = case _ebEff eb of - (ELECTRICAL,_) -> drawStaticBall eb - (FLAMING,_) -> drawFlamelet eb + (ELECTRICAL, _) -> drawStaticBall eb + (FLAMING, _) -> drawFlamelet eb _ -> error "don't know how to draw an energy ball of this type" -drawStaticBall - :: EnergyBall - -> Picture -drawStaticBall pt = setLayer BloomNoZWrite - . setDepth (_ebZ pt + 20) - . uncurryV translate (_ebPos pt) - $ circleSolidCol (_ebColor pt) (withAlpha 0.5 white) (_ebWidth pt+5) +drawStaticBall :: + EnergyBall -> + Picture +drawStaticBall pt = + setLayer BloomNoZWrite + . setDepth (_ebZ pt + 20) + . uncurryV translate (_ebPos pt) + $ circleSolidCol (_ebColor pt) (withAlpha 0.5 white) (_ebWidth pt + 5) drawFlamelet :: EnergyBall -> Picture -drawFlamelet pt = pictures - [ setLayer BloomLayer pic - , setLayer BloomNoZWrite piu - , setLayer BloomNoZWrite pi2 - ] +drawFlamelet pt = + pictures + [ setLayer BloomLayer pic + , setLayer BloomNoZWrite piu + , setLayer BloomNoZWrite pi2 + ] where z = _ebZ pt sp = _ebPos pt @@ -32,32 +35,46 @@ drawFlamelet pt = pictures size = _ebWidth pt siz2 = size + 0.2 time = _ebTimer pt - piu = setDepth (z + 25) - . uncurryV translate ep - . color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time) - (V4 2 0 0 1) (V4 2 0 0 0) - ) - . rotate (negate (rot - 0.1 * fromIntegral time)) - . scale s1 s1 - $ polygon (rectNSWE siz2 (-siz2) (-siz2) siz2) - pi2 = setDepth (z + 25) - . uncurryV translate ep - . color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time) - (V4 2 1 0 0.5) (V4 0 0 0 0) - ) - . rotate (negate (rot + 0.2 * fromIntegral time)) - . scale s2 s2 - $ polygon (rectNSWE siz2 (-siz2) (-siz2) siz2) - pic = setDepth (z + 20) - . uncurryV translate ep - . color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time) - (V4 1 1 1 3) (V4 1 0 0 1) + piu = + setDepth (z + 25) + . uncurryV translate ep + . color + ( mixColors + (fromIntegral (max 0 (time -2))) + (10 - fromIntegral time) + (V4 2 0 0 1) + (V4 2 0 0 0) ) - . rotate (negate ( 0.1 * fromIntegral time + rot)) - . scale (0.5* sc) (0.5 *sc) - $ polygon $ map toV2 [(-size,-size),(size,-size),(size,size),(-size,size)] + . rotate (negate (rot - 0.1 * fromIntegral time)) + . scale s1 s1 + $ polygon (rectNSWE siz2 (- siz2) (- siz2) siz2) + pi2 = + setDepth (z + 25) + . uncurryV translate ep + . color + ( mixColors + (fromIntegral (max 0 (time -2))) + (10 - fromIntegral time) + (V4 2 1 0 0.5) + (V4 0 0 0 0) + ) + . rotate (negate (rot + 0.2 * fromIntegral time)) + . scale s2 s2 + $ polygon (rectNSWE siz2 (- siz2) (- siz2) siz2) + pic = + setDepth (z + 20) + . uncurryV translate ep + . color + ( mixColors + (fromIntegral (max 0 (time -2))) + (10 - fromIntegral time) + (V4 1 1 1 3) + (V4 1 0 0 1) + ) + . rotate (negate (0.1 * fromIntegral time + rot)) + . scale (0.5 * sc) (0.5 * sc) + $ polygon $ map toV2 [(- size, - size), (size, - size), (size, size), (- size, size)] sc = (*) 2 $ log $ 1 + fromIntegral time / 20 s1 = (*) 2 $ log $ 2 + fromIntegral time / 40 s2 = 0.5 * (sc + s1) rot = _ebRot pt - diff --git a/src/Dodge/Equipment.hs b/src/Dodge/Equipment.hs index d42a12c1e..833b45c22 100644 --- a/src/Dodge/Equipment.hs +++ b/src/Dodge/Equipment.hs @@ -1,8 +1,7 @@ module Dodge.Equipment where ---import Data.Strict.IntMap.Autogen.Merge.Strict import Data.IntMap.Merge.Strict -import Dodge.Data +import Dodge.Data.Creature import qualified IntMapHelp as IM getCrEquipment :: Creature -> IM.IntMap Item diff --git a/src/Dodge/Euse.hs b/src/Dodge/Euse.hs index 5683fdd24..21f2ea631 100644 --- a/src/Dodge/Euse.hs +++ b/src/Dodge/Euse.hs @@ -12,7 +12,7 @@ import Dodge.Wall.Move import Dodge.Wall.Delete import Dodge.Wall.ForceField import Dodge.Item.Location -import Dodge.Data +import Dodge.Data.World import Dodge.Item.Weapon.ExtraEffect import Dodge.Item.Weapon.Radar import Dodge.SoundLogic.ExternallyGeneratedSounds @@ -47,24 +47,24 @@ useMagShield it cr w = w & cWorld . magnets . at mgid ?~ themagnet onEquipWristShield :: Item -> Creature -> World -> World onEquipWristShield itm cr w = w - & pointerToItem itm . itUse . eqEq . eqParams .~ EquipID i + & pointerToItem itm . itUse . equipEffect . eeParams .~ EquipID i & cWorld . walls . at i ?~ forceField{_wlID = i} - & setWristShieldPos (itm & itUse . eqEq . eqParams .~ EquipID i) cr + & setWristShieldPos (itm & itUse . equipEffect . eeParams .~ EquipID i) cr where i = IM.newKey (_walls (_cWorld w)) onRemoveWristShield :: Item -> Creature -> World -> World onRemoveWristShield itm _ = - (pointerToItem itm . itUse . eqEq . eqParams .~ NoEquipParams) . deleteWallID i + (pointerToItem itm . itUse . equipEffect . eeParams .~ NoEquipParams) . deleteWallID i where - i = _eparamID $ _eqParams $ _eqEq $ _itUse itm + i = _eparamID $ _eeParams $ _equipEffect $ _itUse itm setWristShieldPos :: Item -> Creature -> World -> World setWristShieldPos itm cr w = w & moveWallIDUnsafe i wlline where - i = _eparamID $ _eqParams $ _eqEq $ _itUse itm + i = _eparamID $ _eeParams $ _equipEffect $ _itUse itm wlline = (f (V3 (-10) 7 0), f (V3 10 7 0)) invid = _ipInvID (_itLocation itm) handtrans = case cr ^? crInvEquipped . ix invid of diff --git a/src/Dodge/Event.hs b/src/Dodge/Event.hs index 92b4e4346..fe95f8e72 100644 --- a/src/Dodge/Event.hs +++ b/src/Dodge/Event.hs @@ -22,7 +22,7 @@ import qualified Data.Set as S import qualified Data.Text as T import Dodge.Base import Dodge.Combine -import Dodge.Data +import Dodge.Data.Universe import Dodge.Event.Keyboard import Dodge.HeldScroll import Dodge.InputFocus diff --git a/src/Dodge/Event/Keyboard.hs b/src/Dodge/Event/Keyboard.hs index 3aae23a1c..6452970b0 100644 --- a/src/Dodge/Event/Keyboard.hs +++ b/src/Dodge/Event/Keyboard.hs @@ -1,49 +1,53 @@ -{- | Deals with keyboard events. -} -module Dodge.Event.Keyboard - ( handleKeyboardEvent - , handleTextInput - , guardDisconnectedID - ) where -import Dodge.Terminal.LeftButton -import Dodge.WorldPos -import Dodge.Button.Event -import Dodge.InputFocus +-- | Deals with keyboard events. +module Dodge.Event.Keyboard ( + handleKeyboardEvent, + handleTextInput, + guardDisconnectedID, +) where + +--import Color + +--import Data.List + +import Data.Maybe +import qualified Data.Set as S +--import Data.Text (unpack) +import qualified Data.Text as T import Dodge.Base +import Dodge.Button.Event import Dodge.Combine import Dodge.Creature.Action -import Dodge.Data +import Dodge.Data.Universe import Dodge.Event.Menu import Dodge.Event.Test +import Dodge.InputFocus import Dodge.Inventory import Dodge.Menu import Dodge.Reloading import Dodge.Save +import Dodge.Terminal.LeftButton +import Dodge.WorldPos +import qualified IntMapHelp as IM import LensHelp ---import Color - ---import Data.List -import qualified IntMapHelp as IM -import Data.Maybe -import qualified Data.Set as S -import SDL ---import Data.Text (unpack) -import qualified Data.Text as T +import SDL -- annoyingly, the text input event doesn't register backspace, so deletion has to be -- dealt with using key presses (handlePressedKey) -- also, note that this currently "doubles" the inputs to both terminals if both -- are open handleTextInput :: T.Text -> Universe -> Universe -handleTextInput text u = u - & menuLayers . ix 0 . scInput %~ updateText - & updateTerminalText +handleTextInput text u = + u + & menuLayers . ix 0 . scInput %~ updateText + & updateTerminalText where updateTerminalText = case u ^? uvWorld . cWorld . hud . hudElement . subInventory of - Just (DisplayTerminal tmid) | hasfocus tmid - -> uvWorld %~ \w -> guardDisconnectedID tmid w (w & cWorld . terminals . ix tmid . tmInput . tiText %~ updateText) - _ -> id + Just (DisplayTerminal tmid) + | hasfocus tmid -> + uvWorld %~ \w -> guardDisconnectedID tmid w (w & cWorld . terminals . ix tmid . tmInput . tiText %~ updateText) + _ -> id hasfocus tmid = fromMaybe False $ u ^? uvWorld . cWorld . terminals . ix tmid . tmInput . tiFocus - updateText s = case T.unpack text of + updateText s = case T.unpack text of ";" -> s _ -> s `T.append` T.toUpper text @@ -52,97 +56,102 @@ guardDisconnectedID tmid w w' = case w ^? cWorld . terminals . ix tmid . tmStatu Just TerminalReady -> w' _ -> w - {- | Handles keyboard press and release. On release, remove scancode from the 'Set' of pressed keys. On press, adds the scancode, and perhaps applies a direct effect: see 'handlePressedKeyInGame'. - -} +-} handleKeyboardEvent :: KeyboardEventData -> Universe -> IO (Maybe Universe) handleKeyboardEvent kev u = case keyboardEventKeyMotion kev of - Released -> return . Just $ u & uvWorld . keys %~ S.delete scode - Pressed -> handlePressedKey (keyboardEventRepeat kev) scode - (u & uvWorld . keys %~ S.insert scode) + Released -> return . Just $ u & uvWorld . keys %~ S.delete scode + Pressed -> + handlePressedKey + (keyboardEventRepeat kev) + scode + (u & uvWorld . keys %~ S.insert scode) where scode = (keysymScancode . keyboardEventKeysym) kev handlePressedKey :: Bool -> Scancode -> Universe -> IO (Maybe Universe) -handlePressedKey True ScancodeBackspace u - | _backspaceTimer (_uvWorld u) <= 0 = handlePressedKey False ScancodeBackspace u - <&> _Just . uvWorld . backspaceTimer .~ 0 - | otherwise = return $ Just $ u & uvWorld . backspaceTimer -~ 1 -handlePressedKey True _ u = return $ Just u -handlePressedKey _ scode u = case scode of - ScancodeF1 -> Just <$> (writeSaveSlot (SaveSlotNum 1) u >> return u) - ScancodeF2 -> Just <$> readSaveSlot (SaveSlotNum 1) u - ScancodeF5 -> return . Just $ doQuicksave u - ScancodeF9 -> return . Just $ loadSaveSlot QuicksaveSlot u - ScancodeSemicolon -> return . Just $ gotoTerminal u +handlePressedKey True ScancodeBackspace u + | _backspaceTimer (_uvWorld u) <= 0 = + handlePressedKey False ScancodeBackspace u + <&> _Just . uvWorld . backspaceTimer .~ 0 + | otherwise = return $ Just $ u & uvWorld . backspaceTimer -~ 1 +handlePressedKey True _ u = return $ Just u +handlePressedKey _ scode u = case scode of + ScancodeF1 -> Just <$> (writeSaveSlot (SaveSlotNum 1) u >> return u) + ScancodeF2 -> Just <$> readSaveSlot (SaveSlotNum 1) u + ScancodeF5 -> return . Just $ doQuicksave u + ScancodeF9 -> return . Just $ loadSaveSlot QuicksaveSlot u + ScancodeSemicolon -> return . Just $ gotoTerminal u _ | null (_menuLayers u) -> case u ^? uvWorld . cWorld . hud . hudElement . subInventory of - Just (DisplayTerminal tmid) | inTermFocus (_uvWorld u) - -> return $ uvWorld (Just . handlePressedKeyTerminal tmid scode) u - _ -> return $ (Just . handlePressedKeyInGame scode) u + Just (DisplayTerminal tmid) + | inTermFocus (_uvWorld u) -> + return $ uvWorld (Just . handlePressedKeyTerminal tmid scode) u + _ -> return $ (Just . handlePressedKeyInGame scode) u _ -> handlePressedKeyInMenu (head $ _menuLayers u) scode u handlePressedKeyInGame :: Scancode -> Universe -> Universe handlePressedKeyInGame scode uv = case scode of - ScancodeEscape -> pauseGame $ over uvWorld escapeMap uv - ScancodeSpace -> over uvWorld spaceAction uv - ScancodeP -> pauseGame $ over uvWorld escapeMap uv - ScancodeF -> over uvWorld youDropItem uv - ScancodeM -> over uvWorld toggleMap uv - ScancodeR -> over uvWorld (crToggleReloading (you w)) uv - ScancodeT -> over uvWorld testEvent uv - ScancodeX -> uv & uvWorld %~ toggleTweakInv - ScancodeC -> over uvWorld toggleCombineInv uv - ScancodeI -> uv & uvWorld . cWorld . hud . hudElement %~ toggleInspectInv - _ -> uv + ScancodeEscape -> pauseGame $ over uvWorld escapeMap uv + ScancodeSpace -> over uvWorld spaceAction uv + ScancodeP -> pauseGame $ over uvWorld escapeMap uv + ScancodeF -> over uvWorld youDropItem uv + ScancodeM -> over uvWorld toggleMap uv + ScancodeR -> over uvWorld (crToggleReloading (you w)) uv + ScancodeT -> over uvWorld testEvent uv + ScancodeX -> uv & uvWorld %~ toggleTweakInv + ScancodeC -> over uvWorld toggleCombineInv uv + ScancodeI -> uv & uvWorld . cWorld . hud . hudElement %~ toggleInspectInv + _ -> uv where w = _uvWorld uv - handlePressedKeyTerminal :: Int -> Scancode -> World -> World handlePressedKeyTerminal tmid scode w = case scode of - ScancodeEscape -> w & cWorld . terminals . ix tmid . tmInput . tiFocus %~ const False - ScancodeReturn -> w & terminalReturnEffect (w ^?! cWorld . terminals . ix tmid) - ScancodeBackspace -> w - & cWorld . terminals . ix tmid . tmInput . tiText %~ doBackspace - & backspaceTimer .~ 5 - _ -> w + ScancodeEscape -> w & cWorld . terminals . ix tmid . tmInput . tiFocus %~ const False + ScancodeReturn -> w & terminalReturnEffect (w ^?! cWorld . terminals . ix tmid) + ScancodeBackspace -> + w + & cWorld . terminals . ix tmid . tmInput . tiText %~ doBackspace + & backspaceTimer .~ 5 + _ -> w where doBackspace t = case T.unsnoc t of Nothing -> t - Just (t',_) -> t' + Just (t', _) -> t' toggleTweakInv :: World -> World toggleTweakInv w = case w ^. cWorld . hud . hudElement of DisplayInventory TweakInventory{} -> w & thepointer .~ DisplayInventory NoSubInventory - _ -> w & thepointer .~ DisplayInventory (TweakInventory mi) + _ -> w & thepointer .~ DisplayInventory (TweakInventory mi) where thepointer = cWorld . hud . hudElement mi = 0 <$ (yourItem w >>= (^? itTweaks . tweakParams . ix 0)) toggleInspectInv :: HUDElement -> HUDElement toggleInspectInv he = case he of - DisplayInventory InspectInventory -> DisplayInventory NoSubInventory - _ -> DisplayInventory InspectInventory + DisplayInventory InspectInventory -> DisplayInventory NoSubInventory + _ -> DisplayInventory InspectInventory gotoTerminal :: Universe -> Universe gotoTerminal w = case _menuLayers w of - (InputScreen {} : _) -> w - _ -> w & menuLayers .:~ InputScreen T.empty "Enter command" + (InputScreen{} : _) -> w + _ -> w & menuLayers .:~ InputScreen T.empty "Enter command" spaceAction :: World -> World spaceAction w = case _hudElement $ _hud (_cWorld w) of DisplayCarte -> w & cWorld . hud . carteCenter .~ theLoc DisplayInventory NoSubInventory -> case selectedCloseObject w of - Just (_,Left flit) -> pickUpItem 0 flit w - Just (_,Right but) -> doButtonEvent (_btEvent but) but w - _ -> w - DisplayInventory DisplayTerminal {} -> w & cWorld . hud . hudElement .~ DisplayInventory NoSubInventory + Just (_, Left flit) -> pickUpItem 0 flit w + Just (_, Right but) -> doButtonEvent (_btEvent but) but w + _ -> w + DisplayInventory DisplayTerminal{} -> w & cWorld . hud . hudElement .~ DisplayInventory NoSubInventory _ -> w & cWorld . hud . hudElement .~ DisplayInventory NoSubInventory where theLoc = doWorldPos (fst (_seenLocations (_cWorld w) IM.! _selLocation (_cWorld w))) w + -- updateTopCloseObject i w' = w' & closeObjects %~ ( Right (_buttons w' IM.! i) : ) . tail pauseGame :: Universe -> Universe @@ -151,8 +160,9 @@ pauseGame = menuLayers .~ [pauseMenu] toggleMap :: World -> World toggleMap w = case _hudElement $ _hud (_cWorld w) of DisplayCarte -> w & cWorld . hud . hudElement .~ DisplayInventory NoSubInventory - _ -> w & cWorld . hud . hudElement .~ DisplayCarte + _ -> w & cWorld . hud . hudElement .~ DisplayCarte + escapeMap :: World -> World escapeMap w = case _hudElement $ _hud (_cWorld w) of DisplayCarte -> w & cWorld . hud . hudElement .~ DisplayInventory NoSubInventory - _ -> w + _ -> w diff --git a/src/Dodge/Event/Menu.hs b/src/Dodge/Event/Menu.hs index ab9e97cd5..fadee908b 100644 --- a/src/Dodge/Event/Menu.hs +++ b/src/Dodge/Event/Menu.hs @@ -1,61 +1,66 @@ -module Dodge.Event.Menu - ( handlePressedKeyInMenu - ) where -import Dodge.Data +module Dodge.Event.Menu ( + handlePressedKeyInMenu, +) where + +import Control.Lens +import Data.Maybe +import qualified Data.Text as T +import Dodge.Data.Universe import Dodge.Debug.Terminal ---import Dodge.Menu import Dodge.Menu.PushPop import Dodge.WindowLayout - -import Data.Maybe ---import Control.Monad -import Control.Lens import SDL ---import qualified Debug.Trace -import qualified Data.Text as T handlePressedKeyInMenu :: ScreenLayer -> Scancode -> Universe -> IO (Maybe Universe) handlePressedKeyInMenu mState scode = case mState of - OptionScreen { _scOptions = mos, _scDefaultEff = defeff} - -> optionListToEffects defeff scode mos - DisplayScreen {} -> popScreen - ColumnsScreen {} -> popScreen - WaitScreen {} -> return . Just - InputScreen s help -> case scode of - ScancodeEscape -> popScreen - ScancodeReturn -> popScreen . applyTerminalString (words $ T.unpack s) - ScancodeTab -> autoCompleteTerminal (T.unpack s) help - ScancodeBackspace -> return . Just . (menuLayers . ix 0 . scInput %~ doBackspace) + OptionScreen{_scOptions = mos, _scDefaultEff = defeff} -> + optionListToEffects defeff scode mos + DisplayScreen{} -> popScreen + ColumnsScreen{} -> popScreen + WaitScreen{} -> return . Just + InputScreen s help -> case scode of + ScancodeEscape -> popScreen + ScancodeReturn -> popScreen . applyTerminalString (words $ T.unpack s) + ScancodeTab -> autoCompleteTerminal (T.unpack s) help + ScancodeBackspace -> return . Just . (menuLayers . ix 0 . scInput %~ doBackspace) -- text input handled by handleTextInput - _ -> return . Just + _ -> return . Just where doBackspace t = case T.unsnoc t of Nothing -> t - Just (t',_) -> t' + Just (t', _) -> t' -optionListToEffects - :: (Universe -> IO (Maybe Universe)) - -> Scancode - -> [MenuOption] - -> Universe -> IO (Maybe Universe) +optionListToEffects :: + (Universe -> IO (Maybe Universe)) -> + Scancode -> + [MenuOption] -> + Universe -> + IO (Maybe Universe) optionListToEffects defaulteff sc mops u = case sc of - ScancodeSpace -> return . Just - . (menuLayers . ix 0 . scOptionsOffset %~ (f . (+ mlines))) - $ u - _ -> (fromMaybe defaulteff - . lookup sc - . concatMap menuOptionToEffects $ mops) u + ScancodeSpace -> + return . Just + . (menuLayers . ix 0 . scOptionsOffset %~ (f . (+ mlines))) + $ u + _ -> + ( fromMaybe defaulteff + . lookup sc + . concatMap menuOptionToEffects + $ mops + ) + u where - f x | x > length mops = 0 + f x + | x > length mops = 0 | otherwise = x mlines = availableMenuLines $ _uvConfig u -menuOptionToEffects :: MenuOption -> [(Scancode,Universe -> IO (Maybe Universe))] -menuOptionToEffects Toggle {_moKey = k, _moEff = eff} = [(k,eff)] -menuOptionToEffects InvisibleToggle {_moKey = k, _moEff = eff} = [(k,eff)] -menuOptionToEffects Toggle2 - { _moKey1 = k1 - , _moEff1 = eff1 - , _moKey2 = k2 - , _moEff2 = eff2 - } = [(k1,eff1) , (k2,eff2)] +menuOptionToEffects :: MenuOption -> [(Scancode, Universe -> IO (Maybe Universe))] +menuOptionToEffects Toggle{_moKey = k, _moEff = eff} = [(k, eff)] +menuOptionToEffects InvisibleToggle{_moKey = k, _moEff = eff} = [(k, eff)] +menuOptionToEffects + Toggle2 + { _moKey1 = k1 + , _moEff1 = eff1 + , _moKey2 = k2 + , _moEff2 = eff2 + } = [(k1, eff1), (k2, eff2)] diff --git a/src/Dodge/Event/Test.hs b/src/Dodge/Event/Test.hs index f2113339b..56dac75cd 100644 --- a/src/Dodge/Event/Test.hs +++ b/src/Dodge/Event/Test.hs @@ -1,15 +1,9 @@ -module Dodge.Event.Test - ( testEvent - ) - where -import Dodge.Data ---import Dodge.Base ---import Dodge.Default ---import Picture ---import Geometry --- ---import qualified IntMapHelp as IM ---import Control.Lens +module Dodge.Event.Test ( + testEvent, +) where + +import Dodge.Data.World + testEvent :: World -> World testEvent w = w @@ -21,17 +15,17 @@ testEvent w = w -- -- testWalls = IM.fromList $ zip [k..] $ setKeys (startWalls ++ errorWalls ++ (errorWall : polyWalls) ++ endWalls) -- --- polyPairs = makeLoopPairs +-- polyPairs = makeLoopPairs -- $ reverse [(-340.0,59.999996),(-374.64102,79.99999),(-340.0,100.0)] ---- [(4172.5835,2597.1892),(3855.1414,2597.1895),(3855.141,2324.7563),(4172.5835,2324.756)] -- polyWalls = map (wallWithCol red . flat2) polyPairs --- --- errorWallPair = +-- +-- errorWallPair = -- (9,[(-340.0,60.0),(-320.0,60.0)]) ---- (48,[(3855.1414,2587.1892),(3855.141,2324.7563)]) -- errorWall = wallWithCol green $ snd errorWallPair -- --- errorWallPairs = +-- errorWallPairs = -- [(1,[(-400.0,59.999996),(-340.0,60.0)]) -- ,(12,[(-340.0,60.0),(-340.0,59.999996)]) -- ] @@ -39,8 +33,8 @@ testEvent w = w ---- ,(49,[(3855.1414,2597.1895),(3855.1414,2587.1892)]) ---- ] -- errorWalls = map (wallWithCol blue . snd) errorWallPairs --- --- startWallPairs = +-- +-- startWallPairs = -- [(0,[(-320.0,60.0),(-320.0,100.0)]) -- ,(1,[(-400.0,59.999996),(-320.0,60.0)]) -- ,(2,[(-400.0,100.0),(-400.0,59.999996)]) @@ -61,9 +55,9 @@ testEvent w = w ---- ,(40,[(3895.1414,2647.1892),(3895.1414,2667.1892)]) ---- ] -- startWalls = map (wallWithCol yellow . snd) startWallPairs --- +-- -- endWalls = map (wallWithCol (withAlpha 0.2 orange) . snd) endWallPairs --- endWallPairs = +-- endWallPairs = -- [(0,[(-320.0,60.0),(-320.0,100.0)]) -- ,(1,[(-400.0,59.999996),(-340.0,60.0)]) -- ,(2,[(-400.0,100.0),(-400.0,59.999996)]) diff --git a/src/Dodge/Flame.hs b/src/Dodge/Flame.hs index 0f3b6b6e3..a978ed6c3 100644 --- a/src/Dodge/Flame.hs +++ b/src/Dodge/Flame.hs @@ -1,58 +1,67 @@ -module Dodge.Flame - ( aFlameParticle - , makeFlame - , moveFlame - ) where -import Dodge.Zoning.Wall -import qualified ListHelp as List -import Dodge.Data +module Dodge.Flame ( + aFlameParticle, + makeFlame, + moveFlame, +) where + +import Dodge.Data.World +import Data.Foldable +import Data.Tuple import Dodge.LightSource -import Dodge.WorldEvent.ThingsHit -import Dodge.WorldEvent.Cloud import Dodge.SoundLogic -import RandomHelp -import Picture +import Dodge.WorldEvent.Cloud +import Dodge.WorldEvent.ThingsHit +import Dodge.Zoning.Wall import Geometry import qualified IntMapHelp as IM import LensHelp +import qualified ListHelp as List +import Picture +import RandomHelp -import Data.Foldable -import Data.Tuple +aFlameParticle :: + -- | Timer + Int -> + -- | Position + Point2 -> + -- | Velocity + Point2 -> + Flame +aFlameParticle t pos vel = + Flame + { _flVel = vel + , _flColor = red + , _flPos = pos + , _flWidth = 4 + , _flTimer = t + , _flZ = 20 + , _flOriginalVel = vel + } -aFlameParticle - :: Int -- ^ Timer - -> Point2 -- ^ Position - -> Point2 -- ^ Velocity - -> Flame -aFlameParticle t pos vel = Flame - { _flVel = vel - , _flColor = red - , _flPos = pos - , _flWidth = 4 - , _flTimer = t - , _flZ = 20 - , _flOriginalVel = vel - } simpleDamFL :: DamageType -> Int -> Flame -> Point2 -> [Damage] -simpleDamFL dt amount bt p = [ Damage dt amount sp p ep NoDamageEffect ] +simpleDamFL dt amount bt p = [Damage dt amount sp p ep NoDamageEffect] where sp = _flPos bt bulVel = _flVel bt ep = sp +.+ bulVel -expireAndDamageFL :: (Flame -> Point2 -> [Damage]) - -> Flame - -> [(Point2, Either Creature Wall)] - -> World - -> (World, Maybe Flame) + +expireAndDamageFL :: + (Flame -> Point2 -> [Damage]) -> + Flame -> + [(Point2, Either Creature Wall)] -> + World -> + (World, Maybe Flame) expireAndDamageFL fdm bt things w = case List.safeHead things of Nothing -> (w, Just $ bt & flTimer -~ 1) Just x -> (doDamagesFL fdm x bt w, Nothing) -doDamagesFL :: (Flame -> Point2 -> [Damage]) - -> (Point2, Either Creature Wall) - -> Flame - -> World - -> World -doDamagesFL fdm (p,thhit) bt = case thhit of + +doDamagesFL :: + (Flame -> Point2 -> [Damage]) -> + (Point2, Either Creature Wall) -> + Flame -> + World -> + World +doDamagesFL fdm (p, thhit) bt = case thhit of Left cr -> cWorld . creatures . ix (_crID cr) . crState . csDamage .++~ dams Right wl -> cWorld . wallDamages %~ IM.insertWith (++) (_wlID wl) dams where @@ -60,60 +69,69 @@ doDamagesFL fdm (p,thhit) bt = case thhit of {- TODO: add generalised area damage particles/hiteffects. -} moveFlame :: World -> Flame -> (World, Maybe Flame) -moveFlame w pt +moveFlame w pt | time <= 0 = (makeFlamerSmokeAt (addZ 20 ep) w, Nothing) | otherwise = case List.safeHead $ thingsHit sp ep w of - Just (_,Left _) -> (doSound $ dodamage w , mvPt' 0.7) - Just (p,Right wl) -> (doSound $ dodamage w , rfl wl p) - _ -> (flFlicker pt $ doSound $ dodamage w , mvPt' 0.98) - where + Just (_, Left _) -> (doSound $ dodamage w, mvPt' 0.7) + Just (p, Right wl) -> (doSound $ dodamage w, rfl wl p) + _ -> (flFlicker pt $ doSound $ dodamage w, mvPt' 0.98) + where rotd = _flOriginalVel pt time = _flTimer pt doSound = soundContinue FlameSound (V2 x y) fireLoudS (Just 2) sp@(V2 x y) = _flPos pt vel = _flVel pt ep = sp +.+ vel - mvPt' drag = Just $ pt - & flTimer -~ 1 - & flPos .~ ep - & flVel %~ (drag *.*) + mvPt' drag = + Just $ + pt + & flTimer -~ 1 + & flPos .~ ep + & flVel %~ (drag *.*) dodamage = flDamageInArea closeCrs closeWls pt closeWls wl = uncurry segOnCirc (_wlLine wl) ep 5 - closeCrs cr = dist ep (_crPos cr) - < _crRad cr + 10 - min 9 (max 0 (fromIntegral time - 80)) - + 5 * angleCoeff (angleVV (ep -.- _crPos cr) rotd) - angleCoeff x' = abs $ 1 - abs ( (x' * 2 - pi) / pi ) - rfl wl p = Just $ pt - { _flTimer = time - 1 - , _flPos = pOut p - , _flVel = reflV wl - } + closeCrs cr = + dist ep (_crPos cr) + < _crRad cr + 10 - min 9 (max 0 (fromIntegral time - 80)) + + 5 * angleCoeff (angleVV (ep -.- _crPos cr) rotd) + angleCoeff x' = abs $ 1 - abs ((x' * 2 - pi) / pi) + rfl wl p = + Just $ + pt + { _flTimer = time - 1 + , _flPos = pOut p + , _flVel = reflV wl + } pOut p = p +.+ squashNormalizeV (sp -.- p) - reflV wall = (0.3 *.* reflectIn (uncurry (-.-) . swap $ _wlLine wall) vel ) - +.+ (0.2 *.* vel) + reflV wall = + (0.3 *.* reflectIn (uncurry (-.-) . swap $ _wlLine wall) vel) + +.+ (0.2 *.* vel) flDamageInArea :: (Creature -> Bool) -> (Wall -> Bool) -> Flame -> World -> World {-# INLINE flDamageInArea #-} flDamageInArea crt wlt pt w = damwls damcrs where p = _flPos pt - damcrs = foldl' (flip $ \cr -> fst . hiteff [(p,Left cr)]) w $ IM.filter crt $ _creatures (_cWorld w) - damwls w' - = foldl' - (flip $ \wl -> fst . hiteff [(p,Right wl)]) - w' - . filter wlt - $ wlsNearPoint p w' + damcrs = foldl' (flip $ \cr -> fst . hiteff [(p, Left cr)]) w $ IM.filter crt $ _creatures (_cWorld w) + damwls w' = + foldl' + (flip $ \wl -> fst . hiteff [(p, Right wl)]) + w' + . filter wlt + $ wlsNearPoint p w' hiteff = expireAndDamageFL (simpleDamFL FLAMING 1) pt flFlicker :: Flame -> World -> World -flFlicker pt - | _flTimer pt `mod` 7 == 0 = cWorld . tempLightSources - .:~ tlsTimeRadColPos 1 70 (0.5 *.*.* xyzV4 (_flColor pt)) (addZ 10 $ _flPos pt) +flFlicker pt + | _flTimer pt `mod` 7 == 0 = + cWorld . tempLightSources + .:~ tlsTimeRadColPos 1 70 (0.5 *.*.* xyzV4 (_flColor pt)) (addZ 10 $ _flPos pt) | otherwise = id + makeFlame :: Point2 -> Point2 -> World -> World -makeFlame pos vel w = w - & cWorld . flames .:~ aFlameParticle t pos vel - & randGen .~ g - where - (t,g) = randomR (99,101) (_randGen w) +makeFlame pos vel w = + w + & cWorld . flames .:~ aFlameParticle t pos vel + & randGen .~ g + where + (t, g) = randomR (99, 101) (_randGen w) diff --git a/src/Dodge/Flame/Draw.hs b/src/Dodge/Flame/Draw.hs index cdb4f533d..0567b6a8a 100644 --- a/src/Dodge/Flame/Draw.hs +++ b/src/Dodge/Flame/Draw.hs @@ -1,35 +1,40 @@ module Dodge.Flame.Draw where -import Dodge.Data + +import Dodge.Data.Flame import Geometry import Picture -drawFlame - :: Flame - -> Picture -drawFlame pt = pictures - [ glow - , aPic BloomNoZWrite prot2 25 (V2 (scaleChange + 1) 2 ) $ V4 2 (-1) (-1) 0.5 - , aPic BloomNoZWrite prot 22 (V2 (scaleChange + 0.5) 1 ) $ V4 1 0.5 0 2 - , aPic BloomLayer prot3 20 (V2 scaleChange 0.5) $ V4 1 1 1 1 - ] - where +drawFlame :: + Flame -> + Picture +drawFlame pt = + pictures + [ glow + , aPic BloomNoZWrite prot2 25 (V2 (scaleChange + 1) 2) $ V4 2 (-1) (-1) 0.5 + , aPic BloomNoZWrite prot 22 (V2 (scaleChange + 0.5) 1) $ V4 1 0.5 0 2 + , aPic BloomLayer prot3 20 (V2 scaleChange 0.5) $ V4 1 1 1 1 + ] + where rotd = _flOriginalVel pt -- rotate direction ep = _flPos pt aPic :: Layer -> (Point2 -> Point2) -> Float -> Point2 -> Color -> Picture - aPic lay offset depth (V2 scalex scaley) col - = setLayer lay - . setDepth depth - . uncurryV translate (offset ep) - . rotate (pi * 0.5 + argV rotd) - . scale scalex scaley - . color col - $ circleSolid 5 - glow = setLayer BloomNoZWrite $ setDepth 0.3 $ uncurryV translate ep - $ circleSolidCol (withAlpha 0 orange) (withAlpha 0.02 orange) 50 + aPic lay offset depth (V2 scalex scaley) col = + setLayer lay + . setDepth depth + . uncurryV translate (offset ep) + . rotate (pi * 0.5 + argV rotd) + . scale scalex scaley + . color col + $ circleSolid 5 + glow = + setLayer BloomNoZWrite $ + setDepth 0.3 $ + uncurryV translate ep $ + circleSolidCol (withAlpha 0 orange) (withAlpha 0.02 orange) 50 time = _flTimer pt - scaleChange + scaleChange | time < 80 = 3 | otherwise = 3 - (fromIntegral time - 80) * 0.2 - prot p' = p' +.+ rotateV (fromIntegral time) (V2 0 1) + prot p' = p' +.+ rotateV (fromIntegral time) (V2 0 1) prot2 p' = p' +.+ rotateV (negate $ fromIntegral time) (V2 0 1) prot3 p' = p' +.+ rotateV (2 + fromIntegral time * 0.1) (V2 0 2) diff --git a/src/Dodge/Flare.hs b/src/Dodge/Flare.hs index 1187f949f..83c8a736a 100644 --- a/src/Dodge/Flare.hs +++ b/src/Dodge/Flare.hs @@ -1,17 +1,18 @@ module Dodge.Flare where + import Dodge.Data.Flare import LensHelp import Picture updateFlare :: Flare -> Maybe Flare -updateFlare rb - | _flareTime rb <= 0 = Nothing - | otherwise = Just $ rb & flareTime -~ 1 +updateFlare rb + | _flareTime rb <= 0 = Nothing + | otherwise = Just $ rb & flareTime -~ 1 drawFlare :: Flare -> Picture drawFlare fl = case fl of - MuzFlare {} -> drawMuzFlare fl - CircFlare {} -> drawCircFlare fl + MuzFlare{} -> drawMuzFlare fl + CircFlare{} -> drawCircFlare fl drawMuzFlare :: Flare -> Picture drawMuzFlare pt = setLayer BloomNoZWrite . translate3 tranv $ theShape @@ -22,8 +23,9 @@ drawMuzFlare pt = setLayer BloomNoZWrite . translate3 tranv $ theShape theShape = color col $ polygon poly drawCircFlare :: Flare -> Picture -drawCircFlare pt = setLayer BloomNoZWrite . translate3 tranv - $ circleSolidCol (withAlpha 0 0) (withAlpha alphax col) 50 +drawCircFlare pt = + setLayer BloomNoZWrite . translate3 tranv $ + circleSolidCol (withAlpha 0 0) (withAlpha alphax col) 50 where col = _flareColor pt tranv = _flareTran3 pt diff --git a/src/Dodge/FloatFunction.hs b/src/Dodge/FloatFunction.hs index ff258d87c..21c9cc256 100644 --- a/src/Dodge/FloatFunction.hs +++ b/src/Dodge/FloatFunction.hs @@ -1,16 +1,17 @@ module Dodge.FloatFunction where + import Dodge.Data.FloatFunction doFloatFloat :: FloatFloat -> Float -> Float doFloatFloat ff x = case ff of FloatID -> x FloatConst y -> y - FloatFOV a - | abs x < 0.5 * a -> 1 - | otherwise -> 0 - FloatLessCheck y - | x > y -> 0 + FloatFOV a + | abs x < 0.5 * a -> 1 + | otherwise -> 0 + FloatLessCheck y + | x > y -> 0 | otherwise -> 1 - FloatAbsCheckGreaterLess a y1 y2 + FloatAbsCheckGreaterLess a y1 y2 | abs x > a -> y1 | otherwise -> y2 diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 86fba055f..4869c32e7 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -1,121 +1,105 @@ ---{-# LANGUAGE TupleSections #-} ---{-# OPTIONS_GHC -Wno-unused-imports #-} -{- | The tree of rooms that make up a level. -} -module Dodge.Floor --- ( initialRoomTree --- ) - where -import Dodge.Cleat ---import Geometry.Data ---import Dodge.Data -import Dodge.LockAndKey ---import Dodge.Creature.State.Data -import Dodge.Room ---import Dodge.Data.DamageType ---import Dodge.Placement.Instance.Button -import Dodge.Tree -import Dodge.PlacementSpot -import Dodge.Annotation ---import Dodge.Placement.Instance.Sensor -import Dodge.Creature -import Dodge.Room.Warning ---import Dodge.LevelGen.Data -import Dodge.Data ---import Dodge.LevelGen.Switch ---import Dodge.Item.Weapon.Launcher ---import Dodge.PlacementSpot ---import Dodge.RoomPos ---import Dodge.Room.RunPast ---import MonadHelp -import LensHelp -import RandomHelp ---import Color ---import Dodge.Wire +-- | The tree of rooms that make up a level. +module Dodge.Floor ( + initialRoomTree, +) where import Data.List (intersperse) ---import Data.Sequence hiding (zipWith) ---import Data.Maybe ---import qualified IntMapHelp as IM +import Dodge.Annotation +import Dodge.Cleat +import Dodge.Creature +import Dodge.Data.GenWorld +import Dodge.LockAndKey +import Dodge.PlacementSpot +import Dodge.Room +import Dodge.Tree +import LensHelp +import RandomHelp initialAnoTree :: Annotation -initialAnoTree = OnwardList - $ intersperse (AnTree corDoor) - [ IntAnno $ AnTree . startRoom --- , AnRoom $ tanksRoom [] [] <&> rmPmnts .~ [] --- , AnRoom $ tanksRoom [] [] --- , AnRoom $ roomCCrits 0 --- , AnRoom $ return airlock0 - , AnRoom slowDoorRoom --- , AnRoom $ roomCCrits 10 --- , AnTree firstBreather --- , AnTree $ telRoomLev 1 >>= rToOnward "telRoomLev" . pure . cleatOnward --- ] --- ---extraAnoList :: [Annotation] ---extraAnoList = ----- , (SpecificRoom . return . tToBTree $ treePost [corridor,corridor,cleatOnward corridor]) --- [ AnRoom $ roomCCrits 10 --- , AnRoom $ roomCCrits 10 --- , AnTree $ tToBTree "spawners" <$> spawnerRoom --- , AnRoom pistolerRoom --- , AnRoom doubleCorridorBarrels - , IntAnno $ PassthroughLockKeyLists - [(sensorRoomRunPast ELECTRICAL, takeOne [CRAFT STATICMODULE,HELD SPARKGUN] )] itemRooms - , IntAnno $ PassthroughLockKeyLists keyCardRunPastRand itemRooms - , IntAnno $ AnTree . warningRooms "INVISIBLE CREATURE AHEAD" - , AnTree $ rToOnward "chaseCrit+armourChaseCrit rectRoom" - $ return . cleatOnward $ roomRectAutoLinks 400 400 & rmPmnts .++~ - [ spNoID anyUnusedSpot (PutCrit invisibleChaseCrit) - , spNoID anyUnusedSpot (PutCrit armourChaseCrit) +initialAnoTree = + OnwardList $ + intersperse + (AnTree corDoor) + [ IntAnno $ AnTree . startRoom + , -- , AnRoom $ tanksRoom [] [] <&> rmPmnts .~ [] + -- , AnRoom $ tanksRoom [] [] + -- , AnRoom $ roomCCrits 0 + -- , AnRoom $ return airlock0 + AnRoom slowDoorRoom + , -- , AnRoom $ roomCCrits 10 + -- , AnTree firstBreather + -- , AnTree $ telRoomLev 1 >>= rToOnward "telRoomLev" . pure . cleatOnward + -- ] + -- + --extraAnoList :: [Annotation] + --extraAnoList = + ---- , (SpecificRoom . return . tToBTree $ treePost [corridor,corridor,cleatOnward corridor]) + -- [ AnRoom $ roomCCrits 10 + -- , AnRoom $ roomCCrits 10 + -- , AnTree $ tToBTree "spawners" <$> spawnerRoom + -- , AnRoom pistolerRoom + -- , AnRoom doubleCorridorBarrels + IntAnno $ + PassthroughLockKeyLists + [(sensorRoomRunPast ELECTRICAL, takeOne [CRAFT STATICMODULE, HELD SPARKGUN])] + itemRooms + , IntAnno $ PassthroughLockKeyLists keyCardRunPastRand itemRooms + , IntAnno $ AnTree . warningRooms "INVISIBLE CREATURE AHEAD" + , AnTree $ + rToOnward "chaseCrit+armourChaseCrit rectRoom" $ + return . cleatOnward $ + roomRectAutoLinks 400 400 & rmPmnts + .++~ [ spNoID anyUnusedSpot (PutCrit invisibleChaseCrit) + , spNoID anyUnusedSpot (PutCrit armourChaseCrit) + ] + , IntAnno $ AnTree . fmap (tToBTree "healthTest") . healthTest + , AnTree (tanksRoom [] [] >>= rToOnward "empty tanksRoom" . pure . cleatOnward) + , IntAnno $ PassthroughLockKeyLists lockRoomKeyItems itemRooms + , AnTree randomChallenges + , IntAnno $ AnTree . lasSensorTurretTest + , -- ,[AnTree $ fmap pure roomCCrits] + -- ,[AirlockAno] + -- ,[Corridor] + ------ ,[AnTree roomCCrits] + ------ ,[Corridor] + ------ ,[AnTree . pure . pure . useAll $ roomGlassOctogon 400 + ------ & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit armourChaseCrit + ------ ,sPS (V2 50 25) 0 $ PutCrit armourChaseCrit + ------ ,sPS (V2 50 0) 0 $ PutCrit armourChaseCrit + ------ ]++) + ------ ] + ------ --,[AnTree . pure . pure . useAll $ roomGlassOctogon 400 + ------ -- & rmPS %~ ([swarmPS 0 (x,y) 0 swarmCrit | x <- [-20,-19.5.. 20] , y <- [200,202] ]++) + ------ -- ] + ------ ,[AnTree . pure . pure . useAll $ roomGlassOctogon 400 + ------ & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit pistolCrit ]++) + ------ ] + ------ ,[Corridor] + ---- --,[AnTree $ pure . useAll <$> twinSlowDoorChasers] + ----- ,[AnTree $ pure $ (pure . useAll) (twinSlowDoorRoom 80 200 40)] + ----- ,[DoorAno] + ----- ,[AnTree $ pure . useAll <$> centerVaultExplosiveExit] + ----- ,[AnTree blockedCorridor] + ----- ,[OrAno [[DoorAno] + ----- ,[Corridor] + ----- ,[DoorNumAno 0,AirlockAno]] + ----- ] + ----- ,[FirstWeapon] + ----- ,[CorridorDebug] + ----- ,[AnTree $ fmap (pure . useAll) randomFourCornerRoom] + -- ,[OrAno + -- [[AnTree $ branchRectWith $ fmap (fmap ) armouredChasers] + -- ,[BossAno $ addArmour launcherCrit & crHP +~ 800 + -- & crState . crDropsOnDeath .~ DropSpecific [0] ] + -- ] + -- ] + ---- ,[AnTree $ fmap (pure . useAll) armouredCorridor] + -- ,[Corridor] + -- ,[TreasureAno [addArmour autoCrit,addArmour autoCrit] [launcher]] + -- ,[Corridor] + AnTree $ randomFourCornerRoom [] >>= rToOnward "randomFourCornerRoom" . pure . cleatOnward ] - , IntAnno $ AnTree . fmap (tToBTree "healthTest") . healthTest - , AnTree (tanksRoom [] [] >>= rToOnward "empty tanksRoom" . pure . cleatOnward) - , IntAnno $ PassthroughLockKeyLists lockRoomKeyItems itemRooms - , AnTree randomChallenges - , IntAnno $ AnTree . lasSensorTurretTest --- ,[AnTree $ fmap pure roomCCrits] --- ,[AirlockAno] --- ,[Corridor] ------- ,[AnTree roomCCrits] ------- ,[Corridor] ------- ,[AnTree . pure . pure . useAll $ roomGlassOctogon 400 ------- & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit armourChaseCrit ------- ,sPS (V2 50 25) 0 $ PutCrit armourChaseCrit ------- ,sPS (V2 50 0) 0 $ PutCrit armourChaseCrit ------- ]++) ------- ] ------- --,[AnTree . pure . pure . useAll $ roomGlassOctogon 400 ------- -- & rmPS %~ ([swarmPS 0 (x,y) 0 swarmCrit | x <- [-20,-19.5.. 20] , y <- [200,202] ]++) ------- -- ] ------- ,[AnTree . pure . pure . useAll $ roomGlassOctogon 400 ------- & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit pistolCrit ]++) ------- ] ------- ,[Corridor] ----- --,[AnTree $ pure . useAll <$> twinSlowDoorChasers] ------ ,[AnTree $ pure $ (pure . useAll) (twinSlowDoorRoom 80 200 40)] ------ ,[DoorAno] ------ ,[AnTree $ pure . useAll <$> centerVaultExplosiveExit] ------ ,[AnTree blockedCorridor] ------ ,[OrAno [[DoorAno] ------ ,[Corridor] ------ ,[DoorNumAno 0,AirlockAno]] ------ ] ------ ,[FirstWeapon] ------ ,[CorridorDebug] ------ ,[AnTree $ fmap (pure . useAll) randomFourCornerRoom] --- ,[OrAno --- [[AnTree $ branchRectWith $ fmap (fmap ) armouredChasers] --- ,[BossAno $ addArmour launcherCrit & crHP +~ 800 --- & crState . crDropsOnDeath .~ DropSpecific [0] ] --- ] --- ] ----- ,[AnTree $ fmap (pure . useAll) armouredCorridor] --- ,[Corridor] --- ,[TreasureAno [addArmour autoCrit,addArmour autoCrit] [launcher]] --- ,[Corridor] - ,AnTree $ randomFourCornerRoom [] >>= rToOnward "randomFourCornerRoom" . pure . cleatOnward - ] -{- | A test level tree. -} -initialRoomTree :: State (StdGen,Int) (MetaTree Room String) +-- | A test level tree. +initialRoomTree :: State (StdGen, Int) (MetaTree Room String) initialRoomTree = annoToRoomTree initialAnoTree diff --git a/src/Dodge/FloorItem.hs b/src/Dodge/FloorItem.hs index ab2d223b1..31c7a9ae3 100644 --- a/src/Dodge/FloorItem.hs +++ b/src/Dodge/FloorItem.hs @@ -1,50 +1,58 @@ -module Dodge.FloorItem - ( copyItemToFloor - , copyItemToFloorID - ) where -import Dodge.Data -import Dodge.Base -import Geometry -import qualified IntMapHelp as IM +module Dodge.FloorItem ( + copyItemToFloor, + copyItemToFloorID, +) where import Control.Lens -import System.Random import Data.Maybe +import Dodge.Base +import Dodge.Data.World +import Geometry +import qualified IntMapHelp as IM +import System.Random -{- | Copy an item to the floor. -} +-- | Copy an item to the floor. copyItemToFloor :: Point2 -> Item -> World -> World copyItemToFloor pos it = snd . copyItemToFloorID pos it -{- | Copy an item to the floor, returns the floor item's id. -} +-- | Copy an item to the floor, returns the floor item's id. copyItemToFloorID :: Point2 -> Item -> World -> (Int, World) -copyItemToFloorID pos it w = (,) flid $ w' - & cWorld . floorItems %~ IM.insert flid theflit - & updateLocation +copyItemToFloorID pos it w = + (,) flid $ + w' + & cWorld . floorItems %~ IM.insert flid theflit + & updateLocation where - (p',w') = findWallFreeDropPoint (_dimRad $ _itDimension it) pos w - rot = fst . randomR (-pi,pi) $ _randGen w + (p', w') = findWallFreeDropPoint (_dimRad $ _itDimension it) pos w + rot = fst . randomR (- pi, pi) $ _randGen w updateLocation = case it ^? itID of - Just (Just i') -> cWorld . itemLocations . ix i' .~ OnFloor flid + Just (Just i') -> cWorld . itemLocations . ix i' .~ OnFloor flid _ -> id flid = IM.newKey $ _floorItems (_cWorld w) - theflit = FlIt - {_flIt = it & itUse . useAmount %~ const 1 - ,_flItPos = p' - ,_flItRot = rot - ,_flItID = flid - } + theflit = + FlIt + { _flIt = it & itUse . useAmount %~ const 1 + , _flItPos = p' + , _flItRot = rot + , _flItID = flid + } + cardinalVectors :: [Point2] cardinalVectors = - [ V2 1 0 - , V2 0 1 - , V2 (-1) 0 - , V2 0 (-1) + [ V2 1 0 + , V2 0 1 + , V2 (-1) 0 + , V2 0 (-1) ] -findWallFreeDropPoint :: Float -> Point2 -> World -> (Point2,World) -findWallFreeDropPoint r p w = (head $ mapMaybe f cardinalVectors ++ [p] - , w {_randGen = g}) + +findWallFreeDropPoint :: Float -> Point2 -> World -> (Point2, World) +findWallFreeDropPoint r p w = + ( head $ mapMaybe f cardinalVectors ++ [p] + , w{_randGen = g} + ) where f q = testOnWall r $ p +.+ rotateV rot (10 *.* q) - testOnWall r' q | circOnSomeWall q r' w = Nothing + testOnWall r' q + | circOnSomeWall q r' w = Nothing | otherwise = Just q - (rot, g) = randomR (0,2*pi) $ _randGen w + (rot, g) = randomR (0, 2 * pi) $ _randGen w diff --git a/src/Dodge/ForceField.hs b/src/Dodge/ForceField.hs new file mode 100644 index 000000000..7ec2e8ef7 --- /dev/null +++ b/src/Dodge/ForceField.hs @@ -0,0 +1,8 @@ +module Dodge.ForceField + where +import Dodge.Wall.ForceField +import Dodge.Data.Wall +import Dodge.Data.Item.Use.Consumption.Ammo + +createForceField :: ForceFieldType -> Wall +createForceField DefaultForceField = forceField diff --git a/src/Dodge/Gas.hs b/src/Dodge/Gas.hs index 6adb163c9..50129902c 100644 --- a/src/Dodge/Gas.hs +++ b/src/Dodge/Gas.hs @@ -1,8 +1,9 @@ module Dodge.Gas where -import Dodge.Data -import Geometry + +import Dodge.Data.World import Dodge.Flame import Dodge.WorldEvent +import Geometry createGas :: GasCreate -> Float -> Point2 -> Float -> Creature -> World -> World createGas gc = case gc of @@ -10,12 +11,14 @@ createGas gc = case gc of CreateFlame -> aFlame aGasCloud :: Float -> Point2 -> Float -> Creature -> World -> World -aGasCloud pressure pos dir cr = makeGasCloud pos - $ (_crPos cr -.- _crOldPos cr) +.+ pressure *.* unitVectorAtAngle dir +aGasCloud pressure pos dir cr = + makeGasCloud pos $ + (_crPos cr -.- _crOldPos cr) +.+ pressure *.* unitVectorAtAngle dir aFlame :: Float -> Point2 -> Float -> Creature -> World -> World aFlame pressure pos dir cr = makeFlame pos vel + where --w & instantParticles .:~ aFlameParticle t pos vel Nothing -- (Just $ _crID cr) - where --- (t,_) = randomR (99,101) (_randGen w) + + -- (t,_) = randomR (99,101) (_randGen w) vel = (_crPos cr -.- _crOldPos cr) +.+ pressure *.* unitVectorAtAngle dir diff --git a/src/Dodge/Hammer.hs b/src/Dodge/Hammer.hs index 21ead8931..100aa6155 100644 --- a/src/Dodge/Hammer.hs +++ b/src/Dodge/Hammer.hs @@ -1,7 +1,7 @@ module Dodge.Hammer where + import Dodge.Data.Hammer moveHammerUp :: HammerPosition -> HammerPosition -moveHammerUp HammerDown = HammerReleased -moveHammerUp _ = HammerUp - +moveHammerUp HammerDown = HammerReleased +moveHammerUp _ = HammerUp diff --git a/src/Dodge/HeldScroll.hs b/src/Dodge/HeldScroll.hs index b64075def..f0e773683 100644 --- a/src/Dodge/HeldScroll.hs +++ b/src/Dodge/HeldScroll.hs @@ -1,24 +1,26 @@ -module Dodge.HeldScroll - ( doHeldScroll - ) where -import Dodge.Data -import Dodge.Item.Weapon.ZoomScope -import Control.Lens hiding ((|>),(<|)) +module Dodge.HeldScroll ( + doHeldScroll, +) where + +import Control.Lens hiding ((<|), (|>)) import Data.Sequence +import Dodge.Data.Creature +import Dodge.Item.Weapon.ZoomScope +-- should be able to just import data.item doHeldScroll :: HeldScroll -> Float -> Creature -> Item -> Item doHeldScroll hs = case hs of HeldScrollDoNothing -> const . const id HeldScrollZoom -> zoomLongGun - HeldScrollCharMode {} -> \ x _ -> itUse . heldScroll . hsCharMode %~ cycleSignum x - HeldScrollInt {} -> undefined + HeldScrollCharMode{} -> \x _ -> itUse . heldScroll . hsCharMode %~ cycleSignum x + HeldScrollInt{} -> undefined cycleSignum :: Float -> Seq a -> Seq a cycleSignum x | x > 0 = cycleL | otherwise = cycleR -cycleL,cycleR :: Seq a -> Seq a +cycleL, cycleR :: Seq a -> Seq a cycleL (x :<| xs) = xs |> x cycleL xs = xs cycleR (xs :|> x) = x <| xs diff --git a/src/Dodge/HeldUse.hs b/src/Dodge/HeldUse.hs index 80792240a..159b0d42a 100644 --- a/src/Dodge/HeldUse.hs +++ b/src/Dodge/HeldUse.hs @@ -1,41 +1,41 @@ module Dodge.HeldUse where -import Dodge.Data + +import Color +import Data.Maybe +import Data.Traversable import Dodge.Base.Coordinate -import Sound.Data import Dodge.Bullet +import Dodge.Data.World +import Dodge.Gas +import Dodge.Item.Location +import Dodge.Item.Weapon.BatteryGuns +import Dodge.Item.Weapon.Launcher +import Dodge.Item.Weapon.Radar +import Dodge.Item.Weapon.Shatter import Dodge.Item.Weapon.TriggerType +import Dodge.Item.Weapon.Utility +import Dodge.Projectile.Create import Dodge.SoundLogic import Dodge.WorldEvent.Flash -import Dodge.Item.Location -import Dodge.Item.Weapon.Radar -import Dodge.Item.Weapon.BatteryGuns -import Dodge.Item.Weapon.Utility -import Dodge.Item.Weapon.Shatter -import Dodge.Item.Weapon.Launcher -import Dodge.Projectile.Create -import Dodge.Gas import Geometry import qualified IntMapHelp as IM import LensHelp import RandomHelp -import Color - -import Data.Maybe -import Data.Traversable +import Sound.Data useMod :: HeldMod -> [(Item -> Creature -> World -> World) -> Item -> Creature -> World -> World] useMod hm = case hm of HeldModNothing -> [] - PoisonSprayerMod -> + PoisonSprayerMod -> [ ammoCheckI , withSoundForI foamSprayLoopS 5 , useAmmoAmount 1 - ] + ] FlameSpitterMod -> [ ammoCheckI , useTimeCheck , lockInvFor 10 - , repeatOnFrames [1..9] FlameSpitterRepeatMod + , repeatOnFrames [1 .. 9] FlameSpitterRepeatMod , withRandomItemParams f , useAmmoAmount 1 , withSidePushI 5 @@ -52,8 +52,8 @@ useMod hm = case hm of [ ammoCheckI , useAmmoAmount 1 , withSidePushI 5 - --, withTempLight 1 100 (V3 1 0 0) - , withSidePushAfterI 20 + , --, withTempLight 1 100 (V3 1 0 0) + withSidePushAfterI 20 ] LauncherMod -> [ hammerCheckI @@ -89,8 +89,8 @@ useMod hm = case hm of ] DualBeamMod -> [ ammoCheckI - , withItem $ \it -> withMuzPosShift (V2 0 (thegapDualBeam it)) $ flareCircleAt (_lasColor $ _itParams it) 0.8 - , withItem $ \it -> withMuzPosShift (V2 0 (-thegapDualBeam it)) $ flareCircleAt (_lasColor2 $ _itParams it) 0.8 + , withItem $ \it -> withMuzPosShift (V2 0 (thegapDualBeam it)) $ flareCircleAt (_lasColor $ _itParams it) 0.8 + , withItem $ \it -> withMuzPosShift (V2 0 (- thegapDualBeam it)) $ flareCircleAt (_lasColor2 $ _itParams it) 0.8 , withSoundForI tone440sawtoothquietS 2 , useAmmoAmount 1 ] @@ -112,11 +112,11 @@ useMod hm = case hm of ShatterMod -> [ ammoHammerCheck , useTimeCheck --- , withSoundStart tap3S - , useAmmoAmount 1 + , -- , withSoundStart tap3S + useAmmoAmount 1 ] - AmmoCheckMod -> [ ammoCheckI ] - AmmoUseCheckMod -> [ ammoUseCheck ] + AmmoCheckMod -> [ammoCheckI] + AmmoUseCheckMod -> [ammoUseCheck] AmmoHammerTimeUseOneMod -> [ ammoHammerCheck , useTimeCheck @@ -144,7 +144,8 @@ useMod hm = case hm of , withMuzFlareI , withRecoil ] - AutoRifleMod -> -- note this is the same as BangCanemMod with the first changed + AutoRifleMod -> + -- note this is the same as BangCanemMod with the first changed [ ammoCheckI , useTimeCheck , withSoundStart tap3S @@ -205,14 +206,14 @@ useMod hm = case hm of , withMuzFlareI , withTorqueAfter , spreadLoaded --- , applyInaccuracy - , withRecoil + , -- , applyInaccuracy + withRecoil ] PistolMod -> - [ ammoHammerCheck + [ ammoHammerCheck , useTimeCheck , useAmmoAmount 1 - , withSoundStart tap3S + , withSoundStart tap3S , applyInaccuracy , withTorqueAfter , withRecoil @@ -220,10 +221,10 @@ useMod hm = case hm of , withMuzFlareI ] AutoPistolMod -> - [ ammoCheckI + [ ammoCheckI , useTimeCheck , useAmmoAmount 1 - , withSoundStart tap3S + , withSoundStart tap3S , applyInaccuracy , withTorqueAfter , withRecoil @@ -234,7 +235,7 @@ useMod hm = case hm of [ ammoCheckI , useTimeCheck , useAmmoAmount 1 - , withSoundStart tap1S + , withSoundStart tap1S , applyInaccuracy , withTorqueAfter , withSidePushI 50 @@ -246,7 +247,7 @@ useMod hm = case hm of , useTimeCheck , sideEffectOnFrame 7 (\_ cr -> TorqueCr 0.2 (_crID cr)) --(torqueSideEffect 0.2) , lockInvFor 7 - , repeatOnFrames [3,6] BurstRifleRepeatMod + , repeatOnFrames [3, 6] BurstRifleRepeatMod , withSoundStart tap3S , useAmmoAmount 1 , applyInaccuracy @@ -266,22 +267,22 @@ useMod hm = case hm of [ ammoCheckI , withWarmUp crankSlowS , withSoundForI mini1S 2 - --, withThinSmokeI - , withSmoke 1 black 20 200 5 + , --, withThinSmokeI + withSmoke 1 black 20 200 5 , withMuzFlareI , useAmmoAmount i , withSidePushI (fromIntegral i * 50) , torqueBefore (fromIntegral i * 0.05) , afterRecoil (fromIntegral i * 5) - ] <> - [ trigDoAlso' (moddelay x) (modcrpos x) useAmmoParams - | x <- map ((/fromIntegral i) . fromIntegral) [1..i-1] ] + <> [ trigDoAlso' (moddelay x) (modcrpos x) useAmmoParams + | x <- map ((/ fromIntegral i) . fromIntegral) [1 .. i -1] + ] SmgMod -> [ ammoCheckI , useTimeCheck , useAmmoAmount 1 - , withSoundStart tap3S + , withSoundStart tap3S , applyInaccuracy , withTorqueAfter , withRecoil @@ -291,28 +292,28 @@ useMod hm = case hm of RevolverXMod -> [ ammoHammerCheck , useTimeCheck - -- rather than locking the inventory, a better solution may be to check - -- that the weapon is still in your hands in the repeated frames - , lockInvFor 10 - , repeatOnFrames [2,4,6,8,10] RevolverXRepeatMod - , withSoundStart tap3S + , -- rather than locking the inventory, a better solution may be to check + -- that the weapon is still in your hands in the repeated frames + lockInvFor 10 + , repeatOnFrames [2, 4, 6, 8, 10] RevolverXRepeatMod + , withSoundStart tap3S , useAmmoUpTo 1 , applyInaccuracy , withMuzFlareI --- , spreadLoaded - , withTorqueAfter + , -- , spreadLoaded + withTorqueAfter , withRecoil ] RevolverXRepeatMod -> [ ammoCheckI - -- rather than locking the inventory, a better solution may be to check - -- that the weapon is still in your hands in the repeated frames - , withSoundStart tap3S + , -- rather than locking the inventory, a better solution may be to check + -- that the weapon is still in your hands in the repeated frames + withSoundStart tap3S , useAmmoUpTo 1 , applyInaccuracy , withMuzFlareI --- , spreadLoaded - , withTorqueAfter + , -- , spreadLoaded + withTorqueAfter , withRecoil ] BangConeMod -> @@ -332,26 +333,27 @@ useMod hm = case hm of ] where f = do - nzpres <- state $ randomR (3,4) + nzpres <- state $ randomR (3, 4) return $ sprayNozzles . ix 0 . nzPressure .~ nzpres - increasecycleLasCircle it = it & itParams . lasCycle %~ (flip mod 2000 . (+ 1)) + increasecycleLasCircle it = it & itParams . lasCycle %~ (flip mod 2000 . (+ 1)) --f it = [it & itParams . lasCycle +~ x | x <- [0,100 .. 1900] ] - fLasCircle it = [it & itParams . lasCycle +~ x | x <- [0,50 .. 1999] ] - increasecycleLasWide n it = case _useHammer (_itUse it) of + fLasCircle it = [it & itParams . lasCycle +~ x | x <- [0, 50 .. 1999]] + increasecycleLasWide n it = case _heldHammer (_itUse it) of HammerUp -> it & itParams . lasCycle .~ 1 _ -> it & itParams . lasCycle %~ (min (n * 5) . (+ 1)) - xsLasWide it = [ V2 ((0.2*yoff x) ^ (2::Int)) (yoff x) | x <- [(0::Int)..n'-1] ] + xsLasWide it = [V2 ((0.2 * yoff x) ^ (2 :: Int)) (yoff x) | x <- [(0 :: Int) .. n' -1]] where - yoff x = fromIntegral x - fromIntegral (n'-1) / 2 + yoff x = fromIntegral x - fromIntegral (n' -1) / 2 n' = _lasCycle (_itParams it) thegapDualBeam = _dbGap . _itParams - directedTelPos it cr w = (p,a) + directedTelPos it cr w = (p, a) where p = fromMaybe (_crPos cr) $ it ^? itTargeting . tgPos . _Just a = argV (mouseWorldPos w -.- p) moddelay x = itUse . heldConsumption . laAmmoType . amBullet . buDelayFraction .~ x - modcrpos x cr = cr & crDir %~ tweenAngles x (_crOldDir cr) - & crPos %~ tweenPoints x (_crOldPos cr) + modcrpos x cr = + cr & crDir %~ tweenAngles x (_crOldDir cr) + & crPos %~ tweenPoints x (_crOldPos cr) useHeld :: HeldUse -> Item -> Creature -> World -> World useHeld hu = case hu of @@ -367,7 +369,7 @@ useHeld hu = case hu of HeldCircleLaser -> circleLaser HeldDualLaser -> shootDualLaser HeldTractor -> aTractorBeam --- HeldSonicWave -> aSonicWave + -- HeldSonicWave -> aSonicWave HeldForceField -> useForceFieldGun HeldShatter -> shootShatter HeldExplodeRemoteShell itid pjid -> const $ const $ explodeRemoteRocket itid pjid @@ -376,77 +378,105 @@ usePjCreation :: Item -> Creature -> World -> World usePjCreation it = createProjectile (_amPjCreation (_laAmmoType (_heldConsumption (_itUse it)))) it usePjCreationX :: Int -> Item -> Creature -> World -> World -usePjCreationX i it cr = foldr f - (createProjectile (_amPjCreation (_laAmmoType (_heldConsumption (_itUse it)))) it cr) - [1..i-1] +usePjCreationX i it cr = + foldr + f + (createProjectile (_amPjCreation (_laAmmoType (_heldConsumption (_itUse it)))) it cr) + [1 .. i -1] where - f n = (. createProjectile (_amPjCreation (_laAmmoType (_heldConsumption (_itUse it)))) it (cr & crDir +~ (2*pi*fromIntegral n / fromIntegral i))) + f n = (. createProjectile (_amPjCreation (_laAmmoType (_heldConsumption (_itUse it)))) it (cr & crDir +~ (2 * pi * fromIntegral n / fromIntegral i))) -overNozzles :: (Nozzle -> Item -> Creature -> World -> World) - -> Item -> Creature -> World -> World +overNozzles :: + (Nozzle -> Item -> Creature -> World -> World) -> + Item -> + Creature -> + World -> + World overNozzles = overNozzles' . overNozzle -overNozzles' :: (Item -> Creature -> World -> Nozzle -> (World,Nozzle)) - -> Item -> Creature -> World -> World +overNozzles' :: + (Item -> Creature -> World -> Nozzle -> (World, Nozzle)) -> + Item -> + Creature -> + World -> + World overNozzles' eff it cr w = neww & cWorld . creatures . ix cid . crInv . ix i . itParams . sprayNozzles .~ newNozzles where cid = _crID cr i = crSel $ _creatures (_cWorld w) IM.! cid - (neww,newNozzles) = mapAccumR (eff it cr) w $ _sprayNozzles (_itParams it) + (neww, newNozzles) = mapAccumR (eff it cr) w $ _sprayNozzles (_itParams it) -overNozzle :: (Nozzle -> Item -> Creature -> World -> World) - -> Item -> Creature -> World -> Nozzle -> (World, Nozzle) -overNozzle eff it cr w nz = +overNozzle :: + (Nozzle -> Item -> Creature -> World -> World) -> + Item -> + Creature -> + World -> + Nozzle -> + (World, Nozzle) +overNozzle eff it cr w nz = ( eff nz it (cr & crDir +~ wa + na) w & randGen .~ g - , nz & nzCurrentWalkAngle .~ wa) + , nz & nzCurrentWalkAngle .~ wa + ) where na = _nzDir nz - (walkamount, g) = randomR (-aspeed,aspeed) (_randGen w) + (walkamount, g) = randomR (- aspeed, aspeed) (_randGen w) aspeed = _nzWalkSpeed nz maxa = _nzMaxWalkAngle nz wa = min maxa $ max (negate maxa) (_nzCurrentWalkAngle nz + walkamount) useGasParams :: Nozzle -> Item -> Creature -> World -> World -useGasParams nz it cr = createGas (_amCreateGas (_laAmmoType (_heldConsumption (_itUse it)))) - (_nzPressure nz) pos dir cr - where +useGasParams nz it cr = + createGas + (_amCreateGas (_laAmmoType (_heldConsumption (_itUse it)))) + (_nzPressure nz) + pos + dir + cr + where dir = _crDir cr pos = _crPos cr +.+ (_nzLength nz *.* unitVectorAtAngle (_crDir cr)) fireRemoteShell :: Item -> Creature -> World -> World -fireRemoteShell it cr w = set (cWorld . creatures . ix cid . crInv . ix j . itUse . rUse) +fireRemoteShell it cr w = + set + (cWorld . creatures . ix cid . crInv . ix j . itUse . heldUse) (HeldExplodeRemoteShell itid i) - $ addRemRocket w' + $ addRemRocket w' where - (w',itid) = getHeldItemLoc cr w - i = IM.newKey $ _props (_cWorld w) + (w', itid) = getHeldItemLoc cr w + i = IM.newKey $ _props (_cWorld w) cid = _crID cr - addRemRocket = makeShell it cr - [ PJSetScope itid - , PJThrust 330 0 - , PJRemoteDirection 340 0 cid itid - ] + addRemRocket = + makeShell + it + cr + [ PJSetScope itid + , PJThrust 330 0 + , PJRemoteDirection 340 0 cid itid + ] j = crSel cr caneStickSoundChoice :: Item -> SoundID caneStickSoundChoice it - | _laLoaded (_heldConsumption (_itUse it)) < 2 = tap3S + | _laLoaded (_heldConsumption (_itUse it)) < 2 = tap3S | otherwise = shotgunS bangStickSoundChoice :: Item -> SoundID bangStickSoundChoice it - | _laLoaded (_heldConsumption (_itUse it)) < 2 = tap3S + | _laLoaded (_heldConsumption (_itUse it)) < 2 = tap3S | otherwise = shotgunS coneRandItemUpdate :: State StdGen (Item -> Item) coneRandItemUpdate = do - wth <- state $ randomR (1,5) + wth <- state $ randomR (1, 5) return (itUse . heldConsumption . laAmmoType . amBullet . buWidth .~ wth) + coneRandItemParams :: State StdGen (ItemParams -> ItemParams) coneRandItemParams = do - muzv <- state $ randomR (0.5,1) - rifl <- state $ randomR (0.3,0.9) - return $ \itparams -> itparams - { _muzVel = muzv - , _rifling = rifl - } + muzv <- state $ randomR (0.5, 1) + rifl <- state $ randomR (0.3, 0.9) + return $ \itparams -> + itparams + { _muzVel = muzv + , _rifling = rifl + } diff --git a/src/Dodge/Humanoid.hs b/src/Dodge/Humanoid.hs index 95e5b659e..faa6af17d 100644 --- a/src/Dodge/Humanoid.hs +++ b/src/Dodge/Humanoid.hs @@ -1,251 +1,283 @@ module Dodge.Humanoid where -import Dodge.Data -import Dodge.Creature.Boid -import Dodge.Creature.YourControl -import Dodge.Creature.State -import Dodge.Creature.Impulse -import Dodge.Creature.ChainUpdates -import Dodge.Creature.Test -import Dodge.Creature.Volition -import LensHelp -import Dodge.Creature.ReaderUpdate -import Dodge.Creature.Action -import Dodge.Creature.Perception -import Dodge.Creature.Strategy -import Dodge.Creature.SentinelAI -import qualified IntMapHelp as IM -import Geometry -import RandomHelp import Data.Maybe +import Dodge.Creature.Action +import Dodge.Creature +import Dodge.Data.CreatureEffect +import Dodge.Data.World +import Geometry +import qualified IntMapHelp as IM +import LensHelp +import RandomHelp updateHumanoid :: Creature -> World -> World updateHumanoid cr = case cr ^?! crType . humanoidAI of - ChaseAI -> defaultImpulsive - [ const doStrategyActions - , performActions - , const overrideMeleeCloseTarget - , const setViewPos - , setMvPos - , chaseCritMv - , chaseCritPerceptionUpdate [0] - , targetYouWhenCognizant - , const searchIfDamaged - , const (crMeleeCooldown %~ max 0 . subtract 1) - ] cr - SpreadGunAI -> defaultImpulsive - [performActions - ,watchUpdateStrat - [ (crHasTargetLOS, \_ _ -> StrategyActions (ShootAt 0) - [DoActionIf (WdCrNegate $ WdCrBlfromCrBl CrIsAiming) drawWeapon - ,DoActionThen - (DoActionWhile WdCrLOSTarget $ ArbitraryAction ChooseMovementSpreadGun) - (DoImpulses [ChangeStrategy WatchAndWait]) - ] - ) - , (const crAwayFromPost, const goToPostStrat) - ] - ,perceptionUpdate [0] - ,const doStrategyActions - ,const reloadOverride - ,targetYouWhenCognizant - ,const $ overrideInternal - (\cr' -> crHasTarget cr' && crStratConMatches (GetTo (V2 0 0)) cr') - (\cr' -> cr' & crActionPlan . apStrategy .~ WatchAndWait) - ] cr - PistolAI -> defaultImpulsive - [ performActions - , watchUpdateStrat - [ (crHasTargetLOS, \w cr' -> StrategyActions (ShootAt 0) - [DoActionIf (WdCrNegate $ WdCrBlfromCrBl CrIsAiming) drawWeapon,chooseMovementPistol cr' w]) - , (const crAwayFromPost, const goToPostStrat) - ] - , perceptionUpdate [0] - , const doStrategyActions - , const reloadOverride - , targetYouWhenCognizant - , const $ overrideInternal - (\cr' -> crHasTarget cr' && crStratConMatches (GetTo (V2 0 0)) cr') - (crActionPlan . apStrategy .~ WatchAndWait) - ] cr - LtAutoAI -> defaultImpulsive - [ performActions - , watchUpdateStrat - [ (crHasTargetLOS, \_ _ -> StrategyActions (ShootAt 0) - [DoActionIf (WdCrNegate $ WdCrBlfromCrBl CrIsAiming) drawWeapon - ,DoActionThen - (DoActionWhile WdCrLOSTarget $ ArbitraryAction ChooseMovementLtAuto) - (DoImpulses [ChangeStrategy WatchAndWait]) + ChaseAI -> + defaultImpulsive + [ const doStrategyActions + , performActions + , const overrideMeleeCloseTarget + , const setViewPos + , setMvPos + , chaseCritMv + , chaseCritPerceptionUpdate [0] + , targetYouWhenCognizant + , const searchIfDamaged + , const (crMeleeCooldown %~ max 0 . subtract 1) + ] + cr + SpreadGunAI -> + defaultImpulsive + [ performActions + , watchUpdateStrat + [ + ( crHasTargetLOS + , \_ _ -> + StrategyActions + (ShootAt 0) + [ DoActionIf (WdCrNegate $ WdCrBlfromCrBl CrIsAiming) drawWeapon + , DoActionThen + (DoActionWhile WdCrLOSTarget $ ArbitraryAction ChooseMovementSpreadGun) + (DoImpulses [ChangeStrategy WatchAndWait]) + ] + ) + , (const crAwayFromPost, const goToPostStrat) ] - ) - , (const crAwayFromPost, const goToPostStrat) + , perceptionUpdate [0] + , const doStrategyActions + , const reloadOverride + , targetYouWhenCognizant + , const $ + overrideInternal + (\cr' -> crHasTarget cr' && crStratConMatches (GetTo (V2 0 0)) cr') + (\cr' -> cr' & crActionPlan . apStrategy .~ WatchAndWait) ] - , perceptionUpdate [0] - , const doStrategyActions - , const reloadOverride - , targetYouWhenCognizant - , const $ overrideInternal - (\cr' -> crHasTarget cr' && crStratConMatches (GetTo (V2 0 0)) cr') - (crActionPlan . apStrategy .~ WatchAndWait) - ] cr - LauncherAI -> defaultImpulsive - [ performActions - , watchUpdateStrat - [ (crHasTargetLOS, \_ _ -> StrategyActions (ShootAt 0) [retreatFireLauncher]) - , (const crAwayFromPost, const goToPostStrat) + cr + PistolAI -> + defaultImpulsive + [ performActions + , watchUpdateStrat + [ + ( crHasTargetLOS + , \w cr' -> + StrategyActions + (ShootAt 0) + [DoActionIf (WdCrNegate $ WdCrBlfromCrBl CrIsAiming) drawWeapon, chooseMovementPistol cr' w] + ) + , (const crAwayFromPost, const goToPostStrat) + ] + , perceptionUpdate [0] + , const doStrategyActions + , const reloadOverride + , targetYouWhenCognizant + , const $ + overrideInternal + (\cr' -> crHasTarget cr' && crStratConMatches (GetTo (V2 0 0)) cr') + (crActionPlan . apStrategy .~ WatchAndWait) ] - , perceptionUpdate [0] - , const doStrategyActions - , const reloadOverride - , targetYouWhenCognizant - , const $ overrideInternal - (\cr' -> crHasTarget cr' && crStratConMatches (GetTo (V2 0 0)) cr') - (crActionPlan . apStrategy .~ WatchAndWait) - ] cr - SwarmAI -> defaultImpulsive - [ flockToPointUsing' (encircleDistP 100) (meleeHeadingMove 0.1 0.1 (pi/4) 3.9) - , const (crMeleeCooldown %~ max 0 . subtract 1) - , perceptionUpdate [0] - , const doStrategyActions - , targetYouWhenCognizant - ] cr + cr + LtAutoAI -> + defaultImpulsive + [ performActions + , watchUpdateStrat + [ + ( crHasTargetLOS + , \_ _ -> + StrategyActions + (ShootAt 0) + [ DoActionIf (WdCrNegate $ WdCrBlfromCrBl CrIsAiming) drawWeapon + , DoActionThen + (DoActionWhile WdCrLOSTarget $ ArbitraryAction ChooseMovementLtAuto) + (DoImpulses [ChangeStrategy WatchAndWait]) + ] + ) + , (const crAwayFromPost, const goToPostStrat) + ] + , perceptionUpdate [0] + , const doStrategyActions + , const reloadOverride + , targetYouWhenCognizant + , const $ + overrideInternal + (\cr' -> crHasTarget cr' && crStratConMatches (GetTo (V2 0 0)) cr') + (crActionPlan . apStrategy .~ WatchAndWait) + ] + cr + LauncherAI -> + defaultImpulsive + [ performActions + , watchUpdateStrat + [ (crHasTargetLOS, \_ _ -> StrategyActions (ShootAt 0) [retreatFireLauncher]) + , (const crAwayFromPost, const goToPostStrat) + ] + , perceptionUpdate [0] + , const doStrategyActions + , const reloadOverride + , targetYouWhenCognizant + , const $ + overrideInternal + (\cr' -> crHasTarget cr' && crStratConMatches (GetTo (V2 0 0)) cr') + (crActionPlan . apStrategy .~ WatchAndWait) + ] + cr + SwarmAI -> + defaultImpulsive + [ flockToPointUsing' (encircleDistP 100) (meleeHeadingMove 0.1 0.1 (pi / 4) 3.9) + , const (crMeleeCooldown %~ max 0 . subtract 1) + , perceptionUpdate [0] + , const doStrategyActions + , targetYouWhenCognizant + ] + cr AutoAI -> defaultImpulsive [sentinelAI] cr - FlockArmourChaseAI -> defaultImpulsive - [ watchUpdateStrat [] - , const doStrategyActions - , performActions - , targetYouWhenCognizant - , setTargetMv (\_ -> _targetCr . _crIntention) - , flockACC - , perceptionUpdate [0] - , goToTarget - , const overrideMeleeCloseTarget - , const (crMeleeCooldown %~ max 0 . subtract 1) - ] cr + FlockArmourChaseAI -> + defaultImpulsive + [ watchUpdateStrat [] + , const doStrategyActions + , performActions + , targetYouWhenCognizant + , setTargetMv (\_ -> _targetCr . _crIntention) + , flockACC + , perceptionUpdate [0] + , goToTarget + , const overrideMeleeCloseTarget + , const (crMeleeCooldown %~ max 0 . subtract 1) + ] + cr MiniGunAI -> defaultImpulsive [sentinelFireType (const shootTillEmpty)] cr LongAI -> defaultImpulsive [sentinelFireType $ const shootTillEmpty] cr - MultGunAI -> defaultImpulsive [sentinelExtraWatchUpdate - [ ( const $ not . crWeaponReady - , \_ _ -> StrategyActions Reload reloadActions - ) - , (const $ not . crSafeDistFromTarg 150 - , \_ _ -> StrategyActions Flee - [WdCrNegate (WdCrSafeDistFromTarget 150) `DoActionWhile` UseSelf CrFleeFromTarget-- (fleeFrom cr') - `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait] ] - ) - , (crHasTargetLOS, \_ _ -> StrategyActions (ShootAt 0) - [ drawwp `DoActionThen` shootFirstMiss `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait] ] - ) + MultGunAI -> + defaultImpulsive + [ sentinelExtraWatchUpdate + [ + ( const $ not . crWeaponReady + , \_ _ -> StrategyActions Reload reloadActions + ) + , + ( const $ not . crSafeDistFromTarg 150 + , \_ _ -> + StrategyActions + Flee + [ WdCrNegate (WdCrSafeDistFromTarget 150) `DoActionWhile` UseSelf CrFleeFromTarget -- (fleeFrom cr') + `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait] + ] + ) + , + ( crHasTargetLOS + , \_ _ -> + StrategyActions + (ShootAt 0) + [drawwp `DoActionThen` shootFirstMiss `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait]] + ) + ] ] - ] cr + cr YourAI -> stateUpdate yourControl cr InanimateAI -> id where drawwp = DoActionIfElse NoAction (WdCrBlfromCrBl CrIsAiming) (DoActionThen drawWeapon (WaitThen 50 NoAction)) - reloadActions = + reloadActions = [ holsterWeapon , WaitThen 1 $ DoActionWhileInterrupt NoAction (WdCrBlfromCrBl CrIsReloading) (DoImpulses [ChangeStrategy WatchAndWait]) ] + -- bit of a hack to get new random generators after each creature's update -defaultImpulsive :: [World -> Creature -> Creature] - -> Creature -> World -> World +defaultImpulsive :: + [World -> Creature -> Creature] -> + Creature -> + World -> + World defaultImpulsive = fmap (fmap updateRandGen) . stateUpdate . impulsiveAIBefore . chainCreatureUpdates where - updateRandGen w = let (_,g) = randomR (0,1::Int) (_randGen w) - in w & randGen .~ g - + updateRandGen w = + let (_, g) = randomR (0, 1 :: Int) (_randGen w) + in w & randGen .~ g chooseMovementPistol :: Creature -> World -> Action -chooseMovementPistol cr w = chooseMovementPistol' cr w - `DoActionThen` - DoImpulses [ChangeStrategy WatchAndWait] +chooseMovementPistol cr w = + chooseMovementPistol' cr w + `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait] chooseMovementPistol' :: Creature -> World -> Action -chooseMovementPistol' cr w = takeOneWeighted [chargeProb,retreatProb,strafeProb,strafeProb] - [chargeActions - ,retreatActionsPistol ycr cr - ,strafeLeftActions - ,strafeRightActions - ] & evalState $ g +chooseMovementPistol' cr w = + takeOneWeighted + [chargeProb, retreatProb, strafeProb, strafeProb] + [ chargeActions + , retreatActionsPistol ycr cr + , strafeLeftActions + , strafeRightActions + ] + & evalState + $ g where g = _randGen w cpos = _crPos cr ycr = _creatures (_cWorld w) IM.! 0 ypos = _crPos ycr - chargeProb | dist cpos ypos > 300 = 5 - | dist cpos ypos > 150 = 1 - | otherwise = 0 - strafeProb | dist cpos ypos > 150 = 1 - | otherwise = 0 - retreatProb | dist cpos ypos < 200 = 1 :: Float - | otherwise = 0 + chargeProb + | dist cpos ypos > 300 = 5 + | dist cpos ypos > 150 = 1 + | otherwise = 0 + strafeProb + | dist cpos ypos > 150 = 1 + | otherwise = 0 + retreatProb + | dist cpos ypos < 200 = 1 :: Float + | otherwise = 0 chargeActions = [TurnToward ypos 0.1] - `DoImpulsesAlongside` - 3 - `DoReplicate` - ImpulsesList (replicate 9 [Move (V2 3 0)] ++ [[Move (V2 3 0),UseItem]]) - strafeLeftActions = - DoImpulses [TurnToward yposr (2*pi)] - `DoActionThen` - 3 - `DoReplicate` - ImpulsesList (replicate 9 [Move (V2 0 3)] ++ [[Move (V2 0 3),UseItem]]) - strafeRightActions = - DoImpulses [TurnToward yposl (2*pi)] - `DoActionThen` - 3 - `DoReplicate` - ImpulsesList (replicate 9 [Move (V2 0 (-3))] ++ [[Move (V2 0 (-3)),UseItem]]) + `DoImpulsesAlongside` 3 + `DoReplicate` ImpulsesList (replicate 9 [Move (V2 3 0)] ++ [[Move (V2 3 0), UseItem]]) + strafeLeftActions = + DoImpulses [TurnToward yposr (2 * pi)] + `DoActionThen` 3 + `DoReplicate` ImpulsesList (replicate 9 [Move (V2 0 3)] ++ [[Move (V2 0 3), UseItem]]) + strafeRightActions = + DoImpulses [TurnToward yposl (2 * pi)] + `DoActionThen` 3 + `DoReplicate` ImpulsesList (replicate 9 [Move (V2 0 (-3))] ++ [[Move (V2 0 (-3)), UseItem]]) yposl = ypos -.- 100 *.* vNormal (normalizeV $ ypos -.- cpos) yposr = ypos +.+ 100 *.* vNormal (normalizeV $ ypos -.- cpos) retreatActionsPistol :: Creature -> Creature -> Action -retreatActionsPistol tcr cr = +retreatActionsPistol tcr cr = [TurnToward retreatOffset 0.2] - `DoImpulsesAlongside` - 3 - `DoReplicate` - ImpulsesList (replicate 9 [Move (V2 (-3) 0)] ++ [[UseItem]]) - where + `DoImpulsesAlongside` 3 + `DoReplicate` ImpulsesList (replicate 9 [Move (V2 (-3) 0)] ++ [[UseItem]]) + where cpos = _crPos cr tpos = _crPos tcr - retreatOffset = - let a | dist cpos tpos < 50 = 0 - | isLeftOfA (_crDir cr) (argV $ tpos -.- cpos) - = -0.7 - | otherwise = 0.7 - in fromMaybe tpos $ intersectLineLine' cpos - (cpos +.+ rotateV a (tpos -.- cpos)) - tpos - (tpos +.+ vNormal (cpos -.- tpos)) - + retreatOffset = + let a + | dist cpos tpos < 50 = 0 + | isLeftOfA (_crDir cr) (argV $ tpos -.- cpos) = + -0.7 + | otherwise = 0.7 + in fromMaybe tpos $ + intersectLineLine' + cpos + (cpos +.+ rotateV a (tpos -.- cpos)) + tpos + (tpos +.+ vNormal (cpos -.- tpos)) retreatFireLauncher :: Action -retreatFireLauncher = ImpulsesList ( [ UseItem ] : replicate 20 [ Turn 0.16 ]) - `DoActionThen` - holsterWeapon - `DoActionThen` - ImpulsesList ( replicate 30 [ MoveForward 3 ]) - `DoActionThen` - drawWeapon - `DoActionThen` - ImpulsesList ( [UseItem] : replicate 20 [ Turn $ negate 0.16 ] ) - `DoActionThen` - holsterWeapon - `DoActionThen` - ImpulsesList ( replicate 15 [ MoveForward 3 ] ) - `DoActionThen` - drawWeapon - `DoActionThen` - ImpulsesList ( - replicate 100 [UseItem, ImpulseUseTarget (TurnTowardCr (pi/16)) -- $ \tcr -> TurnToward (_crPos tcr) (pi/16) ] ) - ]) - `DoActionThen` - 20 - `WaitThen` - holsterWeapon - `DoActionThen` - ImpulsesList ( replicate 15 [ MoveForward 3 ] ) - `DoActionThen` - DoImpulses [ChangeStrategy WatchAndWait] +retreatFireLauncher = + ImpulsesList ([UseItem] : replicate 20 [Turn 0.16]) + `DoActionThen` holsterWeapon + `DoActionThen` ImpulsesList (replicate 30 [MoveForward 3]) + `DoActionThen` drawWeapon + `DoActionThen` ImpulsesList ([UseItem] : replicate 20 [Turn $ negate 0.16]) + `DoActionThen` holsterWeapon + `DoActionThen` ImpulsesList (replicate 15 [MoveForward 3]) + `DoActionThen` drawWeapon + `DoActionThen` ImpulsesList + ( replicate + 100 + [ UseItem + , ImpulseUseTarget (TurnTowardCr (pi / 16)) + ] + ) + `DoActionThen` 20 + `WaitThen` holsterWeapon + `DoActionThen` ImpulsesList (replicate 15 [MoveForward 3]) + `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait] diff --git a/src/Dodge/Initialisation.hs b/src/Dodge/Initialisation.hs index 69c4f1f05..125d01ed4 100644 --- a/src/Dodge/Initialisation.hs +++ b/src/Dodge/Initialisation.hs @@ -1,18 +1,18 @@ module Dodge.Initialisation where -import Dodge.Default.World -import Dodge.Data + +import Control.Lens import Dodge.Creature +import Dodge.Data.World +import Dodge.Default.World import Dodge.SoundLogic import Geometry.Data - import qualified IntMapHelp as IM -import Control.Lens initialWorld :: World -initialWorld = defaultWorld - & cWorld . cameraZoom .~ 10 - & cWorld . creatures .~ IM.fromList [(0,startCr)] - & cWorld . yourID .~ 0 - & cWorld . worldEvents .~ SoundStart BackgroundSound (V2 0 0) foamSprayFadeOutS Nothing - : [MakeStartCloudAt (V3 x y 5) | x <- [-5,-4..5] , y <- [-5,-4..5]] - +initialWorld = + defaultWorld + & cWorld . cameraZoom .~ 10 + & cWorld . creatures .~ IM.fromList [(0, startCr)] + & cWorld . yourID .~ 0 + & cWorld . worldEvents .~ SoundStart BackgroundSound (V2 0 0) foamSprayFadeOutS Nothing : + [MakeStartCloudAt (V3 x y 5) | x <- [-5, -4 .. 5], y <- [-5, -4 .. 5]] diff --git a/src/Dodge/InputFocus.hs b/src/Dodge/InputFocus.hs index c295f74a0..caf6dbdb3 100644 --- a/src/Dodge/InputFocus.hs +++ b/src/Dodge/InputFocus.hs @@ -1,8 +1,8 @@ module Dodge.InputFocus where -import Dodge.Data -import LensHelp import Data.Maybe +import Dodge.Data.World +import LensHelp inTermFocus :: World -> Bool inTermFocus w = fromMaybe False $ do diff --git a/src/Dodge/Inventory.hs b/src/Dodge/Inventory.hs index 7f4a3b65f..7166f497d 100644 --- a/src/Dodge/Inventory.hs +++ b/src/Dodge/Inventory.hs @@ -1,90 +1,90 @@ {-# LANGUAGE TupleSections #-} -module Dodge.Inventory - ( checkInvSlotsYou - , rmSelectedInvItem - , invSelPos - , invSelSize - , selNumPos - , selNumTextPos - , selNumCol - , selNumSlots - , selNumMidHeight - , augmentedInvSizes - , rmInvItem - , updateCloseObjects - , updateRBList - , updateTerminal - , closeObjScrollDir - , closeObjectCol - , changeInvSel - , changeSwapInvSel - , changeAugInvSel - , crNumFreeSlots - , crInvSize - , selectedCloseObject - ) - where -import Dodge.Data -import Dodge.ItEffect -import Dodge.Euse -import Dodge.Inventory.CloseObject -import Dodge.Inventory.CheckSlots -import Dodge.Inventory.ItemSpace -import Dodge.Base -import Geometry ---import FoldableHelp -import Padding -import Color -import qualified IntMapHelp as IM -import ListHelp -import LensHelp ---import qualified Data.IntSet as IS +module Dodge.Inventory ( + checkInvSlotsYou, + rmSelectedInvItem, + invSelPos, + invSelSize, + selNumPos, + selNumTextPos, + selNumCol, + selNumSlots, + selNumMidHeight, + augmentedInvSizes, + rmInvItem, + updateCloseObjects, + updateRBList, + updateTerminal, + closeObjScrollDir, + closeObjectCol, + changeInvSel, + changeSwapInvSel, + changeAugInvSel, + crNumFreeSlots, + crInvSize, + selectedCloseObject, +) where + +import Color import qualified Data.Map.Strict as M ---import qualified Data.Set as S import Data.Maybe ---import qualified Data.Text as T ---import SDL ---import Data.List ---import System.Random +import Dodge.Base +import Dodge.Data.Universe +import Dodge.Euse +import Dodge.Inventory.CheckSlots +import Dodge.Inventory.CloseObject +import Dodge.Inventory.ItemSpace +import Dodge.ItEffect +import Geometry +import qualified IntMapHelp as IM +import LensHelp +import ListHelp +import Padding -- | after this the item at the inventory position will no longer exist -rmInvItem :: Int -- ^ Creature id - -> Int -- ^ Inventory position - -> World - -> World +rmInvItem :: + -- | Creature id + Int -> + -- | Inventory position + Int -> + World -> + World rmInvItem cid invid w = case w ^? cWorld . creatures . ix cid . crInv . ix invid . itUse . useAmount of Just x | x > 1 -> w & cWorld . creatures . ix cid . crInv . ix invid . itUse . useAmount %~ subtract 1 - _ -> w - & cWorld . creatures . ix cid . crInv %~ f - & cWorld . creatures . ix cid . crInvSel %~ stopCrInvSelAction - & cWorld . creatures . ix cid . crInvSel . iselPos %~ g - & cWorld . creatures . ix cid . crLeftInvSel %~ g' - & removeAnySlotEquipment - & dounequipfunction - & doanyitemeffect - & cWorld . creatures . ix cid . crInvEquipped %~ IM.delete invid - & cWorld . creatures . ix cid . crInvEquipped %~ IM.mapKeys g - -- TODO check whether this can be mapKeysMonotonic + _ -> + w + & cWorld . creatures . ix cid . crInv %~ f + & cWorld . creatures . ix cid . crInvSel %~ stopCrInvSelAction + & cWorld . creatures . ix cid . crInvSel . iselPos %~ g + & cWorld . creatures . ix cid . crLeftInvSel %~ g' + & removeAnySlotEquipment + & dounequipfunction + & doanyitemeffect + & cWorld . creatures . ix cid . crInvEquipped %~ IM.delete invid + & cWorld . creatures . ix cid . crInvEquipped %~ IM.mapKeys g where + -- TODO check whether this can be mapKeysMonotonic + stopCrInvSelAction (InvSel i a) | i == invid = InvSel i NoInvSelAction - | otherwise = InvSel i a + | otherwise = InvSel i a cr = _creatures (_cWorld w) IM.! cid itm = _crInv cr IM.! invid dounequipfunction = fromMaybe id $ do - rmf <- itm ^? itUse . eqEq . eqOnRemove + rmf <- itm ^? itUse . equipEffect . eeOnRemove return $ useE rmf itm cr doanyitemeffect = fromMaybe id $ do rmf <- itm ^? itEffect . ieOnDrop return $ doInvEffect rmf itm cr removeAnySlotEquipment = case w ^? cWorld . creatures . ix cid . crInvEquipped . ix invid of - Just epos -> cWorld . creatures . ix cid . crEquipment . at epos .~ Nothing - Nothing -> id + Just epos -> cWorld . creatures . ix cid . crEquipment . at epos .~ Nothing + Nothing -> id maxk = fmap fst $ IM.lookupMax $ _crInv $ _creatures (_cWorld w) IM.! cid - f inv = let (xs,ys) = IM.split invid inv - in xs `IM.union` IM.mapKeys (subtract 1) ys - g x | x > invid || Just x == maxk = max 0 $ x - 1 + f inv = + let (xs, ys) = IM.split invid inv + in xs `IM.union` IM.mapKeys (subtract 1) ys + g x + | x > invid || Just x == maxk = max 0 $ x - 1 | otherwise = x g' Nothing = Nothing g' (Just x) @@ -99,9 +99,10 @@ augmentedInvSizes :: World -> IM.IntMap Int augmentedInvSizes = bimapAugmentInv itSlotsTaken closeObjectSize bimapAugmentInv :: (Item -> a) -> (Either FloorItem Button -> a) -> World -> IM.IntMap a -bimapAugmentInv f g w = IM.union - (f <$> yourInv w) - (IM.fromAscList $ zip [length (yourInv w) ..] $ map g $ _closeObjects (_cWorld w)) +bimapAugmentInv f g w = + IM.union + (f <$> yourInv w) + (IM.fromAscList $ zip [length (yourInv w) ..] $ map g $ _closeObjects (_cWorld w)) invSelSize :: Int -> World -> Int invSelSize i w = fromMaybe 1 $ augmentedInvSizes w IM.!? i @@ -109,11 +110,12 @@ invSelSize i w = fromMaybe 1 $ augmentedInvSizes w IM.!? i closeObjectSize :: Either FloorItem Button -> Int closeObjectSize e = case e of Left flit -> itSlotsTaken $ _flIt flit - Right _ -> 1 + Right _ -> 1 + closeObjectCol :: Either FloorItem Button -> Color closeObjectCol e = case e of Left flit -> _itInvColor $ _flIt flit - Right _ -> yellow + Right _ -> yellow selNumSlots :: Int -> World -> Int selNumSlots i w = fromMaybe 1 $ augmentedInvSizes w IM.!? i @@ -126,17 +128,17 @@ selNumPos i w = splitgap + (foldl' (+) 0 . fst $ IM.split i (augmentedInvSizes w | otherwise = 1 selNumTextPos :: Configuration -> World -> Int -> Point2 -selNumTextPos cfig w i = V2 (150 - hw) ( hh - (20 * fromIntegral ipos + 20)) +selNumTextPos cfig w i = V2 (150 - hw) (hh - (20 * fromIntegral ipos + 20)) where hh = halfHeight cfig - hw = halfWidth cfig + hw = halfWidth cfig ipos = selNumPos i w selNumMidHeight :: Configuration -> World -> Int -> Point2 -selNumMidHeight cfig w i = V2 (150 - hw) ( hh + bump - (20 * fromIntegral ipos + 7.5)) +selNumMidHeight cfig w i = V2 (150 - hw) (hh + bump - (20 * fromIntegral ipos + 7.5)) where hh = halfHeight cfig - hw = halfWidth cfig + hw = halfWidth cfig ipos = selNumPos i w bump = negate $ 10 * fromIntegral (selNumSlots i w) @@ -157,47 +159,54 @@ updateTerminal = checkTermDist checkTermDist :: World -> World checkTermDist w = case w ^? cWorld . hud . hudElement . subInventory . termID of Just tmid -> fromMaybe (w & cWorld . hud . hudElement .~ DisplayInventory NoSubInventory) $ do - btid <- w ^? cWorld . terminals . ix tmid . tmButtonID - btpos <- w ^? cWorld . buttons . ix btid . btPos + btid <- w ^? cWorld . terminals . ix tmid . tmButtonID + btpos <- w ^? cWorld . buttons . ix btid . btPos if dist btpos (_crPos $ you w) < 40 then Just w else Nothing Nothing -> w -- this looks ugly... updateCloseObjects :: World -> World -updateCloseObjects w = w - & cWorld . closeObjects .~ unionBy closeObjEq oldCloseFiltered currentClose - & cWorld . creatures . ix (_yourID (_cWorld w)) . crInvSel . iselPos %~ updateinvsel +updateCloseObjects w = + w + & cWorld . closeObjects .~ unionBy closeObjEq oldCloseFiltered currentClose + & cWorld . creatures . ix (_yourID (_cWorld w)) . crInvSel . iselPos %~ updateinvsel where updateinvsel curinvsel | length (augmentedInvSizes w) <= curinvsel = max 0 $ length (augmentedInvSizes w) - 1 | otherwise = curinvsel filt = filter $ \obj -> dist ypos (closeObjPos obj) < 40 && hasButtonLOS ypos (closeObjPos obj) w ypos = _crPos $ you w - activeButtons = map Right - . filter ( (/=) BtNoLabel . _btState) - . IM.elems - $ _buttons (_cWorld w) + activeButtons = + map Right + . filter ((/=) BtNoLabel . _btState) + . IM.elems + $ _buttons (_cWorld w) currentClose = filt $ map Left (IM.elems $ _floorItems (_cWorld w)) ++ activeButtons - oldClose = filt $ mapMaybe updatebyid $ _closeObjects (_cWorld w) + oldClose = filt $ mapMaybe updatebyid $ _closeObjects (_cWorld w) oldCloseFiltered = intersectBy closeObjEq oldClose currentClose updatebyid (Left flid) = fmap Left $ w ^? cWorld . floorItems . ix (_flItID flid) updatebyid (Right btid) = fmap Right $ w ^? cWorld . buttons . ix (_btID btid) updateRBList :: World -> World -updateRBList w - | w ^? rbOptions . opCurInvPos == Just curinvid - = w & setEquipAllocation & setEquipActivation - | otherwise = case cr ^? crInv . ix curinvid . itUse . eqEq . eqSite of - Just esite -> w - & rbOptions .~ EquipOptions (equipSiteToPositions esite) - (chooseEquipmentPosition cr (equipSiteToPositions esite)) - curinvid - DoNotMoveEquipment - NoChangeActivateEquipment - & setEquipAllocation & setEquipActivation +updateRBList w + | w ^? rbOptions . opCurInvPos == Just curinvid = + w & setEquipAllocation & setEquipActivation + | otherwise = case cr ^? crInv . ix curinvid . itUse . equipEffect . eeSite of + Just esite -> + w + & rbOptions + .~ EquipOptions + (equipSiteToPositions esite) + (chooseEquipmentPosition cr (equipSiteToPositions esite)) + curinvid + DoNotMoveEquipment + NoChangeActivateEquipment + & setEquipAllocation + & setEquipActivation Nothing -> w & rbOptions .~ NoRightButtonOptions --- | otherwise = w & rbOptions .~ NoRightButtonOptions where + -- | otherwise = w & rbOptions .~ NoRightButtonOptions + curinvid = crSel cr cr = you w @@ -213,121 +222,155 @@ chooseFreeSite cr = fromMaybe 0 . findIndex hasnoequipment setEquipAllocation :: World -> World setEquipAllocation w = case _rbOptions w of - EquipOptions {_opEquip = es,_opSel=i} -> + EquipOptions{_opEquip = es, _opSel = i} -> case you w ^? crInvEquipped . ix (crSel (you w)) of - Just epos | es !! i == epos - -> w & rbOptions . opAllocateEquipment .~ RemoveEquipment - {_allocOldPos = epos} - Just epos | isJust (you w ^? crEquipment . ix (es !! i)) - -> w & rbOptions . opAllocateEquipment .~ SwapEquipment - {_allocOldPos = epos - ,_allocNewPos = es !! i - ,_allocSwapID = _crEquipment (you w) M.! (es !! i) + Just epos + | es !! i == epos -> + w & rbOptions . opAllocateEquipment + .~ RemoveEquipment + { _allocOldPos = epos + } + Just epos + | isJust (you w ^? crEquipment . ix (es !! i)) -> + w & rbOptions . opAllocateEquipment + .~ SwapEquipment + { _allocOldPos = epos + , _allocNewPos = es !! i + , _allocSwapID = _crEquipment (you w) M.! (es !! i) + } + Just epos -> + w & rbOptions . opAllocateEquipment + .~ MoveEquipment + { _allocOldPos = epos + , _allocNewPos = es !! i } - Just epos -> w & rbOptions . opAllocateEquipment .~ MoveEquipment - {_allocOldPos = epos - ,_allocNewPos = es !! i + Nothing + | isJust (you w ^? crEquipment . ix (es !! i)) -> + w & rbOptions . opAllocateEquipment + .~ ReplaceEquipment + { _allocNewPos = es !! i + , _allocRemoveID = _crEquipment (you w) M.! (es !! i) + } + Nothing -> + w & rbOptions . opAllocateEquipment + .~ PutOnEquipment + { _allocNewPos = es !! i } - Nothing | isJust (you w ^? crEquipment . ix (es !! i)) - -> w & rbOptions . opAllocateEquipment .~ ReplaceEquipment - {_allocNewPos = es !! i - ,_allocRemoveID = _crEquipment (you w) M.! (es !! i) - } - Nothing -> w & rbOptions . opAllocateEquipment .~ PutOnEquipment - {_allocNewPos = es !! i} _ -> w + -- where -- curpos = invSelPos w setEquipActivation :: World -> World setEquipActivation w = case w ^? rbOptions . opAllocateEquipment of Just DoNotMoveEquipment -> w - Just RemoveEquipment { } - -> case _crLeftInvSel (you w) of - Just i | i == invsel -> w & rbOptions . opActivateEquipment .~ DeactivateEquipment - {_deactivateEquipment = i} + Just RemoveEquipment{} -> + case _crLeftInvSel (you w) of + Just i + | i == invsel -> + w & rbOptions . opActivateEquipment + .~ DeactivateEquipment + { _deactivateEquipment = i + } _ -> w & rbOptions . opActivateEquipment .~ NoChangeActivateEquipment - Just rbos - -> case _crLeftInvSel (you w) of + Just rbos -> + case _crLeftInvSel (you w) of Just i | i == invsel -> w & rbOptions . opActivateEquipment .~ NoChangeActivateEquipment - Just i | invselcanactivate -> w & rbOptions . opActivateEquipment .~ ActivateDeactivateEquipment - {_activateEquipment = invsel,_deactivateEquipment = i} - Just i | Just i == rbos ^? allocRemoveID - -> w & rbOptions . opActivateEquipment .~ DeactivateEquipment i + Just i + | invselcanactivate -> + w & rbOptions . opActivateEquipment + .~ ActivateDeactivateEquipment + { _activateEquipment = invsel + , _deactivateEquipment = i + } + Just i + | Just i == rbos ^? allocRemoveID -> + w & rbOptions . opActivateEquipment .~ DeactivateEquipment i Just _ -> w & rbOptions . opActivateEquipment .~ NoChangeActivateEquipment - Nothing | invselcanactivate -> w & rbOptions . opActivateEquipment .~ ActivateEquipment - {_activateEquipment = invsel} + Nothing + | invselcanactivate -> + w & rbOptions . opActivateEquipment + .~ ActivateEquipment + { _activateEquipment = invsel + } Nothing -> w & rbOptions . opActivateEquipment .~ NoChangeActivateEquipment Nothing -> w & rbOptions . opActivateEquipment .~ NoChangeActivateEquipment where invsel = crSel (you w) - invselcanactivate = isJust (you w ^? crInv . ix invsel . itUse . lUse) + invselcanactivate = isJust (you w ^? crInv . ix invsel . itUse . leftUse) equipSiteToPositions :: EquipSite -> [EquipPosition] equipSiteToPositions es = case es of - GoesOnHead -> [OnHead] - GoesOnChest -> [OnChest] - GoesOnBack -> [OnBack] - GoesOnWrist -> [OnLeftWrist,OnRightWrist] - GoesOnLegs -> [OnLegs] + GoesOnHead -> [OnHead] + GoesOnChest -> [OnChest] + GoesOnBack -> [OnBack] + GoesOnWrist -> [OnLeftWrist, OnRightWrist] + GoesOnLegs -> [OnLegs] GoesOnSpecial -> [OnSpecial] - closeObjScrollDir :: Float -> World -> World -closeObjScrollDir x +closeObjScrollDir x | x > 0 = over (cWorld . closeObjects) rotU | x < 0 = over (cWorld . closeObjects) rotD | otherwise = id changeInvSel :: Int -> World -> World -changeInvSel i w - | n == 0 = w - | yourInvSel w < n = w - & cWorld . creatures . ix (_yourID (_cWorld w)) . crInvSel . iselPos %~ (`mod` n) . subtract i - & cWorld . creatures . ix (_yourID (_cWorld w)) . crInvSel . iselAction .~ NoInvSelAction - | otherwise = w - & cWorld . creatures . ix (_yourID (_cWorld w)) . crInvSel . iselPos %~ ((+n) . (`mod` numCO) . subtract (i+n)) - & cWorld . creatures . ix (_yourID (_cWorld w)) . crInvSel . iselAction .~ NoInvSelAction +changeInvSel i w + | n == 0 = w + | yourInvSel w < n = + w + & cWorld . creatures . ix (_yourID (_cWorld w)) . crInvSel . iselPos %~ (`mod` n) . subtract i + & cWorld . creatures . ix (_yourID (_cWorld w)) . crInvSel . iselAction .~ NoInvSelAction + | otherwise = + w + & cWorld . creatures . ix (_yourID (_cWorld w)) . crInvSel . iselPos %~ ((+ n) . (`mod` numCO) . subtract (i + n)) + & cWorld . creatures . ix (_yourID (_cWorld w)) . crInvSel . iselAction .~ NoInvSelAction + where -- arguably this should jump the invpos into the inventory proper - where + n = length $ _crInv $ _creatures (_cWorld w) IM.! _yourID (_cWorld w) numCO = length $ _closeObjects (_cWorld w) changeSwapInvSel :: Int -> World -> World -changeSwapInvSel k w - | n == 0 = w - | yourInvSel w < n = w - & cWorld . creatures . ix (_yourID (_cWorld w)) %~ updatecreature - | otherwise = w - & cWorld . creatures . ix (_yourID (_cWorld w)) . crInvSel . iselPos .~ ico' - & cWorld . closeObjects %~ swapIndices (i - n) (ico' - n) - where - updatecreature = ( crInv %~ IM.safeSwapKeys (i `mod` n) swapi ) - . (crLeftInvSel . _Just %~ updateLeftInvSel) - . (crInvSel . iselPos %~ (`mod` n) . subtract k) - . (crInvEquipped %~ IM.safeSwapKeys i swapi) - . swapSite i swapi - . swapSite swapi i +changeSwapInvSel k w + | n == 0 = w + | yourInvSel w < n = + w + & cWorld . creatures . ix (_yourID (_cWorld w)) %~ updatecreature + | otherwise = + w + & cWorld . creatures . ix (_yourID (_cWorld w)) . crInvSel . iselPos .~ ico' + & cWorld . closeObjects %~ swapIndices (i - n) (ico' - n) + where + updatecreature = + (crInv %~ IM.safeSwapKeys (i `mod` n) swapi) + . (crLeftInvSel . _Just %~ updateLeftInvSel) + . (crInvSel . iselPos %~ (`mod` n) . subtract k) + . (crInvEquipped %~ IM.safeSwapKeys i swapi) + . swapSite i swapi + . swapSite swapi i swapSite a b = case cr ^? crInvEquipped . ix a of Just epos -> crEquipment . ix epos .~ b Nothing -> id cr = you w swapi = (i - k) `mod` n - updateLeftInvSel li | i == li = swapi + updateLeftInvSel li + | i == li = swapi | swapi == li = i | otherwise = li i = crSel cr - ico' = ( (i - (k+n)) `mod` numCO ) + n + ico' = ((i - (k + n)) `mod` numCO) + n n = length $ _crInv cr numCO = length $ _closeObjects (_cWorld w) changeAugInvSel :: Int -> World -> World -changeAugInvSel i w - | n == 0 = w - | otherwise = w - & cWorld . creatures . ix (_yourID (_cWorld w)) . crInvSel . iselPos %~ (`mod` n) . subtract i - & cWorld . creatures . ix (_yourID (_cWorld w)) . crInvSel . iselAction .~ NoInvSelAction - where +changeAugInvSel i w + | n == 0 = w + | otherwise = + w + & cWorld . creatures . ix (_yourID (_cWorld w)) . crInvSel . iselPos %~ (`mod` n) . subtract i + & cWorld . creatures . ix (_yourID (_cWorld w)) . crInvSel . iselAction .~ NoInvSelAction + where n = length (yourInv w) + length (_closeObjects (_cWorld w)) bestCloseObjectIndex :: World -> Maybe Int @@ -337,7 +380,7 @@ bestCloseObjectIndex w = findIndex f $ _closeObjects (_cWorld w) f (Left flit) = itSlotsTaken (_flIt flit) <= _crInvCapacity ycr - crInvSize ycr ycr = you w -selectedCloseObject :: World -> Maybe (Int,Either FloorItem Button) +selectedCloseObject :: World -> Maybe (Int, Either FloorItem Button) selectedCloseObject w | invsel >= length inv = selectNthCloseObject w (invsel - length inv) | otherwise = selectNthCloseObject w =<< bestCloseObjectIndex w @@ -346,5 +389,5 @@ selectedCloseObject w cr = you w inv = _crInv cr -selectNthCloseObject :: World -> Int -> Maybe (Int,Either FloorItem Button) +selectNthCloseObject :: World -> Int -> Maybe (Int, Either FloorItem Button) selectNthCloseObject w n = (length (yourInv w) + n,) <$> (_closeObjects (_cWorld w) !? n) diff --git a/src/Dodge/Inventory/Add.hs b/src/Dodge/Inventory/Add.hs index a815469d7..eafd9df15 100644 --- a/src/Dodge/Inventory/Add.hs +++ b/src/Dodge/Inventory/Add.hs @@ -1,37 +1,40 @@ module Dodge.Inventory.Add where -import Dodge.Data -import Dodge.Inventory.CheckSlots -import Dodge.FloorItem -import Dodge.Combine.Module -import Dodge.Base.You -import Data.Maybe import Control.Lens +import Data.Maybe +import Dodge.Base.You +import Dodge.Combine.Module +import Dodge.Data.World +import Dodge.FloorItem +import Dodge.Inventory.CheckSlots import qualified IntMapHelp as IM -putItemInInvID :: Int -> Int -> World -> (Maybe Int,World) -putItemInInvID cid flid w = fromMaybe (Nothing,w) $ do - (i,w') <- tryPutItemInInv cid (_floorItems (_cWorld w) IM.! flid) w - return (Just i,w') +putItemInInvID :: Int -> Int -> World -> (Maybe Int, World) +putItemInInvID cid flid w = fromMaybe (Nothing, w) $ do + (i, w') <- tryPutItemInInv cid (_floorItems (_cWorld w) IM.! flid) w + return (Just i, w') putItemInInvSlot :: Int -> Item -> IM.IntMap Item -> IM.IntMap Item putItemInInvSlot = IM.insertWith (const $ itUse . useAmount +~ 1) -{- | Pick up a specific item. -} -tryPutItemInInv :: Int -> FloorItem -> World -> Maybe (Int,World) +-- | Pick up a specific item. +tryPutItemInInv :: Int -> FloorItem -> World -> Maybe (Int, World) tryPutItemInInv cid flit w = case maybeInvSlot of Nothing -> Nothing - Just i -> Just (i, w - & updateItLocation i - & cWorld . floorItems %~ IM.delete (_flItID flit) - & cWorld . creatures . ix cid . crInv %~ putItemInInvSlot i it - ) - where + Just i -> + Just + ( i + , w + & updateItLocation i + & cWorld . floorItems %~ IM.delete (_flItID flit) + & cWorld . creatures . ix cid . crInv %~ putItemInInvSlot i it + ) + where it = _flIt flit maybeInvSlot = checkInvSlotsYou it w - updateItLocation invid w' = case _itID it of + updateItLocation invid w' = case _itID it of Nothing -> w' - Just j -> w' & cWorld . itemLocations . ix j .~ InInv cid invid + Just j -> w' & cWorld . itemLocations . ix j .~ InInv cid invid --{- | Pick up a specific item. -} --putItemInInv :: Int -> FloorItem -> World -> World @@ -41,12 +44,13 @@ tryPutItemInInv cid flit w = case maybeInvSlot of -- & updateItLocation i -- & floorItems %~ IM.delete (_flItID flit) -- & creatures . ix cid . crInv %~ IM.insertWith (const $ itAmount +~ 1) i it --- where +-- where -- it = _flIt flit -- maybeInvSlot = checkInvSlotsYou it w --- updateItLocation invid w' = case _itID it of +-- updateItLocation invid w' = case _itID it of -- Nothing -> w' -- Just j -> w' & itemPositions . ix j .~ InInv cid invid createPutItem :: Item -> World -> (Maybe Int, World) -createPutItem it w = uncurry (putItemInInvID (_yourID (_cWorld w))) - $ copyItemToFloorID (_crPos $ you w) (applyModules it) w +createPutItem it w = + uncurry (putItemInInvID (_yourID (_cWorld w))) $ + copyItemToFloorID (_crPos $ you w) (applyModules it) w diff --git a/src/Dodge/Inventory/CheckSlots.hs b/src/Dodge/Inventory/CheckSlots.hs index 975b33d3e..d3bde0303 100644 --- a/src/Dodge/Inventory/CheckSlots.hs +++ b/src/Dodge/Inventory/CheckSlots.hs @@ -3,7 +3,7 @@ module Dodge.Inventory.CheckSlots where import Control.Lens import Data.Maybe import Dodge.Base.You -import Dodge.Data +import Dodge.Data.World import Dodge.Inventory.ItemSpace import qualified IntMapHelp as IM diff --git a/src/Dodge/Inventory/CloseObject.hs b/src/Dodge/Inventory/CloseObject.hs index 46a2b94c4..65bf43855 100644 --- a/src/Dodge/Inventory/CloseObject.hs +++ b/src/Dodge/Inventory/CloseObject.hs @@ -1,13 +1,15 @@ module Dodge.Inventory.CloseObject where -import Dodge.Data + +import Dodge.Data.Button +import Dodge.Data.FloorItem import Geometry closeObjPos :: Either FloorItem Button -> Point2 closeObjPos e = case e of Right x -> _btPos x - Left x -> _flItPos x + Left x -> _flItPos x closeObjEq :: Either FloorItem Button -> Either FloorItem Button -> Bool -closeObjEq (Right x) (Right y) = _btID x == _btID y -closeObjEq (Left x) (Left y) = _flItID x == _flItID y +closeObjEq (Right x) (Right y) = _btID x == _btID y +closeObjEq (Left x) (Left y) = _flItID x == _flItID y closeObjEq _ _ = False diff --git a/src/Dodge/Inventory/ItemSpace.hs b/src/Dodge/Inventory/ItemSpace.hs index c779f3a0c..e491f18d3 100644 --- a/src/Dodge/Inventory/ItemSpace.hs +++ b/src/Dodge/Inventory/ItemSpace.hs @@ -1,13 +1,12 @@ -module Dodge.Inventory.ItemSpace - ( itSlotsTaken - ) where -import Dodge.Data -import Dodge.Module +module Dodge.Inventory.ItemSpace ( + itSlotsTaken, +) where import Control.Lens ---import Data.Maybe +import Dodge.Data.Item +import Dodge.Module itSlotsTaken :: Item -> Int itSlotsTaken it = case it ^? itUse . useAmount of Nothing -> moduleSizes it + ceiling (_itInvSize it) - Just i -> moduleSizes it + ceiling (_itInvSize it * fromIntegral i) + Just i -> moduleSizes it + ceiling (_itInvSize it * fromIntegral i) diff --git a/src/Dodge/Inventory/Lock.hs b/src/Dodge/Inventory/Lock.hs index d34344eb2..ff6c1c0fe 100644 --- a/src/Dodge/Inventory/Lock.hs +++ b/src/Dodge/Inventory/Lock.hs @@ -1,9 +1,10 @@ module Dodge.Inventory.Lock where -import Dodge.Data + import Control.Lens +import Dodge.Data.World lockInv :: Int -> World -> World -lockInv cid = cWorld . creatures . ix cid . crInvLock %~ (|| True) +lockInv cid = cWorld . creatures . ix cid . crInvLock ||~ True unlockInv :: Int -> World -> World -unlockInv cid = cWorld . creatures . ix cid . crInvLock %~ (&& False) +unlockInv cid = cWorld . creatures . ix cid . crInvLock &&~ False diff --git a/src/Dodge/ItEffect.hs b/src/Dodge/ItEffect.hs index 4e4a7ceac..fb29592fd 100644 --- a/src/Dodge/ItEffect.hs +++ b/src/Dodge/ItEffect.hs @@ -1,15 +1,14 @@ module Dodge.ItEffect where -import Dodge.Euse -import Dodge.Data -import Dodge.LightSource.Torch import Control.Lens +import Dodge.Data.World +import Dodge.Euse +import Dodge.LightSource.Torch doInvEffect :: ItInvEffect -> Item -> Creature -> World -> World doInvEffect iie = case iie of NoInvEffect -> const $ const id RewindEffect -> rewindEffect --- ResetAttachmentEffect -> resetAttachmentEffect EffectIfHeld f g -> onOffEff f g CreateHeldLight -> createHeldLight CreateShieldWall -> createShieldWall @@ -22,23 +21,26 @@ doFloorEffect NoFloorEffect = const id onOffEff :: ItInvEffect -> ItInvEffect -> Item -> Creature -> World -> World onOffEff f g it | _itIsHeld it = doInvEffect f it - | otherwise = doInvEffect g it + | otherwise = doInvEffect g it rewindEffect :: Item -> Creature -> World -> World -rewindEffect itm cr w - | Just invid == _crLeftInvSel cr = w & cWorld . rewindWorlds %~ (take maxcharge . (cw : )) - & ptrWpCharge .~ length (_rewindWorlds (_cWorld w)) - | otherwise = w & cWorld . rewindWorlds .~ [] - & ptrWpCharge .~ 0 +rewindEffect itm cr w + | Just invid == _crLeftInvSel cr = + w & cWorld . rewindWorlds %~ (take maxcharge . (cw :)) + & ptrWpCharge .~ length (_rewindWorlds (_cWorld w)) + | otherwise = + w & cWorld . rewindWorlds .~ [] + & ptrWpCharge .~ 0 where invid = _ipInvID $ _itLocation itm ptrWpCharge = cWorld . creatures . ix (_crID cr) . crInv . ix invid . itUse . leftConsumption . wpCharge maxcharge = itm ^?! itUse . leftConsumption . wpMaxCharge - cw = _cWorld w - & rewindWorlds .~ [] + cw = + _cWorld w + & rewindWorlds .~ [] --resetAttachmentEffect :: Item -> Creature -> World -> World ---resetAttachmentEffect itm cr w +--resetAttachmentEffect itm cr w -- | _ieCounter iteff < 0 = w & pointToIt . itAttachment .~ NoItAttachment -- | otherwise = w & pointToIt . itEffect . ieCounter -~ 1 -- where @@ -48,4 +50,3 @@ rewindEffect itm cr w createHeldLight :: Item -> Creature -> World -> World createHeldLight itm cr = createTorchLightOffset cr itm 0 - diff --git a/src/Dodge/Item.hs b/src/Dodge/Item.hs index 08c2c4f0c..db67591d8 100644 --- a/src/Dodge/Item.hs +++ b/src/Dodge/Item.hs @@ -3,21 +3,20 @@ module Dodge.Item ( module Dodge.Item.Held, module Dodge.Item.Consumable, module Dodge.Item.Equipment, - module Dodge.Item.PassKey, module Dodge.Item.Craftable, itemFromBase, ) where -import Dodge.Data +import Dodge.Data.Item import Dodge.Item.Consumable import Dodge.Item.Craftable import Dodge.Item.Equipment import Dodge.Item.Held -import Dodge.Item.PassKey import Dodge.Item.Weapon itemFromBase :: ItemBaseType -> Item itemFromBase ibt = case ibt of + NoItemType -> undefined HELD ht -> itemFromHeldType ht LEFT lt -> itemFromLeftType lt EQUIP et -> itemFromEquipType et @@ -55,51 +54,3 @@ itemFromLeftType lt = case lt of SHRINKER -> shrinkGun SPAWNER -> error "need to datify creatures first" --- Equipment -itemFromHeldType :: HeldItemType -> Item -itemFromHeldType ht = case ht of - KEYCARD i -> keyCard i - TORCH -> torch - SHATTERGUN -> shatterGun - BANGSTICK i -> bangStick i - PISTOL -> pistol - REVOLVER -> revolver - REVOLVERX i -> revolverX i - MACHINEPISTOL -> machinePistol - AUTOPISTOL -> autoPistol - SMG -> smg - BANGCONE -> bangCone - BLUNDERBUSS -> blunderbuss - GRAPECANNON i -> grapeCannon i - MINIGUNX i -> miniGunX i - VOLLEYGUN i -> volleyGun i - RIFLE -> rifle - REPEATER -> repeater - AUTORIFLE -> autoRifle - BURSTRIFLE -> burstRifle - BANGROD -> bangRod - ELEPHANTGUN -> elephantGun - AMR -> amr - AUTOAMR -> autoAmr - SNIPERRIFLE -> sniperRifle - MACHINEGUN -> machineGun - FLAMESPITTER -> flameSpitter - FLAMETHROWER -> flameThrower - FLAMETORRENT -> flameTorrent - FLAMEWALL -> flameWall - BLOWTORCH -> blowTorch - SPARKGUN -> sparkGun - TESLAGUN -> teslaGun - LASGUN -> lasGun - LASCIRCLE -> lasCircle - DUALBEAM -> dualBeam - LASWIDE i -> lasWide i - TRACTORGUN -> tractorGun - LAUNCHER -> launcher - LAUNCHERX i -> launcherX i - REMOTELAUNCHER -> remoteLauncher - POISONSPRAYER -> poisonSprayer - DRONELAUNCHER -> droneLauncher - FORCEFIELDGUN -> forceFieldGun - HELDDETECTOR d -> clickDetector d - FLATSHIELD -> flatShield diff --git a/src/Dodge/Item/Amount.hs b/src/Dodge/Item/Amount.hs index 03fc32693..6787ed488 100644 --- a/src/Dodge/Item/Amount.hs +++ b/src/Dodge/Item/Amount.hs @@ -1,7 +1,8 @@ module Dodge.Item.Amount where -import Dodge.Data -import Data.Maybe + import Control.Lens +import Data.Maybe +import Dodge.Data.Item itStackAmount :: Item -> ItAmount itStackAmount it = fromMaybe 1 $ it ^? itUse . useAmount diff --git a/src/Dodge/Item/Consumable.hs b/src/Dodge/Item/Consumable.hs index d2c46da0a..fca921870 100644 --- a/src/Dodge/Item/Consumable.hs +++ b/src/Dodge/Item/Consumable.hs @@ -1,27 +1,26 @@ module Dodge.Item.Consumable where -import Dodge.Data ---import Dodge.Picture.Layer + +import Control.Lens +import Dodge.Data.World import Dodge.Default import Dodge.SoundLogic ---import Shape ---import ShapePicture ---import Dodge.Item.Draw ---import Picture - ---import Data.Maybe -import Control.Lens import qualified IntMapHelp as IM medkit :: Int -> Item -medkit i = defaultConsumable - & itUse . cUse .~ CHeal i - & itType . iyBase .~ Consumable (MEDKIT i) +medkit i = + defaultConsumable + & itUse . cUse .~ CHeal i + & itType . iyBase .~ Consumable (MEDKIT i) heal25 :: Int -> World -> Maybe World heal25 = heal 25 + heal :: Int -> Int -> World -> Maybe World -heal hp n w | _crHP (_creatures (_cWorld w) IM.! n) >= 10000 = Nothing - | otherwise = Just $ soundStart (CrSound $ _crID cr) (_crPos cr) healS Nothing w +heal hp n w + | _crHP (_creatures (_cWorld w) IM.! n) >= 10000 = Nothing + | otherwise = + Just $ + soundStart (CrSound $ _crID cr) (_crPos cr) healS Nothing w & cWorld . creatures . ix n . crHP %~ min 10000 . (+ hp) where cr = _creatures (_cWorld w) IM.! n diff --git a/src/Dodge/Item/Craftable.hs b/src/Dodge/Item/Craftable.hs index 197a13d1d..b92165b20 100644 --- a/src/Dodge/Item/Craftable.hs +++ b/src/Dodge/Item/Craftable.hs @@ -1,48 +1,56 @@ module Dodge.Item.Craftable where -import Dodge.Data -import Dodge.Default.Weapon ---import Dodge.Particle.Bullet.HitEffect ---import Dodge.WorldEvent.HitEffect + +import Dodge.Default.Item import Color ---import Dodge.Picture.Layer ---import Picture ---import Geometry import Control.Lens +import Dodge.Data.Item makeTypeCraftNum :: Int -> CraftType -> Item -makeTypeCraftNum i ct = defaultCraftable - & itInvSize .~ 0.5 - & itCurseStatus .~ Uncursed - & itUse . useAmount .~ fromIntegral i - & itType . iyBase .~ CRAFT ct +makeTypeCraftNum i ct = + defaultCraftItem + & itInvSize .~ 0.5 + & itCurseStatus .~ Uncursed + & itUse . useAmount .~ fromIntegral i + & itType . iyBase .~ CRAFT ct makeTypeCraft :: CraftType -> Item makeTypeCraft = makeTypeCraftNum 1 incendiaryModule :: Item -incendiaryModule = makeTypeCraft INCENDIARYMODULE - & itInvSize .~ 1 - & itInvColor .~ chartreuse +incendiaryModule = + makeTypeCraft INCENDIARYMODULE + & itInvSize .~ 1 + & itInvColor .~ chartreuse + bounceModule :: Item -bounceModule = makeTypeCraft BOUNCEMODULE - & itInvSize .~ 1 - & itInvColor .~ chartreuse +bounceModule = + makeTypeCraft BOUNCEMODULE + & itInvSize .~ 1 + & itInvColor .~ chartreuse + teleportModule :: Item -teleportModule = makeTypeCraft TELEPORTMODULE - & itInvSize .~ 1 - & itInvColor .~ chartreuse +teleportModule = + makeTypeCraft TELEPORTMODULE + & itInvSize .~ 1 + & itInvColor .~ chartreuse + timeModule :: Item -timeModule = makeTypeCraft TIMEMODULE - & itInvSize .~ 1 - & itInvColor .~ chartreuse +timeModule = + makeTypeCraft TIMEMODULE + & itInvSize .~ 1 + & itInvColor .~ chartreuse + sizeModule :: Item -sizeModule = makeTypeCraft SIZEMODULE - & itInvSize .~ 1 - & itInvColor .~ chartreuse +sizeModule = + makeTypeCraft SIZEMODULE + & itInvSize .~ 1 + & itInvColor .~ chartreuse + gravityModule :: Item -gravityModule = makeTypeCraft GRAVITYMODULE - & itInvSize .~ 1 - & itInvColor .~ chartreuse +gravityModule = + makeTypeCraft GRAVITYMODULE + & itInvSize .~ 1 + & itInvColor .~ chartreuse pipe :: Item pipe = makeTypeCraft PIPE diff --git a/src/Dodge/Item/Display.hs b/src/Dodge/Item/Display.hs index de91bad02..5643413df 100644 --- a/src/Dodge/Item/Display.hs +++ b/src/Dodge/Item/Display.hs @@ -6,7 +6,7 @@ module Dodge.Item.Display ( import Data.Maybe import Data.Sequence -import Dodge.Data +import Dodge.Data.Creature import Dodge.Inventory.ItemSpace import Dodge.Module import LensHelp @@ -37,6 +37,7 @@ itemString = head . itemDisplay itemBaseName :: Item -> String itemBaseName it = case _iyBase $ _itType it of + NoItemType -> show "NoItemType" CRAFT str -> show str HELD hit -> case hit ^? xNum of Just i -> takeWhile (/= ' ') (show hit) ++ show i @@ -51,7 +52,7 @@ selectedItemDisplay cr it = itemDisplayWithNumber (showSelectedConsumption cr (_ -- | Displays the item name, ammo if loaded, and any selected '_itCharMode'. showSelectedConsumption :: Creature -> ItemUse -> String showSelectedConsumption cr iu = case iu of - RightUse{} -> showReloadProgress cr (_heldConsumption iu) + HeldUse{} -> showReloadProgress cr (_heldConsumption iu) LeftUse{} -> showAutoRechargeProgress (_leftConsumption iu) EquipUse{} -> "" _ -> show $ iu ^?! useAmount . getItAmount -- partial, be careful if adding new data constructors @@ -72,7 +73,7 @@ showReloadProgress cr ic = case cr ^?! crInvSel . iselAction of showConsumption :: ItemUse -> String showConsumption iu = case iu of - RightUse{} -> showReloadProgress' (_heldConsumption iu) + HeldUse{} -> showReloadProgress' (_heldConsumption iu) LeftUse{} -> showAutoRechargeProgress (_leftConsumption iu) EquipUse{} -> "" _ -> show $ iu ^?! useAmount . getItAmount @@ -90,9 +91,9 @@ showLoadActionType la x = case la of LoadPrime{} -> "P" maybeWarmupStatus :: Item -> Maybe String -maybeWarmupStatus it = case it ^? itUse . useDelay . warmMax of +maybeWarmupStatus it = case it ^? itUse . heldDelay . warmMax of Nothing -> Nothing - Just m -> case m - (_warmTime . _useDelay $ _itUse it) of + Just m -> case m - (_warmTime . _heldDelay $ _itUse it) of x | x <= 1 -> Just "*WARM" | otherwise -> @@ -106,6 +107,6 @@ maybeModeStatus it = case it ^? itUse . heldScroll of _ -> Nothing maybeRateStatus :: Item -> Maybe String -maybeRateStatus it = case it ^? itUse . useDelay . rateMaxMax of +maybeRateStatus it = case it ^? itUse . heldDelay . rateMaxMax of Nothing -> Nothing - _ -> Just $ leftPad 3 ' ' (show (_rateMax . _useDelay $ _itUse it)) + _ -> Just $ leftPad 3 ' ' (show (_rateMax . _heldDelay $ _itUse it)) diff --git a/src/Dodge/Item/Draw.hs b/src/Dodge/Item/Draw.hs index 543b6e11b..1ec8bf8e9 100644 --- a/src/Dodge/Item/Draw.hs +++ b/src/Dodge/Item/Draw.hs @@ -1,82 +1,83 @@ -module Dodge.Item.Draw - ( pictureWeaponOnAim - , pictureWeaponAim - , twoFlatHRot - , itemSPic - , itemEquipPict - , heldItemOffset - ) where -import Dodge.Data -import Dodge.Item.HeldOffset -import ShapePicture -import Dodge.Item.Equipment.Shape -import Dodge.Item.Draw.SPic +module Dodge.Item.Draw ( + pictureWeaponOnAim, + pictureWeaponAim, + twoFlatHRot, + itemSPic, + itemEquipPict, + heldItemOffset, +) where -import qualified IntMapHelp as IM import Control.Lens +import Dodge.Data.Creature +import Dodge.Item.Draw.SPic +import Dodge.Item.Equipment.Shape +import Dodge.Item.HeldOffset +import qualified IntMapHelp as IM +import ShapePicture itemEquipPict :: Creature -> Item -> SPic itemEquipPict cr it = case it ^?! itUse of - RightUse {} -> pictureWeaponOnAim cr it - ituse -> case ituse ^? eqEq of + HeldUse{} -> pictureWeaponOnAim cr it + ituse -> case ituse ^? equipEffect of Just _ -> pictureOnEquip (itemSPic it) cr it Nothing -> mempty -pictureWeaponOnAim - :: Creature - -> Item - -> SPic +pictureWeaponOnAim :: + Creature -> + Item -> + SPic pictureWeaponOnAim = pictureWeaponAim itemSPic -pictureWeaponAim - :: (Item -> SPic) - -> Creature - -> Item - -> SPic +pictureWeaponAim :: + (Item -> SPic) -> + Creature -> + Item -> + SPic pictureWeaponAim f cr itm = case _itLocation itm of InInv _ i -> pictureWeaponOnAimItem (f itm) cr i _ -> mempty -{- | Places an item picture onto a creature when the item is selected. -} -pictureWeaponOnAimItem - :: SPic - -> Creature - -> Int -- ^ Position of item in inventory - -> SPic -pictureWeaponOnAimItem p' cr posInInv +-- | Places an item picture onto a creature when the item is selected. +pictureWeaponOnAimItem :: + SPic -> + Creature -> + -- | Position of item in inventory + Int -> + SPic +pictureWeaponOnAimItem p' cr posInInv | _itIsHeld theIt = overPosSP (heldItemOffset theIt cr) p' | otherwise = mempty --- | isSelected && _posture (_crStance cr) == Aiming = --- shoulderD $ translateSPf (aimingWeaponZeroPos cr theIt) 0 p' --- | isSelected && isTwoHandFlat --- = handD holsteredTwoFlat --- | isSelected && isOneHand --- = handD holsteredOneHandWep --- | isSelected --- = handD holsteredWep --- | otherwise = mempty - where --- shoulderD = translateSPz 18 --- handD = translateSPz 15 --- isSelected = crSel cr == posInInv --- twistWep = translateSPf (-5) 0 p --- holsteredWep = translateSPf (_crRad cr) 0 --- (rotateSP (strideRot cr + 1.2) (translateSPf (-5) 0 twistWep)) --- holsteredTwoFlat = translateSPf (_crRad cr) 0 (rotateSP (twoFlatHRot cr) p) --- holsteredOneHandWep = translateSPf (_crRad cr * 0.7 + handPos) (_crRad cr * negate 0.7) --- (translateSPf (-2) 0 p) --- handPos = case cr^? crStance . carriage of --- Just (Walking x LeftForward) -> f x * 50 --- _ -> 0 + where + -- | isSelected && _posture (_crStance cr) == Aiming = + -- shoulderD $ translateSPf (aimingWeaponZeroPos cr theIt) 0 p' + -- | isSelected && isTwoHandFlat + -- = handD holsteredTwoFlat + -- | isSelected && isOneHand + -- = handD holsteredOneHandWep + -- | isSelected + -- = handD holsteredWep + -- | otherwise = mempty + + -- shoulderD = translateSPz 18 + -- handD = translateSPz 15 + -- isSelected = crSel cr == posInInv + -- twistWep = translateSPf (-5) 0 p + -- holsteredWep = translateSPf (_crRad cr) 0 + -- (rotateSP (strideRot cr + 1.2) (translateSPf (-5) 0 twistWep)) + -- holsteredTwoFlat = translateSPf (_crRad cr) 0 (rotateSP (twoFlatHRot cr) p) + -- holsteredOneHandWep = translateSPf (_crRad cr * 0.7 + handPos) (_crRad cr * negate 0.7) + -- (translateSPf (-2) 0 p) + -- handPos = case cr^? crStance . carriage of + -- Just (Walking x LeftForward) -> f x * 50 + -- _ -> 0 theIt = _crInv cr IM.! posInInv + -- p = fromMaybe p' $ do -- x <- theIt ^? itUse . useAim . aimHandlePos -- return $translateSPf (-x) 0 p' -- isOneHand = theIt ^? itUseAimStance == Just OneHand -- || isNothing (theIt ^? itUseAimStance) -- isTwoHandFlat = theIt ^? itUseAimStance == Just TwoHandFlat --- itUseAimStance = itUse . useAim . aimStance +-- itUseAimStance = itUse . useAim . aimStance -- f i = 0.1 * fromIntegral (sLen - i) / fromIntegral sLen -- sLen = _strideLength $ _crStance cr - - diff --git a/src/Dodge/Item/Draw/SPic.hs b/src/Dodge/Item/Draw/SPic.hs index 366aced24..f48d15a2c 100644 --- a/src/Dodge/Item/Draw/SPic.hs +++ b/src/Dodge/Item/Draw/SPic.hs @@ -1,119 +1,138 @@ module Dodge.Item.Draw.SPic where -import Dodge.Data -import Dodge.Item.Weapon.FractionLoaded -import ShapePicture -import Shape -import LensHelp -import Color -import Picture -import Geometry +import Color import Data.Maybe +import Dodge.Data.Item +import Dodge.Item.Weapon.FractionLoaded +import Geometry +import LensHelp +import Picture +import Shape +import ShapePicture itemSPic :: Item -> SPic -itemSPic it = foldMap (modulesSPic it) (_iyModules $ _itType it) <> case it ^. itType . iyBase of - CRAFT _ -> defSPic - HELD ht -> heldItemSPic ht it - LEFT lt -> leftItemSPic lt it - EQUIP et -> equipItemSPic et it - Consumable {} -> defSPic +itemSPic it = + foldMap (modulesSPic it) (_iyModules $ _itType it) <> case it ^. itType . iyBase of + NoItemType -> over _1 (colorSH magenta) defSPic + CRAFT _ -> defSPic + HELD ht -> heldItemSPic ht it + LEFT lt -> leftItemSPic lt it + EQUIP et -> equipItemSPic et it + Consumable{} -> defSPic equipItemSPic :: EquipItemType -> Item -> SPic equipItemSPic et _ = case et of - MAGSHIELD -> defSPic - FLAMESHIELD -> defSPic - FRONTARMOUR -> (emptySH , setDepth 20 $ pictures - [color yellow $ thickArc 0 (pi/2) 10 5 - ,color yellow $ thickArc (3*pi/2) (2*pi) 10 5 - ]) - WRISTARMOUR -> defSPic + MAGSHIELD -> defSPic + FLAMESHIELD -> defSPic + FRONTARMOUR -> + ( emptySH + , setDepth 20 $ + pictures + [ color yellow $ thickArc 0 (pi / 2) 10 5 + , color yellow $ thickArc (3 * pi / 2) (2 * pi) 10 5 + ] + ) + WRISTARMOUR -> defSPic INVISIBILITYEQUIPMENT _ -> noPic (colorSH chartreuse $ upperPrismPoly 3 $ rectWH 2 2) - BRAINHAT -> noPic (colorSH yellow $ upperPrismPoly 3 $ rectWH 4 4) - HAT -> noPic (colorSH yellow $ upperPrismPoly 3 $ rectWH 4 4) - HEADLAMP -> noPic headLampShape + BRAINHAT -> noPic (colorSH yellow $ upperPrismPoly 3 $ rectWH 4 4) + HAT -> noPic (colorSH yellow $ upperPrismPoly 3 $ rectWH 4 4) + HEADLAMP -> noPic headLampShape POWERLEGS -> legsSPic yellow SPEEDLEGS -> legsSPic green - JUMPLEGS -> legsSPic red - JETPACK -> (,) emptySH $ setDepth 20 - $ pictures [color yellow $ polygon $ reverse $ rectNSWE 5 (-5) (-11) (-3) ] + JUMPLEGS -> legsSPic red + JETPACK -> + (,) emptySH $ + setDepth 20 $ + pictures [color yellow $ polygon $ reverse $ rectNSWE 5 (-5) (-11) (-3)] AUTODETECTOR dt -> noPic (colorSH (detectorColor dt) $ upperPrismPoly 3 $ rectWH 2 2) + leftItemSPic :: LeftItemType -> Item -> SPic leftItemSPic lt _ = case lt of BLINKER -> defSPic - _ -> defSPic + _ -> defSPic + heldItemSPic :: HeldItemType -> Item -> SPic heldItemSPic ht it = case ht of FLATSHIELD -> flatShieldEquipSPic - FORCEFIELDGUN -> defSPic - TORCH -> noPic torchShape - BANGSTICK i -> noPic $ baseStickShapeX it i <> stickClip it - PISTOL -> noPic $ baseStickShape <> makeTinClipAt pi (V3 5 2 0) it - REVOLVER -> noPic $ baseStickShape <> revolverClip it - REVOLVERX _ -> noPic $ baseStickShape <> revolverClip it - MACHINEPISTOL -> noPic $ baseStickShape <> makeTinClipAt pi (V3 5 2 0) it - AUTOPISTOL -> noPic $ baseStickShape <> makeTinClipAt pi (V3 5 2 0) it - SMG -> noPic (baseSMGShape <> makeTinClipAt 0 (V3 7 (-2) 0) it) - BANGCONE -> noPic $ colorSH cyan $ upperPrismPoly 3 (rectXH 5 2) - <> upperPrismPoly 6 (reverse $ rectNSWE 4 (-4) 5 15) - BLUNDERBUSS -> noPic $ colorSH cyan $ upperPrismPoly 3 (rectXH 20 2) - <> upperPrismPoly 6 (reverse $ rectNSWE 4 (-4) 20 30) - GRAPECANNON _ -> noPic $ colorSH cyan $ upperPrismPoly 3 (rectXH 20 2) - <> upperPrismPoly 6 (reverse $ rectNSWE 4 (-4) 20 30) - MINIGUNX i -> miniGunXPictItem i it - VOLLEYGUN i -> volleyGunSPic i it - RIFLE -> noPic $ baseRifleShape <> makeSingleClipAt (V3 5 0 3) it - REPEATER -> noPic $ baseRifleShape <> makeTinClipAt 0 (V3 10 (-2) 0) it - AUTORIFLE -> noPic $ baseRifleShape <> makeTinClipAt 0 (V3 10 (-2) 0) it - BURSTRIFLE -> noPic $ baseRifleShape <> makeTinClipAt 0 (V3 10 (-2) 0) it - BANGROD -> noPic $ baseRodShape <> makeSingleClipAt (V3 5 0 3) it - ELEPHANTGUN -> noPic $ baseAMRShape <> makeSingleClipAt (V3 5 0 3) it - AMR -> noPic $ baseAMRShape <> makeTinClipAt 0 (V3 10 (-2) 0) it - AUTOAMR -> noPic $ baseAMRShape <> makeTinClipAt 0 (V3 10 (-2) 0) it - SNIPERRIFLE -> noPic $ baseAMRShape <> makeSingleClipAt (V3 5 0 3) it - MACHINEGUN -> noPic $ baseAMRShape <> makeTinClipAt 0 (V3 10 (-2) 0) it - FLAMESPITTER -> flamerPic it - FLAMETHROWER -> flamerPic it - FLAMETORRENT -> flamerPic it - FLAMEWALL -> flamerPic it - BLOWTORCH -> flamerPic it - SPARKGUN -> teslaGunPic - TESLAGUN -> teslaGunPic - LASGUN -> lasGunPic it - LASCIRCLE -> lasGunPic it - DUALBEAM -> dualBeamPic it - LASWIDE _ -> lasGunPic it + FORCEFIELDGUN -> defSPic + TORCH -> noPic torchShape + BANGSTICK i -> noPic $ baseStickShapeX it i <> stickClip it + PISTOL -> noPic $ baseStickShape <> makeTinClipAt pi (V3 5 2 0) it + REVOLVER -> noPic $ baseStickShape <> revolverClip it + REVOLVERX _ -> noPic $ baseStickShape <> revolverClip it + MACHINEPISTOL -> noPic $ baseStickShape <> makeTinClipAt pi (V3 5 2 0) it + AUTOPISTOL -> noPic $ baseStickShape <> makeTinClipAt pi (V3 5 2 0) it + SMG -> noPic (baseSMGShape <> makeTinClipAt 0 (V3 7 (-2) 0) it) + BANGCONE -> + noPic $ + colorSH cyan $ + upperPrismPoly 3 (rectXH 5 2) + <> upperPrismPoly 6 (reverse $ rectNSWE 4 (-4) 5 15) + BLUNDERBUSS -> + noPic $ + colorSH cyan $ + upperPrismPoly 3 (rectXH 20 2) + <> upperPrismPoly 6 (reverse $ rectNSWE 4 (-4) 20 30) + GRAPECANNON _ -> + noPic $ + colorSH cyan $ + upperPrismPoly 3 (rectXH 20 2) + <> upperPrismPoly 6 (reverse $ rectNSWE 4 (-4) 20 30) + MINIGUNX i -> miniGunXPictItem i it + VOLLEYGUN i -> volleyGunSPic i it + RIFLE -> noPic $ baseRifleShape <> makeSingleClipAt (V3 5 0 3) it + REPEATER -> noPic $ baseRifleShape <> makeTinClipAt 0 (V3 10 (-2) 0) it + AUTORIFLE -> noPic $ baseRifleShape <> makeTinClipAt 0 (V3 10 (-2) 0) it + BURSTRIFLE -> noPic $ baseRifleShape <> makeTinClipAt 0 (V3 10 (-2) 0) it + BANGROD -> noPic $ baseRodShape <> makeSingleClipAt (V3 5 0 3) it + ELEPHANTGUN -> noPic $ baseAMRShape <> makeSingleClipAt (V3 5 0 3) it + AMR -> noPic $ baseAMRShape <> makeTinClipAt 0 (V3 10 (-2) 0) it + AUTOAMR -> noPic $ baseAMRShape <> makeTinClipAt 0 (V3 10 (-2) 0) it + SNIPERRIFLE -> noPic $ baseAMRShape <> makeSingleClipAt (V3 5 0 3) it + MACHINEGUN -> noPic $ baseAMRShape <> makeTinClipAt 0 (V3 10 (-2) 0) it + FLAMESPITTER -> flamerPic it + FLAMETHROWER -> flamerPic it + FLAMETORRENT -> flamerPic it + FLAMEWALL -> flamerPic it + BLOWTORCH -> flamerPic it + SPARKGUN -> teslaGunPic + TESLAGUN -> teslaGunPic + LASGUN -> lasGunPic it + LASCIRCLE -> lasGunPic it + DUALBEAM -> dualBeamPic it + LASWIDE _ -> lasGunPic it --SONICGUN -> noPic baseSonicShape - TRACTORGUN -> tractorGunPic it - LAUNCHER -> launcherPic it - LAUNCHERX _ -> launcherPic it - REMOTELAUNCHER -> launcherPic it - POISONSPRAYER -> flamerPic it - DRONELAUNCHER -> defSPic - SHATTERGUN -> shatterGunSPic + TRACTORGUN -> tractorGunPic it + LAUNCHER -> launcherPic it + LAUNCHERX _ -> launcherPic it + REMOTELAUNCHER -> launcherPic it + POISONSPRAYER -> flamerPic it + DRONELAUNCHER -> defSPic + SHATTERGUN -> shatterGunSPic HELDDETECTOR dt -> noPic (colorSH (detectorColor dt) $ upperPrismPoly 3 $ rectWH 2 2) - KEYCARD _ -> noShape (setDepth 0 $ translate (-5) (-5) $ rotate (pi/2.5) keyPic) + KEYCARD _ -> noShape (setDepth 0 $ translate (-5) (-5) $ rotate (pi / 2.5) keyPic) torchShape :: Shape -torchShape = colorSH blue - $ translateSHf 0 1.5 side - <> translateSHf 0 (-1.5) side - <> translateSHz 2.5 top - <> translateSHz (-0.5) bot - <> back +torchShape = + colorSH blue $ + translateSHf 0 1.5 side + <> translateSHf 0 (-1.5) side + <> translateSHz 2.5 top + <> translateSHz (-0.5) bot + <> back where side = upperPrismPoly 3 $ rectXH 10 0.5 - top = upperPrismPoly 0.5 $ rectXH 10 2 - bot = upperPrismPoly 0.5 $ rectXH 9 2 + top = upperPrismPoly 0.5 $ rectXH 10 2 + bot = upperPrismPoly 0.5 $ rectXH 9 2 back = upperPrismPoly 3 $ rectXH 1 2 - modulesSPic :: Item -> ItemModuleType -> SPic modulesSPic it imt = case imt of ATTACHTORCH -> noPic (overPosSH (+.+.+ _dimAttachPos (_itDimension it)) torchShape) _ -> mempty baseStickShapeX :: Item -> Int -> Shape -baseStickShapeX it i = foldMap f [0..i-1] +baseStickShapeX it i = foldMap f [0 .. i -1] where f j = rotateSH ang baseStickShape where @@ -125,22 +144,25 @@ baseStickShape = colorSH green $ upperPrismPoly 3 $ rectXH 10 2 stickClip :: Item -> Shape stickClip it = case it ^? itUse . heldConsumption . laLoaded of - Just x | x > 0 -> foldMap f [0..x-1] + Just x | x > 0 -> foldMap f [0 .. x -1] _ -> mempty where f i = rotateSH ang $ translateSH (V3 5 0 3) $ upperPrismPoly 2 $ square 1.5 where - ang = barrelspread * fromIntegral i - - 0.5 * barrelspread * fromIntegral (_brlNum (_gunBarrels (_itParams it))-1) + ang = + barrelspread * fromIntegral i + - 0.5 * barrelspread * fromIntegral (_brlNum (_gunBarrels (_itParams it)) -1) barrelspread = it ^?! itParams . gunBarrels . brlSpread . spreadAngle defSPic :: SPic defSPic = noPic $ colorSH green $ upperPrismPoly 3 $ square 4 shatterGunSPic :: SPic -shatterGunSPic = noPic $ colorSH blue $ - upperPrismPoly 5 (rectNESW xb 8 xa 0) - <> upperPrismPoly 5 (rectNESW (-xa) 8 (-xb) 0) +shatterGunSPic = + noPic $ + colorSH blue $ + upperPrismPoly 5 (rectNESW xb 8 xa 0) + <> upperPrismPoly 5 (rectNESW (- xa) 8 (- xb) 0) where xa = 1 xb = 9 @@ -160,48 +182,60 @@ makeSingleClipAt p it = case it ^? itUse . heldConsumption . laLoaded of _ -> translateSH p $ upperPrismPoly 1 $ square 1.5 makeTinClipAt :: Float -> Point3 -> Item -> Shape -makeTinClipAt r p it = translateSH p . overPosSH (rotate3z r) $ upperPrismPoly 1 $ reverse - $ rectNSWE 0 (-y) (-2) 2 +makeTinClipAt r p it = + translateSH p . overPosSH (rotate3z r) $ + upperPrismPoly 1 $ + reverse $ + rectNSWE 0 (- y) (-2) 2 where y = fromIntegral y' * 0.3 y' = fromMaybe 0 $ it ^? itUse . heldConsumption . laLoaded volleyGunSPic :: Int -> Item -> SPic -volleyGunSPic i it = noPic $ - colorSH red (foldMap - ((\y -> upperPrismPoly 3 $ map (+.+ V2 0 y) $ rectXH 15 2) - . (\k -> fromIntegral k * 5 - ((fromIntegral i - 1) * 2.5))) [0..i-1] - ) <> caneClipX i it - +volleyGunSPic i it = + noPic $ + colorSH + red + ( foldMap + ( (\y -> upperPrismPoly 3 $ map (+.+ V2 0 y) $ rectXH 15 2) + . (\k -> fromIntegral k * 5 - ((fromIntegral i - 1) * 2.5)) + ) + [0 .. i -1] + ) + <> caneClipX i it caneClipX :: Int -> Item -> Shape -caneClipX i it = case it ^? itUse . heldConsumption . laLoaded of - Just la | la > 0 -> foldMap - ( (\y -> translateSH (V3 5 0 3) . upperPrismPoly 1 $ map (+.+ V2 0 y) $ square 1.5) - . (\k -> fromIntegral k * 5 - ((fromIntegral i - 1) * 2.5))) - [0..la-1] +caneClipX i it = case it ^? itUse . heldConsumption . laLoaded of + Just la + | la > 0 -> + foldMap + ( (\y -> translateSH (V3 5 0 3) . upperPrismPoly 1 $ map (+.+ V2 0 y) $ square 1.5) + . (\k -> fromIntegral k * 5 - ((fromIntegral i - 1) * 2.5)) + ) + [0 .. la -1] _ -> mempty miniGunXPictItem :: Int -> Item -> SPic miniGunXPictItem i it = miniGunXPict i spin (_laLoaded $ _heldConsumption (_itUse it)) where - spin = (-10) * _laLoaded (_heldConsumption (_itUse it)) + _warmTime (_useDelay $ _itUse it) + spin = (-10) * _laLoaded (_heldConsumption (_itUse it)) + _warmTime (_heldDelay $ _itUse it) miniGunXPict :: Int -> Int -> Int -> SPic -miniGunXPict i spin _ = - ( colorSH red (rotateSHx a barrels) +miniGunXPict i spin _ = + ( colorSH red (rotateSHx a barrels) <> baseRifleShape --- <> clip (-1) 0 --- <> clip (-7) 0 - , mempty + , -- <> clip (-1) 0 + -- <> clip (-7) 0 + mempty ) where aBarrel = translateSH (V3 15 2 2) baseCaneShape - barrels = foldMap (\an -> aBarrel & rotateSHx (2*pi * fromIntegral an / fromIntegral i)) [1..i] + barrels = foldMap (\an -> aBarrel & rotateSHx (2 * pi * fromIntegral an / fromIntegral i)) [1 .. i] a = fromIntegral spin / 100 - --x = fromIntegral am / 10 --- clip y z = translateSH (V3 0 (-1) z) (rotateSHx (negate $ pi/4) --- . upperPrismPoly 2 + +--x = fromIntegral am / 10 +-- clip y z = translateSH (V3 0 (-1) z) (rotateSHx (negate $ pi/4) +-- . upperPrismPoly 2 -- $ rectNESW (negate $ 3 + 0.25 * x) y 3 (y-5)) baseSonicShape :: Shape @@ -209,20 +243,20 @@ baseSonicShape = colorSH rose $ upperPrismPoly 3 $ rectXH 25 2 revolverClip :: Item -> Shape revolverClip it = case it ^? itUse . heldConsumption . laLoaded of - Just al | al > 0 -> translateSH (V3 5 0 1) $ foldMap f [1..al] + Just al | al > 0 -> translateSH (V3 5 0 1) $ foldMap f [1 .. al] _ -> mempty where - f i = rotateSHx (fromIntegral i * pi / 3 + pi/6) . translateSH (V3 0 0 2) $ upperPrismPoly 1 $ square 1 + f i = rotateSHx (fromIntegral i * pi / 3 + pi / 6) . translateSH (V3 0 0 2) $ upperPrismPoly 1 $ square 1 baseSMGShape :: Shape baseSMGShape = colorSH green $ upperPrismPoly 3 $ rectXH 20 2 flamerPic :: Item -> SPic -flamerPic it = - ( colorSH yellow $ +flamerPic it = + ( colorSH yellow $ translateSHf tx ty (upperPrismPoly tz $ polyCirc 3 r) - <> upperPrismPoly 5 (rectNESW 2 18 (-2) 0) - , color black $ translate3 (V3 tx ty (tz+0.01)) $ circleSolid (r * am) + <> upperPrismPoly 5 (rectNESW 2 18 (-2) 0) + , color black $ translate3 (V3 tx ty (tz + 0.01)) $ circleSolid (r * am) ) where tx = 4 @@ -232,94 +266,104 @@ flamerPic it = am = fractionLoadedAmmo2 it launcherPic :: Item -> SPic -launcherPic _ = - ( colorSH cyan $ prismPoly - (map (+.+.+ V3 20 0 5) $ polyCircx 4 5) - (map (+.+.+ V3 0 0 5) $ polyCircx 4 5) +launcherPic _ = + ( colorSH cyan $ + prismPoly + (map (+.+.+ V3 20 0 5) $ polyCircx 4 5) + (map (+.+.+ V3 0 0 5) $ polyCircx 4 5) , mempty ) baseRodShape :: Shape baseRodShape = colorSH orange $ upperPrismPoly 3 $ rectXH 20 2 + baseAMRShape :: Shape baseAMRShape = colorSH orange $ upperPrismPoly 3 $ rectXH 30 2 teslaGunPic :: SPic -teslaGunPic = noPic $ colorSH blue $ - upperPrismPoly 5 (rectNESW xb 8 xa 0) - <> upperPrismPoly 5 (rectNESW (-xa) 8 (-xb) 0) +teslaGunPic = + noPic $ + colorSH blue $ + upperPrismPoly 5 (rectNESW xb 8 xa 0) + <> upperPrismPoly 5 (rectNESW (- xa) 8 (- xb) 0) where xa = 1 xb = 9 lasGunPic :: Item -> SPic -lasGunPic it = - ( colorSH blue $ - upperPrismPoly 4 (rectNESW 3 30 1 0) - <> upperPrismPoly 4 (rectNESW (-1) 30 (-3) 0) - <> upperPrismPoly 1 (rectNESW 3 30 (-3) 0) +lasGunPic it = + ( colorSH blue $ + upperPrismPoly 4 (rectNESW 3 30 1 0) + <> upperPrismPoly 4 (rectNESW (-1) 30 (-3) 0) + <> upperPrismPoly 1 (rectNESW 3 30 (-3) 0) , setLayer BloomNoZWrite . color col . setDepth 1.1 . polygon $ rectNESW 1 30 (-1) 0 ) where amFrac = fractionLoadedAmmo it - col = brightX 2 1.5 $ mixColors amFrac (1-amFrac) green red + col = brightX 2 1.5 $ mixColors amFrac (1 - amFrac) green red dualBeamPic :: Item -> SPic -dualBeamPic it = - ( colorSH blue $ - upperPrismPoly 4 (rectNESW gap 3 (-gap) 1) - <> upperPrismPoly 4 (rectNESW gap (-1) (-gap) (-3)) - <> upperPrismPoly 1 (rectNESW gap 3 (-gap) (-3)) - , setLayer BloomNoZWrite . color col . setDepth 1.1 . polygon $ rectNESW gap 1 (-gap) (-1) +dualBeamPic it = + ( colorSH blue $ + upperPrismPoly 4 (rectNESW gap 3 (- gap) 1) + <> upperPrismPoly 4 (rectNESW gap (-1) (- gap) (-3)) + <> upperPrismPoly 1 (rectNESW gap 3 (- gap) (-3)) + , setLayer BloomNoZWrite . color col . setDepth 1.1 . polygon $ rectNESW gap 1 (- gap) (-1) ) where amFrac = fractionLoadedAmmo it - col = brightX 2 1.5 $ mixColors amFrac (1-amFrac) green red + col = brightX 2 1.5 $ mixColors amFrac (1 - amFrac) green red gap = _dbGap (_itParams it) - 3 tractorGunPic :: Item -> SPic -tractorGunPic it = - ( colorSH red $ - upperPrismPoly 4 (rectNESW 3 30 1 0) - <> upperPrismPoly 4 (rectNESW (-1) 30 (-3) 0) - <> upperPrismPoly 1 (rectNESW 3 30 (-3) 0) +tractorGunPic it = + ( colorSH red $ + upperPrismPoly 4 (rectNESW 3 30 1 0) + <> upperPrismPoly 4 (rectNESW (-1) 30 (-3) 0) + <> upperPrismPoly 1 (rectNESW 3 30 (-3) 0) , setLayer BloomNoZWrite . color col . setDepth 1.1 . polygon $ rectNESW 1 30 (-1) 0 ) where amFrac = fractionLoadedAmmo it - col = brightX 2 1.5 $ mixColors amFrac (1-amFrac) green red + col = brightX 2 1.5 $ mixColors amFrac (1 - amFrac) green red flatShieldEquipSPic :: SPic -flatShieldEquipSPic = +flatShieldEquipSPic = ( colorSH yellow $ upperPrismPoly 10 (rectWH 2 10) , mempty ) headLampShape :: Shape -headLampShape = colorSH yellow $ - translateSH (V3 5 2 4) (upperPrismPoly 4 $ rectWH 4 1) - <> translateSH (V3 5 2 0) (upperPrismPoly 4 $ rectWH 4 1) - <> translateSH (V3 5 (-2) 4) (upperPrismPoly 4 $ rectWH 4 1) - <> translateSH (V3 5 (-2) 0) (upperPrismPoly 4 $ rectWH 4 1) +headLampShape = + colorSH yellow $ + translateSH (V3 5 2 4) (upperPrismPoly 4 $ rectWH 4 1) + <> translateSH (V3 5 2 0) (upperPrismPoly 4 $ rectWH 4 1) + <> translateSH (V3 5 (-2) 4) (upperPrismPoly 4 $ rectWH 4 1) + <> translateSH (V3 5 (-2) 0) (upperPrismPoly 4 $ rectWH 4 1) detectorColor :: Detector -> Color detectorColor dt = case dt of - ITEMDETECTOR -> blue - CREATUREDETECTOR -> green - WALLDETECTOR -> red + ITEMDETECTOR -> blue + CREATUREDETECTOR -> green + WALLDETECTOR -> red keyPic :: Picture -keyPic = color green $ - pictures [translate (-4) 0 $ thickCircle 4 2 - ,thickLine 2 $ map toV2 [(0,0),(8,0),(8,-4)] - ,thickLine 2 $ map toV2 [(4,0),(4,-4)] - ] +keyPic = + color green $ + pictures + [ translate (-4) 0 $ thickCircle 4 2 + , thickLine 2 $ map toV2 [(0, 0), (8, 0), (8, -4)] + , thickLine 2 $ map toV2 [(4, 0), (4, -4)] + ] latchkeyPic :: Picture -latchkeyPic = color yellow $ - pictures [translate (-4) 0 $ thickCircle 4 2 - ,thickLine 2 $ map toV2 [(0,0),(8,0),(8,-4)] - ,thickLine 2 $ map toV2 [(4,0),(4,-4)] - ] +latchkeyPic = + color yellow $ + pictures + [ translate (-4) 0 $ thickCircle 4 2 + , thickLine 2 $ map toV2 [(0, 0), (8, 0), (8, -4)] + , thickLine 2 $ map toV2 [(4, 0), (4, -4)] + ] + legsSPic :: Color -> SPic legsSPic col = noPic $ translateSH (V3 0 4 0) $ colorSH col $ upperPrismPoly 3 $ rectWH 2 2 diff --git a/src/Dodge/Item/Equipment.hs b/src/Dodge/Item/Equipment.hs index 3a0533cd7..8c1080718 100644 --- a/src/Dodge/Item/Equipment.hs +++ b/src/Dodge/Item/Equipment.hs @@ -1,6 +1,5 @@ module Dodge.Item.Equipment ( module Dodge.Item.Equipment.Booster, - torch, magShield, powerLegs, wristInvisibility, @@ -25,68 +24,61 @@ magShield :: Item magShield = defaultEquipment & itParams .~ MagShieldParams Nothing - & itUse . eqEq . eqUse .~ EMagShield - & itUse . eqEq . eqSite .~ GoesOnWrist + & itUse . equipEffect . eeUse .~ EMagShield + & itUse . equipEffect . eeSite .~ GoesOnWrist & itType . iyBase .~ EQUIP MAGSHIELD flameShield :: Item flameShield = defaultEquipment - & itUse . eqEq . eqSite .~ GoesOnChest + & itUse . equipEffect . eeSite .~ GoesOnChest & itType . iyBase .~ EQUIP FLAMESHIELD frontArmour :: Item frontArmour = defaultEquipment - & itUse . eqEq . eqSite .~ GoesOnChest + & itUse . equipEffect . eeSite .~ GoesOnChest & itType . iyBase .~ EQUIP FRONTARMOUR wristArmour :: Item wristArmour = defaultEquipment - & itUse . eqEq . eqSite .~ GoesOnWrist - & itUse . eqEq . eqOnEquip .~ EonWristShield - & itUse . eqEq . eqUse .~ EWristShield - & itUse . eqEq . eqOnRemove .~ EoffWristShield + & itUse . equipEffect . eeSite .~ GoesOnWrist + & itUse . equipEffect . eeOnEquip .~ EonWristShield + & itUse . equipEffect . eeUse .~ EWristShield + & itUse . equipEffect . eeOnRemove .~ EoffWristShield & itType . iyBase .~ EQUIP WRISTARMOUR -torch :: Item -torch = - defaultWeapon - & itEffect . ieInv .~ EffectWhileHeld CreateHeldLight - & itType . iyBase .~ HELD TORCH - & itUse . useAim . aimHandlePos .~ 5 - & itUse . useAim . aimMuzPos .~ 10 jetPack :: Item jetPack = defaultEquipment - & itUse . eqEq . eqSite .~ GoesOnBack + & itUse . equipEffect . eeSite .~ GoesOnBack & itType . iyBase .~ EQUIP JETPACK brainHat :: Item brainHat = defaultEquipment - & itUse . eqEq . eqSite .~ GoesOnHead + & itUse . equipEffect . eeSite .~ GoesOnHead & itType . iyBase .~ EQUIP BRAINHAT hat :: Item hat = defaultEquipment - & itUse . eqEq . eqSite .~ GoesOnHead + & itUse . equipEffect . eeSite .~ GoesOnHead & itType . iyBase .~ EQUIP HAT headLamp :: Item headLamp = defaultEquipment - & itUse . eqEq . eqUse .~ EHeadLamp - & itUse . eqEq . eqSite .~ GoesOnHead + & itUse . equipEffect . eeUse .~ EHeadLamp + & itUse . equipEffect . eeSite .~ GoesOnHead & itType . iyBase .~ EQUIP HEADLAMP powerLegs :: Item powerLegs = defaultEquipment - & itUse . eqEq . eqSite .~ GoesOnLegs + & itUse . equipEffect . eeSite .~ GoesOnLegs & itType . iyBase .~ EQUIP POWERLEGS speedLegs :: Item @@ -102,7 +94,7 @@ jumpLegs = wristInvisibility :: Item wristInvisibility = defaultEquipment - & itUse . eqEq . eqSite .~ GoesOnWrist - & itUse . eqEq . eqOnEquip .~ ECamouflage Invisible --overCID (crCamouflage .~ Invisible) - & itUse . eqEq . eqOnRemove .~ ECamouflage FullyVisible --overCID (crCamouflage .~ FullyVisible) + & itUse . equipEffect . eeSite .~ GoesOnWrist + & itUse . equipEffect . eeOnEquip .~ ECamouflage Invisible --overCID (crCamouflage .~ Invisible) + & itUse . equipEffect . eeOnRemove .~ ECamouflage FullyVisible --overCID (crCamouflage .~ FullyVisible) & itType . iyBase .~ EQUIP (INVISIBILITYEQUIPMENT GoesOnWrist) diff --git a/src/Dodge/Item/Equipment/Booster.hs b/src/Dodge/Item/Equipment/Booster.hs index b0a59032e..3f4a78dd3 100644 --- a/src/Dodge/Item/Equipment/Booster.hs +++ b/src/Dodge/Item/Equipment/Booster.hs @@ -4,17 +4,11 @@ module Dodge.Item.Equipment.Booster ( import Control.Lens import Dodge.Data.Item -import Dodge.Default.Weapon -import Picture +import Dodge.Default.Item boosterGun :: Item boosterGun = defaultLeftItem - { _itInvColor = cyan - , _itUse = luseInstantNoH LBoost --- , _itEffect = resetAttachmentID - } + & itUse . leftUse .~ LBoost + & itUse . leftDelay .~ NoDelay & itType . iyBase .~ LEFT BOOSTER - ---resetAttachmentID :: ItEffect ---resetAttachmentID = ItInvEffect ResetAttachmentEffect 0 diff --git a/src/Dodge/Item/Equipment/Shape.hs b/src/Dodge/Item/Equipment/Shape.hs index 43c86f161..97dc1d844 100644 --- a/src/Dodge/Item/Equipment/Shape.hs +++ b/src/Dodge/Item/Equipment/Shape.hs @@ -1,23 +1,24 @@ module Dodge.Item.Equipment.Shape where -import Dodge.Data -import Dodge.Creature.HandPos -import ShapePicture -import LensHelp import Data.Maybe +import Dodge.Creature.HandPos +import Dodge.Data.Creature +import LensHelp +import ShapePicture pictureOnEquip :: SPic -> Creature -> Item -> SPic pictureOnEquip sp cr itm = fromMaybe mempty $ do i <- itm ^? itLocation . ipInvID - epos <- cr^? crInvEquipped . ix i + epos <- cr ^? crInvEquipped . ix i return $ equipPosition epos cr sp equipPosition :: EquipPosition -> Creature -> SPic -> SPic equipPosition epos cr sh = case epos of OnLeftWrist -> translateToLeftWrist cr sh OnRightWrist -> translateToRightWrist cr sh - OnLegs -> translateToLeftLeg cr sh <> - translateToRightLeg cr (mirrorSPxz sh) + OnLegs -> + translateToLeftLeg cr sh + <> translateToRightLeg cr (mirrorSPxz sh) OnHead -> translateToHead cr sh OnChest -> translateToChest cr sh OnBack -> translateToBack cr sh diff --git a/src/Dodge/Item/Held.hs b/src/Dodge/Item/Held.hs index 8afc184f9..634972b3e 100644 --- a/src/Dodge/Item/Held.hs +++ b/src/Dodge/Item/Held.hs @@ -1,24 +1,71 @@ -module Dodge.Item.Held - where -import Dodge.Default.Weapon -import Dodge.Data.Item -import Control.Lens -flatShield :: Item -flatShield = - defaultWeapon - & itEffect . ieInv .~ EffectIfHeld CreateShieldWall RemoveShieldWall - & itUse - .~ defaultrUse - { _useAim = - AimParams - { _aimWeight = 5 - , _aimRange = 0 - , _aimZoom = ItZoom 20 0.2 1 - , _aimStance = TwoHandFlat - , _aimHandlePos = 0 - , _aimMuzPos = 0 - } - } - & itInvSize .~ 3 - & itType . iyBase .~ HELD FLATSHIELD +module Dodge.Item.Held ( + module Dodge.Item.Held, + module Dodge.Item.Held.Utility, + module Dodge.Item.Held.Launcher, + module Dodge.Item.Held.Weapons, + module Dodge.Item.Held.Stick, + module Dodge.Item.Held.Cone, + module Dodge.Item.Held.Cane, + module Dodge.Item.Held.Rod, + module Dodge.Item.Held.SprayGuns, + module Dodge.Item.Held.BatteryGuns, +) where +import Dodge.Data.Item +import Dodge.Item.Held.Launcher +import Dodge.Item.Held.BatteryGuns +import Dodge.Item.Held.Utility +import Dodge.Item.Held.Weapons +import Dodge.Item.Held.Stick +import Dodge.Item.Held.Cone +import Dodge.Item.Held.Cane +import Dodge.Item.Held.Rod +import Dodge.Item.Held.SprayGuns + +itemFromHeldType :: HeldItemType -> Item +itemFromHeldType ht = case ht of + KEYCARD i -> keyCard i + TORCH -> torch + SHATTERGUN -> shatterGun + BANGSTICK i -> bangStick i + PISTOL -> pistol + REVOLVER -> revolver + REVOLVERX i -> revolverX i + MACHINEPISTOL -> machinePistol + AUTOPISTOL -> autoPistol + SMG -> smg + BANGCONE -> bangCone + BLUNDERBUSS -> blunderbuss + GRAPECANNON i -> grapeCannon i + MINIGUNX i -> miniGunX i + VOLLEYGUN i -> volleyGun i + RIFLE -> rifle + REPEATER -> repeater + AUTORIFLE -> autoRifle + BURSTRIFLE -> burstRifle + BANGROD -> bangRod + ELEPHANTGUN -> elephantGun + AMR -> amr + AUTOAMR -> autoAmr + SNIPERRIFLE -> sniperRifle + MACHINEGUN -> machineGun + FLAMESPITTER -> flameSpitter + FLAMETHROWER -> flameThrower + FLAMETORRENT -> flameTorrent + FLAMEWALL -> flameWall + BLOWTORCH -> blowTorch + SPARKGUN -> sparkGun + TESLAGUN -> teslaGun + LASGUN -> lasGun + LASCIRCLE -> lasCircle + DUALBEAM -> dualBeam + LASWIDE i -> lasWide i + TRACTORGUN -> tractorGun + LAUNCHER -> launcher + LAUNCHERX i -> launcherX i + REMOTELAUNCHER -> remoteLauncher + POISONSPRAYER -> poisonSprayer + DRONELAUNCHER -> undefined + FORCEFIELDGUN -> forceFieldGun + HELDDETECTOR d -> clickDetector d + FLATSHIELD -> flatShield diff --git a/src/Dodge/Item/Held/BatteryGuns.hs b/src/Dodge/Item/Held/BatteryGuns.hs new file mode 100644 index 000000000..6b4e57482 --- /dev/null +++ b/src/Dodge/Item/Held/BatteryGuns.hs @@ -0,0 +1,170 @@ +module Dodge.Item.Held.BatteryGuns where + +import Dodge.Data.Beam +import Dodge.Default.Item +import Color +import Control.Lens +import qualified Data.Map.Strict as M +import Dodge.Data.Item +import Dodge.Reloading.Action +import Dodge.Tesla.ItemParams +import Geometry.Data +import qualified IntMapHelp as IM + +sparkGun :: Item +sparkGun = + teslaGun + & itType . iyBase .~ HELD SPARKGUN + & itParams . arcSize .~ 10 + +teslaGun :: Item +teslaGun = + defaultBatteryGun + & itUse . heldConsumption . laMax .~ 200 + & itUse . heldConsumption . laCycle .~ [loadEject 10, loadInsert 10, loadPrime 60] + & itDimension . dimRad .~ 9 + & itDimension . dimCenter .~ V3 4 0 0 + & itParams .~ teslaParams + & itUse . heldUse .~ HeldTeslaArc --shootTeslaArc + & itUse . heldDelay .~ NoDelay + & itUse . heldMods .~ TeslaMod + & itUse . heldAim . aimWeight .~ 6 + & itUse . heldAim . aimStance .~ TwoHandFlat + & itUse . heldAim . aimHandlePos .~ 4 + & itUse . heldAim . aimMuzPos .~ 4 + & itType . iyBase .~ HELD TESLAGUN + +lasGun :: Item +lasGun = + defaultAutoBatteryGun + & itUse . heldConsumption + .~ ( defaultLoadable + & laMax .~ 200 + & laCycle .~ [loadEject 10, loadInsert 10, loadPrime 60] + ) + & itParams + .~ Refracting + { _phaseV = 1 + , _lasColor = yellow + , _lasColor2 = yellow + , _lasCycle = 0 + , _lasDamage = 11 + } + & itTweaks + .~ Tweakable + { _tweakParams = IM.fromList [(0, lasGunTweak)] + } + & itDimension . dimRad .~ 10 + & itDimension . dimCenter .~ V3 15 0 0 + & itUse . heldUse .~ HeldLaser --shootLaser + & itUse . heldDelay .~ NoDelay + & itUse . heldMods .~ LasMod + & itUse . heldAim . aimWeight .~ 6 + & itUse . heldAim . aimRange .~ 1 + & itUse . heldAim . aimStance .~ TwoHandTwist + & itUse . heldAim . aimHandlePos .~ 5 + & itUse . heldAim . aimMuzPos .~ 30 + & itType . iyBase .~ HELD LASGUN + +lasGunTweak :: TweakParam +lasGunTweak = + TweakParam + { _tweakType = TweakPhaseV + , _tweakVal = 1 + , _tweakMax = 3 + } + +tractorGun :: Item +tractorGun = + lasGun + & itUse . heldConsumption + .~ ( defaultLoadable + & laMax .~ 10000 + & laCycle .~ [loadEject 10, loadInsert 10, loadPrime 60] + ) + & itParams .~ Attracting{_attractionPower = 1} + & itTweaks + .~ Tweakable + { _tweakParams = IM.fromList [(0, tractorGunTweak)] + } + & itUse . heldUse .~ HeldTractor --aTractorBeam + & itUse . heldDelay .~ NoDelay + & itUse . heldMods .~ AmmoCheckMod + & itUse . heldAim . aimWeight .~ 6 + & itUse . heldAim . aimRange .~ 1 + & itUse . heldAim . aimStance .~ TwoHandTwist + & itUse . heldAim . aimHandlePos .~ 5 + & itUse . heldAim . aimMuzPos .~ 30 + & itType . iyBase .~ HELD TRACTORGUN + +tractorGunTweak :: TweakParam +tractorGunTweak = + TweakParam + { _tweakType = TweakTractionPower + , _tweakVal = 1 + , _tweakMax = 4 + } + +lasWide :: Int -> Item +lasWide n = + lasGun + & itType . iyBase .~ HELD (LASWIDE n) + & itParams . lasColor .~ yellow + & itParams . lasDamage .~ 2 + & itUse . heldMods .~ LasWideMod n + +defaultBatteryGun :: Item +defaultBatteryGun = + defaultHeldItem + & itType . iyModules .~ batteryModules + +batteryModules :: M.Map ModuleSlot ItemModuleType +batteryModules = + M.fromList + [ (ModBattery, EMPTYMODULE) + , (ModTeleport, EMPTYMODULE) + ] + +defaultAutoBatteryGun :: Item +defaultAutoBatteryGun = + defaultHeldItem + & itType . iyModules .~ batteryModules + +lasCircle :: Item +lasCircle = + lasGun + & itType . iyBase .~ HELD LASCIRCLE + & itParams . lasColor .~ orange + & itParams . lasDamage .~ 2 + & itUse . heldConsumption . laMax .~ 10000 + & itUse . heldUse .~ HeldLaser --shootLaser + & itUse . heldDelay .~ NoDelay + & itUse . heldUse .~ HeldCircleLaser --circleLaser + & itUse . heldMods .~ CircleLaserMod + & itUse . heldAim . aimWeight .~ 6 + & itUse . heldAim . aimRange .~ 1 + & itUse . heldAim . aimStance .~ TwoHandTwist + +dualBeam :: Item +dualBeam = + lasGun + & itType . iyBase .~ HELD DUALBEAM + & itUse . heldAim . aimMuzPos .~ 0 + & itParams + .~ DualBeam + { _phaseV = 1 + , _lasColor = red + , _lasColor2 = green + , _lasCycle = 0 + , _lasDamage = 11 + , _lasBeam = BeamCombine LasBeamCombine + , _subParams = Nothing + , _dbGap = 20 + } + & itUse . heldUse .~ HeldDualLaser --shootDualLaser + & itUse . heldDelay .~ NoDelay + & itUse . heldMods .~ DualBeamMod + & itUse . heldAim . aimWeight .~ 6 + & itUse . heldAim . aimRange .~ 1 + & itUse . heldAim . aimStance .~ TwoHandFlat + & itType . iyModules . at ModDualBeam ?~ EMPTYMODULE diff --git a/src/Dodge/Item/Held/BulletGun.hs b/src/Dodge/Item/Held/BulletGun.hs new file mode 100644 index 000000000..992514aed --- /dev/null +++ b/src/Dodge/Item/Held/BulletGun.hs @@ -0,0 +1,3 @@ +module Dodge.Item.Held.BulletGun + where + diff --git a/src/Dodge/Item/Weapon/BulletGun/Cane.hs b/src/Dodge/Item/Held/Cane.hs similarity index 70% rename from src/Dodge/Item/Weapon/BulletGun/Cane.hs rename to src/Dodge/Item/Held/Cane.hs index 64b58b4e8..6b9dfd691 100644 --- a/src/Dodge/Item/Weapon/BulletGun/Cane.hs +++ b/src/Dodge/Item/Held/Cane.hs @@ -1,4 +1,4 @@ -module Dodge.Item.Weapon.BulletGun.Cane ( +module Dodge.Item.Held.Cane ( volleyGun, repeater, rifle, @@ -7,10 +7,10 @@ module Dodge.Item.Weapon.BulletGun.Cane ( miniGunX, ) where -import Dodge.Data +import Dodge.Data.Item import Dodge.Default import Dodge.Reloading.Action -import Geometry +import Geometry.Data import LensHelp defaultBangCane :: Item @@ -31,26 +31,25 @@ defaultBangCane = } & itDimension . dimRad .~ 8 & itDimension . dimCenter .~ V3 5 0 0 - & itUse . useDelay . rateMax .~ 6 - & itUse . useMods .~ BangCaneMod - & itUse . useAim . aimStance .~ OneHand - & itUse . useAim . aimHandlePos .~ 5 - & itUse . useAim . aimMuzPos .~ 15 - & itType . iyBase .~ error "undefined bangCane baseitemtype" + & itUse . heldDelay . rateMax .~ 6 + & itUse . heldMods .~ BangCaneMod + & itUse . heldAim . aimStance .~ OneHand + & itUse . heldAim . aimHandlePos .~ 5 + & itUse . heldAim . aimMuzPos .~ 15 & itUse . heldConsumption . laMax .~ 1 & itUse . heldConsumption . laCycle .~ [loadPartialInsert 10 1] volleyGun :: Int -> Item volleyGun i = defaultBangCane - & itUse . useDelay . rateMax .~ 6 - & itUse . useMods .~ VolleyGunMod - & itUse . useAim . aimWeight .~ 6 - & itUse . useAim . aimRange .~ 1 - & itUse . useAim . aimStance .~ TwoHandFlat - & itUse . useAim . aimZoom .~ defaultItZoom{_itZoomFac = 1.5} - & itUse . useAim . aimHandlePos .~ 5 - & itUse . useAim . aimMuzPos .~ 15 + & itUse . heldDelay . rateMax .~ 6 + & itUse . heldMods .~ VolleyGunMod + & itUse . heldAim . aimWeight .~ 6 + & itUse . heldAim . aimRange .~ 1 + & itUse . heldAim . aimStance .~ TwoHandFlat + & itUse . heldAim . aimZoom .~ defaultItZoom{_itZoomFac = 1.5} + & itUse . heldAim . aimHandlePos .~ 5 + & itUse . heldAim . aimMuzPos .~ 15 & itUse . heldConsumption . laMax .~ i & itParams .~ BulletShooter @@ -77,13 +76,13 @@ volleyGun i = rifle :: Item rifle = defaultBangCane - & itUse . useAim . aimStance .~ TwoHandTwist + & itUse . heldAim . aimStance .~ TwoHandTwist & itType . iyBase .~ HELD RIFLE & itUse . heldConsumption . laMax .~ 1 & itUse . heldConsumption . laCycle .~ [loadEject 5, loadInsert 5, loadPrime 5] - & itUse . useAim . aimWeight .~ 6 - & itUse . useAim . aimRange .~ 1 - & itUse . useAim . aimZoom .~ defaultItZoom{_itZoomFac = 2} + & itUse . heldAim . aimWeight .~ 6 + & itUse . heldAim . aimRange .~ 1 + & itUse . heldAim . aimZoom .~ defaultItZoom{_itZoomFac = 2} & itType . iyModules . at ModHeldAttach ?~ EMPTYMODULE repeater :: Item @@ -98,7 +97,7 @@ autoRifle :: Item autoRifle = repeater & itType . iyBase .~ HELD AUTORIFLE - & itUse . useMods .~ AutoRifleMod + & itUse . heldMods .~ AutoRifleMod & itType . iyModules . at ModAutoMag ?~ EMPTYMODULE -- & itUse . useDelay . rateMax .~ 6 @@ -107,32 +106,31 @@ burstRifle = repeater & itType . iyBase .~ HELD BURSTRIFLE & itParams . gunBarrels . brlInaccuracy .~ 0.05 - & itUse . useDelay . rateMax .~ 18 - & itUse . useMods .~ BurstRifleMod + & itUse . heldDelay . rateMax .~ 18 + & itUse . heldMods .~ BurstRifleMod miniGunUse :: Int -> ItemUse miniGunUse i = - defaultrUse - & rUse .~ HeldUseAmmoParams - & useDelay .~ NoDelay - & useMods .~ MiniGunMod i - -miniGunX :: Int -> Item -miniGunX i = - defaultAutoGun - { _itUse = - miniGunUse i - & useDelay .~ WarmUpNoDelay{_warmTime = 0, _warmMax = 100} - & useAim . aimWeight .~ 6 - & useAim . aimRange .~ 1 - & useAim . aimStance .~ TwoHandTwist - & useAim . aimZoom .~ defaultItZoom{_itZoomFac = 1.5} + defaultHeldUse + & heldUse .~ HeldUseAmmoParams + & heldMods .~ MiniGunMod i + & heldDelay .~ WarmUpNoDelay{_warmTime = 0, _warmMax = 100} + & heldAim . aimWeight .~ 6 + & heldAim . aimRange .~ 1 + & heldAim . aimStance .~ TwoHandTwist + & heldAim . aimZoom .~ defaultItZoom{_itZoomFac = 1.5} & heldConsumption .~ defaultBulletLoadable { _laMax = 1500 , _laLoaded = 1500 } & heldConsumption . laCycle .~ [loadEject 40, loadInsert 40, loadPrime 40] + +miniGunX :: Int -> Item +miniGunX i = + autoRifle + { _itUse = + miniGunUse i , _itParams = BulletShooter { _muzVel = 1 @@ -154,4 +152,4 @@ miniGunX i = & itDimension . dimCenter .~ V3 5 0 0 & itDimension . dimAttachPos .~ V3 5 (-5) 0 & itType . iyBase .~ HELD (MINIGUNX i) - & itUse . useAim . aimMuzPos .~ 40 + & itUse . heldAim . aimMuzPos .~ 40 diff --git a/src/Dodge/Item/Held/Cone.hs b/src/Dodge/Item/Held/Cone.hs new file mode 100644 index 000000000..2fe45e371 --- /dev/null +++ b/src/Dodge/Item/Held/Cone.hs @@ -0,0 +1,52 @@ +module Dodge.Item.Held.Cone + where +import Dodge.Default.Item +import Dodge.Data.Item +import Dodge.Reloading.Action +import Control.Lens +import Geometry.Data + +bangCone :: Item +bangCone = + defaultBulletWeapon + { _itParams = + BulletShooter + { _muzVel = 0.7 + , _rifling = 0.8 + , _bore = 5 + , _gunBarrels = SingleBarrel 0.5 + , _recoil = 150 + , _torqueAfter = 0.1 + , _randomOffset = 12 + } + } + & itDimension . dimRad .~ 8 + & itDimension . dimCenter .~ V3 5 0 0 + & itUse . heldDelay . rateMax .~ 20 + & itUse . heldMods .~ BangConeMod + & itUse . heldAim . aimHandlePos .~ 5 + & itUse . heldAim . aimMuzPos .~ 15 + & itType . iyBase .~ HELD BANGCONE + & itUse . heldConsumption . laMax .~ 5 + & itUse . heldConsumption . laCycle .~ [loadEject 5, loadInsert 20, loadPrime 5] + +blunderbuss :: Item +blunderbuss = + bangCone + & itUse . heldConsumption . laMax .~ 25 + & itUse . heldConsumption . laCycle .~ [loadEject 5, loadInsert 30, loadPrime 5] + & itUse . heldAim . aimStance .~ TwoHandTwist + & itUse . heldAim . aimWeight .~ 6 + & itUse . heldAim . aimHandlePos .~ 5 + & itUse . heldAim . aimMuzPos .~ 30 + & itType . iyBase .~ HELD BLUNDERBUSS + +grapeCannon :: Int -> Item +grapeCannon i = + blunderbuss + & itType . iyBase .~ HELD (GRAPECANNON i) + & itUse . heldConsumption . laMax .~ 25 + 25 * i + & itUse . heldConsumption . laCycle .~ [loadEject 5, loadInsert (30 + i * 10), loadPrime 5] + & itParams . recoil .~ (150 + fromIntegral i * 50) + & itParams . torqueAfter .~ (0.1 + 0.2 * fromIntegral i) + & itParams . randomOffset .~ (12 + 4 * fromIntegral i) diff --git a/src/Dodge/Item/Held/Launcher.hs b/src/Dodge/Item/Held/Launcher.hs new file mode 100644 index 000000000..cbfe65254 --- /dev/null +++ b/src/Dodge/Item/Held/Launcher.hs @@ -0,0 +1,94 @@ +module Dodge.Item.Held.Launcher where + +import Dodge.Default.Item +import Dodge.Reloading.Action +import Control.Lens +import Dodge.Data.Item +import qualified IntMapHelp as IM +import Geometry.Data + +launcher :: Item +launcher = + defaultHeldItem + & itParams + .~ ShellLauncher + { _shellSpinDrag = 1 + , _shellSpinAmount = 2 + , _shellThrustDelay = 20 + } + & itTweaks + .~ Tweakable + { _tweakParams = basicAmPjMoves + } + & itInvSize .~ 3 + & itDimension . dimRad .~ 9 + & itDimension . dimCenter .~ V3 10 0 0 + & itUse . heldDelay . rateMax .~ 20 + & itUse . heldUse .~ HeldPJCreation --usePjCreation + & itUse . heldMods .~ LauncherMod + & itUse . heldAim . aimWeight .~ 8 + & itUse . heldAim . aimRange .~ 0.5 + & itUse . heldAim . aimStance .~ TwoHandTwist + & itUse . heldAim . aimHandlePos .~ 5 + & itUse . heldAim . aimMuzPos .~ 20 + & itUse . heldConsumption . laAmmoType + .~ ProjectileAmmo + { _amPayload = ExplosionPayload + , _amString = "EXPLOSIVE SHELL" + , _amPjDraw = DrawShell + , _amPjCreation = CreateShell + } + & itUse . heldConsumption . laMax .~ 1 + & itUse . heldConsumption . laLoaded .~ 1 + & itUse . heldConsumption . laCycle .~ [loadEject 30, loadInsert 30, loadPrime 10] + & itType . iyBase .~ HELD LAUNCHER + & itType . iyModules . at ModLauncherHoming ?~ EMPTYMODULE + +launcherX :: Int -> Item +launcherX i = + launcher + & itType . iyBase .~ HELD (LAUNCHERX i) + & itUse . heldConsumption . laMax .~ i + & itUse . heldConsumption . laLoaded .~ i + & itUse . heldUse .~ HeldPJCreationX i + & itUse . heldMods .~ LauncherXMod i + +remoteLauncher :: Item +remoteLauncher = + launcher + & itType . iyBase .~ HELD REMOTELAUNCHER + & itUse . heldUse .~ HeldFireRemoteShell --fireRemoteShell + & itScope .~ RemoteScope (V2 0 0) 1 True + & itUse . heldConsumption . laAmmoType . amPjDraw .~ DrawRemoteShell + +basicAmPjMoves :: IM.IntMap TweakParam +basicAmPjMoves = + IM.fromList . zip [0 ..] $ + [ spinDrag + , spinStart + , thrustParam + ] + +spinDrag :: TweakParam +spinDrag = + TweakParam + { _tweakType = TweakSpinDrag + , _tweakVal = 1 + , _tweakMax = 5 + } + +spinStart :: TweakParam +spinStart = + TweakParam + { _tweakType = TweakSpinAmount + , _tweakVal = 2 + , _tweakMax = 5 + } + +thrustParam :: TweakParam +thrustParam = + TweakParam + { _tweakType = TweakThrustDelay + , _tweakVal = 1 + , _tweakMax = 5 + } diff --git a/src/Dodge/Item/Held/Rod.hs b/src/Dodge/Item/Held/Rod.hs new file mode 100644 index 000000000..9227b2f8e --- /dev/null +++ b/src/Dodge/Item/Held/Rod.hs @@ -0,0 +1,93 @@ +module Dodge.Item.Held.Rod ( + bangRod, + elephantGun, + amr, + autoAmr, + sniperRifle, + machineGun, +) where + +import Dodge.Item.Targeting +import Dodge.Data.Item +import Dodge.Default +import Dodge.Item.Weapon.Bullet +import Dodge.Reloading.Action +import Geometry +import LensHelp + +bangRod :: Item +bangRod = + defaultBulletWeapon + & itParams + .~ BulletShooter + { _muzVel = 0.8 + , _rifling = 1 + , _bore = 2 + , _gunBarrels = SingleBarrel 0.1 + , _recoil = 50 + , _torqueAfter = 0.3 + , _randomOffset = 0 + } + & itUse . heldDelay . rateMax .~ 12 + & itUse . heldMods .~ BangRodMod + & itDimension . dimRad .~ 12 + & itDimension . dimCenter .~ V3 5 0 0 + & itUse . heldConsumption . laMax .~ 1 + & itUse . heldConsumption . laCycle .~ [loadEject 5, loadInsert 10, loadPrime 5] + & itType . iyBase .~ HELD BANGROD + & itUse . heldAim . aimWeight .~ 8 + & itUse . heldAim . aimRange .~ 1 + & itUse . heldAim . aimStance .~ OneHand + & itUse . heldAim . aimZoom .~ defaultItZoom{_itZoomFac = 1.5} + & itUse . heldAim . aimHandlePos .~ 5 + & itUse . heldAim . aimMuzPos .~ 30 + & itUse . heldConsumption . laAmmoType .~ hvBullet + +elephantGun :: Item +elephantGun = + bangRod + & itType . iyBase .~ HELD ELEPHANTGUN + & itUse . heldAim . aimStance .~ TwoHandTwist + & itParams . gunBarrels .~ SingleBarrel 0.05 + & itUse . heldMods .~ ElephantGunMod + & itParams . recoil .~ 50 + & itParams . torqueAfter .~ 0.1 + +amr :: Item +amr = + elephantGun + & itType . iyBase .~ HELD AMR + & itUse . heldConsumption . laMax .~ 15 + +autoAmr :: Item +autoAmr = + amr + & itType . iyBase .~ HELD AUTOAMR + & itUse . heldMods .~ AutoAmrMod + +sniperRifle :: Item +sniperRifle = + elephantGun + & itType . iyBase .~ HELD SNIPERRIFLE + & itParams . gunBarrels .~ SingleBarrel 0 + & itUse . heldAim . aimZoom .~ defaultItZoom{_itZoomMax = 0.5, _itZoomMin = 0.5} + & itUse . heldScroll .~ HeldScrollZoom -- zoomLongGun + & itScope .~ ZoomScope (V2 0 0) 0 1 0.5 False + & itTargeting .~ targetLaser + & itUse . heldAim . aimZoom .~ defaultItZoom{_itZoomFac = 1} + +machineGun :: Item +machineGun = + bangRod + & itType . iyBase .~ HELD MACHINEGUN + & itUse . heldDelay . rateMax .~ 25 + & itUse . heldMods .~ MachineGunMod + & itUse . heldAim . aimWeight .~ 8 + & itUse . heldAim . aimRange .~ 1 + & itUse . heldAim . aimStance .~ TwoHandTwist + & itUse . heldAim . aimZoom .~ defaultItZoom{_itZoomFac = 1.5} + & itUse . heldDelay .~ VariableRate{_rateMax = 25, _rateMaxMax = 24, _rateMinMax = 7, _rateTime = 0} + & itUse . heldConsumption . laMax .~ 100 + & itUse . heldConsumption . laCycle .~ [loadEject 10, loadInsert 40, loadPrime 10] + & itInvSize .~ 3 + & itParams . torqueAfter .~ 0.2 -- not sure if this is necessary? diff --git a/src/Dodge/Item/Weapon/SprayGuns.hs b/src/Dodge/Item/Held/SprayGuns.hs similarity index 76% rename from src/Dodge/Item/Weapon/SprayGuns.hs rename to src/Dodge/Item/Held/SprayGuns.hs index 7e228ad1d..50d3f650a 100644 --- a/src/Dodge/Item/Weapon/SprayGuns.hs +++ b/src/Dodge/Item/Held/SprayGuns.hs @@ -1,4 +1,4 @@ -module Dodge.Item.Weapon.SprayGuns ( +module Dodge.Item.Held.SprayGuns ( poisonSprayer, flameSpitter, blowTorch, @@ -7,8 +7,8 @@ module Dodge.Item.Weapon.SprayGuns ( flameWall, ) where -import Dodge.Data -import Dodge.Default +import Dodge.Data.Item +import Dodge.Default.Item import Dodge.Reloading.Action import Geometry import LensHelp @@ -22,7 +22,7 @@ poisonSprayer = { _amString = "POISONGAS" , _amCreateGas = CreatePoisonGas --aGasCloud } - & itUse . useMods .~ PoisonSprayerMod + & itUse . heldMods .~ PoisonSprayerMod flameSpitter :: Item flameSpitter = @@ -31,15 +31,15 @@ flameSpitter = & itUse . heldConsumption . laMax .~ 10 & itUse . heldConsumption . laCycle .~ [loadEject 5, loadInsert 10, loadPrime 20] & itParams . sprayNozzles . ix 0 . nzPressure .~ 4 - & itUse . useAim . aimStance .~ OneHand - & itUse . useDelay .~ FixedRate{_rateMax = 12, _rateTime = 0} - & itUse . useMods .~ FlameSpitterMod + & itUse . heldAim . aimStance .~ OneHand + & itUse . heldDelay .~ FixedRate{_rateMax = 12, _rateTime = 0} + & itUse . heldMods .~ FlameSpitterMod flameTorrent :: Item flameTorrent = flameThrower & itType . iyBase .~ HELD FLAMETORRENT - & itUse . useAim . aimZoom .~ defaultItZoom + & itUse . heldAim . aimZoom .~ defaultItZoom & itParams . sprayNozzles . ix 0 %~ ( (nzPressure .~ 10) . (nzMaxWalkAngle .~ 1.5) @@ -69,7 +69,7 @@ flameWall = flameThrower :: Item flameThrower = - defaultAutoGun + defaultHeldItem { _itParams = Sprayer { _sprayNozzles = @@ -86,14 +86,14 @@ flameThrower = } & itDimension . dimRad .~ 7 & itDimension . dimCenter .~ V3 9 0 0 - & itUse . rUse .~ HeldOverNozzlesUseGasParams -- overNozzles useGasParams - & itUse . useDelay .~ NoDelay - & itUse . useMods .~ FlameThrowerMod - & itUse . useAim . aimWeight .~ 5 - & itUse . useAim . aimZoom .~ defaultItZoom{_itZoomMax = 5, _itZoomMin = 1.5} - & itUse . useAim . aimStance .~ TwoHandTwist - & itUse . useAim . aimHandlePos .~ 0 - & itUse . useAim . aimMuzPos .~ 18 + & itUse . heldUse .~ HeldOverNozzlesUseGasParams -- overNozzles useGasParams + & itUse . heldDelay .~ NoDelay + & itUse . heldMods .~ FlameThrowerMod + & itUse . heldAim . aimWeight .~ 5 + & itUse . heldAim . aimZoom .~ defaultItZoom{_itZoomMax = 5, _itZoomMin = 1.5} + & itUse . heldAim . aimStance .~ TwoHandTwist + & itUse . heldAim . aimHandlePos .~ 0 + & itUse . heldAim . aimMuzPos .~ 18 & itUse . heldConsumption .~ ( defaultLoadable & laMax .~ 250 diff --git a/src/Dodge/Item/Held/Stick.hs b/src/Dodge/Item/Held/Stick.hs new file mode 100644 index 000000000..313ebd393 --- /dev/null +++ b/src/Dodge/Item/Held/Stick.hs @@ -0,0 +1,110 @@ +module Dodge.Item.Held.Stick ( + bangStick, + pistol, + autoPistol, + machinePistol, + smg, + revolver, + revolverX, +) where + +import Dodge.Data.Item +import Dodge.Default.Item +import Dodge.Reloading.Action +import Geometry +import LensHelp + +bangStick :: Int -> Item +bangStick i = + defaultBulletWeapon + & itParams + .~ BulletShooter + { _muzVel = 0.8 + , _rifling = 0.8 + , _bore = 2 + , _gunBarrels = + MultiBarrel + { _brlNum = i + , _brlSpread = SpreadBarrels baseStickSpread + , _brlInaccuracy = 0.01 + } + , _recoil = 25 + , _torqueAfter = 0.18 + 0.02 * fromIntegral i + , _randomOffset = 0 + } + & itType . iyBase .~ HELD (BANGSTICK i) + & itInvSize .~ fromIntegral i / 3 + & itDimension . dimRad .~ 5 + & itDimension . dimCenter .~ V3 5 0 0 + & itUse . heldDelay . rateMax .~ 8 + & itUse . heldMods .~ BangStickMod + & itUse . heldAim . aimHandlePos .~ 5 + & itUse . heldAim . aimMuzPos .~ 10 + & itUse . heldConsumption . laMax .~ i + & itUse . heldConsumption . laCycle .~ [loadPartialInsert 10 1] + +baseStickSpread :: Float +baseStickSpread = 0.2 + +revolver :: Item +revolver = + pistol + & itUse . heldConsumption + .~ ( defaultBulletLoadable + & laMax .~ 6 + & laCycle .~ [loadPartialInsert 10 1] + ) + & itType . iyBase .~ HELD REVOLVER + +pistol :: Item +pistol = + bangStick 1 + & itUse . heldConsumption + .~ ( defaultBulletLoadable + & laMax .~ 15 + & laCycle .~ [loadEject 5, loadInsert 5, loadPrime 5] + ) + & itUse . heldDelay . rateMax .~ 6 + & itUse . heldMods .~ PistolMod + & itParams + %~ ( (muzVel .~ 0.8) + . (rifling .~ 0.8) + . (bore .~ 2) + . (gunBarrels .~ SingleBarrel 0.05) + . (recoil .~ 10) + . (torqueAfter .~ 0.2) + ) + & itType . iyBase .~ HELD PISTOL + +autoPistol :: Item +autoPistol = + pistol + & itUse . heldMods .~ AutoPistolMod + & itType . iyBase .~ HELD AUTOPISTOL + & itType . iyModules . at ModAutoMag ?~ EMPTYMODULE + +machinePistol :: Item +machinePistol = + autoPistol + & itUse . heldDelay . rateMax .~ 2 + & itUse . heldMods .~ MachinePistolMod -- (ammoCheckI : machinePistolAfterHamMods) + & itType . iyBase .~ HELD MACHINEPISTOL + & itType . iyModules . at ModAutoMag .~ Nothing + & itParams . recoil .~ 20 + +smg :: Item +smg = + autoPistol -- & some parameter affecting stability + & itUse . heldMods .~ SmgMod --(ammoCheckI : smgAfterHamMods) + & itType . iyBase .~ HELD SMG + & itUse . heldAim . aimStance .~ TwoHandTwist + & itUse . heldAim . aimHandlePos .~ 2 + & itParams . torqueAfter .~ 0.05 + +revolverX :: Int -> Item +revolverX i = + revolver + & itUse . heldDelay . rateMax .~ 8 + & itUse . heldMods .~ RevolverXMod + & itUse . heldConsumption . laMax .~ i * 6 + & itType . iyBase .~ HELD (REVOLVERX i) diff --git a/src/Dodge/Item/Held/Utility.hs b/src/Dodge/Item/Held/Utility.hs new file mode 100644 index 000000000..2c0b871b1 --- /dev/null +++ b/src/Dodge/Item/Held/Utility.hs @@ -0,0 +1,68 @@ +module Dodge.Item.Held.Utility where + +import Dodge.Item.Targeting +import Dodge.Default.Item +import Color +import Control.Lens +import Dodge.Data.Item + +flatShield :: Item +flatShield = + defaultHeldItem + & itEffect . ieInv .~ EffectIfHeld CreateShieldWall RemoveShieldWall + & itUse . heldAim + .~ AimParams + { _aimWeight = 5 + , _aimRange = 0 + , _aimZoom = ItZoom 20 0.2 1 + , _aimStance = TwoHandFlat + , _aimHandlePos = 0 + , _aimMuzPos = 0 + } + & itInvSize .~ 3 + & itType . iyBase .~ HELD FLATSHIELD + +keyCard :: Int -> Item +keyCard n = + defaultHeldItem + & itInvColor .~ aquamarine + & itType . iyBase .~ HELD (KEYCARD n) + +latchkey :: Int -> Item +latchkey _ = + defaultHeldItem + & itInvColor .~ yellow + +torch :: Item +torch = + defaultHeldItem + & itEffect . ieInv .~ EffectWhileHeld CreateHeldLight + & itType . iyBase .~ HELD TORCH + & itUse . heldAim . aimHandlePos .~ 5 + & itUse . heldAim . aimMuzPos .~ 10 + +forceFieldGun :: Item +forceFieldGun = + defaultWeapon + & itTargeting .~ (targetRBPress & tgDraw .~ TargetDistanceDraw) + & itParams .~ ParamMID Nothing + & itUse . heldUse .~ HeldForceField --useForceFieldGun + & itUse . heldDelay .~ NoDelay + & itUse . heldMods .~ AmmoHammerTimeUseOneMod -- this is slightly different + -- than the list below + --[ hammerCheckI , ammoCheckI , useAmmoAmount 1] + & itType . iyBase .~ HELD FORCEFIELDGUN + & itUse . heldConsumption .~ (defaultLoadable & laAmmoType .~ ForceFieldAmmo DefaultForceField) + +{- | +Sends out pulses that display walls. +-} +clickDetector :: Detector -> Item +clickDetector dt = + defaultWeapon + & itUse . heldDelay . rateMax .~ 20 + & itUse . heldUse .~ HeldDetectorEffect dt --detectorEffect dt + & itUse . heldMods .~ AmmoUseCheckMod + & itUse . heldAim . aimRange .~ 1 + & itUse . heldAim . aimZoom .~ defaultItZoom{_itZoomFac = 1} + & itType . iyBase .~ HELD (HELDDETECTOR dt) diff --git a/src/Dodge/Item/Held/Weapons.hs b/src/Dodge/Item/Held/Weapons.hs new file mode 100644 index 000000000..796aa1c2d --- /dev/null +++ b/src/Dodge/Item/Held/Weapons.hs @@ -0,0 +1,14 @@ +module Dodge.Item.Held.Weapons where + +import Dodge.Default.Item +import Dodge.Data.Item +import Control.Lens + +shatterGun :: Item +shatterGun = + defaultHeldItem + & itType . iyBase .~ HELD SHATTERGUN + & itUse . heldDelay . rateMax .~ 10 + & itUse . heldUse .~ HeldShatter --shootShatter + & itUse . heldMods .~ ShatterMod + & itUse . heldAim . aimStance .~ TwoHandFlat diff --git a/src/Dodge/Item/HeldOffset.hs b/src/Dodge/Item/HeldOffset.hs index ed75ba3d7..bdf38a178 100644 --- a/src/Dodge/Item/HeldOffset.hs +++ b/src/Dodge/Item/HeldOffset.hs @@ -1,53 +1,54 @@ module Dodge.Item.HeldOffset where -import Dodge.Data -import Dodge.Creature.HandPos -import Geometry -import LensHelp import Data.Maybe +import Dodge.Creature.HandPos +import Dodge.Data.Creature +import Geometry +import LensHelp heldItemOffset :: Item -> Creature -> Point3 -> Point3 heldItemOffset itm cr | isSelected && _posture (_crStance cr) == Aiming = - (+.+.+ V3 (aimingWeaponZeroPos cr itm) 0 shoulderD) - | isSelected && isTwoHandFlat - = (+.+.+ V3 (_crRad cr) 0 handD) - . rotate3 (twoFlatHRot cr) - . transToHandle - | isSelected && isOneHand - = (+.+.+ V3 0 0 handD) - . (+.+.+ V3 (_crRad cr * 0.7 + handPos) (_crRad cr * negate 0.7) 0) - . (+.+.+ V3 (-2) 0 0) - . transToHandle - | isSelected - = (+.+.+ V3 0 0 handD) - . (+.+.+ V3 (_crRad cr) 0 0) - . rotate3 (strideRot cr + 1.2) - . (+.+.+ V3 (-5) 0 0) --- . (+.+.+ V3 (-5) 0 0) - . transToHandle + (+.+.+ V3 (aimingWeaponZeroPos cr itm) 0 shoulderD) + | isSelected && isTwoHandFlat = + (+.+.+ V3 (_crRad cr) 0 handD) + . rotate3 (twoFlatHRot cr) + . transToHandle + | isSelected && isOneHand = + (+.+.+ V3 0 0 handD) + . (+.+.+ V3 (_crRad cr * 0.7 + handPos) (_crRad cr * negate 0.7) 0) + . (+.+.+ V3 (-2) 0 0) + . transToHandle + | isSelected = + (+.+.+ V3 0 0 handD) + . (+.+.+ V3 (_crRad cr) 0 0) + . rotate3 (strideRot cr + 1.2) + . (+.+.+ V3 (-5) 0 0) + -- . (+.+.+ V3 (-5) 0 0) + . transToHandle | otherwise = id - where + where transToHandle = fromMaybe id $ do - x <- itm ^? itUse . useAim . aimHandlePos + x <- itm ^? itUse . heldAim . aimHandlePos return (-.-.- V3 x 0 0) shoulderD = 18 handD = 15 isSelected = _itIsHeld itm - handPos = case cr^? crStance . carriage of + handPos = case cr ^? crStance . carriage of Just (Walking x LeftForward) -> f x * 50 _ -> 0 theIt = itm - isOneHand = theIt ^? itUseAimStance == Just OneHand - || isNothing (theIt ^? itUseAimStance) - isTwoHandFlat = theIt ^? itUseAimStance == Just TwoHandFlat - itUseAimStance = itUse . useAim . aimStance + isOneHand = + theIt ^? itUseAimStance == Just OneHand + || isNothing (theIt ^? itUseAimStance) + isTwoHandFlat = theIt ^? itUseAimStance == Just TwoHandFlat + itUseAimStance = itUse . heldAim . aimStance f i = 0.1 * fromIntegral (sLen - i) / fromIntegral sLen sLen = _strideLength $ _crStance cr strideRot :: Creature -> Float strideRot cr = case cr ^? crStance . carriage of - Just (Walking x LeftForward) -> f x + Just (Walking x LeftForward) -> f x Just (Walking x RightForward) -> - f x _ -> 0 where @@ -55,4 +56,4 @@ strideRot cr = case cr ^? crStance . carriage of sLen = _strideLength $ _crStance cr twoFlatHRot :: Creature -> Float -twoFlatHRot cr = 2*strideRot cr +twoFlatHRot cr = 2 * strideRot cr diff --git a/src/Dodge/Item/Left.hs b/src/Dodge/Item/Left.hs new file mode 100644 index 000000000..7fbc9e346 --- /dev/null +++ b/src/Dodge/Item/Left.hs @@ -0,0 +1,3 @@ +module Dodge.Item.Left + where + diff --git a/src/Dodge/Item/Location.hs b/src/Dodge/Item/Location.hs index 7272ddde8..7feca20f8 100644 --- a/src/Dodge/Item/Location.hs +++ b/src/Dodge/Item/Location.hs @@ -1,19 +1,20 @@ module Dodge.Item.Location where -import Dodge.Data -import qualified IntMapHelp as IM import Control.Lens import Data.Maybe +import Dodge.Data.World +import qualified IntMapHelp as IM setHeldItemLoc :: Creature -> World -> World setHeldItemLoc cr = fst . getHeldItemLoc cr -getHeldItemLoc :: Creature -> World -> (World,Int) +getHeldItemLoc :: Creature -> World -> (World, Int) getHeldItemLoc cr w = case maybeitid of - Nothing -> + Nothing -> ( w & cWorld . creatures . ix cid . crInv . ix j . itID ?~ newitid & cWorld . itemLocations %~ IM.insert newitid (InInv cid j) - , itid) + , itid + ) _ -> (w, itid) where cid = _crID cr @@ -30,12 +31,20 @@ getItem itid w = do InInv cid invid -> w ^? cWorld . creatures . ix cid . crInv . ix invid VoidItm -> Nothing -pointerToItemLocation :: Applicative f => - ItemLocation -> (Item -> f Item) -> World -> f World +pointerToItemLocation :: + Applicative f => + ItemLocation -> + (Item -> f Item) -> + World -> + f World pointerToItemLocation (InInv cid invid) = cWorld . creatures . ix cid . crInv . ix invid pointerToItemLocation (OnFloor flid) = cWorld . floorItems . ix flid . flIt pointerToItemLocation _ = const pure -pointerToItem :: Applicative f => - Item -> (Item -> f Item) -> World -> f World +pointerToItem :: + Applicative f => + Item -> + (Item -> f Item) -> + World -> + f World pointerToItem = pointerToItemLocation . _itLocation diff --git a/src/Dodge/Item/PassKey.hs b/src/Dodge/Item/PassKey.hs deleted file mode 100644 index eaa83cb5c..000000000 --- a/src/Dodge/Item/PassKey.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Dodge.Item.PassKey where -import Dodge.Data -import Dodge.Default -import Picture -import LensHelp -keyCard :: Int -> Item -keyCard n = defaultEquipment - & itInvColor .~ aquamarine - & itType . iyBase .~ HELD (KEYCARD n) - -latchkey :: Int -> Item -latchkey _ = defaultEquipment - & itInvColor .~ yellow diff --git a/src/Dodge/Item/Random.hs b/src/Dodge/Item/Random.hs index 30d7ed36d..9b0160dee 100644 --- a/src/Dodge/Item/Random.hs +++ b/src/Dodge/Item/Random.hs @@ -1,8 +1,8 @@ module Dodge.Item.Random where -import Dodge.Data -import RandomHelp -import Dodge.Item.Weapon.BulletGuns +import Dodge.Data.Item +import Dodge.Item.Held +import RandomHelp randBlockBreakWeapon :: RandomGen g => State g Item randBlockBreakWeapon = takeOne [bangStick 1] diff --git a/src/Dodge/Item/Targeting.hs b/src/Dodge/Item/Targeting.hs new file mode 100644 index 000000000..90cddeb14 --- /dev/null +++ b/src/Dodge/Item/Targeting.hs @@ -0,0 +1,37 @@ +module Dodge.Item.Targeting where + +import Control.Lens +import Dodge.Data.Item.Targeting + +defaultTargeting :: Targeting +defaultTargeting = + Targeting + { _tgPos = Nothing + , _tgUpdate = NoTargetUpdate + , _tgDraw = NoTargetDraw + , _tgID = Nothing + , _tgActive = False + } + +targetLaser :: Targeting +targetLaser = + defaultTargeting + & tgUpdate .~ TargetLaserUpdate + +targetRBPress :: Targeting +targetRBPress = + defaultTargeting + & tgUpdate .~ TargetRBPressUpdate + & tgDraw .~ SimpleDrawTarget + +targetRBCreature :: Targeting +targetRBCreature = + defaultTargeting + & tgUpdate .~ TargetRBCreatureUpdate + & tgDraw .~ TargetRBCreatureDraw + +targetCursor :: Targeting +targetCursor = + defaultTargeting + & tgUpdate .~ TargetCursorUpdate + & tgDraw .~ SimpleDrawTarget diff --git a/src/Dodge/Item/Weapon.hs b/src/Dodge/Item/Weapon.hs index 247808cbe..eac69594d 100644 --- a/src/Dodge/Item/Weapon.hs +++ b/src/Dodge/Item/Weapon.hs @@ -1,29 +1,24 @@ -{- | Rexport all weapons -} -module Dodge.Item.Weapon - ( module Dodge.Item.Weapon.BulletGuns - , module Dodge.Item.Weapon.Shatter - , module Dodge.Item.Weapon.TriggerType - , module Dodge.Item.Weapon.ExtraEffect - , module Dodge.Item.Weapon.Remote - , module Dodge.Item.Weapon.Grenade - , module Dodge.Item.Weapon.Spawn - , module Dodge.Item.Weapon.Radar - , module Dodge.Item.Weapon.Utility - , module Dodge.Item.Weapon.SprayGuns - , module Dodge.Item.Weapon.BatteryGuns - , module Dodge.Item.Weapon.Launcher - , module Dodge.Item.Weapon.Drone - ) where -import Dodge.Item.Weapon.Utility -import Dodge.Item.Weapon.BulletGuns -import Dodge.Item.Weapon.Drone -import Dodge.Item.Weapon.TriggerType -import Dodge.Item.Weapon.Shatter -import Dodge.Item.Weapon.ExtraEffect -import Dodge.Item.Weapon.Remote -import Dodge.Item.Weapon.Grenade -import Dodge.Item.Weapon.Spawn -import Dodge.Item.Weapon.Radar -import Dodge.Item.Weapon.SprayGuns +-- | Rexport all weapons +module Dodge.Item.Weapon ( + module Dodge.Item.Weapon.TriggerType, + module Dodge.Item.Weapon.ExtraEffect, + module Dodge.Item.Weapon.Remote, + module Dodge.Item.Weapon.Grenade, + module Dodge.Item.Weapon.Spawn, + module Dodge.Item.Weapon.Radar, + module Dodge.Item.Weapon.Utility, + module Dodge.Item.Weapon.BatteryGuns, + module Dodge.Item.Weapon.Launcher, + module Dodge.Item.Weapon.Drone, +) where + import Dodge.Item.Weapon.BatteryGuns +import Dodge.Item.Weapon.Drone +import Dodge.Item.Weapon.ExtraEffect +import Dodge.Item.Weapon.Grenade import Dodge.Item.Weapon.Launcher +import Dodge.Item.Weapon.Radar +import Dodge.Item.Weapon.Remote +import Dodge.Item.Weapon.Spawn +import Dodge.Item.Weapon.TriggerType +import Dodge.Item.Weapon.Utility diff --git a/src/Dodge/Item/Weapon/BatteryGuns.hs b/src/Dodge/Item/Weapon/BatteryGuns.hs index 78a562793..db9b79f04 100644 --- a/src/Dodge/Item/Weapon/BatteryGuns.hs +++ b/src/Dodge/Item/Weapon/BatteryGuns.hs @@ -1,73 +1,32 @@ -module Dodge.Item.Weapon.BatteryGuns - ( lasGun - , lasCircle - , dualBeam - , lasWide - , sparkGun - , teslaGun - , teslaParams - , tractorGun - , lasRayAt - , flameBeamCombine - , teslaBeamCombine - , splitBeamCombine - , shootTeslaArc - , shootLaser - , circleLaser - , shootDualLaser - , aTractorBeam - ) where -import Dodge.Data -import Dodge.Reloading.Action -import Dodge.Tesla -import Dodge.Beam -import Dodge.Item.Weapon.LaserPath -import Dodge.Item.Location -import Dodge.Creature.HandPos -import Dodge.Default.Weapon -import Dodge.Base ---import Dodge.Zone -import Geometry -import Picture -import LensHelp +module Dodge.Item.Weapon.BatteryGuns ( + teslaParams, + lasRayAt, + flameBeamCombine, + teslaBeamCombine, + splitBeamCombine, + shootTeslaArc, + shootLaser, + circleLaser, + shootDualLaser, + aTractorBeam, +) where +import Dodge.Base +import Dodge.Beam +import Dodge.Creature.HandPos +import Dodge.Data.World +import Dodge.Item.Location +import Dodge.Item.Weapon.LaserPath +import Dodge.Tesla +import Geometry import qualified IntMapHelp as IM -import qualified Data.Map.Strict as M +import LensHelp +import Picture + --import Control.Monad.State -defaultBatteryGun :: Item -defaultBatteryGun = defaultWeapon - & itType . iyModules .~ batteryModules -batteryModules :: M.Map ModuleSlot ItemModuleType -batteryModules = M.fromList - [(ModBattery, EMPTYMODULE) - ,(ModTeleport, EMPTYMODULE) - ] -defaultAutoBatteryGun :: Item -defaultAutoBatteryGun = defaultAutoGun - & itType . iyModules .~ batteryModules - -sparkGun :: Item -sparkGun = teslaGun - & itType . iyBase .~ HELD SPARKGUN - & itParams . arcSize .~ 10 -teslaGun :: Item -teslaGun = defaultBatteryGun - & itUse . heldConsumption . laMax .~ 200 - & itUse . heldConsumption . laCycle .~ [loadEject 10, loadInsert 10 , loadPrime 60] - & itDimension . dimRad .~ 9 - & itDimension . dimCenter .~ V3 4 0 0 - & itParams .~ teslaParams - & itUse . rUse .~ HeldTeslaArc --shootTeslaArc - & itUse . useDelay .~ NoDelay - & itUse . useMods .~ TeslaMod - & itUse . useAim . aimWeight .~ 6 - & itUse . useAim . aimStance .~ TwoHandFlat - & itUse . useAim . aimHandlePos .~ 4 - & itUse . useAim . aimMuzPos .~ 4 - & itType . iyBase .~ HELD TESLAGUN --lasPulse :: Item --lasPulse = lasGun -- & itType . iyBase .~ LASPULSE @@ -75,7 +34,7 @@ teslaGun = defaultBatteryGun -- [ ammoCheckI -- , withItem $ \it -> withTempLight 1 (100 * frac it) (xyzV4 (_lasColor $ _itParams it)) -- , withItem $ \it -> withSoundForVol (frac it) tone440sawtoothquietS 2 --- , withItemUpdate itup +-- , withItemUpdate itup -- $ \it -> withMuzPos $ flareCircleAt (_lasColor $ _itParams it) (frac it * 0.8) -- , useAmmoAmount 1 -- ] @@ -86,26 +45,8 @@ teslaGun = defaultBatteryGun -- & itParams . lasColor .~ frac it * orange -- frac it = 0.5 * (1 + sin (pi * fromIntegral (_lasCycle $ _itParams it) * 0.1)) -lasCircle :: Item -lasCircle = lasGun - & itType . iyBase .~ HELD LASCIRCLE - & itParams . lasColor .~ orange - & itParams . lasDamage .~ 2 - & itUse . heldConsumption . laMax .~ 10000 - & itUse . rUse .~ HeldLaser --shootLaser - & itUse . useDelay .~ NoDelay - & itUse . rUse .~ HeldCircleLaser --circleLaser - & itUse . useMods .~ CircleLaserMod - & itUse . useAim . aimWeight .~ 6 - & itUse . useAim . aimRange .~ 1 - & itUse . useAim . aimStance .~ TwoHandTwist -lasWide :: Int -> Item -lasWide n = lasGun - & itType . iyBase .~ HELD (LASWIDE n) - & itParams . lasColor .~ yellow - & itParams . lasDamage .~ 2 - & itUse . useMods .~ LasWideMod n + --lasWidePulse :: Item --lasWidePulse = lasGun -- & itType . iyBase .~ LASGUNWIDEPULSE @@ -115,7 +56,7 @@ lasWide n = lasGun -- [ ammoCheckI -- , withItem $ \it -> withTempLight 1 (100 * frac it) (xyzV4 (_lasColor $ _itParams it)) -- , withItem $ \it -> withSoundForVol (frac it) tone440sawtoothquietS 2 --- , withItemUpdate itup +-- , withItemUpdate itup -- $ \it -> withMuzPos $ flareCircleAt (_lasColor $ _itParams it) (frac it * 0.8) -- , useAmmoAmount 1 -- , withItemUpdate itup $ \it -> duplicateOffsets (xs it) @@ -171,27 +112,7 @@ lasWide n = lasGun -- n' = 9 * n -- xs = [ 0.25 * (fromIntegral x - fromIntegral (n'-1) /2) | x <- [0..n'-1] ] -dualBeam :: Item -dualBeam = lasGun - & itType . iyBase .~ HELD DUALBEAM - & itUse . useAim . aimMuzPos .~ 0 - & itParams .~ DualBeam - { _phaseV = 1 - , _lasColor = red - , _lasColor2 = green - , _lasCycle = 0 - , _lasDamage = 11 - , _lasBeam = BeamCombine LasBeamCombine - , _subParams = Nothing - , _dbGap = 20 - } - & itUse . rUse .~ HeldDualLaser --shootDualLaser - & itUse . useDelay .~ NoDelay - & itUse . useMods .~ DualBeamMod - & itUse . useAim . aimWeight .~ 6 - & itUse . useAim . aimRange .~ 1 - & itUse . useAim . aimStance .~ TwoHandFlat - & itType . iyModules . at ModDualBeam ?~ EMPTYMODULE + --lasSwing :: Item --lasSwing = lasGun -- & itType . iyBase .~ LASGUNSWING @@ -210,79 +131,20 @@ dualBeam = lasGun -- where -- y = 15 * sin (pi * fromIntegral x' * 0.01) -- x' = _lasCycle $ _itParams it -lasGun :: Item -lasGun = defaultAutoBatteryGun - & itUse . heldConsumption .~ ( defaultLoadable - & laMax .~ 200 - & laCycle .~ [loadEject 10, loadInsert 10 , loadPrime 60] - ) - & itParams .~ Refracting - { _phaseV = 1 - , _lasColor = yellow - , _lasColor2 = yellow - , _lasCycle = 0 - , _lasDamage = 11 - } - & itTweaks .~ Tweakable - { _tweakParams = IM.fromList [(0,lasGunTweak)] - } - & itDimension . dimRad .~ 10 - & itDimension . dimCenter .~ V3 15 0 0 - & itUse . rUse .~ HeldLaser --shootLaser - & itUse . useDelay .~ NoDelay - & itUse . useMods .~ LasMod - & itUse . useAim . aimWeight .~ 6 - & itUse . useAim . aimRange .~ 1 - & itUse . useAim . aimStance .~ TwoHandTwist - & itUse . useAim . aimHandlePos .~ 5 - & itUse . useAim . aimMuzPos .~ 30 - & itType . iyBase .~ HELD LASGUN - -lasGunTweak :: TweakParam -lasGunTweak = TweakParam - { _tweakType = TweakPhaseV - , _tweakVal = 1 - , _tweakMax = 3 - } -tractorGun :: Item -tractorGun = lasGun - & itUse . heldConsumption .~ - ( defaultLoadable - & laMax .~ 10000 - & laCycle .~ [loadEject 10, loadInsert 10 , loadPrime 60] ) - & itParams .~ Attracting {_attractionPower = 1} - & itTweaks .~ Tweakable - { _tweakParams = IM.fromList [(0,tractorGunTweak)] - } - & itUse . rUse .~ HeldTractor --aTractorBeam - & itUse . useDelay .~ NoDelay - & itUse . useMods .~ AmmoCheckMod - & itUse . useAim . aimWeight .~ 6 - & itUse . useAim . aimRange .~ 1 - & itUse . useAim . aimStance .~ TwoHandTwist - & itUse . useAim . aimHandlePos .~ 5 - & itUse . useAim . aimMuzPos .~ 30 - & itType . iyBase .~ HELD TRACTORGUN - -tractorGunTweak :: TweakParam -tractorGunTweak = TweakParam - { _tweakType = TweakTractionPower - , _tweakVal = 1 - , _tweakMax = 4 - } -- | assumes that the item is held shootTeslaArc :: Item -> Creature -> World -> World -shootTeslaArc it cr w = w' - & cWorld . creatures . ix (_crID cr) . crInv . ix (crSel cr) . itParams .~ ip - where - (w',ip) = shootTeslaArc' (_itParams it) pos dir w +shootTeslaArc it cr w = + w' + & cWorld . creatures . ix (_crID cr) . crInv . ix (crSel cr) . itParams .~ ip + where + (w', ip) = shootTeslaArc' (_itParams it) pos dir w pos = _crPos cr +.+ aimingMuzzlePos cr it *.* unitVectorAtAngle dir dir = _crDir cr shootLaser :: Item -> Creature -> World -> World shootLaser it cr = cWorld . lasers .:~ lasRayAt (_lasColor $ _itParams it) dam phasev pos dir - where + where pos = _crPos cr dir = _crDir cr phasev = _phaseV . _itParams $ _crInv cr IM.! crSel cr @@ -291,10 +153,11 @@ shootLaser it cr = cWorld . lasers .:~ lasRayAt (_lasColor $ _itParams it) dam p -- this has the feel of a left click item circleLaser :: Item -> Creature -> World -> World circleLaser it cr w - | hasLOSIndirect cpos pos w = w - & cWorld . lasers .:~ lasRayAt (_lasColor $ _itParams it) dam phasev pos dir + | hasLOSIndirect cpos pos w = + w + & cWorld . lasers .:~ lasRayAt (_lasColor $ _itParams it) dam phasev pos dir | otherwise = w - where + where cpos = _crPos cr mwp = mouseWorldPos w pos = _crPos cr +.+ rotateV dir (V2 0 (max 70 $ dist cpos mwp)) @@ -303,19 +166,21 @@ circleLaser it cr w dam = _lasDamage $ _itParams it shootDualLaser :: Item -> Creature -> World -> World -shootDualLaser it cr w = w' - & cWorld . newBeams . positronBeams .:~ dualRayAt (_lasBeam $ _itParams it) itid w (_lasColor $ _itParams it) dam phasev posl dirl - & cWorld . newBeams . electronBeams .:~ basicBeamAt itid w (_lasColor2 $ _itParams it) dam phasev posr dirr - where - (w',itid) = getHeldItemLoc cr w +shootDualLaser it cr w = + w' + & cWorld . newBeams . positronBeams .:~ dualRayAt (_lasBeam $ _itParams it) itid w (_lasColor $ _itParams it) dam phasev posl dirl + & cWorld . newBeams . electronBeams .:~ basicBeamAt itid w (_lasColor2 $ _itParams it) dam phasev posr dirr + where + (w', itid) = getHeldItemLoc cr w dir = _crDir cr pos = _crPos cr +.+ aimlength *.* unitVectorAtAngle dir aimlength = aimingMuzzlePos cr it gap = _dbGap . _itParams $ it - posl = pos +.+ (-gap) *.* vNormal (unitVectorAtAngle dir) + posl = pos +.+ (- gap) *.* vNormal (unitVectorAtAngle dir) posr = pos +.+ gap *.* vNormal (unitVectorAtAngle dir) mwp = mouseWorldPos w - mwp' | dist mwp (_crPos cr) < aimlength + 5 = _crPos cr +.+ (aimlength + 5) *.* unitVectorAtAngle dir + mwp' + | dist mwp (_crPos cr) < aimlength + 5 = _crPos cr +.+ (aimlength + 5) *.* unitVectorAtAngle dir | otherwise = mwp dirl = argV $ mwp' -.- posl dirr = argV $ mwp' -.- posr @@ -323,29 +188,31 @@ shootDualLaser it cr w = w' dam = _lasDamage $ _itParams it basicBeamAt :: Int -> World -> Color -> Int -> Float -> Point2 -> Float -> Beam -basicBeamAt itid w col dam phasev pos dir = Beam - { _bmDraw = BasicBeamDraw --drawBeam - , _bmPos = pos - , _bmDir = dir - , _bmDamage = dam - , _bmRange = 800 - , _bmPhaseV = phasev - , _bmColor = col - , _bmPoints = pos:ps - , _bmFirstPoints = [] - , _bmOrigin = Just itid - , _bmType = BeamCombine NoBeamCombine - } +basicBeamAt itid w col dam phasev pos dir = + Beam + { _bmDraw = BasicBeamDraw --drawBeam + , _bmPos = pos + , _bmDir = dir + , _bmDamage = dam + , _bmRange = 800 + , _bmPhaseV = phasev + , _bmColor = col + , _bmPoints = pos : ps + , _bmFirstPoints = [] + , _bmOrigin = Just itid + , _bmType = BeamCombine NoBeamCombine + } where - (_,ps) = reflectLaserAlong phasev pos (pos +.+ 800 *.* unitVectorAtAngle dir) w + (_, ps) = reflectLaserAlong phasev pos (pos +.+ 800 *.* unitVectorAtAngle dir) w dualRayAt :: BeamType -> Int -> World -> Color -> Int -> Float -> Point2 -> Float -> Beam -dualRayAt bt itid w col dam phasev pos dir = basicBeamAt itid w col dam phasev pos dir - & bmType .~ bt +dualRayAt bt itid w col dam phasev pos dir = + basicBeamAt itid w col dam phasev pos dir + & bmType .~ bt aTractorBeam :: Item -> Creature -> World -> World aTractorBeam _ cr w = w & cWorld . tractorBeams .:~ tractorBeamAt spos outpos dir power - where + where cpos = _crPos cr spos = cpos +.+ (_crRad cr + 10) *.* unitVectorAtAngle dir xpos = cpos +.+ 400 *.* unitVectorAtAngle dir @@ -354,12 +221,12 @@ aTractorBeam _ cr w = w & cWorld . tractorBeams .:~ tractorBeamAt spos outpos di power = _attractionPower . _itParams $ _crInv cr IM.! crSel cr tractorBeamAt :: Point2 -> Point2 -> Float -> Point2 -> TractorBeam -tractorBeamAt pos outpos dir power = TractorBeam - { _tbPos = pos - , _tbStartPos = outpos - , _tbVel = d - , _tbTime = 10 - } - where - d = unitVectorAtAngle dir * power - +tractorBeamAt pos outpos dir power = + TractorBeam + { _tbPos = pos + , _tbStartPos = outpos + , _tbVel = d + , _tbTime = 10 + } + where + d = unitVectorAtAngle dir * power diff --git a/src/Dodge/Item/Weapon/Bullet.hs b/src/Dodge/Item/Weapon/Bullet.hs index 1a0d251c1..bce0ce540 100644 --- a/src/Dodge/Item/Weapon/Bullet.hs +++ b/src/Dodge/Item/Weapon/Bullet.hs @@ -1,46 +1,55 @@ -module Dodge.Item.Weapon.Bullet - ( basicBullet - , hvBullet - ) where -import Dodge.Data +module Dodge.Item.Weapon.Bullet ( + basicBullet, + hvBullet, +) where +import Dodge.Data.Item.Use.Consumption.Ammo import Control.Lens import Geometry.Data + basicBullet :: AmmoType -basicBullet = BulletAmmo - { _amString = "BASIC" - , _amBullet = defaultBullet - } +basicBullet = + BulletAmmo + { _amString = "BASIC" + , _amBullet = defaultBullet + } + defaultBullet :: Bullet -defaultBullet = Bullet - { _buDelayFraction = 1 - , _buEffect = DestroyBullet - , _buSpawn = BulSpark - , _buUpdateMod = NoBulletUpdateMod - , _buTrajectory = BasicBulletTrajectory - , _buVel = V2 50 0 - , _buDrag = 1 - , _buPos = 0 - , _buOldPos = 0 - , _buWidth = 2 - , _buTimer = 100 - , _buDamages = basicBulDams - } +defaultBullet = + Bullet + { _buDelayFraction = 1 + , _buEffect = DestroyBullet + , _buSpawn = BulSpark + , _buUpdateMod = NoBulletUpdateMod + , _buTrajectory = BasicBulletTrajectory + , _buVel = V2 50 0 + , _buDrag = 1 + , _buPos = 0 + , _buOldPos = 0 + , _buWidth = 2 + , _buTimer = 100 + , _buDamages = basicBulDams + } + basicBulDams :: [Damage] basicBulDams = [ Damage PIERCING 100 0 0 0 NoDamageEffect - , Damage PUSHDAM 1 0 0 0 . PushBackDamage $ 2 + , Damage PUSHDAM 1 0 0 0 . PushBackDamage $ 2 ] + hvBullet :: AmmoType -hvBullet = BulletAmmo - { _amString = "HVBULLET" - , _amBullet = defaultBullet - & buWidth .~ 6 - & buVel .~ V2 80 0 - & buDamages .~ heavyBulDams - } +hvBullet = + BulletAmmo + { _amString = "HVBULLET" + , _amBullet = + defaultBullet + & buWidth .~ 6 + & buVel .~ V2 80 0 + & buDamages .~ heavyBulDams + } + heavyBulDams :: [Damage] heavyBulDams = [ Damage PIERCING 300 0 0 0 NoDamageEffect - , Damage PUSHDAM 1 0 0 0 $ PushBackDamage 2 + , Damage PUSHDAM 1 0 0 0 $ PushBackDamage 2 ] diff --git a/src/Dodge/Item/Weapon/BulletGun/Rod.hs b/src/Dodge/Item/Weapon/BulletGun/Rod.hs deleted file mode 100644 index c8a6dd195..000000000 --- a/src/Dodge/Item/Weapon/BulletGun/Rod.hs +++ /dev/null @@ -1,83 +0,0 @@ -module Dodge.Item.Weapon.BulletGun.Rod - ( bangRod - , elephantGun - , amr - , autoAmr - , sniperRifle - , machineGun - ) where -import Dodge.Data -import Dodge.Reloading.Action -import Dodge.Default.Weapon -import Dodge.Item.Weapon.Bullet -import Dodge.Default -import Dodge.Item.Weapon.ExtraEffect -import Geometry -import LensHelp - -bangRod :: Item -bangRod = defaultBulletWeapon - & itParams .~ BulletShooter - { _muzVel = 0.8 - , _rifling = 1 - , _bore = 2 - , _gunBarrels = SingleBarrel 0.1 - , _recoil = 50 - , _torqueAfter = 0.3 - , _randomOffset = 0 - } - & itUse . useDelay . rateMax .~ 12 - & itUse . useMods .~ BangRodMod - & itDimension . dimRad .~ 12 - & itDimension . dimCenter .~ V3 5 0 0 - & itUse . heldConsumption . laMax .~ 1 - & itUse . heldConsumption . laCycle .~ [loadEject 5, loadInsert 10 , loadPrime 5] - & itType . iyBase .~ HELD BANGROD - & itUse . useAim . aimWeight .~ 8 - & itUse . useAim . aimRange .~ 1 - & itUse . useAim . aimStance .~ OneHand - & itUse . useAim . aimZoom .~ defaultItZoom {_itZoomFac = 1.5} - & itUse . useAim . aimHandlePos .~ 5 - & itUse . useAim . aimMuzPos .~ 30 - & itUse . heldConsumption . laAmmoType .~ hvBullet -elephantGun :: Item -elephantGun = bangRod - & itType . iyBase .~ HELD ELEPHANTGUN - & itUse . useAim . aimStance .~ TwoHandTwist - & itParams . gunBarrels .~ SingleBarrel 0.05 - & itUse . useMods .~ ElephantGunMod - & itParams . recoil .~ 50 - & itParams . torqueAfter .~ 0.1 -amr :: Item -amr = elephantGun - & itType . iyBase .~ HELD AMR - & itUse . heldConsumption . laMax .~ 15 - -autoAmr :: Item -autoAmr = amr - & itType . iyBase .~ HELD AUTOAMR - & itUse . useMods .~ AutoAmrMod - -sniperRifle :: Item -sniperRifle = elephantGun - & itType . iyBase .~ HELD SNIPERRIFLE - & itParams . gunBarrels .~ SingleBarrel 0 - & itUse . useAim . aimZoom .~ defaultItZoom {_itZoomMax = 0.5, _itZoomMin = 0.5} - & itUse . heldScroll .~ HeldScrollZoom -- zoomLongGun - & itScope .~ ZoomScope (V2 0 0) 0 1 0.5 False - & itTargeting .~ targetLaser - & itUse . useAim . aimZoom .~ defaultItZoom {_itZoomFac = 1} -machineGun :: Item -machineGun = bangRod - & itType . iyBase .~ HELD MACHINEGUN - & itUse . useDelay . rateMax .~ 25 - & itUse . useMods .~ MachineGunMod - & itUse . useAim . aimWeight .~ 8 - & itUse . useAim . aimRange .~ 1 - & itUse . useAim . aimStance .~ TwoHandTwist - & itUse . useAim . aimZoom .~ defaultItZoom {_itZoomFac = 1.5} - & itUse . useDelay .~ VariableRate {_rateMax = 25, _rateMaxMax = 24, _rateMinMax = 7, _rateTime = 0} - & itUse . heldConsumption . laMax .~ 100 - & itUse . heldConsumption . laCycle .~ [loadEject 10, loadInsert 40 , loadPrime 10] - & itInvSize .~ 3 - & itParams. torqueAfter .~ 0.2 -- not sure if this is necessary? diff --git a/src/Dodge/Item/Weapon/BulletGun/Stick.hs b/src/Dodge/Item/Weapon/BulletGun/Stick.hs deleted file mode 100644 index c9ac27d95..000000000 --- a/src/Dodge/Item/Weapon/BulletGun/Stick.hs +++ /dev/null @@ -1,93 +0,0 @@ -module Dodge.Item.Weapon.BulletGun.Stick - ( bangStick - , pistol - , autoPistol - , machinePistol - , smg - , revolver - , revolverX - ) where -import Dodge.Reloading.Action -import Dodge.Data -import Dodge.Default.Weapon -import Geometry -import LensHelp - -bangStick :: Int -> Item -bangStick i = defaultBulletWeapon - & itParams .~ BulletShooter - { _muzVel = 0.8 - , _rifling = 0.8 - , _bore = 2 - , _gunBarrels = MultiBarrel - {_brlNum = i - ,_brlSpread = SpreadBarrels baseStickSpread - ,_brlInaccuracy = 0.01 - } - , _recoil = 25 - , _torqueAfter = 0.18 + 0.02 * fromIntegral i - , _randomOffset = 0 - } - & itInvSize .~ fromIntegral i / 3 - & itDimension . dimRad .~ 5 - & itDimension . dimCenter .~ V3 5 0 0 - & itUse . useDelay . rateMax .~ 8 - & itUse . useMods .~ BangStickMod - & itType . iyBase .~ HELD (BANGSTICK i) - & itUse . useAim . aimHandlePos .~ 5 - & itUse . useAim . aimMuzPos .~ 10 - & itUse . heldConsumption . laMax .~ i - & itUse . heldConsumption . laCycle .~ [loadPartialInsert 10 1] - -baseStickSpread :: Float -baseStickSpread = 0.2 - -revolver :: Item -revolver = pistol - & itUse . heldConsumption .~ - (defaultBulletLoadable - & laMax .~ 6 - & laCycle .~ [loadPartialInsert 10 1] ) - & itType . iyBase .~ HELD REVOLVER - -pistol :: Item -pistol = bangStick 1 - & itUse . heldConsumption .~ ( defaultBulletLoadable - & laMax .~ 15 - & laCycle .~ [loadEject 5, loadInsert 5 , loadPrime 5] ) - & itUse . useDelay . rateMax .~ 6 - & itUse . useMods .~ PistolMod - & itParams %~ - ( ( muzVel .~ 0.8 ) - . ( rifling .~ 0.8 ) - . ( bore .~ 2 ) - . ( gunBarrels .~ SingleBarrel 0.05 ) - . ( recoil .~ 10 ) - . ( torqueAfter .~ 0.2 ) - ) - & itType . iyBase .~ HELD PISTOL -autoPistol :: Item -autoPistol = pistol - & itUse . useMods .~ AutoPistolMod - & itType . iyBase .~ HELD AUTOPISTOL - & itType . iyModules . at ModAutoMag ?~ EMPTYMODULE -machinePistol :: Item -machinePistol = autoPistol - & itUse . useDelay . rateMax .~ 2 - & itUse . useMods .~ MachinePistolMod -- (ammoCheckI : machinePistolAfterHamMods) - & itType . iyBase .~ HELD MACHINEPISTOL - & itType . iyModules . at ModAutoMag .~ Nothing - & itParams . recoil .~ 20 -smg :: Item -smg = autoPistol -- & some parameter affecting stability - & itUse . useMods .~ SmgMod --(ammoCheckI : smgAfterHamMods) - & itType . iyBase .~ HELD SMG - & itUse . useAim . aimStance .~ TwoHandTwist - & itUse . useAim . aimHandlePos .~ 2 - & itParams . torqueAfter .~ 0.05 -revolverX :: Int -> Item -revolverX i = revolver - & itUse . useDelay . rateMax .~ 8 - & itUse . useMods .~ RevolverXMod - & itUse . heldConsumption . laMax .~ i * 6 - & itType . iyBase .~ HELD (REVOLVERX i) diff --git a/src/Dodge/Item/Weapon/BulletGuns.hs b/src/Dodge/Item/Weapon/BulletGuns.hs deleted file mode 100644 index 04f6266a5..000000000 --- a/src/Dodge/Item/Weapon/BulletGuns.hs +++ /dev/null @@ -1,110 +0,0 @@ -module Dodge.Item.Weapon.BulletGuns - ( bangCone - , blunderbuss - , grapeCannon - , grenadeLauncher - , autogunSpread - --, autoGunPic - , module Dodge.Item.Weapon.BulletGun.Stick - , module Dodge.Item.Weapon.BulletGun.Cane - , module Dodge.Item.Weapon.BulletGun.Rod - ) where -import Dodge.Item.Weapon.BulletGun.Stick -import Dodge.Reloading.Action -import Dodge.Item.Weapon.BulletGun.Cane -import Dodge.Item.Weapon.BulletGun.Rod -import Dodge.Data -import Dodge.Default.Weapon -import Geometry -import LensHelp - ---autoGun :: Item ---autoGun = defaultAutoGun --- { _itConsumption = defaultBulletLoadable --- { _laMax = 30 --- , _laLoaded = 30 --- } --- & laCycle .~ [loadEject 30, loadInsert 30 , loadPrime 10] ----- , _itFloorPict = autoGunPic ----- , _itZoom = defaultItZoom --- , _itAttachment = AttachCharMode $ Seq.fromList "MS" --- , _itParams = BulletShooter --- { _muzVel = 1 --- , _rifling = 0.9 --- , _bore = 2 --- , _gunBarrels = SingleBarrel 0.1 --- , _recoil = 0 --- , _torqueAfter = 0 --- , _randomOffset = 0 --- } --- } --- & itUse . useDelay . rateMax .~ 4 --- & itUse . useMods .~ --- [ ammoCheckI --- , charFiringStratI --- [('S', hammerCheckI) --- ] --- , useTimeCheck --- , charFiringStratI --- [('M', torqueBefore 0.08) --- ,('S', torqueBefore 0.05) --- ] --- , withSoundForI autoBS 5 --- --, withSoundForI seagullChatterS 5 --- , useAmmoAmount 1 --- , applyInaccuracy --- , withMuzFlareI --- , withSmoke 1 black 20 200 5 --- ] --- & itUse . useAim . aimWeight .~ 6 --- & itUse . useAim . aimRange .~ 1 --- & itUse . useAim . aimStance .~ TwoHandTwist --- & itUse . useAim . aimZoom .~ defaultItZoom {_itZoomFac = 1.5} --- & itUse . heldScroll .~ HeldScrollCharMode --- & itType . iyBase .~ HELD AUTOGUN - -bangCone :: Item -bangCone = defaultBulletWeapon - { _itParams = BulletShooter - { _muzVel = 0.7 - , _rifling = 0.8 - , _bore = 5 - , _gunBarrels = SingleBarrel 0.5 - , _recoil = 150 - , _torqueAfter = 0.1 - , _randomOffset = 12 - } - } - & itDimension . dimRad .~ 8 - & itDimension . dimCenter .~ V3 5 0 0 - & itUse . useDelay . rateMax .~ 20 - & itUse . useMods .~ BangConeMod - & itUse . useAim . aimHandlePos .~ 5 - & itUse . useAim . aimMuzPos .~ 15 - & itType . iyBase .~ HELD BANGCONE - & itUse . heldConsumption . laMax .~ 5 - & itUse . heldConsumption . laCycle .~ [loadEject 5, loadInsert 20 , loadPrime 5] - -blunderbuss :: Item -blunderbuss = bangCone - & itUse . heldConsumption . laMax .~ 25 - & itUse . heldConsumption . laCycle .~ [loadEject 5, loadInsert 30 , loadPrime 5] - & itUse . useAim . aimStance .~ TwoHandTwist - & itUse . useAim . aimWeight .~ 6 - & itUse . useAim . aimHandlePos .~ 5 - & itUse . useAim . aimMuzPos .~ 30 - & itType . iyBase .~ HELD BLUNDERBUSS -grapeCannon :: Int -> Item -grapeCannon i = blunderbuss - & itType . iyBase .~ HELD (GRAPECANNON i) - & itUse . heldConsumption . laMax .~ 25 + 25 * i - & itUse . heldConsumption . laCycle .~ [loadEject 5, loadInsert (30 + i * 10) , loadPrime 5] - & itParams . recoil .~ (150 + fromIntegral i * 50) - & itParams . torqueAfter .~ (0.1 + 0.2 * fromIntegral i) - & itParams . randomOffset .~ (12 + 4 * fromIntegral i) - -grenadeLauncher :: Int -> Item -grenadeLauncher _ = bangCone - -autogunSpread :: Float -autogunSpread = 0.07 diff --git a/src/Dodge/Item/Weapon/Drone.hs b/src/Dodge/Item/Weapon/Drone.hs index e765fee87..eb44ee7da 100644 --- a/src/Dodge/Item/Weapon/Drone.hs +++ b/src/Dodge/Item/Weapon/Drone.hs @@ -1,41 +1,44 @@ module Dodge.Item.Weapon.Drone where -import Dodge.Data -import Dodge.Default.Weapon + +import Dodge.Default.Item +import Control.Lens +import Dodge.Data.World import Geometry import Picture -import ShapePicture import Shape - -import Control.Lens +import ShapePicture droneLauncher :: Item -droneLauncher = defaultWeapon - & itUse . useDelay . rateMax .~ 20 --- & itUse . rUse .~ aDroneWithItemParams - & itUse . useMods .~ AmmoUseCheckMod - & itUse . useAim . aimWeight .~ 8 - & itUse . useAim . aimRange .~ 0.5 - & itUse . useAim . aimStance .~ TwoHandTwist - & itUse . heldConsumption . laAmmoType .~ DroneAmmo { _amString = "LASDRONE" } - & itUse . heldConsumption . laMax .~ 2 - & itType . iyBase .~ HELD DRONELAUNCHER +droneLauncher = + defaultHeldItem + & itUse . heldDelay . rateMax .~ 20 + & itUse . heldMods .~ AmmoUseCheckMod + & itUse . heldAim . aimWeight .~ 8 + & itUse . heldAim . aimRange .~ 0.5 + & itUse . heldAim . aimStance .~ TwoHandTwist + & itUse . heldConsumption . laAmmoType .~ DroneAmmo{_amString = "LASDRONE"} + & itUse . heldConsumption . laMax .~ 2 + & itType . iyBase .~ HELD DRONELAUNCHER lasDronesPic :: Item -> SPic -lasDronesPic _ = - ( colorSH chartreuse $ prismPoly - (map (+.+.+ V3 10 0 4.5) $ polyCircx 4 5) - (map (+.+.+ V3 (-10) 0 4.5) $ polyCircx 4 5) +lasDronesPic _ = + ( colorSH chartreuse $ + prismPoly + (map (+.+.+ V3 10 0 4.5) $ polyCircx 4 5) + (map (+.+.+ V3 (-10) 0 4.5) $ polyCircx 4 5) , mempty ) -aDroneWithItemParams - :: Item -- ^ Firing item - -> Creature - -> World - -> World +aDroneWithItemParams :: + -- | Firing item + Item -> + Creature -> + World -> + World aDroneWithItemParams = undefined + --aDroneWithItemParams it cr w = over props (IM.insert i theShell) w --- where +-- where -- am = _itConsumption it -- i = IM.newKey $ _props w -- pos = _crPos cr +.+ ((_crRad cr +1) *.* unitVectorAtAngle dir) diff --git a/src/Dodge/Item/Weapon/ExtraEffect.hs b/src/Dodge/Item/Weapon/ExtraEffect.hs index 047d4ab99..c521869d9 100644 --- a/src/Dodge/Item/Weapon/ExtraEffect.hs +++ b/src/Dodge/Item/Weapon/ExtraEffect.hs @@ -1,95 +1,87 @@ --{-# LANGUAGE BangPatterns #-} + {- | Extra weapon effects, supplementing explicit use effects. - -} -module Dodge.Item.Weapon.ExtraEffect - (-- itemLaserScopeEffect - autoSonarEffect - , autoEffect - , autoRadarEffect - , targetRBPress - , targetRBCreature - , targetCursor - , targetLaser - , targetLaserUpdate - , targetUpdateWith - , targetRBPressUpdate - , targetRBCreatureUp - , targetCursorUpdate --- , rbSetTarget - ) where -import Dodge.Zoning.Creature -import FoldableHelp -import Dodge.Data -import Dodge.Base -import Dodge.RadarSweep -import Dodge.SoundLogic -import Dodge.Item.Weapon.LaserPath +-} +module Dodge.Item.Weapon.ExtraEffect ( + -- itemLaserScopeEffect + autoSonarEffect, + autoEffect, + autoRadarEffect, + targetLaserUpdate, + targetUpdateWith, + targetRBPressUpdate, + targetRBCreatureUp, + targetCursorUpdate, + -- , rbSetTarget +) where + --import Dodge.Item.Attachment.Data -import Dodge.Creature.Test -import Picture -import Geometry.Vector -import LensHelp -import Sound.Data import qualified Data.Map.Strict as M import Data.Maybe +import Dodge.Base +import Dodge.Creature.Test +import Dodge.Data.World +import Dodge.Item.Weapon.LaserPath +import Dodge.RadarSweep +import Dodge.SoundLogic +import Dodge.Zoning.Creature +import FoldableHelp +import Geometry.Vector +import LensHelp +import Picture import qualified SDL +import Sound.Data + autoEffect :: (Item -> Creature -> World -> World) -> Int -> SoundID -> Item -> Creature -> World -> World autoEffect eff t sid itm cr w - | _eparamInt (_eqParams (_eqEq $ _itUse itm)) < 1 = eff itm cr w - & cWorld . creatures . ix (_crID cr) . crInv . ix (_ipInvID $ _itLocation itm) - . itUse . eqEq . eqParams . eparamInt .~ t - & soundStart OnceSound (_crPos cr) sid Nothing - | otherwise = w - & cWorld . creatures . ix (_crID cr) . crInv . ix (_ipInvID $ _itLocation itm) - . itUse . eqEq . eqParams . eparamInt -~ 1 + | _eparamInt (_eeParams (_equipEffect $ _itUse itm)) < 1 = + eff itm cr w + & cWorld . creatures . ix (_crID cr) . crInv . ix (_ipInvID $ _itLocation itm) + . itUse + . equipEffect + . eeParams + . eparamInt + .~ t + & soundStart OnceSound (_crPos cr) sid Nothing + | otherwise = + w + & cWorld . creatures . ix (_crID cr) . crInv . ix (_ipInvID $ _itLocation itm) + . itUse + . equipEffect + . eeParams + . eparamInt + -~ 1 -{- | Automatically send out radar pulses that detect walls. -} +-- | Automatically send out radar pulses that detect walls. autoRadarEffect :: Item -> Creature -> World -> World autoRadarEffect = autoEffect (const (aRadarPulse ObWall)) 100 click1S -{- | Automatically send out sonar pulses that detect creatures. -} + +-- | Automatically send out sonar pulses that detect creatures. autoSonarEffect :: Item -> Creature -> World -> World autoSonarEffect = autoEffect (const (aRadarPulse ObCreature)) 50 click1S -defaultTargeting :: Targeting -defaultTargeting = Targeting - { _tgPos = Nothing - , _tgUpdate = NoTargetUpdate - , _tgDraw = NoTargetDraw - , _tgID = Nothing - , _tgActive = False - } -targetLaser :: Targeting -targetLaser = defaultTargeting - & tgUpdate .~ TargetLaserUpdate -targetRBPress :: Targeting -targetRBPress = defaultTargeting - & tgUpdate .~ TargetRBPressUpdate - & tgDraw .~ SimpleDrawTarget -targetRBCreature :: Targeting -targetRBCreature = defaultTargeting - & tgUpdate .~ TargetRBCreatureUpdate - & tgDraw .~ TargetRBCreatureDraw -targetCursor :: Targeting -targetCursor = defaultTargeting - & tgUpdate .~ TargetCursorUpdate - & tgDraw .~ SimpleDrawTarget + targetRBCreatureUp :: Item -> Creature -> World -> Targeting -> (World, Targeting) targetRBCreatureUp it cr w t - | not $ _itIsHeld it = (w, t - & tgID .~ Nothing - & tgPos .~ Nothing - & tgActive .~ False + | not $ _itIsHeld it = + ( w + , t + & tgID .~ Nothing + & tgPos .~ Nothing + & tgActive .~ False ) | SDL.ButtonRight `M.member` _mouseButtons w && isJust (t ^? tgID . _Just) - && canSeeTarget = (w, t & updatePos & tgActive .~ True) - | otherwise = (w, t & tgID .~ fmap _crID newtarg & updatePos & tgActive .~ False ) + && canSeeTarget = + (w, t & updatePos & tgActive .~ True) + | otherwise = (w, t & tgID .~ fmap _crID newtarg & updatePos & tgActive .~ False) where - newtarg = safeMinimumOn (dist mwp . _crPos) - . filter (canseepos . _crPos) - $ crsNearCirc mwp 40 w + newtarg = + safeMinimumOn (dist mwp . _crPos) + . filter (canseepos . _crPos) + $ crsNearCirc mwp 40 w canseepos p = hasLOS (_crPos cr) p w mwp = mouseWorldPos w updatePos t' = t' & tgPos .~ posFromMaybeID (_tgID t') @@ -100,52 +92,67 @@ targetRBCreatureUp it cr w t cpos <- w ^? cWorld . creatures . ix cid . crPos Just $ hasLOS cpos (_crPos cr) w -targetUpdateWith :: (World -> Targeting -> Targeting) - -> Item -> Creature -> World -> Targeting -> (World,Targeting) -targetUpdateWith f it _ w t +targetUpdateWith :: + (World -> Targeting -> Targeting) -> + Item -> + Creature -> + World -> + Targeting -> + (World, Targeting) +targetUpdateWith f it _ w t | _itIsHeld it = (w, f w t) - | otherwise = (w,t) + | otherwise = (w, t) targetCursorUpdate :: World -> Targeting -> Targeting targetCursorUpdate w t - | SDL.ButtonRight `M.member` _mouseButtons w = t - & tgPos . _Just .~ mouseWorldPos w - & tgActive .~ True - | otherwise = t & tgPos %~ const Nothing - & tgActive .~ False + | SDL.ButtonRight `M.member` _mouseButtons w = + t + & tgPos . _Just .~ mouseWorldPos w + & tgActive .~ True + | otherwise = + t & tgPos %~ const Nothing + & tgActive .~ False targetRBPressUpdate :: World -> Targeting -> Targeting targetRBPressUpdate w t - | SDL.ButtonRight `M.member` _mouseButtons w = t - & tgPos %~ maybe (Just $ mouseWorldPos w) Just - & tgActive .~ True - | otherwise = t & tgPos %~ const Nothing - & tgActive .~ False + | SDL.ButtonRight `M.member` _mouseButtons w = + t + & tgPos %~ maybe (Just $ mouseWorldPos w) Just + & tgActive .~ True + | otherwise = + t & tgPos %~ const Nothing + & tgActive .~ False -targetLaserUpdate :: Item -> Creature -> World -> Targeting -> (World,Targeting) +targetLaserUpdate :: Item -> Creature -> World -> Targeting -> (World, Targeting) targetLaserUpdate _ cr w t - | crIsAiming cr = (addLaserPic w,t - & tgPos .~ fmap fst mp - & tgActive .~ True + | crIsAiming cr = + ( addLaserPic w + , t + & tgPos .~ fmap fst mp + & tgActive .~ True ) - | otherwise = (w,t & tgPos %~ const Nothing - & tgActive .~ False + | otherwise = + ( w + , t & tgPos %~ const Nothing + & tgActive .~ False ) where (mp, _) = reflectLaserAlong 0.2 sp ep w sp = _crPos cr +.+ 15 *.* unitVectorAtAngle (_crDir cr) ep = sp +.+ 5000 *.* normalizeV (mouseWorldPos w -.- sp) - addLaserPic = cWorld . lasers .:~ LaserStart - { _lpPhaseV = 1 - , _lpDir = _crDir cr - , _lpPos = sp - , _lpColor = col - , _lpType = TargetLaser - } + addLaserPic = + cWorld . lasers + .:~ LaserStart + { _lpPhaseV = 1 + , _lpDir = _crDir cr + , _lpPos = sp + , _lpColor = col + , _lpType = TargetLaser + } --wpammo = _itConsumption it --- reloadFrac --- | _laLoaded wpammo == 0 = 1 --- | otherwise = case _laTransfer wpammo of --- Transfer _ rs -> fromIntegral rs / fromIntegral (_laReloadTime wpammo) --- NoTransfer -> 1 + -- reloadFrac + -- | _laLoaded wpammo == 0 = 1 + -- | otherwise = case _laTransfer wpammo of + -- Transfer _ rs -> fromIntegral rs / fromIntegral (_laReloadTime wpammo) + -- NoTransfer -> 1 col = blue -- mixColors reloadFrac (1-reloadFrac) blue red diff --git a/src/Dodge/Item/Weapon/FractionLoaded.hs b/src/Dodge/Item/Weapon/FractionLoaded.hs index a21b7882e..dd3aaf537 100644 --- a/src/Dodge/Item/Weapon/FractionLoaded.hs +++ b/src/Dodge/Item/Weapon/FractionLoaded.hs @@ -2,7 +2,7 @@ module Dodge.Item.Weapon.FractionLoaded ( fractionLoadedAmmo , fractionLoadedAmmo2 ) where -import Dodge.Data +import Dodge.Data.Item ---- this shouldn't really be used loadedAmmo :: Item -> Int diff --git a/src/Dodge/Item/Weapon/LaserPath.hs b/src/Dodge/Item/Weapon/LaserPath.hs index fd361ca15..723f1c64e 100644 --- a/src/Dodge/Item/Weapon/LaserPath.hs +++ b/src/Dodge/Item/Weapon/LaserPath.hs @@ -1,56 +1,62 @@ -module Dodge.Item.Weapon.LaserPath - ( reflectLaserAlong - ) where -import Dodge.Data +module Dodge.Item.Weapon.LaserPath ( + reflectLaserAlong, +) where + +import Data.Bifunctor +import Data.Tuple import Dodge.Base.Wall ---import Dodge.Creature.HandPos +import Dodge.Data.World import Dodge.WorldEvent import Geometry ---import Data.Maybe ---import Data.List -import Data.Bifunctor -import Data.Tuple ---import Streaming ---import qualified Streaming.Prelude as S - -- this needs to be tested with both reflections and refractions -reflectLaserAlong :: Float -> Point2 -> Point2 -> World - -> (Maybe (Point2,Either Creature Wall),[Point2]) +reflectLaserAlong :: + Float -> + Point2 -> + Point2 -> + World -> + (Maybe (Point2, Either Creature Wall), [Point2]) {-# INLINE reflectLaserAlong #-} reflectLaserAlong phasev sp ep w = case thingHitFilt (const True) _wlUnshadowed sp ep w of - Just (p,Right wl) - | _wlReflect wl -> second (p:) $ reflectLaserAlong phasev - (p +.+ unitVectorAtAngle (reflDirWall sp p wl)) - (p +.+ dist p ep *.* unitVectorAtAngle (reflDirWall sp p wl)) - w - | wlIsSeeThrough wl -> second (p:) $ reflectLaserAlong phasev - (p +.+ normalizeV (refract phasev sp ep wl p)) - (refract phasev sp ep wl p) - w - | otherwise -> (Just (p,Right wl), [p]) - Just (p,obj) -> (Just (p,obj), [p]) + Just (p, Right wl) + | _wlReflect wl -> + second (p :) $ + reflectLaserAlong + phasev + (p +.+ unitVectorAtAngle (reflDirWall sp p wl)) + (p +.+ dist p ep *.* unitVectorAtAngle (reflDirWall sp p wl)) + w + | wlIsSeeThrough wl -> + second (p :) $ + reflectLaserAlong + phasev + (p +.+ normalizeV (refract phasev sp ep wl p)) + (refract phasev sp ep wl p) + w + | otherwise -> (Just (p, Right wl), [p]) + Just (p, obj) -> (Just (p, obj), [p]) Nothing -> (Nothing, [ep]) + refract :: Float -> Point2 -> Point2 -> Wall -> Point2 -> Point2 {-# INLINE refract #-} -refract phasev x y wl p - | isEntering = p +.+ rotateV angleRef (normalDist wlNormal) - | otherwise = p +.+ rotateV angleRef' (normalDist wlNormal') - where +refract phasev x y wl p + | isEntering = p +.+ rotateV angleRef (normalDist wlNormal) + | otherwise = p +.+ rotateV angleRef' (normalDist wlNormal') + where wlNormal = vNormal $ uncurry (-.-) $ swap (_wlLine wl) wlNormal' = vNormal $ uncurry (-.-) (_wlLine wl) - normalDist wlnormal = magV (p -.- y) *.* normalizeV wlnormal + normalDist wlnormal = magV (p -.- y) *.* normalizeV wlnormal angleInc = piRange $ argV wlNormal - argV (x -.- y) - angleRef + angleRef | reflectExternal = angleInc | otherwise = asin $ sin angleInc / phasev - piRange a' + piRange a' | a' > pi = a' - 2 * pi | a' > negate pi = a' - | otherwise = a' + 2 * pi + | otherwise = a' + 2 * pi isEntering = not $ isLeftOf (x -.- y) (uncurry (-.-) (_wlLine wl)) angleInc' = piRange $ argV wlNormal' - argV (x -.- y) - angleRef' + angleRef' | reflectInternal = angleInc' | otherwise = asin $ phasev * sin angleInc' reflectInternal = 1 < abs (phasev * sin angleInc') diff --git a/src/Dodge/Item/Weapon/Launcher.hs b/src/Dodge/Item/Weapon/Launcher.hs index ec2702759..c09176f02 100644 --- a/src/Dodge/Item/Weapon/Launcher.hs +++ b/src/Dodge/Item/Weapon/Launcher.hs @@ -1,109 +1,15 @@ module Dodge.Item.Weapon.Launcher ( - launcher, - launcherX, - remoteLauncher, fireTrackingShell, explodeRemoteRocket, ) where import Control.Lens -import Dodge.Data -import Dodge.Default.Weapon +import Dodge.Data.World import Dodge.Item.Location import Dodge.Payload import Dodge.Projectile.Create -import Dodge.Reloading.Action -import Geometry import qualified IntMapHelp as IM -launcher :: Item -launcher = - defaultWeapon - { _itParams = - ShellLauncher - { _shellSpinDrag = 1 - , _shellSpinAmount = 2 - , _shellThrustDelay = 20 - } - , _itTweaks = - Tweakable - { _tweakParams = basicAmPjMoves - } - , _itInvSize = 3 - } - & itDimension . dimRad .~ 9 - & itDimension . dimCenter .~ V3 10 0 0 - & itUse . useDelay . rateMax .~ 20 - & itUse . rUse .~ HeldPJCreation --usePjCreation - & itUse . useMods .~ LauncherMod - & itUse . useAim . aimWeight .~ 8 - & itUse . useAim . aimRange .~ 0.5 - & itUse . useAim . aimStance .~ TwoHandTwist - & itUse . useAim . aimHandlePos .~ 5 - & itUse . useAim . aimMuzPos .~ 20 - & itUse . heldConsumption . laAmmoType .~ ProjectileAmmo - { _amPayload = ExplosionPayload - , _amString = "EXPLOSIVE SHELL" - , _amPjDraw = DrawShell - , _amPjCreation = CreateShell - } - & itUse . heldConsumption . laMax .~ 1 - & itUse . heldConsumption . laLoaded .~ 1 - & itUse . heldConsumption . laCycle .~ [loadEject 30, loadInsert 30, loadPrime 10] - & itType . iyBase .~ HELD LAUNCHER - & itType . iyModules . at ModLauncherHoming ?~ EMPTYMODULE - -launcherX :: Int -> Item -launcherX i = - launcher - & itType . iyBase .~ HELD (LAUNCHERX i) - & itUse . heldConsumption . laMax .~ i - & itUse . heldConsumption . laLoaded .~ i - & itUse . rUse .~ HeldPJCreationX i - & itUse . useMods .~ LauncherXMod i - -basicAmPjMoves :: IM.IntMap TweakParam -basicAmPjMoves = - IM.fromList . zip [0 ..] $ - [ spinDrag - , spinStart - , thrustParam - ] - -spinDrag :: TweakParam -spinDrag = - TweakParam - { _tweakType = TweakSpinDrag - , _tweakVal = 1 - , _tweakMax = 5 - } - -spinStart :: TweakParam -spinStart = - TweakParam - { _tweakType = TweakSpinAmount - , _tweakVal = 2 - , _tweakMax = 5 - } - -thrustParam :: TweakParam -thrustParam = - TweakParam - { _tweakType = TweakThrustDelay - , _tweakVal = 1 - , _tweakMax = 5 - } - -remoteLauncher :: Item -remoteLauncher = - launcher - & itType . iyBase .~ HELD REMOTELAUNCHER - & itUse . rUse .~ HeldFireRemoteShell --fireRemoteShell - & itScope .~ RemoteScope (V2 0 0) 1 True - & itUse . heldConsumption . laAmmoType . amPjDraw .~ DrawRemoteShell - --- TODO consider allowing tweaking rocket speed - explodeRemoteRocket :: -- | Item id Int -> @@ -115,7 +21,7 @@ explodeRemoteRocket itid pjid w = w & cWorld . projectiles . ix pjid . prjUpdates .~ [PJRetireRemote itid 30 pjid] & cWorld . projectiles . ix pjid . prjDraw .~ DrawBlankProjectile - & itPoint . itUse . rUse .~ HeldDoNothing + & itPoint . itUse . heldUse .~ HeldDoNothing & usePayload (_prjPayload thepj) (_prjPos thepj) where itPoint = pointerToItemLocation $ _itemLocations (_cWorld w) IM.! itid diff --git a/src/Dodge/Item/Weapon/Radar.hs b/src/Dodge/Item/Weapon/Radar.hs index 0586645f8..4f7f0c2bc 100644 --- a/src/Dodge/Item/Weapon/Radar.hs +++ b/src/Dodge/Item/Weapon/Radar.hs @@ -1,32 +1,23 @@ module Dodge.Item.Weapon.Radar where -import Dodge.Data -import Dodge.RadarSweep -import Dodge.Default import Control.Lens - -{- | -Sends out pulses that display walls. -} -clickDetector :: Detector -> Item -clickDetector dt = defaultWeapon - & itUse . useDelay . rateMax .~ 20 - & itUse . rUse .~ HeldDetectorEffect dt --detectorEffect dt - & itUse . useMods .~ AmmoUseCheckMod - & itUse . useAim . aimRange .~ 1 - & itUse . useAim . aimZoom .~ defaultItZoom {_itZoomFac = 1} - & itType . iyBase .~ HELD (HELDDETECTOR dt) +import Dodge.Data.World +import Dodge.Default +import Dodge.RadarSweep autoDetector :: Detector -> Item -autoDetector dt = defaultEquipment - & itUse . eqEq . eqSite .~ GoesOnWrist - & itUse . eqEq . eqUse .~ EDetector dt --autoEffect (detectorEffect dt) 100 click1S - & itUse . eqEq . eqParams .~ EquipCounter 0 - & itUse . eqEq . eqViewDist ?~ 350 - & itType . iyBase .~ EQUIP (AUTODETECTOR dt) +autoDetector dt = + defaultEquipment + & itUse . equipEffect . eeSite .~ GoesOnWrist + & itUse . equipEffect . eeUse .~ EDetector dt --autoEffect (detectorEffect dt) 100 click1S + & itUse . equipEffect . eeParams .~ EquipCounter 0 + & itUse . equipEffect . eeViewDist ?~ 350 + & itType . iyBase .~ EQUIP (AUTODETECTOR dt) + -- , _itEffect = autoRadarEffect detectorEffect :: Detector -> Item -> Creature -> World -> World detectorEffect dt = case dt of - ITEMDETECTOR -> const (aRadarPulse ObItem) - CREATUREDETECTOR -> const (aRadarPulse ObCreature) - WALLDETECTOR -> const (aRadarPulse ObWall) + ITEMDETECTOR -> const (aRadarPulse ObItem) + CREATUREDETECTOR -> const (aRadarPulse ObCreature) + WALLDETECTOR -> const (aRadarPulse ObWall) diff --git a/src/Dodge/Item/Weapon/Remote.hs b/src/Dodge/Item/Weapon/Remote.hs index 5be2e72e5..4eaa513c8 100644 --- a/src/Dodge/Item/Weapon/Remote.hs +++ b/src/Dodge/Item/Weapon/Remote.hs @@ -1,26 +1,30 @@ -module Dodge.Item.Weapon.Remote - ( setRemoteScope - , setRemoteBombScope - ) where -import Dodge.Data +module Dodge.Item.Weapon.Remote ( + setRemoteScope, + setRemoteBombScope, +) where + +import Control.Lens +import Dodge.Data.World import Dodge.Default import Geometry - import qualified IntMapHelp as IM -import Control.Lens setRemoteBombScope :: Int -> Prop -> World -> World setRemoteBombScope itid pj w' = case _itemLocations (_cWorld w') IM.! itid of - InInv cid invid - -> w' & cWorld . creatures . ix cid . crInv . ix invid . itScope - . scopePos .~ (_prPos pj -.- _crPos (_creatures (_cWorld w') IM.! cid)) - & cWorld . creatures . ix cid . crInv . ix invid . itUse . useAim . aimZoom - .~ (defaultItZoom {_itZoomMax = 0.5, _itZoomMin = 0.5}) - _ -> w' + InInv cid invid -> + w' + & cWorld . creatures . ix cid . crInv . ix invid . itScope + . scopePos + .~ (_prPos pj -.- _crPos (_creatures (_cWorld w') IM.! cid)) + & cWorld . creatures . ix cid . crInv . ix invid . itUse . heldAim . aimZoom + .~ (defaultItZoom{_itZoomMax = 0.5, _itZoomMin = 0.5}) + _ -> w' setRemoteScope :: Int -> Point2 -> World -> World setRemoteScope itid pos w' = case w' ^? cWorld . itemLocations . ix itid of - Just (InInv cid' invid ) - -> w' & cWorld . creatures . ix cid' . crInv . ix invid . itScope - . scopePos .~ (pos -.- _crPos (_creatures (_cWorld w') IM.! cid')) - _ -> w' + Just (InInv cid' invid) -> + w' + & cWorld . creatures . ix cid' . crInv . ix invid . itScope + . scopePos + .~ (pos -.- _crPos (_creatures (_cWorld w') IM.! cid')) + _ -> w' diff --git a/src/Dodge/Item/Weapon/Shatter.hs b/src/Dodge/Item/Weapon/Shatter.hs index 99fa42e4e..41897eff4 100644 --- a/src/Dodge/Item/Weapon/Shatter.hs +++ b/src/Dodge/Item/Weapon/Shatter.hs @@ -1,29 +1,19 @@ module Dodge.Item.Weapon.Shatter where ---import Dodge.WorldEvent.HitEffect ---import Dodge.Item.Weapon.BulletGun.Clip -import Dodge.Data -import Dodge.Wall.Damage ---import Dodge.SoundLogic -import Dodge.Block.Debris + import Dodge.Base.Collide ---import Dodge.Zone +import Dodge.Block.Debris import Dodge.Creature.HandPos ---import Dodge.ChainEffect -import Dodge.Default.Weapon +import Dodge.Data.World +import Dodge.Wall.Damage import Geometry import LensHelp -shatterGun :: Item -shatterGun = defaultWeapon - & itType . iyBase .~ HELD SHATTERGUN - & itUse . useDelay . rateMax .~ 10 - & itUse . rUse .~ HeldShatter --shootShatter - & itUse . useMods .~ ShatterMod - & itUse . useAim . aimStance .~ TwoHandFlat shootShatter :: Item -> Creature -> World -> World -shootShatter it cr w = maybe w (uncurry $ shatterWall w sp ep) $ sequence - $ collidePointWallsFilterStream canshatter sp ep w +shootShatter it cr w = + maybe w (uncurry $ shatterWall w sp ep) $ + sequence $ + collidePointWallsFilterStream canshatter sp ep w where canshatter wl = case _wlOpacity wl of Opaque -> True @@ -34,9 +24,15 @@ shootShatter it cr w = maybe w (uncurry $ shatterWall w sp ep) $ sequence ep = sp +.+ 200 *.* unitVectorAtAngle dir shatterWall :: World -> Point2 -> Point2 -> Point2 -> Wall -> World -shatterWall w sp ep p wl = w - & makeDebris (_wlMaterial wl) (_wlColor wl) p - & makeDebrisDirected 1 2 (pi/2) (argV $ vNormal $ uncurry (-.-) $ _wlLine wl) (_wlMaterial wl) - (_wlColor wl) p - & damageWall (Damage SHATTERING 1000 sp p ep NoDamageEffect) wl - +shatterWall w sp ep p wl = + w + & makeDebris (_wlMaterial wl) (_wlColor wl) p + & makeDebrisDirected + 1 + 2 + (pi / 2) + (argV $ vNormal $ uncurry (-.-) $ _wlLine wl) + (_wlMaterial wl) + (_wlColor wl) + p + & damageWall (Damage SHATTERING 1000 sp p ep NoDamageEffect) wl diff --git a/src/Dodge/Item/Weapon/Shell.hs b/src/Dodge/Item/Weapon/Shell.hs index 3915a6575..9b1438881 100644 --- a/src/Dodge/Item/Weapon/Shell.hs +++ b/src/Dodge/Item/Weapon/Shell.hs @@ -1,17 +1,19 @@ -module Dodge.Item.Weapon.Shell - ( decTimMvVel - ) where -import Dodge.Data -import Geometry.Vector +module Dodge.Item.Weapon.Shell ( + decTimMvVel, +) where import Control.Lens +import Dodge.Data.World +import Geometry.Vector + decTimMvVel :: Proj -> World -> World -decTimMvVel pj = cWorld . projectiles . ix pjid %~ - ( (prjTimer -~ 1) - . (prjPos %~ (+.+ vel) ) - . (prjAcc %~ rotateV rot ) - ) +decTimMvVel pj = + cWorld . projectiles . ix pjid + %~ ( (prjTimer -~ 1) + . (prjPos %~ (+.+ vel)) + . (prjAcc %~ rotateV rot) + ) where - rot = _prjSpin pj - vel = _prjVel pj - pjid = _prjID pj + rot = _prjSpin pj + vel = _prjVel pj + pjid = _prjID pj diff --git a/src/Dodge/Item/Weapon/Spawn.hs b/src/Dodge/Item/Weapon/Spawn.hs index 6dc2b746d..dd61da622 100644 --- a/src/Dodge/Item/Weapon/Spawn.hs +++ b/src/Dodge/Item/Weapon/Spawn.hs @@ -1,33 +1,34 @@ module Dodge.Item.Weapon.Spawn where -import Dodge.Data -import Dodge.Default.Weapon + +import Dodge.Default.Item +import Control.Lens +import Dodge.Data.World import Geometry import qualified IntMapHelp as IM -import Data.Function -import Control.Lens - - {- | -Creates a creature next to the creature using the item. -} +Creates a creature next to the creature using the item. +-} spawnGun :: Creature -> Item -spawnGun _ = defaultWeapon - & itUse . useDelay . rateMax .~ 100 - & itUse . rUse .~ HeldDoNothing --(\_ -> spawnCrNextTo cr) - & itUse . useMods .~ HeldModNothing --- [ ammoCheckI --- , hammerCheckI --- ] - & itType . iyBase .~ LEFT SPAWNER -spawnCrNextTo - :: Creature -- ^ Creature to spawn - -> Creature -- ^ existing creature that will be spawned next to - -> World - -> World +spawnGun _ = + defaultHeldItem + & itUse . heldDelay . rateMax .~ 100 + & itUse . heldUse .~ HeldDoNothing --(\_ -> spawnCrNextTo cr) + & itUse . heldMods .~ HeldModNothing + & itType . iyBase .~ LEFT SPAWNER + +spawnCrNextTo :: + -- | Creature to spawn + Creature -> + -- | existing creature that will be spawned next to + Creature -> + World -> + World spawnCrNextTo cr sCr w = w & cWorld . creatures %~ IM.insert k newCr where k = IM.newKey $ _creatures (_cWorld w) - newCr = cr - & crID .~ k - & crPos .~ _crPos sCr +.+ unitVectorAtAngle (_crDir sCr) - & crOldPos .~ _crPos sCr +.+ unitVectorAtAngle (_crDir sCr) + newCr = + cr + & crID .~ k + & crPos .~ _crPos sCr +.+ unitVectorAtAngle (_crDir sCr) + & crOldPos .~ _crPos sCr +.+ unitVectorAtAngle (_crDir sCr) diff --git a/src/Dodge/Item/Weapon/Targeting.hs b/src/Dodge/Item/Weapon/Targeting.hs index 5c0b04534..bf8a38ddd 100644 --- a/src/Dodge/Item/Weapon/Targeting.hs +++ b/src/Dodge/Item/Weapon/Targeting.hs @@ -1,17 +1,17 @@ -module Dodge.Item.Weapon.Targeting - ( useTargetPos - , removeItTarget - ) where -import Dodge.Data -import Geometry.Data +module Dodge.Item.Weapon.Targeting ( + useTargetPos, + removeItTarget, +) where import Control.Lens ---import qualified IntMapHelp as IM -useTargetPos - :: (Maybe Point2 -> Creature -> World -> World) - -> Creature - -> World - -> World +import Dodge.Data.World +import Geometry.Data + +useTargetPos :: + (Maybe Point2 -> Creature -> World -> World) -> + Creature -> + World -> + World useTargetPos f cr w = case cr ^? crInv . ix (crSel cr) . itTargeting . tgPos of Nothing -> w Just p -> f p cr w diff --git a/src/Dodge/Item/Weapon/TriggerType.hs b/src/Dodge/Item/Weapon/TriggerType.hs index d7695abc3..9441bfc25 100644 --- a/src/Dodge/Item/Weapon/TriggerType.hs +++ b/src/Dodge/Item/Weapon/TriggerType.hs @@ -1,139 +1,138 @@ {-# LANGUAGE TupleSections #-} + {- | -Weapon effects when pulling the trigger. -} -module Dodge.Item.Weapon.TriggerType - ( useAmmoAmount - , useAllAmmo - , useAmmoUpTo - , lockInvFor - , withMuzFlareI - , withMuzPos - , withMuzPosShift - , crAtMuzPos - , withOldDir - , trigDoAlso - , trigDoAlso' - , withTempLight - , withItem - , withItemUpdate - , withItemUpdate' - , ammoUseCheck - , rateIncAB - , torqueBefore - , torqueBeforeAtLeast --- , torqueAfterI - , withTorqueAfter - , torqueSideEffect - , withRandomItemParams - , withRandomItemUpdate - , withSoundStart - , withSoundItemChoiceStart - , withSoundContinue - , withSoundForI - , withSoundForVol - , withSmoke - , withThickSmokeI - , withThinSmokeI - , withPositionOffset - , withPositionWallCheck - , withPosDirWallCheck - , withRandomOffset - , withRandomDirI - , withRecoil - , afterRecoil - , withSidePushAfterI - , withSidePushI - , withWarmUp - , spreadNumI - , spreadLoaded - , repeatOnFrames - , sideEffectOnFrame - , duplicateItem - , duplicateLoadedBarrels - , duplicateLoaded - , duplicateOffsets - , duplicateOffsetsV2 - , duplicateOffsetsFocus - , hammerCheckI - , hammerCheckL - , shootL - , useTimeCheck - , ammoCheckI - , applyInaccuracy - , modClock - , ammoHammerCheck - ) where -import Dodge.Data.WorldEffect -import Dodge.Data -import Dodge.Base.Collide -import Dodge.SoundLogic -import Dodge.Reloading -import Dodge.WorldEvent -import RandomHelp -import Dodge.Inventory.Lock +Weapon effects when pulling the trigger. +-} +module Dodge.Item.Weapon.TriggerType ( + useAmmoAmount, + useAllAmmo, + useAmmoUpTo, + lockInvFor, + withMuzFlareI, + withMuzPos, + withMuzPosShift, + crAtMuzPos, + withOldDir, + trigDoAlso, + trigDoAlso', + withTempLight, + withItem, + withItemUpdate, + withItemUpdate', + ammoUseCheck, + rateIncAB, + torqueBefore, + torqueBeforeAtLeast, + withTorqueAfter, + torqueSideEffect, + withRandomItemParams, + withRandomItemUpdate, + withSoundStart, + withSoundItemChoiceStart, + withSoundContinue, + withSoundForI, + withSoundForVol, + withSmoke, + withThickSmokeI, + withThinSmokeI, + withPositionOffset, + withPositionWallCheck, + withPosDirWallCheck, + withRandomOffset, + withRandomDirI, + withRecoil, + afterRecoil, + withSidePushAfterI, + withSidePushI, + withWarmUp, + spreadNumI, + spreadLoaded, + repeatOnFrames, + sideEffectOnFrame, + duplicateItem, + duplicateLoadedBarrels, + duplicateLoaded, + duplicateOffsets, + duplicateOffsetsV2, + duplicateOffsetsFocus, + hammerCheckI, + hammerCheckL, + shootL, + useTimeCheck, + ammoCheckI, + applyInaccuracy, + modClock, + ammoHammerCheck, +) where + +import Data.Foldable +import Data.Maybe +import Dodge.Base import Dodge.Creature.HandPos import Dodge.Creature.Test ---import Dodge.Default -import Dodge.Base -import Sound.Data -import Geometry ---import Geometry.Vector3D +import Dodge.Data.World +import Dodge.Inventory.Lock import Dodge.LightSource ---import Data.Preload +import Dodge.Reloading +import Dodge.SoundLogic +import Dodge.WorldEvent +import Geometry import LensHelp +import RandomHelp +import Sound.Data ---import Control.Lens -import Data.Maybe ---import qualified IntMapHelp as IM -import Data.Foldable - -type ChainEffect - = (Item -> Creature -> World -> World) - -> Item - -> Creature - -> World - -> World +type ChainEffect = + (Item -> Creature -> World -> World) -> + Item -> + Creature -> + World -> + World lockInvFor :: Int -> ChainEffect -lockInvFor i f it cr = f it cr . (cWorld . delayedEvents .:~ (i, UnlockInv (_crID cr))) - . lockInv (_crID cr) +lockInvFor i f it cr = + f it cr . (cWorld . delayedEvents .:~ (i, UnlockInv (_crID cr))) + . lockInv (_crID cr) -trigDoAlso' - :: (Item -> Item) - -> (Creature -> Creature) - -> (Item -> Creature -> World -> World) - -> ChainEffect +trigDoAlso' :: + (Item -> Item) -> + (Creature -> Creature) -> + (Item -> Creature -> World -> World) -> + ChainEffect trigDoAlso' fit fcr f g itm cr = g itm cr . f (fit itm) (fcr cr) -- Note that this uses the "base" creature and item values -trigDoAlso - :: (Item -> Creature -> World -> World) - -> ChainEffect +trigDoAlso :: + (Item -> Creature -> World -> World) -> + ChainEffect trigDoAlso afterEff eff item cr = afterEff item cr . eff item cr withSmoke :: Int -> Point4 -> Float -> Int -> Float -> ChainEffect -withSmoke num col rad t alt eff item cr w = eff item cr - $ foldl' (flip $ smokeCloudAt col rad t alt . (+.+.+ pos) . (*8)) w ps +withSmoke num col rad t alt eff item cr w = + eff item cr $ + foldl' (flip $ smokeCloudAt col rad t alt . (+.+.+ pos) . (* 8)) w ps where dir = _crDir cr pos = addZ 0 $ _crPos cr +.+ (_crRad cr + 15) *.* unitVectorAtAngle dir ps = replicateM num randOnUnitSphere & evalState $ _randGen w withThinSmokeI :: ChainEffect -withThinSmokeI eff item cr w = eff item cr - $ foldl' (flip $ makeThinSmokeAt . (+.+.+ pos) . (* 8)) w ps +withThinSmokeI eff item cr w = + eff item cr $ + foldl' (flip $ makeThinSmokeAt . (+.+.+ pos) . (* 8)) w ps where dir = _crDir cr - pos = addZ 0 $ _crPos cr +.+ (_crRad cr +0.5) *.* unitVectorAtAngle dir + pos = addZ 0 $ _crPos cr +.+ (_crRad cr + 0.5) *.* unitVectorAtAngle dir ps = replicateM 5 randOnUnitSphere & evalState $ _randGen w withThickSmokeI :: ChainEffect -withThickSmokeI eff item cr w = eff item cr - $ foldl' (flip $ makeThickSmokeAt . (+.+.+ pos) . (*8)) w ps +withThickSmokeI eff item cr w = + eff item cr $ + foldl' (flip $ makeThickSmokeAt . (+.+.+ pos) . (* 8)) w ps where dir = _crDir cr pos = addZ 0 $ _crPos cr +.+ (_crRad cr + 15) *.* unitVectorAtAngle dir ps = replicateM 20 randOnUnitSphere & evalState $ _randGen w + -- TODO create a trigger that does different things on first and continued -- fire. ammoCheckI :: ChainEffect @@ -148,225 +147,297 @@ ammoCheckI eff itm cr w ammoHammerCheck :: ChainEffect ammoHammerCheck eff it cr w | _laLoaded ic <= 0 || not (_laPrimed ic) = w -- fromMaybe w (startReloadingWeapon cr w) - | otherwise = case it ^? itUse . useHammer of + | otherwise = case it ^? itUse . heldHammer of Just HammerUp -> eff it cr $ w & cWorld . creatures . ix (_crID cr) %~ crCancelReloading - _ -> w - where + _ -> w + where ic = _heldConsumption $ _itUse it itUseCharge :: Int -> Item -> Item -itUseCharge x = itUse . leftConsumption . arLoaded %~ (max 0 . subtract x) +itUseCharge x = itUse . leftConsumption . arLoaded %~ (max 0 . subtract x) itUseAmmo :: Int -> Item -> Item itUseAmmo x = itUse . heldConsumption . laLoaded %~ (max 0 . subtract x) {- | Fires at an increasing rate. Has different effect after first fire. -Applies ammo check and use cooldown check. -} -rateIncAB - :: ChainEffect -- ^ Extra effect on first fire - -> ChainEffect -- ^ Extra effect on continued fire - -> ChainEffect +Applies ammo check and use cooldown check. +-} +rateIncAB :: + -- | Extra effect on first fire + ChainEffect -> + -- | Extra effect on continued fire + ChainEffect -> + ChainEffect rateIncAB exeffFirst exeffCont eff item cr w - | repeatFire = w - & pointItem %~ ( (itUse . useDelay . rateMax .~ max fastRate (currentRate - 1)) - . itUseAmmo 1 - . (itUse . useDelay . rateTime .~ currentRate) ) - & exeffCont eff item cr - | firstFire = w - & pointItem %~ ( (itUse . useDelay . rateMax .~ startRate - 1) - . itUseAmmo 1 - . (itUse . useDelay . rateTime .~ startRate) ) - & exeffFirst eff item cr + | repeatFire = + w + & pointItem + %~ ( (itUse . heldDelay . rateMax .~ max fastRate (currentRate - 1)) + . itUseAmmo 1 + . (itUse . heldDelay . rateTime .~ currentRate) + ) + & exeffCont eff item cr + | firstFire = + w + & pointItem + %~ ( (itUse . heldDelay . rateMax .~ startRate - 1) + . itUseAmmo 1 + . (itUse . heldDelay . rateTime .~ startRate) + ) + & exeffFirst eff item cr | otherwise = w - where - fastRate = _rateMinMax . _useDelay $ _itUse item - startRate = _rateMaxMax . _useDelay $ _itUse item + where + fastRate = _rateMinMax . _heldDelay $ _itUse item + startRate = _rateMaxMax . _heldDelay $ _itUse item cid = _crID cr itRef = crSel cr pointItem = cWorld . creatures . ix cid . crInv . ix itRef - currentRate = _rateMax (_useDelay (_itUse item)) - repeatFire = crWeaponReady cr && _rateTime (_useDelay (_itUse item)) == 1 - firstFire = crWeaponReady cr && _rateTime (_useDelay (_itUse item)) == 0 -{- | Apply effect after a warm up. -} + currentRate = _rateMax (_heldDelay (_itUse item)) + repeatFire = crWeaponReady cr && _rateTime (_heldDelay (_itUse item)) == 1 + firstFire = crWeaponReady cr && _rateTime (_heldDelay (_itUse item)) == 0 + +-- | Apply effect after a warm up. + -- note this is quite unsafe, requires the item to have the correct delay type -withWarmUp - :: SoundID -- ^ warm up sound id - -> ChainEffect +withWarmUp :: + -- | warm up sound id + SoundID -> + ChainEffect withWarmUp soundID f item cr w - | curWarmUp < maxWarmUp && crWeaponReady cr = w - & pointerToItem . itUse . useDelay . warmTime +~ 2 - & soundContinue (CrWeaponSound cid 0) (_crPos cr) soundID (Just 2) - | otherwise = w - & pointerToItem . itUse . useDelay . warmTime .~ maxWarmUp - & f item cr - where + | curWarmUp < maxWarmUp && crWeaponReady cr = + w + & pointerToItem . itUse . heldDelay . warmTime +~ 2 + & soundContinue (CrWeaponSound cid 0) (_crPos cr) soundID (Just 2) + | otherwise = + w + & pointerToItem . itUse . heldDelay . warmTime .~ maxWarmUp + & f item cr + where cid = _crID cr itRef = crSel cr pointerToItem = cWorld . creatures . ix cid . crInv . ix itRef - curWarmUp = _warmTime . _useDelay $ _itUse item - maxWarmUp = _warmMax . _useDelay $ _itUse item -withSoundItemChoiceStart - :: (Item -> SoundID) - -> ChainEffect -withSoundItemChoiceStart soundf f it cr - = soundMultiFrom [CrWeaponSound cid 0,CrWeaponSound cid 1,CrWeaponSound cid 2] (_crPos cr) - (soundf it) Nothing - . f it cr - where - cid = _crID cr -{- | Adds a sound to a creature based world effect. -The sound is emitted from the creature's position. -} -withSoundStart - :: SoundID -- ^ Sound id - -> ChainEffect -withSoundStart soundid f item cr - = soundMultiFrom [CrWeaponSound cid 0,CrWeaponSound cid 1,CrWeaponSound cid 2] (_crPos cr) soundid Nothing - . f item cr - where - cid = _crID cr -{- | Adds a sound to a creature based world effect. -The sound is emitted from the creature's position. -} -withSoundContinue - :: SoundID -- ^ Sound id - -> ChainEffect -withSoundContinue soundid f item cr - = soundContinue (CrWeaponSound cid 0) (_crPos cr) soundid Nothing - . f item cr - where - cid = _crID cr -{- | Adds a sound to a creature based world effect. -The sound is emitted from the creature's position. -} -withSoundForI - :: SoundID -- ^ Sound id - -> Int -- ^ Frames to play - -> ChainEffect -withSoundForI soundid playTime f item cr - = soundContinue (CrWeaponSound (_crID cr) 0) (_crPos cr) soundid (Just playTime) - . f item cr + curWarmUp = _warmTime . _heldDelay $ _itUse item + maxWarmUp = _warmMax . _heldDelay $ _itUse item -{- | Adds a sound to a creature based world effect. -The sound is emitted from the creature's position. -} -withSoundForVol - :: Float -- ^ volume - -> SoundID -- ^ Sound id - -> Int -- ^ Frames to play - -> ChainEffect -withSoundForVol vol soundid playTime f item cr - = soundContinueVol vol (CrWeaponSound (_crID cr) 0) (_crPos cr) soundid (Just playTime) - . f item cr +withSoundItemChoiceStart :: + (Item -> SoundID) -> + ChainEffect +withSoundItemChoiceStart soundf f it cr = + soundMultiFrom + [CrWeaponSound cid 0, CrWeaponSound cid 1, CrWeaponSound cid 2] + (_crPos cr) + (soundf it) + Nothing + . f it cr + where + cid = _crID cr -afterRecoil - :: Float -- ^ Recoil amount - -> ChainEffect +{- | Adds a sound to a creature based world effect. +The sound is emitted from the creature's position. +-} +withSoundStart :: + -- | Sound id + SoundID -> + ChainEffect +withSoundStart soundid f item cr = + soundMultiFrom [CrWeaponSound cid 0, CrWeaponSound cid 1, CrWeaponSound cid 2] (_crPos cr) soundid Nothing + . f item cr + where + cid = _crID cr + +{- | Adds a sound to a creature based world effect. +The sound is emitted from the creature's position. +-} +withSoundContinue :: + -- | Sound id + SoundID -> + ChainEffect +withSoundContinue soundid f item cr = + soundContinue (CrWeaponSound cid 0) (_crPos cr) soundid Nothing + . f item cr + where + cid = _crID cr + +{- | Adds a sound to a creature based world effect. +The sound is emitted from the creature's position. +-} +withSoundForI :: + -- | Sound id + SoundID -> + -- | Frames to play + Int -> + ChainEffect +withSoundForI soundid playTime f item cr = + soundContinue (CrWeaponSound (_crID cr) 0) (_crPos cr) soundid (Just playTime) + . f item cr + +{- | Adds a sound to a creature based world effect. +The sound is emitted from the creature's position. +-} +withSoundForVol :: + -- | volume + Float -> + -- | Sound id + SoundID -> + -- | Frames to play + Int -> + ChainEffect +withSoundForVol vol soundid playTime f item cr = + soundContinueVol vol (CrWeaponSound (_crID cr) 0) (_crPos cr) soundid (Just playTime) + . f item cr + +afterRecoil :: + -- | Recoil amount + Float -> + ChainEffect afterRecoil recoilAmount eff item cr = eff item (pushback cr) . over (cWorld . creatures . ix cid) pushback - where + where cid = _crID cr - pushback = over crPos (+.+ rotateV (_crDir cr) (V2 ((-recoilAmount) / _crMass cr ) 0)) + pushback = over crPos (+.+ rotateV (_crDir cr) (V2 ((- recoilAmount) / _crMass cr) 0)) + withRecoil :: ChainEffect withRecoil eff it cr = eff it cr . over (cWorld . creatures . ix cid) pushback - where - cid = _crID cr - recoilAmount = fromMaybe 0 $ it ^? itParams . recoil - pushback = over crPos (+.+ rotateV (_crDir cr) (V2 ((-recoilAmount) / _crMass cr ) 0)) -{- | Pushes a creature sideways by a random amount. -Applied before the underlying effect. -} -withSidePushI - :: Float -- ^ Maximal possible side push amount - -> ChainEffect -withSidePushI maxSide eff item cr w = eff item (push cr) $ w - & cWorld . creatures . ix cid %~ push - & randGen .~ g - where - cid = _crID cr - push = over crPos (+.+ rotateV (_crDir cr) (V2 0 (pushAmount / _crMass cr))) - (pushAmount, g) = randomR (-maxSide,maxSide) $ _randGen w --- consider unifying the pushes using a direction vector -{- | Pushes a creature sideways by a random amount. -Applied after the underlying effect. -} -withSidePushAfterI - :: Float -- ^ Maximal possible side push amount - -> ChainEffect -withSidePushAfterI maxSide eff item cr w = over (cWorld . creatures . ix cid) push . eff item cr $ w - & randGen .~ g - where - cid = _crID cr - push = over crPos (+.+ rotateV (_crDir cr) (V2 0 (pushAmount / _crMass cr))) - (pushAmount, g) = randomR (-maxSide,maxSide) $ _randGen w -useAllAmmo :: ChainEffect -useAllAmmo eff item cr = eff item cr - . (cWorld . creatures . ix (_crID cr) . crInv . ix (crSel cr) . itUse . heldConsumption . laLoaded .~ 0) -useAmmoUpTo :: Int -> ChainEffect -useAmmoUpTo amAmount eff item cr = eff item cr - . (cWorld . creatures . ix (_crID cr) . crInv . ix (crSel cr) . itUse . heldConsumption . laLoaded - %~ (max 0 . subtract amAmount)) -useAmmoAmount :: Int -> ChainEffect -useAmmoAmount amAmount eff item cr = eff item cr - . (cWorld . creatures . ix (_crID cr) . crInv . ix (crSel cr) . itUse . heldConsumption . laLoaded -~ amAmount) -{- | -Applies a world effect after an item use cooldown check. -} -useTimeCheck :: ChainEffect -useTimeCheck f item cr w = case item ^? itUse . useDelay . rateTime of - Just 0 -> f item cr $ setUseTime w - _ -> w where cid = _crID cr - setUseTime = cWorld . creatures . ix cid . crInv . ix (crSel cr) . itUse . useDelay . rateTime +~ userate - userate = fromMaybe 0 $ item ^? itUse . useDelay . rateMax -{- | Applies a world effect after a hammer position check. -} -hammerCheckI :: ChainEffect -hammerCheckI f it cr w = case it ^? itUse . useHammer of - Just HammerUp | _laPrimed (_heldConsumption (_itUse it)) - -> f it cr w - _ -> w + recoilAmount = fromMaybe 0 $ it ^? itParams . recoil + pushback = over crPos (+.+ rotateV (_crDir cr) (V2 ((- recoilAmount) / _crMass cr) 0)) + +{- | Pushes a creature sideways by a random amount. +Applied before the underlying effect. +-} +withSidePushI :: + -- | Maximal possible side push amount + Float -> + ChainEffect +withSidePushI maxSide eff item cr w = + eff item (push cr) $ + w + & cWorld . creatures . ix cid %~ push + & randGen .~ g + where + cid = _crID cr + push = over crPos (+.+ rotateV (_crDir cr) (V2 0 (pushAmount / _crMass cr))) + (pushAmount, g) = randomR (- maxSide, maxSide) $ _randGen w + +-- consider unifying the pushes using a direction vector + +{- | Pushes a creature sideways by a random amount. +Applied after the underlying effect. +-} +withSidePushAfterI :: + -- | Maximal possible side push amount + Float -> + ChainEffect +withSidePushAfterI maxSide eff item cr w = + over (cWorld . creatures . ix cid) push . eff item cr $ + w + & randGen .~ g + where + cid = _crID cr + push = over crPos (+.+ rotateV (_crDir cr) (V2 0 (pushAmount / _crMass cr))) + (pushAmount, g) = randomR (- maxSide, maxSide) $ _randGen w + +useAllAmmo :: ChainEffect +useAllAmmo eff item cr = + eff item cr + . (cWorld . creatures . ix (_crID cr) . crInv . ix (crSel cr) . itUse . heldConsumption . laLoaded .~ 0) + +useAmmoUpTo :: Int -> ChainEffect +useAmmoUpTo amAmount eff item cr = + eff item cr + . ( cWorld . creatures . ix (_crID cr) . crInv . ix (crSel cr) . itUse . heldConsumption . laLoaded + %~ (max 0 . subtract amAmount) + ) + +useAmmoAmount :: Int -> ChainEffect +useAmmoAmount amAmount eff item cr = + eff item cr + . (cWorld . creatures . ix (_crID cr) . crInv . ix (crSel cr) . itUse . heldConsumption . laLoaded -~ amAmount) + +{- | +Applies a world effect after an item use cooldown check. +-} +useTimeCheck :: ChainEffect +useTimeCheck f item cr w = case item ^? itUse . heldDelay . rateTime of + Just 0 -> f item cr $ setUseTime w + _ -> w + where + cid = _crID cr + setUseTime = cWorld . creatures . ix cid . crInv . ix (crSel cr) . itUse . heldDelay . rateTime +~ userate + userate = fromMaybe 0 $ item ^? itUse . heldDelay . rateMax + +-- | Applies a world effect after a hammer position check. +hammerCheckI :: ChainEffect +hammerCheckI f it cr w = case it ^? itUse . heldHammer of + Just HammerUp + | _laPrimed (_heldConsumption (_itUse it)) -> + f it cr w + _ -> w + +-- | Applies a world effect after an ammo check. -{- | Applies a world effect after an ammo check. -} -- this should be made "safe" incase there is no _rateTime -ammoUseCheck :: ChainEffect -ammoUseCheck f item cr w - | fireCondition = f item cr w & pointerToItem %~ - ( itUseAmmo 1 - . (itUse . useDelay . rateTime .~ _rateMax ( _useDelay (_itUse item)) )) --- | reloadCondition = fromMaybe w $ startReloadingWeapon cr w +ammoUseCheck :: ChainEffect +ammoUseCheck f item cr w + | fireCondition = + f item cr w & pointerToItem + %~ ( itUseAmmo 1 + . (itUse . heldDelay . rateTime .~ _rateMax (_heldDelay (_itUse item))) + ) + -- | reloadCondition = fromMaybe w $ startReloadingWeapon cr w | otherwise = w - where + where cid = _crID cr itRef = crSel cr pointerToItem = cWorld . creatures . ix cid . crInv . ix itRef - fireCondition = crWeaponReady cr - && _rateTime (_useDelay (_itUse item)) == 0 - && _laLoaded (_heldConsumption (_itUse item)) > 0 --- reloadCondition = _laLoaded (_itConsumption item) == 0 -{- | Applies a world effect after a hammer position check. -Arbitrary inventory position. -} -hammerCheckL - :: (Item -> Creature -> World -> World) -- ^ Underlying effect - -> Item -> Creature -> World -> World -hammerCheckL f itm cr w = case itm ^? itUse . useHammer of - Just HammerUp -> f itm cr w - _ -> w + fireCondition = + crWeaponReady cr + && _rateTime (_heldDelay (_itUse item)) == 0 + && _laLoaded (_heldConsumption (_itUse item)) > 0 -{- | Applies a world effect after an ammo check. -Arbitrary inventory position -- cannot be replaced with ammoUseCheck. -} -shootL - :: (Item -> Creature -> World -> World) - -- ^ Underlying effect - -> Item - -> Creature - -> World - -> World -shootL f item cr w - | fireCondition = f item cr w & pointerToItem %~ - ( itUseCharge 1 - . (itUse . useDelay . rateTime .~ _rateMax (_useDelay (_itUse item))) ) --- | reloadCondition = fromMaybe w $ startReloadingWeapon cr w +-- reloadCondition = _laLoaded (_itConsumption item) == 0 + +{- | Applies a world effect after a hammer position check. +Arbitrary inventory position. +-} +hammerCheckL :: + -- | Underlying effect + (Item -> Creature -> World -> World) -> + Item -> + Creature -> + World -> + World +hammerCheckL f itm cr w = case itm ^? itUse . leftHammer of + Just HammerUp -> f itm cr w + _ -> w + +{- | Applies a world effect after an ammo check. +Arbitrary inventory position -- cannot be replaced with ammoUseCheck. +-} +shootL :: + -- | Underlying effect + (Item -> Creature -> World -> World) -> + Item -> + Creature -> + World -> + World +shootL f item cr w + | fireCondition = + f item cr w & pointerToItem + %~ ( itUseCharge 1 + . (itUse . leftDelay . rateTime .~ _rateMax (_leftDelay (_itUse item))) + ) + -- | reloadCondition = fromMaybe w $ startReloadingWeapon cr w | otherwise = w - where + where cid = _crID cr invid = _ipInvID $ _itLocation item pointerToItem = cWorld . creatures . ix cid . crInv . ix invid - fireCondition = _rateTime (_useDelay (_itUse item)) == 0 - && _arLoaded (_leftConsumption (_itUse item)) > 0 + fireCondition = + _rateTime (_leftDelay (_itUse item)) == 0 + && _arLoaded (_leftConsumption (_itUse item)) > 0 + -- reloadCondition = _laLoaded (_itConsumption item) == 0 withItem :: (Item -> ChainEffect) -> ChainEffect withItem g f it = g it f it @@ -377,9 +448,11 @@ withItemUpdate' up f it cr = f (up it) cr . (cWorld . creatures . ix (_crID cr) withItemUpdate :: (Item -> Item) -> (Item -> ChainEffect) -> ChainEffect withItemUpdate up g f it cr = g it f it cr . (cWorld . creatures . ix (_crID cr) . crInv . ix (crSel cr) %~ up) + withTempLight :: Int -> Float -> V3 Float -> ChainEffect -withTempLight time rad col eff item cr = eff item cr - . over (cWorld . tempLightSources) (theTLS :) +withTempLight time rad col eff item cr = + eff item cr + . over (cWorld . tempLightSources) (theTLS :) where theTLS = tlsTimeRadColPos time rad col (V3 x y 10) V2 x y = _crPos cr +.+ 15 *.* unitVectorAtAngle (_crDir cr) @@ -390,150 +463,175 @@ modClock n chainEff eff it cr w | otherwise = eff it cr w withMuzFlareI :: ChainEffect -withMuzFlareI f it cr w = makeTlsTimeRadColPos 2 100 (V3 1 1 0.5) flashPos - . muzFlareAt (V4 5 5 0 2) flarePos cdir - $ f it cr w - where +withMuzFlareI f it cr w = + makeTlsTimeRadColPos 2 100 (V3 1 1 0.5) flashPos + . muzFlareAt (V4 5 5 0 2) flarePos cdir + $ f it cr w + where flarePos = addZ 0 (_crPos cr) +.+.+ rotate3z cdir (muzzleOffset cr it +.+.+ V3 0 0 20) flashPos = addZ 0 (_crPos cr) +.+.+ rotate3z cdir (muzzleOffset cr it +.+.+ V3 5 0 20) --- muzzleOffset = V3 (_muzPos (_dimPortage (_itDimension it))) 0 0 + -- muzzleOffset = V3 (_muzPos (_dimPortage (_itDimension it))) 0 0 cdir = _crDir cr muzzleOffset :: Creature -> Item -> Point3 muzzleOffset cr it = V3 (holdOffset + 5 + _aimMuzPos dimPort - _aimHandlePos dimPort) 0 0 where - dimPort = _useAim $ _itUse it + dimPort = _heldAim $ _itUse it holdOffset | crInAimStance OneHand cr = 10 | otherwise = 0 withMuzPos :: (Point3 -> World -> World) -> ChainEffect withMuzPos = withMuzPosShift (V2 0 0) + withMuzPosShift :: Point2 -> (Point3 -> World -> World) -> ChainEffect -withMuzPosShift p g f it cr w = g (pos `v2z` 20) - $ f it cr w +withMuzPosShift p g f it cr w = + g (pos `v2z` 20) $ + f it cr w where - pos = _crPos cr - +.+ rotateV dir p - +.+ aimingMuzzlePos cr it *.* unitVectorAtAngle dir + pos = + _crPos cr + +.+ rotateV dir p + +.+ aimingMuzzlePos cr it *.* unitVectorAtAngle dir dir = _crDir cr crAtMuzPos :: ChainEffect crAtMuzPos f it cr = f it (cr & crPos +.+.~ (aimingMuzzlePos cr it *.* unitVectorAtAngle (_crDir cr))) {- | Applies the effect to a randomly rotated creature, - - rotation amount given by inaccuracy in itParams -} + - rotation amount given by inaccuracy in itParams +-} applyInaccuracy :: ChainEffect applyInaccuracy f it cr w = f it (cr & crDir +~ a) $ set randGen g w - where + where acc = _brlInaccuracy . _gunBarrels $ _itParams it - (a, g) = randomR (-acc,acc) $ _randGen w -{- | Applies the effect to a randomly rotated creature. -} -withRandomDirI - :: Float -- ^ Max possible rotation - -> ChainEffect -withRandomDirI acc f it cr w = f it (cr & crDir +~ a) $ set randGen g w - where - (a, g) = randomR (-acc,acc) $ _randGen w -withOldDir - :: Float -- ^ The fraction of the old direction - -> ChainEffect -withOldDir aFrac eff item cr - = eff item (cr & crDir %~ tweenAngles aFrac (_crOldDir cr)) + (a, g) = randomR (- acc, acc) $ _randGen w -withRandomItemUpdate - :: State StdGen (Item -> Item) - -> ChainEffect +-- | Applies the effect to a randomly rotated creature. +withRandomDirI :: + -- | Max possible rotation + Float -> + ChainEffect +withRandomDirI acc f it cr w = f it (cr & crDir +~ a) $ set randGen g w + where + (a, g) = randomR (- acc, acc) $ _randGen w + +withOldDir :: + -- | The fraction of the old direction + Float -> + ChainEffect +withOldDir aFrac eff item cr = + eff item (cr & crDir %~ tweenAngles aFrac (_crOldDir cr)) + +withRandomItemUpdate :: + State StdGen (Item -> Item) -> + ChainEffect withRandomItemUpdate randItUp eff it cr w = eff (f it) cr $ w & randGen .~ g where - (f,g) = runState randItUp (_randGen w) + (f, g) = runState randItUp (_randGen w) withRandomItemParams :: State StdGen (ItemParams -> ItemParams) -> ChainEffect withRandomItemParams rip eff it cr w = eff (it & itParams %~ f) cr $ w & randGen .~ g where - (f,g) = runState rip (_randGen w) + (f, g) = runState rip (_randGen w) -withPositionOffset - :: (Item -> Creature -> World -> (Point2,Float)) - -> ChainEffect +withPositionOffset :: + (Item -> Creature -> World -> (Point2, Float)) -> + ChainEffect withPositionOffset h f it cr w = f it (cr & crPos .+.+~ p & crDir +~ a) w where - (p,a) = h it cr w + (p, a) = h it cr w -withPositionWallCheck - :: (Item -> Creature -> World -> Point2) - -> ChainEffect -withPositionWallCheck h f it cr w - | hasLOS p (_crPos cr) w = f it (cr & crPos .~ p) w +withPositionWallCheck :: + (Item -> Creature -> World -> Point2) -> + ChainEffect +withPositionWallCheck h f it cr w + | hasLOS p (_crPos cr) w = f it (cr & crPos .~ p) w | otherwise = w where p = h it cr w -withPosDirWallCheck - :: (Item -> Creature -> World -> (Point2,Float)) - -> ChainEffect -withPosDirWallCheck h f it cr w - | hasLOS p (_crPos cr) w = f it (cr & crPos .~ p & crDir .~ a) w + +withPosDirWallCheck :: + (Item -> Creature -> World -> (Point2, Float)) -> + ChainEffect +withPosDirWallCheck h f it cr w + | hasLOS p (_crPos cr) w = f it (cr & crPos .~ p & crDir .~ a) w | otherwise = w where - (p,a) = h it cr w + (p, a) = h it cr w -{- | Apply the effect to a translated creature. -} +-- | Apply the effect to a translated creature. withRandomOffset :: ChainEffect withRandomOffset f item cr w = f item (cr & crPos %~ (+.+ offV)) $ set randGen g w - where - (offsetVal , g) = randomR (-offsetAmount,offsetAmount) $ _randGen w + where + (offsetVal, g) = randomR (- offsetAmount, offsetAmount) $ _randGen w offV = rotateV (_crDir cr) (V2 0 offsetVal) offsetAmount = fromMaybe 0 $ item ^? itParams . randomOffset --- | Rotates a creature -torqueBefore - :: Float -- ^ Max possible rotation - -> ChainEffect -torqueBefore torque feff item cr w - | cid == 0 = feff item (cr & crDir +~ rot) $ w - & randGen .~ g - & cWorld . creatures . ix cid . crDir +~ rot - & cWorld . cameraRot +~ rot - | otherwise = feff item cr $ set randGen g $ over (cWorld . creatures . ix cid . crDir) (+rot) w - where + +-- | Rotates a creature +torqueBefore :: + -- | Max possible rotation + Float -> + ChainEffect +torqueBefore torque feff item cr w + | cid == 0 = + feff item (cr & crDir +~ rot) $ + w + & randGen .~ g + & cWorld . creatures . ix cid . crDir +~ rot + & cWorld . cameraRot +~ rot + | otherwise = feff item cr $ set randGen g $ over (cWorld . creatures . ix cid . crDir) (+ rot) w + where cid = _crID cr - (rot, g) = randomR (-torque,torque) $ _randGen w --- | Rotates a creature with minimum rotation --- Rotates the player creature before applying the effect, other creatures after. -torqueBeforeAtLeast - :: Float -- ^ Minimal possible rotation - -> Float -- ^ Extra possible rotation - -> ChainEffect -torqueBeforeAtLeast minTorque exTorque feff item cr w - | cid == 0 = feff item (cr & crDir +~ rot') $ w - & randGen .~ g - & cWorld . creatures . ix cid . crDir +~ rot' - & cWorld . cameraRot +~ rot' - | otherwise = feff item cr $ set randGen g $ over (cWorld . creatures . ix cid . crDir) (+rot') w - where + (rot, g) = randomR (- torque, torque) $ _randGen w + +{- | Rotates a creature with minimum rotation + Rotates the player creature before applying the effect, other creatures after. +-} +torqueBeforeAtLeast :: + -- | Minimal possible rotation + Float -> + -- | Extra possible rotation + Float -> + ChainEffect +torqueBeforeAtLeast minTorque exTorque feff item cr w + | cid == 0 = + feff item (cr & crDir +~ rot') $ + w + & randGen .~ g + & cWorld . creatures . ix cid . crDir +~ rot' + & cWorld . cameraRot +~ rot' + | otherwise = feff item cr $ set randGen g $ over (cWorld . creatures . ix cid . crDir) (+ rot') w + where cid = _crID cr - (rot, g) = randomR (-exTorque,exTorque) $ _randGen w - rot' | rot < 0 = rot - minTorque - | otherwise = rot + minTorque + (rot, g) = randomR (- exTorque, exTorque) $ _randGen w + rot' + | rot < 0 = rot - minTorque + | otherwise = rot + minTorque + -- | Rotate a randomly creature after applying an effect. withTorqueAfter :: ChainEffect -withTorqueAfter feff item cr w --- | cid == 0 = rotateScope $ set randGen g $ over cameraRot (+rot) $ feff item cr w - | cid == 0 = set randGen g $ over (cWorld . cameraRot) (+rot) $ feff item cr w - | otherwise = set randGen g $ over (cWorld . creatures . ix cid . crDir) (+rot) $ feff item cr w - where +withTorqueAfter feff item cr w + -- | cid == 0 = rotateScope $ set randGen g $ over cameraRot (+rot) $ feff item cr w + | cid == 0 = set randGen g $ over (cWorld . cameraRot) (+ rot) $ feff item cr w + | otherwise = set randGen g $ over (cWorld . creatures . ix cid . crDir) (+ rot) $ feff item cr w + where cid = _crID cr - (rot, g) = randomR (-torque,torque) $ _randGen w - torque = fromMaybe 0 $ item ^? itParams. torqueAfter + (rot, g) = randomR (- torque, torque) $ _randGen w + torque = fromMaybe 0 $ item ^? itParams . torqueAfter spreadNumI :: ChainEffect spreadNumI eff item cr w = foldr f w dirs where - dirs = zipWith (+) - [-spread,-spread+(2*spread/fromIntegral numBul)..spread] - (randomRs (0,spread/fromIntegral numBul) (_randGen w)) + dirs = + zipWith + (+) + [- spread, - spread + (2 * spread / fromIntegral numBul) .. spread] + (randomRs (0, spread / fromIntegral numBul) (_randGen w)) f dir = eff item (cr & crDir +~ dir) spread = _spreadAngle . _brlSpread . _gunBarrels $ _itParams item numBul = _brlNum . _gunBarrels $ _itParams item + spreadLoaded :: ChainEffect spreadLoaded eff item cr w = foldr f w dirs where @@ -543,32 +641,37 @@ spreadLoaded eff item cr w = foldr f w dirs spread = _spreadAngle . _brlSpread . _gunBarrels $ _itParams item numBulLoaded = _laLoaded $ _heldConsumption (_itUse item) -sideEffectOnFrame :: Int - -> (Item -> Creature -> WdWd) - -> ChainEffect -sideEffectOnFrame i sf f it cr w = f it cr w - & cWorld . delayedEvents .:~ (i, sf it cr) +sideEffectOnFrame :: + Int -> + (Item -> Creature -> WdWd) -> + ChainEffect +sideEffectOnFrame i sf f it cr w = + f it cr w + & cWorld . delayedEvents .:~ (i, sf it cr) torqueSideEffect :: Float -> Item -> Creature -> World -> World torqueSideEffect torque _ cr w - | cid == 0 = set randGen g $ over (cWorld . cameraRot) (+rot) w - | otherwise = set randGen g $ over (cWorld . creatures . ix cid . crDir) (+rot) w - where + | cid == 0 = set randGen g $ over (cWorld . cameraRot) (+ rot) w + | otherwise = set randGen g $ over (cWorld . creatures . ix cid . crDir) (+ rot) w + where cid = _crID cr - (rot, g) = randomR (-torque,torque) $ _randGen w + (rot, g) = randomR (- torque, torque) $ _randGen w -- pump the updated creature into the chain in later frames repeatOnFrames :: [Int] -> HeldMod -> ChainEffect --repeatOnFrames is hm f it cr w = f it cr w -repeatOnFrames is hm f it cr w = f it cr $ w - & cWorld . delayedEvents .++~ (is <&> (, WdWdFromItCrixWdWd (it & itUse . useMods .~ hm) (_crID cr) ItCrWdItemEffect)) +repeatOnFrames is hm f it cr w = + f it cr $ + w + & cWorld . delayedEvents .++~ (is <&> (,WdWdFromItCrixWdWd (it & itUse . heldMods .~ hm) (_crID cr) ItCrWdItemEffect)) + -- where -- f' = fromMaybe w' $ do -- cr' <- w' ^? creatures . ix (_crID cr) -- return $ f it cr' w' duplicateLoaded :: ChainEffect -duplicateLoaded eff it cr w = foldr f w [1..numBul] +duplicateLoaded eff it cr w = foldr f w [1 .. numBul] where f _ = eff it cr numBul = _laLoaded $ _heldConsumption (_itUse it) @@ -579,7 +682,7 @@ duplicateLoadedBarrels eff item cr w = foldr f w poss cp :: Float cp = -0.5 * (fromIntegral numBar - 1) poss :: [V2 Float] - poss = map (rotateV (_crDir cr) . V2 0 . (*5) . (+ cp) . fromIntegral) [0 .. numBul - 1] + poss = map (rotateV (_crDir cr) . V2 0 . (* 5) . (+ cp) . fromIntegral) [0 .. numBul - 1] f pos = eff item (cr & crPos %~ (+.+ pos)) numBar = _brlNum . _gunBarrels $ _itParams item numBul = _laLoaded $ _heldConsumption (_itUse item) @@ -588,14 +691,18 @@ duplicateOffsetsFocus :: [Float] -> ChainEffect duplicateOffsetsFocus xs eff item cr w = foldr f w poss where poss :: [V2 Float] - poss = map (rotateV (_crDir cr) . V2 0 ) xs - f pos = eff item $ cr - & crPos %~ (+.+ pos) - & crDir .~ thedir pos - thedir pos - | dist (mouseWorldPos w) (_crPos cr) < aimingMuzzlePos cr item - = argV (_crPos cr +.+ aimingMuzzlePos cr item *.* unitVectorAtAngle (_crDir cr) - -.- (_crPos cr +.+ pos)) + poss = map (rotateV (_crDir cr) . V2 0) xs + f pos = + eff item $ + cr + & crPos %~ (+.+ pos) + & crDir .~ thedir pos + thedir pos + | dist (mouseWorldPos w) (_crPos cr) < aimingMuzzlePos cr item = + argV + ( _crPos cr +.+ aimingMuzzlePos cr item *.* unitVectorAtAngle (_crDir cr) + -.- (_crPos cr +.+ pos) + ) | otherwise = argV (mouseWorldPos w -.- (_crPos cr +.+ pos)) duplicateItem :: (Item -> [Item]) -> ChainEffect @@ -613,5 +720,5 @@ duplicateOffsets :: [Float] -> ChainEffect duplicateOffsets xs eff item cr w = foldr f w poss where poss :: [V2 Float] - poss = map (rotateV (_crDir cr) . V2 0 ) xs + poss = map (rotateV (_crDir cr) . V2 0) xs f pos = eff item (cr & crPos +.+.~ pos) diff --git a/src/Dodge/Item/Weapon/Utility.hs b/src/Dodge/Item/Weapon/Utility.hs index 77c7684e0..52cff8ab9 100644 --- a/src/Dodge/Item/Weapon/Utility.hs +++ b/src/Dodge/Item/Weapon/Utility.hs @@ -1,11 +1,11 @@ module Dodge.Item.Weapon.Utility where +import Dodge.Default.Item.Use import Control.Lens import Data.Maybe import Dodge.Base.Coordinate -import Dodge.Data +import Dodge.Data.World import Dodge.Default -import Dodge.Item.Weapon.ExtraEffect import Dodge.Wall.ForceField import Dodge.Wall.Move import Geometry @@ -19,9 +19,9 @@ rewindGun = defaultLeftItem { _itInvColor = cyan , _itUse = - defaultlUse - & lUse .~ LRewind --useRewindGun - & eqEq . eqSite .~ GoesOnChest + defaultLeftUse + & leftUse .~ LRewind --useRewindGun + & equipEffect . eeSite .~ GoesOnChest } & itEffect . ieInv .~ RewindEffect & itType . iyBase .~ LEFT REWINDER @@ -35,7 +35,7 @@ rewindGun = shrinkGun :: Item shrinkGun = defaultLeftItem - & itUse .~ (defaultlUse & lUse .~ LShrink) + & itUse .~ (defaultLeftUse & leftUse .~ LShrink) & itParams .~ ShrinkGunParams FullSize & itType . iyBase .~ LEFT SHRINKER @@ -47,9 +47,9 @@ blinkGun = defaultLeftItem { _itInvColor = cyan , _itUse = - defaultlUse - & lUse .~ LBlink --hammerCheckL (shootL $ const blinkAction) - & eqEq . eqSite .~ GoesOnWrist + defaultLeftUse + & leftUse .~ LBlink --hammerCheckL (shootL $ const blinkAction) + & equipEffect . eeSite .~ GoesOnWrist -- , _itFloorPict = const . noPic . colorSH chartreuse $ upperPrismPoly 2 $ square 2 } & itType . iyBase .~ LEFT BLINKER @@ -58,33 +58,9 @@ unsafeBlinkGun :: Item unsafeBlinkGun = blinkGun & itType . iyBase .~ LEFT BLINKERUNSAFE - & itUse . lUse .~ LUnsafeBlink --hammerCheckL (shootL $ const unsafeBlinkAction) - & itUse . eqEq . eqViewDist ?~ 400 + & itUse . leftUse .~ LUnsafeBlink --hammerCheckL (shootL $ const unsafeBlinkAction) + & itUse . equipEffect . eeViewDist ?~ 400 ---effectGun :: String -> (Creature -> World -> World) -> Item ---effectGun name eff = defaultWeapon --- { _itUse = defaultrUse --- & rUse .~ const eff --- & useMods .~ [hammerCheckI] --- } --- & itType . iyBase .~ EFFGUN name ---autoEffectGun :: String -> (Creature -> World -> World) -> Item ---autoEffectGun name eff = defaultWeapon --- { _itUse = defaultrUse {_rUse = const eff} --- } --- & itType . iyBase .~ AUTOEFFGUN name -forceFieldGun :: Item -forceFieldGun = - defaultWeapon - & itTargeting .~ (targetRBPress & tgDraw .~ TargetDistanceDraw) - & itParams .~ ParamMID Nothing - & itUse . rUse .~ HeldForceField --useForceFieldGun - & itUse . useDelay .~ NoDelay - & itUse . useMods .~ AmmoHammerTimeUseOneMod -- this is slightly different - -- than the list below - --[ hammerCheckI , ammoCheckI , useAmmoAmount 1] - & itType . iyBase .~ HELD FORCEFIELDGUN - & itUse . heldConsumption .~ (defaultLoadable & laAmmoType .~ ForceFieldAmmo forceField) -- I believe because the targeting returns to nothing straight after you release -- the rmb, it is possible for this to do nothing diff --git a/src/Dodge/Item/Weapon/ZoomScope.hs b/src/Dodge/Item/Weapon/ZoomScope.hs index f134921f9..5c7318a5a 100644 --- a/src/Dodge/Item/Weapon/ZoomScope.hs +++ b/src/Dodge/Item/Weapon/ZoomScope.hs @@ -1,10 +1,11 @@ module Dodge.Item.Weapon.ZoomScope where -import Dodge.Data + +import Dodge.Data.Creature import LensHelp +-- should be possible without the creature zoomLongGun :: Float -> Creature -> Item -> Item zoomLongGun x _ - | x > 0 = itScope . scopeZoomChange %~ (max 15 . (+4)) + | x > 0 = itScope . scopeZoomChange %~ (max 15 . (+ 4)) | x < 0 = itScope . scopeZoomChange %~ (min (-15) . subtract 4) | otherwise = id ---zoomLongGun x _ = itScope . scopeZoomChange .~ round (signum x) diff --git a/src/Dodge/Lampoid.hs b/src/Dodge/Lampoid.hs index ebb08867e..60a416228 100644 --- a/src/Dodge/Lampoid.hs +++ b/src/Dodge/Lampoid.hs @@ -1,30 +1,35 @@ module Dodge.Lampoid where -import Dodge.Data + +import Dodge.Creature.State +import Dodge.Data.World +import Dodge.LightSource import Dodge.Material.Sound import Dodge.WorldEvent.Flash import Dodge.WorldEvent.Sound -import Dodge.Creature.State -import Dodge.LightSource import Geometry -import LensHelp import qualified IntMapHelp as IM +import LensHelp + updateLampoid :: Creature -> World -> World updateLampoid cr w = case cr ^?! crType . lampLSID of - Nothing -> let i = IM.newKey (_lightSources (_cWorld w)) - in w & cWorld . lightSources %~ IM.insert i (lsColPosID lcol (addZ h cpos) i) - & cWorld . creatures . ix (_crID cr) . crType . lampLSID ?~ i - Just i - | _crHP cr < 0 -> w - & explosionFlashAt cpos - & originsIDsAt [MaterialSound Glass n | n <- [0,1,2]] (destroyMatS Glass) cpos - & cWorld . lightSources . at i .~ Nothing - & cWorld . creatures . at cid .~ Nothing - | otherwise -> w - & cWorld . lightSources . ix i . lsParam . lsPos .~ addZ h cpos - & doDamage cr + Nothing -> + let i = IM.newKey (_lightSources (_cWorld w)) + in w & cWorld . lightSources %~ IM.insert i (lsColPosID lcol (addZ h cpos) i) + & cWorld . creatures . ix (_crID cr) . crType . lampLSID ?~ i + Just i + | _crHP cr < 0 -> + w + & explosionFlashAt cpos + & originsIDsAt [MaterialSound Glass n | n <- [0, 1, 2]] (destroyMatS Glass) cpos + & cWorld . lightSources . at i .~ Nothing + & cWorld . creatures . at cid .~ Nothing + | otherwise -> + w + & cWorld . lightSources . ix i . lsParam . lsPos .~ addZ h cpos + & doDamage cr where cpos = _crPos cr - cid = _crID cr + cid = _crID cr crtype = _crType cr h = _lampHeight crtype lcol = _lampColor crtype diff --git a/src/Dodge/Laser/Draw.hs b/src/Dodge/Laser/Draw.hs index cb405a4a5..76d5ea5b4 100644 --- a/src/Dodge/Laser/Draw.hs +++ b/src/Dodge/Laser/Draw.hs @@ -1,26 +1,14 @@ -module Dodge.Laser.Draw - where +module Dodge.Laser.Draw where + import Dodge.Data.Laser import Picture ---drawLaser :: Particle -> Picture -----drawLaser pt = setLayer BloomNoZWrite $ pictures --- --[ setDepth 19 . color (brightX 0 0.5 col) $ thickLine 20 ps ---drawLaser pt = --- setLayer BloomNoZWrite $ pictures ----- [ setDepth 19 . color (brightX 1 0.5 col) $ thickLine 20 ps --- [ setDepth 19.5 . color (brightX 10 1 col) $ thickLine 3 ps --- ] --- where --- col = _ptColor pt --- ps = _ptPoints pt - - drawLaser :: Laser -> Picture drawLaser pt = - setLayer BloomNoZWrite $ pictures - [ setDepth 19.5 . color (brightX 10 1 col) $ thickLine 3 ps - ] + setLayer BloomNoZWrite $ + pictures + [ setDepth 19.5 . color (brightX 10 1 col) $ thickLine 3 ps + ] where col = _laColor pt - ps = _laPoints pt + ps = _laPoints pt diff --git a/src/Dodge/Laser/Update.hs b/src/Dodge/Laser/Update.hs index 4a0fa6e3c..b3f0559a0 100644 --- a/src/Dodge/Laser/Update.hs +++ b/src/Dodge/Laser/Update.hs @@ -1,25 +1,23 @@ -module Dodge.Laser.Update - where -import Dodge.Item.Weapon.LaserPath -import Dodge.WorldEvent.Damage -import Dodge.Data -import Geometry +module Dodge.Laser.Update where import Control.Lens import Data.Maybe +import Dodge.Data.World +import Dodge.Item.Weapon.LaserPath +import Dodge.WorldEvent.Damage +import Geometry updateLaser :: World -> LaserStart -> (World, Laser) updateLaser w pt = ( w' - , Laser {_laPoints = sp:ps , _laColor = _lpColor pt, _laType = _lpType pt} + , Laser{_laPoints = sp : ps, _laColor = _lpColor pt, _laType = _lpType pt} ) where w' = fromMaybe w $ do dam <- pt ^? lpType . laserTypeDamage return $ damThingHitWith (\p1 p2 p3 -> Damage LASERING dam p1 p2 p3 NoDamageEffect) sp xp thHit w phasev = _lpPhaseV pt - sp = _lpPos pt + sp = _lpPos pt dir = _lpDir pt xp = sp +.+ 800 *.* unitVectorAtAngle dir (thHit, ps) = reflectLaserAlong phasev sp xp w - diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index 11b161cbd..9a38e2d66 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -1,60 +1,59 @@ --{-# LANGUAGE TupleSections #-} -module Dodge.Layout - ( generateLevelFromRoomList - ) where -import Dodge.Zoning.Pathing -import Data.Tile -import Dodge.Data -import Dodge.Path -import Dodge.ShiftPoint -import Dodge.Placement.PlaceSpot ---import Dodge.LevelGen.Data -import Dodge.LevelGen.StaticWalls -import Dodge.LevelGen.LevelStructure -import Dodge.Wall.Zone -import Dodge.GameRoom -import Dodge.Default.Wall -import Dodge.Room.Link -import Dodge.Randify -import Geometry ---import Geometry.ConvexPoly -import qualified IntMapHelp as IM -import Tile -import RandomHelp +module Dodge.Layout ( + generateLevelFromRoomList, +) where -import Data.Graph.Inductive (labNodes,labEdges) -import Data.List (nubBy) -import Data.Traversable +import qualified Control.Foldl as L import Control.Lens import Data.Foldable -import qualified Control.Foldl as L -import Data.Maybe import Data.Function +import Data.Graph.Inductive (labEdges, labNodes) +import Data.List (nubBy) +import Data.Maybe +import Data.Tile +import Data.Traversable +import Dodge.Data.GenWorld +import Dodge.Default.Wall +import Dodge.GameRoom +import Dodge.LevelGen.LevelStructure +import Dodge.LevelGen.StaticWalls +import Dodge.Path +import Dodge.Placement.PlaceSpot +import Dodge.Randify +import Dodge.Room.Link +import Dodge.ShiftPoint +import Dodge.Wall.Zone +import Dodge.Zoning.Pathing +import Geometry +import qualified IntMapHelp as IM +import RandomHelp +import Tile generateLevelFromRoomList :: IM.IntMap Room -> World -> GenWorld -generateLevelFromRoomList gr' w = over gwWorld initWallZoning - . over gwWorld randomCompass - . over gwWorld setupWorldBounds - . doAfterPlacements - . doInPlacements - . doOutPlacements - . doIndividualPlacements - . setFloors - . worldToGenWorld rs' - $ w & cWorld . walls .~ wallsFromRooms rs - & cWorld . gameRooms .~ gameRoomsFromRooms (IM.elems rs') - & cWorld . pathGraph .~ path - & cWorld . pnZoning .~ foldl' (flip zonePn) mempty (labNodes path) - & cWorld . peZoning .~ foldl' (flip zonePe) mempty (labEdges path) +generateLevelFromRoomList gr' w = + over gwWorld initWallZoning + . over gwWorld randomCompass + . over gwWorld setupWorldBounds + . doAfterPlacements + . doInPlacements + . doOutPlacements + . doIndividualPlacements + . setFloors + . worldToGenWorld rs' + $ w & cWorld . walls .~ wallsFromRooms rs + & cWorld . gameRooms .~ gameRoomsFromRooms (IM.elems rs') + & cWorld . pathGraph .~ path + & cWorld . pnZoning .~ foldl' (flip zonePn) mempty (labNodes path) + & cWorld . peZoning .~ foldl' (flip zonePe) mempty (labEdges path) where - (_,path) = pairsToGraph pairPath' + (_, path) = pairsToGraph pairPath' pairPath = foldMap _rmPath rs pairPath' = fusePairs pairPath rs = map doRoomShift $ IM.elems rs' - rs'= mapM shuffleRoomPos gr' & evalState $ _randGen w + rs' = mapM shuffleRoomPos gr' & evalState $ _randGen w randomCompass :: World -> World -randomCompass w = w & cWorld . cameraRot .~ (takeOne [0,0.5*pi,pi,1.5*pi] & evalState $ _randGen w) +randomCompass w = w & cWorld . cameraRot .~ (takeOne [0, 0.5 * pi, pi, 1.5 * pi] & evalState $ _randGen w) putFloorTiles :: GenWorld -> GenWorld putFloorTiles gw = gw & gwWorld . cWorld . floorTiles .~ floorsFromGenWorld gw @@ -70,7 +69,7 @@ setTiles gw = foldr setTile gw . reverse . IM.elems $ _genRooms gw setTile :: Room -> GenWorld -> GenWorld setTile r gw = case _rmFloor r of - Tiled {} -> gw + Tiled{} -> gw InheritFloor -> gw & genRooms . ix (fromJust (_rmMID r)) . rmFloor .~ Tiled [t & tilePoly .~ poly] where t = case _rmMParent r of @@ -86,58 +85,65 @@ shuffleRoomPos rm = do doAfterPlacements :: GenWorld -> GenWorld doAfterPlacements gw = foldr doAfterPlacement gw (_genPlacements gw) -doAfterPlacement :: [(Placement,Int)] -> GenWorld -> GenWorld +doAfterPlacement :: [(Placement, Int)] -> GenWorld -> GenWorld doAfterPlacement pmntis gw = gRandify gw $ do - (pmnt,i) <- takeOne pmntis - let (newgw,rm) = fst $ placeSpot (gw,_genRooms gw IM.! i) pmnt + (pmnt, i) <- takeOne pmntis + let (newgw, rm) = fst $ placeSpot (gw, _genRooms gw IM.! i) pmnt return $ newgw & genRooms . ix i .~ rm -doInPlacements :: ( IM.IntMap [Placement],GenWorld) -> GenWorld -doInPlacements (im,w) = - let (gw,rms) = mapAccumR (doRoomInPlacements im) w (_genRooms w) - in gw & genRooms .~ rms +doInPlacements :: (IM.IntMap [Placement], GenWorld) -> GenWorld +doInPlacements (im, w) = + let (gw, rms) = mapAccumR (doRoomInPlacements im) w (_genRooms w) + in gw & genRooms .~ rms doRoomInPlacements :: IM.IntMap [Placement] -> GenWorld -> Room -> (GenWorld, Room) -doRoomInPlacements im w rm = foldr f (w,rm) $ _rmInPmnt rm +doRoomInPlacements im w rm = foldr f (w, rm) $ _rmInPmnt rm where - f (InPlacement plf i) (w',r') = fst $ placeSpot (w',r') (plf $ im IM.! i) + f (InPlacement plf i) (w', r') = fst $ placeSpot (w', r') (plf $ im IM.! i) -doOutPlacements :: GenWorld -> ( IM.IntMap [Placement], GenWorld) -doOutPlacements w = let ((pmnts,gw),rms) = mapAccumR doRoomOutPlacements (IM.empty,w) (_genRooms w) - in (pmnts,gw & genRooms .~ rms) +doOutPlacements :: GenWorld -> (IM.IntMap [Placement], GenWorld) +doOutPlacements w = + let ((pmnts, gw), rms) = mapAccumR doRoomOutPlacements (IM.empty, w) (_genRooms w) + in (pmnts, gw & genRooms .~ rms) -doRoomOutPlacements :: (IM.IntMap [Placement], GenWorld) - -> Room - -> ( (IM.IntMap [Placement], GenWorld) , Room ) -doRoomOutPlacements imw r = foldr f ( imw, r ) $ _rmOutPmnt r +doRoomOutPlacements :: + (IM.IntMap [Placement], GenWorld) -> + Room -> + ((IM.IntMap [Placement], GenWorld), Room) +doRoomOutPlacements imw r = foldr f (imw, r) $ _rmOutPmnt r where - f (OutPlacement pl i) ( (im,w) , rm ) = - let ((neww,newrm),plmnts) = placeSpot (w,rm) pl - in ((IM.insert i plmnts im, neww) , newrm ) + f (OutPlacement pl i) ((im, w), rm) = + let ((neww, newrm), plmnts) = placeSpot (w, rm) pl + in ((IM.insert i plmnts im, neww), newrm) doIndividualPlacements :: GenWorld -> GenWorld -doIndividualPlacements gw = let (gw', rms) = mapAccumR doRoomPlacements gw (_genRooms gw) - in gw' & genRooms .~ rms +doIndividualPlacements gw = + let (gw', rms) = mapAccumR doRoomPlacements gw (_genRooms gw) + in gw' & genRooms .~ rms doRoomPlacements :: GenWorld -> Room -> (GenWorld, Room) -doRoomPlacements w rm = foldl' (\wr -> fst . placeSpot wr) (w,rm) $ _rmPmnts rm +doRoomPlacements w rm = foldl' (\wr -> fst . placeSpot wr) (w, rm) $ _rmPmnts rm setupWorldBounds :: World -> World -setupWorldBounds w = w & cWorld . worldBounds %~ - ( (bdMinX .~ f minx) - . (bdMaxX .~ f maxx) - . (bdMinY .~ f miny) - . (bdMaxY .~ f maxy) - ) +setupWorldBounds w = + w & cWorld . worldBounds + %~ ( (bdMinX .~ f minx) + . (bdMaxX .~ f maxx) + . (bdMinY .~ f miny) + . (bdMaxY .~ f maxy) + ) where f = fromMaybe 0 ps = IM.map (fst . _wlLine) $ _walls (_cWorld w) - (minx,maxx,miny,maxy) = L.fold ((,,,) - <$> L.premap fstV2 L.minimum - <*> L.premap fstV2 L.maximum - <*> L.premap sndV2 L.minimum - <*> L.premap sndV2 L.maximum - ) ps + (minx, maxx, miny, maxy) = + L.fold + ( (,,,) + <$> L.premap fstV2 L.minimum + <*> L.premap fstV2 L.maximum + <*> L.premap sndV2 L.minimum + <*> L.premap sndV2 L.maximum + ) + ps --polyhedrasToEdges :: [Polyhedra] -> [Point3] --polyhedrasToEdges = concatMap tflat4 . concatMap polyToEdges @@ -149,36 +155,45 @@ initWallZoning w = foldl' (flip insertWallInZones) (w & cWorld . wlZoning .~ IM. --makePath = concatMap _rmPath . flatten wallsFromRooms :: [Room] -> IM.IntMap Wall -wallsFromRooms = -- divideWalls . - IM.fromAscList - . zipWith f [0..] - . removeInverseWalls - . foldl' (flip cutWalls) [] - . concatMap _rmPolys +wallsFromRooms = + -- divideWalls . + IM.fromAscList + . zipWith f [0 ..] + . removeInverseWalls + . foldl' (flip cutWalls) [] + . concatMap _rmPolys where - f i (x,y) = (i, defaultWall {_wlLine = (x,y) , _wlID = i}) + f i (x, y) = (i, defaultWall{_wlLine = (x, y), _wlID = i}) -- TODO sort out shifting before or after etc gameRoomsFromRooms :: [Room] -> [GameRoom] gameRoomsFromRooms = fmap gameRoomFromRoom gameRoomFromRoom :: Room -> GameRoom -gameRoomFromRoom rm = GameRoom - { _grViewpoints = map doshift $ _rmViewpoints rm ++ (map fst . foldl' (flip cutWalls) [] $ _rmPolys rm) - ++ mapMaybe filterUnusedLinks (_rmPos rm) - , _grViewpointsEx = concatMap filterUsedLinks (_rmPos rm) - , _grBound = map doshift $ expandPolyCorners 50 . convexHullSafe . nubBy closePoints - . concat $ _rmBound rm ++ _rmPolys rm - , _grDir = getDir $ _rmPos rm - , _grLinkDirs = mapMaybe undir $ _rmPos rm - , _grName = _rmName rm - } +gameRoomFromRoom rm = + GameRoom + { _grViewpoints = + map doshift $ + _rmViewpoints rm ++ (map fst . foldl' (flip cutWalls) [] $ _rmPolys rm) + ++ mapMaybe filterUnusedLinks (_rmPos rm) + , _grViewpointsEx = concatMap filterUsedLinks (_rmPos rm) + , _grBound = + map doshift $ + expandPolyCorners 50 . convexHullSafe . nubBy closePoints + . concat + $ _rmBound rm ++ _rmPolys rm + , _grDir = getDir $ _rmPos rm + , _grLinkDirs = mapMaybe undir $ _rmPos rm + , _grName = _rmName rm + } where doshift = shiftPointBy (_rmShift rm) - doubleShift p a = map doshift - [p +.+ 10 *.* unitVectorAtAngle a - ,p -.- 10 *.* unitVectorAtAngle a - ] + doubleShift p a = + map + doshift + [ p +.+ 10 *.* unitVectorAtAngle a + , p -.- 10 *.* unitVectorAtAngle a + ] filterUnusedLinks rp = case _rpLinkStatus rp of UnusedLink{} -> Just $ _rpPos rp _ -> Nothing @@ -188,20 +203,20 @@ gameRoomFromRoom rm = GameRoom _ -> [] undir rp = case _rpLinkStatus rp of UsedOutLink{} -> ma - UsedInLink{} -> ma + UsedInLink{} -> ma _ -> Nothing where - ma = Just $ 0.5*pi + _rpDir rp + snd (_rmShift rm) + ma = Just $ 0.5 * pi + _rpDir rp + snd (_rmShift rm) closePoints x y = roundPoint2 x == roundPoint2 y - getDir (rp:xs) = case _rpLinkStatus rp of - UsedInLink {} -> _rpDir rp + snd (_rmShift rm) + getDir (rp : xs) = case _rpLinkStatus rp of + UsedInLink{} -> _rpDir rp + snd (_rmShift rm) _ -> getDir xs getDir _ = 0 -- fallback -floorsFromRooms :: [Room] -> [(Point3,Point3)] +floorsFromRooms :: [Room] -> [(Point3, Point3)] floorsFromRooms = concatMap (concatMap tileToRenderList . getTiles . _rmFloor . doRoomShift) -floorsFromGenWorld :: GenWorld -> [(Point3,Point3)] +floorsFromGenWorld :: GenWorld -> [(Point3, Point3)] floorsFromGenWorld = floorsFromRooms . IM.elems . _genRooms getTiles :: Floor -> [Tile] @@ -216,7 +231,7 @@ getTiles fl = case fl of -- in zipWith (\ x y -> wl & wlLine .~ (x,y) ) (init ps) (tail ps) --divideWallIn :: Wall -> IM.IntMap Wall -> IM.IntMap Wall ---divideWallIn wl wls = +--divideWallIn wl wls = -- let (wl':newWls) = divideWall wl -- k = IM.newKey wls -- newWls' = zipWith (\i w -> w {_wlID = i}) [k..] newWls @@ -231,20 +246,20 @@ getTiles fl = case fl of --shiftRoomTree :: Tree Room -> Tree Room --shiftRoomTree (Node t []) = Node t [] ---shiftRoomTree (Node t ts) = Node t --- $ zipWith (\l -> shiftRoomTree . applyToRoot (shiftRoomToLink l)) --- (_rmLinks t) +--shiftRoomTree (Node t ts) = Node t +-- $ zipWith (\l -> shiftRoomTree . applyToRoot (shiftRoomToLink l)) +-- (_rmLinks t) -- ts --shiftRoomTreeConstruction :: Tree Room -> [Tree Room] --shiftRoomTreeConstruction (Node t []) = [Node t []] --shiftRoomTreeConstruction (Node t ts) = (Node t [] :) $ concat $ --- zipWith (\l -> shiftRoomTreeConstruction . applyToRoot (shiftRoomBy l . f)) --- (_rmLinks t) +-- zipWith (\l -> shiftRoomTreeConstruction . applyToRoot (shiftRoomBy l . f)) +-- (_rmLinks t) -- ts --- where +-- where -- f r = shiftRoomBy ( V2 0 0 -.- rotateV (pi-a) p , 0) $ shiftRoomBy (V2 0 0,pi-a) r --- where +-- where -- (p,a) = last $ _rmLinks r --addTile :: Float -> Room -> Room diff --git a/src/Dodge/Layout.hs.orig b/src/Dodge/Layout.hs.orig index 66cd5fa4e..27bf81db1 100644 --- a/src/Dodge/Layout.hs.orig +++ b/src/Dodge/Layout.hs.orig @@ -3,12 +3,11 @@ module Dodge.Layout ( generateLevelFromRoomList ) where import Data.Tile -import Dodge.Data +import Dodge.Data.GenWorld import Dodge.Path import Dodge.Zone.Update import Dodge.ShiftPoint import Dodge.Placement.PlaceSpot ---import Dodge.LevelGen.Data import Dodge.LevelGen.StaticWalls import Dodge.LevelGen.LevelStructure import Dodge.Wall.Zone @@ -17,7 +16,6 @@ import Dodge.Default.Wall import Dodge.Room.Link import Dodge.Randify import Geometry ---import Geometry.ConvexPoly import qualified IntMapHelp as IM import Tile import RandomHelp diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index ee6fd78f5..2ccd3ced5 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -1,21 +1,19 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RankNTypes #-} module Dodge.LevelGen where -import Dodge.Data -import Dodge.Floor -import Dodge.Layout -import Dodge.Initialisation -import Dodge.Tree -import Geometry.ConvexPoly -import Dodge.Combine.Graph -import Data.Foldable -import System.Directory -import System.Random import Control.Lens import Control.Monad.State -import qualified IntMapHelp as IM +import Data.Foldable import qualified Data.Text.IO as TIO +import Dodge.Combine.Graph +import Dodge.Data.GenWorld +import Dodge.Floor +import Dodge.Initialisation +import Dodge.Layout +import Dodge.Tree +import Geometry.ConvexPoly +import qualified IntMapHelp as IM +import System.Directory +import System.Random generateWorldFromSeed :: Int -> IO World generateWorldFromSeed i = do @@ -25,11 +23,11 @@ generateWorldFromSeed i = do writeFile "log/treeCluster" "" writeFile "log/aGeneratedRoomLayout" "" generateGraphs - (roomList,bounds) <- layoutLevelFromSeed 0 i - return -- $ saveLevelStartSlot - $ postGenerationProcessing - $ _gwWorld (generateLevelFromRoomList roomList initialWorld{_randGen=mkStdGen i}) - & cWorld . roomClipping .~ bounds + (roomList, bounds) <- layoutLevelFromSeed 0 i + return $ + postGenerationProcessing $ + _gwWorld (generateLevelFromRoomList roomList initialWorld{_randGen = mkStdGen i}) + & cWorld . roomClipping .~ bounds postGenerationProcessing :: World -> World postGenerationProcessing w = foldl' assignPushDoors w (_doors (_cWorld w)) @@ -42,42 +40,43 @@ assignPushDoors w dr = case dr ^?! drPushedBy of PushedBy i -> w & cWorld . doors . ix i . drPushes ?~ _drID dr _ -> w -layoutLevelFromSeed :: Int -> Int -> IO (IM.IntMap Room,[ConvexPoly]) +layoutLevelFromSeed :: Int -> Int -> IO (IM.IntMap Room, [ConvexPoly]) layoutLevelFromSeed i seed = do let i' = i + 1 putStrLnAppend "log/attemptedSeeds" $ "Generating level with seed " ++ show seed appendFile "log/attemptedSeeds" "\n" let g = mkStdGen seed - let treecluster = evalState initialRoomTree (g,0) + let treecluster = evalState initialRoomTree (g, 0) let labts = decomposeSelfTree $ numSelfTree $ combineTree _rmName treecluster - appendFile "log/treeCluster" ("Seed: "++ show seed ++ "\n") + appendFile "log/treeCluster" ("Seed: " ++ show seed ++ "\n") mapM_ (putStrLnAppend "log/treeCluster" . smallDrawTree . fmap showIntsString) labts let tc = composeTree treecluster let rmtree = inorderNumberTree tc putStrLn "Room layout (compact): " putStrLn $ compactDrawTree $ fmap (show . snd) rmtree - let nameshow (r,rid) = _rmName r ++ "-" ++ show rid - appendFile "log/aGeneratedRoomLayout" ("Seed: "++ show seed) + let nameshow (r, rid) = _rmName r ++ "-" ++ show rid + appendFile "log/aGeneratedRoomLayout" ("Seed: " ++ show seed) putStrLnAppend "log/aGeneratedRoomLayout" "Layout with room names:" putStrLnAppend "log/aGeneratedRoomLayout" $ smallDrawTree $ fmap nameshow rmtree mrs <- positionRoomsFromTree rmtree case mrs of Just (PosRooms bounds rs) -> do - putStrLnAppend "log/attemptedSeeds" $ "After " ++ show i' - ++ " attempt(s), Successful generation of level with seed " - ++ show seed + putStrLnAppend "log/attemptedSeeds" $ + "After " ++ show i' + ++ " attempt(s), Successful generation of level with seed " + ++ show seed putStrLnAppend "log/attemptedSeeds" $ show (Prelude.length rs) ++ " rooms in total" - return (IM.fromList $ map reversePair rs , bounds) + return (IM.fromList $ map reversePair rs, bounds) Nothing -> do putStrLnAppend "log/attemptedSeeds" $ "Level generation with seed " ++ show seed ++ " failed: " - let (seed',_) = random g + let (seed', _) = random g layoutLevelFromSeed i' seed' putStrLnAppend :: FilePath -> String -> IO () putStrLnAppend fp str = appendFile fp (str ++ "\n") >> putStrLn str -reversePair :: (a,b) -> (b,a) -reversePair (a,b) = (b,a) +reversePair :: (a, b) -> (b, a) +reversePair (a, b) = (b, a) compactDrawTree :: Tree String -> String compactDrawTree = unlines . compactDraw @@ -86,13 +85,13 @@ smallDrawTree :: Tree String -> String smallDrawTree = unlines . compactDraw' compactDraw :: Tree String -> [String] -compactDraw (Node x [Node y ts]) = compactDraw (Node (x++","++y) ts) +compactDraw (Node x [Node y ts]) = compactDraw (Node (x ++ "," ++ y) ts) compactDraw (Node x ts0) = lines x ++ drawSubTrees ts0 where drawSubTrees [] = [] drawSubTrees [t] = "|" : compactDraw t - drawSubTrees (t:ts) = + drawSubTrees (t : ts) = "|" : shift "+- " "| " (compactDraw t) ++ drawSubTrees ts shift first other = zipWith (++) (first : repeat other) @@ -103,6 +102,6 @@ compactDraw' (Node x ts0) = lines x ++ drawSubTrees ts0 drawSubTrees [] = [] drawSubTrees [t] = "|" : compactDraw' t - drawSubTrees (t:ts) = + drawSubTrees (t : ts) = "|" : shift "+- " "| " (compactDraw' t) ++ drawSubTrees ts shift first other = zipWith (++) (first : repeat other) diff --git a/src/Dodge/LevelGen/Data.hs b/src/Dodge/LevelGen/Data.hs index c0b7f923d..c2783f8d6 100644 --- a/src/Dodge/LevelGen/Data.hs +++ b/src/Dodge/LevelGen/Data.hs @@ -1,23 +1,9 @@ ---{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE StrictData #-} module Dodge.LevelGen.Data where -import Dodge.Data ---import Picture -import Geometry ---import Color ---import Shape.Data ---import Data.Tile ---import qualified Data.Set as S ---import qualified Data.Map.Strict as M import Control.Lens ---import Control.Monad.State ---import System.Random import Data.Maybe ---import qualified IntMapHelp as IM ---import Data.Bifunctor - - +import Dodge.Data.GenWorld +import Geometry spNoID :: PlacementSpot -> PSType -> Placement spNoID ps pst = Placement 10 ps pst Nothing (const . const Nothing) @@ -71,8 +57,8 @@ jps0' :: PSType -> (Placement -> Maybe Placement) -> Maybe Placement jps0' pst = Just . Placement 10 (PS (V2 0 0) 0) pst Nothing . const jps0PushPS :: PSType -> (Int -> Maybe Placement) -> Maybe Placement -jps0PushPS pst f = Just . Placement 10 (PSNoShiftCont (V2 0 0) 0) pst Nothing - $ \_ plmnt -> f (fromJust $ _plMID plmnt) <&> plSpot .~ _plSpot plmnt +jps0PushPS pst f = Just . Placement 10 (PSNoShiftCont (V2 0 0) 0) pst Nothing $ + \_ plmnt -> f (fromJust $ _plMID plmnt) <&> plSpot .~ _plSpot plmnt ps0j :: PSType -> Placement -> Placement ps0j pst plmnt = Placement 10 (PS (V2 0 0) 0) pst Nothing (\_ -> const $ Just plmnt) @@ -82,24 +68,24 @@ psj ps pst plmnt = Placement 10 ps pst Nothing (\_ -> const $ Just plmnt) -- the NoShiftCont is necessary when shifting then combining rooms ps0jPushPS :: PSType -> Placement -> Placement -ps0jPushPS pst plmnt = Placement 10 (PSNoShiftCont (V2 0 0) 0) pst Nothing - $ \_ p -> Just $ plmnt & plSpot .~ _plSpot p +ps0jPushPS pst plmnt = Placement 10 (PSNoShiftCont (V2 0 0) 0) pst Nothing $ + \_ p -> Just $ plmnt & plSpot .~ _plSpot p -- the NoShiftCont is necessary when shifting then combining rooms ps0PushPS :: PSType -> (Placement -> Maybe Placement) -> Placement -ps0PushPS pst f = Placement 10 (PSNoShiftCont (V2 0 0) 0) pst Nothing - $ \_ pl -> f pl & _Just . plSpot %~ const (_plSpot pl) +ps0PushPS pst f = Placement 10 (PSNoShiftCont (V2 0 0) 0) pst Nothing $ + \_ pl -> f pl & _Just . plSpot %~ const (_plSpot pl) ps0PushPSw :: PSType -> (World -> Placement -> Maybe Placement) -> Placement -ps0PushPSw pst f = Placement 10 (PSNoShiftCont (V2 0 0) 0) pst Nothing - $ \w pl -> f w pl & _Just . plSpot %~ const (_plSpot pl) +ps0PushPSw pst f = Placement 10 (PSNoShiftCont (V2 0 0) 0) pst Nothing $ + \w pl -> f w pl & _Just . plSpot %~ const (_plSpot pl) addPlmnt :: Placement -> Placement -> Placement addPlmnt pl pl2 = case pl2 of (PlacementUsingPos p f) -> PlacementUsingPos p (fmap (addPlmnt pl) f) (RandomPlacement rp) -> RandomPlacement $ fmap (addPlmnt pl) rp (Placement i ps pt mi f) -> Placement i ps pt mi (fmap (fmap g) f) - PickOnePlacement {} -> error "not written how to combine PickOnePlacement with others yet" + PickOnePlacement{} -> error "not written how to combine PickOnePlacement with others yet" where g Nothing = Just pl g (Just pl') = Just $ addPlmnt pl pl' diff --git a/src/Dodge/LevelGen/LevelStructure.hs b/src/Dodge/LevelGen/LevelStructure.hs index 0257e956d..2d0d91480 100644 --- a/src/Dodge/LevelGen/LevelStructure.hs +++ b/src/Dodge/LevelGen/LevelStructure.hs @@ -1,34 +1,30 @@ ---{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE StrictData #-} -module Dodge.LevelGen.LevelStructure - ( module Dodge.LevelGen.Data - , worldToGenWorld - ) where -import Dodge.LevelGen.Data ---import Dodge.Tree.Compose.Data -import Dodge.Data -import RandomHelp -import Color -import LensHelp +module Dodge.LevelGen.LevelStructure ( + module Dodge.LevelGen.Data, + worldToGenWorld, +) where ---import Data.Tree -import qualified IntMapHelp as IM +import Color import qualified Data.Map.Strict as M ---import Control.Lens +import Dodge.Data.GenWorld +import Dodge.LevelGen.Data +import qualified IntMapHelp as IM +import LensHelp +import RandomHelp worldToGenWorld :: IM.IntMap Room -> World -> GenWorld -worldToGenWorld rms w = GenWorld - { _gwWorld = w & cWorld . genParams .~ evalState generateGenParams (_randGen w) - , _genRooms = rms - , _genPlacements = mempty - } +worldToGenWorld rms w = + GenWorld + { _gwWorld = w & cWorld . genParams .~ evalState generateGenParams (_randGen w) + , _genRooms = rms + , _genPlacements = mempty + } generateGenParams :: RandomGen g => State g GenParams generateGenParams = do cols <- shuffle [RED .. ORANGE] shps <- shuffle [PLUS ..] - return - . GenParams - . M.fromList - . zip [FLAMING,LASERING,ELECTRICAL] + return + . GenParams + . M.fromList + . zip [FLAMING, LASERING, ELECTRICAL] $ zip cols shps diff --git a/src/Dodge/LevelGen/Switch.hs b/src/Dodge/LevelGen/Switch.hs index e3d5a510c..2d6e6f0b7 100644 --- a/src/Dodge/LevelGen/Switch.hs +++ b/src/Dodge/LevelGen/Switch.hs @@ -4,7 +4,8 @@ module Dodge.LevelGen.Switch , makeSwitchSPic , drawSwitchWire ) where -import Dodge.Data +import Dodge.Data.Button +import Dodge.Data.WorldEffect import Dodge.Default import Dodge.SoundLogic import Picture diff --git a/src/Dodge/LightSource.hs b/src/Dodge/LightSource.hs index 8808a1a04..7a2adc5ec 100644 --- a/src/Dodge/LightSource.hs +++ b/src/Dodge/LightSource.hs @@ -1,43 +1,47 @@ -module Dodge.LightSource - ( tlsTimeRadFunPos - , tlsTimeRadColPos - , lsRadCol - , lsPosRadCol - , lsColPosRad - , lsPosColRad - , lsColPos - , lsPosCol - , lsPosRad - , lsColPosID - , makeTlsTimeRadColPos - , destroyLS - ) where -import Dodge.Data +module Dodge.LightSource ( + tlsTimeRadFunPos, + tlsTimeRadColPos, + lsRadCol, + lsPosRadCol, + lsColPosRad, + lsPosColRad, + lsColPos, + lsPosCol, + lsPosRad, + lsColPosID, + makeTlsTimeRadColPos, + destroyLS, +) where + +import Dodge.Data.World +import Dodge.Default.LightSource +import Dodge.Material.Sound +import Dodge.WorldEvent.Sound import Geometry.Data import Geometry.Vector import Geometry.Vector3D -import Dodge.Default.LightSource import LensHelp -import Dodge.WorldEvent.Sound -import Dodge.Material.Sound lsPosRad :: Point3 -> Float -> LightSource lsPosRad = lsColPosRad 0.75 tlsTimeRadFunPos :: Int -> Float -> TLSIntensity -> Point3 -> TempLightSource -tlsTimeRadFunPos t rmax intensityF p = TLS - { _tlsParam = LSParam - { _lsPos = p - , _lsRad = rmax - , _lsCol = 0 -- intensityF t +tlsTimeRadFunPos t rmax intensityF p = + TLS + { _tlsParam = + LSParam + { _lsPos = p + , _lsRad = rmax + , _lsCol = 0 -- intensityF t + } + , _tlsUpdate = IntensityTLS intensityF + , _tlsTime = t } - , _tlsUpdate = IntensityTLS intensityF - , _tlsTime = t - } + -- where --- upF tls +-- upF tls -- | _tlsTime tls <= 0 = Nothing --- | otherwise = Just $ tls +-- | otherwise = Just $ tls -- & tlsTime -~ 1 -- & tlsParam . lsCol .~ f (intensityF (_tlsTime tls) ) -- f x' = V3 x' x' x' @@ -46,13 +50,14 @@ lsPosColRad :: Point3 -> Point3 -> Float -> LightSource lsPosColRad p col = lsColPosRad col p lsPosRadCol :: Point3 -> Float -> Point3 -> LightSource -lsPosRadCol p r col = defaultLS - & lsParam . lsPos .~ p - & lsParam . lsRad .~ r - & lsParam . lsCol .~ col +lsPosRadCol p r col = + defaultLS + & lsParam . lsPos .~ p + & lsParam . lsRad .~ r + & lsParam . lsCol .~ col lsColPosID :: Point3 -> Point3 -> Int -> LightSource -lsColPosID col p i = lsColPos col p & lsID .~ i +lsColPosID col p i = lsColPos col p & lsID .~ i lsColPos :: Point3 -> Point3 -> LightSource lsColPos col pos = lsColPosRad col pos 700 @@ -64,40 +69,49 @@ lsColPosRad :: Point3 -> Point3 -> Float -> LightSource lsColPosRad col pos r = lsPosRadCol pos r col lsRadCol :: Float -> Point3 -> LightSource -lsRadCol r col = defaultLS & lsParam . lsRad .~ r - & lsParam . lsCol .~ col +lsRadCol r col = + defaultLS & lsParam . lsRad .~ r + & lsParam . lsCol .~ col -tlsTimeRadColPos - :: Int - -> Float -- ^ maximal radius - -> Point3 - -> Point3 - -> TempLightSource -tlsTimeRadColPos t rmax col (V3 x y z) = TLS - { _tlsParam = LSParam - { _lsPos = V3 x y z - , _lsRad = rmax - , _lsCol = col +tlsTimeRadColPos :: + Int -> + -- | maximal radius + Float -> + Point3 -> + Point3 -> + TempLightSource +tlsTimeRadColPos t rmax col (V3 x y z) = + TLS + { _tlsParam = + LSParam + { _lsPos = V3 x y z + , _lsRad = rmax + , _lsCol = col + } + , _tlsUpdate = TimerTLS + , _tlsTime = t } - , _tlsUpdate = TimerTLS - , _tlsTime = t - } makeTlsTimeRadColPos :: Int -> Float -> Point3 -> Point3 -> World -> World makeTlsTimeRadColPos i rad (V3 r g b) p = cWorld . tempLightSources .:~ tlsTimeRadColPos i rad (V3 r g b) p destroyLS :: Int -> World -> World -destroyLS lsid w = w - & cWorld . lightSources . at lsid .~ Nothing - & destroyLSFlashAt p3 - & originsIDsAt [MaterialSound Glass n | n <- [0,1,2]] (destroyMatS Glass) (xyV3 p3) +destroyLS lsid w = + w + & cWorld . lightSources . at lsid .~ Nothing + & destroyLSFlashAt p3 + & originsIDsAt [MaterialSound Glass n | n <- [0, 1, 2]] (destroyMatS Glass) (xyV3 p3) where - ls = w ^?! cWorld . lightSources . ix lsid -- unsafe + ls = w ^?! cWorld . lightSources . ix lsid -- unsafe p3 = _lsPos $ _lsParam ls destroyLSFlashAt :: Point3 -> World -> World -destroyLSFlashAt (V3 x' y' z') = cWorld . tempLightSources .:~ tlsTimeRadFunPos 20 150 - (TLSFade 1 10) - (addZ z' p) - where +destroyLSFlashAt (V3 x' y' z') = + cWorld . tempLightSources + .:~ tlsTimeRadFunPos + 20 + 150 + (TLSFade 1 10) + (addZ z' p) + where p = V2 x' y' diff --git a/src/Dodge/LightSource/Draw.hs b/src/Dodge/LightSource/Draw.hs index 79935369e..5d0253118 100644 --- a/src/Dodge/LightSource/Draw.hs +++ b/src/Dodge/LightSource/Draw.hs @@ -1,11 +1,13 @@ module Dodge.LightSource.Draw where + import Dodge.Data.LightSource -import Picture import Geometry.Data +import Picture drawLightSource :: LightSourceDraw -> LightSource -> Picture drawLightSource lsd = case lsd of DefaultLightSourceDraw -> defLSPic + defLSPic :: LightSource -> Picture defLSPic ls = setLayer BloomNoZWrite . translate3 (_lsPos $ _lsParam ls) . color col $ circleSolid 4 where diff --git a/src/Dodge/LightSource/Torch.hs b/src/Dodge/LightSource/Torch.hs index 28b60b06b..b368f250e 100644 --- a/src/Dodge/LightSource/Torch.hs +++ b/src/Dodge/LightSource/Torch.hs @@ -1,12 +1,18 @@ module Dodge.LightSource.Torch where -import Dodge.Data + +import Dodge.Data.World +import Dodge.Item.Draw -- heldItemOffset needs to be moved somewhere more sensible +import Dodge.LightSource -- this needs to be split! import Geometry import LensHelp -import Dodge.Item.Draw -- heldItemOffset needs to be moved somewhere more sensible -import Dodge.LightSource -- this needs to be split! createTorchLightOffset :: Creature -> Item -> Point3 -> World -> World -createTorchLightOffset cr it off = cWorld . tempLightSources .:~ tlsTimeRadColPos 1 250 0.7 - (p +.+.+ rotate3 (_crDir cr) (heldItemOffset it cr (off +.+.+ V3 8 0 1.5))) +createTorchLightOffset cr it off = + cWorld . tempLightSources + .:~ tlsTimeRadColPos + 1 + 250 + 0.7 + (p +.+.+ rotate3 (_crDir cr) (heldItemOffset it cr (off +.+.+ V3 8 0 1.5))) where p = addZ 0 $ _crPos cr diff --git a/src/Dodge/LightSource/Update.hs b/src/Dodge/LightSource/Update.hs index 21b0c5e6f..bccca76ee 100644 --- a/src/Dodge/LightSource/Update.hs +++ b/src/Dodge/LightSource/Update.hs @@ -1,7 +1,8 @@ module Dodge.LightSource.Update where + +import Control.Lens import Dodge.Data.LightSource import Geometry -import Control.Lens updateTempLightSource :: TLSUpdate -> TempLightSource -> Maybe TempLightSource updateTempLightSource tlsu = case tlsu of @@ -17,8 +18,8 @@ fadeTLS startcol x tls | otherwise = Just $ tls & tlsParam . lsCol .~ startcol -- this is wasteful, should be set once at begining where t = _tlsTime tls - + timerTLS :: TempLightSource -> Maybe TempLightSource -timerTLS t +timerTLS t | _tlsTime t <= 0 = Nothing - | otherwise = Just $ t & tlsTime -~ 1 + | otherwise = Just $ t & tlsTime -~ 1 diff --git a/src/Dodge/LinearShockwave/Draw.hs b/src/Dodge/LinearShockwave/Draw.hs index b7b67eeb8..d8477dcfc 100644 --- a/src/Dodge/LinearShockwave/Draw.hs +++ b/src/Dodge/LinearShockwave/Draw.hs @@ -1,34 +1,38 @@ -module Dodge.LinearShockwave.Draw - where -import Geometry.Vector -import Geometry.Data -import ListHelp -import Dodge.Data.LinearShockwave -import Picture +module Dodge.LinearShockwave.Draw where import Data.Maybe +import Dodge.Data.LinearShockwave +import Geometry.Data +import Geometry.Vector +import ListHelp +import Picture drawLinearShockwave :: LinearShockwave -> Picture -drawLinearShockwave lw = setLayer BloomLayer $ setDepth 20 $ pictures $ - theArc ++ - [ lineCol $ zip (reverse lps) $ map (`withAlpha` white) [0,0.05..] - , lineCol $ zip (reverse rps) $ map (`withAlpha` white) [0,0.05..] - ] +drawLinearShockwave lw = + setLayer BloomLayer $ + setDepth 20 $ + pictures $ + theArc + ++ [ lineCol $ zip (reverse lps) $ map (`withAlpha` white) [0, 0.05 ..] + , lineCol $ zip (reverse rps) $ map (`withAlpha` white) [0, 0.05 ..] + ] where --- drawing half a circle here is not perfect, a slightly smaller arc would fit --- better, but this depends upon the angle formed by the following lines, which --- is not fixed (it varies with speed and angle of last turn) + -- drawing half a circle here is not perfect, a slightly smaller arc would fit + -- better, but this depends upon the angle formed by the following lines, which + -- is not fixed (it varies with speed and angle of last turn) theArc = maybeToList $ do - (hp,hv) <- safeHead pvs + (hp, hv) <- safeHead pvs r <- safeHead xs - return $ color (snd $ last lpairs) $ uncurryV translate hp - $ arc (argV hv - pi/2) (argV hv + pi/2) $ r * magV hv - cols = map (`withAlpha` white) [0,0.05..] + return $ + color (snd $ last lpairs) $ + uncurryV translate hp $ + arc (argV hv - pi / 2) (argV hv + pi / 2) $ r * magV hv + cols = map (`withAlpha` white) [0, 0.05 ..] lpairs = zip (reverse lps) cols pvs = _lwPoints lw t = _lwTimer lw - xs = take t $ drop (20 - t) [1,1.2..] + xs = take t $ drop (20 - t) [1, 1.2 ..] lps = zipWith f pvs xs rps = zipWith g pvs xs - f (p,v) x = p +.+ x *.* vNormal v - g (p,v) x = p -.- x *.* vNormal v + f (p, v) x = p +.+ x *.* vNormal v + g (p, v) x = p -.- x *.* vNormal v diff --git a/src/Dodge/LinearShockwave/Update.hs b/src/Dodge/LinearShockwave/Update.hs index a20d244f1..c2e5ecb90 100644 --- a/src/Dodge/LinearShockwave/Update.hs +++ b/src/Dodge/LinearShockwave/Update.hs @@ -1,6 +1,6 @@ module Dodge.LinearShockwave.Update where -import Dodge.Data +import Dodge.Data.World import qualified IntMapHelp as IM import Control.Lens diff --git a/src/Dodge/LockAndKey.hs b/src/Dodge/LockAndKey.hs index 44b361b48..5ca8fd77c 100644 --- a/src/Dodge/LockAndKey.hs +++ b/src/Dodge/LockAndKey.hs @@ -1,93 +1,125 @@ ---{-# LANGUAGE TupleSections #-} module Dodge.LockAndKey where + import Dodge.Cleat -import Dodge.Data -import Dodge.Tree ---import Dodge.LevelGen.Data -import Dodge.Room -import RandomHelp import Dodge.Creature -import Dodge.Item.Craftable -import Dodge.Item.Weapon.BulletGun.Rod +import Dodge.Data.GenWorld import Dodge.Item ---import LensHelp ---import Dodge.Item.Equipment +import Dodge.Room +import Dodge.Tree +import RandomHelp +bossKeyItems :: RandomGen g => [(State g (Tree Room), State g ItemBaseType)] +bossKeyItems = [(return . cleatOnward <$> bossRoom autoCrit, takeOne [HELD PISTOL])] -bossKeyItems :: RandomGen g => [ (State g (Tree Room), State g ItemBaseType) ] -bossKeyItems = [(return . cleatOnward <$> bossRoom autoCrit, takeOne [HELD PISTOL]) ] - -lockRoomMultiItems :: RandomGen g => [ ( State g (MetaTree Room String) , State g [ItemBaseType] ) ] -lockRoomMultiItems = - [ (blinkAcrossChallenge, takeOne [[LEFT BLINKERUNSAFE,EQUIP $ AUTODETECTOR WALLDETECTOR] - ,[LEFT BLINKERUNSAFE,HELD $ HELDDETECTOR WALLDETECTOR] - ] +lockRoomMultiItems :: RandomGen g => [(State g (MetaTree Room String), State g [ItemBaseType])] +lockRoomMultiItems = + [ + ( blinkAcrossChallenge + , takeOne + [ [LEFT BLINKERUNSAFE, EQUIP $ AUTODETECTOR WALLDETECTOR] + , [LEFT BLINKERUNSAFE, HELD $ HELDDETECTOR WALLDETECTOR] + ] ) ] -lockRoomKeyItems :: RandomGen g => [ (Int -> State g (MetaTree Room String) , State g ItemBaseType ) ] -lockRoomKeyItems = - [(lasCenSensEdge, takeOne [HELD LAUNCHER,HELD LASGUN,HELD SPARKGUN,HELD FLATSHIELD,HELD FORCEFIELDGUN] ) - ,(sensorRoomRunPast ELECTRICAL, takeOne [CRAFT STATICMODULE,HELD SPARKGUN] ) - ,(sensorRoomRunPast FLAMING, takeOne [HELD FLAMESPITTER, CRAFT INCENDIARYMODULE] ) - ,(sensorRoomRunPast LASERING, return $ HELD LASGUN ) - ,(const slowDoorRoomRunPast, return $ HELD (MINIGUNX 3)) - ,(const longRoomRunPast, takeOne [HELD SNIPERRIFLE,HELD FLATSHIELD]) - ,(const glassLessonRunPast, takeOne [HELD LASGUN]) - ,(const $ lasTunnelRunPast 400, takeOne [HELD FLATSHIELD,HELD FORCEFIELDGUN]) - ,(keyCardRoomRunPast 0, return (HELD $ KEYCARD 0)) +lockRoomKeyItems :: RandomGen g => [(Int -> State g (MetaTree Room String), State g ItemBaseType)] +lockRoomKeyItems = + [ (lasCenSensEdge, takeOne [HELD LAUNCHER, HELD LASGUN, HELD SPARKGUN, HELD FLATSHIELD, HELD FORCEFIELDGUN]) + , (sensorRoomRunPast ELECTRICAL, takeOne [CRAFT STATICMODULE, HELD SPARKGUN]) + , (sensorRoomRunPast FLAMING, takeOne [HELD FLAMESPITTER, CRAFT INCENDIARYMODULE]) + , (sensorRoomRunPast LASERING, return $ HELD LASGUN) + , (const slowDoorRoomRunPast, return $ HELD (MINIGUNX 3)) + , (const longRoomRunPast, takeOne [HELD SNIPERRIFLE, HELD FLATSHIELD]) + , (const glassLessonRunPast, takeOne [HELD LASGUN]) + , (const $ lasTunnelRunPast 400, takeOne [HELD FLATSHIELD, HELD FORCEFIELDGUN]) + , (keyCardRoomRunPast 0, return (HELD $ KEYCARD 0)) ] -keyCardRunPastRand :: RandomGen g => [ (Int -> State g (MetaTree Room String) , State g ItemBaseType ) ] -keyCardRunPastRand = [(keyCardRoomRunPast 0, return (HELD $ KEYCARD 0)) ] + +keyCardRunPastRand :: RandomGen g => [(Int -> State g (MetaTree Room String), State g ItemBaseType)] +keyCardRunPastRand = [(keyCardRoomRunPast 0, return (HELD $ KEYCARD 0))] itemRooms :: RandomGen g => [(ItemBaseType, State g (MetaTree Room String))] -itemRooms = - [ (HELD LAUNCHER , join $ takeOne - [corridorBoss launcherCrit - , rc $ map makeTypeCraft [TUBE,TUBE,HARDWARE] - ] - ) - , (HELD (MINIGUNX 3) , join $ takeOne - [roomMiniIntro - , rc $ map makeTypeCraft ([MOTOR,HARDWARE] ++ replicate 6 PIPE) - ] ) - , (HELD LASGUN , join $ takeOne - [rc $ map makeTypeCraft [PRISM,TRANSFORMER,PIPE] - ] - ) - , (HELD SPARKGUN , join $ takeOne - [rc $ map makeTypeCraft [TRANSFORMER,CAN,CAN] - ] - ) - , (HELD FLAMESPITTER , join $ takeOne - [rc $ map makeTypeCraft [LIGHTER,PUMP,CAN] - ] - ) - , (HELD FLATSHIELD , join $ takeOne - [rc $ map makeTypeCraft [PLATE,PLATE] - ,rc $ map makeTypeCraft [DRUM,DRUM,PLATE] - ] - ) - , (HELD SNIPERRIFLE , join $ takeOne - [rc [sniperRifle] - ] - ) - , (HELD FORCEFIELDGUN , join $ takeOne - [rc [forceFieldGun] - ] - ) - , (HELD $ KEYCARD 0 , join $ takeOne - [rc [keyCard 0] - ] - ) - , (CRAFT INCENDIARYMODULE , join $ takeOne - [rc [incendiaryModule] - ] - ) - , (CRAFT STATICMODULE , join $ takeOne - [rc [makeTypeCraft STATICMODULE] - ] - ) +itemRooms = + [ + ( HELD LAUNCHER + , join $ + takeOne + [ corridorBoss launcherCrit + , rc $ map makeTypeCraft [TUBE, TUBE, HARDWARE] + ] + ) + , + ( HELD (MINIGUNX 3) + , join $ + takeOne + [ roomMiniIntro + , rc $ map makeTypeCraft ([MOTOR, HARDWARE] ++ replicate 6 PIPE) + ] + ) + , + ( HELD LASGUN + , join $ + takeOne + [ rc $ map makeTypeCraft [PRISM, TRANSFORMER, PIPE] + ] + ) + , + ( HELD SPARKGUN + , join $ + takeOne + [ rc $ map makeTypeCraft [TRANSFORMER, CAN, CAN] + ] + ) + , + ( HELD FLAMESPITTER + , join $ + takeOne + [ rc $ map makeTypeCraft [LIGHTER, PUMP, CAN] + ] + ) + , + ( HELD FLATSHIELD + , join $ + takeOne + [ rc $ map makeTypeCraft [PLATE, PLATE] + , rc $ map makeTypeCraft [DRUM, DRUM, PLATE] + ] + ) + , + ( HELD SNIPERRIFLE + , join $ + takeOne + [ rc [sniperRifle] + ] + ) + , + ( HELD FORCEFIELDGUN + , join $ + takeOne + [ rc [forceFieldGun] + ] + ) + , + ( HELD $ KEYCARD 0 + , join $ + takeOne + [ rc [keyCard 0] + ] + ) + , + ( CRAFT INCENDIARYMODULE + , join $ + takeOne + [ rc [incendiaryModule] + ] + ) + , + ( CRAFT STATICMODULE + , join $ + takeOne + [ rc [makeTypeCraft STATICMODULE] + ] + ) ] where rc its = do @@ -96,10 +128,10 @@ itemRooms = someCrits :: RandomGen g => State g [Creature] someCrits = do - nCrits <- state $ randomR (1,3) - fmap (take nCrits) . shuffle $ [spreadGunCrit,pistolCrit,autoCrit,armourChaseCrit] - ++ replicate 20 chaseCrit - + nCrits <- state $ randomR (1, 3) + fmap (take nCrits) . shuffle $ + [spreadGunCrit, pistolCrit, autoCrit, armourChaseCrit] + ++ replicate 20 chaseCrit --addcrits :: RandomGen g => [Item] -> State g (Tree Room) --addcrits its = do @@ -107,9 +139,8 @@ someCrits = do -- crits <- takeN nCrits <=< shuffle $ fmap PutCrit $ [spreadGunCrit,pistolCrit,autoCrit,armourChaseCrit] -- return $ roomsContaining crits its - corridorBoss :: RandomGen g => Creature -> State g (MetaTree Room String) corridorBoss cr = do endroom <- bossRoom cr - rToOnward ("corridorBoss-"++_crName cr) - $ treeFromPost (replicate 5 corridor) endroom + rToOnward ("corridorBoss-" ++ _crName cr) $ + treeFromPost (replicate 5 corridor) endroom diff --git a/src/Dodge/Luse.hs b/src/Dodge/Luse.hs index 7885ecf1b..024992ac6 100644 --- a/src/Dodge/Luse.hs +++ b/src/Dodge/Luse.hs @@ -2,7 +2,8 @@ module Dodge.Luse where import Dodge.Base import Dodge.Creature.Action -import Dodge.Data +import Dodge.Data.World +import MaybeHelp import Dodge.Default.Creature import Dodge.Item.Weapon.TriggerType import Geometry diff --git a/src/Dodge/Machine.hs b/src/Dodge/Machine.hs index 512738936..fa10ad019 100644 --- a/src/Dodge/Machine.hs +++ b/src/Dodge/Machine.hs @@ -1,45 +1,54 @@ module Dodge.Machine where -import Dodge.Data -import Dodge.Wall.Delete + +import Dodge.Base +import Dodge.Data.World import Dodge.Machine.Damage +import Dodge.SoundLogic +import Dodge.Wall.Delete +import Geometry +import qualified IntMapHelp as IM import LensHelp import Sound.Data -import Dodge.SoundLogic -import Geometry -import Dodge.Base - -import qualified IntMapHelp as IM basicMachineUpdate :: (Machine -> World -> World) -> Machine -> World -> World basicMachineUpdate f mc = basicMachineApplyDamage mc . f mc -machineUpdateLiveDieEff - :: (Machine -> World -> World) -- | effect when hp >= 1 - -> (Machine -> World -> World) -- | effect (once) when hp < 1 - -> Machine -> World -> World +machineUpdateLiveDieEff :: + -- | effect when hp >= 1 + (Machine -> World -> World) -> + -- | effect (once) when hp < 1 + (Machine -> World -> World) -> + Machine -> + World -> + World machineUpdateLiveDieEff livef dief mc - | _mcHP mc < 1 = dief mc - . (cWorld . machines %~ IM.delete mcid) - . deleteWallIDs (_mcWallIDs mc) - | otherwise = livef mc . (cWorld . machines . ix mcid %~ ( (mcDamage .~ []) . (mcHP -~ dams) )) + | _mcHP mc < 1 = + dief mc + . (cWorld . machines %~ IM.delete mcid) + . deleteWallIDs (_mcWallIDs mc) + | otherwise = livef mc . (cWorld . machines . ix mcid %~ ((mcDamage .~ []) . (mcHP -~ dams))) where - dams = sum $ map _dmAmount $ _mcDamage mc + dams = sum $ map _dmAmount $ _mcDamage mc mcid = _mcID mc -machineUpdateDeathEff :: (Machine -> World -> World) - -> Machine -> World -> World +machineUpdateDeathEff :: + (Machine -> World -> World) -> + Machine -> + World -> + World machineUpdateDeathEff f mc - | _mcHP mc < 1 = f mc - . (cWorld . machines %~ IM.delete mcid) - . deleteWallIDs (_mcWallIDs mc) - | otherwise = cWorld . machines . ix mcid %~ ( (mcDamage .~ []) . (mcHP -~ dams) ) + | _mcHP mc < 1 = + f mc + . (cWorld . machines %~ IM.delete mcid) + . deleteWallIDs (_mcWallIDs mc) + | otherwise = cWorld . machines . ix mcid %~ ((mcDamage .~ []) . (mcHP -~ dams)) where - dams = sum $ map _dmAmount $ _mcDamage mc + dams = sum $ map _dmAmount $ _mcDamage mc mcid = _mcID mc machineAddSound :: SoundID -> (Machine -> World -> World) -> Machine -> World -> World machineAddSound sid f mc w - | d < 200 = soundContinueVol (1-0.005*d) (MachineSound mid) (_mcPos mc) sid (Just 2) $ f mc w + | d < 200 = soundContinueVol (1 -0.005 * d) (MachineSound mid) (_mcPos mc) sid (Just 2) $ f mc w | otherwise = f mc w where d = dist (_crPos $ you w) (_mcPos mc) diff --git a/src/Dodge/Machine/Damage.hs b/src/Dodge/Machine/Damage.hs index 77f44f535..9aa2d08de 100644 --- a/src/Dodge/Machine/Damage.hs +++ b/src/Dodge/Machine/Damage.hs @@ -1,9 +1,10 @@ module Dodge.Machine.Damage where -import Dodge.Data + +import Dodge.Data.World import LensHelp basicMachineApplyDamage :: Machine -> World -> World -basicMachineApplyDamage mc = cWorld . machines . ix mcid %~ ( (mcDamage .~ []) . (mcHP -~ dams) ) +basicMachineApplyDamage mc = cWorld . machines . ix mcid %~ ((mcDamage .~ []) . (mcHP -~ dams)) where - dams = sum $ map _dmAmount $ _mcDamage mc + dams = sum $ map _dmAmount $ _mcDamage mc mcid = _mcID mc diff --git a/src/Dodge/Machine/Destroy.hs b/src/Dodge/Machine/Destroy.hs index 7bdb02f1f..504cc5420 100644 --- a/src/Dodge/Machine/Destroy.hs +++ b/src/Dodge/Machine/Destroy.hs @@ -1,26 +1,28 @@ module Dodge.Machine.Destroy where -import Dodge.WorldEffect -import Dodge.Wall.Delete -import Dodge.Data -import Dodge.WorldEvent.Explosion -import LensHelp import Data.Maybe +import Dodge.Data.World +import Dodge.Wall.Delete +import Dodge.WorldEffect +import Dodge.WorldEvent.Explosion import qualified IntMapHelp as IM +import LensHelp destroyMachine :: Machine -> World -> World -destroyMachine mc = (cWorld . machines %~ IM.delete (_mcID mc)) - . deleteWallIDs (_mcWallIDs mc) - . makeExplosionAt (_mcPos mc) - . mcKillTerm mc - . mcKillBut mc +destroyMachine mc = + (cWorld . machines %~ IM.delete (_mcID mc)) + . deleteWallIDs (_mcWallIDs mc) + . makeExplosionAt (_mcPos mc) + . mcKillTerm mc + . mcKillBut mc mcKillTerm :: Machine -> World -> World mcKillTerm mc w = fromMaybe w $ do tmid <- mc ^? mcMounts . ix ObTerminal - tm <- w ^? cWorld . terminals . ix tmid - return $ w - & doTmWdWd (_tmDeathEffect tm) tm + tm <- w ^? cWorld . terminals . ix tmid + return $ + w + & doTmWdWd (_tmDeathEffect tm) tm mcKillBut :: Machine -> World -> World mcKillBut mc w = fromMaybe w $ do diff --git a/src/Dodge/Machine/Update.hs b/src/Dodge/Machine/Update.hs index 25c564a7f..41904727e 100644 --- a/src/Dodge/Machine/Update.hs +++ b/src/Dodge/Machine/Update.hs @@ -1,13 +1,13 @@ module Dodge.Machine.Update where +import Dodge.Item.Held.BatteryGuns import Data.List (partition) import Data.Maybe import Dodge.Base.Collide import Dodge.Base.You -import Dodge.Data +import Dodge.Data.World import Dodge.Default import Dodge.FloorItem -import Dodge.Item.Weapon.BatteryGuns import Dodge.Machine.Destroy import Dodge.Movement.Turn import Dodge.SoundLogic @@ -61,7 +61,7 @@ updateTurret rotSpeed mc w defaultCreature & crID .~ cid & crInv . at 0 - ?~ ( _tuWeapon (_mcType mc) & itUse . useAim . aimHandlePos -~ 10 + ?~ ( _tuWeapon (_mcType mc) & itUse . heldAim . aimHandlePos -~ 10 & itUse . heldConsumption . laLoaded .~ 1 ) & crPos .~ mcpos diff --git a/src/Dodge/Magnet.hs b/src/Dodge/Magnet.hs index 3837cf2b5..a03247705 100644 --- a/src/Dodge/Magnet.hs +++ b/src/Dodge/Magnet.hs @@ -1,8 +1,9 @@ module Dodge.Magnet where -import Dodge.Data -import Geometry import Control.Lens +import Dodge.Data.Bullet +import Dodge.Data.Magnet +import Geometry dampField :: Magnet -> Bullet -> Bullet dampField mg pt = case pt of @@ -21,11 +22,12 @@ curveAroundField minrad maxrad mg pt = case pt of thedist = dist btpos mgpos mgpos = _mgPos mg btpos = _buPos pt - rotateToCircle vel - | (isLHS mgpos btpos (btpos +.+ vel) && isRHS mgpos btpos (mgpos +.+ vNormal vel) ) - || (isRHS mgpos btpos (btpos +.+ vel) && isLHS mgpos btpos (mgpos +.+ vNormal vel) ) - = rotateV rot vel + rotateToCircle vel + | (isLHS mgpos btpos (btpos +.+ vel) && isRHS mgpos btpos (mgpos +.+ vNormal vel)) + || (isRHS mgpos btpos (btpos +.+ vel) && isLHS mgpos btpos (mgpos +.+ vNormal vel)) = + rotateV rot vel | otherwise = rotateV (negate rot) vel - rot | thedist < minrad = 0.5 - | otherwise = 0.5 * ((maxrad - thedist) / (maxrad - minrad) ) ** 2 + rot + | thedist < minrad = 0.5 + | otherwise = 0.5 * ((maxrad - thedist) / (maxrad - minrad)) ** 2 _ -> pt diff --git a/src/Dodge/Magnet/Update.hs b/src/Dodge/Magnet/Update.hs index 00452f0cb..6e4b2e6f1 100644 --- a/src/Dodge/Magnet/Update.hs +++ b/src/Dodge/Magnet/Update.hs @@ -1,10 +1,10 @@ -module Dodge.Magnet.Update - where -import Dodge.Data.Magnet +module Dodge.Magnet.Update where + import Control.Lens +import Dodge.Data.Magnet doMagnetUpdate :: MagnetUpdate -> Magnet -> Maybe Magnet doMagnetUpdate mu = case mu of - MagnetUpdateTimer i - | i < 1 -> const Nothing + MagnetUpdateTimer i + | i < 1 -> const Nothing | otherwise -> Just . (mgUpdate .~ MagnetUpdateTimer (i - 1)) diff --git a/src/Dodge/Material/Damage.hs b/src/Dodge/Material/Damage.hs index efb9800a1..42708ce53 100644 --- a/src/Dodge/Material/Damage.hs +++ b/src/Dodge/Material/Damage.hs @@ -1,46 +1,51 @@ module Dodge.Material.Damage where -import Dodge.Data + +import Dodge.Data.World import Dodge.Spark import Geometry -damageMaterial :: Damage -> Material - -> Float -- the angle of the hit surface, in radians - -> World -> (Int, World) +damageMaterial :: + Damage -> + Material -> + Float -> -- the angle of the hit surface, in radians + World -> + (Int, World) damageMaterial dm mt = case mt of Stone -> damageStone dm _ -> defDamageMaterial dm + -- Glass -> damageGlass dm -defDamageMaterial :: Damage -> Float -> World -> (Int,World) +defDamageMaterial :: Damage -> Float -> World -> (Int, World) defDamageMaterial dm _ w = (_dmAmount dm, w) -damageStone :: Damage -> Float -> World -> (Int,World) +damageStone :: Damage -> Float -> World -> (Int, World) damageStone dm dir = case _dmType dm of - LASERING -> a 0 $ colSparkRandDir 0.2 lSparkCol outTo (argV $ reflectIn (p -.- sp) v) - PIERCING -> a d $ colSparkRandDir 0.2 pSparkCol outTo (argV $ reflectIn (p -.- sp) v) - BLUNT -> a d id - SHATTERING -> a d id - CRUSHING -> a d id - EXPLOSIVE -> a d id - CUTTING -> a d id - SPARKING -> a 0 id - FLAMING -> a 0 id - ELECTRICAL -> a 0 id - CONCUSSIVE -> a d id - TORQUEDAM -> a 0 id - PUSHDAM -> a 0 id - POISONDAM -> a 0 id + LASERING -> a 0 $ colSparkRandDir 0.2 lSparkCol outTo (argV $ reflectIn (p -.- sp) v) + PIERCING -> a d $ colSparkRandDir 0.2 pSparkCol outTo (argV $ reflectIn (p -.- sp) v) + BLUNT -> a d id + SHATTERING -> a d id + CRUSHING -> a d id + EXPLOSIVE -> a d id + CUTTING -> a d id + SPARKING -> a 0 id + FLAMING -> a 0 id + ELECTRICAL -> a 0 id + CONCUSSIVE -> a d id + TORQUEDAM -> a 0 id + PUSHDAM -> a 0 id + POISONDAM -> a 0 id ENTERREMENT -> a 0 id where v = unitVectorAtAngle dir - a x f w = (x,f w) + a x f w = (x, f w) d = _dmAmount dm sp = _dmFrom dm p = _dmAt dm outTo = p +.+ squashNormalizeV (sp -.- p) pSparkCol = V4 5 1 0.5 2 lSparkCol = V4 20 (-5) 0 1 - + --damageGlass :: Damage -> Float -> World -> (World,Int) --damageGlass dm dir w = w & case _dmType dm of -- LASERING -> a 0 $ id @@ -59,7 +64,7 @@ damageStone dm dir = case _dmType dm of -- POISONDAM -> a 0 id -- ENTERREMENT -> a 0 id -- where --- mbl = do +-- mbl = do -- blid <- wl ^? wlStructure . wsBlock -- w ^? blocks . ix blid -- d :: Int diff --git a/src/Dodge/Material/Sound.hs b/src/Dodge/Material/Sound.hs index 118567be2..5df91d747 100644 --- a/src/Dodge/Material/Sound.hs +++ b/src/Dodge/Material/Sound.hs @@ -1,26 +1,27 @@ module Dodge.Material.Sound where + import Dodge.Data.Material import Dodge.SoundLogic.ExternallyGeneratedSounds import Sound.Data destroyMatS :: Material -> [SoundID] destroyMatS mat = case mat of - Glass -> [glassShat1S,glassShat2S,glassShat3S,glassShat4S] - Crystal -> [glassShat1S,glassShat2S,glassShat3S,glassShat4S] - Stone -> [stone1S,stone2S,stone3S,stone4S,stone5S] - Dirt -> [stone1S,stone3S] - Wood -> [stone1S,stone3S] - Metal -> [metal1S,metal2S,metal3S,metal4S,metal5S,metal6S,metal7S] - Electronics -> [metal1S,metal2S,metal3S,metal4S,metal5S,metal6S,metal7S] - Flesh -> [gut1S,gut2S,gut3S,gut4S,gut5S,gut6S] + Glass -> [glassShat1S, glassShat2S, glassShat3S, glassShat4S] + Crystal -> [glassShat1S, glassShat2S, glassShat3S, glassShat4S] + Stone -> [stone1S, stone2S, stone3S, stone4S, stone5S] + Dirt -> [stone1S, stone3S] + Wood -> [stone1S, stone3S] + Metal -> [metal1S, metal2S, metal3S, metal4S, metal5S, metal6S, metal7S] + Electronics -> [metal1S, metal2S, metal3S, metal4S, metal5S, metal6S, metal7S] + Flesh -> [gut1S, gut2S, gut3S, gut4S, gut5S, gut6S] weakenMatS :: Material -> [SoundID] weakenMatS mat = case mat of - Glass -> [smallGlass1S,smallGlass2S,smallGlass3S,smallGlass4S] - Crystal -> [smallGlass1S,smallGlass2S,smallGlass3S,smallGlass4S] - Stone -> [stone1S,stone2S,stone3S,stone4S,stone5S] - Dirt -> [stone1S,stone3S] - Wood -> [stone1S,stone3S] - Metal -> [metal1S,metal2S,metal3S,metal4S,metal5S,metal6S,metal7S] - Electronics -> [metal1S,metal2S,metal3S,metal4S,metal5S,metal6S,metal7S] - Flesh -> [blood1S,blood2S,blood3S,blood4S,blood5S,blood6S,blood7S,blood8S] + Glass -> [smallGlass1S, smallGlass2S, smallGlass3S, smallGlass4S] + Crystal -> [smallGlass1S, smallGlass2S, smallGlass3S, smallGlass4S] + Stone -> [stone1S, stone2S, stone3S, stone4S, stone5S] + Dirt -> [stone1S, stone3S] + Wood -> [stone1S, stone3S] + Metal -> [metal1S, metal2S, metal3S, metal4S, metal5S, metal6S, metal7S] + Electronics -> [metal1S, metal2S, metal3S, metal4S, metal5S, metal6S, metal7S] + Flesh -> [blood1S, blood2S, blood3S, blood4S, blood5S, blood6S, blood7S, blood8S] diff --git a/src/Dodge/Menu.hs b/src/Dodge/Menu.hs index a3b549d4d..75e445add 100644 --- a/src/Dodge/Menu.hs +++ b/src/Dodge/Menu.hs @@ -5,7 +5,7 @@ module Dodge.Menu ( ) where import Dodge.Config.Update -import Dodge.Data +import Dodge.Data.Universe import Dodge.Menu.OptionType import Dodge.Menu.PushPop import Dodge.PreloadData @@ -13,16 +13,12 @@ import Dodge.Save import Dodge.SoundLogic import Dodge.StartNewGame import LensHelp +import MaybeHelp import Padding ---import Dodge.LevelGen - import SDL import System.Clipboard import Text.Read ---import Control.Lens ---import System.Random - slTitleOptionsEff :: String -> [MenuOption] -> (Universe -> IO (Maybe Universe)) -> ScreenLayer slTitleOptionsEff title ops eff = OptionScreen diff --git a/src/Dodge/Menu/OptionType.hs b/src/Dodge/Menu/OptionType.hs index 3b96a2c53..70a1471b1 100644 --- a/src/Dodge/Menu/OptionType.hs +++ b/src/Dodge/Menu/OptionType.hs @@ -1,20 +1,23 @@ {-# OPTIONS -fno-warn-missing-signatures #-} module Dodge.Menu.OptionType where -import Dodge.Data -import Dodge.Menu.PushPop + import Control.Lens +import Dodge.Data.Universe +import Dodge.Menu.PushPop -makeBoolOption lns t = Toggle - (return . Just . (uvConfig . lns #%~ not)) - (\u -> Right (t , show (u ^# uvConfig . lns))) +makeBoolOption lns t = + Toggle + (return . Just . (uvConfig . lns #%~ not)) + (\u -> Right (t, show (u ^# uvConfig . lns))) -makeEnumOption lns str sideeff = Toggle - (\u -> Just <$> sideeff (u & uvConfig . lns #%~ cycleEnum) ) - (\u -> Right (str , show (u ^# uvConfig . lns)) ) +makeEnumOption lns str sideeff = + Toggle + (\u -> Just <$> sideeff (u & uvConfig . lns #%~ cycleEnum)) + (\u -> Right (str, show (u ^# uvConfig . lns))) makeSubmenuOption submenu t = Toggle (pushScreen submenu) (const t) -cycleEnum :: (Eq a, Enum a,Bounded a) => a -> a -cycleEnum x +cycleEnum :: (Eq a, Enum a, Bounded a) => a -> a +cycleEnum x | x == maxBound = minBound | otherwise = succ x diff --git a/src/Dodge/Menu/PushPop.hs b/src/Dodge/Menu/PushPop.hs index 9ffc5cd96..a17471185 100644 --- a/src/Dodge/Menu/PushPop.hs +++ b/src/Dodge/Menu/PushPop.hs @@ -1,14 +1,16 @@ module Dodge.Menu.PushPop where -import Dodge.Data + +import Dodge.Data.Universe import LensHelp popScreen' :: Universe -> Maybe Universe popScreen' = Just . (menuLayers %~ tail) + popScreen :: Universe -> IO (Maybe Universe) popScreen = return . popScreen' - pushScreen' :: ScreenLayer -> Universe -> Maybe Universe pushScreen' ml = Just . (menuLayers .:~ ml) + pushScreen :: ScreenLayer -> Universe -> IO (Maybe Universe) pushScreen ml = return . pushScreen' ml diff --git a/src/Dodge/Module.hs b/src/Dodge/Module.hs index 475089119..54d3f1c52 100644 --- a/src/Dodge/Module.hs +++ b/src/Dodge/Module.hs @@ -1,17 +1,12 @@ -module Dodge.Module - ( moduleSizes - , moduleStrings - , moduleName - ) where -import Dodge.Data ---import Dodge.Combine.Module +module Dodge.Module ( + moduleSizes, + moduleStrings, + moduleName, +) where import qualified Data.Map.Strict as M ---import Control.Lens ---import Data.Maybe +import Dodge.Data.Item ---moduleSizes :: Item -> Int ---moduleSizes = moduleFold (+) (^? modSize) 0 moduleSizes :: Item -> Int moduleSizes = sum . fmap moduleSize . _iyModules . _itType @@ -26,30 +21,30 @@ moduleStrings = M.elems . M.mapMaybe moduleName . _iyModules . _itType moduleName :: ItemModuleType -> Maybe String moduleName imt = case imt of EMPTYMODULE -> Nothing - DRUMMAG -> Just "+DRUM MAG" - BELTMAG -> Just "+BELT FEED" - MAGNETMAG -> Just "+MAGNET FEED" - INCENDBUL -> Just "+INCENDIARY" - BOUNCEBUL -> Just "+BOUNCE" - PENBUL -> Just "+PENETRATE" - STATICBUL -> Just "+STATIC" - CONCUSBUL -> Just "+CONCUSS" - TARGCR -> Just "+CREATURETARGETING" - TARGLAS -> Just "+LASERTARGETING" - TARGPOS -> Just "+POSTIONALTARGETING" - MAGNETTRAJ -> Just "+MAGNETTRAJECTORY" - FLECHETRAJ -> Just "+FLECHETTETRAJECTORY" - BEZIERTRAJ -> Just "+BEZIERTRAJECTORY" - INCENDLAS -> Just "+INCENDIARY" - SPLITLAS -> Just "+SPLIT" - STATICLAS -> Just "+STATIC" - WEPTELE -> Just "+DIRECTEDTELE" - LAUNCHHOME -> Just "+TARGET HOMING" + DRUMMAG -> Just "+DRUM MAG" + BELTMAG -> Just "+BELT FEED" + MAGNETMAG -> Just "+MAGNET FEED" + INCENDBUL -> Just "+INCENDIARY" + BOUNCEBUL -> Just "+BOUNCE" + PENBUL -> Just "+PENETRATE" + STATICBUL -> Just "+STATIC" + CONCUSBUL -> Just "+CONCUSS" + TARGCR -> Just "+CREATURETARGETING" + TARGLAS -> Just "+LASERTARGETING" + TARGPOS -> Just "+POSTIONALTARGETING" + MAGNETTRAJ -> Just "+MAGNETTRAJECTORY" + FLECHETRAJ -> Just "+FLECHETTETRAJECTORY" + BEZIERTRAJ -> Just "+BEZIERTRAJECTORY" + INCENDLAS -> Just "+INCENDIARY" + SPLITLAS -> Just "+SPLIT" + STATICLAS -> Just "+STATIC" + WEPTELE -> Just "+DIRECTEDTELE" + LAUNCHHOME -> Just "+TARGET HOMING" EXTRABATTERY -> Just "+BATTERY" - ATTACHTORCH -> Just "+TORCH" + ATTACHTORCH -> Just "+TORCH" --moduleFold :: (m -> m -> m) -> (ItemModule -> Maybe m) -> m -> Item -> m ---moduleFold g f e = foldr (g . fromMaybe e . f) e --- . fmap fromModuleType +--moduleFold g f e = foldr (g . fromMaybe e . f) e +-- . fmap fromModuleType -- . _iyModules -- . _itType diff --git a/src/Dodge/Particle/Damage.hs b/src/Dodge/Particle/Damage.hs index 8ac9d56e6..226336d03 100644 --- a/src/Dodge/Particle/Damage.hs +++ b/src/Dodge/Particle/Damage.hs @@ -1,15 +1,10 @@ module Dodge.Particle.Damage where -import Dodge.Data + +import Dodge.Data.Bullet import Geometry ---simpleDam :: DamageType -> Int -> Particle -> Point2 -> [Damage] ---simpleDam dt amount bt p = [ Damage dt amount sp p ep NoDamageEffect ] --- where --- sp = _ptPos bt --- bulVel = _ptVel bt --- ep = sp +.+ bulVel simpleDam' :: DamageType -> Int -> Bullet -> Point2 -> [Damage] -simpleDam' dt amount bt p = [ Damage dt amount sp p ep NoDamageEffect ] +simpleDam' dt amount bt p = [Damage dt amount sp p ep NoDamageEffect] where sp = _buPos bt bulVel = _buVel bt @@ -17,12 +12,12 @@ simpleDam' dt amount bt p = [ Damage dt amount sp p ep NoDamageEffect ] hvBulDams :: [Damage] hvBulDams = - [ Damage PIERCING 25 0 0 0 NoDamageEffect - , Damage PIERCING 25 0 0 0 NoDamageEffect - , Damage PIERCING 25 0 0 0 NoDamageEffect - , Damage PIERCING 25 0 0 0 NoDamageEffect - , Damage PIERCING 25 0 0 0 NoDamageEffect - , Damage PIERCING 25 0 0 0 NoDamageEffect - , Damage TORQUEDAM 1 0 0 0 $ TorqueDamage 0.7 - , Damage PUSHDAM 1 0 0 0 $ PushBackDamage 3 - ] + [ Damage PIERCING 25 0 0 0 NoDamageEffect + , Damage PIERCING 25 0 0 0 NoDamageEffect + , Damage PIERCING 25 0 0 0 NoDamageEffect + , Damage PIERCING 25 0 0 0 NoDamageEffect + , Damage PIERCING 25 0 0 0 NoDamageEffect + , Damage PIERCING 25 0 0 0 NoDamageEffect + , Damage TORQUEDAM 1 0 0 0 $ TorqueDamage 0.7 + , Damage PUSHDAM 1 0 0 0 $ PushBackDamage 3 + ] diff --git a/src/Dodge/Particle/Draw.hs b/src/Dodge/Particle/Draw.hs index d71a9da55..8ddda922e 100644 --- a/src/Dodge/Particle/Draw.hs +++ b/src/Dodge/Particle/Draw.hs @@ -1,54 +1,15 @@ module Dodge.Particle.Draw where -import Dodge.Data + +import Dodge.Data.Laser import Picture ---drawParticle :: Particle -> Picture ---drawParticle pt = case pt of --- ShockLine {} -> drawSonicWave pt --- ---drawShockwave :: Particle -> Picture ---drawShockwave pt = setDepth 20 --- . setLayer BloomLayer --- . uncurryV translate (_ptPos pt) --- . color (_ptColor pt) --- $ thickCircle rad thickness --- where --- r = _ptRad pt --- thickness = tFraction**2 * r --- rad = r - (3/4) * r * tFraction --- tFraction = fromIntegral (_ptTimer pt) / fromIntegral (_ptMaxTime pt) - ---drawInverseShockwave :: Particle -> Picture ---drawInverseShockwave pt --- = setLayer BloomLayer $ setDepth 20 $ uncurryV translate p --- $ color cyan $ thickCircle rad thickness --- where --- p = _ptPos pt --- r = _ptRad pt --- t = _ptTimer pt --- rad = r - 0.1 * r * fromIntegral (10 - t) --- thickness = fromIntegral (10 - t) **2 * rad / 40 - ---drawTeslaArc :: Particle -> Picture ---drawTeslaArc pt = setLayer BloomNoZWrite $ pictures --- [ setDepth 20.5 $ color (brightX 2 1 $ _ptColor pt) $ thickLine 3 ps --- , setDepth 20 $ color (V4 0 0 0 0.5) $ thickLine 10 ps --- ] --- where --- ps = _ptPoints pt - drawTargetLaser :: Laser -> Picture -drawTargetLaser pt = setLayer BloomNoZWrite $ pictures - [ setDepth 19 . color (brightX 0 0.5 col) $ thickLine 5 (sp:ps) - , setDepth 19.5 . color (brightX 5 1 col) $ thickLine 1 (sp:ps) - ] +drawTargetLaser pt = + setLayer BloomNoZWrite $ + pictures + [ setDepth 19 . color (brightX 0 0.5 col) $ thickLine 5 (sp : ps) + , setDepth 19.5 . color (brightX 5 1 col) $ thickLine 1 (sp : ps) + ] where col = _laColor pt - (sp:ps) = _laPoints pt - ---drawSonicWave :: Particle -> Picture ---drawSonicWave pt = foldMap (color (_ptColor pt) . setLayer BloomNoZWrite . setDepth 20 --- . lineThick 20 --- . map fst) --- $ _ptPointDirs pt - + (sp : ps) = _laPoints pt diff --git a/src/Dodge/Path.hs b/src/Dodge/Path.hs index 225f7d63b..d924a248d 100644 --- a/src/Dodge/Path.hs +++ b/src/Dodge/Path.hs @@ -1,43 +1,40 @@ --{-# LANGUAGE TupleSections #-} -module Dodge.Path - ( pointTowardsImpulse - , makePathBetween - , makePathBetweenPs --- , removePathsCrossing - , obstructPathsCrossing - , pairsToGraph - , getNodePos - , walkableNodeNear - , bfsNodePoints - , fusePairs - ) where -import Dodge.Zoning.Pathing -import Dodge.Zoning.Base -import Dodge.Data -import Dodge.Base.Collide -import Geometry.Data -import Geometry +module Dodge.Path ( + pointTowardsImpulse, + makePathBetween, + makePathBetweenPs, + -- , removePathsCrossing + obstructPathsCrossing, + pairsToGraph, + getNodePos, + walkableNodeNear, + bfsNodePoints, + fusePairs, +) where -import Data.Foldable import Control.Lens -import Data.Maybe -import Data.List ---import qualified IntMapHelp as IM +import Data.Foldable import Data.Graph.Inductive hiding ((&)) -import qualified Data.Set as Set -import Data.Set (Set) -import qualified Data.Map.Strict as M +import Data.List import Data.Map.Strict (Map) -import StreamingHelp +import qualified Data.Map.Strict as M +import Data.Maybe +import Data.Set (Set) +import qualified Data.Set as Set +import Dodge.Base.Collide +import Dodge.Data.World +import Dodge.Zoning.Base +import Dodge.Zoning.Pathing +import Geometry import qualified Streaming.Prelude as S ---import Data.Graph.Inductive.PatriciaTree ---import Data.Graph.Inductive.Graph hiding ((&)) +import StreamingHelp getNodePos :: Int -> World -> Maybe Point2 getNodePos i w = _pathGraph (_cWorld w) `lab` i makePathBetween :: Point2 -> Point2 -> World -> Maybe [Int] -makePathBetween a b w = do -- join $ sp <$> a' <*> b' <*> return (_pathGraph w) +makePathBetween a b w = do + -- join $ sp <$> a' <*> b' <*> return (_pathGraph w) na <- walkableNodeNear w a nb <- walkableNodeNear w b sp na nb (second _peDist (efilter (not . pathEdgeObstructed . (^. _3)) $ _pathGraph (_cWorld w))) @@ -47,7 +44,6 @@ pathEdgeObstructed pe = DoorObstacle `Set.member` obs || BlockObstacle `Set.memb where obs = _peObstacles pe - walkableNodeNear :: World -> Point2 -> Maybe Int {-# INLINE walkableNodeNear #-} walkableNodeNear w p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear @@ -63,94 +59,99 @@ bfsNodePoints n w = mapMaybe (lab g) $ bfs n g where g = _pathGraph (_cWorld w) - pointTowardsImpulse :: Point2 -> Point2 -> World -> Maybe Point2 pointTowardsImpulse a b w = (find (flip (isWalkable a) w) . reverse) =<< makePathBetweenPs a b w ------ continues a walk from a list of points, without repetitions ------ supposes that the list is non-empty --randomGraphWalk :: RandomGen g => [Int] -> Gr a b -> State g [Int] ---randomGraphWalk (n:ns) g = do +--randomGraphWalk (n:ns) g = do -- next' <- randomGraphStepRestricted n ns g --- case next' of +-- case next' of -- Nothing -> return (n:ns) -- Just n' -> randomGraphWalk (n':n:ns) g --randomGraphWalk _ _ = error "Trying to walk in an empty list" -- --randomPointXStepsFrom :: Int -> Point2 -> World -> Point2 ---randomPointXStepsFrom i p w = +--randomPointXStepsFrom i p w = -- let g = _pathGraph w -- ns = labNodes g -- mp = listToMaybe $ sortBy (compare `on` dist p . snd) $ filter (flip (isWalkable p) w . snd) ns --- in case mp of +-- in case mp of -- Nothing -> p --- Just (n,_) -> fromJust +-- Just (n,_) -> fromJust -- $ lab g (last $ take i $ randomGraphWalk [n] g Data.Function.& evalState $ _randGen w) -- --randomPointsXStepsFrom :: Int -> Point2 -> World -> [Point2] ---randomPointsXStepsFrom i p w = +--randomPointsXStepsFrom i p w = -- let g = _pathGraph w -- ns = labNodes g -- mp = listToMaybe $ sortBy (compare `on` dist p . snd) $ filter (flip (isWalkable p) w . snd) ns --- in case mp of +-- in case mp of -- Nothing -> [p] -- Just (n,_) -> mapMaybe (lab g) (take i $ randomGraphWalk [n] g Data.Function.& evalState $ _randGen w) -- --randomGraphStep :: RandomGen g => Int -> Gr a b -> State g (Maybe Int) ---randomGraphStep n g = +--randomGraphStep n g = -- do let ns = neighbors g n -- i <- state $ randomR (0,length ns - 1) -- case ns of [] -> return Nothing -- _ -> return $ Just $ ns !! i --randomGraphStepRestricted :: RandomGen g => Int -> [Int] -> Gr a b -> State g (Maybe Int) ---randomGraphStepRestricted n notns g = do +--randomGraphStepRestricted n notns g = do -- let ns = neighbors g n \\ notns -- i <- state $ randomR (0,length ns - 1) --- case ns of +-- case ns of -- [] -> return Nothing -- _ -> return $ Just $ ns !! i -- -pairsToGraph :: Set.Set (Point2,Point2) -> (Map (V2 Point2) (Int,Int,PathEdge),Gr Point2 PathEdge) +pairsToGraph :: Set.Set (Point2, Point2) -> (Map (V2 Point2) (Int, Int, PathEdge), Gr Point2 PathEdge) pairsToGraph pairs = addEdges nodemap gr $ S.each pairs where - (nodemap,_,gr) = addNodes $ S.map fst (S.each pairs) <> S.map snd (S.each pairs) + (nodemap, _, gr) = addNodes $ S.map fst (S.each pairs) <> S.map snd (S.each pairs) + -- let nodes' = Set.map fst pairs `Set.union` Set.map snd pairs -- pairs' = Set.map (\(x,y)->(x,y,f x y)) pairs -- in undir $ run_ Data.Graph.Inductive.empty $ insMapNodesM (Set.toList nodes') >> insMapEdgesM (Set.toList pairs') -addNodes :: StreamOf Point2 -> (Map Point2 Int,Int,Gr Point2 PathEdge) -addNodes = runIdentity . S.fold_ f (mempty,0,Data.Graph.Inductive.empty) id +addNodes :: StreamOf Point2 -> (Map Point2 Int, Int, Gr Point2 PathEdge) +addNodes = runIdentity . S.fold_ f (mempty, 0, Data.Graph.Inductive.empty) id where - f (nodemap,i,gr) p = case nodemap M.!? p of - Just _ -> (nodemap,i,gr) - Nothing -> (nodemap & at p ?~i ,i+1, insNode (i,p) gr) -addEdges :: Map Point2 Int -> Gr Point2 PathEdge -> StreamOf (Point2,Point2) - -> (Map (V2 Point2) (Int,Int,PathEdge) , Gr Point2 PathEdge) -addEdges nodemap gr = runIdentity . S.fold_ f (mempty,gr) id + f (nodemap, i, gr) p = case nodemap M.!? p of + Just _ -> (nodemap, i, gr) + Nothing -> (nodemap & at p ?~ i, i + 1, insNode (i, p) gr) + +addEdges :: + Map Point2 Int -> + Gr Point2 PathEdge -> + StreamOf (Point2, Point2) -> + (Map (V2 Point2) (Int, Int, PathEdge), Gr Point2 PathEdge) +addEdges nodemap gr = runIdentity . S.fold_ f (mempty, gr) id where - f (edgemap,gr') (a,b) = (M.insert (V2 a b) theedge edgemap + f (edgemap, gr') (a, b) = + ( M.insert (V2 a b) theedge edgemap , insEdge theedge gr' ) where - theedge = (g a,g b,PathEdge a b (dist a b) mempty) + theedge = (g a, g b, PathEdge a b (dist a b) mempty) g a = nodemap M.! a -obstructPathsCrossing :: EdgeObstacle -> Point2 -> Point2 -> World -> ( World, [(Int,Int,PathEdge)]) -obstructPathsCrossing obstacletype sp' ep w = +obstructPathsCrossing :: EdgeObstacle -> Point2 -> Point2 -> World -> (World, [(Int, Int, PathEdge)]) +obstructPathsCrossing obstacletype sp' ep w = ( w & cWorld . pathGraph %~ updateedges , es ) where es = filter edgecrosses $ pesNearSeg sp' ep w - edgecrosses (_,_,pe) = isJust $ intersectSegSeg sp' ep (_peStart pe) (_peEnd pe) + edgecrosses (_, _, pe) = isJust $ intersectSegSeg sp' ep (_peStart pe) (_peEnd pe) updateedges gr = foldl' updateedge gr es - updateedge gr (x,y,pe) - = insEdge (x,y,pe & peObstacles . at obstacletype ?~ ()) $ delEdge (x,y) gr + updateedge gr (x, y, pe) = + insEdge (x, y, pe & peObstacles . at obstacletype ?~ ()) $ delEdge (x, y) gr fuseFunc :: (a -> a -> Bool) -> [a] -> a -> a fuseFunc t xs x = fromJust . find (t x) $ nubBy t xs -fusePairs :: Set (Point2,Point2) -> Set (Point2,Point2) +fusePairs :: Set (Point2, Point2) -> Set (Point2, Point2) fusePairs ps = Set.map (bimap f f) ps where - f = fuseFunc (\x y -> dist x y < 2) . nub $ concatMap (\(x,y) -> [x,y]) $ toList ps + f = fuseFunc (\x y -> dist x y < 2) . nub $ concatMap (\(x, y) -> [x, y]) $ toList ps diff --git a/src/Dodge/Payload.hs b/src/Dodge/Payload.hs index d79478f80..bc34877d9 100644 --- a/src/Dodge/Payload.hs +++ b/src/Dodge/Payload.hs @@ -1,7 +1,8 @@ module Dodge.Payload where -import Geometry.Data -import Dodge.Data + +import Dodge.Data.World import Dodge.WorldEvent.Explosion +import Geometry.Data usePayload :: Payload -> Point2 -> World -> World usePayload payload = case payload of diff --git a/src/Dodge/Picture/SizeInvariant.hs b/src/Dodge/Picture/SizeInvariant.hs index 888926434..2480dbca5 100644 --- a/src/Dodge/Picture/SizeInvariant.hs +++ b/src/Dodge/Picture/SizeInvariant.hs @@ -1,44 +1,44 @@ -module Dodge.Picture.SizeInvariant - where -import Dodge.Data ---import Dodge.Base +module Dodge.Picture.SizeInvariant where + +import Data.Maybe import Dodge.Base.Window +import Dodge.Data.Universe import Geometry import Picture -import Data.Maybe - -fixedSizePicAt - :: Picture - -> Point2 - -> World - -> Picture -fixedSizePicAt pic p w - = setLayer DebugLayer - . setDepth 20 - . translate x y - . scale theScale theScale - $ pic +fixedSizePicAt :: + Picture -> + Point2 -> + World -> + Picture +fixedSizePicAt pic p w = + setLayer DebugLayer + . setDepth 20 + . translate x y + . scale theScale theScale + $ pic where campos = _cameraViewFrom (_cWorld w) v = p -.- campos theScale = 1 / _cameraZoom (_cWorld w) (V2 x y) = campos +.+ v -fixedSizePicClamp - :: Int -- ^ horizontal border - -> Int -- ^ vertical border - -> Picture - -> Point2 - -> Configuration - -> World - -> Picture -fixedSizePicClamp xbord ybord pic p cfig w - = setLayer DebugLayer - . setDepth 20 - . translate x y - . scale theScale theScale - $ pic +fixedSizePicClamp :: + -- | horizontal border + Int -> + -- | vertical border + Int -> + Picture -> + Point2 -> + Configuration -> + World -> + Picture +fixedSizePicClamp xbord ybord pic p cfig w = + setLayer DebugLayer + . setDepth 20 + . translate x y + . scale theScale theScale + $ pic where r = negate $ _cameraRot (_cWorld w) z = _cameraZoom (_cWorld w) @@ -47,21 +47,24 @@ fixedSizePicClamp xbord ybord pic p cfig w theScale = 1 / _cameraZoom (_cWorld w) (V2 x y) = campos +.+ rotateV (negate r) (V2 xr' yr') (V2 xr yr) = rotateV r v - xr' = absClamp ((halfWidth cfig - fromIntegral xbord) / z) xr + xr' = absClamp ((halfWidth cfig - fromIntegral xbord) / z) xr yr' = absClamp ((halfHeight cfig - fromIntegral ybord) / z) yr -fixedSizePicClampArrow - :: Float -- ^ horizontal border - -> Float -- ^ vertical border - -> Picture - -> Point2 - -> Configuration - -> World - -> Picture -fixedSizePicClampArrow xbord ybord pic p cfig w = pictures - [ setLayer DebugLayer . translate x y . scale theScale theScale $ pic - , setLayer DebugLayer . color white . setDepth 20 $ arrowPic - ] +fixedSizePicClampArrow :: + -- | horizontal border + Float -> + -- | vertical border + Float -> + Picture -> + Point2 -> + Configuration -> + World -> + Picture +fixedSizePicClampArrow xbord ybord pic p cfig w = + pictures + [ setLayer DebugLayer . translate x y . scale theScale theScale $ pic + , setLayer DebugLayer . color white . setDepth 20 $ arrowPic + ] where winps = screenPolygon cfig w bords = screenPolygonBord xbord ybord cfig w @@ -74,8 +77,9 @@ fixedSizePicClampArrow xbord ybord pic p cfig w = pictures campos = _cameraCenter (_cWorld w) theScale = 1 / _cameraZoom (_cWorld w) -absClamp - :: Float -- ^ clamping value, assumed positive - -> Float - -> Float +absClamp :: + -- | clamping value, assumed positive + Float -> + Float -> + Float absClamp maxVal x = max (negate maxVal) $ min maxVal x diff --git a/src/Dodge/Placement/Instance/Analyser.hs b/src/Dodge/Placement/Instance/Analyser.hs index 8aa51b075..61d8e9e18 100644 --- a/src/Dodge/Placement/Instance/Analyser.hs +++ b/src/Dodge/Placement/Instance/Analyser.hs @@ -1,71 +1,45 @@ -module Dodge.Placement.Instance.Analyser - ( analyser - ) where ---import Dodge.LevelGen.Data ---import Dodge.PlacementSpot -import Dodge.Data ---import Dodge.Base.You -import Dodge.Default -import Dodge.Terminal ---import Dodge.Tree ---import Dodge.RoomLink ---import Dodge.Room.Door ---import Dodge.Room.Corridor ---import Dodge.Room.Link ---import Dodge.Room.Ngon ---import Dodge.Room.Procedural ---import Dodge.Room.Foreground ---import Dodge.Room.RoadBlock -import Dodge.Placement.Instance ---import Dodge.Placement.Shift ---import Dodge.SoundLogic ---import Dodge.Default.Room ---import Dodge.Item.Weapon.BulletGuns ---import Dodge.Item.Weapon.Utility ---import Dodge.LevelGen.Data ---import Geometry.Data ---import Geometry ---import Padding +module Dodge.Placement.Instance.Analyser ( + analyser, +) where + import Color ---import Shape ---import ShapePicture +import Dodge.Data.GenWorld +import Dodge.Default +import Dodge.Placement.Instance +import Dodge.Terminal import LensHelp ---import Dodge.RandomHelp ---import qualified Data.Set as S ---import Data.Maybe ---import Data.Tree ---import Control.Monad.State ---import System.Random - -analyser - :: ProximityRequirement - -> PlacementSpot - -> PlacementSpot - -> Placement +analyser :: + ProximityRequirement -> + PlacementSpot -> + PlacementSpot -> + Placement analyser proxreq pslight psmc = extTrigLitPos pslight $ \tp -> - Just $ plSpot .~ psmc $ putTerminal - (themachine & mcMounts . at ObTrigger .~ _plMID tp) - tparams -- (linksensortotrigger tp) + Just $ + plSpot .~ psmc $ + putTerminal + (themachine & mcMounts . at ObTrigger .~ _plMID tp) + tparams -- (linksensortotrigger tp) where tparams = basicTerminal & tmScrollCommands .:~ sensorCommand --- linksensortotrigger tp _ mc --- = triggers . ix (fromJust $ _plMID tp) .~ const (_sensToggle $ _mcSensor mc) - themachine = defaultMachine & mcColor .~ aquamarine --- & mcUpdate .~ mcProximitySensorUpdate - & mcDraw .~ MachineDrawTerminal - & mcHP .~ 100 - & mcSensor .~ defaultProximitySensor {_proxRequirement = proxreq} + -- linksensortotrigger tp _ mc + -- = triggers . ix (fromJust $ _plMID tp) .~ const (_sensToggle $ _mcSensor mc) + themachine = + defaultMachine & mcColor .~ aquamarine + -- & mcUpdate .~ mcProximitySensorUpdate + & mcDraw .~ MachineDrawTerminal + & mcHP .~ 100 + & mcSensor .~ defaultProximitySensor{_proxRequirement = proxreq} --this can probably be deleted --mcProximitySensorUpdate :: Machine -> World -> World ---mcProximitySensorUpdate mc w = case +--mcProximitySensorUpdate mc w = case -- (_proxStatus sens -- , _sensToggle sens --- , mcProxTest mc w +-- , mcProxTest mc w -- , dist (_crPos ycr) (_mcPos mc) < _proxDist sens) of -- (_,True,_,_) -> w --- (_,False,True,True) -> w +-- (_,False,True,True) -> w -- & machines . ix (_mcID mc) . mcSensor . sensToggle .~ True -- & playsound dedaS -- & machines . ix (_mcID mc) . mcSensor . proxStatus .~ IsClose diff --git a/src/Dodge/Placement/Instance/Block.hs b/src/Dodge/Placement/Instance/Block.hs index c93aec1a0..a41087a9c 100644 --- a/src/Dodge/Placement/Instance/Block.hs +++ b/src/Dodge/Placement/Instance/Block.hs @@ -1,26 +1,28 @@ module Dodge.Placement.Instance.Block where -import Dodge.Data -import Geometry -import Color -import LensHelp -import Dodge.Default.Wall -import Dodge.Default.Block ---decoratedBlock :: (Block -> Shape) -> Material -> Color -> Float -> [Point2] -> PSType +import Color +import Dodge.Data.GenWorld +import Dodge.Default.Block +import Dodge.Default.Wall +import Geometry +import LensHelp + decoratedBlock :: BlSh -> Material -> Color -> Float -> [Point2] -> PSType decoratedBlock decf mat col h ps = PutBlock bl wl $ reverse ps where - bl = defaultBlock - & blDraw .~ BlockDraws [BlockDrawColHeightPoss col h (reverse ps),BlockDrawBlSh decf] + bl = + defaultBlock + & blDraw .~ BlockDraws [BlockDrawColHeightPoss col h (reverse ps), BlockDrawBlSh decf] --(\bl' -> noPic (colorSH col (upperPrismPoly h $ reverse ps) <> decf bl')) - & blHeight .~ h - & blMaterial .~ mat - wl = defaultWall - & wlColor .~ col - & wlRotateTo .~ False - & wlOpacity .~ SeeAbove - & wlMaterial .~ mat - & wlHeight .~ h + & blHeight .~ h + & blMaterial .~ mat + wl = + defaultWall + & wlColor .~ col + & wlRotateTo .~ False + & wlOpacity .~ SeeAbove + & wlMaterial .~ mat + & wlHeight .~ h lowBlock :: Material -> Color -> Float -> [Point2] -> PSType lowBlock = decoratedBlock BlShMempty diff --git a/src/Dodge/Placement/Instance/Button.hs b/src/Dodge/Placement/Instance/Button.hs index 220bbd641..09fb2beef 100644 --- a/src/Dodge/Placement/Instance/Button.hs +++ b/src/Dodge/Placement/Instance/Button.hs @@ -1,85 +1,129 @@ module Dodge.Placement.Instance.Button where -import Dodge.Data -import Dodge.LightSource + import Color -import Geometry +import Control.Lens +import Data.Maybe +import Dodge.Data.GenWorld import Dodge.LevelGen.Data import Dodge.LevelGen.Switch +import Dodge.LightSource import Dodge.Placement.Instance.LightSource import Dodge.PlacementSpot - -import Data.Maybe -import Control.Lens +import Geometry triggerSwitchSPic :: ButtonDraw -> PlacementSpot -> Placement -triggerSwitchSPic sdraw ps = psPtCont ps (PutTrigger False) - $ \tp -> Just $ pContID ps (PutButton (makeSwitchSPic sdraw (SetTrigger True $ trigid tp) - (SetTrigger False $ trigid tp))) - (const Nothing) +triggerSwitchSPic sdraw ps = psPtCont ps (PutTrigger False) $ + \tp -> + Just $ + pContID + ps + ( PutButton + ( makeSwitchSPic + sdraw + (SetTrigger True $ trigid tp) + (SetTrigger False $ trigid tp) + ) + ) + (const Nothing) where trigid tp = fromJust $ _plMID tp triggerSwitchSPicLight :: ButtonDraw -> PlacementSpot -> Placement -triggerSwitchSPicLight sdraw ps = psPtCont ps (PutTrigger False) - $ \tp -> Just $ pContID atFstLnkOut (PutLS thels) - $ \lsid -> Just - $ pContID ps (PutButton (makeSwitchSPic sdraw (oneff lsid $ trigid tp) (offeff lsid $ trigid tp))) - (const Nothing) +triggerSwitchSPicLight sdraw ps = psPtCont ps (PutTrigger False) $ + \tp -> Just $ + pContID atFstLnkOut (PutLS thels) $ + \lsid -> + Just $ + pContID + ps + (PutButton (makeSwitchSPic sdraw (oneff lsid $ trigid tp) (offeff lsid $ trigid tp))) + (const Nothing) where thels = lsColPosRad (V3 0.5 0 0) (V3 0 0 78) 75 trigid tp = fromJust $ _plMID tp - oneff lsid tid = WorldEffects [SetLSCol (V3 0 0.5 0) lsid, SetTrigger True tid] + oneff lsid tid = WorldEffects [SetLSCol (V3 0 0.5 0) lsid, SetTrigger True tid] offeff lsid tid = WorldEffects [SetLSCol (V3 0.5 0 0) lsid, SetTrigger False tid] triggerSwitch :: Color -> PlacementSpot -> Placement -triggerSwitch col ps = psPtCont ps (PutTrigger False) - $ \tp -> Just $ pContID ps (PutButton (makeSwitch col col (SetTrigger True $ trigid tp) - (SetTrigger False $ trigid tp))) - (const Nothing) +triggerSwitch col ps = psPtCont ps (PutTrigger False) $ + \tp -> + Just $ + pContID + ps + ( PutButton + ( makeSwitch + col + col + (SetTrigger True $ trigid tp) + (SetTrigger False $ trigid tp) + ) + ) + (const Nothing) where trigid tp = fromJust $ _plMID tp -putLitButOnPos :: Color - -> PlacementSpot - -> (Placement -> Maybe Placement) -> Placement -putLitButOnPos col theps subpl - = plSpot .~ theps $ mntLSOn aShape (Just col) ls 0 (V3 0 (-40) 40) - $ \plmnt -> jps0' (PutButton (makeButton col (changeLight . fromJust $ _plMID plmnt)) {_btPos = V2 0 (-1), _btRot = pi}) - subpl <&> plSpot .~ _plSpot plmnt +putLitButOnPos :: + Color -> + PlacementSpot -> + (Placement -> Maybe Placement) -> + Placement +putLitButOnPos col theps subpl = + plSpot .~ theps $ + mntLSOn aShape (Just col) ls 0 (V3 0 (-40) 40) $ + \plmnt -> + jps0' + (PutButton (makeButton col (changeLight . fromJust $ _plMID plmnt)){_btPos = V2 0 (-1), _btRot = pi}) + subpl + <&> plSpot + .~ _plSpot plmnt where changeLight lsid = SetLSCol (V3 0 0.5 0) lsid ls = lsRadCol 75 (V3 0.5 0 0) -- creates a lit external trigger, passes the trigger placement forward extTrigLitPos :: PlacementSpot -> (Placement -> Maybe Placement) -> Placement -extTrigLitPos ps f = psPtCont ps (PutTrigger False) - $ \tp -> Just $ pContID (ps' tp) (PutLS thels) - $ \lsid -> Just $ pContID (ps' tp) (PutMod $ themod lsid tp) - $ const (f tp) +extTrigLitPos ps f = psPtCont ps (PutTrigger False) $ + \tp -> Just $ + pContID (ps' tp) (PutLS thels) $ + \lsid -> + Just $ + pContID (ps' tp) (PutMod $ themod lsid tp) $ + const (f tp) where ps' tp = _plSpot tp - themod lsid tp = ModIDID - {_mdID = 0 - ,_mdExternalID1 = lsid - ,_mdExternalID2 = fromJust $ _plMID tp - ,_mdUpdate = MdTrigIf (MdSetLSCol (V3 0 0.5 0)) (MdSetLSCol (V3 0.5 0 0)) - } + themod lsid tp = + ModIDID + { _mdID = 0 + , _mdExternalID1 = lsid + , _mdExternalID2 = fromJust $ _plMID tp + , _mdUpdate = MdTrigIf (MdSetLSCol (V3 0 0.5 0)) (MdSetLSCol (V3 0.5 0 0)) + } thels = lsColPosRad (V3 0.5 0 0) (V3 0 0 78) 75 putLitButOnPosExtTrig :: Color -> PlacementSpot -> Placement putLitButOnPosExtTrig col thePS = putLitButOnPosExtTrig' col thePS (const . const . const Nothing) -putLitButOnPosExtTrig' :: Color - -> PlacementSpot - -> (Placement -> Placement -> Placement -> Maybe Placement) - -> Placement -putLitButOnPosExtTrig' col thePS cnt - = psPtCont thePS (PutTrigger False) - $ \tp -> Just $ plSpot .~ _plSpot tp $ mntLSOn aShape (Just col) ls 0 (V3 0 (-40) 40) - $ \plmnt -> jps0' (PutButton - (makeButton col (WorldEffects [changeLight (fromJust $ _plMID plmnt), oneff (trigid tp)])) - {_btPos = V2 0 (-1), _btRot = pi}) - (cnt tp plmnt) <&> plSpot .~ _plSpot plmnt +putLitButOnPosExtTrig' :: + Color -> + PlacementSpot -> + (Placement -> Placement -> Placement -> Maybe Placement) -> + Placement +putLitButOnPosExtTrig' col thePS cnt = + psPtCont thePS (PutTrigger False) $ + \tp -> Just $ + plSpot .~ _plSpot tp $ + mntLSOn aShape (Just col) ls 0 (V3 0 (-40) 40) $ + \plmnt -> + jps0' + ( PutButton + (makeButton col (WorldEffects [changeLight (fromJust $ _plMID plmnt), oneff (trigid tp)])) + { _btPos = V2 0 (-1) + , _btRot = pi + } + ) + (cnt tp plmnt) + <&> plSpot + .~ _plSpot plmnt where trigid tp = fromJust $ _plMID tp oneff tid = SetTrigger True tid diff --git a/src/Dodge/Placement/Instance/Creature.hs b/src/Dodge/Placement/Instance/Creature.hs index 3e388f91d..9dc64882e 100644 --- a/src/Dodge/Placement/Instance/Creature.hs +++ b/src/Dodge/Placement/Instance/Creature.hs @@ -1,9 +1,9 @@ module Dodge.Placement.Instance.Creature where ---import Dodge.LevelGen.Data -import Dodge.Data -import RandomHelp + import Dodge.Creature.ArmourChase import Dodge.Creature.ChaseCrit +import Dodge.Data.GenWorld +import RandomHelp randC1 :: PSType randC1 = RandPS $ takeOne $ map PutCrit $ armourChaseCrit : replicate 50 chaseCrit diff --git a/src/Dodge/Placement/Instance/Door.hs b/src/Dodge/Placement/Instance/Door.hs index 4e34d0728..c441ba454 100644 --- a/src/Dodge/Placement/Instance/Door.hs +++ b/src/Dodge/Placement/Instance/Door.hs @@ -1,76 +1,112 @@ -module Dodge.Placement.Instance.Door - ( putDoubleDoor - , putAutoDoor - , putDoubleDoorThen - , switchDoor -- not used 9/3/22 - ) where -import Dodge.Data -import Dodge.Default.Door +module Dodge.Placement.Instance.Door ( + putDoubleDoor, + putAutoDoor, + putDoubleDoorThen, + switchDoor, -- not used 9/3/22 +) where + import Color -import Geometry +import Control.Lens +import Dodge.Data.CreatureEffect +import Dodge.Data.GenWorld +import Dodge.Default.Door import Dodge.LevelGen.Data import Dodge.LevelGen.Switch - -import Control.Lens +import Geometry putDoubleDoor :: EdgeObstacle -> Wall -> WdBl -> Point2 -> Point2 -> Float -> Placement -putDoubleDoor eo wl cond a b speed - = putDoubleDoorThen eo wl cond 1 a b speed (const $ const Nothing) +putDoubleDoor eo wl cond a b speed = + putDoubleDoorThen eo wl cond 1 a b speed (const $ const Nothing) -putDoubleDoorThen ::EdgeObstacle -> Wall -> WdBl - -> Float -> Point2 -> Point2 -> Float - -> (Placement -> Placement -> Maybe Placement) - -> Placement -putDoubleDoorThen eo wl cond soff a b speed cont - = doorBetween eo wl cond soff a half speed - $ \pl1 -> Just $ doorBetween eo wl cond soff b half speed - $ \pl2 -> cont pl1 pl2 +putDoubleDoorThen :: + EdgeObstacle -> + Wall -> + WdBl -> + Float -> + Point2 -> + Point2 -> + Float -> + (Placement -> Placement -> Maybe Placement) -> + Placement +putDoubleDoorThen eo wl cond soff a b speed cont = + doorBetween eo wl cond soff a half speed $ + \pl1 -> Just $ + doorBetween eo wl cond soff b half speed $ + \pl2 -> cont pl1 pl2 where half = 0.5 *.* (a +.+ b) -doorBetween :: EdgeObstacle -> Wall -> WdBl -> Float -> Point2 -> Point2 -> Float -> - (Placement -> Maybe Placement) -> Placement +doorBetween :: + EdgeObstacle -> + Wall -> + WdBl -> + Float -> + Point2 -> + Point2 -> + Float -> + (Placement -> Maybe Placement) -> + Placement doorBetween eo wl cond soff pa pb speed g = case divideLine 40 pa pb of - [x,y] -> ptCont (PutSlideDr adoor wl eo soff x y) g - (x:y:zs) -> divideDoorPane Nothing wl cond (soff - dist y pb) speed (zip (x:y:zs) (y:zs)) g + [x, y] -> ptCont (PutSlideDr adoor wl eo soff x y) g + (x : y : zs) -> divideDoorPane Nothing wl cond (soff - dist y pb) speed (zip (x : y : zs) (y : zs)) g _ -> undefined where - adoor = defaultDoor - & drTrigger .~ cond - & drSpeed .~ speed + adoor = + defaultDoor + & drTrigger .~ cond + & drSpeed .~ speed -divideDoorPane :: Maybe Int -> Wall -> WdBl -> Float -> Float - -> [(Point2,Point2)] -> (Placement -> Maybe Placement) -> Placement +divideDoorPane :: + Maybe Int -> + Wall -> + WdBl -> + Float -> + Float -> + [(Point2, Point2)] -> + (Placement -> Maybe Placement) -> + Placement divideDoorPane mid wl cond soff speed ppairs g = case ppairs of [p] -> ptCont (adoor p) g - (p:ps) -> ptCont (adoor p) $ \pl -> Just $ divideDoorPane (_plMID pl) wl cond soff speed ps g + (p : ps) -> ptCont (adoor p) $ \pl -> Just $ divideDoorPane (_plMID pl) wl cond soff speed ps g _ -> undefined where - adoor (x,y) = PutSlideDr thedoor wl DoorObstacle soff x y - thedoor = defaultDoor & drSpeed .~ speed & drTrigger .~ cond - & drPushedBy .~ maybe PushesItself PushedBy mid + adoor (x, y) = PutSlideDr thedoor wl DoorObstacle soff x y + thedoor = + defaultDoor & drSpeed .~ speed & drTrigger .~ cond + & drPushedBy .~ maybe PushesItself PushedBy mid putAutoDoor :: Point2 -> Point2 -> Placement -putAutoDoor a b = PlacementUsingPos (addZ 0 a) - $ \az -> PlacementUsingPos (addZ 0 b) - $ \bz -> putDoubleDoor AutoDoorObstacle defaultAutoWall - (cond az bz) a b 3 +putAutoDoor a b = PlacementUsingPos (addZ 0 a) $ + \az -> PlacementUsingPos (addZ 0 b) $ + \bz -> + putDoubleDoor + AutoDoorObstacle + defaultAutoWall + (cond az bz) + a + b + 3 where --cond az bz = any (crNearSeg 40 (stripZ az) (stripZ bz)) . IM.filter isAnimate . _creatures cond az bz = WdBlCrFilterNearPoint 40 (0.5 *.* (stripZ az +.+ stripZ bz)) CrIsAnimate - -- any (crNearPoint 40 (0.5 *.* (stripZ az +.+ stripZ bz))) - -- . IM.filter isAnimate . _creatures + +-- any (crNearPoint 40 (0.5 *.* (stripZ az +.+ stripZ bz))) +-- . IM.filter isAnimate . _creatures switchDoor :: Point2 -> Float -> Point2 -> Point2 -> Color -> Placement -switchDoor btpos btrot dra drb col = pContID (PS btpos btrot) +switchDoor btpos btrot dra drb col = pContID + (PS btpos btrot) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect) - $ \btid -> jsps0J (doorbetween btid dra drc) - $ sps0 (doorbetween btid drb drc) + $ \btid -> + jsps0J (doorbetween btid dra drc) $ + sps0 (doorbetween btid drb drc) where doorbetween btid a b = PutSlideDr thedoor (switchWallCol col) DoorObstacle 1 a b where - thedoor = defaultDoor - & drTrigger .~ WdBlBtOn btid - & drSpeed .~ 2 + thedoor = + defaultDoor + & drTrigger .~ WdBlBtOn btid + & drSpeed .~ 2 drc = 0.5 *.* (dra +.+ drb) - --cond btid w' = _btState (_buttons w' IM.! btid) == BtOn + +--cond btid w' = _btState (_buttons w' IM.! btid) == BtOn diff --git a/src/Dodge/Placement/Instance/LightSource.hs b/src/Dodge/Placement/Instance/LightSource.hs index 54491c794..9db54cb69 100644 --- a/src/Dodge/Placement/Instance/LightSource.hs +++ b/src/Dodge/Placement/Instance/LightSource.hs @@ -1,58 +1,70 @@ module Dodge.Placement.Instance.LightSource where -import Dodge.Data -import Dodge.LightSource + +import Color +import Control.Lens +import Data.Maybe +import Dodge.Creature.Inanimate +import Dodge.Data.GenWorld +import Dodge.Default import Dodge.LevelGen.Data +import Dodge.LightSource import Dodge.Room.Foreground import Geometry ---import Geometry.Vector3D -import Dodge.Creature.Inanimate -import Shape.Data -import Dodge.Default import RandomHelp -import Color import Shape import ShapePicture -import Control.Lens -import Data.Maybe +propLSThen :: + PropUpdate -> + PrWdLsLs -> --(Prop -> World -> LightSource -> LightSource) + LightSource -> + Prop -> + -- | continuation, access to ls and prop placements + (Placement -> Placement -> Maybe Placement) -> + Placement +propLSThen propf lsf ls prop cont = pt0 (PutLS ls) $ + \lspl -> + Just $ + pt0 (PutProp $ prop & prUpdate .~ PropUpdates [propf, PropUpdateLS (fromJust $ _plMID lspl) lsf]) $ + cont lspl -propLSThen :: PropUpdate - -> PrWdLsLs --(Prop -> World -> LightSource -> LightSource) - -> LightSource - -> Prop - -> (Placement -> Placement -> Maybe Placement) -- ^ continuation, access to ls and prop placements - -> Placement -propLSThen propf lsf ls prop cont = pt0 (PutLS ls) - $ \lspl -> Just $ pt0 (PutProp $ prop & prUpdate .~ PropUpdates [propf,PropUpdateLS (fromJust $ _plMID lspl) lsf]) - $ cont lspl +moveLSThen :: + WdP2f -> --(World -> (Point2,Float)) -moveLSThen :: WdP2f --(World -> (Point2,Float)) - -> Point3 -- ^ light source offset - -> Shape - -> (Placement -> Placement -> Maybe Placement) - -> Placement + -- | light source offset + Point3 -> + Shape -> + (Placement -> Placement -> Maybe Placement) -> + Placement moveLSThen posf off sh = propLSThen (PropUpdatePosition posf) (PrWdLsSetPosition posf off) thels theprop where --lsupdate _ w = lsParam . lsPos .~ addZ 0 (fst (posf w)) +.+.+ rotate3z (snd (posf w)) off thels = defaultLS - theprop = ShapeProp - { _prPos = 0 - , _prID = 0 - , _prRot = 0 - , _prUpdate = PropUpdateId - --, _prDraw = PropDrawSPic $ noPic $ uncurryV translateSHf (_prPos pr) $ rotateSH (_pjRot pr) sh - , _prDraw = PropDrawFlatTranslate $ PropDrawSPic $ noPic sh - , _prToggle = True - } - + theprop = + ShapeProp + { _prPos = 0 + , _prID = 0 + , _prRot = 0 + , _prUpdate = PropUpdateId + , --, _prDraw = PropDrawSPic $ noPic $ uncurryV translateSHf (_prPos pr) $ rotateSH (_pjRot pr) sh + _prDraw = PropDrawFlatTranslate $ PropDrawSPic $ noPic sh + , _prToggle = True + } + -- | mount a light source on a shape -mntLSOn - :: (Point2 -> Point3 -> Shape) -- ^ function describing the mount shape - -> Maybe Color -- ^ describing a possible color override for the shape - -> LightSource -> Point2 -> Point3 -> (Placement -> Maybe Placement) -> Placement -mntLSOn shapeF mcol ls wallp lsp@(V3 lx ly _) - = ps0jPushPS (putShape . setCol $ shapeF wallp lsp) - . pt0 (PutLS $ ls & lsParam . lsPos .~ lsp') +mntLSOn :: + -- | function describing the mount shape + (Point2 -> Point3 -> Shape) -> + -- | describing a possible color override for the shape + Maybe Color -> + LightSource -> + Point2 -> + Point3 -> + (Placement -> Maybe Placement) -> + Placement +mntLSOn shapeF mcol ls wallp lsp@(V3 lx ly _) = + ps0jPushPS (putShape . setCol $ shapeF wallp lsp) + . pt0 (PutLS $ ls & lsParam . lsPos .~ lsp') where lsp' = lsp -.-.- V3 x y 1 -- hack! perturb the light position @@ -63,17 +75,19 @@ iShape :: Point2 -> Point3 -> Shape iShape wp (V3 x y z) = thinHighBar z wp (V2 x y) lShape :: Point2 -> Point3 -> Shape -lShape wp (V3 x y z) = thinHighBar z wallposUp turnpos - <> thinHighBar z turnpos (V2 x y) +lShape wp (V3 x y z) = + thinHighBar z wallposUp turnpos + <> thinHighBar z turnpos (V2 x y) where n = vNormal (wp -.- V2 x y) wallposUp = wp +.+ n turnpos = V2 x y +.+ n jShape :: Point2 -> Point3 -> Shape -jShape wallpos (V3 x y z) = thinHighBar z wallposUp turn1 - <> thinHighBar z turn1 turn2 - <> thinHighBar z turn2 endpos +jShape wallpos (V3 x y z) = + thinHighBar z wallposUp turn1 + <> thinHighBar z turn1 turn2 + <> thinHighBar z turn2 endpos where n = vNormal (wallpos -.- V2 x y) wallposUp = wallpos +.+ n @@ -84,8 +98,8 @@ jShape wallpos (V3 x y z) = thinHighBar z wallposUp turn1 liShape :: Point2 -> Point3 -> Shape liShape wallpos (V3 x y z) = - thinHighBar z wallposUp turnpos - <> thinHighBar z turnpos (V2 x y) + thinHighBar z wallposUp turnpos + <> thinHighBar z turnpos (V2 x y) where n = vNormal (V2 x y -.- wallpos) wallposUp = wallpos +.+ n @@ -93,14 +107,14 @@ liShape wallpos (V3 x y z) = aShape :: Point2 -> Point3 -> Shape aShape wallpos (V3 x y z) = - girder (z+2) 20 10 pout wallpos + girder (z + 2) 20 10 pout wallpos where pout = V2 x y -.- 2 *.* squashNormalizeV (V2 x y -.- wallpos) vShape :: Point2 -> Point3 -> Shape vShape wallpos (V3 x y z) = thinHighBar z wallposUp lxy - <> thinHighBar z wallposDown lxy + <> thinHighBar z wallposDown lxy where lxy = V2 x y n = vNormal (wallpos -.- lxy) @@ -114,52 +128,65 @@ mntLSCol :: (Point2 -> Point3 -> Shape) -> Color -> Point2 -> Point3 -> Placemen mntLSCol shp col wallp lampp = mntLSOn shp (Just col) defaultLS wallp lampp (const Nothing) mntLSLampCol :: (Point2 -> Point3 -> Shape) -> Color -> Point2 -> Point3 -> Placement -mntLSLampCol shp (V4 x y z _) wallp lampp = mntLSOn shp Nothing (defaultLS & lsParam . lsCol .~ col) - wallp lampp (const Nothing) +mntLSLampCol shp (V4 x y z _) wallp lampp = + mntLSOn + shp + Nothing + (defaultLS & lsParam . lsCol .~ col) + wallp + lampp + (const Nothing) where col = V3 x y z -mntLSCond :: (Point2 -> Point3 -> Shape) --- -> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)) - -> PlacementSpot - -> Placement -mntLSCond shp ps = -- updatePSToLevel 1 (const $ PSLnk shift (const id) Nothing) $ +mntLSCond :: + (Point2 -> Point3 -> Shape) -> + -- -> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)) + PlacementSpot -> + Placement +mntLSCond shp ps = + -- updatePSToLevel 1 (const $ PSLnk shift (const id) Nothing) $ mntLS shp 0 (V3 0 (-20) 95) - & plSpot .~ ps - -- note that this perhaps pushes the vshape light out too far + & plSpot .~ ps + +-- note that this perhaps pushes the vshape light out too far mntLight :: Point2 -> Point2 -> Placement mntLight a b = RandomPlacement $ do - shp <- takeOne [vShape,iShape,lShape,jShape,liShape] + shp <- takeOne [vShape, iShape, lShape, jShape, liShape] return $ mntLS shp a (addZ 90 b) mntLightLnkCond :: PlacementSpot -> Placement mntLightLnkCond ps = RandomPlacement $ do - shp <- takeOne [vShape,lShape,jShape,liShape] + shp <- takeOne [vShape, lShape, jShape, liShape] return $ mntLSCond (fmap (fmap $ colorSH black) shp) ps spanLSLightI :: LightSource -> Float -> Point2 -> Point2 -> Placement -spanLSLightI ls h a b = ps0j (PutLS $ ls & lsParam . lsPos .~ V3 x y h) - $ sps0 $ putShape $ thinHighBar h a b +spanLSLightI ls h a b = + ps0j (PutLS $ ls & lsParam . lsPos .~ V3 x y h) $ + sps0 $ putShape $ thinHighBar h a b where V2 x y = 0.5 *.* (a +.+ b) spanLS :: LightSource -> Point2 -> Point2 -> Placement -spanLS ls a b = Placement 10 (PS (V2 x y) 0) (PutLS ls) Nothing - $ const $ const $ Just $ sps0 $ putShape $ thinHighBar h a b +spanLS ls a b = + Placement 10 (PS (V2 x y) 0) (PutLS ls) Nothing $ + const $ const $ Just $ sps0 $ putShape $ thinHighBar h a b where V3 _ _ h = _lsPos (_lsParam ls) + 5 V2 x y = 0.5 *.* (a +.+ b) spanColLightI :: Point3 -> Float -> Point2 -> Point2 -> Placement -spanColLightI col h a b = ps0j (PutLS $ lsColPos col (V3 x y (h-5))) - $ sps0 $ putShape $ thinHighBar h a b +spanColLightI col h a b = + ps0j (PutLS $ lsColPos col (V3 x y (h -5))) $ + sps0 $ putShape $ thinHighBar h a b where V2 x y = 0.5 *.* (a +.+ b) spanColLightBlackI :: Point3 -> Float -> Point2 -> Point2 -> Placement -spanColLightBlackI col h a b = ps0j (PutLS $ lsColPos col (V3 x y (h-5))) - $ sps0 $ putShape $ colorSH black $ thinHighBar h a b +spanColLightBlackI col h a b = + ps0j (PutLS $ lsColPos col (V3 x y (h -5))) $ + sps0 $ putShape $ colorSH black $ thinHighBar h a b where V2 x y = 0.5 *.* (a +.+ b) diff --git a/src/Dodge/Placement/Instance/LightSource/Cover.hs b/src/Dodge/Placement/Instance/LightSource/Cover.hs index 31a97d40a..c3079bbb2 100644 --- a/src/Dodge/Placement/Instance/LightSource/Cover.hs +++ b/src/Dodge/Placement/Instance/LightSource/Cover.hs @@ -1,35 +1,43 @@ module Dodge.Placement.Instance.LightSource.Cover where -import Dodge.Data -import Geometry.Data + +import Dodge.Data.Prop +import Dodge.Data.WorldEffect import Dodge.Default.Prop +import Geometry.Data + lampCover :: Float -> Prop -lampCover h = ShapeProp - { _prPos = V2 0 0 - , _prID = 0 - , _prRot = 0 - , _prUpdate = PropRotate 0.15 - , _prDraw = PropLampCover h - , _prToggle = True - } +lampCover h = + ShapeProp + { _prPos = V2 0 0 + , _prID = 0 + , _prRot = 0 + , _prUpdate = PropRotate 0.15 + , _prDraw = PropLampCover h + , _prToggle = True + } + lampCoverWhen :: WdBl -> Point2 -> Float -> Prop -lampCoverWhen cond pos h = defaultProp - { _prPos = pos - , _prUpdate = PropSetToggleAnd cond (PropRotate 0.15) - , _prDraw = PropLampCover h - , _prToggle = True - } +lampCoverWhen cond pos h = + defaultProp + { _prPos = pos + , _prUpdate = PropSetToggleAnd cond (PropRotate 0.15) + , _prDraw = PropLampCover h + , _prToggle = True + } doubleLampCover :: Float -> Prop -doubleLampCover h = defaultProp - { _prPos = V2 0 0 - , _prUpdate = PropRotate 0.15 - , _prDraw = PropDoubleLampCover h - } +doubleLampCover h = + defaultProp + { _prPos = V2 0 0 + , _prUpdate = PropRotate 0.15 + , _prDraw = PropDoubleLampCover h + } -- on the current (27/9/21) version of shadow stencilling, this glitches -- slightly when the shadow rotates towards the screen verticalLampCover :: Float -> Prop -verticalLampCover h = defaultProp - { _prUpdate = PropRotate 0.15 - , _prDraw = PropVerticalLampCover h - } +verticalLampCover h = + defaultProp + { _prUpdate = PropRotate 0.15 + , _prDraw = PropVerticalLampCover h + } diff --git a/src/Dodge/Placement/Instance/LightSource/Flicker.hs b/src/Dodge/Placement/Instance/LightSource/Flicker.hs index 6835b178d..bb5bd9b1b 100644 --- a/src/Dodge/Placement/Instance/LightSource/Flicker.hs +++ b/src/Dodge/Placement/Instance/LightSource/Flicker.hs @@ -1,32 +1,39 @@ module Dodge.Placement.Instance.LightSource.Flicker where -import Dodge.LevelGen.Data -import Dodge.Data -import Data.Maybe + import Control.Lens +import Data.Maybe +import Dodge.Data.GenWorld +import Dodge.LevelGen.Data import System.Random + -- Supposes the orginal placement is a light source, adds a flicker flickerMod :: Placement -> Maybe Placement -flickerMod pl = Just $ sps0 $ PutMod $ ModIDTimerPoint3Bool - { _mdID = 0 - , _mdExternalID = fromJust $ _plMID pl - , _mdUpdate = MdFlickerUpdate - , _mdTimer = 10 - , _mdPoint3 = 0.8 - , _mdBool = True - } +flickerMod pl = + Just $ + sps0 $ + PutMod $ + ModIDTimerPoint3Bool + { _mdID = 0 + , _mdExternalID = fromJust $ _plMID pl + , _mdUpdate = MdFlickerUpdate + , _mdTimer = 10 + , _mdPoint3 = 0.8 + , _mdBool = True + } flickerUpdate :: Modification -> World -> World -flickerUpdate md w +flickerUpdate md w | _mdTimer md > 0 = w & cWorld . modifications . ix mdid . mdTimer -~ 1 - | otherwise = w & cWorld . lightSources . ix lsid . lsParam . lsCol .~ mdcol - & cWorld . modifications . ix mdid - %~ ( (mdTimer .~ newtime) . (mdPoint3 .~ lscol) . (mdBool %~ not) ) + | otherwise = + w & cWorld . lightSources . ix lsid . lsParam . lsCol .~ mdcol + & cWorld . modifications . ix mdid + %~ ((mdTimer .~ newtime) . (mdPoint3 .~ lscol) . (mdBool %~ not)) where mdcol = _mdPoint3 md lscol = w ^?! cWorld . lightSources . ix lsid . lsParam . lsCol -- _lsCol $ _lsParam $ _lightSources w IM.! lsid lsid = _mdExternalID md mdid = _mdID md - timerange - | _mdBool md = (2,10) - | otherwise = (2,30) - (newtime,_) = randomR timerange $ _randGen w + timerange + | _mdBool md = (2, 10) + | otherwise = (2, 30) + (newtime, _) = randomR timerange $ _randGen w diff --git a/src/Dodge/Placement/Instance/Sensor.hs b/src/Dodge/Placement/Instance/Sensor.hs index 04dfc8a57..c06aedf52 100644 --- a/src/Dodge/Placement/Instance/Sensor.hs +++ b/src/Dodge/Placement/Instance/Sensor.hs @@ -1,48 +1,55 @@ -module Dodge.Placement.Instance.Sensor - ( lightSensor - , damageSensor - , sensorSPic -- this should be moved - ) where +module Dodge.Placement.Instance.Sensor ( + lightSensor, + damageSensor, + sensorSPic, -- this should be moved +) where + import Color -import Dodge.LightSource -import Dodge.Data -import Dodge.LevelGen.Data +import Control.Lens +import qualified Data.Map.Strict as M +import Dodge.Data.GenWorld import Dodge.Default +import Dodge.LevelGen.Data +import Dodge.LightSource import Dodge.Placement.TopDecoration import Geometry -import ShapePicture import Shape +import ShapePicture -import qualified Data.Map.Strict as M -import Control.Lens +damageSensor :: + DamageType -> + Float -> + Maybe Int -> + PlacementSpot -> + Placement +damageSensor dt wdth mtrid ps = pContID ps (PutLS $ lsPosCol (V3 0 0 30) 0.1) $ + \lsid -> Just $ + spNoID ps $ + PutUsingGenParams $ + \gw -> + (,) gw $ + PutMachine + (reverse $ square wdth) + ( defaultMachine + & mcColor .~ yellow + & mcMounts . at ObTrigger .~ mtrid + & mcMounts . at ObLightSource ?~ lsid + & mcDraw .~ MachineDrawDamageSensor wdth (_sensorCoding (_genParams (_cWorld gw)) M.! dt) + & mcSensor .~ DamageSensor False 0 dt + ) + defaultSensorWall -damageSensor - :: DamageType - -> Float - -> Maybe Int - -> PlacementSpot - -> Placement -damageSensor dt wdth mtrid ps = pContID ps (PutLS $ lsPosCol (V3 0 0 30) 0.1) - $ \lsid -> Just $ spNoID ps $ PutUsingGenParams - $ \gw -> (,) gw $ PutMachine (reverse $ square wdth) - (defaultMachine - & mcColor .~ yellow - & mcMounts . at ObTrigger .~ mtrid - & mcMounts . at ObLightSource ?~ lsid - & mcDraw .~ MachineDrawDamageSensor wdth (_sensorCoding (_genParams (_cWorld gw)) M.! dt) - & mcSensor .~ DamageSensor False 0 dt - ) - defaultSensorWall - -lightSensor :: Float - -> Maybe Int - -> PlacementSpot - -> Placement +lightSensor :: + Float -> + Maybe Int -> + PlacementSpot -> + Placement lightSensor = damageSensor LASERING -sensorSPic :: Float -> (PaletteColor,DecorationShape) -> Machine -> SPic -sensorSPic wdth (pc,ds) mc = noPic - $ colorSH (_mcColor mc) (upperPrismPoly 25 (square wdth)) - <> decorationToShape ds wdth wdth 25 col col +sensorSPic :: Float -> (PaletteColor, DecorationShape) -> Machine -> SPic +sensorSPic wdth (pc, ds) mc = + noPic $ + colorSH (_mcColor mc) (upperPrismPoly 25 (square wdth)) + <> decorationToShape ds wdth wdth 25 col col where col = paletteToColor pc diff --git a/src/Dodge/Placement/Instance/Tank.hs b/src/Dodge/Placement/Instance/Tank.hs index 714dfbd0e..dd7fcc15a 100644 --- a/src/Dodge/Placement/Instance/Tank.hs +++ b/src/Dodge/Placement/Instance/Tank.hs @@ -1,47 +1,52 @@ -module Dodge.Placement.Instance.Tank - ( tankSquareDec - , roundTank - , roundTankCross - ) where -import Dodge.Data +module Dodge.Placement.Instance.Tank ( + tankSquareDec, + roundTank, + roundTankCross, +) where + +import Color +import Dodge.Data.GenWorld import Dodge.LevelGen.Data -import Dodge.Room.Foreground import Dodge.Placement.Instance.Block +import Dodge.Room.Foreground import Geometry import Shape -import Color ---import LensHelp ---import Quaternion -tankSquareDec :: (Float -> Float -> Float -> Color -> Color -> Shape) - -> Color -> Color -> Placement +tankSquareDec :: + (Float -> Float -> Float -> Color -> Color -> Shape) -> + Color -> + Color -> + Placement tankSquareDec dec = tankShape (square 20) (dec 20 20 31) tankShape :: [Point2] -> (Color -> Color -> Shape) -> Color -> Color -> Placement tankShape baseshape facade col col' = sps0 $ decoratedBlock (BlShConst $ facade col col') Metal col 31 baseshape + -- = sps0 $ PutBlock bl wl $ reverse baseshape -- where -- bl = defaultBlock -- & blDraw .~ const (noPic $ colorSH col (upperPrismPoly 31 $ reverse baseshape) <> facade col col') -- & blDeath .~ const id --- wl = defaultWall --- & wlColor .~ col --- & wlRotateTo .~ False +-- wl = defaultWall +-- & wlColor .~ col +-- & wlRotateTo .~ False -- & wlOpacity .~ SeeAbove -- & wlMaterial .~ Metal -- = ps0jPushPS -- (PutShape $ colorSH col (upperPrismPoly 31 baseshape) <> facade col col') --- $ sps0 $ PutWall baseshape defaultWall +-- $ sps0 $ PutWall baseshape defaultWall -- {_wlUnshadowed = False, _wlColor = col, _wlRotateTo = False, _wlOpacity = SeeAbove} roundTank :: Color -> Color -> Placement -roundTank = tankShape (polyCirc 4 20) - $ \_ c' -> colorSH c' $ foldMap toprail (take 8 [0,pi/4..]) +roundTank = tankShape (polyCirc 4 20) $ + \_ c' -> colorSH c' $ foldMap toprail (take 8 [0, pi / 4 ..]) where - toprail a = rotateSH a $ thinHighBar 31 (V2 0 20) (rotateV (pi/4) $ V2 0 20) + toprail a = rotateSH a $ thinHighBar 31 (V2 0 20) (rotateV (pi / 4) $ V2 0 20) roundTankCross :: Color -> Color -> Placement -roundTankCross = tankShape (polyCirc 4 20) - $ \_ c -> colorSH c $ thinHighBar 31 (V2 20 0) (V2 (-20) 0) - <> thinHighBar 31 (V2 0 20) (V2 0 (-20)) +roundTankCross = tankShape (polyCirc 4 20) $ + \_ c -> + colorSH c $ + thinHighBar 31 (V2 20 0) (V2 (-20) 0) + <> thinHighBar 31 (V2 0 20) (V2 0 (-20)) diff --git a/src/Dodge/Placement/Instance/Terminal.hs b/src/Dodge/Placement/Instance/Terminal.hs index ef25d725a..ea7a80f1c 100644 --- a/src/Dodge/Placement/Instance/Terminal.hs +++ b/src/Dodge/Placement/Instance/Terminal.hs @@ -1,62 +1,67 @@ ---{-# LANGUAGE TupleSections #-} -module Dodge.Placement.Instance.Terminal - ( putMessageTerminal - , putTerminal --- , simpleTermMessage - , terminalColor --- , accessTerminal - ) where -import Dodge.Data -import Dodge.LevelGen.Data -import Dodge.Default -import Dodge.SoundLogic +module Dodge.Placement.Instance.Terminal ( + putMessageTerminal, + putTerminal, + terminalColor, +) where + import Color +import Data.Maybe +import Dodge.Data.GenWorld +import Dodge.Default +import Dodge.LevelGen.Data +import Dodge.SoundLogic import Geometry import LensHelp -import Data.Maybe - putTerminal :: Machine -> Terminal -> Placement -putTerminal mc tm - = ps0PushPS (PutTerminal tm) - $ \tmpl -> Just $ ps0PushPS (PutButton termButton) - $ \btpl -> Just $ pt0 - (PutMachine (reverse $ square 10) - (mc & mcMounts . at ObButton ?~ fromJust (_plMID btpl) - & mcCloseSound ?~ fridgeHumS) - defaultSensorWall - ) - $ \mcpl -> Just $ sps0 $ PutWorldUpdate $ const (setids tmpl btpl mcpl) +putTerminal mc tm = + ps0PushPS (PutTerminal tm) $ + \tmpl -> Just $ + ps0PushPS (PutButton termButton) $ + \btpl -> Just $ + pt0 + ( PutMachine + (reverse $ square 10) + ( mc & mcMounts . at ObButton ?~ fromJust (_plMID btpl) + & mcCloseSound ?~ fridgeHumS + ) + defaultSensorWall + ) + $ \mcpl -> Just $ sps0 $ PutWorldUpdate $ const (setids tmpl btpl mcpl) where - setids tmpl btpl mcpl w = w - & cWorld . terminals . ix tmid . tmButtonID .~ btid - & cWorld . terminals . ix tmid . tmMachineID .~ mcid - & cWorld . machines . ix mcid . mcMounts . at ObTerminal ?~ tmid - & cWorld . buttons . ix btid . btTermMID ?~ tmid + setids tmpl btpl mcpl w = + w + & cWorld . terminals . ix tmid . tmButtonID .~ btid + & cWorld . terminals . ix tmid . tmMachineID .~ mcid + & cWorld . machines . ix mcid . mcMounts . at ObTerminal ?~ tmid + & cWorld . buttons . ix btid . btTermMID ?~ tmid where tmid = fromJust (_plMID tmpl) btid = fromJust (_plMID btpl) mcid = fromJust (_plMID mcpl) putMessageTerminal :: Color -> Terminal -> Placement -putMessageTerminal col = putTerminal $ defaultMachine - & mcColor .~ col - & mcDraw .~ MachineDrawTerminal --terminalSPic - & mcHP .~ 100 +putMessageTerminal col = + putTerminal $ + defaultMachine + & mcColor .~ col + & mcDraw .~ MachineDrawTerminal --terminalSPic + & mcHP .~ 100 termButton :: Button -termButton = Button - { _btPict = DrawNoButton - , _btPos = 0 - , _btRot = 0 - , _btEvent = ButtonAccessTerminal - , _btID = 0 - , _btText = "TERMINAL" - , _btState = BtOff - , _btTermMID = Nothing - , _btName = "" - , _btColor = dark magenta - } +termButton = + Button + { _btPict = DrawNoButton + , _btPos = 0 + , _btRot = 0 + , _btEvent = ButtonAccessTerminal + , _btID = 0 + , _btText = "TERMINAL" + , _btState = BtOff + , _btTermMID = Nothing + , _btName = "" + , _btColor = dark magenta + } terminalColor :: Color terminalColor = dark magenta diff --git a/src/Dodge/Placement/Instance/Turret.hs b/src/Dodge/Placement/Instance/Turret.hs index 3225a672e..b5f234987 100644 --- a/src/Dodge/Placement/Instance/Turret.hs +++ b/src/Dodge/Placement/Instance/Turret.hs @@ -1,87 +1,99 @@ module Dodge.Placement.Instance.Turret where -import Color -import Dodge.Data -import Dodge.LevelGen.Data -import Dodge.Default -import Dodge.Movement.Turn -import Dodge.FloorItem -import Dodge.Wall.Delete -import Dodge.WorldEvent.Explosion -import Dodge.Item.Weapon.BatteryGuns -import Geometry -import ShapePicture -import Shape -import Dodge.Base -import LensHelp -import qualified IntMapHelp as IM +import Dodge.Item.Held.BatteryGuns +import Color import Data.List import Data.Maybe +import Dodge.Base +import Dodge.Data.GenWorld +import Dodge.Default +import Dodge.FloorItem +import Dodge.LevelGen.Data +import Dodge.Movement.Turn +import Dodge.Wall.Delete +import Dodge.WorldEvent.Explosion +import Geometry +import qualified IntMapHelp as IM +import LensHelp +import Shape +import ShapePicture putLasTurret :: Float -> Placement -putLasTurret rotSpeed = sps0 $ PutMachine (reverse $ square wdth) - (defaultMachine - & mcColor .~ blue - & mcDraw .~ MachineDrawTurret - & mcType .~ (lasTurret & tuTurnSpeed .~ rotSpeed) - & mcHP .~ 50000 - ) - defaultMachineWall +putLasTurret rotSpeed = + sps0 $ + PutMachine + (reverse $ square wdth) + ( defaultMachine + & mcColor .~ blue + & mcDraw .~ MachineDrawTurret + & mcType .~ (lasTurret & tuTurnSpeed .~ rotSpeed) + & mcHP .~ 50000 + ) + defaultMachineWall + lasTurret :: MachineType -lasTurret = Turret - { _tuWeapon = lasGun --- { _tuWeapon = autoRifle - , _tuTurnSpeed = 0.1 - , _tuFireTime = 0 - , _tuMCrID = Nothing - } +lasTurret = + Turret + { _tuWeapon = lasGun + , -- { _tuWeapon = autoRifle + _tuTurnSpeed = 0.1 + , _tuFireTime = 0 + , _tuMCrID = Nothing + } -- this needs a major cleanup updateTurret :: Float -> Machine -> World -> World -updateTurret rotSpeed mc w - | _mcHP mc < 1 = w & cWorld . machines %~ IM.delete mcid - & deleteWallIDs (_mcWallIDs mc) - & makeExplosionAt mcpos - & copyItemToFloor mcpos lasGun - & deleteHomonculus - | otherwise = w - & initHomonculus - & dodamage - & maybeFire - & elecDamBranch +updateTurret rotSpeed mc w + | _mcHP mc < 1 = + w & cWorld . machines %~ IM.delete mcid + & deleteWallIDs (_mcWallIDs mc) + & makeExplosionAt mcpos + & copyItemToFloor mcpos lasGun + & deleteHomonculus + | otherwise = + w + & initHomonculus + & dodamage + & maybeFire + & elecDamBranch where deleteHomonculus = case _tuMCrID (_mcType mc) of Nothing -> id Just cid -> cWorld . creatures . at cid .~ Nothing initHomonculus w' = case w' ^? cWorld . machines . ix mcid . mcType . tuMCrID . _Just of - Nothing -> w' & cWorld . machines . ix mcid . mcType . tuMCrID ?~ cid - & cWorld . creatures . at cid ?~ thecreature + Nothing -> + w' & cWorld . machines . ix mcid . mcType . tuMCrID ?~ cid + & cWorld . creatures . at cid ?~ thecreature where cid = IM.newKey (_creatures (_cWorld w')) - thecreature = defaultCreature - & crID .~ cid - & crInv . at 0 ?~ (_tuWeapon (_mcType mc) & itUse . useAim . aimHandlePos -~ 10 - & itUse . heldConsumption . laLoaded .~ 1 - ) - & crPos .~ mcpos - & crOldPos .~ mcpos - & crRad .~ 1 - & crDir .~ mcdir - & crStance . posture .~ Aiming - & crMaterial .~ Crystal - Just cid -> w' - & cWorld . creatures . ix cid . crPos .~ mcpos - & cWorld . creatures . ix cid . crDir .~ mcdir - dodamage = cWorld . machines . ix mcid %~ - ( (mcDamage .~ [Damage ELECTRICAL (min 2500 $ max 0 (elecDam - 10)) 0 0 0 NoDamageEffect]) - . (mcHP -~ dam) - ) + thecreature = + defaultCreature + & crID .~ cid + & crInv . at 0 + ?~ ( _tuWeapon (_mcType mc) & itUse . heldAim . aimHandlePos -~ 10 + & itUse . heldConsumption . laLoaded .~ 1 + ) + & crPos .~ mcpos + & crOldPos .~ mcpos + & crRad .~ 1 + & crDir .~ mcdir + & crStance . posture .~ Aiming + & crMaterial .~ Crystal + Just cid -> + w' + & cWorld . creatures . ix cid . crPos .~ mcpos + & cWorld . creatures . ix cid . crDir .~ mcdir + dodamage = + cWorld . machines . ix mcid + %~ ( (mcDamage .~ [Damage ELECTRICAL (min 2500 $ max 0 (elecDam - 10)) 0 0 0 NoDamageEffect]) + . (mcHP -~ dam) + ) elecDamBranch | elecDam < 10 = updateFiringStatus . doTurn | otherwise = id maybeFire - | _tuFireTime (_mcType mc) > 0 - = fromMaybe id $ do + | _tuFireTime (_mcType mc) > 0 = + fromMaybe id $ do cid <- _tuMCrID (_mcType mc) return $ cWorld . creatures . ix cid . crActionPlan . apImpulse .~ [UseItem] | otherwise = id @@ -93,19 +105,20 @@ updateTurret rotSpeed mc w (elecDams, dams) = partition isElectrical $ _mcDamage mc dam = sum $ map _dmAmount dams elecDam = sum $ map _dmAmount elecDams - doTurn + doTurn | seesYou = cWorld . machines . ix mcid . mcDir %~ turnTo rotSpeed mcpos ypos | otherwise = id closeFireAngle = seesYou -- && angleVV (ypos -.- mcpos) (unitVectorAtAngle mcdir) < 1 - updateFiringStatus + updateFiringStatus | closeFireAngle = cWorld . machines . ix mcid . mcType . tuFireTime .~ 20 - | otherwise = cWorld . machines . ix mcid . mcType . tuFireTime %~ (max 0 . subtract 1) - + | otherwise = cWorld . machines . ix mcid . mcType . tuFireTime %~ (max 0 . subtract 1) drawTurret :: Machine -> SPic -drawTurret mc = (rotateSH (-_mcDir mc) . colorSH (_mcColor mc) $ upperPrismPoly 20 (square wdth) +drawTurret mc = + ( rotateSH (- _mcDir mc) . colorSH (_mcColor mc) $ upperPrismPoly 20 (square wdth) , mempty -- setLayer 5 $ scale 0.5 0.5 $ text $ show $ _mcDir mc ) ) + -- <> translateSPz 20 (itSPic it) -- where -- it = _tuWeapon $ _mcType mc diff --git a/src/Dodge/Placement/Instance/Wall.hs b/src/Dodge/Placement/Instance/Wall.hs index c810ca019..bac3e6353 100644 --- a/src/Dodge/Placement/Instance/Wall.hs +++ b/src/Dodge/Placement/Instance/Wall.hs @@ -1,38 +1,40 @@ -module Dodge.Placement.Instance.Wall - where -import Dodge.Data -import Dodge.Placement.Instance.Block -import Dodge.Default.Block ---import Dodge.Block.Debris -import Dodge.LevelGen.Data -import Dodge.Default.Wall -import Geometry -import Color +module Dodge.Placement.Instance.Wall where -import Data.List +import Color import Control.Lens +import Data.List +import Dodge.Data.GenWorld +import Dodge.Default.Block +import Dodge.Default.Wall +import Dodge.LevelGen.Data +import Dodge.Placement.Instance.Block +import Geometry heightWallPS :: PlacementSpot -> Float -> [Point2] -> Placement heightWallPS spot h ps = spNoID spot $ lowBlock Stone (_wlColor defaultWall) h ps invisibleWall :: [Point2] -> Placement -invisibleWall ps = sps0 $ PutWall ps $ defaultWall - { _wlOpacity = SeeAbove - , _wlUnshadowed = False - , _wlHeight = 0 - , _wlTouchThrough = True - } +invisibleWall ps = + sps0 $ + PutWall ps $ + defaultWall + { _wlOpacity = SeeAbove + , _wlUnshadowed = False + , _wlHeight = 0 + , _wlTouchThrough = True + } midWall :: [Point2] -> Placement midWall = heightWallPS (PS 0 0) 50 singleBlock :: Point2 -> [Placement] -singleBlock a = - [sPS a 0 - $ PutBlock defaultBlock baseBlockPane - $ reverse - $ square 10 +singleBlock a = + [ sPS a 0 $ + PutBlock defaultBlock baseBlockPane $ + reverse $ + square 10 ] + {- Places a line of blocks between two points. -} @@ -45,15 +47,17 @@ Width 8, also extends out from each point by 8. -} windowLine :: Point2 -> Point2 -> Placement windowLine a b = sps0 $ PutLineBlock defaultWindow 8 a b + {- Places an unbreakable window between two points. Width 7, also extends out from each point by 7. -} crystalLine :: Point2 -> Point2 -> Placement crystalLine a b = sps0 $ PutLineBlock defaultCrystalWall 7 a b + --crystalLine a b = sps0 $ PutWall ps defaultCrystalWall -- where --- ps = +-- ps = -- [ a +.+ left +.+ up -- , (a +.+ left) -.- up -- , (b -.- left) -.- up @@ -67,63 +71,74 @@ Depth 15, does not extend wider than points. wallLine :: Point2 -> Point2 -> Placement wallLine a b = sps0 $ PutWall ps defaultWall where - ps = [ a +.+ up - , a -.- up - , b -.- up - , b +.+ up + ps = + [ a +.+ up + , a -.- up + , b -.- up + , b +.+ up ] - left = 15 *.* normalizeV (a-.-b) - up = vNormal left + left = 15 *.* normalizeV (a -.- b) + up = vNormal left windowLineType :: Point2 -> Point2 -> PSType windowLineType = PutLineBlock defaultWindow 8 baseBlockPane :: Wall -baseBlockPane = defaultWall - { _wlLine = (V2 0 0,V2 50 0) - , _wlID = 0 - , _wlColor = greyN 0.5 - , _wlSeen = False - , _wlOpacity = Opaque - , _wlUnshadowed = True - , _wlFireThrough = True - , _wlPenetrable = True - } +baseBlockPane = + defaultWall + { _wlLine = (V2 0 0, V2 50 0) + , _wlID = 0 + , _wlColor = greyN 0.5 + , _wlSeen = False + , _wlOpacity = Opaque + , _wlUnshadowed = True + , _wlFireThrough = True + , _wlPenetrable = True + } + -- TODO find home for this {- Replaces instances of a given 'PutID' with 'PSType's drawn from a list. -} -replacePutID - :: Int -- ^ The id of 'PutID' to be replaced - -> [PSType] -- ^ List of replacements - -> Room - -> Room +replacePutID :: + -- | The id of 'PutID' to be replaced + Int -> + -- | List of replacements + [PSType] -> + Room -> + Room replacePutID i psts r = r & rmPmnts %~ flip (subZipWith (isPutID i) (\ps pt -> ps & plType .~ pt)) psts -{- Partition a list by a predicate, apply a zip to those elements -that satisfy the predicate, concatenate + +{- Partition a list by a predicate, apply a zip to those elements +that satisfy the predicate, concatenate the new zipped list and the other (unchanged) half. -} -subZipWith - :: (a -> Bool) -- ^ Filter: elements to apply zip to - -> (a -> b -> a) -- ^ Combining function - -> [a] -- ^ List to be partitioned - -> [b] -- ^ Modifying list - -> [a] +subZipWith :: + -- | Filter: elements to apply zip to + (a -> Bool) -> + -- | Combining function + (a -> b -> a) -> + -- | List to be partitioned + [a] -> + -- | Modifying list + [b] -> + [a] subZipWith f g xs ys = - let (zs,ws) = partition f xs - in zipWith g zs ys ++ ws + let (zs, ws) = partition f xs + in zipWith g zs ys ++ ws isPutID :: Int -> Placement -> Bool isPutID i ps = Just i == ps ^? plType . putID putBlockRect' :: Float -> Float -> Placement -putBlockRect' w h = ps0jPushPS (aline tl tr) - $ ps0jPushPS (aline tr br) - $ ps0jPushPS (aline br bl) - $ sps0 (aline bl tl) +putBlockRect' w h = + ps0jPushPS (aline tl tr) $ + ps0jPushPS (aline tr br) $ + ps0jPushPS (aline br bl) $ + sps0 (aline bl tl) where - tl = V2 (-w) h + tl = V2 (- w) h tr = V2 w h - br = V2 w (-h) - bl = V2 (-w) (-h) + br = V2 w (- h) + bl = V2 (- w) (- h) aline = PutLineBlock baseBlockPane 9 putBlockRect :: Float -> Float -> Float -> Float -> [Placement] @@ -133,19 +148,22 @@ putBlockRect a x b y = , blockLine (V2 x y) (V2 x b) , blockLine (V2 x b) (V2 a b) ] + putBlockV :: Float -> Float -> Float -> Float -> [Placement] -putBlockV a x b y = +putBlockV a x b y = [ blockLine (V2 a b) (V2 a y) , blockLine (V2 x b) (V2 a b) ] + putBlockC :: Float -> Float -> Float -> Float -> [Placement] -putBlockC a x b y = +putBlockC a x b y = [ blockLine (V2 a b) (V2 a y) , blockLine (V2 x b) (V2 a b) , blockLine (V2 a y) (V2 x y) ] + putBlockN :: Float -> Float -> Float -> Float -> [Placement] -putBlockN a x b y = +putBlockN a x b y = [ blockLine (V2 a b) (V2 a y) , blockLine (V2 x b) (V2 a b) , blockLine (V2 x y) (V2 x b) diff --git a/src/Dodge/Placement/PlaceSpot.hs b/src/Dodge/Placement/PlaceSpot.hs index 7cff41400..bfe33322b 100644 --- a/src/Dodge/Placement/PlaceSpot.hs +++ b/src/Dodge/Placement/PlaceSpot.hs @@ -1,39 +1,37 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RankNTypes #-} --- | deals with placement of objects within the world --- after they have had their coordinates set by the layout -module Dodge.Placement.PlaceSpot - ( placeSpot - ) where -import Dodge.Placement.Shift -import Dodge.Data ---import Dodge.Path +{- | deals with placement of objects within the world + after they have had their coordinates set by the layout +-} +module Dodge.Placement.PlaceSpot ( + placeSpot, +) where + +import Color +import Control.Lens +import Control.Monad.State +import Data.Bifunctor +import Data.Foldable +import qualified Data.IntSet as IS +import Data.Maybe +import Dodge.Base.NewID +import Dodge.Data.GenWorld +import Dodge.Path import Dodge.Placement.PlaceSpot.Block import Dodge.Placement.PlaceSpot.TriggerDoor -import Dodge.Path +import Dodge.Placement.Shift import Dodge.ShiftPoint -import Dodge.Base.NewID import Geometry import qualified IntMapHelp as IM -import Color import Picture - -import Data.Foldable -import Data.Maybe import System.Random -import Control.Monad.State -import Control.Lens -import qualified Data.IntSet as IS -import Data.Bifunctor -- when placing a placement, we update the world and the room and assign an id -- to the placement -placeSpot :: (GenWorld,Room) -> Placement -> ( (GenWorld,Room), [Placement] ) -placeSpot (w,rm) plmnt = case plmnt of +placeSpot :: (GenWorld, Room) -> Placement -> ((GenWorld, Room), [Placement]) +placeSpot (w, rm) plmnt = case plmnt of Placement{_plSpot = PSRoomRand i f} -> placeSpotRoomRand rm i f plmnt w Placement{_plSpot = PSPos extract eff fallback} -> placeSpotUsingLink w rm plmnt extract eff fallback Placement{} -> placePlainPSSpot w rm plmnt shift - PlacementUsingPos p subpl -> placeSpot (w,rm) (subpl (shiftPoint3By shift p)) + PlacementUsingPos p subpl -> placeSpot (w, rm) (subpl (shiftPoint3By shift p)) RandomPlacement rplmnt -> placeRandomPlacement rplmnt w rm PickOnePlacement i pl -> ((placePickOne i pl rm w, rm), []) where @@ -42,162 +40,180 @@ placeSpot (w,rm) plmnt = case plmnt of placePickOne :: Int -> Placement -> Room -> GenWorld -> GenWorld placePickOne i pl rm w = w & genPlacements %~ IM.insertWith (++) i [(pl, fromJust (_rmMID rm))] -placeRandomPlacement :: State StdGen Placement -> GenWorld -> Room -> ((GenWorld,Room),[Placement]) -placeRandomPlacement rplmnt w rm = placeSpot (w & gwWorld . randGen .~ g,rm) plmnt' +placeRandomPlacement :: State StdGen Placement -> GenWorld -> Room -> ((GenWorld, Room), [Placement]) +placeRandomPlacement rplmnt w rm = placeSpot (w & gwWorld . randGen .~ g, rm) plmnt' where (plmnt', g) = runState rplmnt (_randGen (_gwWorld w)) -placePlainPSSpot :: GenWorld -> Room -> Placement -> DPoint2 -> ((GenWorld,Room),[Placement]) -placePlainPSSpot w rm plmnt shift = - let (i,w') = placeSpotID (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w +placePlainPSSpot :: GenWorld -> Room -> Placement -> DPoint2 -> ((GenWorld, Room), [Placement]) +placePlainPSSpot w rm plmnt shift = + let (i, w') = placeSpotID (shiftPSBy shift (_plSpot plmnt)) (_plType plmnt) w newplmnt = plmnt & plMID ?~ i - in maybe ((w',rm),[newplmnt]) (recrPlace newplmnt w') (_plIDCont plmnt (_gwWorld w') newplmnt) + in maybe ((w', rm), [newplmnt]) (recrPlace newplmnt w') (_plIDCont plmnt (_gwWorld w') newplmnt) where - recrPlace newplmnt w' pl = let (wr,newplmnts) = placeSpot (w',rm) pl - in (wr,newplmnt:newplmnts) + recrPlace newplmnt w' pl = + let (wr, newplmnts) = placeSpot (w', rm) pl + in (wr, newplmnt : newplmnts) -- this should be tidied up -placeSpotUsingLink :: GenWorld - -> Room - -> Placement - -> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)) - -> (RoomPos -> Room -> Room) - -> Maybe Placement - -> ((GenWorld, Room), [Placement]) +placeSpotUsingLink :: + GenWorld -> + Room -> + Placement -> + (RoomPos -> Room -> Maybe (PlacementSpot, RoomPos)) -> + (RoomPos -> Room -> Room) -> + Maybe Placement -> + ((GenWorld, Room), [Placement]) placeSpotUsingLink w rm plmnt extract eff fallback = case searchedPoss (_rmPos rm) of - Just (ps,rmposs) -> placeSpot (w, eff (head rmposs) $ rm & rmPos .~ rmposs) (plmnt & plSpot .~ ps) + Just (ps, rmposs) -> placeSpot (w, eff (head rmposs) $ rm & rmPos .~ rmposs) (plmnt & plSpot .~ ps) Nothing -> case fallback of - Nothing -> ((w,rm),[plmnt]) - Just plmnt' -> placeSpot (w,rm) plmnt' + Nothing -> ((w, rm), [plmnt]) + Just plmnt' -> placeSpot (w, rm) plmnt' where searchedPoss [] = Nothing - searchedPoss (pos:poss) = case extract pos rm of - Nothing -> second (pos:) <$> searchedPoss poss - Just (ps,rmpos) -> Just ( ps,rmpos:poss) + searchedPoss (pos : poss) = case extract pos rm of + Nothing -> second (pos :) <$> searchedPoss poss + Just (ps, rmpos) -> Just (ps, rmpos : poss) -placeSpotRoomRand :: Room -> Int -> (DPoint2 -> PlacementSpot) - -> Placement -> GenWorld -> ((GenWorld,Room),[Placement]) +placeSpotRoomRand :: + Room -> + Int -> + (DPoint2 -> PlacementSpot) -> + Placement -> + GenWorld -> + ((GenWorld, Room), [Placement]) placeSpotRoomRand rm i f plmnt w = - let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen (_gwWorld w) - in placeSpot (w & gwWorld . randGen .~ g,rm) (plmnt & plSpot .~ f ps) + let (ps, g) = runState (_rmRandPSs rm !! i) $_randGen (_gwWorld w) + in placeSpot (w & gwWorld . randGen .~ g, rm) (plmnt & plSpot .~ f ps) placeSpotID :: PlacementSpot -> PSType -> GenWorld -> (Int, GenWorld) -placeSpotID ps pt gw = let (i,w) = placeSpotID' ps pt (_gwWorld gw) - in (i,gw & gwWorld .~ w) +placeSpotID ps pt gw = + let (i, w) = placeSpotID' ps pt (_gwWorld gw) + in (i, gw & gwWorld .~ w) -- the Int here is some id that is assigned when the placement is placed placeSpotID' :: PlacementSpot -> PSType -> World -> (Int, World) placeSpotID' ps pt w = case pt of - PutTrigger cnd -> plNewID (cWorld . triggers) cnd w - PutMod mdi -> plNewUpID (cWorld . modifications) mdID mdi w - PutProp prp -> plNewUpID (cWorld . props) prID (mvProp p rot prp) w - PutButton bt -> plNewUpID (cWorld . buttons) btID (mvButton p rot bt) w - PutTerminal tm -> plNewUpID (cWorld . terminals) tmID tm w - PutFlIt itm -> plNewUpID (cWorld . floorItems) flItID (createFlIt p rot itm) w - PutCrit cr -> plNewUpID (cWorld . creatures) crID (mvCr p rot cr) w - PutForeground fs -> plNewUpID (cWorld . foregroundShapes) fsID (mvFS p rot fs) w - PutDecoration pic -> plNewID (cWorld . decorations) (shiftDec p rot pic) w - PutMachine pps mc wl -> plMachine (map doShift pps) mc wl p rot w - PutLS ls -> plNewUpID (cWorld . lightSources) lsID (mvLS p' rot ls) w - PutPPlate pp -> plNewUpID (cWorld . pressPlates) ppID (mvPP p rot pp) w - RandPS rgn -> evaluateRandPS rgn ps w - PutDoor col eo f pss -> plDoor col eo f (map (bimap doShift doShift) pss) w - PutCoord cp -> plNewID (cWorld . coordinates) (doShift cp) w - PutSlideDr wl dr eo off a b - -> plSlideDoor wl dr eo off (doShift a) (doShift b) w - PutBlock bl wl ps' -> plBlock (map doShift ps') (bl & blPos %~ doShift & blDir .~ rot) - wl w - PutLineBlock wl wdth a b -> plLineBlock wl wdth (doShift a) (doShift b) w - PutWall qs wl -> (0,placeWallPoly (map doShift qs) wl w) - PutNothing -> (0,w) - PutID i -> (i, w) - PutWorldUpdate f -> (0, w & f ps) - PutUsingGenParams f -> let (w',pt') = f w - in placeSpotID' ps pt' w' - where + PutTrigger cnd -> plNewID (cWorld . triggers) cnd w + PutMod mdi -> plNewUpID (cWorld . modifications) mdID mdi w + PutProp prp -> plNewUpID (cWorld . props) prID (mvProp p rot prp) w + PutButton bt -> plNewUpID (cWorld . buttons) btID (mvButton p rot bt) w + PutTerminal tm -> plNewUpID (cWorld . terminals) tmID tm w + PutFlIt itm -> plNewUpID (cWorld . floorItems) flItID (createFlIt p rot itm) w + PutCrit cr -> plNewUpID (cWorld . creatures) crID (mvCr p rot cr) w + PutForeground fs -> plNewUpID (cWorld . foregroundShapes) fsID (mvFS p rot fs) w + PutDecoration pic -> plNewID (cWorld . decorations) (shiftDec p rot pic) w + PutMachine pps mc wl -> plMachine (map doShift pps) mc wl p rot w + PutLS ls -> plNewUpID (cWorld . lightSources) lsID (mvLS p' rot ls) w + PutPPlate pp -> plNewUpID (cWorld . pressPlates) ppID (mvPP p rot pp) w + RandPS rgn -> evaluateRandPS rgn ps w + PutDoor col eo f pss -> plDoor col eo f (map (bimap doShift doShift) pss) w + PutCoord cp -> plNewID (cWorld . coordinates) (doShift cp) w + PutSlideDr wl dr eo off a b -> + plSlideDoor wl dr eo off (doShift a) (doShift b) w + PutBlock bl wl ps' -> + plBlock + (map doShift ps') + (bl & blPos %~ doShift & blDir .~ rot) + wl + w + PutLineBlock wl wdth a b -> plLineBlock wl wdth (doShift a) (doShift b) w + PutWall qs wl -> (0, placeWallPoly (map doShift qs) wl w) + PutNothing -> (0, w) + PutID i -> (i, w) + PutWorldUpdate f -> (0, w & f ps) + PutUsingGenParams f -> + let (w', pt') = f w + in placeSpotID' ps pt' w' + where p@(V2 px py) = _psPos ps p' = V3 px py 0 rot = _psRot ps - doShift = shiftPointBy (p,rot) + doShift = shiftPointBy (p, rot) shiftDec :: Point2 -> Float -> Picture -> Picture shiftDec p r pic = uncurryV translate p $ rotate r pic -evaluateRandPS :: State StdGen PSType -> PlacementSpot -> World -> (Int,World) +evaluateRandPS :: State StdGen PSType -> PlacementSpot -> World -> (Int, World) evaluateRandPS rgen ps w = placeSpotID' ps evaluatedType (set randGen g w) - where + where (evaluatedType, g) = runState rgen (_randGen w) --placeWallPoly :: [Point2] -> Wall -> World -> World ---placeWallPoly ps wl = -- rmCrossPaths . +--placeWallPoly ps wl = -- rmCrossPaths . -- over walls (placeWalls ps wl) ---- where ---- rmCrossPaths w = foldr (uncurry obstructPathsCrossing) w $ loopPairs ps --placeWalls :: [Point2] -> Wall -> IM.IntMap Wall -> IM.IntMap Wall --placeWalls qs wl wls = foldl' (addPane wl) wls pairs --- where +-- where -- (p:ps) = orderPolygon qs -- pairs = zip (ps ++ [p]) (p:ps) placeWallPoly :: [Point2] -> Wall -> World -> World placeWallPoly qs wl w = foldl' (addPane wl) w pairs - where - (p:ps) = orderPolygon qs - pairs = zip (ps ++ [p]) (p:ps) + where + (p : ps) = orderPolygon qs + pairs = zip (ps ++ [p]) (p : ps) -addPane :: Wall -> World -> (Point2,Point2) -> World +addPane :: Wall -> World -> (Point2, Point2) -> World --addPane wl w l = w & walls %~ IM.insert wlid (wl { _wlLine = l, _wlID = wlid }) -addPane wl w l = w & plNew (cWorld . walls) wlID (wl & wlLine .~ l) - & fst . uncurry (obstructPathsCrossing WallObstacle) l +addPane wl w l = + w & plNew (cWorld . walls) wlID (wl & wlLine .~ l) + & fst . uncurry (obstructPathsCrossing WallObstacle) l + -- where -- wlid = IM.newKey (_walls w) mvProp :: Point2 -> Float -> Prop -> Prop -mvProp p a = (prRot +~ a) . (prPos %~ ( (p +.+) . rotateV a )) +mvProp p a = (prRot +~ a) . (prPos %~ ((p +.+) . rotateV a)) mvButton :: Point2 -> Float -> Button -> Button -mvButton p a = (btRot +~ a) . (btPos %~ ( (p +.+) . rotateV a )) +mvButton p a = (btRot +~ a) . (btPos %~ ((p +.+) . rotateV a)) {- Creates a floor item at a given point.-} createFlIt :: Point2 -> Float -> Item -> FloorItem -createFlIt p rot itm = FlIt { _flItPos = p , _flItRot = rot , _flItID = 0 , _flIt = itm } +createFlIt p rot itm = FlIt{_flItPos = p, _flItRot = rot, _flItID = 0, _flIt = itm} mvPP :: Point2 -> Float -> PressPlate -> PressPlate -mvPP p rot pp = pp {_ppPos = p,_ppRot = rot} +mvPP p rot pp = pp{_ppPos = p, _ppRot = rot} mvCr :: Point2 -> Float -> Creature -> Creature -mvCr p rot cr = cr {_crPos = p,_crOldPos = p,_crDir = rot} +mvCr p rot cr = cr{_crPos = p, _crOldPos = p, _crDir = rot} mvFS :: Point2 -> Float -> ForegroundShape -> ForegroundShape -mvFS p a = (fsDir +~ a) . (fsPos %~ ( (p +.+) . rotateV a )) +mvFS p a = (fsDir +~ a) . (fsPos %~ ((p +.+) . rotateV a)) -plMachine :: [Point2] -> Machine -> Wall -> Point2 -> Float -> World -> (Int,World) -plMachine wallpoly mc wl p rot gw = (mcid - , gw & cWorld . machines %~ addMc - & cWorld . walls %~ placeMachineWalls wl col wallpoly mcid wlid +plMachine :: [Point2] -> Machine -> Wall -> Point2 -> Float -> World -> (Int, World) +plMachine wallpoly mc wl p rot gw = + ( mcid + , gw & cWorld . machines %~ addMc + & cWorld . walls %~ placeMachineWalls wl col wallpoly mcid wlid ) - where + where col = _mcColor mc w' = gw mcid = IM.newKey $ _machines (_cWorld w') wlid = IM.newKey $ _walls (_cWorld w') wlids = IS.fromList [wlid .. wlid + length wallpoly - 1] --addMc = IM.insert mcid (mc {_mcPos = centroid wallpoly,_mcDir = rot,_mcID = mcid, _mcWallIDs = wlids}) - addMc = IM.insert mcid (mc {_mcPos = p,_mcDir = rot,_mcID = mcid, _mcWallIDs = wlids}) + addMc = IM.insert mcid (mc{_mcPos = p, _mcDir = rot, _mcID = mcid, _mcWallIDs = wlids}) -- TODO correctly remove/shift pathfinding lines (removePathsCrossing) placeMachineWalls :: Wall -> Color -> [Point2] -> Int -> Int -> IM.IntMap Wall -> IM.IntMap Wall -placeMachineWalls wl col poly mcid wlid = flip (foldr f) $ zip [wlid..] $ loopPairs poly +placeMachineWalls wl col poly mcid wlid = flip (foldr f) $ zip [wlid ..] $ loopPairs poly where - f (wid,l) = IM.insert wid baseWall{_wlID = wid, _wlLine = l} - baseWall = wl - & wlColor .~ col - & wlStructure . wsMachine .~ mcid - & wlTouchThrough .~ True + f (wid, l) = IM.insert wid baseWall{_wlID = wid, _wlLine = l} + baseWall = + wl + & wlColor .~ col + & wlStructure . wsMachine .~ mcid + & wlTouchThrough .~ True mvLS :: Point3 -> Float -> LightSource -> LightSource -mvLS (V3 x y z) rot ls = ls & lsParam . lsPos .~ V3 x y z +.+.+ startPos - & lsDir .~ rot +mvLS (V3 x y z) rot ls = + ls & lsParam . lsPos .~ V3 x y z +.+.+ startPos + & lsDir .~ rot where startPos = onXY (rotateV rot) $ _lsPos (_lsParam ls) diff --git a/src/Dodge/Placement/PlaceSpot/Block.hs b/src/Dodge/Placement/PlaceSpot/Block.hs index 5bded3b5c..f1281cda4 100644 --- a/src/Dodge/Placement/PlaceSpot/Block.hs +++ b/src/Dodge/Placement/PlaceSpot/Block.hs @@ -1,105 +1,123 @@ -{- | Creation, update and destruction of destructible walls. -} -module Dodge.Placement.PlaceSpot.Block - ( plBlock - , plLineBlock - ) - where -import Dodge.Data -import Dodge.Path +-- | Creation, update and destruction of destructible walls. +module Dodge.Placement.PlaceSpot.Block ( + plBlock, + plLineBlock, +) where + +import Control.Lens +import qualified Data.IntSet as IS +import Data.List import Dodge.Base ---import Dodge.Zone +import Dodge.Data.World +import Dodge.Path import Geometry import qualified IntMapHelp as IM -import Control.Lens -import Data.List -import qualified Data.IntSet as IS - -plBlock - :: [Point2] -- ^ Block polygon - -> Block - -> Wall -- ^ Base Pane - -> World - -> (Int,World) +plBlock :: + -- | Block polygon + [Point2] -> + Block -> + -- | Base Pane + Wall -> + World -> + (Int, World) plBlock [] _ _ _ = error "Trying to add a block with incomplete polygon" -plBlock (p:ps) bl wl w = (,) blid $ w - & cWorld . blocks . at blid ?~ bl - { _blID = blid - , _blWallIDs = IS.fromList is - , _blShadows = [] - , _blFootprint = p:ps - } - & insertWalls blid wls - where +plBlock (p : ps) bl wl w = + (,) blid $ + w + & cWorld . blocks . at blid + ?~ bl + { _blID = blid + , _blWallIDs = IS.fromList is + , _blShadows = [] + , _blFootprint = p : ps + } + & insertWalls blid wls + where blid = IM.newKey $ _blocks (_cWorld w) - lns = zip (p:ps) (ps ++ [p]) + lns = zip (p : ps) (ps ++ [p]) i = IM.newKey $ _walls (_cWorld w) - is = [i.. i + length lns-1] - wls = zipWith - (\j ln -> wl & wlLine .~ ln & wlID .~ j & wlStructure .~ BlockPart blid) - is - lns - -{- | Splits a line into many four cornered blocks. -} -plLineBlock - :: Wall -- ^ Base pane - -> Float - -> Point2 -- ^ Start point (symmetric) - -> Point2 -- ^ End point (symmetric) - -> World - -> (Int, World) -plLineBlock basePane blwidth a b gw = ( 0 --- , foldr insertWall (insertBlocks gw) listWalls - , insertBlocks gw + is = [i .. i + length lns -1] + wls = + zipWith + (\j ln -> wl & wlLine .~ ln & wlID .~ j & wlStructure .~ BlockPart blid) + is + lns + +-- | Splits a line into many four cornered blocks. +plLineBlock :: + -- | Base pane + Wall -> + Float -> + -- | Start point (symmetric) + Point2 -> + -- | End point (symmetric) + Point2 -> + World -> + (Int, World) +plLineBlock basePane blwidth a b gw = + ( 0 + , -- , foldr insertWall (insertBlocks gw) listWalls + insertBlocks gw ) - where + where depth = blwidth psOnLine = divideLineOddNumPoints blwidth a b halfBlockWidth = dist a b / fromIntegral (length psOnLine - 1) blockCenPs = snd $ evenOddSplit psOnLine numBlocks = length blockCenPs - is = [0.. numBlocks - 1] + is = [0 .. numBlocks - 1] cornerPoints = reverse $ rectWH halfBlockWidth depth -- goes clockwise around the block - cornersAt p = fmap ( (p +.+) . rotateV (argV (b -.- a)) ) cornerPoints + cornersAt p = fmap ((p +.+) . rotateV (argV (b -.- a))) cornerPoints linesAt p = loopPairs $ cornersAt p wlid = IM.newKey $ _walls (_cWorld gw) blid = IM.newKey $ _blocks (_cWorld gw) - insertBlock (i,p) = + insertBlock (i, p) = insertWalls (i + blid) (makeWallAt p i) - . over (cWorld . blocks) (IM.insert (i+blid) Block - { _blID = i + blid, _blWallIDs = IS.fromList $ ksAtI i - , _blHP = 1000, _blShadows = shadowsAt i - , _blDir = 0 -- THIS IS NOT SENSIBLE. TODO rethink block positioning - , _blFootprint = cornersAt p -- TODO check winding (clockwise, anticlockwise) - , _blObstructs = [] - , _blMaterial = _wlMaterial basePane - , _blHeight = 100 - , _blPos = p, _blDraw = BlockDrawMempty } - ) + . over + (cWorld . blocks) + ( IM.insert + (i + blid) + Block + { _blID = i + blid + , _blWallIDs = IS.fromList $ ksAtI i + , _blHP = 1000 + , _blShadows = shadowsAt i + , _blDir = 0 -- THIS IS NOT SENSIBLE. TODO rethink block positioning + , _blFootprint = cornersAt p -- TODO check winding (clockwise, anticlockwise) + , _blObstructs = [] + , _blMaterial = _wlMaterial basePane + , _blHeight = 100 + , _blPos = p + , _blDraw = BlockDrawMempty + } + ) insertBlocks = flip (foldr insertBlock) $ zip is blockCenPs - ksAtI i = map ( + (wlid + i*4) ) [0,1,2,3] - visibilityAt i - | i == 0 = [False,True,True ,True] - | i == numBlocks - 1 = [True ,True,False,True] - | otherwise = [False,True,False,True] + ksAtI i = map (+ (wlid + i * 4)) [0, 1, 2, 3] + visibilityAt i + | i == 0 = [False, True, True, True] + | i == numBlocks - 1 = [True, True, False, True] + | otherwise = [False, True, False, True] shadowsAt i - | i == 0 = ksAtI 1 + | i == 0 = ksAtI 1 | i == numBlocks - 1 = ksAtI $ numBlocks - 2 - | otherwise = ksAtI (i-1) ++ ksAtI (i+1) + | otherwise = ksAtI (i -1) ++ ksAtI (i + 1) makeWallAt p i = zipWith3 (makePane i) (visibilityAt i) (ksAtI i) (linesAt p) - makePane i visStatus k ps = basePane - {_wlID = k - ,_wlStructure = BlockPart $ i + blid - ,_wlLine = ps - ,_wlUnshadowed = visStatus - } + makePane i visStatus k ps = + basePane + { _wlID = k + , _wlStructure = BlockPart $ i + blid + , _wlLine = ps + , _wlUnshadowed = visStatus + } -- | Must be done after inserting the block insertWalls :: Int -> [Wall] -> World -> World insertWalls blid wls w = w' & cWorld . blocks . ix blid . blObstructs .~ concat paths where - (w',paths) = mapAccumR (flip insertWall) w wls + (w', paths) = mapAccumR (flip insertWall) w wls -insertWall :: Wall -> World -> (World,[(Int,Int,PathEdge)]) -insertWall wl = uncurry (obstructPathsCrossing BlockObstacle) (_wlLine wl) - . (cWorld . walls . at (_wlID wl) ?~ wl) +insertWall :: Wall -> World -> (World, [(Int, Int, PathEdge)]) +insertWall wl = + uncurry (obstructPathsCrossing BlockObstacle) (_wlLine wl) + . (cWorld . walls . at (_wlID wl) ?~ wl) diff --git a/src/Dodge/Placement/PlaceSpot/Block.hs.orig b/src/Dodge/Placement/PlaceSpot/Block.hs.orig index fa8f565ec..4ed7bbfbd 100644 --- a/src/Dodge/Placement/PlaceSpot/Block.hs.orig +++ b/src/Dodge/Placement/PlaceSpot/Block.hs.orig @@ -4,15 +4,12 @@ module Dodge.Placement.PlaceSpot.Block , plLineBlock ) where -import Dodge.Data +import Dodge.Data.World import Dodge.Path import Dodge.Block.Debris ---import Dodge.LevelGen.LevelStructure import Dodge.Base ---import Dodge.Zone import Geometry import qualified IntMapHelp as IM - import Control.Lens import qualified Data.IntSet as IS diff --git a/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs b/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs index 7326dfe88..ca064b4b0 100644 --- a/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs +++ b/src/Dodge/Placement/PlaceSpot/TriggerDoor.hs @@ -1,118 +1,128 @@ ---{-# LANGUAGE BangPatterns #-} -module Dodge.Placement.PlaceSpot.TriggerDoor - ( plDoor - , plSlideDoor - , maybeClearDoorPaths - ) where -import Dodge.Zoning.Wall -import Dodge.Data +module Dodge.Placement.PlaceSpot.TriggerDoor ( + plDoor, + plSlideDoor, + maybeClearDoorPaths, +) where + +import qualified Data.Graph.Inductive as FGL +import qualified Data.IntSet as IS +import Data.List import Dodge.Base -import Dodge.Path +import Dodge.Data.World import Dodge.Default.Door import Dodge.LevelGen.DoorPane -import Picture +import Dodge.Path +import Dodge.Zoning.Wall import Geometry import qualified IntMapHelp as IM import LensHelp ---import Dodge.LevelGen.LevelStructure +import Picture ---import Data.Maybe -import Data.List -import qualified Data.IntSet as IS -import qualified Data.Graph.Inductive as FGL -plDoor :: Color - -> EdgeObstacle - -> WdBl -- ^ Opening condition - -> [(Point2,Point2)] -- ^ Door positions, closed to open. - -- Bumped out up and down by 9, not widened - -> World - -> (Int,World) +plDoor :: + Color -> + EdgeObstacle -> + -- | Opening condition + WdBl -> + -- | Door positions, closed to open. + -- Bumped out up and down by 9, not widened + [(Point2, Point2)] -> + World -> + (Int, World) plDoor col eo cond pss gw = (drid, addWalls $ gw & cWorld . doors %~ addDoor) -- carefull with the ordering of addWalls where drid = IM.newKey $ _doors (_cWorld gw) - addDoor = IM.insert drid $ defaultDoor - { _drID = drid - , _drWallIDs = IS.fromList wlids - , _drStatus = DoorInt 0 - , _drTrigger = cond - , _drMech = DrWdMechanismStepwise nsteps wlids pss - , _drPos = head pss - , _drOpenPos = head pss - , _drClosePos = last pss - , _drObstacleType = eo - } + addDoor = + IM.insert drid $ + defaultDoor + { _drID = drid + , _drWallIDs = IS.fromList wlids + , _drStatus = DoorInt 0 + , _drTrigger = cond + , _drMech = DrWdMechanismStepwise nsteps wlids pss + , _drPos = head pss + , _drOpenPos = head pss + , _drClosePos = last pss + , _drObstacleType = eo + } nsteps = length pss - 1 wlids = take 4 [IM.newKey $ _walls (_cWorld gw) ..] wlps' = uncurry (rectanglePairs 9) $ head pss addWalls w' = foldl' (addDoorWall eo drid $ switchWallCol col) w' $ zip wlids wlps' -addDoorWall :: EdgeObstacle -> Int -> Wall -> World -> (Int,(Point2,Point2)) -> World -addDoorWall eo drid wl w (wlid,wlps) = w' - & cWorld . walls %~ IM.insert wlid wl - { _wlLine = wlps - , _wlID = wlid - , _wlStructure = DoorPart drid - } - & cWorld . doors . ix drid . drObstructs .++~ es +addDoorWall :: EdgeObstacle -> Int -> Wall -> World -> (Int, (Point2, Point2)) -> World +addDoorWall eo drid wl w (wlid, wlps) = + w' + & cWorld . walls + %~ IM.insert + wlid + wl + { _wlLine = wlps + , _wlID = wlid + , _wlStructure = DoorPart drid + } + & cWorld . doors . ix drid . drObstructs .++~ es where - (w',es) = uncurry (obstructPathsCrossing eo) wlps w + (w', es) = uncurry (obstructPathsCrossing eo) wlps w -maybeClearDoorPaths :: EdgeObstacle -> [(Int,Int,PathEdge)] -> World -> World +maybeClearDoorPaths :: EdgeObstacle -> [(Int, Int, PathEdge)] -> World -> World maybeClearDoorPaths eo es w = foldl' (maybeClearDoorPath eo) w es -maybeClearDoorPath :: EdgeObstacle -> World -> (Int,Int,PathEdge) -> World -maybeClearDoorPath eo w (x,y,pe) - | not . null $ overlapSegWalls (_peStart pe) (_peEnd pe) $ wlsNearSeg (_peStart pe) (_peEnd pe) w - = w & cWorld . pathGraph %~ FGL.insEdge (x,y,pe & peObstacles . at eo ?~ ()) . FGL.delEdge (x,y) - | otherwise - = w & cWorld . pathGraph %~ FGL.insEdge (x,y,pe & peObstacles . at eo .~ Nothing) . FGL.delEdge (x,y) +maybeClearDoorPath :: EdgeObstacle -> World -> (Int, Int, PathEdge) -> World +maybeClearDoorPath eo w (x, y, pe) + | not . null $ overlapSegWalls (_peStart pe) (_peEnd pe) $ wlsNearSeg (_peStart pe) (_peEnd pe) w = + w & cWorld . pathGraph %~ FGL.insEdge (x, y, pe & peObstacles . at eo ?~ ()) . FGL.delEdge (x, y) + | otherwise = + w & cWorld . pathGraph %~ FGL.insEdge (x, y, pe & peObstacles . at eo .~ Nothing) . FGL.delEdge (x, y) -plSlideDoor - :: Door - -> Wall - -> EdgeObstacle - -> Float - -> Point2 - -> Point2 - -> World - -> (Int, World) -plSlideDoor dr wl eo shiftOffset a b gw - = (drid, addDoorWalls $ gw & cWorld . doors %~ addDoor) +plSlideDoor :: + Door -> + Wall -> + EdgeObstacle -> + Float -> + Point2 -> + Point2 -> + World -> + (Int, World) +plSlideDoor dr wl eo shiftOffset a b gw = + (drid, addDoorWalls $ gw & cWorld . doors %~ addDoor) where drid = IM.newKey $ _doors (_cWorld gw) - addDoor = IM.insert drid $ dr - { _drID = drid - , _drWallIDs = IS.fromList wlids - , _drStatus = DoorClosed - , _drMech = DoorMechanism - , _drPos = (a,b) - , _drOpenPos = (shiftLeft a,shiftLeft b) - , _drClosePos = (a,b) - , _drObstacleType = eo - } + addDoor = + IM.insert drid $ + dr + { _drID = drid + , _drWallIDs = IS.fromList wlids + , _drStatus = DoorClosed + , _drMech = DoorMechanism + , _drPos = (a, b) + , _drOpenPos = (shiftLeft a, shiftLeft b) + , _drClosePos = (a, b) + , _drObstacleType = eo + } addDoorWalls w' = foldl' (addDoorWall eo drid wl) w' $ zip wlids pairs pairs = rectanglePairs 9 a b - shiftLeft = (+.+ (a -.- b +.+ shiftOffset *.* normalizeV (b -.- a))) + shiftLeft = (+.+ (a -.- b +.+ shiftOffset *.* normalizeV (b -.- a))) wlids = take 4 [IM.newKey $ _walls (_cWorld gw) ..] + -- old code that may help with pathing --import Dodge.LevelGen.Pathing --import Data.Graph.Inductive hiding ((&)) --addButtonDoor :: Color -> Point2 -> Float -> Point2 -> Point2 -> Float -> World -> (Int, World) ---addButtonDoor c btp btr a b speed w +--addButtonDoor c btp btr a b speed w -- = (,) 0 --- . over buttons (IM.insert bid bt) +-- . over buttons (IM.insert bid bt) -- $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph)) -- $ set pathGraph newGraph -- $ set pathGraphP newGraphPairs -- $ snd (placeSlideDoor False c cond a b speed w) --- where +-- where -- bid = IM.newKey $ _buttons w -- cond w' = BtNoLabel == _btState (_buttons w' IM.! bid) -- bt = (makeButton c eff) {_btPos = btp, _btRot = btr, _btID = bid} --- (newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg a b)) +-- (newGraphPairs,removedPairs) = partition (isNothing . uncurry (intersectSegSeg a b)) -- $ _pathGraphP w -- newGraph = pairsToGraph dist newGraphPairs -- insertPoint pp@(_,V2 x y) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp] --- eff w' = over pathGraphP (removedPairs ++) +-- eff w' = over pathGraphP (removedPairs ++) -- . over pathGraph (flip run_ $ insMapEdgesM $ map f removedPairs) $ w' -- f (x,y) = (x,y,dist x y) diff --git a/src/Dodge/Placement/Random.hs b/src/Dodge/Placement/Random.hs index dbdd9a993..7fdb32f41 100644 --- a/src/Dodge/Placement/Random.hs +++ b/src/Dodge/Placement/Random.hs @@ -1,13 +1,15 @@ module Dodge.Placement.Random where -import Dodge.Data + +import Dodge.Data.Item import Dodge.Item import RandomHelp {- Probabilites of the type of the first floor weapon. -} randFirstWeapon :: State StdGen Item -randFirstWeapon = takeOne $ - replicate 10 pistol - ++ replicate 5 (bangStick 4) - ++ replicate 5 (volleyGun 3) - ++ replicate 5 bangCone - ++ [lasGun] +randFirstWeapon = + takeOne $ + replicate 10 pistol + ++ replicate 5 (bangStick 4) + ++ replicate 5 (volleyGun 3) + ++ replicate 5 bangCone + ++ [lasGun] diff --git a/src/Dodge/Placement/Shift.hs b/src/Dodge/Placement/Shift.hs index 8252362e8..cce4d993d 100644 --- a/src/Dodge/Placement/Shift.hs +++ b/src/Dodge/Placement/Shift.hs @@ -1,27 +1,33 @@ -module Dodge.Placement.Shift - ( shiftPlacement - , shiftPSBy - , shiftRelativeToPS - ) where ---import Dodge.LevelGen.Data -import Dodge.Data +module Dodge.Placement.Shift ( + shiftPlacement, + shiftPSBy, + shiftRelativeToPS, +) where + +import Dodge.Data.GenWorld import Dodge.ShiftPoint +import Geometry import LensHelp -import Geometry -shiftPSBy :: (Point2,Float) -> PlacementSpot -> PlacementSpot -shiftPSBy (pos,rot) ps = ps - & psPos %~ shiftPointBy (pos,rot) - & psRot +~ rot +shiftPSBy :: (Point2, Float) -> PlacementSpot -> PlacementSpot +shiftPSBy (pos, rot) ps = + ps + & psPos %~ shiftPointBy (pos, rot) + & psRot +~ rot + shiftRelativeToPS :: Point2 -> PlacementSpot -> PlacementSpot shiftRelativeToPS p ps = ps & psPos .+.+~ rotateV (_psRot ps) p -shiftPlacement :: (Point2,Float) -> Placement -> Placement + +shiftPlacement :: (Point2, Float) -> Placement -> Placement shiftPlacement shift plmnt = case plmnt of --- slightly messy NoShiftCont, necessary to stop interference with ps0jPushPS - Placement {_plSpot = PSNoShiftCont {}} -> plmnt & plSpot %~ shiftPSBy shift - Placement {} -> plmnt & plSpot %~ shiftPSBy shift - & plIDCont %~ fmap (fmap (fmap $ shiftPlacement shift)) - PlacementUsingPos p f -> PlacementUsingPos (shiftPoint3By shift p) - (fmap (shiftPlacement shift) f) + -- slightly messy NoShiftCont, necessary to stop interference with ps0jPushPS + Placement{_plSpot = PSNoShiftCont{}} -> plmnt & plSpot %~ shiftPSBy shift + Placement{} -> + plmnt & plSpot %~ shiftPSBy shift + & plIDCont %~ fmap (fmap (fmap $ shiftPlacement shift)) + PlacementUsingPos p f -> + PlacementUsingPos + (shiftPoint3By shift p) + (fmap (shiftPlacement shift) f) RandomPlacement rpl -> RandomPlacement $ fmap (shiftPlacement shift) rpl PickOnePlacement i pl -> PickOnePlacement i (shiftPlacement shift pl) diff --git a/src/Dodge/Placement/TopDecoration.hs b/src/Dodge/Placement/TopDecoration.hs index f85b203b5..100162909 100644 --- a/src/Dodge/Placement/TopDecoration.hs +++ b/src/Dodge/Placement/TopDecoration.hs @@ -1,62 +1,73 @@ module Dodge.Placement.TopDecoration where -import Dodge.Data -import Dodge.Room.Foreground ---import Dodge.LevelGen.Data -import Shape -import Geometry + import Color +import Dodge.Data.GenParams +import Dodge.Room.Foreground +import Geometry +import Shape decorationToShape :: DecorationShape -> Float -> Float -> Float -> Color -> Color -> Shape decorationToShape dec = case dec of - PLUS -> plusDecoration - SQUARE -> squareDecoration - CIRCLE -> circleDecoration - THREELINES -> threeLineDecoration + PLUS -> plusDecoration + SQUARE -> squareDecoration + CIRCLE -> circleDecoration + THREELINES -> threeLineDecoration midBarDecoration :: Float -> Float -> Float -> Color -> Color -> Shape -midBarDecoration w h z _ c = embossingR - <> rotateSH pi embossingR - <> colorSH c (thinHighBar (z + 7) (V2 (-0.3*w) 0) (V2 (0.3*w) 0)) +midBarDecoration w h z _ c = + embossingR + <> rotateSH pi embossingR + <> colorSH c (thinHighBar (z + 7) (V2 (-0.3 * w) 0) (V2 (0.3 * w) 0)) where w' = 0.3 * w - embossingR = colorSH c $ prismPoly - [V3 w h z,V3 w (0.3*h) 41,V3 w (-0.3*h) 41,V3 w (-h) z] - [V3 w' h z,V3 w' (0.3*h) 41,V3 w' (-0.3*h) 41,V3 w' (-h) z] + embossingR = + colorSH c $ + prismPoly + [V3 w h z, V3 w (0.3 * h) 41, V3 w (-0.3 * h) 41, V3 w (- h) z] + [V3 w' h z, V3 w' (0.3 * h) 41, V3 w' (-0.3 * h) 41, V3 w' (- h) z] fourEmbossDecoration :: Float -> Float -> Float -> Color -> Color -> Shape -fourEmbossDecoration w h z _ c = colorSH c $ foldMap f [(w,h),(-w,h),(w,-h),(-w,-h)] +fourEmbossDecoration w h z _ c = colorSH c $ foldMap f [(w, h), (- w, h), (w, - h), (- w, - h)] where - f (a,b) = translateSH (V3 (a/2) (b/2) z) embossing - embossing = upperPrismPolyHalf 10 $ reverse $ rectNSWE (h/2) (-h/2) (-w/2) (w/2) + f (a, b) = translateSH (V3 (a / 2) (b / 2) z) embossing + embossing = upperPrismPolyHalf 10 $ reverse $ rectNSWE (h / 2) (- h / 2) (- w / 2) (w / 2) plusDecoration :: Float -> Float -> Float -> Color -> Color -> Shape -plusDecoration w h z _ c = colorSH c $ thinHighBar z (V2 w 0) (V2 (-w) 0) - <> thinHighBar z (V2 0 h) (V2 0 (-h)) +plusDecoration w h z _ c = + colorSH c $ + thinHighBar z (V2 w 0) (V2 (- w) 0) + <> thinHighBar z (V2 0 h) (V2 0 (- h)) squareDecoration :: Float -> Float -> Float -> Color -> Color -> Shape -squareDecoration w h z _ col = colorSH col $ foldMap f - [(w',-w',h',h') - ,(w',-w',-h',-h') - ,(w',w',h',-h') - ,(-w',-w',h',-h') - ] +squareDecoration w h z _ col = + colorSH col $ + foldMap + f + [ (w', - w', h', h') + , (w', - w', - h', - h') + , (w', w', h', - h') + , (- w', - w', h', - h') + ] where w' = w - 1.5 h' = h - 1.5 - f (a,c,b,d) = thinHighBar z (V2 a b) (V2 c d) + f (a, c, b, d) = thinHighBar z (V2 a b) (V2 c d) circleDecoration :: Float -> Float -> Float -> Color -> Color -> Shape -circleDecoration w _ z _ c = colorSH c $ foldMap toprail (take 8 [0,pi/4..]) +circleDecoration w _ z _ c = colorSH c $ foldMap toprail (take 8 [0, pi / 4 ..]) where - toprail a = rotateSH a $ thinHighBar z (V2 0 w) (rotateV (pi/4) $ V2 0 w) + toprail a = rotateSH a $ thinHighBar z (V2 0 w) (rotateV (pi / 4) $ V2 0 w) threeLineDecoration :: Float -> Float -> Float -> Color -> Color -> Shape -threeLineDecoration w h z _ col = colorSH col $ foldMap f - [(w',-w',h',h') - ,(w',-w',0,0) - ,(w',-w',-h',-h') - ] +threeLineDecoration w h z _ col = + colorSH col $ + foldMap + f + [ (w', - w', h', h') + , (w', - w', 0, 0) + , (w', - w', - h', - h') + ] where w' = w - 1.5 h' = h - 1.5 - f (a,c,b,d) = thinHighBar z (V2 a b) (V2 c d) + f (a, c, b, d) = thinHighBar z (V2 a b) (V2 c d) diff --git a/src/Dodge/PlacementSpot.hs b/src/Dodge/PlacementSpot.hs index 3446d9194..9833a92cf 100644 --- a/src/Dodge/PlacementSpot.hs +++ b/src/Dodge/PlacementSpot.hs @@ -35,8 +35,8 @@ module Dodge.PlacementSpot , usedRoomLinkPoss , usedRoomInLinkPoss ) where ---import Dodge.LevelGen.Data -import Dodge.Data + +import Dodge.Data.GenWorld import Geometry import Control.Lens diff --git a/src/Dodge/PosEvent.hs b/src/Dodge/PosEvent.hs index acc83a9c1..e25c9c5f9 100644 --- a/src/Dodge/PosEvent.hs +++ b/src/Dodge/PosEvent.hs @@ -1,17 +1,17 @@ module Dodge.PosEvent where -import Dodge.Data + +import Color +import Control.Monad.State +import Dodge.Data.World import Dodge.Spark import Geometry.Data -import Color import LensHelp - -import Control.Monad.State import RandomHelp updatePosEvent :: World -> PosEvent -> (World, Maybe PosEvent) updatePosEvent w pv - | _pvTimer pv < 1 = (w,Nothing) - | otherwise = (posEventEffect pv w,Just $ pv & pvTimer -~ 1) + | _pvTimer pv < 1 = (w, Nothing) + | otherwise = (posEventEffect pv w, Just $ pv & pvTimer -~ 1) posEventEffect :: PosEvent -> World -> World posEventEffect pv = case _pvType pv of @@ -20,6 +20,6 @@ posEventEffect pv = case _pvType pv of spawnElectricalSparks :: Point2 -> World -> World spawnElectricalSparks = randSpark ELECTRICAL rspeed rcol rdir where - rspeed = state (randomR (3,6)) - rcol = brightX 100 1.5 <$> takeOne [white,azure,blue,cyan] - rdir = state $ randomR (0,2*pi) + rspeed = state (randomR (3, 6)) + rcol = brightX 100 1.5 <$> takeOne [white, azure, blue, cyan] + rdir = state $ randomR (0, 2 * pi) diff --git a/src/Dodge/PrWdLsLs.hs b/src/Dodge/PrWdLsLs.hs index 0024f9160..8bebd94f8 100644 --- a/src/Dodge/PrWdLsLs.hs +++ b/src/Dodge/PrWdLsLs.hs @@ -1,13 +1,13 @@ -module Dodge.PrWdLsLs - where +module Dodge.PrWdLsLs where + +import Control.Lens +import Dodge.Data.World import Dodge.WdP2f import Geometry.Vector3D -import Dodge.Data -import Control.Lens -doPrWdLsLs :: PrWdLsLs -> Prop -> World -> LightSource -> LightSource +doPrWdLsLs :: PrWdLsLs -> Prop -> World -> LightSource -> LightSource doPrWdLsLs x = case x of - PrWdLsId -> \_ _ -> id - PrWdLsSetPosition y off -> \_ w - -> lsParam . lsPos .~ addZ 0 (fst (doWdP2f y w)) +.+.+ rotate3z (snd (doWdP2f y w)) off + PrWdLsId -> \_ _ -> id + PrWdLsSetPosition y off -> \_ w -> + lsParam . lsPos .~ addZ 0 (fst (doWdP2f y w)) +.+.+ rotate3z (snd (doWdP2f y w)) off PrWdLsSetColor c -> \_ _ -> lsParam . lsCol .~ c diff --git a/src/Dodge/PreloadData.hs b/src/Dodge/PreloadData.hs index 08b3a8638..25551bad0 100644 --- a/src/Dodge/PreloadData.hs +++ b/src/Dodge/PreloadData.hs @@ -1,29 +1,22 @@ module Dodge.PreloadData where -import Dodge.Data ---import Dodge.Base ---import Dodge.Base.Window ---import Dodge.Creature.Action ---import Dodge.SoundLogic ---import Dodge.Inventory ---import Geometry -import Preload.Update ---import qualified IntMapHelp as IM import Control.Lens +import Dodge.Data.Universe +import Preload.Update sideEffectUpdatePreload :: Int -> Int -> Int -> (Universe -> IO Universe) -> Universe -> IO Universe -sideEffectUpdatePreload divRes x y f u = do +sideEffectUpdatePreload divRes x y f u = do pdata <- pdataResizeUpdate (x `div` divRes) (y `div` divRes) x y (_preloadData u) f $ u & preloadData .~ pdata updatePreload :: Int -> Int -> Int -> Universe -> IO Universe -updatePreload divRes x y u = do +updatePreload divRes x y u = do pdata <- pdataResizeUpdate (x `div` divRes) (y `div` divRes) x y (_preloadData u) return $ u & preloadData .~ pdata updateFramebufferSize :: Universe -> IO Universe updateFramebufferSize u = updatePreload divRes x y u - where - (x,y) = (round $ _windowX cfig, round $ _windowY cfig) + where + (x, y) = (round $ _windowX cfig, round $ _windowY cfig) cfig = _uvConfig u divRes = resFactorNum $ u ^. uvConfig . graphics_resolution_factor diff --git a/src/Dodge/PressPlate.hs b/src/Dodge/PressPlate.hs index 859a8a18f..83297ee63 100644 --- a/src/Dodge/PressPlate.hs +++ b/src/Dodge/PressPlate.hs @@ -1,17 +1,16 @@ -module Dodge.PressPlate - where -import Dodge.Data -import Geometry +module Dodge.PressPlate where + import Dodge.Base.You +import Dodge.Data.World import Dodge.WorldEvent.Explosion +import Geometry doPressPlateEvent :: PressPlateEvent -> PressPlate -> World -> World doPressPlateEvent ppe = case ppe of - PressPlateId -> const id + PressPlateId -> const id PPLevelReset -> ppLevelReset ppLevelReset :: PressPlate -> World -> World ppLevelReset pp w - | dist (_crPos $ you w) (_ppPos pp) < 20 = makeExplosionAt (_ppPos pp) w + | dist (_crPos $ you w) (_ppPos pp) < 20 = makeExplosionAt (_ppPos pp) w | otherwise = w - diff --git a/src/Dodge/Projectile/Create.hs b/src/Dodge/Projectile/Create.hs index c479a5180..592b62342 100644 --- a/src/Dodge/Projectile/Create.hs +++ b/src/Dodge/Projectile/Create.hs @@ -1,6 +1,6 @@ module Dodge.Projectile.Create where -import Dodge.Data +import Dodge.Data.World import Dodge.Item.Location import Geometry import qualified IntMapHelp as IM diff --git a/src/Dodge/Projectile/Draw.hs b/src/Dodge/Projectile/Draw.hs index 641c04587..298e7a8d2 100644 --- a/src/Dodge/Projectile/Draw.hs +++ b/src/Dodge/Projectile/Draw.hs @@ -1,5 +1,7 @@ module Dodge.Projectile.Draw where -import Dodge.Data + +import Dodge.Data.Item.Use.Consumption.Ammo +import Dodge.Data.Projectile import Geometry import Picture import Shape @@ -11,25 +13,31 @@ drawProjectile prj = case _prjDraw prj of DrawRemoteShell -> drawRemoteShell prj DrawDrone -> drawShell prj DrawBlankProjectile -> mempty + drawShell :: Proj -> SPic -drawShell pj = noPic - . translateSHz 18 - . uncurryV translateSHf (_prjPos pj) - $ rotateSH (argV $ _prjAcc pj) shellShape +drawShell pj = + noPic + . translateSHz 18 + . uncurryV translateSHf (_prjPos pj) + $ rotateSH (argV $ _prjAcc pj) shellShape + shellShape :: Shape -shellShape = colorSH black $ upperPrismPoly 4 $ map toV2 [(-6,4),(-6,-4),(6,-4),(8,0),(6,4)] +shellShape = colorSH black $ upperPrismPoly 4 $ map toV2 [(-6, 4), (-6, -4), (6, -4), (8, 0), (6, 4)] + drawRemoteShell :: Proj -> SPic drawRemoteShell pj - | rem (t+200) 20 < 9 - = doposition $ noPic shellShape + | rem (t + 200) 20 < 9 = + doposition $ noPic shellShape | otherwise = doposition $ remoteShellShape col where - col | t > (-99) = green + col + | t > (-99) = green | otherwise = red t = _prjTimer pj doposition = translateSPz 18 . uncurryV translateSPf (_prjPos pj) . rotateSP (_prjDir pj) + remoteShellShape :: Color -> SPic -remoteShellShape col = (shellShape +remoteShellShape col = + ( shellShape , setLayer BloomNoZWrite . setDepth 4.5 . color col $ circleSolid 3 ) - diff --git a/src/Dodge/Projectile/Update.hs b/src/Dodge/Projectile/Update.hs index ac298e061..4b74bdfae 100644 --- a/src/Dodge/Projectile/Update.hs +++ b/src/Dodge/Projectile/Update.hs @@ -2,13 +2,11 @@ module Dodge.Projectile.Update where ---import qualified Data.Set as S - import Control.Lens import qualified Data.Map.Strict as M import Data.Maybe import Dodge.Base -import Dodge.Data +import Dodge.Data.World import Dodge.Default.Weapon import Dodge.EnergyBall import Dodge.Item.Location @@ -71,7 +69,7 @@ explodeRemoteRocket' mitid thepj w = itid <- mitid itpos <- w ^? cWorld . itemLocations . ix itid return $ - (pointerToItemLocation itpos . itUse . rUse .~ HeldDoNothing) + (pointerToItemLocation itpos . itUse . heldUse .~ HeldDoNothing) . (cWorld . projectiles . ix pjid . prjUpdates .~ [PJRetireRemote itid 30 pjid]) pjid = _prjID thepj @@ -127,7 +125,7 @@ retireRemoteProj'' itid pjid w = w & pointerToItemLocation (_itemLocations (_cWorld w) IM.! itid) %~ ( (itScope . scopePos .~ V2 0 0) - . (itUse . rUse .~ HeldFireRemoteShell) + . (itUse . heldUse .~ HeldFireRemoteShell) ) & cWorld . props %~ IM.delete pjid diff --git a/src/Dodge/Prop/Draw.hs b/src/Dodge/Prop/Draw.hs index b98ebd3b0..ce15f28e6 100644 --- a/src/Dodge/Prop/Draw.hs +++ b/src/Dodge/Prop/Draw.hs @@ -1,12 +1,12 @@ -module Dodge.Prop.Draw - where -import Geometry.Polygon -import Geometry.Data +module Dodge.Prop.Draw where + import Dodge.Data.Prop -import ShapePicture -import Shape +import Geometry.Data +import Geometry.Polygon import Picture import qualified Quaternion as Q +import Shape +import ShapePicture drawProp' :: Prop -> SPic drawProp' pr = drawProp (_prDraw pr) pr @@ -21,18 +21,20 @@ drawProp pd = case pd of PropLampCover h -> drawLampCover h PropDrawToggle pd' -> propDrawToggle pd' PropDrawGib x -> noPic . drawGib x - PropDrawFlatTranslate x -> \pr - -> uncurryV translateSPf (_prPos pr) $ rotateSP (_prRot pr) $ drawProp x pr + PropDrawFlatTranslate x -> \pr -> + uncurryV translateSPf (_prPos pr) $ rotateSP (_prRot pr) $ drawProp x pr drawGib :: Float -> Prop -> Shape drawGib x pr = flesh <> skin where - flesh = colorSH (dark $ dark red) - . translateSHz (negate x) - $ upperPrismPoly (2*x) $ square x - skin = colorSH (_prColor pr) - . translateSH (V3 1 1 (1 - x)) - $ upperPrismPoly (2*x) $ square x + flesh = + colorSH (dark $ dark red) + . translateSHz (negate x) + $ upperPrismPoly (2 * x) $ square x + skin = + colorSH (_prColor pr) + . translateSH (V3 1 1 (1 - x)) + $ upperPrismPoly (2 * x) $ square x propDrawToggle :: PropDraw -> Prop -> SPic propDrawToggle pd pr @@ -40,48 +42,53 @@ propDrawToggle pd pr | otherwise = drawProp pd pr drawLampCover :: Float -> Prop -> SPic -drawLampCover h pr = ( translateSHz (h-2.5) . uncurryV translateSHf (_prPos pr) - $ rotateSH (_prRot pr) $ mconcat - [ translateSHz 1 . upperPrismPoly 1 . reverse $ rectNSWE 3 2 (-1) 3 - , translateSHz 1 . upperPrismPoly 1 . reverse $ rectNSWE 3 (-1) 2 3 - , translateSHz 2 . upperPrismPoly 1 . reverse $ rectNSWE 3 2 (-1) 3 - , translateSHz 2 . upperPrismPoly 1 . reverse $ rectNSWE 3 (-1) 2 3 - , upperPrismPoly 1 [V2 2 2,V2 (-1) 2,V2 2 (-1)] - ] +drawLampCover h pr = + ( translateSHz (h -2.5) . uncurryV translateSHf (_prPos pr) $ + rotateSH (_prRot pr) $ + mconcat + [ translateSHz 1 . upperPrismPoly 1 . reverse $ rectNSWE 3 2 (-1) 3 + , translateSHz 1 . upperPrismPoly 1 . reverse $ rectNSWE 3 (-1) 2 3 + , translateSHz 2 . upperPrismPoly 1 . reverse $ rectNSWE 3 2 (-1) 3 + , translateSHz 2 . upperPrismPoly 1 . reverse $ rectNSWE 3 (-1) 2 3 + , upperPrismPoly 1 [V2 2 2, V2 (-1) 2, V2 2 (-1)] + ] , mempty ) drawVerticalLampCover :: Float -> Prop -> SPic drawVerticalLampCover h pr = - ( translateSHz h . uncurryV translateSHf (_prPos pr) - $ rotateSHx (_prRot pr) $ mconcat - [ - translateSHz (-3) . upperPrismPoly 1 $ reverse $ rectNSWE 2 (-2) (-5) 5 - ] + ( translateSHz h . uncurryV translateSHf (_prPos pr) $ + rotateSHx (_prRot pr) $ + mconcat + [ translateSHz (-3) . upperPrismPoly 1 $ reverse $ rectNSWE 2 (-2) (-5) 5 + ] , mempty ) drawMovingShape :: Prop -> Shape -> SPic -drawMovingShape pr = noPic - . translateSHz (_prPosZ pr) - . uncurryV translateSHf (_prPos pr) - . overPosSH (Q.rotate (_prQuat pr)) +drawMovingShape pr = + noPic + . translateSHz (_prPosZ pr) + . uncurryV translateSHf (_prPos pr) + . overPosSH (Q.rotate (_prQuat pr)) drawMovingShapeCol :: Prop -> Shape -> SPic -drawMovingShapeCol pr = noPic - . translateSHz (_prPosZ pr) - . uncurryV translateSHf (_prPos pr) - . overPosSH (Q.rotate (_prQuat pr)) - . colorSH (_prColor pr) +drawMovingShapeCol pr = + noPic + . translateSHz (_prPosZ pr) + . uncurryV translateSHf (_prPos pr) + . overPosSH (Q.rotate (_prQuat pr)) + . colorSH (_prColor pr) drawDoubleLampCover :: Float -> Prop -> SPic drawDoubleLampCover h pr = - ( translateSHz (h-2.5) . uncurryV translateSHf (_prPos pr) - $ rotateSH (_prRot pr) $ mconcat - [ upperPrismPoly 5 $ reverse $ rectNSWE 6 5 (-6) 6 - , upperPrismPoly 5 $ reverse $ rectNSWE (-5) (-6) (-6) 6 - , upperPrismPoly 1 [V2 0 (-1),V2 6 5,V2 (-6) 5] - , upperPrismPoly 1 [V2 0 1 ,V2 (-6) (-5),V2 6 (-5)] - ] + ( translateSHz (h -2.5) . uncurryV translateSHf (_prPos pr) $ + rotateSH (_prRot pr) $ + mconcat + [ upperPrismPoly 5 $ reverse $ rectNSWE 6 5 (-6) 6 + , upperPrismPoly 5 $ reverse $ rectNSWE (-5) (-6) (-6) 6 + , upperPrismPoly 1 [V2 0 (-1), V2 6 5, V2 (-6) 5] + , upperPrismPoly 1 [V2 0 1, V2 (-6) (-5), V2 6 (-5)] + ] , mempty ) diff --git a/src/Dodge/Prop/Gib.hs b/src/Dodge/Prop/Gib.hs index b8e01b03f..45d6f6c94 100644 --- a/src/Dodge/Prop/Gib.hs +++ b/src/Dodge/Prop/Gib.hs @@ -1,119 +1,136 @@ module Dodge.Prop.Gib where -import Dodge.Base -import Dodge.Data -import Dodge.Damage -import Geometry + import Color +import Data.Foldable +import Data.List (zip4) +import Dodge.Base +import Dodge.Damage +import Dodge.Data.World +import Geometry import LensHelp +import qualified Quaternion as Q import RandomHelp -import qualified Quaternion as Q -import Data.List (zip4) -import Data.Foldable - aGib :: Prop -aGib = PropZ - {_prPos = 0 - ,_prStartPos = 0 - ,_prVel = 0 - ,_prDraw = PropDrawMovingShape (PropDrawGib 3) - ,_prID = 0 - ,_prUpdate = PropFallSmallBounce - ,_prPosZ = 10 - ,_prVelZ = 5 - ,_prTimer = 20 - ,_prQuat = Q.axisAngle (V3 1 0 0) 0 - ,_prQuatSpin = Q.axisAngle (V3 1 1 0) 0.1 - ,_prColor = white - } +aGib = + PropZ + { _prPos = 0 + , _prStartPos = 0 + , _prVel = 0 + , _prDraw = PropDrawMovingShape (PropDrawGib 3) + , _prID = 0 + , _prUpdate = PropFallSmallBounce + , _prPosZ = 10 + , _prVelZ = 5 + , _prTimer = 20 + , _prQuat = Q.axisAngle (V3 1 0 0) 0 + , _prQuatSpin = Q.axisAngle (V3 1 1 0) 0.1 + , _prColor = white + } addCrGibs :: Creature -> World -> World addCrGibs cr w = case damageDirection $ _csDamage $ _crState cr of - Nothing -> w - & addGibAt 25 (_skinHead skin) cpos - & addGibsAt 3 7 (_skinLower skin) cpos - & addGibsAt 13 20 (_skinUpper skin) cpos - Just d -> w - & addGibsAtDir d 3 7 (_skinLower skin) cpos - & addGibsAtDir d 13 20 (_skinUpper skin) cpos - & addGibAtDir d 25 (_skinHead skin) cpos + Nothing -> + w + & addGibAt 25 (_skinHead skin) cpos + & addGibsAt 3 7 (_skinLower skin) cpos + & addGibsAt 13 20 (_skinUpper skin) cpos + Just d -> + w + & addGibsAtDir d 3 7 (_skinLower skin) cpos + & addGibsAtDir d 13 20 (_skinUpper skin) cpos + & addGibAtDir d 25 (_skinHead skin) cpos where skin = _crType cr -- this should be cleaned up cpos = _crPos cr addGibsAt :: Float -> Float -> Color -> Point2 -> World -> World -addGibsAt minh maxh col p w = foldl' (flip $ addGib4 p col) w (zip4 vels zspeeds quats hs) - & randGen .~ newg +addGibsAt minh maxh col p w = + foldl' (flip $ addGib4 p col) w (zip4 vels zspeeds quats hs) + & randGen .~ newg where - (speeds,newg) = replicateM 4 (state (randomR (1,4))) & runState $ _randGen w - hs = replicateM 4 (state (randomR (minh,maxh))) & evalState $ _randGen w + (speeds, newg) = replicateM 4 (state (randomR (1, 4))) & runState $ _randGen w + hs = replicateM 4 (state (randomR (minh, maxh))) & evalState $ _randGen w dirs = unitVectorAtAngle <$> (randsOnCirc 4 & evalState $ _randGen w) vels = zipWith (*.*) speeds dirs - zspeeds = replicateM 4 (state (randomR (-8,8))) & evalState $ _randGen w + zspeeds = replicateM 4 (state (randomR (-8, 8))) & evalState $ _randGen w quats :: [Q.Quaternion Float] quats = replicateM 4 (Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere) & evalState $ _randGen w -- this is ugly because it is mostly copy-paste from addGibsAt addGibsAtDir :: Float -> Float -> Float -> Color -> Point2 -> World -> World -addGibsAtDir dir minh maxh col p w = foldl' (flip $ addGib4 p col) w (zip4 vels zspeeds quats hs) - & randGen .~ newg +addGibsAtDir dir minh maxh col p w = + foldl' (flip $ addGib4 p col) w (zip4 vels zspeeds quats hs) + & randGen .~ newg where - (speeds,newg) = replicateM 4 (state (randomR (1,4))) & runState $ _randGen w - hs = replicateM 4 (state (randomR (minh,maxh))) & evalState $ _randGen w - dirs = unitVectorAtAngle <$> (randsSpread (dir-pi/4,dir+pi/4) 4 & evalState $ _randGen w) + (speeds, newg) = replicateM 4 (state (randomR (1, 4))) & runState $ _randGen w + hs = replicateM 4 (state (randomR (minh, maxh))) & evalState $ _randGen w + dirs = unitVectorAtAngle <$> (randsSpread (dir - pi / 4, dir + pi / 4) 4 & evalState $ _randGen w) vels = zipWith (*.*) speeds dirs - zspeeds = replicateM 4 (state (randomR (-8,8))) & evalState $ _randGen w + zspeeds = replicateM 4 (state (randomR (-8, 8))) & evalState $ _randGen w quats :: [Q.Quaternion Float] quats = replicateM 4 (Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere) & evalState $ _randGen w - -addGib4 :: Point2 -> Color -> (Point2, Float, Q.Quaternion Float, Float) - -> World -> World -addGib4 p col (v,zs,q,h) = plNew (cWorld . props) prID (aGib & prPos .~ p +.+ (5 *.* normalizeV v) - & prColor .~ col - & prVel .~ v - & prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1) - & prQuat .~ q - & prVelZ .~ zs - & prPosZ .~ h - ) + +addGib4 :: + Point2 -> + Color -> + (Point2, Float, Q.Quaternion Float, Float) -> + World -> + World +addGib4 p col (v, zs, q, h) = + plNew + (cWorld . props) + prID + ( aGib & prPos .~ p +.+ (5 *.* normalizeV v) + & prColor .~ col + & prVel .~ v + & prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1) + & prQuat .~ q + & prVelZ .~ zs + & prPosZ .~ h + ) addGibAt :: Float -> Color -> Point2 -> World -> World -addGibAt h col p w = w - & plNew (cWorld . props) prID gib - & randGen .~ newg +addGibAt h col p w = + w + & plNew (cWorld . props) prID gib + & randGen .~ newg where - (gib,newg) = runState f $ _randGen w + (gib, newg) = runState f $ _randGen w f = do - s <- state $ randomR (1,4) - dir <- unitVectorAtAngle <$> state (randomR (0,2*pi)) - zs <- state $ randomR (-8,8) + s <- state $ randomR (1, 4) + dir <- unitVectorAtAngle <$> state (randomR (0, 2 * pi)) + zs <- state $ randomR (-8, 8) q <- Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere let v = s *.* dir - return $ aGib - & prPos .~ p - & prColor .~ col - & prVel .~ v - & prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1) - & prQuat .~ q - & prVelZ .~ zs - & prPosZ .~ h + return $ + aGib + & prPos .~ p + & prColor .~ col + & prVel .~ v + & prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1) + & prQuat .~ q + & prVelZ .~ zs + & prPosZ .~ h addGibAtDir :: Float -> Float -> Color -> Point2 -> World -> World -addGibAtDir dir h col p w = w - & plNew (cWorld . props) prID gib - & randGen .~ newg +addGibAtDir dir h col p w = + w + & plNew (cWorld . props) prID gib + & randGen .~ newg where - (gib,newg) = runState f $ _randGen w + (gib, newg) = runState f $ _randGen w f = do - s <- state $ randomR (1,4) - zs <- state $ randomR (-8,8) + s <- state $ randomR (1, 4) + zs <- state $ randomR (-8, 8) q <- Q.vToQuat (V3 0 0 1) <$> randOnUnitSphere let v = s *.* unitVectorAtAngle dir - return $ aGib - & prPos .~ p - & prColor .~ col - & prVel .~ v - & prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1) - & prQuat .~ q - & prVelZ .~ zs - & prPosZ .~ h + return $ + aGib + & prPos .~ p + & prColor .~ col + & prVel .~ v + & prQuatSpin .~ Q.axisAngle (vNormal v `v2z` 0) (-0.1) + & prQuat .~ q + & prVelZ .~ zs + & prPosZ .~ h diff --git a/src/Dodge/Prop/Moving.hs b/src/Dodge/Prop/Moving.hs index e2654ef73..a65cf4b34 100644 --- a/src/Dodge/Prop/Moving.hs +++ b/src/Dodge/Prop/Moving.hs @@ -1,15 +1,18 @@ -module Dodge.Prop.Moving - ( fallSmallBounceDamage - , fallSmallBounce - ) where +module Dodge.Prop.Moving ( + fallSmallBounceDamage, + fallSmallBounce, +) where + import Dodge.Base -import Dodge.Data +import Dodge.Data.World import Geometry import LensHelp + fallSmallBounceDamage :: Prop -> World -> World -fallSmallBounceDamage pr w = w - & dodamage - & cWorld . props . ix (_prID pr) %~ fallSmallBounce' w +fallSmallBounceDamage pr w = + w + & dodamage + & cWorld . props . ix (_prID pr) %~ fallSmallBounce' w where p = _prPos pr v = _prVel pr @@ -17,36 +20,40 @@ fallSmallBounceDamage pr w = w | _prPosZ pr < 25 = cWorld . creatures %~ fmap dodamage' | otherwise = id dodamage' cr - | dist (_crPos cr) p < _crRad cr + 5 = cr & crState . csDamage - .:~ Damage CRUSHING (floor . (*10) . max 0 . subtract 5 . abs $ _prVelZ pr) (p -.- v) p (p +.+ v) NoDamageEffect + | dist (_crPos cr) p < _crRad cr + 5 = + cr & crState . csDamage + .:~ Damage CRUSHING (floor . (* 10) . max 0 . subtract 5 . abs $ _prVelZ pr) (p -.- v) p (p +.+ v) NoDamageEffect | otherwise = cr fallSmallBounce :: Prop -> World -> World -fallSmallBounce pr w = w - & cWorld . props . ix (_prID pr) %~ fallSmallBounce' w +fallSmallBounce pr w = + w + & cWorld . props . ix (_prID pr) %~ fallSmallBounce' w fallSmallBounce' :: World -> Prop -> Prop fallSmallBounce' w pr - | newposz < 0 && velz < (-2) = pr - & prVelZ %~ ((*0.5) . negate) --- & pjPos +~ (0.5*.* vel) - & updateWithVel (0.5 *.* vel) - & prVel %~ (0.5 *.*) --- & pjPos +~ (0.5*.* vel) - | newposz < 0 = pr & prUpdate .~ PropUpdateId - & prPosZ .~ 0 --- & pjQuat *~ (_pjQuatSpin pr) - | otherwise = pr - & prVelZ -~ 1 - & prPosZ +~ velz - & updateWithVel vel - & prQuat *~ _prQuatSpin pr + | newposz < 0 && velz < (-2) = + pr + & prVelZ %~ ((* 0.5) . negate) + -- & pjPos +~ (0.5*.* vel) + & updateWithVel (0.5 *.* vel) + & prVel %~ (0.5 *.*) + -- & pjPos +~ (0.5*.* vel) + | newposz < 0 = + pr & prUpdate .~ PropUpdateId + & prPosZ .~ 0 + -- & pjQuat *~ (_pjQuatSpin pr) + | otherwise = + pr + & prVelZ -~ 1 + & prPosZ +~ velz + & updateWithVel vel + & prQuat *~ _prQuatSpin pr where newposz = _prPosZ pr + velz velz = _prVelZ pr - vel = _prVel pr - pos = _prPos pr + vel = _prVel pr + pos = _prPos pr updateWithVel v = case bouncePoint (const True) 0.5 pos (pos + v) w of Nothing -> prPos +~ v - Just (p,v') -> (prPos .~ p) . (prVel .~ v') - + Just (p, v') -> (prPos .~ p) . (prVel .~ v') diff --git a/src/Dodge/Prop/Update.hs b/src/Dodge/Prop/Update.hs index 98ca00e7b..e5018fcc4 100644 --- a/src/Dodge/Prop/Update.hs +++ b/src/Dodge/Prop/Update.hs @@ -1,13 +1,12 @@ -module Dodge.Prop.Update - where -import Dodge.WdP2f -import Dodge.PrWdLsLs -import Dodge.WorldBool -import Dodge.Data -import Dodge.Prop.Moving +module Dodge.Prop.Update where -import Data.Foldable import Control.Lens +import Data.Foldable +import Dodge.Data.World +import Dodge.PrWdLsLs +import Dodge.Prop.Moving +import Dodge.WdP2f +import Dodge.WorldBool updateProp :: Prop -> World -> World updateProp pr = case _prUpdate pr of @@ -20,20 +19,19 @@ updateProp pr = case _prUpdate pr of PropUpdateLS lsid x -> \w -> w & cWorld . lightSources . ix lsid %~ doPrWdLsLs x pr w PropUpdatePosition x -> propUpdatePosition x pr PropUpdateWhen t x -> propUpdateIf t x PropUpdateId pr - PropUpdateAnd x y -> doPropUpdates pr [x,y] + PropUpdateAnd x y -> doPropUpdates pr [x, y] PropUpdateIf t x y -> propUpdateIf t x y pr propUpdateIf :: WdBl -> PropUpdate -> PropUpdate -> Prop -> World -> World propUpdateIf wb x y pr w - | doWdBl wb w = updateProp (pr & prUpdate .~ x) w - | otherwise = updateProp (pr & prUpdate .~ y) w - - + | doWdBl wb w = updateProp (pr & prUpdate .~ x) w + | otherwise = updateProp (pr & prUpdate .~ y) w propUpdatePosition :: WdP2f -> Prop -> World -> World -propUpdatePosition x pr w = w - & cWorld . props . ix (_prID pr) . prPos .~ fst (doWdP2f x w) - & cWorld . props . ix (_prID pr) . prRot .~ snd (doWdP2f x w) +propUpdatePosition x pr w = + w + & cWorld . props . ix (_prID pr) . prPos .~ fst (doWdP2f x w) + & cWorld . props . ix (_prID pr) . prRot .~ snd (doWdP2f x w) doPropUpdates :: Prop -> [PropUpdate] -> World -> World doPropUpdates pr pus w = foldl' f w pus @@ -42,12 +40,13 @@ doPropUpdates pr pus w = foldl' f w pus propSetToggleAnd :: WdBl -> PropUpdate -> Prop -> World -> World propSetToggleAnd wb pu pr = setToggle (doWdBl wb) pr . updateProp (pr & prUpdate .~ pu) - -- fugly + +-- fugly setToggle :: (World -> Bool) -> Prop -> World -> World setToggle cond pr w = w & cWorld . props . ix (_prID pr) . prToggle .~ cond w rotateProp :: Float -> Prop -> World -> World -rotateProp rotAmount pr w = w - & cWorld . props . ix (_prID pr) . prRot +~ rotAmount - +rotateProp rotAmount pr w = + w + & cWorld . props . ix (_prID pr) . prRot +~ rotAmount diff --git a/src/Dodge/RadarBlip.hs b/src/Dodge/RadarBlip.hs index 1d2f7fda0..b9adb9cff 100644 --- a/src/Dodge/RadarBlip.hs +++ b/src/Dodge/RadarBlip.hs @@ -1,20 +1,22 @@ module Dodge.RadarBlip where + import Dodge.Data.RadarBlip import Geometry.Data import LensHelp import Picture updateRadarBlip :: RadarBlip -> Maybe RadarBlip -updateRadarBlip rb - | _rbTime rb <= 0 = Nothing - | otherwise = Just $ rb & rbTime -~ 1 +updateRadarBlip rb + | _rbTime rb <= 0 = Nothing + | otherwise = Just $ rb & rbTime -~ 1 drawBlip :: RadarBlip -> Picture -drawBlip pt = setDepth (-0.5) - . setLayer DebugLayer - . uncurryV translate p - . color (withAlpha (fromIntegral t / fromIntegral maxt) col) - $ circleSolid r +drawBlip pt = + setDepth (-0.5) + . setLayer DebugLayer + . uncurryV translate p + . color (withAlpha (fromIntegral t / fromIntegral maxt) col) + $ circleSolid r where p = _rbPos pt t = _rbTime pt diff --git a/src/Dodge/RadarSweep.hs b/src/Dodge/RadarSweep.hs index c3e0513b0..e437d44f8 100644 --- a/src/Dodge/RadarSweep.hs +++ b/src/Dodge/RadarSweep.hs @@ -1,27 +1,30 @@ module Dodge.RadarSweep where -import Dodge.Zoning.Wall -import Dodge.Data + import Color +import Data.Maybe +import Dodge.Data.World +import Dodge.Zoning.Wall import Geometry +import qualified IntMapHelp as IM import LensHelp -import Data.Maybe -import qualified IntMapHelp as IM - aRadarPulse :: ObjectType -> Creature -> World -> World -aRadarPulse ob cr = cWorld . radarSweeps .:~ RadarSweep - { _rsTimer = 100 - , _rsRad = 0 - , _rsPos = _crPos cr - , _rsObject = ob - } -updateRadarSweep - :: World -> RadarSweep -> (World, Maybe RadarSweep) +aRadarPulse ob cr = + cWorld . radarSweeps + .:~ RadarSweep + { _rsTimer = 100 + , _rsRad = 0 + , _rsPos = _crPos cr + , _rsObject = ob + } + +updateRadarSweep :: + World -> RadarSweep -> (World, Maybe RadarSweep) updateRadarSweep w pt | x < 1 = (w, Nothing) | otherwise = ( putBlips w - , Just $ pt & rsRad .~ r & rsTimer .~ (x-1) + , Just $ pt & rsRad .~ r & rsTimer .~ (x -1) ) where p = _rsPos pt @@ -32,33 +35,35 @@ updateRadarSweep w pt putBlips = cWorld . radarBlips .++~ blips blips = map bf circPoints circPoints = blipsF p r w - r = fromIntegral (400 - x*4) + r = fromIntegral (400 - x * 4) findBlips :: ObjectType -> Point2 -> Float -> World -> [Point2] findBlips ob = case ob of ObCreature -> crBlips - ObItem -> itemBlips - ObWall -> wallBlips + ObItem -> itemBlips + ObWall -> wallBlips _ -> undefined + makeBlip :: ObjectType -> Point2 -> RadarBlip makeBlip ob = case ob of - ObCreature -> blipAt 8 (withAlpha 0.2 green) 50 - ObWall -> blipAt 2 red 50 - ObItem -> blipAt 6 blue 50 + ObCreature -> blipAt 8 (withAlpha 0.2 green) 50 + ObWall -> blipAt 2 red 50 + ObItem -> blipAt 6 blue 50 _ -> undefined -{- | Radar blip at a point. -} +-- | Radar blip at a point. blipAt :: Float -> Color -> Int -> Point2 -> RadarBlip -blipAt r col i p = RadarBlip - {_rbColor = col - ,_rbTime = i - ,_rbMaxTime = i - ,_rbRad = r - ,_rbPos = p - } +blipAt r col i p = + RadarBlip + { _rbColor = col + , _rbTime = i + , _rbMaxTime = i + , _rbRad = r + , _rbPos = p + } crBlips :: Point2 -> Float -> World -> [Point2] -crBlips p r = IM.elems . IM.filter f . fmap _crPos . IM.filter g . _creatures . _cWorld +crBlips p r = IM.elems . IM.filter f . fmap _crPos . IM.filter g . _creatures . _cWorld where f q = dist p q <= r && dist p q > r - 100 g cr = _crID cr /= 0 @@ -76,9 +81,9 @@ itemBlips p r = IM.elems . IM.filter f . fmap _flItPos . _floorItems . _cWorld -- swp (a,b) = (b,a) wallBlips :: Point2 -> Float -> World -> [Point2] -wallBlips p r w = mapMaybe (uncurry (intersectCircSegFirst p r) . _wlLine) - $ map (over wlLine swp) (wlsNearCirc p r w) - <> wlsNearCirc p r w +wallBlips p r w = + mapMaybe (uncurry (intersectCircSegFirst p r) . _wlLine) $ + map (over wlLine swp) (wlsNearCirc p r w) + <> wlsNearCirc p r w where - swp (a,b) = (b,a) - + swp (a, b) = (b, a) diff --git a/src/Dodge/RandImpulse.hs b/src/Dodge/RandImpulse.hs index d7e9311c9..dc1a2b3a0 100644 --- a/src/Dodge/RandImpulse.hs +++ b/src/Dodge/RandImpulse.hs @@ -1,9 +1,10 @@ module Dodge.RandImpulse where -import Dodge.Data.ActionPlan + import Control.Monad.State +import Dodge.Data.ActionPlan import RandomHelp doRandImpulse :: RandImpulse -> State StdGen Impulse doRandImpulse ri = case ri of - RandImpulseList xs -> takeOne xs + RandImpulseList xs -> takeOne xs RandImpulseCircMove r -> Move <$> randInCirc r diff --git a/src/Dodge/Randify.hs b/src/Dodge/Randify.hs index 3736ecdb6..598da680f 100644 --- a/src/Dodge/Randify.hs +++ b/src/Dodge/Randify.hs @@ -1,11 +1,11 @@ module Dodge.Randify where -import Dodge.Data ---import Dodge.LevelGen.LevelStructure -import System.Random -import Control.Monad.State import Control.Lens +import Control.Monad.State +import Dodge.Data.GenWorld +import System.Random gRandify :: GenWorld -> State StdGen GenWorld -> GenWorld -gRandify gw mw = let (gw',g) = runState mw (_randGen $ _gwWorld gw) - in gw' & gwWorld . randGen .~ g +gRandify gw mw = + let (gw', g) = runState mw (_randGen $ _gwWorld gw) + in gw' & gwWorld . randGen .~ g diff --git a/src/Dodge/Reloading.hs b/src/Dodge/Reloading.hs index f2f1db859..9b8a1f201 100644 --- a/src/Dodge/Reloading.hs +++ b/src/Dodge/Reloading.hs @@ -1,48 +1,52 @@ -module Dodge.Reloading - ( crCancelReloading - , crToggleReloading - , crHoldReloading - , stepReloading - , tryStartLoading - ) where -import Dodge.Data -import Dodge.Hammer +module Dodge.Reloading ( + crCancelReloading, + crToggleReloading, + crHoldReloading, + stepReloading, + tryStartLoading, +) where import Control.Lens ---import Data.Maybe +import Dodge.Data.World +import Dodge.Hammer crCancelReloading :: Creature -> Creature -crCancelReloading cr = cr - & crInv . ix (crSel cr) . itUse . heldConsumption . laProgress %~ const Nothing - & crInvSel . iselAction .~ NoInvSelAction +crCancelReloading cr = + cr + & crInv . ix (crSel cr) . itUse . heldConsumption . laProgress %~ const Nothing + & crInvSel . iselAction .~ NoInvSelAction stepReloading :: Creature -> Creature stepReloading cr = case cr ^?! crInvSel . iselAction of - ReloadAction _ _ (HasHammer HammerUp) -> cr & crInvSel . iselAction .~ NoInvSelAction + ReloadAction _ _ (HasHammer HammerUp) -> cr & crInvSel . iselAction .~ NoInvSelAction ReloadAction x la _ - | x > 0 -> cr & crInvSel . iselAction . actionProgress -~ 1 - & crInvSel . iselAction . actionHammer . hammerPosition %~ moveHammerUp - | otherwise -> cr - & crInvSel . iselAction . actionHammer . hammerPosition %~ moveHammerUp - & crInv . ix (crSel cr) . itUse . heldConsumption %~ doLoadAction la - & crInv . ix (crSel cr) . itUse . heldConsumption %~ rotateActionProgress - & tryNextLoadAction + | x > 0 -> + cr & crInvSel . iselAction . actionProgress -~ 1 + & crInvSel . iselAction . actionHammer . hammerPosition %~ moveHammerUp + | otherwise -> + cr + & crInvSel . iselAction . actionHammer . hammerPosition %~ moveHammerUp + & crInv . ix (crSel cr) . itUse . heldConsumption %~ doLoadAction la + & crInv . ix (crSel cr) . itUse . heldConsumption %~ rotateActionProgress + & tryNextLoadAction _ -> cr tryNextLoadAction :: Creature -> Creature tryNextLoadAction cr = case cr ^? crInv . ix (crSel cr) . itUse . heldConsumption . laProgress . _Just . ix 0 of Nothing -> cr & crInvSel . iselAction .~ NoInvSelAction - Just la -> cr & crInvSel . iselAction . actionProgress .~ _actionTime la - & crInvSel . iselAction . reloadAction .~ la + Just la -> + cr & crInvSel . iselAction . actionProgress .~ _actionTime la + & crInvSel . iselAction . reloadAction .~ la crToggleReloading :: Creature -> World -> World crToggleReloading cr w = case cr ^?! crInvSel . iselAction of - ReloadAction {} -> w & cWorld . creatures . ix (_crID cr) . crInvSel . iselAction .~ NoInvSelAction + ReloadAction{} -> w & cWorld . creatures . ix (_crID cr) . crInvSel . iselAction .~ NoInvSelAction _ -> w & cWorld . creatures . ix (_crID cr) %~ tryStartLoading crHoldReloading :: Creature -> World -> World -crHoldReloading cr w = w - & cWorld . creatures . ix (_crID cr) . crInvSel . iselAction . actionHammer .~ HasHammer HammerDown +crHoldReloading cr w = + w + & cWorld . creatures . ix (_crID cr) . crInvSel . iselAction . actionHammer .~ HasHammer HammerDown tryStartLoading :: Creature -> Creature tryStartLoading cr = case ic ^? laProgress . _Just . ix 0 of @@ -51,30 +55,29 @@ tryStartLoading cr = case ic ^? laProgress . _Just . ix 0 of Nothing -> cr Just [] -> error ("item has empty load cycle" ++ show (cr ^?! crInv . ix (crSel cr) . itType)) Just _ | _laLoaded ic >= _laMax ic -> cr - Just (la:las) -> cr & startLoadAction la - & crInv . ix (crSel cr) . itUse . heldConsumption . laProgress ?~ (la:las) + Just (la : las) -> + cr & startLoadAction la + & crInv . ix (crSel cr) . itUse . heldConsumption . laProgress ?~ (la : las) where ic = cr ^?! crInv . ix (crSel cr) . itUse . heldConsumption startLoadAction :: LoadAction -> Creature -> Creature startLoadAction la cr = cr & crInvSel . iselAction .~ ReloadAction (_actionTime la) la NoHammer - rotateActionProgress :: HeldConsumption -> HeldConsumption rotateActionProgress ic = case ic ^? laProgress . _Just of - Just (_:la:las) -> ic & laProgress . _Just .~ (la:las) + Just (_ : la : las) -> ic & laProgress . _Just .~ (la : las) _ | _laLoaded ic < _laMax ic -> ic & laProgress ?~ _laCycle ic _ -> ic & laProgress .~ Nothing - doLoadAction :: LoadAction -> HeldConsumption -> HeldConsumption doLoadAction la ic = case la of - LoadEject {} -> ic & laLoaded .~ 0 & laPrimed .~ False - LoadInsert {} -> ic & laLoaded .~ _laMax ic - LoadAdd {_insertMax = x} - -> ic & laLoaded +~ min x (_laMax ic - _laLoaded ic) - LoadPrime {} -> ic & laPrimed .~ True - + LoadEject{} -> ic & laLoaded .~ 0 & laPrimed .~ False + LoadInsert{} -> ic & laLoaded .~ _laMax ic + LoadAdd{_insertMax = x} -> + ic & laLoaded +~ min x (_laMax ic - _laLoaded ic) + LoadPrime{} -> ic & laPrimed .~ True + --{- | Start reloading if clip is empty. -} --crAutoReload :: Creature -> Creature --crAutoReload cr = case cr ^? ptrItConsumption' . ammoLoaded of @@ -82,7 +85,7 @@ doLoadAction la ic = case la of -- -> cr & ptrItConsumption . reloadState .~ strictify reloadT -- & ptrItConsumption . ammoLoaded %~ (`fromMaybe` maxA) -- _ -> cr --- where +-- where -- ptrItConsumption = crInv . ix (_crInvSel cr) . itConsumption -- ptrItConsumption' = crInv . ix (_crInvSel cr) . itConsumption -- reloadT = cr ^? ptrItConsumption' . reloadTime diff --git a/src/Dodge/Reloading/Action.hs b/src/Dodge/Reloading/Action.hs index f2f2a3e47..55ea91141 100644 --- a/src/Dodge/Reloading/Action.hs +++ b/src/Dodge/Reloading/Action.hs @@ -1,6 +1,7 @@ module Dodge.Reloading.Action where -import Dodge.SoundLogic.ExternallyGeneratedSounds + import Dodge.Data.Item.Use.Consumption.LoadAction +import Dodge.SoundLogic.ExternallyGeneratedSounds loadInsert :: Int -> LoadAction loadInsert x = LoadInsert x insertS diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs index 02dc19846..aceeba1dc 100644 --- a/src/Dodge/Render.hs +++ b/src/Dodge/Render.hs @@ -1,66 +1,65 @@ -{- | Contains the central drawing functions for the dodge loop. -} -module Dodge.Render - ( doDrawing - ) where -import Dodge.Data -import Dodge.Render.Picture -import Dodge.Render.ShapePicture -import Dodge.Render.Walls -import Dodge.Render.Lights -import Geometry -import Render -import Data.Preload.Render -import Shader -import Shader.Poke -import Shader.Bind -import Shader.Data -import MatrixHelper -import Shader.ExtraPrimitive -import Shader.Parameters -import Picture.Data +-- | Contains the central drawing functions for the dodge loop. +module Dodge.Render ( + doDrawing, +) where -import Foreign import Control.Lens import Control.Monad import qualified Control.Monad.Parallel as MP -import Graphics.Rendering.OpenGL hiding (color,scale,translate,rotate) -import qualified SDL +import Data.Preload.Render import qualified Data.Vector.Unboxed.Mutable as UMV +import Dodge.Data.Universe +import Dodge.Render.Lights +import Dodge.Render.Picture +import Dodge.Render.ShapePicture +import Dodge.Render.Walls +import Foreign +import Geometry import Graphics.GL.Core43 ---import qualified Streaming.Prelude as S +import Graphics.Rendering.OpenGL hiding (color, rotate, scale, translate) +import MatrixHelper +import Render +import qualified SDL +import Shader +import Shader.Bind +import Shader.Data +import Shader.ExtraPrimitive +import Shader.Parameters +import Shader.Poke doDrawing :: RenderData -> Universe -> IO Word32 doDrawing pdata u = do sTicks <- SDL.ticks - let w = _uvWorld u - cfig = _uvConfig u - rot = _cameraRot (_cWorld w) + let w = _uvWorld u + cfig = _uvConfig u + rot = _cameraRot (_cWorld w) camzoom = _cameraZoom (_cWorld w) - trans = _cameraCenter (_cWorld w) + trans = _cameraCenter (_cWorld w) wins@(V2 winx winy) = V2 (_windowX cfig) (_windowY cfig) - resFact = resFactorNum $ cfig ^. graphics_resolution_factor - (wallPointsCol,windowPoints,wallSPics) = wallsToDraw w - lightPoints = lightsToRender cfig w - viewFroms@(V2 vfx vfy) = _cameraViewFrom (_cWorld w) - viewFrom3d = Vector3 vfx vfy 20 - shadV = _pictureShaders pdata - lwShad = _lightingWallShadShader pdata + resFact = resFactorNum $ cfig ^. graphics_resolution_factor + (wallPointsCol, windowPoints, wallSPics) = wallsToDraw w + lightPoints = lightsToRender cfig w + viewFroms@(V2 vfx vfy) = _cameraViewFrom (_cWorld w) + viewFrom3d = Vector3 vfx vfy 20 + shadV = _pictureShaders pdata + lwShad = _lightingWallShadShader pdata -- bind as much data into vbos as feasible at this point -- count mutable vectors setup - layerCounts <- UMV.replicate (numLayers*6) 0 + layerCounts <- UMV.replicate (numLayers * 6) 0 -- attempt to poke in parallel - let (ws,wp) = wallSPics <> worldSPic cfig w + let (ws, wp) = wallSPics <> worldSPic cfig w --( (nWalls, nWins , nFls),(nShapeVs, nIndices, nSilIndices) ) - ( (nWalls, nWins , nFls),(nShapeVs, nIndices, nSilIndices) ) - <- MP.bindM3 (\_ a b -> return (a,b)) + ((nWalls, nWins, nFls), (nShapeVs, nIndices, nSilIndices)) <- + MP.bindM3 + (\_ a b -> return (a, b)) ( pokeLayVerxs - shadV + shadV layerCounts wp ) ( pokeWallsWindowsFloor - (shadVBOptr $ _wallTextureShader pdata) - (shadVBOptr $ _windowShader pdata) + (shadVBOptr $ _wallTextureShader pdata) + (shadVBOptr $ _windowShader pdata) (shadVBOptr $ _textureArrayShader pdata) wallPointsCol windowPoints @@ -70,41 +69,42 @@ doDrawing pdata u = do (_vboPtr $ _vaoVBO $ _shadVAO $ _shapeShader pdata) (_eboPtr $ _shapeEBO pdata) (_eboPtr $ _silhouetteEBO pdata) - (0,0,0) + (0, 0, 0) ws ) --- ( pokeSPics --- shadV --- layerCounts --- (_vboPtr $ _vaoVBO $ _shadVAO $ _shapeShader pdata) --- (_eboPtr $ _shapeEBO pdata) --- (_eboPtr $ _silhouetteEBO pdata) --- (S.cons wallSPics $ worldSPic cfig w) --- ) --- <- MP.bindM3 (\ _ wlwifl counts -> return (wlwifl,counts)) --- ( pokeBindFoldableLayer shadV layerCounts wp) --- ( pokeWallsWindowsFloor --- (shadVBOptr $ _wallTextureShader pdata) --- (shadVBOptr $ _windowShader pdata) --- (shadVBOptr $ _textureArrayShader pdata) --- wallPointsCol --- windowPoints --- (_floorTiles w) --- ) --- ( pokeShape --- (_vboPtr $ _vaoVBO $ _shadVAO $ _shapeShader pdata) --- (_eboPtr $ _shapeEBO pdata) --- (_eboPtr $ _silhouetteEBO pdata) --- ws --- ) + -- ( pokeSPics + -- shadV + -- layerCounts + -- (_vboPtr $ _vaoVBO $ _shadVAO $ _shapeShader pdata) + -- (_eboPtr $ _shapeEBO pdata) + -- (_eboPtr $ _silhouetteEBO pdata) + -- (S.cons wallSPics $ worldSPic cfig w) + -- ) + -- <- MP.bindM3 (\ _ wlwifl counts -> return (wlwifl,counts)) + -- ( pokeBindFoldableLayer shadV layerCounts wp) + -- ( pokeWallsWindowsFloor + -- (shadVBOptr $ _wallTextureShader pdata) + -- (shadVBOptr $ _windowShader pdata) + -- (shadVBOptr $ _textureArrayShader pdata) + -- wallPointsCol + -- windowPoints + -- (_floorTiles w) + -- ) + -- ( pokeShape + -- (_vboPtr $ _vaoVBO $ _shadVAO $ _shapeShader pdata) + -- (_eboPtr $ _shapeEBO pdata) + -- (_eboPtr $ _silhouetteEBO pdata) + -- ws + -- ) -- bind wall points, silhouette data, surface geometry bindShaderLayers shadV layerCounts - uncurry bindShaderBuffers $ unzip - [ ( _wallTextureShader pdata, nWalls) - , (_shapeShader pdata, nShapeVs) - , (_windowShader pdata, nWins) - , (_textureArrayShader pdata, nFls) - ] + uncurry bindShaderBuffers $ + unzip + [ (_wallTextureShader pdata, nWalls) + , (_shapeShader pdata, nShapeVs) + , (_windowShader pdata, nWins) + , (_textureArrayShader pdata, nFls) + ] bindBuffer ElementArrayBuffer $= Just (_ebo $ _shapeEBO pdata) bufferSubData ElementArrayBuffer @@ -124,16 +124,17 @@ doDrawing pdata u = do setViewportSize (round winx `div` resFact) (round winy `div` resFact) bindFramebuffer Framebuffer $= fst (_fboBase pdata) clearColor $= Color4 0 0 0 0 - clear [ColorBuffer,DepthBuffer] + clear [ColorBuffer, DepthBuffer] depthFunc $= Just Less -- draw wall occlusions from the camera's point of view currentProgram $= Just (_shadProg lwShad) - uniform (head $ _shadUnis lwShad) $= viewFrom3d + uniform (head $ _shadUnis lwShad) $= viewFrom3d bindVertexArrayObject $= Just (_vao $ _shadVAO lwShad) - unless (debugOn Remove_LOS cfig) $ glDrawArrays - (marshalEPrimitiveMode $ _shadPrim lwShad) - 0 - (fromIntegral nWalls) + unless (debugOn Remove_LOS cfig) $ + glDrawArrays + (marshalEPrimitiveMode $ _shadPrim lwShad) + 0 + (fromIntegral nWalls) --draw walls onto base buffer if cfig ^. graphics_wall_textured then renderTextureWalls pdata nWalls @@ -145,43 +146,43 @@ doDrawing pdata u = do currentProgram $= Just (_shadProg fs) bindVertexArrayObject $= Just (_vao $ _shadVAO fs) glDrawElements - (marshalEPrimitiveMode $ _shadPrim fs) + (marshalEPrimitiveMode $ _shadPrim fs) (fromIntegral nIndices) GL_UNSIGNED_SHORT nullPtr --draw floor onto base buffer --- nTextArrayVs <- pokePoint33s (shadVBOptr $ _textureArrayShader pdata) (_floorTiles w) + -- nTextArrayVs <- pokePoint33s (shadVBOptr $ _textureArrayShader pdata) (_floorTiles w) drawShader (_textureArrayShader pdata) nFls --draw lightmap into its own buffer bindFramebuffer Framebuffer $= fst (_fboLighting pdata) createLightMap - pdata - lightPoints - nWalls - nSilIndices - nIndices + pdata + lightPoints + nWalls + nSilIndices + nIndices (_graphics_object_shadows $ _uvConfig u) (snd $ snd $ _fboBase pdata) - colorMask $= Color4 Enabled Enabled Enabled Enabled - clearColor $= Color4 0 0 0 0 + colorMask $= Color4 Enabled Enabled Enabled Enabled + clearColor $= Color4 0 0 0 0 --apply lightmap to base buffer bindFramebuffer Framebuffer $= fst (_fboBase pdata) - textureBinding Texture2D $= Just (snd $ _fboLighting pdata) - blend $= Enabled - blendFunc $= (Zero, OneMinusSrcColor) + textureBinding Texture2D $= Just (snd $ _fboLighting pdata) + blend $= Enabled + blendFunc $= (Zero, OneMinusSrcColor) drawShader (_fullscreenShader pdata) 4 --draw bloom onto bloom buffer bindFramebuffer Framebuffer $= fst (_fboBloom pdata) clear [ColorBuffer] depthFunc $= Just Less - blendFunc $= (SrcAlpha,OneMinusSrcAlpha) + blendFunc $= (SrcAlpha, OneMinusSrcAlpha) depthMask $= Disabled renderLayer BloomNoZWrite shadV layerCounts depthMask $= Enabled renderLayer BloomLayer shadV layerCounts --depthMask $= Enabled --setup downscale viewport for blurring bloom - setViewportSize (round winx `div` (2*resFact)) (round winy `div` (2*resFact)) + setViewportSize (round winx `div` (2 * resFact)) (round winy `div` (2 * resFact)) bindFramebuffer Framebuffer $= fst (_fboHalf1 pdata) depthFunc $= Just Always textureBinding Texture2D $= Just (snd $ _fboBloom pdata) @@ -198,8 +199,8 @@ doDrawing pdata u = do --blendFunc $= (SrcAlphaSaturate,One) --blendColor $= Color4 0.5 0.5 0.5 0.5 --blendFuncSeparate $= ((SrcAlphaSaturate,One) , (One,OneMinusSrcAlpha)) - blendFuncSeparate $= ((SrcAlpha,OneMinusSrcAlpha),(One,OneMinusSrcAlpha)) - drawBuffers $= [FBOColorAttachment 0,NoBuffers] + blendFuncSeparate $= ((SrcAlpha, OneMinusSrcAlpha), (One, OneMinusSrcAlpha)) + drawBuffers $= [FBOColorAttachment 0, NoBuffers] clear [ColorBuffer] renderLayer MidLayer shadV layerCounts --renderWindows pdata windowPoints @@ -208,14 +209,19 @@ doDrawing pdata u = do ----render transparency depths depthMask $= Enabled blend $= Disabled - drawBuffers $= [NoBuffers,FBOColorAttachment 1] + drawBuffers $= [NoBuffers, FBOColorAttachment 1] renderLayer MidLayer shadV layerCounts drawShader (_windowShader pdata) nWins ----draw lightmap for cloud buffer depthMask $= Disabled blend $= Enabled bindFramebuffer Framebuffer $= fst (_fboLighting pdata) - createLightMap pdata lightPoints nWalls nSilIndices nIndices + createLightMap + pdata + lightPoints + nWalls + nSilIndices + nIndices (_graphics_object_shadows $ _uvConfig u) (snd $ snd $ _fboCloud pdata) colorMask $= Color4 Enabled Enabled Enabled Enabled @@ -224,12 +230,12 @@ doDrawing pdata u = do clearColor $= Color4 0 0 0 0 bindFramebuffer Framebuffer $= fst (_fboCloud pdata) depthMask $= Disabled - drawBuffers $= [FBOColorAttachment 0,NoBuffers] + drawBuffers $= [FBOColorAttachment 0, NoBuffers] depthFunc $= Just Always textureBinding Texture2D $= Just (snd $ _fboLighting pdata) blend $= Enabled --blendFunc $= (Zero, OneMinusSrcAlpha) - blendFuncSeparate $= ((Zero, OneMinusSrcColor),(Zero, One)) + blendFuncSeparate $= ((Zero, OneMinusSrcColor), (Zero, One)) drawShader (_fullscreenShader pdata) 4 blendFunc $= (SrcAlpha, OneMinusSrcAlpha) -- bind base buffer for drawing bloom then clouds @@ -246,7 +252,7 @@ doDrawing pdata u = do --set viewport for radial distortion setViewportSize (round winx) (round winy) depthFunc $= Just Always - blendFunc $= (One,Zero) + blendFunc $= (One, Zero) -- perform any radial distortion case _distortions (_cWorld w) of [] -> do @@ -257,31 +263,33 @@ doDrawing pdata u = do rds -> do let bindDrawDist :: Distortion -> IO () bindDrawDist (RadialDistortion (V2 a b) (V2 c d) (V2 e f) g) = do - pokeArray (shadVBOptr $ _barrelShader pdata) [a,b,c,d,e,f,g] + pokeArray (shadVBOptr $ _barrelShader pdata) [a, b, c, d, e, f, g] bindShaderBuffers [_barrelShader pdata] [1] drawShader (_barrelShader pdata) 1 - fboList = take (length rds - 1) (concat (repeat [fst $ _fbo2 pdata,fst $ _fbo3 pdata])) - ++ [defaultFramebufferObject] - toList = fst (snd (_fboBase pdata)) : concat (repeat [snd $ _fbo2 pdata,snd $ _fbo3 pdata]) + fboList = + take (length rds - 1) (concat (repeat [fst $ _fbo2 pdata, fst $ _fbo3 pdata])) + ++ [defaultFramebufferObject] + toList = fst (snd (_fboBase pdata)) : concat (repeat [snd $ _fbo2 pdata, snd $ _fbo3 pdata]) bindings = zipWith (>>) (map bindFBO fboList) (map bindTO toList) activeTexture $= TextureUnit 1 zipWithM_ (>>) bindings $ map bindDrawDist rds activeTexture $= TextureUnit 0 depthFunc $= Just Always blend $= Enabled - blendFunc $= (SrcAlpha,OneMinusSrcAlpha) + blendFunc $= (SrcAlpha, OneMinusSrcAlpha) renderLayer DebugLayer shadV layerCounts -- draw overlay depthFunc $= Just Always depthMask $= Disabled blend $= Enabled - blendFunc $= (SrcAlpha,OneMinusSrcAlpha) + blendFunc $= (SrcAlpha, OneMinusSrcAlpha) bufferUBO $ isoMatrix 0 1 (V2 0 0) (V2 2 2) renderLayer FixedCoordLayer shadV layerCounts renderFoldable shadV $ fixedCoordPictures u depthMask $= Enabled eTicks <- SDL.ticks return (eTicks - sTicks) + -------------------------------------------------------------------------------- -- note: currently assume there is only one UBO, we only bind it once at setup bufferUBO :: [Float] -> IO () @@ -289,24 +297,27 @@ bufferUBO mat = withArray mat $ \ptr -> bufferSubData UniformBuffer WriteToBuffer 0 64 ptr setViewportSize :: Int -> Int -> IO () -setViewportSize x y = viewport $= - ( Position 0 0 - , Size (fromIntegral x) (fromIntegral y) - ) +setViewportSize x y = + viewport + $= ( Position 0 0 + , Size (fromIntegral x) (fromIntegral y) + ) -renderBlankWalls - :: RenderData - -> Int -- ^ number of walls - -> IO () +renderBlankWalls :: + RenderData -> + -- | number of walls + Int -> + IO () renderBlankWalls pdata nWalls = do cullFace $= Just Back drawShader (_wallBlankShader pdata) nWalls cullFace $= Nothing -renderTextureWalls - :: RenderData - -> Int -- ^ number of walls - -> IO () +renderTextureWalls :: + RenderData -> + -- | number of walls + Int -> + IO () renderTextureWalls pdata nWalls = do cullFace $= Just Back drawShader (_wallTextureShader pdata) nWalls diff --git a/src/Dodge/Render/HUD.hs b/src/Dodge/Render/HUD.hs index c6ee4e8e4..46d243e3d 100644 --- a/src/Dodge/Render/HUD.hs +++ b/src/Dodge/Render/HUD.hs @@ -1,53 +1,48 @@ --{-# LANGUAGE TupleSections #-} -module Dodge.Render.HUD - ( hudDrawings - ) where -import Dodge.WorldPos -import Dodge.Data -import Dodge.Tweak.Show -import Dodge.Item.Display -import Dodge.Combine -import Dodge.Clock +module Dodge.Render.HUD ( + hudDrawings, +) where + +import Control.Lens +import qualified Data.Map.Strict as M +import Data.Maybe +import qualified Data.Text as T +import qualified Data.Vector as V import Dodge.Base ---import Dodge.InputFocus ---import Dodge.Combine.Combinations +import Dodge.Clock +import Dodge.Combine +import Dodge.Data.Universe import Dodge.Inventory import Dodge.Inventory.ItemSpace +import Dodge.Item.Display import Dodge.Render.Connectors import Dodge.Render.List -import Picture +import Dodge.Tweak.Show +import Dodge.WorldPos import Geometry -import Padding -import ListHelp - -import qualified Data.Vector as V ---import Data.Foldable -import Data.Maybe import qualified IntMapHelp as IM -import qualified Data.Map.Strict as M ---import qualified Data.Set as S ---import qualified Data.IntSet as IS -import Control.Lens +import ListHelp +import Padding +import Picture import SDL (MouseButton (..)) -import qualified Data.Text as T ---import Data.List ---import Data.Bifunctor hudDrawings :: Universe -> Picture hudDrawings uv = case _hudElement $ _hud (_cWorld w) of DisplayCarte -> drawCarte cfig w - DisplayInventory subinv -> drawInGameHUD uv - <> subInventoryDisplay subinv cfig w + DisplayInventory subinv -> + drawInGameHUD uv + <> subInventoryDisplay subinv cfig w where w = _uvWorld uv cfig = _uvConfig uv drawInGameHUD :: Universe -> Picture -drawInGameHUD uv = pictures - [ winScale cfig . dShadCol white $ displayHP 0 cfig w - , listPicturesAt (halfWidth cfig) 0 cfig $ map text (_uvTestString uv uv) - , inventoryDisplay cfig w - ] +drawInGameHUD uv = + pictures + [ winScale cfig . dShadCol white $ displayHP 0 cfig w + , listPicturesAt (halfWidth cfig) 0 cfig $ map text (_uvTestString uv uv) + , inventoryDisplay cfig w + ] where w = _uvWorld uv cfig = _uvConfig uv @@ -57,13 +52,14 @@ inventoryDisplay cfig w = listPicturesAt 0 0 cfig invlist where cr = you w inv = _crInv cr - invlist = concatMap (itemText' cr) (IM.toList inv) - ++ displayFreeSlots - ++ concatMap (closeObjectToTextPictures nfreeslots) (_closeObjects (_cWorld w)) --- ++ map floorItemsColor (concatMap (closeObjectToTextPictures nfreeslots) (_closeObjects w)) --- floorItemsColor = case _hudElement (_hud w) of --- DisplayInventory NoSubInventory -> id --- _ -> color invDimColor + invlist = + concatMap (itemText' cr) (IM.toList inv) + ++ displayFreeSlots + ++ concatMap (closeObjectToTextPictures nfreeslots) (_closeObjects (_cWorld w)) + -- ++ map floorItemsColor (concatMap (closeObjectToTextPictures nfreeslots) (_closeObjects w)) + -- floorItemsColor = case _hudElement (_hud w) of + -- DisplayInventory NoSubInventory -> id + -- _ -> color invDimColor nfreeslots = crNumFreeSlots cr displayFreeSlots = case nfreeslots of 0 -> [color invDimColor . text $ " INVENTORY FULL"] @@ -73,58 +69,72 @@ inventoryDisplay cfig w = listPicturesAt 0 0 cfig invlist subInventoryDisplay :: SubInventory -> Configuration -> World -> Picture subInventoryDisplay subinv cfig w = case subinv of LockedInventory -> mempty -- topInvCursor col cursPos cfig w - NoSubInventory -> pictures - [ selcursor - , closeobjectcursor - , equipcursors - , equipcursor -- the order is important, this should go on top of the other equipcursors - , rboptions - ] - TweakInventory mtweaki -> pictures - --[ mCurs it cfig w - [ selcursor' listCursorNESW --- , cursorsZ cfig curpos it - , fromMaybe mempty $ do - tweaki <- mtweaki + NoSubInventory -> + pictures + [ selcursor + , closeobjectcursor + , equipcursors + , equipcursor -- the order is important, this should go on top of the other equipcursors + , rboptions + ] + TweakInventory mtweaki -> + pictures + --[ mCurs it cfig w + [ selcursor' listCursorNESW + , -- , cursorsZ cfig curpos it + fromMaybe mempty $ do + tweaki <- mtweaki -- consider moving this functionality out into a tweaks module - tparam <- it ^? _Just . itTweaks . tweakParams . ix tweaki - return $ lnkMidInvSel cfig w curpos tweaki - <> listCursorNSW subInvX 60 cfig tweaki white (length $ showTweak tparam) 1 - , invHead cfig "TWEAK" - , listPicturesAt subInvX 60 cfig $ map text (ammoTweakStrings it) - ] + tparam <- it ^? _Just . itTweaks . tweakParams . ix tweaki + return $ + lnkMidInvSel cfig w curpos tweaki + <> listCursorNSW subInvX 60 cfig tweaki white (length $ showTweak tparam) 1 + , invHead cfig "TWEAK" + , listPicturesAt subInvX 60 cfig $ map text (ammoTweakStrings it) + ] DisplayTerminal tid -> displayTerminal tid cfig w - CombineInventory mi -> pictures - [ invHead cfig "COMBINE" - , listPicturesAt subInvX 60 cfig $ combineListStringPictures w - , fromMaybe mempty $ do - i <- mi - cpos <- combinePoss w !? i - col <- (combineItemListYou w !? i) <&> _itInvColor . snd - return $ pictures - [ fromMaybe mempty $ do - strs <- fmap (fst . snd) (combineListInfo w !? i) - return $ listPicturesAtOff (subInvX + 150) 60 cfig cpos $ map (color red . text) strs - , fromMaybe mempty $ do - csize <- combineSizes w !? i - return $ listCursorNSW subInvX 60 cfig cpos col 15 csize - , fromMaybe mempty $ do - lnks <- map fst (combineItemListYou w) !? i - return $ lnkMidPosInvSelsCol cfig w cpos col lnks - <> foldMap (topCursorTypeWidth listCursorNESW (topInvW +2) cfig w) lnks - <> combineCounts cfig w lnks - ] - ] - InspectInventory -> mconcat - [ selcursor' listCursorNESW - , invHead cfig "INSPECT" - , listPicturesAt subInvX 60 cfig $ map text (itmInfo it) - ] - where + CombineInventory mi -> + pictures + [ invHead cfig "COMBINE" + , listPicturesAt subInvX 60 cfig $ combineListStringPictures w + , fromMaybe mempty $ do + i <- mi + cpos <- combinePoss w !? i + col <- (combineItemListYou w !? i) <&> _itInvColor . snd + return $ + pictures + [ fromMaybe mempty $ do + strs <- fmap (fst . snd) (combineListInfo w !? i) + return $ listPicturesAtOff (subInvX + 150) 60 cfig cpos $ map (color red . text) strs + , fromMaybe mempty $ do + csize <- combineSizes w !? i + return $ listCursorNSW subInvX 60 cfig cpos col 15 csize + , fromMaybe mempty $ do + lnks <- map fst (combineItemListYou w) !? i + return $ + lnkMidPosInvSelsCol cfig w cpos col lnks + <> foldMap (topCursorTypeWidth listCursorNESW (topInvW + 2) cfig w) lnks + <> combineCounts cfig w lnks + ] + ] + InspectInventory -> + mconcat + [ selcursor' listCursorNESW + , invHead cfig "INSPECT" + , listPicturesAt subInvX 60 cfig $ map text (itmInfo it) + ] + where closeobjectcursor = case selectedCloseObject w of Nothing -> mempty - Just (i,co) -> listCursorNS - clObjFloatIn 0 cfig (selNumPos i w) (closeObjectCol co) topInvW (invSelSize i w) + Just (i, co) -> + listCursorNS + clObjFloatIn + 0 + cfig + (selNumPos i w) + (closeObjectCol co) + topInvW + (invSelSize i w) itcol = fromMaybe (greyN 0.5) (it ^? _Just . itInvColor) cr = you w it = yourItem w @@ -134,15 +144,16 @@ subInventoryDisplay subinv cfig w = case subinv of | ButtonRight `M.member` _mouseButtons w = listCursorNESW | otherwise = listCursorNSW curpos = invSelPos w - cury = fromMaybe 1 $ augmentedInvSizes w IM.!? crSel (you w) + cury = fromMaybe 1 $ augmentedInvSizes w IM.!? crSel (you w) equipcursor = case _crLeftInvSel cr of Just invid -> f cyan invid (_crInvEquipped cr IM.! invid) _ -> mempty equipcursors = IM.foldMapWithKey (f yellow) (_crInvEquipped cr) f col invid epos = listTextPictureAt 144 0 cfig (selNumPos invid w) . color col $ text $ eqPosText epos - rboptions = if ButtonRight `M.member` _mouseButtons w - then drawRBOptions cfig w (_rbOptions w) - else mempty + rboptions = + if ButtonRight `M.member` _mouseButtons w + then drawRBOptions cfig w (_rbOptions w) + else mempty itmInfo :: Maybe Item -> [String] itmInfo mit = fromMaybe [] $ do @@ -152,38 +163,40 @@ itmInfo mit = fromMaybe [] $ do displayTerminal :: Int -> Configuration -> World -> Picture displayTerminal tid cfig w = fromMaybe mempty $ do tm <- w ^? cWorld . terminals . ix tid - return $ pictures - [ invHead cfig (_tmTitle tm ++ ":T" ++ show tid) - , renderListAt subInvX 60 cfig - . displayTermInput tm - . reverse - . take (_tmMaxLines tm) - $ _tmDisplayedLines tm - ] + return $ + pictures + [ invHead cfig (_tmTitle tm ++ ":T" ++ show tid) + , renderListAt subInvX 60 cfig + . displayTermInput tm + . reverse + . take (_tmMaxLines tm) + $ _tmDisplayedLines tm + ] where displayTermInput tm = case _tmInput tm of - TerminalInput s hasfoc _ -> (++ [(displayInputText tm s++displayBlinkCursor hasfoc,white)]) + TerminalInput s hasfoc _ -> (++ [(displayInputText tm s ++ displayBlinkCursor hasfoc, white)]) displayInputText tm s - | _tmStatus tm == TerminalReady = '>':T.unpack s + | _tmStatus tm == TerminalReady = '>' : T.unpack s | otherwise = "" - displayBlinkCursor hasfoc | hasfoc = clockCycle 10 (V.fromList ["_",""]) w + displayBlinkCursor hasfoc + | hasfoc = clockCycle 10 (V.fromList ["_", ""]) w | otherwise = [] drawRBOptions :: Configuration -> World -> RightButtonOptions -> Picture -drawRBOptions cfig w EquipOptions{_opEquip = es,_opSel=i, _opAllocateEquipment=ae} = - listPicturesAtOff 342 0 cfig (curpos-i) (map (text . eqPosText) es) - <> case ae of - DoNotMoveEquipment -> mempty - PutOnEquipment {} - -> midtext "PUT ONTO" - MoveEquipment {} - -> midtext "MOVE TO" <> extratext [] - SwapEquipment { _allocOldPos = oldp, _allocSwapID = sid } - -> midtext "MOVE TO" <> extratext ("SWAPS "++otheritem sid ++ " ONTO " ++eqPosText oldp) - ReplaceEquipment { _allocRemoveID = rid } - -> midtext "PUT ONTO" <> extratext ("REMOVES " ++ otheritem rid) - RemoveEquipment { } - -> midtext "TAKE OFF" +drawRBOptions cfig w EquipOptions{_opEquip = es, _opSel = i, _opAllocateEquipment = ae} = + listPicturesAtOff 342 0 cfig (curpos - i) (map (text . eqPosText) es) + <> case ae of + DoNotMoveEquipment -> mempty + PutOnEquipment{} -> + midtext "PUT ONTO" + MoveEquipment{} -> + midtext "MOVE TO" <> extratext [] + SwapEquipment{_allocOldPos = oldp, _allocSwapID = sid} -> + midtext "MOVE TO" <> extratext ("SWAPS " ++ otheritem sid ++ " ONTO " ++ eqPosText oldp) + ReplaceEquipment{_allocRemoveID = rid} -> + midtext "PUT ONTO" <> extratext ("REMOVES " ++ otheritem rid) + RemoveEquipment{} -> + midtext "TAKE OFF" where midtext str = listTextPictureAt 252 0 cfig curpos (text str) extratext str = listTextPictureAt 432 0 cfig curpos (text (str ++ deactivatetext)) @@ -196,13 +209,13 @@ drawRBOptions _ _ _ = mempty eqPosText :: EquipPosition -> String eqPosText ep = case ep of - OnHead -> "HEAD" - OnChest -> "CHEST" - OnBack -> "BACK" - OnLeftWrist -> "L.WRIST" - OnRightWrist -> "R.WRIST" - OnLegs -> "LEGS" - OnSpecial -> "EQUIPPED" + OnHead -> "HEAD" + OnChest -> "CHEST" + OnBack -> "BACK" + OnLeftWrist -> "L.WRIST" + OnRightWrist -> "R.WRIST" + OnLegs -> "LEGS" + OnSpecial -> "EQUIPPED" topInvW :: Int topInvW = 15 @@ -211,19 +224,20 @@ subInvX :: Float subInvX = 9 * fromIntegral topInvW + 50 lnkMidInvSel :: Configuration -> World -> Int -> Int -> Picture -lnkMidInvSel cfig w lefti midi = winScale cfig - . color white - . zConnect rp $ selNumMidHeight cfig w lefti +lnkMidInvSel cfig w lefti midi = + winScale cfig + . color white + . zConnect rp + $ selNumMidHeight cfig w lefti where --- lp ipos = V2 (150 - hw) ( hh - (20 * fromIntegral ipos + 17.5)) - rp = V2 (190 - hw) ( hh - (20 * fromIntegral midi + 77.5)) + -- lp ipos = V2 (150 - hw) ( hh - (20 * fromIntegral ipos + 17.5)) + rp = V2 (190 - hw) (hh - (20 * fromIntegral midi + 77.5)) hh = halfHeight cfig - hw = halfWidth cfig - + hw = halfWidth cfig --lnkMidPosInvSels :: Configuration -> World -> Int -> [Int] -> Picture ---lnkMidPosInvSels cfig w i = winScale cfig --- . color white +--lnkMidPosInvSels cfig w i = winScale cfig +-- . color white -- . concatMap (zConnect rp . selNumMidHeight cfig w) -- where ---- lp ipos = V2 (150 - hw) ( hh - (20 * fromIntegral ipos + 17.5)) @@ -234,32 +248,38 @@ lnkMidInvSel cfig w lefti midi = winScale cfig combineCounts :: Configuration -> World -> [Int] -> Picture combineCounts cfig w = winScale cfig . foldMap f . group where - f (i:is) = case yourInv w ^? ix i . itUse . useAmount of - Just _ -> color (selNumCol i w) $ uncurryV translate (selNumTextPos cfig w i) . scale 0.1 0.1 . text $ ('-': show (length is + 1)) + f (i : is) = case yourInv w ^? ix i . itUse . useAmount of + Just _ -> color (selNumCol i w) $ uncurryV translate (selNumTextPos cfig w i) . scale 0.1 0.1 . text $ ('-' : show (length is + 1)) _ -> mempty f _ = mempty lnkMidPosInvSelsCol :: Configuration -> World -> Int -> Color -> [Int] -> Picture -lnkMidPosInvSelsCol cfig w i col = winScale cfig - . foldMap (\j -> zConnectCol rp (V2 18 0+selNumMidHeight cfig w j) col white white (selNumCol j w)) +lnkMidPosInvSelsCol cfig w i col = + winScale cfig + . foldMap (\j -> zConnectCol rp (V2 18 0 + selNumMidHeight cfig w j) col white white (selNumCol j w)) where --- lp ipos = V2 (150 - hw) ( hh - (20 * fromIntegral ipos + 17.5)) - rp = V2 (190 - hw) ( hh - (20 * fromIntegral i + 77.5)) + -- lp ipos = V2 (150 - hw) ( hh - (20 * fromIntegral ipos + 17.5)) + rp = V2 (190 - hw) (hh - (20 * fromIntegral i + 77.5)) hh = halfHeight cfig - hw = halfWidth cfig + hw = halfWidth cfig -topCursorTypeWidth :: (Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture) - -> Int - -> Configuration -> World -> Int -> Picture -topCursorTypeWidth ctype width cfig w i - = ctype 0 0 cfig (selNumPos i w) (selNumCol i w) width (selNumSlots i w) +topCursorTypeWidth :: + (Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture) -> + Int -> + Configuration -> + World -> + Int -> + Picture +topCursorTypeWidth ctype width cfig w i = + ctype 0 0 cfig (selNumPos i w) (selNumCol i w) width (selNumSlots i w) determineInvSelCursorWidth :: World -> Int determineInvSelCursorWidth w = case _rbOptions w of NoRightButtonOptions -> topInvW - EquipOptions {} -> if ButtonRight `M.member` _mouseButtons w - then 47 - else topInvW + EquipOptions{} -> + if ButtonRight `M.member` _mouseButtons w + then 47 + else topInvW --listSelHeight :: Configuration -> World -> Int -> Float --listSelHeight @@ -278,74 +298,77 @@ tweakString :: TweakParam -> String tweakString tp = rightPad 12 ' ' (show $ _tweakType tp) ++ " " ++ showTweak tp invHead :: Configuration -> String -> Picture -invHead cfig s = winScale cfig - . translate (-halfWidth cfig + subInvX + 20) (halfHeight cfig - 40) - . dShadCol white - . scale 0.4 0.4 - $ text s +invHead cfig s = + winScale cfig + . translate (- halfWidth cfig + subInvX + 20) (halfHeight cfig - 40) + . dShadCol white + . scale 0.4 0.4 + $ text s invDimColor :: Color invDimColor = greyN 0.7 + closeObjectToTextPictures :: Int -> Either FloorItem Button -> [Picture] closeObjectToTextPictures nfreeslots e = case e of Left flit -> let it = _flIt flit in map (applycolor it . textindent) $ itemDisplay it - Right bt -> [color yellow $ textindent $ _btText bt] + Right bt -> [color yellow $ textindent $ _btText bt] where - textindent = text . (replicate clObjIntIn ' '++) + textindent = text . (replicate clObjIntIn ' ' ++) applycolor it | nfreeslots >= itSlotsTaken it = color $ _itInvColor it | otherwise = color invDimColor clObjIntIn :: Int clObjIntIn = 2 + clObjFloatIn :: Float clObjFloatIn = fromIntegral clObjIntIn * 9 - drawCarte :: Configuration -> World -> Picture -drawCarte cfig w = pictures $ - renderListAt 0 0 cfig locs - : zipWith bConnect (displayListEndCoords cfig locTexts) locPoss - ++ mapOverlay cfig w - ++ [mainListCursor white iPos cfig] +drawCarte cfig w = + pictures $ + renderListAt 0 0 cfig locs : + zipWith bConnect (displayListEndCoords cfig locTexts) locPoss + ++ mapOverlay cfig w + ++ [mainListCursor white iPos cfig] where iPos = _selLocation (_cWorld w) - locs = map (\(_,s) -> (s,white)) . IM.elems . _seenLocations $ _cWorld w + locs = map (\(_, s) -> (s, white)) . IM.elems . _seenLocations $ _cWorld w locPoss = map (cartePosToScreen cfig w . ($ w) . doWorldPos . fst) . IM.elems . _seenLocations $ _cWorld w locTexts = map fst locs displayListEndCoords :: Configuration -> [String] -> [Point2] -displayListEndCoords cfig ss = map (doWindowScale cfig) $ zipWith h ss $ map f [1..] - where +displayListEndCoords cfig ss = map (doWindowScale cfig) $ zipWith h ss $ map f [1 ..] + where f :: Int -> Point2 - f i = V2 ( 15 - halfWidth cfig ) ( 2.5 + halfHeight cfig - (20 * fromIntegral i)) + f i = V2 (15 - halfWidth cfig) (2.5 + halfHeight cfig - (20 * fromIntegral i)) h :: String -> Point2 -> Point2 h s (V2 x y) = V2 (x + 9 * fromIntegral (length s)) y - mapOverlay :: Configuration -> World -> [Picture] -mapOverlay cfig w = (color (withAlpha 0.5 black) . polygon $ reverse $ rectNSWE 1 (-1) 1 (-1)) : - (mapMaybe (mapWall cfig w) . IM.elems $ _walls (_cWorld w)) +mapOverlay cfig w = + (color (withAlpha 0.5 black) . polygon $ reverse $ rectNSWE 1 (-1) 1 (-1)) : + (mapMaybe (mapWall cfig w) . IM.elems $ _walls (_cWorld w)) mapWall :: Configuration -> World -> Wall -> Maybe Picture mapWall cfig w wl = if _wlSeen wl - then Just . color c . polygon $ map (cartePosToScreen cfig w) [x,x +.+ n2,y +.+ n2, y] - else Nothing - where + then Just . color c . polygon $ map (cartePosToScreen cfig w) [x, x +.+ n2, y +.+ n2, y] + else Nothing + where t = normalizeV (y -.- x) n2 = 20 *.* vNormal t - (x,y) = _wlLine wl + (x, y) = _wlLine wl c = _wlColor wl - --selectedCloseObjectLink :: Configuration -> World -> Picture --selectedCloseObjectLink cfig w = mempty -{- | Pictures of popup text for items close to your position.-} +-- | Pictures of popup text for items close to your position. + --closeObjectTexts :: Configuration -> World -> Picture ---closeObjectTexts cfig w = pictures $ --- renderListAt pushout (negate 20 * fromIntegral invPos) cfig (map colAndText $ _closeObjects w) +--closeObjectTexts cfig w = pictures $ +-- renderListAt pushout (negate 20 * fromIntegral invPos) cfig (map colAndText $ _closeObjects w) -- : maybeToList maybeLine -- where -- colAndText (Left x) = ( _itName $ _flIt x, _itInvColor $ _flIt x) @@ -358,11 +381,11 @@ mapWall cfig w wl = -- maybeLeft (Left x) = Just x -- maybeLeft _ = Nothing -- pushout = 120 --- objPos obj = case obj of +-- objPos obj = case obj of -- Left flit -> _flItPos flit -- Right bt -> _btPos bt -- mayScreenPos = fmap (worldPosToScreen w . objPos) mayObj --- maybeLine = do +-- maybeLine = do -- itScreenPos <- mayScreenPos -- (theText,col) <- fmap colAndText mayObj -- let textWidth = 9 * fromIntegral (length theText) @@ -373,9 +396,9 @@ mapWall cfig w wl = mainListCursor :: Color -> Int -> Configuration -> Picture mainListCursor c = openCursorAt 120 c 5 0 -itemText' :: Creature -> (Int,Item) -> [Picture] +itemText' :: Creature -> (Int, Item) -> [Picture] {-# INLINE itemText' #-} -itemText' cr (i,it) = f $ case _itCurseStatus it of +itemText' cr (i, it) = f $ case _itCurseStatus it of UndroppableIdentified -> map (color yellow . text) (itemDisplay it) _ | crSel cr == i -> map (color thecolor . text) (selectedItemDisplay cr it) _ -> map (color thecolor . text) (itemDisplay it) @@ -383,40 +406,44 @@ itemText' cr (i,it) = f $ case _itCurseStatus it of thecolor = _itInvColor it f = take (itSlotsTaken it) . (++ replicate 10 (color (_itInvColor it) $ text "*")) - - itemText :: Item -> [Picture] {-# INLINE itemText #-} itemText it = f $ case _itCurseStatus it of UndroppableIdentified -> map (color yellow . text) (itemDisplay it) --- <> color (withAlpha 0.9 thecolor) (polygon (rectNSEW 110 (-65) 885 (-90))) + -- <> color (withAlpha 0.9 thecolor) (polygon (rectNSEW 110 (-65) 885 (-90))) _ -> map (color thecolor . text) (itemDisplay it) where thecolor = _itInvColor it f = take (itSlotsTaken it) . (++ replicate 10 (color (_itInvColor it) $ text "*")) -openCursorAt - :: Float -- ^ Width - -> Color - -> Float -- ^ x offset - -> Float -- ^ y offset - -> Int -- ^ y offset (discrete) - -> Configuration - -> Picture -openCursorAt wth col xoff yoff yint w = winScale w - . translate (xoff-halfWidth w) (halfHeight w - (20* fromIntegral yint + yoff) - 20) - $ lineCol - [(V2 wth 12.5 ,withAlpha 0 col) - ,(V2 0 12.5 ,col) - ,(V2 0 (-7.5),col) - ,(V2 wth (-7.5),withAlpha 0 col) - ] +openCursorAt :: + -- | Width + Float -> + Color -> + -- | x offset + Float -> + -- | y offset + Float -> + -- | y offset (discrete) + Int -> + Configuration -> + Picture +openCursorAt wth col xoff yoff yint w = + winScale w + . translate (xoff - halfWidth w) (halfHeight w - (20 * fromIntegral yint + yoff) - 20) + $ lineCol + [ (V2 wth 12.5, withAlpha 0 col) + , (V2 0 12.5, col) + , (V2 0 (-7.5), col) + , (V2 wth (-7.5), withAlpha 0 col) + ] displayHP :: Int -> Configuration -> World -> Picture -displayHP cid cfig w = translate (halfWidth cfig-80) (halfHeight cfig-20) - . scale 0.2 0.2 - . text - . leftPad 5 ' ' - . show - . _crHP - $ _creatures (_cWorld w) IM.! cid +displayHP cid cfig w = + translate (halfWidth cfig -80) (halfHeight cfig -20) + . scale 0.2 0.2 + . text + . leftPad 5 ' ' + . show + . _crHP + $ _creatures (_cWorld w) IM.! cid diff --git a/src/Dodge/Render/InfoBox.hs b/src/Dodge/Render/InfoBox.hs index 175167e74..c8040e99c 100644 --- a/src/Dodge/Render/InfoBox.hs +++ b/src/Dodge/Render/InfoBox.hs @@ -1,29 +1,26 @@ module Dodge.Render.InfoBox where -import Dodge.Data ---import Dodge.Base.Window ---import Dodge.Base.WinScale + +import Dodge.Base +import Dodge.Data.Universe import Dodge.Render.Connectors import Dodge.Render.List -import Dodge.Base -import Picture import Geometry +import Picture ---import qualified Control.Foldl as L ---import Control.Monad ---import Data.Maybe - -renderInfoListAt :: Float -> Float -> Configuration -> World -> (Point2,[String]) -> Picture -renderInfoListAt x y cfig w (p,ss) = renderListAt x y cfig (zip ss (repeat white)) - <> winScale cfig (color white $ lConnect (V2 (x-hw) (hh-25-y)) (worldPosToScreen w p)) - <> listCursorNSW x y cfig 0 white 19 (length ss) +renderInfoListAt :: Float -> Float -> Configuration -> World -> (Point2, [String]) -> Picture +renderInfoListAt x y cfig w (p, ss) = + renderListAt x y cfig (zip ss (repeat white)) + <> winScale cfig (color white $ lConnect (V2 (x - hw) (hh -25 - y)) (worldPosToScreen w p)) + <> listCursorNSW x y cfig 0 white 19 (length ss) where hw = halfWidth cfig hh = halfHeight cfig -renderInfoListsAt :: Float -> Float -> Configuration -> World -> [(Point2,[String])] -> Picture -renderInfoListsAt x y cfig w = - fst . foldr f (mempty,0) +renderInfoListsAt :: Float -> Float -> Configuration -> World -> [(Point2, [String])] -> Picture +renderInfoListsAt x y cfig w = + fst . foldr f (mempty, 0) where - f (p,ss) (pic,offset) = (pic <> renderInfoListAt x (y + offset) cfig w (p,ss) + f (p, ss) (pic, offset) = + ( pic <> renderInfoListAt x (y + offset) cfig w (p, ss) , offset + 20 * fromIntegral (length ss) ) diff --git a/src/Dodge/Render/Lights.hs b/src/Dodge/Render/Lights.hs index 800550465..64a570891 100644 --- a/src/Dodge/Render/Lights.hs +++ b/src/Dodge/Render/Lights.hs @@ -1,27 +1,27 @@ -module Dodge.Render.Lights - ( lightsToRender - ) where -import Dodge.Data ---import Dodge.CullBox -import Geometry +module Dodge.Render.Lights ( + lightsToRender, +) where import Data.Maybe +import Dodge.Data.Universe +import Geometry import qualified IntMapHelp as IM -lightsToRender :: Configuration -> World -> [(Point3,Float,Point3)] -lightsToRender cfig w = mapMaybe getLS (IM.elems $ _lightSources (_cWorld w)) - ++ mapMaybe getTLS (_tempLightSources (_cWorld w)) - where - getLS = getlsparam . _lsParam - getTLS = getlsparam . _tlsParam +lightsToRender :: Configuration -> World -> [(Point3, Float, Point3)] +lightsToRender cfig w = + mapMaybe getLS (IM.elems $ _lightSources (_cWorld w)) + ++ mapMaybe getTLS (_tempLightSources (_cWorld w)) + where + getLS = getlsparam . _lsParam + getTLS = getlsparam . _tlsParam cbox = _boundBox (_cWorld w) cpos = _cameraCenter (_cWorld w) getlsparam ls | not (pointInPolygon lpos cbox) && extraculltest = Nothing - | otherwise = Just ( _lsPos ls, rad^(2::Int) , _lsCol ls) + | otherwise = Just (_lsPos ls, rad ^ (2 :: Int), _lsCol ls) where lpos = xyV3 $ _lsPos ls - rad = _lsRad ls + rad = _lsRad ls extraculltest | debugOn Cull_more_lights cfig = True | otherwise = isNothing (intersectSegPolyFirst lpos (lpos +.+ rad *.* normalizeV (cpos -.- lpos)) cbox) diff --git a/src/Dodge/Render/List.hs b/src/Dodge/Render/List.hs index 0f099409f..95dc4f888 100644 --- a/src/Dodge/Render/List.hs +++ b/src/Dodge/Render/List.hs @@ -1,12 +1,12 @@ module Dodge.Render.List where -import Dodge.Data -import Dodge.Base.Window -import Dodge.Base.WinScale -import Picture -import Geometry ---import Control.Monad -import Data.Maybe + import Data.Foldable +import Data.Maybe +import Dodge.Base.WinScale +import Dodge.Base.Window +import Dodge.Data.Universe +import Geometry +import Picture -- given a list of pictures that are each the size of a "text" call, displays them as -- a list on the screen @@ -14,62 +14,72 @@ listPicturesAt :: Float -> Float -> Configuration -> [Picture] -> Picture listPicturesAt tx ty cfig = listPicturesAtOff tx ty cfig 0 listPicturesAtOff :: Float -> Float -> Configuration -> Int -> [Picture] -> Picture -listPicturesAtOff tx ty cfig i = mconcat . zipWith (listTextPictureAt tx ty cfig) [i..] +listPicturesAtOff tx ty cfig i = mconcat . zipWith (listTextPictureAt tx ty cfig) [i ..] -- displays a cursor that should match up to list text pictures -- the width of a character appears to be 9(?!) -- this is probably because it is 8 pixels plus one for the border listCursorChooseBorder :: [Bool] -> Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture -listCursorChooseBorder borders xoff yoff cfig yint col cursxsize cursysize = winScale cfig - . translate (6+xoff-halfWidth cfig) - (halfHeight cfig + 12.5 - (20* fromIntegral yint + yoff + 20 + hgt)) - . color col - $ chooseCursorBorders wth hgt borders +listCursorChooseBorder borders xoff yoff cfig yint col cursxsize cursysize = + winScale cfig + . translate + (6 + xoff - halfWidth cfig) + (halfHeight cfig + 12.5 - (20 * fromIntegral yint + yoff + 20 + hgt)) + . color col + $ chooseCursorBorders wth hgt borders where x = 9 - wth = x * fromIntegral cursxsize + 9 + wth = x * fromIntegral cursxsize + 9 hgt = 20 * fromIntegral cursysize + -- note we cannot simply scale lines because they are drawn as solid rectangles chooseCursorBorders :: Float -> Float -> [Bool] -> Picture -chooseCursorBorders wth hgt = fold . catMaybes . zipWith f - [ line [V2 0 hgt , V2 wth hgt ] - , line [V2 wth hgt , V2 wth 0 ] - , line [V2 wth 0 , V2 0 0 ] - , line [V2 0 0 , V2 0 hgt ] - ] +chooseCursorBorders wth hgt = + fold . catMaybes + . zipWith + f + [ line [V2 0 hgt, V2 wth hgt] + , line [V2 wth hgt, V2 wth 0] + , line [V2 wth 0, V2 0 0] + , line [V2 0 0, V2 0 hgt] + ] where f _ False = Nothing - f a True = Just a + f a True = Just a listCursorNS :: Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture -listCursorNS = listCursorChooseBorder [True,False,True] +listCursorNS = listCursorChooseBorder [True, False, True] listCursorNES :: Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture -listCursorNES = listCursorChooseBorder [True,True,True] +listCursorNES = listCursorChooseBorder [True, True, True] listCursorNESW :: Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture -listCursorNESW = listCursorChooseBorder [True,True,True,True] +listCursorNESW = listCursorChooseBorder [True, True, True, True] listCursorNSW :: Float -> Float -> Configuration -> Int -> Color -> Int -> Int -> Picture -listCursorNSW = listCursorChooseBorder [True,False,True,True] +listCursorNSW = listCursorChooseBorder [True, False, True, True] listTextPictureAt :: Float -> Float -> Configuration -> Int -> Picture -> Picture -listTextPictureAt xoff yoff cfig yint = winScale cfig - . translate (xoff + 15 - hw) (negate yoff + hh - (20 * (fromIntegral yint+1))) - . scale 0.1 0.1 +listTextPictureAt xoff yoff cfig yint = + winScale cfig + . translate (xoff + 15 - hw) (negate yoff + hh - (20 * (fromIntegral yint + 1))) + . scale 0.1 0.1 where - hw = halfWidth cfig + hw = halfWidth cfig hh = halfHeight cfig -renderListAt :: Float -> Float -> Configuration -> [(String,Color)] -> Picture -renderListAt tx ty cfig = listPicturesAt tx ty cfig . map (\(str,col) -> color col $ text str) +renderListAt :: Float -> Float -> Configuration -> [(String, Color)] -> Picture +renderListAt tx ty cfig = listPicturesAt tx ty cfig . map (\(str, col) -> color col $ text str) + -- concatMapPic (winScale cfig) . zipWith (listPairAt tx ty cfig) [0..] --TODO put the following functions in an appropriate place -{- | Colour picture and add black drop shadow. -} + +-- | Colour picture and add black drop shadow. dShadCol :: Color -> Picture -> Picture {-# INLINE dShadCol #-} -dShadCol c p = pictures - [ color black $ translate 1.2 (-1.2) p - , color c p - ] +dShadCol c p = + pictures + [ color black $ translate 1.2 (-1.2) p + , color c p + ] diff --git a/src/Dodge/Render/MenuScreen.hs b/src/Dodge/Render/MenuScreen.hs index 45d47c660..826d15a29 100644 --- a/src/Dodge/Render/MenuScreen.hs +++ b/src/Dodge/Render/MenuScreen.hs @@ -1,23 +1,23 @@ {- The menu picture. -} -module Dodge.Render.MenuScreen - ( menuScreen - ) where -import Dodge.Data -import Dodge.WindowLayout -import Dodge.Base.Window -import Picture -import Dodge.Menu -import Padding +module Dodge.Render.MenuScreen ( + menuScreen, +) where import qualified Data.Text as T +import Dodge.Base.Window +import Dodge.Data.Universe +import Dodge.Menu +import Dodge.WindowLayout +import Padding +import Picture menuScreen :: Universe -> ScreenLayer -> Picture menuScreen w screen = case screen of - OptionScreen {_scTitle = titf, _scOptions = mos, _scOptionsOffset = off} - -> drawOptions w (titf w) mos off "Use keys to navigate the menu" - (WaitScreen sf _) -> drawOptions w (sf w) [] 0 "" - (InputScreen inputstr help) -> drawOptions w ('>':T.unpack inputstr) [] 0 help - (DisplayScreen sd ) -> sd w + OptionScreen{_scTitle = titf, _scOptions = mos, _scOptionsOffset = off} -> + drawOptions w (titf w) mos off "Use keys to navigate the menu" + (WaitScreen sf _) -> drawOptions w (sf w) [] 0 "" + (InputScreen inputstr help) -> drawOptions w ('>' : T.unpack inputstr) [] 0 help + (DisplayScreen sd) -> sd w (ColumnsScreen titf pairs) -> drawTwoColumnsScreen (_uvConfig w) (titf w) pairs --displayStringList :: World -> [String] -> Picture @@ -30,40 +30,48 @@ menuScreen w screen = case screen of -- ys = [0,22..] -- f y s = translate (10-hw) y . scale 0.15 0.15 $ text s -drawTwoColumnsScreen :: Configuration -> String -> [(String,String)] -> Picture -drawTwoColumnsScreen cfig title lps = pictures - [darkenBackground cfig - ,drawTitle cfig title - ,drawTwoColumns cfig lps - ] +drawTwoColumnsScreen :: Configuration -> String -> [(String, String)] -> Picture +drawTwoColumnsScreen cfig title lps = + pictures + [ darkenBackground cfig + , drawTitle cfig title + , drawTwoColumns cfig lps + ] -drawTwoColumns :: Configuration -> [(String,String)] -> Picture -drawTwoColumns cfig lps = pictures $ zipWith f [hh-100,hh-130..] lps +drawTwoColumns :: Configuration -> [(String, String)] -> Picture +drawTwoColumns cfig lps = pictures $ zipWith f [hh -100, hh -130 ..] lps where - f y (s1,s2) = placeString (50-hw) y 0.15 $ rightPad ln '.' s1 ++ s2 + f y (s1, s2) = placeString (50 - hw) y 0.15 $ rightPad ln '.' s1 ++ s2 hh = halfHeight cfig - hw = halfWidth cfig + hw = halfWidth cfig ln = maximum (map (length . fst) lps) + 3 - -drawOptions - :: Universe - -> String -- ^ Title - -> [MenuOption] -- ^ Options - -> Int -- ^ Options offset - -> String -- ^ Help Text - -> Picture -drawOptions u title ops off footer = pictures $ - [ darkenBackground cfig - , drawTitle cfig title - , drawFooterText cfig red footer - ] ++ - zipWith (\s vpos -> placeString (-hw + 50) vpos 0.2 s) - ops'' - [hh-100,hh-150 ..] --- ++ [color yellow $ concat [line [V2 (negate hw) (hh-y), V2 hw (hh-y)] | --- y <- map (+75) [0,50..hh*2]] --- ] + +drawOptions :: + Universe -> + -- | Title + String -> + -- | Options + [MenuOption] -> + -- | Options offset + Int -> + -- | Help Text + String -> + Picture +drawOptions u title ops off footer = + pictures $ + [ darkenBackground cfig + , drawTitle cfig title + , drawFooterText cfig red footer + ] + ++ zipWith + (\s vpos -> placeString (- hw + 50) vpos 0.2 s) + ops'' + [hh -100, hh -150 ..] where + -- ++ [color yellow $ concat [line [V2 (negate hw) (hh-y), V2 hw (hh-y)] | + -- y <- map (+75) [0,50..hh*2]] + -- ] + maxOptionLength = 3 + maximum (0 : map (optionValueOffset u) ops') ops' = case availableMenuLines cfig of x | x < length ops -> take (availableMenuLines cfig) (drop off visibleops) @@ -72,36 +80,39 @@ drawOptions u title ops off footer = pictures $ x | x < length ops -> map (menuOptionToString u maxOptionLength) ops' ++ ["SPACE: MORE OPTIONS"] _ -> map (menuOptionToString u maxOptionLength) ops' visibleops = filter notInvisible ops - notInvisible InvisibleToggle {} = False + notInvisible InvisibleToggle{} = False notInvisible _ = True hh = halfHeight cfig - hw = halfWidth cfig + hw = halfWidth cfig cfig = _uvConfig u optionValueOffset :: Universe -> MenuOption -> Int optionValueOffset u mo = case _moString mo u of Left _ -> 0 - Right (s,_) -> length s + Right (s, _) -> length s darkenBackground :: Configuration -> Picture darkenBackground = color (withAlpha 0.5 black) . polygon . reverse . screenBox drawTitle :: Configuration -> String -> Picture -drawTitle cfig = placeString (-hw + 30) (hh - 50) 0.4 +drawTitle cfig = placeString (- hw + 30) (hh - 50) 0.4 where hh = halfHeight cfig - hw = halfWidth cfig + hw = halfWidth cfig -placeString - :: Float -- | x distance from center - -> Float -- | y distance from center - -> Float -- | scale - -> String - -> Picture +placeString :: + -- | x distance from center + Float -> + -- | y distance from center + Float -> + -- | scale + Float -> + String -> + Picture placeString x y sc = color white . translate x y . scale sc sc . text drawFooterText :: Configuration -> Color -> String -> Picture -drawFooterText cfig col = color col . placeString (-hw + 30) (-hh+10) 0.1 +drawFooterText cfig col = color col . placeString (- hw + 30) (- hh + 10) 0.1 where hh = halfHeight cfig hw = halfWidth cfig @@ -111,9 +122,9 @@ menuOptionToString w padAmount mo = theKeys ++ optionText where optionText = case _moString mo w of Left s -> s - Right (s,t) -> rightPad padAmount '.' s ++ t + Right (s, t) -> rightPad padAmount '.' s ++ t theKeys = case mo of - Toggle {_moKey = k} -> stc k : ":" - Toggle2 {_moKey1 = k1, _moKey2 = k2} -> stc k1 : '/' : stc k2 : ":" + Toggle{_moKey = k} -> stc k : ":" + Toggle2{_moKey1 = k1, _moKey2 = k2} -> stc k1 : '/' : stc k2 : ":" _ -> undefined stc = scodeToChar diff --git a/src/Dodge/Render/Picture.hs b/src/Dodge/Render/Picture.hs index c7a289066..bc3c427c3 100644 --- a/src/Dodge/Render/Picture.hs +++ b/src/Dodge/Render/Picture.hs @@ -1,28 +1,29 @@ ---{-# LANGUAGE TupleSections #-} -module Dodge.Render.Picture - ( fixedCoordPictures - ) where -import Dodge.Data ---import Dodge.Base.Window +module Dodge.Render.Picture ( + fixedCoordPictures, +) where + import Dodge.Base.WinScale +import Dodge.Data.Universe import Dodge.Render.HUD import Dodge.Render.MenuScreen import Geometry import Picture fixedCoordPictures :: Universe -> Picture -fixedCoordPictures u = case _menuLayers u of - [] -> pictures - [ hudDrawings u - , customMouseCursor cfig w - ] - (lay:_) -> setDepth (-1) . winScale cfig $ menuScreen u lay - where +fixedCoordPictures u = case _menuLayers u of + [] -> + pictures + [ hudDrawings u + , customMouseCursor cfig w + ] + (lay : _) -> setDepth (-1) . winScale cfig $ menuScreen u lay + where w = _uvWorld u cfig = _uvConfig u customMouseCursor :: Configuration -> World -> Picture -customMouseCursor cfig w = winScale cfig - . uncurryV translate (_mousePos w) - . color white - $ pictures [ line [V2 (-5) 0,V2 5 0] , line [V2 0 (-5),V2 0 5] ] +customMouseCursor cfig w = + winScale cfig + . uncurryV translate (_mousePos w) + . color white + $ pictures [line [V2 (-5) 0, V2 5 0], line [V2 0 (-5), V2 0 5]] diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index 582962bdb..526b527d7 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/src/Dodge/Render/ShapePicture.hs @@ -31,8 +31,8 @@ import Dodge.Data.Config import Dodge.Render.InfoBox import Dodge.Debug.Picture import Dodge.Picture.SizeInvariant -import Dodge.Data import Dodge.Zone +import Dodge.Data.World import Dodge.Base import Dodge.SoundLogic.LoadSound import Dodge.Graph diff --git a/src/Dodge/Render/ShapePicture.hs.orig b/src/Dodge/Render/ShapePicture.hs.orig index 97569e3f4..f895947ff 100644 --- a/src/Dodge/Render/ShapePicture.hs.orig +++ b/src/Dodge/Render/ShapePicture.hs.orig @@ -7,10 +7,9 @@ import Dodge.Config.Data import Dodge.Render.InfoBox import Dodge.Debug.Picture import Dodge.Picture.SizeInvariant -import Dodge.Data +import Dodge.Data.World import Dodge.Zone import Dodge.Base ---import Dodge.Base.Window import Dodge.SoundLogic.LoadSound import Dodge.Graph import Dodge.GameRoom @@ -18,16 +17,13 @@ import Dodge.Update.Camera import Dodge.Item.Draw import Dodge.Render.List import Dodge.Path ---import Dodge.Zone import Geometry import Geometry.Zone import ShapePicture import Picture import Sound.Data import Geometry.ConvexPoly ---import Dodge.Base.Collide ---import Data.Foldable import qualified IntMapHelp as IM -- Lazy? import qualified Data.Map.Strict as M --import qualified Data.Set as Set diff --git a/src/Dodge/Render/Walls.hs b/src/Dodge/Render/Walls.hs index c7cf2e299..d901e80d3 100644 --- a/src/Dodge/Render/Walls.hs +++ b/src/Dodge/Render/Walls.hs @@ -1,29 +1,32 @@ -module Dodge.Render.Walls - ( wallsToDraw - ) where -import Dodge.Zoning.World +module Dodge.Render.Walls ( + wallsToDraw, +) where + +import qualified Control.Foldl as L +import Control.Lens +import Dodge.Base.Wall +import Dodge.Data.World +import Dodge.Wall.Draw import Dodge.Zoning.Base import Dodge.Zoning.Wall -import Dodge.Data -import Dodge.Wall.Draw -import Dodge.Base.Wall +import Dodge.Zoning.World import Geometry import ShapePicture -import Control.Lens ---import Data.Maybe -import qualified Control.Foldl as L -wallsToDraw :: World -> ( [((Point2,Point2),Point4)] ,[((Point2,Point2),Point4)], SPic ) -wallsToDraw w - = ( wls, wins,spic) +wallsToDraw :: World -> ([((Point2, Point2), Point4)], [((Point2, Point2), Point4)], SPic) +wallsToDraw w = + (wls, wins, spic) where f wl = (_wlLine wl, _wlColor wl) - (wls, wins, spic) = L.fold - ((,,) - <$> L.prefilter wlOpaqueDraw (L.premap f L.list) - <*> L.prefilter wlSeeThroughDraw (L.premap f L.list) - <*> L.premap getWallSPic L.mconcat - ) (wlsFromIXs w $ zonesExtract (w ^. cWorld . wlZoning) $ zoneOfSight' wlZoneSize w) + (wls, wins, spic) = + L.fold + ( (,,) + <$> L.prefilter wlOpaqueDraw (L.premap f L.list) + <*> L.prefilter wlSeeThroughDraw (L.premap f L.list) + <*> L.premap getWallSPic L.mconcat + ) + (wlsFromIXs w $ zonesExtract (w ^. cWorld . wlZoning) $ zoneOfSight' wlZoneSize w) + --wallsToDraw -- :: World -- -> ( [((Point2,Point2),Point4)] ,[((Point2,Point2),Point4)], SPic ) @@ -31,26 +34,26 @@ wallsToDraw w -- = ( wls, wins,spic) -- where -- f wl = (_wlLine wl, _wlColor wl) --- (wls, wins, spic) = runIdentity $ L.purely S.fold_ +-- (wls, wins, spic) = runIdentity $ L.purely S.fold_ -- ((,,) -- <$> L.prefilter wlOpaqueDraw (L.premap f L.list) -- <*> L.prefilter wlSeeThroughDraw (L.premap f L.list) -- <*> L.premap getWallSPic L.mconcat -- ) (S.concat $ S.mapMaybe g $ zoneOfSight wlZoneSize w) -- g (V2 i j) = w ^? wlZoning . znObjects . ix i . ix j - + wlOpaqueDraw :: Wall -> Bool wlOpaqueDraw wl = wlIsOpaque wl && _wlHeight wl == 100 + wlSeeThroughDraw :: Wall -> Bool wlSeeThroughDraw wl = wlIsSeeThrough wl && _wlHeight wl == 100 getWallSPic :: Wall -> SPic getWallSPic wl = case wl ^? wlOpacity . opDraw of Nothing -> mempty - Just f -> drawWall f wl + Just f -> drawWall f wl -- (wins,wls) = partition theTest . IM.elems . IM.filter _wlUnshadowed $ wallsDoubleScreen cfig w -- theTest wl = case _wlOpacity wl of -- Opaque -> False -- _ -> True - diff --git a/src/Dodge/Room.hs b/src/Dodge/Room.hs index b88fe45d0..ed4a4ac3c 100644 --- a/src/Dodge/Room.hs +++ b/src/Dodge/Room.hs @@ -1,53 +1,56 @@ {- Specification of individual rooms. -} -module Dodge.Room - ( module Dodge.Room.Room - , module Dodge.Room.Breather - , module Dodge.Room.RoadBlock - , module Dodge.Room.LasTurret - , module Dodge.Room.Foreground - , module Dodge.LevelGen.Data - , module Dodge.Room.Procedural - , module Dodge.Room.Corridor - , module Dodge.Room.Link - , module Dodge.Room.Door - , module Dodge.Room.Airlock - , module Dodge.Room.LongDoor - , module Dodge.Room.LongRoom - , module Dodge.Room.Branch - , module Dodge.Room.Teleport - , module Dodge.Room.BlinkAcross - , module Dodge.Room.Start - , module Dodge.Room.Boss - , module Dodge.Room.Treasure - , module Dodge.Room.GlassLesson - , module Dodge.Room.Tanks - , module Dodge.Room.Containing - , module Dodge.Room.SensorDoor - , module Dodge.Room.Ngon - , module Dodge.Room.Pillar - ) where -import Dodge.Room.Room -import Dodge.Room.Breather -import Dodge.Room.RoadBlock -import Dodge.Room.LasTurret -import Dodge.Room.Treasure -import Dodge.Room.Boss -import Dodge.Room.Start -import Dodge.Room.Teleport -import Dodge.Room.Branch -import Dodge.Room.Foreground -import Dodge.Room.BlinkAcross +module Dodge.Room ( + module Dodge.Room.Room, + module Dodge.Room.Breather, + module Dodge.Room.Warning, + module Dodge.Room.RoadBlock, + module Dodge.Room.LasTurret, + module Dodge.Room.Foreground, + module Dodge.LevelGen.Data, + module Dodge.Room.Procedural, + module Dodge.Room.Corridor, + module Dodge.Room.Link, + module Dodge.Room.Door, + module Dodge.Room.Airlock, + module Dodge.Room.LongDoor, + module Dodge.Room.LongRoom, + module Dodge.Room.Branch, + module Dodge.Room.Teleport, + module Dodge.Room.BlinkAcross, + module Dodge.Room.Start, + module Dodge.Room.Boss, + module Dodge.Room.Treasure, + module Dodge.Room.GlassLesson, + module Dodge.Room.Tanks, + module Dodge.Room.Containing, + module Dodge.Room.SensorDoor, + module Dodge.Room.Ngon, + module Dodge.Room.Pillar, +) where + import Dodge.LevelGen.Data -import Dodge.Room.Procedural -import Dodge.Room.Corridor -import Dodge.Room.Link -import Dodge.Room.Door import Dodge.Room.Airlock +import Dodge.Room.BlinkAcross +import Dodge.Room.Boss +import Dodge.Room.Branch +import Dodge.Room.Breather +import Dodge.Room.Containing +import Dodge.Room.Corridor +import Dodge.Room.Door +import Dodge.Room.Foreground +import Dodge.Room.GlassLesson +import Dodge.Room.LasTurret +import Dodge.Room.Link import Dodge.Room.LongDoor import Dodge.Room.LongRoom -import Dodge.Room.GlassLesson -import Dodge.Room.Tanks -import Dodge.Room.Containing -import Dodge.Room.SensorDoor import Dodge.Room.Ngon import Dodge.Room.Pillar +import Dodge.Room.Procedural +import Dodge.Room.RoadBlock +import Dodge.Room.Room +import Dodge.Room.SensorDoor +import Dodge.Room.Start +import Dodge.Room.Tanks +import Dodge.Room.Teleport +import Dodge.Room.Treasure +import Dodge.Room.Warning diff --git a/src/Dodge/Room/Airlock.hs b/src/Dodge/Room/Airlock.hs index 895a13bd2..da00d3d36 100644 --- a/src/Dodge/Room/Airlock.hs +++ b/src/Dodge/Room/Airlock.hs @@ -1,157 +1,183 @@ {-# LANGUAGE TupleSections #-} + {- Rooms that contain two doors and a switch alternating both. -} module Dodge.Room.Airlock where + +import Dodge.Data.GenWorld +import Dodge.Default.Door +import Dodge.Default.Room +import Dodge.LevelGen.Data +import Dodge.LevelGen.Switch import Dodge.Placement.Instance import Dodge.Room.Foreground import Dodge.RoomLink -import Dodge.Default.Room -import Dodge.Default.Door -import Dodge.Data -import Dodge.LevelGen.Data -import Dodge.LevelGen.Switch -import RandomHelp import Geometry import Picture +import RandomHelp ---import Control.Lens -{- | A passage with a switch that opens forward access while closing backwards access. -} +-- | A passage with a switch that opens forward access while closing backwards access. airlock :: RandomGen g => State g Room -airlock = takeOne [airlock0,airlock90,airlockCrystal,airlockZ] +airlock = takeOne [airlock0, airlock90, airlockCrystal, airlockZ] + --airlock = takeOne [airlockCrystal] -{- | Straight airlock -} + +-- | Straight airlock airlock0 :: Room -airlock0 = defaultRoom - { _rmPolys = [ rectNSWE 100 0 0 40 , switchcut] - , _rmLinks = muout lnks ++ muin [last lnks] - , _rmPath = foldMap doublePairSet [(V2 20 95,V2 20 45) ,(V2 20 45,V2 20 5) ] - , _rmPmnts = - [pContID (PS (V2 (-35) 50) (negate $ pi/2)) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect) - $ \btid -> Just $ putDoubleDoorThen DoorObstacle thewall (WdBlNegate $ WdBlBtOn btid) 1 (V2 0 20) (V2 40 20) 2 - $ \_ _ -> Just $ putDoubleDoor DoorObstacle thewall (WdBlBtOn btid) (V2 0 80) (V2 40 80) 2 - , invisibleWall $ rectNSWE 60 40 (-40) (-30) - ,spanLightI (V2 (-2) 30) (V2 (-2) 70) - ,sps0 $ putShape $ thinHighBar 75 (V2 40 50) (V2 (-1) 50) - ] - , _rmBound = [rectNSWE 75 15 0 40,switchcut] - } - where +airlock0 = + defaultRoom + { _rmPolys = [rectNSWE 100 0 0 40, switchcut] + , _rmLinks = muout lnks ++ muin [last lnks] + , _rmPath = foldMap doublePairSet [(V2 20 95, V2 20 45), (V2 20 45, V2 20 5)] + , _rmPmnts = + [ pContID (PS (V2 (-35) 50) (negate $ pi / 2)) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect) $ + \btid -> Just $ + putDoubleDoorThen DoorObstacle thewall (WdBlNegate $ WdBlBtOn btid) 1 (V2 0 20) (V2 40 20) 2 $ + \_ _ -> Just $ putDoubleDoor DoorObstacle thewall (WdBlBtOn btid) (V2 0 80) (V2 40 80) 2 + , invisibleWall $ rectNSWE 60 40 (-40) (-30) + , spanLightI (V2 (-2) 30) (V2 (-2) 70) + , sps0 $ putShape $ thinHighBar 75 (V2 40 50) (V2 (-1) 50) + ] + , _rmBound = [rectNSWE 75 15 0 40, switchcut] + } + where thewall = switchWallCol col - switchcut = rectNSWE 65 35 (-40) 20 - lnks = [(V2 20 95,0) - ,(V2 20 5,pi) - ] + switchcut = rectNSWE 65 35 (-40) 20 + lnks = + [ (V2 20 95, 0) + , (V2 20 5, pi) + ] col = dim $ dim $ bright red -airlockDoor :: Color -> WdBl -> [(Point2,Point2)] -> PSType +airlockDoor :: Color -> WdBl -> [(Point2, Point2)] -> PSType airlockDoor col = PutDoor col DoorObstacle -airlockDoubleDoor :: Point2 -> Point2 -> Color -> WdBl -> [(Point2,Point2)] - -> [(Point2,Point2)] -> Maybe Placement -airlockDoubleDoor p1 p2 col cond outDoorps inDoorps = jspsJ p1 0 (airlockDoor col cond outDoorps) - $ sPS p2 0 (airlockDoor col cond inDoorps) +airlockDoubleDoor :: + Point2 -> + Point2 -> + Color -> + WdBl -> + [(Point2, Point2)] -> + [(Point2, Point2)] -> + Maybe Placement +airlockDoubleDoor p1 p2 col cond outDoorps inDoorps = + jspsJ p1 0 (airlockDoor col cond outDoorps) $ + sPS p2 0 (airlockDoor col cond inDoorps) airlockSimple :: Room -airlockSimple = defaultRoom - { _rmPolys = - [ rectNSWE 120 0 0 180 ] - , _rmLinks = map (uncurry outLink) (init lnks) ++ [uncurry inLink $ last lnks] - , _rmPath = foldMap (doublePairSet . (V2 90 30,) . fst) lnks - , _rmPmnts = - [pContID (PS (V2 90 115) pi) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect) - $ \btid -> airlockDoubleDoor 0 (V2 180 0) col (WdBlBtOn btid) outDoorps inDoorps --- jspsJ (V2 0 0) 0 (airlockDoor col (cond btid) outDoorps) --- $ sPS (V2 180 0) 0 (airlockDoor col (cond btid) inDoorps) +airlockSimple = + defaultRoom + { _rmPolys = + [rectNSWE 120 0 0 180] + , _rmLinks = map (uncurry outLink) (init lnks) ++ [uncurry inLink $ last lnks] + , _rmPath = foldMap (doublePairSet . (V2 90 30,) . fst) lnks + , _rmPmnts = + [ pContID (PS (V2 90 115) pi) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect) $ + \btid -> airlockDoubleDoor 0 (V2 180 0) col (WdBlBtOn btid) outDoorps inDoorps + -- jspsJ (V2 0 0) 0 (airlockDoor col (cond btid) outDoorps) + -- $ sPS (V2 180 0) 0 (airlockDoor col (cond btid) inDoorps) + ] + , _rmBound = + [rectNSWE 120 0 0 180] + } + where + lnks = + [ (V2 0 30, pi / 2) + , (V2 180 30, 1.5 * pi) ] - , _rmBound = - [ rectNSWE 120 0 0 180 ] - } - where - lnks = - [(V2 0 30,pi/2) - ,(V2 180 30,1.5*pi) - ] col = dim $ dim $ bright red - outDoorps = (V2 0 0 ,) <$> arcStepwise 3 (negate $ pi/2) (V2 0 0) (V2 0 55) - inDoorps = (V2 0 0 ,) <$> arcStepwise 3 (negate $ pi/2) (V2 0 0) (V2 (-55) 0) + outDoorps = (V2 0 0,) <$> arcStepwise 3 (negate $ pi / 2) (V2 0 0) (V2 0 55) + inDoorps = (V2 0 0,) <$> arcStepwise 3 (negate $ pi / 2) (V2 0 0) (V2 (-55) 0) + airlockZ :: Room -airlockZ = defaultRoom - { _rmPolys = - [ rectNSWE 120 0 0 180 ] - , _rmLinks = muout[(V2 0 30,pi/2)] ++ muin[(V2 180 30,1.5*pi) ] - , _rmPath = mempty --- [(V2 0 40,V2 40 0) --- ,(V2 40 0,V2 0 40) --- ] - , _rmPmnts = - [pContID (PS (V2 90 115) pi) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect) - $ \btid -> airlockDoubleDoor (V2 0 60) (V2 180 60) col (WdBlBtOn btid) outDoorps inDoorps --- jspsJ (V2 0 60) 0 (airlockDoor col (cond btid) outDoorps) --- $ sPS (V2 180 60) 0 (airlockDoor col (cond btid) inDoorps) - , sps0 $ PutWall (reverse $ rectNSWE 70 50 60 120) defaultWall - , lighting - ] - , _rmBound = - [ rectNSWE 120 0 0 180 ] - } - where +airlockZ = + defaultRoom + { _rmPolys = + [rectNSWE 120 0 0 180] + , _rmLinks = muout [(V2 0 30, pi / 2)] ++ muin [(V2 180 30, 1.5 * pi)] + , _rmPath = mempty + , -- [(V2 0 40,V2 40 0) + -- ,(V2 40 0,V2 0 40) + -- ] + _rmPmnts = + [ pContID (PS (V2 90 115) pi) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect) $ + \btid -> airlockDoubleDoor (V2 0 60) (V2 180 60) col (WdBlBtOn btid) outDoorps inDoorps + , -- jspsJ (V2 0 60) 0 (airlockDoor col (cond btid) outDoorps) + -- $ sPS (V2 180 60) 0 (airlockDoor col (cond btid) inDoorps) + sps0 $ PutWall (reverse $ rectNSWE 70 50 60 120) defaultWall + , lighting + ] + , _rmBound = + [rectNSWE 120 0 0 180] + } + where col = dim $ dim $ bright red - outDoorps = (V2 0 0 ,) <$> arcStepwise 3 (pi/2) (V2 0 0) (V2 0 (-61)) - inDoorps = (V2 0 0 ,) <$> arcStepwise 3 (pi/2) (V2 0 0) (V2 (-61) 0) - cenlight = mntLS vShape (V2 90 60) (V3 90 40 50) `addPlmnt` mntLS vShape (V2 90 60) (V3 90 80 50) - cornlight = mntLS vShape (V2 0 120) (V3 30 90 50) `addPlmnt` mntLS vShape (V2 180 120) (V3 150 90 50) - `addPlmnt` sps0 (putShape (thinHighBar 50 (V2 30 90) (V2 150 90))) - lighting = RandomPlacement $ takeOne [cenlight,cornlight] + outDoorps = (V2 0 0,) <$> arcStepwise 3 (pi / 2) (V2 0 0) (V2 0 (-61)) + inDoorps = (V2 0 0,) <$> arcStepwise 3 (pi / 2) (V2 0 0) (V2 (-61) 0) + cenlight = mntLS vShape (V2 90 60) (V3 90 40 50) `addPlmnt` mntLS vShape (V2 90 60) (V3 90 80 50) + cornlight = + mntLS vShape (V2 0 120) (V3 30 90 50) `addPlmnt` mntLS vShape (V2 180 120) (V3 150 90 50) + `addPlmnt` sps0 (putShape (thinHighBar 50 (V2 30 90) (V2 150 90))) + lighting = RandomPlacement $ takeOne [cenlight, cornlight] airlock90 :: Room -airlock90 = defaultRoom - { _rmPolys = - [ rectNSWE 100 10 10 100 - , rectNSWE 20 0 20 60 - , rectNSWE 20 60 20 0 - , map toV2 [ (10,100) - , (100,150) - , (150,100) - , (100,10) +airlock90 = + defaultRoom + { _rmPolys = + [ rectNSWE 100 10 10 100 + , rectNSWE 20 0 20 60 + , rectNSWE 20 60 20 0 + , map + toV2 + [ (10, 100) + , (100, 150) + , (150, 100) + , (100, 10) + ] ] - ] - , _rmLinks = muout[(V2 0 40,pi/2)] ++ muin[(V2 40 0,pi) ] - , _rmPath = doublePairSet (V2 0 40,V2 40 0) - , _rmPmnts = - [ pContID (PS (V2 120 120) (3 * pi/4)) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect) - $ \btid -> jsps (V2 5 5) 0 $ airlockDoor col (WdBlBtOn btid) pss - , mntLS vShape (V2 35 35) (V3 70 70 50) - ] - , _rmBound = - [map toV2 [ (10,10) - , (10,100) - , (100,150) - , (150,100) - , (100,10) - ]] - , _rmName = "airlock90" - } - where + , _rmLinks = muout [(V2 0 40, pi / 2)] ++ muin [(V2 40 0, pi)] + , _rmPath = doublePairSet (V2 0 40, V2 40 0) + , _rmPmnts = + [ pContID (PS (V2 120 120) (3 * pi / 4)) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect) $ + \btid -> jsps (V2 5 5) 0 $ airlockDoor col (WdBlBtOn btid) pss + , mntLS vShape (V2 35 35) (V3 70 70 50) + ] + , _rmBound = + [ map + toV2 + [ (10, 10) + , (10, 100) + , (100, 150) + , (150, 100) + , (100, 10) + ] + ] + , _rmName = "airlock90" + } + where --cond w = or $ M.lookup (DoorNumOpen n) (_worldState w) col = dim $ dim $ bright red - pss = (V2 0 0 ,) <$> arcStepwise 3 (negate $ pi/2) (V2 0 0) (V2 0 55) + pss = (V2 0 0,) <$> arcStepwise 3 (negate $ pi / 2) (V2 0 0) (V2 0 55) airlockCrystal :: Room -airlockCrystal = defaultRoom - { _rmPolys = [ rectNSWE 140 0 0 40 , switchcutout ] - , _rmLinks = muout[(V2 20 130,0) ] ++ muin[(V2 20 0 ,pi) ] - , _rmPath = mempty - , _rmPmnts = - [pContID (PS (V2 145 70) (pi/2)) ( PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect) - $ \btid -> jsps0 $ airlockDoor col (WdBlBtOn btid) pss - , crystalLine (V2 0 70) (V2 40 70) - , mntLS vShape (V2 150 70) (V3 110 70 70) - ] - , _rmBound = [ rectNSWE 120 20 0 40 , switchcutout ] - } - where - switchcutout = orderPolygon $ map toV2 [ (39,20) , (150,60) , (150,80) , (39,120) ] +airlockCrystal = + defaultRoom + { _rmPolys = [rectNSWE 140 0 0 40, switchcutout] + , _rmLinks = muout [(V2 20 130, 0)] ++ muin [(V2 20 0, pi)] + , _rmPath = mempty + , _rmPmnts = + [ pContID (PS (V2 145 70) (pi / 2)) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect) $ + \btid -> jsps0 $ airlockDoor col (WdBlBtOn btid) pss + , crystalLine (V2 0 70) (V2 40 70) + , mntLS vShape (V2 150 70) (V3 110 70 70) + ] + , _rmBound = [rectNSWE 120 20 0 40, switchcutout] + } + where + switchcutout = orderPolygon $ map toV2 [(39, 20), (150, 60), (150, 80), (39, 120)] col = dim $ dim $ bright red - pss :: [(Point2,Point2)] - pss = reverse $ fmap ( (\x -> (V2 50 (x - 10),V2 50 (x+60)) ) . fromIntegral) - [20::Int,22..70] - + pss :: [(Point2, Point2)] + pss = + reverse $ + fmap + ((\x -> (V2 50 (x - 10), V2 50 (x + 60))) . fromIntegral) + [20 :: Int, 22 .. 70] diff --git a/src/Dodge/Room/BlinkAcross.hs b/src/Dodge/Room/BlinkAcross.hs index 9e30ad632..7382595c8 100644 --- a/src/Dodge/Room/BlinkAcross.hs +++ b/src/Dodge/Room/BlinkAcross.hs @@ -1,50 +1,28 @@ module Dodge.Room.BlinkAcross where ---import Dodge.LevelGen.Data -import Dodge.PlacementSpot + +import Control.Monad.State import Dodge.Cleat -import Dodge.Data -import Dodge.Tree ---import Dodge.RoomLink ---import Dodge.Room.Door +import Dodge.Data.GenWorld +import Dodge.PlacementSpot import Dodge.Room.Corridor import Dodge.Room.Link ---import Dodge.Room.Ngon import Dodge.Room.Procedural ---import Dodge.Room.Foreground ---import Dodge.Room.RoadBlock ---import Dodge.Placement.Instance ---import Dodge.Placement.Instance.Analyser ---import Dodge.Default.Room ---import Dodge.Item.Consumable ---import Dodge.Machine ---import Dodge.Item.Weapon.Utility ---import Dodge.LevelGen.Data ---import Geometry.Data ---import Geometry ---import Padding ---import Color ---import Shape +import Dodge.Tree import LensHelp ---import Dodge.RandomHelp ---import Dodge.SoundLogic - ---import qualified Data.Set as S ---import Data.Maybe ---import Data.Tree -import Control.Monad.State import System.Random blinkAcrossChallenge :: RandomGen g => State g (MetaTree Room String) blinkAcrossChallenge = do teleFromRoom <- shuffleLinks $ roomRectAutoLinks 200 200 - teleToRoom <- shuffleLinks $ roomRectAutoLinks 200 200 - emptylink <- shuffleLinks emptyCorridor - rToOnward "blinkAcrossChallenge" - $ treePost [ teleFromRoom, emptylink, cleatOnward teleToRoom] + teleToRoom <- shuffleLinks $ roomRectAutoLinks 200 200 + emptylink <- shuffleLinks emptyCorridor + rToOnward "blinkAcrossChallenge" $ + treePost [teleFromRoom, emptylink, cleatOnward teleToRoom] emptyCorridor :: Room -emptyCorridor = corridor & rmPolys .~ [] - & rmPath .~ mempty - & rmPmnts .~ [] - & rmRandPSs .~ [psRandRanges (10,30) (30,60) (0,2*pi)] - & rmName .~ "WalledCorridor" +emptyCorridor = + corridor & rmPolys .~ [] + & rmPath .~ mempty + & rmPmnts .~ [] + & rmRandPSs .~ [psRandRanges (10, 30) (30, 60) (0, 2 * pi)] + & rmName .~ "WalledCorridor" diff --git a/src/Dodge/Room/Boss.hs b/src/Dodge/Room/Boss.hs index d99ea4c60..54363ac96 100644 --- a/src/Dodge/Room/Boss.hs +++ b/src/Dodge/Room/Boss.hs @@ -1,151 +1,181 @@ {- Rooms containing particularly challenging creatures, that may drop useful loot. -} -module Dodge.Room.Boss - where -import Dodge.Data -import Dodge.RoomLink -import Dodge.Default.Room -import Dodge.Placement.Instance -import Dodge.LevelGen.Data -import Dodge.Room.Procedural -import Dodge.Room.Link -import Dodge.Room.Corridor -import Dodge.Room.Path ---import Dodge.LevelGen.Data +module Dodge.Room.Boss where + import Dodge.Creature -import RandomHelp -import Dodge.Tree +import Dodge.Data.GenWorld +import Dodge.Default.Room +import Dodge.LevelGen.Data import Dodge.LevelGen.StaticWalls +import Dodge.Placement.Instance +import Dodge.Room.Corridor +import Dodge.Room.Link +import Dodge.Room.Path +import Dodge.Room.Procedural +import Dodge.RoomLink +import Dodge.Tree import Geometry import LensHelp +import RandomHelp -roomGlassOctogon - :: Float -- ^ Size - -> Room -roomGlassOctogon x = createPathGrid $ defaultRoom - { _rmPolys = - [rectNSWE x (-x) (-x) x - ,rectNSWE 0 (-(x + 40)) (-20) 20 - ] - , _rmLinks = map (uncurry outLink) (init lnks) ++ [uncurry inLink $ last lnks] - , _rmPath = linksAndPath lnks - [ ( V2 0 x , V2 0 (-(x+40))) - , ( V2 0 (-(x+40)), V2 0 x) - ] - , _rmPmnts = - [sPS (V2 fx fx) 0 putLamp - ,sPS (V2 (-fx) fx) 0 putLamp - ,sPS (V2 fx (-fx)) 0 putLamp - ,sPS (V2 (-fx) (-fx)) 0 putLamp - ,crystalLine (V2 (-x) (x/2)) (V2 (negate (x/2)) x) - ,crystalLine (V2 x (x/2)) (V2 (x/2) x) - ,crystalLine (V2 (x/2) (-x)) (V2 x (negate (x/2))) - ,crystalLine (V2 (negate $ x/2) (-x)) (V2 (-x) (negate (x/2))) - ,blockLine (V2 (-40) (50-x)) (V2 40 (50-x)) - ] - , _rmBound = [rectNSWE x (-x) (-x) x] - , _rmName = "glass8gon" - } +roomGlassOctogon :: + -- | Size + Float -> + Room +roomGlassOctogon x = + createPathGrid $ + defaultRoom + { _rmPolys = + [ rectNSWE x (- x) (- x) x + , rectNSWE 0 (- (x + 40)) (-20) 20 + ] + , _rmLinks = map (uncurry outLink) (init lnks) ++ [uncurry inLink $ last lnks] + , _rmPath = + linksAndPath + lnks + [ (V2 0 x, V2 0 (- (x + 40))) + , (V2 0 (- (x + 40)), V2 0 x) + ] + , _rmPmnts = + [ sPS (V2 fx fx) 0 putLamp + , sPS (V2 (- fx) fx) 0 putLamp + , sPS (V2 fx (- fx)) 0 putLamp + , sPS (V2 (- fx) (- fx)) 0 putLamp + , crystalLine (V2 (- x) (x / 2)) (V2 (negate (x / 2)) x) + , crystalLine (V2 x (x / 2)) (V2 (x / 2) x) + , crystalLine (V2 (x / 2) (- x)) (V2 x (negate (x / 2))) + , crystalLine (V2 (negate $ x / 2) (- x)) (V2 (- x) (negate (x / 2))) + , blockLine (V2 (-40) (50 - x)) (V2 40 (50 - x)) + ] + , _rmBound = [rectNSWE x (- x) (- x) x] + , _rmName = "glass8gon" + } where fx = 4 * x / 5 - lnks = - [ (V2 0 x,0) - , (V2 0 (-(x+40)),pi) + lnks = + [ (V2 0 x, 0) + , (V2 0 (- (x + 40)), pi) ] bossRoom :: RandomGen g => Creature -> State g Room -bossRoom cr = randomMediumRoom <&> rmPmnts .:~ sPS (V2 0 100) (negate $ pi/2) (PutCrit cr) +bossRoom cr = randomMediumRoom <&> rmPmnts .:~ sPS (V2 0 100) (negate $ pi / 2) (PutCrit cr) armouredChasers :: RandomGen g => State g (Tree Room) armouredChasers = do - ps <- takeN 5 [V2 x y | x <- [-100,-80 .. 100] ,y <- [-100,-80 .. 100] ] - as <- replicateM 5 . state $ randomR (0,2*pi) + ps <- takeN 5 [V2 x y | x <- [-100, -80 .. 100], y <- [-100, -80 .. 100]] + as <- replicateM 5 . state $ randomR (0, 2 * pi) let theCrits = zipWith3 (\p a c -> sPS p a (PutCrit c)) ps as cs - treeFromPost [corridor,corridor] <$> (randomMediumRoom <&> rmPmnts %~ (++ theCrits)) + treeFromPost [corridor, corridor] <$> (randomMediumRoom <&> rmPmnts %~ (++ theCrits)) where - cs = (armourChaseCrit & crState . csDropsOnDeath .~ DropSpecific [0]) - : replicate 4 chaseCrit + cs = + (armourChaseCrit & crState . csDropsOnDeath .~ DropSpecific [0]) : + replicate 4 chaseCrit randomMediumRoom :: RandomGen g => State g Room -randomMediumRoom = takeOne - [ roomGlassOctogon 300 - , roomCross 180 300 - , roomShuriken 200 300 - , roomTwistCross 230 300 0 - ] +randomMediumRoom = + takeOne + [ roomGlassOctogon 300 + , roomCross 180 300 + , roomShuriken 200 300 + , roomTwistCross 230 300 0 + ] -roomCross - :: Float -- ^ First width/2 - -> Float -- ^ Second width/2 - -> Room -roomCross x y = defaultRoom - { _rmPolys = [rectNSWE y (-y) (-x) x - ,rectNSWE (-x) x y (-y) - ] - , _rmLinks = map (uncurry outLink) - [(V2 x (y-20),negate $ pi/2) - ,(V2 x (20-y),negate $ pi/2) - ,(V2 (20-y) x ,0) - ,(V2 (y-20) x ,0) - ,(V2 (-x) (y-20),pi/2) - ,(V2 (-x) (20-y),pi/2) - ,(V2 (20-y) (-x),pi) - ] ++ - [uncurry inLink (V2 (y-20) (-x),pi) - ] - , _rmPath = mempty - , _rmPmnts = - [ spanLightI (V2 (x+5) x) (V2 (x+5) (-x)) - , spanLightI (V2 (-x-5) x) (V2 (-x-5) (-x)) - ] - , _rmBound = - [rectNSWE y (-y) (-x) x - ,rectNSWE x (-x) (-y) y - ] - , _rmName = "cross" - } -{- | TODO: pathing -} -roomShuriken - :: Float -- ^ First width/2 - -> Float -- ^ Second width/2 - -> Room -roomShuriken x y = - let ps = [ map toV2 - [ (0,-20) - , (x,-20) - , (x,y) - , (0,x) - ] ] - corner = defaultRoom - { _rmPolys = ps - , _rmLinks = [toBothLnk (V2 (x-1) (y-20),negate $ pi/2)] - , _rmPath = mempty - , _rmPmnts = [mntLS iShape (V2 x x) (V3 (x-20) x 70)] - , _rmBound = ps - } - in (foldr1 combineRooms $ map (\r -> moveRoomBy (V2 0 0, r) corner) [0,pi/2,pi,3*pi/2]) - {_rmName = "shuriken"} -{- | TODO: pathing -Precondition: first float is less than the second by at least 40. -} -roomTwistCross - :: Float -- ^ First width/2, - -> Float -- ^ Second width/2, should be biggest - -> Float -- ^ Third width, should be smallest, possibly negative - -> Room -roomTwistCross x y z = - let ps = [ map toV2 [ (x,negate $ z+20) - , (x,x) - , (z,y) - , (z-20,x) - , (z,negate $ z+20) - ] - , rectNSWE (x-5) 0 0 (x-5) +roomCross :: + -- | First width/2 + Float -> + -- | Second width/2 + Float -> + Room +roomCross x y = + defaultRoom + { _rmPolys = + [ rectNSWE y (- y) (- x) x + , rectNSWE (- x) x y (- y) ] - corner = defaultRoom - { _rmPolys = ps - , _rmLinks = [toBothLnk (V2 z (y-20), pi/2)] - , _rmPath = mempty - , _rmPmnts = [mntLS iShape (V2 x x) (V3 (x-20) (x-20) 70)] - , _rmBound = map (expandPolyCorners 10) ps + , _rmLinks = + map + (uncurry outLink) + [ (V2 x (y -20), negate $ pi / 2) + , (V2 x (20 - y), negate $ pi / 2) + , (V2 (20 - y) x, 0) + , (V2 (y -20) x, 0) + , (V2 (- x) (y -20), pi / 2) + , (V2 (- x) (20 - y), pi / 2) + , (V2 (20 - y) (- x), pi) + ] + ++ [ uncurry inLink (V2 (y -20) (- x), pi) + ] + , _rmPath = mempty + , _rmPmnts = + [ spanLightI (V2 (x + 5) x) (V2 (x + 5) (- x)) + , spanLightI (V2 (- x -5) x) (V2 (- x -5) (- x)) + ] + , _rmBound = + [ rectNSWE y (- y) (- x) x + , rectNSWE x (- x) (- y) y + ] + , _rmName = "cross" + } + +-- | TODO: pathing +roomShuriken :: + -- | First width/2 + Float -> + -- | Second width/2 + Float -> + Room +roomShuriken x y = + let ps = + [ map + toV2 + [ (0, -20) + , (x, -20) + , (x, y) + , (0, x) + ] + ] + corner = + defaultRoom + { _rmPolys = ps + , _rmLinks = [toBothLnk (V2 (x -1) (y -20), negate $ pi / 2)] + , _rmPath = mempty + , _rmPmnts = [mntLS iShape (V2 x x) (V3 (x -20) x 70)] + , _rmBound = ps + } + in (foldr1 combineRooms $ map (\r -> moveRoomBy (V2 0 0, r) corner) [0, pi / 2, pi, 3 * pi / 2]) + { _rmName = "shuriken" + } + +{- | TODO: pathing +Precondition: first float is less than the second by at least 40. +-} +roomTwistCross :: + -- | First width/2, + Float -> + -- | Second width/2, should be biggest + Float -> + -- | Third width, should be smallest, possibly negative + Float -> + Room +roomTwistCross x y z = + let ps = + [ map + toV2 + [ (x, negate $ z + 20) + , (x, x) + , (z, y) + , (z -20, x) + , (z, negate $ z + 20) + ] + , rectNSWE (x -5) 0 0 (x -5) + ] + corner = + defaultRoom + { _rmPolys = ps + , _rmLinks = [toBothLnk (V2 z (y -20), pi / 2)] + , _rmPath = mempty + , _rmPmnts = [mntLS iShape (V2 x x) (V3 (x -20) (x -20) 70)] + , _rmBound = map (expandPolyCorners 10) ps + } + in (foldr1 combineRooms $ map (\r -> moveRoomBy (V2 0 0, r) corner) [0, pi / 2, pi, 3 * pi / 2]) + { _rmName = "twistCross" } - in (foldr1 combineRooms $ map (\r -> moveRoomBy (V2 0 0, r) corner) [0,pi/2,pi,3*pi/2]) - {_rmName = "twistCross" } diff --git a/src/Dodge/Room/Branch.hs b/src/Dodge/Room/Branch.hs index 3487ccbf1..ef547852a 100644 --- a/src/Dodge/Room/Branch.hs +++ b/src/Dodge/Room/Branch.hs @@ -1,28 +1,26 @@ {- Collections of rooms that branch into multiple paths. -} -module Dodge.Room.Branch - where ---import Geometry ---import Dodge.LevelGen.Data -import Dodge.Data +module Dodge.Room.Branch where + +import Control.Monad.State import Dodge.Cleat +import Dodge.Data.GenWorld import Dodge.Room.Door import Dodge.Room.Link import Dodge.Room.Procedural ---import Dodge.LevelGen.Data import Dodge.Tree - -import Control.Monad.State import System.Random -branchRectWith :: RandomGen g => State g (Tree Room) -> State g (Tree Room) +branchRectWith :: RandomGen g => State g (Tree Room) -> State g (Tree Room) branchRectWith t = do - x <- state $ randomR (100,200) - y <- state $ randomR (100,200) + x <- state $ randomR (100, 200) + y <- state $ randomR (100, 200) b <- t rt <- shuffleLinks $ roomRectAutoLinks x y - return $ Node rt - [ pure $ cleatOnward door - , treeFromTrunk [door] b - ] + return $ + Node + rt + [ pure $ cleatOnward door + , treeFromTrunk [door] b + ] diff --git a/src/Dodge/Room/Breather.hs b/src/Dodge/Room/Breather.hs index fa3c1d4f2..8c7c0b9a5 100644 --- a/src/Dodge/Room/Breather.hs +++ b/src/Dodge/Room/Breather.hs @@ -1,6 +1,6 @@ module Dodge.Room.Breather where -import Dodge.Data +import Dodge.Data.GenWorld import Dodge.Item import Dodge.Room.Containing import Dodge.Tree diff --git a/src/Dodge/Room/CheckConsistency.hs b/src/Dodge/Room/CheckConsistency.hs index 6cd75b62e..11291e334 100644 --- a/src/Dodge/Room/CheckConsistency.hs +++ b/src/Dodge/Room/CheckConsistency.hs @@ -1,7 +1,6 @@ -module Dodge.Room.CheckConsistency - where ---import Dodge.LevelGen.Data -import Dodge.Data +module Dodge.Room.CheckConsistency where + +import Dodge.Data.GenWorld import Dodge.Graph import Dodge.RoomLink diff --git a/src/Dodge/Room/Containing.hs b/src/Dodge/Room/Containing.hs index e7dd0dfdb..7454c6775 100644 --- a/src/Dodge/Room/Containing.hs +++ b/src/Dodge/Room/Containing.hs @@ -1,57 +1,60 @@ --{-# LANGUAGE TupleSections #-} module Dodge.Room.Containing where -import Dodge.Data + +import Dodge.Cleat +import Dodge.Data.GenWorld import Dodge.Item.Display -import Dodge.Tree import Dodge.LevelGen.Data import Dodge.PlacementSpot -import RandomHelp -import Dodge.Room.Procedural -import Dodge.Room.Pillar -import Dodge.Room.Tanks import Dodge.Room.Link import Dodge.Room.Ngon -import Dodge.Cleat -import LensHelp +import Dodge.Room.Pillar +import Dodge.Room.Procedural +import Dodge.Room.Tanks +import Dodge.Tree import Geometry ---import Dodge.Item.Equipment +import LensHelp +import RandomHelp roomsContaining :: RandomGen g => [Creature] -> [Item] -> State g (MetaTree Room String) roomsContaining crs its = tToBTree str <$> roomsContaining' crs its where - str = "roomsContaining "++ concatMap _crName crs ++ concatMap (head . itemDisplay) its + str = "roomsContaining " ++ concatMap _crName crs ++ concatMap (head . itemDisplay) its roomsContaining' :: RandomGen g => [Creature] -> [Item] -> State g (Tree Room) roomsContaining' crs its = do - endroom <- join $ takeOne - [ roomPillarsSquare <&> rmPmnts ++.~ crsItmsUnused crs its - , randomFourCornerRoomCrsIts crs its - , tanksRoom crs its - , tanksPipesRoom <&> rmPmnts ++.~ crsItmsUnused crs its - , roomPillarsContaining crs its - , roomPillarsPassage <&> rmPmnts ++.~ crsItmsUnused crs its - ] + endroom <- + join $ + takeOne + [ roomPillarsSquare <&> rmPmnts ++.~ crsItmsUnused crs its + , randomFourCornerRoomCrsIts crs its + , tanksRoom crs its + , tanksPipesRoom <&> rmPmnts ++.~ crsItmsUnused crs its + , roomPillarsContaining crs its + , roomPillarsPassage <&> rmPmnts ++.~ crsItmsUnused crs its + ] return (pure $ cleatOnward endroom) roomPillarsContaining :: RandomGen g => [Creature] -> [Item] -> State g Room roomPillarsContaining crs itms = do - (w,wn) <- takeOne [(240,2),(340,3)] - (h,hn) <- takeOne [(240,2),(340,3)] + (w, wn) <- takeOne [(240, 2), (340, 3)] + (h, hn) <- takeOne [(240, 2), (340, 3)] roomPillars 30 w h wn hn <&> rmPmnts .++~ crsItmsUnused crs itms crsItmsUnused :: [Creature] -> [Item] -> [Placement] -crsItmsUnused crs itms = map (\it -> sps0 (PutFlIt it) & plSpot .~ anyUnusedSpot) itms - ++ map (\cr -> sps0 (PutCrit cr) & plSpot .~ unusedSpotAwayFromLink 50) crs - +crsItmsUnused crs itms = + map (\it -> sps0 (PutFlIt it) & plSpot .~ anyUnusedSpot) itms + ++ map (\cr -> sps0 (PutCrit cr) & plSpot .~ unusedSpotAwayFromLink 50) crs pedestalRoom :: RandomGen g => Item -> State g Room pedestalRoom it = do let flit = PutFlIt it - x <- state $ randomR (150,250) - ngon <- state $ randomR (5,9) - r <- takeOne - [ shuffleLinks =<< (centerVaultRoom x x 50 <&> rmPmnts .:~ sps0 flit) - , shuffleLinks $ roomRectAutoLinks (2*x) (2*x) & rmPmnts .:~ sPS (V2 x x) 0 flit - , shuffleLinks $ roomNgon ngon x & rmPmnts .:~ sps0 flit - ] + x <- state $ randomR (150, 250) + ngon <- state $ randomR (5, 9) + r <- + takeOne + [ shuffleLinks =<< (centerVaultRoom x x 50 <&> rmPmnts .:~ sps0 flit) + , shuffleLinks $ roomRectAutoLinks (2 * x) (2 * x) & rmPmnts .:~ sPS (V2 x x) 0 flit + , shuffleLinks $ roomNgon ngon x & rmPmnts .:~ sps0 flit + ] r <&> rmName .++~ "ped-" diff --git a/src/Dodge/Room/Corridor.hs b/src/Dodge/Room/Corridor.hs index ec40c0f3d..313c70f6a 100644 --- a/src/Dodge/Room/Corridor.hs +++ b/src/Dodge/Room/Corridor.hs @@ -1,118 +1,133 @@ {-# LANGUAGE TupleSections #-} + module Dodge.Room.Corridor where + import Data.Tile ---import Dodge.LevelGen.Data -import Dodge.Data -import Dodge.RoomLink ---import Dodge.Room.Foreground +import Dodge.Data.GenWorld import Dodge.Default.Room ---import Dodge.LevelGen.Data ---import Dodge.LightSources.Lamp import Dodge.Placement.Instance import Dodge.PlacementSpot +import Dodge.RoomLink import Geometry import Tile ---import Data.Bifunctor {- | First exit due north, two other exits at angles next to this. - Entrance from south. -} + Entrance from south. +-} corridor :: Room -corridor = defaultRoom - { _rmPolys = [poly] - , _rmLinks = lnks' - --, _rmPath = foldMap (doublePairSet . (,) (V2 20 60) . fst) lnks - , _rmPath = foldMap (doublePairSet . (,) (V2 20 60)) [V2 20 70,V2 20 10] - , _rmPmnts = [ spanLightI (V2 0 39.5) (V2 40 39.5) ] - , _rmBound = [ rectNSWE 50 30 (-5) 45 ] - , _rmFloor = Tiled [makeTileFromPoly poly 2] - , _rmRandPSs = [psRandRanges (10,30) (30,60) (0,2*pi)] - , _rmName = "Corridor" - } - where +corridor = + defaultRoom + { _rmPolys = [poly] + , _rmLinks = lnks' + , --, _rmPath = foldMap (doublePairSet . (,) (V2 20 60) . fst) lnks + _rmPath = foldMap (doublePairSet . (,) (V2 20 60)) [V2 20 70, V2 20 10] + , _rmPmnts = [spanLightI (V2 0 39.5) (V2 40 39.5)] + , _rmBound = [rectNSWE 50 30 (-5) 45] + , _rmFloor = Tiled [makeTileFromPoly poly 2] + , _rmRandPSs = [psRandRanges (10, 30) (30, 60) (0, 2 * pi)] + , _rmName = "Corridor" + } + where poly = rectNSWE 80 0 0 40 lnks' = - [uncurry outLink (V2 20 70 , 0) - ,uncurry outLink (V2 20 70 , pi/6) - ,uncurry outLink (V2 20 70 , negate $ pi/6) - ,uncurry inLink (V2 20 10 , pi) + [ uncurry outLink (V2 20 70, 0) + , uncurry outLink (V2 20 70, pi / 6) + , uncurry outLink (V2 20 70, negate $ pi / 6) + , uncurry inLink (V2 20 10, pi) ] + keyholeCorridor :: Room -keyholeCorridor = corridor - { _rmPath = mempty - , _rmPmnts = - [ midWall $ rectNSWE top bot 15 0 - , midWall $ rectNSWE top bot 40 25] - } +keyholeCorridor = + corridor + { _rmPath = mempty + , _rmPmnts = + [ midWall $ rectNSWE top bot 15 0 + , midWall $ rectNSWE top bot 40 25 + ] + } where top = 65 bot = 15 - + corridorN :: Room -corridorN = defaultRoom - { _rmPolys = [rectNSWE 80 0 0 40 - ] - , _rmLinks = lnks - , _rmPath = pth - , _rmPmnts = [] - , _rmBound = [ rectNSWE 50 30 0 40 ] - , _rmName = "corridorN" - } - where lnks = [uncurry outLink (V2 20 70 ,0) - ,uncurry inLink (V2 20 10 ,pi) - ] - pth = doublePairSet (V2 20 70,V2 20 10) +corridorN = + defaultRoom + { _rmPolys = + [ rectNSWE 80 0 0 40 + ] + , _rmLinks = lnks + , _rmPath = pth + , _rmPmnts = [] + , _rmBound = [rectNSWE 50 30 0 40] + , _rmName = "corridorN" + } + where + lnks = + [ uncurry outLink (V2 20 70, 0) + , uncurry inLink (V2 20 10, pi) + ] + pth = doublePairSet (V2 20 70, V2 20 10) + corridorWallN :: Room -corridorWallN = defaultRoom - { _rmPolys = [rectNSWE 70 0 0 40 - ] - , _rmLinks = lnks - , _rmPath = pth - , _rmPmnts = [] - , _rmBound = [ rectNSWE 50 30 0 40 ] - } - where - lnks = [uncurry outLink(V2 20 70 ,0) - ,uncurry inLink(V2 20 10 ,pi) - ] - pth = doublePairSet (V2 20 70,V2 20 10) +corridorWallN = + defaultRoom + { _rmPolys = + [ rectNSWE 70 0 0 40 + ] + , _rmLinks = lnks + , _rmPath = pth + , _rmPmnts = [] + , _rmBound = [rectNSWE 50 30 0 40] + } + where + lnks = + [ uncurry outLink (V2 20 70, 0) + , uncurry inLink (V2 20 10, pi) + ] + pth = doublePairSet (V2 20 70, V2 20 10) -- this should be combined with tWest tEast :: Room -tEast = defaultRoom - { _rmPolys = [rectNSWE 80 0 (-20) 20 - ,rectNSWE 80 40 (-40) 40 - ] - , _rmLinks = lnks' - , _rmPath = foldMap (doublePairSet . (,) (V2 0 60) . fst) lnks - , _rmPmnts = [] - , _rmBound = [ rectNSWE 70 10 0 40 ] - , _rmName = "tEast" - } - where +tEast = + defaultRoom + { _rmPolys = + [ rectNSWE 80 0 (-20) 20 + , rectNSWE 80 40 (-40) 40 + ] + , _rmLinks = lnks' + , _rmPath = foldMap (doublePairSet . (,) (V2 0 60) . fst) lnks + , _rmPmnts = [] + , _rmBound = [rectNSWE 70 10 0 40] + , _rmName = "tEast" + } + where lnks = - [(V2 30 60, (-pi/2)::Float) - ,(V2 (-30) 60, pi/2 ) - ,(V2 0 10, pi ) + [ (V2 30 60, (- pi / 2) :: Float) + , (V2 (-30) 60, pi / 2) + , (V2 0 10, pi) ] lnks' = - [uncurry outLink (V2 30 60,-pi/2) - ,uncurry outLink (V2 (-30) 60,pi/2) - ,uncurry inLink (V2 0 10,pi) + [ uncurry outLink (V2 30 60, - pi / 2) + , uncurry outLink (V2 (-30) 60, pi / 2) + , uncurry inLink (V2 0 10, pi) ] + tWest :: Room -tWest = defaultRoom - { _rmPolys = [rectNSWE 80 0 (-20) 20 - ,rectNSWE 80 40 (-40) 40 - ] - , _rmLinks = lnks - , _rmPath = foldMap (doublePairSet . (V2 0 60 ,) . _rlPos) lnks - , _rmPmnts = [] - , _rmBound = [ rectNSWE 70 10 0 40 ] - , _rmName = "tWest" - } - where +tWest = + defaultRoom + { _rmPolys = + [ rectNSWE 80 0 (-20) 20 + , rectNSWE 80 40 (-40) 40 + ] + , _rmLinks = lnks + , _rmPath = foldMap (doublePairSet . (V2 0 60,) . _rlPos) lnks + , _rmPmnts = [] + , _rmBound = [rectNSWE 70 10 0 40] + , _rmName = "tWest" + } + where lnks = - [outLink (V2 (-30) 60) ( pi/2) - ,outLink (V2 30 60) (-pi/2) - ,inLink (V2 0 10) pi + [ outLink (V2 (-30) 60) (pi / 2) + , outLink (V2 30 60) (- pi / 2) + , inLink (V2 0 10) pi ] diff --git a/src/Dodge/Room/Door.hs b/src/Dodge/Room/Door.hs index 10e39062a..2101910ae 100644 --- a/src/Dodge/Room/Door.hs +++ b/src/Dodge/Room/Door.hs @@ -1,42 +1,44 @@ {- Rooms that connect other rooms, blocking sight. -} -module Dodge.Room.Door - where -import Geometry -import Dodge.RoomLink -import Dodge.Data -import Dodge.Default.Room -import Dodge.Default.Door -import Dodge.Placement.Instance -import Color +module Dodge.Room.Door where +import Color import Data.Maybe +import Dodge.Data.GenWorld +import Dodge.Default.Door +import Dodge.Default.Room +import Dodge.Placement.Instance +import Dodge.RoomLink +import Geometry door :: Room -door = defaultRoom - { _rmPolys = [rectNSWE 40 0 0 40] - , _rmLinks = lnks - , _rmPath = doublePairSet (V2 20 35,V2 20 5) --- door extends into side walls (for shadows as rendered 12/03) - , _rmPmnts = [putAutoDoor (V2 0 20) (V2 40 20)] - , _rmName = "autoDoor" - , _rmBound = [rectNSWE 21 19 0 40] - } - where - lnks = [uncurry outLink (V2 20 35,0) - ,uncurry inLink (V2 20 5,pi) +door = + defaultRoom + { _rmPolys = [rectNSWE 40 0 0 40] + , _rmLinks = lnks + , _rmPath = doublePairSet (V2 20 35, V2 20 5) + , -- door extends into side walls (for shadows as rendered 12/03) + _rmPmnts = [putAutoDoor (V2 0 20) (V2 40 20)] + , _rmName = "autoDoor" + , _rmBound = [rectNSWE 21 19 0 40] + } + where + lnks = + [ uncurry outLink (V2 20 35, 0) + , uncurry inLink (V2 20 5, pi) ] triggerDoorRoom :: Int -> Room -triggerDoorRoom inplid = defaultRoom - { _rmPolys = [rectNSWE 40 0 0 40] - , _rmLinks = [uncurry outLink (V2 20 35,0) ,uncurry inLink(V2 20 5,pi) ] - , _rmPath = doublePairSet (V2 20 35,V2 20 5) - , _rmInPmnt = [InPlacement f inplid] - , _rmName = "triggerDoorRoom" --- door extends into side walls (for shadows as rendered 12/03/21) --- note no bounds - } - where - f (pmnt:_) = putDoubleDoor DoorObstacle (switchWallCol red) (cond pmnt) (V2 0 20) (V2 40 20) 2 +triggerDoorRoom inplid = + defaultRoom + { _rmPolys = [rectNSWE 40 0 0 40] + , _rmLinks = [uncurry outLink (V2 20 35, 0), uncurry inLink (V2 20 5, pi)] + , _rmPath = doublePairSet (V2 20 35, V2 20 5) + , _rmInPmnt = [InPlacement f inplid] + , _rmName = "triggerDoorRoom" + -- door extends into side walls (for shadows as rendered 12/03/21) + -- note no bounds + } + where + f (pmnt : _) = putDoubleDoor DoorObstacle (switchWallCol red) (cond pmnt) (V2 0 20) (V2 40 20) 2 f _ = error "tried to put a door using an empty placement list" cond pmnt = WdTrig $ fromJust (_plMID pmnt) diff --git a/src/Dodge/Room/Foreground.hs b/src/Dodge/Room/Foreground.hs index f96037bf3..2d9ffdba1 100644 --- a/src/Dodge/Room/Foreground.hs +++ b/src/Dodge/Room/Foreground.hs @@ -1,60 +1,65 @@ ---{-# LANGUAGE TupleSections #-} -module Dodge.Room.Foreground - ( thinHighBar - , putShape - , girder - , girderZ - , girderV - , girderV' - , barPP - , highDiagonalMesh - , highMesh - ) where -import Dodge.Data -import Picture -import Geometry -import Shape -import Quaternion -import Bound +module Dodge.Room.Foreground ( + thinHighBar, + putShape, + girder, + girderZ, + girderV, + girderV', + barPP, + highDiagonalMesh, + highMesh, +) where ---import Dodge.Data.ForegroundShape -import Dodge.Default.Foreground +import Bound +import Control.Lens import Data.List import Data.Maybe -import Control.Lens +import Dodge.Data.GenWorld +import Dodge.Default.ForegroundShape +import Geometry +import Picture +import Quaternion +import Shape import ShapePicture import Streaming import qualified Streaming.Prelude as S -highMesh - :: Point2 - -> Point2 - -> Float -- ^ width - -> Picture -highMesh pa pb w = highDiagonalMesh pa pb w 20 - <> highDiagonalMesh (pa +.+ w *.* normalizeV (vNormal (pb -.- pa))) pa (dist pa pb) 20 +highMesh :: + Point2 -> + Point2 -> + -- | width + Float -> + Picture +highMesh pa pb w = + highDiagonalMesh pa pb w 20 + <> highDiagonalMesh (pa +.+ w *.* normalizeV (vNormal (pb -.- pa))) pa (dist pa pb) 20 -highDiagonalMesh - :: Point2 - -> Point2 - -> Float -- ^ width - -> Float -- ^ vertical distance between lines - -> Picture -highDiagonalMesh pa pb w d = setDepth 100 $ pictures $ - map (thickLine 2 . tflat2) (diagonalLinesRect pb pa w d (3*pi/4)) - ++ - map (thickLine 2 . tflat2) (diagonalLinesRect pb pc (negate h) d (pi/4)) +highDiagonalMesh :: + Point2 -> + Point2 -> + -- | width + Float -> + -- | vertical distance between lines + Float -> + Picture +highDiagonalMesh pa pb w d = + setDepth 100 $ + pictures $ + map (thickLine 2 . tflat2) (diagonalLinesRect pb pa w d (3 * pi / 4)) + ++ map (thickLine 2 . tflat2) (diagonalLinesRect pb pc (negate h) d (pi / 4)) where pc = pb +.+ w *.* normalizeV (vNormal (pb -.- pa)) h = dist pa pb -diagonalLinesRect - :: Point2 - -> Point2 - -> Float -- ^ width - -> Float -- ^ vertical distance between lines - -> Float - -> [(Point2,Point2)] +diagonalLinesRect :: + Point2 -> + Point2 -> + -- | width + Float -> + -- | vertical distance between lines + Float -> + Float -> + [(Point2, Point2)] diagonalLinesRect pa pb w d ang = zip lhsPoints $ map findDiPoint lhsPoints where xVec = negate w *.* vNormal (normalizeV $ pb -.- pa) @@ -62,11 +67,13 @@ diagonalLinesRect pa pb w d ang = zip lhsPoints $ map findDiPoint lhsPoints pax = pa +.+ xVec pbx = pb +.+ xVec lhsPoints = divideLineExact d (pa -.- yN) (pb +.+ yN) - findDiPoint p = head . sortOn (dist p) $ catMaybes - [intersectLineLine' p (p +.+ diVec) pax pbx - ,intersectSegLine pa pax p (p +.+ diVec) - ,intersectSegLine pb pbx p (p +.+ diVec) - ] + findDiPoint p = + head . sortOn (dist p) $ + catMaybes + [ intersectLineLine' p (p +.+ diVec) pax pbx + , intersectSegLine pa pax p (p +.+ diVec) + , intersectSegLine pb pbx p (p +.+ diVec) + ] yN = d * 0.5 *.* normalizeV (pa -.- pb) thinHighBar :: Float -> Point2 -> Point2 -> Shape @@ -82,8 +89,12 @@ thinHighBar = highBar 3 --thickHighBar = highBar 5 highBar :: Float -> Float -> Point2 -> Point2 -> Shape -highBar thickness h x y = translateSHz h $ colorSH orange $ upperPrismPoly thickness - [x +.+ n, y +.+ n, y -.- n, x -.- n] +highBar thickness h x y = + translateSHz h $ + colorSH orange $ + upperPrismPoly + thickness + [x +.+ n, y +.+ n, y -.- n, x -.- n] where n = 0.5 * thickness *.* normalizeV (vNormal (y -.- x)) @@ -95,16 +106,23 @@ highBar thickness h x y = translateSHz h $ colorSH orange $ upperPrismPoly thick -- n2 = 1.25 *.* normalizeV (vNormal (y -.- x)) -- n = 2.5 *.* normalizeV (vNormal (y -.- x)) -girderZ - :: Float -- ^ height - -> Float -- ^ distance between cross bars - -> Float -- ^ width - -> Point2 -> Point2 -> Shape -girderZ h d w x y = colorSH red $ mconcat $ - [ thinHighBar h xt yt - , thinHighBar h xb yb - ] - <> zipWith (thinHighBar (h- 1)) ps qs +girderZ :: + -- | height + Float -> + -- | distance between cross bars + Float -> + -- | width + Float -> + Point2 -> + Point2 -> + Shape +girderZ h d w x y = + colorSH red $ + mconcat $ + [ thinHighBar h xt yt + , thinHighBar h xb yb + ] + <> zipWith (thinHighBar (h - 1)) ps qs where n = w *.* normalizeV (vNormal $ y -.- x) xb = x +.+ n @@ -115,10 +133,12 @@ girderZ h d w x y = colorSH red $ mconcat $ qs = tail $ divideLineExact d xt yt putShape :: Shape -> PSType -putShape sh = PutForeground $ defaultForeground - & fsPos .~ m - & fsRad .~ radBounds bnds - & fsSPic .~ noPic (uncurryV translateSHf (-m) sh) +putShape sh = + PutForeground $ + defaultForeground + & fsPos .~ m + & fsRad .~ radBounds bnds + & fsSPic .~ noPic (uncurryV translateSHf (- m) sh) where bnds = shapeBounds sh m = midBounds bnds @@ -126,43 +146,56 @@ putShape sh = PutForeground $ defaultForeground shapePoints :: Shape -> Stream (Of Point2) Identity () shapePoints = S.each . concatMap (map (stripZ . _svPos) . _shVs) -shapeBounds :: Shape -> (Float,Float,Float,Float) -shapeBounds = fromMaybe (0,0,0,0) . boundPoints . shapePoints +shapeBounds :: Shape -> (Float, Float, Float, Float) +shapeBounds = fromMaybe (0, 0, 0, 0) . boundPoints . shapePoints -midBounds :: (Float,Float,Float,Float) -> Point2 -midBounds (n,s,e,w) = V2 ((n + s)/2) ((e + w)/2) +midBounds :: (Float, Float, Float, Float) -> Point2 +midBounds (n, s, e, w) = V2 ((n + s) / 2) ((e + w) / 2) -radBounds :: (Float, Float,Float,Float) -> Float -radBounds (n,s,e,w) = max (n-s) (e-w) / 2 +radBounds :: (Float, Float, Float, Float) -> Float +radBounds (n, s, e, w) = max (n - s) (e - w) / 2 -girderV' - :: Float -- ^ height - -> Float -- ^ distance between cross bars - -> Float -- ^ width - -> Point2 -> Point2 -> ForegroundShape -girderV' h d w x y = defaultForeground - & fsPos .~ m - & fsRad .~ dist m x - & fsSPic .~ noPic sh +girderV' :: + -- | height + Float -> + -- | distance between cross bars + Float -> + -- | width + Float -> + Point2 -> + Point2 -> + ForegroundShape +girderV' h d w x y = + defaultForeground + & fsPos .~ m + & fsRad .~ dist m x + & fsSPic .~ noPic sh where m = midPoint x y x' = x - m y' = y - m - sh = thinHighBar h (x' -.- n) (x' +.+ n) - <> thinHighBar h (y' -.- n) (y' +.+ n) - <> girderV h d w x' y' + sh = + thinHighBar h (x' -.- n) (x' +.+ n) + <> thinHighBar h (y' -.- n) (y' +.+ n) + <> girderV h d w x' y' n = min (w + 10) 20 *.* vNormal (normalizeV (x' -.- y')) -girderV - :: Float -- ^ height - -> Float -- ^ distance between cross bars - -> Float -- ^ width - -> Point2 -> Point2 -> Shape -girderV h d w x y = mconcat $ - [ thinHighBar h xt yt - , thinHighBar h xb yb - ] - <> zipWith (thinHighBar (h- 1)) ps qs +girderV :: + -- | height + Float -> + -- | distance between cross bars + Float -> + -- | width + Float -> + Point2 -> + Point2 -> + Shape +girderV h d w x y = + mconcat $ + [ thinHighBar h xt yt + , thinHighBar h xb yb + ] + <> zipWith (thinHighBar (h - 1)) ps qs where n = w *.* normalizeV (vNormal $ y -.- x) xb = x +.+ n @@ -170,22 +203,28 @@ girderV h d w x y = mconcat $ xt = x -.- n yt = y -.- n ps = evenDouble $ divideLineExact d xb yb - qs = head qs' : evenDouble(tail qs') + qs = head qs' : evenDouble (tail qs') where qs' = divideLineExact d xt yt - evenDouble (a:_:xs) = a:a:evenDouble xs + evenDouble (a : _ : xs) = a : a : evenDouble xs evenDouble xs = xs -girder - :: Float -- ^ height - -> Float -- ^ distance between cross bars - -> Float -- ^ width - -> Point2 -> Point2 -> Shape -girder h d w x y = mconcat $ - [ thinHighBar h xt yt - , thinHighBar h xb yb - ] - <> zipWith (thinHighBar (h- 1)) ps qs +girder :: + -- | height + Float -> + -- | distance between cross bars + Float -> + -- | width + Float -> + Point2 -> + Point2 -> + Shape +girder h d w x y = + mconcat $ + [ thinHighBar h xt yt + , thinHighBar h xb yb + ] + <> zipWith (thinHighBar (h - 1)) ps qs where n = w *.* normalizeV (vNormal $ y -.- x) xb = x +.+ n @@ -196,11 +235,12 @@ girder h d w x y = mconcat $ qs = divideLineExact d xt yt barPP :: Float -> Point3 -> Point3 -> Shape -barPP w a b +barPP w a b | a == b = mempty - | otherwise = prismPoly - (map ((+.+.+ a) . rotateToZ z1 . addZ 0) $ polyCirc 2 w) - (map ((+.+.+ b) . rotateToZ z1 . addZ 0) $ polyCirc 2 w) + | otherwise = + prismPoly + (map ((+.+.+ a) . rotateToZ z1 . addZ 0) $ polyCirc 2 w) + (map ((+.+.+ b) . rotateToZ z1 . addZ 0) $ polyCirc 2 w) where z1 = b -.-.- a @@ -210,11 +250,11 @@ barPP w a b -- (map ((+.+.+ b) . rotateToZ z1 . addZ 0) $ polyCirc 4 w) -- where -- z1 = b -.-.- a - + --tankTopPipe :: Shape ---tankTopPipe = colorSH orange $ +--tankTopPipe = colorSH orange $ -- upperPrismPoly 31 (polyCirc 4 20) --- <> prismPoly +-- <> prismPoly -- (map (addZ 41) $ polyCirc 4 5) -- (map (addZ 31) $ polyCirc 4 20) ---- <> pipePP 5 (V3 0 0 51) (V3 0 0 41) diff --git a/src/Dodge/Room/Girder.hs b/src/Dodge/Room/Girder.hs index 2fc7d6615..7b17fbb18 100644 --- a/src/Dodge/Room/Girder.hs +++ b/src/Dodge/Room/Girder.hs @@ -1,19 +1,20 @@ module Dodge.Room.Girder where -import Dodge.Data -import RandomHelp + +import Color +import Dodge.Data.GenWorld import Dodge.Room.Foreground import Dodge.Room.Modify.Girder -import Color +import RandomHelp addRandomGirderEW :: RandomGen g => Room -> State g Room addRandomGirderEW rm = do hgshape <- takeOne [girder 96 20 10, girderZ 96 20 10, girderV 96 20 10] lgshape <- takeOne [girder 60 20 10, girderZ 60 20 10, girderV 60 20 10] - addgird <- takeOne [ addGirderNS' hgshape black , addGirderNS' lgshape red ] + addgird <- takeOne [addGirderNS' hgshape black, addGirderNS' lgshape red] addgird rm addRandomGirderFrom :: RandomGen g => CardinalPoint -> Int -> Room -> State g Room addRandomGirderFrom cp i rm = do - (h,col) <- takeOne [(96,black),(60,red)] - gtype <- takeOne [girder,girderZ,girderV] + (h, col) <- takeOne [(96, black), (60, red)] + gtype <- takeOne [girder, girderZ, girderV] return $ addGirderFrom cp i (gtype h 20 10) col rm diff --git a/src/Dodge/Room/GlassLesson.hs b/src/Dodge/Room/GlassLesson.hs index d4f7dbb65..e9b61a611 100644 --- a/src/Dodge/Room/GlassLesson.hs +++ b/src/Dodge/Room/GlassLesson.hs @@ -1,59 +1,69 @@ --{-# LANGUAGE TupleSections #-} module Dodge.Room.GlassLesson where -import Dodge.Cleat -import Dodge.Annotation.Data -import Dodge.RoomLink -import Dodge.Creature -import Dodge.LevelGen.Data -import Dodge.Data -import RandomHelp -import Dodge.Default.Wall -import Dodge.Tree -import Dodge.Placement.Instance ---import Dodge.LevelGen.Data -import Dodge.Room.Procedural -import Dodge.Room.Corridor -import Dodge.Room.Link -import Dodge.Room.Door -import Geometry -import LensHelp import qualified Data.Set as S ---import Control.Monad.Loops +import Dodge.Annotation.Data +import Dodge.Cleat +import Dodge.Creature +import Dodge.Data.GenWorld +import Dodge.Default.Wall +import Dodge.LevelGen.Data +import Dodge.Placement.Instance +import Dodge.Room.Corridor +import Dodge.Room.Door +import Dodge.Room.Link +import Dodge.Room.Procedural +import Dodge.RoomLink +import Dodge.Tree +import Geometry +import LensHelp +import RandomHelp + glassLesson :: RandomGen g => State g (Tree Room) glassLesson = do - i <- takeOne [1,2,3] + i <- takeOne [1, 2, 3] corridors <- replicateM i $ shuffleLinks corridor - return $ Node botRoom - [ pure $ door & rmConnectsTo .~ fromWest North 1 - , uppers - , treeFromPost ( (door & rmConnectsTo .~ S.member (OnEdge East)) - : corridors) $ cleatOnward door] - where - fromWest edge i s = OnEdge edge `S.member` s && FromEdge West i `S.member` s + return $ + Node + botRoom + [ pure $ door & rmConnectsTo .~ fromWest North 1 + , uppers + , treeFromPost + ( (door & rmConnectsTo .~ S.member (OnEdge East)) : + corridors + ) + $ cleatOnward door + ] + where + fromWest edge i s = OnEdge edge `S.member` s && FromEdge West i `S.member` s uppers = Node (door & rmConnectsTo .~ fromWest North 0) [pure topRoom] - botRoom = roomRect 200 200 1 1 - & rmPmnts .~ botplmnts - & rmLinks %~ setInLinksByType (OnEdge West) - topRoom = roomRect 200 200 1 1 - & rmPmnts .~ topplmnts - & rmLinks %~ setInLinks (fromWest South 0 . _rlType) - botplmnts = - [sPS (V2 0 0) 0 $ PutWall (rectNSWE 200 0 90 110) defaultCrystalWall - ,sPS (V2 50 100) 0 $ PutCrit miniGunCrit - ,RandomPlacement $ takeOne - [ spanLightI (V2 160 (-20)) (V2 160 220) - , mntLS vShape (V2 180 200) (V3 160 180 50) - ] + botRoom = + roomRect 200 200 1 1 + & rmPmnts .~ botplmnts + & rmLinks %~ setInLinksByType (OnEdge West) + topRoom = + roomRect 200 200 1 1 + & rmPmnts .~ topplmnts + & rmLinks %~ setInLinks (fromWest South 0 . _rlType) + botplmnts = + [ sPS (V2 0 0) 0 $ PutWall (rectNSWE 200 0 90 110) defaultCrystalWall + , sPS (V2 50 100) 0 $ PutCrit miniGunCrit + , RandomPlacement $ + takeOne + [ spanLightI (V2 160 (-20)) (V2 160 220) + , mntLS vShape (V2 180 200) (V3 160 180 50) + ] ] - topplmnts = - [windowLine (V2 100 200) (V2 100 0) - ,sPS (V2 50 100) 0 $ PutCrit miniGunCrit - ,RandomPlacement $ takeOne - [ spanLightI (V2 160 (-20)) (V2 160 220) - , mntLS vShape (V2 180 200) (V3 160 180 50) - ] + topplmnts = + [ windowLine (V2 100 200) (V2 100 0) + , sPS (V2 50 100) 0 $ PutCrit miniGunCrit + , RandomPlacement $ + takeOne + [ spanLightI (V2 160 (-20)) (V2 160 220) + , mntLS vShape (V2 180 200) (V3 160 180 50) + ] ] + glassLessonRunPast :: RandomGen g => State g MTRS glassLessonRunPast = glassLesson >>= rToOnward "glassLessonRunPast" . f where diff --git a/src/Dodge/Room/LasTurret.hs b/src/Dodge/Room/LasTurret.hs index 669fcdcaf..c64c04e83 100644 --- a/src/Dodge/Room/LasTurret.hs +++ b/src/Dodge/Room/LasTurret.hs @@ -1,68 +1,70 @@ ---{-# LANGUAGE TupleSections #-} module Dodge.Room.LasTurret where -import Dodge.LevelGen.Data + +import qualified Data.Set as S import Dodge.Cleat +import Dodge.Data.GenWorld +import Dodge.Default.Room +import Dodge.Item.Consumable +import Dodge.LevelGen.Data +import Dodge.Placement.Instance +import Dodge.Placement.Instance.Analyser import Dodge.PlacementSpot -import Dodge.Data -import Dodge.Tree -import Dodge.RoomLink -import Dodge.Room.Door import Dodge.Room.Corridor +import Dodge.Room.Door import Dodge.Room.Link import Dodge.Room.Ngon import Dodge.Room.SensorDoor ---import Dodge.Room.Foreground +import Dodge.RoomLink +import Dodge.Tree import Dodge.Wire -import Dodge.Placement.Instance -import Dodge.Placement.Instance.Analyser -import Dodge.Default.Room -import Dodge.Item.Consumable import Geometry import LensHelp import RandomHelp -import qualified Data.Set as S ---import Data.Maybe - cenLasTur :: Room -cenLasTur = roomNgon 8 200 & rmPmnts .~ - [ putLasTurret 0.02 - , heightWallPS (resetPLUse $ rprBoolShift (const . isInLnk) (shiftInBy 100)) 30 covershape - , mntLightLnkCond $ rprBool $ const . isInLnk - ] +cenLasTur = + roomNgon 8 200 & rmPmnts + .~ [ putLasTurret 0.02 + , heightWallPS (resetPLUse $ rprBoolShift (const . isInLnk) (shiftInBy 100)) 30 covershape + , mntLightLnkCond $ rprBool $ const . isInLnk + ] where covershape = rectNSWE 10 (-10) (-20) 20 lightSensInsideDoor :: Int -> Room -> Room -lightSensInsideDoor outplid rm = rm - & rmPmnts .++~ - [ psPt atFstLnkOut (PutForeground $ floorWire (V2 20 0) (V2 20 (-100))) - , psPt atFstLnkOut (PutForeground $ floorWire (V2 0 (-100)) (V2 20 (-100))) - , psPt atFstLnkOut (PutForeground $ verticalWire (V2 20 0) 0 80) - ] - & rmOutPmnt .~ [OutPlacement (sensAboveDoor LASERING 10 (atFstLnkOutShiftInward 100)) outplid] +lightSensInsideDoor outplid rm = + rm + & rmPmnts + .++~ [ psPt atFstLnkOut (PutForeground $ floorWire (V2 20 0) (V2 20 (-100))) + , psPt atFstLnkOut (PutForeground $ floorWire (V2 0 (-100)) (V2 20 (-100))) + , psPt atFstLnkOut (PutForeground $ verticalWire (V2 20 0) 0 80) + ] + & rmOutPmnt .~ [OutPlacement (sensAboveDoor LASERING 10 (atFstLnkOutShiftInward 100)) outplid] lightSensByDoor :: Int -> Room -> Room -lightSensByDoor outplid rm = rm - & rmPmnts .++~ - [ psPt atFstLnkOut $ PutForeground $ verticalWire (V2 20 0) 0 80 - , heightWallPS (atNthLnkOutShiftInward 1 100) 30 covershape - , heightWallPS (atFstLnkOutShiftInward 100) 30 covershape - ] - & rmOutPmnt .~ [OutPlacement (sensAboveDoor LASERING 20 (atFstLnkOutShiftBy sensorshift)) outplid] +lightSensByDoor outplid rm = + rm + & rmPmnts + .++~ [ psPt atFstLnkOut $ PutForeground $ verticalWire (V2 20 0) 0 80 + , heightWallPS (atNthLnkOutShiftInward 1 100) 30 covershape + , heightWallPS (atFstLnkOutShiftInward 100) 30 covershape + ] + & rmOutPmnt .~ [OutPlacement (sensAboveDoor LASERING 20 (atFstLnkOutShiftBy sensorshift)) outplid] where covershape = rectNSWE 10 (-10) (-20) 20 - sensorshift (p,a) = (p +.+ rotateV a (V2 60 (-20)), a) + sensorshift (p, a) = (p +.+ rotateV a (V2 60 (-20)), a) keyCardRoomRunPast :: RandomGen g => Int -> Int -> State g (MetaTree Room String) keyCardRoomRunPast keyid rmid = do cenroom <- shuffleLinks $ keyCardAnalyserByDoor keyid rmid $ roomNgon 6 200 let doorroom = triggerDoorRoom rmid rToOnward "keyCardRoomRunPast" $ - treeFromTrunk [door] $ Node cenroom - [ treeFromPost [doorroom] (cleatOnward door) - , treeFromPost [door] (cleatLabel rmid corridor) - ] + treeFromTrunk [door] $ + Node + cenroom + [ treeFromPost [doorroom] (cleatOnward door) + , treeFromPost [door] (cleatLabel rmid corridor) + ] keyCardAnalyserByDoor :: Int -> Int -> Room -> Room keyCardAnalyserByDoor keyid = analyserByDoor (RequireEquipment (HELD (KEYCARD keyid))) @@ -71,78 +73,91 @@ healthAnalyserByDoor :: Int -> Room -> Room healthAnalyserByDoor = analyserByDoor (RequireHealth 1100) analyserByDoor :: ProximityRequirement -> Int -> Room -> Room -analyserByDoor proxreq outplid rm = rm - & rmPmnts .++~ - [ psPt atFstLnkOut $ PutForeground $ verticalWire (V2 20 0) 0 80 - ] - & rmOutPmnt .~ - [OutPlacement - (analyser proxreq - (atFstLnkOutShiftBy (\(p,a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a))) - (atFstLnkOutShiftBy sensorshift) - ) - outplid] +analyserByDoor proxreq outplid rm = + rm + & rmPmnts + .++~ [ psPt atFstLnkOut $ PutForeground $ verticalWire (V2 20 0) 0 80 + ] + & rmOutPmnt + .~ [ OutPlacement + ( analyser + proxreq + (atFstLnkOutShiftBy (\(p, a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a))) + (atFstLnkOutShiftBy sensorshift) + ) + outplid + ] where - sensorshift (p,a) = (p +.+ rotateV a (V2 30 (-10)), a) + sensorshift (p, a) = (p +.+ rotateV a (V2 30 (-10)), a) healthTest :: RandomGen g => Int -> State g (Tree Room) healthTest n = do cenroom <- shuffleLinks $ healthAnalyserByDoor n $ roomNgon 8 200 - return $ treePost - [ door - , corridor & rmPmnts .:~ spNoID (PS 20 0) (PutFlIt (medkit 100)) - , cenroom - , triggerDoorRoom n - , cleatOnward door - ] + return $ + treePost + [ door + , corridor & rmPmnts .:~ spNoID (PS 20 0) (PutFlIt (medkit 100)) + , cenroom + , triggerDoorRoom n + , cleatOnward door + ] lasSensorTurretTest :: RandomGen g => Int -> State g (MetaTree Room String) lasSensorTurretTest n = do cenroom <- shuffleLinks $ lightSensInsideDoor n cenLasTur - rToOnward "lasSensorTurretTest" $ treePost - [ door, cenroom, triggerDoorRoom n, cleatOnward door] + rToOnward "lasSensorTurretTest" $ + treePost + [door, cenroom, triggerDoorRoom n, cleatOnward door] lasCenSensEdge :: RandomGen g => Int -> State g (MetaTree Room String) lasCenSensEdge n = do cenroom <- shuffleLinks $ lightSensByDoor n cenLasTur let doorroom = triggerDoorRoom n - rToOnward "lasCenSensEdge" - $ treeFromTrunk [ door] $ Node cenroom - [ treePost [ doorroom, cleatOnward door ] - , treePost [ door, cleatLabel 0 corridor] - ] + rToOnward "lasCenSensEdge" $ + treeFromTrunk [door] $ + Node + cenroom + [ treePost [doorroom, cleatOnward door] + , treePost [door, cleatLabel 0 corridor] + ] lasTunnel :: RandomGen g => Float -> State g Room lasTunnel y = do - extraPlmnts <- takeOne - [ [ midWall ( rectNSWE 115 90 0 60) - , midWall ( rectNSWE 65 40 (-40) 25) + extraPlmnts <- + takeOne + [ + [ midWall (rectNSWE 115 90 0 60) + , midWall (rectNSWE 65 40 (-40) 25) + ] + , + [ midWall (rectNSWE 125 100 0 25) + , midWall (rectNSWE 80 40 (-40) 0) + , midWall (rectNSWE 80 40 25 60) + ] ] - , [ midWall ( rectNSWE 125 100 0 25) - , midWall ( rectNSWE 80 40 (-40) 0) - , midWall ( rectNSWE 80 40 25 60) - ] - ] - return defaultRoom - { _rmPolys = polys - , _rmBound = polys - , _rmLinks = - [outLink (V2 20 (190 + y)) (1.5* pi) - ,outLink (V2 0 (190 + y)) (0.5* pi) - , inLink (V2 (-40) 20) (0.5* pi) - , inLink (V2 60 20) (1.5* pi) - , inLink (V2 10 0) pi - ] - , _rmPmnts = [putLasTurret 0.005 & plSpot .~ PS (V2 10 (240+y)) (1.5*pi) - --, midWall (rectNSEW 65 40 0 25) - , mntLS vShape (V2 60 145) (V3 40 125 90) - , mntLS vShape (V2 (-40) 145) (V3 (-20) 125 90) - ] - ++ extraPlmnts - , _rmName = "lasTunnel" ++ show y - } + return + defaultRoom + { _rmPolys = polys + , _rmBound = polys + , _rmLinks = + [ outLink (V2 20 (190 + y)) (1.5 * pi) + , outLink (V2 0 (190 + y)) (0.5 * pi) + , inLink (V2 (-40) 20) (0.5 * pi) + , inLink (V2 60 20) (1.5 * pi) + , inLink (V2 10 0) pi + ] + , _rmPmnts = + [ putLasTurret 0.005 & plSpot .~ PS (V2 10 (240 + y)) (1.5 * pi) + , --, midWall (rectNSEW 65 40 0 25) + mntLS vShape (V2 60 145) (V3 40 125 90) + , mntLS vShape (V2 (-40) 145) (V3 (-20) 125 90) + ] + ++ extraPlmnts + , _rmName = "lasTunnel" ++ show y + } where - polys = [rectNSWE (250+y) 0 0 20 + polys = + [ rectNSWE (250 + y) 0 0 20 , rectNSWE 145 0 (-40) 60 ] @@ -150,9 +165,11 @@ lasTunnel y = do lasTunnelRunPast :: RandomGen g => Float -> State g (MetaTree Room String) lasTunnelRunPast y = do r <- lasTunnel y - r1 <- takeOne [door,corridor] - r2 <- takeOne [door,corridor] - rToOnward "lasTunnelRunPast" $ Node r - [ pure $ cleatOnward r1 - , return (cleatLabel 0 $ r2 & rmConnectsTo .~ S.member InLink) - ] + r1 <- takeOne [door, corridor] + r2 <- takeOne [door, corridor] + rToOnward "lasTunnelRunPast" $ + Node + r + [ pure $ cleatOnward r1 + , return (cleatLabel 0 $ r2 & rmConnectsTo .~ S.member InLink) + ] diff --git a/src/Dodge/Room/Link.hs b/src/Dodge/Room/Link.hs index b5a15b083..e9ee6d6d6 100644 --- a/src/Dodge/Room/Link.hs +++ b/src/Dodge/Room/Link.hs @@ -3,31 +3,29 @@ Link pairs determine where rooms can attach to each other; each pair consists of a position and a rotation. The last link in the list is considered the incoming link, the other links are the outgoing links. -} -module Dodge.Room.Link - ( shiftRoomShiftToLink - , moveRoomBy - , shiftLinkBy - , doRoomShift - , shuffleLinks - , restrictRMInLinksPD - ) where -import Dodge.ShiftPoint ---import Dodge.Placement.PlaceSpot -import Dodge.Placement.Shift ---import Dodge.LevelGen.Data -import Dodge.Data -import RandomHelp -import Geometry -import Data.Tile -import Dodge.RoomLink +module Dodge.Room.Link ( + shiftRoomShiftToLink, + moveRoomBy, + shiftLinkBy, + doRoomShift, + shuffleLinks, + restrictRMInLinksPD, +) where import Control.Lens import qualified Data.Set as S +import Data.Tile +import Dodge.Data.GenWorld +import Dodge.Placement.Shift +import Dodge.RoomLink +import Dodge.ShiftPoint +import Geometry +import RandomHelp -restrictRMInLinksPD :: ((Point2,Float) -> Bool) -> Room -> Room +restrictRMInLinksPD :: ((Point2, Float) -> Bool) -> Room -> Room restrictRMInLinksPD f = rmLinks %~ restrictLinkType InLink f -{- Shuffle the order of all links of a room randomly. +{- Shuffle the order of all links of a room randomly. - Note this does not change their types. -} shuffleLinks :: RandomGen g => Room -> State g Room shuffleLinks = rmLinks %%~ shuffle @@ -36,57 +34,63 @@ doRoomShift :: Room -> Room doRoomShift rm = shiftRoomBy (_rmShift rm) rm & rmShift .~ _rmShift rm -- NOTE placements, when placed, will be shifted by the value _rmShift -shiftRoomBy :: (Point2,Float) -> Room -> Room -shiftRoomBy shift r = r - & rmPolys %~ fmap (map (shiftPointBy shift)) - & rmLinks %~ fmap (shiftLinkBy shift) - & rmPath %~ S.map (shiftPathBy shift) - & rmBound %~ fmap (map (shiftPointBy shift)) - & rmShift %~ shiftPosDirBy shift - & rmFloor . tiles %~ map - ( (tilePoly %~ map (shiftPointBy shift)) - . (tileZero %~ shiftPointBy shift ) - . (tileX %~ shiftPointBy shift ) - ) - & rmViewpoints %~ map (shiftPointBy shift) - -moveRoomBy :: (Point2,Float) -> Room -> Room -moveRoomBy shift r = r - & rmPolys %~ fmap (map (shiftPointBy shift)) - & rmLinks %~ fmap (shiftLinkBy shift) - & rmPath %~ S.map (shiftPathBy shift) - & rmBound %~ fmap (map (shiftPointBy shift)) - & rmPmnts %~ map (shiftPlacement shift) - & rmFloor . tiles %~ map - ( (tilePoly %~ map (shiftPointBy shift)) - . (tileZero %~ shiftPointBy shift ) - . (tileX %~ shiftPointBy shift ) - ) - & rmViewpoints %~ map (shiftPointBy shift) - & rmPos %~ map ( ( rpPos %~ shiftPointBy shift ) . (rpDir +~ snd shift) ) - -shiftRoomShiftToLink :: (Point2,Float) -> (Point2,Float) -> Room -> Room -shiftRoomShiftToLink l inlink r - = shiftRoomShiftBy l - . shiftRoomShiftBy (V2 0 0 , pi-a) - $ shiftRoomShiftBy (V2 0 0 -.- p , 0) +shiftRoomBy :: (Point2, Float) -> Room -> Room +shiftRoomBy shift r = r - where - (p,a) = inlink + & rmPolys %~ fmap (map (shiftPointBy shift)) + & rmLinks %~ fmap (shiftLinkBy shift) + & rmPath %~ S.map (shiftPathBy shift) + & rmBound %~ fmap (map (shiftPointBy shift)) + & rmShift %~ shiftPosDirBy shift + & rmFloor . tiles + %~ map + ( (tilePoly %~ map (shiftPointBy shift)) + . (tileZero %~ shiftPointBy shift) + . (tileX %~ shiftPointBy shift) + ) + & rmViewpoints %~ map (shiftPointBy shift) + +moveRoomBy :: (Point2, Float) -> Room -> Room +moveRoomBy shift r = + r + & rmPolys %~ fmap (map (shiftPointBy shift)) + & rmLinks %~ fmap (shiftLinkBy shift) + & rmPath %~ S.map (shiftPathBy shift) + & rmBound %~ fmap (map (shiftPointBy shift)) + & rmPmnts %~ map (shiftPlacement shift) + & rmFloor . tiles + %~ map + ( (tilePoly %~ map (shiftPointBy shift)) + . (tileZero %~ shiftPointBy shift) + . (tileX %~ shiftPointBy shift) + ) + & rmViewpoints %~ map (shiftPointBy shift) + & rmPos %~ map ((rpPos %~ shiftPointBy shift) . (rpDir +~ snd shift)) + +shiftRoomShiftToLink :: (Point2, Float) -> (Point2, Float) -> Room -> Room +shiftRoomShiftToLink l inlink r = + shiftRoomShiftBy l + . shiftRoomShiftBy (V2 0 0, pi - a) + $ shiftRoomShiftBy + (V2 0 0 -.- p, 0) + r + where + (p, a) = inlink + -- NOTE placements, when placed, will be shifted by the value _rmShift -shiftRoomShiftBy :: (Point2,Float) -> Room -> Room +shiftRoomShiftBy :: (Point2, Float) -> Room -> Room shiftRoomShiftBy shift = rmShift %~ shiftPosDirBy shift -shiftPosDirBy :: (Point2,Float) -> (Point2,Float) -> (Point2,Float) -shiftPosDirBy (pos,rot) (p,r) = (shiftPointBy (pos,rot) p, r + rot) +shiftPosDirBy :: (Point2, Float) -> (Point2, Float) -> (Point2, Float) +shiftPosDirBy (pos, rot) (p, r) = (shiftPointBy (pos, rot) p, r + rot) -shiftLinkBy :: (Point2,Float) -> RoomLink -> RoomLink -shiftLinkBy (pos,rot) = overLnkPosDir f +shiftLinkBy :: (Point2, Float) -> RoomLink -> RoomLink +shiftLinkBy (pos, rot) = overLnkPosDir f where - f (p,r) = (shiftPointBy (pos,rot) p, r + rot) + f (p, r) = (shiftPointBy (pos, rot) p, r + rot) -shiftPathBy :: (Point2,Float) -> (Point2,Point2) -> (Point2,Point2) -shiftPathBy s (p1,p2) = sp1 `seq` sp2 `seq` (sp1, sp2) +shiftPathBy :: (Point2, Float) -> (Point2, Point2) -> (Point2, Point2) +shiftPathBy s (p1, p2) = sp1 `seq` sp2 `seq` (sp1, sp2) where sp1 = shiftPointBy s p1 sp2 = shiftPointBy s p2 diff --git a/src/Dodge/Room/LongDoor.hs b/src/Dodge/Room/LongDoor.hs index 2e70551cc..bbbfb4a03 100644 --- a/src/Dodge/Room/LongDoor.hs +++ b/src/Dodge/Room/LongDoor.hs @@ -1,77 +1,83 @@ ---{-# LANGUAGE TupleSections #-} -{- | Rooms containing long doors, probably with a big reveal behind them. - -} +-- | Rooms containing long doors, probably with a big reveal behind them. module Dodge.Room.LongDoor where -import Dodge.Terminal -import Dodge.Data -import Dodge.Default.Door + +import Dodge.LevelGen.Switch +import Data.Maybe +import qualified Data.Set as S import Dodge.Cleat -import Dodge.RoomLink -import Dodge.Tree +import Dodge.Creature +import Dodge.Data.GenWorld +import Dodge.Default.Door import Dodge.Default.Room import Dodge.LevelGen.Data +import Dodge.LightSource import Dodge.Placement.Instance import Dodge.PlacementSpot -import Dodge.Room.Link import Dodge.Room.Door +import Dodge.Room.Link import Dodge.Room.Procedural ---import Dodge.Layout.Tree.Either ---import Dodge.LevelGen.Data -import Dodge.LevelGen.Switch -import RandomHelp -import Dodge.Creature.Inanimate -import Dodge.Creature -import Dodge.LightSource -import Picture +import Dodge.RoomLink +import Dodge.Terminal +import Dodge.Tree import Geometry import LensHelp ---import Shape +import Picture +import RandomHelp -import qualified Data.Set as S -import Data.Maybe - -twinSlowDoorRoom - :: Float -- ^ Half width - -> Float -- ^ Half height - -> Float -- ^ Inner width - -> Room -twinSlowDoorRoom w h x = defaultRoom - { _rmPolys = ps - , _rmLinks = map (uncurry outLink) - [ (V2 w (h/2) , negate $ pi/2) - , (V2 (-w) (h/2) , pi/2) ] - ++ [uncurry inLink (V2 0 (-h), pi) ] - , _rmPath = mempty - , _rmPmnts = - [ pContID (PS (V2 0 (h-5)) pi) ( PutButton $ makeButton col NoWorldEffect) - $ \btid -> jsps0J (PutSlideDr (thedoor btid) thewall DoorObstacle 1 (V2 x 1) (V2 x h)) - $ ps0 (PutSlideDr (thedoor btid) thewall DoorObstacle 1 (V2 (-x) 1) (V2 (-x) h)) - $ \did -> jps0' (PutLS (lsColPos (V3 0.75 0 0) (V3 0 (h-1) lampheight))) - $ \lspl -> jsps0 $ PutProp $ addColorChange (fromJust $ _plMID lspl) did $ lampCoverWhen (WdBlDoorMoving did) (V2 0 (h-1)) lampheight - ] - , _rmBound = ps - , _rmName = "twinSlowDoorRoom" - , _rmViewpoints = [V2 0 h] - } +twinSlowDoorRoom :: + -- | Half width + Float -> + -- | Half height + Float -> + -- | Inner width + Float -> + Room +twinSlowDoorRoom w h x = + defaultRoom + { _rmPolys = ps + , _rmLinks = + map + (uncurry outLink) + [ (V2 w (h / 2), negate $ pi / 2) + , (V2 (- w) (h / 2), pi / 2) + ] + ++ [uncurry inLink (V2 0 (- h), pi)] + , _rmPath = mempty + , _rmPmnts = + [ pContID (PS (V2 0 (h -5)) pi) (PutButton $ makeButton col NoWorldEffect) $ + \btid -> jsps0J (PutSlideDr (thedoor btid) thewall DoorObstacle 1 (V2 x 1) (V2 x h)) $ + ps0 (PutSlideDr (thedoor btid) thewall DoorObstacle 1 (V2 (- x) 1) (V2 (- x) h)) $ + \did -> jps0' (PutLS (lsColPos (V3 0.75 0 0) (V3 0 (h -1) lampheight))) $ + \lspl -> jsps0 $ PutProp $ addColorChange (fromJust $ _plMID lspl) did $ lampCoverWhen (WdBlDoorMoving did) (V2 0 (h -1)) lampheight + ] + , _rmBound = ps + , _rmName = "twinSlowDoorRoom" + , _rmViewpoints = [V2 0 h] + } where thewall = switchWallCol red wlSpeed = 0.5 - addColorChange lsid drid = over prUpdate $ PropUpdateAnd $ PropUpdateIf (WdBlDoorMoving drid) - (PropUpdateLS lsid (PrWdLsSetColor (V3 8 0 0))) - (PropUpdateLS lsid (PrWdLsSetColor 0.7)) + addColorChange lsid drid = + over prUpdate $ + PropUpdateAnd $ + PropUpdateIf + (WdBlDoorMoving drid) + (PropUpdateLS lsid (PrWdLsSetColor (V3 8 0 0))) + (PropUpdateLS lsid (PrWdLsSetColor 0.7)) lampheight = 41 - ps = - [rectNSWE h 0 (-w) w - ,rectNSWE 20 (-h) (negate x) x + ps = + [ rectNSWE h 0 (- w) w + , rectNSWE 20 (- h) (negate x) x ] - thedoor btid = defaultDoor - & drSpeed .~ wlSpeed - & drTrigger .~ WdBlBtNotOff btid + thedoor btid = + defaultDoor + & drSpeed .~ wlSpeed + & drTrigger .~ WdBlBtNotOff btid col = dim $ dim $ bright red twinSlowDoorChasers :: RandomGen g => State g Room twinSlowDoorChasers = do - ps <- takeN 4 $ [ V2 x y | x <- [-65,65], y <- [20,40 .. 180] ] + ps <- takeN 4 $ [V2 x y | x <- [-65, 65], y <- [20, 40 .. 180]] let plmnts = map (\p -> sPS p 0 $ PutCrit chaseCrit) ps return $ twinSlowDoorRoom 80 200 40 & rmPmnts %~ (plmnts ++) @@ -81,59 +87,79 @@ southPillarsRoom x y h = addSouthPillars x h (roomRectAutoLinks x y) addSouthPillars :: RandomGen g => Float -> Float -> Room -> State g Room addSouthPillars x h r = do let pillarsa = [] - pillarsb = concat [putBlockRect (i*x/5-20) (i*x/5+20) (h/2-20) (h/2+20) | i <- [1..4] ] - pillarsc = concat [putBlockRect (i*x/3-20) (i*x/3+20) (h/2-20) (h/2+20) | i <- [1,2] ] + pillarsb = concat [putBlockRect (i * x / 5 -20) (i * x / 5 + 20) (h / 2 -20) (h / 2 + 20) | i <- [1 .. 4]] + pillarsc = concat [putBlockRect (i * x / 3 -20) (i * x / 3 + 20) (h / 2 -20) (h / 2 + 20) | i <- [1, 2]] pillars <- takeOne [pillarsa, pillarsb, pillarsc] return $ r & rmPmnts .++~ pillars addButtonSlowDoor :: RandomGen g => Float -> Float -> Room -> State g Room addButtonSlowDoor x h rm = do - shuffleLinks $ setOutLinksPD aboveH $ setInLinksPD belowH $ rm - & rmPmnts .++~ [butDoor , theterminal] - & rmBound .:~ openDoorBound + shuffleLinks $ + setOutLinksPD aboveH $ + setInLinksPD belowH $ + rm + & rmPmnts .++~ [butDoor, theterminal] + & rmBound .:~ openDoorBound where - theterminal = putMessageTerminal terminalColor (simpleTermMessage themessage) - & plSpot .~ rprBoolShift (isUnusedLnkType InLink) (shiftByV2 (V2 0 (-10))) - themessage = - ["WARNING:" - ,"LARGE BIOMASS DETECTED" + theterminal = + putMessageTerminal terminalColor (simpleTermMessage themessage) + & plSpot .~ rprBoolShift (isUnusedLnkType InLink) (shiftByV2 (V2 0 (-10))) + themessage = + [ "WARNING:" + , "LARGE BIOMASS DETECTED" ] - openDoorBound = reverse $ rectNSWE (h + 5) (h - 5) (3*x/2) (-x/2) + openDoorBound = reverse $ rectNSWE (h + 5) (h - 5) (3 * x / 2) (- x / 2) belowH y = (sndV2 . fst) y < h - 40 aboveH y = (sndV2 . fst) y > h + 40 - amountedlight dr xoff mpl = Just . moveLSThen (WdP2fDoorPosition (fromJust $ _plMID dr)) - (V3 15 xoff 89) (aShape (V2 15 0) (V3 15 xoff 90)) - $ \plls plpr -> Just $ ptCont (PutWorldUpdate (const $ setmount dr plls plpr)) - $ const mpl - setmount pldr plls plpr = cWorld . doors . ix (fromJust $ _plMID pldr) . drMounts .++~ - [MountedLS (fromJust $ _plMID plls), MountedProp (fromJust $ _plMID plpr)] + amountedlight dr xoff mpl = Just + . moveLSThen + (WdP2fDoorPosition (fromJust $ _plMID dr)) + (V3 15 xoff 89) + (aShape (V2 15 0) (V3 15 xoff 90)) + $ \plls plpr -> + Just $ + ptCont (PutWorldUpdate (const $ setmount dr plls plpr)) $ + const mpl + setmount pldr plls plpr = + cWorld . doors . ix (fromJust $ _plMID pldr) . drMounts + .++~ [MountedLS (fromJust $ _plMID plls), MountedProp (fromJust $ _plMID plpr)] -- TODO make the height of this light source and of other mounted lights -- be taken from a single consistent source thewall = switchWallCol red - butDoor = putLitButOnPos col + butDoor = putLitButOnPos + col (rprBool (isUnusedLnkType InLink)) - $ \btplmnt -> Just $ putDoubleDoorThen DoorObstacle thewall (WdBlBtNotOff $ fromJust $ _plMID btplmnt) - 30 (V2 0 h) (V2 x h) 2 - $ \dr1 dr2 -> - amountedlight dr1 50 - $ amountedlight dr1 (-50) - $ amountedlight dr2 50 - $ amountedlight dr2 (-50) - Nothing + $ \btplmnt -> Just $ + putDoubleDoorThen + DoorObstacle + thewall + (WdBlBtNotOff $ fromJust $ _plMID btplmnt) + 30 + (V2 0 h) + (V2 x h) + 2 + $ \dr1 dr2 -> + amountedlight dr1 50 $ + amountedlight dr1 (-50) $ + amountedlight dr2 50 $ + amountedlight + dr2 + (-50) + Nothing col = dim $ light red slowDoorRoom :: RandomGen g => State g Room slowDoorRoom = do - x <- state $ randomR (400,800) - y <- state $ randomR (400,800) - h <- state $ randomR (200,min (y-100) 500) + x <- state $ randomR (400, 800) + y <- state $ randomR (400, 800) + h <- state $ randomR (200, min (y -100) 500) let n = 25 - xs <- replicateM n $ state $ randomR (10,x-10) - ys <- replicateM n $ state $ randomR (h+20,y) - rs <- replicateM n $ state $ randomR (0,2*pi) + xs <- replicateM n $ state $ randomR (10, x -10) + ys <- replicateM n $ state $ randomR (h + 20, y) + rs <- replicateM n $ state $ randomR (0, 2 * pi) let ps = zipWith V2 xs ys - xs' <- replicateM 5 $ state $ randomR (10,x-10) - ys' <- replicateM 5 $ state $ randomR (h+20,y) + xs' <- replicateM 5 $ state $ randomR (10, x -10) + ys' <- replicateM 5 $ state $ randomR (h + 20, y) let crits = zipWith (\p r -> sPS p r randC1) ps rs barrels = zipWith (\x' y' -> sPS (V2 x' y') 0 $ PutCrit explosiveBarrel) xs' ys' proom <- southPillarsRoom x y h @@ -142,7 +168,10 @@ slowDoorRoom = do slowDoorRoomRunPast :: RandomGen g => State g (MetaTree Room String) slowDoorRoomRunPast = do r <- slowDoorRoom - rToOnward "slowDoorRoomRunPast" $ treeFromTrunk [ door] $ Node r - [ pure $ cleatOnward door - , return (cleatLabel 0 $ door & rmConnectsTo .~ S.member InLink) - ] + rToOnward "slowDoorRoomRunPast" $ + treeFromTrunk [door] $ + Node + r + [ pure $ cleatOnward door + , return (cleatLabel 0 $ door & rmConnectsTo .~ S.member InLink) + ] diff --git a/src/Dodge/Room/LongRoom.hs b/src/Dodge/Room/LongRoom.hs index b34d9813d..aa9fb5467 100644 --- a/src/Dodge/Room/LongRoom.hs +++ b/src/Dodge/Room/LongRoom.hs @@ -1,57 +1,56 @@ ---{-# LANGUAGE TupleSections #-} module Dodge.Room.LongRoom where -import Dodge.Cleat -import Dodge.RoomLink -import Dodge.Tree ---import Dodge.Default.Room -import Dodge.Default.Wall -import Dodge.LevelGen.Data -import Dodge.Data -import Dodge.Placement.Instance -import Dodge.Room.Link -import Dodge.Room.Door -import Dodge.Room.Corridor -import Dodge.Room.Procedural ---import Dodge.Layout.Tree.Either ---import Dodge.LevelGen.Data ---import Dodge.LevelGen.Switch -import RandomHelp -import Dodge.Creature.Inanimate -import Dodge.Creature ---import Dodge.LightSource ---import Picture -import Geometry -import LensHelp -import Data.Tile import qualified Data.Set as S ---import qualified Data.IntMap as IM +import Data.Tile +import Dodge.Cleat +import Dodge.Creature +import Dodge.Data.GenWorld +import Dodge.Default.Wall +import Dodge.LevelGen.Data +import Dodge.Placement.Instance +import Dodge.Room.Corridor +import Dodge.Room.Door +import Dodge.Room.Link +import Dodge.Room.Procedural +import Dodge.RoomLink +import Dodge.Tree +import Geometry +import LensHelp +import RandomHelp longRoom :: RandomGen g => State g Room longRoom = do - h <- state $ randomR (1500,1500) + h <- state $ randomR (1500, 1500) let w = 75 - let wlsNSEWs wln wls listew = [sps0 $ PutWall (rectNSWE wln wls wallw walle) defaultCrystalWall - | (wallw,walle) <- listew ] - let ws = wlsNSEWs (h-35) (h-135) [(-10,10) , (15,35) , (40,60) , (65,85)] - let wsDefense = wlsNSEWs 95 70 [(0,25) , (50,75) ] - brlN <- state $ randomR (0,5) - brlOffsets <- replicateM brlN $ randInRect (w-20) 900 - let brls = [ sPS (p +.+ V2 10 200) 0 $ PutCrit explosiveBarrel | p <- brlOffsets ] - rm <- shuffleLinks $ roomRect w (h+70) 1 1 & rmPolys .++~ [rectNSWE h (h-165) (-45) (w+45)] - & rmFloor .~ InheritFloor - return $ restrictInLinks (\x -> (sndV2 . fst) x < 40) - $ restrictOutLinks (\x -> (sndV2 . fst) x > h * 0.75) - $ rm & rmPmnts .~ ws ++ brls ++ wsDefense ++ - [sPS (V2 crx (h-25)) 0 $ PutCrit longCrit - | crx <- [12.5,37.5,62.5] ] ++ - [sPS (V2 25 lampy ) 0 putLamp | lampy <- [20,h-10] ] + let wlsNSEWs wln wls listew = + [ sps0 $ PutWall (rectNSWE wln wls wallw walle) defaultCrystalWall + | (wallw, walle) <- listew + ] + let ws = wlsNSEWs (h -35) (h -135) [(-10, 10), (15, 35), (40, 60), (65, 85)] + let wsDefense = wlsNSEWs 95 70 [(0, 25), (50, 75)] + brlN <- state $ randomR (0, 5) + brlOffsets <- replicateM brlN $ randInRect (w -20) 900 + let brls = [sPS (p +.+ V2 10 200) 0 $ PutCrit explosiveBarrel | p <- brlOffsets] + rm <- + shuffleLinks $ + roomRect w (h + 70) 1 1 & rmPolys .++~ [rectNSWE h (h -165) (-45) (w + 45)] + & rmFloor .~ InheritFloor + return $ + restrictInLinks (\x -> (sndV2 . fst) x < 40) $ + restrictOutLinks (\x -> (sndV2 . fst) x > h * 0.75) $ + rm & rmPmnts .~ ws ++ brls ++ wsDefense + ++ [ sPS (V2 crx (h -25)) 0 $ PutCrit longCrit + | crx <- [12.5, 37.5, 62.5] + ] + ++ [sPS (V2 25 lampy) 0 putLamp | lampy <- [20, h -10]] longRoomRunPast :: RandomGen g => State g (MetaTree Room String) longRoomRunPast = do r <- longRoom - rToOnward "longRoomRunPast" - $ treeFromTrunk [door] $ Node r - [ pure $ cleatOnward door - , treePost [ corridor & rmConnectsTo .~ S.member InLink, cleatLabel 0 door ] - ] + rToOnward "longRoomRunPast" $ + treeFromTrunk [door] $ + Node + r + [ pure $ cleatOnward door + , treePost [corridor & rmConnectsTo .~ S.member InLink, cleatLabel 0 door] + ] diff --git a/src/Dodge/Room/Modify/Girder.hs b/src/Dodge/Room/Modify/Girder.hs index 7d9fbce88..4aa031694 100644 --- a/src/Dodge/Room/Modify/Girder.hs +++ b/src/Dodge/Room/Modify/Girder.hs @@ -1,76 +1,90 @@ -module Dodge.Room.Modify.Girder - ( addGirderLights - , addGirderFrom - , addHighGirder - , addHighGirder' - , addGirderEW - , addGirderNS - , addGirderNS' - ) where ---import Dodge.Data -import Dodge.LevelGen.Data -import Dodge.Data ---import Dodge.Room.Procedural -import Dodge.Room.Foreground ---import Dodge.Room.RoadBlock ---import Dodge.Placement.Instance ---import Dodge.Placement.TopDecoration -import Dodge.PlacementSpot -import Dodge.LightSource ---import Padding -import Color -import Shape -import LensHelp -import Geometry -import RandomHelp +module Dodge.Room.Modify.Girder ( + addGirderLights, + addGirderFrom, + addHighGirder, + addHighGirder', + addGirderEW, + addGirderNS, + addGirderNS', +) where -import Data.Maybe +import Color import Data.List (nub) +import Data.Maybe import qualified Data.Set as S +import Dodge.Data.GenWorld +import Dodge.LevelGen.Data +import Dodge.LightSource +import Dodge.PlacementSpot +import Dodge.Room.Foreground +import Geometry +import LensHelp +import RandomHelp +import Shape addGirderNS :: RandomGen g => (Point2 -> Point2 -> Shape) -> Color -> Room -> State g Room addGirderNS shapef col room = do let nwestlnks = length $ filter ((OnEdge North `S.member`) . _rlType) $ _rmLinks room girderPosOrder <- shuffle [1 .. nwestlnks - 2] - return $ room & rmPmnts .:~ foldr1 setFallback - (sps0 PutNothing : [ twoRoomPoss - (isUnusedLnkType (FromEdge West i)) - (isUnusedLnkType (FromEdge West i)) - $ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2) - | i <- girderPosOrder] - ) + return $ + room & rmPmnts + .:~ foldr1 + setFallback + ( sps0 PutNothing : + [ twoRoomPoss + (isUnusedLnkType (FromEdge West i)) + (isUnusedLnkType (FromEdge West i)) + $ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2) + | i <- girderPosOrder + ] + ) addGirderFrom :: CardinalPoint -> Int -> (Point2 -> Point2 -> Shape) -> Color -> Room -> Room -addGirderFrom cp fromi shapef col = rmPmnts .:~ foldr1 setFallback - [ sps0 PutNothing - , twoRoomPoss rmposcond rmposcond - $ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2) ] +addGirderFrom cp fromi shapef col = + rmPmnts + .:~ foldr1 + setFallback + [ sps0 PutNothing + , twoRoomPoss rmposcond rmposcond $ + \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2) + ] where rmposcond = isUnusedLnkType (FromEdge cp fromi) + -- | Allows girder to be on edge addGirderNS' :: RandomGen g => (Point2 -> Point2 -> Shape) -> Color -> Room -> State g Room addGirderNS' shapef col room = do let nwestlnks = length $ filter ((OnEdge North `S.member`) . _rlType) $ _rmLinks room girderPosOrder <- shuffle [0 .. nwestlnks - 1] - return $ room & rmPmnts .:~ foldr1 setFallback - (sps0 PutNothing : [ twoRoomPoss - (isUnusedLnkType (FromEdge West i)) - (isUnusedLnkType (FromEdge West i)) - $ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2) - | i <- girderPosOrder] - ) + return $ + room & rmPmnts + .:~ foldr1 + setFallback + ( sps0 PutNothing : + [ twoRoomPoss + (isUnusedLnkType (FromEdge West i)) + (isUnusedLnkType (FromEdge West i)) + $ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2) + | i <- girderPosOrder + ] + ) + addGirderEW :: RandomGen g => (Point2 -> Point2 -> Shape) -> Color -> Room -> State g Room addGirderEW shapef col room = do let nwestlnks = length $ filter ((OnEdge West `S.member`) . _rlType) $ _rmLinks room girderPosOrder <- shuffle [1 .. nwestlnks - 2] - return $ room & rmPmnts .:~ foldr1 setFallback - (sps0 PutNothing : - [ twoRoomPoss - (isUnusedLnkType (FromEdge South i)) - (isUnusedLnkType (FromEdge South i)) - $ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2) - | i <- girderPosOrder] - ) + return $ + room & rmPmnts + .:~ foldr1 + setFallback + ( sps0 PutNothing : + [ twoRoomPoss + (isUnusedLnkType (FromEdge South i)) + (isUnusedLnkType (FromEdge South i)) + $ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2) + | i <- girderPosOrder + ] + ) -- TODO add a central light to this, with mounted light fallback? addGirder :: RandomGen g => (Point2 -> Point2 -> Shape) -> Color -> Room -> State g Room @@ -80,14 +94,19 @@ addGirder shapef col room = do nsgirds = girdson (FromEdge East) nslnks ewgirds = girdson (FromEdge North) ewlnks girders <- shuffle $ nsgirds ++ ewgirds - return $ room & rmPmnts .:~ foldr1 setFallback - (sps0 PutNothing : girders) + return $ + room & rmPmnts + .:~ foldr1 + setFallback + (sps0 PutNothing : girders) where - girdson f numlnks = [ twoRoomPoss + girdson f numlnks = + [ twoRoomPoss (isUnusedLnkType (f i)) (isUnusedLnkType (f i)) - $ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2) - | i <- [1 .. numlnks - 2] ] + $ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2) + | i <- [1 .. numlnks - 2] + ] addGirder' :: RandomGen g => (Point2 -> Point2 -> Shape) -> Color -> Room -> State g Room addGirder' shapef col room = do @@ -96,41 +115,53 @@ addGirder' shapef col room = do nsgirds = girdson (FromEdge East) nslnks ewgirds = girdson (FromEdge North) ewlnks girders <- shuffle $ nsgirds ++ ewgirds - return $ room & rmPmnts .:~ foldr1 setFallback - (sps0 PutNothing : girders) + return $ + room & rmPmnts + .:~ foldr1 + setFallback + (sps0 PutNothing : girders) where - girdson f numlnks = [ twoRoomPoss + girdson f numlnks = + [ twoRoomPoss (isUnusedLnkType (f i)) (isUnusedLnkType (f i)) - $ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2) - | i <- [0 .. numlnks - 1] ] + $ \ps1 ps2 -> sps0 $ putShape $ colorSH col $ shapef (_psPos ps1) (_psPos ps2) + | i <- [0 .. numlnks - 1] + ] addHighGirder :: RandomGen g => Room -> State g Room addHighGirder r = do - gsize <- takeOne [(20,10),(30,10),(40,10),(30,15)] - hgshape <- takeOne $ map (\f -> uncurry (f 96) gsize) - [girder, girderZ, girderV] + gsize <- takeOne [(20, 10), (30, 10), (40, 10), (30, 15)] + hgshape <- + takeOne $ + map + (\f -> uncurry (f 96) gsize) + [girder, girderZ, girderV] addGirder hgshape black r addHighGirder' :: RandomGen g => Room -> State g Room addHighGirder' r = do - gsize <- takeOne [(20,10),(30,10),(40,10),(30,15)] - hgshape <- takeOne $ map (\f -> uncurry (f 96) gsize) - [girder, girderZ, girderV] + gsize <- takeOne [(20, 10), (30, 10), (40, 10), (30, 15)] + hgshape <- + takeOne $ + map + (\f -> uncurry (f 96) gsize) + [girder, girderZ, girderV] addGirder' hgshape black r -randomLightPositions :: RandomGen g => Room -> State g [(Int,Int)] +randomLightPositions :: RandomGen g => Room -> State g [(Int, Int)] randomLightPositions rm = do let rmtype = _rmType rm - xs <- shuffle [0.._numLinkEW rmtype] - ys <- shuffle [0.._numLinkNS rmtype] + xs <- shuffle [0 .. _numLinkEW rmtype] + ys <- shuffle [0 .. _numLinkNS rmtype] let n = max (length xs) (length ys) return $ take n $ zip (xs ++ xs) (ys ++ ys) -intsToPos :: Room -> (Int,Int) -> Point2 -intsToPos rm (x,y) = V2 - (20 + _linkGapEW rmtype * fromIntegral x) - (20 + _linkGapNS rmtype * fromIntegral y) +intsToPos :: Room -> (Int, Int) -> Point2 +intsToPos rm (x, y) = + V2 + (20 + _linkGapEW rmtype * fromIntegral x) + (20 + _linkGapNS rmtype * fromIntegral y) where rmtype = _rmType rm @@ -149,15 +180,34 @@ addGirderLights rm = do w = _rmWidth rmtype h = _rmHeight rmtype midw = wiToFloat rm midi - extragirderpos = nub $ map (\(wi,hi) -> (wi - midi, hi)) lpis - extragirders = mapMaybe (\(i,hi) -> case i of - x | x < 0 -> Just $ girderV' 96 20 10 (V2 (midw - 10) (hiToFloat rm hi)) - (V2 0 (hiToFloat rm hi)) - x | x > 0 -> Just $ girderV' 96 20 10 (V2 (midw + 10) (hiToFloat rm hi)) - (V2 w (hiToFloat rm hi)) - _ -> Nothing - ) extragirderpos - return $ rm & rmPmnts .++~ - (sps0 (PutForeground $ girderV' 96 20 10 (V2 midw 0) (V2 midw h)) - : map (\p -> sps (PS p 0) (PutLS $ lsColPos 0.75 (V3 0 0 90))) lps - ) ++ map (sps0 . PutForeground) extragirders + extragirderpos = nub $ map (\(wi, hi) -> (wi - midi, hi)) lpis + extragirders = + mapMaybe + ( \(i, hi) -> case i of + x + | x < 0 -> + Just $ + girderV' + 96 + 20 + 10 + (V2 (midw - 10) (hiToFloat rm hi)) + (V2 0 (hiToFloat rm hi)) + x + | x > 0 -> + Just $ + girderV' + 96 + 20 + 10 + (V2 (midw + 10) (hiToFloat rm hi)) + (V2 w (hiToFloat rm hi)) + _ -> Nothing + ) + extragirderpos + return $ + rm & rmPmnts + .++~ ( sps0 (PutForeground $ girderV' 96 20 10 (V2 midw 0) (V2 midw h)) : + map (\p -> sps (PS p 0) (PutLS $ lsColPos 0.75 (V3 0 0 90))) lps + ) + ++ map (sps0 . PutForeground) extragirders diff --git a/src/Dodge/Room/Ngon.hs b/src/Dodge/Room/Ngon.hs index e82af0eb2..890d98132 100644 --- a/src/Dodge/Room/Ngon.hs +++ b/src/Dodge/Room/Ngon.hs @@ -1,36 +1,34 @@ module Dodge.Room.Ngon where + +import Data.List +import Data.Maybe import Data.Tile +import Dodge.Data.GenWorld +import Dodge.Default.Room +import Dodge.Placement.Instance import Dodge.PlacementSpot import Dodge.RoomLink -import Dodge.Default.Room ---import Dodge.LevelGen.Data -import Dodge.Data -import Dodge.Placement.Instance ---import Dodge.LevelGen.Data import Geometry import Tile ---import qualified Data.Set as S ---import Control.Monad.Loops -import Data.Maybe -import Data.List - roomNgon :: Int -> Float -> Room -roomNgon n x = defaultRoom - { _rmPolys = [poly] - , _rmLinks = map toBothLnk lnks -- muout (init lnks) ++ muin[last lnks] - , _rmPath = mempty -- TODO - , _rmPmnts = [mntLightLnkCond $ resetPLUse $ rprBool $ const . isInLnk] - , _rmBound = [poly] - , _rmFloor = Tiled [makeTileFromPoly poly 9] - , _rmName = show n ++ "gon" - } - where - rot = 2*pi / fromIntegral n - rots = map ((rot *) . fromIntegral) [0..n-1] - poly = mapMaybe - (\(ra,rb) -> intersectLineLine' (rotateV ra bl) (rotateV ra br) (rotateV rb bl) (rotateV rb br)) - $ loopPairs rots - bl = V2 x x - br = V2 (-x) x - lnks = sortOn ((\(V2 a b) -> (negate b,a)) . fst) $ map (\r -> (rotateV r (V2 0 x),r)) rots +roomNgon n x = + defaultRoom + { _rmPolys = [poly] + , _rmLinks = map toBothLnk lnks -- muout (init lnks) ++ muin[last lnks] + , _rmPath = mempty -- TODO + , _rmPmnts = [mntLightLnkCond $ resetPLUse $ rprBool $ const . isInLnk] + , _rmBound = [poly] + , _rmFloor = Tiled [makeTileFromPoly poly 9] + , _rmName = show n ++ "gon" + } + where + rot = 2 * pi / fromIntegral n + rots = map ((rot *) . fromIntegral) [0 .. n -1] + poly = + mapMaybe + (\(ra, rb) -> intersectLineLine' (rotateV ra bl) (rotateV ra br) (rotateV rb bl) (rotateV rb br)) + $ loopPairs rots + bl = V2 x x + br = V2 (- x) x + lnks = sortOn ((\(V2 a b) -> (negate b, a)) . fst) $ map (\r -> (rotateV r (V2 0 x), r)) rots diff --git a/src/Dodge/Room/NoNeedWeapon.hs b/src/Dodge/Room/NoNeedWeapon.hs index 1de6b8110..3c0643084 100644 --- a/src/Dodge/Room/NoNeedWeapon.hs +++ b/src/Dodge/Room/NoNeedWeapon.hs @@ -1,36 +1,34 @@ -{- | Rooms that can be successfully tackled without having any items. -} -module Dodge.Room.NoNeedWeapon - ( centerVaultExplosiveExit - ) where -import Dodge.Data -import Dodge.Creature ---import Dodge.Creature.Inanimate -import Dodge.LevelGen.Data -import Dodge.Room.Procedural ---import Dodge.Room.Link -import RandomHelp ---import Dodge.LevelGen.Data -import Geometry.Data +-- | Rooms that can be successfully tackled without having any items. +module Dodge.Room.NoNeedWeapon ( + centerVaultExplosiveExit, +) where import Control.Lens ---import Control.Monad +import Dodge.Creature +import Dodge.Data.GenWorld +import Dodge.LevelGen.Data +import Dodge.Room.Procedural +import Geometry.Data +import RandomHelp + {- | A room designed to be /passable/ with no weapons. Highlights an issue: when trying to place next door rooms, if the level generation fails it will try a different link. So if there are multiple such, we cannot assume that a given link will be chosen. To solve this, here we delete unwanted links. -} -centerVaultExplosiveExit - :: RandomGen g - => State g Room +centerVaultExplosiveExit :: + RandomGen g => + State g Room centerVaultExplosiveExit = do cr <- takeOne [miniGunCrit, autoCrit] - let extraPS = - [sPS (V2 0 110) 0 $ PutCrit explosiveBarrel - ,sPS (V2 5 115) 0 $ PutCrit explosiveBarrel - ,sPS (V2 0 120) 0 $ PutCrit explosiveBarrel - ,sPS (V2 0 0) 0 $ PutCrit (cr & crState . csDropsOnDeath .~ DropAll) + let extraPS = + [ sPS (V2 0 110) 0 $ PutCrit explosiveBarrel + , sPS (V2 5 115) 0 $ PutCrit explosiveBarrel + , sPS (V2 0 120) 0 $ PutCrit explosiveBarrel + , sPS (V2 0 0) 0 $ PutCrit (cr & crState . csDropsOnDeath .~ DropAll) ] centerVaultRoom 120 120 50 <&> rmPmnts %~ (extraPS ++) - --r <- centerVaultRoom 120 120 50 <&> rmPmnts %~ (extraPS ++) - --randomiseLinksBy shuffleTail r <&> rmOutLinks %~ take 2 + +--r <- centerVaultRoom 120 120 50 <&> rmPmnts %~ (extraPS ++) +--randomiseLinksBy shuffleTail r <&> rmOutLinks %~ take 2 diff --git a/src/Dodge/Room/Path.hs b/src/Dodge/Room/Path.hs index 3d8f50f8a..de118af38 100644 --- a/src/Dodge/Room/Path.hs +++ b/src/Dodge/Room/Path.hs @@ -1,59 +1,58 @@ -module Dodge.Room.Path - ( gridPoints - , linksAndPath - , linksAndPath' - , makeGrid - , createPathGrid - , gridPoints'' - ) - where ---import Dodge.LevelGen.Data -import Dodge.Data +module Dodge.Room.Path ( + gridPoints, + linksAndPath, + linksAndPath', + makeGrid, + createPathGrid, + gridPoints'', +) where + +import qualified Control.Foldl as L +import Data.Function (on) +import Data.List +import Data.Maybe +import qualified Data.Set as S +import Dodge.Data.GenWorld import Dodge.LevelGen.StaticWalls import Dodge.RoomLink import Geometry import Grid -import Data.Function (on) -import Data.List -import Data.Maybe -import qualified Control.Foldl as L -import qualified Data.Set as S - createPathGrid :: Room -> Room -createPathGrid rm = rm - { _rmPath = linksAndPath (map lnkPosDir $ _rmLinks rm) filterGrid } +createPathGrid rm = + rm + { _rmPath = linksAndPath (map lnkPosDir $ _rmLinks rm) filterGrid + } where filterGrid = filter (\p -> pairInPolys (_rmPolys rm) p && testCrossWalls outerWalls p) grid grid = fromMaybe [] $ shiftedGrid <$> minx <*> maxx <*> miny <*> maxy outerWalls = foldr cutPoly [] $ _rmPolys rm outerPoints = map fst outerWalls (minx, maxx, miny, maxy) = L.fold theFold outerPoints - theFold = (,,,) - <$> L.premap fstV2 L.minimum - <*> L.premap fstV2 L.maximum - <*> L.premap sndV2 L.minimum - <*> L.premap sndV2 L.maximum + theFold = + (,,,) + <$> L.premap fstV2 L.minimum + <*> L.premap fstV2 L.maximum + <*> L.premap sndV2 L.minimum + <*> L.premap sndV2 L.maximum -linksAndPath :: [(Point2,Float)] -> [(Point2,Point2)] -> S.Set (Point2,Point2) +linksAndPath :: [(Point2, Float)] -> [(Point2, Point2)] -> S.Set (Point2, Point2) linksAndPath lnks subpth = S.fromList subpth <> foldMap linkClosest lnks - where - linkClosest (p,_) = doublePairSet (p, minimumBy (compare `on` dist p) $ map fst subpth) + where + linkClosest (p, _) = doublePairSet (p, minimumBy (compare `on` dist p) $ map fst subpth) -linksAndPath' :: [RoomLink] -> [(Point2,Point2)] -> S.Set (Point2,Point2) +linksAndPath' :: [RoomLink] -> [(Point2, Point2)] -> S.Set (Point2, Point2) linksAndPath' = linksAndPath . map lnkPosDir -testCrossWalls - :: [(Point2,Point2)] - -> (Point2,Point2) - -> Bool -testCrossWalls wls (a,b) = not $ any (isJust . uncurry (intersectSegSeg a b)) wls +testCrossWalls :: + [(Point2, Point2)] -> + (Point2, Point2) -> + Bool +testCrossWalls wls (a, b) = not $ any (isJust . uncurry (intersectSegSeg a b)) wls --extra test whether both members of the path edge are in some poly -pairInPolys - :: [[Point2]] - -> (Point2,Point2) - -> Bool -pairInPolys polys (a,b) = any (pointInPolygon a) polys && any (pointInPolygon b) polys - - +pairInPolys :: + [[Point2]] -> + (Point2, Point2) -> + Bool +pairInPolys polys (a, b) = any (pointInPolygon a) polys && any (pointInPolygon b) polys diff --git a/src/Dodge/Room/Pillar.hs b/src/Dodge/Room/Pillar.hs index 62558e503..56fc6f83a 100644 --- a/src/Dodge/Room/Pillar.hs +++ b/src/Dodge/Room/Pillar.hs @@ -1,43 +1,41 @@ module Dodge.Room.Pillar where -import Dodge.Default.Block -import Dodge.Placement.Instance.LightSource -import Dodge.Data + +import qualified Data.Set as S import Dodge.Cleat -import Dodge.PlacementSpot -import Dodge.Room.Modify.Girder +import Dodge.Data.GenWorld +import Dodge.Default.Block import Dodge.LevelGen.Data import Dodge.Placement.Instance ---import Dodge.LevelGen.Data -import Dodge.Room.Procedural +import Dodge.PlacementSpot import Dodge.Room.Link +import Dodge.Room.Modify.Girder +import Dodge.Room.Procedural import Geometry import LensHelp import RandomHelp ---import Control.Monad.State ---import System.Random -import qualified Data.Set as S - blockPillar :: Float -> Float -> Placement -blockPillar w' h' = ps0jPushPS (aline tl tr) - $ ps0jPushPS (aline tr br) - $ ps0jPushPS (aline br bl) - $ sps0 (aline bl tl) +blockPillar w' h' = + ps0jPushPS (aline tl tr) $ + ps0jPushPS (aline tr br) $ + ps0jPushPS (aline br bl) $ + sps0 (aline bl tl) where w = w' - 10 h = h' - 10 - tl = V2 (-w) h + tl = V2 (- w) h tr = V2 w h - br = V2 w (-h) - bl = V2 (-w) (-h) + br = V2 w (- h) + bl = V2 (- w) (- h) aline = PutLineBlock baseBlockPane 9 smallPillar :: PSType smallPillar = PutBlock defaultBlock baseBlockPane $ reverse $ square 5 crossPillar :: Float -> Float -> Placement -crossPillar w' h' = ps0jPushPS (aline (V2 (-w) 0) (V2 w 0)) - $ sps0 (aline (V2 0 (-h)) (V2 0 h)) +crossPillar w' h' = + ps0jPushPS (aline (V2 (- w) 0) (V2 w 0)) $ + sps0 (aline (V2 0 (- h)) (V2 0 h)) where w = w' - 9 h = h' - 9 @@ -48,25 +46,39 @@ roomPillarsSquare = do let rm' = roomRectAutoLinks 300 300 nlew = _numLinkEW (_rmType rm') nlns = _numLinkNS (_rmType rm') - addlights <- takeOne - [ return . set rmPmnts [mntLS vShape - (rotateVAround (V2 150 150) a (V2 30 30)) - (onXY (rotateVAround (V2 150 150) a) $ V3 60 60 95) - | a <- [0,pi/2,pi,3*pi/2] ] - , return . set rmPmnts [mntLS vShape - (rotateVAround (V2 150 150) a (V2 150 0)) - (onXY (rotateVAround (V2 150 150) a) $ V3 150 20 95) - | a <- [0,pi/2,pi,3*pi/2] ] - , addGirderLights . set rmPmnts [] - , return . (rmPmnts .++~ - [ spanColLightBlackI 0.75 95 (V2 0 130) (V2 300 130) - , spanColLightBlackI 0.75 95 (V2 0 170) (V2 300 170) - ,mntLightLnkCond $ resetPLUse $ rprBool $ \rp _ -> isOutLnk rp - ] ) - ] + addlights <- + takeOne + [ return + . set + rmPmnts + [ mntLS + vShape + (rotateVAround (V2 150 150) a (V2 30 30)) + (onXY (rotateVAround (V2 150 150) a) $ V3 60 60 95) + | a <- [0, pi / 2, pi, 3 * pi / 2] + ] + , return + . set + rmPmnts + [ mntLS + vShape + (rotateVAround (V2 150 150) a (V2 150 0)) + (onXY (rotateVAround (V2 150 150) a) $ V3 150 20 95) + | a <- [0, pi / 2, pi, 3 * pi / 2] + ] + , addGirderLights . set rmPmnts [] + , return + . ( rmPmnts + .++~ [ spanColLightBlackI 0.75 95 (V2 0 130) (V2 300 130) + , spanColLightBlackI 0.75 95 (V2 0 170) (V2 300 170) + , mntLightLnkCond $ resetPLUse $ rprBool $ \rp _ -> isOutLnk rp + ] + ) + ] rm <- addlights rm' - shuffleLinks $ rm & rmPmnts .++~ concatMap (replicate nlew . makepill) [South,North] - ++ concatMap (replicate nlns . makepill) [East,West] + shuffleLinks $ + rm & rmPmnts .++~ concatMap (replicate nlew . makepill) [South, North] + ++ concatMap (replicate nlns . makepill) [East, West] where makepill edge = sps (rprBool $ \rp _ -> t edge rp) smallPillar t edge rp = any (f edge) (_rpType rp) && _rpPlacementUse rp == 0 @@ -75,27 +87,36 @@ roomPillarsSquare = do roomPillarsPassage :: RandomGen g => State g Room roomPillarsPassage = do let rm = roomRect 100 300 1 3 - shuffleLinks $ rm & rmPmnts .~ - [mntLS iShape (V2 50 0) (V3 50 10 90) - ,mntLS iShape (V2 50 300) (V3 50 290 90) - ,mntLS iShape (V2 0 150) (V3 10 150 90) - ,mntLS iShape (V2 100 150) (V3 90 150 90) - ] ++ - [ sPS (V2 30 y) 0 smallPillar | y <- [50,90.. 250] ] ++ - [ sPS (V2 70 y) 0 smallPillar | y <- [50,90.. 250] ] + shuffleLinks $ + rm & rmPmnts + .~ [ mntLS iShape (V2 50 0) (V3 50 10 90) + , mntLS iShape (V2 50 300) (V3 50 290 90) + , mntLS iShape (V2 0 150) (V3 10 150 90) + , mntLS iShape (V2 100 150) (V3 90 150 90) + ] + ++ [sPS (V2 30 y) 0 smallPillar | y <- [50, 90 .. 250]] + ++ [sPS (V2 70 y) 0 smallPillar | y <- [50, 90 .. 250]] + roomPillars :: RandomGen g => Float -> Float -> Float -> Int -> Int -> State g Room roomPillars pillarsize w h wn hn = do let rm = roomRect w h wn hn npillars = length $ filter rpIsOffPath $ _rmPos rm - let plmnts = replicate npillars (blockPillar (0.5*pilw) (0.5*pilh) & plSpot .~ rprBool - (\rp _ -> rpIsOffPath rp - && _rpPlacementUse rp == 0 - && _rpLinkStatus rp == NotLink ) + let plmnts = + replicate + npillars + ( blockPillar (0.5 * pilw) (0.5 * pilh) & plSpot + .~ rprBool + ( \rp _ -> + rpIsOffPath rp + && _rpPlacementUse rp == 0 + && _rpLinkStatus rp == NotLink + ) ) - addGirderLights $ rm - & cleatSide - & rmPmnts .~ plmnts - & rmName .~ "rectPillars" - where - pilw = (( w - 40 * (fromIntegral wn +1) ) / fromIntegral wn) - pillarsize - pilh = (( h - 40 * (fromIntegral hn +1) ) / fromIntegral hn) - pillarsize + addGirderLights $ + rm + & cleatSide + & rmPmnts .~ plmnts + & rmName .~ "rectPillars" + where + pilw = ((w - 40 * (fromIntegral wn + 1)) / fromIntegral wn) - pillarsize + pilh = ((h - 40 * (fromIntegral hn + 1)) / fromIntegral hn) - pillarsize diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs index 461cc6db5..9d2c84297 100644 --- a/src/Dodge/Room/Procedural.hs +++ b/src/Dodge/Room/Procedural.hs @@ -1,144 +1,166 @@ -{- | Procedural creation of rooms and subroom parts. -} -module Dodge.Room.Procedural - ( roomRect - , roomRectAutoLinks - , randomFourCornerRoom - , randomFourCornerRoomCrsIts - , centerVaultRoom - , combineRooms - , linksAndPath - , makeGrid - ) where -import Dodge.Data -import Dodge.Placement.Shift -import Dodge.Default.Wall -import Dodge.Default.Door ---import Shape.Data -import Dodge.PlacementSpot -import Dodge.Placement.Instance -import Dodge.RoomLink ---import Dodge.Item.Weapon.Utility -import Dodge.Room.Link -import Dodge.Room.Path -import Dodge.Default.Room ---import Dodge.Item.Consumable ---import Dodge.Item.Equipment ---import Dodge.Item.Weapon -import RandomHelp -import Dodge.LevelGen.Data -import Dodge.LevelGen.Switch -import Dodge.Creature -import Geometry -import Picture -import Data.Tile -import LensHelp +-- | Procedural creation of rooms and subroom parts. +module Dodge.Room.Procedural ( + roomRect, + roomRectAutoLinks, + randomFourCornerRoom, + randomFourCornerRoomCrsIts, + centerVaultRoom, + combineRooms, + linksAndPath, + makeGrid, +) where import qualified Data.Set as S +import Data.Tile +import Dodge.Creature +import Dodge.Data.GenWorld +import Dodge.Default.Door +import Dodge.Default.Room +import Dodge.LevelGen.Data +import Dodge.LevelGen.Switch +import Dodge.Placement.Instance +import Dodge.Placement.Shift +import Dodge.PlacementSpot +import Dodge.Room.Link +import Dodge.Room.Path +import Dodge.RoomLink +import Geometry +import LensHelp +import Picture +import RandomHelp + --import Control.Lens -- This will need a cleanup, but it might change a bit first {- A simple rectangular room with a light in the center. Creates links and pathfinding graph. -} -roomRect - :: Float -- ^ Width - -> Float -- ^ Height - -> Int -- ^ Number of links on vertical walls - -> Int -- ^ Number of links on horizontal walls - -> Room -roomRect x y xn yn = defaultRoom - { _rmPolys = [rectNSWE y 0 0 x ] - , _rmLinks = lnks - , _rmName = "rect" - , _rmPath = foldMap doublePairSet pth - --, _rmPos = map (roomposat (RoomPosOnPath S.empty)) posps - -- ++ map (roomposat (RoomPosOffPath S.empty)) interposps - , _rmPos = map makeonpos posps' - ++ map makeoffpos interposps' - , _rmPmnts = [] - , _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)] - , _rmFloor = Tiled [Tile - { _tilePoly = rectNSWE y 0 0 x - , _tileZero = V2 0 0 - , _tileX = V2 1 0 - , _tileZ = 16 - } ] - , _rmRandPSs = [psRandRanges (10,x-10) (10,y-10) (0,2*pi)] - , _rmType = RectRoomType - { _numLinkEW = xn - , _numLinkNS = yn - , _linkGapEW = xd - , _linkGapNS = yd - , _rmWidth = x - , _rmHeight = y +roomRect :: + -- | Width + Float -> + -- | Height + Float -> + -- | Number of links on vertical walls + Int -> + -- | Number of links on horizontal walls + Int -> + Room +roomRect x y xn yn = + defaultRoom + { _rmPolys = [rectNSWE y 0 0 x] + , _rmLinks = lnks + , _rmName = "rect" + , _rmPath = foldMap doublePairSet pth + , --, _rmPos = map (roomposat (RoomPosOnPath S.empty)) posps + -- ++ map (roomposat (RoomPosOffPath S.empty)) interposps + _rmPos = + map makeonpos posps' + ++ map makeoffpos interposps' + , _rmPmnts = [] + , _rmBound = [rectNSWE (y + 5) (-5) (-5) (x + 5)] + , _rmFloor = + Tiled + [ Tile + { _tilePoly = rectNSWE y 0 0 x + , _tileZero = V2 0 0 + , _tileX = V2 1 0 + , _tileZ = 16 + } + ] + , _rmRandPSs = [psRandRanges (10, x -10) (10, y -10) (0, 2 * pi)] + , _rmType = + RectRoomType + { _numLinkEW = xn + , _numLinkNS = yn + , _linkGapEW = xd + , _linkGapNS = yd + , _rmWidth = x + , _rmHeight = y + } } - } where yd = (y - 40) / fromIntegral yn xd = (x - 40) / fromIntegral xn somelnks poffset ps a = zip (map (+.+ poffset) ps) (repeat a) - wlnks = somelnks (V2 0 20) (gridPoints 0 1 yd (yn+1)) ( pi/2) - elnks = somelnks (V2 x 20) (gridPoints 0 1 yd (yn+1)) (-pi/2) - nlnks = somelnks (V2 20 y) (gridPoints xd (xn+1) 0 1 ) 0 - slnks = somelnks (V2 20 0) (gridPoints xd (xn+1) 0 1 ) pi - lnks = m North (FromEdge West) (FromEdge East) nlnks - ++ m East (FromEdge South) (FromEdge North) elnks - ++ m West (FromEdge South) (FromEdge North) wlnks - ++ m South (FromEdge West) (FromEdge East) slnks - m edge edgefrom1 edgefrom2 = zipWith (lnkBothAnd (OnEdge edge) edgefrom1 edgefrom2) [0..] - . zipCountDown + wlnks = somelnks (V2 0 20) (gridPoints 0 1 yd (yn + 1)) (pi / 2) + elnks = somelnks (V2 x 20) (gridPoints 0 1 yd (yn + 1)) (- pi / 2) + nlnks = somelnks (V2 20 y) (gridPoints xd (xn + 1) 0 1) 0 + slnks = somelnks (V2 20 0) (gridPoints xd (xn + 1) 0 1) pi + lnks = + m North (FromEdge West) (FromEdge East) nlnks + ++ m East (FromEdge South) (FromEdge North) elnks + ++ m West (FromEdge South) (FromEdge North) wlnks + ++ m South (FromEdge West) (FromEdge East) slnks + m edge edgefrom1 edgefrom2 = + zipWith (lnkBothAnd (OnEdge edge) edgefrom1 edgefrom2) [0 ..] + . zipCountDown pth = linksAndPath' lnks $ map (bimap (+.+ V2 20 20) (+.+ V2 20 20)) (makeGrid xd xn yd yn) - makeonpos (p,a) = RoomPos p 0 (S.singleton $ RoomPosOnPath $ makerpedges a) NotLink 0 - makerpedges (a,b) = S.fromList - [PathFromEdge South b - ,PathFromEdge North (yn-b) - ,PathFromEdge East (xn-a) - ,PathFromEdge West a - ] - posps' = map (over _1 (+.+ V2 20 20)) $ gridPoints'' xd (xn+1) yd (yn+1) - interposps' = map (over _1 (+.+ V2 (20 + xd/2) (20 + yd/2))) $ gridPoints'' xd xn yd yn - makeoffpos (p,a) = RoomPos p 0 (S.singleton $ RoomPosOffPath $ makerpedges' a) NotLink 0 - makerpedges' (a,b) = S.fromList - [PathFromEdge South b - ,PathFromEdge North (yn-(b+1)) - ,PathFromEdge East (xn-(a+1)) - ,PathFromEdge West a - ] + makeonpos (p, a) = RoomPos p 0 (S.singleton $ RoomPosOnPath $ makerpedges a) NotLink 0 + makerpedges (a, b) = + S.fromList + [ PathFromEdge South b + , PathFromEdge North (yn - b) + , PathFromEdge East (xn - a) + , PathFromEdge West a + ] + posps' = map (over _1 (+.+ V2 20 20)) $ gridPoints'' xd (xn + 1) yd (yn + 1) + interposps' = map (over _1 (+.+ V2 (20 + xd / 2) (20 + yd / 2))) $ gridPoints'' xd xn yd yn + makeoffpos (p, a) = RoomPos p 0 (S.singleton $ RoomPosOffPath $ makerpedges' a) NotLink 0 + makerpedges' (a, b) = + S.fromList + [ PathFromEdge South b + , PathFromEdge North (yn - (b + 1)) + , PathFromEdge East (xn - (a + 1)) + , PathFromEdge West a + ] -zipCountDown :: [a] -> [(Int,a)] +zipCountDown :: [a] -> [(Int, a)] zipCountDown xs = zip [length xs - 1, length xs - 2 ..] xs -lnkBothAnd :: RoomLinkType -> (Int -> RoomLinkType) -> (Int -> RoomLinkType) - -> Int -> (Int,(Point2,Float)) -> RoomLink -lnkBothAnd rlt ltcon ltcon2 i (j,(p,a)) = RoomLink - { _rlType = S.fromList [OutLink,InLink,rlt,ltcon i,ltcon2 j] - , _rlPos = p - , _rlDir = a - } +lnkBothAnd :: + RoomLinkType -> + (Int -> RoomLinkType) -> + (Int -> RoomLinkType) -> + Int -> + (Int, (Point2, Float)) -> + RoomLink +lnkBothAnd rlt ltcon ltcon2 i (j, (p, a)) = + RoomLink + { _rlType = S.fromList [OutLink, InLink, rlt, ltcon i, ltcon2 j] + , _rlPos = p + , _rlDir = a + } + {- Creates a rectangular room, automatically creates links and pathfinding graph at a sensible size. -} -- it is not clear to me that this works for very small rooms (but it does seem -- to do so) roomRectAutoLinks :: Float -> Float -> Room -roomRectAutoLinks x y = roomRect x y (f x) (f y) - & rmName .~ "autoRect" - & rmPmnts .~ [mntLightLnkCond $ resetPLUse $ rprBool $ \rp _ -> isInLnk rp - ,mntLightLnkCond $ resetPLUse $ rprBool $ \rp _ -> isOutLnk rp] +roomRectAutoLinks x y = + roomRect x y (f x) (f y) + & rmName .~ "autoRect" + & rmPmnts + .~ [ mntLightLnkCond $ resetPLUse $ rprBool $ \rp _ -> isInLnk rp + , mntLightLnkCond $ resetPLUse $ rprBool $ \rp _ -> isOutLnk rp + ] where f z = max 1 $ (ceiling z - 40) `div` 60 + {- Combines two rooms into one room. - will have to work out exactly what to do with combining links Mostly involves concatenation. -} combineRooms :: Room -> Room -> Room -combineRooms r r' = defaultRoom - { _rmPolys = _rmPolys r ++ _rmPolys r' - , _rmLinks = _rmLinks r ++ _rmLinks r' - , _rmPath = S.map clampPath $ _rmPath r <> _rmPath r' - , _rmPmnts = _rmPmnts r ++ _rmPmnts r' - , _rmBound = _rmBound r ++ _rmBound r' - , _rmPos = _rmPos r ++ _rmPos r' - , _rmFloor = combineFloors (_rmFloor r) (_rmFloor r') - , _rmShift = (V2 0 0 , 0) - } +combineRooms r r' = + defaultRoom + { _rmPolys = _rmPolys r ++ _rmPolys r' + , _rmLinks = _rmLinks r ++ _rmLinks r' + , _rmPath = S.map clampPath $ _rmPath r <> _rmPath r' + , _rmPmnts = _rmPmnts r ++ _rmPmnts r' + , _rmBound = _rmBound r ++ _rmBound r' + , _rmPos = _rmPos r ++ _rmPos r' + , _rmFloor = combineFloors (_rmFloor r) (_rmFloor r') + , _rmShift = (V2 0 0, 0) + } + -- not that this assumes that any link paths are integral -clampPath :: (Point2,Point2) -> (Point2, Point2) +clampPath :: (Point2, Point2) -> (Point2, Point2) clampPath = bimap f f where f (V2 x y) = V2 (g x) (g y) @@ -146,130 +168,165 @@ clampPath = bimap f f combineFloors :: Floor -> Floor -> Floor combineFloors = const + {- Randomly generate a top fourth of a room possibly with a wall. Add a light and a 'PutNothing' placement. -} quarterRoomTri :: RandomGen g => Float -> State g Room quarterRoomTri w = do - b <- takeOne - [ [ mntLS vShape (V2 0 w) (V3 0 (w-20) 70) - , blockLine (V2 (w/2) (w/2)) (V2 (w/2) w) + b <- + takeOne + [ + [ mntLS vShape (V2 0 w) (V3 0 (w -20) 70) + , blockLine (V2 (w / 2) (w / 2)) (V2 (w / 2) w) + ] + , [blockLine (V2 (w / 2) (w / 2)) (V2 (negate $ w / 2) (w / 2))] + , + [ blockLine (V2 (w / 2) (w / 2)) (V2 0 (w / 2)) + , blockLine (V2 (-29) w) (V2 0 (w / 2)) & plType . putWall . wlRotateTo .~ False + ] ] - , [ blockLine (V2 (w/2) (w/2)) (V2 (negate $ w/2) (w/2))] - , [ blockLine (V2 (w/2) (w/2)) (V2 0 (w/2)) - , blockLine (V2 (-29) w) (V2 0 (w/2)) & plType . putWall . wlRotateTo .~ False - ] - ] - pure $ defaultRoom - { _rmPolys = [ [V2 0 0,V2 w w,V2 (-w) w] ] - , _rmLinks = [toBothLnk (V2 0 w, 0)] - , _rmPath = foldMap doublePairSet - [(V2 0 w,V2 0 (w-20)) - ,(V2 0 (w-20),V2 (w-20) (w-20)) - ,(V2 0 (w-20),V2 (55-w) (w-20)) - ,(V2 (55-w) (w-20),V2 (20-w) (w-20)) - ,(V2 0 (w-20),V2 0 0) - ,(V2 (55-w) (w-20),V2 0 0) - ] - , _rmPmnts = b ++ [ mntLS iShape (V2 (w-20) w) (V3 (w-20) (w-20) 70) ] - , _rmPos = - [ RoomPos (V2 (w-20) (w-20)) pi S.empty NotLink 0 - , RoomPos (V2 (w-15) (w-25)) pi S.empty NotLink 0 - ] - , _rmBound = [[V2 0 0,V2 w w,V2 (-w) w]] - } + pure $ + defaultRoom + { _rmPolys = [[V2 0 0, V2 w w, V2 (- w) w]] + , _rmLinks = [toBothLnk (V2 0 w, 0)] + , _rmPath = + foldMap + doublePairSet + [ (V2 0 w, V2 0 (w -20)) + , (V2 0 (w -20), V2 (w -20) (w -20)) + , (V2 0 (w -20), V2 (55 - w) (w -20)) + , (V2 (55 - w) (w -20), V2 (20 - w) (w -20)) + , (V2 0 (w -20), V2 0 0) + , (V2 (55 - w) (w -20), V2 0 0) + ] + , _rmPmnts = b ++ [mntLS iShape (V2 (w -20) w) (V3 (w -20) (w -20) 70)] + , _rmPos = + [ RoomPos (V2 (w -20) (w -20)) pi S.empty NotLink 0 + , RoomPos (V2 (w -15) (w -25)) pi S.empty NotLink 0 + ] + , _rmBound = [[V2 0 0, V2 w w, V2 (- w) w]] + } quarterRoomSquare :: RandomGen g => Float -> State g Room quarterRoomSquare w = do - b <- takeOne - [ [ mntLS vShape (V2 0 (2*w-20)) (V3 0 (2*w-40) 70) - , blockLine (V2 (negate $ w/2) (w/2)) (V2 0 w) + b <- + takeOne + [ + [ mntLS vShape (V2 0 (2 * w -20)) (V3 0 (2 * w -40) 70) + , blockLine (V2 (negate $ w / 2) (w / 2)) (V2 0 w) + ] + , + [ mntLS vShape (V2 0 (2 * w -20)) (V3 0 (2 * w -40) 70) + , blockLine (V2 (negate w) w) (V2 0 w) + ] + , + [ mntLS iShape (V2 (0.7 * w) (1.3 * w)) (V3 (0.7 * w -20) (1.3 * w -20) 70) + , blockLine (V2 0 w) (V2 0 (w * 2)) + ] ] - , [ mntLS vShape (V2 0 (2*w-20)) (V3 0 (2*w-40) 70) - , blockLine (V2 (negate w) w ) (V2 0 w) - ] - , [ mntLS iShape (V2 (0.7*w) (1.3*w)) (V3 (0.7*w-20) (1.3*w-20) 70) - , blockLine (V2 0 w) (V2 0 (w*2)) - ] - ] - let thepoly = [ map toV2 [(0,0),(w,w),(0,2*w),(-w,w)] ] - pure $ defaultRoom - { _rmPolys = thepoly - , _rmLinks = map toBothLnk - [ (V2 (w/2) (3*w/2), negate $ pi/4) - , (V2 (negate $ w/2) (3*w/2), pi/4) - ] - , _rmPath = foldMap doublePairSet - [(V2 (0.5*w) (1.5*w),V2 (0.5*w-20) (1.5*w-20)) - ,(V2 (-0.5*w) (1.5*w),V2 (-0.5*w+20) (1.5*w-20)) - ,(V2 0 (2*w-40),V2 (-0.5*w+20) (1.5*w-20)) - ,(V2 0 (2*w-40),V2 (0.5*w-20) (1.5*w-20)) - ,(V2 (w-20) (w-20),V2 (0.5*w-20) (1.5*w-20)) - ,(V2 (20-w) (w-20),V2 (-0.5*w+20) (1.5*w-20)) - --,(V2 (40-w) (w),V2 0 (w-40)) - ,(V2 (20-w) (w-20),V2 0 (w-40)) - ,(V2 0 0,V2 0 (w-40)) --- ,(V2 (20-w) (w-20),V2 (40-w) (w)) - ] - , _rmPmnts = b ++ [ blockLine (V2 (w/2) (w/2)) (V2 0 w) ] - , _rmPos = [ RoomPos p pi S.empty NotLink 0 - | p <- [V2 20 (2*w-40),V2 25 (2*w-45)] ] - --, _rmBound = [map toV2 [(w,w),(0,2*w),(-w,w)]] - , _rmBound = [ map toV2 [(0,0),(w,w),(0,2*w),(-w,w)] ] - } -{- | A randomly generate room based on four randomly generated corners. -Tight corridors, random placements. -} + let thepoly = [map toV2 [(0, 0), (w, w), (0, 2 * w), (- w, w)]] + pure $ + defaultRoom + { _rmPolys = thepoly + , _rmLinks = + map + toBothLnk + [ (V2 (w / 2) (3 * w / 2), negate $ pi / 4) + , (V2 (negate $ w / 2) (3 * w / 2), pi / 4) + ] + , _rmPath = + foldMap + doublePairSet + [ (V2 (0.5 * w) (1.5 * w), V2 (0.5 * w -20) (1.5 * w -20)) + , (V2 (-0.5 * w) (1.5 * w), V2 (-0.5 * w + 20) (1.5 * w -20)) + , (V2 0 (2 * w -40), V2 (-0.5 * w + 20) (1.5 * w -20)) + , (V2 0 (2 * w -40), V2 (0.5 * w -20) (1.5 * w -20)) + , (V2 (w -20) (w -20), V2 (0.5 * w -20) (1.5 * w -20)) + , (V2 (20 - w) (w -20), V2 (-0.5 * w + 20) (1.5 * w -20)) + , --,(V2 (40-w) (w),V2 0 (w-40)) + (V2 (20 - w) (w -20), V2 0 (w -40)) + , (V2 0 0, V2 0 (w -40)) + -- ,(V2 (20-w) (w-20),V2 (40-w) (w)) + ] + , _rmPmnts = b ++ [blockLine (V2 (w / 2) (w / 2)) (V2 0 w)] + , _rmPos = + [ RoomPos p pi S.empty NotLink 0 + | p <- [V2 20 (2 * w -40), V2 25 (2 * w -45)] + ] + , --, _rmBound = [map toV2 [(w,w),(0,2*w),(-w,w)]] + _rmBound = [map toV2 [(0, 0), (w, w), (0, 2 * w), (- w, w)]] + } + +{- | A randomly generate room based on four randomly generated corners. +Tight corridors, random placements. +-} randomFourCornerRoom :: RandomGen g => [Item] -> State g Room randomFourCornerRoom its = do - nCrits <- state $ randomR (1,3) - crits <- takeN nCrits <=< shuffle $ [spreadGunCrit,pistolCrit,autoCrit,armourChaseCrit] - ++ replicate 20 chaseCrit + nCrits <- state $ randomR (1, 3) + crits <- + takeN nCrits <=< shuffle $ + [spreadGunCrit, pistolCrit, autoCrit, armourChaseCrit] + ++ replicate 20 chaseCrit randomFourCornerRoomCrsIts crits its -{- | A randomly generate room based on four randomly generated corners. -Tight corridors. -} + +{- | A randomly generate room based on four randomly generated corners. +Tight corridors. +-} randomFourCornerRoomCrsIts :: RandomGen g => [Creature] -> [Item] -> State g Room randomFourCornerRoomCrsIts crits its = do corners <- replicateM 4 . join $ takeOne [quarterRoomTri 100, quarterRoomSquare 100] - let putitms = map (\it -> sps0 (PutFlIt it) & plSpot .~ anyUnusedSpot) its + let putitms = map (\it -> sps0 (PutFlIt it) & plSpot .~ anyUnusedSpot) its putcrits = map (\cr -> sps0 (PutCrit cr) & plSpot .~ unusedSpotAwayFromLink 50) crits - shuffleLinks - . (rmPmnts .++~ (sps0 putLamp : putitms ++ putcrits)) + shuffleLinks + . (rmPmnts .++~ (sps0 putLamp : putitms ++ putcrits)) . foldr1 combineRooms - $ zipWith (\r a -> moveRoomBy (V2 0 0,a) r) corners [0,pi/2,pi,3*pi/2] -{- | Creates room with a central vault with doors around it. -} -centerVaultRoom - :: Float -- ^ Width - -> Float -- ^ Height - -> Float -- ^ Vault dimensions - -> State g Room -centerVaultRoom w h d = return $ defaultRoom - { _rmPolys = [rectNSWE h (-h) (-w) w] - , _rmLinks = - [outLink (V2 0 h) 0 - ,outLink (V2 w 0) (-pi/2) - ,outLink (V2 (-w) 0) (pi/2) - , inLink (V2 0 (-h)) pi ] - , _rmPath = mempty - , _rmPmnts = - [sps0 $ PutWall (reverse $ rectNSWE d (d - 30) (d - 30) d ) defaultWall - ,sps0 $ PutWall (reverse $ rectNSWE d (d - 30) (30 - d) (-d)) defaultWall - ,sps0 $ PutWall (reverse $ rectNSWE (-d) (30 - d) (d - 30) d ) defaultWall - ,sps0 $ PutWall (reverse $ rectNSWE (-d) (30 - d) (30 - d) (-d)) defaultWall - ] - ++ map (\a -> mntLS vShape (rotateV a $ V2 0 d) (rotate3z a $ V3 0 (d+30) 70)) - [0,0.5*pi,pi,1.5*pi] - ++ concatMap (\r -> map (shiftPlacement (V2 0 0,r)) theDoor) - [0,pi/2,pi,3*pi/2] - , _rmBound = [rectNSWE h (-h) (-w) w] - , _rmName = "cenVault" - } + $ zipWith (\r a -> moveRoomBy (V2 0 0, a) r) corners [0, pi / 2, pi, 3 * pi / 2] + +-- | Creates room with a central vault with doors around it. +centerVaultRoom :: + -- | Width + Float -> + -- | Height + Float -> + -- | Vault dimensions + Float -> + State g Room +centerVaultRoom w h d = + return $ + defaultRoom + { _rmPolys = [rectNSWE h (- h) (- w) w] + , _rmLinks = + [ outLink (V2 0 h) 0 + , outLink (V2 w 0) (- pi / 2) + , outLink (V2 (- w) 0) (pi / 2) + , inLink (V2 0 (- h)) pi + ] + , _rmPath = mempty + , _rmPmnts = + [ sps0 $ PutWall (reverse $ rectNSWE d (d - 30) (d - 30) d) defaultWall + , sps0 $ PutWall (reverse $ rectNSWE d (d - 30) (30 - d) (- d)) defaultWall + , sps0 $ PutWall (reverse $ rectNSWE (- d) (30 - d) (d - 30) d) defaultWall + , sps0 $ PutWall (reverse $ rectNSWE (- d) (30 - d) (30 - d) (- d)) defaultWall + ] + ++ map + (\a -> mntLS vShape (rotateV a $ V2 0 d) (rotate3z a $ V3 0 (d + 30) 70)) + [0, 0.5 * pi, pi, 1.5 * pi] + ++ concatMap + (\r -> map (shiftPlacement (V2 0 0, r)) theDoor) + [0, pi / 2, pi, 3 * pi / 2] + , _rmBound = [rectNSWE h (- h) (- w) w] + , _rmName = "cenVault" + } where col = dim $ dim $ bright red - theDoor = - [ pContID (PS (V2 35 (d+4)) 0) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect) - $ \btid -> jspsJ (V2 0 (d-10)) 0 (PutSlideDr (thedoor btid) thewall DoorObstacle 1 (V2 (-21) 0) (V2 0 0)) - $ sPS (V2 0 (d-10)) 0 (PutSlideDr (thedoor btid) thewall DoorObstacle 1 (V2 21 0) (V2 0 0)) + theDoor = + [ pContID (PS (V2 35 (d + 4)) 0) (PutButton $ makeSwitch col red NoWorldEffect NoWorldEffect) $ + \btid -> + jspsJ (V2 0 (d -10)) 0 (PutSlideDr (thedoor btid) thewall DoorObstacle 1 (V2 (-21) 0) (V2 0 0)) $ + sPS (V2 0 (d -10)) 0 (PutSlideDr (thedoor btid) thewall DoorObstacle 1 (V2 21 0) (V2 0 0)) ] thewall = switchWallCol col - thedoor btid = defaultDoor - & drTrigger .~ WdBlBtOn btid - & drSpeed .~ 2 + thedoor btid = + defaultDoor + & drTrigger .~ WdBlBtOn btid + & drSpeed .~ 2 diff --git a/src/Dodge/Room/RezBox.hs b/src/Dodge/Room/RezBox.hs index e226dc6fd..e2fcefe8e 100644 --- a/src/Dodge/Room/RezBox.hs +++ b/src/Dodge/Room/RezBox.hs @@ -1,128 +1,131 @@ module Dodge.Room.RezBox where -import Dodge.LevelGen.Data -import Dodge.Cleat ---import Dodge.PlacementSpot ---import Dodge.Room.RunPast -import Dodge.RoomLink -import Dodge.LightSource ---import Dodge.Room.LasTurret -import Dodge.Data ---import Dodge.Default ---import Dodge.RoomLink -import Dodge.Tree -import RandomHelp -import Dodge.Room.Door -import Dodge.Room.Corridor ---import Dodge.Room.Room -import Dodge.Room.Link -import Dodge.Room.Procedural ---import Dodge.Room.Foreground -import Dodge.Room.RoadBlock -import Dodge.Placement.Instance -import Dodge.Item.Random ---import Dodge.Item.Weapon.BulletGuns ---import Dodge.Item.Weapon.Utility ---import Dodge.LevelGen.Data ---import Geometry.Data -import Geometry -import Padding -import LensHelp ---import Color ---import Shape import qualified Data.Set as S ---import Data.Maybe +import Dodge.Cleat +import Dodge.Data.GenWorld +import Dodge.Item.Random +import Dodge.LevelGen.Data +import Dodge.LightSource +import Dodge.Placement.Instance +import Dodge.Room.Corridor +import Dodge.Room.Door +import Dodge.Room.Link +import Dodge.Room.Procedural +import Dodge.Room.RoadBlock +import Dodge.RoomLink +import Dodge.Tree +import Geometry +import LensHelp +import Padding +import RandomHelp rezBox :: LightSource -> Room -rezBox ls = roomRect 40 60 1 1 - & rmPmnts .~ [ sPS (V2 20 1) 0 $ PutLS ls] - & restrictInLinks (\(V2 _ h,_)-> h < 1) - & restrictOutLinks (\(V2 _ h,_)-> h > 59) - & rmName .~ "rezBox" +rezBox ls = + roomRect 40 60 1 1 + & rmPmnts .~ [sPS (V2 20 1) 0 $ PutLS ls] + & restrictInLinks (\(V2 _ h, _) -> h < 1) + & restrictOutLinks (\(V2 _ h, _) -> h > 59) + & rmName .~ "rezBox" rezBox' :: RandomGen g => State g (MetaTree Room String) rezBox' = do col <- rezColor - return $ tToBTree "rezBox'" $ treePost - [roomRect 40 60 1 1 - & rmPmnts .~ [ sPS (V2 20 1) 0 $ PutLS col] - & restrictInLinks (\(V2 _ h,_)-> h < 1) - & restrictOutLinks (\(V2 _ h,_)-> h > 59) - & rmName .~ "rezBox" - , cleatOnward door - ] + return $ + tToBTree "rezBox'" $ + treePost + [ roomRect 40 60 1 1 + & rmPmnts .~ [sPS (V2 20 1) 0 $ PutLS col] + & restrictInLinks (\(V2 _ h, _) -> h < 1) + & restrictOutLinks (\(V2 _ h, _) -> h > 59) + & rmName .~ "rezBox" + , cleatOnward door + ] rezBoxesWp :: RandomGen g => State g (Tree Room) rezBoxesWp = do - w <- state $ randomR (100,400) - h <- state $ randomR (40,40) + w <- state $ randomR (100, 400) + h <- state $ randomR (40, 40) theweapon <- randBlockBreakWeapon thecol <- rezColor let aroom = rezInvBox thecol -- & rmConnectsTo .~ S.singleton (OnEdge North) let isnorth = S.member (OnEdge North) . _rlType - centralRoom <- shuffleLinks $(roomRectAutoLinks w h) {_rmPmnts = []} - & rmLinks %~ setLinkType InLink isnorth + centralRoom <- + shuffleLinks $(roomRectAutoLinks w h){_rmPmnts = []} + & rmLinks %~ setLinkType InLink isnorth onwardpassage <- shootOutPassage - let n = length $ getLinksOfType (OnEdge North) $ _rmLinks centralRoom - let rezrooms = map adddoor - $ wpAdd theweapon aroom : replicate (n-2) aroom - return $ treeFromTrunk [ rezBox thecol , door ] - $ Node centralRoom (rezrooms ++ [onwardpassage]) + let n = length $ getLinksOfType (OnEdge North) $ _rmLinks centralRoom + let rezrooms = + map adddoor $ + wpAdd theweapon aroom : replicate (n -2) aroom + return $ + treeFromTrunk [rezBox thecol, door] $ + Node centralRoom (rezrooms ++ [onwardpassage]) where - adddoor rm = treeFromPost [ connectsToNorth door ] rm + adddoor rm = treeFromPost [connectsToNorth door] rm connectsToNorth = rmConnectsTo .~ S.member (OnEdge North) + maybeBlockedPassage :: RandomGen g => State g (Tree Room) -maybeBlockedPassage = fmap (pure . cleatOnward) - $ join $ takeOne [return corridor, blockedCorridorCloseBlocks] +maybeBlockedPassage = + fmap (pure . cleatOnward) $ + join $ takeOne [return corridor, blockedCorridorCloseBlocks] shootOutPassage :: RandomGen g => State g (Tree Room) -shootOutPassage = fmap (pure . cleatOnward) - $ join $ takeOne [ blockedCorridorCloseBlocks] +shootOutPassage = + fmap (pure . cleatOnward) $ + join $ takeOne [blockedCorridorCloseBlocks] + rezBoxesWpCrit :: RandomGen g => State g (Tree Room) rezBoxesWpCrit = do - w <- state $ randomR (200,400) - h <- state $ randomR (40,40) + w <- state $ randomR (200, 400) + h <- state $ randomR (40, 40) thecol <- rezColor theweapon <- randBlockBreakWeapon - let bottomEdgeTest (V2 _ y,_) = y < 1 + let bottomEdgeTest (V2 _ y, _) = y < 1 aroom = rezInvBox thecol - let centralRoom = (roomRectAutoLinks w h) {_rmPmnts = []} + let centralRoom = (roomRectAutoLinks w h){_rmPmnts = []} onwardpassage <- over root (rmConnectsTo .~ S.member (OnEdge West)) <$> maybeBlockedPassage let n = length $ filter bottomEdgeTest $ map lnkPosDir $ _rmLinks centralRoom - i <- state $ randomR (0,n-3) - j <- state $ randomR (i,n-2) - let rezrooms = map adddoor - $ insertAt i (wpAdd theweapon aroom) - $ insertAt j (crAdd aroom) - $ replicate (n-3) aroom - return $ treeFromTrunk [rezBox thecol , door] - $ Node centralRoom (rezrooms ++ [onwardpassage]) + i <- state $ randomR (0, n -3) + j <- state $ randomR (i, n -2) + let rezrooms = + map adddoor $ + insertAt i (wpAdd theweapon aroom) $ + insertAt j (crAdd aroom) $ + replicate (n -3) aroom + return $ + treeFromTrunk [rezBox thecol, door] $ + Node centralRoom (rezrooms ++ [onwardpassage]) where - adddoor rm = treeFromPost [ door & rmConnectsTo .~ S.member (OnEdge North)] rm + adddoor rm = treeFromPost [door & rmConnectsTo .~ S.member (OnEdge North)] rm crAdd :: Room -> Room -crAdd = rmPmnts .:~ sPS (V2 20 10) (0.5*pi) randC1 +crAdd = rmPmnts .:~ sPS (V2 20 10) (0.5 * pi) randC1 rezBoxes :: RandomGen g => State g (MetaTree Room String) rezBoxes = do - w <- state $ randomR (100,400) - h <- state $ randomR (40,40) + w <- state $ randomR (100, 400) + h <- state $ randomR (40, 40) thecol <- rezColor - let bottomEdgeTest = S.member (OnEdge South) . _rlType - dbox = treeFromPost [ door & rmConnectsTo .~ S.member (OnEdge South)] - (rezInvBox thecol) - centralRoom <- shuffleLinks $ (roomRectAutoLinks w h) {_rmPmnts = []} - & rmLinks %~ setInLinks bottomEdgeTest + let bottomEdgeTest = S.member (OnEdge South) . _rlType + dbox = + treeFromPost + [door & rmConnectsTo .~ S.member (OnEdge South)] + (rezInvBox thecol) + centralRoom <- + shuffleLinks $ + (roomRectAutoLinks w h){_rmPmnts = []} + & rmLinks %~ setInLinks bottomEdgeTest let n = length $ filter bottomEdgeTest $_rmLinks centralRoom - return $ tToBTree "rezBoxes" $treeFromTrunk [rezBox thecol, door] - $ Node centralRoom (replicate (n-1) dbox ++ [Node (cleatOnward door) []]) + return $ + tToBTree "rezBoxes" $treeFromTrunk [rezBox thecol, door] $ + Node centralRoom (replicate (n -1) dbox ++ [Node (cleatOnward door) []]) rezColor :: RandomGen g => State g LightSource rezColor = do col <- takeOne [V3 0.0 0.1 0.5, V3 0.0 0.5 0.1] - h <- takeOne [30,50,80,90,90,90,90] - rad <- takeOne [150,200,200,250,250,300,300,300] + h <- takeOne [30, 50, 80, 90, 90, 90, 90] + rad <- takeOne [150, 200, 200, 250, 250, 300, 300, 300] return $ lsPosColRad (V3 0 0 h) col rad rezInvBox :: LightSource -> Room @@ -131,6 +134,6 @@ rezInvBox = swapInOutLinks . rezBox wpAdd :: Item -> Room -> Room wpAdd wp = rmPmnts %~ f where - f (x:xs) = sPS (V2 15 30) 1 (PutFlIt wp) : g x : xs + f (x : xs) = sPS (V2 15 30) 1 (PutFlIt wp) : g x : xs f _ = [sPS (V2 15 30) 1 (PutFlIt wp)] g x = x & plIDCont .~ const flickerMod diff --git a/src/Dodge/Room/RoadBlock.hs b/src/Dodge/Room/RoadBlock.hs index 908fbb203..b0cbcbad5 100644 --- a/src/Dodge/Room/RoadBlock.hs +++ b/src/Dodge/Room/RoadBlock.hs @@ -1,23 +1,21 @@ {- Connecting rooms designed with a pass-through technique in mind. -} module Dodge.Room.RoadBlock where -import Dodge.Default.Wall -import Dodge.Default.Block -import Dodge.Cleat -import Dodge.Data -import Dodge.RoomLink -import Geometry -import Dodge.Default.Room -import Dodge.LevelGen.Data -import Dodge.Room.Link -import Dodge.Placement.Instance -import Dodge.Room.Corridor ---import Dodge.LevelGen.Data ---import Dodge.Default.Wall -import RandomHelp -import Dodge.Creature -import Dodge.Tree import Control.Lens +import Dodge.Cleat +import Dodge.Creature +import Dodge.Data.GenWorld +import Dodge.Default.Block +import Dodge.Default.Room +import Dodge.Default.Wall +import Dodge.LevelGen.Data +import Dodge.Placement.Instance +import Dodge.Room.Corridor +import Dodge.Room.Link +import Dodge.RoomLink +import Dodge.Tree +import Geometry +import RandomHelp armouredCorridor :: RandomGen g => State g Room armouredCorridor = fmap (replacePutID 0 [PutCrit $ addArmour autoCrit]) litCorridor90 @@ -27,41 +25,47 @@ A corridor of random length with a 90 degree link at the end. -} litCorridor90 :: RandomGen g => State g Room litCorridor90 = do - h <- state $ randomR (500,800) + h <- state $ randomR (500, 800) let poly = rectNSWE h 0 0 40 - poly2 = rectNSWE (h-60) (h-100) (-60) 5 - pure $ defaultRoom - { _rmPolys = [poly,poly2] - , _rmLinks = - [ outLink (V2 40 (h - 80)) (-pi/2) - , inLink (V2 20 0 ) pi ] - , _rmPath = foldMap doublePairSet - [( V2 20 0 , V2 20 (h-40) ) - ,( V2 0 (h-40) , V2 20 (h-40) ) - ,( V2 40 (h-40) , V2 20 (h-40) ) - ] - , _rmPmnts = - [ sPS (V2 20 (h-5)) 0 putLamp - , spanLightI (V2 0 (0.4*h)) (V2 40 (0.4*h)) - , windowLine (V2 0 (h-20)) (V2 40 (h-20)) - , sPS (V2 (-50) (h-85)) 0 putLamp - , windowLine (V2 (-40) (h-60)) (V2 (-40) (h-100)) - , sPS (V2 20 (h-40)) 0 $ PutID 0 - , sPS (V2 (-20) (h-80)) 0 $ PutID 2 - ] - , _rmBound = [poly] - } + poly2 = rectNSWE (h -60) (h -100) (-60) 5 + pure $ + defaultRoom + { _rmPolys = [poly, poly2] + , _rmLinks = + [ outLink (V2 40 (h - 80)) (- pi / 2) + , inLink (V2 20 0) pi + ] + , _rmPath = + foldMap + doublePairSet + [ (V2 20 0, V2 20 (h -40)) + , (V2 0 (h -40), V2 20 (h -40)) + , (V2 40 (h -40), V2 20 (h -40)) + ] + , _rmPmnts = + [ sPS (V2 20 (h -5)) 0 putLamp + , spanLightI (V2 0 (0.4 * h)) (V2 40 (0.4 * h)) + , windowLine (V2 0 (h -20)) (V2 40 (h -20)) + , sPS (V2 (-50) (h -85)) 0 putLamp + , windowLine (V2 (-40) (h -60)) (V2 (-40) (h -100)) + , sPS (V2 20 (h -40)) 0 $ PutID 0 + , sPS (V2 (-20) (h -80)) 0 $ PutID 2 + ] + , _rmBound = [poly] + } -- | A random length corridor with a destructible block blocking it. longBlockedCorridor :: RandomGen g => Int -> State g (Tree Room) longBlockedCorridor maxn = do - r <- state $ randomR (0,pi) - n <- state $ randomR (0,maxn) - let plmnts = [sPS (V2 20 40) r $ dirtPoly $ square 10 - ,sPS (V2 20 15) 0 putLamp + r <- state $ randomR (0, pi) + n <- state $ randomR (0, maxn) + let plmnts = + [ sPS (V2 20 40) r $ dirtPoly $ square 10 + , sPS (V2 20 15) 0 putLamp ] - sequence $ treeFromPost (replicate n $ shuffleLinks corridor) - $ return $ cleatOnward $ set rmPmnts plmnts corridor + sequence $ + treeFromPost (replicate n $ shuffleLinks corridor) $ + return $ cleatOnward $ set rmPmnts plmnts corridor -- | A single corridor with a destructible block blocking it. blockedCorridor :: RandomGen g => State g (Tree Room) @@ -73,18 +77,20 @@ dirtPoly = PutBlock defaultDirtBlock defaultDirtWall . reverse -- | A single corridor with a destructible block blocking it. blockedCorridorCloseBlocks :: RandomGen g => State g Room blockedCorridorCloseBlocks = do - r <- state $ randomR (0,pi) - r' <- state $ randomR (0,pi) - theblocks <- takeOne - [ [sPS (V2 20 40) r $ dirtPoly $ square 8] - --, [ sPS (V2 5 40) r $ dirtPoly $ square 10 - -- , sPS (V2 35 40) (r+0.5) $ dirtPoly $ square 10 - -- ] - --, - --[ sPS (V2 5 50) r $ dirtPoly $ square 10 - --, sPS (V2 35 35) (r+0.5) $ dirtPoly $ square 10 - , [ sPS (V2 6 25) r $ dirtPoly $ square 8 - , sPS (V2 35 20) r' $ dirtPoly $ square 8 + r <- state $ randomR (0, pi) + r' <- state $ randomR (0, pi) + theblocks <- + takeOne + [ [sPS (V2 20 40) r $ dirtPoly $ square 8] + , --, [ sPS (V2 5 40) r $ dirtPoly $ square 10 + -- , sPS (V2 35 40) (r+0.5) $ dirtPoly $ square 10 + -- ] + --, + --[ sPS (V2 5 50) r $ dirtPoly $ square 10 + --, sPS (V2 35 35) (r+0.5) $ dirtPoly $ square 10 + + [ sPS (V2 6 25) r $ dirtPoly $ square 8 + , sPS (V2 35 20) r' $ dirtPoly $ square 8 + ] ] - ] return $ corridor & rmPmnts .~ theblocks diff --git a/src/Dodge/Room/Room.hs b/src/Dodge/Room/Room.hs index 8ae3d3688..4f5d7265d 100644 --- a/src/Dodge/Room/Room.hs +++ b/src/Dodge/Room/Room.hs @@ -1,111 +1,114 @@ --{-# LANGUAGE TupleSections #-} -module Dodge.Room.Room - ( shootingRange - , weaponRoom - , roomMiniIntro - , roomCCrits - , doubleCorridorBarrels - , pistolerRoom - , spawnerRoom - , corDoor - ) where -import Dodge.Cleat -import Dodge.Item.Display -import Dodge.Data -import Dodge.PlacementSpot -import Dodge.RoomLink -import Dodge.Default.Room -import Dodge.Creature -import Dodge.Room.Pillar -import Dodge.Room.Foreground -import Dodge.Room.Girder -import Dodge.Room.Modify.Girder -import Dodge.LevelGen.Data -import RandomHelp -import Dodge.Tree -import Dodge.Placement.Instance -import Dodge.Placement.Random ---import Dodge.LevelGen.Data -import Dodge.Room.Procedural -import Dodge.Room.Corridor ---import Dodge.Room.Tanks -import Dodge.Room.Link -import Dodge.Room.Door -import Dodge.Room.Airlock -import Geometry -import MonadHelp -import LensHelp +module Dodge.Room.Room ( + shootingRange, + weaponRoom, + roomMiniIntro, + roomCCrits, + doubleCorridorBarrels, + pistolerRoom, + spawnerRoom, + corDoor, +) where import qualified Data.Set as S +import Dodge.Cleat +import Dodge.Creature +import Dodge.Data.GenWorld +import Dodge.Default.Room +import Dodge.Item.Display +import Dodge.LevelGen.Data +import Dodge.Placement.Instance +import Dodge.Placement.Random +import Dodge.PlacementSpot +import Dodge.Room.Airlock +import Dodge.Room.Corridor +import Dodge.Room.Door +import Dodge.Room.Foreground +import Dodge.Room.Girder +import Dodge.Room.Link +import Dodge.Room.Modify.Girder +import Dodge.Room.Pillar +import Dodge.Room.Procedural +import Dodge.RoomLink +import Dodge.Tree +import Geometry +import LensHelp +import MonadHelp +import RandomHelp roomC :: RandomGen g => Float -> Float -> State g Room roomC w h = do - wallf <- takeOne [ crystalLine , windowLine ] + wallf <- takeOne [crystalLine, windowLine] maybeaddgird <- takeOne [return, addRandomGirderFrom West 0, addRandomGirderFrom North 0] - maybeaddgird =<< shuffleLinks (roomRectAutoLinks w h - & rmLinks %~ - ( setInLinks (\rl -> S.fromList [FromEdge East 0,OnEdge South] `S.isSubsetOf` _rlType rl) - . setOutLinks (\rl -> OnEdge West `S.member` _rlType rl) + maybeaddgird + =<< shuffleLinks + ( roomRectAutoLinks w h + & rmLinks + %~ ( setInLinks (\rl -> S.fromList [FromEdge East 0, OnEdge South] `S.isSubsetOf` _rlType rl) + . setOutLinks (\rl -> OnEdge West `S.member` _rlType rl) + ) + & rmPmnts .:~ wallf (V2 (w / 2) 0) (V2 (w / 2) (h -60)) + & rmPmnts .:~ sps0 (PutDecoration (highMesh (V2 0 0) (V2 0 h) 50)) + & rmRandPSs .~ [farside] ) - & rmPmnts .:~ wallf (V2 (w/2) 0) (V2 (w/2) (h-60)) - & rmPmnts .:~ sps0 (PutDecoration (highMesh (V2 0 0) (V2 0 h) 50)) - & rmRandPSs .~ [farside] - ) where farside = do - x <- state $ randomR (5, w/2 - 20) + x <- state $ randomR (5, w / 2 - 20) y <- state $ randomR (5, h - 70) - a <- state $ randomR (0, 2*pi) - return (V2 x y,a) + a <- state $ randomR (0, 2 * pi) + return (V2 x y, a) roomPadCut :: [Point2] -> Point2 -> Room -roomPadCut ps p = defaultRoom - { _rmPolys = [ps] - , _rmLinks = muout [(p,0)] ++ muin [(V2 0 0,pi)] - , _rmPath = doublePairSet (V2 0 0,p) - } +roomPadCut ps p = + defaultRoom + { _rmPolys = [ps] + , _rmLinks = muout [(p, 0)] ++ muin [(V2 0 0, pi)] + , _rmPath = doublePairSet (V2 0 0, p) + } branchWith :: Room -> [Tree Room] -> Tree Room branchWith r = Node r . (return (cleatOnward door) :) glassSwitchBack :: RandomGen g => State g Room glassSwitchBack = do - wth <- state $ randomR (200,400) - hgt <- state $ randomR (400,600) - wllen <- state $ randomR (60,wth/2-40) - let hf = hgt/5 - awindow h xl xr = windowLine (V2 xl h) (V2 xr h) - plmnts = - [awindow hf (wth-60) wllen - ,awindow (2*hf) (wth-wllen) 60 - ,awindow (3*hf) (wth-60) wllen - ,awindow (4*hf) (wth-wllen) 60 - ,blockLine (V2 0 (1*hf)) (V2 wllen (1*hf)) - ,blockLine (V2 (wth-wllen) (2*hf)) (V2 wth (2*hf)) - ,blockLine (V2 0 (3*hf)) (V2 wllen (3*hf)) - ,blockLine (V2 (wth-wllen) (4*hf)) (V2 wth (4*hf)) - , sPS (V2 (wth/2) (hgt/2)) 0 putLamp + wth <- state $ randomR (200, 400) + hgt <- state $ randomR (400, 600) + wllen <- state $ randomR (60, wth / 2 -40) + let hf = hgt / 5 + awindow h xl xr = windowLine (V2 xl h) (V2 xr h) + plmnts = + [ awindow hf (wth -60) wllen + , awindow (2 * hf) (wth - wllen) 60 + , awindow (3 * hf) (wth -60) wllen + , awindow (4 * hf) (wth - wllen) 60 + , blockLine (V2 0 (1 * hf)) (V2 wllen (1 * hf)) + , blockLine (V2 (wth - wllen) (2 * hf)) (V2 wth (2 * hf)) + , blockLine (V2 0 (3 * hf)) (V2 wllen (3 * hf)) + , blockLine (V2 (wth - wllen) (4 * hf)) (V2 wth (4 * hf)) + , sPS (V2 (wth / 2) (hgt / 2)) 0 putLamp ] let northPSs = do - cry <- randomRanges [3*hf+10,4*hf-10 ,4*hf+10,5*hf-10 ] - crx <- state $ randomR (wllen,wth-(wllen+40)) - return (V2 crx cry,1.5*pi) - midPS = return (V2 (wth-20) (hgt/2+40), pi) - return $ roomRect wth hgt 2 4 - & rmPmnts .~ plmnts - & rmRandPSs .~ [northPSs,midPS] - & rmName .~ "glassSwitchBack" + cry <- randomRanges [3 * hf + 10, 4 * hf -10, 4 * hf + 10, 5 * hf -10] + crx <- state $ randomR (wllen, wth - (wllen + 40)) + return (V2 crx cry, 1.5 * pi) + midPS = return (V2 (wth -20) (hgt / 2 + 40), pi) + return $ + roomRect wth hgt 2 4 + & rmPmnts .~ plmnts + & rmRandPSs .~ [northPSs, midPS] + & rmName .~ "glassSwitchBack" glassSwitchBackCrits :: RandomGen g => State g Room -glassSwitchBackCrits = glassSwitchBack <&> rmPmnts .++~ - [ spNoID (PSRoomRand 0 (uncurry PS)) (PutCrit miniGunCrit) - , spNoID (PSRoomRand 1 (uncurry PS)) randC1 - ] +glassSwitchBackCrits = + glassSwitchBack <&> rmPmnts + .++~ [ spNoID (PSRoomRand 0 (uncurry PS)) (PutCrit miniGunCrit) + , spNoID (PSRoomRand 1 (uncurry PS)) randC1 + ] miniTree2 :: RandomGen g => State g (Tree Room) miniTree2 = do rm <- glassSwitchBackCrits >>= shuffleLinks . restrictInLinks (\p -> (sndV2 . fst) p < 70) - return $ branchWith rm (replicate 3 $ treePost [door,corridor,critInDeadEnd]) + return $ branchWith rm (replicate 3 $ treePost [door, corridor, critInDeadEnd]) -- So, the idea is to attach outer children to the bottommost right nodes -- inside an inner tree @@ -117,217 +120,265 @@ roomMiniIntro = do roomCenterPillar :: RandomGen g => State g Room roomCenterPillar = do - addHighGirder' =<< (shuffleLinks . restrictInLinks ((\p -> dist p (V2 120 0) < 10) . fst) - $ cleatSide - $ set rmPmnts plmnts - $ set rmName "roomCenterPillar" - $ roomRect 240 240 2 2 - ) - where - plmnts = + addHighGirder' + =<< ( shuffleLinks . restrictInLinks ((\p -> dist p (V2 120 0) < 10) . fst) $ + cleatSide $ + set rmPmnts plmnts $ + set rmName "roomCenterPillar" $ + roomRect 240 240 2 2 + ) + where + plmnts = [ blockLine (V2 115 115) (V2 115 125) , blockLine (V2 125 115) (V2 125 125) --- , mntLightLnkCond useUnusedLnk - , mntLightLnkCond (resetPLUse $ rprBool $ \rp _ -> isInLnk rp) - , mntLightLnkCond (resetPLUse $ rprBool $ \rp _ -> isOutLnk rp) + , -- , mntLightLnkCond useUnusedLnk + mntLightLnkCond (resetPLUse $ rprBool $ \rp _ -> isInLnk rp) + , mntLightLnkCond (resetPLUse $ rprBool $ \rp _ -> isOutLnk rp) ] weaponEmptyRoom :: State StdGen (Tree Room) weaponEmptyRoom = do - w <- state $ randomR (220,300) - h <- state $ randomR (220,300) + w <- state $ randomR (220, 300) + h <- state $ randomR (220, 300) wp <- randFirstWeapon - let plmnts = - [sPS (V2 (w/2) (h-40)) 0 $ PutFlIt wp - ,sPS (V2 20 20) (pi/2) randC1 - ,sPS (V2 (w-20) 20) (pi/2) randC1 - ,mntLightLnkCond useUnusedLnk + let plmnts = + [ sPS (V2 (w / 2) (h -40)) 0 $ PutFlIt wp + , sPS (V2 20 20) (pi / 2) randC1 + , sPS (V2 (w -20) 20) (pi / 2) randC1 + , mntLightLnkCond useUnusedLnk ] - f (V2 x y,a) = (a == pi && x > 25 && x < w - 25) || (a /= 0 && y > w - 30) - rm <- addHighGirder >=> shuffleLinks - $ restrictRMInLinksPD f (roomRect w h 2 2 & rmPmnts .~ plmnts) - return $ treePost [ corridor, cleatSide $ cleatOnward rm ] - + f (V2 x y, a) = (a == pi && x > 25 && x < w - 25) || (a /= 0 && y > w - 30) + rm <- + addHighGirder >=> shuffleLinks $ + restrictRMInLinksPD f (roomRect w h 2 2 & rmPmnts .~ plmnts) + return $ treePost [corridor, cleatSide $ cleatOnward rm] + weaponUnderCrits :: RandomGen g => Int -> State g (MetaTree Room String) weaponUnderCrits i = do let addwpat p = rmPmnts .:~ PickOnePlacement i (sPS p 0 $ RandPS $ fmap PutFlIt randFirstWeapon) - continuationRoom = treePost - [ addwpat (V2 20 0) corridorN - , addwpat (V2 20 0) corridorN - , cleatOnward $ corridorN & rmPmnts .~ - [ sPS (V2 20 0) (negate $ pi/2) randC1 - , sPS (V2 20 20) ( pi/2) randC1 + continuationRoom = + treePost + [ addwpat (V2 20 0) corridorN + , addwpat (V2 20 0) corridorN + , cleatOnward $ + corridorN & rmPmnts + .~ [ sPS (V2 20 0) (negate $ pi / 2) randC1 + , sPS (V2 20 20) (pi / 2) randC1 + ] ] - ] rcp <- roomCenterPillar rmpils <- roomPillars 30 240 240 2 2 - deadEndRoom' <- takeOne [ addwpat (V2 120 20) rmpils , addwpat (V2 120 20) $ cleatSide rcp] - junctionRoom <- takeOne [ tEast, tWest] - rToOnward "weaponUnderCrits" $ treeFromTrunk [ corridorN , corridorN] - $ Node junctionRoom [continuationRoom ,pure deadEndRoom' ] + deadEndRoom' <- takeOne [addwpat (V2 120 20) rmpils, addwpat (V2 120 20) $ cleatSide rcp] + junctionRoom <- takeOne [tEast, tWest] + rToOnward "weaponUnderCrits" $ + treeFromTrunk [corridorN, corridorN] $ + Node junctionRoom [continuationRoom, pure deadEndRoom'] weaponBehindPillar :: RandomGen g => State g (Tree Room) -weaponBehindPillar = do - wpa <- state $ randomR (0,pi) - wpos <- takeOne [V2 120 160,V2 80 40,V2 160 40,V2 220 200,V2 40 200,V2 120 35] - cpos <- takeOne $ [V2 x y | x <- [20,220], y <- [20,40]] ++ [V2 120 160,V2 120 200] +weaponBehindPillar = do + wpa <- state $ randomR (0, pi) + wpos <- takeOne [V2 120 160, V2 80 40, V2 160 40, V2 220 200, V2 40 200, V2 120 35] + cpos <- takeOne $ [V2 x y | x <- [20, 220], y <- [20, 40]] ++ [V2 120 160, V2 120 200] rcp <- roomCenterPillar - return $ treePost - [ corridor - , rcp & rmPmnts ++.~ - [sPS wpos wpa $ RandPS $ fmap PutFlIt randFirstWeapon - ,sPS cpos (argV $ V2 120 80 -.- cpos) randC1 + return $ + treePost + [ corridor + , rcp & rmPmnts + ++.~ [ sPS wpos wpa $ RandPS $ fmap PutFlIt randFirstWeapon + , sPS cpos (argV $ V2 120 80 -.- cpos) randC1 + ] + , cleatOnward $ set rmPmnts [sPS (V2 20 60) (negate $ pi / 2) randC1] corridorN ] - , cleatOnward $ set rmPmnts [sPS (V2 20 60) (negate $ pi/2) randC1] corridorN - ] weaponBetweenPillars :: State StdGen (MetaTree Room String) weaponBetweenPillars = do - (w,wn) <- takeOne [(240,2),(340,3)] - (h,hn) <- takeOne [(240,2),(340,3)] - let wpPos = rprBool $ \rp r -> and - [ rpIsOnPath rp - , _rpPlacementUse rp == 0 - , _rpLinkStatus rp == NotLink - , any ((<100) . dist (_rpPos rp)) (usedRoomInLinkPoss r) - ] - ncrits <- state $ randomR (1,3) + (w, wn) <- takeOne [(240, 2), (340, 3)] + (h, hn) <- takeOne [(240, 2), (340, 3)] + let wpPos = rprBool $ \rp r -> + and + [ rpIsOnPath rp + , _rpPlacementUse rp == 0 + , _rpLinkStatus rp == NotLink + , any ((< 100) . dist (_rpPos rp)) (usedRoomInLinkPoss r) + ] + ncrits <- state $ randomR (1, 3) wp <- randFirstWeapon - critPlacementSpots <- replicateM ncrits $ randDirPS $ rprBool $ \rp r -> - rpIsOnPath rp - && _rpPlacementUse rp == 0 - && all ((>100) . dist (_rpPos rp)) (usedRoomLinkPoss r) - (roomPillars 30 w h wn hn - <&> rmPmnts .++~ map (`sps` randC1) critPlacementSpots ++ [ sps wpPos (PutFlIt wp) ] - <&> cleatOnward) >>= rToOnward ("weaponBetweenPillars_"++itemString wp) . pure + critPlacementSpots <- replicateM ncrits $ + randDirPS $ + rprBool $ \rp r -> + rpIsOnPath rp + && _rpPlacementUse rp == 0 + && all ((> 100) . dist (_rpPos rp)) (usedRoomLinkPoss r) + ( roomPillars 30 w h wn hn + <&> rmPmnts .++~ map (`sps` randC1) critPlacementSpots ++ [sps wpPos (PutFlIt wp)] + <&> cleatOnward + ) + >>= rToOnward ("weaponBetweenPillars_" ++ itemString wp) . pure weaponLongCorridor :: RandomGen g => State g (Tree Room) weaponLongCorridor = do rt <- takeOne [tEast, tWest] - connectingRoom <- takeOne [tEast & rmPmnts .~ [spanLightI (V2 (-30) 40) (V2 (-30) 80)] ] - i1 <- state $ randomR (2,5) - i2 <- state $ randomR (2,5) - let branch1 = treeFromTrunk (replicate i1 corridorN) - (pure . cleatSide . cleatOnward $ putCrs connectingRoom) - let branch2 = treeFromTrunk (replicate i2 corridorN) (pure . cleatSide $ putWp corridor) - return $ Node rt [branch1,branch2] - where - putCrs = rmPmnts .++~ [sPS (V2 10 40) (-pi/2) randC1 ,sPS (V2 (-10) 40) (-pi/2) randC1 ] - putWp = rmPmnts .~ [sPS (V2 20 60) 0 $ RandPS $ fmap PutFlIt randFirstWeapon ,spanLightI (V2 0 40) (V2 40 40)] + connectingRoom <- takeOne [tEast & rmPmnts .~ [spanLightI (V2 (-30) 40) (V2 (-30) 80)]] + i1 <- state $ randomR (2, 5) + i2 <- state $ randomR (2, 5) + let branch1 = + treeFromTrunk + (replicate i1 corridorN) + (pure . cleatSide . cleatOnward $ putCrs connectingRoom) + let branch2 = treeFromTrunk (replicate i2 corridorN) (pure . cleatSide $ putWp corridor) + return $ Node rt [branch1, branch2] + where + putCrs = rmPmnts .++~ [sPS (V2 10 40) (- pi / 2) randC1, sPS (V2 (-10) 40) (- pi / 2) randC1] + putWp = rmPmnts .~ [sPS (V2 20 60) 0 $ RandPS $ fmap PutFlIt randFirstWeapon, spanLightI (V2 0 40) (V2 40 40)] critInDeadEnd :: Room critInDeadEnd = deadEndRoom & rmPmnts .~ [sPS (V2 0 0) 0 randC1] deadEndRoom :: Room -deadEndRoom = defaultRoom - { _rmPolys = [rectNSWE 40 (-20) (-20) 20 ] - , _rmLinks = muout (init lnks) ++ muin [last lnks] - , _rmPath = mempty - , _rmPmnts = [sPS (V2 0 (-10)) 0 putLamp] - , _rmBound = [rectNSWE 20 (-20) (-30) 30] - , _rmName = "deadEndRoom" - } - where - lnks = [(V2 0 30 ,0) ] +deadEndRoom = + defaultRoom + { _rmPolys = [rectNSWE 40 (-20) (-20) 20] + , _rmLinks = muout (init lnks) ++ muin [last lnks] + , _rmPath = mempty + , _rmPmnts = [sPS (V2 0 (-10)) 0 putLamp] + , _rmBound = [rectNSWE 20 (-20) (-30) 30] + , _rmName = "deadEndRoom" + } + where + lnks = [(V2 0 30, 0)] + {- A random Either tree with a weapon and melee monster challenge. -} weaponRoom :: Int -> State StdGen (MetaTree Room String) -weaponRoom i = join $ takeOne - [ weaponEmptyRoom >>= rToOnward "weaponEmptyRoom" - , weaponUnderCrits i -- this int is used for PickOnePlacement - , weaponBehindPillar >>= rToOnward "weaponBehindPillar" - , weaponBetweenPillars-- >>= rToOnward "weaponBetweenPillars" - , weaponLongCorridor >>= rToOnward "weaponLongCorridor" - ] +weaponRoom i = + join $ + takeOne + [ weaponEmptyRoom >>= rToOnward "weaponEmptyRoom" + , weaponUnderCrits i -- this int is used for PickOnePlacement + , weaponBehindPillar >>= rToOnward "weaponBehindPillar" + , weaponBetweenPillars -- >>= rToOnward "weaponBetweenPillars" + , weaponLongCorridor >>= rToOnward "weaponLongCorridor" + ] roomCCrits :: RandomGen g => Int -> State g Room -roomCCrits i = roomC 200 200 - <&> rmPmnts .++~ replicate i (spNoID (PSRoomRand 0 (uncurry PS)) randC1) +roomCCrits i = + roomC 200 200 + <&> rmPmnts .++~ replicate i (spNoID (PSRoomRand 0 (uncurry PS)) randC1) doubleCorridorBarrels :: RandomGen g => State g Room doubleCorridorBarrels = do - h <- state $ randomR (200,300) + h <- state $ randomR (200, 300) let cond x = (sndV2 . fst) x < h - 40 - return $ restrictInLinks cond $ roomRect 100 h 1 1 & rmPmnts .~ - [blockLine (V2 50 50) (V2 50 h) - ,sPS (V2 25 (h-25)) (negate pi/2) $ PutCrit $ addArmour autoCrit - ,sPS (V2 75 (h-80)) 0 putLamp - ] ++ - [sPS p 0 $ PutCrit explosiveBarrel - | p <- [ V2 75 (h-30) ,V2 75 (h-60) ,V2 85 (h-10) ,V2 85 (h-45) ] ] + return $ + restrictInLinks cond $ + roomRect 100 h 1 1 & rmPmnts + .~ [ blockLine (V2 50 50) (V2 50 h) + , sPS (V2 25 (h -25)) (negate pi / 2) $ PutCrit $ addArmour autoCrit + , sPS (V2 75 (h -80)) 0 putLamp + ] + ++ [ sPS p 0 $ PutCrit explosiveBarrel + | p <- [V2 75 (h -30), V2 75 (h -60), V2 85 (h -10), V2 85 (h -45)] + ] shootersRoom' :: RandomGen g => State g Room shootersRoom' = do - w <- state $ randomR (200,300) - x1 <- state $ randomR (20,w/3-20) - x2 <- state $ randomR (w/3+20,2*w/3-20) - x3 <- state $ randomR (2*w/3+20,w-20) - y1 <- state $ randomR (280,550) - y2 <- state $ randomR (280,550) - y3 <- iterateWhile (\y' -> abs (y1 - y2) < 60 && abs (y2 - y') < 60) $ state $ randomR (280,560) - x4 <- state $ randomR (60,w-60) - y4 <- state $ randomR (40,150) - let bln x y = putBlockN (x+25) (x-25) (y+20) (y+10) - blv x y = putBlockV (x+25) (x-25) (y+20) (y+10) - plmnts = bln x1 y1 ++ bln x2 y2 ++ bln x3 y3 ++ blv x4 y4 - ++ [spanLightI (V2 (-10) 200) (V2 (w/2) 200) - ,spanLightI (V2 (w/2) 200) (V2 (w+10) 200) - ] - toPS x y = return (V2 x y,-0.5*pi) - return $ set rmPmnts plmnts $ roomRectAutoLinks w 600 - & rmPmnts .~ plmnts - & rmRandPSs .~ [toPS x1 y1,toPS x2 y2,toPS x3 y3] + w <- state $ randomR (200, 300) + x1 <- state $ randomR (20, w / 3 -20) + x2 <- state $ randomR (w / 3 + 20, 2 * w / 3 -20) + x3 <- state $ randomR (2 * w / 3 + 20, w -20) + y1 <- state $ randomR (280, 550) + y2 <- state $ randomR (280, 550) + y3 <- iterateWhile (\y' -> abs (y1 - y2) < 60 && abs (y2 - y') < 60) $ state $ randomR (280, 560) + x4 <- state $ randomR (60, w -60) + y4 <- state $ randomR (40, 150) + let bln x y = putBlockN (x + 25) (x -25) (y + 20) (y + 10) + blv x y = putBlockV (x + 25) (x -25) (y + 20) (y + 10) + plmnts = + bln x1 y1 ++ bln x2 y2 ++ bln x3 y3 ++ blv x4 y4 + ++ [ spanLightI (V2 (-10) 200) (V2 (w / 2) 200) + , spanLightI (V2 (w / 2) 200) (V2 (w + 10) 200) + ] + toPS x y = return (V2 x y, -0.5 * pi) + return $ + set rmPmnts plmnts $ + roomRectAutoLinks w 600 + & rmPmnts .~ plmnts + & rmRandPSs .~ [toPS x1 y1, toPS x2 y2, toPS x3 y3] shootersRoom1 :: RandomGen g => State g Room -shootersRoom1 = shootersRoom' <&> rmPmnts .:~ RandomPlacement - (takeOne $ map (\i -> spNoID (PSRoomRand i (uncurry PS)) (PutCrit autoCrit)) - [0,1,2]) +shootersRoom1 = + shootersRoom' <&> rmPmnts + .:~ RandomPlacement + ( takeOne $ + map + (\i -> spNoID (PSRoomRand i (uncurry PS)) (PutCrit autoCrit)) + [0, 1, 2] + ) shootersRoom :: RandomGen g => State g Room -shootersRoom = shootersRoom' <&> rmPmnts .++~ - map (\i -> spNoID (PSRoomRand i (uncurry PS)) (PutCrit autoCrit)) [0,1,2] +shootersRoom = + shootersRoom' <&> rmPmnts + .++~ map (\i -> spNoID (PSRoomRand i (uncurry PS)) (PutCrit autoCrit)) [0, 1, 2] -- TODO stop from spawning on inlinks fromedge pistolerRoom :: RandomGen g => State g Room pistolerRoom = do - (w,wn) <- takeOne [(200,3),(255,4)] - roomPillars 10 w 200 wn 3 <&> rmPmnts .++~ replicate 3 - (spNoID (rprBool $ \rp _ -> _rpPlacementUse rp == 0 && rpIsOnPath rp) - (PutCrit pistolCrit)) + (w, wn) <- takeOne [(200, 3), (255, 4)] + roomPillars 10 w 200 wn 3 <&> rmPmnts + .++~ replicate + 3 + ( spNoID + (rprBool $ \rp _ -> _rpPlacementUse rp == 0 && rpIsOnPath rp) + (PutCrit pistolCrit) + ) shootingRange :: RandomGen g => State g (MetaTree Room String) shootingRange = do - rm1 <- shootersRoom1 >>= shuffleLinks . restrictInLinks (\(V2 _ y,_) -> y < 40) - . restrictOutLinks (\(V2 _ y,r) -> y > 200 && r /= 0) - rm2 <- shootersRoom >>= shuffleLinks - . restrictInLinks (\(V2 x y,_) -> y < 10 && x > 20 && x < 180) - . restrictOutLinks (\(V2 _ y,r) -> y > 200 && r /= 0) - rm3 <- shootersRoom >>= shuffleLinks - . restrictInLinks (\(V2 x y,_) -> y < 10 && x > 20 && x < 180) - . restrictOutLinks (\(_,r) -> r == 0) - let padcutroom = roomPadCut (rectNSWE 40 (-40) (-80) 80) (V2 0 20) - & rmPmnts .:~ spanLightI (V2 (-80) 10) (V2 80 10) - rToOnward "shootingRange" $ treePost - [ rm1 - , padcutroom - , rm2 - , padcutroom - , cleatOnward rm3 - ] + rm1 <- + shootersRoom1 + >>= shuffleLinks . restrictInLinks (\(V2 _ y, _) -> y < 40) + . restrictOutLinks (\(V2 _ y, r) -> y > 200 && r /= 0) + rm2 <- + shootersRoom + >>= shuffleLinks + . restrictInLinks (\(V2 x y, _) -> y < 10 && x > 20 && x < 180) + . restrictOutLinks (\(V2 _ y, r) -> y > 200 && r /= 0) + rm3 <- + shootersRoom + >>= shuffleLinks + . restrictInLinks (\(V2 x y, _) -> y < 10 && x > 20 && x < 180) + . restrictOutLinks (\(_, r) -> r == 0) + let padcutroom = + roomPadCut (rectNSWE 40 (-40) (-80) 80) (V2 0 20) + & rmPmnts .:~ spanLightI (V2 (-80) 10) (V2 80 10) + rToOnward "shootingRange" $ + treePost + [ rm1 + , padcutroom + , rm2 + , padcutroom + , cleatOnward rm3 + ] spawnerRoom :: RandomGen g => State g (Tree Room) spawnerRoom = do - x <- state $ randomR (250,300) - y <- state $ randomR (300,400) - roomWithSpawner <- roomC x y <&> rmPmnts .:~ spNoID - (rprBool $ \rp _ -> _rpPlacementUse rp == 0 && rpIsOnPath rp - && xV2 (_rpPos rp) < x/2 && yV2 (_rpPos rp) < y/2 ) - (PutCrit spawnerCrit) + x <- state $ randomR (250, 300) + y <- state $ randomR (300, 400) + roomWithSpawner <- + roomC x y <&> rmPmnts + .:~ spNoID + ( rprBool $ \rp _ -> + _rpPlacementUse rp == 0 && rpIsOnPath rp + && xV2 (_rpPos rp) < x / 2 + && yV2 (_rpPos rp) < y / 2 + ) + (PutCrit spawnerCrit) aRoom <- airlock - return $ treeFromTrunk [ aRoom, corridor] $ pure $ cleatOnward roomWithSpawner + return $ treeFromTrunk [aRoom, corridor] $ pure $ cleatOnward roomWithSpawner corDoor :: State StdGen (MetaTree Room String) corDoor = do cor <- shuffleLinks (cleatOnward corridor) <&> rmPmnts .~ [] - return $ tToBTree "corDoor" $ treePost [door,cor] + return $ tToBTree "corDoor" $ treePost [door, cor] + -- cor <- shuffleLinks corridor -- return $ tToBTree "corDoor" $ treePost [door,cor,cleatOnward door] diff --git a/src/Dodge/Room/RunPast.hs b/src/Dodge/Room/RunPast.hs index 3f6e0b9e2..94f749313 100644 --- a/src/Dodge/Room/RunPast.hs +++ b/src/Dodge/Room/RunPast.hs @@ -1,54 +1,57 @@ -module Dodge.Room.RunPast - ( lockedStart - ) where +module Dodge.Room.RunPast ( + lockedStart, +) where + +import Color +import qualified Data.Set as S import Dodge.Cleat -import Geometry.Polygon +import Dodge.Data.GenWorld +import Dodge.Item.Random import Dodge.LevelGen.Data import Dodge.LightSource -import Dodge.Data -import RandomHelp +import Dodge.Placement.Instance +import Dodge.PlacementSpot +import Dodge.Room.Corridor import Dodge.Room.Door import Dodge.Room.Link import Dodge.Room.Procedural -import Dodge.Room.Corridor -import Dodge.PlacementSpot -import Dodge.Placement.Instance import Dodge.Tree -import Dodge.Item.Random import Geometry.Data -import Color +import Geometry.Polygon import LensHelp - -import qualified Data.Set as S +import RandomHelp roomCritLS :: RandomGen g => State g LightSource roomCritLS = do col <- takeOne [0.5, 0.6] - h <- takeOne [30,35] + h <- takeOne [30, 35] rad <- takeOne [300] return $ lsPosColRad (V3 0 0 h) col rad smallRoom :: Room -smallRoom = corridorWallN & rmRandPSs .~ [psRandRanges (15,25) (30,45) (pi,2*pi)] +smallRoom = corridorWallN & rmRandPSs .~ [psRandRanges (15, 25) (30, 45) (pi, 2 * pi)] lockedStart :: RandomGen g => Int -> State g (Tree Room) lockedStart i = do - h <- state $ randomR (200,400::Float) - thels <- roomCritLS - theweapon <- randBlockBreakWeapon - cenroom <- shuffleLinks $ roomRectAutoLinks 40 h & rmPmnts .~ [] - theedge <- takeOne $ map OnEdge [West,East] - let linkcor = smallRoom & rmPmnts .~ [ spanLS thels (V2 0 65) (V2 40 65) ] + h <- state $ randomR (200, 400 :: Float) + thels <- roomCritLS + theweapon <- randBlockBreakWeapon + cenroom <- shuffleLinks $ roomRectAutoLinks 40 h & rmPmnts .~ [] + theedge <- takeOne $ map OnEdge [West, East] + let linkcor = smallRoom & rmPmnts .~ [spanLS thels (V2 0 65) (V2 40 65)] n = length $ filter (elem theedge . _rlType) (_rmLinks cenroom) - doorrooms = map (treePost . (triggerDoorRoom i:)) - $ [linkcor & rmPmnts .:~ plRRpt 0 randC1] - : [linkcor,corridor,corridor,cleatOnward door] - : replicate (n-2) [linkcor] - return $ Node cenroom $ - map (over root $ rmConnectsTo .~ S.member theedge) doorrooms - ++ [return smallRoom - {_rmOutPmnt = [OutPlacement (putLitButOnPosExtTrig red useUnusedLnk) i] - ,_rmPmnts = [plRRpt 0 (PutFlIt theweapon)] - ,_rmBound = [rectNSWE 70 30 0 40] - } - ] + doorrooms = + map (treePost . (triggerDoorRoom i :)) $ + [linkcor & rmPmnts .:~ plRRpt 0 randC1] : + [linkcor, corridor, corridor, cleatOnward door] : + replicate (n -2) [linkcor] + return $ + Node cenroom $ + map (over root $ rmConnectsTo .~ S.member theedge) doorrooms + ++ [ return + smallRoom + { _rmOutPmnt = [OutPlacement (putLitButOnPosExtTrig red useUnusedLnk) i] + , _rmPmnts = [plRRpt 0 (PutFlIt theweapon)] + , _rmBound = [rectNSWE 70 30 0 40] + } + ] diff --git a/src/Dodge/Room/SensorDoor.hs b/src/Dodge/Room/SensorDoor.hs index dd8ddfc3a..a916e8fbd 100644 --- a/src/Dodge/Room/SensorDoor.hs +++ b/src/Dodge/Room/SensorDoor.hs @@ -1,39 +1,40 @@ --{-# LANGUAGE TupleSections #-} module Dodge.Room.SensorDoor where + +--import Dodge.RoomLink + +import qualified Data.Set as S import Dodge.Annotation.Data import Dodge.Cleat +import Dodge.Data.GenWorld import Dodge.LevelGen.Data +import Dodge.Placement.Instance import Dodge.PlacementSpot -import Dodge.Placement.Instance.Terminal -import Dodge.Terminal -import Dodge.Data -import Dodge.Tree -import Dodge.Wire ---import Dodge.RoomLink +import Dodge.Room.Corridor import Dodge.Room.Door +import Dodge.Room.Link import Dodge.Room.Ngon import Dodge.Room.Procedural -import Dodge.Room.Corridor -import Dodge.Room.Link -import Dodge.Placement.Instance +import Dodge.Terminal +import Dodge.Tree +import Dodge.Wire import Geometry import LensHelp import RandomHelp -import qualified Data.Set as S - -- TODO fix case where the sensor created by sensInsideDoor blocks another door -- for roomRectAutoLinks-- make the locked door a center door? sensorRoom :: RandomGen g => DamageType -> Int -> State g (Tree Room) sensorRoom senseType n = do rm <- takeOne [roomNgon 8 200, roomRectAutoLinks 200 200] cenroom <- shuffleLinks $ sensInsideDoor senseType n rm - return $ treePost - [ door - , cenroom & rmLinkEff .~ f - , triggerDoorRoom n - , cleatOnward door - ] + return $ + treePost + [ door + , cenroom & rmLinkEff .~ f + , triggerDoorRoom n + , cleatOnward door + ] where f _ _ 0 rl rm = rm & rmLinks %~ map (g (_rlPos rl) (_rlDir rl)) f _ _ _ _ rm = rm @@ -47,27 +48,33 @@ sensorRoom senseType n = do sensorRoomRunPast :: RandomGen g => DamageType -> Int -> State g MTRS sensorRoomRunPast dt n = do t <- sensorRoom dt n - rToOnward "sensorRoomRunPast" $ t & applyToSubforest [0] - (++ - [treePost - [ door & rmConnectsTo .~ (\s -> S.member InLink s && not (S.member BlockedLink s)) - , cleatLabel n corridor ] - ] - ) + rToOnward "sensorRoomRunPast" $ + t + & applyToSubforest + [0] + ( ++ + [ treePost + [ door & rmConnectsTo .~ (\s -> S.member InLink s && not (S.member BlockedLink s)) + , cleatLabel n corridor + ] + ] + ) sensAboveDoor :: DamageType -> Float -> PlacementSpot -> Placement -sensAboveDoor sensetype wth ps = extTrigLitPos - (atFstLnkOutShiftBy (\(p,a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a))) - ( \tp -> Just $ damageSensor sensetype wth (_plMID tp) ps ) +sensAboveDoor sensetype wth ps = + extTrigLitPos + (atFstLnkOutShiftBy (\(p, a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a))) + (\tp -> Just $ damageSensor sensetype wth (_plMID tp) ps) sensInsideDoor :: DamageType -> Int -> Room -> Room -sensInsideDoor senseType outplid rm = rm - & rmName .++~ take 4 (show senseType) - & rmPmnts .++~ - [ psPt atFstLnkOut . PutForeground $ floorWire (V2 20 0) (V2 20 (-100)) - , psPt atFstLnkOut . PutForeground $ floorWire (V2 0 (-100)) (V2 20 (-100)) - , psPt atFstLnkOut . PutForeground $ verticalWire (V2 20 0) 0 80 - , putMessageTerminal terminalColor (basicTerminal & tmScrollCommands .:~ damageCodeCommand) - & plSpot .~ rprBoolShift isUnusedLnk (shiftInBy 10) - ] - & rmOutPmnt .~ [OutPlacement (sensAboveDoor senseType 10 (atFstLnkOutShiftInward 100)) outplid] +sensInsideDoor senseType outplid rm = + rm + & rmName .++~ take 4 (show senseType) + & rmPmnts + .++~ [ psPt atFstLnkOut . PutForeground $ floorWire (V2 20 0) (V2 20 (-100)) + , psPt atFstLnkOut . PutForeground $ floorWire (V2 0 (-100)) (V2 20 (-100)) + , psPt atFstLnkOut . PutForeground $ verticalWire (V2 20 0) 0 80 + , putMessageTerminal terminalColor (basicTerminal & tmScrollCommands .:~ damageCodeCommand) + & plSpot .~ rprBoolShift isUnusedLnk (shiftInBy 10) + ] + & rmOutPmnt .~ [OutPlacement (sensAboveDoor senseType 10 (atFstLnkOutShiftInward 100)) outplid] diff --git a/src/Dodge/Room/Start.hs b/src/Dodge/Room/Start.hs index 8c954d54d..c2153634c 100644 --- a/src/Dodge/Room/Start.hs +++ b/src/Dodge/Room/Start.hs @@ -1,33 +1,31 @@ {-# LANGUAGE TupleSections #-} -module Dodge.Room.Start - ( startRoom - , randomChallenges - ) where + +module Dodge.Room.Start ( + startRoom, + randomChallenges, +) where + +import Dodge.Item.Held.Cane +import Dodge.Item.Held.Launcher import Dodge.Cleat -import Dodge.Data -import Dodge.LevelGen.Data ---import Dodge.PlacementSpot -import Dodge.Room.RunPast -import Dodge.Room.Containing ---import Dodge.Room.LongDoor ---import Dodge.RoomLink ---import Dodge.Data ---import Dodge.Default ---import Dodge.RoomLink -import Dodge.Tree -import RandomHelp -import Dodge.Room.Door -import Dodge.Room.RezBox -import Dodge.Room.Corridor -import Dodge.Room.Room -import Dodge.Room.Link -import Dodge.Item.Weapon +import Dodge.Data.GenWorld import Dodge.Item.Craftable +import Dodge.Item.Weapon +import Dodge.LevelGen.Data +import Dodge.Room.Containing +import Dodge.Room.Corridor +import Dodge.Room.Door +import Dodge.Room.Link +import Dodge.Room.RezBox +import Dodge.Room.Room +import Dodge.Room.RunPast +import Dodge.Tree --import Dodge.LevelGen.Data --import Geometry.Data --import Padding --import Shape import LensHelp +import RandomHelp --import Data.Maybe --import Data.Tree @@ -38,33 +36,42 @@ powerFakeout' = tToBTree "powerFakeout'" <$> powerFakeout powerFakeout :: RandomGen g => State g (Tree Room) powerFakeout = do - ncor <- state $ randomR (0,2) - it <- takeOne - [miniGunX 6 - ,launcherX 7 - ] + ncor <- state $ randomR (0, 2) + it <- + takeOne + [ miniGunX 6 + , launcherX 7 + ] roomwithmini <- pedestalRoom it randcors <- replicateM ncor $ shuffleLinks corridor - return $ treePost $ - [ corridor,door - , roomwithmini - , door - ] - ++ randcors - ++ [ corridor & rmPmnts .:~ plRRpt 0 (PutFlIt shrinkGun) - , keyholeCorridor, corridor - ,cleatOnward door] + return $ + treePost $ + [ corridor + , door + , roomwithmini + , door + ] + ++ randcors + ++ [ corridor & rmPmnts .:~ plRRpt 0 (PutFlIt shrinkGun) + , keyholeCorridor + , corridor + , cleatOnward door + ] -- the i is used either for a PickOnePlacement or a room id, this is not great startRoom :: Int -> State StdGen (MetaTree Room String) -startRoom i = join $ takeOne - [ attachOnward "startThenWeaponRoom" <$> preCritStart <*> weaponRoom i - , rezBoxesWpCrit >>= rToOnward "rezBoxesWpCrit" - , runPastStart i >>= rToOnward ("runPastStart " ++ show i) - , attachOnward "startThenCraft" <$> preCritStart <*> (startCrafts >>= roomsContaining []) - ] +startRoom i = + join $ + takeOne + [ attachOnward "startThenWeaponRoom" <$> preCritStart <*> weaponRoom i + , rezBoxesWpCrit >>= rToOnward "rezBoxesWpCrit" + , runPastStart i >>= rToOnward ("runPastStart " ++ show i) + , attachOnward "startThenCraft" <$> preCritStart <*> (startCrafts >>= roomsContaining []) + ] + randomChallenges :: RandomGen g => State g (MetaTree Room String) randomChallenges = shootingRange + -- join (takeOne -- [fmap (return . useAll) doubleCorridorBarrels <&> (,TreeSubLabelling "doubleCorridorBarrels" Nothing) -- ,shootingRange @@ -76,26 +83,30 @@ runPastStart i = do s <- rezBoxStart rp <- lockedStart i return . shiftChildren $ attachTree toOnward rp $ fmap ([],) s - rezBoxStart :: RandomGen g => State g (Tree Room) rezBoxStart = do ls <- rezColor - return $ treePost [ rezBox ls, cleatOnward door ] + return $ treePost [rezBox ls, cleatOnward door] preCritStart :: RandomGen g => State g (MetaTree Room String) -preCritStart = join $ takeOneWeighted - [100,100,1::Float] - [rezBoxes - ,rezBox' - ,attachOnward "rezBoxPowerFakeout" <$> rezBox' <*> powerFakeout' - ] +preCritStart = + join $ + takeOneWeighted + [100, 100, 1 :: Float] + [ rezBoxes + , rezBox' + , attachOnward "rezBoxPowerFakeout" <$> rezBox' <*> powerFakeout' + ] startCrafts :: RandomGen g => State g [Item] -startCrafts = takeOne $ map (map makeTypeCraft) - [ [PIPE,PIPE,HARDWARE] - , [TUBE,PIPE,HARDWARE] - , [PIPE,HARDWARE,HARDWARE] - , [TUBE,TUBE,HARDWARE] - , [TUBE,HARDWARE,HARDWARE] - ] +startCrafts = + takeOne $ + map + (map makeTypeCraft) + [ [PIPE, PIPE, HARDWARE] + , [TUBE, PIPE, HARDWARE] + , [PIPE, HARDWARE, HARDWARE] + , [TUBE, TUBE, HARDWARE] + , [TUBE, HARDWARE, HARDWARE] + ] diff --git a/src/Dodge/Room/Tanks.hs b/src/Dodge/Room/Tanks.hs index 4f06858a0..45946b8a1 100644 --- a/src/Dodge/Room/Tanks.hs +++ b/src/Dodge/Room/Tanks.hs @@ -1,92 +1,129 @@ module Dodge.Room.Tanks where -import Dodge.Data -import Dodge.Placement.Instance.Pipe +import Color +import Dodge.Base.CardinalPoint +import Dodge.Data.GenWorld import Dodge.LevelGen.Data -import RandomHelp -import Dodge.Room.Procedural -import Dodge.Room.Foreground -import Dodge.Room.Modify.Girder ---import Dodge.Room.RoadBlock import Dodge.Placement.Instance +import Dodge.Placement.Instance.Pipe import Dodge.Placement.TopDecoration import Dodge.PlacementSpot -import Dodge.Base.CardinalPoint ---import Padding -import Color -import Shape -import LensHelp +import Dodge.Room.Foreground +import Dodge.Room.Modify.Girder +import Dodge.Room.Procedural import Geometry +import LensHelp +import RandomHelp +import Shape --import Data.Maybe --import Data.Tree --import qualified Data.Set as S randomTank :: RandomGen g => State g Placement -randomTank = takeOne $ map (\f -> f (dim orange) orange) - [ tankSquareDec fourEmbossDecoration - , tankSquareDec midBarDecoration - , tankSquareDec squareDecoration - , roundTank - , roundTankCross - , tankSquareDec plusDecoration - ] +randomTank = + takeOne $ + map + (\f -> f (dim orange) orange) + [ tankSquareDec fourEmbossDecoration + , tankSquareDec midBarDecoration + , tankSquareDec squareDecoration + , roundTank + , roundTankCross + , tankSquareDec plusDecoration + ] -- dup with randEdgeTanks? randEdgeTank :: RandomGen g => State g Placement randEdgeTank = do edge <- takeOne cardList basetank <- randomTank - return $ basetank - & plType . putBlock . blDraw - %~ ( \bd -> BlockDraws [bd, BlockDrawBlSh (BlShConst $ colorSH orange (verticalPipe 80 - <> horPipe 80 0 (70 *.* cardVec edge)))] ) - -- %~ fmap (<> noPic ( colorSH orange (verticalPipe 80 - -- <> horPipe 80 0 (70 *.* cardVec edge)))) - -- 70 is a guess, the true value depends on the distance to the wall - & plSpot .~ rprBool (\rp _ -> _rpPlacementUse rp == 0 - && rpOffPathFromEdge (PathFromEdge edge 0) rp) + return $ + basetank + & plType . putBlock . blDraw + %~ ( \bd -> + BlockDraws + [ bd + , BlockDrawBlSh + ( BlShConst $ + colorSH + orange + ( verticalPipe 80 + <> horPipe 80 0 (70 *.* cardVec edge) + ) + ) + ] + ) + -- %~ fmap (<> noPic ( colorSH orange (verticalPipe 80 + -- <> horPipe 80 0 (70 *.* cardVec edge)))) + -- 70 is a guess, the true value depends on the distance to the wall + & plSpot + .~ rprBool + ( \rp _ -> + _rpPlacementUse rp == 0 + && rpOffPathFromEdge (PathFromEdge edge 0) rp + ) randEdgeTanks :: RandomGen g => Int -> State g [Placement] randEdgeTanks i = do edge <- takeOne cardList basetank <- randomTank - return $ replicate i $ basetank - & plType . putBlock . blDraw - %~ ( \bd -> BlockDraws [bd, BlockDrawBlSh (BlShConst $ colorSH orange (verticalPipe 80 - <> horPipe 80 0 (70 *.* cardVec edge)))] ) - -- 70 is a guess, the true value depends on the distance to the wall - & plSpot .~ rprBool (\rp _ -> _rpPlacementUse rp == 0 - && rpOffPathFromEdge (PathFromEdge edge 0) rp) + return $ + replicate i $ + basetank + & plType . putBlock . blDraw + %~ ( \bd -> + BlockDraws + [ bd + , BlockDrawBlSh + ( BlShConst $ + colorSH + orange + ( verticalPipe 80 + <> horPipe 80 0 (70 *.* cardVec edge) + ) + ) + ] + ) + -- 70 is a guess, the true value depends on the distance to the wall + & plSpot + .~ rprBool + ( \rp _ -> + _rpPlacementUse rp == 0 + && rpOffPathFromEdge (PathFromEdge edge 0) rp + ) tanksPipesRoom :: RandomGen g => State g Room tanksPipesRoom = do - w <- state $ randomR (200,300) - h <- state $ randomR (200,300) - i <- state $ randomR (2,5) + w <- state $ randomR (200, 300) + h <- state $ randomR (200, 300) + i <- state $ randomR (2, 5) tanks <- randEdgeTanks i return $ roomRectAutoLinks w h & rmPmnts .++~ tanks tanksRoom :: RandomGen g => [Creature] -> [Item] -> State g Room tanksRoom crs its = do - w <- state $ randomR (100,400) - h <- state $ randomR (200,400) - ntanks <- state $ randomR (3,6) + w <- state $ randomR (100, 400) + h <- state $ randomR (200, 400) + ntanks <- state $ randomR (3, 6) thetank <- randomTank <&> plSpot .~ unusedOffPathAwayFromLink 50 let room = roomRectAutoLinks w h - let plmnts = + let plmnts = map (\it -> sps0 (PutFlIt it) & plSpot .~ anyUnusedSpot) its - ++ map (\cr -> sps0 (PutCrit cr) & plSpot .~ unusedSpotAwayFromLink 50) crs - ++ replicate ntanks thetank - ++ [mntLightLnkCond $ resetPLUse $ rprBool $ \rp _ -> isOutLnk rp] --- , sps0 $ PutShape $ colorSH orange $ pipePP 2 (V3 50 50 25) (V3 50 120 25) + ++ map (\cr -> sps0 (PutCrit cr) & plSpot .~ unusedSpotAwayFromLink 50) crs + ++ replicate ntanks thetank + ++ [mntLightLnkCond $ resetPLUse $ rprBool $ \rp _ -> isOutLnk rp] + -- , sps0 $ PutShape $ colorSH orange $ pipePP 2 (V3 50 50 25) (V3 50 120 25) hgshape <- takeOne [girder 96 20 10, girderZ 96 20 10, girderV 96 20 10] - addhighgirds <- takeOne $ - [ addGirderEW hgshape black >=> addGirderEW hgshape black - , addGirderEW hgshape black - , addGirderNS hgshape black >=> addGirderNS hgshape black - , addGirderNS hgshape black - ] ++ replicate 4 return + addhighgirds <- + takeOne $ + [ addGirderEW hgshape black >=> addGirderEW hgshape black + , addGirderEW hgshape black + , addGirderNS hgshape black >=> addGirderNS hgshape black + , addGirderNS hgshape black + ] + ++ replicate 4 return lgshape <- takeOne [girder 60 20 10, girderZ 60 20 10, girderV 60 20 10] - addlowgirds <- takeOne $ addGirderNS lgshape red : replicate 4 return - (addlowgirds >=> addhighgirds) $ room & rmPmnts .++~ plmnts - & rmName .~ "tanksRoom" + addlowgirds <- takeOne $ addGirderNS lgshape red : replicate 4 return + (addlowgirds >=> addhighgirds) $ + room & rmPmnts .++~ plmnts + & rmName .~ "tanksRoom" diff --git a/src/Dodge/Room/Teleport.hs b/src/Dodge/Room/Teleport.hs index b273af1f4..64929b539 100644 --- a/src/Dodge/Room/Teleport.hs +++ b/src/Dodge/Room/Teleport.hs @@ -1,36 +1,37 @@ {- Specification of rooms that teleport (between levels). -} -module Dodge.Room.Teleport - where -import Dodge.Data -import Dodge.LevelGen.Data -import Dodge.Room.Procedural -import Dodge.Placement.Instance ---import Dodge.LevelGen.Data -import Geometry -import Picture +module Dodge.Room.Teleport where import Control.Lens import Control.Monad.State +import Dodge.Data.GenWorld +import Dodge.LevelGen.Data +import Dodge.Placement.Instance +import Dodge.Room.Procedural +import Geometry +import Picture import System.Random -telRoomLev - :: RandomGen g - => Int -- ^ Level number to teleport to - -> State g Room +telRoomLev :: + RandomGen g => + -- | Level number to teleport to + Int -> + State g Room telRoomLev _ = do - w <- state $ randomR (200,300) - h <- state $ randomR (200,300) - return $ roomRectAutoLinks w h & rmPmnts .~ - [ sPS (V2 (w/2) (h/2)) 0 $ PutPPlate telPP - , sPS (V2 (w/2) (h/2+ 30)) 0 putLamp - ] + w <- state $ randomR (200, 300) + h <- state $ randomR (200, 300) + return $ + roomRectAutoLinks w h & rmPmnts + .~ [ sPS (V2 (w / 2) (h / 2)) 0 $ PutPPlate telPP + , sPS (V2 (w / 2) (h / 2 + 30)) 0 putLamp + ] where - telPP = PressPlate - { _ppPict = setDepth 0.5 . color red $ polygon ppFootprint - , _ppPos = V2 0 0 - , _ppRot = 0 - , _ppEvent = PPLevelReset - , _ppID = 0 - , _ppText = "NEW LEVEL" - } + telPP = + PressPlate + { _ppPict = setDepth 0.5 . color red $ polygon ppFootprint + , _ppPos = V2 0 0 + , _ppRot = 0 + , _ppEvent = PPLevelReset + , _ppID = 0 + , _ppText = "NEW LEVEL" + } ppFootprint = reverse $ rectNSWE 20 (-20) (-20) 20 diff --git a/src/Dodge/Room/Treasure.hs b/src/Dodge/Room/Treasure.hs index feab7ae44..f1e32c142 100644 --- a/src/Dodge/Room/Treasure.hs +++ b/src/Dodge/Room/Treasure.hs @@ -2,52 +2,59 @@ Rooms that contain valuable items, typically protected in some manner. Typically dead ends. -} -module Dodge.Room.Treasure - where -import Dodge.Data -import Dodge.RoomLink -import Dodge.Placement.Instance +module Dodge.Room.Treasure where + +import Control.Monad.State +import Dodge.Data.GenWorld import Dodge.Default.Room import Dodge.LevelGen.Data +import Dodge.Placement.Instance +import Dodge.RoomLink import Geometry ---import Data.List -import Control.Monad.State --import Control.Lens ---import System.Random -{- | A triangular room with loot at the top (with 'PutID' 2), -creatures in the bottom two corners (with 'PutID' 0), -and (single) entrance bottom middle. -} -triLootRoom - :: Float -- Width - -> Float -- Height - -> State g Room -triLootRoom w h = pure $ defaultRoom - { _rmPolys = [ tri - , base - ] - , _rmLinks = [uncurry inLink(V2 0 (-80) , pi)] - , _rmPath = doublePairSet (V2 0 (-80) , V2 0 (h/2)) - , _rmPmnts = - [sPS (V2 (15-w) 15 ) 0 $ PutID 0 - ,sPS (V2 (w-15) 15 ) pi $ PutID 0 - ,sPS (V2 0 (h-35)) 0 $ PutID 2 - ,mntLS vShape (V2 0 (h-20)) (V3 0 (h-80) 70) - ,sPS (V2 0 ( -60)) 0 putLamp - ] - , _rmBound = [tri , base] - } +--import System.Random + +{- | A triangular room with loot at the top (with 'PutID' 2), +creatures in the bottom two corners (with 'PutID' 0), +and (single) entrance bottom middle. +-} +triLootRoom :: + Float -> -- Width + Float -> -- Height + State g Room +triLootRoom w h = + pure $ + defaultRoom + { _rmPolys = + [ tri + , base + ] + , _rmLinks = [uncurry inLink (V2 0 (-80), pi)] + , _rmPath = doublePairSet (V2 0 (-80), V2 0 (h / 2)) + , _rmPmnts = + [ sPS (V2 (15 - w) 15) 0 $ PutID 0 + , sPS (V2 (w -15) 15) pi $ PutID 0 + , sPS (V2 0 (h -35)) 0 $ PutID 2 + , mntLS vShape (V2 0 (h -20)) (V3 0 (h -80) 70) + , sPS (V2 0 (-60)) 0 putLamp + ] + , _rmBound = [tri, base] + } where - tri = map toV2 - [ ( -w,30) - , ( -w, 0) - , ( w, 0) - , ( w,30) - , ( 20, h) - , (-20, h) - ] - base = rectNSWE 20 (-80) (-20) 20 -{- | Create a random room with one entrance containing given creatures and items. -} + tri = + map + toV2 + [ (- w, 30) + , (- w, 0) + , (w, 0) + , (w, 30) + , (20, h) + , (-20, h) + ] + base = rectNSWE 20 (-80) (-20) 20 + +-- | Create a random room with one entrance containing given creatures and items. lootRoom :: [Creature] -> [Item] -> State g Room lootRoom crs itms = do let w = 300 diff --git a/src/Dodge/Room/Warning.hs b/src/Dodge/Room/Warning.hs index cd52256de..a089e1072 100644 --- a/src/Dodge/Room/Warning.hs +++ b/src/Dodge/Room/Warning.hs @@ -1,63 +1,69 @@ --{-# LANGUAGE TupleSections #-} module Dodge.Room.Warning where -import Dodge.WorldEffect + +import Color +--import qualified Data.Set as S + +import qualified Data.Map.Strict as M +import Data.Maybe import Dodge.Cleat -import Dodge.Terminal +import Dodge.Data.GenWorld +import Dodge.Placement.Instance import Dodge.PlacementSpot -import Dodge.Placement.Instance.Terminal -import Dodge.Data -import Dodge.Tree import Dodge.Room.Door +import Dodge.Room.Link import Dodge.Room.Ngon import Dodge.Room.Procedural import Dodge.Room.Tanks -import Dodge.Room.Link -import Dodge.Placement.Instance +import Dodge.Terminal +import Dodge.Tree +import Dodge.WorldEffect import Geometry -import Color import LensHelp import RandomHelp ---import qualified Data.Set as S -import Data.Maybe -import qualified Data.Map.Strict as M --import Data.Char --import Data.Tree --import qualified Data.Text as T - warningRooms :: RandomGen g => String -> Int -> State g (MetaTree Room String) warningRooms str n = do rm <- do tr <- tanksRoom [] [] - takeOne [roomNgon 8 200, roomRectAutoLinks 200 200,tr] + takeOne [roomNgon 8 200, roomRectAutoLinks 200 200, tr] cenroom <- shuffleLinks $ addWarningTerminal str n rm - rToOnward "warningRooms" $ treePost [ door, cenroom, triggerDoorRoom n, cleatOnward door] + rToOnward "warningRooms" $ treePost [door, cenroom, triggerDoorRoom n, cleatOnward door] addWarningTerminal :: String -> Int -> Room -> Room -addWarningTerminal str outplid = (rmName .++~ "warningTerm-") - . (rmOutPmnt .~ [OutPlacement outplace outplid]) +addWarningTerminal str outplid = + (rmName .++~ "warningTerm-") + . (rmOutPmnt .~ [OutPlacement outplace outplid]) where - outplace = extTrigLitPos - (atFstLnkOutShiftBy (\(p,a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a))) - (Just . set plSpot (rprShift moveToSideFirstOutLink) - . putMessageTerminal terminalColor . termMessages) - termMessages trpl = lineOutputTerminal (makeColorTermLine red "WARNING":makeTermPara str) - & tmScrollCommands .:~ toggleCommand - & tmToggles .~ M.fromList - [("DOOR",TerminalToggle (fromJust $ _plMID trpl) (BlConst True))] + outplace = + extTrigLitPos + (atFstLnkOutShiftBy (\(p, a) -> (p +.+ rotateV a (V2 18.5 (-2.5)), a))) + ( Just . set plSpot (rprShift moveToSideFirstOutLink) + . putMessageTerminal terminalColor + . termMessages + ) + termMessages trpl = + lineOutputTerminal (makeColorTermLine red "WARNING" : makeTermPara str) + & tmScrollCommands .:~ toggleCommand + & tmToggles + .~ M.fromList + [("DOOR", TerminalToggle (fromJust $ _plMID trpl) (BlConst True))] -moveToSideFirstOutLink :: RoomPos -> Room -> Maybe (Point2,Float) +moveToSideFirstOutLink :: RoomPos -> Room -> Maybe (Point2, Float) moveToSideFirstOutLink rp rm = case rp ^? rpLinkStatus . rplsChildNum of - Just 0 -> + Just 0 -> let rppos = _rpPos rp rpdir = _rpDir rp inpos = rppos +.+ rotateV rpdir (V2 0 (-12.5)) rtpos = inpos +.+ rotateV rpdir (V2 30 0) ltpos = inpos +.+ rotateV rpdir (V2 (-30) 0) - in if any (isJust . intersectSegPolyFirst inpos ltpos) (_rmPolys rm) - -- the above test may not work properly if the room polys are - -- complicated, it should really use created walls... - then Just (rtpos, rpdir) - else Just (ltpos, rpdir) + in if any (isJust . intersectSegPolyFirst inpos ltpos) (_rmPolys rm) + then -- the above test may not work properly if the room polys are + -- complicated, it should really use created walls... + Just (rtpos, rpdir) + else Just (ltpos, rpdir) _ -> Nothing diff --git a/src/Dodge/RoomLink.hs b/src/Dodge/RoomLink.hs index f0b86ae2d..60d2b4b1b 100644 --- a/src/Dodge/RoomLink.hs +++ b/src/Dodge/RoomLink.hs @@ -1,48 +1,48 @@ -module Dodge.RoomLink - ( muout - , muin - , outLink - , inLink - , restrictLinkType - , overLnkType - , lnkPosDir - , overLnkPosDir - , toBothLnk - , rmInLinks - , rmOutLinks - , setOutLinksPD - , setOutLinksByType - , setInLinksPD - , restrictOutLinks - , restrictInLinks - , setOutLinks - , setInLinks - , setInLinksByType - , setLinkType - , getLinksOfType - , swapInOutLinks - ) where ---import Dodge.LevelGen.Data -import Dodge.Data -import Geometry +module Dodge.RoomLink ( + muout, + muin, + outLink, + inLink, + restrictLinkType, + overLnkType, + lnkPosDir, + overLnkPosDir, + toBothLnk, + rmInLinks, + rmOutLinks, + setOutLinksPD, + setOutLinksByType, + setInLinksPD, + restrictOutLinks, + restrictInLinks, + setOutLinks, + setInLinks, + setInLinksByType, + setLinkType, + getLinksOfType, + swapInOutLinks, +) where +import Control.Lens import Data.List (partition) import qualified Data.Set as S -import Control.Lens +import Dodge.Data.GenWorld +import Geometry -restrictLinkType :: RoomLinkType -> ((Point2,Float) -> Bool) -> [RoomLink] -> [RoomLink] +restrictLinkType :: RoomLinkType -> ((Point2, Float) -> Bool) -> [RoomLink] -> [RoomLink] restrictLinkType rlt f = map g where - g rl | f $ rlPosDir rl = rl - | otherwise = rl & rlType %~ S.delete rlt + g rl + | f $ rlPosDir rl = rl + | otherwise = rl & rlType %~ S.delete rlt getLinksOfType :: RoomLinkType -> [RoomLink] -> [RoomLink] getLinksOfType lt = filter (S.member lt . _rlType) -restrictInLinks :: ((Point2,Float) -> Bool) -> Room -> Room +restrictInLinks :: ((Point2, Float) -> Bool) -> Room -> Room restrictInLinks = over rmLinks . restrictLinkType InLink -restrictOutLinks :: ((Point2,Float) -> Bool) -> Room -> Room +restrictOutLinks :: ((Point2, Float) -> Bool) -> Room -> Room restrictOutLinks f = rmLinks %~ restrictLinkType OutLink f setOutLinks :: (RoomLink -> Bool) -> [RoomLink] -> [RoomLink] @@ -60,19 +60,21 @@ setOutLinksByType lt = setOutLinks (\rl -> lt `S.member` _rlType rl) setLinkType :: RoomLinkType -> (RoomLink -> Bool) -> [RoomLink] -> [RoomLink] setLinkType rlt f = map g where - g rl | f rl = rl & rlType %~ S.insert rlt - | otherwise = rl & rlType %~ S.delete rlt + g rl + | f rl = rl & rlType %~ S.insert rlt + | otherwise = rl & rlType %~ S.delete rlt -setLinkTypePD :: RoomLinkType -> ((Point2,Float) -> Bool) -> [RoomLink] -> [RoomLink] +setLinkTypePD :: RoomLinkType -> ((Point2, Float) -> Bool) -> [RoomLink] -> [RoomLink] setLinkTypePD rlt f = map g where - g rl | f $ rlPosDir rl = rl & rlType %~ S.insert rlt - | otherwise = rl & rlType %~ S.delete rlt + g rl + | f $ rlPosDir rl = rl & rlType %~ S.insert rlt + | otherwise = rl & rlType %~ S.delete rlt -setInLinksPD :: ((Point2,Float) -> Bool) -> Room -> Room +setInLinksPD :: ((Point2, Float) -> Bool) -> Room -> Room setInLinksPD f = rmLinks %~ setLinkTypePD InLink f -setOutLinksPD :: ((Point2,Float) -> Bool) -> Room -> Room +setOutLinksPD :: ((Point2, Float) -> Bool) -> Room -> Room setOutLinksPD f = rmLinks %~ setLinkTypePD OutLink f swapInOutLinks :: Room -> Room @@ -85,46 +87,54 @@ swapInOutLinks = rmLinks %~ map (rlType %~ S.map f) overLnkType :: RoomLinkType -> ([RoomLink] -> [RoomLink]) -> Room -> Room overLnkType lt f = rmLinks %~ g where - g lnks = let (xs,ys) = partition (S.member lt . _rlType) lnks - in f xs ++ ys + g lnks = + let (xs, ys) = partition (S.member lt . _rlType) lnks + in f xs ++ ys -rlPosDir :: RoomLink -> (Point2,Float) +rlPosDir :: RoomLink -> (Point2, Float) rlPosDir rl = (_rlPos rl, _rlDir rl) -lnkPosDir :: RoomLink -> (Point2,Float) +lnkPosDir :: RoomLink -> (Point2, Float) lnkPosDir rl = (_rlPos rl, _rlDir rl) -overLnkPosDir :: ((Point2,Float) -> (Point2,Float)) -> RoomLink -> RoomLink +overLnkPosDir :: ((Point2, Float) -> (Point2, Float)) -> RoomLink -> RoomLink overLnkPosDir f rl = rl & rlPos .~ p & rlDir .~ a where - (p,a) = f (_rlPos rl,_rlDir rl) + (p, a) = f (_rlPos rl, _rlDir rl) outLink :: Point2 -> Float -> RoomLink -outLink p a = RoomLink - {_rlType = S.singleton OutLink - ,_rlPos = p - , _rlDir = a - } -inLink :: Point2 -> Float -> RoomLink -inLink p a = RoomLink - {_rlType = S.singleton InLink - ,_rlPos = p - , _rlDir = a - } +outLink p a = + RoomLink + { _rlType = S.singleton OutLink + , _rlPos = p + , _rlDir = a + } -toBothLnk :: (Point2,Float) -> RoomLink -toBothLnk (p,a) = RoomLink - { _rlType = S.fromList [OutLink,InLink] - , _rlPos = p - , _rlDir = a - } -muout :: [(Point2,Float)] -> [RoomLink] +inLink :: Point2 -> Float -> RoomLink +inLink p a = + RoomLink + { _rlType = S.singleton InLink + , _rlPos = p + , _rlDir = a + } + +toBothLnk :: (Point2, Float) -> RoomLink +toBothLnk (p, a) = + RoomLink + { _rlType = S.fromList [OutLink, InLink] + , _rlPos = p + , _rlDir = a + } + +muout :: [(Point2, Float)] -> [RoomLink] muout = map (uncurry outLink) -muin :: [(Point2,Float)] -> [RoomLink] + +muin :: [(Point2, Float)] -> [RoomLink] muin = map (uncurry inLink) rmLinksOfType :: RoomLinkType -> Room -> [RoomLink] rmLinksOfType lt = filter (S.member lt . _rlType) . _rmLinks -rmOutLinks,rmInLinks :: Room -> [RoomLink] + +rmOutLinks, rmInLinks :: Room -> [RoomLink] rmOutLinks = rmLinksOfType OutLink rmInLinks = rmLinksOfType InLink diff --git a/src/Dodge/RoomPos.hs b/src/Dodge/RoomPos.hs index 33eb543ff..07d119353 100644 --- a/src/Dodge/RoomPos.hs +++ b/src/Dodge/RoomPos.hs @@ -1,7 +1,7 @@ module Dodge.RoomPos where ---import Dodge.LevelGen.Data -import Dodge.Data + +import Dodge.Data.GenWorld import Geometry -extractRoomPos :: RoomPos -> (Point2,Float) -extractRoomPos rp = (_rpPos rp,_rpDir rp) +extractRoomPos :: RoomPos -> (Point2, Float) +extractRoomPos rp = (_rpPos rp, _rpDir rp) diff --git a/src/Dodge/Save.hs b/src/Dodge/Save.hs index a551e54c4..ec5f59847 100644 --- a/src/Dodge/Save.hs +++ b/src/Dodge/Save.hs @@ -1,62 +1,62 @@ -module Dodge.Save - ( saveWorldInEmptySlot - , loadSaveSlot - , doQuicksave - , saveLevelStartSlot - , writeSaveSlot - , readSaveSlot - ) where -import Dodge.Data +module Dodge.Save ( + saveWorldInEmptySlot, + loadSaveSlot, + doQuicksave, + saveLevelStartSlot, + writeSaveSlot, + readSaveSlot, +) where +import Control.Lens import Data.Aeson import qualified Data.Aeson.Encode.Pretty as AEP import qualified Data.ByteString.Lazy as BS ---import Text.Read (readMaybe) import qualified Data.Map.Strict as M ---import Data.Maybe -import Control.Lens +import Dodge.Data.Universe --import qualified Data.Set as S import System.Directory writeSaveSlot :: SaveSlot -> Universe -> IO () writeSaveSlot ss u = do createDirectoryIfMissing True "saveSlot" - BS.writeFile (saveSlotPath ss) - $ AEP.encodePretty' - (AEP.Config (AEP.Spaces 2) compare AEP.Generic False) + BS.writeFile (saveSlotPath ss) $ + AEP.encodePretty' + (AEP.Config (AEP.Spaces 2) compare AEP.Generic False) (u ^. uvWorld . cWorld) - --writeFile (saveSlotPath ss) (show $ u ^. uvWorld . cWorld) + +--writeFile (saveSlotPath ss) (show $ u ^. uvWorld . cWorld) readSaveSlot :: SaveSlot -> Universe -> IO Universe readSaveSlot ss uv = do fExists <- doesFileExist $ saveSlotPath ss if fExists - then do - --cwstr <- readFile $ saveSlotPath ss - --case readMaybe cwstr of - cwstr <- decodeFileStrict $ saveSlotPath ss - case cwstr of - Nothing -> putStrLn "loadSaveSlot failed to read saved file" >> return uv - Just cw -> return $ uv & uvWorld . cWorld .~ cw - else putStrLn "loadSaveSlot failed to find saved file" >> return uv + then do + --cwstr <- readFile $ saveSlotPath ss + --case readMaybe cwstr of + cwstr <- decodeFileStrict $ saveSlotPath ss + case cwstr of + Nothing -> putStrLn "loadSaveSlot failed to read saved file" >> return uv + Just cw -> return $ uv & uvWorld . cWorld .~ cw + else putStrLn "loadSaveSlot failed to find saved file" >> return uv saveSlotPath :: SaveSlot -> String saveSlotPath (SaveSlotNum i) = "saveSlot/" ++ show i saveSlotPath QuicksaveSlot = "saveSlot/QuickSave" saveSlotPath LevelStartSlot = "saveSlot/LevelStartSave" - saveWorldInEmptySlot :: SaveSlot -> Universe -> Universe saveWorldInEmptySlot slot w = case M.lookup slot $ _savedWorlds w of Nothing -> w & savedWorlds %~ M.insert slot (clearKeys (_uvWorld w)) - _ -> w + _ -> w saveWorldInSlot :: SaveSlot -> Universe -> Universe saveWorldInSlot slot u = u & savedWorlds %~ M.insert slot (clearKeys (_uvWorld u)) loadSaveSlot :: SaveSlot -> Universe -> Universe -loadSaveSlot slot u = maybe u - (\w -> u & menuLayers .~ [] & uvWorld .~ w) - $ M.lookup slot (_savedWorlds u) +loadSaveSlot slot u = + maybe + u + (\w -> u & menuLayers .~ [] & uvWorld .~ w) + $ M.lookup slot (_savedWorlds u) doQuicksave :: Universe -> Universe doQuicksave = saveWorldInSlot QuicksaveSlot @@ -67,4 +67,5 @@ clearKeys = (keys .~ mempty) . (mouseButtons .~ mempty) saveLevelStartSlot :: Universe -> Universe --saveLevelStartSlot = id saveLevelStartSlot = saveWorldInSlot LevelStartSlot + --saveLevelStartSlot = sideEffects %~ (fmap (undefined) . ) diff --git a/src/Dodge/Shockwave/Draw.hs b/src/Dodge/Shockwave/Draw.hs index 9344a31f9..930e20b3d 100644 --- a/src/Dodge/Shockwave/Draw.hs +++ b/src/Dodge/Shockwave/Draw.hs @@ -1,17 +1,18 @@ -module Dodge.Shockwave.Draw - where +module Dodge.Shockwave.Draw where + import Dodge.Data.Shockwave -import Picture import Geometry +import Picture drawShockwave :: Shockwave -> Picture -drawShockwave sw = setDepth 20 - . setLayer BloomLayer - . uncurryV translate (_swPos sw) - . color (_swColor sw) - $ thickCircle rad thickness +drawShockwave sw = + setDepth 20 + . setLayer BloomLayer + . uncurryV translate (_swPos sw) + . color (_swColor sw) + $ thickCircle rad thickness where - r = _swRad sw - thickness = tFraction**2 * r - rad = r - (3/4) * r * tFraction + r = _swRad sw + thickness = tFraction ** 2 * r + rad = r - (3 / 4) * r * tFraction tFraction = fromIntegral (_swTimer sw) / fromIntegral (_swMaxTime sw) diff --git a/src/Dodge/Shockwave/Update.hs b/src/Dodge/Shockwave/Update.hs index ef0ddb304..bc8f19f23 100644 --- a/src/Dodge/Shockwave/Update.hs +++ b/src/Dodge/Shockwave/Update.hs @@ -1,67 +1,74 @@ -module Dodge.Shockwave.Update - where -import Geometry.Vector -import Dodge.Zoning.Wall +module Dodge.Shockwave.Update where + +import Data.Foldable import Dodge.Base.Collide +import Dodge.Data.World import Dodge.Wall.Damage -import Dodge.Data +import Dodge.Zoning.Wall +import Geometry.Vector import qualified IntMapHelp as IM import LensHelp -import Data.Foldable - -updateShockwave :: World -> Shockwave -> (World,Maybe Shockwave) +updateShockwave :: World -> Shockwave -> (World, Maybe Shockwave) updateShockwave w sw = case _swDirection sw of OutwardShockwave -> moveShockwave w sw InwardShockwave -> moveInverseShockwave w sw -moveShockwave :: World -> Shockwave -> (World,Maybe Shockwave) -moveShockwave w sw - | _swTimer sw <= 0 = ( w , Nothing) - | otherwise = (doDams w , Just $ sw & swTimer -~ 1) - where - is = _swInvulnerableCrs sw - r = _swRad sw - p = _swPos sw +moveShockwave :: World -> Shockwave -> (World, Maybe Shockwave) +moveShockwave w sw + | _swTimer sw <= 0 = (w, Nothing) + | otherwise = (doDams w, Just $ sw & swTimer -~ 1) + where + is = _swInvulnerableCrs sw + r = _swRad sw + p = _swPos sw push = _swPush sw - dam = _swDam sw - t = _swTimer sw + dam = _swDam sw + t = _swTimer sw tFraction = fromIntegral t / fromIntegral (_swMaxTime sw) - rad = r - (3/4) * r * tFraction - doDams w' = over (cWorld . creatures) (IM.map damCr) - $ foldl' - (flip $ damageWall (Damage EXPLOSIVE 10000 p p p NoDamageEffect)) - w' - hitBlocks - hitBlocks = map snd . overlapCircWalls p rad $ wlsNearCirc p rad w - -- this is not expansive enough - damCr cr - | _crID cr `elem` is || dist (_crPos cr) p >= rad + _crRad cr = cr - | otherwise = cr & crState . csDamage .:~ - Damage PUSHDAM dam (cpos -.- v) cpos (cpos +.+ v) - (PushBackDamage (25 * push)) - where - cpos = _crPos cr - v = normalizeV (cpos -.- p) + rad = r - (3 / 4) * r * tFraction + doDams w' = + over (cWorld . creatures) (IM.map damCr) $ + foldl' + (flip $ damageWall (Damage EXPLOSIVE 10000 p p p NoDamageEffect)) + w' + hitBlocks + hitBlocks = map snd . overlapCircWalls p rad $ wlsNearCirc p rad w + -- this is not expansive enough + damCr cr + | _crID cr `elem` is || dist (_crPos cr) p >= rad + _crRad cr = cr + | otherwise = + cr & crState . csDamage + .:~ Damage + PUSHDAM + dam + (cpos -.- v) + cpos + (cpos +.+ v) + (PushBackDamage (25 * push)) + where + cpos = _crPos cr + v = normalizeV (cpos -.- p) -moveInverseShockwave - :: World - -> Shockwave - -> (World, Maybe Shockwave) -moveInverseShockwave w sw - | t <= 0 = ( w, Nothing) - | otherwise = (dams w, Just $ swTimer -~ 1 $ sw ) - where +moveInverseShockwave :: + World -> + Shockwave -> + (World, Maybe Shockwave) +moveInverseShockwave w sw + | t <= 0 = (w, Nothing) + | otherwise = (dams w, Just $ swTimer -~ 1 $ sw) + where p = _swPos sw r = _swRad sw t = _swTimer sw rad = r - 0.1 * r * fromIntegral (10 - t) dams = over (cWorld . creatures) (IM.map damCr) -- . flip (foldr (damageBlocksBy 1)) hitBlocks --- hitBlocks = wallsOnCirc' p rad $ wallsNearPoint' p w - damCr cr + -- hitBlocks = wallsOnCirc' p rad $ wallsNearPoint' p w + damCr cr | dist (_crPos cr) p >= rad + _crRad cr = cr - | otherwise = cr & crState . csDamage .:~ - Damage PUSHDAM 1 (cpos +.+ v) cpos (cpos -.- v) (PushBackDamage 25) - where - cpos = _crPos cr - v = normalizeV (cpos -.- p) + | otherwise = + cr & crState . csDamage + .:~ Damage PUSHDAM 1 (cpos +.+ v) cpos (cpos -.- v) (PushBackDamage 25) + where + cpos = _crPos cr + v = normalizeV (cpos -.- p) diff --git a/src/Dodge/SoundLogic.hs b/src/Dodge/SoundLogic.hs index e5c239635..7585c28d2 100644 --- a/src/Dodge/SoundLogic.hs +++ b/src/Dodge/SoundLogic.hs @@ -1,4 +1,4 @@ -{-| +{- | Module : Dodge.SoundLogic Description : Messages to "Sound" backend @@ -6,85 +6,98 @@ This module allows us to talk to the "Sound" module. -} module Dodge.SoundLogic ( -- * Manipulation of individual sounds - soundStart - , soundContinue - , soundContinueVol - , soundFromGeneral - , soundMultiFrom - , stopSoundFrom + soundStart, + soundContinue, + soundContinueVol, + soundFromGeneral, + soundMultiFrom, + stopSoundFrom, -- * helper to determine the angle of a sound given a world position - , soundAngle + soundAngle, -- * Manipulation of all sounds - , haltSound - , resumeSound - , pauseSound - , module Dodge.SoundLogic.LoadSound - ) where -import Dodge.Data -import Sound.Data -import Geometry.Data -import Geometry.Vector -import Dodge.SoundLogic.LoadSound + haltSound, + resumeSound, + pauseSound, + module Dodge.SoundLogic.LoadSound, +) where import Control.Lens -import qualified Data.Map as M import Data.Int (Int16) +import qualified Data.Map as M import Data.Maybe +import Dodge.Data.Universe +import Dodge.SoundLogic.LoadSound +import Geometry.Data +import Geometry.Vector +import Sound.Data -{-| Placeholder...-} +-- | Placeholder... haltSound :: World -> World haltSound w = w -{-| Placeholder...-} +-- | Placeholder... pauseSound :: World -> World pauseSound w = w -{-| Placeholder...-} +-- | Placeholder... resumeSound :: Universe -> Universe resumeSound w = w -soundWithStatusVolumeGeneral - :: Float -- ^ Volume factor, 0 - 1 - -> PlayStatus - -> SoundOrigin -- ^ \"Creator\" of sound - -> (World -> Point2) -- ^ Position of sound - -> SoundID -- ^ ID of sound to be played - -> Maybe Int -- ^ Frames to play sound for, Nothing for until finished - -> World - -> World +soundWithStatusVolumeGeneral :: + -- | Volume factor, 0 - 1 + Float -> + PlayStatus -> + -- | \"Creator\" of sound + SoundOrigin -> + -- | Position of sound + (World -> Point2) -> + -- | ID of sound to be played + SoundID -> + -- | Frames to play sound for, Nothing for until finished + Maybe Int -> + World -> + World soundWithStatusVolumeGeneral vol status so fpos sType mtime w = w & toPlaySounds %~ M.insertWith f so sound - where - sound = Sound - { _soundChunkID = sType - , _soundTime = mtime - , _soundStatus = SoundStatus - {_playStatus = status - ,_isLooping = isJust mtime + where + sound = + Sound + { _soundChunkID = sType + , _soundTime = mtime + , _soundStatus = + SoundStatus + { _playStatus = status + , _isLooping = isJust mtime + } + , _soundChannel = Nothing + , _soundAngDist = Just (a, floor (225 * (1 - vol))) + , _soundPos = fpos w + , _soundVolume = soundToVol sType * vol + , _soundVolumeFraction = vol } - , _soundChannel = Nothing - , _soundAngDist = Just (a,floor (225 * (1 - vol))) - , _soundPos = fpos w - , _soundVolume = soundToVol sType * vol - , _soundVolumeFraction = vol - } - f _ s = s {_soundTime = mtime } + f _ s = s{_soundTime = mtime} a = soundAngle (fpos w) w -soundWithStatusVolume - :: Float -- ^ Volume factor, 0 - 1 - -> PlayStatus - -> SoundOrigin -- ^ \"Creator\" of sound - -> Point2 -- ^ Position of sound - -> SoundID -- ^ ID of sound to be played - -> Maybe Int -- ^ Frames to play sound for, Nothing for until finished - -> World - -> World +soundWithStatusVolume :: + -- | Volume factor, 0 - 1 + Float -> + PlayStatus -> + -- | \"Creator\" of sound + SoundOrigin -> + -- | Position of sound + Point2 -> + -- | ID of sound to be played + SoundID -> + -- | Frames to play sound for, Nothing for until finished + Maybe Int -> + World -> + World soundWithStatusVolume vol status so pos = soundWithStatusVolumeGeneral vol status so (const pos) + --soundWithStatusVolume vol status so pos sType mtime w = w & toPlaySounds %~ M.insertWith f so sound --- where --- sound = Sound +-- where +-- sound = Sound -- { _soundChunkID = sType -- , _soundTime = mtime -- , _soundStatus = SoundStatus @@ -100,55 +113,78 @@ soundWithStatusVolume vol status so pos = soundWithStatusVolumeGeneral vol statu -- f _ s = s {_soundTime = mtime } -- a = soundAngle pos w -soundWithStatus - :: PlayStatus - -> SoundOrigin -- ^ \"Creator\" of sound - -> Point2 -- ^ Position of sound - -> SoundID -- ^ ID of sound to be played - -> Maybe Int -- ^ Frames to play sound for, Nothing for until finished - -> World - -> World +soundWithStatus :: + PlayStatus -> + -- | \"Creator\" of sound + SoundOrigin -> + -- | Position of sound + Point2 -> + -- | ID of sound to be played + SoundID -> + -- | Frames to play sound for, Nothing for until finished + Maybe Int -> + World -> + World soundWithStatus = soundWithStatusVolume 1 -soundStart - :: SoundOrigin -- ^ \"Creator\" of sound - -> Point2 -- ^ Position of sound - -> SoundID -- ^ ID of sound to be played - -> Maybe Int -- ^ Frames to play sound for, Nothing for until finished - -> World - -> World +soundStart :: + -- | \"Creator\" of sound + SoundOrigin -> + -- | Position of sound + Point2 -> + -- | ID of sound to be played + SoundID -> + -- | Frames to play sound for, Nothing for until finished + Maybe Int -> + World -> + World soundStart = soundWithStatus ToStart -soundContinue - :: SoundOrigin -- ^ \"Creator\" of sound - -> Point2 -- ^ Position of sound - -> SoundID -- ^ ID of sound to be played - -> Maybe Int -- ^ Frames to play sound for, Nothing for until finished - -> World - -> World + +soundContinue :: + -- | \"Creator\" of sound + SoundOrigin -> + -- | Position of sound + Point2 -> + -- | ID of sound to be played + SoundID -> + -- | Frames to play sound for, Nothing for until finished + Maybe Int -> + World -> + World soundContinue = soundWithStatus ToContinueStart -- this needs to all be cleaned up, moved to general sounds -soundContinueVol - :: Float -- ^ volume - -> SoundOrigin -- ^ \"Creator\" of sound - -> Point2 -- ^ Position of sound - -> SoundID -- ^ ID of sound to be played - -> Maybe Int -- ^ Frames to play sound for, Nothing for until finished - -> World - -> World +soundContinueVol :: + -- | volume + Float -> + -- | \"Creator\" of sound + SoundOrigin -> + -- | Position of sound + Point2 -> + -- | ID of sound to be played + SoundID -> + -- | Frames to play sound for, Nothing for until finished + Maybe Int -> + World -> + World soundContinueVol vol = soundWithStatusVolume vol ToContinueStart -soundFromGeneral - :: SoundOrigin -- ^ \"Creator\" of sound - -> (World -> Point2) -- ^ Position of sound - -> SoundID -- ^ ID of sound to be played - -> Maybe Int -- ^ Frames to play sound for, Nothing for until finished - -> World - -> World +soundFromGeneral :: + -- | \"Creator\" of sound + SoundOrigin -> + -- | Position of sound + (World -> Point2) -> + -- | ID of sound to be played + SoundID -> + -- | Frames to play sound for, Nothing for until finished + Maybe Int -> + World -> + World soundFromGeneral = soundWithStatusVolumeGeneral 1 ToStart + --soundFromGeneral so fpos sType mtime w = w & toPlaySounds %~ M.insertWith f so sound --- where --- sound = Sound +-- where +-- sound = Sound -- { _soundChunkID = sType -- , _soundTime = mtime -- , _soundStatus = SoundStatus @@ -164,38 +200,43 @@ soundFromGeneral = soundWithStatusVolumeGeneral 1 ToStart -- f _ s = s {_soundTime = mtime } -- a = soundAngle (fpos w) w -{-| Calculates the angle of a sound with reference to '_cameraViewFrom'. +{- | Calculates the angle of a sound with reference to '_cameraViewFrom'. Within 10 units considers the sound to be directly in front. -} soundAngle :: Point2 -> World -> Int16 {-# INLINE soundAngle #-} soundAngle p w | dist p earPos < 10 = 0 - | otherwise = round - . radToDeg - . normalizeAngle - . (+ pi) - $ argV (vNormal (p -.- earPos)) - _cameraRot (_cWorld w) + | otherwise = + round + . radToDeg + . normalizeAngle + . (+ pi) + $ argV (vNormal (p -.- earPos)) - _cameraRot (_cWorld w) where earPos = _cameraViewFrom (_cWorld w) -{-| Uses the first free origin from a list. -Does nothing if all origins are already creating sounds. -} -soundMultiFrom - :: [SoundOrigin] - -> Point2 -- ^ Position - -> SoundID -- ^ Sound ID - -> Maybe Int -- ^ Frames to play for, Nothing for full length - -> World - -> World +{- | Uses the first free origin from a list. +Does nothing if all origins are already creating sounds. +-} +soundMultiFrom :: + [SoundOrigin] -> + -- | Position + Point2 -> + -- | Sound ID + SoundID -> + -- | Frames to play for, Nothing for full length + Maybe Int -> + World -> + World soundMultiFrom [] _ _ _ w = w --soundMultiFrom [so] pos sType mtime w -- = over toPlaySounds (M.insert so sound) w --- where --- sound = Sound +-- where +-- sound = Sound -- { _soundChunkID = sType -- , _soundTime = mtime --- , _soundStatus = SoundStatus +-- , _soundStatus = SoundStatus -- { _playStatus = ToStart -- , _isLooping = isJust mtime -- } @@ -206,25 +247,29 @@ soundMultiFrom [] _ _ _ w = w -- , _soundVolumeFraction = 1 -- } -- a = soundAngle pos w -soundMultiFrom (so:sos) pos sType mtime w +soundMultiFrom (so : sos) pos sType mtime w | so `M.member` _playingSounds w = soundMultiFrom sos pos sType mtime w | otherwise = over toPlaySounds (M.insert so sound) w - where - sound = Sound - { _soundChunkID = sType - , _soundTime = mtime - , _soundStatus = SoundStatus - { _playStatus = ToStart - , _isLooping = isJust mtime + where + sound = + Sound + { _soundChunkID = sType + , _soundTime = mtime + , _soundStatus = + SoundStatus + { _playStatus = ToStart + , _isLooping = isJust mtime + } + , _soundChannel = Nothing + , _soundAngDist = Just (a, 0) + , _soundPos = pos + , _soundVolume = soundToVol sType + , _soundVolumeFraction = 1 } - , _soundChannel = Nothing - , _soundAngDist = Just (a,0) - , _soundPos = pos - , _soundVolume = soundToVol sType - , _soundVolumeFraction = 1 - } a = soundAngle pos w -{- | Sets '_soundTime' to 0. -} + +-- | Sets '_soundTime' to 0. stopSoundFrom :: SoundOrigin -> World -> World stopSoundFrom so = playingSounds . ix so . soundTime ?~ 0 + --stopSoundFrom so = over (playingSounds . ix so . soundTime) (fmap $ min 0) diff --git a/src/Dodge/Spark.hs b/src/Dodge/Spark.hs index 5e8d92b82..06a9e0ea4 100644 --- a/src/Dodge/Spark.hs +++ b/src/Dodge/Spark.hs @@ -1,42 +1,44 @@ -module Dodge.Spark - ( moveSpark - , colSpark - , colSparkRandDir - , createBarrelSpark - , randColDirSpark - , randSpark - ) where -import Dodge.Data +module Dodge.Spark ( + moveSpark, + colSpark, + colSparkRandDir, + createBarrelSpark, + randColDirSpark, + randSpark, +) where + +import Color +import Control.Monad.State +import Dodge.Data.World import Dodge.WorldEvent.ThingsHit import Geometry -import LensHelp -import Color - import qualified IntMapHelp as IM -import Control.Monad.State +import LensHelp import System.Random moveSpark :: World -> Spark -> (World, Maybe Spark) moveSpark w sk - | magV (_skVel sk) < 1 = (w,Nothing) + | magV (_skVel sk) < 1 = (w, Nothing) | otherwise = case thingHit sp ep w of Nothing -> (w, Just $ sk & skPos .~ ep & skVel .*.*~ 0.9 & skOldPos .~ sp) - Just (hp,hthing) -> (sparkDam sk sp ep (hp,hthing) w - , Just $ sk & skPos .~ hp & skOldPos .~ sp & skVel .~ 0) + Just (hp, hthing) -> + ( sparkDam sk sp ep (hp, hthing) w + , Just $ sk & skPos .~ hp & skOldPos .~ sp & skVel .~ 0 + ) where sp = _skPos sk ep = sp +.+ _skVel sk -sparkDam - :: Spark - -> Point2 - -> Point2 - -> (Point2, Either Creature Wall) - -> World - -> World +sparkDam :: + Spark -> + Point2 -> + Point2 -> + (Point2, Either Creature Wall) -> + World -> + World sparkDam sk sp ep mayEiCrWl = case mayEiCrWl of - (hitp,Left cr) -> cWorld . creatures . ix (_crID cr) . crState . csDamage .:~ thedam hitp - (hitp,Right wl) -> cWorld . wallDamages %~ IM.insertWith (++) (_wlID wl) [thedam hitp] + (hitp, Left cr) -> cWorld . creatures . ix (_crID cr) . crState . csDamage .:~ thedam hitp + (hitp, Right wl) -> cWorld . wallDamages %~ IM.insertWith (++) (_wlID wl) [thedam hitp] where thedam hitp = Damage (_skDamageType sk) 1 sp hitp ep NoDamageEffect @@ -46,56 +48,61 @@ createBarrelSpark pos dir colid = colSparkRandDir 0.1 (numColor colid) pos dir colSpark :: Color -> Point2 -> Float -> World -> World colSpark = colSparkRandDir 0.7 -randColDirSpark - :: State StdGen Color - -> State StdGen Float - -> Point2 - -> World - -> World -randColDirSpark randcol randdir pos w = w - & cWorld . sparks .:~ spark - & randGen .~ g +randColDirSpark :: + State StdGen Color -> + State StdGen Float -> + Point2 -> + World -> + World +randColDirSpark randcol randdir pos w = + w + & cWorld . sparks .:~ spark + & randGen .~ g where - ((col,dir),g) = (`runState` _randGen w) $ do + ((col, dir), g) = (`runState` _randGen w) $ do c <- randcol d <- randdir - return (c,d) - spark = Spark - { _skVel = rotateV dir (V2 5 0) - , _skColor = col - , _skPos = pos - , _skOldPos = pos - , _skWidth = 1 - , _skDamageType = SPARKING - } + return (c, d) + spark = + Spark + { _skVel = rotateV dir (V2 5 0) + , _skColor = col + , _skPos = pos + , _skOldPos = pos + , _skWidth = 1 + , _skDamageType = SPARKING + } -randSpark - :: DamageType - -> State StdGen Float - -> State StdGen Color - -> State StdGen Float - -> Point2 - -> World - -> World -randSpark dt randspeed randcol randdir pos w = w - & randGen .~ g - & cWorld . sparks .:~ Spark - { _skVel = rotateV dir (V2 speed 0) - , _skColor = col - , _skPos = pos - , _skOldPos = pos - , _skWidth = 1 - , _skDamageType = dt - } +randSpark :: + DamageType -> + State StdGen Float -> + State StdGen Color -> + State StdGen Float -> + Point2 -> + World -> + World +randSpark dt randspeed randcol randdir pos w = + w + & randGen .~ g + & cWorld . sparks + .:~ Spark + { _skVel = rotateV dir (V2 speed 0) + , _skColor = col + , _skPos = pos + , _skOldPos = pos + , _skWidth = 1 + , _skDamageType = dt + } where - ((col,dir,speed),g) = (`runState` _randGen w) $ do + ((col, dir, speed), g) = (`runState` _randGen w) $ do c <- randcol d <- randdir x <- randspeed - return (c,d,x) + return (c, d, x) colSparkRandDir :: Float -> Color -> Point2 -> Float -> World -> World -colSparkRandDir a col pos dir = randColDirSpark - (return col) - (state $ randomR (dir - a, dir + a)) - pos +colSparkRandDir a col pos dir = + randColDirSpark + (return col) + (state $ randomR (dir - a, dir + a)) + pos diff --git a/src/Dodge/Spark/Draw.hs b/src/Dodge/Spark/Draw.hs index 929aa255d..def708d75 100644 --- a/src/Dodge/Spark/Draw.hs +++ b/src/Dodge/Spark/Draw.hs @@ -1,9 +1,11 @@ module Dodge.Spark.Draw where + import Dodge.Data.Spark import Picture drawSpark :: Spark -> Picture -drawSpark pt = setLayer BloomNoZWrite - . setDepth 20 - . color (_skColor pt) - $ thickLine (_skWidth pt) [_skOldPos pt, _skPos pt] +drawSpark pt = + setLayer BloomNoZWrite + . setDepth 20 + . color (_skColor pt) + $ thickLine (_skWidth pt) [_skOldPos pt, _skPos pt] diff --git a/src/Dodge/StartNewGame.hs b/src/Dodge/StartNewGame.hs index 3d82ec9d1..2ce211f5d 100644 --- a/src/Dodge/StartNewGame.hs +++ b/src/Dodge/StartNewGame.hs @@ -1,18 +1,21 @@ module Dodge.StartNewGame where -import Dodge.Data -import Dodge.LevelGen + import Control.Lens +import Dodge.Data.Universe +import Dodge.LevelGen import System.Random startNewGame :: Universe -> Universe startNewGame u = startSeedGame i u where - i = fst $ randomR (0,maxBound) (_randGen (_uvWorld u)) + i = fst $ randomR (0, maxBound) (_randGen (_uvWorld u)) startSeedGame :: Int -> Universe -> Universe -startSeedGame i u = u - & menuLayers .~ [WaitScreen (const "GENERATING...") 1] - & uvIOEffects .~ \_ -> do - w <- generateWorldFromSeed i - return $ u & menuLayers .~ [] & uvWorld .~ w - & savedWorlds . at LevelStartSlot ?~ w +startSeedGame i u = + u + & menuLayers .~ [WaitScreen (const "GENERATING...") 1] + & uvIOEffects .~ \_ -> do + w <- generateWorldFromSeed i + return $ + u & menuLayers .~ [] & uvWorld .~ w + & savedWorlds . at LevelStartSlot ?~ w diff --git a/src/Dodge/Targeting.hs b/src/Dodge/Targeting.hs index e9b1b1fee..906da37f4 100644 --- a/src/Dodge/Targeting.hs +++ b/src/Dodge/Targeting.hs @@ -1,11 +1,12 @@ module Dodge.Targeting where -import Dodge.Data + +import Dodge.Data.World import Dodge.Item.Weapon.ExtraEffect updateTargeting :: TargetUpdate -> Item -> Creature -> World -> Targeting -> (World, Targeting) updateTargeting tu = case tu of - NoTargetUpdate -> \_ _ w t -> (w,t) + NoTargetUpdate -> \_ _ w t -> (w, t) TargetLaserUpdate -> targetLaserUpdate TargetRBPressUpdate -> targetUpdateWith targetRBPressUpdate - TargetRBCreatureUpdate -> targetRBCreatureUp + TargetRBCreatureUpdate -> targetRBCreatureUp TargetCursorUpdate -> targetUpdateWith targetCursorUpdate diff --git a/src/Dodge/Targeting/Draw.hs b/src/Dodge/Targeting/Draw.hs index daaa3fc9c..d932f029f 100644 --- a/src/Dodge/Targeting/Draw.hs +++ b/src/Dodge/Targeting/Draw.hs @@ -1,13 +1,13 @@ module Dodge.Targeting.Draw where -import Dodge.Data -import Dodge.Base -import Picture -import Geometry.Vector -import Geometry.Data -import LensHelp -import ShortShow import Data.Maybe +import Dodge.Base +import Dodge.Data.Universe +import Geometry.Data +import Geometry.Vector +import LensHelp +import Picture +import ShortShow drawTargeting :: TargetDraw -> Item -> Creature -> Configuration -> World -> Picture drawTargeting td = case td of @@ -26,50 +26,55 @@ targetDistanceDraw itm _ cfig w = fromMaybe mempty $ do mwp = mouseWorldPos w p2 = worldPosToScreen w mwp thecol = if dist p mwp > 100 then red else white - return $ winScale cfig - $ setLayer FixedCoordLayer - $ color thecol - $ line [p1, p2] - <> transMidLine p1 p2 (scale 0.1 0.1 . text . shortShow $ dist p mwp) + return $ + winScale cfig $ + setLayer FixedCoordLayer $ + color thecol $ + line [p1, p2] + <> transMidLine p1 p2 (scale 0.1 0.1 . text . shortShow $ dist p mwp) targetDraw :: (Item -> Picture) -> Item -> Creature -> Configuration -> World -> Picture targetDraw f it _ cfig w = fromMaybe mempty $ do p <- it ^? itTargeting . tgPos . _Just - return $ winScale cfig - $ setLayer FixedCoordLayer - $ color white - $ uncurryV translate (worldPosToScreen w p) - $ f it + return $ + winScale cfig $ + setLayer FixedCoordLayer $ + color white $ + uncurryV translate (worldPosToScreen w p) $ + f it activeTargetCursorPic :: Picture -activeTargetCursorPic = pictures - [rotate a $ line [V2 15 0,V2 10 0] <> targCorner | a <- [0,0.5*pi,pi,1.5*pi]] +activeTargetCursorPic = + pictures + [rotate a $ line [V2 15 0, V2 10 0] <> targCorner | a <- [0, 0.5 * pi, pi, 1.5 * pi]] transMidLine :: Point2 -> Point2 -> Picture -> Picture transMidLine p1 p2 = translate 20 (f p1 p2) . uncurryV translate (0.5 *.* (p1 +.+ p2)) where - f (V2 x y) (V2 x' y') - | y > y' && x > x' = max (-10) (x'-x) - | y > y' && x < x' = min 10 (x'-x) - | x > x' = min 10 (x-x') - | otherwise = max (-10) (x-x') + f (V2 x y) (V2 x' y') + | y > y' && x > x' = max (-10) (x' - x) + | y > y' && x < x' = min 10 (x' - x) + | x > x' = min 10 (x - x') + | otherwise = max (-10) (x - x') targetRBCreatureDraw :: Item -> Creature -> Configuration -> World -> Picture targetRBCreatureDraw = targetDraw thepic where - thepic it | _tgActive $ _itTargeting it = activeTargetCursorPic + thepic it + | _tgActive $ _itTargeting it = activeTargetCursorPic | otherwise = targetCursorPic targCorner :: Picture -targCorner = pictures - [line [V2 x x, V2 x (x-y)] - ,line [V2 x x, V2 (x-y) x] - ] +targCorner = + pictures + [ line [V2 x x, V2 x (x - y)] + , line [V2 x x, V2 (x - y) x] + ] where x = 10 y = 5 targetCursorPic :: Picture -targetCursorPic = pictures - [rotate a targCorner | a <- [0,0.5*pi,pi,1.5*pi]] - +targetCursorPic = + pictures + [rotate a targCorner | a <- [0, 0.5 * pi, pi, 1.5 * pi]] diff --git a/src/Dodge/Terminal.hs b/src/Dodge/Terminal.hs index 2463fde79..765cc1ce5 100644 --- a/src/Dodge/Terminal.hs +++ b/src/Dodge/Terminal.hs @@ -1,88 +1,100 @@ ---{-# LANGUAGE TupleSections #-} module Dodge.Terminal where -import Dodge.SoundLogic -import Dodge.Data -import Dodge.Default -import Color -import Justify -import LensHelp -import Sound.Data -import ListHelp (safeUncons,safeHead) +import Color import Data.Char -import Data.Maybe import Data.Foldable import qualified Data.Map.Strict as M +import Data.Maybe import qualified Data.Text as T +import Dodge.Data.World +import Dodge.Default +import Dodge.SoundLogic +import Justify +import LensHelp +import ListHelp (safeHead, safeUncons) +import Sound.Data basicTerminal :: Terminal -basicTerminal = defaultTerminal - {_tmDisplayedLines = [] - ,_tmFutureLines = [] - ,_tmMaxLines = 14 - ,_tmTitle = "TERMINAL" - ,_tmInput = defaultTerminalInput - ,_tmScrollCommands = [quitCommand] - ,_tmWriteCommands = [helpCommand,commandsCommand] - ,_tmBootProgram = TerminalBootLines connectionBlurb - , _tmDeathEffect = TmWdWdDoDeathTriggers - } +basicTerminal = + defaultTerminal + { _tmDisplayedLines = [] + , _tmFutureLines = [] + , _tmMaxLines = 14 + , _tmTitle = "TERMINAL" + , _tmInput = defaultTerminalInput + , _tmScrollCommands = [quitCommand] + , _tmWriteCommands = [helpCommand, commandsCommand] + , _tmBootProgram = TerminalBootLines connectionBlurb + , _tmDeathEffect = TmWdWdDoDeathTriggers + } connectionBlurbLines :: [TerminalLine] -> [TerminalLine] -connectionBlurbLines tls = - [termSoundLine computerBeepingS - ,TerminalLineDisplay 0 (TerminalLineConst "CONNECTING" termTextColor) - ,TerminalLineDisplay 10 (TerminalLineConst "..." termTextColor) - ,TerminalLineDisplay 10 (TerminalLineConst "CONNECTED" termTextColor) - ] ++ tls ++ - [TerminalLineTerminalEffect 0 (TmTmSetStatus TerminalReady)] +connectionBlurbLines tls = + [ termSoundLine computerBeepingS + , TerminalLineDisplay 0 (TerminalLineConst "CONNECTING" termTextColor) + , TerminalLineDisplay 10 (TerminalLineConst "..." termTextColor) + , TerminalLineDisplay 10 (TerminalLineConst "CONNECTED" termTextColor) + ] + ++ tls + ++ [TerminalLineTerminalEffect 0 (TmTmSetStatus TerminalReady)] quitCommand :: TerminalCommand -quitCommand = TerminalCommand - { _tcString = "QUIT" - , _tcAlias = ["Q","EXIT","X","SHUTDOWN",""] - , _tcHelp = "DISCONNECTS THE TERMINAL." - , _tcEffect = TerminalCommandArguments $ NoArguments [TerminalLineEffect 0 TmWdWdDisconnectTerminal] - } +quitCommand = + TerminalCommand + { _tcString = "QUIT" + , _tcAlias = ["Q", "EXIT", "X", "SHUTDOWN", ""] + , _tcHelp = "DISCONNECTS THE TERMINAL." + , _tcEffect = TerminalCommandArguments $ NoArguments [TerminalLineEffect 0 TmWdWdDisconnectTerminal] + } + helpCommand :: TerminalCommand -helpCommand = TerminalCommand - { _tcString = "HELP" - , _tcAlias = ["H","MAN"] - , _tcHelp = "DISPLAYS HELP FOR A SPECIFIC COMMAND." - , _tcEffect = TerminalCommandEffectHelp -- \tm -> OneArgument "AN AVAILABLE COMMAND" . getCommandsHelp tm - } +helpCommand = + TerminalCommand + { _tcString = "HELP" + , _tcAlias = ["H", "MAN"] + , _tcHelp = "DISPLAYS HELP FOR A SPECIFIC COMMAND." + , _tcEffect = TerminalCommandEffectHelp -- \tm -> OneArgument "AN AVAILABLE COMMAND" . getCommandsHelp tm + } getCommandsHelp :: Terminal -> World -> M.Map String [TerminalLine] getCommandsHelp tm w = foldr f mempty $ getCommands tm where - f tc = M.insert (_tcString tc) - ( [makeTermLine "COMMAND:" - , makeColorTermLine commandColor (_tcString tc) - ,makeTermLine "ALIASES:" - , makeColorTermLine commandColor ( unwords (_tcAlias tc)) ] - ++ case argumentHelp tc tm w of - (arghelp,Nothing) -> makeTermPara $ _tcHelp tc ++ " " ++ arghelp - (arghelp,Just args) -> makeTermPara (_tcHelp tc ++ " " ++ arghelp) - ++ [makeColorTermLine commandColor $ unwords args] - ) + f tc = + M.insert + (_tcString tc) + ( [ makeTermLine "COMMAND:" + , makeColorTermLine commandColor (_tcString tc) + , makeTermLine "ALIASES:" + , makeColorTermLine commandColor (unwords (_tcAlias tc)) + ] + ++ case argumentHelp tc tm w of + (arghelp, Nothing) -> makeTermPara $ _tcHelp tc ++ " " ++ arghelp + (arghelp, Just args) -> + makeTermPara (_tcHelp tc ++ " " ++ arghelp) + ++ [makeColorTermLine commandColor $ unwords args] + ) + commandsCommand :: TerminalCommand -commandsCommand = TerminalCommand - { _tcString = "COMMANDS" - , _tcAlias = ["COMMAND","COM"] - , _tcHelp = "DISPLAYS AVAILABLE COMMANDS." - , _tcEffect = TerminalCommandEffectCommands - } +commandsCommand = + TerminalCommand + { _tcString = "COMMANDS" + , _tcAlias = ["COMMAND", "COM"] + , _tcHelp = "DISPLAYS AVAILABLE COMMANDS." + , _tcEffect = TerminalCommandEffectCommands + } connectionBlurb :: [TerminalLine] -connectionBlurb = - [termSoundLine computerBeepingS - ,TerminalLineDisplay 0 (TerminalLineConst "CONNECTING" termTextColor) - ,TerminalLineDisplay 10 (TerminalLineConst "..." termTextColor) - ,TerminalLineDisplay 10 (TerminalLineConst "CONNECTED" termTextColor) - ,TerminalLineTerminalEffect 0 (TmTmSetStatus TerminalReady)] +connectionBlurb = + [ termSoundLine computerBeepingS + , TerminalLineDisplay 0 (TerminalLineConst "CONNECTING" termTextColor) + , TerminalLineDisplay 10 (TerminalLineConst "..." termTextColor) + , TerminalLineDisplay 10 (TerminalLineConst "CONNECTED" termTextColor) + , TerminalLineTerminalEffect 0 (TmTmSetStatus TerminalReady) + ] termSoundLine :: SoundID -> TerminalLine termSoundLine sid = TerminalLineEffect 0 (TmWdWdTermSound sid) + -- where -- termsound tm w = soundStart TerminalSound tpos sid Nothing w -- where @@ -117,78 +129,93 @@ doTerminalCommandEffect tce = case tce of TerminalCommandEffectLinkedObject -> \tm _ -> OneArgument "A LINKED OBJECT" (togglesToEffects tm) TerminalCommandEffectHelp -> \tm -> OneArgument "AN AVAILABLE COMMAND" . getCommandsHelp tm TerminalCommandEffectNoArgumentsStr str -> \_ _ -> NoArguments (makeTermPara str) - TerminalCommandEffectCommands -> \tm _ -> NoArguments - ( makeTermLine "AVAILABLE COMMANDS:" - : makeColorTermPara commandColor (unwords (map _tcString $ getCommands tm)) - ) + TerminalCommandEffectCommands -> \tm _ -> + NoArguments + ( makeTermLine "AVAILABLE COMMANDS:" : + makeColorTermPara commandColor (unwords (map _tcString $ getCommands tm)) + ) TerminalCommandEffectSingleCommand eff followingLines -> \_ _ -> NoArguments $ TerminalLineEffect 0 (TmWdWdfromWdWd eff) : map makeTermLine followingLines TerminalCommandEffectNone -> \_ _ -> NoArguments [] -argumentHelp :: TerminalCommand -> Terminal -> World -> (String,Maybe [String]) +argumentHelp :: TerminalCommand -> Terminal -> World -> (String, Maybe [String]) argumentHelp tc tm w = case doTerminalCommandEffect (_tcEffect tc) tm w of - NoArguments {} -> ("ANY ARGUMENTS PROVIDED TO THIS COMMAND ARE IGNORED.",Nothing) - OneArgument argtype argm -> ("EXPECTS " ++ argtype ++ " AS ARGUMENT. AVAILABLE ARGUMENTS: " - , Just (M.keys argm) ) - + NoArguments{} -> ("ANY ARGUMENTS PROVIDED TO THIS COMMAND ARE IGNORED.", Nothing) + OneArgument argtype argm -> + ( "EXPECTS " ++ argtype ++ " AS ARGUMENT. AVAILABLE ARGUMENTS: " + , Just (M.keys argm) + ) infoCommand :: String -> TerminalCommand -infoCommand str = TerminalCommand - { _tcString = "INFORMATION" - , _tcAlias = ["INFO","I"] - , _tcHelp = "DISPLAYS INFORMATION CONCERNING THE TERMINAL." - , _tcEffect = TerminalCommandEffectNoArgumentsStr str -- \_ _ -> NoArguments (makeTermPara str) - } +infoCommand str = + TerminalCommand + { _tcString = "INFORMATION" + , _tcAlias = ["INFO", "I"] + , _tcHelp = "DISPLAYS INFORMATION CONCERNING THE TERMINAL." + , _tcEffect = TerminalCommandEffectNoArgumentsStr str -- \_ _ -> NoArguments (makeTermPara str) + } singleCommand :: [String] -> String -> [String] -> String -> WdWd -> TerminalCommand -singleCommand followingLines command aliases htext eff = TerminalCommand - {_tcString = command - ,_tcAlias = aliases - ,_tcHelp = htext - ,_tcEffect = TerminalCommandEffectSingleCommand eff followingLines } +singleCommand followingLines command aliases htext eff = + TerminalCommand + { _tcString = command + , _tcAlias = aliases + , _tcHelp = htext + , _tcEffect = TerminalCommandEffectSingleCommand eff followingLines + } guardDisconnected :: Terminal -> World -> World -> World guardDisconnected tm w w' = case _tmStatus tm of TerminalOff -> w TerminalBusy -> w TerminalReady -> w' + getDamageCoding :: World -> M.Map String [TerminalLine] getDamageCoding = decodedtmap . _sensorCoding . _genParams . _cWorld sensorInfoMap :: Terminal -> World -> M.Map String [TerminalLine] -sensorInfoMap tm w = M.fromList - [("REQUIREMENT", getSensor _proxRequirement tm w) - ,("DISTANCE", getSensor _proxDist tm w) - ,("CURRENTSTATUS", getSensor _proxStatus tm w) - ,("PASTSTATUS", getSensor _sensToggle tm w) - ] +sensorInfoMap tm w = + M.fromList + [ ("REQUIREMENT", getSensor _proxRequirement tm w) + , ("DISTANCE", getSensor _proxDist tm w) + , ("CURRENTSTATUS", getSensor _proxStatus tm w) + , ("PASTSTATUS", getSensor _sensToggle tm w) + ] + getSensor :: Show a => (Sensor -> a) -> Terminal -> World -> [TerminalLine] -getSensor f tm w = maybe [] (makeTermPara . map toUpper . show . f) - (w ^? cWorld . machines . ix (_tmMachineID tm) . mcSensor) +getSensor f tm w = + maybe + [] + (makeTermPara . map toUpper . show . f) + (w ^? cWorld . machines . ix (_tmMachineID tm) . mcSensor) toggleCommand :: TerminalCommand -toggleCommand = TerminalCommand - { _tcString = "TOGGLE" - , _tcAlias = ["TOG"] - , _tcHelp = "PERFORMS A REVERSABLE EFFECT." - , _tcEffect = TerminalCommandEffectLinkedObject -- \tm _ -> OneArgument "A LINKED OBJECT" (togglesToEffects tm) - } -decodedtmap :: M.Map DamageType (PaletteColor,DecorationShape) -> M.Map String [TerminalLine] -decodedtmap = M.mapKeys show . M.map ((:[]) . makeTermLine . show) +toggleCommand = + TerminalCommand + { _tcString = "TOGGLE" + , _tcAlias = ["TOG"] + , _tcHelp = "PERFORMS A REVERSABLE EFFECT." + , _tcEffect = TerminalCommandEffectLinkedObject -- \tm _ -> OneArgument "A LINKED OBJECT" (togglesToEffects tm) + } + +decodedtmap :: M.Map DamageType (PaletteColor, DecorationShape) -> M.Map String [TerminalLine] +decodedtmap = M.mapKeys show . M.map ((: []) . makeTermLine . show) sensorCommand :: TerminalCommand -sensorCommand = TerminalCommand - { _tcString = "SENSOR" - , _tcAlias = ["SEN"] - , _tcHelp = "ACCESS INFORMATION CONCERNING THE CONNECTED SENSOR." - , _tcEffect = TerminalCommandEffectSensorParameter -- \tm -> OneArgument "A SENSOR PARAMETER" . sensorInfoMap tm - } +sensorCommand = + TerminalCommand + { _tcString = "SENSOR" + , _tcAlias = ["SEN"] + , _tcHelp = "ACCESS INFORMATION CONCERNING THE CONNECTED SENSOR." + , _tcEffect = TerminalCommandEffectSensorParameter -- \tm -> OneArgument "A SENSOR PARAMETER" . sensorInfoMap tm + } disconnectTerminal :: Terminal -> World -> World -disconnectTerminal tm w = w - & cWorld . terminals . ix (_tmID tm) . tmStatus .~ TerminalOff - & exitTerminalSubInv - & cWorld . terminals . ix (_tmID tm) . tmFutureLines .~ - [ TerminalLineTerminalEffect 0 TmTmClearDisplayedLines ] +disconnectTerminal tm w = + w + & cWorld . terminals . ix (_tmID tm) . tmStatus .~ TerminalOff + & exitTerminalSubInv + & cWorld . terminals . ix (_tmID tm) . tmFutureLines + .~ [TerminalLineTerminalEffect 0 TmTmClearDisplayedLines] exitTerminalSubInv :: World -> World exitTerminalSubInv w = case w ^? cWorld . hud . hudElement . subInventory . termID of @@ -196,35 +223,39 @@ exitTerminalSubInv w = case w ^? cWorld . hud . hudElement . subInventory . term _ -> w damageCodeCommand :: TerminalCommand -damageCodeCommand = TerminalCommand - { _tcString = "DAMAGECODE" - , _tcAlias = ["DCODE","DC"] - , _tcHelp = "DISPLAYS THE SHAPE AND COLOR ASSOCIATED WITH A GIVEN DAMAGE TYPE." - , _tcEffect = TerminalCommandEffectDamageCoding -- \_ -> OneArgument "A DAMAGE TYPE" . getDamageCoding - } - +damageCodeCommand = + TerminalCommand + { _tcString = "DAMAGECODE" + , _tcAlias = ["DCODE", "DC"] + , _tcHelp = "DISPLAYS THE SHAPE AND COLOR ASSOCIATED WITH A GIVEN DAMAGE TYPE." + , _tcEffect = TerminalCommandEffectDamageCoding -- \_ -> OneArgument "A DAMAGE TYPE" . getDamageCoding + } infoClearInput :: Terminal -> [TerminalLine] -> World -> World -infoClearInput tm tls = cWorld . terminals . ix (_tmID tm) %~ - ( (tmInput .~ TerminalInput T.empty True (0,0)) - . (tmFutureLines ++.~ tls) - ) +infoClearInput tm tls = + cWorld . terminals . ix (_tmID tm) + %~ ( (tmInput .~ TerminalInput T.empty True (0, 0)) + . (tmFutureLines ++.~ tls) + ) togglesToEffects :: Terminal -> M.Map String [TerminalLine] togglesToEffects = fmap f . _tmToggles where - f tt = [TerminalLineEffect 0 $ TmWdWdfromWdWd $ WdWdNegateTrig (_ttTriggerID tt)] - -- \_ -> triggers . ix (_ttTriggerID tt) %~ not] + f tt = [TerminalLineEffect 0 $ TmWdWdfromWdWd $ WdWdNegateTrig (_ttTriggerID tt)] + +-- \_ -> triggers . ix (_ttTriggerID tt) %~ not] simpleTermMessage :: [String] -> Terminal simpleTermMessage strs = defaultTerminal & tmFutureLines .~ map makeTermLine strs commandFutureLines :: String -> Terminal -> World -> [TerminalLine] commandFutureLines s tm w = fromMaybe [errline "^ INVALID COMMAND"] $ do - (str,args) <- safeUncons $ words s - command <- find (\tc -> _tcString tc == str || str `elem` _tcAlias tc) (getCommands tm) + (str, args) <- safeUncons $ words s + command <- find (\tc -> _tcString tc == str || str `elem` _tcAlias tc) (getCommands tm) case doTerminalCommandEffect (_tcEffect command) tm w of NoArguments tls -> Just tls - OneArgument argtype m -> Just $ fromMaybe [errline $ "^ INVALID ARGUMENT: EXPECTS "++ argtype] - $ safeHead args >>= (m M.!?) + OneArgument argtype m -> + Just $ + fromMaybe [errline $ "^ INVALID ARGUMENT: EXPECTS " ++ argtype] $ + safeHead args >>= (m M.!?) where errline = makeColorTermLine red diff --git a/src/Dodge/Terminal/LeftButton.hs b/src/Dodge/Terminal/LeftButton.hs index ee7070352..4ba9f0240 100644 --- a/src/Dodge/Terminal/LeftButton.hs +++ b/src/Dodge/Terminal/LeftButton.hs @@ -1,24 +1,27 @@ -module Dodge.Terminal.LeftButton - where -import Dodge.Data -import Dodge.Terminal -- this goes the wrong way! +module Dodge.Terminal.LeftButton where + +import Data.Maybe +import qualified Data.Text as T +import Dodge.Data.World +import Dodge.Terminal--oops import LensHelp -import qualified Data.Text as T -import Data.Maybe - doTerminalEffectLB :: Terminal -> World -> World -doTerminalEffectLB tm w = guardDisconnected tm w $ fromMaybe w $ do - s <- fmap T.unpack $ w ^? cWorld . terminals . ix (_tmID tm) . tmInput . tiText - if null (words s) - then Just $ defocusTerminalInput w - else return $ terminalReturnEffect tm w +doTerminalEffectLB tm w = guardDisconnected tm w $ + fromMaybe w $ do + s <- fmap T.unpack $ w ^? cWorld . terminals . ix (_tmID tm) . tmInput . tiText + if null (words s) + then Just $ defocusTerminalInput w + else return $ terminalReturnEffect tm w terminalReturnEffect :: Terminal -> World -> World -terminalReturnEffect tm w = guardDisconnected tm w $ fromMaybe w $ do - s <- fmap T.unpack $ w ^? cWorld . terminals . ix (_tmID tm) . tmInput . tiText - return $ runTerminalString s tm $ w - & cWorld . terminals . ix (_tmID tm) . tmFutureLines .~ [makeTermLine ('>':s)] +terminalReturnEffect tm w = guardDisconnected tm w $ + fromMaybe w $ do + s <- fmap T.unpack $ w ^? cWorld . terminals . ix (_tmID tm) . tmInput . tiText + return $ + runTerminalString s tm $ + w + & cWorld . terminals . ix (_tmID tm) . tmFutureLines .~ [makeTermLine ('>' : s)] defocusTerminalInput :: World -> World defocusTerminalInput w = fromMaybe w $ do @@ -26,8 +29,9 @@ defocusTerminalInput w = fromMaybe w $ do return $ w & cWorld . terminals . ix tmid . tmInput . tiFocus %~ const False runTerminalString :: String -> Terminal -> World -> World -runTerminalString s tm w = w & cWorld . terminals . ix (_tmID tm) %~ - ( (tmInput .~ TerminalInput T.empty True (0,0)) - . (tmFutureLines ++.~ commandFutureLines s tm w) - . (tmCommandHistory %~ take 10 . (s:)) - ) +runTerminalString s tm w = + w & cWorld . terminals . ix (_tmID tm) + %~ ( (tmInput .~ TerminalInput T.empty True (0, 0)) + . (tmFutureLines ++.~ commandFutureLines s tm w) + . (tmCommandHistory %~ take 10 . (s :)) + ) diff --git a/src/Dodge/Tesla/Arc.hs b/src/Dodge/Tesla/Arc.hs index df07dbb1c..3eba3d3a7 100644 --- a/src/Dodge/Tesla/Arc.hs +++ b/src/Dodge/Tesla/Arc.hs @@ -1,124 +1,116 @@ -module Dodge.Tesla.Arc - where -import Dodge.Data +module Dodge.Tesla.Arc where + +import Dodge.Data.CrWlID +import Dodge.Data.ArcStep +import Data.Maybe +import Dodge.ArcStep import Dodge.Damage +import Dodge.Data.World import Dodge.Spark -import RandomHelp -import Picture import Geometry import LensHelp -import Dodge.ArcStep ---import Dodge.Data ---import Geometry ---import LensHelp ---import RandomHelp ---import Color ---import Dodge.Item.Location ---import Dodge.WorldEvent.Damage ---import Dodge.WorldEvent.ThingsHit ---import Dodge.WorldEvent.HelperParticle ---import Dodge.Item.Weapon.LaserPath ---import Geometry ---import LensHelp ---import Picture ---import RandomHelp ---import Dodge.Zone ---import Dodge.Base.Collide ---import Shape - ---import qualified IntMapHelp as IM ---import Data.List (sortOn) import MonadHelp -import Data.Maybe ---import qualified IntMapHelp as IM +import Picture +import RandomHelp aTeslaArcAt :: Color -> [ArcStep] -> TeslaArc -aTeslaArcAt col thearc = TeslaArc - { _taPoints = map (^. asPos) thearc - , _taArcSteps = thearc - , _taTimer = 2 - , _taColor = brightX 100 1.5 col - } +aTeslaArcAt col thearc = + TeslaArc + { _taPoints = map (^. asPos) thearc + , _taArcSteps = thearc + , _taTimer = 2 + , _taColor = brightX 100 1.5 col + } -moveTeslaArc :: World - -> TeslaArc - -> (World,Maybe TeslaArc) +moveTeslaArc :: + World -> + TeslaArc -> + (World, Maybe TeslaArc) moveTeslaArc w pt - | _taTimer pt == 2 = (makesparks $ foldr damthings w thearc, Just $ pt & taTimer -~ 1) - | _taTimer pt < 1 = (w, Nothing) - | otherwise = (w, Just $ pt & taTimer -~ 1) + | _taTimer pt == 2 = (makesparks $ foldr damthings w thearc, Just $ pt & taTimer -~ 1) + | _taTimer pt < 1 = (w, Nothing) + | otherwise = (w, Just $ pt & taTimer -~ 1) where thearc = _taArcSteps pt - rcol = brightX 100 1.5 <$> takeOne [white,azure,blue,cyan] - rdir = state (randomR (-0.7,0.7)) <&> (+ ld) - rspeed = state (randomR (3,6)) + rcol = brightX 100 1.5 <$> takeOne [white, azure, blue, cyan] + rdir = state (randomR (-0.7, 0.7)) <&> (+ ld) + rspeed = state (randomR (3, 6)) makeaspark = randSpark ELECTRICAL rspeed rcol rdir lp makesparks = makeaspark . makeaspark . makeaspark - (lp,ld) = case last thearc of - ArcStep lp' ld' NothingID -> (lp',ld') + (lp, ld) = case last thearc of + ArcStep lp' ld' NothingID -> (lp', ld') ArcStep lp' ld' (CrID crid) -> case w ^? cWorld . creatures . ix crid of - Nothing -> (lp',ld') - Just cr -> (lp' -.- (_crRad cr + 1) *.* unitVectorAtAngle ld',ld'+pi) + Nothing -> (lp', ld') + Just cr -> (lp' -.- (_crRad cr + 1) *.* unitVectorAtAngle ld', ld' + pi) ArcStep lp' ld' (WlID wlid) -> case w ^? cWorld . walls . ix wlid of - Nothing -> (lp',ld') - Just _ -> (lp' -.- 2 *.* unitVectorAtAngle ld',ld'+pi) + Nothing -> (lp', ld') + Just _ -> (lp' -.- 2 *.* unitVectorAtAngle ld', ld' + pi) --damthings (ArcStep _ _ NothingID) = id damthings (ArcStep p dir crwl) = damageCrWlID (thedamage p dir) crwl thedamage p dir = Damage ELECTRICAL 50 (p -.- q) p (p +.+ q) NoDamageEffect where q = 5 *.* unitVectorAtAngle dir -shootTeslaArc' :: ItemParams -> Point2 -> Float -> World -> (World,ItemParams) -shootTeslaArc' ip pos dir w = - (w & randGen .~ g - & cWorld . teslaArcs .:~ aTeslaArcAt col newarc +shootTeslaArc' :: ItemParams -> Point2 -> Float -> World -> (World, ItemParams) +shootTeslaArc' ip pos dir w = + ( w & randGen .~ g + & cWorld . teslaArcs .:~ aTeslaArcAt col newarc , ip & currentArc ?~ newarc ) where - (col,g) = takeOne [white,azure,blue,cyan] & runState $ _randGen w + (col, g) = takeOne [white, azure, blue, cyan] & runState $ _randGen w newarc = createArc ip w pos dir & evalState $ _randGen w -createArc :: ItemParams - -> World - -> Point2 - -> Float - -> State StdGen [ArcStep] +createArc :: + ItemParams -> + World -> + Point2 -> + Float -> + State StdGen [ArcStep] createArc arcparams@Arcing{_currentArc = Nothing} w p dir = createNewArc arcparams w p dir createArc arcparams w p dir = updateArc arcparams w p dir -createNewArc :: ItemParams -> World -> Point2 -> Float - -> State StdGen [ArcStep] -createNewArc arcparams w p dir = take (_arcNumber arcparams) - <$> unfoldrMID (doStep (_newArcStep arcparams) arcparams w) (ArcStep p dir NothingID) +createNewArc :: + ItemParams -> + World -> + Point2 -> + Float -> + State StdGen [ArcStep] +createNewArc arcparams w p dir = + take (_arcNumber arcparams) + <$> unfoldrMID (doStep (_newArcStep arcparams) arcparams w) (ArcStep p dir NothingID) -updateArc :: ItemParams - -> World - -> Point2 - -> Float - -> State StdGen [ArcStep] +updateArc :: + ItemParams -> + World -> + Point2 -> + Float -> + State StdGen [ArcStep] updateArc ip w p dir = take (_arcNumber ip) <$> zipArcs ip w (ArcStep p dir NothingID) carc where carc = tail $ fromJust $ _currentArc ip -zipArcs :: ItemParams - -> World - -> ArcStep - -> [ArcStep] - -> State StdGen [ArcStep] -zipArcs ip w x (y:ys) = (x :) <$> do - defaultnext <- doStep (_newArcStep ip) ip w x - case defaultnext of - Nothing -> return [] - Just z@(ArcStep _ _ (CrID _)) -> return [z] - Just z@(ArcStep _ _ (WlID _)) -> return [z] - Just z -> do - p <- randInCirc 5 - let csize = _arcSize ip - center = _asPos x +.+ csize *.* unitVectorAtAngle (_asDir x) - newp = _asPos y +.+ p - --newdir = argV $ newp -.- _asPos x - newdir = _asDir x - if dist newp center < csize - then zipArcs ip w (y & asPos .~ newp & asDir .~ newdir) ys - else zipArcs ip w z ys +zipArcs :: + ItemParams -> + World -> + ArcStep -> + [ArcStep] -> + State StdGen [ArcStep] +zipArcs ip w x (y : ys) = + (x :) <$> do + defaultnext <- doStep (_newArcStep ip) ip w x + case defaultnext of + Nothing -> return [] + Just z@(ArcStep _ _ (CrID _)) -> return [z] + Just z@(ArcStep _ _ (WlID _)) -> return [z] + Just z -> do + p <- randInCirc 5 + let csize = _arcSize ip + center = _asPos x +.+ csize *.* unitVectorAtAngle (_asDir x) + newp = _asPos y +.+ p + --newdir = argV $ newp -.- _asPos x + newdir = _asDir x + if dist newp center < csize + then zipArcs ip w (y & asPos .~ newp & asDir .~ newdir) ys + else zipArcs ip w z ys zipArcs ip w y _ = createNewArc ip w (_asPos y) (_asDir y) diff --git a/src/Dodge/Tesla/Arc/Default.hs b/src/Dodge/Tesla/Arc/Default.hs index cbf5dc58b..b96ec68b9 100644 --- a/src/Dodge/Tesla/Arc/Default.hs +++ b/src/Dodge/Tesla/Arc/Default.hs @@ -1,36 +1,44 @@ module Dodge.Tesla.Arc.Default where -import Dodge.Data -import RandomHelp -import Geometry + +import Dodge.Data.CrWlID +import Data.List (sortOn) +import Data.Maybe import Dodge.Base.Collide +import Dodge.Data.ArcStep +import Dodge.Data.World +import Geometry +import qualified IntMapHelp as IM import LensHelp +import RandomHelp import Shape -import Data.Maybe -import Data.List (sortOn) -import qualified IntMapHelp as IM - -defaultArcStep :: RandomGen g => ItemParams -> World -> ArcStep - -> State g (Maybe ArcStep) -defaultArcStep _ _ (ArcStep _ _ (CrID _)) = return Nothing -defaultArcStep _ _ (ArcStep _ _ (WlID _)) = return Nothing +defaultArcStep :: + RandomGen g => + ItemParams -> + World -> + ArcStep -> + State g (Maybe ArcStep) +defaultArcStep _ _ (ArcStep _ _ (CrID _)) = return Nothing +defaultArcStep _ _ (ArcStep _ _ (WlID _)) = return Nothing defaultArcStep itparams w (ArcStep p dir _) = do let csize = _arcSize itparams --rot <- takeOne [pi/4,negate pi/4] rot <- takeOne [0] let center = csize *.* rotateV rot (unitVectorAtAngle dir) +.+ p newp <- (center +.+) <$> randInCirc csize - let mcr = listToMaybe - . sortOn (dist center . _crPos) - . filter (\cr -> dist center (_crPos cr) < csize) - . IM.elems - $ _creatures (_cWorld w) - mwl = listToMaybe - . sortOn (dist p . fst) - . mapMaybe (\ q -> sequence $ collidePointWallsFilterStream (const True) p (center +.+ q) w) + let mcr = + listToMaybe + . sortOn (dist center . _crPos) + . filter (\cr -> dist center (_crPos cr) < csize) + . IM.elems + $ _creatures (_cWorld w) + mwl = + listToMaybe + . sortOn (dist p . fst) + . mapMaybe (\q -> sequence $ collidePointWallsFilterStream (const True) p (center +.+ q) w) -- collidePointWallsWall and wlsnearpoint - $ polyCirc 6 csize - f (q,wl) = ArcStep q dir (WlID $ _wlID wl) - g cr = ArcStep (_crPos cr +.+ csize *.* unitVectorAtAngle dir) dir (CrID $ _crID cr) - return . listToMaybe . sortOn (dist p . (^. asPos)) - $ ArcStep newp dir NothingID : catMaybes [fmap f mwl,fmap g mcr] + $ polyCirc 6 csize + f (q, wl) = ArcStep q dir (WlID $ _wlID wl) + g cr = ArcStep (_crPos cr +.+ csize *.* unitVectorAtAngle dir) dir (CrID $ _crID cr) + return . listToMaybe . sortOn (dist p . (^. asPos)) $ + ArcStep newp dir NothingID : catMaybes [fmap f mwl, fmap g mcr] diff --git a/src/Dodge/Tesla/Arc/Draw.hs b/src/Dodge/Tesla/Arc/Draw.hs index 71f43e375..daa901379 100644 --- a/src/Dodge/Tesla/Arc/Draw.hs +++ b/src/Dodge/Tesla/Arc/Draw.hs @@ -1,12 +1,15 @@ module Dodge.Tesla.Arc.Draw where + import Dodge.Data.TeslaArc import Geometry import Picture + drawTeslaArc :: TeslaArc -> Picture -drawTeslaArc pt = setLayer BloomNoZWrite $ pictures - [ setDepth 20.5 $ color (brightX 2 1 $ _taColor pt) $ thickLine 3 ps - , setDepth 20 $ color (V4 0 0 0 0.5) $ thickLine 10 ps - ] +drawTeslaArc pt = + setLayer BloomNoZWrite $ + pictures + [ setDepth 20.5 $ color (brightX 2 1 $ _taColor pt) $ thickLine 3 ps + , setDepth 20 $ color (V4 0 0 0 0.5) $ thickLine 10 ps + ] where ps = _taPoints pt - diff --git a/src/Dodge/Tesla/Ball.hs b/src/Dodge/Tesla/Ball.hs index afa12af3a..90cd1a295 100644 --- a/src/Dodge/Tesla/Ball.hs +++ b/src/Dodge/Tesla/Ball.hs @@ -1,5 +1,6 @@ module Dodge.Tesla.Ball where -import Dodge.Data + +import Dodge.Data.World import Geometry makeTeslaBallAt :: Point2 -> World -> World diff --git a/src/Dodge/Tesla/ItemParams.hs b/src/Dodge/Tesla/ItemParams.hs index a98e6b59c..2e374cdad 100644 --- a/src/Dodge/Tesla/ItemParams.hs +++ b/src/Dodge/Tesla/ItemParams.hs @@ -1,11 +1,14 @@ module Dodge.Tesla.ItemParams where -import Dodge.Data + +import Dodge.Data.ArcStep +import Dodge.Data.Item.Params teslaParams :: ItemParams -teslaParams = Arcing - { _currentArc = Nothing - , _arcSize = 20 - , _arcNumber = 10 - , _newArcStep = DefaultArcStep --defaultArcStep - , _previousArcEffect = NoPreviousArcEffect - } +teslaParams = + Arcing + { _currentArc = Nothing + , _arcSize = 20 + , _arcNumber = 10 + , _newArcStep = DefaultArcStep --defaultArcStep + , _previousArcEffect = NoPreviousArcEffect + } diff --git a/src/Dodge/TestString.hs b/src/Dodge/TestString.hs index d4850a629..49d3f3f6f 100644 --- a/src/Dodge/TestString.hs +++ b/src/Dodge/TestString.hs @@ -1,7 +1,6 @@ module Dodge.TestString where -import Dodge.Data + +import Dodge.Data.Universe testStringInit :: Universe -> [String] testStringInit _ = [] ---testStringInit = map (show . _drStatus) . IM.elems . _doors ---testStringInit = const . const [] diff --git a/src/Dodge/TmTm.hs b/src/Dodge/TmTm.hs index 3b1307e44..c4a959cb4 100644 --- a/src/Dodge/TmTm.hs +++ b/src/Dodge/TmTm.hs @@ -1,10 +1,10 @@ -module Dodge.TmTm - where -import Dodge.Data.Terminal +module Dodge.TmTm where + import Control.Lens +import Dodge.Data.Terminal + doTmTm :: TmTm -> Terminal -> Terminal doTmTm tmtm = case tmtm of TmTmClearDisplayedLines -> tmDisplayedLines .~ [] TmTmSetStatus s -> tmStatus .~ s TmId -> id - diff --git a/src/Dodge/TractorBeam/Draw.hs b/src/Dodge/TractorBeam/Draw.hs index f232aad81..fdee50866 100644 --- a/src/Dodge/TractorBeam/Draw.hs +++ b/src/Dodge/TractorBeam/Draw.hs @@ -1,5 +1,5 @@ -module Dodge.TractorBeam.Draw - where +module Dodge.TractorBeam.Draw where + import Dodge.Data.TractorBeam import Geometry import Picture @@ -8,13 +8,17 @@ drawTractorBeam :: TractorBeam -> Picture drawTractorBeam = tractorSPic tractorSPic :: TractorBeam -> Picture -tractorSPic pj = setLayer BloomNoZWrite $ setDepth 20 $ color (withAlpha 0.5 col) $ polygon - [ spos -- not sure if this is anticlockwise... - , spos +.+ size *.* (d +.+ n) - , xpos +.+ size *.* n - , xpos -.- size *.* n - , spos +.+ size *.* (d -.- n) - ] +tractorSPic pj = + setLayer BloomNoZWrite $ + setDepth 20 $ + color (withAlpha 0.5 col) $ + polygon + [ spos -- not sure if this is anticlockwise... + , spos +.+ size *.* (d +.+ n) + , xpos +.+ size *.* n + , xpos -.- size *.* n + , spos +.+ size *.* (d -.- n) + ] where size = fromIntegral (_tbTime pj) spos = _tbPos pj diff --git a/src/Dodge/TractorBeam/Update.hs b/src/Dodge/TractorBeam/Update.hs index 0499bfc35..4e735925e 100644 --- a/src/Dodge/TractorBeam/Update.hs +++ b/src/Dodge/TractorBeam/Update.hs @@ -1,24 +1,26 @@ -module Dodge.TractorBeam.Update - where -import Geometry -import Dodge.Data -import qualified IntMapHelp as IM +module Dodge.TractorBeam.Update where + import Control.Lens +import Dodge.Data.World +import Geometry +import qualified IntMapHelp as IM updateTractorBeam :: World -> TractorBeam -> (World, Maybe TractorBeam) updateTractorBeam w pj | _tbTime pj <= 0 = (w, Nothing) - | otherwise = (w - & cWorld . creatures %~ IM.map (tractCr pullVel pos outpos) - & cWorld . floorItems %~ IM.map (tractFlIt pullVel pos outpos) - , Just (pj & tbTime -~ 1)) - where + | otherwise = + ( w + & cWorld . creatures %~ IM.map (tractCr pullVel pos outpos) + & cWorld . floorItems %~ IM.map (tractFlIt pullVel pos outpos) + , Just (pj & tbTime -~ 1) + ) + where pullVel = _tbVel pj - pos = _tbPos pj - outpos = _tbStartPos pj + pos = _tbPos pj + outpos = _tbStartPos pj tractFlIt :: Point2 -> Point2 -> Point2 -> FloorItem -> FloorItem -tractFlIt q p1 outpos it +tractFlIt q p1 outpos it | segOnCirc p1 outpos (_flItPos it) 10 = it & flItPos %~ tractorPullPos q p1 | otherwise = it @@ -28,13 +30,15 @@ tractCr q p1 outpos cr | otherwise = cr tractorPullPos :: Point2 -> Point2 -> Point2 -> Point2 -tractorPullPos q p1 p = p -.- m *.* (0.3/ x' *.* q +.+ g y *.* p4) +tractorPullPos q p1 p = p -.- m *.* (0.3 / x' *.* q +.+ g y *.* p4) where x' = abs y + 1 y = errorClosestPointOnLineParam 1 p1 p3 p - m | dist p p1 < 350 = 1 - | otherwise = (400 - dist p p1) / 50 - g x | x > 5 = (10 - x) / 250 + m + | dist p p1 < 350 = 1 + | otherwise = (400 - dist p p1) / 50 + g x + | x > 5 = (10 - x) / 250 | x > 1 = 0.02 | x > -1 = x * 0.02 | x > -5 = -0.02 @@ -42,4 +46,3 @@ tractorPullPos q p1 p = p -.- m *.* (0.3/ x' *.* q +.+ g y *.* p4) --p4 = vNormal p5 p4 = vNormal $ squashNormalizeV q p3 = p1 +.+ p4 - diff --git a/src/Dodge/Tree/Compose.hs b/src/Dodge/Tree/Compose.hs index 0fb9294d7..61a46b241 100644 --- a/src/Dodge/Tree/Compose.hs +++ b/src/Dodge/Tree/Compose.hs @@ -1,51 +1,47 @@ {-# LANGUAGE TupleSections #-} -{-| Combining and composing trees of trees. -} -module Dodge.Tree.Compose - ( tToBTree - , overwriteLabel - , composeTree - , decomposeTree - , numMetaTree - , numSelfTree - , combineTree - , decomposeSelfTree - , shiftChildren - , attachTree - , toOnward - , attachOnward - , attachOnward' - , showIntsString - , module Dodge.Tree.Compose.Data - ) where -import Dodge.Data -import Dodge.Tree.Compose.Data ---import Dodge.RoomCluster.Data -import TreeHelp ---import Dodge.Base -import LensHelp -import Data.List (intersperse) -import Data.Tuple ---import Data.Bifunctor ---import Control.Monad.State ---import Data.Foldable ---import System.Random -import Data.Maybe +-- | Combining and composing trees of trees. +module Dodge.Tree.Compose ( + tToBTree, + overwriteLabel, + composeTree, + decomposeTree, + numMetaTree, + numSelfTree, + combineTree, + decomposeSelfTree, + shiftChildren, + attachTree, + toOnward, + attachOnward, + attachOnward', + showIntsString, + module Dodge.Tree.Compose.Data, +) where + import Control.Monad.State +import Data.List (intersperse) +import Data.Maybe +import Data.Tuple +import Dodge.Data.GenWorld +import Dodge.Tree.Compose.Data +import LensHelp +import TreeHelp overwriteLabel :: Int -> Tree Room -> [Tree Room] -> Tree Room -overwriteLabel i t ts = safeUpdateSingleNode - (\rm -> LabelCluster i `elem` (rm ^?! rmClusterStatus . csLinks)) - ((branches .~ ts) . (root . rmClusterStatus . csLinks . at (LabelCluster i) .~ Nothing)) - t +overwriteLabel i t ts = + safeUpdateSingleNode + (\rm -> LabelCluster i `elem` (rm ^?! rmClusterStatus . csLinks)) + ((branches .~ ts) . (root . rmClusterStatus . csLinks . at (LabelCluster i) .~ Nothing)) + t -attachTree :: (a -> Maybe a) -> Tree a -> Tree ([Tree a],a) -> Tree ([Tree a],a) -attachTree upf t = safeUpdateSingleNode (isJust . upf . snd) ( (root . _2 %~ g) . (root . _1 .:~ t ) ) +attachTree :: (a -> Maybe a) -> Tree a -> Tree ([Tree a], a) -> Tree ([Tree a], a) +attachTree upf t = safeUpdateSingleNode (isJust . upf . snd) ((root . _2 %~ g) . (root . _1 .:~ t)) where g x = fromMaybe x (upf x) -shiftChildren :: Tree ([Tree a],a) -> Tree a -shiftChildren (Node (ts,x) ts') = Node x (ts ++ map shiftChildren ts') +shiftChildren :: Tree ([Tree a], a) -> Tree a +shiftChildren (Node (ts, x) ts') = Node x (ts ++ map shiftChildren ts') composeTree :: MetaTree a b -> Tree a composeTree mt = attachList' (composeNode $ _mtTree mt) (_mtBranches mt) @@ -54,8 +50,9 @@ mtTopLabels :: MetaTree a b -> Tree b mtTopLabels (MTree lab _ bs) = Node lab (map (mtTopLabels . _mbTree) bs) mtUnderLabels :: MetaTree a b -> [Tree b] -mtUnderLabels mt = maybe [] decomposeTree (mt ^? mtTree . nodeMetaTree) - ++ concatMap (mtUnderLabels . _mbTree) (_mtBranches mt) +mtUnderLabels mt = + maybe [] decomposeTree (mt ^? mtTree . nodeMetaTree) + ++ concatMap (mtUnderLabels . _mbTree) (_mtBranches mt) decomposeTree :: MetaTree a b -> [Tree b] decomposeTree mt = mtTopLabels mt : mtUnderLabels mt @@ -68,10 +65,13 @@ decomposeSelfTree st = fmap fst (_unST st) : concatMap (f . snd) (_unST st) combineTree :: (a -> b) -> MetaTree a b -> SelfTree b combineTree f mt = case _mtTree mt of - NodeTree t -> ST (Node (_mtLabel mt,Left $ fmap f t) (_unST . combineTree f . _mbTree <$> _mtBranches mt)) + NodeTree t -> ST (Node (_mtLabel mt, Left $ fmap f t) (_unST . combineTree f . _mbTree <$> _mtBranches mt)) --NodeTree t -> ST (Node (Left $ fmap f t) _) - NodeMTree mt' -> ST (Node (_mtLabel mt,Right $ combineTree f mt') - $ map (_unST . combineTree f . _mbTree) $ _mtBranches mt) + NodeMTree mt' -> + ST + ( Node (_mtLabel mt, Right $ combineTree f mt') $ + map (_unST . combineTree f . _mbTree) $ _mtBranches mt + ) composeNode :: MetaNode a b -> Tree a composeNode (NodeTree t) = t @@ -80,14 +80,15 @@ composeNode (NodeMTree mt) = composeTree mt attachList' :: Tree a -> [MetaBranch a b] -> Tree a attachList' t xs = shiftChildren $ foldr attachBranch (fmap ([],) t) xs -attachBranch :: MetaBranch a b -> Tree ([Tree a],a) -> Tree ([Tree a],a) -attachBranch mb = safeUpdateSingleNode (isJust . upf . snd) - ( (root . _2 %~ g) . (root ._1 .:~ composeTree (_mbTree mb)) ) +attachBranch :: MetaBranch a b -> Tree ([Tree a], a) -> Tree ([Tree a], a) +attachBranch mb = + safeUpdateSingleNode + (isJust . upf . snd) + ((root . _2 %~ g) . (root . _1 .:~ composeTree (_mbTree mb))) where upf = _mbAttach mb g x = fromMaybe x (upf x) - tToBTree :: String -> Tree Room -> MetaTree Room String tToBTree str t = MTree str (NodeTree t) [] @@ -99,31 +100,31 @@ attachOnward' t1 t2 = MTree (_mtLabel t1) (NodeMTree t1) [MBranch toOnward t2] toOnward :: Room -> Maybe Room toOnward rm - | OnwardCluster `elem` rm ^?! rmClusterStatus . csLinks - = Just (rm & rmClusterStatus . csLinks . at OnwardCluster .~ Nothing) + | OnwardCluster `elem` rm ^?! rmClusterStatus . csLinks = + Just (rm & rmClusterStatus . csLinks . at OnwardCluster .~ Nothing) | otherwise = Nothing -numSelfTree :: SelfTree a -> SelfTree ([Int],a) +numSelfTree :: SelfTree a -> SelfTree ([Int], a) numSelfTree st = evalState (numSelfTree' st) [0] -numSelfTree' :: SelfTree a -> State [Int] (SelfTree ([Int],a)) +numSelfTree' :: SelfTree a -> State [Int] (SelfTree ([Int], a)) numSelfTree' (ST (Node lrt bs)) = do is <- get modify (ix 0 +~ 1) bs' <- mapM (fmap _unST . numSelfTree' . ST) bs case lrt of - (y,Left t) -> return $ ST (Node ((is,y),Left $ (_1 %~ (:is)) . swap <$> numTraversable t) bs') - (y,Right mt') -> return $ ST (Node ((is,y),Right (evalState (numSelfTree' mt') (0:is))) bs') + (y, Left t) -> return $ ST (Node ((is, y), Left $ (_1 %~ (: is)) . swap <$> numTraversable t) bs') + (y, Right mt') -> return $ ST (Node ((is, y), Right (evalState (numSelfTree' mt') (0 : is))) bs') -numMetaTree :: MetaTree a String -> MetaTree a ([Int],String) +numMetaTree :: MetaTree a String -> MetaTree a ([Int], String) numMetaTree mt = evalState (numMetaTree' mt) [0] -numMetaTree' :: MetaTree a b -> State [Int] (MetaTree a ([Int],b)) +numMetaTree' :: MetaTree a b -> State [Int] (MetaTree a ([Int], b)) numMetaTree' (MTree lab mn bs) = do is <- get modify (ix 0 +~ 1) bs' <- mapM (mbTree %%~ numMetaTree') bs - return $ MTree (is,lab) (mn & nodeMetaTree %~ (\nmt -> evalState (numMetaTree' nmt) (0:is))) bs' + return $ MTree (is, lab) (mn & nodeMetaTree %~ (\nmt -> evalState (numMetaTree' nmt) (0 : is))) bs' -showIntsString :: ([Int],String) -> String -showIntsString (is,s) = foldr1 (++) (intersperse ":" (map show $ reverse is)) ++ ':':s +showIntsString :: ([Int], String) -> String +showIntsString (is, s) = foldr1 (++) (intersperse ":" (map show $ reverse is)) ++ ':' : s diff --git a/src/Dodge/Tree/Shift.hs b/src/Dodge/Tree/Shift.hs index f3bb4408a..c6ca7bc0a 100644 --- a/src/Dodge/Tree/Shift.hs +++ b/src/Dodge/Tree/Shift.hs @@ -1,150 +1,164 @@ +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TemplateHaskell #-} + {- | Given a tree of rooms, tries to shift them into place in such a way that their links connect and that none of them clip. -Creates a list of rooms; after this step the structure is determined by the actual positions of rooms. -} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE StrictData #-} -module Dodge.Tree.Shift - ( positionRoomsFromTree - , PosRooms (..) - ) where ---import Dodge.LevelGen.Data -import Dodge.Data +Creates a list of rooms; after this step the structure is determined by the actual positions of rooms. +-} +module Dodge.Tree.Shift ( + positionRoomsFromTree, + PosRooms (..), +) where + +import Control.Lens +import Data.Bifunctor +import Data.List (delete) +import qualified Data.Sequence as Seq +import qualified Data.Set as S +import Dodge.Data.GenWorld import Dodge.Room.Link -import TreeHelp import Dodge.RoomLink import Geometry.ConvexPoly ---import Geometry.Data +import LensHelp hiding (Empty, (<|), (|>)) import Padding -import LensHelp hiding (Empty, (<|) , (|>)) ---import Control.Lens hiding (Empty, (<|) , (|>)) +import TreeHelp -import qualified Data.Set as S -import qualified Data.Sequence as Seq -import Data.List (delete) -import Data.Bifunctor -import Control.Lens - -type RoomInt = (Room,Int) +type RoomInt = (Room, Int) data PosRooms = PosRooms { _prBounds :: [ConvexPoly] - , _prRooms :: [RoomInt] + , _prRooms :: [RoomInt] } + makeLenses ''PosRooms - positionRoomsFromTree :: Tree RoomInt -> IO (Maybe PosRooms) -positionRoomsFromTree (Node (r,i) ts) = printColumnTitles - >> fmap (fmap (prRooms %~ map (first createUnusedLinkPos))) - (posRms (PosRooms (map pointsToPoly $ _rmBound r') []) (r',i) (zipCount ts) Empty) +positionRoomsFromTree (Node (r, i) ts) = + printColumnTitles + >> fmap + (fmap (prRooms %~ map (first createUnusedLinkPos))) + (posRms (PosRooms (map pointsToPoly $ _rmBound r') []) (r', i) (zipCount ts) Empty) where r' = r & rmMID ?~ 0 -posRms :: PosRooms - -> RoomInt - -> [(Int,Tree RoomInt)] -- the list of children, with indices - -> Seq.Seq (Tree RoomInt) - -> IO (Maybe PosRooms) +posRms :: + PosRooms -> + RoomInt -> + [(Int, Tree RoomInt)] -> -- the list of children, with indices + Seq.Seq (Tree RoomInt) -> + IO (Maybe PosRooms) posRms prs roomi [] st = case st of - Empty -> return $ Just $ prs & prRooms .:~ roomi + Empty -> return $ Just $ prs & prRooms .:~ roomi Node nextroomi ts Seq.:<| tseq -> posRms (prs & prRooms .:~ roomi) nextroomi (zipCount ts) tseq _ -> error "unexpected outcome in posRms" -posRms prs parenti@(parent,_) ( (numChild,t@(Node childi _) ):its) tseq = do +posRms prs parenti@(parent, _) ((numChild, t@(Node childi _)) : its) tseq = do printInfoCheckNum parenti numChild childi tryParentLinks outlinks where child = fst childi - outlinks = zipCount - . Prelude.filter (_rmConnectsTo child . _rlType) - $ _rmLinks parent + outlinks = + zipCount + . Prelude.filter (_rmConnectsTo child . _rlType) + $ _rmLinks parent tryParentLinks [] = putStrLn "no viable link pairs, backtrack" >> return Nothing - tryParentLinks ((j,outlnk):ls) = tryChildLinks . zipCount . rmInLinks $ fst childi + tryParentLinks ((j, outlnk) : ls) = tryChildLinks . zipCount . rmInLinks $ fst childi where tryChildLinks [] = tryParentLinks ls - tryChildLinks ((numinlink,il):ils) - | clipping = tryChildLinks ils + tryChildLinks ((numinlink, il) : ils) + | clipping = tryChildLinks ils | otherwise = do putStrLn $ show j ++ "-" ++ show numinlink - mayrs <- posRms - (prs & prBounds .++~ newBounds) - (first updateparent parenti) - its - (tseq |> shiftedt) + mayrs <- + posRms + (prs & prBounds .++~ newBounds) + (first updateparent parenti) + its + (tseq |> shiftedt) case mayrs of Just rms -> return $ Just rms - Nothing -> printInfo parenti numChild childi - >> tryChildLinks ils + Nothing -> + printInfo parenti numChild childi + >> tryChildLinks ils where newBounds = map pointsToPoly . _rmBound . doRoomShift . fst $ rootLabel shiftedt clipping = or (convexPolysOverlap <$> newBounds <*> _prBounds prs) - updateparent rm = _rmLinkEff rm il child numChild outlnk rm - & rmLinks %~ delete outlnk - & rmPos .:~ RoomPos - { _rpPos = fst (lnkPosDir outlnk) - , _rpDir = snd (lnkPosDir outlnk) - , _rpType = S.empty - , _rpLinkStatus = UsedOutLink (_rlType outlnk) numChild (snd childi) - , _rpPlacementUse = 0 - } - & rmChildren .:~ snd childi + updateparent rm = + _rmLinkEff rm il child numChild outlnk rm + & rmLinks %~ delete outlnk + & rmPos + .:~ RoomPos + { _rpPos = fst (lnkPosDir outlnk) + , _rpDir = snd (lnkPosDir outlnk) + , _rpType = S.empty + , _rpLinkStatus = UsedOutLink (_rlType outlnk) numChild (snd childi) + , _rpPlacementUse = 0 + } + & rmChildren .:~ snd childi shiftedoutlink = shiftLinkBy (_rmShift parent) outlnk - updatechild rm = rm - & rmMParent ?~ snd parenti - & rmMID ?~ snd childi - & rmLinks %~ delete il - & rmPos .:~ RoomPos - { _rpPos = fst (lnkPosDir il) - , _rpDir = snd (lnkPosDir il) - , _rpType = S.empty - , _rpLinkStatus = UsedInLink (_rlType il) (snd parenti) - , _rpPlacementUse = 0 - } - shiftedt = over root - (first $ updatechild . shiftRoomShiftToLink (lnkPosDir shiftedoutlink) (lnkPosDir il)) - t + updatechild rm = + rm + & rmMParent ?~ snd parenti + & rmMID ?~ snd childi + & rmLinks %~ delete il + & rmPos + .:~ RoomPos + { _rpPos = fst (lnkPosDir il) + , _rpDir = snd (lnkPosDir il) + , _rpType = S.empty + , _rpLinkStatus = UsedInLink (_rlType il) (snd parenti) + , _rpPlacementUse = 0 + } + shiftedt = + over + root + (first $ updatechild . shiftRoomShiftToLink (lnkPosDir shiftedoutlink) (lnkPosDir il)) + t createUnusedLinkPos :: Room -> Room createUnusedLinkPos rm = rm & rmPos .++~ map f (_rmLinks rm) where - f rl = RoomPos - { _rpPos = _rlPos rl - , _rpDir = _rlDir rl - , _rpType = S.empty - , _rpLinkStatus = UnusedLink $ _rlType rl - , _rpPlacementUse = 0 - } + f rl = + RoomPos + { _rpPos = _rlPos rl + , _rpDir = _rlDir rl + , _rpType = S.empty + , _rpLinkStatus = UnusedLink $ _rlType rl + , _rpPlacementUse = 0 + } -zipCount :: [a] -> [(Int,a)] -zipCount = Prelude.zip [0..] +zipCount :: [a] -> [(Int, a)] +zipCount = Prelude.zip [0 ..] printColumns :: [Int] -> [String] -> IO () printColumns is ss = printPartialColumns is ss >> putStrLn "" printPartialColumns :: [Int] -> [String] -> IO () -printPartialColumns (i:is) (s:strs) = putStr (rightPad i ' ' s) >> printPartialColumns is strs +printPartialColumns (i : is) (s : strs) = putStr (rightPad i ' ' s) >> printPartialColumns is strs printPartialColumns _ strs = putStr $ concat strs theColumns :: [String] -> IO () -theColumns = printColumns [20,5,20,20] +theColumns = printColumns [20, 5, 20, 20] printColumnTitles :: IO () -printColumnTitles = theColumns ["Parent","Cnum","Child","Link pair"] +printColumnTitles = theColumns ["Parent", "Cnum", "Child", "Link pair"] printInfo :: (Show a) => RoomInt -> a -> RoomInt -> IO () -printInfo (parentrm,parenti) childn (childrm,childi) = printPartialColumns - [20,5,20] - [_rmName parentrm ++ "-" ++ show parenti - ,show childn ++ " " - ,_rmName childrm ++ "-" ++ show childi - ] +printInfo (parentrm, parenti) childn (childrm, childi) = + printPartialColumns + [20, 5, 20] + [ _rmName parentrm ++ "-" ++ show parenti + , show childn ++ " " + , _rmName childrm ++ "-" ++ show childi + ] printInfoCheckNum :: (Show a, Eq a, Num a) => RoomInt -> a -> RoomInt -> IO () -printInfoCheckNum (parentrm,parenti) childn (childrm,childi) = printPartialColumns - [20,5,20] - [rname - ,show childn - ,_rmName childrm ++ "-" ++ show childi - ] +printInfoCheckNum (parentrm, parenti) childn (childrm, childi) = + printPartialColumns + [20, 5, 20] + [ rname + , show childn + , _rmName childrm ++ "-" ++ show childi + ] where rname = case childn of 0 -> _rmName parentrm ++ "-" ++ show parenti diff --git a/src/Dodge/Turretoid.hs b/src/Dodge/Turretoid.hs index e3f92703c..0a34088b9 100644 --- a/src/Dodge/Turretoid.hs +++ b/src/Dodge/Turretoid.hs @@ -1,7 +1,8 @@ module Dodge.Turretoid where -import Dodge.Data -import Dodge.Creature.State + import Dodge.Creature.Impulse +import Dodge.Creature.State +import Dodge.Data.World updateTurretoid :: Creature -> World -> World updateTurretoid = stateUpdate followThenClearImpulses diff --git a/src/Dodge/Tweak.hs b/src/Dodge/Tweak.hs index 12157459f..61b24c0b8 100644 --- a/src/Dodge/Tweak.hs +++ b/src/Dodge/Tweak.hs @@ -1,8 +1,7 @@ module Dodge.Tweak where -import Dodge.Data.Item import Control.Lens - +import Dodge.Data.Item doTweak :: TweakType -> Int -> Item -> Item doTweak tt = case tt of @@ -11,6 +10,7 @@ doTweak tt = case tt of TweakSpinDrag -> \i -> itParams . shellSpinDrag .~ i TweakSpinAmount -> \i -> itParams . shellSpinAmount .~ i TweakThrustDelay -> \i -> itParams . shellThrustDelay .~ i + tweakTractionPower :: Int -> Item -> Item tweakTractionPower 0 = itParams . attractionPower .~ 1 tweakTractionPower 1 = itParams . attractionPower .~ -1 diff --git a/src/Dodge/Tweak/Show.hs b/src/Dodge/Tweak/Show.hs index f42359b4d..0169f5aa0 100644 --- a/src/Dodge/Tweak/Show.hs +++ b/src/Dodge/Tweak/Show.hs @@ -1,5 +1,7 @@ module Dodge.Tweak.Show where -import Dodge.Data.Item + +import Dodge.Data.Item.Tweak + showTweak :: TweakParam -> String showTweak tp = case tt of TweakPhaseV -> showPhaseV ct diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 1a9ddce84..a55166ecb 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -19,7 +19,7 @@ import Dodge.Bullet import Dodge.CrGroupUpdate import Dodge.Creature.Update import Dodge.CullBox -import Dodge.Data +import Dodge.Data.Universe import Dodge.Distortion import Dodge.DrWdWd import Dodge.EnergyBall @@ -56,6 +56,7 @@ import Dodge.Zoning.Creature import Geometry import qualified IntMapHelp as IM import LensHelp +import MaybeHelp --import qualified Streaming.Prelude as S import SDL import Sound.Data diff --git a/src/Dodge/Update/Camera.hs b/src/Dodge/Update/Camera.hs index 5c9220847..bea1b8706 100644 --- a/src/Dodge/Update/Camera.hs +++ b/src/Dodge/Update/Camera.hs @@ -1,56 +1,59 @@ -{- Functions controlling the movement of the screen camera: +{- Functions controlling the movement of the screen camera: '_cameraCenter', '_cameraZoom', _cameraRot'; and the position that the character sees from: '_cameraViewFrom'. -} -module Dodge.Update.Camera - ( updateCamera - , farWallPoints - , streamViewpoints - , farWallDistDirection - ) where -import Dodge.Zoning.Wall -import Dodge.Data -import Dodge.Base -import Dodge.Equipment -import Dodge.Creature.Test -import Geometry ---import Geometry.ConvexPoly -import Dodge.GameRoom -import LensHelp -import Bound +module Dodge.Update.Camera ( + updateCamera, + farWallPoints, + streamViewpoints, + farWallDistDirection, +) where +import Bound +import Control.Monad import Data.Foldable import qualified Data.Map.Strict as M import Data.Maybe -import Control.Monad import qualified Data.Set as Set +import Dodge.Base +import Dodge.Creature.Test +import Dodge.Data.Universe +import Dodge.Equipment +import Dodge.GameRoom +import Dodge.Zoning.Wall +import Geometry import qualified IntMapHelp as IM +import LensHelp import qualified SDL --import Data.Monoid --import Data.Semigroup -import qualified Streaming.Prelude as S + import Streaming -{- Update the screen camera rotation and position, including any in rold scope/remote camera modifiers; +import qualified Streaming.Prelude as S + +{- Update the screen camera rotation and position, including any in rold scope/remote camera modifiers; update where your avatar's view is from. -} updateCamera :: Universe -> Universe -updateCamera uv = uv - & over uvWorld (setViewDistance cfig ) - & moveZoomCamera - & over uvWorld updateScopeZoom - & over uvWorld (rotateCamera cfig ) +updateCamera uv = + uv + & over uvWorld (setViewDistance cfig) + & moveZoomCamera + & over uvWorld updateScopeZoom + & over uvWorld (rotateCamera cfig) where cfig = _uvConfig uv moveZoomCamera :: Universe -> Universe -moveZoomCamera uv = uv - & uvWorld . cWorld . cameraCenter .~ newcen - & uvWorld . cWorld . cameraViewFrom .~ newvf - & uvWorld . cWorld . cameraZoom .~ newzoom - & uvWorld . cWorld . defaultZoom .~ newDefaultZoom - & uvWorld . cWorld . itemZoom .~ newItemZoom - where +moveZoomCamera uv = + uv + & uvWorld . cWorld . cameraCenter .~ newcen + & uvWorld . cWorld . cameraViewFrom .~ newvf + & uvWorld . cWorld . cameraZoom .~ newzoom + & uvWorld . cWorld . defaultZoom .~ newDefaultZoom + & uvWorld . cWorld . itemZoom .~ newItemZoom + where cfig = _uvConfig uv w = _uvWorld uv - cpos =_crPos (you w) + cpos = _crPos (you w) newvf = cpos +.+ fromMaybe (V2 0 0) vfoffset vfoffset = do iscam <- yourItem w ^? _Just . itScope . scopeIsCamera @@ -61,67 +64,72 @@ moveZoomCamera uv = uv guard (SDL.ButtonRight `M.member` _mouseButtons w) yourItem w ^? _Just . itScope . scopePos newcen = cpos +.+ fromMaybe (V2 0 0) mscopeoffset +.+ offset - offset = rotateV (_cameraRot (_cWorld w)) $ ((newzoom - newDefaultZoom)/(newDefaultZoom*newzoom)) *.* _mousePos w + offset = rotateV (_cameraRot (_cWorld w)) $ ((newzoom - newDefaultZoom) / (newDefaultZoom * newzoom)) *.* _mousePos w --newzoom = changeZoom (_cameraZoom w) idealZoom' newzoom = case yourItem w ^? _Just . itScope of - Just zs@ZoomScope {} -> _scopeZoom zs + Just zs@ZoomScope{} -> _scopeZoom zs _ -> newDefaultZoom * newItemZoom idealDefaultZoom = clipZoom wallZoom newDefaultZoom = case yourItem w ^? _Just . itScope of - Just zs@ZoomScope {} -> _scopeZoom zs + Just zs@ZoomScope{} -> _scopeZoom zs _ -> changeZoom (_defaultZoom (_cWorld w)) idealDefaultZoom idealItemZoom = fromMaybe 1 $ do guard $ crIsAiming (you w) - zoomFromItem' <$> (yourItem w ^? _Just . itUse . useAim . aimZoom) + zoomFromItem' <$> (yourItem w ^? _Just . itUse . heldAim . aimZoom) newItemZoom = changeZoom (_itemZoom (_cWorld w)) idealItemZoom changeZoom curZoom idealZoom - | curZoom > idealZoom + 0.01 = ((zoomOutSpeed-1)*curZoom + idealZoom) / zoomOutSpeed - | curZoom < idealZoom - 0.01 = ((zoomInSpeed -1)*curZoom + idealZoom) / zoomInSpeed - | otherwise = idealZoom + | curZoom > idealZoom + 0.01 = ((zoomOutSpeed -1) * curZoom + idealZoom) / zoomOutSpeed + | curZoom < idealZoom - 0.01 = ((zoomInSpeed -1) * curZoom + idealZoom) / zoomInSpeed + | otherwise = idealZoom --wallZoom = farWallDist newvf cfig w wallZoom = min4 (_boundDist (_cWorld w)) - min4 (a,b,c,d) = minimum [hh/maxd a,hh/maxd (-b),hw/maxd c,hw/maxd (-d)] + min4 (a, b, c, d) = minimum [hh / maxd a, hh / maxd (- b), hw / maxd c, hw / maxd (- d)] maxd = max distFromEqmnt - distFromEqmnt = foldr max 1 $ IM.mapMaybe (_eqViewDist . _eqEq. _itUse) $ getCrEquipment $ you w - hw = halfWidth cfig + distFromEqmnt = foldr max 1 $ IM.mapMaybe (_eeViewDist . _equipEffect . _itUse) $ getCrEquipment $ you w + hw = halfWidth cfig hh = halfHeight cfig --- = maybe clipZoom zoomFromItem (yourItem w ^? itZoom) wallZoom + -- = maybe clipZoom zoomFromItem (yourItem w ^? itZoom) wallZoom -- these speeds are inverted, larger means slower - zoomInSpeed = 25 + zoomInSpeed = 25 zoomOutSpeed = 15 - updateScopeZoom :: World -> World -updateScopeZoom w - | SDL.ButtonRight `M.member` _mouseButtons w - = case w ^? cWorld . creatures . ix 0 . crInv . ix (crSel (_creatures (_cWorld w) IM.! 0)) - . itScope . scopeZoomChange of - Just x - | x > 10 -> zoomInLongGun $ zoomInLongGun $ zoomInLongGun w - | x > 5 -> zoomInLongGun $ zoomInLongGun w - | x > 0 -> zoomInLongGun w - | x < -10 -> zoomOutLongGun $ zoomOutLongGun $ zoomOutLongGun w - | x < -5 -> zoomOutLongGun $ zoomOutLongGun w - | x < 0 -> zoomOutLongGun w - | otherwise -> w - _ -> w - | otherwise = w & cWorld . creatures . ix 0 . crInv . ix (crSel (_creatures (_cWorld w) IM.! 0)) - . itScope %~ updateScope - where +updateScopeZoom w + | SDL.ButtonRight `M.member` _mouseButtons w = + case w + ^? cWorld . creatures . ix 0 . crInv . ix (crSel (_creatures (_cWorld w) IM.! 0)) + . itScope + . scopeZoomChange of + Just x + | x > 10 -> zoomInLongGun $ zoomInLongGun $ zoomInLongGun w + | x > 5 -> zoomInLongGun $ zoomInLongGun w + | x > 0 -> zoomInLongGun w + | x < -10 -> zoomOutLongGun $ zoomOutLongGun $ zoomOutLongGun w + | x < -5 -> zoomOutLongGun $ zoomOutLongGun w + | x < 0 -> zoomOutLongGun w + | otherwise -> w + _ -> w + | otherwise = + w + & cWorld . creatures . ix 0 . crInv . ix (crSel (_creatures (_cWorld w) IM.! 0)) + . itScope + %~ updateScope + where updateScope (ZoomScope _ _ _ defz bl) = ZoomScope (V2 0 0) 0 defz defz bl updateScope otherAtt = otherAtt zoomSpeed :: Float -zoomSpeed = 39/40 +zoomSpeed = 39 / 40 zoomInLongGun :: World -> World -zoomInLongGun w - | currentZoom < 8 = w - & wpPointer . itScope . scopePos .+.+~ (1-zoomSpeed) / newzoom *.* mousep - & wpPointer . itScope . scopeZoom %~ (/ zoomSpeed) - & decreaseScopeZoomChange +zoomInLongGun w + | currentZoom < 8 = + w + & wpPointer . itScope . scopePos .+.+~ (1 - zoomSpeed) / newzoom *.* mousep + & wpPointer . itScope . scopeZoom %~ (/ zoomSpeed) + & decreaseScopeZoomChange | otherwise = w & wpPointer . itScope . scopeZoomChange .~ 0 - where + where decreaseScopeZoomChange = wpPointer . itScope . scopeZoomChange -~ 1 wpPointer = cWorld . creatures . ix 0 . crInv . ix (crSel (_creatures (_cWorld w) IM.! 0)) wp = _crInv (_creatures (_cWorld w) IM.! 0) IM.! crSel (_creatures (_cWorld w) IM.! 0) @@ -130,14 +138,15 @@ zoomInLongGun w mousep = rotateV (_cameraRot (_cWorld w)) $ _mousePos w zoomOutLongGun :: World -> World -zoomOutLongGun w - | currentZoom > 0.5 = w --- & wpPointer . itScope . scopePos .+.+~ ((1*zoomSpeed-1)) / currentZoom *.* mousep - & wpPointer . itScope . scopeZoom *~ zoomSpeed - & increaseScopeZoomChange --- | otherwise = increaseScopeZoomChange w +zoomOutLongGun w + | currentZoom > 0.5 = + w + -- & wpPointer . itScope . scopePos .+.+~ ((1*zoomSpeed-1)) / currentZoom *.* mousep + & wpPointer . itScope . scopeZoom *~ zoomSpeed + & increaseScopeZoomChange + -- | otherwise = increaseScopeZoomChange w | otherwise = w & wpPointer . itScope . scopeZoomChange .~ 0 - where + where --mousep = rotateV (_cameraRot w) $ _mousePos w increaseScopeZoomChange = wpPointer . itScope . scopeZoomChange +~ 1 wpPointer = cWorld . creatures . ix 0 . crInv . ix (crSel (_creatures (_cWorld w) IM.! 0)) @@ -146,16 +155,17 @@ zoomOutLongGun w ifConfigWallRotate :: Configuration -> World -> World ifConfigWallRotate cfig w - | _gameplay_rotate_to_wall cfig && not (SDL.ButtonRight `M.member` _mouseButtons w) - = rotateToOverlappingWall w + | _gameplay_rotate_to_wall cfig && not (SDL.ButtonRight `M.member` _mouseButtons w) = + rotateToOverlappingWall w | otherwise = w rotateToOverlappingWall :: World -> World -rotateToOverlappingWall w = maybe - id - (doWallRotate . snd) - (overlapCircWallsClosest p (_crRad cr + 5) (filter _wlRotateTo $ wlsNearPoint p w)) - w +rotateToOverlappingWall w = + maybe + id + (doWallRotate . snd) + (overlapCircWallsClosest p (_crRad cr + 5) (filter _wlRotateTo $ wlsNearPoint p w)) + w where cr = you w p = _crPos (you w) @@ -164,24 +174,27 @@ doWallRotate :: Wall -> World -> World doWallRotate wl' w = rotateUsing $ (argV . uncurry (-.-) $ _wlLine wl') - _cameraRot (_cWorld w) where rotateUsing a - | b - b' > 0.01 = w & cWorld . cameraRot +~ 0.01 + | b - b' > 0.01 = w & cWorld . cameraRot +~ 0.01 | b - b' < negate 0.01 = w & cWorld . cameraRot -~ 0.01 - | otherwise = w + | otherwise = w where --b = a * (2 / pi) b = a * (4 / pi) b' = fromIntegral (round b :: Int) rotateCameraBy :: Float -> World -> World -rotateCameraBy x w = w - & cWorld . cameraRot +~ x - & cWorld . creatures . ix 0 . crInv . ix (crSel (_creatures (_cWorld w) IM.! 0)) - . itScope . scopePos %~ rotateV x +rotateCameraBy x w = + w + & cWorld . cameraRot +~ x + & cWorld . creatures . ix 0 . crInv . ix (crSel (_creatures (_cWorld w) IM.! 0)) + . itScope + . scopePos + %~ rotateV x rotateCamera :: Configuration -> World -> World rotateCamera cfig w | keyl && keyr = w - | keyl = rotateCameraBy 0.025 w + | keyl = rotateCameraBy 0.025 w | keyr = rotateCameraBy (-0.025) w | otherwise = ifConfigWallRotate cfig w where @@ -194,49 +207,56 @@ notAtTerminal w = isNothing $ w ^? cWorld . hud . hudElement . subInventory . te --zoomCamBy :: Float -> World -> World --zoomCamBy x w = w {_cameraZoom = max (_cameraZoom w + x) 0.01} -zoomFromItem' - :: ItZoom - -> Float -zoomFromItem' ItZoom {_itZoomMax = zMax, _itZoomMin = zMin, _itZoomFac = zFac} - = min zMax $ max zMin zFac +zoomFromItem' :: + ItZoom -> + Float +zoomFromItem' ItZoom{_itZoomMax = zMax, _itZoomMin = zMin, _itZoomFac = zFac} = + min zMax $ max zMin zFac -clipZoom - :: Float -- ^ Furthest viewable distance - -> Float +clipZoom :: + -- | Furthest viewable distance + Float -> + Float clipZoom = min 20 . max 0.2 setViewDistance :: Configuration -> World -> World -setViewDistance cfig w = w & cWorld . viewDistance - .~ sqrt (halfWidth cfig ** 2 + halfHeight cfig ** 2) / _cameraZoom (_cWorld w) +setViewDistance cfig w = + w & cWorld . viewDistance + .~ sqrt (halfWidth cfig ** 2 + halfHeight cfig ** 2) / _cameraZoom (_cWorld w) + -- .~ max (halfWidth cfig) (halfHeight cfig) / _cameraZoom w streamViewpoints :: Monad m => Point2 -> World -> Stream (Of Point2) m () {-# INLINE streamViewpoints #-} -streamViewpoints p w = flip S.for (gameRoomViewpoints p) - $ S.filter (pointInOrOnPolygon p . _grBound) $ S.each (_gameRooms (_cWorld w)) +streamViewpoints p w = + flip S.for (gameRoomViewpoints p) $ + S.filter (pointInOrOnPolygon p . _grBound) $ S.each (_gameRooms (_cWorld w)) gameRoomViewpoints :: Monad m => Point2 -> GameRoom -> Stream (Of Point2) m () -gameRoomViewpoints p gr = S.each (_grViewpoints gr) - <> S.map extend (S.each (_grViewpointsEx gr) <> S.map addDir (S.each $ _grLinkDirs gr)) +gameRoomViewpoints p gr = + S.each (_grViewpoints gr) + <> S.map extend (S.each (_grViewpointsEx gr) <> S.map addDir (S.each $ _grLinkDirs gr)) where extend outp = p +.+ maxViewDistance *.* squashNormalizeV (outp -.- p) addDir a = p +.+ unitVectorAtAngle a -farWallDistDirection :: Point2 -> World -> Maybe (Float,Float,Float,Float) -farWallDistDirection p w = boundPoints - $ S.map f vps +farWallDistDirection :: Point2 -> World -> Maybe (Float, Float, Float, Float) +farWallDistDirection p w = + boundPoints $ + S.map f vps where f q = (rotateV (negate $ _cameraRot (_cWorld w)) . (-.- p)) (foldl' findPoint q (wls q)) wls q = filter wlIsOpaque $ wlsNearSeg p q w findPoint q = fromMaybe q . uncurry (intersectSegSeg p q) . _wlLine vps = streamViewpoints p w - extendedViewPoints :: Point2 -> [GameRoom] -> [Point2] -extendedViewPoints p grs = map extend - (concatMap _grViewpointsEx grs - ++ map addDir (concatMap _grLinkDirs grs) - ) +extendedViewPoints p grs = + map + extend + ( concatMap _grViewpointsEx grs + ++ map addDir (concatMap _grLinkDirs grs) + ) where extend outp = p +.+ maxViewDistance *.* squashNormalizeV (outp -.- p) addDir a = p +.+ unitVectorAtAngle a diff --git a/src/Dodge/Update/Cloud.hs b/src/Dodge/Update/Cloud.hs index afca35086..582b84465 100644 --- a/src/Dodge/Update/Cloud.hs +++ b/src/Dodge/Update/Cloud.hs @@ -1,15 +1,18 @@ module Dodge.Update.Cloud where + +import Data.Foldable +import Dodge.Data.World import Dodge.Zoning.Creature -import Dodge.Data import Geometry.Vector3D import LensHelp -import Data.Foldable + cloudPoisonDamage :: Cloud -> World -> World cloudPoisonDamage c w = w & dodamagesto (filter f $ crsNearPoint clpos w) - where + where dodamagesto :: [Creature] -> World -> World dodamagesto scrs mcrs = foldl' (flip doDam) mcrs scrs - doDam cr = cWorld . creatures . ix (_crID cr) . crState . csDamage - .:~ Damage POISONDAM 1 clpos clpos clpos NoDamageEffect + doDam cr = + cWorld . creatures . ix (_crID cr) . crState . csDamage + .:~ Damage POISONDAM 1 clpos clpos clpos NoDamageEffect f cr = dist3 (addZ 20 $ _crPos cr) (_clPos c) < _crRad cr + _clRad c + 10 clpos = stripZ $ _clPos c diff --git a/src/Dodge/Update/UsingInput.hs b/src/Dodge/Update/UsingInput.hs index 9e6da8949..1dbb5d814 100644 --- a/src/Dodge/Update/UsingInput.hs +++ b/src/Dodge/Update/UsingInput.hs @@ -1,48 +1,48 @@ {- Functions that affect the world according to what pressed buttons are stored in a Set. -} -module Dodge.Update.UsingInput - ( updateUsingInput - ) where -import Dodge.Terminal.LeftButton -import Dodge.Data +module Dodge.Update.UsingInput ( + updateUsingInput, +) where + +import Control.Lens +import qualified Data.Map.Strict as M import Dodge.Base.You -import Dodge.Creature.Impulse.UseItem -import Dodge.InputFocus import Dodge.Combine +import Dodge.Creature.Impulse.UseItem +import Dodge.Data.World +import Dodge.InputFocus import Dodge.Inventory import Dodge.Inventory.Add +import Dodge.Terminal.LeftButton import Geometry - import ListHelp import SDL ---import qualified Data.Set as S -import qualified Data.Map.Strict as M -import Control.Lens updateUsingInput :: World -> World updateUsingInput w = case _hudElement $ _hud (_cWorld w) of - DisplayInventory subinv - -> updatePressedButtons subinv (_mouseButtons w) w - DisplayCarte - -> updatePressedButtonsCarte (_mouseButtons w) w + DisplayInventory subinv -> + updatePressedButtons subinv (_mouseButtons w) w + DisplayCarte -> + updatePressedButtonsCarte (_mouseButtons w) w updatePressedButtons :: SubInventory -> M.Map MouseButton Bool -> World -> World updatePressedButtons subinv pkeys w = case subinv of NoSubInventory - | ButtonLeft `M.member` pkeys && w ^?! hammers . ix SubInvHam /= HammerUp - -> w & hammers . ix SubInvHam .~ HammerDown + | ButtonLeft `M.member` pkeys && w ^?! hammers . ix SubInvHam /= HammerUp -> + w & hammers . ix SubInvHam .~ HammerDown | otherwise -> updatePressedButtons' pkeys w CombineInventory mi - | pkeys ^? ix ButtonLeft == Just False - -> maybeexitcombine (maybe id doCombine mi w) & hammers . ix SubInvHam .~ HammerDown + | pkeys ^? ix ButtonLeft == Just False -> + maybeexitcombine (maybe id doCombine mi w) & hammers . ix SubInvHam .~ HammerDown DisplayTerminal tmid - | pkeys ^? ix ButtonLeft == Just False && inTermFocus w - -> doTerminalEffectLB (w ^?! cWorld . terminals . ix tmid) w - & hammers . ix SubInvHam .~ HammerDown - | pkeys ^? ix ButtonLeft == Just False - -> w & cWorld . terminals . ix tmid . tmInput . tiFocus %~ const True - & hammers . ix SubInvHam .~ HammerDown - _ | ButtonLeft `M.member` pkeys - -> w & hammers . ix SubInvHam .~ HammerDown + | pkeys ^? ix ButtonLeft == Just False && inTermFocus w -> + doTerminalEffectLB (w ^?! cWorld . terminals . ix tmid) w + & hammers . ix SubInvHam .~ HammerDown + | pkeys ^? ix ButtonLeft == Just False -> + w & cWorld . terminals . ix tmid . tmInput . tiFocus %~ const True + & hammers . ix SubInvHam .~ HammerDown + _ + | ButtonLeft `M.member` pkeys -> + w & hammers . ix SubInvHam .~ HammerDown _ -> w where maybeexitcombine @@ -50,55 +50,56 @@ updatePressedButtons subinv pkeys w = case subinv of | otherwise = cWorld . hud . hudElement .~ DisplayInventory NoSubInventory updatePressedButtons' :: M.Map MouseButton Bool -> World -> World -updatePressedButtons' pkeys w - | isDown ButtonLeft && isDown ButtonRight && inTopInv - = useItem (you w) w & hammers . ix DoubleMouseHam .~ HammerDown +updatePressedButtons' pkeys w + | isDown ButtonLeft && isDown ButtonRight && inTopInv = + useItem (you w) w & hammers . ix DoubleMouseHam .~ HammerDown | isDown ButtonLeft && (inTopInv || _timeFlow w == RewindingLastFrame) - && w ^?! hammers . ix DoubleMouseHam == HammerUp - = useLeftItem (_yourID (_cWorld w)) w - | isDown ButtonLeft && (inTopInv || _timeFlow w == RewindingLastFrame) - = w & hammers . ix DoubleMouseHam .~ HammerDown + && w ^?! hammers . ix DoubleMouseHam == HammerUp = + useLeftItem (_yourID (_cWorld w)) w + | isDown ButtonLeft && (inTopInv || _timeFlow w == RewindingLastFrame) = + w & hammers . ix DoubleMouseHam .~ HammerDown | isDown ButtonRight && inTopInv = w - | isDown ButtonMiddle - = w & cWorld . cameraRot -~ rotation - & cWorld . clickMousePos .~ _mousePos w + | isDown ButtonMiddle = + w & cWorld . cameraRot -~ rotation + & cWorld . clickMousePos .~ _mousePos w | isDown ButtonLeft = w & hammers . ix DoubleMouseHam .~ HammerDown | otherwise = w - where + where inTopInv = case _hudElement (_hud (_cWorld w)) of DisplayInventory NoSubInventory -> True _ -> False isDown but = but `M.member` pkeys rotation = angleBetween (_mousePos w) (_clickMousePos (_cWorld w)) - -- note "sort" on the inventory indices; otherwise -- lower items may be shifted up and items below these removed instead doCombine :: Int -> World -> World doCombine i w = case combineItemListYou w ^? ix i of Nothing -> w - Just (is,it) -> -- set (hud . hudElement) (DisplayInventory NoSubInventory) + Just (is, it) -> + -- set (hud . hudElement) (DisplayInventory NoSubInventory) selectinv --enterCombineInv - . createPutItem it - $ foldr (rmInvItem yid) w (sort is) + . createPutItem it + $ foldr (rmInvItem yid) w (sort is) where yid = _yourID (_cWorld w) selectinv (Just i', w') = w' & cWorld . creatures . ix yid . crInvSel .~ InvSel i' NoInvSelAction selectinv (Nothing, w') = w' - updatePressedButtonsCarte :: M.Map MouseButton Bool -> World -> World -updatePressedButtonsCarte pkeys w - | isDown ButtonRight = w - & cWorld . clickMousePos .~ _mousePos w - & cWorld . hud . carteCenter %~ (-.- trans) - | isDown ButtonLeft = w - & cWorld . clickMousePos .~ _mousePos w - & cWorld . hud . carteRot -~ rot - & cWorld . hud . carteZoom *~ czoom +updatePressedButtonsCarte pkeys w + | isDown ButtonRight = + w + & cWorld . clickMousePos .~ _mousePos w + & cWorld . hud . carteCenter %~ (-.- trans) + | isDown ButtonLeft = + w + & cWorld . clickMousePos .~ _mousePos w + & cWorld . hud . carteRot -~ rot + & cWorld . hud . carteZoom *~ czoom | otherwise = w - where + where isDown but = but `M.member` pkeys - rot = angleBetween (_mousePos w) (_clickMousePos (_cWorld w)) + rot = angleBetween (_mousePos w) (_clickMousePos (_cWorld w)) czoom = magV (_mousePos w) / magV (_clickMousePos (_cWorld w)) trans = rotateV (_carteRot (_hud (_cWorld w))) $ 1 / _carteZoom (_hud (_cWorld w)) *.* (_mousePos w -.- _clickMousePos (_cWorld w)) diff --git a/src/Dodge/Update/WallDamage.hs b/src/Dodge/Update/WallDamage.hs index 5383d2756..f28b599c1 100644 --- a/src/Dodge/Update/WallDamage.hs +++ b/src/Dodge/Update/WallDamage.hs @@ -1,15 +1,16 @@ module Dodge.Update.WallDamage where -import Dodge.Wall.Damage -import Dodge.Data -import qualified IntMapHelp as IM import Control.Lens import Data.Maybe +import Dodge.Data.World +import Dodge.Wall.Damage +import qualified IntMapHelp as IM updateWallDamages :: World -> World -updateWallDamages w = w - & cWorld . wallDamages .~ IM.empty - & flip (IM.foldrWithKey f) (_wallDamages (_cWorld w)) +updateWallDamages w = + w + & cWorld . wallDamages .~ IM.empty + & flip (IM.foldrWithKey f) (_wallDamages (_cWorld w)) where f k dams w' = fromMaybe w' $ do wl <- w' ^? cWorld . walls . ix k diff --git a/src/Dodge/Wall/Create.hs b/src/Dodge/Wall/Create.hs index 368194f4b..348b92799 100644 --- a/src/Dodge/Wall/Create.hs +++ b/src/Dodge/Wall/Create.hs @@ -1,16 +1,16 @@ -module Dodge.Wall.Create - where -import Dodge.Data -import Dodge.Wall.Zone +module Dodge.Wall.Create where import Control.Lens +import Dodge.Data.World +import Dodge.Wall.Zone import qualified IntMapHelp as IM -createWall :: Wall -> World -> (Int,World) -createWall wl w = (wlid +createWall :: Wall -> World -> (Int, World) +createWall wl w = + ( wlid , w & cWorld . walls %~ IM.insert wlid newwl & insertWallInZones newwl ) where - newwl = wl {_wlID = wlid} + newwl = wl{_wlID = wlid} wlid = IM.newKey $ _walls (_cWorld w) diff --git a/src/Dodge/Wall/Damage.hs b/src/Dodge/Wall/Damage.hs index 28481fc8a..7162a095e 100644 --- a/src/Dodge/Wall/Damage.hs +++ b/src/Dodge/Wall/Damage.hs @@ -1,37 +1,42 @@ {- | Controls a walls response to external damage. - Indestructible walls may still produce sparks, dust etc - -} -module Dodge.Wall.Damage - ( damageBlocksBy - , damageWall - ) where -import Dodge.Data +-} +module Dodge.Wall.Damage ( + damageBlocksBy, + damageWall, +) where + import Dodge.Block -import LensHelp +import Dodge.Data.World import Dodge.Wall.DamageEffect +import LensHelp damageWall :: Damage -> Wall -> World -> World damageWall dt wl w = case _wlStructure wl of - MachinePart mcid -> fst . defaultWallDamage dt wl $ w - & cWorld . machines . ix mcid . mcDamage .:~ dt - BlockPart blid -> let (w',x) = defaultWallDamage dt wl w - in w' & cWorld . blocks . ix blid . blHP -~ x & maybeDestroyBlock blid - DoorPart drid -> let (w',x) = defaultWallDamage dt wl w - in w' & cWorld . doors . ix drid . drHP -~ x & maybeDestroyDoor drid - _ -> fst $ defaultWallDamage dt wl w + MachinePart mcid -> + fst . defaultWallDamage dt wl $ + w + & cWorld . machines . ix mcid . mcDamage .:~ dt + BlockPart blid -> + let (w', x) = defaultWallDamage dt wl w + in w' & cWorld . blocks . ix blid . blHP -~ x & maybeDestroyBlock blid + DoorPart drid -> + let (w', x) = defaultWallDamage dt wl w + in w' & cWorld . doors . ix drid . drHP -~ x & maybeDestroyDoor drid + _ -> fst $ defaultWallDamage dt wl w -- block destruction is convoluted... maybeDestroyBlock :: Int -> World -> World maybeDestroyBlock blid w = case w ^? cWorld . blocks . ix blid of - Just bl | _blHP bl < 1 -> destroyBlock bl w + Just bl | _blHP bl < 1 -> destroyBlock bl w _ -> w maybeDestroyDoor :: Int -> World -> World maybeDestroyDoor drid w = case w ^? cWorld . doors . ix drid of - Just dr | _drHP dr < 1 -> destroyDoor dr w + Just dr | _drHP dr < 1 -> destroyDoor dr w _ -> w damageBlocksBy :: Int -> Wall -> World -> World damageBlocksBy x wl = case wl ^? wlStructure . wsBlock of Just blid -> cWorld . blocks . ix blid . blHP -~ x - Nothing -> id + Nothing -> id diff --git a/src/Dodge/Wall/DamageEffect.hs b/src/Dodge/Wall/DamageEffect.hs index 2b8cf8f54..789184e06 100644 --- a/src/Dodge/Wall/DamageEffect.hs +++ b/src/Dodge/Wall/DamageEffect.hs @@ -1,42 +1,43 @@ module Dodge.Wall.DamageEffect where -import Dodge.Data -import Dodge.Spark + import Dodge.Base.Wall -import Dodge.Wall.Dust import Dodge.Block +import Dodge.Data.World +import Dodge.Spark +import Dodge.Wall.Dust import Geometry import LensHelp -defaultWallDamage :: Damage -> Wall -> World -> (World,Int) +defaultWallDamage :: Damage -> Wall -> World -> (World, Int) defaultWallDamage dm wl = case _wlMaterial wl of - Stone -> stoneWallDamage dm wl - Glass -> windowWallDamage dm wl - Dirt -> dirtWallDamage dm wl + Stone -> stoneWallDamage dm wl + Glass -> windowWallDamage dm wl + Dirt -> dirtWallDamage dm wl Crystal -> crystalWallDamage dm wl - Metal -> stoneWallDamage dm wl - Wood -> stoneWallDamage dm wl + Metal -> stoneWallDamage dm wl + Wood -> stoneWallDamage dm wl Electronics -> stoneWallDamage dm wl Flesh -> stoneWallDamage dm wl -stoneWallDamage :: Damage -> Wall -> World -> (World,Int) +stoneWallDamage :: Damage -> Wall -> World -> (World, Int) stoneWallDamage dm wl = case _dmType dm of - LASERING -> a 0 $ colSparkRandDir 0.2 lSparkCol outTo (reflDirWall sp p wl) - PIERCING -> a d $ colSparkRandDir 0.2 pSparkCol outTo (reflDirWall sp p wl) . wlDustAt wl outTo - BLUNT -> a d $ wlDustAt wl outTo - SHATTERING -> a d $ muchWlDustAt wl outTo - CRUSHING -> a d id - EXPLOSIVE -> a d id - CUTTING -> a d id - SPARKING -> a 0 id - FLAMING -> a 0 id - ELECTRICAL -> a 0 id - CONCUSSIVE -> a d id - TORQUEDAM -> a 0 id - PUSHDAM -> a 0 id - POISONDAM -> a 0 id + LASERING -> a 0 $ colSparkRandDir 0.2 lSparkCol outTo (reflDirWall sp p wl) + PIERCING -> a d $ colSparkRandDir 0.2 pSparkCol outTo (reflDirWall sp p wl) . wlDustAt wl outTo + BLUNT -> a d $ wlDustAt wl outTo + SHATTERING -> a d $ muchWlDustAt wl outTo + CRUSHING -> a d id + EXPLOSIVE -> a d id + CUTTING -> a d id + SPARKING -> a 0 id + FLAMING -> a 0 id + ELECTRICAL -> a 0 id + CONCUSSIVE -> a d id + TORQUEDAM -> a 0 id + PUSHDAM -> a 0 id + POISONDAM -> a 0 id ENTERREMENT -> a 0 id where - a x f w = (f w,x) + a x f w = (f w, x) d = _dmAmount dm sp = _dmFrom dm p = _dmAt dm @@ -44,31 +45,32 @@ stoneWallDamage dm wl = case _dmType dm of pSparkCol = V4 5 1 0.5 2 lSparkCol = V4 20 (-5) 0 1 -windowWallDamage :: Damage -> Wall -> World -> (World,Int) -windowWallDamage dm wl w = w & case _dmType dm of - LASERING -> a 0 $ colSparkRandDir 0.2 lSparkCol outTo (reflDirWall sp p wl) - PIERCING -> a d $ dosplint . colSparkRandDir 0.2 pSparkCol outTo (reflDirWall sp p wl) . wlDustAt wl outTo - BLUNT -> a d $ dosplint . wlDustAt wl outTo - SHATTERING -> a d $ dosplint . muchWlDustAt wl outTo - CRUSHING -> a d dosplint - EXPLOSIVE -> a d dosplint - CUTTING -> a d dosplint - SPARKING -> a 0 id - FLAMING -> a 0 id - ELECTRICAL -> a 0 id - CONCUSSIVE -> a 0 dosplint - TORQUEDAM -> a 0 id - PUSHDAM -> a 0 id - POISONDAM -> a 0 id - ENTERREMENT -> a 0 id +windowWallDamage :: Damage -> Wall -> World -> (World, Int) +windowWallDamage dm wl w = + w & case _dmType dm of + LASERING -> a 0 $ colSparkRandDir 0.2 lSparkCol outTo (reflDirWall sp p wl) + PIERCING -> a d $ dosplint . colSparkRandDir 0.2 pSparkCol outTo (reflDirWall sp p wl) . wlDustAt wl outTo + BLUNT -> a d $ dosplint . wlDustAt wl outTo + SHATTERING -> a d $ dosplint . muchWlDustAt wl outTo + CRUSHING -> a d dosplint + EXPLOSIVE -> a d dosplint + CUTTING -> a d dosplint + SPARKING -> a 0 id + FLAMING -> a 0 id + ELECTRICAL -> a 0 id + CONCUSSIVE -> a 0 dosplint + TORQUEDAM -> a 0 id + PUSHDAM -> a 0 id + POISONDAM -> a 0 id + ENTERREMENT -> a 0 id where - mbl = do + mbl = do blid <- wl ^? wlStructure . wsBlock w ^? cWorld . blocks . ix blid d :: Int d = max 1 $ maybe 1 (subtract 1 . _blHP) mbl - a :: Int -> (World -> World) -> World -> (World,Int) - a x f w' = (f w',x) + a :: Int -> (World -> World) -> World -> (World, Int) + a x f w' = (f w', x) dosplint = maybe id splinterBlock mbl sp = _dmFrom dm p = _dmAt dm @@ -76,25 +78,25 @@ windowWallDamage dm wl w = w & case _dmType dm of pSparkCol = V4 5 1 0.5 2 lSparkCol = V4 20 (-5) 0 1 -crystalWallDamage :: Damage -> Wall -> World -> (World,Int) +crystalWallDamage :: Damage -> Wall -> World -> (World, Int) crystalWallDamage dm wl = case _dmType dm of - LASERING -> a 0 $ colSparkRandDir 0.2 lSparkCol outTo (reflDirWall sp p wl) - PIERCING -> a 0 $ colSparkRandDir 0.2 pSparkCol outTo (reflDirWall sp p wl) . wlDustAt wl outTo - BLUNT -> a 0 $ wlDustAt wl outTo - SHATTERING -> a d $ muchWlDustAt wl outTo - CRUSHING -> a 0 id - EXPLOSIVE -> a 0 id - CUTTING -> a 0 id - SPARKING -> a 0 id - FLAMING -> a 0 id - ELECTRICAL -> a 0 id - CONCUSSIVE -> a 0 id - TORQUEDAM -> a 0 id - PUSHDAM -> a 0 id - POISONDAM -> a 0 id + LASERING -> a 0 $ colSparkRandDir 0.2 lSparkCol outTo (reflDirWall sp p wl) + PIERCING -> a 0 $ colSparkRandDir 0.2 pSparkCol outTo (reflDirWall sp p wl) . wlDustAt wl outTo + BLUNT -> a 0 $ wlDustAt wl outTo + SHATTERING -> a d $ muchWlDustAt wl outTo + CRUSHING -> a 0 id + EXPLOSIVE -> a 0 id + CUTTING -> a 0 id + SPARKING -> a 0 id + FLAMING -> a 0 id + ELECTRICAL -> a 0 id + CONCUSSIVE -> a 0 id + TORQUEDAM -> a 0 id + PUSHDAM -> a 0 id + POISONDAM -> a 0 id ENTERREMENT -> a 0 id where - a x f w = (f w,x) + a x f w = (f w, x) d = _dmAmount dm sp = _dmFrom dm p = _dmAt dm @@ -102,25 +104,25 @@ crystalWallDamage dm wl = case _dmType dm of pSparkCol = V4 5 1 0.5 2 lSparkCol = V4 20 (-5) 0 1 -dirtWallDamage :: Damage -> Wall -> World -> (World,Int) +dirtWallDamage :: Damage -> Wall -> World -> (World, Int) dirtWallDamage dm wl = case _dmType dm of - LASERING -> a d $ wlDustAt wl outTo - PIERCING -> a d $ wlDustAt wl outTo - BLUNT -> a d $ wlDustAt wl outTo - SHATTERING -> a d $ muchWlDustAt wl outTo - CRUSHING -> a d $ wlDustAt wl outTo - EXPLOSIVE -> a d $ muchWlDustAt wl outTo - CUTTING -> a d $ muchWlDustAt wl outTo - SPARKING -> a 0 id - FLAMING -> a 0 id - ELECTRICAL -> a 0 id - CONCUSSIVE -> a d id - TORQUEDAM -> a 0 id - PUSHDAM -> a 0 id - POISONDAM -> a 0 id + LASERING -> a d $ wlDustAt wl outTo + PIERCING -> a d $ wlDustAt wl outTo + BLUNT -> a d $ wlDustAt wl outTo + SHATTERING -> a d $ muchWlDustAt wl outTo + CRUSHING -> a d $ wlDustAt wl outTo + EXPLOSIVE -> a d $ muchWlDustAt wl outTo + CUTTING -> a d $ muchWlDustAt wl outTo + SPARKING -> a 0 id + FLAMING -> a 0 id + ELECTRICAL -> a 0 id + CONCUSSIVE -> a d id + TORQUEDAM -> a 0 id + PUSHDAM -> a 0 id + POISONDAM -> a 0 id ENTERREMENT -> a 0 id where - a x f w = (f w,x) + a x f w = (f w, x) d = _dmAmount dm sp = _dmFrom dm p = _dmAt dm diff --git a/src/Dodge/Wall/Delete.hs b/src/Dodge/Wall/Delete.hs index e73899a8c..863e1e5f0 100644 --- a/src/Dodge/Wall/Delete.hs +++ b/src/Dodge/Wall/Delete.hs @@ -1,23 +1,25 @@ -module Dodge.Wall.Delete - ( deleteWallIDs - , deleteWallID - ) where -import Dodge.Data -import Dodge.Wall.Zone +module Dodge.Wall.Delete ( + deleteWallIDs, + deleteWallID, +) where import Control.Lens -import qualified IntMapHelp as IM import qualified Data.IntSet as IS +import Dodge.Data.World +import Dodge.Wall.Zone +import qualified IntMapHelp as IM deleteWallID :: Int -> World -> World -deleteWallID i w = w & cWorld . walls %~ IM.delete i - & deleteWallFromZones wl +deleteWallID i w = + w & cWorld . walls %~ IM.delete i + & deleteWallFromZones wl where wl = _walls (_cWorld w) IM.! i deleteWall :: Wall -> World -> World -deleteWall wl = (cWorld . walls %~ IM.delete i) - . deleteWallFromZones wl +deleteWall wl = + (cWorld . walls %~ IM.delete i) + . deleteWallFromZones wl where i = _wlID wl diff --git a/src/Dodge/Wall/Draw.hs b/src/Dodge/Wall/Draw.hs index eb32a4f4b..5bfaf89ba 100644 --- a/src/Dodge/Wall/Draw.hs +++ b/src/Dodge/Wall/Draw.hs @@ -1,18 +1,20 @@ module Dodge.Wall.Draw where + import Dodge.Data.Wall -import ShapePicture import Picture.Base +import ShapePicture drawWall :: WallDraw -> Wall -> SPic drawWall wd = case wd of DrawForceField -> drawForceField drawForceField :: Wall -> SPic -drawForceField wl = (mempty +drawForceField wl = + ( mempty , setLayer BloomLayer . setDepth 20 . color (_wlColor wl) - $ thickLine 5 [a,b] + $ thickLine 5 [a, b] ) where - (a,b) = _wlLine wl + (a, b) = _wlLine wl diff --git a/src/Dodge/Wall/Dust.hs b/src/Dodge/Wall/Dust.hs index 2472134b5..cf3b51621 100644 --- a/src/Dodge/Wall/Dust.hs +++ b/src/Dodge/Wall/Dust.hs @@ -1,8 +1,9 @@ module Dodge.Wall.Dust where -import Dodge.Data + +import Control.Lens +import Dodge.Data.World import Dodge.WorldEvent.Cloud import Geometry -import Control.Lens import RandomHelp wlDustAt :: Wall -> Point2 -> World -> World @@ -11,12 +12,12 @@ wlDustAt wl = smokeCloudAt dustcol 20 200 1 . addZ 20 dustcol = _wlColor wl & _4 .~ 1 muchWlDustAt :: Wall -> Point2 -> World -> World -muchWlDustAt wl p = flip (foldr f) [10,20..100] +muchWlDustAt wl p = flip (foldr f) [10, 20 .. 100] where - f h w = w - & smokeCloudAt dustcol 20 200 1 (addZ h (p +.+ off)) - & randGen .~ g + f h w = + w + & smokeCloudAt dustcol 20 200 1 (addZ h (p +.+ off)) + & randGen .~ g where - (off,g) = runState (randInCirc 1) (_randGen w) + (off, g) = runState (randInCirc 1) (_randGen w) dustcol = _wlColor wl & _4 .~ 1 - diff --git a/src/Dodge/Wall/ForceField.hs b/src/Dodge/Wall/ForceField.hs index 1a2846f0d..85ccc9b04 100644 --- a/src/Dodge/Wall/ForceField.hs +++ b/src/Dodge/Wall/ForceField.hs @@ -1,18 +1,19 @@ module Dodge.Wall.ForceField where -import Dodge.Data -import Dodge.Default.Wall + import Color +import Dodge.Data.Wall +import Dodge.Default.Wall forceField :: Wall -forceField = defaultWall - {_wlColor = orange - ,_wlOpacity = DrawnWall DrawForceField - ,_wlPathable = True - ,_wlWalkable = True - ,_wlFireThrough = True - ,_wlReflect = True - ,_wlUnshadowed = True - ,_wlRotateTo = False - ,_wlStructure = StandaloneWall - } - +forceField = + defaultWall + { _wlColor = orange + , _wlOpacity = DrawnWall DrawForceField + , _wlPathable = True + , _wlWalkable = True + , _wlFireThrough = True + , _wlReflect = True + , _wlUnshadowed = True + , _wlRotateTo = False + , _wlStructure = StandaloneWall + } diff --git a/src/Dodge/Wall/Move.hs b/src/Dodge/Wall/Move.hs index f1d3dfff6..2ab6d0081 100644 --- a/src/Dodge/Wall/Move.hs +++ b/src/Dodge/Wall/Move.hs @@ -1,47 +1,51 @@ {-# LANGUAGE BangPatterns #-} -module Dodge.Wall.Move - ( moveWallID - , moveWallIDUnsafe - , moveWall - , moveWallIDToward - , translateWallID - , mvPs - ) where -import Dodge.Data -import Dodge.Base -import Geometry -import Dodge.Wall.Zone -import Data.Maybe +module Dodge.Wall.Move ( + moveWallID, + moveWallIDUnsafe, + moveWall, + moveWallIDToward, + translateWallID, + mvPs, +) where + import Control.Lens +import Data.Maybe +import Dodge.Base +import Dodge.Data.World +import Dodge.Wall.Zone +import Geometry import qualified IntMapHelp as IM -moveWallIDUnsafe :: Int -> (Point2,Point2) -> World -> World +moveWallIDUnsafe :: Int -> (Point2, Point2) -> World -> World moveWallIDUnsafe wlid wlline w = case w ^? cWorld . walls . ix wlid of Nothing -> error "tried moving nonexistant wall" Just wl -> moveWall wlid wl wlline w -moveWallID :: Int -> (Point2,Point2) -> World -> World +moveWallID :: Int -> (Point2, Point2) -> World -> World moveWallID wlid wlline w = case w ^? cWorld . walls . ix wlid of Nothing -> w Just wl -> moveWall wlid wl wlline w -moveWall :: Int -> Wall -> (Point2,Point2) -> World -> World -moveWall wlid wl wlline w = w & cWorld . walls . ix wlid .~ newwl - & deleteWallFromZones wl - & insertWallInZones newwl + +moveWall :: Int -> Wall -> (Point2, Point2) -> World -> World +moveWall wlid wl wlline w = + w & cWorld . walls . ix wlid .~ newwl + & deleteWallFromZones wl + & insertWallInZones newwl where - newwl = wl {_wlLine = wlline} + newwl = wl{_wlLine = wlline} translateWallID :: Int -> Point2 -> World -> World translateWallID wlid p w = fromMaybe w $ do oldwl <- w ^? cWorld . walls . ix wlid let newwl = oldwl & wlLine . each +~ p - return $ w - & cWorld . walls . ix wlid .~ newwl - & deleteWallFromZones oldwl - & insertWallInZones newwl + return $ + w + & cWorld . walls . ix wlid .~ newwl + & deleteWallFromZones oldwl + & insertWallInZones newwl -moveWallIDToward :: Int -> Float -> (Point2,Point2) -> World -> World +moveWallIDToward :: Int -> Float -> (Point2, Point2) -> World -> World moveWallIDToward wlid speed ep w = moveWall wlid wl newwlline w where wl = _walls (_cWorld w) IM.! wlid @@ -51,6 +55,6 @@ mvP :: Float -> Point2 -> Point2 -> Point2 {-# INLINE mvP #-} mvP !speed !ep !p = mvPointTowardAtSpeed speed ep p -mvPs :: Float -> (Point2,Point2) -> (Point2,Point2) -> (Point2,Point2) +mvPs :: Float -> (Point2, Point2) -> (Point2, Point2) -> (Point2, Point2) {-# INLINE mvPs #-} -mvPs !speed (!ex,!ey) (!sx,!sy) = (mvP speed ex sx,mvP speed ey sy) +mvPs !speed (!ex, !ey) (!sx, !sy) = (mvP speed ex sx, mvP speed ey sy) diff --git a/src/Dodge/Wall/Zone.hs b/src/Dodge/Wall/Zone.hs index 8787c3b95..766d3bcde 100644 --- a/src/Dodge/Wall/Zone.hs +++ b/src/Dodge/Wall/Zone.hs @@ -1,10 +1,8 @@ -module Dodge.Wall.Zone - where -import Dodge.Zoning.Wall -import Dodge.Data +module Dodge.Wall.Zone where ---import qualified Data.IntSet as IS import Control.Lens +import Dodge.Data.World +import Dodge.Zoning.Wall -- need to verify that this not only inserts but also overwrites (updates) any -- already existing walls @@ -19,4 +17,5 @@ insertWallInZones wl = cWorld . wlZoning %~ zoneWall wl deleteWallFromZones :: Wall -> World -> World deleteWallFromZones wl = cWorld . wlZoning %~ deZoneWall wl + -- %~ flip (foldl' (flip $ \(a,b) updateeIMInZone a b (_wlID wl))) (zoneOfWall wl) diff --git a/src/Dodge/WallCreatureCollisions.hs b/src/Dodge/WallCreatureCollisions.hs index ab0f8a626..d24ff507b 100644 --- a/src/Dodge/WallCreatureCollisions.hs +++ b/src/Dodge/WallCreatureCollisions.hs @@ -1,66 +1,70 @@ -{- | Deals with moving creature wall collisions. -} -module Dodge.WallCreatureCollisions - ( colCrsWalls - , colCrWall - , pushCreatureOutFromWalls - , crOnWall - ) where -import Dodge.Zoning.Wall -import Dodge.Data -import Dodge.Base -import Geometry +-- | Deals with moving creature wall collisions. +module Dodge.WallCreatureCollisions ( + colCrsWalls, + colCrWall, + pushCreatureOutFromWalls, + crOnWall, +) where -import Data.Monoid -import Data.Maybe -import Data.Function import Control.Lens +import Data.Maybe +import Data.Monoid +import Dodge.Base +import Dodge.Data.Universe +import Dodge.Zoning.Wall +import Geometry colCrsWalls :: Universe -> Universe colCrsWalls uv = uv & uvWorld . cWorld . creatures %~ fmap (noclipCheck (_uvConfig uv) (_uvWorld uv)) noclipCheck :: Configuration -> World -> Creature -> Creature -noclipCheck cfig w c +noclipCheck cfig w c | debugOn Noclip cfig && _crID c == 0 = c -- for noclip | otherwise = colCrWall w c -- no noclip check, so no need for a configuration file colCrWall :: World -> Creature -> Creature -colCrWall w c - | p1 == p2 = pushOrCrush ls c --- | _crPos c' == _crPos c'' = c' --- | otherwise = c & crPos .~ _crOldPos c +colCrWall w c + | p1 == p2 = pushOrCrush ls c + -- | _crPos c' == _crPos c'' = c' + -- | otherwise = c & crPos .~ _crOldPos c | otherwise = c' - where --- c'' = c' & crPos %~ pushOutFromWalls rad ls + where + -- c'' = c' & crPos %~ pushOutFromWalls rad ls --c' = c & crPos %~ pushOutFromWalls' rad (reverse ls) - c' = c & crPos %~ pushOutFromCorners rad ls' - . pushOutFromWalls rad ls' - . fst . flip (collidePoint p1) wls' -- check push throughs --- . flip (collidePointWalls' p1) wls -- check push throughs + c' = + c & crPos + %~ pushOutFromCorners rad ls' + . pushOutFromWalls rad ls' + . fst + . flip (collidePoint p1) wls' -- check push throughs + -- . flip (collidePointWalls' p1) wls -- check push throughs rad = _crRad c + wallBuffer - p1 = _crOldPos c - p2 = _crPos c - ls = _wlLine <$> wls + p1 = _crOldPos c + p2 = _crPos c + ls = _wlLine <$> wls ls' = filter (uncurry $ isLHS p1) ls wls' = filter (not . _wlWalkable) $ wlsNearPoint p2 w wls = filter (not . _wlWalkable) $ wlsNearPoint p2 w - --wallPoints = map fst ls + +--wallPoints = map fst ls -- the amount to push creatures out from walls, extra to their radius wallBuffer :: Float wallBuffer = 0 -pushCreatureOutFromWalls :: [(Point2,Point2)] -> Creature -> Creature -pushCreatureOutFromWalls ls cr = cr & crPos %~ pushOutFromWalls (_crRad cr) ls +pushCreatureOutFromWalls :: [(Point2, Point2)] -> Creature -> Creature +pushCreatureOutFromWalls ls cr = cr & crPos %~ pushOutFromWalls (_crRad cr) ls -- the following tests whether or not a point is on a wall, and if so pushes it -- out from the wall -- this is then repeated if the point ends up on a new wall -pushOutFromWalls :: Float -> [(Point2,Point2)] -> Point2 -> Point2 +pushOutFromWalls :: Float -> [(Point2, Point2)] -> Point2 -> Point2 pushOutFromWalls rad wls p1 = case (getFirst . foldMap (First . pushOutFromWall rad p1)) wls of Nothing -> p1 Just p2 -> pushOutFromWalls rad (tail wls) p2 - -- possible improvement: choose between the closer of p2 and "p3" to p1 + +-- possible improvement: choose between the closer of p2 and "p3" to p1 --pushOutFromWalls' :: Float -> [(Point2,Point2)] -> Point2 -> Point2 --pushOutFromWalls' rad wls p1 = case (getFirst . foldMap (First . pushOutFromWall' rad p1)) wls of @@ -68,43 +72,45 @@ pushOutFromWalls rad wls p1 = case (getFirst . foldMap (First . pushOutFromWall -- Just p2 -> fromMaybe p2 $ (getLast . foldMap (Last . pushOutFromWall' rad p2)) wls -- -- possible improvement: choose between the closer of p2 and "p3" to p1 -pushOrCrush :: [(Point2,Point2)] -> Creature -> Creature +pushOrCrush :: [(Point2, Point2)] -> Creature -> Creature pushOrCrush wls cr = case mapMaybe (pushOutFromWall (_crRad cr) cpos) wls of - [] -> cr - (p:_) -> cr & crPos .~ p --- (_:p:_) -> cr --- & crPos .~ p --- & crState . crDamage %~ ( Blunt 50 cpos cpos cpos : ) + [] -> cr + (p : _) -> cr & crPos .~ p where + -- (_:p:_) -> cr + -- & crPos .~ p + -- & crState . crDamage %~ ( Blunt 50 cpos cpos cpos : ) + cpos = _crPos cr -- note the inclusion of endpoints in circOnSeg crOnWall :: Creature -> World -> Bool -crOnWall cr = any (uncurry (circOnSeg p r) . _wlLine) - . filter (not . _wlWalkable) - . wlsNearPoint p +crOnWall cr = + any (uncurry (circOnSeg p r) . _wlLine) + . filter (not . _wlWalkable) + . wlsNearPoint p where p = _crPos cr r = _crRad cr - + -- assumes that the wall is orientated -- assumes wall points are different -pushOutFromWall :: Float -> Point2 -> (Point2,Point2) -> Maybe Point2 -pushOutFromWall rad cp2 (wp1,wp2) - | isOnWall = Just newP +pushOutFromWall :: Float -> Point2 -> (Point2, Point2) -> Maybe Point2 +pushOutFromWall rad cp2 (wp1, wp2) + | isOnWall = Just newP | otherwise = Nothing - where + where norm = errorNormalizeV 61 $ vNormal (wp1 -.- wp2) wp1' = wp1 +.+ rad *.* norm wp2' = wp2 +.+ rad *.* norm newP = errorClosestPointOnLine 5 wp1' wp2' cp2 isOnWall = circOnSegNoEndpoints wp1 wp2 cp2 rad -pushOutFromCorners :: Float -> [(Point2,Point2)] -> Point2 -> Point2 +pushOutFromCorners :: Float -> [(Point2, Point2)] -> Point2 -> Point2 --pushOutFromCorners r ls p = foldr (squashIntersectCirclePoint r . fst) p ls pushOutFromCorners r = flip $ foldr (squashIntersectCirclePoint r . fst) squashIntersectCirclePoint :: Float -> Point2 -> Point2 -> Point2 -squashIntersectCirclePoint rad p cCen +squashIntersectCirclePoint rad p cCen | dist cCen p > rad = cCen - | otherwise = p +.+ (rad *.* squashNormalizeV (cCen -.- p)) + | otherwise = p +.+ (rad *.* squashNormalizeV (cCen -.- p)) diff --git a/src/Dodge/WdP2f.hs b/src/Dodge/WdP2f.hs index 4746191be..e289db961 100644 --- a/src/Dodge/WdP2f.hs +++ b/src/Dodge/WdP2f.hs @@ -1,12 +1,13 @@ -module Dodge.WdP2f - where -import Geometry.Vector -import Dodge.Data -import Geometry.Data -import Control.Lens +module Dodge.WdP2f where -doWdP2f :: WdP2f -> World -> (Point2,Float) +import Control.Lens +import Dodge.Data.World +import Geometry.Data +import Geometry.Vector + +doWdP2f :: WdP2f -> World -> (Point2, Float) doWdP2f x = case x of - WdP2f0 -> const (0,0) - WdP2fDoorPosition drid -> \w -> let Just (a,b) = w ^? cWorld . doors . ix drid . drPos - in (b, argV (a-.-b)) + WdP2f0 -> const (0, 0) + WdP2fDoorPosition drid -> \w -> + let Just (a, b) = w ^? cWorld . doors . ix drid . drPos + in (b, argV (a -.- b)) diff --git a/src/Dodge/Wire.hs b/src/Dodge/Wire.hs index 24aa30493..6bf337abd 100644 --- a/src/Dodge/Wire.hs +++ b/src/Dodge/Wire.hs @@ -1,33 +1,35 @@ module Dodge.Wire where ---import Dodge.LevelGen.Data -import Dodge.Default.Foreground -import Dodge.Data -import Geometry -import LensHelp -import ShapePicture -import Shape -import Color -import Dodge.Room.Foreground +import Color +import Dodge.Data.GenWorld +import Dodge.Default.ForegroundShape +import Dodge.Room.Foreground +import Geometry import qualified IntMapHelp as IM +import LensHelp +import Shape +import ShapePicture floorWire :: Point2 -> Point2 -> ForegroundShape -floorWire a b = defaultForeground - & fsPos .~ m - & fsRad .~ dist m a - & fsSPic .~ noPic (colorSH yellow $ thinHighBar 0 a' b') +floorWire a b = + defaultForeground + & fsPos .~ m + & fsRad .~ dist m a + & fsSPic .~ noPic (colorSH yellow $ thinHighBar 0 a' b') where m = midPoint a b a' = a - m b' = b - m + verticalWire :: Point2 -> Float -> Float -> ForegroundShape -verticalWire p h1 h2 = defaultForeground - & fsPos .~ p - & fsRad .~ 2 - & fsSPic .~ noPic (colorSH yellow $ barPP 1.5 (V3 0 0 h1) (V3 0 0 h2)) +verticalWire p h1 h2 = + defaultForeground + & fsPos .~ p + & fsRad .~ 2 + & fsSPic .~ noPic (colorSH yellow $ barPP 1.5 (V3 0 0 h1) (V3 0 0 h2)) -putWireEnd :: Int -> (Point2,Float) -> Float -> Room -> Room -putWireEnd i (p,a) h = rmEndWires %~ IM.insert i (WallWire p a h) +putWireEnd :: Int -> (Point2, Float) -> Float -> Room -> Room +putWireEnd i (p, a) h = rmEndWires %~ IM.insert i (WallWire p a h) -putWireStart :: Int -> (Point2,Float) -> Float -> Room -> Room -putWireStart i (p,a) h = rmStartWires %~ IM.insert i (WallWire p a h) +putWireStart :: Int -> (Point2, Float) -> Float -> Room -> Room +putWireStart i (p, a) h = rmStartWires %~ IM.insert i (WallWire p a h) diff --git a/src/Dodge/WorldBool.hs b/src/Dodge/WorldBool.hs index cfea0ab86..0acf4038a 100644 --- a/src/Dodge/WorldBool.hs +++ b/src/Dodge/WorldBool.hs @@ -1,11 +1,10 @@ -module Dodge.WorldBool - where -import Dodge.CreatureEffect -import Dodge.Creature.Test -import Dodge.Data -import Data.Maybe -import Control.Lens +module Dodge.WorldBool where +import Control.Lens +import Data.Maybe +import Dodge.Creature.Test +import Dodge.CreatureEffect +import Dodge.Data.World import qualified IntMapHelp as IM doWdBl :: WdBl -> World -> Bool @@ -16,7 +15,6 @@ doWdBl wb w = case wb of dr <- w ^? cWorld . doors . ix i return (DoorHalfway == _drStatus dr) WdBlCrFilterNearPoint r p t -> any (crNearPoint r p) (IM.filter (doCrBl t) (_creatures (_cWorld w))) - WdBlBtOn btid -> _btState (_buttons (_cWorld w) IM.! btid) == BtOn -- unsafe - WdBlBtNotOff btid -> _btState (_buttons (_cWorld w) IM.! btid) /= BtOff -- unsafe + WdBlBtOn btid -> _btState (_buttons (_cWorld w) IM.! btid) == BtOn -- unsafe + WdBlBtNotOff btid -> _btState (_buttons (_cWorld w) IM.! btid) /= BtOff -- unsafe WdBlNegate x -> not $ doWdBl x w - diff --git a/src/Dodge/WorldEffect.hs b/src/Dodge/WorldEffect.hs index d28345c1b..114c48b9d 100644 --- a/src/Dodge/WorldEffect.hs +++ b/src/Dodge/WorldEffect.hs @@ -4,7 +4,7 @@ import Data.Foldable import qualified Data.Map.Strict as M import Data.Maybe import Dodge.Creature.Impulse.UseItem -import Dodge.Data +import Dodge.Data.World import Dodge.Default import Dodge.Inventory.Lock import Dodge.Item.Location diff --git a/src/Dodge/WorldEvent/Cloud.hs b/src/Dodge/WorldEvent/Cloud.hs index e70389a8e..61291d275 100644 --- a/src/Dodge/WorldEvent/Cloud.hs +++ b/src/Dodge/WorldEvent/Cloud.hs @@ -1,51 +1,58 @@ -module Dodge.WorldEvent.Cloud - ( makeFlamerSmokeAt - , smokeCloudAt - , makeThinSmokeAt - , makeThickSmokeAt - , shellTrailCloud - , spawnSmokeAtCursor - , makeStartCloudAt - ) where -import Dodge.Data -import Dodge.Base -import Geometry.Data -import Picture -import LensHelp +module Dodge.WorldEvent.Cloud ( + makeFlamerSmokeAt, + smokeCloudAt, + makeThinSmokeAt, + makeThickSmokeAt, + shellTrailCloud, + spawnSmokeAtCursor, + makeStartCloudAt, +) where +import Dodge.Base +import Dodge.Data.World +import Geometry.Data +import LensHelp +import Picture --import qualified Streaming.Prelude as S --import Control.Lens import System.Random -makeCloudAt - :: CloudDraw - -> Float -- ^ radius - -> Int -- ^ timer - -> Float -- ^ resting altitude - -> Point3 -- start position - -> World - -> World -makeCloudAt drawFunc rad t alt p = cWorld . clouds .:~ Cloud ---makeCloudAt drawFunc rad t alt p = clouds %~ S.cons Cloud - { _clPos = p - , _clVel = V3 0 0 0 - , _clPict = drawFunc - , _clRad = rad - , _clAlt = alt - , _clTimer = t - , _clType = SmokeCloud - } - -smokeCloudAt - :: Color - -> Float -- ^ radius - -> Int -- ^ timer - -> Float -- ^ resting altitude - -> Point3 -- start position - -> World - -> World -smokeCloudAt col = makeCloudAt (CloudColor (4/3) 800 col) +makeCloudAt :: + CloudDraw -> + -- | radius + Float -> + -- | timer + Int -> + -- | resting altitude + Float -> + Point3 -> -- start position + World -> + World +makeCloudAt drawFunc rad t alt p = + cWorld . clouds + .:~ Cloud + { --makeCloudAt drawFunc rad t alt p = clouds %~ S.cons Cloud + _clPos = p + , _clVel = V3 0 0 0 + , _clPict = drawFunc + , _clRad = rad + , _clAlt = alt + , _clTimer = t + , _clType = SmokeCloud + } +smokeCloudAt :: + Color -> + -- | radius + Float -> + -- | timer + Int -> + -- | resting altitude + Float -> + Point3 -> -- start position + World -> + World +smokeCloudAt col = makeCloudAt (CloudColor (4 / 3) 800 col) makeThickSmokeAt :: Point3 -> World -> World makeThickSmokeAt = makeCloudAt (CloudColor 4 50 black) 3 50 30 @@ -57,12 +64,12 @@ makeStartCloudAt :: Point3 -> World -> World makeStartCloudAt = makeCloudAt (CloudColor 2 800 white) 10 400 5 shellTrailCloud :: Point3 -> World -> World -shellTrailCloud = makeCloudAt (CloudColor (4/3) 800 (greyN 0.5)) 15 400 40 +shellTrailCloud = makeCloudAt (CloudColor (4 / 3) 800 (greyN 0.5)) 15 400 40 makeFlamerSmokeAt :: Point3 -> World -> World makeFlamerSmokeAt p w = makeCloudAt (CloudColor 4 300 (greyN x)) 6 200 40 p w where - x = fst $ randomR (0.5,0.8) (_randGen w) + x = fst $ randomR (0.5, 0.8) (_randGen w) spawnSmokeAtCursor :: World -> World spawnSmokeAtCursor w = shellTrailCloud (V3 x y 20) w diff --git a/src/Dodge/WorldEvent/Damage.hs b/src/Dodge/WorldEvent/Damage.hs index 9aa38f868..93870e1d7 100644 --- a/src/Dodge/WorldEvent/Damage.hs +++ b/src/Dodge/WorldEvent/Damage.hs @@ -1,19 +1,20 @@ -module Dodge.WorldEvent.Damage - ( damThingHitWith - ) where -import Dodge.Data -import Geometry +module Dodge.WorldEvent.Damage ( + damThingHitWith, +) where + +import Dodge.Data.World import Dodge.Wall.Damage +import Geometry import LensHelp -damThingHitWith - :: (Point2 -> Point2 -> Point2 -> Damage) - -> Point2 - -> Point2 - -> Maybe (Point2, Either Creature Wall) - -> World - -> World +damThingHitWith :: + (Point2 -> Point2 -> Point2 -> Damage) -> + Point2 -> + Point2 -> + Maybe (Point2, Either Creature Wall) -> + World -> + World damThingHitWith partDT sp ep mayEiCrWl = case mayEiCrWl of - Just (hitp,Left cr) -> cWorld . creatures . ix (_crID cr) . crState . csDamage .:~ partDT sp hitp ep - Just (hitp,Right wl) -> damageWall (partDT sp hitp ep) wl + Just (hitp, Left cr) -> cWorld . creatures . ix (_crID cr) . crState . csDamage .:~ partDT sp hitp ep + Just (hitp, Right wl) -> damageWall (partDT sp hitp ep) wl Nothing -> id diff --git a/src/Dodge/WorldEvent/Explosion.hs b/src/Dodge/WorldEvent/Explosion.hs index 27383e68b..74ff0a198 100644 --- a/src/Dodge/WorldEvent/Explosion.hs +++ b/src/Dodge/WorldEvent/Explosion.hs @@ -1,96 +1,108 @@ {- Explosions: creation of shockwave and particles at a given point. -} -module Dodge.WorldEvent.Explosion - ( makeExplosionAt - , makeFlameExplosionAt - , makePoisonExplosionAt - , makeTeslaExplosionAt - ) where -import Dodge.Data -import Dodge.EnergyBall -import Dodge.LightSource -import Dodge.Flame -import Dodge.Base.Collide -import Dodge.WorldEvent.SpawnParticle +module Dodge.WorldEvent.Explosion ( + makeExplosionAt, + makeFlameExplosionAt, + makePoisonExplosionAt, + makeTeslaExplosionAt, +) where + --import Dodge.WorldEvent.Flash -import RandomHelp -import Dodge.SoundLogic -import Dodge.WorldEvent.Shockwave -import Geometry + --import Geometry.Vector3D -import Picture -import LensHelp import Data.List +import Dodge.Base.Collide +import Dodge.Data.World +import Dodge.EnergyBall +import Dodge.Flame +import Dodge.LightSource +import Dodge.SoundLogic +import Dodge.WorldEvent.Shockwave +import Dodge.WorldEvent.SpawnParticle +import Geometry +import LensHelp +import Picture +import RandomHelp + --import Data.Maybe -makePoisonExplosionAt - :: Point2 -- ^ Position - -> World - -> World -makePoisonExplosionAt p w - = soundMultiFrom [Explosion 0,Explosion 1] p bangS Nothing - $ foldl' (flip $ makeGasCloud p) w - $ replicateM 25 (randInCirc 2) & evalState $ _randGen w +makePoisonExplosionAt :: + -- | Position + Point2 -> + World -> + World +makePoisonExplosionAt p w = + soundMultiFrom [Explosion 0, Explosion 1] p bangS Nothing $ + foldl' (flip $ makeGasCloud p) w $ + replicateM 25 (randInCirc 2) & evalState $ _randGen w + -- just change the number after replicateM to get more or less clouds -- suggested change: use random positions, offset from p, rather than velocities -- so, p +.+ randomOffset -- currently the clouds push away from each other rather hard if they are close -makeTeslaExplosionAt - :: Point2 -- ^ Position - -> World - -> World +makeTeslaExplosionAt :: + -- | Position + Point2 -> + World -> + World makeTeslaExplosionAt = undefined + -- soundOncePos grenadeBang pos $ foldr ($) w listOfFunctions -- a bit shorter --- where +-- where -- xs = randomRs (0, 2*pi) $ _randGen w -- j = newProjectileKey w -- pks = [j..] --- listOfFunctions = map --- (\i -> over projectiles (IM.insert (pks!!i) (makeTeslaArcAt (pks!!i) pos (xs!!i)))) +-- listOfFunctions = map +-- (\i -> over projectiles (IM.insert (pks!!i) (makeTeslaArcAt (pks!!i) pos (xs!!i)))) -- [1 .. 29] - -makeFlameExplosionAt - :: Point2 -- ^ Position - -> World - -> World -makeFlameExplosionAt p w - = soundMultiFrom [Explosion 0,Explosion 1] p bangS Nothing w - & cWorld . flames .++~ newFlames - where + +makeFlameExplosionAt :: + -- | Position + Point2 -> + World -> + World +makeFlameExplosionAt p w = + soundMultiFrom [Explosion 0, Explosion 1] p bangS Nothing w + & cWorld . flames .++~ newFlames + where newFlames = zipWith makeFlameWithVelAndTime velocities timers makeFlameWithVelAndTime vel time = aFlameParticle time p vel velocities = replicateM 15 (randInCirc 1) & evalState $ _randGen w - timers = randomRs (80,100) $ _randGen w - -- the ( Nthing :: Maybe Int ) here is "maybe" a creature id that the - -- particle passes through for the first frame of its existence + timers = randomRs (80, 100) $ _randGen w + +-- the ( Nthing :: Maybe Int ) here is "maybe" a creature id that the +-- particle passes through for the first frame of its existence makeExplosionAt :: Point2 -> World -> World -makeExplosionAt p w = w - & soundMultiFrom [Explosion 0,Explosion 1] p bangS Nothing - & addFlames - & cWorld . tempLightSources .:~ theTLS - & makeShockwaveAt [] p 50 50 1 white - where - theTLS = tlsTimeRadColPos 20 150 (V3 1 0.5 0) (addZ 20 p) - fVs = replicateM 100 (randInCirc 1) & evalState $ _randGen w +makeExplosionAt p w = + w + & soundMultiFrom [Explosion 0, Explosion 1] p bangS Nothing + & addFlames + & cWorld . tempLightSources .:~ theTLS + & makeShockwaveAt [] p 50 50 1 white + where + theTLS = tlsTimeRadColPos 20 150 (V3 1 0.5 0) (addZ 20 p) + fVs = replicateM 100 (randInCirc 1) & evalState $ _randGen w --fPs'' = replicateM 100 (fmap (15 *.*.*) randInHemisphere) & evalState $ _randGen w fPs'' = replicateM 100 (fmap (15 *.*.*) randInHemisphere) & evalState $ _randGen w - (fPs',zs) = let (a,b,c) = unzip3 $ map fromV3 fPs'' - in (zipWith V2 a b, c) + (fPs', zs) = + let (a, b, c) = unzip3 $ map fromV3 fPs'' + in (zipWith V2 a b, c) --fPs = map (pushAgainstWalls . (+.+) p . (*.*) 0.5) fPs' - fPs = map (pushAgainstWalls . (+.+) p) fPs' + fPs = map (pushAgainstWalls . (+.+) p) fPs' inversePushOut v = (15 - magV v) * 0.01 *.* v fVs' = zipWith (+.+) fVs $ map inversePushOut fPs' - sizes = randomRs (2,9) $ _randGen w + sizes = randomRs (2, 9) $ _randGen w --times = randomRs (20,25) $ _randGen w - times = randomRs (15,20) $ _randGen w + times = randomRs (15, 20) $ _randGen w mF q z v size time = makeFlamelet q z v size time newFs = zipWith5 mF fPs zs (fmap (3 *.*) fVs') sizes times addFlames w' = foldl' (flip ($)) w' newFs --pushAgainstWalls q = maybe q (uncurry (+.+)) $ reflectPointWalls p q wls --pushAgainstWalls q = maybe q fst $ reflectPointWalls p q wls pushAgainstWalls q = maybe q fst $ bouncePoint (const True) 1 p q w + -- wls = wallsNearPoint p w diff --git a/src/Dodge/WorldEvent/Flash.hs b/src/Dodge/WorldEvent/Flash.hs index d30e294c5..5cee1a5ba 100644 --- a/src/Dodge/WorldEvent/Flash.hs +++ b/src/Dodge/WorldEvent/Flash.hs @@ -8,42 +8,48 @@ flash : short, abrupt changes in alpha glow : continuous, potentially long, fading, slow changes in alpha flicker : potentially long, moving, abrupt changes in alpha -} -module Dodge.WorldEvent.Flash - ( explosionFlashAt - , muzFlareAt - , flareCircleAt - ) where -import Dodge.Data +module Dodge.WorldEvent.Flash ( + explosionFlashAt, + muzFlareAt, + flareCircleAt, +) where + +import Dodge.Data.World import Dodge.LightSource --import Dodge.Default -import Picture + import Geometry import LensHelp - +import Picture import System.Random muzFlareAt :: Color -> Point3 -> Float -> World -> World -muzFlareAt col tranv dir w = w & cWorld . flares .:~ MuzFlare - { _flarePoly = map (rotateV dir) - [ V2 0 0 - , V2 a (-b) - , V2 c d - ] - , _flareColor = col - , _flareTran3 = tranv - , _flareTime = 2 - } +muzFlareAt col tranv dir w = + w & cWorld . flares + .:~ MuzFlare + { _flarePoly = + map + (rotateV dir) + [ V2 0 0 + , V2 a (- b) + , V2 c d + ] + , _flareColor = col + , _flareTran3 = tranv + , _flareTime = 2 + } where - (a:b:c:d:_) = randomRs (2,20) (_randGen w) + (a : b : c : d : _) = randomRs (2, 20) (_randGen w) flareCircleAt :: Color -> Float -> Point3 -> World -> World -flareCircleAt col alphax tranv = cWorld . flares .:~ CircFlare - { _flareTime = 2 - , _flareColor = col - , _flareAlpha = alphax - , _flareTran3 = tranv - } - +flareCircleAt col alphax tranv = + cWorld . flares + .:~ CircFlare + { _flareTime = 2 + , _flareColor = col + , _flareAlpha = alphax + , _flareTran3 = tranv + } explosionFlashAt :: Point2 -> World -> World explosionFlashAt p = cWorld . tempLightSources .:~ tlsTimeRadFunPos 20 150 (TLSFade 1 10) (addZ 20 p) diff --git a/src/Dodge/WorldEvent/Shockwave.hs b/src/Dodge/WorldEvent/Shockwave.hs index 83f32b796..c9ec2e1bb 100644 --- a/src/Dodge/WorldEvent/Shockwave.hs +++ b/src/Dodge/WorldEvent/Shockwave.hs @@ -1,50 +1,62 @@ -module Dodge.WorldEvent.Shockwave - ( makeShockwaveAt - , inverseShockwaveAt - ) where -import Dodge.Data +module Dodge.WorldEvent.Shockwave ( + makeShockwaveAt, + inverseShockwaveAt, +) where + +import Dodge.Data.World import Geometry -import Picture import LensHelp +import Picture -- currently very effective against walls -makeShockwaveAt - :: [Int] -- ^ IDs of invulnerable creatures. - -> Point2 -- ^ Center of shockwave. - -> Float -- ^ Maximal radius. - -> Int -- ^ Damage caused per frame. - -> Float -- ^ Amount of pushback per frame. - -> Color -- ^ Color of shockwave. - -> World -- ^ Start world. - -> World -makeShockwaveAt is p rad dam push col = cWorld . shockwaves .:~ Shockwave - { _swInvulnerableCrs = is - , _swDirection = OutwardShockwave - , _swColor = col - , _swPos = p - , _swRad = rad - , _swDam = dam - , _swPush = push - , _swMaxTime = 10 - , _swTimer = 10 - } +makeShockwaveAt :: + -- | IDs of invulnerable creatures. + [Int] -> + -- | Center of shockwave. + Point2 -> + -- | Maximal radius. + Float -> + -- | Damage caused per frame. + Int -> + -- | Amount of pushback per frame. + Float -> + -- | Color of shockwave. + Color -> + -- | Start world. + World -> + World +makeShockwaveAt is p rad dam push col = + cWorld . shockwaves + .:~ Shockwave + { _swInvulnerableCrs = is + , _swDirection = OutwardShockwave + , _swColor = col + , _swPos = p + , _swRad = rad + , _swDam = dam + , _swPush = push + , _swMaxTime = 10 + , _swTimer = 10 + } {- Create a shockwave going from an outside circle into a center point. -} -inverseShockwaveAt - :: Point2 -- Center position - -> Float -- Radius - -> Int -- Damage - -> Float -- Push amount - -> World - -> World -inverseShockwaveAt p rad dam push = cWorld . shockwaves .:~ Shockwave - { _swDirection = InwardShockwave - , _swInvulnerableCrs = [] - , _swColor = cyan - , _swPos = p - , _swRad = rad - , _swDam = dam - , _swPush = push - , _swMaxTime = 10 - , _swTimer = 10 - } +inverseShockwaveAt :: + Point2 -> -- Center position + Float -> -- Radius + Int -> -- Damage + Float -> -- Push amount + World -> + World +inverseShockwaveAt p rad dam push = + cWorld . shockwaves + .:~ Shockwave + { _swDirection = InwardShockwave + , _swInvulnerableCrs = [] + , _swColor = cyan + , _swPos = p + , _swRad = rad + , _swDam = dam + , _swPush = push + , _swMaxTime = 10 + , _swTimer = 10 + } diff --git a/src/Dodge/WorldEvent/Sound.hs b/src/Dodge/WorldEvent/Sound.hs index 6a4328cd1..280e33cc3 100644 --- a/src/Dodge/WorldEvent/Sound.hs +++ b/src/Dodge/WorldEvent/Sound.hs @@ -1,20 +1,21 @@ -module Dodge.WorldEvent.Sound - ( originIDsAt - , originsIDsAt - ) where -import Dodge.Data -import Dodge.SoundLogic -import Sound.Data -import Geometry.Data -import RandomHelp +module Dodge.WorldEvent.Sound ( + originIDsAt, + originsIDsAt, +) where import Control.Lens +import Dodge.Data.World +import Dodge.SoundLogic +import Geometry.Data +import RandomHelp +import Sound.Data + originsIDsAt :: [SoundOrigin] -> [SoundID] -> Point2 -> World -> World originsIDsAt sos sids p w = soundMultiFrom sos p sid Nothing $ set randGen g w where - (sid,g) = _randGen w & runState (takeOne sids) + (sid, g) = _randGen w & runState (takeOne sids) originIDsAt :: SoundOrigin -> [SoundID] -> Point2 -> World -> World originIDsAt so sids p w = soundStart so p sid Nothing $ set randGen g w where - (sid,g) = _randGen w & runState (takeOne sids) + (sid, g) = _randGen w & runState (takeOne sids) diff --git a/src/Dodge/WorldEvent/SpawnParticle.hs b/src/Dodge/WorldEvent/SpawnParticle.hs index 40ef229e9..1726935b8 100644 --- a/src/Dodge/WorldEvent/SpawnParticle.hs +++ b/src/Dodge/WorldEvent/SpawnParticle.hs @@ -1,15 +1,15 @@ -{- | Creation of particles in the world. -} -module Dodge.WorldEvent.SpawnParticle - ( makeGasCloud - , makeStaticBall - , concBall --- , randParticleAt - ) where -import Dodge.Data -import RandomHelp -import Picture +-- | Creation of particles in the world. +module Dodge.WorldEvent.SpawnParticle ( + makeGasCloud, + makeStaticBall, + concBall, +) where + +import Dodge.Data.World import Geometry import LensHelp +import Picture +import RandomHelp --randParticleAt :: (Point2 -> State StdGen Particle) -> Point2 -> World -> World --randParticleAt f p w = w @@ -18,11 +18,12 @@ import LensHelp -- where -- (thepart,g) = runState (f p) (_randGen w) randEnergyBallAt :: (Point2 -> State StdGen EnergyBall) -> Point2 -> World -> World -randEnergyBallAt f p w = w - & cWorld . energyBalls .:~ thepart - & randGen .~ g +randEnergyBallAt f p w = + w + & cWorld . energyBalls .:~ thepart + & randGen .~ g where - (thepart,g) = runState (f p) (_randGen w) + (thepart, g) = runState (f p) (_randGen w) makeStaticBall :: Point2 -> World -> World makeStaticBall p = randEnergyBallAt aStaticBall p . (cWorld . posEvents .:~ thesparker) @@ -30,37 +31,41 @@ makeStaticBall p = randEnergyBallAt aStaticBall p . (cWorld . posEvents .:~ thes thesparker = PosEvent SparkSpawner 10 p concBall :: Point2 -> Shockwave -concBall p = Shockwave - { _swDirection = OutwardShockwave - , _swInvulnerableCrs = [] - , _swColor = white - , _swPos = p - , _swRad = 15 - , _swDam = 4 - , _swPush = 1 - , _swMaxTime = 10 - , _swTimer = 10 - } +concBall p = + Shockwave + { _swDirection = OutwardShockwave + , _swInvulnerableCrs = [] + , _swColor = white + , _swPos = p + , _swRad = 15 + , _swDam = 4 + , _swPush = 1 + , _swMaxTime = 10 + , _swTimer = 10 + } aStaticBall :: Point2 -> State g EnergyBall -aStaticBall p = return EnergyBall - { _ebVel = 0 - , _ebColor = blue - , _ebPos = p - , _ebWidth = 3 - , _ebTimer = 20 - , _ebEff = (ELECTRICAL,1) - , _ebZ = 20 - , _ebRot = 0 - } +aStaticBall p = + return + EnergyBall + { _ebVel = 0 + , _ebColor = blue + , _ebPos = p + , _ebWidth = 3 + , _ebTimer = 20 + , _ebEff = (ELECTRICAL, 1) + , _ebZ = 20 + , _ebRot = 0 + } --- | Note damgeInRadius by itself never destroys the particle ---damageInRadius :: Float -> Particle -> World -> World ---damageInRadius size pt = damageInArea isClose closeWls pt --- where --- p = _ptPos pt --- closeWls wl = uncurry segOnCirc (_wlLine wl) p size --- isClose cr = dist p (_crPos cr) < _crRad cr + size +{- | Note damgeInRadius by itself never destroys the particle +damageInRadius :: Float -> Particle -> World -> World +damageInRadius size pt = damageInArea isClose closeWls pt + where + p = _ptPos pt + closeWls wl = uncurry segOnCirc (_wlLine wl) p size + isClose cr = dist p (_crPos cr) < _crRad cr + size +-} --damageInArea :: (Creature -> Bool) -> (Wall -> Bool) -> Particle -> World -> World --{-# INLINE damageInArea #-} @@ -69,46 +74,50 @@ aStaticBall p = return EnergyBall -- p = _ptPos pt -- damcrs = foldl' (flip $ \cr -> fst . hiteff (S.yield (p,Left cr))) w $ IM.filter crt $ _creatures w -- damwls w' = runIdentity --- . S.fold_ --- (flip $ \wl -> fst . hiteff (S.yield (p,Right wl))) --- w' +-- . S.fold_ +-- (flip $ \wl -> fst . hiteff (S.yield (p,Right wl))) +-- w' -- id -- . S.filter wlt -- $ wlsNearPoint p w' -- hiteff = _ptHitEff pt pt -- | At writing the radius is half the size of the effect area -makeGasCloud - :: Point2 -- ^ Position - -> Point2 -- ^ Velocity - -> World - -> World -makeGasCloud pos vel w = w - & cWorld . clouds .:~ theCloud - & randGen .~ g - where - theCloud = Cloud - { _clPos = addZ 20 pos - , _clVel = addZ 0 vel - , _clPict = DrawGasCloud col - , _clRad = 10 - , _clAlt = 25 - , _clTimer = 400 - , _clType = GasCloud - } - (col, g) = runState (takeOne [green,yellow]) $ _randGen w -{- Attach poison cloud damage to creatures near cloud. -} +makeGasCloud :: + -- | Position + Point2 -> + -- | Velocity + Point2 -> + World -> + World +makeGasCloud pos vel w = + w + & cWorld . clouds .:~ theCloud + & randGen .~ g + where + theCloud = + Cloud + { _clPos = addZ 20 pos + , _clVel = addZ 0 vel + , _clPict = DrawGasCloud col + , _clRad = 10 + , _clAlt = 25 + , _clTimer = 400 + , _clType = GasCloud + } + (col, g) = runState (takeOne [green, yellow]) $ _randGen w +{- Attach poison cloud damage to creatures near cloud. -} {- Update of a flamelet. Applies movement and attaches damage to nearby creatures. -} -- This should be unified in many ways with moveFlame --moveFlamelet :: World -> Particle -> (World, Maybe Particle) ---moveFlamelet w pt +--moveFlamelet w pt -- | _ptTimer pt <= 0 = ( w, Nothing) -- | otherwise = (ptFlicker pt $ damageInRadius 5 mvPt' w, Just mvPt') --- where --- mvPt' = pt +-- where +-- mvPt' = pt -- & ptTimer -~ 1 -- & ptPos .~ _ptPos pt +.+ _ptVel pt -- & ptVel .*.*~ 0.8 diff --git a/src/Dodge/WorldEvent/ThingsHit.hs b/src/Dodge/WorldEvent/ThingsHit.hs index 9c23e2037..8641abece 100644 --- a/src/Dodge/WorldEvent/ThingsHit.hs +++ b/src/Dodge/WorldEvent/ThingsHit.hs @@ -1,66 +1,77 @@ {-# LANGUAGE TupleSections #-} + {- | Find which objects lie upon a line. - -} -module Dodge.WorldEvent.ThingsHit - ( thingsHit - , thingHit - , thingHitFilt - , thingsHitExceptCr - , crsHitRadial - , wlsHitRadial - ) - where -import Dodge.Zoning.Wall -import Dodge.Zoning.Creature -import Dodge.Data +-} +module Dodge.WorldEvent.ThingsHit ( + thingsHit, + thingHit, + thingHitFilt, + thingsHitExceptCr, + crsHitRadial, + wlsHitRadial, +) where + +import Control.Lens +import Data.Bifunctor +import qualified Data.IntSet as IS +import Data.List (sortOn) +import Data.Maybe import Dodge.Base +import Dodge.Data.World +import Dodge.Zoning.Creature +import Dodge.Zoning.Wall import Geometry import qualified ListHelp as List -import Control.Lens -import Data.Maybe -import Data.List (sortOn) -import Data.Bifunctor -import qualified Data.IntSet as IS - {- List those objects that appear on a line. -} -thingsHit - :: Point2 -- ^ Line start point - -> Point2 -- ^ Line end point - -> World - -> [(Point2, Either Creature Wall)] -thingsHit sp ep w = List.mergeOn (dist sp . fst) - (map (second Left) (crsHit sp ep w)) - (map (second Right) (wlsHit sp ep w)) +thingsHit :: + -- | Line start point + Point2 -> + -- | Line end point + Point2 -> + World -> + [(Point2, Either Creature Wall)] +thingsHit sp ep w = + List.mergeOn + (dist sp . fst) + (map (second Left) (crsHit sp ep w)) + (map (second Right) (wlsHit sp ep w)) + --{- List those objects that appear on a line. -} --thingsHit -- :: Point2 -- ^ Line start point -- -> Point2 -- ^ Line end point --- -> World +-- -> World -- -> StreamOf (Point2, Either Creature Wall) ---thingsHit sp ep w = void $ S.mergeOn (dist sp . fst) +--thingsHit sp ep w = void $ S.mergeOn (dist sp . fst) -- (S.map (second Left) (S.each $ crsHit sp ep w)) -- (S.map (second Right) (wlsHit sp ep w)) crsHit :: Point2 -> Point2 -> World -> [(Point2, Creature)] crsHit sp ep w - | sp == ep = mempty - | otherwise = sortOn (dist sp . fst) - . overlap1SegCrs sp ep - . mapMaybe (\cid -> w ^? cWorld . creatures . ix cid) - . IS.toList - . crsNearSeg sp ep - $ w + | sp == ep = mempty + | otherwise = + sortOn (dist sp . fst) + . overlap1SegCrs sp ep + . mapMaybe (\cid -> w ^? cWorld . creatures . ix cid) + . IS.toList + . crsNearSeg sp ep + $ w -thingHitFilt :: (Creature -> Bool) -> (Wall -> Bool) - -> Point2 -> Point2 -> World -> Maybe (Point2, Either Creature Wall) +thingHitFilt :: + (Creature -> Bool) -> + (Wall -> Bool) -> + Point2 -> + Point2 -> + World -> + Maybe (Point2, Either Creature Wall) thingHitFilt fcr fwl sp ep = List.find (f . snd) . thingsHit sp ep where f (Left cr) = fcr cr f (Right wl) = fwl wl ---thingHitFilt :: (Creature -> Bool) -> (Wall -> Bool) +--thingHitFilt :: (Creature -> Bool) -> (Wall -> Bool) -- -> Point2 -> Point2 -> World -> Maybe (Point2, Either Creature Wall) --thingHitFilt fcr fwl sp ep = runIdentity . S.head_ . S.filter (f . snd) . thingsHit sp ep -- where @@ -72,37 +83,43 @@ thingHit sp ep = listToMaybe . thingsHit sp ep {- List objects that appear on a line. Can filter out a creature. -} -thingsHitExceptCr - :: Maybe Int -- ^ A possible creature ID - -> Point2 -- ^ Line start point - -> Point2 -- ^ Line end point - -> World - -> [(Point2, Either Creature Wall)] -thingsHitExceptCr Nothing sp ep = thingsHit sp ep +thingsHitExceptCr :: + -- | A possible creature ID + Maybe Int -> + -- | Line start point + Point2 -> + -- | Line end point + Point2 -> + World -> + [(Point2, Either Creature Wall)] +thingsHitExceptCr Nothing sp ep = thingsHit sp ep thingsHitExceptCr (Just cid) sp ep = filter crNotCid . thingsHit sp ep - where - crNotCid (_,Left cr) = _crID cr /= cid + where + crNotCid (_, Left cr) = _crID cr /= cid crNotCid _ = True + --{- List objects that appear on a line. --Can filter out a creature. -} ---thingsHitExceptCr +--thingsHitExceptCr -- :: Maybe Int -- ^ A possible creature ID -- -> Point2 -- ^ Line start point -- -> Point2 -- ^ Line end point --- -> World +-- -> World -- -> StreamOf (Point2, Either Creature Wall) --thingsHitExceptCr Nothing sp ep = thingsHit sp ep --thingsHitExceptCr (Just cid) sp ep = S.filter crNotCid . thingsHit sp ep --- where +-- where -- crNotCid (_,Left cr) = _crID cr /= cid -- crNotCid _ = True wlsHit :: Point2 -> Point2 -> World -> [(Point2, Wall)] wlsHit sp ep - | sp == ep = const mempty - | otherwise = sortOn (dist sp . fst) - . overlapSegWalls sp ep - . wlsNearSeg sp ep + | sp == ep = const mempty + | otherwise = + sortOn (dist sp . fst) + . overlapSegWalls sp ep + . wlsNearSeg sp ep + --wlsHit :: Point2 -> Point2 -> World -> StreamOf (Point2, Wall) --wlsHit sp ep -- | sp == ep = const mempty @@ -116,6 +133,7 @@ wlsHitRadial p r = mapMaybe f . wlsNearCirc p r f wl = uncurry (intersectSegSeg p (p -.- r *.* v)) (_wlLine wl) <&> (,wl) where v = normalizeV $ vNormal $ uncurry (-.-) $ _wlLine wl + --wlsHitRadial :: Point2 -> Float -> World -> StreamOf (Point2, Wall) --wlsHitRadial p r = S.mapMaybe f . wlsInsideCirc p r -- where @@ -126,7 +144,7 @@ wlsHitRadial p r = mapMaybe f . wlsNearCirc p r crsHitRadial :: Point2 -> Float -> World -> [(Point2, Creature)] crsHitRadial p r = mapMaybe f . crsNearCirc p r where - f cr + f cr | dist cpos p <= r = Just (cpos +.+ r *.* normalizeV (p -.- cpos), cr) | otherwise = Nothing where diff --git a/src/Dodge/WorldPos.hs b/src/Dodge/WorldPos.hs index 0a9f212a8..46a360f4e 100644 --- a/src/Dodge/WorldPos.hs +++ b/src/Dodge/WorldPos.hs @@ -1,6 +1,7 @@ module Dodge.WorldPos where -import Dodge.Data + import Dodge.Base.You +import Dodge.Data.World import Geometry doWorldPos :: WdP2 -> World -> Point2 diff --git a/src/Dodge/Zone/Object.hs b/src/Dodge/Zone/Object.hs index a548a6fde..bb2250cab 100644 --- a/src/Dodge/Zone/Object.hs +++ b/src/Dodge/Zone/Object.hs @@ -1,9 +1,11 @@ module Dodge.Zone.Object where -import Dodge.Data -import Geometry.Zone + +import Dodge.Data.Creature +import Dodge.Data.Wall import Geometry.Data -import StreamingHelp +import Geometry.Zone import qualified Streaming.Prelude as S +import StreamingHelp zoneOfCreature :: Float -> Creature -> StreamOf Int2 zoneOfCreature x cr = zoneInsideCirc x (_crPos cr) (_crRad cr) diff --git a/src/Dodge/Zone/Update.hs b/src/Dodge/Zone/Update.hs index 82892e880..727bebb4e 100644 --- a/src/Dodge/Zone/Update.hs +++ b/src/Dodge/Zone/Update.hs @@ -1,12 +1,12 @@ -module Dodge.Zone.Update - ( updateZoning - ) where +module Dodge.Zone.Update ( + updateZoning, +) where + import Dodge.Data.Zoning -import StreamingHelp -import qualified Streaming.Prelude as S -import qualified IntMapHelp as IM import Geometry +import qualified IntMapHelp as IM import LensHelp +import qualified Streaming.Prelude as S updateZoning :: Monoid (t a) => (a -> t a -> t a) -> a -> Zoning t a -> Zoning t a {-# INLINE updateZoning #-} @@ -14,12 +14,14 @@ updateZoning f obj zn = runIdentity (S.fold_ doinsert zn id (_znFunc zn (_znSize where doinsert znobs vxy = insertInZoneWith vxy (\_ -> f obj) (f obj mempty) znobs -insertInZoneWith - :: Int2 - -> (t a -> t a -> t a) -- ^ Combining function - -> t a -- ^ Value to insert - -> Zoning t a - -> Zoning t a +insertInZoneWith :: + Int2 -> + -- | Combining function + (t a -> t a -> t a) -> + -- | Value to insert + t a -> + Zoning t a -> + Zoning t a {-# INLINE insertInZoneWith #-} insertInZoneWith (V2 x y) fun obj = over znObjects $ IM.insertWith f x $ IM.singleton y obj where diff --git a/src/Dodge/Zoning/Cloud.hs b/src/Dodge/Zoning/Cloud.hs index de9b1bb10..245825acf 100644 --- a/src/Dodge/Zoning/Cloud.hs +++ b/src/Dodge/Zoning/Cloud.hs @@ -1,12 +1,10 @@ -module Dodge.Zoning.Cloud - where -import Geometry.Vector -import Dodge.Zoning.Base -import Dodge.Data -import Geometry +module Dodge.Zoning.Cloud where --import Data.Foldable import Control.Lens +import Dodge.Data.World +import Dodge.Zoning.Base +import Geometry import qualified IntMapHelp as IM clsNearPoint :: Point2 -> World -> [Cloud] diff --git a/src/Dodge/Zoning/Creature.hs b/src/Dodge/Zoning/Creature.hs index ac4a9c6f5..3be20a438 100644 --- a/src/Dodge/Zoning/Creature.hs +++ b/src/Dodge/Zoning/Creature.hs @@ -1,15 +1,13 @@ module Dodge.Zoning.Creature where -import FoldableHelp -import Dodge.Data -import Geometry -import Dodge.Zoning.Base ---import qualified FoldlHelp as L -import qualified IntMapHelp as IM -import Data.Maybe ---import Data.Function -import qualified Data.IntSet as IS import Control.Lens +import qualified Data.IntSet as IS +import Data.Maybe +import Dodge.Data.World +import Dodge.Zoning.Base +import FoldableHelp +import Geometry +import qualified IntMapHelp as IM crIXsNearPoint :: Point2 -> World -> IS.IntSet crIXsNearPoint p w = zoneExtract (zoneOfPoint' crZoneSize p) (w ^. cWorld . crZoning) diff --git a/src/Dodge/Zoning/Pathing.hs b/src/Dodge/Zoning/Pathing.hs index f04a2a1c9..5e6dae317 100644 --- a/src/Dodge/Zoning/Pathing.hs +++ b/src/Dodge/Zoning/Pathing.hs @@ -1,56 +1,52 @@ -module Dodge.Zoning.Pathing - where -import Geometry.Vector -import Dodge.Zoning.Base -import Dodge.Data -import Geometry +module Dodge.Zoning.Pathing where -import Data.Foldable import Control.Lens +import Data.Foldable +import Dodge.Data.World +import Dodge.Zoning.Base +import Geometry import qualified IntMapHelp as IM -pnsNearPoint :: Point2 -> World -> [(Int,Point2)] +pnsNearPoint :: Point2 -> World -> [(Int, Point2)] pnsNearPoint p w = zoneExtract (zoneOfPoint' pnZoneSize p) (w ^. cWorld . pnZoning) -pnsNearSeg :: Point2 -> Point2 -> World -> [(Int,Point2)] +pnsNearSeg :: Point2 -> Point2 -> World -> [(Int, Point2)] pnsNearSeg sp ep w = zonesExtract (w ^. cWorld . pnZoning) (zoneOfSeg' pnZoneSize sp ep) -pnsNearRect :: Point2 -> Point2 -> World -> [(Int,Point2)] +pnsNearRect :: Point2 -> Point2 -> World -> [(Int, Point2)] pnsNearRect sp ep w = zonesExtract (w ^. cWorld . pnZoning) $ zoneOfRect' pnZoneSize sp ep -pnsNearCirc :: Point2 -> Float -> World -> [(Int,Point2)] +pnsNearCirc :: Point2 -> Float -> World -> [(Int, Point2)] pnsNearCirc p r = pnsNearRect (p +.+ V2 r r) (p -.- V2 r r) pnZoneSize :: Float pnZoneSize = 50 -zoneOfPn :: (Int,Point2) -> Int2 +zoneOfPn :: (Int, Point2) -> Int2 zoneOfPn = zoneOfPoint'' pnZoneSize . snd -zonePn :: (Int,Point2) -> IM.IntMap (IM.IntMap [(Int,Point2)]) -> IM.IntMap (IM.IntMap [(Int,Point2)]) +zonePn :: (Int, Point2) -> IM.IntMap (IM.IntMap [(Int, Point2)]) -> IM.IntMap (IM.IntMap [(Int, Point2)]) zonePn pn = zoneMonoid (zoneOfPn pn) [pn] - - -pesNearPoint :: Point2 -> World -> [(Int,Int,PathEdge)] +pesNearPoint :: Point2 -> World -> [(Int, Int, PathEdge)] pesNearPoint p w = zoneExtract (zoneOfPoint' peZoneSize p) (w ^. cWorld . peZoning) -pesNearSeg :: Point2 -> Point2 -> World -> [(Int,Int,PathEdge)] +pesNearSeg :: Point2 -> Point2 -> World -> [(Int, Int, PathEdge)] pesNearSeg sp ep w = zonesExtract (w ^. cWorld . peZoning) (zoneOfSeg' peZoneSize sp ep) -pesNearRect :: Point2 -> Point2 -> World -> [(Int,Int,PathEdge)] +pesNearRect :: Point2 -> Point2 -> World -> [(Int, Int, PathEdge)] pesNearRect sp ep w = zonesExtract (w ^. cWorld . peZoning) $ zoneOfRect' peZoneSize sp ep -pesNearCirc :: Point2 -> Float -> World -> [(Int,Int,PathEdge)] +pesNearCirc :: Point2 -> Float -> World -> [(Int, Int, PathEdge)] pesNearCirc p r = pesNearRect (p +.+ V2 r r) (p -.- V2 r r) peZoneSize :: Float peZoneSize = 50 -zoneOfPe :: (Int,Int,PathEdge) -> [Int2] -zoneOfPe (_,_,pe) = zoneOfSeg' peZoneSize (_peStart pe) (_peEnd pe) +zoneOfPe :: (Int, Int, PathEdge) -> [Int2] +zoneOfPe (_, _, pe) = zoneOfSeg' peZoneSize (_peStart pe) (_peEnd pe) -zonePe :: (Int,Int,PathEdge) -> IM.IntMap (IM.IntMap [(Int,Int,PathEdge)]) -> IM.IntMap (IM.IntMap [(Int,Int,PathEdge)]) +zonePe :: (Int, Int, PathEdge) -> IM.IntMap (IM.IntMap [(Int, Int, PathEdge)]) -> IM.IntMap (IM.IntMap [(Int, Int, PathEdge)]) zonePe pe im = foldl' f im (zoneOfPe pe) where f im' i2 = zoneMonoid i2 [pe] im' diff --git a/src/Dodge/Zoning/Wall.hs b/src/Dodge/Zoning/Wall.hs index 50d9a03cd..7dd44b001 100644 --- a/src/Dodge/Zoning/Wall.hs +++ b/src/Dodge/Zoning/Wall.hs @@ -1,13 +1,13 @@ module Dodge.Zoning.Wall where -import FoldableHelp -import Dodge.Data -import Geometry -import Dodge.Zoning.Base -import qualified IntMapHelp as IM -import Data.Maybe -import qualified Data.IntSet as IS import Control.Lens +import qualified Data.IntSet as IS +import Data.Maybe +import Dodge.Data.World +import Dodge.Zoning.Base +import FoldableHelp +import Geometry +import qualified IntMapHelp as IM wlIXsNearPoint :: Point2 -> World -> IS.IntSet wlIXsNearPoint p w = zoneExtract (zoneOfPoint' wlZoneSize p) (w ^. cWorld . wlZoning) diff --git a/src/Dodge/Zoning/World.hs b/src/Dodge/Zoning/World.hs index 824394e90..0ff92af44 100644 --- a/src/Dodge/Zoning/World.hs +++ b/src/Dodge/Zoning/World.hs @@ -1,17 +1,16 @@ module Dodge.Zoning.World where -import Dodge.Data + +import Dodge.Data.World import Geometry.Data zoneOfSight' :: Float -> World -> [Int2] -zoneOfSight' s w = - [ V2 a b +zoneOfSight' s w = + [ V2 a b | a <- [minimum xs .. maximum xs] , b <- [minimum ys .. maximum ys] ] - where - --(xs,ys) = unzip $ map zoneOfPoint $ screenPolygon cfig w -- ++ [_cameraViewFrom w] - (xs,ys) = unzip $ map sizeZoneOfPoint $ _boundBox (_cWorld w) -- ++ [_cameraViewFrom w] + where + (xs, ys) = unzip $ map sizeZoneOfPoint $ _boundBox (_cWorld w) -- ++ [_cameraViewFrom w] sizeZoneOfPoint (V2 x y) = (f x, f y) where f = floor . (/ s) - diff --git a/src/Picture/Data.hs b/src/Picture/Data.hs index 93d2c8495..7e6e359e9 100644 --- a/src/Picture/Data.hs +++ b/src/Picture/Data.hs @@ -1,25 +1,23 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE StrictData #-} {-# LANGUAGE TemplateHaskell #-} -module Picture.Data - where -import GHC.Generics -import Data.Aeson -import Geometry.Data + +module Picture.Data where import Control.Lens +import Data.Aeson +import Data.Aeson.TH +import Geometry.Data import Streaming + data Verx = Verx - { _vxPos :: !Point3 - , _vxCol :: !Point4 - , _vxExt :: [Float] - , _vxLayer :: !Layer - , _vxShadNum :: !ShadNum + { _vxPos :: !Point3 + , _vxCol :: !Point4 + , _vxExt :: [Float] + , _vxLayer :: !Layer + , _vxShadNum :: !ShadNum } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON Verx where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Verx + deriving (Eq, Ord, Show, Read) + data Layer = BottomLayer | MidLayer @@ -27,20 +25,17 @@ data Layer | BloomNoZWrite | DebugLayer | FixedCoordLayer - deriving (Eq,Ord,Enum,Bounded,Show,Read,Generic) -instance ToJSON Layer where - toEncoding = genericToEncoding defaultOptions -instance FromJSON Layer + deriving (Eq, Ord, Enum, Bounded, Show, Read) + layerNum :: Layer -> Int layerNum = fromEnum + numLayers :: Int -numLayers = length [minBound::Layer .. maxBound] ---TODO use synonyms for layer numbers -newtype ShadNum = ShadNum { _unShadNum :: Int } - deriving (Eq,Ord,Show,Read,Generic) -instance ToJSON ShadNum where - toEncoding = genericToEncoding defaultOptions -instance FromJSON ShadNum +numLayers = length [minBound :: Layer .. maxBound] + +newtype ShadNum = ShadNum {_unShadNum :: Int} + deriving (Eq, Ord, Show, Read) + polyNum, polyzNum, bezNum, textNum, arcNum, ellNum :: ShadNum {-# INLINE polyNum #-} {-# INLINE polyzNum #-} @@ -48,30 +43,48 @@ polyNum, polyzNum, bezNum, textNum, arcNum, ellNum :: ShadNum {-# INLINE textNum #-} {-# INLINE arcNum #-} {-# INLINE ellNum #-} -polyNum = ShadNum 0 -polyzNum = ShadNum 1 -bezNum = ShadNum 2 -textNum = ShadNum 3 -arcNum = ShadNum 4 -ellNum = ShadNum 5 +polyNum = ShadNum 0 +polyzNum = ShadNum 1 +bezNum = ShadNum 2 +textNum = ShadNum 3 +arcNum = ShadNum 4 +ellNum = ShadNum 5 + type Picture' = Stream (Of Verx) IO () + type Picture = [Verx] -flat2 :: V2 a -> [a] -flat2 (V2 x y) = [x,y] -flat3 :: V3 a -> [a] -flat3 (V3 x y z) = [x,y,z] -flat4 :: V4 a -> [a] -flat4 (V4 x y z w) = [x,y,z,w] -{-# INLINE flat2 #-} -{-# INLINE flat3 #-} -{-# INLINE flat4 #-} -tflat2 :: (a,a) -> [a] -tflat2 (x,y) = [x,y] -tflat3 :: (a,a,a) -> [a] -tflat3 (x,y,z) = [x,y,z] -tflat4 :: (a,a,a,a) -> [a] -tflat4 (x,y,z,w) = [x,y,z,w] + +flatV2 :: V2 a -> [a] +flatV2 (V2 x y) = [x, y] + +flatV3 :: V3 a -> [a] +flatV3 (V3 x y z) = [x, y, z] + +flatV4 :: V4 a -> [a] +flatV4 (V4 x y z w) = [x, y, z, w] + +{-# INLINE flatV2 #-} + +{-# INLINE flatV3 #-} + +{-# INLINE flatV4 #-} + +tflat2 :: (a, a) -> [a] +tflat2 (x, y) = [x, y] + +tflat3 :: (a, a, a) -> [a] +tflat3 (x, y, z) = [x, y, z] + +tflat4 :: (a, a, a, a) -> [a] +tflat4 (x, y, z, w) = [x, y, z, w] + {-# INLINE tflat2 #-} + {-# INLINE tflat3 #-} + {-# INLINE tflat4 #-} + makeLenses ''Verx +deriveJSON defaultOptions ''Verx +deriveJSON defaultOptions ''Layer +deriveJSON defaultOptions ''ShadNum