diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,47 @@ +## [v0.11.0.0](https://github.com/LambdaHack/LambdaHack/compare/v0.10.3.0...v0.11.0.0) + +- Partially work around regression in libsdl2 2.0.16 (https://github.com/LambdaHack/LambdaHack/issues/281); to also avoid deformed boxes around tiles on the game map, please switch to a different SDL2 version +- Deduplicate UI code for exiting game, with extra style points +- Create monadic test harness and use it for UI and other unit tests +- Validate empty content and fix other soundness issues revealed by unit tests +- Add extra hints in --more and similar lines when tutorial is on +- Show full history at SPACE press and let second SPACE close it +- Spawn insects in the swamp +- Remove slot letter display in menus and instead display subtle bullets +- Repurpose item slots to item roles +- Redo display and control of main menu and its submenus +- Make Teletype frontend a bit closer to playable +- Switch right pane item description display from mono to prop font +- Ensure score not zero if victory +- Add a custom SDL cursor, working around a bug in SDL2 bindings +- Gut out most content symbols; weren't used even in lore menus after all +- Add a flag to disable the costly optimizations (that give 15-25% speedup) +- Add faction kind content and redo game mode content to use it +- Display seen faction lore +- Simplify and fortify faction and client assignment code +- Make a few unique items that were identified meta-game identifiable instead +- Fix persistence of meta-game discoveries in save files +- When assigning a faction, first try the group actor was picked from +- When assigned faction is dead, don't spawn the actor +- Don't use benign weapons on projectiles not to lose the fun +- Make the unique harpoon worth saving for a unique foe +- Spawn enemies closer and fix too random spawning location +- Improve display of item's range +- Warn when SDL game windows is resized not via config file +- Ban or force sleep on levels +- Protect against unset or primitive OS locale +- Add temporary hearing aids +- Disallow generating a door beside an opening in room's wall +- Permit smaller caves and validate cave content more accurately +- Try harder to generate escape from dungeon in a level corner +- Avoid exit/escape confusion in content names and descriptions +- Extend LH game mode a descriptions since people play it instead of Allure +- Make sure every cave has a description +- Many fixes, refactorings and tweaks + ## [v0.10.3.0](https://github.com/LambdaHack/LambdaHack/compare/v0.10.2.0...v0.10.3.0) -- Work around regression https://gitlab.freedesktop.org/freetype/freetype/-/issues/1076 by making the scalable square font the default as the map font; the tiny map fonts, for which there is no such workaround, wont work for anybody with freetype 2.11.0 +- Work around regression https://gitlab.freedesktop.org/freetype/freetype/-/issues/1076 by making the scalable square font the default as the map font; the tiny map fonts, for which there is no such workaround, won't work for anybody with freetype 2.11.0 - Enable display of details in right pane in many menus - Switch mouse wheel to move selection now that it changes right pane display - Make the line where messages wrap configurable in config file diff --git a/CREDITS b/CREDITS --- a/CREDITS +++ b/CREDITS @@ -16,6 +16,14 @@ +Binary distributions of this package may be linked or bundled with libraries +such as SDL2, SDL_ttf, FreeType and many others. These libraries +are copyright of their respective owners, with all rights reserved. +In particular, portions of this software are copyright © 2021 The FreeType +Project (www.freetype.org). All rights reserved. + + + Fonts 16x16xw.woff, 16x16xw.bdf, 16x16x.fnt, 8x8x.fnt and 8x8xb.fnt are are derived from fonts taken from https://github.com/angband/angband, copyrighted by Leon Marrick, diff --git a/GameDefinition/Content/CaveKind.hs b/GameDefinition/Content/CaveKind.hs --- a/GameDefinition/Content/CaveKind.hs +++ b/GameDefinition/Content/CaveKind.hs @@ -2,7 +2,7 @@ -- cave kind. module Content.CaveKind ( -- * Group name patterns - pattern CAVE_ROGUE, pattern CAVE_ARENA, pattern CAVE_SMOKING, pattern CAVE_LABORATORY, pattern CAVE_NOISE, pattern CAVE_MINE, pattern CAVE_EMPTY, pattern CAVE_SHALLOW_ROGUE, pattern CAVE_OUTERMOST, pattern CAVE_RAID, pattern CAVE_BRAWL, pattern CAVE_SHOOTOUT, pattern CAVE_HUNT, pattern CAVE_ESCAPE, pattern CAVE_ZOO, pattern CAVE_AMBUSH, pattern CAVE_BATTLE, pattern CAVE_SAFARI_1, pattern CAVE_SAFARI_2, pattern CAVE_SAFARI_3 + pattern CAVE_ROGUE, pattern CAVE_ARENA, pattern CAVE_SMOKING, pattern CAVE_LABORATORY, pattern CAVE_NOISE, pattern CAVE_MINE, pattern CAVE_EMPTY, pattern CAVE_SHALLOW_ROGUE, pattern CAVE_OUTERMOST, pattern CAVE_RAID, pattern CAVE_BRAWL, pattern CAVE_SHOOTOUT, pattern CAVE_HUNT, pattern CAVE_FLIGHT, pattern CAVE_ZOO, pattern CAVE_AMBUSH, pattern CAVE_BATTLE, pattern CAVE_SAFARI_1, pattern CAVE_SAFARI_2, pattern CAVE_SAFARI_3 , groupNamesSingleton, groupNames , -- * Content content @@ -14,13 +14,6 @@ import Data.Ratio -import Content.ItemKind hiding - (content, groupNames, groupNamesSingleton) -import Content.ItemKindActor -import Content.PlaceKind hiding - (content, groupNames, groupNamesSingleton) -import Content.TileKind hiding - (content, groupNames, groupNamesSingleton) import Game.LambdaHack.Content.CaveKind import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.TileKind @@ -28,6 +21,11 @@ import Game.LambdaHack.Definition.Defs import Game.LambdaHack.Definition.DefsInternal +import Content.ItemKind hiding (content, groupNames, groupNamesSingleton) +import Content.ItemKindActor +import Content.PlaceKind hiding (content, groupNames, groupNamesSingleton) +import Content.TileKind hiding (content, groupNames, groupNamesSingleton) + -- * Group name patterns groupNamesSingleton :: [GroupName CaveKind] @@ -35,9 +33,9 @@ groupNames :: [GroupName CaveKind] groupNames = - [CAVE_ROGUE, CAVE_ARENA, CAVE_SMOKING, CAVE_LABORATORY, CAVE_NOISE, CAVE_MINE, CAVE_EMPTY, CAVE_SHALLOW_ROGUE, CAVE_OUTERMOST, CAVE_RAID, CAVE_BRAWL, CAVE_SHOOTOUT, CAVE_HUNT, CAVE_ESCAPE, CAVE_ZOO, CAVE_AMBUSH, CAVE_BATTLE, CAVE_SAFARI_1, CAVE_SAFARI_2, CAVE_SAFARI_3] + [CAVE_ROGUE, CAVE_ARENA, CAVE_SMOKING, CAVE_LABORATORY, CAVE_NOISE, CAVE_MINE, CAVE_EMPTY, CAVE_SHALLOW_ROGUE, CAVE_OUTERMOST, CAVE_RAID, CAVE_BRAWL, CAVE_SHOOTOUT, CAVE_HUNT, CAVE_FLIGHT, CAVE_ZOO, CAVE_AMBUSH, CAVE_BATTLE, CAVE_SAFARI_1, CAVE_SAFARI_2, CAVE_SAFARI_3] -pattern CAVE_ROGUE, CAVE_ARENA, CAVE_SMOKING, CAVE_LABORATORY, CAVE_NOISE, CAVE_MINE, CAVE_EMPTY, CAVE_SHALLOW_ROGUE, CAVE_OUTERMOST, CAVE_RAID, CAVE_BRAWL, CAVE_SHOOTOUT, CAVE_HUNT, CAVE_ESCAPE, CAVE_ZOO, CAVE_AMBUSH, CAVE_BATTLE, CAVE_SAFARI_1, CAVE_SAFARI_2, CAVE_SAFARI_3 :: GroupName CaveKind +pattern CAVE_ROGUE, CAVE_ARENA, CAVE_SMOKING, CAVE_LABORATORY, CAVE_NOISE, CAVE_MINE, CAVE_EMPTY, CAVE_SHALLOW_ROGUE, CAVE_OUTERMOST, CAVE_RAID, CAVE_BRAWL, CAVE_SHOOTOUT, CAVE_HUNT, CAVE_FLIGHT, CAVE_ZOO, CAVE_AMBUSH, CAVE_BATTLE, CAVE_SAFARI_1, CAVE_SAFARI_2, CAVE_SAFARI_3 :: GroupName CaveKind pattern CAVE_ROGUE = GroupName "caveRogue" pattern CAVE_ARENA = GroupName "caveArena" @@ -52,7 +50,7 @@ pattern CAVE_BRAWL = GroupName "caveBrawl" pattern CAVE_SHOOTOUT = GroupName "caveShootout" pattern CAVE_HUNT = GroupName "caveHunt" -pattern CAVE_ESCAPE = GroupName "caveEscape" +pattern CAVE_FLIGHT = GroupName "caveFlight" pattern CAVE_ZOO = GroupName "caveZoo" pattern CAVE_AMBUSH = GroupName "caveAmbush" pattern CAVE_BATTLE = GroupName "caveBattle" @@ -64,15 +62,14 @@ content :: [CaveKind] content = - [rogue, arena, smoking, laboratory, noise, mine, empty, outermost, shallowRogue, raid, brawl, shootout, hunt, escape, zoo, ambush, battle, safari1, safari2, safari3] + [rogue, arena, smoking, laboratory, noise, mine, empty, outermost, shallowRogue, raid, brawl, shootout, hunt, flight, zoo, ambush, battle, safari1, safari2, safari3] -rogue, arena, smoking, laboratory, noise, mine, empty, outermost, shallowRogue, raid, brawl, shootout, hunt, escape, zoo, ambush, battle, safari1, safari2, safari3 :: CaveKind +rogue, arena, smoking, laboratory, noise, mine, empty, outermost, shallowRogue, raid, brawl, shootout, hunt, flight, zoo, ambush, battle, safari1, safari2, safari3 :: CaveKind -- * Underground caves; most of mediocre height and size rogue = CaveKind - { csymbol = 'R' - , cname = "A maze of twisty passages" + { cname = "A maze of twisty passages" , cfreq = [(DEFAULT_RANDOM, 100), (CAVE_ROGUE, 1)] , cXminSize = 80 , cYminSize = 21 @@ -87,7 +84,7 @@ , cdoorChance = 3%4 , copenChance = 1%5 , chidden = 7 - , cactorCoeff = 65 -- the maze requires time to explore + , cactorCoeff = 70 -- the maze requires time to explore , cactorFreq = [(MONSTER, 60), (ANIMAL, 40)] , citemNum = 6 `d` 5 + 10 - 10 `dL` 1 -- deep down quality over quantity; generally quite random, @@ -95,7 +92,7 @@ , citemFreq = [(IK.COMMON_ITEM, 40), (IK.TREASURE, 60)] , cplaceFreq = [(ROGUE, 1)] , cpassable = False - , labyrinth = False + , clabyrinth = False , cdefTile = FILLER_WALL , cdarkCorTile = FLOOR_CORRIDOR_DARK , clitCorTile = FLOOR_CORRIDOR_LIT @@ -113,11 +110,11 @@ , (TINY_STAIRCASE, 1) ] , cstairAllowed = [] , cskip = [] + , cinitSleep = InitSleepPermitted , cdesc = "Winding tunnels stretch into the dark." } -- no lit corridors cave alternative, since both lit # and . look bad here arena = rogue - { csymbol = 'A' - , cname = "Dusty underground library" + { cname = "Dusty underground library" , cfreq = [(DEFAULT_RANDOM, 60), (CAVE_ARENA, 1)] , cXminSize = 50 , cYminSize = 21 @@ -132,7 +129,7 @@ , cauxConnects = 1 , cmaxVoid = 1%8 , chidden = 0 - , cactorCoeff = 75 -- small open level, don't rush the player + , cactorCoeff = 70 -- small open level, don't rush the player , cactorFreq = [(MONSTER, 30), (ANIMAL, 70)] , citemNum = 4 `d` 5 -- few rooms , citemFreq = [ (IK.COMMON_ITEM, 20), (IK.TREASURE, 40) @@ -146,7 +143,8 @@ , cmaxStairsNum = 1 `d` 2 , cstairFreq = [ (WALLED_STAIRCASE, 20), (CLOSED_STAIRCASE, 80) , (TINY_STAIRCASE, 1) ] - , cdesc = "The shelves groan with dusty books and tattered scrolls." + , cinitSleep = InitSleepAlways + , cdesc = "The shelves groan with dusty books and tattered scrolls. Subtle snoring can be heard from a distance." } smoking = arena { cname = "Smoking rooms" @@ -160,8 +158,7 @@ , cdesc = "Velvet couches exude the strong smell of tobacco." } laboratory = rogue - { csymbol = 'L' - , cname = "Burnt laboratory" + { cname = "Burnt laboratory" , cfreq = [(CAVE_LABORATORY, 1)] , cXminSize = 60 , cYminSize = 21 @@ -186,8 +183,7 @@ , cdesc = "Shattered glassware and the sharp scent of spilt chemicals show that something terrible happened here." } noise = rogue - { csymbol = 'N' - , cname = "Leaky burrowed sediment" + { cname = "Leaky burrowed sediment" , cfreq = [(DEFAULT_RANDOM, 30), (CAVE_NOISE, 1)] , cXminSize = 50 , cYminSize = 21 @@ -202,12 +198,12 @@ , cmaxVoid = 1%100 , cdoorChance = 1 -- to avoid lit quasi-door tiles , chidden = 0 - , cactorCoeff = 80 -- the maze requires time to explore; also, small + , cactorCoeff = 100 -- the maze requires time to explore; also, small , cactorFreq = [(MONSTER, 80), (ANIMAL, 20)] , citemNum = 6 `d` 5 -- an incentive to explore the labyrinth , cpassable = True - , labyrinth = True , cplaceFreq = [(NOISE, 1)] + , clabyrinth = True , cdefTile = NOISE_SET_LIT , cfenceApart = True -- ensures no cut-off parts from collapsed , cdarkCorTile = DAMP_FLOOR_DARK @@ -215,6 +211,7 @@ , cminStairDist = 15 , cstairFreq = [ (CLOSED_STAIRCASE, 50), (OPEN_STAIRCASE, 50) , (TINY_STAIRCASE, 1) ] + , cinitSleep = InitSleepBanned , cdesc = "Soon, these passages will be swallowed up by the mud." } mine = noise @@ -225,15 +222,16 @@ , citemFreq = [(IK.COMMON_ITEM, 20), (GEM, 20)] -- can't be "valuable" or template items generated , cplaceFreq = [(NOISE, 1), (MINE, 99)] + , clabyrinth = True , cdefTile = POWER_SET_DARK , cstairFreq = [ (GATED_CLOSED_STAIRCASE, 50) , (GATED_OPEN_STAIRCASE, 50) , (GATED_TINY_STAIRCASE, 1) ] + , cinitSleep = InitSleepBanned , cdesc = "Pillars of shining ice create a frozen labyrinth." } empty = rogue - { csymbol = 'E' - , cname = "Tall cavern" + { cname = "Tall cavern" , cfreq = [(CAVE_EMPTY, 1)] , ccellSize = DiceXY (2 `d` 2 + 11) (1 `d` 2 + 8) , cminPlaceSize = DiceXY 13 11 @@ -245,7 +243,7 @@ , cdoorChance = 0 , copenChance = 0 , chidden = 0 - , cactorCoeff = 7 + , cactorCoeff = 8 , cactorFreq = [(ANIMAL, 10), (IMMOBILE_ANIMAL, 90)] -- The healing geysers on lvl 3 act like HP resets. Needed to avoid -- cascading failure, if the particular starting conditions were @@ -266,18 +264,17 @@ , cdesc = "Swirls of warm fog fill the air, the hiss of geysers sounding all around." } outermost = shallowRogue - { csymbol = 'B' - , cname = "Cave entrance" + { cname = "Cave entrance" , cfreq = [(CAVE_OUTERMOST, 100)] , cXminSize = 40 , cYminSize = 21 , cdarkOdds = 0 -- all rooms lit, for a gentle start - , cactorCoeff = 80 -- already animals start there; also, pity on the noob + , cactorCoeff = 100 -- already animals start there; also, pity on the noob , cactorFreq = filter ((/= MONSTER) . fst) $ cactorFreq rogue - , citemNum = 6 `d` 5 -- lure them in with loot + , citemNum = 12 `d` 2 -- lure them in with loot; relatively consisten , citemFreq = filter ((/= IK.TREASURE) . fst) $ citemFreq rogue - , cminStairDist = 10 - , cmaxStairsNum = 1 + , cminStairDist = 10 -- distance from the escape + , cmaxStairsNum = 1 -- simplify at the start , cescapeFreq = [(INDOOR_ESCAPE_UP, 1)] , cdesc = "This close to the surface, the sunlight still illuminates the dungeon." } @@ -285,15 +282,14 @@ { cfreq = [(CAVE_SHALLOW_ROGUE, 100)] , cXminSize = 60 , cYminSize = 21 - , cmaxStairsNum = 1 -- ensure heroes meet initial monsters and their loot + , cmaxStairsNum = 1 -- simplify at the start , cdesc = "The snorts and grunts of savage beasts can be clearly heard." } -- * Overground "caves"; no story-wise limits wrt height and size raid = rogue - { csymbol = 'T' - , cname = "Typing den" + { cname = "Typing den" , cfreq = [(CAVE_RAID, 1)] , cXminSize = 50 , cYminSize = 21 @@ -302,22 +298,23 @@ , cmaxPlaceSize = DiceXY 16 20 , cdarkOdds = 0 -- all rooms lit, for a gentle start , cmaxVoid = 1%10 - , cactorCoeff = 250 -- deep level with no kit, so slow spawning + , cdoorChance = 1 -- make sure enemies not seen on turn 1 + , copenChance = 0 -- make sure enemies not seen on turn 1 + , cactorCoeff = 300 -- deep level with no kit, so slow spawning , cactorFreq = [(ANIMAL, 100)] - , citemNum = 6 `d` 6 -- just one level, hard enemies, treasure + , citemNum = 18 -- first tutorial mode, so make it consistent , citemFreq = [ (IK.COMMON_ITEM, 100), (IK.S_CURRENCY, 500) , (STARTING_WEAPON, 100) ] , cmaxStairsNum = 0 , cescapeFreq = [(INDOOR_ESCAPE_UP, 1)] , cstairFreq = [] , cstairAllowed = [] - , cdesc = "" + , cdesc = "Mold spreads across the walls and scuttling sounds can be heard in the distance." } brawl = rogue -- many random solid tiles, to break LOS, since it's a day -- and this scenario is not focused on ranged combat; -- also, sanctuaries against missiles in shadow under trees - { csymbol = 'b' - , cname = "Sunny woodland" + { cname = "Sunny woodland" , cfreq = [(CAVE_BRAWL, 1)] , cXminSize = 60 , cYminSize = 21 @@ -351,8 +348,7 @@ -- opaque tiles, to make scouting and sniping more interesting -- and to avoid obstructing view too much, since this -- scenario is about ranged combat at long range - { csymbol = 'S' - , cname = "Misty meadow" + { cname = "Misty meadow" , cfreq = [(CAVE_SHOOTOUT, 1)] , ccellSize = DiceXY (1 `d` 2 + 6) 6 , cminPlaceSize = DiceXY 3 3 @@ -383,11 +379,10 @@ , cfenceTileS = OUTDOOR_OUTER_FENCE , cfenceTileW = OUTDOOR_OUTER_FENCE , cmaxStairsNum = 0 - , cdesc = "" + , cdesc = "The warmth has released fog and the wind brooms it away." } hunt = rogue -- a scenario with strong missiles for ranged and shade for melee - { csymbol = 'H' - , cname = "Noon swamp" + { cname = "Afternoon swamp" , cfreq = [(CAVE_HUNT, 1)] , ccellSize = DiceXY (1 `d` 2 + 6) 6 , cminPlaceSize = DiceXY 3 3 @@ -398,7 +393,8 @@ , cdoorChance = 1 , copenChance = 0 , chidden = 0 - , cactorFreq = [] + , cactorCoeff = 400 -- spawn slowly + , cactorFreq = [(INSECT, 100)] , citemNum = 5 `d` 10 , citemFreq = [ (IK.COMMON_ITEM, 30) , (ANY_ARROW, 400), (HARPOON, 300), (IK.EXPLOSIVE, 50) ] @@ -413,15 +409,14 @@ , cfenceTileS = OUTDOOR_OUTER_FENCE , cfenceTileW = OUTDOOR_OUTER_FENCE , cmaxStairsNum = 0 - , cdesc = "" + , cdesc = "Tired after the day's heat, the insects gather strength in their hiding places." } -escape = rogue -- a scenario with weak missiles, because heroes don't depend +flight = rogue -- a scenario with weak missiles, because heroes don't depend -- on them; dark, so solid obstacles are to hide from missiles, -- not view; obstacles are not lit, to frustrate the AI; -- lots of small lights to cross, to have some risks - { csymbol = 'E' - , cname = "Metropolitan park at dusk" -- "night" didn't fit - , cfreq = [(CAVE_ESCAPE, 1)] + { cname = "Metropolitan park at dusk" -- "night" didn't fit + , cfreq = [(CAVE_FLIGHT, 1)] , ccellSize = DiceXY (1 `d` 3 + 7) 6 , cminPlaceSize = DiceXY 5 3 , cmaxPlaceSize = DiceXY 9 9 -- bias towards larger lamp areas @@ -435,9 +430,9 @@ , citemFreq = [ (IK.COMMON_ITEM, 30), (GEM, 500) , (WEAK_ARROW, 500), (HARPOON, 400) , (IK.EXPLOSIVE, 100) ] - , cplaceFreq = [(ESCAPE, 1)] + , cplaceFreq = [(FLIGHT, 1)] , cpassable = True - , cdefTile = ESCAPE_SET_DARK -- unlike in ambush, tiles not burning yet + , cdefTile = FLIGHT_SET_DARK -- unlike in ambush, tiles not burning yet , cdarkCorTile = SAFE_TRAIL_LIT -- let trails give off light , clitCorTile = SAFE_TRAIL_LIT , cfenceTileN = OUTDOOR_OUTER_FENCE @@ -447,12 +442,11 @@ , cmaxStairsNum = 0 , cescapeFreq = [(OUTDOOR_ESCAPE_DOWN, 1)] , cstairFreq = [] - , cskip = [0] -- don't start heroes nor opponents on escape - , cdesc = "" + , cskip = [] + , cdesc = "The darkening greyness is settling into silence." } zoo = rogue -- few lights and many solids, to help the less numerous heroes - { csymbol = 'Z' - , cname = "Menagerie in flames" + { cname = "Menagerie in flames" , cfreq = [(CAVE_ZOO, 1)] , ccellSize = DiceXY (1 `d` 3 + 7) 6 , cminPlaceSize = DiceXY 4 4 @@ -479,7 +473,7 @@ , cfenceTileS = OUTDOOR_OUTER_FENCE , cfenceTileW = OUTDOOR_OUTER_FENCE , cmaxStairsNum = 0 - , cdesc = "" + , cdesc = "The night is filled with animal calls." } ambush = rogue -- a scenario with strong missiles; -- dark, so solid obstacles are to hide from missiles, @@ -490,8 +484,7 @@ -- of missiles are usually not seen, so enemy can't be guessed; -- camping doesn't pay off, because enemies can sneak and only -- active scouting, throwing flares and shooting discovers them - { csymbol = 'M' - , cname = "Burning metropolitan park" + { cname = "Burning metropolitan park" , cfreq = [(CAVE_AMBUSH, 1)] , ccellSize = DiceXY (1 `d` 4 + 7) 6 , cminPlaceSize = DiceXY 5 3 @@ -515,14 +508,13 @@ , cfenceTileS = OUTDOOR_OUTER_FENCE , cfenceTileW = OUTDOOR_OUTER_FENCE , cmaxStairsNum = 0 - , cdesc = "" + , cdesc = "Fires have reached into the city, glowing in darkness." } -- * Other caves; testing, Easter egg, future work battle = rogue -- few lights and many solids, to help the less numerous heroes - { csymbol = 'B' - , cname = "Old battle ground" + { cname = "Old battle ground" , cfreq = [(CAVE_BATTLE, 1)] , ccellSize = DiceXY (5 `d` 3 + 11) 5 -- cfenceApart results in 2 rows , cminPlaceSize = DiceXY 4 4 @@ -549,7 +541,7 @@ , cfenceApart = True -- ensures no cut-off parts from collapsed , cmaxStairsNum = 0 , cstairFreq = [] - , cdesc = "" + , cdesc = "Eroded walls, rusted weapons and unidentifiable bones cruch underfoot all alike." } safari1 = brawl { cname = "Hunam habitat" @@ -562,7 +554,7 @@ , cskip = [0] , cdesc = "\"Act 1. Hunams scavenge in a forest in their usual disgusting way.\"" } -safari2 = escape -- lamps instead of trees, but ok, it's only a simulation +safari2 = flight -- lamps instead of trees, but ok, it's only a simulation { cname = "Deep into the jungle" , cfreq = [(CAVE_SAFARI_2, 1)] , cmaxStairsNum = 1 diff --git a/GameDefinition/Content/FactionKind.hs b/GameDefinition/Content/FactionKind.hs new file mode 100644 --- /dev/null +++ b/GameDefinition/Content/FactionKind.hs @@ -0,0 +1,369 @@ +-- | Definitions of kinds of factions present in a game, both human +-- and computer-controlled. +module Content.FactionKind + ( -- * Group name patterns + pattern EXPLORER_REPRESENTATIVE, pattern EXPLORER_SHORT, pattern EXPLORER_NO_ESCAPE, pattern EXPLORER_MEDIUM, pattern EXPLORER_TRAPPED, pattern EXPLORER_AUTOMATED, pattern EXPLORER_AUTOMATED_TRAPPED, pattern EXPLORER_CAPTIVE, pattern EXPLORER_PACIFIST, pattern COMPETITOR_REPRESENTATIVE, pattern COMPETITOR_SHORT, pattern COMPETITOR_NO_ESCAPE, pattern CIVILIAN_REPRESENTATIVE, pattern CONVICT_REPRESENTATIVE, pattern MONSTER_REPRESENTATIVE, pattern MONSTER_ANTI, pattern MONSTER_ANTI_CAPTIVE, pattern MONSTER_ANTI_PACIFIST, pattern MONSTER_TOURIST, pattern MONSTER_TOURIST_PASSIVE, pattern MONSTER_CAPTIVE, pattern MONSTER_CAPTIVE_NARRATING, pattern ANIMAL_REPRESENTATIVE, pattern ANIMAL_MAGNIFICENT, pattern ANIMAL_EXQUISITE, pattern ANIMAL_CAPTIVE, pattern ANIMAL_NARRATING, pattern ANIMAL_MAGNIFICENT_NARRATING, pattern ANIMAL_CAPTIVE_NARRATING, pattern HORROR_REPRESENTATIVE, pattern HORROR_CAPTIVE, pattern HORROR_PACIFIST + , pattern REPRESENTATIVE + , groupNamesSingleton, groupNames + , -- * Content + content +#ifdef EXPOSE_INTERNAL + -- * Group name patterns +#endif + ) where + +import Prelude () + +import Game.LambdaHack.Core.Prelude + +import Game.LambdaHack.Content.FactionKind +import qualified Game.LambdaHack.Content.ItemKind as IK +import Game.LambdaHack.Definition.Ability +import Game.LambdaHack.Definition.Defs +import Game.LambdaHack.Definition.DefsInternal + +import Content.ItemKindActor +import Content.ItemKindOrgan + +-- * Group name patterns + +groupNamesSingleton :: [GroupName FactionKind] +groupNamesSingleton = + [EXPLORER_REPRESENTATIVE, EXPLORER_SHORT, EXPLORER_NO_ESCAPE, EXPLORER_MEDIUM, EXPLORER_TRAPPED, EXPLORER_AUTOMATED, EXPLORER_AUTOMATED_TRAPPED, EXPLORER_CAPTIVE, EXPLORER_PACIFIST, COMPETITOR_REPRESENTATIVE, COMPETITOR_SHORT, COMPETITOR_NO_ESCAPE, CIVILIAN_REPRESENTATIVE, CONVICT_REPRESENTATIVE, MONSTER_REPRESENTATIVE, MONSTER_ANTI, MONSTER_ANTI_CAPTIVE, MONSTER_ANTI_PACIFIST, MONSTER_TOURIST, MONSTER_TOURIST_PASSIVE, MONSTER_CAPTIVE, MONSTER_CAPTIVE_NARRATING, ANIMAL_REPRESENTATIVE, ANIMAL_MAGNIFICENT, ANIMAL_EXQUISITE, ANIMAL_CAPTIVE, ANIMAL_NARRATING, ANIMAL_MAGNIFICENT_NARRATING, ANIMAL_CAPTIVE_NARRATING, HORROR_REPRESENTATIVE, HORROR_CAPTIVE, HORROR_PACIFIST] + +pattern EXPLORER_REPRESENTATIVE, EXPLORER_SHORT, EXPLORER_NO_ESCAPE, EXPLORER_MEDIUM, EXPLORER_TRAPPED, EXPLORER_AUTOMATED, EXPLORER_AUTOMATED_TRAPPED, EXPLORER_CAPTIVE, EXPLORER_PACIFIST, COMPETITOR_REPRESENTATIVE, COMPETITOR_SHORT, COMPETITOR_NO_ESCAPE, CIVILIAN_REPRESENTATIVE, CONVICT_REPRESENTATIVE, MONSTER_REPRESENTATIVE, MONSTER_ANTI, MONSTER_ANTI_CAPTIVE, MONSTER_ANTI_PACIFIST, MONSTER_TOURIST, MONSTER_TOURIST_PASSIVE, MONSTER_CAPTIVE, MONSTER_CAPTIVE_NARRATING, ANIMAL_REPRESENTATIVE, ANIMAL_MAGNIFICENT, ANIMAL_EXQUISITE, ANIMAL_CAPTIVE, ANIMAL_NARRATING, ANIMAL_MAGNIFICENT_NARRATING, ANIMAL_CAPTIVE_NARRATING, HORROR_REPRESENTATIVE, HORROR_CAPTIVE, HORROR_PACIFIST :: GroupName FactionKind + +groupNames :: [GroupName FactionKind] +groupNames = [REPRESENTATIVE] + +pattern REPRESENTATIVE :: GroupName FactionKind + +pattern REPRESENTATIVE = GroupName "representative" +pattern EXPLORER_REPRESENTATIVE = GroupName "explorer" +pattern EXPLORER_SHORT = GroupName "explorer short" +pattern EXPLORER_NO_ESCAPE = GroupName "explorer no escape" +pattern EXPLORER_MEDIUM = GroupName "explorer medium" +pattern EXPLORER_TRAPPED = GroupName "explorer trapped" +pattern EXPLORER_AUTOMATED = GroupName "explorer automated" +pattern EXPLORER_AUTOMATED_TRAPPED = GroupName "explorer automated trapped" +pattern EXPLORER_CAPTIVE = GroupName "explorer captive" +pattern EXPLORER_PACIFIST = GroupName "explorer pacifist" +pattern COMPETITOR_REPRESENTATIVE = GroupName "competitor" +pattern COMPETITOR_SHORT = GroupName "competitor short" +pattern COMPETITOR_NO_ESCAPE = GroupName "competitor no escape" +pattern CIVILIAN_REPRESENTATIVE = GroupName "civilian" +pattern CONVICT_REPRESENTATIVE = GroupName "convict" +pattern MONSTER_REPRESENTATIVE = GroupName "monster" +pattern MONSTER_ANTI = GroupName "monster anti" +pattern MONSTER_ANTI_CAPTIVE = GroupName "monster anti captive" +pattern MONSTER_ANTI_PACIFIST = GroupName "monster anti pacifist" +pattern MONSTER_TOURIST = GroupName "monster tourist" +pattern MONSTER_TOURIST_PASSIVE = GroupName "monster tourist passive" +pattern MONSTER_CAPTIVE = GroupName "monster captive" +pattern MONSTER_CAPTIVE_NARRATING = GroupName "monster captive narrating" +pattern ANIMAL_REPRESENTATIVE = GroupName "animal" +pattern ANIMAL_MAGNIFICENT = GroupName "animal magnificent" +pattern ANIMAL_EXQUISITE = GroupName "animal exquisite" +pattern ANIMAL_CAPTIVE = GroupName "animal captive" +pattern ANIMAL_NARRATING = GroupName "animal narrating" +pattern ANIMAL_MAGNIFICENT_NARRATING = GroupName "animal magnificent narrating" +pattern ANIMAL_CAPTIVE_NARRATING = GroupName "animal captive narrating" +pattern HORROR_REPRESENTATIVE = GroupName "horror" +pattern HORROR_CAPTIVE = GroupName "horror captive" +pattern HORROR_PACIFIST = GroupName "horror pacifist" + +-- * Teams + +teamCompetitor, teamCivilian, teamConvict, teamMonster, teamAnimal, teamHorror, teamOther :: TeamContinuity +teamCompetitor = TeamContinuity 2 +teamCivilian = TeamContinuity 3 +teamConvict = TeamContinuity 4 +teamMonster = TeamContinuity 5 +teamAnimal = TeamContinuity 6 +teamHorror = TeamContinuity 7 +teamOther = TeamContinuity 10 + +-- * Content + +content :: [FactionKind] +content = [factExplorer, factExplorerShort, factExplorerNoEscape, factExplorerMedium, factExplorerTrapped, factExplorerAutomated, factExplorerAutomatedTrapped, factExplorerCaptive, factExplorerPacifist, factCompetitor, factCompetitorShort, factCompetitorNoEscape, factCivilian, factConvict, factMonster, factMonsterAnti, factMonsterAntiCaptive, factMonsterAntiPacifist, factMonsterTourist, factMonsterTouristPassive, factMonsterCaptive, factMonsterCaptiveNarrating, factAnimal, factAnimalMagnificent, factAnimalExquisite, factAnimalCaptive, factAnimalNarrating, factAnimalMagnificentNarrating, factAnimalCaptiveNarrating, factHorror, factHorrorCaptive, factHorrorPacifist] + +factExplorer, factExplorerShort, factExplorerNoEscape, factExplorerMedium, factExplorerTrapped, factExplorerAutomated, factExplorerAutomatedTrapped, factExplorerCaptive, factExplorerPacifist, factCompetitor, factCompetitorShort, factCompetitorNoEscape, factCivilian, factConvict, factMonster, factMonsterAnti, factMonsterAntiCaptive, factMonsterAntiPacifist, factMonsterTourist, factMonsterTouristPassive, factMonsterCaptive, factMonsterCaptiveNarrating, factAnimal, factAnimalMagnificent, factAnimalExquisite, factAnimalCaptive, factAnimalNarrating, factAnimalMagnificentNarrating, factAnimalCaptiveNarrating, factHorror, factHorrorCaptive, factHorrorPacifist :: FactionKind + +-- * Content + +-- ** teamExplorer + +factExplorer = FactionKind + { fname = "Explorer" + , ffreq = [(EXPLORER_REPRESENTATIVE, 1), (REPRESENTATIVE, 1)] + , fteam = teamExplorer + , fgroups = [(HERO, 100)] -- don't spam the escapists, etc., in description + , fskillsOther = meleeAdjacent + , fcanEscape = True + , fneverEmpty = True + , fhiCondPoly = hiHeroLong + , fhasGender = True + , finitDoctrine = TExplore + , fspawnsFast = False + , fhasPointman = True + , fhasUI = True + , finitUnderAI = False + , fenemyTeams = [teamCompetitor, teamMonster, teamAnimal, teamHorror] + , falliedTeams = [] + } +factExplorerShort = factExplorer + { ffreq = [(EXPLORER_SHORT, 1)] + , fhiCondPoly = hiHeroShort + , fenemyTeams = [teamMonster, teamAnimal, teamHorror] + } +factExplorerNoEscape = factExplorer + { ffreq = [(EXPLORER_NO_ESCAPE, 1)] + , fcanEscape = False + , fhiCondPoly = hiHeroMedium + } +factExplorerMedium = factExplorer + { ffreq = [(EXPLORER_MEDIUM, 1)] + , fhiCondPoly = hiHeroMedium + } +factExplorerTrapped = factExplorer + { ffreq = [(EXPLORER_TRAPPED, 1)] + , fcanEscape = False + , fhiCondPoly = hiHeroLong + } +factExplorerAutomated = factExplorer + { ffreq = [(EXPLORER_AUTOMATED, 1)] + , fhasUI = False + , finitUnderAI = True + } +factExplorerAutomatedTrapped = factExplorerAutomated + { ffreq = [(EXPLORER_AUTOMATED_TRAPPED, 1)] + , fcanEscape = False + , fhiCondPoly = hiHeroLong + } +factExplorerCaptive = factExplorer + { ffreq = [(EXPLORER_CAPTIVE, 1)] + , fneverEmpty = True -- already there + } +factExplorerPacifist = factExplorerCaptive + { ffreq = [(EXPLORER_PACIFIST, 1)] + , fenemyTeams = [] + , falliedTeams = [] + } + +-- ** teamCompetitor, symmetric opponents of teamExplorer + +factCompetitor = factExplorer + { fname = "Indigo Researcher" + , ffreq = [(COMPETITOR_REPRESENTATIVE, 1), (REPRESENTATIVE, 1)] + , fteam = teamCompetitor + , fhasUI = False + , finitUnderAI = True + , fenemyTeams = [teamExplorer, teamMonster, teamAnimal, teamHorror] + , falliedTeams = [] + } +factCompetitorShort = factCompetitor + { fname = "Indigo Founder" -- early + , ffreq = [(COMPETITOR_SHORT, 1)] + , fhiCondPoly = hiHeroShort + , fenemyTeams = [teamMonster, teamAnimal, teamHorror] + } +factCompetitorNoEscape = factCompetitor + { ffreq = [(COMPETITOR_NO_ESCAPE, 1)] + , fcanEscape = False + , fhiCondPoly = hiHeroMedium + } + +-- ** teamCivilian + +factCivilian = FactionKind + { fname = "Civilian" + , ffreq = [(CIVILIAN_REPRESENTATIVE, 1), (REPRESENTATIVE, 1)] + , fteam = teamCivilian + , fgroups = [(HERO, 100), (CIVILIAN, 100)] -- symmetric vs player + , fskillsOther = zeroSkills -- not coordinated by any leadership + , fcanEscape = False + , fneverEmpty = True + , fhiCondPoly = hiHeroMedium + , fhasGender = True + , finitDoctrine = TPatrol + , fspawnsFast = False + , fhasPointman = False -- unorganized + , fhasUI = False + , finitUnderAI = True + , fenemyTeams = [teamMonster, teamAnimal, teamHorror] + , falliedTeams = [] + } + +-- ** teamConvict, different demographics + +factConvict = factCivilian + { fname = "Hunam Convict" + , ffreq = [(CONVICT_REPRESENTATIVE, 1), (REPRESENTATIVE, 1)] + , fteam = teamConvict + , fhasPointman = True -- convicts organize better + , finitUnderAI = True + , fenemyTeams = [teamMonster, teamAnimal, teamHorror] + , falliedTeams = [] + } + +-- ** teamMonster + +factMonster = FactionKind + { fname = "Monster Hive" + , ffreq = [(MONSTER_REPRESENTATIVE, 1), (REPRESENTATIVE, 1)] + , fteam = teamMonster + , fgroups = [ (MONSTER, 100) + , (MOBILE_MONSTER, 1) ] + , fskillsOther = zeroSkills + , fcanEscape = False + , fneverEmpty = False + , fhiCondPoly = hiDweller + , fhasGender = False + , finitDoctrine = TExplore + , fspawnsFast = True + , fhasPointman = True + , fhasUI = False + , finitUnderAI = True + , fenemyTeams = [teamExplorer, teamCompetitor, teamCivilian, teamConvict] + , falliedTeams = [teamAnimal] + } +-- This has continuity @teamMonster@, despite being playable. +factMonsterAnti = factMonster + { ffreq = [(MONSTER_ANTI, 1)] + , fhasUI = True + , finitUnderAI = False + } +factMonsterAntiCaptive = factMonsterAnti + { ffreq = [(MONSTER_ANTI_CAPTIVE, 1)] + , fneverEmpty = True + } +factMonsterAntiPacifist = factMonsterAntiCaptive + { ffreq = [(MONSTER_ANTI_PACIFIST, 1)] + , fenemyTeams = [] + , falliedTeams = [] + } +-- More flavour and special backstory, but the same team. +factMonsterTourist = factMonsterAnti + { fname = "Monster Tourist Office" + , ffreq = [(MONSTER_TOURIST, 1)] + , fcanEscape = True + , fneverEmpty = True -- no spawning + , fhiCondPoly = hiHeroMedium + , finitDoctrine = TFollow -- follow-the-guide, as tourists do + , fspawnsFast = False -- on a trip, so no spawning + , finitUnderAI = False + , fenemyTeams = + [teamAnimal, teamExplorer, teamCompetitor, teamCivilian, teamConvict] + , falliedTeams = [] + } +factMonsterTouristPassive = factMonsterTourist + { ffreq = [(MONSTER_TOURIST_PASSIVE, 1)] + , fhasUI = False + , finitUnderAI = True + } +factMonsterCaptive = factMonster + { ffreq = [(MONSTER_CAPTIVE, 1)] + , fneverEmpty = True + } +factMonsterCaptiveNarrating = factMonsterAntiCaptive + { ffreq = [(MONSTER_CAPTIVE_NARRATING, 1)] + , fhasUI = True + } + +-- ** teamAnimal + +factAnimal = FactionKind + { fname = "Animal Kingdom" + , ffreq = [(ANIMAL_REPRESENTATIVE, 1), (REPRESENTATIVE, 1)] + , fteam = teamAnimal + , fgroups = [ (ANIMAL, 100), (INSECT, 100), (GEOPHENOMENON, 100) + -- only the distinct enough ones + , (MOBILE_ANIMAL, 1), (IMMOBILE_ANIMAL, 1), (SCAVENGER, 1) ] + , fskillsOther = zeroSkills + , fcanEscape = False + , fneverEmpty = False + , fhiCondPoly = hiDweller + , fhasGender = False + , finitDoctrine = TRoam -- can't pick up, so no point exploring + , fspawnsFast = True + , fhasPointman = False + , fhasUI = False + , finitUnderAI = True + , fenemyTeams = [teamExplorer, teamCompetitor, teamCivilian, teamConvict] + , falliedTeams = [teamMonster] + } +-- These two differ from outside, but share information and boasting +-- about them tends to be general, too. +factAnimalMagnificent = factAnimal + { fname = "Animal Magnificent Specimen Variety" + , ffreq = [(ANIMAL_MAGNIFICENT, 1)] + , fneverEmpty = True + , fenemyTeams = + [teamMonster, teamExplorer, teamCompetitor, teamCivilian, teamConvict] + , falliedTeams = [] + } +factAnimalExquisite = factAnimal + { fname = "Animal Exquisite Herds and Packs Galore" + , ffreq = [(ANIMAL_EXQUISITE, 1)] + , fteam = teamOther + -- in the same mode as @factAnimalMagnificent@, so borrow + -- identity from horrors to avoid a clash + , fneverEmpty = True + , fenemyTeams = + [teamMonster, teamExplorer, teamCompetitor, teamCivilian, teamConvict] + , falliedTeams = [] + } +factAnimalCaptive = factAnimal + { ffreq = [(ANIMAL_CAPTIVE, 1)] + , fneverEmpty = True + } +factAnimalNarrating = factAnimal + { ffreq = [(ANIMAL_NARRATING, 1)] + , fhasUI = True + } +factAnimalMagnificentNarrating = factAnimalMagnificent + { ffreq = [(ANIMAL_MAGNIFICENT_NARRATING, 1)] + , fhasPointman = True + , fhasUI = True + , finitUnderAI = False + } +factAnimalCaptiveNarrating = factAnimalCaptive + { ffreq = [(ANIMAL_CAPTIVE_NARRATING, 1)] + , fhasUI = True + } + +-- ** teamHorror, not much of a continuity intended, but can't be ignored + +-- | A special faction, for summoned actors that don't belong to any +-- of the main factions of a given game. E.g., animals summoned during +-- a brawl game between two hero factions land in the horror faction. +-- In every game, either all factions for which summoning items exist +-- should be present or a horror faction should be added to host them. +factHorror = FactionKind + { fname = "Horror Den" + , ffreq = [(HORROR_REPRESENTATIVE, 1), (REPRESENTATIVE, 1)] + , fteam = teamHorror + , fgroups = [(IK.HORROR, 100)] + , fskillsOther = zeroSkills + , fcanEscape = False + , fneverEmpty = False + , fhiCondPoly = [] + , fhasGender = False + , finitDoctrine = TPatrol -- disoriented + , fspawnsFast = False + , fhasPointman = False + , fhasUI = False + , finitUnderAI = True + , fenemyTeams = [teamExplorer, teamCompetitor, teamCivilian, teamConvict] + , falliedTeams = [] + } +factHorrorCaptive = factHorror + { ffreq = [(HORROR_CAPTIVE, 1)] + , fneverEmpty = True + } +factHorrorPacifist = factHorrorCaptive + { ffreq = [(HORROR_PACIFIST, 1)] + , fenemyTeams = [] + , falliedTeams = [] + } diff --git a/GameDefinition/Content/ItemKind.hs b/GameDefinition/Content/ItemKind.hs --- a/GameDefinition/Content/ItemKind.hs +++ b/GameDefinition/Content/ItemKind.hs @@ -1,4 +1,4 @@ --- | Item definitions. +-- | Definitions of basic items. module Content.ItemKind ( -- * Group name patterns pattern HARPOON, pattern EDIBLE_PLANT, pattern RING_OF_OPPORTUNITY_GRENADIER, pattern ARMOR_LOOSE, pattern CLOTHING_MISC, pattern CHIC_GEAR @@ -11,12 +11,6 @@ import Game.LambdaHack.Core.Prelude -import Content.ItemKindActor -import Content.ItemKindBlast -import Content.ItemKindEmbed -import Content.ItemKindOrgan -import Content.ItemKindTemporary -import Content.RuleKind import Game.LambdaHack.Content.ItemKind import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Core.Dice @@ -26,6 +20,13 @@ import Game.LambdaHack.Definition.DefsInternal import Game.LambdaHack.Definition.Flavour +import Content.ItemKindActor +import Content.ItemKindBlast +import Content.ItemKindEmbed +import Content.ItemKindOrgan +import Content.ItemKindTemporary +import Content.RuleKind + -- * Group name patterns groupNamesSingleton :: [GroupName ItemKind] @@ -265,12 +266,13 @@ , ikit = [] } harpoon2 = harpoon - { iname = "whaling harpoon" - , ifreq = [(COMMON_ITEM, 5), (HARPOON, 2)] + { iname = "The whaling Harpoon" + , ifreq = [(COMMON_ITEM, 10), (HARPOON, 2)] , icount = 2 `dL` 5 , iweight = 1000 - , idamage = 10 `d` 1 - , idesc = "With a brittle, barbed head and thick cord, this ancient weapon is designed for formidable prey." + , idamage = 21 `d` 1 + , iaspects = SetFlag Unique : delete (SetFlag Durable) (iaspects harpoon) + , idesc = "With a brittle, barbed head and thick cord, this ancient weapon is designed for formidable prey. The age has made the edge thinner and sharper, but brittle and splintering, so it won't last beyond a single hit. " } net = ItemKind { isymbol = symbolProjectile @@ -348,7 +350,7 @@ firecrackerBomb = fragmentationBomb { iname = "roll" -- not fireworks, as they require outdoors , iflavour = zipPlain [BrMagenta] - , irarity = [(1, 5), (5, 6)] -- a toy, if deadly + , irarity = [(1, 5), (5, 6)] -- a toy, if harmful , iverbHit = "crack" -- a pun, matches the verb from "ItemKindBlast" , iweight = 1000 , iaspects = [SetFlag Lobable, SetFlag Fragile] @@ -567,9 +569,8 @@ , ifreq = [(TREASURE, 100), (ANY_GLASS, 100)] , icount = 1 , irarity = [(5, 8), (10, 8)] - , iaspects = [ SetFlag Unique, ELabel "of Attraction" - , SetFlag Precious, SetFlag Lobable, SetFlag Fragile - , toVelocity 50 ] -- identified + , iaspects = [SetFlag Unique, ELabel "of Attraction", SetFlag MetaGame] + ++ iaspects potionTemplate , ieffects = [ Dominate , toOrganGood S_HASTED (20 + 1 `d` 5) , OnSmash (Explode S_PHEROMONE) @@ -636,9 +637,8 @@ , ifreq = [(TREASURE, 100), (ANY_GLASS, 100)] , icount = 1 , irarity = [(10, 5)] - , iaspects = [ SetFlag Unique, ELabel "of Love" - , SetFlag Precious, SetFlag Lobable, SetFlag Fragile - , toVelocity 50 ] -- identified + , iaspects = [SetFlag Unique, ELabel "of Love", SetFlag MetaGame] + ++ iaspects potionTemplate , ieffects = [ RefillHP 60, RefillCalm (-60) , toOrganGood S_ROSE_SMELLING (80 + 1 `d` 20) , OnSmash (Explode S_HEALING_MIST_2) @@ -1304,7 +1304,7 @@ , ifreq = [(COMMON_ITEM, 100), (ARMOR_LOOSE, 1), (STARTING_ARMOR, 100)] , iflavour = zipPlain [Brown] , icount = 1 - , irarity = [(1, 9), (10, 3)] + , irarity = [(1, 9), (10, 2)] , iverbHit = "thud" , iweight = 7000 , idamage = 0 @@ -1607,11 +1607,12 @@ hammer3 = hammerTemplate { ifreq = [(COMMON_ITEM, 3), (STARTING_WEAPON, 1)] , iverbHit = "puncture" - , iweight = 2400 -- weight gives it away + , iweight = 2400 , idamage = 12 `d` 1 , iaspects = [ Timeout 12 -- balance, or @DupItem@ would break the game + , SetFlag MetaGame -- weight gives it away after seen once , EqpSlot EqpSlotWeaponBig] - ++ delete (PresentAs HAMMER_UNKNOWN) (iaspects hammerTemplate) + ++ iaspects hammerTemplate , idesc = "This hammer sports a long metal handle that increases the momentum of the sharpened head's swing, at the cost of long recovery." } hammerParalyze = hammerTemplate @@ -1629,13 +1630,14 @@ { iname = "The Grand Smithhammer" , ifreq = [(TREASURE, 20)] , irarity = [(5, 1), (8, 6)] - , iweight = 2400 -- weight gives it away + , iweight = 2400 , idamage = 12 `d` 1 , iaspects = [ SetFlag Unique + , SetFlag MetaGame -- weight gives it away after seen once , Timeout 10 , EqpSlot EqpSlotWeaponBig , AddSkill SkShine 3] - ++ delete (PresentAs HAMMER_UNKNOWN) (iaspects hammerTemplate) + ++ iaspects hammerTemplate , ieffects = [Explode S_SPARK] -- we can't use a focused explosion, because it would harm the hammer -- wielder as well, unlike this one @@ -1810,7 +1812,7 @@ jumpingPole = ItemKind { isymbol = symbolWand , iname = "jumping pole" - , ifreq = [(COMMON_ITEM, 100)] + , ifreq = [(COMMON_ITEM, 90)] , iflavour = zipFancy [White] , icount = 1 , irarity = [(1, 3)] diff --git a/GameDefinition/Content/ItemKindActor.hs b/GameDefinition/Content/ItemKindActor.hs --- a/GameDefinition/Content/ItemKindActor.hs +++ b/GameDefinition/Content/ItemKindActor.hs @@ -2,7 +2,7 @@ module Content.ItemKindActor ( -- * Group name patterns pattern S_WOODEN_TORCH, pattern S_SANDSTONE_ROCK - , pattern HERO, pattern SCOUT_HERO, pattern RANGER_HERO, pattern ESCAPIST_HERO, pattern AMBUSHER_HERO, pattern BRAWLER_HERO, pattern SOLDIER_HERO, pattern CIVILIAN, pattern MONSTER, pattern MOBILE_MONSTER, pattern SCOUT_MONSTER, pattern ANIMAL, pattern MOBILE_ANIMAL, pattern IMMOBILE_ANIMAL + , pattern HERO, pattern SCOUT_HERO, pattern RANGER_HERO, pattern ESCAPIST_HERO, pattern AMBUSHER_HERO, pattern BRAWLER_HERO, pattern SOLDIER_HERO, pattern CIVILIAN, pattern MONSTER, pattern MOBILE_MONSTER, pattern SCOUT_MONSTER, pattern ANIMAL, pattern MOBILE_ANIMAL, pattern IMMOBILE_ANIMAL, pattern INSECT, pattern GEOPHENOMENON , pattern ADD_SIGHT, pattern ARMOR_RANGED, pattern ADD_NOCTO_1, pattern WEAK_ARROW, pattern LIGHT_ATTENUATOR, pattern FIREPROOF_CLOTH, pattern RING_OF_OPPORTUNITY_SNIPER, pattern ANY_ARROW, pattern STARTING_ARMOR, pattern STARTING_WEAPON, pattern GEM , actorsGN, actorsGNSingleton , -- * Content @@ -13,7 +13,6 @@ import Game.LambdaHack.Core.Prelude -import Content.ItemKindOrgan import Game.LambdaHack.Content.ItemKind import Game.LambdaHack.Definition.Ability import Game.LambdaHack.Definition.Color @@ -21,6 +20,8 @@ import Game.LambdaHack.Definition.DefsInternal import Game.LambdaHack.Definition.Flavour +import Content.ItemKindOrgan + -- * Group name patterns actorsGNSingleton :: [GroupName ItemKind] @@ -31,27 +32,29 @@ actorsGN :: [GroupName ItemKind] actorsGN = - [HERO, SCOUT_HERO, RANGER_HERO, ESCAPIST_HERO, AMBUSHER_HERO, BRAWLER_HERO, SOLDIER_HERO, CIVILIAN, MONSTER, MOBILE_MONSTER, SCOUT_MONSTER, ANIMAL, MOBILE_ANIMAL, IMMOBILE_ANIMAL] + [HERO, SCOUT_HERO, RANGER_HERO, ESCAPIST_HERO, AMBUSHER_HERO, BRAWLER_HERO, SOLDIER_HERO, CIVILIAN, MONSTER, MOBILE_MONSTER, SCOUT_MONSTER, ANIMAL, MOBILE_ANIMAL, IMMOBILE_ANIMAL, INSECT, GEOPHENOMENON] ++ [ADD_SIGHT, ARMOR_RANGED, ADD_NOCTO_1, WEAK_ARROW, LIGHT_ATTENUATOR, FIREPROOF_CLOTH, RING_OF_OPPORTUNITY_SNIPER, ANY_ARROW, STARTING_ARMOR, STARTING_WEAPON, GEM] -pattern HERO, SCOUT_HERO, RANGER_HERO, ESCAPIST_HERO, AMBUSHER_HERO, BRAWLER_HERO, SOLDIER_HERO, CIVILIAN, MONSTER, MOBILE_MONSTER, SCOUT_MONSTER, ANIMAL, MOBILE_ANIMAL, IMMOBILE_ANIMAL :: GroupName ItemKind +pattern HERO, SCOUT_HERO, RANGER_HERO, ESCAPIST_HERO, AMBUSHER_HERO, BRAWLER_HERO, SOLDIER_HERO, CIVILIAN, MONSTER, MOBILE_MONSTER, SCOUT_MONSTER, ANIMAL, MOBILE_ANIMAL, IMMOBILE_ANIMAL, INSECT, GEOPHENOMENON :: GroupName ItemKind pattern ADD_SIGHT, ARMOR_RANGED, ADD_NOCTO_1, WEAK_ARROW, LIGHT_ATTENUATOR, FIREPROOF_CLOTH, RING_OF_OPPORTUNITY_SNIPER, ANY_ARROW, STARTING_ARMOR, STARTING_WEAPON, GEM :: GroupName ItemKind -pattern HERO = GroupName "hero" -pattern SCOUT_HERO = GroupName "scout hero" -pattern RANGER_HERO = GroupName "ranger hero" -pattern ESCAPIST_HERO = GroupName "escapist hero" -pattern AMBUSHER_HERO = GroupName "ambusher hero" -pattern BRAWLER_HERO = GroupName "brawler hero" -pattern SOLDIER_HERO = GroupName "soldier hero" +pattern HERO = GroupName "adventurer" +pattern SCOUT_HERO = GroupName "scout" +pattern RANGER_HERO = GroupName "ranger" +pattern ESCAPIST_HERO = GroupName "escapist" +pattern AMBUSHER_HERO = GroupName "ambusher" +pattern BRAWLER_HERO = GroupName "brawler" +pattern SOLDIER_HERO = GroupName "soldier" pattern CIVILIAN = GroupName "civilian" -pattern MONSTER = GroupName "monster" -pattern MOBILE_MONSTER = GroupName "mobile monster" -pattern SCOUT_MONSTER = GroupName "scout monster" +pattern MONSTER = GroupName "monstrosity" +pattern MOBILE_MONSTER = GroupName "mobile monstrosity" +pattern SCOUT_MONSTER = GroupName "scout monstrosity" pattern ANIMAL = GroupName "animal" pattern MOBILE_ANIMAL = GroupName "mobile animal" pattern IMMOBILE_ANIMAL = GroupName "immobile animal" +pattern INSECT = GroupName "insect" +pattern GEOPHENOMENON = GroupName "geological phenomenon" pattern S_WOODEN_TORCH = GroupName "wooden torch" pattern S_SANDSTONE_ROCK = GroupName "sandstone rock" @@ -88,13 +91,14 @@ -- * Hunams +-- TODO: bring back S_EAR_3 when character progression permits hearing boosts. humanOrgans :: [(GroupName ItemKind, CStore)] humanOrgans = [ (S_FIST, COrgan), (S_FOOT, COrgan) - , (S_EYE_6, COrgan), (S_EAR_3, COrgan) + , (S_EYE_6, COrgan), (S_EAR_6, COrgan) , (S_SAPIENT_BRAIN, COrgan) ] warrior = ItemKind { isymbol = toContentSymbol '@' - , iname = "warrior" -- modified if initial actors in hero faction + , iname = "adventurer" -- modified if initial actors in hero faction , ifreq = [(HERO, 100), (MOBILE, 1)] , iflavour = zipPlain [BrWhite] , icount = 1 @@ -112,12 +116,12 @@ , AddSkill SkOdor 1 , SetFlag Durable ] , ieffects = [] - , idesc = "" -- "A hardened veteran of combat." , ikit = humanOrgans ++ [(S_SANDSTONE_ROCK, CStash)] + , idesc = "" -- "A hardened veteran of combat." } warrior2 = warrior - { iname = "adventurer" + { iname = "warrior" , ikit = humanOrgans ++ [(COMMON_ITEM, CStash)] -- , idesc = "" @@ -136,8 +140,7 @@ } scout = warrior - { iname = "scout" - , ifreq = [(SCOUT_HERO, 100), (MOBILE, 1)] + { ifreq = [(SCOUT_HERO, 100), (MOBILE, 1)] , ikit = humanOrgans ++ [ (ADD_SIGHT, CEqp) , (ARMOR_RANGED, CEqp) @@ -145,16 +148,14 @@ -- , idesc = "" } ranger = warrior - { iname = "ranger" - , ifreq = [(RANGER_HERO, 100), (MOBILE, 1)] + { ifreq = [(RANGER_HERO, 100), (MOBILE, 1)] , ikit = humanOrgans ++ [ (ARMOR_RANGED, CEqp) , (WEAK_ARROW, CStash) ] -- , idesc = "" } escapist = warrior - { iname = "escapist" - , ifreq = [(ESCAPIST_HERO, 100), (MOBILE, 1)] + { ifreq = [(ESCAPIST_HERO, 100), (MOBILE, 1)] , ikit = humanOrgans ++ [ (ADD_SIGHT, CEqp) , (STARTING_ARMOR, CEqp) @@ -165,8 +166,7 @@ -- , idesc = "" } ambusher = warrior - { iname = "ambusher" - , ifreq = [(AMBUSHER_HERO, 100), (MOBILE, 1)] + { ifreq = [(AMBUSHER_HERO, 100), (MOBILE, 1)] , ikit = humanOrgans -- dark and numerous, so more kit without exploring ++ [ (RING_OF_OPPORTUNITY_SNIPER, CEqp) , (ANY_ARROW, CStash), (ANY_ARROW, CStash) @@ -177,15 +177,14 @@ -- , idesc = "" } brawler = warrior - { iname = "brawler" - , ifreq = [(BRAWLER_HERO, 100), (MOBILE, 1)] + { ifreq = [(BRAWLER_HERO, 100), (MOBILE, 1)] , ikit = humanOrgans - ++ [(STARTING_WEAPON, CEqp)] + ++ [ (STARTING_WEAPON, CEqp) + , (ANY_POTION, CStash) ] -- , idesc = "" } soldier = brawler - { iname = "soldier" - , ifreq = [(SOLDIER_HERO, 100), (MOBILE, 1)] + { ifreq = [(SOLDIER_HERO, 100), (MOBILE, 1)] , ikit = ikit brawler ++ [(EXPLOSIVE, CStash)] -- , idesc = "" @@ -430,7 +429,7 @@ , iverbHit = "thud" , iweight = 54000 , idamage = 0 - , iaspects = [ AddSkill SkMaxHP 30, AddSkill SkMaxCalm 30 + , iaspects = [ AddSkill SkMaxHP 25, AddSkill SkMaxCalm 30 , AddSkill SkSpeed 20, AddSkill SkNocto 2 , AddSkill SkHurtMelee (-70) -- quite harmless rolled in a ball , AddSkill SkAlter (-2) -- can't use hard stairs nor doors @@ -582,7 +581,7 @@ beeSwarm = ItemKind { isymbol = toContentSymbol 'b' , iname = "bee swarm" - , ifreq = [(ANIMAL, 100), (MOBILE, 1)] + , ifreq = [(ANIMAL, 100), (INSECT, 50), (MOBILE, 1)] , iflavour = zipPlain [Brown] , icount = 1 , irarity = [(1, 3), (10, 4)] @@ -604,7 +603,7 @@ hornetSwarm = ItemKind -- kind of tank with armor, but short-lived { isymbol = toContentSymbol 'h' , iname = "hornet swarm" - , ifreq = [(ANIMAL, 100), (MOBILE, 1), (MOBILE_ANIMAL, 100)] + , ifreq = [(ANIMAL, 100), (INSECT, 100), (MOBILE, 1), (MOBILE_ANIMAL, 100)] , iflavour = zipPlain [Magenta] , icount = 1 , irarity = [(5, 1), (10, 4), (20, 10)] @@ -648,7 +647,7 @@ geyserBoiling = ItemKind { isymbol = toContentSymbol 'g' , iname = "geyser" - , ifreq = [(ANIMAL, 8), (IMMOBILE_ANIMAL, 30)] + , ifreq = [(ANIMAL, 8), (IMMOBILE_ANIMAL, 30), (GEOPHENOMENON, 1)] , iflavour = zipPlain [Blue] , icount = 1 , irarity = [(1, 10), (10, 6)] @@ -666,7 +665,7 @@ geyserArsenic = ItemKind { isymbol = toContentSymbol 'g' , iname = "arsenic geyser" - , ifreq = [(ANIMAL, 8), (IMMOBILE_ANIMAL, 40)] + , ifreq = [(ANIMAL, 8), (IMMOBILE_ANIMAL, 40), (GEOPHENOMENON, 1)] , iflavour = zipPlain [Cyan] , icount = 1 , irarity = [(1, 10), (10, 6)] @@ -684,7 +683,7 @@ geyserSulfur = ItemKind { isymbol = toContentSymbol 'g' , iname = "sulfur geyser" - , ifreq = [(ANIMAL, 8), (IMMOBILE_ANIMAL, 120)] + , ifreq = [(ANIMAL, 8), (IMMOBILE_ANIMAL, 120), (GEOPHENOMENON, 1)] , iflavour = zipPlain [BrYellow] -- exception, animal with bright color , icount = 1 , irarity = [(1, 10), (10, 6)] diff --git a/GameDefinition/Content/ItemKindBlast.hs b/GameDefinition/Content/ItemKindBlast.hs --- a/GameDefinition/Content/ItemKindBlast.hs +++ b/GameDefinition/Content/ItemKindBlast.hs @@ -13,7 +13,6 @@ import Game.LambdaHack.Core.Prelude -import Content.ItemKindTemporary import Game.LambdaHack.Content.ItemKind import Game.LambdaHack.Core.Dice import Game.LambdaHack.Definition.Ability @@ -22,6 +21,8 @@ import Game.LambdaHack.Definition.DefsInternal import Game.LambdaHack.Definition.Flavour +import Content.ItemKindTemporary + -- * Group name patterns blastsGNSingleton :: [GroupName ItemKind] @@ -538,7 +539,7 @@ , iname = "boiling water" , ifreq = [(S_BOILING_WATER, 1)] , iflavour = zipPlain [White] - , icount = 18 + , icount = 17 -- 18 causes 3 particles to hit the same actor 3 tiles away , irarity = [(1, 1)] , iverbHit = "boil" , iweight = 1 diff --git a/GameDefinition/Content/ItemKindEmbed.hs b/GameDefinition/Content/ItemKindEmbed.hs --- a/GameDefinition/Content/ItemKindEmbed.hs +++ b/GameDefinition/Content/ItemKindEmbed.hs @@ -11,9 +11,6 @@ import Game.LambdaHack.Core.Prelude -import Content.ItemKindActor -import Content.ItemKindBlast -import Content.ItemKindTemporary import Game.LambdaHack.Content.ItemKind import Game.LambdaHack.Core.Dice import Game.LambdaHack.Definition.Ability @@ -21,6 +18,10 @@ import Game.LambdaHack.Definition.Defs import Game.LambdaHack.Definition.DefsInternal import Game.LambdaHack.Definition.Flavour + +import Content.ItemKindActor +import Content.ItemKindBlast +import Content.ItemKindTemporary -- * Group name patterns diff --git a/GameDefinition/Content/ItemKindOrgan.hs b/GameDefinition/Content/ItemKindOrgan.hs --- a/GameDefinition/Content/ItemKindOrgan.hs +++ b/GameDefinition/Content/ItemKindOrgan.hs @@ -13,9 +13,6 @@ import Game.LambdaHack.Core.Prelude -import Content.ItemKindBlast -import Content.ItemKindTemporary -import Content.RuleKind import Game.LambdaHack.Content.ItemKind import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Core.Dice @@ -25,6 +22,10 @@ import Game.LambdaHack.Definition.DefsInternal import Game.LambdaHack.Definition.Flavour +import Content.ItemKindBlast +import Content.ItemKindTemporary +import Content.RuleKind + -- * Group name patterns organsGNSingleton :: [GroupName ItemKind] @@ -587,7 +588,7 @@ bonusHP = armoredSkin { isymbol = toContentSymbol 'H' -- '+' reserved for conditions - , iname = "bonus HP" + , iname = "extra HP" , ifreq = [(S_BONUS_HP, 1)] , iflavour = zipPlain [BrBlue] , iverbHit = "intimidate" diff --git a/GameDefinition/Content/ItemKindTemporary.hs b/GameDefinition/Content/ItemKindTemporary.hs --- a/GameDefinition/Content/ItemKindTemporary.hs +++ b/GameDefinition/Content/ItemKindTemporary.hs @@ -137,12 +137,14 @@ [AddSkill SkArmorRanged 25] tmpDefenseless = tmpAspects S_DEFENSELESS [ AddSkill SkArmorMelee (-50) , AddSkill SkArmorRanged (-25) ] -tmpResolute = tmpAspects S_RESOLUTE [AddSkill SkMaxCalm 60] +tmpResolute = tmpAspects S_RESOLUTE [ AddSkill SkMaxCalm 60 + , AddSkill SkHearing 10 ] tmpFast20 = tmpAspects S_HASTED [AddSkill SkSpeed 20] tmpSlow10 = tmpAspects S_SLOWED [AddSkill SkSpeed (-10)] tmpFarSighted = tmpAspects S_FAR_SIGHTED [AddSkill SkSight 5] tmpBlind = tmpAspects S_BLIND [ AddSkill SkSight (-99) - , AddSkill SkArmorMelee (-30) ] + , AddSkill SkArmorMelee (-30) + , AddSkill SkHearing 10 ] tmpKeenSmelling = tmpAspects S_KEEN_SMELLING [AddSkill SkSmell 2] tmpFoulSmelling = tmpAspects S_FOUL_SMELLING [AddSkill SkOdor 2] tmpRoseSmelling = tmpAspects S_ROSE_SMELLING [AddSkill SkOdor (-4)] diff --git a/GameDefinition/Content/ModeKind.hs b/GameDefinition/Content/ModeKind.hs --- a/GameDefinition/Content/ModeKind.hs +++ b/GameDefinition/Content/ModeKind.hs @@ -1,12 +1,12 @@ --- | The type of game mode definitions. +-- | Definitions of game mode kinds. module Content.ModeKind - ( -- * Group names + ( -- * Group name patterns groupNamesSingleton, groupNames , -- * Content content #ifdef EXPOSE_INTERNAL -- * Group name patterns - , pattern RAID, pattern BRAWL, pattern LONG, pattern CRAWL, pattern FOGGY, pattern SHOOTOUT, pattern PERILOUS, pattern HUNT, pattern NIGHT, pattern ESCAPE, pattern BURNING, pattern ZOO, pattern RANGED, pattern AMBUSH, pattern SAFARI, pattern DIG, pattern SEE, pattern SHORT, pattern CRAWL_EMPTY, pattern CRAWL_SURVIVAL, pattern SAFARI_SURVIVAL, pattern BATTLE, pattern BATTLE_DEFENSE, pattern BATTLE_SURVIVAL, pattern DEFENSE, pattern DEFENSE_EMPTY + , pattern RAID, pattern BRAWL, pattern LONG, pattern CRAWL, pattern FOGGY, pattern SHOOTOUT, pattern PERILOUS, pattern HUNT, pattern NIGHT, pattern FLIGHT, pattern BURNING, pattern ZOO, pattern RANGED, pattern AMBUSH, pattern SAFARI, pattern DIG, pattern SEE, pattern SHORT, pattern CRAWL_EMPTY, pattern CRAWL_SURVIVAL, pattern SAFARI_SURVIVAL, pattern BATTLE, pattern BATTLE_DEFENSE, pattern BATTLE_SURVIVAL, pattern DEFENSE, pattern DEFENSE_EMPTY #endif ) where @@ -16,25 +16,27 @@ import qualified Data.Text as T -import Content.CaveKind hiding (content, groupNames, groupNamesSingleton) -import Content.ItemKindActor -import Content.ModeKindPlayer import Game.LambdaHack.Content.CaveKind (CaveKind, pattern DEFAULT_RANDOM) +import Game.LambdaHack.Content.FactionKind (Outcome (..)) import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Core.Dice import Game.LambdaHack.Definition.Defs import Game.LambdaHack.Definition.DefsInternal +import Content.CaveKind hiding (content, groupNames, groupNamesSingleton) +import Content.FactionKind hiding (content, groupNames, groupNamesSingleton) +import Content.ItemKindActor + -- * Group name patterns groupNamesSingleton :: [GroupName ModeKind] groupNamesSingleton = - [RAID, BRAWL, LONG, CRAWL, FOGGY, SHOOTOUT, PERILOUS, HUNT, NIGHT, ESCAPE, BURNING, ZOO, RANGED, AMBUSH, SAFARI, DIG, SEE, SHORT, CRAWL_EMPTY, CRAWL_SURVIVAL, SAFARI_SURVIVAL, BATTLE, BATTLE_DEFENSE, BATTLE_SURVIVAL, DEFENSE, DEFENSE_EMPTY] + [RAID, BRAWL, LONG, CRAWL, FOGGY, SHOOTOUT, PERILOUS, HUNT, NIGHT, FLIGHT, BURNING, ZOO, RANGED, AMBUSH, SAFARI, DIG, SEE, SHORT, CRAWL_EMPTY, CRAWL_SURVIVAL, SAFARI_SURVIVAL, BATTLE, BATTLE_DEFENSE, BATTLE_SURVIVAL, DEFENSE, DEFENSE_EMPTY] -pattern RAID, BRAWL, LONG, CRAWL, FOGGY, SHOOTOUT, PERILOUS, HUNT, NIGHT, ESCAPE, BURNING, ZOO, RANGED, AMBUSH, SAFARI, DIG, SEE, SHORT, CRAWL_EMPTY, CRAWL_SURVIVAL, SAFARI_SURVIVAL, BATTLE, BATTLE_DEFENSE, BATTLE_SURVIVAL, DEFENSE, DEFENSE_EMPTY :: GroupName ModeKind +pattern RAID, BRAWL, LONG, CRAWL, FOGGY, SHOOTOUT, PERILOUS, HUNT, NIGHT, FLIGHT, BURNING, ZOO, RANGED, AMBUSH, SAFARI, DIG, SEE, SHORT, CRAWL_EMPTY, CRAWL_SURVIVAL, SAFARI_SURVIVAL, BATTLE, BATTLE_DEFENSE, BATTLE_SURVIVAL, DEFENSE, DEFENSE_EMPTY :: GroupName ModeKind groupNames :: [GroupName ModeKind] -groupNames = [NO_CONFIRMS] +groupNames = [] pattern RAID = GroupName "raid" pattern BRAWL = GroupName "brawl" @@ -44,8 +46,8 @@ pattern SHOOTOUT = GroupName "shootout" pattern PERILOUS = GroupName "perilous hunt" pattern HUNT = GroupName "hunt" -pattern NIGHT = GroupName "night escape" -pattern ESCAPE = GroupName "escape" +pattern NIGHT = GroupName "night flight" +pattern FLIGHT = GroupName "flight" pattern BURNING = GroupName "burning zoo" pattern ZOO = GroupName "zoo" pattern RANGED = GroupName "ranged ambush" @@ -67,9 +69,9 @@ content :: [ModeKind] content = - [raid, brawl, crawl, shootout, hunt, escape, zoo, ambush, safari, dig, see, short, crawlEmpty, crawlSurvival, safariSurvival, battle, battleDefense, battleSurvival, defense, defenseEmpty, screensaverRaid, screensaverBrawl, screensaverCrawl, screensaverShootout, screensaverHunt, screensaverEscape, screensaverZoo, screensaverAmbush, screensaverSafari] + [raid, brawl, crawl, shootout, hunt, flight, zoo, ambush, safari, dig, see, short, crawlEmpty, crawlSurvival, safariSurvival, battle, battleDefense, battleSurvival, defense, defenseEmpty, screensaverRaid, screensaverBrawl, screensaverCrawl, screensaverShootout, screensaverHunt, screensaverFlight, screensaverZoo, screensaverAmbush, screensaverSafari] -raid, brawl, crawl, shootout, hunt, escape, zoo, ambush, safari, dig, see, short, crawlEmpty, crawlSurvival, safariSurvival, battle, battleDefense, battleSurvival, defense, defenseEmpty, screensaverRaid, screensaverBrawl, screensaverCrawl, screensaverShootout, screensaverHunt, screensaverEscape, screensaverZoo, screensaverAmbush, screensaverSafari :: ModeKind +raid, brawl, crawl, shootout, hunt, flight, zoo, ambush, safari, dig, see, short, crawlEmpty, crawlSurvival, safariSurvival, battle, battleDefense, battleSurvival, defense, defenseEmpty, screensaverRaid, screensaverBrawl, screensaverCrawl, screensaverShootout, screensaverHunt, screensaverFlight, screensaverZoo, screensaverAmbush, screensaverSafari :: ModeKind -- What other symmetric (two only-one-moves factions) and asymmetric vs crowd -- scenarios make sense (e.g., are good for a tutorial or for standalone @@ -85,10 +87,10 @@ -- crawl, even without reaction fire raid = ModeKind - { msymbol = 'r' - , mname = "raid (tutorial, 1)" + { mname = "raid (tutorial, 1)" , mfreq = [(RAID, 1), (CAMPAIGN_SCENARIO, 1)] , mtutorial = True + , mattract = False , mroster = rosterRaid , mcaves = cavesRaid , mendMsg = [ (Killed, "This expedition has gone wrong. However, scientific mind does not despair, but analyzes and corrects. Did you perchance awake one animal too many? Did you remember to try using all consumables at your disposal for your immediate survival? Did you choose a challenge with difficulty level within your means? Answer honestly, ponder wisely, experiment methodically.") @@ -98,18 +100,18 @@ [ "* One level only" , "* Two heroes vs. Spawned enemies" , "* Gather gold" - , "* Find exit and escape ASAP" + , "* Find a way out and escape ASAP" ] , mdesc = "An incredibly advanced typing machine worth 100 gold is buried at the exit of this maze. Be the first to find it and fund a research team that makes typing accurate and dependable forever." - , mreason = "In addition to initiating the (loose) game plot, this adventure provides an introductory tutorial. Relax, explore, gather loot, find the exit and escape. With some luck, you won't even need to fight anything." + , mreason = "In addition to initiating the (loose) game plot, this adventure provides an introductory tutorial. Relax, explore, gather loot, find the way out and escape. With some luck, you won't even need to fight anything." , mhint = "You can't use gathered items in your next encounters, so trigger any consumables at will. Feel free to scout with only one of the heroes and keep the other one immobile, e.g., standing guard over the squad's shared inventory stash. If in grave danger, retreat with the scout to join forces with the guard. The more gold collected and the faster the victory, the higher your score in this encounter." } brawl = ModeKind -- sparse melee in daylight, with shade for melee ambush - { msymbol = 'k' - , mname = "brawl (tutorial, 2)" + { mname = "brawl (tutorial, 2)" , mfreq = [(BRAWL, 1), (CAMPAIGN_SCENARIO, 1)] , mtutorial = True + , mattract = False , mroster = rosterBrawl , mcaves = cavesBrawl , mendMsg = [ (Killed, "The inquisitive scholars turned out to be envious of our deep insight to the point of outright violence. It would still not result in such a defeat and recanting of our thesis if we figured out to use terrain to protect us from missiles or even completely hide our presence. It would also help if we honourably kept our ground together to the end, at the same time preventing the overwhelming enemy forces from brutishly ganging up on our modest-sized, though valiant, research team.") @@ -127,10 +129,10 @@ } crawl = ModeKind - { msymbol = 'c' - , mname = "long crawl (main)" + { mname = "long crawl (main)" , mfreq = [(LONG, 1), (CRAWL, 1), (CAMPAIGN_SCENARIO, 1)] , mtutorial = False + , mattract = False , mroster = rosterCrawl , mcaves = cavesCrawl , mendMsg = [ (Killed, "To think that followers of science and agents of enlightenment would earn death as their reward! Where did we err in our ways? Perhaps nature should not have been disturbed so brashly and the fell beasts woken up from their slumber so eagerly?\nPerhaps the gathered items should have been used for scientific experiments on the spot rather than hoarded as if of base covetousness? Or perhaps the challenge, chosen freely but without the foreknowledge of the grisly difficulty, was insurmountable and forlorn from the start, despite the enormous power of educated reason at out disposal?") @@ -139,7 +141,7 @@ [ "* Many levels" , "* Three heroes vs. Spawned enemies" , "* Gather gold, gems and elixirs" - , "* Find exit and escape ASAP" + , "* Find a way out and escape ASAP" ] , mdesc = "Enjoy the peaceful seclusion of these cold austere tunnels, but don't let wanton curiosity, greed and the ever-creeping abstraction madness keep you down there for too long. If you find survivors (whole or perturbed or segmented) of the past scientific missions, exercise extreme caution and engage or ignore at your discretion." , mreason = "This is the main, longest and most replayable scenario of the game." @@ -155,13 +157,14 @@ -- the other team members are more spotters and guardians than snipers -- and that's their only role, so a small party makes sense. shootout = ModeKind -- sparse ranged in daylight - { msymbol = 's' - , mname = "foggy shootout (3)" + { mname = "foggy shootout (3)" , mfreq = [(FOGGY, 1), (SHOOTOUT, 1), (CAMPAIGN_SCENARIO, 1)] , mtutorial = False + , mattract = False , mroster = rosterShootout , mcaves = cavesShootout - , mendMsg = [] + , mendMsg = [ (Killed, "This is a disgrace. What have we missed in our theoretic models of this fight? Did we miss a human lookout placed in a covered but unobstructed spot that lets the rest of the squad snipe from concealment or from a safe distance?\nBarring that, would we end up in a better shape even if we all hid and only fired blindly? We'd listen to impact sounds and wait vigilantly for incoming enemy missiles in order to register their trajectories and derive hints of enemy location. Apparently, ranged combat requires a change of pace and better planning than our previous simple but efficient calculations accustomed us to.") + , (Conquer, "That was a good fight, with scientifically accurate application of missiles, cover and concealment. Not even skilled logicians can routinely deduce enemy position from the physical trajectory of their projectiles nor by firing without line of sight and interpreting auditory cues. However, while this steep hurdle is overcome, the dispute is not over yet.") ] , mrules = T.intercalate "\n" [ "* One level only" , "* Three heroes vs. Three human enemies" @@ -174,38 +177,41 @@ } hunt = ModeKind -- melee vs ranged with reaction fire in daylight - { msymbol = 'h' - , mname = "perilous hunt (4)" + { mname = "perilous hunt (4)" , mfreq = [(PERILOUS, 1), (HUNT, 1), (CAMPAIGN_SCENARIO, 1)] , mtutorial = False + , mattract = False , mroster = rosterHunt , mcaves = cavesHunt - , mendMsg = [] + , mendMsg = [ (Killed, "Leaving concealment might have not been rational enough, leaving cover is hard to justify on a scientific basis and wandering off on an area of a heated dispute is foolhardy. All this is doubly regrettable, given that our cold-hearted opponents supported their weak arguments with inexplicably effective telegraphy and triangulation equipment. And we so deserve a complete intellectual victory, if only we strove to lower the difficulty of this altercation instead of raising it.") + -- this is in the middle of the scenario list and the mission is not tricky, so a subtle reminder about lowering difficulty, in case the player struggles + , (Conquer, "We chased them off and proved our argument, like we knew that we would. It feels efficient to stick together and prevail. We taught them a lesson in rationality, despite their superior scientific equipment. Scientific truth prevails over brute force.") ] , mrules = T.intercalate "\n" [ "* One level only" , "* Seven heroes vs. Seven human enemies capable of concurrent attacks" , "* Minimize losses" - , "* Incapacitate all enemies ASAP" + , "* Incapacitate all human enemies ASAP" ] - , mdesc = "Who is the hunter and who is the prey? The only criterion is last man standing when the chase ends." + , mdesc = "Who is the hunter and who is the prey? The only criterion is last man standing when the chase for truth ends." , mreason = "This adventure is quite a tactical challenge, because enemies are allowed to fling their ammo simultaneously at your team, which has no such ability." - , mhint = "Try not to outshoot the enemy, but to instead focus more on melee tactics. A useful concept here is communication overhead. Any team member that is not waiting and spotting for everybody, but acts, e.g., melees or moves or manages items, slows down all other team members by rougly 10%, because they need to keep track of his actions. Therefore, if other heroes melee, consider carefully if it makes sense to come to their aid, slowing them while you move, or if it's better to stay put and monitor the perimeter. This is true for all factions and all actors on each level separately, except the pointman of each faction, if any." -- this also eliminates lag in big battles and helps the player to focus on combat and not get distracted by distant team members frantically trying to reach the battleground in time + , mhint = "Try not to outshoot the enemy, but to instead focus more on melee tactics. A useful concept here is communication overhead. Any team member that is not waiting and spotting for everybody, but acts, e.g., melees or moves or manages items, slows down all other team members by roughly 10%, because they need to keep track of his actions. Therefore, if other heroes melee, consider carefully if it makes sense to come to their aid, slowing them while you move, or if it's better to stay put and monitor the perimeter. This is true for all factions and all actors on each level separately, except the pointman of each faction, if it has one." -- this also eliminates lag in big battles and helps the player to focus on combat and not get distracted by distant team members frantically trying to reach the battleground in time } -escape = ModeKind -- asymmetric ranged and stealth race at night - { msymbol = 'e' - , mname = "night escape (5)" - , mfreq = [(NIGHT, 1), (ESCAPE, 1), (CAMPAIGN_SCENARIO, 1)] +flight = ModeKind -- asymmetric ranged and stealth race at night + { mname = "night flight (5)" + , mfreq = [(NIGHT, 1), (FLIGHT, 1), (CAMPAIGN_SCENARIO, 1)] , mtutorial = False - , mroster = rosterEscape - , mcaves = cavesEscape - , mendMsg = [ (Conquer, "It was enough to reach the escape area marked by yellow '>' symbol. Spilling that much blood was risky. unnecessary and alerted the authorities. Having said that --- impressive indeed.") ] + , mattract = False + , mroster = rosterFlight + , mcaves = cavesFlight + , mendMsg = [ (Killed, "Somebody must have tipped the enemies of free inquiry off. However, us walking along a lit trail, yelling, could have been a contributing factor. Also, it's worth noting that the torches prepared for this assault are best used as thrown makeshift flares.\nOn the other hand, equipping a lit torch makes one visible in the dark, regrettably but not quite unexpectedly to a scientific mind. Lastly, the goal of this foray was to definitely disengage from the fruitless dispute, via a way out marked by a yellow '>' sign, and to gather treasure that would support our future research. Not to harass every nearby scientific truth denier, as much as they do deserve it.") + , (Conquer, "It was enough to reach the escape area marked by yellow '>' symbol. Spilling that much blood was risky. unnecessary and alerted the authorities. Having said that --- impressive indeed.") ] , mrules = T.intercalate "\n" [ "* One level only" , "* Three heroes vs. Seven human enemies capable of concurrent attacks" , "* Minimize losses" , "* Gather gems" - , "* Find exit and escape ASAP" + , "* Find a way out and escape ASAP" ] , mdesc = "Dwelling into dark matters is dangerous, so avoid the crowd of firebrand disputants, catch any gems of thought, find a way out and bring back a larger team to shed new light on the field." , mreason = "The focus of this installment is on stealthy exploration under the threat of numerically superior enemy." @@ -213,13 +219,14 @@ } zoo = ModeKind -- asymmetric crowd melee at night - { msymbol = 'b' - , mname = "burning zoo (6)" + { mname = "burning zoo (6)" , mfreq = [(BURNING, 1), (ZOO, 1), (CAMPAIGN_SCENARIO, 1)] , mtutorial = False + , mattract = False , mroster = rosterZoo , mcaves = cavesZoo - , mendMsg = [] + , mendMsg = [ (Killed, "Against such an onslaught, only clever positioning, use of terrain and patient vigilance gives any chance of survival.") + , (Conquer, "That was a grim harvest. Science demands sacrifices.") ] , mrules = T.intercalate "\n" [ "* One level only" , "* Five heroes vs. Many enemies" @@ -240,13 +247,14 @@ -- without reaction fire don't make sense, because then usually only one hero -- shoots (and often also scouts) and others just gather ammo. ambush = ModeKind -- dense ranged with reaction fire vs melee at night - { msymbol = 'm' - , mname = "ranged ambush (7)" + { mname = "ranged ambush (7)" , mfreq = [(RANGED, 1), (AMBUSH, 1), (CAMPAIGN_SCENARIO, 1)] , mtutorial = False + , mattract = False , mroster = rosterAmbush , mcaves = cavesAmbush - , mendMsg = [] + , mendMsg = [ (Killed, "You turned out to be the prey, this time, not the hunter. In fact, you are not even in the hunters' league. When fighting against such odds, passively waiting for enemy to spring a trap is to no avail, because a professional team can sneak in darkness and ambush the ambushers.\nGranted, good positioning is crucial, so that each squad member can overwatch the battlefield and fire opportunistically, using the recently recovered instant telegraphy equipment. However, there is no hope without active scouting, throwing lit objects and probing suspect areas with missiles while paying attention to sounds. And that may still not be enough.") + , (Conquer, "The new instant telegraphy equipment enabling simultaneous ranged attacks with indirect triangulation and aiming proved effective beyond expectation. Your ideas are safe, your research programme on track, your chartered company ready to launch and introduce progress and science into every household of the nation.") ] , mrules = T.intercalate "\n" [ "* One level only" , "* Three heroes with concurrent attacks vs. Unidentified foes" @@ -255,14 +263,14 @@ ] , mdesc = "Prevent hijacking of your ideas at all cost! Be stealthy, be observant, be aggressive. Fast execution is what makes or breaks a creative team." , mreason = "In this adventure, finally, your heroes are able to all use ranged attacks at once, given enough ammunition." - , mhint = "" + , mhint = "Beware of friendly fire, particularly from explosives. But you need no more hints. Go fulfill your destiny! For Science!" } safari = ModeKind -- Easter egg available only via screensaver - { msymbol = 'f' - , mname = "safari" + { mname = "safari" , mfreq = [(SAFARI, 1)] , mtutorial = False + , mattract = False , mroster = rosterSafari , mcaves = cavesSafari , mendMsg = [] @@ -270,7 +278,7 @@ [ "* Three levels" , "* Many teammates capable of concurrent action vs. Many enemies" , "* Minimize losses" - , "* Find exit and escape ASAP" + , "* Find a way out and escape ASAP" ] , mdesc = "\"In this enactment you'll discover the joys of hunting the most exquisite of Earth's flora and fauna, both animal and semi-intelligent. Exit at the bottommost level.\" This is a drama script recovered from a monster nest debris." , mreason = "This is an Easter egg. The default squad doctrine is that all team members follow the pointman, but it can be changed from the settings submenu of the main menu." @@ -280,10 +288,10 @@ -- * Testing modes dig = ModeKind - { msymbol = 'd' - , mname = "dig" + { mname = "dig" , mfreq = [(DIG, 1)] , mtutorial = False + , mattract = False , mroster = rosterCrawlEmpty , mcaves = cavesDig , mendMsg = [] @@ -294,10 +302,10 @@ } see = ModeKind - { msymbol = 'a' - , mname = "see" + { mname = "see" , mfreq = [(SEE, 1)] , mtutorial = False + , mattract = False , mroster = rosterCrawlEmpty , mcaves = cavesSee , mendMsg = [] @@ -308,10 +316,10 @@ } short = ModeKind - { msymbol = 's' - , mname = "short" + { mname = "short" , mfreq = [(SHORT, 1)] , mtutorial = False + , mattract = False , mroster = rosterCrawlEmpty , mcaves = cavesShort , mendMsg = [] @@ -322,10 +330,10 @@ } crawlEmpty = ModeKind - { msymbol = 'c' - , mname = "crawl empty" + { mname = "crawl empty" , mfreq = [(CRAWL_EMPTY, 1)] , mtutorial = False + , mattract = False , mroster = rosterCrawlEmpty , mcaves = cavesCrawlEmpty , mendMsg = [] @@ -336,10 +344,10 @@ } crawlSurvival = ModeKind - { msymbol = 'd' - , mname = "crawl survival" + { mname = "crawl survival" , mfreq = [(CRAWL_SURVIVAL, 1)] , mtutorial = False + , mattract = False , mroster = rosterCrawlSurvival , mcaves = cavesCrawl , mendMsg = [] @@ -350,10 +358,10 @@ } safariSurvival = ModeKind - { msymbol = 'u' - , mname = "safari survival" + { mname = "safari survival" , mfreq = [(SAFARI_SURVIVAL, 1)] , mtutorial = False + , mattract = False , mroster = rosterSafariSurvival , mcaves = cavesSafari , mendMsg = [] @@ -364,10 +372,10 @@ } battle = ModeKind - { msymbol = 'b' - , mname = "battle" + { mname = "battle" , mfreq = [(BATTLE, 1)] , mtutorial = False + , mattract = False , mroster = rosterBattle , mcaves = cavesBattle , mendMsg = [] @@ -378,10 +386,10 @@ } battleDefense = ModeKind - { msymbol = 'f' - , mname = "battle defense" + { mname = "battle defense" , mfreq = [(BATTLE_DEFENSE, 1)] , mtutorial = False + , mattract = False , mroster = rosterBattleDefense , mcaves = cavesBattle , mendMsg = [] @@ -392,10 +400,10 @@ } battleSurvival = ModeKind - { msymbol = 'i' - , mname = "battle survival" + { mname = "battle survival" , mfreq = [(BATTLE_SURVIVAL, 1)] , mtutorial = False + , mattract = False , mroster = rosterBattleSurvival , mcaves = cavesBattle , mendMsg = [] @@ -406,10 +414,10 @@ } defense = ModeKind -- perhaps a real scenario in the future - { msymbol = 'e' - , mname = "defense" + { mname = "defense" , mfreq = [(DEFENSE, 1)] , mtutorial = False + , mattract = False , mroster = rosterDefense , mcaves = cavesCrawl , mendMsg = [] @@ -420,10 +428,10 @@ } defenseEmpty = ModeKind - { msymbol = 'e' - , mname = "defense empty" + { mname = "defense empty" , mfreq = [(DEFENSE_EMPTY, 1)] , mtutorial = False + , mattract = False , mroster = rosterDefenseEmpty , mcaves = cavesCrawlEmpty , mendMsg = [] @@ -435,322 +443,205 @@ -- * Screensaver modes -screensaverRaid = screensave (AutoLeader False False) $ raid +screensaverRaid = raid { mname = "auto-raid (1)" - , mfreq = [(INSERT_COIN, 2), (NO_CONFIRMS, 1)] + , mfreq = [(INSERT_COIN, 2)] + , mattract = True } -screensaverBrawl = screensave (AutoLeader False False) $ brawl +screensaverBrawl = brawl { mname = "auto-brawl (2)" - , mfreq = [(NO_CONFIRMS, 1)] + , mfreq = [] + , mattract = True } -screensaverCrawl = screensave (AutoLeader False False) $ crawl +screensaverCrawl = crawl { mname = "auto-crawl (long)" - , mfreq = [(NO_CONFIRMS, 1)] + , mfreq = [] + , mattract = True } -screensaverShootout = screensave (AutoLeader False False) $ shootout +screensaverShootout = shootout { mname = "auto-shootout (3)" - , mfreq = [(INSERT_COIN, 2), (NO_CONFIRMS, 1)] + , mfreq = [(INSERT_COIN, 2)] + , mattract = True } -screensaverHunt = screensave (AutoLeader False False) $ hunt +screensaverHunt = hunt { mname = "auto-hunt (4)" - , mfreq = [(INSERT_COIN, 2), (NO_CONFIRMS, 1)] + , mfreq = [(INSERT_COIN, 2)] + , mattract = True } -screensaverEscape = screensave (AutoLeader False False) $ escape - { mname = "auto-escape (5)" - , mfreq = [(INSERT_COIN, 2), (NO_CONFIRMS, 1)] +screensaverFlight = flight + { mname = "auto-flight (5)" + , mfreq = [(INSERT_COIN, 2)] + , mattract = True } -screensaverZoo = screensave (AutoLeader False False) $ zoo +screensaverZoo = zoo { mname = "auto-zoo (6)" - , mfreq = [(NO_CONFIRMS, 1)] + , mfreq = [] + , mattract = True } -screensaverAmbush = screensave (AutoLeader False False) $ ambush +screensaverAmbush = ambush { mname = "auto-ambush (7)" - , mfreq = [(NO_CONFIRMS, 1)] + , mfreq = [] + , mattract = True } --- changing leader by client needed, because of TFollow -screensaverSafari = screensave (AutoLeader False True) $ safari +screensaverSafari = safari { mname = "auto-safari" - , mfreq = [(INSERT_COIN, 1), (NO_CONFIRMS, 1)] + , mfreq = [(INSERT_COIN, 1)] + , mattract = True } -teamCompetitor, teamCivilian :: TeamContinuity -teamCompetitor = TeamContinuity 2 -teamCivilian = TeamContinuity 3 - -rosterRaid, rosterBrawl, rosterCrawl, rosterShootout, rosterHunt, rosterEscape, rosterZoo, rosterAmbush, rosterSafari, rosterCrawlEmpty, rosterCrawlSurvival, rosterSafariSurvival, rosterBattle, rosterBattleDefense, rosterBattleSurvival, rosterDefense, rosterDefenseEmpty :: Roster +rosterRaid, rosterBrawl, rosterCrawl, rosterShootout, rosterHunt, rosterFlight, rosterZoo, rosterAmbush, rosterSafari, rosterCrawlEmpty, rosterCrawlSurvival, rosterSafariSurvival, rosterBattle, rosterBattleDefense, rosterBattleSurvival, rosterDefense, rosterDefenseEmpty :: Roster -rosterRaid = Roster - { rosterList = [ ( playerAnimal -- starting over escape - , Nothing - , [(-2, 2, ANIMAL)] ) - , ( playerHero {fhiCondPoly = hiHeroShort} - , Just teamExplorer - , [(-2, 2, HERO)] ) - , ( playerAntiHero { fname = "Indigo Founder" - , fhiCondPoly = hiHeroShort } - , Just teamCompetitor - , [(-2, 1, HERO)] ) - , (playerHorror, Nothing, []) ] -- for summoned monsters - , rosterEnemy = [ ("Explorer", "Animal Kingdom") - , ("Explorer", "Horror Den") - , ("Indigo Founder", "Animal Kingdom") - , ("Indigo Founder", "Horror Den") ] - , rosterAlly = [] } +rosterRaid = + [ ( ANIMAL_REPRESENTATIVE -- starting over escape + , [(-2, 2, ANIMAL)] ) + , ( EXPLORER_SHORT + , [(-2, 2, HERO)] ) + , ( COMPETITOR_SHORT + , [(-2, 1, HERO)] ) + , (HORROR_REPRESENTATIVE, []) ] -- for summoned monsters -rosterBrawl = Roster - { rosterList = [ ( playerHero { fcanEscape = False - , fhiCondPoly = hiHeroMedium } - , Just teamExplorer - , [(-2, 3, BRAWLER_HERO)] ) - , ( playerAntiHero { fname = "Indigo Researcher" - , fcanEscape = False - , fhiCondPoly = hiHeroMedium } - , Just teamCompetitor - , [(-2, 3, BRAWLER_HERO)] ) - , (playerHorror, Nothing, []) ] - , rosterEnemy = [ ("Explorer", "Indigo Researcher") - , ("Explorer", "Horror Den") - , ("Indigo Researcher", "Horror Den") ] - , rosterAlly = [] } +rosterBrawl = + [ ( EXPLORER_NO_ESCAPE + , [(-2, 3, BRAWLER_HERO)] ) + , ( COMPETITOR_NO_ESCAPE + , [(-2, 3, BRAWLER_HERO)] ) + , (HORROR_REPRESENTATIVE, []) ] -rosterCrawl = Roster - { rosterList = [ ( playerAnimal -- starting over escape - , Nothing - , -- Fun from the start to avoid empty initial level: - [ (-1, 1 + 1 `d` 2, ANIMAL) - -- Huge battle at the end: - , (-10, 100, MOBILE_ANIMAL) ] ) - , ( playerHero -- start on stairs so that stash is handy - , Just teamExplorer - , [(-1, 3, HERO)] ) - , ( playerMonster - , Nothing - , [(-4, 1, SCOUT_MONSTER), (-4, 3, MONSTER)] ) ] - , rosterEnemy = [ ("Explorer", "Monster Hive") - , ("Explorer", "Animal Kingdom") ] - , rosterAlly = [("Monster Hive", "Animal Kingdom")] } +rosterCrawl = + [ ( ANIMAL_REPRESENTATIVE -- starting over escape + , -- Fun from the start to avoid empty initial level: + [ (-1, 1 + 1 `d` 2, ANIMAL) + -- Huge battle at the end: + , (-10, 100, MOBILE_ANIMAL) ] ) + , ( EXPLORER_REPRESENTATIVE + -- start on stairs so that stash is handy + , [(-1, 3, HERO)] ) + , ( MONSTER_REPRESENTATIVE + , [(-4, 1, SCOUT_MONSTER), (-4, 3, MONSTER)] ) ] -- Exactly one scout gets a sight boost, to help the aggressor, because he uses -- the scout for initial attack, while camper (on big enough maps) -- can't guess where the attack would come and so can't position his single -- scout to counter the stealthy advance. -rosterShootout = Roster - { rosterList = [ ( playerHero { fcanEscape = False - , fhiCondPoly = hiHeroMedium } - , Just teamExplorer - , [(-5, 2, RANGER_HERO), (-5, 1, SCOUT_HERO)] ) - , ( playerAntiHero { fname = "Indigo Researcher" - , fcanEscape = False - , fhiCondPoly = hiHeroMedium } - , Just teamCompetitor - , [(-5, 2, RANGER_HERO), (-5, 1, SCOUT_HERO)] ) - , (playerHorror, Nothing, []) ] - , rosterEnemy = [ ("Explorer", "Indigo Researcher") - , ("Explorer", "Horror Den") - , ("Indigo Researcher", "Horror Den") ] - , rosterAlly = [] } +rosterShootout = + [ ( EXPLORER_NO_ESCAPE + , [(-5, 2, RANGER_HERO), (-5, 1, SCOUT_HERO)] ) + , ( COMPETITOR_NO_ESCAPE + , [(-5, 2, RANGER_HERO), (-5, 1, SCOUT_HERO)] ) + , (HORROR_REPRESENTATIVE, []) ] -rosterHunt = Roster - { rosterList = [ ( playerHero { fcanEscape = False - , fhiCondPoly = hiHeroMedium } - , Just teamExplorer - , [(-6, 7, SOLDIER_HERO)] ) - , ( playerAntiHero { fname = "Indigo Researcher" - , fcanEscape = False - , fhiCondPoly = hiHeroMedium } - , Just teamCompetitor - , [(-6, 6, AMBUSHER_HERO), (-6, 1, SCOUT_HERO)] ) - , (playerHorror, Nothing, []) ] - , rosterEnemy = [ ("Explorer", "Indigo Researcher") - , ("Explorer", "Horror Den") - , ("Indigo Researcher", "Horror Den") ] - , rosterAlly = [] } +rosterHunt = + [ ( EXPLORER_NO_ESCAPE + , [(-6, 7, SOLDIER_HERO)] ) + , ( COMPETITOR_NO_ESCAPE + , [(-6, 6, AMBUSHER_HERO), (-6, 1, SCOUT_HERO)] ) + , (HORROR_REPRESENTATIVE, []) ] -rosterEscape = Roster - { rosterList = [ ( playerAntiHero { fname = "Indigo Researcher" - , fcanEscape = False -- start on escape - , fhiCondPoly = hiHeroMedium } - , Just teamCompetitor - , [(-7, 6, AMBUSHER_HERO), (-7, 1, SCOUT_HERO)] ) - , ( playerHero {fhiCondPoly = hiHeroMedium} - , Just teamExplorer - , [(-7, 2, ESCAPIST_HERO), (-7, 1, SCOUT_HERO)] ) - -- second on the list to let foes occupy the exit - , (playerHorror, Nothing, []) ] - , rosterEnemy = [ ("Explorer", "Indigo Researcher") - , ("Explorer", "Horror Den") - , ("Indigo Researcher", "Horror Den") ] - , rosterAlly = [] } +rosterFlight = + [ ( COMPETITOR_NO_ESCAPE -- start on escape + , [(-7, 6, AMBUSHER_HERO), (-7, 1, SCOUT_HERO)] ) + , ( EXPLORER_MEDIUM + , [(-7, 2, ESCAPIST_HERO), (-7, 1, SCOUT_HERO)] ) + -- second on the list to let foes occupy the escape + , (HORROR_REPRESENTATIVE, []) ] -rosterZoo = Roster - { rosterList = [ ( playerHero { fcanEscape = False - , fhiCondPoly = hiHeroLong } - , Just teamExplorer - , [(-8, 5, SOLDIER_HERO)] ) - , ( playerAnimal {fneverEmpty = True} - , Nothing - , [(-8, 100, MOBILE_ANIMAL)] ) - , (playerHorror, Nothing, []) ] -- for summoned monsters - , rosterEnemy = [ ("Explorer", "Animal Kingdom") - , ("Explorer", "Horror Den") ] - , rosterAlly = [] } +rosterZoo = + [ ( EXPLORER_TRAPPED + , [(-8, 5, SOLDIER_HERO)] ) + , ( ANIMAL_CAPTIVE + , [(-8, 100, MOBILE_ANIMAL)] ) + , (HORROR_REPRESENTATIVE, []) ] -- for summoned monsters -rosterAmbush = Roster - { rosterList = [ ( playerHero { fcanEscape = False - , fhiCondPoly = hiHeroMedium } - , Just teamExplorer - , [(-9, 5, AMBUSHER_HERO), (-9, 1, SCOUT_HERO)] ) - , ( playerAntiHero { fname = "Indigo Researcher" - , fcanEscape = False - , fhiCondPoly = hiHeroMedium } - , Just teamCompetitor - , [(-9, 12, SOLDIER_HERO)] ) - , (playerHorror, Nothing, []) ] - , rosterEnemy = [ ("Explorer", "Indigo Researcher") - , ("Explorer", "Horror Den") - , ("Indigo Researcher", "Horror Den") ] - , rosterAlly = [] } +rosterAmbush = + [ ( EXPLORER_NO_ESCAPE + , [(-9, 5, AMBUSHER_HERO), (-9, 1, SCOUT_HERO)] ) + , ( COMPETITOR_NO_ESCAPE + , [(-9, 12, SOLDIER_HERO)] ) + , (HORROR_REPRESENTATIVE, []) ] -- No horrors faction needed, because spawned heroes land in civilian faction. -rosterSafari = Roster - { rosterList = [ ( playerMonsterTourist - , Nothing - , [(-4, 15, MONSTER)] ) - , ( playerHunamConvict - , Just teamCivilian - , [(-4, 2, CIVILIAN)] ) - , ( playerAnimalMagnificent - , Nothing - , [(-7, 15, MOBILE_ANIMAL)] ) - , ( playerAnimalExquisite -- start on escape - , Nothing - , [(-10, 20, MOBILE_ANIMAL)] ) ] - , rosterEnemy = [ ("Monster Tourist Office", "Hunam Convict") - , ( "Monster Tourist Office" - , "Animal Magnificent Specimen Variety" ) - , ( "Monster Tourist Office" - , "Animal Exquisite Herds and Packs Galore" ) - , ( "Animal Magnificent Specimen Variety" - , "Hunam Convict" ) - , ( "Hunam Convict" - , "Animal Exquisite Herds and Packs Galore" ) ] - , rosterAlly = [ ( "Animal Magnificent Specimen Variety" - , "Animal Exquisite Herds and Packs Galore" ) ] } +rosterSafari = + [ ( MONSTER_TOURIST + , [(-4, 15, MONSTER)] ) + , ( CONVICT_REPRESENTATIVE + , [(-4, 2, CIVILIAN)] ) + , ( ANIMAL_MAGNIFICENT + , [(-7, 15, MOBILE_ANIMAL)] ) + , ( ANIMAL_EXQUISITE -- start on escape + , [(-10, 20, MOBILE_ANIMAL)] ) ] -rosterCrawlEmpty = Roster - { rosterList = [ ( playerHero - , Just teamExplorer - , [(-1, 1, HERO)] ) - , (playerHorror, Nothing, []) ] - -- for spawned and summoned monsters - , rosterEnemy = [] - , rosterAlly = [] } +rosterCrawlEmpty = + [ ( EXPLORER_PACIFIST + , [(-1, 1, HERO)] ) + , (HORROR_PACIFIST, []) ] + -- for spawned and summoned monsters -rosterCrawlSurvival = rosterCrawl - { rosterList = [ ( playerAntiHero - , Just teamExplorer - , [(-1, 3, HERO)] ) - , ( playerMonster - , Nothing - , [(-4, 1, SCOUT_MONSTER), (-4, 3, MONSTER)] ) - , ( playerAnimal {fhasUI = True} - , Nothing - , -- Fun from the start to avoid empty initial level: - [ (-1, 1 + 1 `d` 2, ANIMAL) - -- Huge battle at the end: - , (-10, 100, MOBILE_ANIMAL) ] ) ] } +rosterCrawlSurvival = + [ ( EXPLORER_AUTOMATED + , [(-1, 3, HERO)] ) + , ( MONSTER_REPRESENTATIVE + , [(-4, 1, SCOUT_MONSTER), (-4, 3, MONSTER)] ) + , ( ANIMAL_NARRATING + , [(-5, 10, ANIMAL)] ) ] -- explore unopposed for some time -rosterSafariSurvival = rosterSafari - { rosterList = [ ( playerMonsterTourist - { fleaderMode = Just $ AutoLeader True True - , fhasUI = False - , funderAI = True } - , Nothing - , [(-4, 15, MONSTER)] ) - , ( playerHunamConvict - , Just teamCivilian - , [(-4, 3, CIVILIAN)] ) - , ( playerAnimalMagnificent - { fleaderMode = Just $ AutoLeader True False - , fhasUI = True - , funderAI = False } - , Nothing - , [(-7, 20, MOBILE_ANIMAL)] ) - , ( playerAnimalExquisite - , Nothing - , [(-10, 30, MOBILE_ANIMAL)] ) ] } +rosterSafariSurvival = + [ ( MONSTER_TOURIST_PASSIVE + , [(-4, 15, MONSTER)] ) + , ( CONVICT_REPRESENTATIVE + , [(-4, 3, CIVILIAN)] ) + , ( ANIMAL_MAGNIFICENT_NARRATING + , [(-7, 20, MOBILE_ANIMAL)] ) + , ( ANIMAL_EXQUISITE + , [(-10, 30, MOBILE_ANIMAL)] ) ] -rosterBattle = Roster - { rosterList = [ ( playerHero { fcanEscape = False - , fhiCondPoly = hiHeroLong } - , Just teamExplorer - , [(-5, 5, SOLDIER_HERO)] ) - , ( playerMonster {fneverEmpty = True} - , Nothing - , [(-5, 35, MOBILE_MONSTER)] ) - , ( playerAnimal {fneverEmpty = True} - , Nothing - , [(-5, 30, MOBILE_ANIMAL)] ) ] - , rosterEnemy = [ ("Explorer", "Monster Hive") - , ("Explorer", "Animal Kingdom") ] - , rosterAlly = [("Monster Hive", "Animal Kingdom")] } +rosterBattle = + [ ( EXPLORER_TRAPPED + , [(-5, 5, SOLDIER_HERO)] ) + , ( MONSTER_CAPTIVE + , [(-5, 35, MOBILE_MONSTER)] ) + , ( ANIMAL_CAPTIVE + , [(-5, 30, MOBILE_ANIMAL)] ) ] -rosterBattleDefense = rosterBattle - { rosterList = [ ( playerAntiHero { fcanEscape = False - , fhiCondPoly = hiHeroLong } - , Just teamExplorer - , [(-5, 5, SOLDIER_HERO)] ) - , ( playerMonster { fneverEmpty = True - , fhasUI = True } - , Nothing - , [(-5, 35, MOBILE_MONSTER)] ) - , ( playerAnimal {fneverEmpty = True} - , Nothing - , [(-5, 30, MOBILE_ANIMAL)] ) ] } +rosterBattleDefense = + [ ( EXPLORER_AUTOMATED_TRAPPED + , [(-5, 5, SOLDIER_HERO)] ) + , ( MONSTER_CAPTIVE_NARRATING + , [(-5, 35, MOBILE_MONSTER)] ) + , ( ANIMAL_CAPTIVE + , [(-5, 30, MOBILE_ANIMAL)] ) ] -rosterBattleSurvival = rosterBattle - { rosterList = [ ( playerAntiHero { fcanEscape = False - , fhiCondPoly = hiHeroLong } - , Just teamExplorer - , [(-5, 5, SOLDIER_HERO)] ) - , ( playerMonster {fneverEmpty = True} - , Nothing - , [(-5, 35, MOBILE_MONSTER)] ) - , ( playerAnimal { fneverEmpty = True - , fhasUI = True } - , Nothing - , [(-5, 30, MOBILE_ANIMAL)] ) ] } +rosterBattleSurvival = + [ ( EXPLORER_AUTOMATED_TRAPPED + , [(-5, 5, SOLDIER_HERO)] ) + , ( MONSTER_CAPTIVE + , [(-5, 35, MOBILE_MONSTER)] ) + , ( ANIMAL_CAPTIVE_NARRATING + , [(-5, 30, MOBILE_ANIMAL)] ) ] -rosterDefense = rosterCrawl - { rosterList = [ ( playerAntiHero - , Just teamExplorer - , [(-1, 3, HERO)] ) - , ( playerAntiMonster - , Nothing - , [(-4, 1, SCOUT_MONSTER), (-4, 3, MONSTER)] ) - , ( playerAnimal - , Nothing - , [ (-1, 1 + 1 `d` 2, ANIMAL) - , (-10, 100, MOBILE_ANIMAL) ] ) ] } +rosterDefense = + [ ( EXPLORER_AUTOMATED + , [(-1, 3, HERO)] ) + , ( MONSTER_ANTI + , [(-4, 1, SCOUT_MONSTER), (-4, 3, MONSTER)] ) + , ( ANIMAL_REPRESENTATIVE + , [ (-1, 1 + 1 `d` 2, ANIMAL) + , (-10, 100, MOBILE_ANIMAL) ] ) ] -rosterDefenseEmpty = rosterCrawl - { rosterList = [ ( playerAntiMonster {fneverEmpty = True} - , Nothing - , [(-4, 1, SCOUT_MONSTER)] ) - , (playerHorror, Nothing, []) ] - -- for spawned and summoned animals - , rosterEnemy = [] - , rosterAlly = [] } +rosterDefenseEmpty = + [ ( MONSTER_ANTI_PACIFIST + , [(-4, 1, SCOUT_MONSTER)] ) + , (HORROR_PACIFIST, []) ] + -- for spawned and summoned animals -cavesRaid, cavesBrawl, cavesCrawl, cavesShootout, cavesHunt, cavesEscape, cavesZoo, cavesAmbush, cavesSafari, cavesDig, cavesSee, cavesShort, cavesCrawlEmpty, cavesBattle :: Caves +cavesRaid, cavesBrawl, cavesCrawl, cavesShootout, cavesHunt, cavesFlight, cavesZoo, cavesAmbush, cavesSafari, cavesDig, cavesSee, cavesShort, cavesCrawlEmpty, cavesBattle :: Caves cavesRaid = [([-2], [CAVE_RAID])] @@ -772,7 +663,7 @@ cavesHunt = [([-6], [CAVE_HUNT])] -cavesEscape = [([-7], [CAVE_ESCAPE])] +cavesFlight = [([-7], [CAVE_FLIGHT])] cavesZoo = [([-8], [CAVE_ZOO])] @@ -800,7 +691,7 @@ allCaves :: [GroupName CaveKind] allCaves = - [ CAVE_RAID, CAVE_BRAWL, CAVE_SHOOTOUT, CAVE_HUNT, CAVE_ESCAPE, CAVE_ZOO + [ CAVE_RAID, CAVE_BRAWL, CAVE_SHOOTOUT, CAVE_HUNT, CAVE_FLIGHT, CAVE_ZOO , CAVE_AMBUSH , CAVE_ROGUE, CAVE_LABORATORY, CAVE_EMPTY, CAVE_ARENA, CAVE_SMOKING , CAVE_NOISE, CAVE_MINE ] diff --git a/GameDefinition/Content/ModeKindPlayer.hs b/GameDefinition/Content/ModeKindPlayer.hs deleted file mode 100644 --- a/GameDefinition/Content/ModeKindPlayer.hs +++ /dev/null @@ -1,184 +0,0 @@ --- | Basic players definitions. -module Content.ModeKindPlayer - ( playerHero, playerAntiHero, playerCivilian - , playerMonster, playerAntiMonster, playerAnimal - , playerHorror, playerMonsterTourist, playerHunamConvict - , playerAnimalMagnificent, playerAnimalExquisite - , hiHeroShort, hiHeroMedium, hiHeroLong, hiDweller - ) where - -import Prelude () - -import Game.LambdaHack.Core.Prelude - -import Content.ItemKindActor -import Content.ItemKindOrgan -import qualified Game.LambdaHack.Content.ItemKind as IK -import Game.LambdaHack.Content.ModeKind -import Game.LambdaHack.Definition.Ability - -playerHero, playerAntiHero, playerCivilian, playerMonster, playerAntiMonster, playerAnimal, playerHorror, playerMonsterTourist, playerHunamConvict, playerAnimalMagnificent, playerAnimalExquisite :: Player - -playerHero = Player - { fname = "Explorer" - , fgroups = [HERO] - , fskillsOther = meleeAdjacent - , fcanEscape = True - , fneverEmpty = True - , fhiCondPoly = hiHeroLong - , fhasGender = True - , fdoctrine = TExplore - , fleaderMode = Just $ AutoLeader False False - , fhasUI = True - , funderAI = False - } - -playerAntiHero = playerHero - { fleaderMode = Just $ AutoLeader True False - , fhasUI = False - , funderAI = True - } - -playerCivilian = Player - { fname = "Civilian" - , fgroups = [HERO, CIVILIAN] - , fskillsOther = zeroSkills -- not coordinated by any leadership - , fcanEscape = False - , fneverEmpty = True - , fhiCondPoly = hiHeroMedium - , fhasGender = True - , fdoctrine = TPatrol - , fleaderMode = Nothing -- unorganized - , fhasUI = False - , funderAI = True - } - -playerMonster = Player - { fname = "Monster Hive" - , fgroups = [MONSTER, MOBILE_MONSTER] - , fskillsOther = zeroSkills - , fcanEscape = False - , fneverEmpty = False - , fhiCondPoly = hiDweller - , fhasGender = False - , fdoctrine = TExplore - , fleaderMode = - -- No point changing leader on level, since all move and they - -- don't follow the leader. - Just $ AutoLeader True True - , fhasUI = False - , funderAI = True - } - -playerAntiMonster = playerMonster - { fleaderMode = Just $ AutoLeader True True - , fhasUI = True - , funderAI = False - } - -playerAnimal = Player - { fname = "Animal Kingdom" - , fgroups = [ANIMAL, MOBILE_ANIMAL, IMMOBILE_ANIMAL, SCAVENGER] - , fskillsOther = zeroSkills - , fcanEscape = False - , fneverEmpty = False - , fhiCondPoly = hiDweller - , fhasGender = False - , fdoctrine = TRoam -- can't pick up, so no point exploring - , fleaderMode = Nothing - , fhasUI = False - , funderAI = True - } - --- | A special player, for summoned actors that don't belong to any --- of the main players of a given game. E.g., animals summoned during --- a brawl game between two hero factions land in the horror faction. --- In every game, either all factions for which summoning items exist --- should be present or a horror player should be added to host them. -playerHorror = Player - { fname = "Horror Den" - , fgroups = [IK.HORROR] - , fskillsOther = zeroSkills - , fcanEscape = False - , fneverEmpty = False - , fhiCondPoly = [] - , fhasGender = False - , fdoctrine = TPatrol -- disoriented - , fleaderMode = Nothing - , fhasUI = False - , funderAI = True - } - -playerMonsterTourist = - playerAntiMonster { fname = "Monster Tourist Office" - , fcanEscape = True - , fneverEmpty = True -- no spawning - , fhiCondPoly = hiHeroMedium - , fdoctrine = TFollow -- follow-the-guide, as tourists do - , fleaderMode = Just $ AutoLeader False False - , funderAI = False } - -playerHunamConvict = - playerCivilian { fname = "Hunam Convict" - , fleaderMode = Just $ AutoLeader True False - , funderAI = True } - -playerAnimalMagnificent = - playerAnimal { fname = "Animal Magnificent Specimen Variety" - , fneverEmpty = True } - -playerAnimalExquisite = - playerAnimal { fname = "Animal Exquisite Herds and Packs Galore" - , fneverEmpty = True } - -hiHeroLong, hiHeroMedium, hiHeroShort, hiDweller :: HiCondPoly - -hiHeroShort = - [ ( [(HiLoot, 100)] - , [minBound..maxBound] ) - , ( [(HiConst, 100)] - , victoryOutcomes ) - , ( [(HiSprint, -500)] -- speed matters, but only if fast enough - , victoryOutcomes ) - , ( [(HiSurvival, 10)] -- few points for surviving long - , deafeatOutcomes ) - ] - -hiHeroMedium = - [ ( [(HiLoot, 200)] -- usually no loot, but if so, no harm - , [minBound..maxBound] ) - , ( [(HiConst, 200), (HiLoss, -10)] - , victoryOutcomes ) - , ( [(HiSprint, -500)] -- speed matters, but only if fast enough - , victoryOutcomes ) - , ( [(HiBlitz, -100)] -- speed matters always - , victoryOutcomes ) - , ( [(HiSurvival, 10)] -- few points for surviving long - , deafeatOutcomes ) - ] - --- Heroes in long crawls rejoice in loot. -hiHeroLong = - [ ( [(HiLoot, 10000)] -- multiplied by fraction of collected - , [minBound..maxBound] ) - , ( [(HiSprint, -20000)] -- speedrun bonus, if below this number of turns - , victoryOutcomes ) - , ( [(HiBlitz, -100)] -- speed matters always - , victoryOutcomes ) - , ( [(HiSurvival, 10)] -- few points for surviving long - , deafeatOutcomes ) - ] - --- Spawners get no points from loot, but try to kill --- all opponents fast or at least hold up for long. -hiDweller = [ ( [(HiConst, 1000)] -- no loot, so big win reward - , victoryOutcomes ) - , ( [(HiConst, 1000), (HiLoss, -10)] - , victoryOutcomes ) - , ( [(HiSprint, -1000)] -- speedrun bonus, if below - , victoryOutcomes ) - , ( [(HiBlitz, -100)] -- speed matters - , victoryOutcomes ) - , ( [(HiSurvival, 100)] - , deafeatOutcomes ) - ] diff --git a/GameDefinition/Content/PlaceKind.hs b/GameDefinition/Content/PlaceKind.hs --- a/GameDefinition/Content/PlaceKind.hs +++ b/GameDefinition/Content/PlaceKind.hs @@ -2,7 +2,7 @@ -- place kind. module Content.PlaceKind ( -- * Group name patterns - pattern ROGUE, pattern LABORATORY, pattern ZOO, pattern BRAWL, pattern SHOOTOUT, pattern ARENA, pattern ESCAPE, pattern AMBUSH, pattern BATTLE, pattern NOISE, pattern MINE, pattern EMPTY + pattern ROGUE, pattern LABORATORY, pattern ZOO, pattern BRAWL, pattern SHOOTOUT, pattern ARENA, pattern FLIGHT, pattern AMBUSH, pattern BATTLE, pattern NOISE, pattern MINE, pattern EMPTY , pattern INDOOR_ESCAPE_DOWN, pattern INDOOR_ESCAPE_UP, pattern OUTDOOR_ESCAPE_DOWN, pattern TINY_STAIRCASE, pattern OPEN_STAIRCASE, pattern CLOSED_STAIRCASE, pattern WALLED_STAIRCASE, pattern GATED_TINY_STAIRCASE, pattern GATED_OPEN_STAIRCASE, pattern GATED_CLOSED_STAIRCASE, pattern OUTDOOR_TINY_STAIRCASE, pattern OUTDOOR_CLOSED_STAIRCASE, pattern OUTDOOR_WALLED_STAIRCASE , groupNamesSingleton, groupNames , -- * Content @@ -16,12 +16,13 @@ import qualified Data.EnumMap.Strict as EM import qualified Data.Text as T -import Content.TileKind hiding (content, groupNames, groupNamesSingleton) import Game.LambdaHack.Content.PlaceKind import Game.LambdaHack.Content.TileKind (TileKind) import Game.LambdaHack.Definition.Defs import Game.LambdaHack.Definition.DefsInternal +import Content.TileKind hiding (content, groupNames, groupNamesSingleton) + -- * Group name patterns groupNamesSingleton :: [GroupName PlaceKind] @@ -31,11 +32,11 @@ -- group names, let's also add the generated group names to @groupNames@. groupNames :: [GroupName PlaceKind] groupNames = - [ROGUE, LABORATORY, ZOO, BRAWL, SHOOTOUT, ARENA, ESCAPE, AMBUSH, BATTLE, NOISE, MINE, EMPTY] + [ROGUE, LABORATORY, ZOO, BRAWL, SHOOTOUT, ARENA, FLIGHT, AMBUSH, BATTLE, NOISE, MINE, EMPTY] ++ [INDOOR_ESCAPE_DOWN, INDOOR_ESCAPE_UP, OUTDOOR_ESCAPE_DOWN, TINY_STAIRCASE, OPEN_STAIRCASE, CLOSED_STAIRCASE, WALLED_STAIRCASE] ++ fst generatedStairs -pattern ROGUE, LABORATORY, ZOO, BRAWL, SHOOTOUT, ARENA, ESCAPE, AMBUSH, BATTLE, NOISE, MINE, EMPTY :: GroupName PlaceKind +pattern ROGUE, LABORATORY, ZOO, BRAWL, SHOOTOUT, ARENA, FLIGHT, AMBUSH, BATTLE, NOISE, MINE, EMPTY :: GroupName PlaceKind pattern INDOOR_ESCAPE_DOWN, INDOOR_ESCAPE_UP, OUTDOOR_ESCAPE_DOWN, TINY_STAIRCASE, OPEN_STAIRCASE, CLOSED_STAIRCASE, WALLED_STAIRCASE, GATED_TINY_STAIRCASE, GATED_OPEN_STAIRCASE, GATED_CLOSED_STAIRCASE, OUTDOOR_TINY_STAIRCASE, OUTDOOR_CLOSED_STAIRCASE, OUTDOOR_WALLED_STAIRCASE :: GroupName PlaceKind @@ -45,16 +46,16 @@ pattern BRAWL = GroupName "brawl" pattern SHOOTOUT = GroupName "shootout" pattern ARENA = GroupName "arena" -pattern ESCAPE = GroupName "escape" +pattern FLIGHT = GroupName "flight" pattern AMBUSH = GroupName "ambush" pattern BATTLE = GroupName "battle" pattern NOISE = GroupName "noise" pattern MINE = GroupName "mine" pattern EMPTY = GroupName "empty" -pattern INDOOR_ESCAPE_DOWN = GroupName "escape down" -pattern INDOOR_ESCAPE_UP = GroupName "escape up" -pattern OUTDOOR_ESCAPE_DOWN = GroupName "outdoor escape route" +pattern INDOOR_ESCAPE_DOWN = GroupName "indoor escape down" +pattern INDOOR_ESCAPE_UP = GroupName "indoor escape up" +pattern OUTDOOR_ESCAPE_DOWN = GroupName "outdoor escape down" pattern TINY_STAIRCASE = GroupName "tiny staircase" pattern OPEN_STAIRCASE = GroupName "open staircase" pattern CLOSED_STAIRCASE = GroupName "closed staircase" @@ -113,8 +114,8 @@ , ('-', S_WALL_HORIZONTAL_LIT) , ('0', S_PILLAR) , ('&', S_RUBBLE_PILE) - , ('<', ESCAPE_UP) - , ('>', ESCAPE_DOWN) + , ('<', TILE_INDOOR_ESCAPE_UP) + , ('>', TILE_INDOOR_ESCAPE_DOWN) , ('·', FLOOR_ACTOR_ITEM_LIT) , ('~', S_SHALLOW_WATER_LIT) , ('I', SIGNBOARD) ] @@ -126,15 +127,14 @@ , ('-', S_WALL_HORIZONTAL_DARK) , ('0', S_PILLAR) , ('&', S_RUBBLE_PILE) - , ('<', ESCAPE_UP) - , ('>', ESCAPE_DOWN) + , ('<', TILE_INDOOR_ESCAPE_UP) + , ('>', TILE_INDOOR_ESCAPE_DOWN) , ('·', FLOOR_ACTOR_ITEM_DARK) , ('~', S_SHALLOW_WATER_DARK) , ('I', SIGNBOARD) ] deadEnd = PlaceKind -- needs to have index 0 - { psymbol = 'd' - , pname = "a dead end" + { pname = "a dead end" , pfreq = [] , prarity = [] , pcover = CStretch @@ -144,8 +144,7 @@ , plegendLit = defaultLegendLit } rect = PlaceKind -- Valid for any nonempty area, hence low frequency. - { psymbol = 'r' - , pname = "a chamber" + { pname = "a chamber" , pfreq = [(ROGUE, 30), (LABORATORY, 10)] , prarity = [(1, 10), (10, 6)] , pcover = CStretch @@ -174,9 +173,8 @@ , ('!', RECT_WINDOWS_VERTICAL_DARK) ] [ ('=', RECT_WINDOWS_HORIZONTAL_LIT) , ('!', RECT_WINDOWS_VERTICAL_LIT) ] $ PlaceKind - { psymbol = 'w' - , pname = "a hut" - , pfreq = [(ESCAPE, 10), (AMBUSH, 7)] + { pname = "a hut" + , pfreq = [(FLIGHT, 10), (AMBUSH, 7)] , prarity = [(1, 10), (10, 10)] , pcover = CStretch , pfence = FNone @@ -189,8 +187,7 @@ glasshouse = overridePlaceKind [ ('=', GLASSHOUSE_HORIZONTAL_LIT) -- visible from afar , ('!', GLASSHOUSE_VERTICAL_LIT) ] $ PlaceKind - { psymbol = 'g' - , pname = "a glasshouse" + { pname = "a glasshouse" , pfreq = [(SHOOTOUT, 4)] , prarity = [(1, 10), (10, 7)] , pcover = CStretch @@ -216,8 +213,7 @@ , ('!', GLASSHOUSE_VERTICAL_LIT) , ('0', S_PULPIT) ] $ PlaceKind -- except for floor, all will be lit, regardless of night/dark; OK - { psymbol = 'p' - , pname = "a stand dais" + { pname = "a stand dais" , pfreq = [(ARENA, 200), (ZOO, 200)] , prarity = [(1, 1)] , pcover = CMirror @@ -230,8 +226,7 @@ , plegendLit = defaultLegendLit } ruin = PlaceKind - { psymbol = 'R' - , pname = "ruins" + { pname = "ruins" , pfreq = [(BATTLE, 330)] , prarity = [(1, 1)] , pcover = CStretch @@ -248,8 +243,7 @@ , pfreq = [(AMBUSH, 50)] } collapsed = PlaceKind - { psymbol = 'c' - , pname = "a collapsed cavern" + { pname = "a collapsed cavern" , pfreq = [(NOISE, 1)] -- no point taking up space if very little space taken, -- but if no other place can be generated, a failsafe is useful @@ -301,8 +295,7 @@ ] } pillar = PlaceKind - { psymbol = 'p' - , pname = "a hall" + { pname = "a hall" , pfreq = [(ROGUE, 600), (LABORATORY, 2000)] , prarity = [(1, 1)] , pcover = CStretch @@ -354,11 +347,10 @@ ] } colonnade = PlaceKind - { psymbol = 'c' - , pname = "a colonnade" + { pname = "a colonnade" , pfreq = [ (ROGUE, 3), (ARENA, 20), (LABORATORY, 2) , (EMPTY, 10000), (MINE, 1000), (BRAWL, 4) - , (ESCAPE, 40), (AMBUSH, 40) ] + , (FLIGHT, 40), (AMBUSH, 40) ] , prarity = [(1, 10), (10, 10)] , pcover = CAlternate , pfence = FFloor @@ -403,9 +395,8 @@ } lampPost = overridePlaceKind [ ('0', S_LAMP_POST) , ('·', S_FLOOR_ACTOR_LIT) ] $ PlaceKind - { psymbol = 'l' - , pname = "a lamp-lit area" - , pfreq = [(ESCAPE, 200), (AMBUSH, 200), (ZOO, 100), (BATTLE, 100)] + { pname = "a lamp-lit area" + , pfreq = [(FLIGHT, 200), (AMBUSH, 200), (ZOO, 100), (BATTLE, 100)] , prarity = [(1, 1)] , pcover = CVerbatim , pfence = FNone @@ -423,7 +414,7 @@ ] } lampPost3 = lampPost - { pfreq = [ (ESCAPE, 3000), (AMBUSH, 3000), (ZOO, 50) + { pfreq = [ (FLIGHT, 3000), (AMBUSH, 3000), (ZOO, 50) , (BATTLE, 110) ] , ptopLeft = [ "XX·XX" , "X···X" @@ -433,7 +424,7 @@ ] } lampPost4 = lampPost - { pfreq = [(ESCAPE, 3000), (AMBUSH, 3000), (ZOO, 50), (BATTLE, 60)] + { pfreq = [(FLIGHT, 3000), (AMBUSH, 3000), (ZOO, 50), (BATTLE, 60)] , ptopLeft = [ "X···X" , "·····" , "··0··" @@ -446,8 +437,7 @@ [ ('0', S_TREE_LIT) , ('s', TREE_SHADE_WALKABLE_LIT) ] $ overridePlaceKind [('·', S_SHADED_GROUND)] $ PlaceKind - { psymbol = 't' - , pname = "a tree shade" + { pname = "a tree shade" , pfreq = [(BRAWL, 1000)] , prarity = [(1, 1)] , pcover = CMirror @@ -462,8 +452,7 @@ fogClump = override2PlaceKind [('f', FOG_CLUMP_DARK)] [('f', FOG_CLUMP_LIT)] $ overridePlaceKind [(';', S_FOG_LIT)] $ PlaceKind - { psymbol = 'f' - , pname = "a foggy patch" + { pname = "a foggy patch" , pfreq = [(SHOOTOUT, 150), (EMPTY, 15)] , prarity = [(1, 1)] , pcover = CMirror @@ -488,8 +477,7 @@ [ ('f', SMOKE_CLUMP_LIT) , ('·', S_FLOOR_ACTOR_LIT) ] $ overridePlaceKind [(';', S_SMOKE_LIT)] $ PlaceKind - { psymbol = 's' - , pname = "a smoky patch" + { pname = "a smoky patch" , pfreq = [(ZOO, 50)] , prarity = [(1, 1)] , pcover = CMirror @@ -526,8 +514,7 @@ bushClump = override2PlaceKind [('f', BUSH_CLUMP_DARK)] [('f', BUSH_CLUMP_LIT)] $ overridePlaceKind [(';', S_BUSH_LIT)] $ PlaceKind - { psymbol = 'b' - , pname = "a bushy patch" + { pname = "a bushy patch" , pfreq = [(SHOOTOUT, 40)] , prarity = [(1, 1)] , pcover = CMirror @@ -551,8 +538,7 @@ } escapeDown = overridePlaceKind [ ('|', S_WALL_LIT) -- visible from afar , ('-', S_WALL_HORIZONTAL_LIT) ] $ PlaceKind - { psymbol = '>' - , pname = "an escape down" + { pname = "an escape down" , pfreq = [(INDOOR_ESCAPE_DOWN, 1)] , prarity = [(1, 1)] , pcover = CVerbatim @@ -604,8 +590,7 @@ , ('>', STAIRCASE_DOWN) , ('|', S_WALL_LIT) -- visible from afar , ('-', S_WALL_HORIZONTAL_LIT) ] $ PlaceKind - { psymbol = '/' - , pname = "a staircase" + { pname = "a staircase" , pfreq = [(TINY_STAIRCASE, 1)] -- no cover when arriving; low freq , prarity = [(1, 100), (10, 100)] , pcover = CVerbatim @@ -989,16 +974,14 @@ switchStaircaseToUp :: PlaceKind -> PlaceKind switchStaircaseToUp s = override2PlaceKind [('>', STAIR_TERMINAL_DARK)] [('>', STAIR_TERMINAL_LIT)] $ s - { psymbol = '<' - , pname = pname s <+> "up" + { pname = pname s <+> "up" , pfreq = renameFreqs (<+> "up") $ pfreq s } switchStaircaseToDown :: PlaceKind -> PlaceKind switchStaircaseToDown s = override2PlaceKind [('<', STAIR_TERMINAL_DARK)] [('<', STAIR_TERMINAL_LIT)] $ s - { psymbol = '>' - , pname = pname s <+> "down" + { pname = pname s <+> "down" , pfreq = renameFreqs (<+> "down") $ pfreq s } @@ -1009,8 +992,7 @@ switchStaircaseToGated :: PlaceKind -> PlaceKind switchStaircaseToGated s = overridePlaceKind overrideGated $ s - { psymbol = 'g' - , pname = T.unwords $ "a gated" : tail (T.words (pname s)) + { pname = T.unwords $ "a gated" : tail (T.words (pname s)) , pfreq = renameFreqs ("gated" <+>) $ pfreq s } @@ -1021,20 +1003,19 @@ switchStaircaseToOutdoor :: PlaceKind -> PlaceKind switchStaircaseToOutdoor s = overridePlaceKind overrideOutdoor $ s - { psymbol = 'o' - , pname = "an outdoor area exit" + { pname = "an outdoor area exit" , pfreq = renameFreqs ("outdoor" <+>) $ pfreq s } switchEscapeToUp :: PlaceKind -> PlaceKind -switchEscapeToUp s = overridePlaceKind [('>', ESCAPE_UP)] $ s - { psymbol = '<' - , pname = "an escape up" +switchEscapeToUp s = overridePlaceKind [('>', TILE_INDOOR_ESCAPE_UP)] $ s + { pname = "an escape up" , pfreq = map (\(_, n) -> (INDOOR_ESCAPE_UP, n)) $ pfreq s } switchEscapeToOutdoorDown :: PlaceKind -> PlaceKind -switchEscapeToOutdoorDown s = overridePlaceKind [('>', ESCAPE_OUTDOOR_DOWN)] $ s +switchEscapeToOutdoorDown s = overridePlaceKind + [('>', TILE_OUTDOOR_ESCAPE_DOWN)] $ s { pname = "outdoor escape route" , pfreq = map (\(_, n) -> (OUTDOOR_ESCAPE_DOWN, n)) $ pfreq s } diff --git a/GameDefinition/Content/RuleKind.hs b/GameDefinition/Content/RuleKind.hs --- a/GameDefinition/Content/RuleKind.hs +++ b/GameDefinition/Content/RuleKind.hs @@ -34,17 +34,17 @@ , rcfgUIDefault = $(do let path = "GameDefinition" "config.ui" <.> "default" qAddDependentFile path - s <- qRunIO $ do + !s <- qRunIO $ do inputHandle <- openFile path ReadMode hSetEncoding inputHandle utf8 hGetContents inputHandle - let cfgUIDefault = + let !cfgUIDefault = either (error . ("Ini.parse of default config" `showFailure`)) id $ Ini.parse s lift (s, cfgUIDefault)) , rwriteSaveClips = 1000 , rleadLevelClips = 50 - , rscoresFile = "LambdaHack.scores" + , rscoresFileName = "LambdaHack.scores" , rnearby = 20 , rstairWordCarried = ["staircase"] -- only one, so inert , ritemSymbols = ItemSymbolsUsedInEngine diff --git a/GameDefinition/Content/TileKind.hs b/GameDefinition/Content/TileKind.hs --- a/GameDefinition/Content/TileKind.hs +++ b/GameDefinition/Content/TileKind.hs @@ -4,9 +4,9 @@ ( -- * Group name patterns -- ** Used in CaveKind and perhaps elsewhere. pattern FILLER_WALL, pattern FLOOR_CORRIDOR_LIT, pattern FLOOR_CORRIDOR_DARK, pattern TRAIL_LIT, pattern SAFE_TRAIL_LIT, pattern LAB_TRAIL_LIT, pattern DAMP_FLOOR_LIT, pattern DAMP_FLOOR_DARK, pattern OUTDOOR_OUTER_FENCE, pattern DIRT_LIT, pattern DIRT_DARK, pattern FLOOR_ARENA_LIT, pattern FLOOR_ARENA_DARK - , pattern EMPTY_SET_LIT, pattern EMPTY_SET_DARK, pattern NOISE_SET_LIT, pattern POWER_SET_LIT, pattern POWER_SET_DARK, pattern BATTLE_SET_LIT, pattern BATTLE_SET_DARK, pattern BRAWL_SET_LIT, pattern SHOOTOUT_SET_LIT, pattern ZOO_SET_LIT, pattern ZOO_SET_DARK, pattern ESCAPE_SET_LIT, pattern ESCAPE_SET_DARK, pattern AMBUSH_SET_LIT, pattern AMBUSH_SET_DARK, pattern ARENA_SET_LIT, pattern ARENA_SET_DARK + , pattern EMPTY_SET_LIT, pattern EMPTY_SET_DARK, pattern NOISE_SET_LIT, pattern POWER_SET_LIT, pattern POWER_SET_DARK, pattern BATTLE_SET_LIT, pattern BATTLE_SET_DARK, pattern BRAWL_SET_LIT, pattern SHOOTOUT_SET_LIT, pattern ZOO_SET_LIT, pattern ZOO_SET_DARK, pattern FLIGHT_SET_LIT, pattern FLIGHT_SET_DARK, pattern AMBUSH_SET_LIT, pattern AMBUSH_SET_DARK, pattern ARENA_SET_LIT, pattern ARENA_SET_DARK -- ** Used in PlaceKind, but not in CaveKind. - , pattern RECT_WINDOWS_VERTICAL_LIT, pattern RECT_WINDOWS_VERTICAL_DARK, pattern RECT_WINDOWS_HORIZONTAL_LIT, pattern RECT_WINDOWS_HORIZONTAL_DARK, pattern TREE_SHADE_WALKABLE_LIT, pattern TREE_SHADE_WALKABLE_DARK, pattern SMOKE_CLUMP_LIT, pattern SMOKE_CLUMP_DARK, pattern GLASSHOUSE_VERTICAL_LIT, pattern GLASSHOUSE_VERTICAL_DARK, pattern GLASSHOUSE_HORIZONTAL_LIT, pattern GLASSHOUSE_HORIZONTAL_DARK, pattern BUSH_CLUMP_LIT, pattern BUSH_CLUMP_DARK, pattern FOG_CLUMP_LIT, pattern FOG_CLUMP_DARK, pattern STAIR_TERMINAL_LIT, pattern STAIR_TERMINAL_DARK, pattern CACHE, pattern SIGNBOARD, pattern STAIRCASE_UP, pattern ORDINARY_STAIRCASE_UP, pattern STAIRCASE_OUTDOOR_UP, pattern GATED_STAIRCASE_UP, pattern STAIRCASE_DOWN, pattern ORDINARY_STAIRCASE_DOWN, pattern STAIRCASE_OUTDOOR_DOWN, pattern GATED_STAIRCASE_DOWN, pattern ESCAPE_UP, pattern ESCAPE_DOWN, pattern ESCAPE_OUTDOOR_DOWN, pattern FLOOR_ACTOR_ITEM_LIT, pattern FLOOR_ACTOR_ITEM_DARK + , pattern RECT_WINDOWS_VERTICAL_LIT, pattern RECT_WINDOWS_VERTICAL_DARK, pattern RECT_WINDOWS_HORIZONTAL_LIT, pattern RECT_WINDOWS_HORIZONTAL_DARK, pattern TREE_SHADE_WALKABLE_LIT, pattern TREE_SHADE_WALKABLE_DARK, pattern SMOKE_CLUMP_LIT, pattern SMOKE_CLUMP_DARK, pattern GLASSHOUSE_VERTICAL_LIT, pattern GLASSHOUSE_VERTICAL_DARK, pattern GLASSHOUSE_HORIZONTAL_LIT, pattern GLASSHOUSE_HORIZONTAL_DARK, pattern BUSH_CLUMP_LIT, pattern BUSH_CLUMP_DARK, pattern FOG_CLUMP_LIT, pattern FOG_CLUMP_DARK, pattern STAIR_TERMINAL_LIT, pattern STAIR_TERMINAL_DARK, pattern CACHE, pattern SIGNBOARD, pattern STAIRCASE_UP, pattern ORDINARY_STAIRCASE_UP, pattern STAIRCASE_OUTDOOR_UP, pattern GATED_STAIRCASE_UP, pattern STAIRCASE_DOWN, pattern ORDINARY_STAIRCASE_DOWN, pattern STAIRCASE_OUTDOOR_DOWN, pattern GATED_STAIRCASE_DOWN, pattern TILE_INDOOR_ESCAPE_UP, pattern TILE_INDOOR_ESCAPE_DOWN, pattern TILE_OUTDOOR_ESCAPE_DOWN, pattern FLOOR_ACTOR_ITEM_LIT, pattern FLOOR_ACTOR_ITEM_DARK , pattern S_PILLAR, pattern S_RUBBLE_PILE, pattern S_LAMP_POST, pattern S_TREE_LIT, pattern S_TREE_DARK, pattern S_WALL_LIT, pattern S_WALL_DARK, pattern S_WALL_HORIZONTAL_LIT, pattern S_WALL_HORIZONTAL_DARK, pattern S_PULPIT, pattern S_BUSH_LIT, pattern S_FOG_LIT, pattern S_SMOKE_LIT, pattern S_FLOOR_ACTOR_LIT, pattern S_FLOOR_ACTOR_DARK, pattern S_FLOOR_ASHES_LIT, pattern S_FLOOR_ASHES_DARK, pattern S_SHADED_GROUND, pattern S_SHALLOW_WATER_LIT, pattern S_SHALLOW_WATER_DARK , groupNamesSingleton, groupNames -- * Content @@ -19,12 +19,13 @@ import qualified Data.Text as T -import Content.ItemKindEmbed import Game.LambdaHack.Content.TileKind import Game.LambdaHack.Definition.Color import Game.LambdaHack.Definition.Defs import Game.LambdaHack.Definition.DefsInternal +import Content.ItemKindEmbed + -- * Group name patterns -- Warning, many of these are also sythesized, so typos can happen. @@ -49,17 +50,17 @@ groupNames :: [GroupName TileKind] groupNames = [FILLER_WALL, FLOOR_CORRIDOR_LIT, FLOOR_CORRIDOR_DARK, TRAIL_LIT, SAFE_TRAIL_LIT, LAB_TRAIL_LIT, DAMP_FLOOR_LIT, DAMP_FLOOR_DARK, OUTDOOR_OUTER_FENCE, DIRT_LIT, DIRT_DARK, FLOOR_ARENA_LIT, FLOOR_ARENA_DARK] - ++ [EMPTY_SET_LIT, EMPTY_SET_DARK, NOISE_SET_LIT, POWER_SET_LIT, POWER_SET_DARK, BATTLE_SET_LIT, BATTLE_SET_DARK, BRAWL_SET_LIT, SHOOTOUT_SET_LIT, ZOO_SET_LIT, ZOO_SET_DARK, ESCAPE_SET_LIT, ESCAPE_SET_DARK, AMBUSH_SET_LIT, AMBUSH_SET_DARK, ARENA_SET_LIT, ARENA_SET_DARK] - ++ [RECT_WINDOWS_VERTICAL_LIT, RECT_WINDOWS_VERTICAL_DARK, RECT_WINDOWS_HORIZONTAL_LIT, RECT_WINDOWS_HORIZONTAL_DARK, TREE_SHADE_WALKABLE_LIT, TREE_SHADE_WALKABLE_DARK, SMOKE_CLUMP_LIT, SMOKE_CLUMP_DARK, GLASSHOUSE_VERTICAL_LIT, GLASSHOUSE_VERTICAL_DARK, GLASSHOUSE_HORIZONTAL_LIT, GLASSHOUSE_HORIZONTAL_DARK, BUSH_CLUMP_LIT, BUSH_CLUMP_DARK, FOG_CLUMP_LIT, FOG_CLUMP_DARK, STAIR_TERMINAL_LIT, STAIR_TERMINAL_DARK, CACHE, SIGNBOARD, STAIRCASE_UP, ORDINARY_STAIRCASE_UP, STAIRCASE_OUTDOOR_UP, GATED_STAIRCASE_UP, STAIRCASE_DOWN, ORDINARY_STAIRCASE_DOWN, STAIRCASE_OUTDOOR_DOWN, GATED_STAIRCASE_DOWN, ESCAPE_UP, ESCAPE_DOWN, ESCAPE_OUTDOOR_DOWN, FLOOR_ACTOR_ITEM_LIT, FLOOR_ACTOR_ITEM_DARK] + ++ [EMPTY_SET_LIT, EMPTY_SET_DARK, NOISE_SET_LIT, POWER_SET_LIT, POWER_SET_DARK, BATTLE_SET_LIT, BATTLE_SET_DARK, BRAWL_SET_LIT, SHOOTOUT_SET_LIT, ZOO_SET_LIT, ZOO_SET_DARK, FLIGHT_SET_LIT, FLIGHT_SET_DARK, AMBUSH_SET_LIT, AMBUSH_SET_DARK, ARENA_SET_LIT, ARENA_SET_DARK] + ++ [RECT_WINDOWS_VERTICAL_LIT, RECT_WINDOWS_VERTICAL_DARK, RECT_WINDOWS_HORIZONTAL_LIT, RECT_WINDOWS_HORIZONTAL_DARK, TREE_SHADE_WALKABLE_LIT, TREE_SHADE_WALKABLE_DARK, SMOKE_CLUMP_LIT, SMOKE_CLUMP_DARK, GLASSHOUSE_VERTICAL_LIT, GLASSHOUSE_VERTICAL_DARK, GLASSHOUSE_HORIZONTAL_LIT, GLASSHOUSE_HORIZONTAL_DARK, BUSH_CLUMP_LIT, BUSH_CLUMP_DARK, FOG_CLUMP_LIT, FOG_CLUMP_DARK, STAIR_TERMINAL_LIT, STAIR_TERMINAL_DARK, CACHE, SIGNBOARD, STAIRCASE_UP, ORDINARY_STAIRCASE_UP, STAIRCASE_OUTDOOR_UP, GATED_STAIRCASE_UP, STAIRCASE_DOWN, ORDINARY_STAIRCASE_DOWN, STAIRCASE_OUTDOOR_DOWN, GATED_STAIRCASE_DOWN, TILE_INDOOR_ESCAPE_UP, TILE_INDOOR_ESCAPE_DOWN, TILE_OUTDOOR_ESCAPE_DOWN, FLOOR_ACTOR_ITEM_LIT, FLOOR_ACTOR_ITEM_DARK] ++ [OBSCURED_VERTICAL_WALL_LIT, OBSCURED_HORIZONTAL_WALL_LIT, TRAPPED_VERTICAL_DOOR_LIT, TRAPPED_HORIZONAL_DOOR_LIT, TREE_BURNING_OR_NOT, BUSH_BURNING_OR_NOT, CACHE_OR_NOT] ++ [BRAWL_SET_DARK, NOISE_SET_DARK, OBSCURED_HORIZONTAL_WALL_DARK, OBSCURED_VERTICAL_WALL_DARK, SHOOTOUT_SET_DARK, TRAPPED_HORIZONAL_DOOR_DARK, TRAPPED_VERTICAL_DOOR_DARK] pattern FILLER_WALL, FLOOR_CORRIDOR_LIT, FLOOR_CORRIDOR_DARK, TRAIL_LIT, SAFE_TRAIL_LIT, LAB_TRAIL_LIT, DAMP_FLOOR_LIT, DAMP_FLOOR_DARK, OUTDOOR_OUTER_FENCE, DIRT_LIT, DIRT_DARK, FLOOR_ARENA_LIT, FLOOR_ARENA_DARK :: GroupName TileKind -pattern EMPTY_SET_LIT, EMPTY_SET_DARK, NOISE_SET_LIT, POWER_SET_LIT, POWER_SET_DARK, BATTLE_SET_LIT, BATTLE_SET_DARK, BRAWL_SET_LIT, SHOOTOUT_SET_LIT, ZOO_SET_LIT, ZOO_SET_DARK, ESCAPE_SET_LIT, ESCAPE_SET_DARK, AMBUSH_SET_LIT, AMBUSH_SET_DARK, ARENA_SET_LIT, ARENA_SET_DARK :: GroupName TileKind +pattern EMPTY_SET_LIT, EMPTY_SET_DARK, NOISE_SET_LIT, POWER_SET_LIT, POWER_SET_DARK, BATTLE_SET_LIT, BATTLE_SET_DARK, BRAWL_SET_LIT, SHOOTOUT_SET_LIT, ZOO_SET_LIT, ZOO_SET_DARK, FLIGHT_SET_LIT, FLIGHT_SET_DARK, AMBUSH_SET_LIT, AMBUSH_SET_DARK, ARENA_SET_LIT, ARENA_SET_DARK :: GroupName TileKind -- ** Used in PlaceKind, but not in CaveKind. -pattern RECT_WINDOWS_VERTICAL_LIT, RECT_WINDOWS_VERTICAL_DARK, RECT_WINDOWS_HORIZONTAL_LIT, RECT_WINDOWS_HORIZONTAL_DARK, TREE_SHADE_WALKABLE_LIT, TREE_SHADE_WALKABLE_DARK, SMOKE_CLUMP_LIT, SMOKE_CLUMP_DARK, GLASSHOUSE_VERTICAL_LIT, GLASSHOUSE_VERTICAL_DARK, GLASSHOUSE_HORIZONTAL_LIT, GLASSHOUSE_HORIZONTAL_DARK, BUSH_CLUMP_LIT, BUSH_CLUMP_DARK, FOG_CLUMP_LIT, FOG_CLUMP_DARK, STAIR_TERMINAL_LIT, STAIR_TERMINAL_DARK, CACHE, SIGNBOARD, STAIRCASE_UP, ORDINARY_STAIRCASE_UP, STAIRCASE_OUTDOOR_UP, GATED_STAIRCASE_UP, STAIRCASE_DOWN, ORDINARY_STAIRCASE_DOWN, STAIRCASE_OUTDOOR_DOWN, GATED_STAIRCASE_DOWN, ESCAPE_UP, ESCAPE_DOWN, ESCAPE_OUTDOOR_DOWN, FLOOR_ACTOR_ITEM_LIT, FLOOR_ACTOR_ITEM_DARK :: GroupName TileKind +pattern RECT_WINDOWS_VERTICAL_LIT, RECT_WINDOWS_VERTICAL_DARK, RECT_WINDOWS_HORIZONTAL_LIT, RECT_WINDOWS_HORIZONTAL_DARK, TREE_SHADE_WALKABLE_LIT, TREE_SHADE_WALKABLE_DARK, SMOKE_CLUMP_LIT, SMOKE_CLUMP_DARK, GLASSHOUSE_VERTICAL_LIT, GLASSHOUSE_VERTICAL_DARK, GLASSHOUSE_HORIZONTAL_LIT, GLASSHOUSE_HORIZONTAL_DARK, BUSH_CLUMP_LIT, BUSH_CLUMP_DARK, FOG_CLUMP_LIT, FOG_CLUMP_DARK, STAIR_TERMINAL_LIT, STAIR_TERMINAL_DARK, CACHE, SIGNBOARD, STAIRCASE_UP, ORDINARY_STAIRCASE_UP, STAIRCASE_OUTDOOR_UP, GATED_STAIRCASE_UP, STAIRCASE_DOWN, ORDINARY_STAIRCASE_DOWN, STAIRCASE_OUTDOOR_DOWN, GATED_STAIRCASE_DOWN, TILE_INDOOR_ESCAPE_UP, TILE_INDOOR_ESCAPE_DOWN, TILE_OUTDOOR_ESCAPE_DOWN, FLOOR_ACTOR_ITEM_LIT, FLOOR_ACTOR_ITEM_DARK :: GroupName TileKind -- ** Used only internally in other TileKind definitions or never used. pattern OBSCURED_VERTICAL_WALL_LIT, OBSCURED_HORIZONTAL_WALL_LIT, TRAPPED_VERTICAL_DOOR_LIT, TRAPPED_HORIZONAL_DOOR_LIT, TREE_BURNING_OR_NOT, BUSH_BURNING_OR_NOT, CACHE_OR_NOT :: GroupName TileKind @@ -97,8 +98,8 @@ pattern SHOOTOUT_SET_LIT = GroupName "shootoutSetLit" pattern ZOO_SET_LIT = GroupName "zooSetLit" pattern ZOO_SET_DARK = GroupName "zooSetDark" -pattern ESCAPE_SET_LIT = GroupName "escapeSetLit" -pattern ESCAPE_SET_DARK = GroupName "escapeSetDark" +pattern FLIGHT_SET_LIT = GroupName "flightSetLit" +pattern FLIGHT_SET_DARK = GroupName "flightSetDark" pattern AMBUSH_SET_LIT = GroupName "ambushSetLit" pattern AMBUSH_SET_DARK = GroupName "ambushSetDark" pattern ARENA_SET_LIT = GroupName "arenaSetLit" @@ -133,9 +134,9 @@ pattern ORDINARY_STAIRCASE_DOWN = GroupName "ordinary staircase down" pattern STAIRCASE_OUTDOOR_DOWN = GroupName "staircase outdoor down" pattern GATED_STAIRCASE_DOWN = GroupName "gated staircase down" -pattern ESCAPE_UP = GroupName "escape up" -pattern ESCAPE_DOWN = GroupName "escape down" -pattern ESCAPE_OUTDOOR_DOWN = GroupName "escape outdoor down" +pattern TILE_INDOOR_ESCAPE_UP = GroupName "indoor escape up" +pattern TILE_INDOOR_ESCAPE_DOWN = GroupName "indoor escape down" +pattern TILE_OUTDOOR_ESCAPE_DOWN = GroupName "outdoor escape down" pattern FLOOR_ACTOR_ITEM_LIT = GroupName "floorActorItemLit" pattern FLOOR_ACTOR_ITEM_DARK = GroupName "floorActorItemDark" @@ -417,7 +418,7 @@ signboardRead = TileKind { tsymbol = '0' , tname = "signboard" - , tfreq = [(SIGNBOARD, 1), (ESCAPE_SET_DARK, 1)] + , tfreq = [(SIGNBOARD, 1), (FLIGHT_SET_DARK, 1)] , tcolor = BrCyan , tcolor2 = Cyan , talter = 5 @@ -427,7 +428,7 @@ { tsymbol = '0' , tname = "tree" , tfreq = [ (BRAWL_SET_LIT, 140), (SHOOTOUT_SET_LIT, 10) - , (ESCAPE_SET_LIT, 35), (AMBUSH_SET_LIT, 3) + , (FLIGHT_SET_LIT, 35), (AMBUSH_SET_LIT, 3) , (S_TREE_LIT, 1) ] , tcolor = BrGreen , tcolor2 = Green @@ -573,8 +574,8 @@ } escapeUp = TileKind { tsymbol = '<' - , tname = "exit hatch up" - , tfreq = [(ESCAPE_UP, 1)] + , tname = "escape hatch up" + , tfreq = [(TILE_INDOOR_ESCAPE_UP, 1)] , tcolor = BrYellow , tcolor2 = BrYellow , talter = 0 -- anybody can escape (or guard escape) @@ -582,16 +583,16 @@ } escapeDown = TileKind { tsymbol = '>' - , tname = "exit trapdoor down" - , tfreq = [(ESCAPE_DOWN, 1)] + , tname = "escape trapdoor down" + , tfreq = [(TILE_INDOOR_ESCAPE_DOWN, 1)] , tcolor = BrYellow , tcolor2 = BrYellow , talter = 0 -- anybody can escape (or guard escape) , tfeature = [Embed ESCAPE, ConsideredByAI] } escapeOutdoorDown = escapeDown - { tname = "exit back to town" - , tfreq = [(ESCAPE_OUTDOOR_DOWN, 1)] + { tname = "escape back to town" + , tfreq = [(TILE_OUTDOOR_ESCAPE_DOWN, 1)] } -- *** Clear @@ -644,7 +645,7 @@ bush = TileKind { tsymbol = '%' , tname = "bush" - , tfreq = [ (S_BUSH_LIT, 1), (SHOOTOUT_SET_LIT, 30), (ESCAPE_SET_LIT, 40) + , tfreq = [ (S_BUSH_LIT, 1), (SHOOTOUT_SET_LIT, 30), (FLIGHT_SET_LIT, 40) , (AMBUSH_SET_LIT, 3), (BUSH_CLUMP_LIT, 1) ] , tcolor = BrGreen , tcolor2 = Green @@ -691,7 +692,7 @@ fogDark = fog { tname = "thick fog" , tfreq = [ (EMPTY_SET_DARK, 50), (POWER_SET_DARK, 100) - , (ESCAPE_SET_DARK, 50) ] + , (FLIGHT_SET_DARK, 50) ] , tfeature = Dark : tfeature fog } smoke = TileKind @@ -759,7 +760,7 @@ } floorDirt = floorArena { tname = "dirt floor" - , tfreq = [ (SHOOTOUT_SET_LIT, 1000), (ESCAPE_SET_LIT, 1000) + , tfreq = [ (SHOOTOUT_SET_LIT, 1000), (FLIGHT_SET_LIT, 1000) , (AMBUSH_SET_LIT, 1000), (BATTLE_SET_LIT, 1000) , (BRAWL_SET_LIT, 1000), (DIRT_LIT, 1) ] } diff --git a/GameDefinition/InGameHelp.txt b/GameDefinition/InGameHelp.txt --- a/GameDefinition/InGameHelp.txt +++ b/GameDefinition/InGameHelp.txt @@ -168,7 +168,7 @@ C-c exit to desktop without saving ? display help F1 display help immediately - F12 open dashboard + F12 show history v voice last action again V voice recorded macro again ' start recording commands diff --git a/GameDefinition/Main.hs b/GameDefinition/Main.hs --- a/GameDefinition/Main.hs +++ b/GameDefinition/Main.hs @@ -10,8 +10,8 @@ import Control.Concurrent.Async import qualified Control.Exception as Ex +import qualified GHC.IO.Encoding as SIO import qualified Options.Applicative as OA -import System.Exit import qualified System.IO as SIO #ifndef USE_JSFILE @@ -30,6 +30,10 @@ -- run the game and handle exit. main :: IO () main = do + -- Correct unset or some other too primitive encodings. + let enc = SIO.localeEncoding + when (show enc `elem` ["ASCII", "ISO-8859-1", "ISO-8859-2"]) $ + SIO.setLocaleEncoding SIO.utf8 -- This test is faulty with JS, because it reports the browser console -- is not a terminal, but then we can't open files to contain the logs. -- Also it bloats the outcome JS file, so disabled. @@ -61,7 +65,5 @@ _ -> e case resOrEx of Right () -> return () - Left e -> case Ex.fromException $ unwrapEx e of - Just ExitSuccess -> - exitSuccess -- we are in the main thread, so here it really exits - _ -> Ex.throwIO $ unwrapEx e + Left ex -> Ex.throwIO $ unwrapEx ex + -- we are in the main thread, so now really exit diff --git a/GameDefinition/PLAYING.md b/GameDefinition/PLAYING.md --- a/GameDefinition/PLAYING.md +++ b/GameDefinition/PLAYING.md @@ -81,6 +81,9 @@ Game difficulty level, from the new game setup menu, determines how hard the survival in the game is. Each of the several named optional challenges make the game additionally much harder, but usually simpler, as well. +Not that in-game hints don't take challenges into account +so kindly ignore, e.g., advice to use ranged combat more often, +if the chosen challenge bans ranged combat use altogether. Of the convenience settings, the `suspect terrain` choice is of particular interest, because it determines not only screen display of the floor map, but also whether suspect tiles are considered for mouse go-to, auto-explore @@ -460,7 +463,7 @@ You win an adventure if you escape the location alive (which may prove difficult, because your foes tend to gradually build up the ambush squad -blocking your escape route) or, in scenarios with no exit locations, +blocking your escape route) or, in scenarios with no escape locations, if you eliminate all opposition. In the former case, your score is based predominantly on the gold and precious gems you've plundered. In the latter case, your score is most influenced by the number diff --git a/GameDefinition/config.ui.default b/GameDefinition/config.ui.default --- a/GameDefinition/config.ui.default +++ b/GameDefinition/config.ui.default @@ -125,4 +125,4 @@ ; any more, the game crashes. To prevent that, one of the first three components ; of the game version should be bumped whenever fonts are changed. ; Configs from old versions are rejected, preventing the crash. -version = 0.10.3 +version = 0.11.0 diff --git a/GameDefinition/game-src/Client/UI/Content/Input.hs b/GameDefinition/game-src/Client/UI/Content/Input.hs --- a/GameDefinition/game-src/Client/UI/Content/Input.hs +++ b/GameDefinition/game-src/Client/UI/Content/Input.hs @@ -52,7 +52,7 @@ , aiming = Accept } )) , ("space", ( [CmdMinimal, CmdAim] , "clear messages/show history/cycle detail level" - , ByAimMode AimModeCmd { exploration = ExecuteIfClear LastHistory + , ByAimMode AimModeCmd { exploration = ExecuteIfClear AllHistory , aiming = DetailCycle } )) , ("Tab", memberCycle Forward [CmdMinimal, CmdMove]) -- listed here to keep proper order of the minimal cheat sheet @@ -93,7 +93,7 @@ , ChooseItemMenu MOwned )) , ("@", ( [CmdMeta, CmdDashboard] , "describe organs of the pointman" - , ChooseItemMenu MOrgans )) + , ChooseItemMenu (MLore SBody) )) , ("#", ( [CmdMeta, CmdDashboard] , "show skill summary of the pointman" , ChooseItemMenu MSkills )) @@ -105,15 +105,18 @@ , ("safeD0", ([CmdInternal, CmdDashboard], "", Cancel)) -- blank line ] ++ - map (\(k, slore) -> ("safeD" ++ show (k :: Int) - , ( [CmdInternal, CmdDashboard] - , "display" <+> ppSLore slore <+> "lore" - , ChooseItemMenu (MLore slore) ))) - (zip [1..] [minBound..maxBound]) + zipWith (\k slore -> ("safeD" ++ show (k :: Int) + , ( [CmdInternal, CmdDashboard] + , "display" <+> ppSLore slore <+> "lore" + , ChooseItemMenu (MLore slore) ))) + [1..] [minBound..SEmbed] ++ - [ ("safeD97", ( [CmdInternal, CmdDashboard] + [ ("safeD96", ( [CmdInternal, CmdDashboard] , "display place lore" , ChooseItemMenu MPlaces) ) + , ("safeD97", ( [CmdInternal, CmdDashboard] + , "display faction lore" + , ChooseItemMenu MFactions) ) , ("safeD98", ( [CmdInternal, CmdDashboard] , "display adventure lore" , ChooseItemMenu MModes) ) @@ -170,7 +173,7 @@ , ("C-c", ([CmdMeta], "exit to desktop without saving", GameDrop)) , ("?", ([CmdMeta], "display help", Hint)) , ("F1", ([CmdMeta, CmdDashboard], "display help immediately", Help)) - , ("F12", ([CmdMeta], "open dashboard", Dashboard)) + , ("F12", ([CmdMeta, CmdDashboard], "show history", AllHistory)) , ("v", repeatLastTriple 1 [CmdMeta]) , ("C-v", repeatLastTriple 25 []) , ("A-v", repeatLastTriple 100 []) @@ -181,9 +184,6 @@ , ("C-S", ([CmdMeta], "save game backup", GameSave)) , ("C-P", ([CmdMeta], "print screen", PrintScreen)) - -- Dashboard, in addition to commands marked above - , ("safeD101", ([CmdInternal, CmdDashboard], "display history", AllHistory)) - -- Mouse , ( "LeftButtonRelease" , mouseLMB goToCmd @@ -204,6 +204,8 @@ , ("WheelSouth", ([CmdMouse], "unswerve the aiming line", Macro ["-"])) -- Debug and others not to display in help screens + , ("Escape", ([CmdMeta], "", AutomateBack)) + , ("Escape", ([CmdMeta], "", MainMenu)) , ("C-semicolon", ( [] , "move one step towards the crosshair" , MoveOnceToXhair )) @@ -245,17 +247,17 @@ , "accept target" , Accept )) , ("safe11", ( [CmdInternal] - , "show history" - , LastHistory )) - , ("safe12", ( [CmdInternal] , "wait a turn, bracing for impact" , Wait )) - , ("safe13", ( [CmdInternal] + , ("safe12", ( [CmdInternal] , "lurk 0.1 of a turn" , Wait10 )) - , ("safe14", ( [CmdInternal] + , ("safe13", ( [CmdInternal] , "snap crosshair to enemy" , XhairPointerEnemy )) + , ("safe14", ( [CmdInternal] + , "open dashboard" + , Dashboard )) ] ++ map defaultHeroSelect [0..9] diff --git a/GameDefinition/game-src/Implementation/MonadClientImplementation.hs b/GameDefinition/game-src/Implementation/MonadClientImplementation.hs --- a/GameDefinition/game-src/Implementation/MonadClientImplementation.hs +++ b/GameDefinition/game-src/Implementation/MonadClientImplementation.hs @@ -26,7 +26,6 @@ import Game.LambdaHack.Client.MonadClient import Game.LambdaHack.Client.State import Game.LambdaHack.Client.UI -import Game.LambdaHack.Client.UI.SessionUI import Game.LambdaHack.Common.ClientOptions import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.MonadStateRead @@ -120,14 +119,15 @@ -- | Run the main client loop, with the given arguments and empty -- initial states, in the @IO@ monad. -executorCli :: CCUI -> UIOptions -> ClientOptions +executorCli :: CCUI -> UIOptions -> ClientOptions -> Bool -> COps - -> Bool -> FactionId -> ChanServer -> IO () -executorCli ccui sUIOptions clientOptions cops@COps{corule} isUI fid cliDict = - let cliSession | isUI = Just $ emptySessionUI sUIOptions +executorCli ccui sUIOptions clientOptions startsNewGame + cops@COps{corule} fid cliDict = + let cliSession | isJust (requestUIS cliDict) = + Just $ emptySessionUI sUIOptions | otherwise = Nothing stateToFileName (cli, _) = ssavePrefixCli (soptions cli) <> Save.saveNameCli corule (sside cli) @@ -139,6 +139,6 @@ , cliToSave , cliSession } - m = loopCli ccui sUIOptions clientOptions + m = loopCli ccui sUIOptions clientOptions startsNewGame exe = evalStateT (runCliImplementation m) . totalState in Save.wrapInSaves cops stateToFileName exe diff --git a/GameDefinition/game-src/Implementation/MonadServerImplementation.hs b/GameDefinition/game-src/Implementation/MonadServerImplementation.hs --- a/GameDefinition/game-src/Implementation/MonadServerImplementation.hs +++ b/GameDefinition/game-src/Implementation/MonadServerImplementation.hs @@ -14,6 +14,7 @@ import Game.LambdaHack.Core.Prelude import Control.Concurrent +import Control.Concurrent.Async import qualified Control.Exception as Ex import qualified Control.Monad.IO.Class as IO import Control.Monad.Trans.State.Strict hiding (State) @@ -21,7 +22,7 @@ import qualified Data.Text.IO as T import Options.Applicative (defaultPrefs, execParserPure, handleParseResult) -import System.Exit (ExitCode (ExitSuccess)) +import System.Exit (ExitCode) import System.IO (hFlush, stdout) import Game.LambdaHack.Atomic @@ -41,11 +42,11 @@ import Implementation.MonadClientImplementation (executorCli) data SerState = SerState - { serState :: State -- ^ current global state - , serServer :: StateServer -- ^ current server state - , serDict :: ConnServerDict -- ^ client-server connection information + { serState :: State -- ^ current global state + , serServer :: StateServer -- ^ current server state + , serDict :: ConnServerDict -- ^ client-server connection information , serToSave :: Save.ChanSave (State, StateServer) - -- ^ connection to the save thread + -- ^ connection to the save thread } -- | Server state transformation monad. @@ -79,10 +80,10 @@ instance MonadServerComm SerImplementation where {-# INLINE getsDict #-} - getsDict f = SerImplementation $ gets $ f . serDict - {-# INLINE modifyDict #-} - modifyDict f = SerImplementation $ state $ \serS -> - let !newSerS = serS {serDict = f $ serDict serS} + getsDict f = SerImplementation $ gets $ f . serDict + {-# INLINE putDict #-} + putDict newSerDict = SerImplementation $ state $ \serS -> + let !newSerS = serS {serDict = newSerDict} in ((), newSerS) liftIO = SerImplementation . IO.liftIO @@ -145,7 +146,8 @@ $ sclientOptions soptionsNxtRaw soptionsNxt = soptionsNxtRaw {sclientOptions = clientOptions} -- Partially applied main loop of the clients. - executorClient = executorCli ccui sUIOptions clientOptions cops + executorClient startsNewGame = + executorCli ccui sUIOptions clientOptions startsNewGame cops -- Wire together game content, the main loop of game clients -- and the game server loop. let stateToFileName (_, ser) = @@ -160,11 +162,14 @@ m = loopSer soptionsNxt executorClient exe = evalStateT (runSerImplementation m) . totalState exeWithSaves = Save.wrapInSaves cops stateToFileName exe + unwrapEx e = case Ex.fromException e of + Just (ExceptionInLinkedThread _ ex) -> unwrapEx ex + _ -> e -- Wait for clients to exit even in case of server crash -- (or server and client crash), which gives them time to save -- and report their own inconsistencies, if any. - Ex.handle (\ex -> case Ex.fromException ex of - Just ExitSuccess -> + Ex.handle (\ex -> case Ex.fromException (unwrapEx ex) :: Maybe ExitCode of + Just{} -> -- User-forced shutdown, not crash, so the intention is -- to keep old saves and also clients may be not ready to save. Ex.throwIO ex diff --git a/GameDefinition/game-src/TieKnot.hs b/GameDefinition/game-src/TieKnot.hs --- a/GameDefinition/game-src/TieKnot.hs +++ b/GameDefinition/game-src/TieKnot.hs @@ -24,6 +24,7 @@ import Game.LambdaHack.Common.Point (speedupHackXSize) import qualified Game.LambdaHack.Common.Tile as Tile import qualified Game.LambdaHack.Content.CaveKind as CK +import qualified Game.LambdaHack.Content.FactionKind as FK import qualified Game.LambdaHack.Content.ItemKind as IK import qualified Game.LambdaHack.Content.ModeKind as MK import qualified Game.LambdaHack.Content.PlaceKind as PK @@ -34,6 +35,7 @@ import qualified Client.UI.Content.Input as Content.Input import qualified Client.UI.Content.Screen as Content.Screen import qualified Content.CaveKind +import qualified Content.FactionKind import qualified Content.ItemKind import qualified Content.ModeKind import qualified Content.PlaceKind @@ -64,40 +66,45 @@ -- equal to what was generated last time, ensures the same item boost. initialGen <- maybe SM.newSMGen return sdungeonRng let soptionsNxt = options {sdungeonRng = Just initialGen} + corule = RK.makeData Content.RuleKind.standardRules boostedItems = IK.boostItemKindList initialGen Content.ItemKind.items itemContent = if sboostRandomItem then boostedItems ++ Content.ItemKind.otherItemContent else Content.ItemKind.content - coitem = IK.makeData (RK.ritemSymbols Content.RuleKind.standardRules) + coitem = IK.makeData (RK.ritemSymbols corule) itemContent Content.ItemKind.groupNamesSingleton Content.ItemKind.groupNames - coItemSpeedup = speedupItem coitem cotile = TK.makeData Content.TileKind.content Content.TileKind.groupNamesSingleton Content.TileKind.groupNames - coTileSpeedup = Tile.speedupTile sallClear cotile + cofact = FK.makeData Content.FactionKind.content + Content.FactionKind.groupNamesSingleton + Content.FactionKind.groupNames -- Common content operations, created from content definitions. -- Evaluated fully to discover errors ASAP and to free memory. -- Fail here, not inside server code, so that savefiles are not removed, -- because they are not the source of the failure. copsRaw = COps - { cocave = CK.makeData Content.CaveKind.content + { cocave = CK.makeData corule + Content.CaveKind.content Content.CaveKind.groupNamesSingleton Content.CaveKind.groupNames + , cofact , coitem - , comode = MK.makeData Content.ModeKind.content + , comode = MK.makeData cofact + Content.ModeKind.content Content.ModeKind.groupNamesSingleton Content.ModeKind.groupNames , coplace = PK.makeData cotile Content.PlaceKind.content Content.PlaceKind.groupNamesSingleton Content.PlaceKind.groupNames - , corule = RK.makeData Content.RuleKind.standardRules + , corule , cotile - , coItemSpeedup - , coTileSpeedup + , coItemSpeedup = speedupItem coitem + , coTileSpeedup = Tile.speedupTile sallClear cotile } -- Evaluating for compact regions catches all kinds of errors in content ASAP, -- even in unused items. @@ -113,13 +120,13 @@ -- It is reparsed at each start of the game executable. -- Fail here, not inside client code, so that savefiles are not removed, -- because they are not the source of the failure. - sUIOptions <- mkUIOptions (corule cops) (sclientOptions soptionsNxt) + sUIOptions <- mkUIOptions corule (sclientOptions soptionsNxt) -- Client content operations containing default keypresses -- and command descriptions. let !ccui = CCUI { coinput = IC.makeData (Just sUIOptions) Content.Input.standardKeysAndMouse - , coscreen = SC.makeData Content.Screen.standardLayoutAndFeatures + , coscreen = SC.makeData corule Content.Screen.standardLayoutAndFeatures } -- Wire together game content, the main loops of game clients -- and the game server loop. diff --git a/LambdaHack.cabal b/LambdaHack.cabal --- a/LambdaHack.cabal +++ b/LambdaHack.cabal @@ -6,7 +6,7 @@ -- PVP summary:+-+------- breaking API changes -- | | +----- minor or non-breaking API additions -- | | | +--- code changes with no API change -version: 0.10.3.0 +version: 0.11.0.0 synopsis: A game engine library for tactical squad ASCII roguelike dungeon crawlers description: LambdaHack is a Haskell game engine library for ASCII roguelike games of arbitrary theme, size and complexity, with optional @@ -39,7 +39,7 @@ . This is a workaround .cabal file, flattened to eliminate internal libraries until generating haddocks for them - is fixed. The original .cabal file is stored in the github repo. + is fixed. The original .cabal file is in .cabal.bkp file. homepage: https://lambdahack.github.io bug-reports: http://github.com/LambdaHack/LambdaHack/issues license: BSD-3-Clause @@ -84,6 +84,11 @@ default: False manual: True +flag with_costly_optimizations + description: turn on costly (mostly GHC heap size) optimizations (that give 15-25% speedup) + default: True + manual: True + flag release description: prepare for a release (expose internal functions and types, etc.) default: True @@ -114,9 +119,11 @@ DataKinds, KindSignatures, DeriveGeneric, DeriveLift ghc-options: -Wall -Wcompat -Worphans -Wincomplete-uni-patterns -Wincomplete-record-updates -Wimplicit-prelude -Wmissing-home-modules -Widentities -Wredundant-constraints -Wmissing-export-lists -Wpartial-fields -Wunused-packages -Winvalid-haddock -- TODO: remove -Winvalid-haddock when added to -Wall in a GHC I use for haddock - ghc-options: -Wall-missed-specialisations - ghc-options: -fno-ignore-asserts -fexpose-all-unfoldings -fspecialise-aggressively -fsimpl-tick-factor=200 + ghc-options: -fno-ignore-asserts + if flag(with_costly_optimizations) + ghc-options: -fexpose-all-unfoldings -fspecialise-aggressively -fsimpl-tick-factor=200 + if flag(with_expensive_assertions) cpp-options: -DWITH_EXPENSIVE_ASSERTIONS @@ -163,6 +170,7 @@ Game.LambdaHack.Definition.DefsInternal Game.LambdaHack.Definition.Flavour Game.LambdaHack.Content.CaveKind + Game.LambdaHack.Content.FactionKind Game.LambdaHack.Content.ItemKind Game.LambdaHack.Content.ModeKind Game.LambdaHack.Content.PlaceKind @@ -211,7 +219,6 @@ Game.LambdaHack.Client.UI.HumanCmd Game.LambdaHack.Client.UI.InventoryM Game.LambdaHack.Client.UI.ItemDescription - Game.LambdaHack.Client.UI.ItemSlot Game.LambdaHack.Client.UI.Key Game.LambdaHack.Client.UI.KeyBindings Game.LambdaHack.Client.UI.MonadClientUI @@ -279,9 +286,8 @@ Game.LambdaHack.Server.ServerOptions Game.LambdaHack.Server.StartM Game.LambdaHack.Server.State --- for doctest: - Paths_LambdaHack exposed-modules: Content.CaveKind + Content.FactionKind Content.ItemKind Content.ItemKindEmbed Content.ItemKindActor @@ -289,7 +295,6 @@ Content.ItemKindBlast Content.ItemKindTemporary Content.ModeKind - Content.ModeKindPlayer Content.PlaceKind Content.RuleKind Content.TileKind @@ -298,6 +303,7 @@ Client.UI.Content.Screen Implementation.MonadClientImplementation Implementation.MonadServerImplementation + other-modules: Paths_LambdaHack autogen-modules: Paths_LambdaHack build-depends: assert-failure >= 0.1.2 && < 0.2, async >= 2.2.1, @@ -311,7 +317,6 @@ enummapset >= 0.5.2.2, file-embed >= 0.0.11, filepath >= 1.2.0.1, - ghc-prim, hashable >= 1.1.2.5, hsini >= 0.2, witch >= 0.3, @@ -368,12 +373,20 @@ type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs - other-modules: ItemDescriptionUnitTests + other-modules: ActorStateUnitTests + CommonMUnitTests + HandleHelperMUnitTests + HandleHumanLocalMUnitTests + InventoryMUnitTests + ItemDescriptionUnitTests ItemKindUnitTests ItemRevUnitTests + LevelUnitTests + MonadClientUIUnitTests ReqFailureUnitTests SessionUIMock SessionUIUnitTests + UnitTestHelpers build-depends: ,LambdaHack ,base ,containers @@ -386,13 +399,3 @@ ,text ,transformers ,vector - -test-suite doctests - import: options, exe-options - type: exitcode-stdio-1.0 - main-is: test/doctest-driver.hs - build-tool-depends: doctest-driver-gen:doctest-driver-gen - ghc-options: -Wno-unused-packages - build-depends: ,base - ,doctest >= 0.13 - ,QuickCheck diff --git a/Makefile b/Makefile --- a/Makefile +++ b/Makefile @@ -32,10 +32,10 @@ google-chrome --no-sandbox --js-flags="--logfile=%t.log --prof" ../lambdahack.github.io/index.html minific: - npx google-closure-compiler dist-newstyle/build/x86_64-linux/ghcjs-8.6.0.1/LambdaHack-0.10.3.0/x/LambdaHack/build/LambdaHack/LambdaHack.jsexe/all.js --compilation_level=ADVANCED_OPTIMIZATIONS --isolation_mode=IIFE --assume_function_wrapper --externs=dist-newstyle/build/x86_64-linux/ghcjs-8.6.0.1/LambdaHack-0.10.3.0/x/LambdaHack/build/LambdaHack/LambdaHack.jsexe/all.js.externs --externs=/home/mikolaj/r/lambdahack.github.io/lz-string.extern.js --jscomp_off="*" > ../lambdahack.github.io/lambdahack.all.js + npx google-closure-compiler dist-newstyle/build/x86_64-linux/ghcjs-8.6.0.1/LambdaHack-0.11.0.0/x/LambdaHack/build/LambdaHack/LambdaHack.jsexe/all.js --compilation_level=ADVANCED_OPTIMIZATIONS --isolation_mode=IIFE --assume_function_wrapper --externs=dist-newstyle/build/x86_64-linux/ghcjs-8.6.0.1/LambdaHack-0.11.0.0/x/LambdaHack/build/LambdaHack/LambdaHack.jsexe/all.js.externs --externs=/home/mikolaj/r/lambdahack.github.io/lz-string.extern.js --jscomp_off="*" > ../lambdahack.github.io/lambdahack.all.js minificForNode: - npx google-closure-compiler dist-newstyle/build/x86_64-linux/ghcjs-8.6.0.1/LambdaHack-0.10.3.0/x/LambdaHack/build/LambdaHack/LambdaHack.jsexe/all.js --compilation_level=ADVANCED_OPTIMIZATIONS --isolation_mode=IIFE --assume_function_wrapper --externs=/home/mikolaj/r/lambdahack.github.io/lz-string.extern.js --externs=dist-newstyle/build/x86_64-linux/ghcjs-8.6.0.1/LambdaHack-0.10.3.0/x/LambdaHack/build/LambdaHack/LambdaHack.jsexe/all.js.externs --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/assert.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/child_process.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/crypto.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/dns.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/events.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/globals.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/https.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/os.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/punycode.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/readline.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/stream.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/tls.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/url.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/vm.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/buffer.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/cluster.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/dgram.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/domain.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/fs.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/http.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/net.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/path.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/querystring.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/repl.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/string_decoder.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/tty.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/util.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/zlib.js --jscomp_off="*" > ../lambdahack.github.io/lambdahack.all.js + npx google-closure-compiler dist-newstyle/build/x86_64-linux/ghcjs-8.6.0.1/LambdaHack-0.11.0.0/x/LambdaHack/build/LambdaHack/LambdaHack.jsexe/all.js --compilation_level=ADVANCED_OPTIMIZATIONS --isolation_mode=IIFE --assume_function_wrapper --externs=/home/mikolaj/r/lambdahack.github.io/lz-string.extern.js --externs=dist-newstyle/build/x86_64-linux/ghcjs-8.6.0.1/LambdaHack-0.11.0.0/x/LambdaHack/build/LambdaHack/LambdaHack.jsexe/all.js.externs --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/assert.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/child_process.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/crypto.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/dns.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/events.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/globals.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/https.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/os.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/punycode.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/readline.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/stream.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/tls.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/url.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/vm.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/buffer.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/cluster.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/dgram.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/domain.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/fs.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/http.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/net.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/path.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/querystring.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/repl.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/string_decoder.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/tty.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/util.js --externs=/home/mikolaj/r/closure-compiler/contrib/nodejs/zlib.js --jscomp_off="*" > ../lambdahack.github.io/lambdahack.all.js # Low delay to display animations swiftly and not bore the public too much. # Delay can't be lower than 2, because browsers sometimes treat delay 1 @@ -56,8 +56,8 @@ frontendHunt: $$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --savePrefix test --newGame 5 --dumpInitRngs --automateAll --gameMode hunt -frontendEscape: - $$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --savePrefix test --newGame 3 --dumpInitRngs --automateAll --gameMode escape +frontendFlight: + $$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --savePrefix test --newGame 3 --dumpInitRngs --automateAll --gameMode flight frontendZoo: $$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --savePrefix test --newGame 2 --dumpInitRngs --automateAll --gameMode zoo --exposeActors @@ -158,7 +158,7 @@ test-short: test-short-new test-short-load -test-medium: testRaid-medium testBrawl-medium testShootout-medium testHunt-medium testEscape-medium testZoo-medium testAmbush-medium testCrawlEmpty-medium testCrawl-medium-know testSafari-medium testSafariSurvival-medium testBattle-medium testBattleDefense-medium testBattleSurvival-medium testDig-medium testDefenseEmpty-medium testMany-teletype +test-medium: testRaid-medium testBrawl-medium testShootout-medium testHunt-medium testFlight-medium testZoo-medium testAmbush-medium testCrawlEmpty-medium testCrawl-medium-know testSafari-medium testSafariSurvival-medium testBattle-medium testBattleDefense-medium testBattleSurvival-medium testDig-medium testDefenseEmpty-medium testMany-teletype test-sniff: $$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --newGame 5 --noAnim --maxFps 100000 --frontendTeletype --benchmark --stopAfterFrames 1 --dumpInitRngs --automateAll --keepAutomated --gameMode raid --sniff > /tmp/teletypetest.log 2>&1 @@ -181,8 +181,8 @@ testHunt-medium: $$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --maxFps 100000 --frontendTeletype --benchmark --benchMessages --stopAfterSeconds 20 --dumpInitRngs --automateAll --keepAutomated --gameMode hunt 2> /tmp/teletypetest.log -testEscape-medium: - $$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 3 --maxFps 100000 --frontendTeletype --benchmark --benchMessages --stopAfterSeconds 40 --dumpInitRngs --automateAll --keepAutomated --gameMode escape 2> /tmp/teletypetest.log +testFlight-medium: + $$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 3 --maxFps 100000 --frontendTeletype --benchmark --benchMessages --stopAfterSeconds 40 --dumpInitRngs --automateAll --keepAutomated --gameMode flight 2> /tmp/teletypetest.log testZoo-medium: $$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 2 --maxFps 100000 --frontendTeletype --benchmark --benchMessages --stopAfterSeconds 40 --dumpInitRngs --automateAll --keepAutomated --gameMode zoo 2> /tmp/teletypetest.log @@ -238,7 +238,7 @@ $$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --savePrefix brawl --dumpInitRngs --automateAll --keepAutomated --gameMode brawl --showItemSamples --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log $$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --savePrefix shootout --dumpInitRngs --automateAll --keepAutomated --gameMode shootout --showItemSamples --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log $$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --savePrefix hunt --dumpInitRngs --automateAll --keepAutomated --gameMode hunt --showItemSamples --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log - $$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --savePrefix escape --dumpInitRngs --automateAll --keepAutomated --gameMode escape --showItemSamples --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log + $$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --savePrefix flight --dumpInitRngs --automateAll --keepAutomated --gameMode flight --showItemSamples --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log $$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --savePrefix zoo --dumpInitRngs --automateAll --keepAutomated --gameMode zoo --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log $$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --savePrefix ambush --dumpInitRngs --automateAll --keepAutomated --gameMode ambush --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log $$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --newGame 5 --savePrefix crawl --dumpInitRngs --automateAll --keepAutomated --gameMode crawl --frontendTeletype --stopAfterSeconds 2 2> /tmp/teletypetest.log @@ -255,7 +255,7 @@ $$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --savePrefix brawl --dumpInitRngs --automateAll --keepAutomated --gameMode brawl --frontendTeletype --stopAfterSeconds 2 $(RNGOPTS) 2> /tmp/teletypetest.log $$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --savePrefix shootout --dumpInitRngs --automateAll --keepAutomated --gameMode shootout --frontendTeletype --stopAfterSeconds 2 $(RNGOPTS) 2> /tmp/teletypetest.log $$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --savePrefix hunt --dumpInitRngs --automateAll --keepAutomated --gameMode hunt --frontendTeletype --stopAfterSeconds 2 $(RNGOPTS) 2> /tmp/teletypetest.log - $$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --savePrefix escape --dumpInitRngs --automateAll --keepAutomated --gameMode escape --frontendTeletype --stopAfterSeconds 2 $(RNGOPTS) 2> /tmp/teletypetest.log + $$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --savePrefix flight --dumpInitRngs --automateAll --keepAutomated --gameMode flight --frontendTeletype --stopAfterSeconds 2 $(RNGOPTS) 2> /tmp/teletypetest.log $$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --savePrefix zoo --dumpInitRngs --automateAll --keepAutomated --gameMode zoo --frontendTeletype --stopAfterSeconds 2 $(RNGOPTS) 2> /tmp/teletypetest.log $$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --savePrefix ambush --dumpInitRngs --automateAll --keepAutomated --gameMode ambush --frontendTeletype --stopAfterSeconds 2 $(RNGOPTS) 2> /tmp/teletypetest.log $$(cabal list-bin exe:LambdaHack) --dbgMsgSer --logPriority 4 --boostRandomItem --savePrefix crawl --dumpInitRngs --automateAll --keepAutomated --gameMode crawl --frontendTeletype --stopAfterSeconds 2 $(RNGOPTS) 2> /tmp/teletypetest.log diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -43,8 +43,8 @@ for desktop and there is a JavaScript browser frontend) and many other generic engine components are easily overridden, but the fundamental source of flexibility lies in the strict -and enforced with types separation of code from the content -and of clients (human and AI-controlled) from the server. +and enforced with types separation of engine code from the read-only +content and of clients (human and AI-controlled) from the server. Please see the changelog file for recent improvements and the issue tracker for short-term plans. Long term goals @@ -188,7 +188,7 @@ and then you can compile (and recompile) with - cabal build . + cabal build and run the game with @@ -212,17 +212,13 @@ Unit tests and integration tests can be run and displayed with - cabal test test --enable-tests --test-show-details=direct - -To prepare doctests[7], set `tests: True` in your `cabal.project.local`. -Afterwards, doctests can be executed with + cabal test --test-show-details=direct - cabal build . && cabal exec cabal test doctests +and doctests with -and their detailed results observed in a log file. -(This repeating of `cabal build` before each testsuite run -is required due to bug https://github.com/haskell/cabal/issues/7522. -Contributions to cabal development are very welcome.) + cabal install doctest --overwrite-policy=always && cabal build + cabal repl --build-depends=QuickCheck --with-ghc=doctest definition + cabal repl --build-depends=QuickCheck --build-depends=template-haskell --with-ghc=doctest lib:LambdaHack The [Makefile](https://github.com/LambdaHack/LambdaHack/blob/master/Makefile) contains many sample automated playtest commands. @@ -342,7 +338,6 @@ [4]: https://github.com/LambdaHack/LambdaHack/wiki [5]: https://github.com/LambdaHack/LambdaHack [6]: http://allureofthestars.com -[7]: https://github.com/sol/doctest [9]: https://github.com/LambdaHack/LambdaHack/wiki/Sample-dungeon-crawler [10]: https://github.com/AllureOfTheStars/Allure [11]: https://github.com/LambdaHack/LambdaHack/releases diff --git a/definition-src/Game/LambdaHack/Content/CaveKind.hs b/definition-src/Game/LambdaHack/Content/CaveKind.hs --- a/definition-src/Game/LambdaHack/Content/CaveKind.hs +++ b/definition-src/Game/LambdaHack/Content/CaveKind.hs @@ -2,7 +2,7 @@ -- cave kind. module Game.LambdaHack.Content.CaveKind ( pattern DEFAULT_RANDOM - , CaveKind(..), makeData + , CaveKind(..), InitSleep(..), makeData #ifdef EXPOSE_INTERNAL -- * Internal operations , validateSingle, validateAll, mandatoryGroups @@ -17,6 +17,7 @@ import Game.LambdaHack.Content.ItemKind (ItemKind) import Game.LambdaHack.Content.PlaceKind (PlaceKind) +import qualified Game.LambdaHack.Content.RuleKind as RK import Game.LambdaHack.Content.TileKind (TileKind) import qualified Game.LambdaHack.Core.Dice as Dice import Game.LambdaHack.Core.Random @@ -27,8 +28,7 @@ -- | Parameters for the generation of dungeon levels. -- Warning: for efficiency, avoid embedded items in any of the common tiles. data CaveKind = CaveKind - { csymbol :: Char -- ^ a symbol - , cname :: Text -- ^ short description + { cname :: Text -- ^ short description , cfreq :: Freqs CaveKind -- ^ frequency within groups , cXminSize :: X -- ^ minimal X size of the whole cave , cYminSize :: Y -- ^ minimal Y size of the whole cave @@ -36,9 +36,9 @@ , cminPlaceSize :: Dice.DiceXY -- ^ minimal size of places; for merging , cmaxPlaceSize :: Dice.DiceXY -- ^ maximal size of places; for growing , cdarkOdds :: Dice.Dice -- ^ the odds a place is dark - -- (level-scaled dice roll > 50) + -- (level-scaled dice roll > 50) , cnightOdds :: Dice.Dice -- ^ the odds the cave is dark - -- (level-scaled dice roll > 50) + -- (level-scaled dice roll > 50) , cauxConnects :: Rational -- ^ a proportion of extra connections , cmaxVoid :: Rational -- ^ at most this proportion of rooms may be void @@ -49,12 +49,13 @@ , cactorFreq :: Freqs ItemKind -- ^ actor groups to consider , citemNum :: Dice.Dice -- ^ number of initial items in the cave , citemFreq :: Freqs ItemKind -- ^ item groups to consider; - -- note that the groups are flattened; e.g., if an item is moved to another - -- included group with the same weight, the outcome doesn't change + -- note that the groups are flattened; e.g., if an item is moved + -- to another included group with the same weight, the outcome + -- doesn't change , cplaceFreq :: Freqs PlaceKind -- ^ place groups to consider , cpassable :: Bool -- ^ are passable default tiles permitted - , labyrinth :: Bool -- ^ waste of time for AI to explore + , clabyrinth :: Bool -- ^ waste of time for AI to explore , cdefTile :: GroupName TileKind -- ^ the default cave tile , cdarkCorTile :: GroupName TileKind -- ^ the dark cave corridor tile , clitCorTile :: GroupName TileKind -- ^ the lit cave corridor tile @@ -71,23 +72,36 @@ , cstairFreq :: Freqs PlaceKind -- ^ place groups for created stairs , cstairAllowed :: Freqs PlaceKind -- ^ extra groups for inherited , cskip :: [Int] -- ^ which faction starting positions to skip + , cinitSleep :: InitSleep -- ^ whether actors spawn sleeping , cdesc :: Text -- ^ full cave description } deriving Show -- No Eq and Ord to make extending logically sound +data InitSleep = InitSleepAlways | InitSleepPermitted | InitSleepBanned + deriving (Show, Eq) + -- | Catch caves with not enough space for all the places. Check the size -- of the cave descriptions to make sure they fit on screen. Etc. -validateSingle :: CaveKind -> [Text] -validateSingle CaveKind{..} = +validateSingle :: RK.RuleContent -> CaveKind -> [Text] +validateSingle corule CaveKind{..} = let (minCellSizeX, minCellSizeY) = Dice.infDiceXY ccellSize + (maxCellSizeX, maxCellSizeY) = Dice.supDiceXY ccellSize (minMinSizeX, minMinSizeY) = Dice.infDiceXY cminPlaceSize (maxMinSizeX, maxMinSizeY) = Dice.supDiceXY cminPlaceSize (minMaxSizeX, minMaxSizeY) = Dice.infDiceXY cmaxPlaceSize in [ "cname longer than 25" | T.length cname > 25 ] - ++ [ "cXminSize < 20" | cXminSize < 20 ] - ++ [ "cYminSize < 20" | cYminSize < 20 ] - ++ [ "minCellSizeX < 1" | minCellSizeX < 1 ] - ++ [ "minCellSizeY < 1" | minCellSizeY < 1 ] + ++ [ "cXminSize > RK.rWidthMax" | cXminSize > RK.rWidthMax corule ] + ++ [ "cYminSize > RK.rHeightMax" | cYminSize > RK.rHeightMax corule ] + ++ [ "cXminSize < 8" | cXminSize < 8 ] + ++ [ "cYminSize < 8" | cYminSize < 8 ] -- see @focusArea@ + ++ [ "cXminSize - 2 < maxCellSizeX" | cXminSize - 2 < maxCellSizeX ] + ++ [ "cYminSize - 2 < maxCellSizeY" | cYminSize - 2 < maxCellSizeY ] + ++ [ "minCellSizeX < 2" | minCellSizeX < 2 ] + ++ [ "minCellSizeY < 2" | minCellSizeY < 2 ] + ++ [ "minCellSizeX < 4 and stairs" + | minCellSizeX < 4 && not (null cstairFreq) ] + ++ [ "minCellSizeY < 4 and stairs" + | minCellSizeY < 4 && not (null cstairFreq) ] -- The following four are heuristics, so not too restrictive: ++ [ "minCellSizeX < 6 && non-trivial stairs" | minCellSizeX < 6 && not (length cstairFreq <= 1 && null cescapeFreq) ] @@ -124,9 +138,11 @@ pattern DEFAULT_RANDOM = GroupName "default random" -makeData :: [CaveKind] -> [GroupName CaveKind] -> [GroupName CaveKind] +makeData :: RK.RuleContent + -> [CaveKind] -> [GroupName CaveKind] -> [GroupName CaveKind] -> ContentData CaveKind -makeData content groupNamesSingleton groupNames = - makeContentData "CaveKind" cname cfreq validateSingle validateAll content +makeData corule content groupNamesSingleton groupNames = + makeContentData "CaveKind" cname cfreq (validateSingle corule) validateAll + content groupNamesSingleton (mandatoryGroups ++ groupNames) diff --git a/definition-src/Game/LambdaHack/Content/FactionKind.hs b/definition-src/Game/LambdaHack/Content/FactionKind.hs new file mode 100644 --- /dev/null +++ b/definition-src/Game/LambdaHack/Content/FactionKind.hs @@ -0,0 +1,217 @@ +{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-} +-- | The type of kinds of factions present in a game, both human +-- and computer-controlled. +module Game.LambdaHack.Content.FactionKind + ( FactionKind(..), makeData + , HiCondPoly, HiSummand, HiPolynomial, HiIndeterminant(..) + , TeamContinuity(..), Outcome(..) + , teamExplorer, hiHeroLong, hiHeroMedium, hiHeroShort, hiDweller + , victoryOutcomes, deafeatOutcomes + , nameOutcomePast, nameOutcomeVerb, endMessageOutcome +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , validateSingle, validateAll +#endif + ) where + +import Prelude () + +import Game.LambdaHack.Core.Prelude + +import Data.Binary +import qualified Data.Text as T +import GHC.Generics (Generic) + +import Game.LambdaHack.Content.ItemKind (ItemKind) +import qualified Game.LambdaHack.Definition.Ability as Ability +import Game.LambdaHack.Definition.ContentData +import Game.LambdaHack.Definition.Defs + +-- | Properties of a particular faction. +data FactionKind = FactionKind + { fname :: Text -- ^ name of the faction + , ffreq :: Freqs FactionKind + -- ^ frequency within groups + , fteam :: TeamContinuity + -- ^ the team the faction identifies with + -- across games and modes + , fgroups :: Freqs ItemKind + -- ^ names of actor groups that may naturally fall under faction's + -- control, e.g., upon spawning; make sure all groups that may + -- ever continuousely generate actors, e.g., through spawning + -- or summoning, are mentioned in at least one faction kind; + -- groups of initial faction actors don't need to be included + , fskillsOther :: Ability.Skills + -- ^ fixed skill modifiers to the non-leader + -- actors; also summed with skills implied + -- by @fdoctrine@ (which is not fixed) + , fcanEscape :: Bool -- ^ the faction can escape the dungeon + , fneverEmpty :: Bool -- ^ the faction declared killed if no actors + , fhiCondPoly :: HiCondPoly -- ^ score formula (conditional polynomial) + , fhasGender :: Bool -- ^ whether actors have gender + , finitDoctrine :: Ability.Doctrine + -- ^ initial faction's non-leaders doctrine + , fspawnsFast :: Bool + -- ^ spawns fast enough that switching pointman to another level + -- to optimize spawning is a winning tactics, which would spoil + -- the fun, so switching is disabled in UI and AI clients + , fhasPointman :: Bool -- ^ whether the faction can have a pointman + , fhasUI :: Bool -- ^ does the faction have a UI client + -- (for control or passive observation) + , finitUnderAI :: Bool -- ^ is the faction initially under AI control + , fenemyTeams :: [TeamContinuity] + -- ^ teams starting at war with the faction + , falliedTeams :: [TeamContinuity] + -- ^ teams starting allied with the faction + } + deriving (Show, Eq, Generic) + +instance Binary FactionKind + +-- | Team continuity index. Starting with 1. See the comment for `FactionId`. +newtype TeamContinuity = TeamContinuity Int + deriving (Show, Eq, Ord, Enum, Generic) + +instance Binary TeamContinuity + +-- | Conditional polynomial representing score calculation for this faction. +type HiCondPoly = [HiSummand] + +type HiSummand = (HiPolynomial, [Outcome]) + +type HiPolynomial = [(HiIndeterminant, Double)] + +data HiIndeterminant = + HiConst + | HiLoot + | HiSprint + | HiBlitz + | HiSurvival + | HiKill + | HiLoss + deriving (Show, Eq, Generic) + +instance Binary HiIndeterminant + +-- | Outcome of a game. +data Outcome = + Escape -- ^ the faction escaped the dungeon alive + | Conquer -- ^ the faction won by eliminating all rivals + | Defeated -- ^ the faction lost the game in another way + | Killed -- ^ the faction was eliminated + | Restart -- ^ game is restarted; the quitter quit + | Camping -- ^ game is supended + deriving (Show, Eq, Ord, Enum, Bounded, Generic) + +instance Binary Outcome + +teamExplorer :: TeamContinuity +teamExplorer = TeamContinuity 1 + +hiHeroLong, hiHeroMedium, hiHeroShort, hiDweller :: HiCondPoly + +hiHeroShort = + [ ( [(HiLoot, 100)] + , [minBound..maxBound] ) + , ( [(HiConst, 100)] + , victoryOutcomes ) + , ( [(HiSprint, -500)] -- speed matters, but only if fast enough + , victoryOutcomes ) + , ( [(HiSurvival, 10)] -- few points for surviving long + , deafeatOutcomes ) + ] + +hiHeroMedium = + [ ( [(HiLoot, 200)] -- usually no loot, but if so, no harm + , [minBound..maxBound] ) + , ( [(HiConst, 200), (HiLoss, -10)] -- normally, always positive + , victoryOutcomes ) + , ( [(HiSprint, -500)] -- speed matters, but only if fast enough + , victoryOutcomes ) + , ( [(HiBlitz, -100)] -- speed matters always + , victoryOutcomes ) + , ( [(HiSurvival, 10)] -- few points for surviving long + , deafeatOutcomes ) + ] + +-- Heroes in long crawls rejoice in loot. +hiHeroLong = + [ ( [(HiLoot, 10000)] -- multiplied by fraction of collected + , [minBound..maxBound] ) + , ( [(HiConst, 15)] -- a token bonus in case all loot lost, but victory + , victoryOutcomes ) + , ( [(HiSprint, -20000)] -- speedrun bonus, if below this number of turns + , victoryOutcomes ) + , ( [(HiBlitz, -100)] -- speed matters always + , victoryOutcomes ) + , ( [(HiSurvival, 10)] -- few points for surviving long + , deafeatOutcomes ) + ] + +-- Spawners get no points from loot, but try to kill +-- all opponents fast or at least hold up for long. +hiDweller = [ ( [(HiConst, 1000)] -- no loot, so big win reward + , victoryOutcomes ) + , ( [(HiConst, 1000), (HiLoss, -10)] + , victoryOutcomes ) + , ( [(HiSprint, -1000)] -- speedrun bonus, if below + , victoryOutcomes ) + , ( [(HiBlitz, -100)] -- speed matters + , victoryOutcomes ) + , ( [(HiSurvival, 100)] + , deafeatOutcomes ) + ] + +victoryOutcomes :: [Outcome] +victoryOutcomes = [Escape, Conquer] + +deafeatOutcomes :: [Outcome] +deafeatOutcomes = [Defeated, Killed, Restart] + +nameOutcomePast :: Outcome -> Text +nameOutcomePast = \case + Escape -> "emerged victorious" + Conquer -> "vanquished all opposition" + Defeated -> "got decisively defeated" + Killed -> "got eliminated" + Restart -> "resigned prematurely" + Camping -> "set camp" + +nameOutcomeVerb :: Outcome -> Text +nameOutcomeVerb = \case + Escape -> "emerge victorious" + Conquer -> "vanquish all opposition" + Defeated -> "be decisively defeated" + Killed -> "be eliminated" + Restart -> "resign prematurely" + Camping -> "set camp" + +endMessageOutcome :: Outcome -> Text +endMessageOutcome = \case + Escape -> "Can it be done more efficiently, though?" + Conquer -> "Can it be done in a better style, though?" + Defeated -> "Let's hope your new overlords let you live." + Killed -> "Let's hope a rescue party arrives in time!" + Restart -> "This time for real." + Camping -> "See you soon, stronger and braver!" + +validateSingle :: FactionKind -> [Text] +validateSingle FactionKind{..} = + [ "fname longer than 50" | T.length fname > 50 ] + ++ [ "fskillsOther not negative:" <+> fname + | any ((>= 0) . snd) $ Ability.skillsToList fskillsOther ] + ++ let checkLoveHate l team = + [ "love-hate relationship for" <+> tshow team | team `elem` l ] + in concatMap (checkLoveHate fenemyTeams) falliedTeams + ++ let checkDipl field l team = + [ "self-diplomacy in" <+> field | length (elemIndices team l) > 1 ] + in concatMap (checkDipl "fenemyTeams" fenemyTeams) fenemyTeams + ++ concatMap (checkDipl "falliedTeams" falliedTeams) falliedTeams + +-- | Validate game faction kinds together. +validateAll :: [FactionKind] -> ContentData FactionKind -> [Text] +validateAll _ _ = [] -- so far, always valid + +makeData :: [FactionKind] -> [GroupName FactionKind] -> [GroupName FactionKind] + -> ContentData FactionKind +makeData = makeContentData "FactionKind" fname ffreq validateSingle validateAll diff --git a/definition-src/Game/LambdaHack/Content/ItemKind.hs b/definition-src/Game/LambdaHack/Content/ItemKind.hs --- a/definition-src/Game/LambdaHack/Content/ItemKind.hs +++ b/definition-src/Game/LambdaHack/Content/ItemKind.hs @@ -15,11 +15,11 @@ , damageUsefulness, verbMsgNoLonger, verbMsgLess, toVelocity, toLinger , timerNone, isTimerNone, foldTimer, toOrganBad, toOrganGood, toOrganNoTimer , validateSingle + , mandatoryGroups, mandatoryGroupsSingleton #ifdef EXPOSE_INTERNAL -- * Internal operations , boostItemKind, onSmashOrCombineEffect , validateAll, validateDups, validateDamage - , mandatoryGroups, mandatoryGroupsSingleton #endif ) where @@ -396,7 +396,7 @@ NopEffect -> False AndEffect eff1 eff2 -> forApplyEffect eff1 || forApplyEffect eff2 OrEffect eff1 eff2 -> forApplyEffect eff1 || forApplyEffect eff2 - SeqEffect effs -> or $ map forApplyEffect effs + SeqEffect effs -> any forApplyEffect effs When _ eff1 -> forApplyEffect eff1 Unless _ eff1 -> forApplyEffect eff1 IfThenElse _ eff1 eff2 -> forApplyEffect eff1 || forApplyEffect eff2 @@ -427,7 +427,7 @@ isEffEscape (OnUser eff) = isEffEscape eff isEffEscape (AndEffect eff1 eff2) = isEffEscape eff1 || isEffEscape eff2 isEffEscape (OrEffect eff1 eff2) = isEffEscape eff1 || isEffEscape eff2 -isEffEscape (SeqEffect effs) = or $ map isEffEscape effs +isEffEscape (SeqEffect effs) = any isEffEscape effs isEffEscape (When _ eff) = isEffEscape eff isEffEscape (Unless _ eff) = isEffEscape eff isEffEscape (IfThenElse _ eff1 eff2) = isEffEscape eff1 || isEffEscape eff2 @@ -445,7 +445,7 @@ isEffEscapeOrAscend (OrEffect eff1 eff2) = isEffEscapeOrAscend eff1 || isEffEscapeOrAscend eff2 isEffEscapeOrAscend (SeqEffect effs) = - or $ map isEffEscapeOrAscend effs + any isEffEscapeOrAscend effs isEffEscapeOrAscend (When _ eff) = isEffEscapeOrAscend eff isEffEscapeOrAscend (Unless _ eff) = isEffEscapeOrAscend eff isEffEscapeOrAscend (IfThenElse _ eff1 eff2) = @@ -583,7 +583,7 @@ | length ts == 1 && not equipable && not meleeable ] ++ [ "EqpSlot not specified but Equipable or Meleeable and not a likely organ or necklace or template" | not likelyException - && length ts == 0 && (equipable || meleeable) ] + && null ts && (equipable || meleeable) ] ++ [ "More than one EqpSlot specified" | length ts > 1 ] ) ++ [ "Redundant Equipable or Meleeable" @@ -613,7 +613,7 @@ f _ = False ts = filter f iaspects in ["more than one PresentAs specification" | length ts > 1]) - ++ concatMap (validateDups ik) (map SetFlag [minBound .. maxBound]) + ++ concatMap (validateDups ik . SetFlag) [minBound .. maxBound] ++ (let f :: Effect -> Bool f VerbNoLonger{} = True f _ = False @@ -694,7 +694,7 @@ g (OnUser effect) = h effect g (AndEffect eff1 eff2) = h eff1 || h eff2 g (OrEffect eff1 eff2) = h eff1 || h eff2 - g (SeqEffect effs2) = or $ map h effs2 + g (SeqEffect effs2) = any h effs2 g (When _ effect) = h effect g (Unless _ effect) = h effect g (IfThenElse _ eff1 eff2) = h eff1 || h eff2 @@ -702,7 +702,7 @@ h effect = f effect || g effect ts = filter g effs in [ "effect" <+> t <+> "should be specified at top level, not nested" - | length ts > 0 ] + | not (null ts) ] checkSubEffectProp :: (Effect -> Bool) -> Effect -> Bool checkSubEffectProp f eff = @@ -713,7 +713,7 @@ g (OnUser effect) = h effect g (AndEffect eff1 eff2) = h eff1 || h eff2 g (OrEffect eff1 eff2) = h eff1 || h eff2 - g (SeqEffect effs) = or $ map h effs + g (SeqEffect effs) = any h effs g (When _ effect) = h effect g (Unless _ effect) = h effect g (IfThenElse _ eff1 eff2) = h eff1 || h eff2 diff --git a/definition-src/Game/LambdaHack/Content/ModeKind.hs b/definition-src/Game/LambdaHack/Content/ModeKind.hs --- a/definition-src/Game/LambdaHack/Content/ModeKind.hs +++ b/definition-src/Game/LambdaHack/Content/ModeKind.hs @@ -1,17 +1,12 @@ -{-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-} --- | The type of kinds of game modes. +-- | The type of game modes. module Game.LambdaHack.Content.ModeKind - ( pattern CAMPAIGN_SCENARIO, pattern INSERT_COIN, pattern NO_CONFIRMS + ( pattern CAMPAIGN_SCENARIO, pattern INSERT_COIN , ModeKind(..), makeData - , Caves, Roster(..), TeamContinuity(..), Outcome(..) - , HiCondPoly, HiSummand, HiPolynomial, HiIndeterminant(..) - , Player(..), AutoLeader(..) - , teamExplorer, victoryOutcomes, deafeatOutcomes, nameOutcomePast - , nameOutcomeVerb, endMessageOutcome, screensave + , Caves, Roster + , mandatoryGroups #ifdef EXPOSE_INTERNAL -- * Internal operations - , validateSingle, validateAll - , validateSingleRoster, validateSinglePlayer, mandatoryGroups + , validateSingle, validateAll, validateSingleRoster #endif ) where @@ -19,25 +14,24 @@ import Game.LambdaHack.Core.Prelude -import Data.Binary import qualified Data.Text as T -import GHC.Generics (Generic) import Game.LambdaHack.Content.CaveKind (CaveKind) +import Game.LambdaHack.Content.FactionKind + (FactionKind (..), Outcome (..)) import Game.LambdaHack.Content.ItemKind (ItemKind) import qualified Game.LambdaHack.Core.Dice as Dice -import qualified Game.LambdaHack.Definition.Ability as Ability import Game.LambdaHack.Definition.ContentData import Game.LambdaHack.Definition.Defs import Game.LambdaHack.Definition.DefsInternal -- | Game mode specification. data ModeKind = ModeKind - { msymbol :: Char -- ^ a symbol - , mname :: Text -- ^ short description + { mname :: Text -- ^ short description , mfreq :: Freqs ModeKind -- ^ frequency within groups , mtutorial :: Bool -- ^ whether to show tutorial messages, etc. - , mroster :: Roster -- ^ players taking part in the game + , mattract :: Bool -- ^ whether this is an attract mode + , mroster :: Roster -- ^ factions taking part in the game , mcaves :: Caves -- ^ arena of the game , mendMsg :: [(Outcome, Text)] -- ^ messages displayed at each particular game ends; if message empty, @@ -52,206 +46,68 @@ -- | Requested cave groups for particular level intervals. type Caves = [([Int], [GroupName CaveKind])] --- | The specification of players for the game mode. -data Roster = Roster - { rosterList :: [( Player - , Maybe TeamContinuity - , [(Int, Dice.Dice, GroupName ItemKind)] )] - -- ^ players in the particular team and levels, numbers and groups - -- of their initial members - , rosterEnemy :: [(Text, Text)] -- ^ the initial enmity matrix - , rosterAlly :: [(Text, Text)] -- ^ the initial aliance matrix - } - deriving Show - --- | Team continuity index. Starting with 1, lower than 100. -newtype TeamContinuity = TeamContinuity Int - deriving (Show, Eq, Ord, Enum, Generic) - -instance Binary TeamContinuity - --- | Outcome of a game. -data Outcome = - Escape -- ^ the player escaped the dungeon alive - | Conquer -- ^ the player won by eliminating all rivals - | Defeated -- ^ the faction lost the game in another way - | Killed -- ^ the faction was eliminated - | Restart -- ^ game is restarted; the quitter quit - | Camping -- ^ game is supended - deriving (Show, Eq, Ord, Enum, Bounded, Generic) - -instance Binary Outcome - --- | Conditional polynomial representing score calculation for this player. -type HiCondPoly = [HiSummand] - -type HiSummand = (HiPolynomial, [Outcome]) - -type HiPolynomial = [(HiIndeterminant, Double)] - -data HiIndeterminant = - HiConst - | HiLoot - | HiSprint - | HiBlitz - | HiSurvival - | HiKill - | HiLoss - deriving (Show, Eq, Generic) - -instance Binary HiIndeterminant - --- | Properties of a particular player. -data Player = Player - { fname :: Text -- ^ name of the player - , fgroups :: [GroupName ItemKind] - -- ^ names of actor groups that may naturally - -- fall under player's control, e.g., upon - -- spawning or summoning - , fskillsOther :: Ability.Skills - -- ^ fixed skill modifiers to the non-leader - -- actors; also summed with skills implied - -- by @fdoctrine@ (which is not fixed) - , fcanEscape :: Bool -- ^ the player can escape the dungeon - , fneverEmpty :: Bool -- ^ the faction declared killed if no actors - , fhiCondPoly :: HiCondPoly -- ^ score polynomial for the player - , fhasGender :: Bool -- ^ whether actors have gender - , fdoctrine :: Ability.Doctrine - -- ^ non-leaders behave according to this - -- doctrine; can be changed during the game - , fleaderMode :: Maybe AutoLeader - -- ^ whether the faction can have a leader - -- and what's its switching mode; - , fhasUI :: Bool -- ^ does the faction have a UI client - -- (for control or passive observation) - , funderAI :: Bool -- ^ is the faction under AI control - } - deriving (Show, Eq, Generic) - -instance Binary Player - -data AutoLeader = AutoLeader - { autoDungeon :: Bool - -- ^ leader switching between levels is automatically done by the server - -- and client is not permitted to change to leaders from other levels - -- (the frequency of leader level switching done by the server - -- is controlled by @RuleKind.rleadLevelClips@); - -- if the flag is @False@, server still does a subset - -- of the automatic switching, e.g., when the old leader dies - -- and no other actor of the faction resides on his level, - -- but the client (particularly UI) is expected to do changes as well - , autoLevel :: Bool - -- ^ client is discouraged from leader switching (e.g., because - -- non-leader actors have the same skills as leader); - -- server is guaranteed to switch leader within a level very rarely, - -- e.g., when the old leader dies; - -- if the flag is @False@, server still does a subset - -- of the automatic switching, but the client is expected to do more, - -- because it's advantageous for that kind of a faction - } - deriving (Show, Eq, Generic) - -instance Binary AutoLeader - -teamExplorer :: TeamContinuity -teamExplorer = TeamContinuity 1 - -victoryOutcomes :: [Outcome] -victoryOutcomes = [Escape, Conquer] - -deafeatOutcomes :: [Outcome] -deafeatOutcomes = [Defeated, Killed, Restart] - -nameOutcomePast :: Outcome -> Text -nameOutcomePast = \case - Escape -> "emerged victorious" - Conquer -> "vanquished all opposition" - Defeated -> "got decisively defeated" - Killed -> "got eliminated" - Restart -> "resigned prematurely" - Camping -> "set camp" - -nameOutcomeVerb :: Outcome -> Text -nameOutcomeVerb = \case - Escape -> "emerge victorious" - Conquer -> "vanquish all opposition" - Defeated -> "be decisively defeated" - Killed -> "be eliminated" - Restart -> "resign prematurely" - Camping -> "set camp" - -endMessageOutcome :: Outcome -> Text -endMessageOutcome = \case - Escape -> "Can it be done more efficiently, though?" - Conquer -> "Can it be done in a better style, though?" - Defeated -> "Let's hope your new overlords let you live." - Killed -> "Let's hope a rescue party arrives in time!" - Restart -> "This time for real." - Camping -> "See you soon, stronger and braver!" - -screensave :: AutoLeader -> ModeKind -> ModeKind -screensave auto mk = - let f x@(Player{funderAI=True}, _, _) = x - f (player, teamContinuity, initial) = - ( player { funderAI = True - , fleaderMode = Just auto } - , teamContinuity - , initial ) - in mk { mroster = (mroster mk) {rosterList = map f $ rosterList $ mroster mk} - , mreason = "This is one of the screensaver scenarios, not available from the main menu, with all factions controlled by AI. Feel free to take over or relinquish control at any moment, but to register a legitimate high score, choose a standard scenario instead.\n" <> mreason mk - } +-- | The specification of factions and of levels, numbers and groups +-- of their initial members. +type Roster = [( GroupName FactionKind + , [(Int, Dice.Dice, GroupName ItemKind)] )] -- | Catch invalid game mode kind definitions. -validateSingle :: ModeKind -> [Text] -validateSingle ModeKind{..} = - [ "mname longer than 20" | T.length mname > 20 ] +validateSingle :: ContentData FactionKind -> ModeKind -> [Text] +validateSingle cofact ModeKind{..} = + [ "mname longer than 22" | T.length mname > 22 ] ++ let f cave@(ns, l) = [ "not enough or too many levels for required cave groups:" <+> tshow cave | length ns /= length l ] in concatMap f mcaves - ++ validateSingleRoster mcaves mroster + ++ validateSingleRoster cofact mcaves mroster -- | Checks, in particular, that there is at least one faction with fneverEmpty -- or the game would get stuck as soon as the dungeon is devoid of actors. -validateSingleRoster :: Caves -> Roster -> [Text] -validateSingleRoster caves Roster{..} = - [ "no player keeps the dungeon alive" - | all (\(pl, _, _) -> not $ fneverEmpty pl) rosterList ] - ++ [ "not exactly one UI client" - | length (filter (\(pl, _, _) -> fhasUI pl) rosterList) /= 1 ] - ++ let tokens = mapMaybe (\(_, tc, _) -> tc) rosterList - nubTokens = nub $ sort tokens - in [ "duplicate team continuity token" +validateSingleRoster :: ContentData FactionKind -> Caves -> Roster -> [Text] +validateSingleRoster cofact caves roster = + let emptyGroups = filter (not . oexistsGroup cofact) $ map fst roster + in [ "the following faction kind groups have no representative with non-zero frequency:" + <+> T.intercalate ", " (map displayGroupName emptyGroups) + | not $ null emptyGroups ] + ++ let fkKeepsAlive acc _ _ fk = acc && fneverEmpty fk + -- all of group elements have to keep level alive, hence conjunction + fkGroupKeepsAlive (fkGroup, _) = + ofoldlGroup' cofact fkGroup fkKeepsAlive True + in [ "potentially no faction keeps the dungeon alive" + | not $ any fkGroupKeepsAlive roster ] + ++ let fkHasUIor acc _ _ fk = acc || fhasUI fk + -- single group element having UI already incurs the risk + -- of duplication, hence disjunction + fkGroupHasUIor (fkGroup, _) = + ofoldlGroup' cofact fkGroup fkHasUIor False + in [ "potentially more than one UI client" + | length (filter fkGroupHasUIor roster) > 1 ] + ++ let fkHasUIand acc _ _ fk = acc && fhasUI fk + -- single group element missing UI already incurs the risk + -- of no UI in the whole game, hence disjunction + fkGroupHasUIand (fkGroup, _) = + ofoldlGroup' cofact fkGroup fkHasUIand True + in [ "potentially less than one UI client" + | not (any fkGroupHasUIand roster) ] + ++ let fkTokens acc _ _ fk = fteam fk : acc + fkGroupTokens (fkGroup, _) = ofoldlGroup' cofact fkGroup fkTokens [] + tokens = concatMap (nub . sort . fkGroupTokens) roster + nubTokens = nub . sort $ tokens + in [ "potentially duplicate team continuity token" | length tokens /= length nubTokens ] - ++ concatMap (\(pl, _, _) -> validateSinglePlayer pl) rosterList - ++ let checkPl field plName = - [ plName <+> "is not a player name in" <+> field - | all (\(pl, _, _) -> fname pl /= plName) rosterList ] - checkDipl field (pl1, pl2) = - [ "self-diplomacy in" <+> field | pl1 == pl2 ] - ++ checkPl field pl1 - ++ checkPl field pl2 - in concatMap (checkDipl "rosterEnemy") rosterEnemy - ++ concatMap (checkDipl "rosterAlly") rosterAlly - ++ let keys = concatMap fst caves + ++ let keys = concatMap fst caves -- permitted to be empty, for tests minD = minimum keys maxD = maximum keys - f (_, _, l) = concatMap g l + f (_, l) = concatMap g l g i3@(ln, _, _) = [ "initial actor levels not among caves:" <+> tshow i3 | ln `notElem` keys ] - in concatMap f rosterList - ++ [ "player confused by both positive and negative level numbers" - | signum minD /= signum maxD ] - ++ [ "player confused by level numer zero" - | any (== 0) keys ] - -validateSinglePlayer :: Player -> [Text] -validateSinglePlayer Player{..} = - [ "fname empty:" <+> fname | T.null fname ] - ++ [ "fskillsOther not negative:" <+> fname - | any ((>= 0) . snd) $ Ability.skillsToList fskillsOther ] + in concatMap f roster + ++ [ "player is confused by both positive and negative level numbers" + | not (null keys) && signum minD /= signum maxD ] + ++ [ "player is confused by level numer zero" + | 0 `elem` keys ] -- | Validate game mode kinds together. validateAll :: [ModeKind] -> ContentData ModeKind -> [Text] @@ -268,15 +124,11 @@ pattern CAMPAIGN_SCENARIO = GroupName "campaign scenario" pattern INSERT_COIN = GroupName "insert coin" --- * Optional item groups - -pattern NO_CONFIRMS :: GroupName ModeKind - -pattern NO_CONFIRMS = GroupName "no confirms" - -makeData :: [ModeKind] -> [GroupName ModeKind] -> [GroupName ModeKind] +makeData :: ContentData FactionKind + -> [ModeKind] -> [GroupName ModeKind] -> [GroupName ModeKind] -> ContentData ModeKind -makeData content groupNamesSingleton groupNames = - makeContentData "ModeKind" mname mfreq validateSingle validateAll content +makeData cofact content groupNamesSingleton groupNames = + makeContentData "ModeKind" mname mfreq (validateSingle cofact) validateAll + content groupNamesSingleton (mandatoryGroups ++ groupNames) diff --git a/definition-src/Game/LambdaHack/Content/PlaceKind.hs b/definition-src/Game/LambdaHack/Content/PlaceKind.hs --- a/definition-src/Game/LambdaHack/Content/PlaceKind.hs +++ b/definition-src/Game/LambdaHack/Content/PlaceKind.hs @@ -27,8 +27,7 @@ -- | Parameters for the generation of small areas within a dungeon level. data PlaceKind = PlaceKind - { psymbol :: Char -- ^ a symbol - , pname :: Text -- ^ short description, singular or plural + { pname :: Text -- ^ short description, singular or plural , pfreq :: Freqs PlaceKind -- ^ frequency within groups , prarity :: Rarity -- ^ rarity on given depths , pcover :: Cover -- ^ how to fill whole place using the corner @@ -110,7 +109,7 @@ (concatMap T.unpack ptopLeft) in [ "top-left corner empty" | dxcorner == 0 ] ++ [ "top-left corner not rectangular" - | any (/= dxcorner) (map T.length ptopLeft) ] + | any ((/= dxcorner) . T.length) ptopLeft ] ++ inLegendAll "plegendDark" plegendDark ++ inLegendAll "plegendLit" plegendLit ++ validateRarity prarity diff --git a/definition-src/Game/LambdaHack/Content/RuleKind.hs b/definition-src/Game/LambdaHack/Content/RuleKind.hs --- a/definition-src/Game/LambdaHack/Content/RuleKind.hs +++ b/definition-src/Game/LambdaHack/Content/RuleKind.hs @@ -3,7 +3,7 @@ ( RuleContent(..), emptyRuleContent, makeData #ifdef EXPOSE_INTERNAL -- * Internal operations - , validateSingle + , emptyRuleContentRaw, validateSingle #endif ) where @@ -22,17 +22,15 @@ -- | The type of game rules and assorted game data. data RuleContent = RuleContent { rtitle :: String -- ^ title of the game (not lib) - , rWidthMax :: X -- ^ maximum level width; for now, - -- keep equal to ScreenContent.rwidth - , rHeightMax :: Y -- ^ maximum level height; for now, - -- keep equal to ScreenContent.rheight - 3 + , rWidthMax :: X -- ^ maximum level width + , rHeightMax :: Y -- ^ maximum level height , rexeVersion :: Version -- ^ version of the game , rcfgUIName :: FilePath -- ^ name of the UI config file - , rcfgUIDefault :: (String, Ini.Config) + , rcfgUIDefault :: (Text, Ini.Config) -- ^ the default UI settings config file , rwriteSaveClips :: Int -- ^ game saved that often (not on browser) , rleadLevelClips :: Int -- ^ server switches leader level that often - , rscoresFile :: FilePath -- ^ name of the scores file + , rscoresFileName :: FilePath -- ^ name of the scores file , rnearby :: Int -- ^ what is a close distance between actors , rstairWordCarried :: [Text] -- ^ words that can't be dropped from stair -- name as it goes through levels @@ -40,25 +38,31 @@ -- ^ item symbols treated specially in engine } -emptyRuleContent :: RuleContent -emptyRuleContent = RuleContent +emptyRuleContentRaw :: RuleContent +emptyRuleContentRaw = RuleContent { rtitle = "" - , rWidthMax = 0 - , rHeightMax = 0 + , rWidthMax = 5 + , rHeightMax = 2 , rexeVersion = makeVersion [] , rcfgUIName = "" , rcfgUIDefault = ("", Ini.emptyConfig) , rwriteSaveClips = 0 , rleadLevelClips = 0 - , rscoresFile = "" + , rscoresFileName = "" , rnearby = 0 , rstairWordCarried = [] , ritemSymbols = emptyItemSymbolsUsedInEngine } +emptyRuleContent :: RuleContent +emptyRuleContent = assert (null $ validateSingle emptyRuleContentRaw) + emptyRuleContentRaw + -- | Catch invalid rule kind definitions. validateSingle :: RuleContent -> [Text] -validateSingle _ = [] +validateSingle RuleContent{..} = + [ "rWidthMax < 5" | rWidthMax < 5 ] -- indented (4 prop spaces) text + ++ [ "rHeightMax < 2" | rHeightMax < 2 ] -- or 4 tiles of sentinel wall makeData :: RuleContent -> RuleContent makeData rc = diff --git a/definition-src/Game/LambdaHack/Content/TileKind.hs b/definition-src/Game/LambdaHack/Content/TileKind.hs --- a/definition-src/Game/LambdaHack/Content/TileKind.hs +++ b/definition-src/Game/LambdaHack/Content/TileKind.hs @@ -7,10 +7,10 @@ , isUknownSpace, unknownId , isSuspectKind, isOpenableKind, isClosableKind , talterForStairs, floorSymbol + , mandatoryGroups, mandatoryGroupsSingleton #ifdef EXPOSE_INTERNAL -- * Internal operations - , validateSingle, validateAll - , validateDups, mandatoryGroups, mandatoryGroupsSingleton + , validateSingle, validateAll, validateDups #endif ) where @@ -81,7 +81,8 @@ | Dark -- ^ is not lit with an ambient light | OftenItem -- ^ initial items often generated there | VeryOftenItem -- ^ initial items very often generated there - | OftenActor -- ^ initial actors often generated there + | OftenActor -- ^ initial actors often generated there; + -- counterpart of @VeryOftenItem@ for dark places | NoItem -- ^ no items ever generated there | NoActor -- ^ no actors ever generated there | ConsideredByAI -- ^ even if otherwise uninteresting, taken into @@ -139,8 +140,8 @@ ts = filter f tfeature in ["more than one BuildAs specification" | length ts > 1]) ++ concatMap (validateDups t) - [ Walkable, Clear, Dark, OftenItem, OftenActor, NoItem, NoActor - , ConsideredByAI, Trail, Spice ] + [ Walkable, Clear, Dark, OftenItem, VeryOftenItem, OftenActor + , NoItem, NoActor, ConsideredByAI, Trail, Spice ] validateDups :: TileKind -> Feature -> [Text] validateDups TileKind{..} feat = diff --git a/definition-src/Game/LambdaHack/Core/Frequency.hs b/definition-src/Game/LambdaHack/Core/Frequency.hs --- a/definition-src/Game/LambdaHack/Core/Frequency.hs +++ b/definition-src/Game/LambdaHack/Core/Frequency.hs @@ -23,8 +23,8 @@ maxBoundInt32 = toIntegralCrash (maxBound :: Int32) -- | The frequency distribution type. Not normalized (operations may --- or may not group the same elements and sum their frequencies). --- However, elements with zero frequency are removed upon construction. +-- or may not group the same elements and sum their frequencies). However, +-- elements with less than zero frequency are removed upon construction. -- -- The @Eq@ instance compares raw representations, not relative, -- normalized frequencies, so operations don't need to preserve diff --git a/definition-src/Game/LambdaHack/Core/Prelude.hs b/definition-src/Game/LambdaHack/Core/Prelude.hs --- a/definition-src/Game/LambdaHack/Core/Prelude.hs +++ b/definition-src/Game/LambdaHack/Core/Prelude.hs @@ -13,7 +13,7 @@ , Text, (<+>), tshow, divUp, sum, (<$$>), partitionM, length, null, comparing , into, fromIntegralWrap, toIntegralCrash, intToDouble, int64ToDouble - , mapM_, forM_ + , mapM_, forM_, vectorUnboxedUnsafeIndex, unsafeShiftL, unsafeShiftR , (***), (&&&), first, second ) where @@ -30,7 +30,6 @@ , null , readFile , sum - , writeFile , (<>) ) @@ -46,8 +45,8 @@ import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import qualified Data.Fixed as Fixed -import Data.Hashable import qualified Data.HashMap.Strict as HM +import Data.Hashable import Data.Int (Int64) import Data.Key import Data.List.Compat hiding (foldl, foldl1, length, null, sum) @@ -58,6 +57,7 @@ import Data.Text (Text) import qualified Data.Text as T (pack) import qualified Data.Time as Time +import qualified Data.Vector.Unboxed as U import NLP.Miniutter.English ((<+>)) import qualified NLP.Miniutter.English as MU import qualified Prelude.Compat @@ -197,3 +197,27 @@ -- | This has a more specific type (unit result) than normally, to catch errors. forM_ :: (Foldable t, Monad m) => t a -> (a -> m ()) -> m () forM_ = Control.Monad.Compat.forM_ + +vectorUnboxedUnsafeIndex :: U.Unbox a => U.Vector a -> Int -> a +vectorUnboxedUnsafeIndex = +#ifdef WITH_EXPENSIVE_ASSERTIONS + (U.!) -- index checking is sometimes an expensive (kind of) assertion +#else + U.unsafeIndex +#endif + +unsafeShiftL :: Bits.Bits a => a -> Int -> a +unsafeShiftL = +#ifdef WITH_EXPENSIVE_ASSERTIONS + Bits.shiftL +#else + Bits.unsafeShiftL +#endif + +unsafeShiftR :: Bits.Bits a => a -> Int -> a +unsafeShiftR = +#ifdef WITH_EXPENSIVE_ASSERTIONS + Bits.shiftR +#else + Bits.unsafeShiftR +#endif diff --git a/definition-src/Game/LambdaHack/Core/Random.hs b/definition-src/Game/LambdaHack/Core/Random.hs --- a/definition-src/Game/LambdaHack/Core/Random.hs +++ b/definition-src/Game/LambdaHack/Core/Random.hs @@ -37,7 +37,7 @@ -- | Get a random object within a (inclusive) range with a uniform distribution. randomR :: (Integral a) => (a, a) -> Rnd a {-# INLINE randomR #-} -randomR (0, h) = St.state $ nextRandom h +randomR (0, h) = randomR0 h randomR (l, h) | l > h = error "randomR: empty range" randomR (l, h) = St.state $ \g -> let (x, g') = nextRandom (h - l) g @@ -56,8 +56,9 @@ -- to keep it working for arbitrary fixed number of bits. nextRandom :: forall a. (Integral a) => a -> SM.SMGen -> (a, SM.SMGen) {-# INLINE nextRandom #-} -nextRandom h g = assert (toInteger h - <= (toInteger :: Int32 -> Integer) maxBound) $ +nextRandom 0 g = (0, g) +nextRandom h g = assert (h > 0 && toInteger h + <= (toInteger :: Int32 -> Integer) maxBound) $ let (w32, g') = SM.bitmaskWithRejection32' ((fromIntegralWrap :: a -> Word32) h) g -- `fromIntegralWrap` is fine here, because wrapping is OK. diff --git a/definition-src/Game/LambdaHack/Definition/Ability.hs b/definition-src/Game/LambdaHack/Definition/Ability.hs --- a/definition-src/Game/LambdaHack/Definition/Ability.hs +++ b/definition-src/Game/LambdaHack/Definition/Ability.hs @@ -141,7 +141,7 @@ -- | Doctrine of non-leader actors. Apart of determining AI operation, -- each doctrine implies a skill modifier, that is added to the non-leader --- skills defined in @fskillsOther@ field of @Player@. +-- skills defined in @fskillsOther@ field of @FactionKind@. data Doctrine = TExplore -- ^ if enemy nearby, attack, if no items, etc., explore unknown | TFollow -- ^ always follow leader's target or his position if no target @@ -228,12 +228,12 @@ s -> Just s in Skills $ EM.mergeWithKey combine id id sk1 sk2 -scaleSkills :: Skills -> Int -> Skills -scaleSkills _ 0 = zeroSkills -scaleSkills (Skills sk) n = Skills $ EM.map (n *) sk +scaleSkills :: (Skills, Int) -> Skills +scaleSkills (_, 0) = zeroSkills +scaleSkills (Skills sk, n) = Skills $ EM.map (n *) sk sumScaledSkills :: [(Skills, Int)] -> Skills -sumScaledSkills = foldr addSkills zeroSkills . map (uncurry scaleSkills) +sumScaledSkills = foldr (addSkills . scaleSkills) zeroSkills nameDoctrine :: Doctrine -> Text nameDoctrine TExplore = "explore" @@ -255,7 +255,7 @@ describeDoctrine TMeleeAdjacent = "engage exclusively in melee, don't move" describeDoctrine TBlock = "block and wait, don't move" describeDoctrine TRoam = "move freely, chase targets" -describeDoctrine TPatrol = "find and patrol an area (WIP)" +describeDoctrine TPatrol = "find and patrol an area" doctrineSkills :: Doctrine -> Skills doctrineSkills TExplore = zeroSkills diff --git a/definition-src/Game/LambdaHack/Definition/Color.hs b/definition-src/Game/LambdaHack/Definition/Color.hs --- a/definition-src/Game/LambdaHack/Definition/Color.hs +++ b/definition-src/Game/LambdaHack/Definition/Color.hs @@ -15,7 +15,7 @@ , AttrChar(..), AttrCharW32(..) , attrCharToW32, attrCharFromW32 , fgFromW32, bgFromW32, charFromW32, attrFromW32 - , spaceAttrW32, nbspAttrW32, spaceCursorAttrW32, trimmedLineAttrW32 + , spaceAttrW32, nbspAttrW32, trimmedLineAttrW32 , attrChar2ToW32, attrChar1ToW32 ) where @@ -25,7 +25,7 @@ import Control.DeepSeq import Data.Binary -import Data.Bits (unsafeShiftL, unsafeShiftR, (.&.)) +import Data.Bits ((.&.)) import qualified Data.Char as Char import GHC.Generics (Generic) @@ -232,10 +232,6 @@ nbspAttrW32 :: AttrCharW32 nbspAttrW32 = attrCharToW32 $ AttrChar defAttr '\x00a0' - -spaceCursorAttrW32 :: AttrCharW32 -spaceCursorAttrW32 = - attrCharToW32 $ AttrChar (defAttr {bg = HighlightNoneCursor}) ' ' trimmedLineAttrW32 :: AttrCharW32 trimmedLineAttrW32 = attrChar2ToW32 BrBlack '$' diff --git a/definition-src/Game/LambdaHack/Definition/ContentData.hs b/definition-src/Game/LambdaHack/Definition/ContentData.hs --- a/definition-src/Game/LambdaHack/Definition/ContentData.hs +++ b/definition-src/Game/LambdaHack/Definition/ContentData.hs @@ -107,7 +107,7 @@ allGroupNamesNonUnique = allGroupNamesSorted \\ allGroupNamesUnique missingGroups = filter (not . omemberGroup contentData) (groupNamesSingleton ++ groupNames) - groupsMoreThanOne = filter (oisMoreThanOneGroup contentData) + groupsMoreThanOne = filter (not . oisSingletonGroup contentData) groupNamesSingleton groupsDeclaredSet = S.fromAscList allGroupNamesUnique groupsNotDeclared = filter (`S.notMember` groupsDeclaredSet) @@ -160,12 +160,6 @@ oisSingletonGroup ContentData{groupFreq} cgroup = case M.lookup cgroup groupFreq of Just [_] -> True - _ -> False - -oisMoreThanOneGroup :: ContentData a -> GroupName a -> Bool -oisMoreThanOneGroup ContentData{groupFreq} cgroup = - case M.lookup cgroup groupFreq of - Just (_:_:_) -> True _ -> False -- | The id of the unique member of a singleton content group. diff --git a/definition-src/Game/LambdaHack/Definition/Defs.hs b/definition-src/Game/LambdaHack/Definition/Defs.hs --- a/definition-src/Game/LambdaHack/Definition/Defs.hs +++ b/definition-src/Game/LambdaHack/Definition/Defs.hs @@ -9,7 +9,7 @@ , Rarity, linearInterpolation , CStore(..), ppCStore, ppCStoreIn, verbCStore , SLore(..), ItemDialogMode(..), ppSLore, headingSLore - , ppItemDialogMode, ppItemDialogModeIn, ppItemDialogModeFrom + , ppItemDialogMode, ppItemDialogModeIn, ppItemDialogModeFrom, loreFromMode , Direction(..) ) where @@ -124,6 +124,8 @@ | SCondition | SBlast | SEmbed + | SBody -- contains the sum of @SOrgan@, @STrunk@ and @SCondition@ + -- but only present in the current pointman's body deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) instance Binary SLore @@ -132,11 +134,11 @@ data ItemDialogMode = MStore CStore -- ^ a leader's store - | MOrgans -- ^ leader's organs | MOwned -- ^ all party's items | MSkills -- ^ not items, but determined by leader's items | MLore SLore -- ^ not party's items, but all known generalized items | MPlaces -- ^ places; not items at all, but definitely a lore + | MFactions -- ^ factions in this game, with some data from previous | MModes -- ^ scenarios; not items at all, but definitely a lore deriving (Show, Read, Eq, Ord, Generic) @@ -151,6 +153,7 @@ ppSLore SCondition = "condition" ppSLore SBlast = "blast" ppSLore SEmbed = "terrain" +ppSLore SBody = "body" headingSLore :: SLore -> Text headingSLore SItem = "miscellaneous item" @@ -159,14 +162,16 @@ headingSLore SCondition = "momentary bodily condition" headingSLore SBlast = "explosion blast particle" headingSLore SEmbed = "landmark feature" +headingSLore SBody = "body part" ppItemDialogMode :: ItemDialogMode -> (Text, Text) ppItemDialogMode (MStore cstore) = ppCStore cstore -ppItemDialogMode MOrgans = ("in", "body") ppItemDialogMode MOwned = ("among", "our total team belongings") ppItemDialogMode MSkills = ("among", "skills") +ppItemDialogMode (MLore SBody) = ("in", "body") ppItemDialogMode (MLore slore) = ("among", ppSLore slore <+> "lore") ppItemDialogMode MPlaces = ("among", "place lore") +ppItemDialogMode MFactions = ("among", "faction lore") ppItemDialogMode MModes = ("among", "adventure lore") ppItemDialogModeIn :: ItemDialogMode -> Text @@ -174,6 +179,17 @@ ppItemDialogModeFrom :: ItemDialogMode -> Text ppItemDialogModeFrom c = let (_tIn, t) = ppItemDialogMode c in "from" <+> t + +loreFromMode :: ItemDialogMode -> SLore +loreFromMode c = case c of + MStore COrgan -> SOrgan + MStore _ -> SItem + MOwned -> SItem + MSkills -> undefined -- artificial slots + MLore slore -> slore + MPlaces -> undefined -- artificial slots + MFactions -> undefined -- artificial slots + MModes -> undefined -- artificial slots data Direction = Forward | Backward deriving (Show, Read, Eq, Ord, Generic) diff --git a/definition-src/Game/LambdaHack/Definition/DefsInternal.hs b/definition-src/Game/LambdaHack/Definition/DefsInternal.hs --- a/definition-src/Game/LambdaHack/Definition/DefsInternal.hs +++ b/definition-src/Game/LambdaHack/Definition/DefsInternal.hs @@ -42,11 +42,13 @@ contentIdIndex (ContentId k) = fromEnum k -- TODO: temporary, not to break compilation too soon: +--{-- type ContentSymbol c = Char toContentSymbol :: Char -> ContentSymbol c toContentSymbol = id displayContentSymbol :: ContentSymbol c -> Char displayContentSymbol = id +--} -- TODO: The intended definitions. Error they are going to cause will -- point out all the remaining item symbols hardwired in the engine @@ -58,7 +60,7 @@ -- by accident (this is still possible via conversion functions, -- if one insists, so the abstraction is leaky, but that's fine). newtype ContentSymbol c = ContentSymbol Char - deriving (Show, Eq, Ord, Generic, Binary, NFData) + deriving (Show, Eq, Ord, Binary, NFData) -- TODO: Generic and most others are only needed for TriggerItem, so once the latter is removed, these instances can go. -- | This is a 1-1 inclusion. Don't use, if an equal named symbol already -- exists in rules content. diff --git a/definition-src/Game/LambdaHack/Definition/Flavour.hs b/definition-src/Game/LambdaHack/Definition/Flavour.hs --- a/definition-src/Game/LambdaHack/Definition/Flavour.hs +++ b/definition-src/Game/LambdaHack/Definition/Flavour.hs @@ -21,7 +21,7 @@ import Game.LambdaHack.Core.Prelude import Data.Binary -import Data.Bits (unsafeShiftL, unsafeShiftR, (.&.)) +import Data.Bits ((.&.)) import GHC.Generics (Generic) import Game.LambdaHack.Definition.Color diff --git a/engine-src/Game/LambdaHack/Atomic/CmdAtomic.hs b/engine-src/Game/LambdaHack/Atomic/CmdAtomic.hs --- a/engine-src/Game/LambdaHack/Atomic/CmdAtomic.hs +++ b/engine-src/Game/LambdaHack/Atomic/CmdAtomic.hs @@ -162,7 +162,7 @@ | SfxTrigger ActorId LevelId Point (ContentId TileKind) | SfxShun ActorId LevelId Point (ContentId TileKind) | SfxEffect FactionId ActorId ItemId IK.Effect Int64 - | SfxItemApplied ItemId Container + | SfxItemApplied Bool ItemId Container | SfxMsgFid FactionId SfxMsg | SfxRestart | SfxCollideTile ActorId Point diff --git a/engine-src/Game/LambdaHack/Atomic/HandleAtomicWrite.hs b/engine-src/Game/LambdaHack/Atomic/HandleAtomicWrite.hs --- a/engine-src/Game/LambdaHack/Atomic/HandleAtomicWrite.hs +++ b/engine-src/Game/LambdaHack/Atomic/HandleAtomicWrite.hs @@ -49,8 +49,8 @@ import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Types import Game.LambdaHack.Common.Vector +import Game.LambdaHack.Content.FactionKind import Game.LambdaHack.Content.ItemKind (ItemKind) -import Game.LambdaHack.Content.ModeKind import qualified Game.LambdaHack.Content.PlaceKind as PK import Game.LambdaHack.Content.TileKind (TileKind, unknownId) import qualified Game.LambdaHack.Definition.Ability as Ability @@ -279,7 +279,7 @@ updSpotItemBag :: MonadStateWrite m => Container -> ItemBag -> m () updSpotItemBag c bag = -- The case of empty bag is for a hack to help identifying sample items. - when (not $ EM.null bag) $ do + unless (EM.null bag) $ do insertBagContainer bag c case c of CActor aid store -> @@ -453,7 +453,7 @@ -> m () updLeadFaction fid source target = assert (source /= target) $ do fact <- getsState $ (EM.! fid) . sfactionD - let !_A = assert (fleaderMode (gplayer fact) /= Nothing) () + let !_A = assert (fhasPointman (gkind fact)) () -- @PosNone@ ensures this mtb <- getsState $ \s -> flip getActorBody s <$> target let !_A = assert (maybe True (not . bproj) mtb @@ -482,17 +482,13 @@ updDoctrineFaction :: MonadStateWrite m => FactionId -> Ability.Doctrine -> Ability.Doctrine -> m () updDoctrineFaction fid toT fromT = do - let adj fact = - let player = gplayer fact - in assert (fdoctrine player == fromT) - $ fact {gplayer = player {fdoctrine = toT}} + let adj fact = assert (gdoctrine fact == fromT) $ fact {gdoctrine = toT} updateFaction fid adj updAutoFaction :: MonadStateWrite m => FactionId -> Bool -> m () updAutoFaction fid st = updateFaction fid (\fact -> - assert (isAIFact fact == not st) - $ fact {gplayer = automatePlayer st (gplayer fact)}) + assert (gunderAI fact == not st) $ fact {gunderAI = st}) -- Record a given number (usually just 1, or -1 for undo) of actor kills -- for score calculation. diff --git a/engine-src/Game/LambdaHack/Atomic/PosAtomicRead.hs b/engine-src/Game/LambdaHack/Atomic/PosAtomicRead.hs --- a/engine-src/Game/LambdaHack/Atomic/PosAtomicRead.hs +++ b/engine-src/Game/LambdaHack/Atomic/PosAtomicRead.hs @@ -113,7 +113,7 @@ UpdLoseStashFaction _ fid lid pos -> return $! PosFidAndSight fid lid [pos] UpdLeadFaction fid _ _ -> return $! PosFidAndSer fid UpdDiplFaction{} -> return PosAll - UpdDoctrineFaction fid _ _ -> return $! PosFidAndSer fid + UpdDoctrineFaction{} -> return PosAll -- make faction lore fun UpdAutoFaction{} -> return PosAll UpdRecordKill aid _ _ -> singleAid aid UpdAlterTile lid p _ _ -> return $! PosSight lid [p] @@ -190,7 +190,7 @@ body <- getsState $ getActorBody aid return $! PosSightLevels [(lid, p), (blid body, bpos body)] SfxEffect _ aid _ _ _ -> singleAid aid -- sometimes we don't see source, OK - SfxItemApplied _ c -> singleContainerActor c + SfxItemApplied _ _ c -> singleContainerActor c SfxMsgFid fid _ -> return $! PosFid fid SfxRestart -> return PosAll SfxCollideTile aid _ -> singleAid aid @@ -272,7 +272,7 @@ SfxTrigger{} -> [] SfxShun{} -> [] SfxEffect{} -> [] - SfxItemApplied iid _ -> [iid] + SfxItemApplied _ iid _ -> [iid] SfxMsgFid{} -> [] SfxRestart{} -> [] SfxCollideTile{} -> [] diff --git a/engine-src/Game/LambdaHack/Client/AI.hs b/engine-src/Game/LambdaHack/Client/AI.hs --- a/engine-src/Game/LambdaHack/Client/AI.hs +++ b/engine-src/Game/LambdaHack/Client/AI.hs @@ -83,6 +83,6 @@ -- a non-waiting action should be found. -- If a new leader found, there is hope (but we don't check) -- that he gets a non-waiting action without any desperate measures. - let retry = maybe False (aidToMove ==) maid + let retry = Just aidToMove == maid treq <- pickAction foeAssocs friendAssocs aidToMove retry return (aidToMove, treq, oldFlee) diff --git a/engine-src/Game/LambdaHack/Client/AI/ConditionM.hs b/engine-src/Game/LambdaHack/Client/AI/ConditionM.hs --- a/engine-src/Game/LambdaHack/Client/AI/ConditionM.hs +++ b/engine-src/Game/LambdaHack/Client/AI/ConditionM.hs @@ -48,8 +48,8 @@ import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Types import Game.LambdaHack.Common.Vector +import Game.LambdaHack.Content.FactionKind import qualified Game.LambdaHack.Content.ItemKind as IK -import Game.LambdaHack.Content.ModeKind import qualified Game.LambdaHack.Content.RuleKind as RK import qualified Game.LambdaHack.Core.Dice as Dice import qualified Game.LambdaHack.Definition.Ability as Ability @@ -185,7 +185,7 @@ -- | Check whether the actor has no weapon in equipment. condNoEqpWeaponM :: MonadStateRead m => ActorId -> m Bool condNoEqpWeaponM aid = - all (not . IA.checkFlag Ability.Meleeable . aspectRecordFull . snd) <$> + not . any (IA.checkFlag Ability.Meleeable . aspectRecordFull . snd) <$> getsState (fullAssocs aid [CEqp]) -- | Require that the actor can project any items. @@ -195,7 +195,7 @@ curChal <- getsClient scurChal fact <- getsState $ (EM.! side) . sfactionD if skill < 1 - || ckeeper curChal && fhasUI (gplayer fact) + || ckeeper curChal && fhasUI (gkind fact) then return False else -- shortcut -- Compared to conditions in @projectItem@, range and charge are ignored, @@ -293,7 +293,7 @@ b <- getsState $ getActorBody aid fact <- getsState $ (EM.! bfid b) . sfactionD discoBenefit <- getsClient sdiscoBenefit - let canEsc = fcanEscape (gplayer fact) + let canEsc = fcanEscape (gkind fact) isDesirable (ben, _, _, itemFull, _) = desirableItem cops canEsc (benPickup ben) (aspectRecordFull itemFull) (itemKind itemFull) diff --git a/engine-src/Game/LambdaHack/Client/AI/PickActionM.hs b/engine-src/Game/LambdaHack/Client/AI/PickActionM.hs --- a/engine-src/Game/LambdaHack/Client/AI/PickActionM.hs +++ b/engine-src/Game/LambdaHack/Client/AI/PickActionM.hs @@ -47,8 +47,8 @@ import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Types import Game.LambdaHack.Common.Vector +import Game.LambdaHack.Content.FactionKind import qualified Game.LambdaHack.Content.ItemKind as IK -import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Core.Frequency import Game.LambdaHack.Core.Random import Game.LambdaHack.Definition.Ability @@ -584,7 +584,7 @@ || not calmE || heavilyDistressed || recentlyFled - canEsc = fcanEscape (gplayer fact) + canEsc = fcanEscape (gkind fact) -- We filter out unneeded items. In particular, we ignore them in eqp -- when comparing to items we may want to equip, so that the unneeded -- but powerful items don't fool us. @@ -758,6 +758,8 @@ -- If enemy (or even a friend) blocks the way, sometimes melee him -- even though normally you wouldn't. +-- This is also a trick to make a foe use up its non-durable weapons, +-- e.g., on cheap slow projectiles fired in its path. meleeBlocker :: MonadClient m => Ability.Skills -> ActorId -> m (Strategy RequestTimed) meleeBlocker actorSk aid = do @@ -932,7 +934,7 @@ skill = getSk SkApply actorSk -- This detects if the value of keeping the item in eqp is in fact < 0. hind = hinders condShineWouldBetray uneasy actorSk - canEsc = fcanEscape (gplayer fact) + canEsc = fcanEscape (gkind fact) permittedActor cstore itemFull kit = fromRight False $ permittedApply corule localTime skill calmE cstore itemFull kit @@ -1192,7 +1194,7 @@ fact <- getsState $ (EM.! bfid body) . sfactionD mtgtMPath <- getsClient $ EM.lookup aid . stargetD let -- With no leader, the goal is vague, so permit arbitrary detours. - relaxed = isNothing $ fleaderMode (gplayer fact) + relaxed = not $ fhasPointman (gkind fact) strAmbient avoid = case mtgtMPath of Just TgtAndPath{tapPath=Just AndPath{pathList=q : _, ..}} -> if pathGoal == bpos body diff --git a/engine-src/Game/LambdaHack/Client/AI/PickActorM.hs b/engine-src/Game/LambdaHack/Client/AI/PickActorM.hs --- a/engine-src/Game/LambdaHack/Client/AI/PickActorM.hs +++ b/engine-src/Game/LambdaHack/Client/AI/PickActorM.hs @@ -28,7 +28,7 @@ import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Types -import Game.LambdaHack.Content.ModeKind +import Game.LambdaHack.Content.FactionKind (fskillsOther) import Game.LambdaHack.Core.Frequency import Game.LambdaHack.Core.Random import qualified Game.LambdaHack.Definition.Ability as Ability @@ -56,9 +56,15 @@ void $ refreshTarget foeAssocs friendAssocs (oldAid, oldBody) return oldAid oursNotSleeping = filter (\(_, b) -> bwatch b /= WSleep) ours + -- Faction discourages client leader change on level, because + -- non-leader actors have the same skills as leader, so no point. + -- Server is guaranteed to switch leader within a level occasionally, + -- e.g., when the old leader dies, so this works fine. + discouragedPointmanSwitchOnLevel = + fskillsOther (gkind fact) == Ability.zeroSkills case oursNotSleeping of - _ | -- Keep the leader: faction discourages client leader change on level, - -- so will only be changed if waits (maidToAvoid) + _ | -- Keep the leader: client is discouraged from leader switching, + -- so it will only be changed if pointman waits (maidToAvoid) -- to avoid wasting his higher mobility. -- This is OK for monsters even if in melee, because both having -- a meleeing actor a leader (and higher DPS) and rescuing actor @@ -66,7 +72,7 @@ -- And we are guaranteed that only the two classes of actors are -- not waiting, with some exceptions (urgent unequip, flee via starts, -- melee-less trying to flee, first aid, etc.). - snd (autoDungeonLevel fact) && isNothing maidToAvoid -> pickOld + discouragedPointmanSwitchOnLevel && isNothing maidToAvoid -> pickOld [] -> pickOld [(aidNotSleeping, bNotSleeping)] -> do -- Target of asleep actors won't change unless foe adjacent, @@ -350,8 +356,7 @@ modifyClient $ updateLeader aid s -- When you become a leader, stop following old leader, but follow -- his target, if still valid, to avoid distraction. - when (fdoctrine (gplayer fact) - `elem` [Ability.TFollow, Ability.TFollowNoItems] + when (gdoctrine fact `elem` [Ability.TFollow, Ability.TFollowNoItems] && not condInMelee) $ void $ refreshTarget foeAssocs friendAssocs (aid, b) return aid @@ -410,7 +415,7 @@ unless nonEnemyPathSet -- If no path even to the leader himself, explore. explore - case fdoctrine $ gplayer fact of + case gdoctrine fact of Ability.TExplore -> explore Ability.TFollow -> follow Ability.TFollowNoItems -> follow diff --git a/engine-src/Game/LambdaHack/Client/AI/PickTargetM.hs b/engine-src/Game/LambdaHack/Client/AI/PickTargetM.hs --- a/engine-src/Game/LambdaHack/Client/AI/PickTargetM.hs +++ b/engine-src/Game/LambdaHack/Client/AI/PickTargetM.hs @@ -36,7 +36,7 @@ import Game.LambdaHack.Common.Types import Game.LambdaHack.Common.Vector import qualified Game.LambdaHack.Content.CaveKind as CK -import Game.LambdaHack.Content.ModeKind +import Game.LambdaHack.Content.FactionKind import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Content.TileKind (isUknownSpace) import Game.LambdaHack.Core.Frequency @@ -139,10 +139,9 @@ factionD <- getsState sfactionD seps <- getsClient seps let fact = factionD EM.! bfid b - slackDoctrine = - fdoctrine (gplayer fact) - `elem` [ Ability.TMeleeAndRanged, Ability.TMeleeAdjacent - , Ability.TBlock, Ability.TRoam, Ability.TPatrol ] + slackDoctrine = gdoctrine fact + `elem` [ Ability.TMeleeAndRanged, Ability.TMeleeAdjacent + , Ability.TBlock, Ability.TRoam, Ability.TPatrol ] canMove = Ability.getSk Ability.SkMove actorMaxSk > 0 canReach = canMove || Ability.getSk Ability.SkDisplace actorMaxSk > 0 @@ -168,7 +167,7 @@ recentlyFled20 = maybe False (\(_, time) -> timeRecent5 localTime time) mfled actorTurn = ticksPerMeter $ gearSpeed actorMaxSk - let canEscape = fcanEscape (gplayer fact) + let canEscape = fcanEscape (gkind fact) canSmell = Ability.getSk Ability.SkSmell actorMaxSk > 0 meleeNearby | canEscape = rnearby `div` 2 | otherwise = rnearby @@ -233,7 +232,7 @@ cstashes <- if canMove && (calmE || null nearbyFoes) -- danger or risk of defecting && not heavilyDistressed - && isAIFact fact -- humans target any stashes explicitly + && gunderAI fact -- humans target any stashes explicitly then closestStashes aid else return [] let desirableIid (iid, (k, _)) = @@ -394,18 +393,19 @@ updateTgt tap@TgtAndPath{tapPath=Just AndPath{..},tapTgt} = case tapTgt of TEnemy a -> do body <- getsState $ getActorBody a - if | (condInMelee -- fight close foes or nobody at all + if (condInMelee -- fight close foes or nobody at all || bweapon body <= 0 -- not dangerous || not focused && not (null nearbyFoes)) -- prefers closer foes && a `notElem` map fst nearbyFoes -- old one not close enough || blid body /= blid b -- wrong level || actorDying body -- foe already dying || not (worthTargeting a body) - || recentlyFled -> + || recentlyFled + then -- forget enemy positions to prevent attacking them -- again soon after flight pickNewTarget - | otherwise -> do + else do -- If there are no unwalkable tiles on the path to enemy, -- he gets target @TEnemy@ and then, even if such tiles emerge, -- the target updated by his moves remains @TEnemy@. @@ -441,7 +441,8 @@ filter (\(_, body) -> blid body == lid) oursExploring spawnFreqs = CK.cactorFreq $ okind cocave $ lkind lvl hasGroup grp = fromMaybe 0 (lookup grp spawnFreqs) > 0 - lvlSpawnsUs = any hasGroup $ fgroups (gplayer fact) + lvlSpawnsUs = any (hasGroup . fst) $ filter ((> 0) . snd) + $ fgroups (gkind fact) -- Even if made peace with the faction, loot stash one last time. if (calmE || null nearbyFoes) -- no risk or can't defend anyway && not heavilyDistressed -- not under heavy fire diff --git a/engine-src/Game/LambdaHack/Client/Bfs.hs b/engine-src/Game/LambdaHack/Client/Bfs.hs --- a/engine-src/Game/LambdaHack/Client/Bfs.hs +++ b/engine-src/Game/LambdaHack/Client/Bfs.hs @@ -132,10 +132,19 @@ (!tabAThawed, !tabBThawed) !vThawed = do let unsafeReadI :: PointI -> ST s BfsDistance {-# INLINE unsafeReadI #-} +#ifdef WITH_EXPENSIVE_ASSERTIONS + unsafeReadI p = BfsDistance <$> VM.read vThawed p + -- index checking is sometimes an expensive (kind of) assertion +#else unsafeReadI p = BfsDistance <$> VM.unsafeRead vThawed p +#endif unsafeWriteI :: PointI -> BfsDistance -> ST s () {-# INLINE unsafeWriteI #-} +#ifdef WITH_EXPENSIVE_ASSERTIONS + unsafeWriteI p c = VM.write vThawed p (bfsDistance c) +#else unsafeWriteI p c = VM.unsafeWrite vThawed p (bfsDistance c) +#endif -- The two tabs (arrays) are used as a staged, optimized queue. -- The first tab is for writes, the second one for reads. -- They switch places in each recursive @bfs@ call. @@ -195,7 +204,11 @@ if acc3 == 0 || distanceNew == maxBfsDistance then return () -- no more close enough dungeon positions else bfs tabWriteThawed tabReadThawed distanceNew acc3 +#ifdef WITH_EXPENSIVE_ASSERTIONS + VM.write vThawed sourceI (bfsDistance minKnownBfs) +#else VM.unsafeWrite vThawed sourceI (bfsDistance minKnownBfs) +#endif PA.writePrimArray tabAThawed 0 sourceI bfs tabAThawed tabBThawed (succBfsDistance minKnownBfs) 1 diff --git a/engine-src/Game/LambdaHack/Client/BfsM.hs b/engine-src/Game/LambdaHack/Client/BfsM.hs --- a/engine-src/Game/LambdaHack/Client/BfsM.hs +++ b/engine-src/Game/LambdaHack/Client/BfsM.hs @@ -44,8 +44,8 @@ import Game.LambdaHack.Common.Types import Game.LambdaHack.Common.Vector import qualified Game.LambdaHack.Content.CaveKind as CK +import Game.LambdaHack.Content.FactionKind import qualified Game.LambdaHack.Content.ItemKind as IK -import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Content.TileKind (isUknownSpace) import Game.LambdaHack.Core.Random @@ -184,9 +184,9 @@ getCachePath aid target = do b <- getsState $ getActorBody aid let source = bpos b - if | source == target -> - return $ Just $ AndPath (bpos b) [] target 0 -- speedup - | otherwise -> snd <$> getCacheBfsAndPath aid target + if source == target + then return $ Just $ AndPath (bpos b) [] target 0 -- speedup + else snd <$> getCacheBfsAndPath aid target createPath :: MonadClient m => ActorId -> Target -> m TgtAndPath createPath aid tapTgt = do @@ -237,11 +237,10 @@ || Ability.getSk Ability.SkProject actorMaxSk > 0 smarkSuspect <- getsClient smarkSuspect fact <- getsState $ (EM.! side) . sfactionD - let underAI = isAIFact fact - -- Under UI, playing a hero party, we let AI set our target each + let -- Under UI, playing a hero party, we let AI set our target each -- turn for non-pointmen that can't move and can't alter, -- usually to TUnknown. This is rather useless, but correct. - enterSuspect = smarkSuspect > 0 || underAI + enterSuspect = smarkSuspect > 0 || gunderAI fact skill | enterSuspect = alterSkill -- dig and search as skill allows | otherwise = 0 -- only walkable tiles return (canMove, skill) -- keep it lazy @@ -354,7 +353,8 @@ filter (\(_, body) -> blid body == blid b) oursExploring spawnFreqs = CK.cactorFreq $ okind cocave $ lkind lvl hasGroup grp = fromMaybe 0 (lookup grp spawnFreqs) > 0 - lvlSpawnsUs = any hasGroup $ fgroups (gplayer fact) + lvlSpawnsUs = any (hasGroup . fst) $ filter ((> 0) . snd) + $ fgroups (gkind fact) actorSk <- if fleeVia `elem` [ViaAnything, ViaExit] -- targeting, possibly when not a leader then getsState $ getActorMaxSkills aid @@ -382,8 +382,8 @@ Just IK.Escape{} -> -- Escape (or guard) only after exploring, for high score, etc. let escapeOrGuard = - fcanEscape (gplayer fact) - || fleeVia `elem` [ViaExit] -- target to guard after explored + fcanEscape (gkind fact) + || fleeVia == ViaExit -- target to guard after explored in if fleeVia `elem` [ViaAnything, ViaEscape, ViaExit] && escapeOrGuard && allExplored @@ -488,8 +488,8 @@ condEnoughGearM aid = do b <- getsState $ getActorBody aid fact <- getsState $ (EM.! bfid b) . sfactionD - let followDoctrine = fdoctrine (gplayer fact) - `elem` [Ability.TFollow, Ability.TFollowNoItems] + let followDoctrine = + gdoctrine fact `elem` [Ability.TFollow, Ability.TFollowNoItems] eqpAssocs <- getsState $ fullAssocs aid [CEqp] return $ not followDoctrine -- keep it lazy && (any (IA.checkFlag Ability.Meleeable @@ -569,7 +569,8 @@ let fact = factionD EM.! bfid b spawnFreqs = CK.cactorFreq $ okind cocave $ lkind lvl hasGroup grp = fromMaybe 0 (lookup grp spawnFreqs) > 0 - lvlSpawnsUs = any hasGroup $ fgroups (gplayer fact) + lvlSpawnsUs = any (hasGroup . fst) $ filter ((> 0) . snd) + $ fgroups (gkind fact) qualifyStash (fid2, Faction{gstash}) = case gstash of Nothing -> Nothing Just (lid, pos) -> diff --git a/engine-src/Game/LambdaHack/Client/CommonM.hs b/engine-src/Game/LambdaHack/Client/CommonM.hs --- a/engine-src/Game/LambdaHack/Client/CommonM.hs +++ b/engine-src/Game/LambdaHack/Client/CommonM.hs @@ -74,7 +74,7 @@ let COps{coTileSpeedup} = cops dist = chessDist (bpos body) fpos calcScore :: Int -> Int - calcScore eps = case bla eps (bpos body) fpos of + calcScore eps = case bresenhamsLineAlgorithm eps (bpos body) fpos of Just bl -> let blDist = take (dist - 1) bl -- goal not checked; actor well aware noActor p = p == fpos || not (occupiedBigLvl p lvl) @@ -137,19 +137,23 @@ -- that hits multiple tagets comes into the equation. AI has to be very -- primitive and random here as well. pickWeaponClient :: MonadClient m - => ActorId -> ActorId - -> m (Maybe RequestTimed) + => ActorId -> ActorId -> m (Maybe RequestTimed) pickWeaponClient source target = do eqpAssocs <- getsState $ kitAssocs source [CEqp] bodyAssocs <- getsState $ kitAssocs source [COrgan] actorSk <- currentSkillsClient source + tb <- getsState $ getActorBody target let kitAssRaw = eqpAssocs ++ bodyAssocs kitAss = filter (IA.checkFlag Ability.Meleeable . aspectRecordFull . fst . snd) kitAssRaw + benign itemFull = let arItem = aspectRecordFull itemFull + in IA.checkFlag Ability.Benign arItem discoBenefit <- getsClient sdiscoBenefit strongest <- pickWeaponM False (Just discoBenefit) kitAss actorSk source case strongest of [] -> return Nothing + (_, _, _, _, _, (itemFull, _)) : _ | benign itemFull && bproj tb -> + return Nothing -- if strongest is benign, don't waste fun on a projectile iis@(ii1@(value1, hasEffect1, timeout1, _, _, (itemFull1, _)) : _) -> do let minIis = takeWhile (\(value, hasEffect, timeout, _, _, _) -> value == value1 diff --git a/engine-src/Game/LambdaHack/Client/HandleAtomicM.hs b/engine-src/Game/LambdaHack/Client/HandleAtomicM.hs --- a/engine-src/Game/LambdaHack/Client/HandleAtomicM.hs +++ b/engine-src/Game/LambdaHack/Client/HandleAtomicM.hs @@ -20,7 +20,6 @@ import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES -import qualified Data.Map.Strict as M import Game.LambdaHack.Atomic import Game.LambdaHack.Client.Bfs @@ -43,7 +42,7 @@ import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Types import qualified Game.LambdaHack.Content.CaveKind as CK -import Game.LambdaHack.Content.ModeKind +import Game.LambdaHack.Content.FactionKind import Game.LambdaHack.Content.TileKind (TileKind) import Game.LambdaHack.Definition.Defs @@ -129,23 +128,7 @@ insertInMeleeM (blid b) -- @bhp@ checked in several places UpdRefillCalm{} -> return () UpdTrajectory{} -> return () - UpdQuitFaction fid _ toSt _ -> do - side <- getsClient sside - gameModeId <- getsState sgameModeId - when (side == fid) $ case toSt of - Just Status{stOutcome=Camping} -> - modifyClient $ \cli -> - cli {scampings = ES.insert gameModeId $ scampings cli} - Just Status{stOutcome=Restart} -> - modifyClient $ \cli -> - cli {srestarts = ES.insert gameModeId $ srestarts cli} - Just Status{stOutcome} | stOutcome `elem` victoryOutcomes -> do - scurChal <- getsClient scurChal - let sing = M.singleton scurChal 1 - f = M.unionWith (+) - g = EM.insertWith f gameModeId sing - modifyClient $ \cli -> cli {svictories = g $ svictories cli} - _ -> return () + UpdQuitFaction{} -> return () UpdSpotStashFaction{} -> return () UpdLoseStashFaction{} -> return () UpdLeadFaction fid source target -> do @@ -259,13 +242,10 @@ fact <- getsState $ (EM.! side) . sfactionD snxtChal <- getsClient snxtChal smarkSuspect <- getsClient smarkSuspect - svictories <- getsClient svictories - scampings <- getsClient scampings - srestarts <- getsClient srestarts stabs <- getsClient stabs soptionsOld <- getsClient soptions - let h lvl = CK.labyrinth (okind cocave $ lkind lvl) - && not (fhasGender $ gplayer fact) + let h lvl = CK.clabyrinth (okind cocave $ lkind lvl) + && not (fhasGender $ gkind fact) -- Not to burrow through a labyrinth instead of leaving it for -- the human player and to prevent AI losing time there instead -- of congregating at exits. @@ -278,9 +258,6 @@ , scurChal , snxtChal , smarkSuspect - , svictories - , scampings - , srestarts , soptions = soptionsNew {snoAnim = -- persist @snoAnim@ between games snoAnim soptionsOld `mplus` snoAnim soptionsNew} @@ -295,8 +272,8 @@ let !_A = assert (sfperNew == sfperOld `blame` (_side, sfperNew, sfperOld)) () #endif - modifyClient $ \cli -> cli {sfper = sfperNew} - salter <- getsState createSalter + modifyClient $ \cli -> cli {sfper = sfperNew} -- just in case + salter <- getsState createSalter -- because space saved by not storing it modifyClient $ \cli -> cli {salter} UpdResumeServer{} -> return () UpdKillExit _fid -> killExit diff --git a/engine-src/Game/LambdaHack/Client/HandleResponseM.hs b/engine-src/Game/LambdaHack/Client/HandleResponseM.hs --- a/engine-src/Game/LambdaHack/Client/HandleResponseM.hs +++ b/engine-src/Game/LambdaHack/Client/HandleResponseM.hs @@ -16,7 +16,6 @@ import Game.LambdaHack.Client.Request import Game.LambdaHack.Client.Response import Game.LambdaHack.Client.UI -import Game.LambdaHack.Client.UI.SessionUI import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.State diff --git a/engine-src/Game/LambdaHack/Client/LoopM.hs b/engine-src/Game/LambdaHack/Client/LoopM.hs --- a/engine-src/Game/LambdaHack/Client/LoopM.hs +++ b/engine-src/Game/LambdaHack/Client/LoopM.hs @@ -25,10 +25,6 @@ import Game.LambdaHack.Client.Response import Game.LambdaHack.Client.State import Game.LambdaHack.Client.UI -import Game.LambdaHack.Client.UI.MonadClientUI -import Game.LambdaHack.Client.UI.Msg -import Game.LambdaHack.Client.UI.MsgM -import Game.LambdaHack.Client.UI.SessionUI import Game.LambdaHack.Common.ClientOptions import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.MonadStateRead @@ -65,65 +61,81 @@ , MonadClientAtomic m , MonadClientReadResponse m , MonadClientWriteRequest m ) - => CCUI -> UIOptions -> ClientOptions -> m () -loopCli ccui sUIOptions clientOptions = do + => CCUI -> UIOptions -> ClientOptions -> Bool -> m () +loopCli ccui sUIOptions clientOptions startsNewGame = do modifyClient $ \cli -> cli {soptions = clientOptions} side <- getsClient sside hasUI <- clientHasUI if not hasUI then initAI else initUI ccui let cliendKindText = if not hasUI then "AI" else "UI" debugPossiblyPrint $ cliendKindText <+> "client" - <+> tshow side <+> "started 1/4." + <+> tshow side <+> "starting 1/4." -- Warning: state and client state are invalid here, e.g., sdungeon -- and sper are empty. - restoredG <- tryRestore - restored <- case restoredG of - Just (cli, msess) | not $ snewGameCli clientOptions -> do - -- Restore game. - schanF <- getsSession schanF - sccui <- getsSession sccui - maybe (return ()) (\sess -> modifySession $ const - sess {schanF, sccui, sUIOptions}) msess - let noAnim = fromMaybe False $ snoAnim $ soptions cli - putClient cli {soptions = clientOptions {snoAnim = Just noAnim}} - return True - Just (_, msessR) -> do - -- Preserve previous history, if any. - maybe (return ()) (\sessR -> modifySession $ \sess -> - sess {shistory = shistory sessR}) msessR - return False - _ -> return False + restored <- + if startsNewGame && not hasUI + then return False + else do + restoredG <- tryRestore + case restoredG of + Just (cli, msess)-> do + -- Restore game. + case msess of + Just sess | hasUI -> do + -- Preserve almost everything from the saved session. + -- Renew the communication channel to the newly spawned frontend + -- and get the possibly updated UI content and UI options. + schanF <- getsSession schanF + sccui <- getsSession sccui + putSession $ sess {schanF, sccui, sUIOptions} + _ -> return () + if startsNewGame then + -- Don't restore client state, due to new game starting right now, + -- which means everything will be overwritten soon anyway + -- via an @UpdRestart@ command (instead of @UpdResume@). + return False + else do + -- We preserve the client state from savefile except for the single + -- option that can be overwritten on commandline. + let noAnim = fromMaybe False $ snoAnim $ soptions cli + putClient cli {soptions = clientOptions {snoAnim = Just noAnim}} + return True + Nothing -> return False debugPossiblyPrint $ cliendKindText <+> "client" - <+> tshow side <+> "started 2/4." + <+> tshow side <+> "starting 2/4." -- At this point @ClientState@ not overriten dumbly and @State@ valid. tabA <- createTabBFS tabB <- createTabBFS modifyClient $ \cli -> cli {stabs = (tabA, tabB)} cmd1 <- receiveResponse debugPossiblyPrint $ cliendKindText <+> "client" - <+> tshow side <+> "started 3/4." - case (restored, cmd1) of - (True, RespUpdAtomic _ UpdResume{}) -> return () - (True, RespUpdAtomic _ UpdRestart{}) -> + <+> tshow side <+> "starting 3/4." + case (restored, startsNewGame, cmd1) of + (True, False, RespUpdAtomic _ UpdResume{}) -> + return () + (True, True, RespUpdAtomic _ UpdRestart{}) -> when hasUI $ clientPrintUI "Ignoring an old savefile and starting a new game." - (False, RespUpdAtomic _ UpdResume{}) -> + (False, False, RespUpdAtomic _ UpdResume{}) -> error $ "Savefile of client " ++ show side ++ " not usable." `showFailure` () - (False, RespUpdAtomic _ UpdRestart{}) -> return () - (True, RespUpdAtomicNoState UpdResume{}) -> undefined - (True, RespUpdAtomicNoState UpdRestart{}) -> + (False, True, RespUpdAtomic _ UpdRestart{}) -> + return () + (True, False, RespUpdAtomicNoState UpdResume{}) -> + undefined + (True, True, RespUpdAtomicNoState UpdRestart{}) -> when hasUI $ clientPrintUI "Ignoring an old savefile and starting a new game." - (False, RespUpdAtomicNoState UpdResume{}) -> + (False, False, RespUpdAtomicNoState UpdResume{}) -> error $ "Savefile of client " ++ show side ++ " not usable." `showFailure` () - (False, RespUpdAtomicNoState UpdRestart{}) -> return () + (False, True, RespUpdAtomicNoState UpdRestart{}) -> + return () _ -> error $ "unexpected command" `showFailure` (side, restored, cmd1) handleResponse cmd1 -- State and client state now valid. debugPossiblyPrint $ cliendKindText <+> "client" - <+> tshow side <+> "started 4/4." + <+> tshow side <+> "starting 4/4." if hasUI then loopUI 0 else loopAI @@ -197,10 +209,12 @@ -- during the insert coin demo before game is started. side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD - if isAIFact fact then + if gunderAI fact then -- Mark for immediate control regain from AI. modifySession $ \sess -> sess {sregainControl = True} else do -- should work fine even if UI faction has no leader ATM + -- The keys mashed to make UI accessible are not considered a command. + resetPressedKeys -- Stop displaying the prompt, if any, but keep UI simple. modifySession $ \sess -> sess {sreqDelay = ReqDelayHandled} let msg = if isNothing sreqPending @@ -208,6 +222,8 @@ else "Server delayed receiving a command from us. The command is cancelled. Issue a new one." msgAdd MsgActionAlert msg mreqNew <- queryUI + msgAdd MsgPromptGeneric "Your client is listening to the server again." + pushReportFrame -- TODO: once this is really used, verify that if a request -- overwritten, nothing breaks due to some things in our ClientState -- and SessionUI (but fortunately not in State nor ServerState) @@ -215,10 +231,10 @@ modifySession $ \sess -> sess {sreqPending = mreqNew} -- Now relax completely. modifySession $ \sess -> sess {sreqDelay = ReqDelayNot} - -- We may yet not know if server is ready, but perhaps server - -- tried hard to contact us while we took control and now it sleeps - -- for a bit, so let's give it the benefit of the doubt - -- and a slight pause before we alarm the player again. + -- We may yet not know if server is ready, but perhaps server + -- tried hard to contact us while we took control and now it sleeps + -- for a bit, so let's give it the benefit of the doubt + -- and a slight pause before we alarm the player again. loopUI 0 | otherwise -> do -- We know server is not ready. diff --git a/engine-src/Game/LambdaHack/Client/MonadClient.hs b/engine-src/Game/LambdaHack/Client/MonadClient.hs --- a/engine-src/Game/LambdaHack/Client/MonadClient.hs +++ b/engine-src/Game/LambdaHack/Client/MonadClient.hs @@ -15,11 +15,13 @@ import Game.LambdaHack.Core.Prelude +import qualified Control.Exception as Ex import Control.Monad.ST.Strict (stToIO) import qualified Control.Monad.Trans.State.Strict as St import qualified Data.EnumSet as ES import qualified Data.Primitive.PrimArray as PA import qualified Data.Text.IO as T +import System.Directory import System.FilePath import System.IO (hFlush, stdout) @@ -72,7 +74,9 @@ dataDir <- appDataDir tryCreateDir dataDir let path = dataDir filename - T.writeFile path t + Ex.handle (\(_ :: Ex.IOException) -> return ()) $ + removeFile path + tryWriteFile path t return path -- | Invoke pseudo-random computation with the generator kept in the state. diff --git a/engine-src/Game/LambdaHack/Client/Preferences.hs b/engine-src/Game/LambdaHack/Client/Preferences.hs --- a/engine-src/Game/LambdaHack/Client/Preferences.hs +++ b/engine-src/Game/LambdaHack/Client/Preferences.hs @@ -23,9 +23,9 @@ import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Types +import Game.LambdaHack.Content.FactionKind import Game.LambdaHack.Content.ItemKind (ItemKind) import qualified Game.LambdaHack.Content.ItemKind as IK -import Game.LambdaHack.Content.ModeKind import qualified Game.LambdaHack.Core.Dice as Dice import qualified Game.LambdaHack.Definition.Ability as Ability import Game.LambdaHack.Definition.Defs @@ -99,7 +99,8 @@ fact = factionD EM.! fid friendlyHasGrp fid2 = isFriend fid fact fid2 - && grp `elem` fgroups (gplayer $ factionD EM.! fid2) + && fromMaybe 0 (lookup grp $ fgroups $ gkind $ factionD EM.! fid2) + > 0 in -- Prefer applying summoning items to flinging them; the actor gets -- spawned further from foes, but it's more robust. if any friendlyHasGrp $ EM.keys factionD diff --git a/engine-src/Game/LambdaHack/Client/State.hs b/engine-src/Game/LambdaHack/Client/State.hs --- a/engine-src/Game/LambdaHack/Client/State.hs +++ b/engine-src/Game/LambdaHack/Client/State.hs @@ -14,7 +14,6 @@ import Data.Binary import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES -import qualified Data.Map.Strict as M import qualified Data.Primitive.PrimArray as PA import GHC.Generics (Generic) import qualified System.Random.SplitMix32 as SM @@ -32,8 +31,6 @@ import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Types import Game.LambdaHack.Common.Vector -import Game.LambdaHack.Content.ModeKind (ModeKind) -import Game.LambdaHack.Definition.Defs -- | Client state, belonging to a single faction. data StateClient = StateClient @@ -61,22 +58,24 @@ -- Faction.gleader is the old leader , _sside :: FactionId -- ^ faction controlled by the client , squit :: Bool -- ^ exit the game loop - , scurChal :: Challenge -- ^ current game challenge setup - , snxtChal :: Challenge -- ^ next game challenge setup - , smarkSuspect :: Int -- ^ whether to mark suspect features , scondInMelee :: ES.EnumSet LevelId -- ^ whether we are in melee, per level - , svictories :: EM.EnumMap (ContentId ModeKind) (M.Map Challenge Int) - -- ^ won games at particular difficulty lvls - , scampings :: ES.EnumSet (ContentId ModeKind) -- ^ camped games - , srestarts :: ES.EnumSet (ContentId ModeKind) -- ^ restarted games , soptions :: ClientOptions -- ^ client options , stabs :: (PA.PrimArray PointI, PA.PrimArray PointI) -- ^ Instead of a BFS queue (list) we use these two arrays, -- for (JS) speed. They need to be per-client distinct, -- because sometimes multiple clients interleave BFS computation. + + -- The three fields below only make sense for the UI faction, + -- but can't be in SessionUI, because AI-moved actors of the UI faction + -- require them for their action. Fortunately, being in StateClient + -- of the UI client, these are never lost, even when a different faction + -- becomes the UI faction. + , scurChal :: Challenge -- ^ current game challenge setup + , snxtChal :: Challenge -- ^ next game challenge setup + , smarkSuspect :: Int -- ^ whether to mark suspect features } - deriving Show + -- No @Show@ instance, because @stabs@ start undefined. type AlterLid = EM.EnumMap LevelId (PointArray.Array Word8) @@ -139,20 +138,18 @@ , _sleader = Nothing -- no heroes yet alive , _sside , squit = False - , scurChal = defaultChallenge - , snxtChal = defaultChallenge - , smarkSuspect = 1 , scondInMelee = ES.empty - , svictories = EM.empty - , scampings = ES.empty - , srestarts = ES.empty , soptions = defClientOptions , stabs = (undefined, undefined) + , scurChal = defaultChallenge + , snxtChal = defaultChallenge + , smarkSuspect = 1 } -- | Cycle the 'smarkSuspect' setting. -cycleMarkSuspect :: StateClient -> StateClient -cycleMarkSuspect cli = cli {smarkSuspect = succ (smarkSuspect cli) `mod` 3} +cycleMarkSuspect :: Int -> StateClient -> StateClient +cycleMarkSuspect delta cli = + cli {smarkSuspect = (smarkSuspect cli + delta) `mod` 3} -- | Update target parameters within client state. updateTarget :: ActorId -> (Maybe Target -> Maybe Target) -> StateClient @@ -192,14 +189,11 @@ put (show srandom) put _sleader put _sside + put scondInMelee + put soptions put scurChal put snxtChal put smarkSuspect - put scondInMelee - put svictories - put scampings - put srestarts - put soptions #ifdef WITH_EXPENSIVE_ASSERTIONS put sfper #endif @@ -212,14 +206,11 @@ g <- get _sleader <- get _sside <- get + scondInMelee <- get + soptions <- get scurChal <- get snxtChal <- get smarkSuspect <- get - scondInMelee <- get - svictories <- get - scampings <- get - srestarts <- get - soptions <- get let sbfsD = EM.empty sundo = () salter = EM.empty diff --git a/engine-src/Game/LambdaHack/Client/UI.hs b/engine-src/Game/LambdaHack/Client/UI.hs --- a/engine-src/Game/LambdaHack/Client/UI.hs +++ b/engine-src/Game/LambdaHack/Client/UI.hs @@ -1,18 +1,27 @@ -- | Ways for the client to use player input via UI to produce server -- requests, based on the client's view (visualized for the player) -- of the game state. +-- +-- This module is leaking quite a bit of implementation details +-- for the sake of "Game.LambdaHack.Client.LoopM". After multiplayer +-- is enabled again and the new requirements sorted out, this should be +-- redesigned and some code moved down the module hierarhy tree, +-- exposing a smaller API here. module Game.LambdaHack.Client.UI ( -- * Querying the human player queryUI, queryUIunderAI - -- * UI monad and session type - , MonadClientUI(..), SessionUI(..) + -- * UI monad operations + , MonadClientUI(..), putSession, anyKeyPressed, resetPressedKeys + -- * UI session type + , SessionUI(..), ReqDelay(..), emptySessionUI -- * Updating UI state wrt game state changes , watchRespUpdAtomicUI, watchRespSfxAtomicUI -- * Startup and initialization , CCUI(..) , UIOptions, applyUIOptions, uOverrideCmdline, mkUIOptions - -- * Operations exposed for "Game.LambdaHack.Client.LoopM" + -- * Assorted operations and types , ChanFrontend, chanFrontend, tryRestore, clientPrintUI + , pushReportFrame, msgAdd, MsgClassShow(..) #ifdef EXPOSE_INTERNAL -- * Internal operations , stepQueryUIwithLeader, stepQueryUI @@ -55,7 +64,7 @@ import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.State -import Game.LambdaHack.Content.ModeKind +import Game.LambdaHack.Content.FactionKind -- | Handle the move of a human player. queryUI :: (MonadClient m, MonadClientUI m) => m (Maybe RequestUI) diff --git a/engine-src/Game/LambdaHack/Client/UI/Animation.hs b/engine-src/Game/LambdaHack/Client/UI/Animation.hs --- a/engine-src/Game/LambdaHack/Client/UI/Animation.hs +++ b/engine-src/Game/LambdaHack/Client/UI/Animation.hs @@ -39,10 +39,10 @@ let modifyFrame :: OverlaySpace -> PreFrame -- Overlay not truncated, because guaranteed within bounds. modifyFrame am = overlayFrame width am basicFrame - modifyFrames :: (OverlaySpace, OverlaySpace) -> Maybe PreFrame - modifyFrames (am, amPrevious) = + modifyFrames :: OverlaySpace -> OverlaySpace -> Maybe PreFrame + modifyFrames am amPrevious = if am == amPrevious then Nothing else Just $ modifyFrame am - in Just basicFrame : map modifyFrames (zip anim ([] : anim)) + in Just basicFrame : zipWith modifyFrames anim ([] : anim) blank :: Maybe AttrCharW32 blank = Nothing diff --git a/engine-src/Game/LambdaHack/Client/UI/Content/Input.hs b/engine-src/Game/LambdaHack/Client/UI/Content/Input.hs --- a/engine-src/Game/LambdaHack/Client/UI/Content/Input.hs +++ b/engine-src/Game/LambdaHack/Client/UI/Content/Input.hs @@ -78,6 +78,8 @@ `swith` rawContent \\ filteredNoMovement bcmdList = rawContent ++ movementDefinitions -- This catches repetitions (usually) not involving movement keys. + rejectRepetitions _ t1 (_, "", _) = t1 + rejectRepetitions _ (_, "", _) t2 = t2 rejectRepetitions k t1 t2 = error $ "duplicate key among command definitions (you can instead disable some movement key sets in config file and overwrite the freed keys)" `showFailure` (k, t1, t2) in InputContent @@ -87,7 +89,7 @@ [ [(cmd, [k])] | (k, (cats, _desc, cmd)) <- bcmdList , not (null cats) - && all (/= CmdDebug) cats + && CmdDebug `notElem` cats ] } @@ -146,7 +148,7 @@ , (CaArenaName, Accept) , (CaPercentSeen, XhairStair True) ] } common = - [ (CaMessage, LastHistory) + [ (CaMessage, AllHistory) , (CaLevelNumber, AimAscend 1) , (CaXhairDesc, AimEnemy) -- inits aiming and then cycles enemies , (CaSelected, PickLeaderWithPointer) diff --git a/engine-src/Game/LambdaHack/Client/UI/Content/Screen.hs b/engine-src/Game/LambdaHack/Client/UI/Content/Screen.hs --- a/engine-src/Game/LambdaHack/Client/UI/Content/Screen.hs +++ b/engine-src/Game/LambdaHack/Client/UI/Content/Screen.hs @@ -1,9 +1,9 @@ -- | The type of definitions of screen layout and features. module Game.LambdaHack.Client.UI.Content.Screen - ( ScreenContent(..), makeData + ( ScreenContent(..), emptyScreenContent, makeData #ifdef EXPOSE_INTERNAL -- * Internal operations - , validateSingle + , emptyScreenContentRaw, validateSingle #endif ) where @@ -15,10 +15,18 @@ import qualified Data.EnumMap.Strict as EM import qualified Data.Text as T -import Game.LambdaHack.Content.ItemKind (ItemKind) -import Game.LambdaHack.Definition.Defs +import Game.LambdaHack.Content.ItemKind (ItemKind) +import qualified Game.LambdaHack.Content.RuleKind as RK +import Game.LambdaHack.Definition.Defs -- | Screen layout and features definition. +-- +-- Warning: this type is not abstract, but its values should not be +-- created ad hoc, even for unit tests, but should be constructed +-- with @makeData@, which includes validation, +-- +-- The @emptyScreenContent@ is one such valid by construction value +-- of this type. It's suitable for bootstrapping and for testing. data ScreenContent = ScreenContent { rwidth :: X -- ^ screen width , rheight :: Y -- ^ screen height @@ -32,9 +40,23 @@ -- ^ embedded game-supplied font files } +emptyScreenContentRaw :: ScreenContent +emptyScreenContentRaw = ScreenContent { rwidth = 5 + , rheight = 5 + , rwebAddress = "" + , rintroScreen = ([], []) + , rapplyVerbMap = EM.empty + , rFontFiles = [] + } + +emptyScreenContent :: ScreenContent +emptyScreenContent = + assert (null $ validateSingle RK.emptyRuleContent emptyScreenContentRaw) + emptyScreenContentRaw + -- | Catch invalid rule kind definitions. -validateSingle :: ScreenContent -> [Text] -validateSingle ScreenContent{rwebAddress, rintroScreen} = +validateSingle :: RK.RuleContent -> ScreenContent -> [Text] +validateSingle corule ScreenContent{..} = (let tsGt80 = filter ((> 80) . T.length) $ map T.pack [rwebAddress] in case tsGt80 of [] -> [] @@ -48,11 +70,14 @@ in case tsGt80 of [] -> [] tGt80 : _ -> ["manual has a line with length over 80:" <> tGt80]) + -- The following reflect the only current UI implementation. + ++ [ "rwidth /= RK.rWidthMax" | rwidth /= RK.rWidthMax corule ] + ++ [ "rheight /= RK.rHeightMax + 3" | rheight /= RK.rHeightMax corule + 3] -makeData :: ScreenContent -> ScreenContent -makeData sc = - let singleOffenders = validateSingle sc +makeData :: RK.RuleContent -> ScreenContent -> ScreenContent +makeData corule sc = + let singleOffenders = validateSingle corule sc in assert (null singleOffenders - `blame` "Screen Content" ++ ": some content items not valid" + `blame` "Screen Content not valid" `swith` singleOffenders) sc diff --git a/engine-src/Game/LambdaHack/Client/UI/ContentClientUI.hs b/engine-src/Game/LambdaHack/Client/UI/ContentClientUI.hs --- a/engine-src/Game/LambdaHack/Client/UI/ContentClientUI.hs +++ b/engine-src/Game/LambdaHack/Client/UI/ContentClientUI.hs @@ -5,13 +5,12 @@ import Prelude () -import qualified Data.EnumMap.Strict as EM import qualified Data.Map.Strict as M import Game.LambdaHack.Client.UI.Content.Input import Game.LambdaHack.Client.UI.Content.Screen --- | Operations for all content types, gathered together. +-- | Operations for all UI content types, gathered together. data CCUI = CCUI { coinput :: InputContent , coscreen :: ScreenContent @@ -20,11 +19,5 @@ emptyCCUI :: CCUI emptyCCUI = CCUI { coinput = InputContent M.empty [] M.empty - , coscreen = ScreenContent { rwidth = 0 - , rheight = 0 - , rwebAddress = "" - , rintroScreen = ([], []) - , rapplyVerbMap = EM.empty - , rFontFiles = [] - } + , coscreen = emptyScreenContent } diff --git a/engine-src/Game/LambdaHack/Client/UI/DrawM.hs b/engine-src/Game/LambdaHack/Client/UI/DrawM.hs --- a/engine-src/Game/LambdaHack/Client/UI/DrawM.hs +++ b/engine-src/Game/LambdaHack/Client/UI/DrawM.hs @@ -38,6 +38,7 @@ import Game.LambdaHack.Client.UI.ActorUI import Game.LambdaHack.Client.UI.Content.Screen import Game.LambdaHack.Client.UI.ContentClientUI +import Game.LambdaHack.Client.UI.EffectDescription import Game.LambdaHack.Client.UI.Frame import Game.LambdaHack.Client.UI.Frontend (frontendName) import Game.LambdaHack.Client.UI.ItemDescription @@ -63,8 +64,8 @@ import Game.LambdaHack.Common.Types import Game.LambdaHack.Common.Vector import Game.LambdaHack.Content.CaveKind (cname) +import qualified Game.LambdaHack.Content.FactionKind as FK import qualified Game.LambdaHack.Content.ItemKind as IK -import qualified Game.LambdaHack.Content.ModeKind as MK import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Content.TileKind (TileKind, isUknownSpace) import qualified Game.LambdaHack.Content.TileKind as TK @@ -224,75 +225,82 @@ $ IM.assocs $ EM.enumMapToIntMap lsmell) v return upd -drawFramePath :: forall m. MonadClientUI m => LevelId -> m FrameForall +drawFramePath :: forall m. MonadClientUI m + => LevelId -> m (FrameForall, FrameForall) drawFramePath drawnLevelId = do SessionUI{saimMode} <- getSession sreportNull <- getsSession sreportNull - if isNothing saimMode || sreportNull - then return $! FrameForall $ \_ -> return () - else do - COps{corule=RuleContent{rWidthMax, rHeightMax}, coTileSpeedup} - <- getsState scops - StateClient{seps} <- getClient - -- Not @ScreenContent@, because pathing in level's map. - Level{ltile=PointArray.Array{avector}} <- getLevel drawnLevelId - totVisible <- totalVisible <$> getPerFid drawnLevelId - mleader <- getsClient sleader - xhairPos <- xhairToPos - bline <- case mleader of - Just leader -> do - Actor{bpos, blid} <- getsState $ getActorBody leader - return $! if blid /= drawnLevelId - then [] - else fromMaybe [] $ bla seps bpos xhairPos - _ -> return [] - mpath <- maybe (return Nothing) (\aid -> do - mtgtMPath <- getsClient $ EM.lookup aid . stargetD - case mtgtMPath of - Just TgtAndPath{tapPath=tapPath@(Just AndPath{pathGoal})} - | pathGoal == xhairPos -> return tapPath - _ -> getCachePath aid xhairPos) mleader - assocsAtxhair <- getsState $ posToAidAssocs xhairPos drawnLevelId - let lpath = delete xhairPos - $ if null bline then [] else maybe [] pathList mpath - shiftedBTrajectory = case assocsAtxhair of - (_, Actor{btrajectory = Just p, bpos = prPos}) : _-> - trajectoryToPath prPos (fst p) - _ -> [] - shiftedLine = delete xhairPos - $ takeWhile (insideP (0, 0, rWidthMax - 1, rHeightMax - 1)) - $ if null shiftedBTrajectory - then bline - else shiftedBTrajectory - acOnPathOrLine :: Char -> Point -> ContentId TileKind - -> Color.AttrCharW32 - acOnPathOrLine !ch !p0 !tile = - let fgOnPathOrLine = - case ( ES.member p0 totVisible - , Tile.isWalkable coTileSpeedup tile ) of - _ | isUknownSpace tile -> Color.BrBlack - _ | Tile.isSuspect coTileSpeedup tile -> Color.BrMagenta - (True, True) -> Color.BrGreen - (True, False) -> Color.BrRed - (False, True) -> Color.Green - (False, False) -> Color.Red - in Color.attrChar2ToW32 fgOnPathOrLine ch - mapVTL :: forall s. (Point -> ContentId TileKind -> Color.AttrCharW32) - -> [Point] - -> FrameST s - mapVTL f l v = do - let g :: Point -> ST s () - g !p0 = do - let pI = fromEnum p0 - tile = avector U.! pI - w = Color.attrCharW32 $ f p0 (DefsInternal.toContentId tile) - VM.write v (pI + rWidthMax) w - mapM_ g l - upd :: FrameForall - upd = FrameForall $ \v -> do - mapVTL (acOnPathOrLine ';') lpath v - mapVTL (acOnPathOrLine '*') shiftedLine v -- overwrites path - return upd + let frameForallId = FrameForall $ const $ return () + case saimMode of + Just AimMode{detailLevel} | not sreportNull -> do + COps{corule=RuleContent{rWidthMax, rHeightMax}, coTileSpeedup} + <- getsState scops + StateClient{seps} <- getClient + -- Not @ScreenContent@, because pathing in level's map. + Level{ltile=PointArray.Array{avector}} <- getLevel drawnLevelId + totVisible <- totalVisible <$> getPerFid drawnLevelId + mleader <- getsClient sleader + xhairPos <- xhairToPos + bline <- case mleader of + Just leader -> do + Actor{bpos, blid} <- getsState $ getActorBody leader + return $! if blid /= drawnLevelId + then [] + else fromMaybe [] + $ bresenhamsLineAlgorithm seps bpos xhairPos + _ -> return [] + mpath <- maybe (return Nothing) (\aid -> do + mtgtMPath <- getsClient $ EM.lookup aid . stargetD + case mtgtMPath of + Just TgtAndPath{tapPath=tapPath@(Just AndPath{pathGoal})} + | pathGoal == xhairPos -> return tapPath + _ -> getCachePath aid xhairPos) mleader + assocsAtxhair <- getsState $ posToAidAssocs xhairPos drawnLevelId + let shiftedBTrajectory = case assocsAtxhair of + (_, Actor{btrajectory = Just p, bpos = prPos}) : _ + | detailLevel == defaultDetailLevel -> + trajectoryToPath prPos (fst p) + _ -> [] + shiftedLine = + delete xhairPos + $ takeWhile (insideP (0, 0, rWidthMax - 1, rHeightMax - 1)) + $ if null shiftedBTrajectory + then bline + else shiftedBTrajectory + lpath = if not (null bline) && null shiftedBTrajectory + then delete xhairPos $ maybe [] pathList mpath + else [] + acOnPathOrLine :: Char -> Point -> ContentId TileKind + -> Color.AttrCharW32 + acOnPathOrLine !ch !p0 !tile = + let fgOnPathOrLine = + case ( ES.member p0 totVisible + , Tile.isWalkable coTileSpeedup tile ) of + _ | isUknownSpace tile -> Color.BrBlack + _ | Tile.isSuspect coTileSpeedup tile -> Color.BrMagenta + (True, True) -> Color.BrGreen + (True, False) -> Color.BrRed + (False, True) -> Color.Green + (False, False) -> Color.Red + in Color.attrChar2ToW32 fgOnPathOrLine ch + mapVTL :: forall s. (Point -> ContentId TileKind -> Color.AttrCharW32) + -> [Point] + -> FrameST s + mapVTL f l v = do + let g :: Point -> ST s () + g !p0 = do + let pI = fromEnum p0 + tile = avector U.! pI + w = Color.attrCharW32 + $ f p0 (DefsInternal.toContentId tile) + VM.write v (pI + rWidthMax) w + mapM_ g l + upd :: FrameForall + upd = FrameForall $ \v -> do + mapVTL (acOnPathOrLine ';') lpath v + mapVTL (acOnPathOrLine '*') shiftedLine v -- overwrites path + return (upd, if null shiftedBTrajectory then frameForallId else upd) + _ -> return (frameForallId, frameForallId) drawFrameActor :: forall m. MonadClientUI m => LevelId -> m FrameForall drawFrameActor drawnLevelId = do @@ -300,9 +308,7 @@ SessionUI{sactorUI, sselected, sUIOptions} <- getSession -- Not @ScreenContent@, because indexing in level's data. Level{lbig, lproj} <- getLevel drawnLevelId - SessionUI{saimMode} <- getSession side <- getsClient sside - mleader <- getsClient sleader s <- getState let {-# INLINE viewBig #-} viewBig aid = @@ -312,11 +318,7 @@ symbol | bhp > 0 = bsymbol | otherwise = '%' dominated = maybe False (/= bfid) jfid - leaderColor = if isJust saimMode - then Color.HighlightYellowAim - else Color.HighlightYellow - bg = if | mleader == Just aid -> leaderColor - | bwatch == WSleep -> Color.HighlightBlue + bg = if | bwatch == WSleep -> Color.HighlightBlue | dominated -> if bfid == side -- dominated by us then Color.HighlightCyan else Color.HighlightBrown @@ -357,13 +359,14 @@ drawFrameExtra :: forall m. MonadClientUI m => ColorMode -> LevelId -> m FrameForall drawFrameExtra dm drawnLevelId = do + -- Not @ScreenContent@, because indexing in level's data. COps{corule=RuleContent{rWidthMax, rHeightMax}} <- getsState scops SessionUI{saimMode, smarkVision} <- getSession - -- Not @ScreenContent@, because indexing in level's data. + mleader <- getsClient sleader + mbody <- getsState $ \s -> flip getActorBody s <$> mleader totVisible <- totalVisible <$> getPerFid drawnLevelId mxhairPos <- mxhairToPos mtgtPos <- do - mleader <- getsClient sleader mtgt <- getsClient $ maybe (const Nothing) getTarget mleader getsState $ aidTgtToPos mleader drawnLevelId mtgt side <- getsClient sside @@ -392,6 +395,9 @@ -- Here @rWidthMax@ and @rHeightMax@ are correct, because we are not -- turning the whole screen into black&white, but only the level map. lDungeon = [0..rWidthMax * rHeightMax - 1] + leaderColor = if isJust saimMode + then Color.HighlightYellowAim + else Color.HighlightYellow xhairColor = if isJust saimMode then Color.HighlightRedAim else Color.HighlightRed @@ -412,7 +418,11 @@ Just p -> mapVL (writeSquare Color.HighlightGrey) [fromEnum p] v mapM_ (\(pos, color) -> mapVL (writeSquare color) [fromEnum pos] v) stashesToDisplay - case mxhairPos of -- overwrites target + case mbody of -- overwrites target + Just body | drawnLevelId == blid body -> + mapVL (writeSquare leaderColor) [fromEnum $ bpos body] v + _ -> return () + case mxhairPos of -- overwrites target and non-aim leader box Nothing -> return () Just p -> mapVL (writeSquare xhairColor) [fromEnum p] v when (dm == ColorBW) $ mapVL turnBW lDungeon v @@ -424,7 +434,7 @@ SessionUI{sselected, saimMode, swaitTimes, sitemSel} <- getSession mleader <- getsClient sleader mxhairPos <- mxhairToPos - mbfs <- maybe (return Nothing) (\aid -> Just <$> getCacheBfs aid) mleader + mbfs <- maybe (return Nothing) (fmap Just . getCacheBfs) mleader (mhairDesc, mxhairHP, mxhairWatchfulness) <- targetDescXhair lvl <- getLevel drawnLevelId side <- getsClient sside @@ -482,10 +492,10 @@ -- The indicators must fit, they are the actual information. widthXhairOrItem = widthTgt - T.length pathCsr nMember = MU.Ord $ 1 + sum (EM.elems $ gvictims fact) - fallback = if MK.fleaderMode (gplayer fact) == Nothing - then "This faction never picks a pointman" - else makePhrase + fallback = if FK.fhasPointman (gkind fact) + then makePhrase ["Waiting for", nMember, "team member to spawn"] + else "This faction never picks a pointman" leaderName bUI = trimTgtDesc (widthTgt - 10) (bname bUI) leaderBlurbLong = maybe fallback (\bUI -> "Pointman:" <+> leaderName bUI) mbodyUI @@ -575,7 +585,7 @@ drawHudFrame dm drawnLevelId = do baseTerrain <- drawFrameTerrain drawnLevelId updContent <- drawFrameContent drawnLevelId - updPath <- drawFramePath drawnLevelId + (updPath, updTrajectory) <- drawFramePath drawnLevelId updActor <- drawFrameActor drawnLevelId updExtra <- drawFrameExtra dm drawnLevelId soptions <- getsClient soptions @@ -584,6 +594,7 @@ -- ANSI frontend is screen-reader friendly, so avoid visual fluff unless (frontendName soptions == "ANSI") $ unFrameForall updPath v unFrameForall updActor v + unFrameForall updTrajectory v unFrameForall updExtra v return (baseTerrain, upd) @@ -761,7 +772,7 @@ -- but often it's the player's mistake, so show them anyway showStrongest showInBrief l = let lToDisplay = concatMap (ppDice showInBrief) l - (ldischarged, lrest) = span (not . fst) lToDisplay + (ldischarged, lrest) = break fst lToDisplay lWithBonus = case map snd lrest of [] -> [] -- no timeout-free organ, e.g., rattlesnake or hornet (ldmg, lextra) : rest -> (ldmg ++ lbonus, lextra) : rest diff --git a/engine-src/Game/LambdaHack/Client/UI/EffectDescription.hs b/engine-src/Game/LambdaHack/Client/UI/EffectDescription.hs --- a/engine-src/Game/LambdaHack/Client/UI/EffectDescription.hs +++ b/engine-src/Game/LambdaHack/Client/UI/EffectDescription.hs @@ -3,7 +3,7 @@ module Game.LambdaHack.Client.UI.EffectDescription ( DetailLevel(..), defaultDetailLevel , effectToSuffix, detectToObject, detectToVerb - , skillName, skillDesc, skillToDecorator, skillSlots + , skillName, skillDesc, skillToDecorator, skillsInDisplayOrder , kindAspectToSuffix, aspectToSentence, affixDice , describeToolsAlternative, describeCrafting, wrapInParens #ifdef EXPOSE_INTERNAL @@ -194,20 +194,21 @@ object2 = effectToSuffix detailLevel eff in if T.null object2 then "" -- no 'conditional processing' --- probably a hack - else "when" <+> object <+> "then" <+> object2 + else "(when" <+> object <+> "then" <+> object2 <> ")" Unless cond eff -> let object = conditionToObject cond object2 = effectToSuffix detailLevel eff in if T.null object2 then "" - else "unless" <+> object <+> "then" <+> object2 + else "(unless" <+> object <+> "then" <+> object2 <> ")" IfThenElse cond eff1 eff2 -> let object = conditionToObject cond object1 = effectToSuffix detailLevel eff1 object2 = effectToSuffix detailLevel eff2 in if T.null object1 && T.null object2 then "" - else "if" <+> object <+> "then" <+> object1 <+> "else" <+> object2 + else "(if" <+> object <+> "then" <+> object1 + <+> "else" <+> object2 <> ")" VerbNoLonger{} -> "" -- no description for a flavour effect VerbMsg{} -> "" -- no description for an effect that prints a description VerbMsgFail{} -> "" @@ -402,8 +403,8 @@ SkDeflectRanged -> tshow t SkDeflectMelee -> tshow t -skillSlots :: [Skill] -skillSlots = [minBound .. maxBound] +skillsInDisplayOrder :: [Skill] +skillsInDisplayOrder = [minBound .. maxBound] tmodToSuff :: Text -> ThrowMod -> Text tmodToSuff verb ThrowMod{..} = @@ -488,7 +489,7 @@ SetFlag Blast -> Nothing SetFlag Condition -> Nothing SetFlag Unique -> Just "It is one of a kind." - SetFlag MetaGame -> Just "It's characteristic to a person and easy to recognize once learned, even under very different circumstances." + SetFlag MetaGame -> Just "It's so characteristic that it's recognizable every time after being identified once, even under very different circumstances." SetFlag MinorEffects -> Nothing SetFlag MinorAspects -> Nothing SetFlag Meleeable -> Just "It is considered for melee strikes." diff --git a/engine-src/Game/LambdaHack/Client/UI/FrameM.hs b/engine-src/Game/LambdaHack/Client/UI/FrameM.hs --- a/engine-src/Game/LambdaHack/Client/UI/FrameM.hs +++ b/engine-src/Game/LambdaHack/Client/UI/FrameM.hs @@ -109,14 +109,16 @@ lidV <- viewedLevelUI report <- getsSession $ newReport . shistory sreqQueried <- getsSession sreqQueried + macroFrame <- getsSession smacroFrame let interrupted = -- If server is not querying for request, then the key is needed due to -- a special event, not ordinary querying the player for command, -- so interrupt. not sreqQueried - -- Any alarming message interupts macros. - || anyInReport disturbsResting report - macroFrame <- getsSession smacroFrame + -- Any alarming message interupts macros, except when the macro + -- displays help and ends, which is a helpful thing to do. + || (anyInReport disturbsResting report + && keyPending macroFrame /= KeyMacro [K.mkKM "F1"]) km <- case keyPending macroFrame of KeyMacro (km : kms) | not interrupted -- A faulty key in a macro is a good reason @@ -139,7 +141,7 @@ -- This marks a special event, regardless of @sreqQueried@. side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD - unless (isAIFact fact) -- don't forget special autoplay keypresses + unless (gunderAI fact) -- don't forget special autoplay keypresses -- Forget the furious keypresses just before a special event. resetPressedKeys -- Running, if any, must have ended naturally, because no macro. @@ -237,10 +239,9 @@ fact <- getsState $ (EM.! side) . sfactionD report <- getReportUI False let par1 = firstParagraph $ foldr (<+:>) [] $ renderReport True report - underAI = isAIFact fact -- If messages are benchmarked, they can't be displayed under AI, -- because this is not realistic when player is in control. - truncRep | not sbenchMessages && fromMaybe underAI forceReport = + truncRep | not sbenchMessages && fromMaybe (gunderAI fact) forceReport = EM.fromList [(propFont, [(PointUI 0 0, par1)])] | otherwise = EM.empty drawOverlay ColorFull False truncRep arena diff --git a/engine-src/Game/LambdaHack/Client/UI/Frontend/ANSI.hs b/engine-src/Game/LambdaHack/Client/UI/Frontend/ANSI.hs --- a/engine-src/Game/LambdaHack/Client/UI/Frontend/ANSI.hs +++ b/engine-src/Game/LambdaHack/Client/UI/Frontend/ANSI.hs @@ -11,6 +11,7 @@ import Data.Char (chr, ord) import qualified Data.Text as T import qualified System.Console.ANSI as ANSI +import System.Exit (die) import qualified System.IO as SIO import Game.LambdaHack.Client.UI.Content.Screen @@ -32,19 +33,21 @@ -- | Starts the main program loop using the frontend input and output. startup :: ScreenContent -> IO RawFrontend startup coscreen@ScreenContent{rwidth, rheight} = do + ANSI.clearScreen myx <- ANSI.getTerminalSize case myx of Just (y, x) | x < rwidth || y < rheight -> - error $ T.unpack - $ "The terminal is too small. It should have" - <+> tshow rwidth - <+> "columns and" - <+> tshow rheight - <+> "rows, but is has" - <+> tshow x - <+> "columns and" - <+> tshow y - <+> "rows. Resize it and run the program again." + -- Unlike @error@, @die@ does not move savefiles aside. + die $ T.unpack $ + "The terminal is too small. It should have" + <+> tshow rwidth + <+> "columns and" + <+> tshow rheight + <+> "rows, but is has" + <+> tshow x + <+> "columns and" + <+> tshow y + <+> "rows. Resize it and run the program again." _ -> do rf <- createRawFrontend coscreen (display coscreen) (shutdown coscreen) let storeKeys :: IO () diff --git a/engine-src/Game/LambdaHack/Client/UI/Frontend/Dom.hs b/engine-src/Game/LambdaHack/Client/UI/Frontend/Dom.hs --- a/engine-src/Game/LambdaHack/Client/UI/Frontend/Dom.hs +++ b/engine-src/Game/LambdaHack/Client/UI/Frontend/Dom.hs @@ -254,7 +254,7 @@ let Point{..} = toEnum i Color.AttrChar{acAttr=Color.Attr{fg=fgRaw,bg}, acChar} = Color.attrCharFromW32 $ Color.AttrCharW32 w - fg | py `mod` 2 == 0 && fgRaw == Color.White = Color.AltWhite + fg | even py && fgRaw == Color.White = Color.AltWhite | otherwise = fgRaw (!cell, !style) = scharCells V.! i if | acChar == ' ' -> setTextContent cell $ Just ("\x00a0" :: JSString) diff --git a/engine-src/Game/LambdaHack/Client/UI/Frontend/Sdl.hs b/engine-src/Game/LambdaHack/Client/UI/Frontend/Sdl.hs --- a/engine-src/Game/LambdaHack/Client/UI/Frontend/Sdl.hs +++ b/engine-src/Game/LambdaHack/Client/UI/Frontend/Sdl.hs @@ -19,6 +19,7 @@ import qualified Data.Text as T import Data.Time.Clock.POSIX import Data.Time.LocalTime +import qualified Data.Vector.Storable as VS import qualified Data.Vector.Unboxed as U import Data.Word (Word32, Word8) import Foreign.C.String (withCString) @@ -26,7 +27,7 @@ import Foreign.Ptr (nullPtr) import Foreign.Storable (peek) import System.Directory -import System.Exit (exitSuccess) +import System.Exit (die, exitSuccess) import System.FilePath import qualified SDL @@ -35,6 +36,7 @@ import qualified SDL.Internal.Types import qualified SDL.Raw.Basic as SDL (logSetAllPriority) import qualified SDL.Raw.Enum +import qualified SDL.Raw.Event import qualified SDL.Raw.Types import qualified SDL.Raw.Video import qualified SDL.Vect as Vect @@ -53,6 +55,14 @@ import Game.LambdaHack.Content.TileKind (floorSymbol) import qualified Game.LambdaHack.Definition.Color as Color +-- These are needed until SDL is fixed and all our devs move +-- to the fixed version: +import Control.Monad.IO.Class (MonadIO, liftIO) +import SDL.Internal.Exception (throwIfNull) +import qualified SDL.Raw.Event as Raw +import Unsafe.Coerce (unsafeCoerce) +--import qualified SDL.Raw.Enum as Raw + type FontAtlas = EM.EnumMap Color.AttrCharW32 SDL.Texture -- | Session data maintained by the frontend. @@ -96,19 +106,20 @@ TTF.initialize let title = T.pack $ fromJust stitle chosenFontsetID = fromJust schosenFontset - chosenFontset = case lookup chosenFontsetID sfontsets of - Nothing -> error $ "Fontset not defined in config file" - `showFailure` chosenFontsetID - Just fs -> fs + -- Unlike @error@, @die@ does not move savefiles aside. + chosenFontset <- case lookup chosenFontsetID sfontsets of + Nothing -> die $ "Fontset not defined in config file" + `showFailure` chosenFontsetID + Just fs -> return fs -- If some auxiliary fonts are equal and at the same size, this wastefully -- opens them many times. However, native builds are efficient enough -- and slow machines should use the most frugal case (only square font) -- in which no waste occurs and all rendering is aided with an atlas. - findFontFile t = + let findFontFile t = if T.null t then return Nothing else case lookup t sfonts of - Nothing -> error $ "Font not defined in config file" `showFailure` t + Nothing -> die $ "Font not defined in config file" `showFailure` t Just (FontProportional fname fsize fhint) -> do sdlFont <- loadFontFile fname fsize setHintMode sdlFont fhint @@ -163,12 +174,12 @@ mfontMapScalable <- findFontFile $ fontMapScalable chosenFontset case mfontMapScalable of Just (sdlFont, size) -> return (sdlFont, size, False) - Nothing -> error "Neither bitmap nor scalable map font defined" + Nothing -> die "Neither bitmap nor scalable map font defined" else do mfontMapScalable <- findFontFile $ fontMapScalable chosenFontset case mfontMapScalable of Just (sdlFont, size) -> return (sdlFont, size, False) - Nothing -> error "Scaling requested but scalable map font not defined" + Nothing -> die "Scaling requested but scalable map font not defined" let halfSize = squareFontSize `div` 2 boxSize = 2 * halfSize -- map font determines cell size for all others -- Real size of these fonts ignored. @@ -195,6 +206,15 @@ else do -- The code below fails without access to a graphics system. SDL.initialize [SDL.InitVideo] + -- This cursor size if fine for default size and Full HD 1.5x size. + let (cursorAlpha, cursorBW) = cursorXhair + xhairCursor <- + createCursor cursorBW cursorAlpha (SDL.V2 32 27) (SDL.P (SDL.V2 13 13)) + SDL.activeCursor SDL.$= xhairCursor +-- xhairCursor <- +-- throwIfNull "SDL.Input.Mouse.createSystemCursor" "SDL_createSystemCursor" +-- $ Raw.createSystemCursor Raw.SDL_SYSTEM_CURSOR_CROSSHAIR +-- SDL.activeCursor SDL.$= unsafeCoerce xhairCursor let screenV2 = SDL.V2 (toEnum $ rwidth coscreen * boxSize) (toEnum $ rheight coscreen * boxSize) windowConfig = SDL.defaultWindow @@ -274,6 +294,8 @@ prevFrame <- readIORef spreviousFrame writeIORef spreviousFrame $ blankSingleFrame coscreen drawFrame coscreen soptions sess prevFrame + SDL.pumpEvents + SDL.Raw.Event.flushEvents minBound maxBound loopSDL :: IO () loopSDL = do me <- SDL.pollEvent -- events take precedence over frames @@ -348,13 +370,85 @@ (\key -> saveKMP rf modifier key (pointTranslate p)) mkey SDL.WindowClosedEvent{} -> forceShutdown sess SDL.QuitEvent -> forceShutdown sess - SDL.WindowRestoredEvent{} -> redraw + SDL.WindowRestoredEvent{} -> redraw -- e.g., unminimize SDL.WindowExposedEvent{} -> redraw -- needed on Windows + SDL.WindowResizedEvent{} -> do + -- Eome window managers apparently are able to resize. + SDL.showSimpleMessageBox Nothing SDL.Warning + "Windows resize detected" + "Please resize the game and/or make it fullscreen via 'allFontsScale' and 'fullscreenMode' settings in the 'config.ui.ini' file. Resizing fonts via generic scaling algorithms gives poor results." + redraw -- Probably not needed, because no textures nor their content lost: -- SDL.WindowShownEvent{} -> redraw _ -> return () loopSDL +-- | Copied from SDL2 and fixed (packed booleans are needed). +-- +-- Create a cursor using the specified bitmap data and mask (in MSB format, +-- packed). Width must be a multiple of 8. +-- +-- +createCursor :: MonadIO m + => VS.Vector Word8 -- ^ Whether this part of the cursor is black. Use bit 1 for white and bit 0 for black. + -> VS.Vector Word8 -- ^ Whether or not pixels are visible. Use bit 1 for visible and bit 0 for transparent. + -> Vect.V2 CInt -- ^ The width and height of the cursor. + -> Vect.Point Vect.V2 CInt -- ^ The X- and Y-axis location of the upper left corner of the cursor relative to the actual mouse position + -> m SDL.Cursor +createCursor dta msk (Vect.V2 w h) (Vect.P (Vect.V2 hx hy)) = + liftIO . fmap unsafeCoerce $ + throwIfNull "SDL.Input.Mouse.createCursor" "SDL_createCursor" $ + VS.unsafeWith dta $ \unsafeDta -> + VS.unsafeWith msk $ \unsafeMsk -> + Raw.createCursor unsafeDta unsafeMsk w h hx hy + +-- Ignores bits after the last 8 multiple. +boolListToWord8List :: [Bool] -> [Word8] +boolListToWord8List = + let i True multiple = multiple + i False _ = 0 + in \case + b1 : b2 : b3 : b4 : b5 : b6 : b7 : b8 : rest -> + i b1 128 + i b2 64 + i b3 32 + i b4 16 + i b5 8 + i b6 4 + i b7 2 + i b8 1 + : boolListToWord8List rest + _ -> [] + +cursorXhair :: (VS.Vector Word8, VS.Vector Word8) -- alpha, BW +cursorXhair = + let charToBool '.' = (True, True) -- visible black + charToBool '#' = (True, False) -- visible white + charToBool _ = (False, False) -- transparent white + toVS = VS.fromList . boolListToWord8List + in toVS *** toVS $ unzip $ map charToBool $ concat + + [ " ... " + , " .#. " + , " .. .#. .. " + , " ..## .#. ##.. " + , " .## .#. ##. " + , " .# .#. #. " + , " .# .#. #. " + , " .# ... #. " + , " .# #. " + , " .# #. " + , " " + , " . " + , "........ .#. ........ " + , ".######. .###. .######. " + , "........ .#. ........ " + , " . " + , " " + , " .# #. " + , " .# #. " + , " .# ... #. " + , " .# .#. #. " + , " .# .#. #. " + , " .## .#. ##. " + , " ..## .#. ##.. " + , " .. .#. .. " + , " .#. " + , " ... " ] + shutdown :: FrontendSession -> IO () shutdown FrontendSession{..} = writeIORef scontinueSdlLoop False @@ -393,20 +487,31 @@ prevFrame <- readIORef spreviousFrame let halfSize = squareFontSize `div` 2 boxSize = 2 * halfSize + tt2Square = Vect.V2 (toEnum boxSize) (toEnum boxSize) vp :: Int -> Int -> Vect.Point Vect.V2 CInt vp x y = Vect.P $ Vect.V2 (toEnum x) (toEnum y) drawHighlight !col !row !color = do SDL.rendererDrawColor srenderer SDL.$= colorToRGBA color - let tt2Square = Vect.V2 (toEnum boxSize) (toEnum boxSize) - rect = SDL.Rectangle (vp (col * boxSize) (row * boxSize)) tt2Square + let rect = SDL.Rectangle (vp (col * boxSize) (row * boxSize)) tt2Square SDL.drawRect srenderer $ Just rect SDL.rendererDrawColor srenderer SDL.$= blackRGBA -- reset back to black - chooseAndDrawHighlight !col !row !bg = case bg of - Color.HighlightNone -> return () - Color.HighlightBackground -> return () - Color.HighlightNoneCursor -> return () + chooseAndDrawHighlight !col !row !bg = do +-- Rectangle drawing is broken in SDL 2.0.16 +-- (https://github.com/LambdaHack/LambdaHack/issues/281) +-- and simple workarounds fail with old SDL, e.g., four lines instead of +-- a rectangle, so we have to manually erase the broken rectangles +-- instead of depending on glyphs overwriting them fully. + let workaroundOverwriteHighlight = do + let rect = SDL.Rectangle (vp (col * boxSize) (row * boxSize)) + tt2Square + SDL.drawRect srenderer $ Just rect + case bg of + Color.HighlightNone -> workaroundOverwriteHighlight + Color.HighlightBackground -> workaroundOverwriteHighlight + Color.HighlightNoneCursor -> workaroundOverwriteHighlight _ -> drawHighlight col row $ Color.highlightToColor bg +-- workarounds end -- This also frees the surface it gets. scaleSurfaceToTexture :: Int -> SDL.Surface -> IO SDL.Texture scaleSurfaceToTexture xsize textSurfaceRaw = do @@ -495,7 +600,7 @@ atlas <- readIORef smonoAtlas let Color.AttrChar{acAttr=Color.Attr{fg=fgRaw, bg}, acChar} = Color.attrCharFromW32 w - fg | row `mod` 2 == 0 && fgRaw == Color.White = Color.AltWhite + fg | even row && fgRaw == Color.White = Color.AltWhite | otherwise = fgRaw ac = Color.attrChar2ToW32 fg acChar !_A = assert (bg `elem` [ Color.HighlightNone @@ -529,7 +634,7 @@ let Color.AttrChar{ acAttr=Color.Attr{fg=fgRaw, bg} , acChar=acCharRaw } = Color.attrCharFromW32 w - fg | row `mod` 2 == 0 && fgRaw == Color.White = Color.AltWhite + fg | even row && fgRaw == Color.White = Color.AltWhite | otherwise = fgRaw ac = if bg == Color.HighlightBackground then w @@ -553,8 +658,7 @@ writeIORef squareAtlas $ EM.insert ac textTexture atlas return textTexture Just textTexture -> return textTexture - let tt2Square = Vect.V2 (toEnum boxSize) (toEnum boxSize) - tgtR = SDL.Rectangle (vp (col * boxSize) (row * boxSize)) tt2Square + let tgtR = SDL.Rectangle (vp (col * boxSize) (row * boxSize)) tt2Square SDL.copy srenderer textTexture Nothing (Just tgtR) -- Potentially overwrite a portion of the glyph. chooseAndDrawHighlight col row bg @@ -568,7 +672,7 @@ -- This chunk starts at $ sign or beyond so, for KISS, reject it. return () drawPropLine x row (w : rest) = do - let isSpace = (`elem` [Color.spaceAttrW32, Color.spaceCursorAttrW32]) + let isSpace = (== Color.spaceAttrW32) Color.AttrChar{acAttr=Color.Attr{fg=fgRaw, bg}} = Color.attrCharFromW32 $ if isSpace w @@ -581,7 +685,7 @@ (sameRest, otherRest) = span sameAttr rest !_A = assert (bg `elem` [ Color.HighlightNone , Color.HighlightNoneCursor ]) () - fg | row `mod` 2 == 0 && fgRaw == Color.White = Color.AltWhite + fg | even row && fgRaw == Color.White = Color.AltWhite | otherwise = fgRaw t = T.pack $ map Color.charFromW32 $ w : sameRest width <- drawPropChunk x row fg t diff --git a/engine-src/Game/LambdaHack/Client/UI/Frontend/Teletype.hs b/engine-src/Game/LambdaHack/Client/UI/Frontend/Teletype.hs --- a/engine-src/Game/LambdaHack/Client/UI/Frontend/Teletype.hs +++ b/engine-src/Game/LambdaHack/Client/UI/Frontend/Teletype.hs @@ -34,6 +34,7 @@ let storeKeys :: IO () storeKeys = do c <- SIO.getChar -- blocks here, so no polling + SIO.hPutStrLn SIO.stderr "" -- prevent next line starting indented let K.KM{..} = keyTranslate c saveKMP rf modifier key (PointUI 0 0) storeKeys diff --git a/engine-src/Game/LambdaHack/Client/UI/HandleHelperM.hs b/engine-src/Game/LambdaHack/Client/UI/HandleHelperM.hs --- a/engine-src/Game/LambdaHack/Client/UI/HandleHelperM.hs +++ b/engine-src/Game/LambdaHack/Client/UI/HandleHelperM.hs @@ -3,13 +3,13 @@ ( FailError, showFailError, MError, mergeMError, FailOrCmd, failWith , failSer, failMsg, weaveJust , pointmanCycle, pointmanCycleLevel, partyAfterLeader - , pickLeader, pickLeaderWithPointer - , itemOverlay, skillsOverlay - , placesFromState, placesOverlay + , pickLeader, doLook, pickLeaderWithPointer + , itemOverlay, skillsOverlay, placesFromState, placesOverlay + , factionsFromState, factionsOverlay , describeMode, modesOverlay , pickNumber, guardItemSize, lookAtItems, lookAtStash, lookAtPosition - , displayItemLore, okxItemLorePointedAt, cycleLore, spoilsBlurb - , ppContainerWownW, nxtGameMode + , displayOneMenuItem, okxItemLoreInline, okxItemLoreMsg, itemDescOverlays + , cycleLore, spoilsBlurb, ppContainerWownW, nxtGameMode #ifdef EXPOSE_INTERNAL -- * Internal operations , itemOverlayFromState, lookAtTile, lookAtActors, guardItemVerbs @@ -20,6 +20,7 @@ import Game.LambdaHack.Core.Prelude +import Control.Applicative import qualified Data.Char as Char import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES @@ -36,7 +37,6 @@ import Game.LambdaHack.Client.UI.EffectDescription import Game.LambdaHack.Client.UI.Frame import Game.LambdaHack.Client.UI.ItemDescription -import Game.LambdaHack.Client.UI.ItemSlot import qualified Game.LambdaHack.Client.UI.Key as K import Game.LambdaHack.Client.UI.MonadClientUI import Game.LambdaHack.Client.UI.Msg @@ -61,9 +61,9 @@ import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.ReqFailure import Game.LambdaHack.Common.State -import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Types +import qualified Game.LambdaHack.Content.FactionKind as FK import qualified Game.LambdaHack.Content.ItemKind as IK import qualified Game.LambdaHack.Content.ModeKind as MK import qualified Game.LambdaHack.Content.PlaceKind as PK @@ -112,12 +112,12 @@ lidV <- viewedLevelUI body <- getsState $ getActorBody leader hs <- partyAfterLeader leader - let (autoDun, _) = autoDungeonLevel fact - let hsSort = case direction of + let banned = bannedPointmanSwitchBetweenLevels fact + hsSort = case direction of Forward -> hs Backward -> reverse hs case filter (\(_, b, _) -> blid b == lidV) hsSort of - _ | autoDun && lidV /= blid body -> + _ | banned && lidV /= blid body -> failMsg $ showReqFailure NoChangeDunLeader [] -> failMsg "cannot pick any other pointman on this level" (np, b, _) : _ -> do @@ -133,12 +133,12 @@ side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD hs <- partyAfterLeader leader - let (autoDun, _) = autoDungeonLevel fact - let hsSort = case direction of + let banned = bannedPointmanSwitchBetweenLevels fact + hsSort = case direction of Forward -> hs Backward -> reverse hs case hsSort of - _ | autoDun -> failMsg $ showReqFailure NoChangeDunLeader + _ | banned -> failMsg $ showReqFailure NoChangeDunLeader [] -> failMsg "no other member in the party" (np, b, _) : _ -> do success <- pickLeader verbose np @@ -179,12 +179,46 @@ modifySession $ \sess -> sess {saimMode = (\aimMode -> aimMode {aimLevelId = blid body}) <$> saimMode sess} -- Inform about items, etc. - (itemsBlurb, _) <- - lookAtItems True (bpos body) (blid body) (Just aid) Nothing - stashBlurb <- lookAtStash (bpos body) (blid body) - when verbose $ msgAdd MsgAtFeetMinor $ stashBlurb <+> itemsBlurb + saimMode <- getsSession saimMode + when verbose $ + if isJust saimMode + then doLook + else do + (itemsBlurb, _) <- + lookAtItems True (bpos body) (blid body) (Just aid) Nothing + stashBlurb <- lookAtStash (bpos body) (blid body) + msgAdd MsgAtFeetMinor $ stashBlurb <+> itemsBlurb return True +-- | Perform look around in the current position of the xhair. +-- Does nothing outside aiming mode. +doLook :: MonadClientUI m => m () +doLook = do + saimMode <- getsSession saimMode + case saimMode of + Just aimMode -> do + let lidV = aimLevelId aimMode + mxhairPos <- mxhairToPos + xhairPos <- xhairToPos + blurb <- lookAtPosition xhairPos lidV + itemSel <- getsSession sitemSel + mleader <- getsClient sleader + outOfRangeBlurb <- case (itemSel, mxhairPos, mleader) of + (Just (iid, _, _), Just pos, Just leader) -> do + b <- getsState $ getActorBody leader + if lidV /= blid b -- no range warnings on remote levels + || detailLevel aimMode < DetailAll -- no spam + then return [] + else do + itemFull <- getsState $ itemToFull iid + let arItem = aspectRecordFull itemFull + return [ (MsgPromptGeneric, "This position is out of range when flinging the selected item.") + | 1 + IA.totalRange arItem (itemKind itemFull) + < chessDist (bpos b) pos ] + _ -> return [] + mapM_ (uncurry msgAdd) $ blurb ++ outOfRangeBlurb + _ -> return () + pickLeaderWithPointer :: MonadClientUI m => ActorId -> m MError pickLeaderWithPointer leader = do CCUI{coscreen=ScreenContent{rheight}} <- getsSession sccui @@ -197,13 +231,12 @@ . actorAssocs (== side) lidV let oursUI = map (\(aid, b) -> (aid, b, sactorUI EM.! aid)) ours viewed = sortOn keySelected oursUI - (autoDun, _) = autoDungeonLevel fact - pick (aid, b) = - if | blid b /= arena && autoDun -> - failMsg $ showReqFailure NoChangeDunLeader - | otherwise -> do - void $ pickLeader True aid - return Nothing + banned = bannedPointmanSwitchBetweenLevels fact + pick (aid, b) = if blid b /= arena && banned + then failMsg $ showReqFailure NoChangeDunLeader + else do + void $ pickLeader True aid + return Nothing pUI <- getsSession spointer let p@(Point px py) = squareToMap $ uiToSquare pUI -- Pick even if no space in status line for the actor's symbol. @@ -218,93 +251,46 @@ Nothing -> failMsg "not pointing at an actor" Just (aid, b, _) -> pick (aid, b) -itemOverlay :: MonadClientUI m - => SingleItemSlots -> LevelId -> ItemBag -> Bool -> m OKX -itemOverlay lSlots lid bag displayRanged = do - sccui <- getsSession sccui - side <- getsClient sside - discoBenefit <- getsClient sdiscoBenefit - fontSetup <- getFontSetup - okx <- getsState $ itemOverlayFromState lSlots lid bag displayRanged - sccui side discoBenefit fontSetup - return $! okx - -itemOverlayFromState :: SingleItemSlots -> LevelId -> ItemBag -> Bool +itemOverlayFromState :: LevelId -> [(ItemId, ItemQuant)] -> Bool -> CCUI -> FactionId -> DiscoveryBenefit -> FontSetup -> State -> OKX -itemOverlayFromState lSlots lid bag displayRanged - sccui side discoBenefit FontSetup{..} s = +itemOverlayFromState arena iids displayRanged sccui side discoBenefit + FontSetup{..} s = let CCUI{coscreen=ScreenContent{rwidth}} = sccui - localTime = getLocalTime lid s + localTime = getLocalTime arena s itemToF = flip itemToFull s factionD = sfactionD s - combGround = combinedGround side s - combOrgan = combinedOrgan side s - combEqp = combinedEqp side s - stashBag = getFactionStashBag side s - !_A = assert (allB (`elem` EM.elems lSlots) (EM.keys bag) - `blame` (lid, bag, lSlots)) () - markEqp iid periodic k ncha t = - if | periodic -> T.snoc (T.init t) '/' -- if equipped, no charges - | ncha == 0 -> T.snoc (T.init t) '-' -- no charges left - | k > ncha -> T.snoc (T.init t) '+' -- not all charges left - | iid `EM.member` combOrgan || iid `EM.member` combEqp -> - if iid `EM.member` stashBag || iid `EM.member` combGround - then T.snoc (T.init t) '}' -- some spares in shared stash - else T.snoc (T.init t) ']' -- all ready to fight with - | otherwise -> t - pr :: (SlotChar, ItemId) -> Maybe (AttrString, AttrString, KeyOrSlot) - pr (c, iid) = - case EM.lookup iid bag of - Nothing -> Nothing - Just kit@(k, _) -> - let itemFull = itemToF iid - arItem = aspectRecordFull itemFull - colorSymbol = - if IA.checkFlag Ability.Condition arItem - then viewItemBenefitColored discoBenefit iid itemFull - else viewItem itemFull - phrase = makePhrase - [partItemWsRanged rwidth side factionD displayRanged - DetailMedium 4 k localTime itemFull kit] - ncha = ncharges localTime kit - periodic = IA.checkFlag Ability.Periodic arItem - !tLab = markEqp iid periodic k ncha $ slotLabel c - aLab = textToAS tLab ++ [colorSymbol] - !tDesc = " " <> phrase - in Just (aLab, textToAS tDesc, Right c) - l = mapMaybe pr $ EM.assocs lSlots + attrCursor = Color.defAttr {Color.bg = Color.HighlightNoneCursor} + markEqp periodic k ncha = + if | periodic -> '"' -- if equipped, no charges + | ncha == 0 -> '-' -- no charges left + | k > ncha -> '~' -- not all charges left + | otherwise -> '+' + pr :: MenuSlot -> (ItemId, ItemQuant) + -> (AttrString, AttrString, KeyOrSlot) + pr c (iid, kit@(k, _)) = + let itemFull = itemToF iid + arItem = aspectRecordFull itemFull + colorSymbol = + if IA.checkFlag Ability.Condition arItem + then viewItemBenefitColored discoBenefit iid itemFull + else viewItem itemFull + phrase = makePhrase + [partItemWsRanged rwidth side factionD displayRanged + DetailMedium 4 k localTime itemFull kit] + ncha = ncharges localTime kit + periodic = IA.checkFlag Ability.Periodic arItem + !cLab = Color.AttrChar { acAttr = attrCursor + , acChar = markEqp periodic k ncha } + asLab = [Color.attrCharToW32 cLab] + ++ [Color.spaceAttrW32 | isSquareFont propFont] + ++ [colorSymbol] + !tDesc = " " <> phrase + in (asLab, textToAS tDesc, Right c) + l = zipWith pr natSlots iids in labDescOKX squareFont propFont l -skillsOverlay :: MonadClientUI m => ActorId -> m OKX -skillsOverlay aid = do - b <- getsState $ getActorBody aid - actorMaxSk <- getsState $ getActorMaxSkills aid - FontSetup{..} <- getFontSetup - let prSlot :: (Int, SlotChar) -> Ability.Skill - -> ((AttrLine, (Int, AttrLine), (Int, AttrLine)), KYX) - prSlot (y, c) skill = - let skName = " " <> skillName skill - slotLab = slotLabel c - lab = textToAL slotLab - labLen = textSize squareFont $ attrLine lab - indentation = if isSquareFont propFont then 52 else 26 - valueText = skillToDecorator skill b - $ Ability.getSk skill actorMaxSk - triple = ( lab - , (labLen, textToAL skName) - , (indentation, textToAL valueText) ) - lenButton = 26 + T.length valueText - in (triple, (Right c, ( PointUI 0 y - , ButtonWidth propFont lenButton ))) - (ts, kxs) = unzip $ zipWith prSlot (zip [0..] allSlots) skillSlots - (skLab, skDescr, skValue) = unzip3 ts - skillLab = EM.singleton squareFont $ offsetOverlay skLab - skillDescr = EM.singleton propFont $ offsetOverlayX skDescr - skillValue = EM.singleton monoFont $ offsetOverlayX skValue - return (EM.unionsWith (++) [skillLab, skillDescr, skillValue], kxs) - -- | Extract whole-dungeon statistics for each place kind, -- counting the number of occurrences of each type of -- `Game.LambdaHack.Content.PlaceKind.PlaceEntry` @@ -349,32 +335,142 @@ -- then aggregate them over all levels, remembering that the place -- appeared on the given level (but not how man times) +-- TODO: if faction not known, it's info should not be updated +-- by the server. But let's wait until server sends general state diffs +-- and then block diffs that don't apply, because faction is missing. +factionsFromState :: ItemRoles -> State -> [(FactionId, Faction)] +factionsFromState (ItemRoles itemRoles) s = + let seenTrunks = ES.toList $ itemRoles EM.! STrunk + trunkBelongs fid iid = jfid (getItemBody iid s) == Just fid + factionSeen (fid, fact) = not (EM.null (gvictims fact)) -- shortcut + || any (trunkBelongs fid) seenTrunks + in filter factionSeen $ EM.assocs $ sfactionD s + +itemOverlay :: MonadClientUI m + => [(ItemId, ItemQuant)] -> ItemDialogMode -> m OKX +itemOverlay iids dmode = do + sccui <- getsSession sccui + side <- getsClient sside + arena <- getArenaUI + discoBenefit <- getsClient sdiscoBenefit + fontSetup <- getFontSetup + let displayRanged = + dmode `elem` [ MStore CGround, MStore CEqp, MStore CStash + , MOwned, MLore SItem, MLore SBlast ] + okx <- getsState $ itemOverlayFromState arena iids displayRanged + sccui side discoBenefit fontSetup + return $! okx + +skillsOverlay :: MonadClientUI m => ActorId -> m OKX +skillsOverlay aid = do + b <- getsState $ getActorBody aid + actorMaxSk <- getsState $ getActorMaxSkills aid + FontSetup{..} <- getFontSetup + let prSlot :: MenuSlot -> Ability.Skill + -> ((AttrLine, (Int, AttrLine), (Int, AttrLine)), KYX) + prSlot c skill = + let skName = " " <> skillName skill + attrCursor = Color.defAttr {Color.bg = Color.HighlightNoneCursor} + labAc = Color.AttrChar { acAttr = attrCursor + , acChar = '+' } + lab = attrStringToAL [Color.attrCharToW32 labAc] + labLen = textSize squareFont $ attrLine lab + indentation = if isSquareFont propFont then 52 else 26 + valueText = skillToDecorator skill b + $ Ability.getSk skill actorMaxSk + triple = ( lab + , (labLen, textToAL skName) + , (indentation, textToAL valueText) ) + lenButton = 26 + T.length valueText + in (triple, (Right c, ( PointUI 0 (fromEnum c) + , ButtonWidth propFont lenButton ))) + (ts, kxs) = unzip $ zipWith prSlot natSlots skillsInDisplayOrder + (skLab, skDescr, skValue) = unzip3 ts + skillLab = EM.singleton squareFont $ offsetOverlay skLab + skillDescr = EM.singleton propFont $ offsetOverlayX skDescr + skillValue = EM.singleton monoFont $ offsetOverlayX skValue + return (EM.unionsWith (++) [skillLab, skillDescr, skillValue], kxs) + placesOverlay :: MonadClientUI m => m OKX placesOverlay = do COps{coplace} <- getsState scops soptions <- getsClient soptions FontSetup{..} <- getFontSetup places <- getsState $ placesFromState coplace (sexposePlaces soptions) - let prSlot :: SlotChar + let prSlot :: MenuSlot -> (ContentId PK.PlaceKind, (ES.EnumSet LevelId, Int, Int, Int)) -> (AttrString, AttrString, KeyOrSlot) prSlot c (pk, (es, _, _, _)) = - let placeName = PK.pname $ okind coplace pk - markPlace t = if ES.null es - then T.snoc (T.init t) '>' - else t - !tLab = markPlace $ slotLabel c -- ! to free @places@ as you go + let name = PK.pname $ okind coplace pk + labChar = if ES.null es then '-' else '+' + attrCursor = Color.defAttr {Color.bg = Color.HighlightNoneCursor} + labAc = Color.AttrChar { acAttr = attrCursor + , acChar = labChar } + -- Bang required to free @places@ as you go. + !asLab = [Color.attrCharToW32 labAc] !tDesc = " " - <> placeName + <> name <+> if ES.null es then "" else "(" <> makePhrase [MU.CarWs (ES.size es) "level"] <> ")" - in (textToAS tLab, textToAS tDesc, Right c) - l = zipWith prSlot allSlots $ EM.assocs places + in (asLab, textToAS tDesc, Right c) + l = zipWith prSlot natSlots $ EM.assocs places return $! labDescOKX squareFont propFont l +factionsOverlay :: MonadClientUI m => m OKX +factionsOverlay = do + FontSetup{..} <- getFontSetup + sroles <- getsSession sroles + factions <- getsState $ factionsFromState sroles + let prSlot :: MenuSlot + -> (FactionId, Faction) + -> (AttrString, AttrString, KeyOrSlot) + prSlot c (_, fact) = + let name = FK.fname $ gkind fact -- we ignore "Controlled", etc. + gameOver = isJust $ gquit fact + labChar = if gameOver then '-' else '+' + attrCursor = Color.defAttr {Color.bg = Color.HighlightNoneCursor} + labAc = Color.AttrChar { acAttr = attrCursor + , acChar = labChar } + !asLab = [Color.attrCharToW32 labAc] + !tDesc = " " + <> name + <+> case gquit fact of + Just Status{stOutcome} | not $ isHorrorFact fact -> + "(" <> FK.nameOutcomePast stOutcome <> ")" + _ -> "" + in (asLab, textToAS tDesc, Right c) + l = zipWith prSlot natSlots factions + return $! labDescOKX squareFont propFont l + +modesOverlay :: MonadClientUI m => m OKX +modesOverlay = do + COps{comode} <- getsState scops + FontSetup{..} <- getFontSetup + svictories <- getsSession svictories + nxtChal <- getsClient snxtChal -- mark victories only for current difficulty + let f !acc _p !i !a = (i, a) : acc + campaignModes = ofoldlGroup' comode MK.CAMPAIGN_SCENARIO f [] + prSlot :: MenuSlot + -> (ContentId MK.ModeKind, MK.ModeKind) + -> (AttrString, AttrString, KeyOrSlot) + prSlot c (gameModeId, gameMode) = + let modeName = MK.mname gameMode + victories = case EM.lookup gameModeId svictories of + Nothing -> 0 + Just cm -> fromMaybe 0 (M.lookup nxtChal cm) + labChar = if victories > 0 then '-' else '+' + attrCursor = Color.defAttr {Color.bg = Color.HighlightNoneCursor} + labAc = Color.AttrChar { acAttr = attrCursor + , acChar = labChar } + !asLab = [Color.attrCharToW32 labAc] + !tDesc = " " <> modeName + in (asLab, textToAS tDesc, Right c) + l = zipWith prSlot natSlots campaignModes + return $! labDescOKX squareFont propFont l + describeMode :: MonadClientUI m => Bool -> ContentId MK.ModeKind -> m (EM.EnumMap DisplayFont Overlay) @@ -384,11 +480,12 @@ <- getsSession sccui FontSetup{..} <- getFontSetup scoreDict <- getsState shigh - scampings <- getsClient scampings - srestarts <- getsClient srestarts + scampings <- getsSession scampings + srestarts <- getsSession srestarts side <- getsClient sside total <- getsState $ snd . calculateTotal side dungeonTotal <- getsState sgold + let screensaverBlurb = "This is one of the screensaver scenarios, not available from the main menu, with all factions controlled by AI. Feel free to take over or relinquish control at any moment, but to register a legitimate high score, choose a standard scenario instead.\n" let gameMode = okind comode gameModeId duplicateEOL '\n' = "\n\n" duplicateEOL c = T.singleton c @@ -398,7 +495,10 @@ , ( textFgToAS Color.cMeta "Rules of the game:" , MK.mrules gameMode ) , ( textFgToAS Color.BrCyan "Running commentary:" - , T.concatMap duplicateEOL (MK.mreason gameMode) ) + , T.concatMap duplicateEOL + (if MK.mattract gameMode + then screensaverBlurb <> MK.mreason gameMode + else MK.mreason gameMode) ) , ( textFgToAS Color.cGreed "Hints, not needed unless stuck:" , T.concatMap duplicateEOL (MK.mhint gameMode) ) ] @@ -419,8 +519,8 @@ else "" blurb = map (second $ splitAttrString (rwidth - 2) (rwidth - 2)) $ (propFont, textToAS (title <> "\n")) - : concat (intersperse [(monoFont, textToAS "\n")] - (mapMaybe renderSection sections)) + : intercalate [(monoFont, textToAS "\n")] + (mapMaybe renderSection sections) -- Colour is used to delimit the section when displayed in one -- column, when using square fonts only. blurbEnd = map (second $ splitAttrString (rwidth - 2) (rwidth - 2)) $ @@ -430,10 +530,10 @@ : if null sectionsEndAS then [(monoFont, textToAS "*none*")] else sectionsEndAS - sectionsEndAS = concat (intersperse [(monoFont, textToAS "\n")] - (mapMaybe renderSection sectionsEnd)) + sectionsEndAS = intercalate [(monoFont, textToAS "\n")] + (mapMaybe renderSection sectionsEnd) sectionsEnd = map outcomeSection [minBound..maxBound] - outcomeSection :: MK.Outcome -> (AttrString, Text) + outcomeSection :: FK.Outcome -> (AttrString, Text) outcomeSection outcome = ( renderOutcome outcome , if not (outcomeSeen outcome) @@ -444,33 +544,37 @@ ) -- These are not added to @mendMsg@, because they only fit here. endMsgDefault = - [ (MK.Restart, "No shame there is in noble defeat and there is honour in perseverance. Sometimes there are ways and places to turn rout into victory.") - , (MK.Camping, "Don't fear to take breaks. While you move, others move, even on distant floors, but while you stay still, the world stays still.") + [ (FK.Restart, "No shame there is in noble defeat and there is honour in perseverance. Sometimes there are ways and places to turn rout into victory.") + , (FK.Camping, "Don't fear to take breaks. While you move, others move, even on distant floors, but while you stay still, the world stays still.") ] scoreRecords = maybe [] HighScore.unTable $ EM.lookup gameModeId scoreDict - outcomeSeen :: MK.Outcome -> Bool + -- This doesn't use @svictories@, but high scores, because high scores + -- are more persistent and granular (per-outcome). OTOH, @svictories@ + -- are per-challenge, which is important in other cases. + -- @Camping@ and @Restart@ are fine to be less persistent. + outcomeSeen :: FK.Outcome -> Bool outcomeSeen outcome = case outcome of - MK.Camping -> gameModeId `ES.member` scampings - MK.Restart -> gameModeId `ES.member` srestarts + FK.Camping -> gameModeId `ES.member` scampings + FK.Restart -> gameModeId `ES.member` srestarts _ -> outcome `elem` map (stOutcome . HighScore.getStatus) scoreRecords -- Camping not taken into account. - lastOutcome :: MK.Outcome + lastOutcome :: FK.Outcome lastOutcome = if null scoreRecords - then MK.Restart -- only if nothing else + then FK.Restart -- only if nothing else else stOutcome . HighScore.getStatus $ maximumBy (comparing HighScore.getDate) scoreRecords - renderOutcome :: MK.Outcome -> AttrString + renderOutcome :: FK.Outcome -> AttrString renderOutcome outcome = - let color | outcome `elem` MK.deafeatOutcomes = Color.cVeryBadEvent - | outcome `elem` MK.victoryOutcomes = Color.cVeryGoodEvent + let color | outcome `elem` FK.deafeatOutcomes = Color.cVeryBadEvent + | outcome `elem` FK.victoryOutcomes = Color.cVeryGoodEvent | otherwise = Color.cNeutralEvent lastRemark | outcome /= lastOutcome = "" - | outcome `elem` MK.deafeatOutcomes = "(last suffered ending)" - | outcome `elem` MK.victoryOutcomes = "(last achieved ending)" + | outcome `elem` FK.deafeatOutcomes = "(last suffered ending)" + | outcome `elem` FK.victoryOutcomes = "(last achieved ending)" | otherwise = "(last seen ending)" in textToAS "Game over message when" - <+:> (textFgToAS color (T.toTitle $ MK.nameOutcomePast outcome) + <+:> (textFgToAS color (T.toTitle $ FK.nameOutcomePast outcome) <+:> textToAS lastRemark) <> textToAS ":" return $! if isSquareFont propFont @@ -483,31 +587,6 @@ (EM.map (xtranslateOverlay $ rwidth + 1) $ attrLinesToFontMap blurbEnd) -modesOverlay :: MonadClientUI m => m OKX -modesOverlay = do - COps{comode} <- getsState scops - FontSetup{..} <- getFontSetup - svictories <- getsClient svictories - nxtChal <- getsClient snxtChal -- mark victories only for current difficulty - let f !acc _p !i !a = (i, a) : acc - campaignModes = ofoldlGroup' comode MK.CAMPAIGN_SCENARIO f [] - prSlot :: SlotChar - -> (ContentId MK.ModeKind, MK.ModeKind) - -> (AttrString, AttrString, KeyOrSlot) - prSlot c (gameModeId, gameMode) = - let modeName = MK.mname gameMode - victories = case EM.lookup gameModeId svictories of - Nothing -> 0 - Just cm -> fromMaybe 0 (M.lookup nxtChal cm) - markMode t = if victories > 0 - then T.snoc (T.init t) '>' - else t - !tLab = markMode $ slotLabel c - !tDesc = " " <> modeName - in (textToAS tLab, textToAS tDesc, Right c) - l = zipWith prSlot allSlots campaignModes - return $! labDescOKX squareFont propFont l - pickNumber :: MonadClientUI m => Bool -> Int -> m (Either MError Int) pickNumber askNumber kAll = assert (kAll >= 1) $ do let shownKeys = [ K.returnKM, K.spaceKM, K.mkChar '+', K.mkChar '-' @@ -535,13 +614,14 @@ K.Esc -> weaveJust <$> failWith "never mind" K.Space -> return $ Left Nothing _ -> error $ "unexpected key" `showFailure` kkm - Right sc -> error $ "unexpected slot char" `showFailure` sc - if | kAll == 1 || not askNumber -> return $ Right kAll - | otherwise -> do - res <- gatherNumber kAll - case res of - Right k | k <= 0 -> error $ "" `showFailure` (res, kAll) - _ -> return res + Right slot -> error $ "unexpected menu slot" `showFailure` slot + if kAll == 1 || not askNumber + then return $ Right kAll + else do + res <- gatherNumber kAll + case res of + Right k | k <= 0 -> error $ "" `showFailure` (res, kAll) + _ -> return res -- | Produces a textual description of the tile at a position. lookAtTile :: MonadClientUI m @@ -566,7 +646,7 @@ getKind <- getsState $ flip getIidKind let inhabitants = posToAidsLvl p lvl detail = maybe DetailAll detailLevel saimMode - aims = isJust $ maybe Nothing (\b -> makeLine False b p seps cops lvl) mb + aims = isJust $ (\b -> makeLine False b p seps cops lvl) =<< mb tkid = lvl `at` p tile = okind cotile tkid vis | TK.tname tile == "unknown space" = "that is" @@ -756,7 +836,7 @@ leaderPronoun <- partPronounLeader aid return $ Just (leaderPronoun, (bhp <$> mb) >= Just 0) _ -> return Nothing - let mactorPronounAliveLeader = maybe mLeader Just mactorPronounAlive + let mactorPronounAliveLeader = mactorPronounAlive <|> mLeader (subject, verb) <- case mactorPronounAliveLeader of Just (actorPronoun, actorAlive) -> return (actorPronoun, if actorAlive then "stand over" else "fall over") @@ -840,19 +920,19 @@ embedKindList = map (\(iid, kit) -> (getKind iid, (iid, kit))) (EM.assocs embeds) feats = TK.tfeature $ okind cotile $ lvl `at` p - tileActions = mapMaybe (Tile.parseTileAction False False embedKindList) + tileActions = mapMaybe (parseTileAction False False embedKindList) feats - isEmbedAction Tile.EmbedAction{} = True + isEmbedAction EmbedAction{} = True isEmbedAction _ = False embedVerb = [ "activated" | any isEmbedAction tileActions && any (\(itemKind, _) -> not $ null $ IK.ieffects itemKind) embedKindList ] - isToAction Tile.ToAction{} = True + isToAction ToAction{} = True isToAction _ = False - isWithAction Tile.WithAction{} = True + isWithAction WithAction{} = True isWithAction _ = False - isEmptyWithAction (Tile.WithAction [] _) = True + isEmptyWithAction (WithAction [] _) = True isEmptyWithAction _ = False alterVerb | any isEmptyWithAction tileActions = ["very easily modified"] | any isToAction tileActions = ["easily modified"] @@ -862,7 +942,7 @@ alterBlurb = if null verbs then "" else makeSentence ["can be", MU.WWandW verbs] - toolFromAction (Tile.WithAction grps _) = Just grps + toolFromAction (WithAction grps _) = Just grps toolFromAction _ = Nothing toolsToAlterWith = mapMaybe toolFromAction tileActions tItems = describeToolsAlternative toolsToAlterWith @@ -904,67 +984,83 @@ then [(MsgPromptFocus, tileBlurb)] else ms -displayItemLore :: MonadClientUI m - => ItemBag -> Int -> (ItemId -> ItemFull -> Int -> Text) -> Int - -> SingleItemSlots -> Bool - -> m K.KM -displayItemLore itemBag meleeSkill promptFun slotIndex lSlots addTilde = do - CCUI{coscreen=ScreenContent{rwidth, rheight}} <- getsSession sccui - FontSetup{propFont} <- getFontSetup - let lSlotsElems = EM.elems lSlots - lSlotsBound = length lSlotsElems - 1 +displayOneMenuItem :: MonadClientUI m + => (MenuSlot -> m OKX) -> [K.KM] -> Int -> MenuSlot + -> m K.KM +displayOneMenuItem renderOneItem extraKeys slotBound slot = do + CCUI{coscreen=ScreenContent{rheight}} <- getsSession sccui let keys = [K.spaceKM, K.escKM] - ++ [K.mkChar '~' | addTilde] - ++ [K.upKM | slotIndex /= 0] - ++ [K.downKM | slotIndex /= lSlotsBound] - okx <- okxItemLorePointedAt - propFont rwidth False itemBag meleeSkill promptFun slotIndex lSlots + ++ [K.upKM | fromEnum slot > 0] + ++ [K.downKM | fromEnum slot < slotBound] + ++ extraKeys + okx <- renderOneItem slot slides <- overlayToSlideshow (rheight - 2) keys okx km <- getConfirms ColorFull keys slides case K.key km of - K.Up -> displayItemLore itemBag meleeSkill promptFun (slotIndex - 1) - lSlots addTilde - K.Down -> displayItemLore itemBag meleeSkill promptFun (slotIndex + 1) - lSlots addTilde + K.Up -> displayOneMenuItem renderOneItem extraKeys slotBound $ pred slot + K.Down -> displayOneMenuItem renderOneItem extraKeys slotBound $ succ slot _ -> return km -okxItemLorePointedAt :: MonadClientUI m - => DisplayFont -> Int -> Bool -> ItemBag -> Int - -> (ItemId -> ItemFull -> Int -> Text) - -> Int -> SingleItemSlots - -> m OKX -okxItemLorePointedAt descFont width inlineMsg itemBag meleeSkill promptFun - slotIndex lSlots = do +okxItemLoreInline :: MonadClientUI m + => (ItemId -> ItemFull -> Int -> Text) + -> Int -> ItemDialogMode -> [(ItemId, ItemQuant)] + -> Int -> MenuSlot + -> m OKX +okxItemLoreInline promptFun meleeSkill dmode iids widthRaw slot = do + FontSetup{..} <- getFontSetup + let (iid, kit@(k, _)) = iids !! fromEnum slot + -- Some prop fonts are wider than mono (e.g., in dejavuBold font set), + -- so the width in these artificial texts full of digits and strange + -- characters needs to be smaller than @rwidth - 2@ that would suffice + -- for mono. + width = widthRaw - 5 + itemFull <- getsState $ itemToFull iid + (ovLab, ovDesc) <- itemDescOverlays True meleeSkill dmode iid kit itemFull + width + let prompt = promptFun iid itemFull k + promptBlurb | T.null prompt = [] + | otherwise = offsetOverlay $ splitAttrString width width + $ textFgToAS Color.Brown $ prompt <> "\n\n" + len = length promptBlurb + descSym2 = ytranslateOverlay len ovLab + descBlurb2 = promptBlurb ++ ytranslateOverlay len ovDesc + ov = EM.insertWith (++) squareFont descSym2 + $ EM.singleton propFont descBlurb2 + return (ov, []) + +okxItemLoreMsg :: MonadClientUI m + => (ItemId -> ItemFull -> Int -> Text) + -> Int -> ItemDialogMode -> [(ItemId, ItemQuant)] + -> MenuSlot + -> m OKX +okxItemLoreMsg promptFun meleeSkill dmode iids slot = do + CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui + FontSetup{..} <- getFontSetup + let (iid, kit@(k, _)) = iids !! fromEnum slot + itemFull <- getsState $ itemToFull iid + (ovLab, ovDesc) <- itemDescOverlays True meleeSkill dmode iid kit itemFull + rwidth + let prompt = promptFun iid itemFull k + msgAdd MsgPromptGeneric prompt + let ov = EM.insertWith (++) squareFont ovLab + $ EM.singleton propFont ovDesc + return (ov, []) + +itemDescOverlays :: MonadClientUI m + => Bool -> Int -> ItemDialogMode -> ItemId -> ItemQuant + -> ItemFull -> Int + -> m (Overlay, Overlay) +itemDescOverlays markParagraphs meleeSkill dmode iid kit itemFull width = do FontSetup{squareFont} <- getFontSetup side <- getsClient sside arena <- getArenaUI - let lSlotsElems = EM.elems lSlots - iid2 = lSlotsElems !! slotIndex - kit2@(k, _) = itemBag EM.! iid2 - itemFull2 <- getsState $ itemToFull iid2 localTime <- getsState $ getLocalTime arena factionD <- getsState sfactionD -- The hacky level 0 marks items never seen, but sent by server at gameover. - jlid <- getsSession $ fromMaybe (toEnum 0) <$> EM.lookup iid2 . sitemUI - let descAs = itemDesc width True side factionD meleeSkill - CGround localTime jlid itemFull2 kit2 - (ovLab, ovDesc) = labDescOverlay squareFont width descAs - prompt = promptFun iid2 itemFull2 k - promptBlurb | T.null prompt = [] - | otherwise = offsetOverlay $ splitAttrString width width - $ textFgToAS Color.Brown $ prompt <> "\n\n" - (descSym2, descBlurb2) <- - if inlineMsg - then do - let len = length promptBlurb - return ( ytranslateOverlay len ovLab - , promptBlurb ++ ytranslateOverlay len ovDesc ) - else do - msgAdd MsgPromptGeneric prompt - return (ovLab, ovDesc) - let ov = EM.insertWith (++) squareFont descSym2 - $ EM.singleton descFont descBlurb2 - return (ov, []) + jlid <- getsSession $ fromMaybe (toEnum 0) <$> EM.lookup iid . sitemUI + let descAs = itemDesc width markParagraphs side factionD meleeSkill + dmode localTime jlid itemFull kit + return $! labDescOverlay squareFont width descAs cycleLore :: MonadClientUI m => [m K.KM] -> [m K.KM] -> m () cycleLore _ [] = return () diff --git a/engine-src/Game/LambdaHack/Client/UI/HandleHumanGlobalM.hs b/engine-src/Game/LambdaHack/Client/UI/HandleHumanGlobalM.hs --- a/engine-src/Game/LambdaHack/Client/UI/HandleHumanGlobalM.hs +++ b/engine-src/Game/LambdaHack/Client/UI/HandleHumanGlobalM.hs @@ -17,13 +17,13 @@ , alterDirHuman, alterWithPointerHuman, closeDirHuman , helpHuman, hintHuman, dashboardHuman, itemMenuHuman, chooseItemMenuHuman , mainMenuHuman, mainMenuAutoOnHuman, mainMenuAutoOffHuman - , settingsMenuHuman, challengeMenuHuman - , gameTutorialToggle, gameDifficultyIncr + , settingsMenuHuman, challengeMenuHuman, gameDifficultyIncr , gameFishToggle, gameGoodsToggle, gameWolfToggle, gameKeeperToggle , gameScenarioIncr -- * Global commands that never take time - , gameRestartHuman, gameQuitHuman, gameDropHuman, gameExitHuman, gameSaveHuman - , doctrineHuman, automateHuman, automateToggleHuman, automateBackHuman + , gameExitWithHuman, ExitStrategy(..), gameDropHuman, gameExitHuman + , gameSaveHuman, doctrineHuman, automateHuman, automateToggleHuman + , automateBackHuman #ifdef EXPOSE_INTERNAL -- * Internal operations , areaToRectangles, meleeAid, displaceAid, moveSearchAlter, alterCommon @@ -40,7 +40,7 @@ import Game.LambdaHack.Core.Prelude import qualified Data.Char as Char -import Data.Either (isLeft) +import Data.Either import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES import qualified Data.Map.Strict as M @@ -65,7 +65,6 @@ import Game.LambdaHack.Client.UI.HumanCmd import Game.LambdaHack.Client.UI.InventoryM import Game.LambdaHack.Client.UI.ItemDescription -import Game.LambdaHack.Client.UI.ItemSlot (SlotChar (SlotChar)) import qualified Game.LambdaHack.Client.UI.Key as K import Game.LambdaHack.Client.UI.KeyBindings import Game.LambdaHack.Client.UI.MonadClientUI @@ -95,6 +94,7 @@ import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Types import Game.LambdaHack.Common.Vector +import qualified Game.LambdaHack.Content.FactionKind as FK import qualified Game.LambdaHack.Content.ItemKind as IK import qualified Game.LambdaHack.Content.ModeKind as MK import Game.LambdaHack.Content.RuleKind @@ -122,7 +122,7 @@ -- for the whole UI screen in square font coordinates pointerInArea a = do rs <- areaToRectangles a - return $! any (flip inside p) $ catMaybes rs + return $! any (`inside` p) $ catMaybes rs cmds <- filterM (pointerInArea . fst) l case cmds of [] -> do @@ -552,7 +552,7 @@ if bumping then return $ Right $ ReqMove $ vectorToFrom tpos spos else do - msgAddDone leader tpos "modify" + msgAddDone False leader tpos "modify" return $ Right $ ReqAlter tpos Left err -> return $ Left err -- Even when bumping, we don't use ReqMove, because we don't want @@ -627,7 +627,7 @@ xhair <- getsSession sxhair xhairGoTo <- getsSession sxhairGoTo mfail <- - if not (isNothing xhairGoTo) && xhairGoTo /= xhair + if isJust xhairGoTo && xhairGoTo /= xhair then failWith "crosshair position changed" else do when (isNothing xhairGoTo) $ -- set it up for next steps @@ -1097,7 +1097,7 @@ tile = lvl `at` tpos feats = TK.tfeature $ okind cotile tile tileActions = - mapMaybe (Tile.parseTileAction + mapMaybe (parseTileAction (bproj sb) (underFeet || blockedByItem) -- avoids AlterBlockItem embedKindList) @@ -1110,7 +1110,7 @@ else processTileActions leader bumping tpos tileActions processTileActions :: forall m. MonadClientUI m - => ActorId -> Bool -> Point -> [Tile.TileAction] + => ActorId -> Bool -> Point -> [TileAction] -> m (FailOrCmd ()) processTileActions leader bumping tpos tas = do COps{coTileSpeedup} <- getsState scops @@ -1121,7 +1121,7 @@ let leaderIsMist = IA.checkFlag Ability.Blast sar && Dice.infDice (IK.idamage $ getKind $ btrunk sb) <= 0 tileMinSkill = Tile.alterMinSkill coTileSpeedup $ lvl `at` tpos - processTA :: Maybe Bool -> [Tile.TileAction] -> Bool + processTA :: Maybe Bool -> [TileAction] -> Bool -> m (FailOrCmd (Maybe (Bool, Bool))) processTA museResult [] bumpFailed = do let useResult = fromMaybe False museResult @@ -1137,7 +1137,7 @@ then Nothing -- success of some kind else Just (useResult, bumpFailed) -- not quite processTA museResult (ta : rest) bumpFailed = case ta of - Tile.EmbedAction (iid, _) -> do + EmbedAction (iid, _) -> do -- Embeds are activated in the order in tile definition -- and never after the tile is changed. -- We assume the item would trigger and we let the player @@ -1148,7 +1148,7 @@ || bproj sb && tileMinSkill > 0 -> -- local skill check processTA (Just useResult) rest bumpFailed -- embed won't fire; try others - | all (not . IK.isEffEscape) (IK.ieffects $ getKind iid) -> + | (not . any IK.isEffEscape) (IK.ieffects $ getKind iid) -> processTA (Just True) rest False -- no escape checking needed, effect found; -- also bumpFailed reset, because must have been @@ -1159,13 +1159,13 @@ Left err -> return $ Left err Right () -> processTA (Just True) rest False -- effect found, bumpFailed reset - Tile.ToAction{} -> + ToAction{} -> if fromMaybe True museResult && not (bproj sb && tileMinSkill > 0) -- local skill check then return $ Right Nothing -- tile changed, no more activations else processTA museResult rest bumpFailed -- failed, but not due to bumping - Tile.WithAction tools0 _ -> + WithAction tools0 _ -> if not bumping || null tools0 then if fromMaybe True museResult then do -- UI requested, so this is voluntary, so item loss is fine. @@ -1216,7 +1216,7 @@ verifyEscape = do side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD - if not (MK.fcanEscape $ gplayer fact) + if not (FK.fcanEscape $ gkind fact) then failWith "This is the way out, but where would you go in this alien world?" -- exceptionally a full sentence, because a real question @@ -1224,7 +1224,7 @@ (_, total) <- getsState $ calculateTotal side dungeonTotal <- getsState sgold let prompt | dungeonTotal == 0 = - "You finally reached the way out. Really leave now?" + "You finally reached your goal. Really leave now?" | total == 0 = "Afraid of the challenge? Leaving so soon and without any treasure? Are you sure?" | total < dungeonTotal = @@ -1249,7 +1249,9 @@ let (name1, powers) = partItemShort rwidth side factionD localTime itemFull quantSingle objectA = makePhrase [MU.AW name1, powers] - prompt = "Do you really want to transform the terrain using" + -- "Potentially", because an unidentified items on the ground can take + -- precedence (perhaps placed there in order to get identified!). + prompt = "Do you really want to transform the terrain potentially using" <+> objectA <+> ppCStoreIn store <+> "that may cause substantial side-effects?" objectThe = makePhrase ["the", name1] @@ -1319,12 +1321,12 @@ -> failSer AlterBlockActor | otherwise -> do - msgAddDone leader tpos "close" + msgAddDone True leader tpos "close" return $ Right (ReqAlter tpos) -- | Adds message with proper names. -msgAddDone :: MonadClientUI m => ActorId -> Point -> Text -> m () -msgAddDone leader p verb = do +msgAddDone :: MonadClientUI m => Bool -> ActorId -> Point -> Text -> m () +msgAddDone mentionTile leader p verb = do COps{cotile} <- getsState scops b <- getsState $ getActorBody leader lvl <- getLevel $ blid b @@ -1333,10 +1335,12 @@ [] -> "thing" ("open" : xs) -> T.unwords xs _ -> tname + object | mentionTile = "the" <+> s + | otherwise = "" v = p `vectorToFrom` bpos b dir | v == Vector 0 0 = "underneath" | otherwise = compassText v - msgAdd MsgActionComplete $ "You" <+> verb <+> "the" <+> s <+> dir <> "." + msgAdd MsgActionComplete $ "You" <+> verb <+> object <+> dir <> "." -- | Prompts user to pick a point. pickPoint :: MonadClientUI m => ActorId -> Text -> m (Maybe Point) @@ -1369,7 +1373,10 @@ fontSetup@FontSetup{..} <- getFontSetup gameModeId <- getsState sgameModeId modeOv <- describeMode True gameModeId - let modeH = ( "Press SPACE or PGDN to advance or ESC to see the map again." + curTutorial <- getsSession scurTutorial + overrideTut <- getsSession soverrideTut + let displayTutorialHints = fromMaybe curTutorial overrideTut + modeH = ( "Press SPACE or PGDN to advance or ESC to see the map again." , (modeOv, []) ) keyH = keyHelp ccui fontSetup -- This takes a list of paragraphs and returns a list of screens. @@ -1418,16 +1425,21 @@ ( "Showing PLAYING.md (best viewed in the browser)." , (ov, []) ) manualH = map addMnualHeader manualOvs - splitHelp (t, okx) = splitOKX fontSetup True rwidth rheight rwidth - (textToAS t) [K.spaceKM, K.escKM] okx - sli = toSlideshow fontSetup $ concat $ map splitHelp - $ modeH : keyH ++ manualH + splitHelp (t, okx) = + splitOKX fontSetup True rwidth rheight rwidth (textToAS t) + [K.spaceKM, K.returnKM, K.escKM] okx + sli = toSlideshow fontSetup displayTutorialHints + $ concatMap splitHelp $ modeH : keyH ++ manualH -- Thus, the whole help menu corresponds to a single menu of item or lore, -- e.g., shared stash menu. This is especially clear when the shared stash -- menu contains many pages. - ekm <- displayChoiceScreen "help" ColorFull True sli [K.spaceKM, K.escKM] + ekm <- displayChoiceScreen "help" ColorFull True sli + [K.spaceKM, K.returnKM, K.escKM] case ekm of Left km | km `elem` [K.escKM, K.spaceKM] -> return $ Left Nothing + Left km | km == K.returnKM -> do + msgAdd MsgPromptGeneric "Press RET when a command help text is selected to invoke the command." + return $ Left Nothing Left km -> case km `M.lookup` bcmdMap coinput of Just (_desc, _cats, cmd) -> cmdSemInCxtOfKM km cmd Nothing -> weaveJust <$> failWith "never mind" @@ -1456,18 +1468,25 @@ dashboardHuman cmdSemInCxtOfKM = do CCUI{coinput, coscreen=ScreenContent{rwidth, rheight}} <- getsSession sccui fontSetup@FontSetup{..} <- getFontSetup - let offsetCol2 = 2 + curTutorial <- getsSession scurTutorial + overrideTut <- getsSession soverrideTut + let displayTutorialHints = fromMaybe curTutorial overrideTut + offsetCol2 = 3 (ov0, kxs0) = okxsN coinput monoFont propFont offsetCol2 (const False) False CmdDashboard ([], [], []) ([], []) al1 = textToAS "Dashboard" - let splitHelp (al, okx) = splitOKX fontSetup False rwidth (rheight - 2) rwidth - al [K.escKM] okx - sli = toSlideshow fontSetup $ splitHelp (al1, (ov0, kxs0)) - extraKeys = [K.escKM] + splitHelp (al, okx) = splitOKX fontSetup False rwidth (rheight - 2) rwidth + al [K.returnKM, K.escKM] okx + sli = toSlideshow fontSetup displayTutorialHints + $ splitHelp (al1, (ov0, kxs0)) + extraKeys = [K.returnKM, K.escKM] ekm <- displayChoiceScreen "dashboard" ColorFull False sli extraKeys case ekm of Left km -> case km `M.lookup` bcmdMap coinput of _ | km == K.escKM -> weaveJust <$> failWith "never mind" + _ | km == K.returnKM -> do + msgAdd MsgPromptGeneric "Press RET when a menu name is selected to browse the menu." + return $ Left Nothing Just (_desc, _cats, cmd) -> cmdSemInCxtOfKM km cmd Nothing -> weaveJust <$> failWith "never mind" Right _slot -> error $ "" `showFailure` ekm @@ -1484,6 +1503,7 @@ fontSetup@FontSetup{..} <- getFontSetup case itemSel of Just (iid, fromCStore, _) -> do + side <- getsClient sside b <- getsState $ getActorBody leader bUI <- getsSession $ getActorUI leader bag <- getsState $ getBodyStoreBag b fromCStore @@ -1494,28 +1514,26 @@ actorCurAndMaxSk <- getsState $ getActorMaxSkills leader itemFull <- getsState $ itemToFull iid localTime <- getsState $ getLocalTime (blid b) - found <- getsState $ findIid leader (bfid b) iid - factionD <- getsState sfactionD - jlid <- getsSession $ (EM.! iid) . sitemUI + found <- getsState $ findIid leader side iid let !_A = assert (not (null found) || fromCStore == CGround `blame` (iid, leader)) () fAlt (aid, (_, store)) = aid /= leader || store /= fromCStore foundAlt = filter fAlt found + markParagraphs = rheight >= 45 + meleeSkill = Ability.getSk Ability.SkHurtMelee actorCurAndMaxSk partRawActor aid = getsSession (partActor . getActorUI aid) ppLoc aid store = do parts <- ppContainerWownW partRawActor False (CActor aid store) return $! "[" ++ T.unpack (makePhrase parts) ++ "]" + dmode = MStore fromCStore foundTexts <- mapM (\(aid, (_, store)) -> ppLoc aid store) foundAlt + (ovLab, ovDesc) <- + itemDescOverlays markParagraphs meleeSkill dmode iid kit + itemFull rwidth let foundPrefix = textToAS $ if null foundTexts then "" else "The item is also in:" - markParagraphs = rheight >= 45 - descAs = itemDesc rwidth markParagraphs (bfid b) factionD - (Ability.getSk Ability.SkHurtMelee - actorCurAndMaxSk) - fromCStore localTime jlid itemFull kit - (ovLab, ovDesc) = labDescOverlay squareFont rwidth descAs ovPrefix = ytranslateOverlay (length ovDesc) $ offsetOverlay $ splitAttrString rwidth rwidth foundPrefix @@ -1530,8 +1548,11 @@ ovFound = ovPrefix ++ ovFoundRaw report <- getReportUI True CCUI{coinput} <- getsSession sccui - mstash <- getsState $ \s -> gstash $ sfactionD s EM.! bfid b - let calmE = calmEnough b actorCurAndMaxSk + mstash <- getsState $ \s -> gstash $ sfactionD s EM.! side + curTutorial <- getsSession scurTutorial + overrideTut <- getsSession soverrideTut + let displayTutorialHints = fromMaybe curTutorial overrideTut + calmE = calmEnough b actorCurAndMaxSk greyedOut cmd = not calmE && fromCStore == CEqp || mstash == Just (blid b, bpos b) && fromCStore == CGround @@ -1547,13 +1568,13 @@ || destCStore == CGround && mstash == Just (blid b, bpos b) Apply{} -> let skill = Ability.getSk Ability.SkApply actorCurAndMaxSk - in not $ either (const False) id - $ permittedApply corule localTime skill calmE - (Just fromCStore) itemFull kit + in not $ fromRight False + $ permittedApply corule localTime skill calmE + (Just fromCStore) itemFull kit Project{} -> let skill = Ability.getSk Ability.SkProject actorCurAndMaxSk - in not $ either (const False) id - $ permittedProject False skill calmE itemFull + in not $ fromRight False + $ permittedProject False skill calmE itemFull _ -> False fmt n k h = " " <> T.justifyLeft n ' ' k <> " " <> h offsetCol2 = 11 @@ -1570,7 +1591,7 @@ splitHelp (al, okx) = splitOKX fontSetup False rwidth (rheight - 2) rwidth al [K.spaceKM, K.escKM] okx - sli = toSlideshow fontSetup + sli = toSlideshow fontSetup displayTutorialHints $ splitHelp ( al1 , ( EM.insertWith (++) squareFont ovLab $ EM.insertWith (++) propFont ovDesc @@ -1584,19 +1605,21 @@ Left km -> case km `M.lookup` bcmdMap coinput of _ | km == K.escKM -> weaveJust <$> failWith "never mind" _ | km == K.spaceKM -> - chooseItemMenuHuman leader cmdSemInCxtOfKM (MStore fromCStore) + chooseItemMenuHuman leader cmdSemInCxtOfKM dmode _ | km `elem` foundKeys -> case km of K.KM{key=K.Fun n} -> do let (newAid, (bNew, newCStore)) = foundAlt !! (n - 1) - fact <- getsState $ (EM.! bfid bNew) . sfactionD - let (autoDun, _) = autoDungeonLevel fact - if | blid bNew /= blid b && autoDun -> - weaveJust <$> failSer NoChangeDunLeader - | otherwise -> do - void $ pickLeader True newAid - modifySession $ \sess -> - sess {sitemSel = Just (iid, newCStore, False)} - itemMenuHuman newAid cmdSemInCxtOfKM + fact <- getsState $ (EM.! side) . sfactionD + let banned = bannedPointmanSwitchBetweenLevels fact + if blid bNew /= blid b && banned + then weaveJust <$> failSer NoChangeDunLeader + else do + -- Verbosity not necessary to notice the switch + -- and it's explicitly requested, so no surprise. + void $ pickLeader False newAid + modifySession $ \sess -> + sess {sitemSel = Just (iid, newCStore, False)} + itemMenuHuman newAid cmdSemInCxtOfKM _ -> error $ "" `showFailure` km Just (_desc, _cats, cmd) -> do modifySession $ \sess -> @@ -1624,44 +1647,49 @@ generateMenu :: MonadClientUI m => (K.KM -> HumanCmd -> m (Either MError ReqUI)) -> FontOverlayMap - -> [(String, (Text, HumanCmd, Maybe FontOverlayMap))] + -> [(Text, HumanCmd, Maybe HumanCmd, Maybe FontOverlayMap)] -> [String] -> String -> m (Either MError ReqUI) generateMenu cmdSemInCxtOfKM blurb kdsRaw gameInfo menuName = do COps{corule} <- getsState scops - CCUI{coscreen=ScreenContent{rheight, rwebAddress}} <- getsSession sccui + CCUI{ coinput=InputContent{brevMap} + , coscreen=ScreenContent{rheight, rwebAddress} } <- getsSession sccui FontSetup{..} <- getFontSetup - let kds = map (first K.mkKM) kdsRaw + let matchKM slot kd@(_, cmd, _, _) = case M.lookup cmd brevMap of + Just (km : _) -> (Left km, kd) + _ -> (Right slot, kd) + kds = zipWith matchKM natSlots kdsRaw bindings = -- key bindings to display - let fmt (km, (d, _, _)) = - ( Just km - , T.unpack - $ T.justifyLeft 3 ' ' (T.pack $ K.showKM km) <> " " <> d ) + let attrCursor = Color.defAttr {Color.bg = Color.HighlightNoneCursor} + highAttr ac = ac {Color.acAttr = attrCursor} + highW32 = Color.attrCharToW32 . highAttr . Color.attrCharFromW32 + markFirst d = markFirstAS $ textToAS d + markFirstAS [] = [] + markFirstAS (ac : rest) = highW32 ac : rest + fmt (ekm, (d, _, _, _)) = (ekm, markFirst d) in map fmt kds - generate :: Int -> (Maybe K.KM, String) -> Maybe KYX - generate y (mkey, binding) = - let lenB = length binding - yxx key = (Left key, ( PointUI 0 y - , ButtonWidth squareFont lenB )) - in yxx <$> mkey - titleLine = rtitle corule ++ " " - ++ showVersion (rexeVersion corule) ++ " " - rawLines = zip (repeat Nothing) - (["", titleLine ++ "[" ++ rwebAddress ++ "]", ""] - ++ gameInfo) - ++ bindings - browserKey = ( Right $ SlotChar 1042 'a' - , ( PointUI (2 * length titleLine) 1 - , ButtonWidth squareFont (2 + length rwebAddress) ) ) - kyxs = browserKey : catMaybes (zipWith generate [0..] rawLines) - ov = EM.singleton squareFont $ offsetOverlay - $ map (stringToAL . snd) rawLines - kxy = xytranslateOKX 2 0 (ov, kyxs) - menuIxMap <- getsSession smenuIxMap - unless (menuName `M.member` menuIxMap) $ - modifySession $ \sess -> sess {smenuIxMap = M.insert menuName 1 menuIxMap} - let prepareBlurb ovs = + generate :: Int -> (KeyOrSlot, AttrString) -> KYX + generate y (ekm, binding) = + (ekm, (PointUI 0 y, ButtonWidth squareFont (length binding))) + okxBindings = ( EM.singleton squareFont + $ offsetOverlay $ map (attrStringToAL . snd) bindings + , zipWith generate [0..] bindings ) + titleLine = + rtitle corule ++ " " ++ showVersion (rexeVersion corule) ++ " " + titleAndInfo = map stringToAL + ([ "" + , titleLine ++ "[" ++ rwebAddress ++ "]" + , "" ] + ++ gameInfo) + webButton = ( Left $ K.mkChar '@' -- to start the menu not here + , ( PointUI (2 * length titleLine) 1 + , ButtonWidth squareFont (2 + length rwebAddress) ) ) + okxTitle = ( EM.singleton squareFont $ offsetOverlay titleAndInfo + , [webButton] ) + okx = xytranslateOKX 2 0 + $ sideBySideOKX 2 (length titleAndInfo) okxTitle okxBindings + prepareBlurb ovs = let introLen = 1 + maxYofFontOverlayMap ovs start0 = max 0 (rheight - introLen - if isSquareFont propFont then 1 else 2) @@ -1669,25 +1697,38 @@ -- subtracting 2 from X and Y to negate the indentation in -- @displayChoiceScreenWithRightPane@ returnDefaultOKS = return (prepareBlurb blurb, []) - displayInRightPane (Right _) = returnDefaultOKS - displayInRightPane (Left km) = case km `lookup` kds of - Just (_, _, mblurbRight) -> case mblurbRight of + displayInRightPane ekm = case ekm `lookup` kds of + Just (_, _, _, mblurbRight) -> case mblurbRight of Nothing -> returnDefaultOKS Just blurbRight -> return (prepareBlurb blurbRight, []) - Nothing -> error "displayInRightPane: unexpected key" - ekm <- displayChoiceScreenWithRightPane displayInRightPane - menuName ColorFull True - (menuToSlideshow kxy) [K.escKM] - case ekm of - Left km -> case km `lookup` kds of - Just (_desc, cmd, _) -> cmdSemInCxtOfKM km cmd - Nothing -> weaveJust <$> failWith "never mind" - Right (SlotChar 1042 'a') -> do - success <- tryOpenBrowser rwebAddress - if success - then generateMenu cmdSemInCxtOfKM blurb kdsRaw gameInfo menuName - else weaveJust <$> failWith "failed to open web browser" - Right _slot -> error $ "" `showFailure` ekm + Nothing | ekm == Left (K.mkChar '@') -> returnDefaultOKS + Nothing -> error $ "generateMenu: unexpected key:" + `showFailure` ekm + keys = [K.leftKM, K.rightKM, K.escKM, K.mkChar '@'] + loop = do + kmkm <- displayChoiceScreenWithRightPaneKMKM displayInRightPane True + menuName ColorFull True + (menuToSlideshow okx) keys + case kmkm of + Left (km@(K.KM {key=K.Left}), ekm) -> case ekm `lookup` kds of + Just (_, _, Nothing, _) -> loop + Just (_, _, Just cmdReverse, _) -> cmdSemInCxtOfKM km cmdReverse + Nothing -> weaveJust <$> failWith "never mind" + Left (km@(K.KM {key=K.Right}), ekm) -> case ekm `lookup` kds of + Just (_, cmd, _, _) -> cmdSemInCxtOfKM km cmd + Nothing -> weaveJust <$> failWith "never mind" + Left (K.KM {key=K.Char '@'}, _)-> do + success <- tryOpenBrowser rwebAddress + if success + then generateMenu cmdSemInCxtOfKM blurb kdsRaw gameInfo menuName + else weaveJust <$> failWith "failed to open web browser" + Left (km, _) -> case Left km `lookup` kds of + Just (_, cmd, _, _) -> cmdSemInCxtOfKM km cmd + Nothing -> weaveJust <$> failWith "never mind" + Right slot -> case Right slot `lookup` kds of + Just (_, cmd, _, _) -> cmdSemInCxtOfKM K.escKM cmd + Nothing -> weaveJust <$> failWith "never mind" + loop -- | Display the main menu. mainMenuHuman :: MonadClientUI m @@ -1697,25 +1738,29 @@ CCUI{coscreen=ScreenContent{rintroScreen}} <- getsSession sccui FontSetup{propFont} <- getFontSetup gameMode <- getGameMode + curTutorial <- getsSession scurTutorial + overrideTut <- getsSession soverrideTut curChal <- getsClient scurChal let offOn b = if b then "on" else "off" -- Key-description-command tuples. - kds = [ ("s", ("setup and start new game>", ChallengeMenu, Nothing)) - , ("x", ("save and exit to desktop", GameExit, Nothing)) - , ("c", ("tweak convenience settings>", SettingsMenu, Nothing)) - , ("t", ("toggle autoplay", AutomateToggle, Nothing)) - , ("?", ("see command help", Help, Nothing)) - , ("F12", ("switch to dashboard", Dashboard, Nothing)) - , ("Escape", ("back to playing", AutomateBack, Nothing)) ] + kds = [ ("+ setup and start new game>", ChallengeMenu, Nothing, Nothing) + , ("@ save and exit to desktop", GameExit, Nothing, Nothing) + , ("+ tweak convenience settings>", SettingsMenu, Nothing, Nothing) + , ("@ toggle autoplay", AutomateToggle, Nothing, Nothing) + , ("@ see command help", Help, Nothing, Nothing) + , ("@ switch to dashboard", Dashboard, Nothing, Nothing) + , ("^ back to playing", AutomateBack, Nothing, Nothing) ] gameName = MK.mname gameMode + displayTutorialHints = fromMaybe curTutorial overrideTut gameInfo = map T.unpack [ "Now playing:" <+> gameName , "" - , " with difficulty:" <+> tshow (cdiff curChal) - , " cold fish:" <+> offOn (cfish curChal) - , " ready goods:" <+> offOn (cgoods curChal) - , " lone wolf:" <+> offOn (cwolf curChal) - , " finder keeper:" <+> offOn (ckeeper curChal) + , " with difficulty:" <+> tshow (cdiff curChal) + , " cold fish:" <+> offOn (cfish curChal) + , " ready goods:" <+> offOn (cgoods curChal) + , " lone wolf:" <+> offOn (cwolf curChal) + , " finder keeper:" <+> offOn (ckeeper curChal) + , " tutorial hints:" <+> offOn displayTutorialHints , "" ] glueLines (l1 : l2 : rest) = if | null l1 -> l1 : glueLines (l2 : rest) @@ -1724,7 +1769,7 @@ glueLines ll = ll backstory | isSquareFont propFont = fst rintroScreen | otherwise = glueLines $ fst rintroScreen - backstoryAL = map stringToAL $ map (dropWhile (== ' ')) backstory + backstoryAL = map (stringToAL . dropWhile (== ' ')) backstory blurb = attrLinesToFontMap [(propFont, backstoryAL)] generateMenu cmdSemInCxtOfKM blurb kds gameInfo "main" @@ -1763,7 +1808,7 @@ markSmell <- getsSession smarkSmell noAnim <- getsClient $ fromMaybe False . snoAnim . soptions side <- getsClient sside - factDoctrine <- getsState $ MK.fdoctrine . gplayer . (EM.! side) . sfactionD + factDoctrine <- getsState $ gdoctrine . (EM.! side) . sfactionD overrideTut <- getsSession soverrideTut let offOn b = if b then "on" else "off" offOnAll n = case n of @@ -1779,34 +1824,33 @@ offOnUnset mb = case mb of Nothing -> "pass" Just b -> if b then "force on" else "force off" - tsuspect = "mark suspect terrain:" <+> offOnAll markSuspect - tvisible = "show visible zone:" <+> neverEver markVision - tsmell = "display smell clues:" <+> offOn markSmell - tanim = "play animations:" <+> offOn (not noAnim) - tdoctrine = "squad doctrine:" <+> Ability.nameDoctrine factDoctrine - toverride = "override tutorial hints:" <+> offOnUnset overrideTut + tsuspect = "@ mark suspect terrain:" <+> offOnAll markSuspect + tvisible = "@ show visible zone:" <+> neverEver markVision + tsmell = "@ display smell clues:" <+> offOn markSmell + tanim = "@ play animations:" <+> offOn (not noAnim) + tdoctrine = "@ squad doctrine:" <+> Ability.nameDoctrine factDoctrine + toverride = "@ override tutorial hints:" <+> offOnUnset overrideTut width = if isSquareFont propFont then rwidth `div` 2 else min uMsgWrapColumn (rwidth - 2) textToBlurb t = Just $ attrLinesToFontMap - [ ( monoFont + [ ( propFont , splitAttrString width width $ textToAS t ) ] -- Key-description-command-text tuples. - kds = [ ("s", ( tsuspect, MarkSuspect - , textToBlurb "* mark suspect terrain\nThis setting affects the ongoing and the next games. It determines which suspect terrain is marked in special color on the map: none, untried (not searched nor revealed), all. It correspondingly determines which, if any, suspect tiles are considered for mouse go-to, auto-explore and for the command that marks the nearest unexplored position." )) - , ("v", (tvisible, MarkVision - , textToBlurb "* show visible zone\nThis setting affects the ongoing and the next games. It determines the conditions under which the area visible to the party is marked on the map via a gray background: never, when aiming, always." )) - , ("c", (tsmell, MarkSmell - , textToBlurb "* display smell clues\nThis setting affects the ongoing and the next games. It determines whether the map displays any smell traces (regardless of who left them) detected by a party member that can track via smell (as determined by the smell radius skill; not common among humans)." )) - , ("a", (tanim, MarkAnim - , textToBlurb "* play animations\nThis setting affects the ongoing and the next games. It determines whether important events, such combat, are highlighted by animations. This overrides the corresponding config file setting." )) - , ("d", (tdoctrine, Doctrine - , textToBlurb "* squad doctrine\nThis setting affects the ongoing game, but does not persist to the next games. It determines the behaviour of henchmen (non-pointman characters) in the party and, in particular, if they are permitted to move autonomously or fire opportunistically (assuming they are able to, usually due to rare equipment). This setting has a poor UI that will be improved in the future." )) - , ("t", (toverride, OverrideTut - , textToBlurb "* override tutorial hints\nThis setting affects the ongoing and the next games. It determines whether tutorial hints are, respectively, not overridden with respect to the setting that was chosen when starting the current game, forced to be off, forced to be on." )) - , ("Escape", ( "back to main menu", MainMenu - , Just EM.empty )) ] + kds = [ ( tsuspect, MarkSuspect 1, Just (MarkSuspect (-1)) + , textToBlurb "* mark suspect terrain\nThis setting affects the ongoing and the next games. It determines which suspect terrain is marked in special color on the map: none, untried (not searched nor revealed), all. It correspondingly determines which, if any, suspect tiles are considered for mouse go-to, auto-explore and for the command that marks the nearest unexplored position." ) + , ( tvisible, MarkVision 1, Just (MarkVision (-1)) + , textToBlurb "* show visible zone\nThis setting affects the ongoing and the next games. It determines the conditions under which the area visible to the party is marked on the map via a gray background: never, when aiming, always." ) + , ( tsmell, MarkSmell, Just MarkSmell + , textToBlurb "* display smell clues\nThis setting affects the ongoing and the next games. It determines whether the map displays any smell traces (regardless of who left them) detected by a party member that can track via smell (as determined by the smell radius skill; not common among humans)." ) + , ( tanim, MarkAnim, Just MarkAnim + , textToBlurb "* play animations\nThis setting affects the ongoing and the next games. It determines whether important events, such combat, are highlighted by animations. This overrides the corresponding config file setting." ) + , ( tdoctrine, Doctrine, Nothing + , textToBlurb "* squad doctrine\nThis setting affects the ongoing game, but does not persist to the next games. It determines the behaviour of henchmen (non-pointman characters) in the party and, in particular, if they are permitted to move autonomously or fire opportunistically (assuming they are able to, usually due to rare equipment). This setting has a poor UI that will be improved in the future." ) + , ( toverride, OverrideTut 1, Just (OverrideTut (-1)) + , textToBlurb "* override tutorial hints\nThis setting affects the ongoing and the next games. It determines whether tutorial hints are, respectively, not overridden with respect to the default game mode setting, forced to be off, forced to be on. Tutorial hints are rendered as pink messages and can afterwards be re-read from message history." ) + , ( "^ back to main menu", MainMenu, Nothing, Just EM.empty ) ] gameInfo = map T.unpack [ "Tweak convenience settings:" , "" ] @@ -1823,30 +1867,25 @@ CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui UIOptions{uMsgWrapColumn} <- getsSession sUIOptions FontSetup{..} <- getFontSetup - svictories <- getsClient svictories + svictories <- getsSession svictories snxtScenario <- getsSession snxtScenario - nxtTutorial <- getsSession snxtTutorial - overrideTut <- getsSession soverrideTut nxtChal <- getsClient snxtChal let (gameModeId, gameMode) = nxtGameMode cops snxtScenario victories = case EM.lookup gameModeId svictories of Nothing -> 0 Just cm -> fromMaybe 0 (M.lookup nxtChal cm) star t = if victories > 0 then "*" <> t else t - tnextScenario = "adventure:" <+> star (MK.mname gameMode) + tnextScenario = "@ adventure:" <+> star (MK.mname gameMode) offOn b = if b then "on" else "off" - starTut t = if isJust overrideTut then "*" <> t else t - displayTutorialHints = fromMaybe nxtTutorial overrideTut - tnextTutorial = "tutorial hints:" <+> starTut (offOn displayTutorialHints) - tnextDiff = "difficulty level:" <+> tshow (cdiff nxtChal) - tnextFish = "cold fish (rather hard):" <+> offOn (cfish nxtChal) - tnextGoods = "ready goods (hard):" <+> offOn (cgoods nxtChal) - tnextWolf = "lone wolf (very hard):" <+> offOn (cwolf nxtChal) - tnextKeeper = "finder keeper (hard):" <+> offOn (ckeeper nxtChal) + tnextDiff = "@ difficulty level:" <+> tshow (cdiff nxtChal) + tnextFish = "@ cold fish (rather hard):" <+> offOn (cfish nxtChal) + tnextGoods = "@ ready goods (hard):" <+> offOn (cgoods nxtChal) + tnextWolf = "@ lone wolf (very hard):" <+> offOn (cwolf nxtChal) + tnextKeeper = "@ finder keeper (hard):" <+> offOn (ckeeper nxtChal) width = if isSquareFont propFont then rwidth `div` 2 else min uMsgWrapColumn (rwidth - 2) - widthMono = if isSquareFont propFont + widthFull = if isSquareFont propFont then rwidth `div` 2 else rwidth - 2 duplicateEOL '\n' = "\n\n" @@ -1857,8 +1896,8 @@ $ textFgToAS Color.BrBlack $ T.concatMap duplicateEOL (MK.mdesc gameMode) <> "\n\n" ) - , ( monoFont - , splitAttrString widthMono widthMono + , ( propFont + , splitAttrString widthFull widthFull $ textToAS $ MK.mrules gameMode <> "\n\n" ) @@ -1868,46 +1907,34 @@ $ T.concatMap duplicateEOL (MK.mreason gameMode) ) ] textToBlurb t = Just $ attrLinesToFontMap - [ ( monoFont - , splitAttrString width width -- not widthMono! + [ ( propFont + , splitAttrString width width -- not widthFull! $ textToAS t ) ] -- Key-description-command-text tuples. - kds = [ ("s", (tnextScenario, GameScenarioIncr, blurb)) - , ("t", ( tnextTutorial, GameTutorialToggle - , textToBlurb "* tutorial hints\nThis determines whether tutorial hint messages will be shown in the next game that's about to be started. They are rendered in pink and can be re-read from message history. Display of tutorial hints in the current game can be overridden from the convenience settings menu.")) - , ("d", ( tnextDiff, GameDifficultyIncr - , textToBlurb "* difficulty level\nThis determines the difficulty of survival in the next game that's about to be started. Lower numbers result in easier game. In particular, difficulty below 5 multiplies hitpoints of player characters and difficulty over 5 multiplies hitpoints of their enemies. Game score scales with difficulty.")) - , ("f", ( tnextFish, GameFishToggle - , textToBlurb "* cold fish\nThis challenge mode setting will affect the next game that's about to be started. When on, it makes it impossible for player characters to be healed by actors from other factions (this is a significant restriction in the long crawl adventure).")) - , ("r", ( tnextGoods, GameGoodsToggle - , textToBlurb "* ready goods\nThis challenge mode setting will affect the next game that's about to be started. When on, it disables crafting for the player, making the selection of equipment, especially melee weapons, very limited, unless the player has the luck to find the rare powerful ready weapons (this applies only if the chosen adventure supports crafting at all).")) - , ("w", ( tnextWolf, GameWolfToggle - , textToBlurb "* lone wolf\nThis challenge mode setting will affect the next game that's about to be started. When on, it reduces player's starting actors to exactly one, though later on new heroes may join the party. This makes the game very hard in the long run.")) - , ("k", ( tnextKeeper, GameKeeperToggle - , textToBlurb "* finder keeper\nThis challenge mode setting will affect the next game that's about to be started. When on, it completely disables flinging projectiles by the player, which affects not only ranged damage dealing, but also throwing of consumables that buff teammates engaged in melee combat, weaken and distract enemies, light dark corners, etc.")) - , ("g", ("start new game", GameRestart, blurb)) - , ("Escape", ("back to main menu", MainMenu, Nothing)) ] + kds = [ ( tnextScenario, GameScenarioIncr 1, Just (GameScenarioIncr (-1)) + , blurb ) + , ( tnextDiff, GameDifficultyIncr 1, Just (GameDifficultyIncr (-1)) + , textToBlurb "* difficulty level\nThis determines the difficulty of survival in the next game that's about to be started. Lower numbers result in easier game. In particular, difficulty below 5 multiplies hitpoints of player characters and difficulty over 5 multiplies hitpoints of their enemies. Game score scales with difficulty.") + , ( tnextFish, GameFishToggle, Just GameFishToggle + , textToBlurb "* cold fish\nThis challenge mode setting will affect the next game that's about to be started. When on, it makes it impossible for player characters to be healed by actors from other factions (this is a significant restriction in the long crawl adventure).") + , ( tnextGoods, GameGoodsToggle, Just GameGoodsToggle + , textToBlurb "* ready goods\nThis challenge mode setting will affect the next game that's about to be started. When on, it disables crafting for the player, making the selection of equipment, especially melee weapons, very limited, unless the player has the luck to find the rare powerful ready weapons (this applies only if the chosen adventure supports crafting at all).") + , ( tnextWolf, GameWolfToggle, Just GameWolfToggle + , textToBlurb "* lone wolf\nThis challenge mode setting will affect the next game that's about to be started. When on, it reduces player's starting actors to exactly one, though later on new heroes may join the party. This makes the game very hard in the long run.") + , ( tnextKeeper, GameKeeperToggle, Just GameKeeperToggle + , textToBlurb "* finder keeper\nThis challenge mode setting will affect the next game that's about to be started. When on, it completely disables flinging projectiles by the player, which affects not only ranged damage dealing, but also throwing of consumables that buff teammates engaged in melee combat, weaken and distract enemies, light dark corners, etc.") + , ( "@ start new game", GameRestart, Nothing, blurb ) + , ( "^ back to main menu", MainMenu, Nothing, Nothing ) ] gameInfo = map T.unpack [ "Setup and start new game:" , "" ] generateMenu cmdSemInCxtOfKM EM.empty kds gameInfo "challenge" --- * GameTutorialToggle - -gameTutorialToggle :: MonadClientUI m => m () -gameTutorialToggle = do - nxtTutorial <- getsSession snxtTutorial - overrideTut <- getsSession soverrideTut - let displayTutorialHints = fromMaybe nxtTutorial overrideTut - modifySession $ \sess -> sess { snxtTutorial = not displayTutorialHints - , soverrideTut = Nothing } - -- * GameDifficultyIncr -gameDifficultyIncr :: MonadClient m => m () -gameDifficultyIncr = do +gameDifficultyIncr :: MonadClient m => Int -> m () +gameDifficultyIncr delta = do nxtDiff <- getsClient $ cdiff . snxtChal - let delta = -1 - d | nxtDiff + delta > difficultyBound = 1 + let d | nxtDiff + delta > difficultyBound = 1 | nxtDiff + delta < 1 = difficultyBound | otherwise = nxtDiff + delta modifyClient $ \cli -> cli {snxtChal = (snxtChal cli) {cdiff = d} } @@ -1942,66 +1969,54 @@ -- * GameScenarioIncr -gameScenarioIncr :: MonadClientUI m => m () -gameScenarioIncr = do +gameScenarioIncr :: MonadClientUI m => Int -> m () +gameScenarioIncr delta = do cops <- getsState scops oldScenario <- getsSession snxtScenario - let snxtScenario = oldScenario + 1 + let snxtScenario = oldScenario + delta snxtTutorial = MK.mtutorial $ snd $ nxtGameMode cops snxtScenario modifySession $ \sess -> sess {snxtScenario, snxtTutorial} --- * GameRestart +-- * GameRestart & GameQuit -gameRestartHuman :: MonadClientUI m => m (FailOrCmd ReqUI) -gameRestartHuman = do - cops <- getsState scops +data ExitStrategy = Restart | Quit + +gameExitWithHuman :: MonadClientUI m => ExitStrategy -> m (FailOrCmd ReqUI) +gameExitWithHuman exitStrategy = do + snxtChal <- getsClient snxtChal + cops <- getsState scops noConfirmsGame <- isNoConfirmsGame - gameMode <- getGameMode - snxtScenario <- getsSession snxtScenario + gameMode <- getGameMode + snxtScenario <- getsSession snxtScenario let nxtGameName = MK.mname $ snd $ nxtGameMode cops snxtScenario - b <- if noConfirmsGame - then return True - else displayYesNo ColorBW - $ "You just requested a new" <+> nxtGameName - <+> "game. The progress of the ongoing" <+> MK.mname gameMode - <+> "game will be lost! Are you sure?" - if b - then do - snxtChal <- getsClient snxtChal - -- This ignores all but the first word of game mode names picked - -- via main menu and assumes the fist word of such game modes - -- is present in their frequencies. - let (mainName, _) = T.span (\c -> Char.isAlpha c || c == ' ') nxtGameName - nxtGameGroup = DefsInternal.GroupName $ T.intercalate " " - $ take 2 $ T.words mainName - return $ Right $ ReqUIGameRestart nxtGameGroup snxtChal - else do - msg2 <- rndToActionUI $ oneOf - [ "yea, would be a pity to leave them to die" - , "yea, a shame to get your team stranded" ] - failWith msg2 + exitReturn x = return $ Right $ ReqUIGameRestart x snxtChal + displayExitMessage diff = + displayYesNo ColorBW + $ diff <+> "progress of the ongoing" + <+> MK.mname gameMode <+> "game will be lost! Are you sure?" + ifM (if' noConfirmsGame + (return True) -- true case + (displayExitMessage $ case exitStrategy of -- false case + Restart -> "You just requested a new" <+> nxtGameName + <+> "game. The " + Quit -> "If you quit, the ")) + (exitReturn $ case exitStrategy of -- ifM true case + Restart -> + let (mainName, _) = T.span (\c -> Char.isAlpha c || c == ' ') + nxtGameName + in DefsInternal.GroupName $ T.intercalate " " + $ take 2 $ T.words mainName + Quit -> MK.INSERT_COIN) + (rndToActionUI (oneOf -- ifM false case + [ "yea, would be a pity to leave them to die" + , "yea, a shame to get your team stranded" ]) + >>= failWith) --- * GameQuit +ifM :: Monad m => m Bool -> m b -> m b -> m b +ifM b t f = do b' <- b; if b' then t else f --- TODO: deduplicate with gameRestartHuman -gameQuitHuman :: MonadClientUI m => m (FailOrCmd ReqUI) -gameQuitHuman = do - noConfirmsGame <- isNoConfirmsGame - gameMode <- getGameMode - b <- if noConfirmsGame - then return True - else displayYesNo ColorBW - $ "If you quit, the progress of the ongoing" <+> MK.mname gameMode - <+> "game will be lost! Are you sure?" - if b - then do - snxtChal <- getsClient snxtChal - return $ Right $ ReqUIGameRestart MK.INSERT_COIN snxtChal - else do - msg2 <- rndToActionUI $ oneOf - [ "yea, would be a pity to leave them to die" - , "yea, a shame to get your team stranded" ] - failWith msg2 +if' :: Bool -> p -> p -> p +if' b t f = if b then t else f -- * GameDrop @@ -2035,13 +2050,13 @@ doctrineHuman :: MonadClientUI m => m (FailOrCmd ReqUI) doctrineHuman = do fid <- getsClient sside - fromT <- getsState $ MK.fdoctrine . gplayer . (EM.! fid) . sfactionD + fromT <- getsState $ gdoctrine . (EM.! fid) . sfactionD let toT = if fromT == maxBound then minBound else succ fromT go <- displaySpaceEsc ColorFull $ "(Beware, work in progress!)" - <+> "Current squad doctrine is" <+> Ability.nameDoctrine fromT + <+> "Current squad doctrine is '" <> Ability.nameDoctrine fromT <> "'" <+> "(" <> Ability.describeDoctrine fromT <> ")." - <+> "Switching doctrine to" <+> Ability.nameDoctrine toT + <+> "Switching doctrine to '" <> Ability.nameDoctrine toT <> "'" <+> "(" <> Ability.describeDoctrine toT <> ")." <+> "This clears targets of all non-pointmen teammates." <+> "New targets will be picked according to new doctrine." diff --git a/engine-src/Game/LambdaHack/Client/UI/HandleHumanLocalM.hs b/engine-src/Game/LambdaHack/Client/UI/HandleHumanLocalM.hs --- a/engine-src/Game/LambdaHack/Client/UI/HandleHumanLocalM.hs +++ b/engine-src/Game/LambdaHack/Client/UI/HandleHumanLocalM.hs @@ -13,8 +13,7 @@ , selectActorHuman, selectNoneHuman, selectWithPointerHuman , repeatHuman, repeatHumanTransition , repeatLastHuman, repeatLastHumanTransition - , recordHuman, recordHumanTransition - , allHistoryHuman, lastHistoryHuman + , recordHuman, recordHumanTransition, allHistoryHuman , markVisionHuman, markSmellHuman, markSuspectHuman, markAnimHuman , overrideTutHuman , printScreenHuman @@ -28,11 +27,12 @@ , aimPointerFloorHuman, aimPointerEnemyHuman #ifdef EXPOSE_INTERNAL -- * Internal operations - , chooseItemDialogModeLore, permittedProjectClient, projectCheck - , xhairLegalEps, posFromXhair - , permittedApplyClient, eitherHistory, endAiming, endAimingMsg - , doLook, flashAiming + , chooseItemDialogModeLore, projectCheck + , posFromXhair, permittedApplyClient, endAiming, endAimingMsg + , flashAiming #endif + -- * Operations both internal and used in unit tests + , permittedProjectClient, xhairLegalEps ) where import Prelude () @@ -61,7 +61,6 @@ import Game.LambdaHack.Client.UI.HandleHelperM import qualified Game.LambdaHack.Client.UI.HumanCmd as HumanCmd import Game.LambdaHack.Client.UI.InventoryM -import Game.LambdaHack.Client.UI.ItemSlot import qualified Game.LambdaHack.Client.UI.Key as K import Game.LambdaHack.Client.UI.MonadClientUI import Game.LambdaHack.Client.UI.Msg @@ -88,6 +87,7 @@ import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Types import Game.LambdaHack.Common.Vector +import qualified Game.LambdaHack.Content.FactionKind as FK import qualified Game.LambdaHack.Content.ItemKind as IK import qualified Game.LambdaHack.Content.ModeKind as MK import Game.LambdaHack.Content.RuleKind @@ -122,13 +122,26 @@ chooseItemHuman leader c = either Just (const Nothing) <$> chooseItemDialogMode leader False c -chooseItemDialogModeLore :: MonadClientUI m => m (Maybe ResultItemDialogMode) +chooseItemDialogModeLore :: forall m . MonadClientUI m + => m (Maybe ResultItemDialogMode) chooseItemDialogModeLore = do - schosenLore <- getsSession schosenLore - (inhabitants, embeds) <- case schosenLore of + schosenLoreOld <- getsSession schosenLore + (inhabitants, embeds) <- case schosenLoreOld of ChosenLore inh emb -> return (inh, emb) ChosenNothing -> computeChosenLore - bagAll <- getsState $ EM.map (const quantSingle) . sitemD + bagHuge <- getsState $ EM.map (const quantSingle) . sitemD + itemToF <- getsState $ flip itemToFull + ItemRoles itemRoles <- getsSession sroles + let rlore :: ItemId -> SLore -> ChosenLore -> m (Maybe ResultItemDialogMode) + rlore iid slore schosenLore = do + let itemRole = itemRoles EM.! slore + bagAll = EM.filterWithKey (\iid2 _ -> iid2 `ES.member` itemRole) + bagHuge + modifySession $ \sess -> sess {schosenLore} + let iids = sortIids itemToF $ EM.assocs bagAll + slot = toEnum $ fromMaybe (error $ "" `showFailure` (iid, iids)) + $ elemIndex iid $ map fst iids + return $ Just $ RLore slore slot iids case inhabitants of (_, b) : rest -> do let iid = btrunk b @@ -136,27 +149,22 @@ let slore | not $ bproj b = STrunk | IA.checkFlag Ability.Blast arItem = SBlast | otherwise = SItem - lSlots <- slotsOfItemDialogMode $ MLore slore - modifySession $ \sess -> sess {schosenLore = ChosenLore rest embeds} - return $ Just $ RLore slore iid bagAll lSlots + rlore iid slore (ChosenLore rest embeds) [] -> case embeds of (iid, _) : rest -> do let slore = SEmbed - lSlots <- slotsOfItemDialogMode $ MLore slore - modifySession $ \sess -> - sess {schosenLore = ChosenLore inhabitants rest} - return $ Just $ RLore slore iid bagAll lSlots + rlore iid slore (ChosenLore inhabitants rest) [] -> do modifySession $ \sess -> sess {schosenLore = ChosenNothing} return Nothing -chooseItemDialogMode :: MonadClientUI m +chooseItemDialogMode :: forall m. MonadClientUI m => ActorId -> Bool -> ItemDialogMode -> m (FailOrCmd ActorId) chooseItemDialogMode leader0 permitLoreCycle c = do CCUI{coscreen=ScreenContent{rwidth, rheight}} <- getsSession sccui - FontSetup{..} <- getFontSetup + FontSetup{propFont} <- getFontSetup side <- getsClient sside fact <- getsState $ (EM.! side) . sfactionD (ggi, loreFound) <- do @@ -170,7 +178,8 @@ return (ggi, False) -- Pointman could have been changed in @getStoreItem@ above. mleader <- getsClient sleader - let leader = fromMaybe (error "UI manipulation killed the pointman") mleader + -- When run inside a test, without mleader, assume leader not changed. + let leader = fromMaybe leader0 mleader recordHistory -- item chosen, wipe out already shown msgs actorCurAndMaxSk <- getsState $ getActorMaxSkills leader let meleeSkill = Ability.getSk Ability.SkHurtMelee actorCurAndMaxSk @@ -182,21 +191,6 @@ sess {sitemSel = Just (iid, fromCStore, False)} return $ Right leader RStore{} -> error $ "" `showFailure` result - ROrgans iid itemBag lSlots -> do - let blurb itemFull = - if IA.checkFlag Ability.Condition $ aspectRecordFull itemFull - then "condition" - else "organ" - promptFun _ itemFull _ = - makeSentence [ partActor bUI, "is aware of" - , MU.AW $ blurb itemFull ] - ix0 = fromMaybe (error $ "" `showFailure` result) - $ elemIndex iid $ EM.elems lSlots - km <- displayItemLore itemBag meleeSkill promptFun ix0 lSlots False - case K.key km of - K.Space -> chooseItemDialogMode leader False MOrgans - K.Esc -> failWith "never mind" - _ -> error $ "" `showFailure` km ROwned iid -> do found <- getsState $ findIid leader side iid let (newAid, bestStore) = case leader `lookup` found of @@ -208,50 +202,38 @@ sess {sitemSel = Just (iid, bestStore, False)} arena <- getArenaUI b2 <- getsState $ getActorBody newAid - let (autoDun, _) = autoDungeonLevel fact + let banned = bannedPointmanSwitchBetweenLevels fact if | newAid == leader -> return $ Right leader - | blid b2 /= arena && autoDun -> + | blid b2 /= arena && banned -> failSer NoChangeDunLeader | otherwise -> do -- We switch leader only here, not when processing results -- of lore screens, because lore is only about inspecting items. + -- + -- This is a bit too verbose in aiming mode, but verbosity + -- here is good to turn player's attention to the switch. void $ pickLeader True newAid return $ Right newAid - RSkills slotIndex0 -> do - -- This can be used in the future, e.g., to increase stats from - -- level-up stat points, so let's keep it even if it shows - -- no extra info compared to right pane display in menu. - let slotListBound = length skillSlots - 1 - displayOneSlot slotIndex = do - (prompt2, attrString) <- skillCloseUp leader slotIndex - let ov0 = EM.singleton propFont - $ offsetOverlay - $ splitAttrString rwidth rwidth attrString - keys = [K.spaceKM, K.escKM] - ++ [K.upKM | slotIndex /= 0] - ++ [K.downKM | slotIndex /= slotListBound] - msgAdd MsgPromptGeneric prompt2 - slides <- overlayToSlideshow (rheight - 2) keys (ov0, []) - km <- getConfirms ColorFull keys slides - case K.key km of - K.Space -> chooseItemDialogMode leader False MSkills - K.Up -> displayOneSlot $ slotIndex - 1 - K.Down -> displayOneSlot $ slotIndex + 1 - K.Esc -> failWith "never mind" - _ -> error $ "" `showFailure` km - displayOneSlot slotIndex0 - RLore slore iid itemBag lSlots -> do - let ix0 = fromMaybe (error $ "" `showFailure` result) - $ elemIndex iid $ EM.elems lSlots - promptFun _ _ _ = - makeSentence [ MU.SubjectVerbSg (partActor bUI) "remember" - , MU.AW $ MU.Text (headingSLore slore) ] + RLore slore slot iids -> do + let promptFun _ itemFull _ = case slore of + SBody -> + let blurb = if IA.checkFlag Ability.Condition + $ aspectRecordFull itemFull + then "condition" + else "organ" + in makeSentence [partActor bUI, "is aware of" ,MU.AW blurb] + _ -> + makeSentence [ MU.SubjectVerbSg (partActor bUI) "remember" + , MU.AW $ MU.Text (headingSLore slore) ] schosenLore <- getsSession schosenLore let lorePending = loreFound && case schosenLore of ChosenLore [] [] -> False _ -> True - km <- displayItemLore itemBag meleeSkill promptFun ix0 - lSlots lorePending + renderOneItem = + okxItemLoreMsg promptFun meleeSkill (MLore slore) iids + extraKeys = [K.mkChar '~' | lorePending] + slotBound = length iids - 1 + km <- displayOneMenuItem renderOneItem extraKeys slotBound slot case K.key km of K.Space -> do modifySession $ \sess -> sess {schosenLore = ChosenNothing} @@ -261,44 +243,93 @@ modifySession $ \sess -> sess {schosenLore = ChosenNothing} failWith "never mind" _ -> error $ "" `showFailure` km - RPlaces slotIndex0 -> do + RSkills slot0 -> do + -- This can be used in the future, e.g., to increase stats from + -- level-up stat points, so let's keep it even if it shows + -- no extra info compared to right pane display in menu. + let renderOneItem slot = do + (prompt2, attrString) <- skillCloseUp leader slot + let ov0 = EM.singleton propFont + $ offsetOverlay + $ splitAttrString rwidth rwidth attrString + msgAdd MsgPromptGeneric prompt2 + return (ov0, []) + extraKeys = [] + slotBound = length skillsInDisplayOrder - 1 + km <- displayOneMenuItem renderOneItem extraKeys slotBound slot0 + case K.key km of + K.Space -> chooseItemDialogMode leader False MSkills + K.Esc -> failWith "never mind" + _ -> error $ "" `showFailure` km + RPlaces slot0 -> do COps{coplace} <- getsState scops soptions <- getsClient soptions -- This is computed just once for the whole series of up and down arrow -- navigations, avoid quadratic blowup. places <- getsState $ EM.assocs . placesFromState coplace (sexposePlaces soptions) - let slotListBound = length places - 1 - displayOneSlot slotIndex = do + let renderOneItem slot = do (prompt2, blurbs) <- - placeCloseUp places (sexposePlaces soptions) slotIndex - let splitText = splitAttrString rwidth rwidth . textToAS + placeCloseUp places (sexposePlaces soptions) slot + let splitText = splitAttrString rwidth rwidth ov0 = attrLinesToFontMap - $ map (second (concatMap splitText)) blurbs - keys = [K.spaceKM, K.escKM] - ++ [K.upKM | slotIndex /= 0] - ++ [K.downKM | slotIndex /= slotListBound] + $ map (second $ concatMap splitText) blurbs msgAdd MsgPromptGeneric prompt2 - slides <- overlayToSlideshow (rheight - 2) keys (ov0, []) - km <- getConfirms ColorFull keys slides + return (ov0, []) + extraKeys = [] + slotBound = length places - 1 + km <- displayOneMenuItem renderOneItem extraKeys slotBound slot0 + case K.key km of + K.Space -> chooseItemDialogMode leader False MPlaces + K.Esc -> failWith "never mind" + _ -> error $ "" `showFailure` km + RFactions slot0 -> do + sroles <- getsSession sroles + factions <- getsState $ factionsFromState sroles + let renderOneItem slot = do + (prompt2, blurbs) <- factionCloseUp factions slot + let splitText = splitAttrString rwidth rwidth + ov0 = attrLinesToFontMap + $ map (second $ concatMap splitText) blurbs + msgAdd MsgPromptGeneric prompt2 + return (ov0, []) + extraKeys = [] + slotBound = length factions - 1 + km <- displayOneMenuItem renderOneItem extraKeys slotBound slot0 + case K.key km of + K.Space -> chooseItemDialogMode leader False MFactions + K.Esc -> failWith "never mind" + _ -> error $ "" `showFailure` km + RModes slot0 -> do + let displayOneMenuItemBig :: (MenuSlot -> m OKX) + -> [K.KM] -> Int -> MenuSlot + -> m K.KM + displayOneMenuItemBig renderOneItem extraKeys slotBound slot = do + let keys = [K.spaceKM, K.escKM] + ++ [K.upKM | fromEnum slot > 0] + ++ [K.downKM | fromEnum slot < slotBound] + ++ extraKeys + okx <- renderOneItem slot + -- Here it differs from @displayOneMenuItem@, + slides <- overlayToSlideshow rheight keys okx + ekm2 <- displayChoiceScreen "" ColorFull True slides keys + let km = either id (error $ "" `showFailure` ekm2) ekm2 + -- Here it stops differing. case K.key km of - K.Space -> chooseItemDialogMode leader False MPlaces - K.Up -> displayOneSlot $ slotIndex - 1 - K.Down -> displayOneSlot $ slotIndex + 1 - K.Esc -> failWith "never mind" - _ -> error $ "" `showFailure` km - displayOneSlot slotIndex0 - RModes slotIndex0 -> do + K.Up -> displayOneMenuItemBig renderOneItem extraKeys + slotBound $ pred slot + K.Down -> displayOneMenuItemBig renderOneItem extraKeys + slotBound $ succ slot + _ -> return km COps{comode} <- getsState scops - svictories <- getsClient svictories + svictories <- getsSession svictories nxtChal <- getsClient snxtChal -- mark victories only for current difficulty let f !acc _p !i !a = (i, a) : acc campaignModes = ofoldlGroup' comode MK.CAMPAIGN_SCENARIO f [] - slotListBound = length campaignModes - 1 - displayOneSlot slotIndex = do - let (gameModeId, gameMode) = campaignModes !! slotIndex - modeOKX <- describeMode False gameModeId + renderOneItem slot = do + let (gameModeId, gameMode) = campaignModes !! fromEnum slot + ov0 <- describeMode False gameModeId let victories = case EM.lookup gameModeId svictories of Nothing -> 0 Just cm -> fromMaybe 0 (M.lookup nxtChal cm) @@ -306,20 +337,15 @@ prompt2 = makeSentence [ MU.SubjectVerbSg "you" verb , MU.Text $ "the '" <> MK.mname gameMode <> "' adventure" ] - keys = [K.spaceKM, K.escKM] - ++ [K.upKM | slotIndex /= 0] - ++ [K.downKM | slotIndex /= slotListBound] msgAdd MsgPromptGeneric prompt2 - slides <- overlayToSlideshow rheight keys (modeOKX, []) - ekm2 <- displayChoiceScreen "" ColorFull True slides keys - let km = either id (error $ "" `showFailure` ekm2) ekm2 - case K.key km of - K.Space -> chooseItemDialogMode leader False MModes - K.Up -> displayOneSlot $ slotIndex - 1 - K.Down -> displayOneSlot $ slotIndex + 1 - K.Esc -> failWith "never mind" - _ -> error $ "" `showFailure` km - displayOneSlot slotIndex0 + return (ov0, []) + extraKeys = [] + slotBound = length campaignModes - 1 + km <- displayOneMenuItemBig renderOneItem extraKeys slotBound slot0 + case K.key km of + K.Space -> chooseItemDialogMode leader False MModes + K.Esc -> failWith "never mind" + _ -> error $ "" `showFailure` km Left err -> failWith err -- * ChooseItemProject @@ -395,7 +421,7 @@ let lid = blid sb spos = bpos sb -- Not @ScreenContent@, because not drawing here. - case bla eps spos tpos of + case bresenhamsLineAlgorithm eps spos tpos of Nothing -> return $ Just ProjectAimOnself Just [] -> error $ "project from the edge of level" `showFailure` (spos, tpos, sb) @@ -500,7 +526,18 @@ in Right (pos, 1 + IA.totalRange arItem (itemKind itemFull) >= chessDist (bpos b) pos) -triggerSymbols :: [HumanCmd.TriggerItem] -> [Char] +-- $setup +-- >>> import Game.LambdaHack.Definition.DefsInternal + +-- | +-- >>> let trigger1 = HumanCmd.TriggerItem{tiverb="verb", tiobject="object", tisymbols=[toContentSymbol 'a', toContentSymbol 'b']} +-- >>> let trigger2 = HumanCmd.TriggerItem{tiverb="verb2", tiobject="object2", tisymbols=[toContentSymbol 'c']} +-- >>> triggerSymbols [trigger1, trigger2] +-- "abc" +-- +-- >>> triggerSymbols [] +-- "" +triggerSymbols :: [HumanCmd.TriggerItem] -> [ContentSymbol IK.ItemKind] triggerSymbols [] = [] triggerSymbols (HumanCmd.TriggerItem{tisymbols} : ts) = tisymbols ++ triggerSymbols ts @@ -583,12 +620,12 @@ mactor = case drop k hs of [] -> Nothing (aid, b, _) : _ -> Just (aid, b) - mchoice = if MK.fhasGender (gplayer fact) then mhero else mactor - (autoDun, _) = autoDungeonLevel fact + mchoice = if FK.fhasGender (gkind fact) then mhero else mactor + banned = bannedPointmanSwitchBetweenLevels fact case mchoice of Nothing -> failMsg "no such member of the party" Just (aid, b) - | blid b /= arena && autoDun -> + | blid b /= arena && banned -> failMsg $ showReqFailure NoChangeDunLeader | otherwise -> do void $ pickLeader True aid @@ -730,11 +767,8 @@ -- * AllHistory -allHistoryHuman :: MonadClientUI m => m () -allHistoryHuman = eitherHistory True - -eitherHistory :: forall m. MonadClientUI m => Bool -> m () -eitherHistory showAll = do +allHistoryHuman :: forall m. MonadClientUI m => m () +allHistoryHuman = do CCUI{coscreen=ScreenContent{rwidth, rheight}} <- getsSession sccui history <- getsSession shistory arena <- getArenaUI @@ -742,14 +776,14 @@ global <- getsState stime FontSetup{..} <- getFontSetup let renderedHistoryRaw = renderHistory history - histBoundRaw = length renderedHistoryRaw + histLenRaw = length renderedHistoryRaw placeholderLine = textFgToAS Color.BrBlack "Newest_messages_are_at_the_bottom._Press_END_to_get_there." placeholderCount = - (- histBoundRaw `mod` (rheight - 4)) `mod` (rheight - 4) + (- histLenRaw `mod` (rheight - 4)) `mod` (rheight - 4) renderedHistory = replicate placeholderCount placeholderLine ++ renderedHistoryRaw - histBound = placeholderCount + histBoundRaw + histLen = placeholderCount + histLenRaw splitRow as = let (tLab, tDesc) = span (/= Color.spaceAttrW32) as labLen = textSize monoFont tLab @@ -769,18 +803,21 @@ , MU.CarWs turnsGlobal "half-second turn" , "(this level:" , MU.Car turnsLocal <> ")" ] - kxs = [ (Right sn, ( PointUI 0 (slotPrefix sn) + kxs = [ (Right sn, ( PointUI 0 (fromEnum sn) , ButtonWidth propFont 1000 )) - | sn <- take histBound intSlots ] + | sn <- take histLen natSlots ] msgAdd MsgPromptGeneric msg let keysAllHistory = K.returnKM #ifndef USE_JSFILE : K.mkChar '.' #endif - : [K.escKM] + : [K.spaceKM, K.escKM] slides <- overlayToSlideshow (rheight - 2) keysAllHistory (ovs, kxs) - let maxIx = length (concatMap snd $ slideshow slides) - 1 + let historyLines = case reverse $ concatMap snd $ slideshow slides of + (Left{}, _) : rest -> rest -- don't count the @--more--@ line + l -> l + maxIx = length historyLines - 1 - length keysAllHistory menuName = "history" modifySession $ \sess -> sess {smenuIxMap = M.insert menuName maxIx $ smenuIxMap sess} @@ -795,47 +832,46 @@ msgAdd MsgPromptGeneric $ "All of history dumped to file" <+> T.pack path <> "." Left km | km == K.escKM -> msgAdd MsgPromptGeneric "Try to survive a few seconds more, if you can." - Left km | km == K.spaceKM -> -- click in any unused space + Left km | km == K.spaceKM -> msgAdd MsgPromptGeneric "Steady on." - Right SlotChar{..} | slotChar == 'a' -> - displayOneReport $ max 0 $ slotPrefix - placeholderCount + Left km | km == K.returnKM -> + msgAdd MsgPromptGeneric "Press RET when history message selected to see it in full." + Right slot -> + displayOneReport $ toEnum $ max 0 $ fromEnum slot - placeholderCount _ -> error $ "" `showFailure` ekm - displayOneReport :: Int -> m () - displayOneReport histSlot = do - let timeReport = case drop histSlot renderedHistoryRaw of - [] -> error $ "" `showFailure` histSlot - tR : _ -> tR - (ovLab, ovDesc) = labDescOverlay monoFont rwidth timeReport - ov0 = EM.insertWith (++) monoFont ovLab - $ EM.singleton propFont ovDesc - prompt = makeSentence - [ "the", MU.Ordinal $ histSlot + 1 - , "most recent record follows" ] - keys = [K.spaceKM, K.escKM] - ++ [K.upKM | histSlot /= 0] - ++ [K.downKM | histSlot /= histBoundRaw - 1] - msgAdd MsgPromptGeneric prompt - slides2 <- overlayToSlideshow (rheight - 2) keys (ov0, []) - km <- getConfirms ColorFull keys slides2 + displayOneReport :: MenuSlot -> m () + displayOneReport slot0 = do + let renderOneItem slot = do + let timeReport = case drop (fromEnum slot) + renderedHistoryRaw of + [] -> error $ "" `showFailure` slot + tR : _ -> tR + markParagraph c | Color.charFromW32 c == '\n' = [c, c] + markParagraph c = [c] + reportWithParagraphs = concatMap markParagraph timeReport + (ovLab, ovDesc) = + labDescOverlay monoFont rwidth reportWithParagraphs + ov0 = EM.insertWith (++) monoFont ovLab + $ EM.singleton propFont ovDesc + prompt = makeSentence + [ "the", MU.Ordinal $ fromEnum slot + 1 + , "most recent record follows" ] + msgAdd MsgPromptGeneric prompt + return (ov0, []) + extraKeys = [] + slotBound = histLenRaw - 1 + km <- displayOneMenuItem renderOneItem extraKeys slotBound slot0 case K.key km of K.Space -> displayAllHistory - K.Up -> displayOneReport $ histSlot - 1 - K.Down -> displayOneReport $ histSlot + 1 - K.Esc -> msgAdd MsgPromptGeneric "Try to learn from your previous mistakes." + K.Esc -> msgAdd MsgPromptGeneric + "Try to learn from your previous mistakes." _ -> error $ "" `showFailure` km - if showAll - then displayAllHistory - else displayOneReport (histBoundRaw - 1) - --- * LastHistory - -lastHistoryHuman :: MonadClientUI m => m () -lastHistoryHuman = eitherHistory False + displayAllHistory -- * MarkVision -markVisionHuman :: MonadClientUI m => m () -markVisionHuman = modifySession cycleMarkVision +markVisionHuman :: MonadClientUI m => Int -> m () +markVisionHuman delta = modifySession $ cycleMarkVision delta -- * MarkSmell @@ -844,11 +880,11 @@ -- * MarkSuspect -markSuspectHuman :: MonadClient m => m () -markSuspectHuman = do +markSuspectHuman :: MonadClient m => Int -> m () +markSuspectHuman delta = do -- @condBFS@ depends on the setting we change here. invalidateBfsAll - modifyClient cycleMarkSuspect + modifyClient (cycleMarkSuspect delta) -- * MarkAnim @@ -860,8 +896,8 @@ -- * OverrideTut -overrideTutHuman :: MonadClientUI m => m () -overrideTutHuman = modifySession cycleOverrideTut +overrideTutHuman :: MonadClientUI m => Int -> m () +overrideTutHuman delta = modifySession $ cycleOverrideTut delta -- * PrintScreen @@ -942,35 +978,6 @@ setXHairFromGUI Nothing modifyClient $ updateTarget leader (const Nothing) doLook - --- | Perform look around in the current position of the xhair. --- Does nothing outside aiming mode. -doLook :: MonadClientUI m => m () -doLook = do - saimMode <- getsSession saimMode - case saimMode of - Just aimMode -> do - let lidV = aimLevelId aimMode - mxhairPos <- mxhairToPos - xhairPos <- xhairToPos - blurb <- lookAtPosition xhairPos lidV - itemSel <- getsSession sitemSel - mleader <- getsClient sleader - outOfRangeBlurb <- case (itemSel, mxhairPos, mleader) of - (Just (iid, _, _), Just pos, Just leader) -> do - b <- getsState $ getActorBody leader - if lidV /= blid b -- no range warnings on remote levels - || detailLevel aimMode < DetailAll -- no spam - then return [] - else do - itemFull <- getsState $ itemToFull iid - let arItem = aspectRecordFull itemFull - return [ (MsgPromptGeneric, "This position is out of range when flinging the selected item.") - | 1 + IA.totalRange arItem (itemKind itemFull) - < chessDist (bpos b) pos ] - _ -> return [] - mapM_ (uncurry msgAdd) $ blurb ++ outOfRangeBlurb - _ -> return () -- * ItemClear diff --git a/engine-src/Game/LambdaHack/Client/UI/HandleHumanM.hs b/engine-src/Game/LambdaHack/Client/UI/HandleHumanM.hs --- a/engine-src/Game/LambdaHack/Client/UI/HandleHumanM.hs +++ b/engine-src/Game/LambdaHack/Client/UI/HandleHumanM.hs @@ -136,10 +136,8 @@ MainMenuAutoOn -> CmdNoNeed $ mainMenuAutoOnHuman cmdSemInCxtOfKM MainMenuAutoOff -> CmdNoNeed $ mainMenuAutoOffHuman cmdSemInCxtOfKM Dashboard -> CmdNoNeed $ dashboardHuman cmdSemInCxtOfKM - GameTutorialToggle -> - CmdNoNeed $ gameTutorialToggle >> challengeMenuHuman cmdSemInCxtOfKM - GameDifficultyIncr -> - CmdNoNeed $ gameDifficultyIncr >> challengeMenuHuman cmdSemInCxtOfKM + GameDifficultyIncr delta -> + CmdNoNeed $ gameDifficultyIncr delta >> challengeMenuHuman cmdSemInCxtOfKM GameFishToggle -> CmdNoNeed $ gameFishToggle >> challengeMenuHuman cmdSemInCxtOfKM GameGoodsToggle -> @@ -148,11 +146,11 @@ CmdNoNeed $ gameWolfToggle >> challengeMenuHuman cmdSemInCxtOfKM GameKeeperToggle -> CmdNoNeed $ gameKeeperToggle >> challengeMenuHuman cmdSemInCxtOfKM - GameScenarioIncr -> - CmdNoNeed $ gameScenarioIncr >> challengeMenuHuman cmdSemInCxtOfKM + GameScenarioIncr delta -> + CmdNoNeed $ gameScenarioIncr delta >> challengeMenuHuman cmdSemInCxtOfKM - GameRestart -> CmdNoNeed $ weaveJust <$> gameRestartHuman - GameQuit -> CmdNoNeed $ weaveJust <$> gameQuitHuman + GameRestart -> CmdNoNeed $ weaveJust <$> gameExitWithHuman Restart + GameQuit -> CmdNoNeed $ weaveJust <$> gameExitWithHuman Quit GameDrop -> CmdNoNeed $ weaveJust <$> fmap Right gameDropHuman GameExit -> CmdNoNeed $ weaveJust <$> fmap Right gameExitHuman GameSave -> CmdNoNeed $ weaveJust <$> fmap Right gameSaveHuman @@ -169,7 +167,7 @@ CmdLeader $ \leader -> Left <$> chooseItemApplyHuman leader ts PickLeader k -> CmdNoNeed $ Left <$> pickLeaderHuman k PickLeaderWithPointer -> - CmdLeader $ \leader -> Left <$> pickLeaderWithPointerHuman leader + CmdLeader $ fmap Left . pickLeaderWithPointerHuman PointmanCycle direction -> CmdLeader $ \leader -> Left <$> pointmanCycleHuman leader direction PointmanCycleLevel direction -> @@ -181,17 +179,16 @@ RepeatLast n -> addNoError $ repeatLastHuman n Record -> addNoError recordHuman AllHistory -> addNoError allHistoryHuman - LastHistory -> addNoError lastHistoryHuman - MarkVision -> - CmdNoNeed $ markVisionHuman >> settingsMenuHuman cmdSemInCxtOfKM + MarkVision delta -> + CmdNoNeed $ markVisionHuman delta >> settingsMenuHuman cmdSemInCxtOfKM MarkSmell -> CmdNoNeed $ markSmellHuman >> settingsMenuHuman cmdSemInCxtOfKM - MarkSuspect -> - CmdNoNeed $ markSuspectHuman >> settingsMenuHuman cmdSemInCxtOfKM + MarkSuspect delta -> + CmdNoNeed $ markSuspectHuman delta >> settingsMenuHuman cmdSemInCxtOfKM MarkAnim -> CmdNoNeed $ markAnimHuman >> settingsMenuHuman cmdSemInCxtOfKM - OverrideTut -> - CmdNoNeed $ overrideTutHuman >> settingsMenuHuman cmdSemInCxtOfKM + OverrideTut delta -> + CmdNoNeed $ overrideTutHuman delta >> settingsMenuHuman cmdSemInCxtOfKM SettingsMenu -> CmdNoNeed $ settingsMenuHuman cmdSemInCxtOfKM ChallengeMenu -> CmdNoNeed $ challengeMenuHuman cmdSemInCxtOfKM PrintScreen -> addNoError printScreenHuman @@ -208,8 +205,8 @@ AimItem -> addNoError aimItemHuman AimAscend k -> CmdNoNeed $ Left <$> aimAscendHuman k EpsIncr b -> addNoError $ epsIncrHuman b - XhairUnknown -> CmdLeader $ \leader -> Left <$> xhairUnknownHuman leader - XhairItem -> CmdLeader $ \leader -> Left <$> xhairItemHuman leader + XhairUnknown -> CmdLeader $ fmap Left . xhairUnknownHuman + XhairItem -> CmdLeader $ fmap Left . xhairItemHuman XhairStair up -> CmdLeader $ \leader -> Left <$> xhairStairHuman leader up XhairPointerFloor -> addNoError xhairPointerFloorHuman XhairPointerMute -> addNoError xhairPointerMuteHuman @@ -225,5 +222,4 @@ CmdLeader $ \leader -> cmdCli leader >> return (Left Nothing) weaveLeader :: Monad m => (ActorId -> m (FailOrCmd ReqUI)) -> CmdLeaderNeed m -weaveLeader cmdCli = - CmdLeader $ \leader -> weaveJust <$> cmdCli leader +weaveLeader cmdCli = CmdLeader $ fmap weaveJust . cmdCli diff --git a/engine-src/Game/LambdaHack/Client/UI/HumanCmd.hs b/engine-src/Game/LambdaHack/Client/UI/HumanCmd.hs --- a/engine-src/Game/LambdaHack/Client/UI/HumanCmd.hs +++ b/engine-src/Game/LambdaHack/Client/UI/HumanCmd.hs @@ -133,13 +133,12 @@ | MainMenuAutoOff | Dashboard -- Below this line, commands do not take time. - | GameTutorialToggle - | GameDifficultyIncr + | GameDifficultyIncr Int | GameFishToggle | GameGoodsToggle | GameWolfToggle | GameKeeperToggle - | GameScenarioIncr + | GameScenarioIncr Int | GameRestart | GameQuit | GameDrop @@ -165,12 +164,11 @@ | RepeatLast Int | Record | AllHistory - | LastHistory - | MarkVision + | MarkVision Int | MarkSmell - | MarkSuspect + | MarkSuspect Int | MarkAnim - | OverrideTut + | OverrideTut Int | SettingsMenu | ChallengeMenu | PrintScreen diff --git a/engine-src/Game/LambdaHack/Client/UI/InventoryM.hs b/engine-src/Game/LambdaHack/Client/UI/InventoryM.hs --- a/engine-src/Game/LambdaHack/Client/UI/InventoryM.hs +++ b/engine-src/Game/LambdaHack/Client/UI/InventoryM.hs @@ -1,12 +1,16 @@ -- | UI of inventory management. module Game.LambdaHack.Client.UI.InventoryM ( Suitability(..), ResultItemDialogMode(..) - , slotsOfItemDialogMode, getFull, getGroupItem, getStoreItem - , skillCloseUp, placeCloseUp + , getFull, getGroupItem, getStoreItem + , skillCloseUp, placeCloseUp, factionCloseUp #ifdef EXPOSE_INTERNAL -- * Internal operations , ItemDialogState(..), accessModeBag, storeItemPrompt, getItem - , DefItemKey(..), transition, keyOfEKM, runDefItemKey, inventoryInRightPane + , DefItemKey(..), transition + , runDefMessage, runDefAction, runDefSkills, skillsInRightPane + , runDefPlaces, placesInRightPane + , runDefFactions, factionsInRightPane + , runDefModes, runDefInventory #endif ) where @@ -14,10 +18,10 @@ import Game.LambdaHack.Core.Prelude -import qualified Data.Char as Char import Data.Either import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES +import Data.Function import qualified Data.Text as T import qualified NLP.Miniutter.English as MU @@ -27,10 +31,8 @@ import Game.LambdaHack.Client.UI.Content.Screen import Game.LambdaHack.Client.UI.ContentClientUI import Game.LambdaHack.Client.UI.EffectDescription -import Game.LambdaHack.Client.UI.Frame import Game.LambdaHack.Client.UI.HandleHelperM import Game.LambdaHack.Client.UI.HumanCmd -import Game.LambdaHack.Client.UI.ItemSlot import qualified Game.LambdaHack.Client.UI.Key as K import Game.LambdaHack.Client.UI.MonadClientUI import Game.LambdaHack.Client.UI.Msg @@ -43,13 +45,14 @@ import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.ClientOptions import Game.LambdaHack.Common.Faction +import qualified Game.LambdaHack.Common.Faction as Faction import Game.LambdaHack.Common.Item -import qualified Game.LambdaHack.Common.ItemAspect as IA import Game.LambdaHack.Common.Kind import Game.LambdaHack.Common.Misc import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.State import Game.LambdaHack.Common.Types +import qualified Game.LambdaHack.Content.FactionKind as FK import qualified Game.LambdaHack.Content.ItemKind as IK import qualified Game.LambdaHack.Content.PlaceKind as PK import qualified Game.LambdaHack.Definition.Ability as Ability @@ -61,53 +64,27 @@ data ResultItemDialogMode = RStore CStore [ItemId] - | ROrgans ItemId ItemBag SingleItemSlots | ROwned ItemId - | RSkills Int - | RLore SLore ItemId ItemBag SingleItemSlots - | RPlaces Int - | RModes Int + | RLore SLore MenuSlot [(ItemId, ItemQuant)] + | RSkills MenuSlot + | RPlaces MenuSlot + | RFactions MenuSlot + | RModes MenuSlot deriving Show accessModeBag :: ActorId -> State -> ItemDialogMode -> ItemBag accessModeBag leader s (MStore cstore) = let b = getActorBody leader s in getBodyStoreBag b cstore s -accessModeBag leader s MOrgans = let b = getActorBody leader s - in getBodyStoreBag b COrgan s accessModeBag leader s MOwned = let fid = bfid $ getActorBody leader s in combinedItems fid s accessModeBag _ _ MSkills = EM.empty +accessModeBag leader s (MLore SBody) = let b = getActorBody leader s + in getBodyStoreBag b COrgan s accessModeBag _ s MLore{} = EM.map (const quantSingle) $ sitemD s accessModeBag _ _ MPlaces = EM.empty +accessModeBag _ _ MFactions = EM.empty accessModeBag _ _ MModes = EM.empty --- This is the only place slots are sorted. As a side-effect, --- slots in inventories always agree with slots of item lore. --- Not so for organ menu, because many lore maps point there. --- Sorting in @updateItemSlot@ would not be enough, because, e.g., --- identifying an item should change its slot position. -slotsOfItemDialogMode :: MonadClientUI m => ItemDialogMode -> m SingleItemSlots -slotsOfItemDialogMode cCur = do - itemToF <- getsState $ flip itemToFull - ItemSlots itemSlotsPre <- getsSession sslots - case cCur of - MOrgans -> do - let newSlots = EM.adjust (sortSlotMap itemToF) SOrgan - $ EM.adjust (sortSlotMap itemToF) STrunk - $ EM.adjust (sortSlotMap itemToF) SCondition itemSlotsPre - modifySession $ \sess -> sess {sslots = ItemSlots newSlots} - return $! mergeItemSlots itemToF [ newSlots EM.! SOrgan - , newSlots EM.! STrunk - , newSlots EM.! SCondition ] - MSkills -> return EM.empty - MPlaces -> return EM.empty - MModes -> return EM.empty - _ -> do - let slore = IA.loreFromMode cCur - newSlots = EM.adjust (sortSlotMap itemToF) slore itemSlotsPre - modifySession $ \sess -> sess {sslots = ItemSlots newSlots} - return $! newSlots EM.! slore - -- | Let a human player choose any item from a given group. -- Note that this does not guarantee the chosen item belongs to the group, -- as the player can override the choice. @@ -152,15 +129,27 @@ -> m (Either Text ResultItemDialogMode) getStoreItem leader cInitial = do side <- getsClient sside - let itemCs = map MStore [CStash, CEqp, CGround] - -- No @COrgan@, because triggerable organs are rare and, - -- if really needed, accessible directly from the trigger menu. - loreCs = map MLore [minBound..maxBound] ++ [MPlaces, MModes] - allCs = case cInitial of - MLore{} -> loreCs - MPlaces -> loreCs - MModes -> loreCs - _ -> itemCs ++ [MOwned, MOrgans, MSkills] + let -- No @COrgan@, because triggerable organs are rare and, + -- if really needed, accessible directly from the trigger menu. + itemCs = map MStore [CStash, CEqp, CGround] + -- This should match, including order, the items in standardKeysAndMouse + -- marked with CmdDashboard up to @MSkills@. + leaderCs = itemCs ++ [MOwned, MLore SBody, MSkills] + -- No @SBody@, because repeated in other lores and included elsewhere. + itemLoreCs = map MLore [minBound..SEmbed] + -- This should match, including order, the items in standardKeysAndMouse + -- marked with CmdDashboard past @MSkills@ and up to @MModes@. + loreCs = itemLoreCs ++ [MPlaces, MFactions, MModes] + let !_A1 = assert (null (leaderCs `intersect` loreCs)) () + !_A2 = assert (sort (leaderCs ++ loreCs ++ [MStore COrgan]) + == map MStore [minBound..maxBound] + ++ [MOwned, MSkills] + ++ map MLore [minBound..maxBound] + ++ [MPlaces, MFactions, MModes]) () + allCs | cInitial `elem` leaderCs = leaderCs + | cInitial `elem` loreCs = loreCs + | otherwise = assert (cInitial == MStore COrgan) leaderCs + -- werrd content, but let it be (pre, rest) = break (== cInitial) allCs post = dropWhile (== cInitial) rest remCs = post ++ pre @@ -218,11 +207,6 @@ in makePhrase $ [ MU.Capitalize $ MU.SubjectVerbSg subject verb , nItems, MU.Text tIn ] ++ ownObject ++ onLevel - MOrgans -> - makePhrase - [ MU.Capitalize $ MU.SubjectVerbSg subject "feel" - , MU.Text tIn - , MU.WownW (MU.Text $ bpronoun bodyUI) $ MU.Text t ] MOwned -> -- We assume "gold grain", not "grain" with label "of gold": let currencyName = IK.iname $ okind coitem @@ -235,6 +219,11 @@ makePhrase [ MU.Capitalize $ MU.SubjectVerbSg subject "estimate" , MU.WownW (MU.Text $ bpronoun bodyUI) $ MU.Text t ] + MLore SBody -> + makePhrase + [ MU.Capitalize $ MU.SubjectVerbSg subject "feel" + , MU.Text tIn + , MU.WownW (MU.Text $ bpronoun bodyUI) $ MU.Text t ] MLore slore -> makePhrase [ MU.Capitalize $ MU.Text $ @@ -244,6 +233,9 @@ MPlaces -> makePhrase [ MU.Capitalize $ MU.Text t ] + MFactions -> + makePhrase + [ MU.Capitalize $ MU.Text t ] MModes -> makePhrase [ MU.Capitalize $ MU.Text t ] @@ -325,12 +317,13 @@ ([(iid, _)], MStore rstore) | null cRest && not askWhenLone -> return $ Right $ RStore rstore [iid] _ -> transition leader psuit prompt promptGeneric permitMulitple - 0 cCur cRest ISuitable + cCur cRest ISuitable data DefItemKey m = DefItemKey { defLabel :: Either Text K.KM , defCond :: Bool - , defAction :: KeyOrSlot -> m (Either Text ResultItemDialogMode) + , defAction :: ~(m (Either Text ResultItemDialogMode)) + -- this field may be expensive or undefined when @defCond@ is false } data Suitability = @@ -345,131 +338,35 @@ -> (Actor -> ActorUI -> Ability.Skills -> ItemDialogMode -> State -> Text) -> Bool - -> Int -> ItemDialogMode -> [ItemDialogMode] -> ItemDialogState -> m (Either Text ResultItemDialogMode) transition leader psuit prompt promptGeneric permitMulitple - numPrefix cCur cRest itemDialogState = do - let recCall numPrefix2 cCur2 cRest2 itemDialogState2 = do + cCur cRest itemDialogState = do + let recCall cCur2 cRest2 itemDialogState2 = do -- Pointman could have been changed by keypresses near the end of -- the current recursive call, so refresh it for the next call. mleader <- getsClient sleader - let leader2 = fromMaybe (error "UI manipulation killed the pointman") - mleader + -- When run inside a test, without mleader, assume leader not changed. + let leader2 = fromMaybe leader mleader transition leader2 psuit prompt promptGeneric permitMulitple - numPrefix2 cCur2 cRest2 itemDialogState2 + cCur2 cRest2 itemDialogState2 actorCurAndMaxSk <- getsState $ getActorMaxSkills leader body <- getsState $ getActorBody leader bodyUI <- getsSession $ getActorUI leader fact <- getsState $ (EM.! bfid body) . sfactionD hs <- partyAfterLeader leader - bagAll <- getsState $ \s -> accessModeBag leader s cCur - itemToF <- getsState $ flip itemToFull revCmd <- revCmdMap - mpsuit <- psuit -- when throwing, this sets eps and checks xhair validity - psuitFun <- case mpsuit of - SuitsEverything -> return $ \_ _ _ -> True - SuitsSomething f -> return f -- When throwing, this function takes - -- missile range into accout. - lSlots <- slotsOfItemDialogMode cCur - let getResult :: [ItemId] -> Either Text ResultItemDialogMode - getResult iids = Right $ case cCur of - MStore rstore -> RStore rstore iids - MOrgans -> case iids of - [iid] -> ROrgans iid bagAll bagItemSlotsAll - _ -> error $ "" `showFailure` (cCur, iids) - MOwned -> case iids of - [iid] -> ROwned iid - _ -> error $ "" `showFailure` (cCur, iids) - MSkills -> error $ "" `showFailure` cCur - MLore rlore -> case iids of - [iid] -> RLore rlore iid bagAll bagItemSlotsAll - _ -> error $ "" `showFailure` (cCur, iids) - MPlaces -> error $ "" `showFailure` cCur - MModes -> error $ "" `showFailure` cCur - mstore = case cCur of - MStore store -> Just store - _ -> Nothing - filterP iid = psuitFun mstore (itemToF iid) - bagAllSuit = EM.filterWithKey filterP bagAll - bagItemSlotsAll = EM.filter (`EM.member` bagAll) lSlots - -- Predicate for slot matching the current prefix, unless the prefix - -- is 0, in which case we display all slots, even if they require - -- the user to start with number keys to get to them. - -- Could be generalized to 1 if prefix 1x exists, etc., but too rare. - hasPrefixOpen x _ = slotPrefix x == numPrefix || numPrefix == 0 - bagItemSlotsOpen = EM.filterWithKey hasPrefixOpen bagItemSlotsAll - hasPrefix x _ = slotPrefix x == numPrefix - bagItemSlots = EM.filterWithKey hasPrefix bagItemSlotsOpen - bag = EM.fromList $ map (\iid -> (iid, bagAll EM.! iid)) - (EM.elems bagItemSlotsOpen) - suitableItemSlotsAll = EM.filter (`EM.member` bagAllSuit) lSlots - suitableItemSlotsOpen = - EM.filterWithKey hasPrefixOpen suitableItemSlotsAll - bagSuit = EM.fromList $ map (\iid -> (iid, bagAllSuit EM.! iid)) - (EM.elems suitableItemSlotsOpen) - nextContainers direction = case direction of - Forward -> case cRest ++ [cCur] of - c1 : rest -> (c1, rest) - [] -> error $ "" `showFailure` cRest - Backward -> case reverse $ cCur : cRest of - c1 : rest -> (c1, reverse rest) - [] -> error $ "" `showFailure` cRest - (bagFiltered, promptChosen) <- getsState $ \s -> - case itemDialogState of - ISuitable -> (bagSuit, prompt body bodyUI actorCurAndMaxSk cCur s <> ":") - IAll -> (bag, promptGeneric body bodyUI actorCurAndMaxSk cCur s <> ":") - let (autoDun, _) = autoDungeonLevel fact - multipleSlots = if itemDialogState == IAll - then bagItemSlotsAll - else suitableItemSlotsAll - maySwitchLeader MOwned = False - maySwitchLeader MLore{} = False - maySwitchLeader MPlaces = False - maySwitchLeader MModes = False - maySwitchLeader _ = True - cycleKeyDef direction = - let km = revCmd $ PointmanCycle direction - in (km, DefItemKey - { defLabel = if direction == Forward then Right km else Left "" - , defCond = maySwitchLeader cCur && not (autoDun || null hs) - , defAction = \_ -> do - err <- pointmanCycle leader False direction - let !_A = assert (isNothing err `blame` err) () - recCall numPrefix cCur cRest itemDialogState - }) - cycleLevelKeyDef direction = - let km = revCmd $ PointmanCycleLevel direction - in (km, DefItemKey - { defLabel = Left "" - , defCond = maySwitchLeader cCur - && any (\(_, b, _) -> blid b == blid body) hs - , defAction = \_ -> do - err <- pointmanCycleLevel leader False direction - let !_A = assert (isNothing err `blame` err) () - recCall numPrefix cCur cRest itemDialogState - }) - keyDefs :: [(K.KM, DefItemKey m)] - keyDefs = filter (defCond . snd) $ + promptChosen <- getsState $ \s -> case itemDialogState of + ISuitable -> prompt body bodyUI actorCurAndMaxSk cCur s <> ":" + IAll -> promptGeneric body bodyUI actorCurAndMaxSk cCur s <> ":" + let keyDefsCommon :: [(K.KM, DefItemKey m)] + keyDefsCommon = filter (defCond . snd) [ let km = K.mkChar '<' in (km, changeContainerDef Backward $ Right km) , let km = K.mkChar '>' in (km, changeContainerDef Forward $ Right km) - , let km = K.mkChar '+' - in (km, DefItemKey - { defLabel = Right km - , defCond = bag /= bagSuit - , defAction = \_ -> recCall numPrefix cCur cRest - $ case itemDialogState of - ISuitable -> IAll - IAll -> ISuitable - }) - , let km = K.mkChar '*' - in (km, useMultipleDef $ Right km) - , let km = K.mkChar '!' - in (km, useMultipleDef $ Left "") -- alias close to 'g' , cycleKeyDef Forward , cycleKeyDef Backward , cycleLevelKeyDef Forward @@ -477,203 +374,286 @@ , (K.KM K.NoModifier K.LeftButtonRelease, DefItemKey { defLabel = Left "" , defCond = maySwitchLeader cCur && not (null hs) - , defAction = \_ -> do + , defAction = do + -- This is verbose even in aiming mode, displaying + -- terrain description, but it's fine, mouse may do that. merror <- pickLeaderWithPointer leader case merror of - Nothing -> recCall numPrefix cCur cRest itemDialogState + Nothing -> recCall cCur cRest itemDialogState Just{} -> return $ Left "not a menu item nor teammate position" -- don't inspect the error, it's expected }) , (K.escKM, DefItemKey { defLabel = Right K.escKM , defCond = True - , defAction = \_ -> return $ Left "never mind" + , defAction = return $ Left "never mind" }) ] - ++ numberPrefixes + cycleLevelKeyDef direction = + let km = revCmd $ PointmanCycleLevel direction + in (km, DefItemKey + { defLabel = Left "" + , defCond = maySwitchLeader cCur + && any (\(_, b, _) -> blid b == blid body) hs + , defAction = do + err <- pointmanCycleLevel leader False direction + let !_A = assert (isNothing err `blame` err) () + recCall cCur cRest itemDialogState + }) changeContainerDef direction defLabel = let (cCurAfterCalm, cRestAfterCalm) = nextContainers direction in DefItemKey { defLabel , defCond = cCurAfterCalm /= cCur - , defAction = \_ -> - recCall numPrefix cCurAfterCalm cRestAfterCalm itemDialogState + , defAction = recCall cCurAfterCalm cRestAfterCalm itemDialogState } - useMultipleDef defLabel = DefItemKey - { defLabel - , defCond = permitMulitple && not (EM.null multipleSlots) - , defAction = \_ -> - let eslots = EM.elems multipleSlots - in return $! getResult eslots - } - prefixCmdDef d = - (K.mkChar $ Char.intToDigit d, DefItemKey - { defLabel = Left "" - , defCond = True - , defAction = \_ -> - recCall (10 * numPrefix + d) cCur cRest itemDialogState - }) - numberPrefixes = map prefixCmdDef [0..9] - lettersDef :: DefItemKey m - lettersDef = DefItemKey - { defLabel = Left "" - , defCond = True - , defAction = \ekm -> - let slot = case ekm of - Left K.KM{key=K.Char l} -> SlotChar numPrefix l - Left km -> - error $ "unexpected key:" `showFailure` K.showKM km - Right sl -> sl - in case EM.lookup slot bagItemSlotsAll of - Nothing -> error $ "unexpected slot" - `showFailure` (slot, bagItemSlots) - Just iid -> return $! getResult [iid] - } - processSpecialOverlay :: OKX -> (Int -> ResultItemDialogMode) - -> m (Either Text ResultItemDialogMode) - processSpecialOverlay io resultConstructor = do - let slotLabels = map fst $ snd io - slotKeys = mapMaybe (keyOfEKM numPrefix) slotLabels - skillsDef :: DefItemKey m - skillsDef = DefItemKey - { defLabel = Left "" - , defCond = True - , defAction = \ekm -> - let slot = case ekm of - Left K.KM{key} -> case key of - K.Char l -> SlotChar numPrefix l - _ -> error $ "unexpected key:" - `showFailure` K.showKey key - Right sl -> sl - slotIndex = fromMaybe (error "illegal slot") - $ elemIndex slot allSlots - in return (Right (resultConstructor slotIndex)) - } - runDefItemKey leader lSlots bagFiltered keyDefs skillsDef io slotKeys - promptChosen cCur + nextContainers direction = case direction of + Forward -> case cRest ++ [cCur] of + c1 : rest -> (c1, rest) + [] -> error $ "" `showFailure` cRest + Backward -> case reverse $ cCur : cRest of + c1 : rest -> (c1, reverse rest) + [] -> error $ "" `showFailure` cRest + banned = bannedPointmanSwitchBetweenLevels fact + maySwitchLeader MStore{} = True + maySwitchLeader MOwned = False + maySwitchLeader MSkills = True + maySwitchLeader (MLore SBody) = True + maySwitchLeader MLore{} = False + maySwitchLeader MPlaces = False + maySwitchLeader MFactions = False + maySwitchLeader MModes = False + cycleKeyDef direction = + let km = revCmd $ PointmanCycle direction + in (km, DefItemKey + { defLabel = if direction == Forward then Right km else Left "" + , defCond = maySwitchLeader cCur && not (banned || null hs) + , defAction = do + err <- pointmanCycle leader False direction + let !_A = assert (isNothing err `blame` err) () + recCall cCur cRest itemDialogState + }) case cCur of - MSkills -> do - io <- skillsOverlay leader - processSpecialOverlay io RSkills - MPlaces -> do - io <- placesOverlay - processSpecialOverlay io RPlaces - MModes -> do - io <- modesOverlay - processSpecialOverlay io RModes + MSkills -> runDefSkills keyDefsCommon promptChosen leader + MPlaces -> runDefPlaces keyDefsCommon promptChosen + MFactions -> runDefFactions keyDefsCommon promptChosen + MModes -> runDefModes keyDefsCommon promptChosen _ -> do - let displayRanged = - cCur `notElem` [MStore COrgan, MOrgans, MLore SOrgan, MLore STrunk] - io <- itemOverlay lSlots (blid body) bagFiltered displayRanged - let slotKeys = mapMaybe (keyOfEKM numPrefix . Right) - $ EM.keys bagItemSlots - runDefItemKey leader lSlots bagFiltered keyDefs lettersDef io slotKeys - promptChosen cCur - -keyOfEKM :: Int -> KeyOrSlot -> Maybe K.KM -keyOfEKM _ (Left kms) = error $ "" `showFailure` kms -keyOfEKM numPrefix (Right SlotChar{..}) | slotPrefix == numPrefix = - Just $ K.mkChar slotChar -keyOfEKM _ _ = Nothing + bagHuge <- getsState $ \s -> accessModeBag leader s cCur + itemToF <- getsState $ flip itemToFull + mpsuit <- psuit -- when throwing, this sets eps and checks xhair validity + psuitFun <- case mpsuit of + SuitsEverything -> return $ \_ _ _ -> True + SuitsSomething f -> return f -- When throwing, this function takes + -- missile range into accout. + ItemRoles itemRoles <- getsSession sroles + let slore = loreFromMode cCur + itemRole = itemRoles EM.! slore + bagAll = EM.filterWithKey (\iid _ -> iid `ES.member` itemRole) bagHuge + mstore = case cCur of + MStore store -> Just store + _ -> Nothing + filterP = psuitFun mstore . itemToF + bagSuit = EM.filterWithKey filterP bagAll + bagFiltered = case itemDialogState of + ISuitable -> bagSuit + IAll -> bagAll + iids = sortIids itemToF $ EM.assocs bagFiltered + keyDefsExtra = + [ let km = K.mkChar '+' + in (km, DefItemKey + { defLabel = Right km + , defCond = bagAll /= bagSuit + , defAction = recCall cCur cRest $ case itemDialogState of + ISuitable -> IAll + IAll -> ISuitable + }) + , let km = K.mkChar '*' + in (km, useMultipleDef $ Right km) + , let km = K.mkChar '!' + in (km, useMultipleDef $ Left "") -- alias close to 'g' + ] + useMultipleDef defLabel = DefItemKey + { defLabel + , defCond = permitMulitple && not (null iids) + , defAction = case cCur of + MStore rstore -> return $! Right $ RStore rstore $ map fst iids + _ -> error "transition: multiple items not for MStore" + } + keyDefs = keyDefsCommon ++ filter (defCond . snd) keyDefsExtra + runDefInventory keyDefs promptChosen leader cCur iids --- We don't create keys from slots in @okx@, so they have to be --- exolicitly given in @slotKeys@. -runDefItemKey :: MonadClientUI m - => ActorId - -> SingleItemSlots - -> ItemBag - -> [(K.KM, DefItemKey m)] - -> DefItemKey m - -> OKX - -> [K.KM] +runDefMessage :: MonadClientUI m + => [(K.KM, DefItemKey m)] -> Text - -> ItemDialogMode - -> m (Either Text ResultItemDialogMode) -runDefItemKey leader lSlots bag keyDefs lettersDef okx slotKeys prompt cCur = do - let itemKeys = slotKeys ++ map fst keyDefs - wrapB s = "[" <> s <> "]" - (keyLabelsRaw, keys) = partitionEithers $ map (defLabel . snd) keyDefs + -> m () +runDefMessage keyDefs prompt = do + let wrapB s = "[" <> s <> "]" + keyLabelsRaw = lefts $ map (defLabel . snd) keyDefs keyLabels = filter (not . T.null) keyLabelsRaw choice = T.intercalate " " $ map wrapB $ nub keyLabels -- switch to Data.Containers.ListUtils.nubOrd when we drop GHC 8.4.4 msgAdd MsgPromptGeneric $ prompt <+> choice + +runDefAction :: MonadClientUI m + => [(K.KM, DefItemKey m)] + -> (MenuSlot -> Either Text ResultItemDialogMode) + -> KeyOrSlot + -> m (Either Text ResultItemDialogMode) +runDefAction keyDefs slotDef ekm = case ekm of + Left km -> case km `lookup` keyDefs of + Just keyDef -> defAction keyDef + Nothing -> error $ "unexpected key:" `showFailure` K.showKM km + Right slot -> return $! slotDef slot + +runDefSkills :: MonadClientUI m + => [(K.KM, DefItemKey m)] -> Text -> ActorId + -> m (Either Text ResultItemDialogMode) +runDefSkills keyDefsCommon promptChosen leader = do CCUI{coscreen=ScreenContent{rheight}} <- getsSession sccui - ekm <- do - sli <- overlayToSlideshow (rheight - 2) keys okx - displayChoiceScreenWithRightPane - (inventoryInRightPane leader lSlots bag cCur) - (show cCur) ColorFull False sli itemKeys - case ekm of - Left km -> case km `lookup` keyDefs of - Just keyDef -> defAction keyDef ekm - Nothing -> defAction lettersDef ekm -- pressed; with current prefix - Right _slot -> defAction lettersDef ekm -- selected; with the given prefix + runDefMessage keyDefsCommon promptChosen + let itemKeys = map fst keyDefsCommon + keys = rights $ map (defLabel . snd) keyDefsCommon + okx <- skillsOverlay leader + sli <- overlayToSlideshow (rheight - 2) keys okx + ekm <- displayChoiceScreenWithDefItemKey + (skillsInRightPane leader) sli itemKeys (show MSkills) + runDefAction keyDefsCommon (Right . RSkills) ekm -inventoryInRightPane :: MonadClientUI m - => ActorId -> SingleItemSlots -> ItemBag -> ItemDialogMode - -> KeyOrSlot - -> m OKX -inventoryInRightPane leader lSlots bag c ekm = case ekm of - Left{} -> return emptyOKX - Right slot -> do - CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui - FontSetup{..} <- getFontSetup - let -- Lower width, to permit extra vertical space at the start, - -- because gameover menu prompts are sometimes wide and/or long. - width = rwidth - 2 - slotIndex = fromMaybe (error "illegal slot") $ elemIndex slot allSlots - case c of - _ | isSquareFont propFont -> return emptyOKX - MSkills -> do - (prompt, attrString) <- skillCloseUp leader slotIndex - let promptAS | T.null prompt = [] - | otherwise = textFgToAS Color.Brown $ prompt <> "\n\n" - ov = EM.singleton propFont $ offsetOverlay - $ splitAttrString width width - $ promptAS ++ attrString - return (ov, []) - MPlaces -> do - COps{coplace} <- getsState scops - soptions <- getsClient soptions - -- This is very slow when many places are exposed, - -- because this is computed once per place menu keypress. - -- Fortunately, the mode after entering a place and with pressing - -- up and down arrow keys is not quadratic, so should be used instead, - -- particularly with @sexposePlaces@. - places <- getsState $ EM.assocs - . placesFromState coplace (sexposePlaces soptions) - (prompt, blurbs) <- - placeCloseUp places (sexposePlaces soptions) slotIndex - let promptAS | T.null prompt = [] - | otherwise = textFgToAS Color.Brown $ prompt <> "\n\n" - ov = attrLinesToFontMap - $ map (second $ concatMap (splitAttrString width width)) - $ (propFont, [promptAS]) : map (second $ map textToAS) blurbs - return (ov, []) - MModes -> return emptyOKX - -- modes cover the right part of screen, so let's keep it empty - _ -> do - let ix0 = fromMaybe (error $ show slot) - (elemIndex slot $ EM.keys lSlots) - promptFun _iid _itemFull _k = "" - -- TODO, e.g., if the party still owns any copies, if the actor - -- was ever killed by us or killed ours, etc. - -- This can be the same prompt or longer than what entering - -- the item screen shows. - -- Mono font used, because lots of numbers in these blurbs - -- and because some prop fonts wider than mono (e.g., in the - -- dejavuBold font set). - -- A side effect is a larger space between the symbol and description, - -- so this is not a bug, not a double space, not worth focusing on. - okxItemLorePointedAt - monoFont (rwidth - 2) True bag 0 promptFun ix0 lSlots +skillsInRightPane :: MonadClientUI m => ActorId -> Int -> MenuSlot -> m OKX +skillsInRightPane leader width slot = do + FontSetup{propFont} <- getFontSetup + (prompt, attrString) <- skillCloseUp leader slot + let promptAS | T.null prompt = [] + | otherwise = textFgToAS Color.Brown $ prompt <> "\n\n" + ov = EM.singleton propFont $ offsetOverlay + $ splitAttrString width width + $ promptAS ++ attrString + return (ov, []) -skillCloseUp :: MonadClientUI m => ActorId -> Int -> m (Text, AttrString) -skillCloseUp leader slotIndex = do +runDefPlaces :: MonadClientUI m + => [(K.KM, DefItemKey m)] -> Text + -> m (Either Text ResultItemDialogMode) +runDefPlaces keyDefsCommon promptChosen = do + COps{coplace} <- getsState scops + CCUI{coscreen=ScreenContent{rheight}} <- getsSession sccui + soptions <- getsClient soptions + places <- getsState $ EM.assocs + . placesFromState coplace (sexposePlaces soptions) + runDefMessage keyDefsCommon promptChosen + let itemKeys = map fst keyDefsCommon + keys = rights $ map (defLabel . snd) keyDefsCommon + okx <- placesOverlay + sli <- overlayToSlideshow (rheight - 2) keys okx + ekm <- displayChoiceScreenWithDefItemKey + (placesInRightPane places) sli itemKeys (show MPlaces) + runDefAction keyDefsCommon (Right . RPlaces) ekm + +placesInRightPane :: MonadClientUI m + => [( ContentId PK.PlaceKind + , (ES.EnumSet LevelId, Int, Int, Int) )] + -> Int -> MenuSlot + -> m OKX +placesInRightPane places width slot = do + FontSetup{propFont} <- getFontSetup + soptions <- getsClient soptions + (prompt, blurbs) <- placeCloseUp places (sexposePlaces soptions) slot + let promptAS | T.null prompt = [] + | otherwise = textFgToAS Color.Brown $ prompt <> "\n\n" + splitText = splitAttrString width width + ov = attrLinesToFontMap + $ map (second $ concatMap splitText) + $ (propFont, [promptAS]) : blurbs + return (ov, []) + +runDefFactions :: MonadClientUI m + => [(K.KM, DefItemKey m)] -> Text + -> m (Either Text ResultItemDialogMode) +runDefFactions keyDefsCommon promptChosen = do + CCUI{coscreen=ScreenContent{rheight}} <- getsSession sccui + sroles <- getsSession sroles + factions <- getsState $ factionsFromState sroles + runDefMessage keyDefsCommon promptChosen + let itemKeys = map fst keyDefsCommon + keys = rights $ map (defLabel . snd) keyDefsCommon + okx <- factionsOverlay + sli <- overlayToSlideshow (rheight - 2) keys okx + ekm <- displayChoiceScreenWithDefItemKey + (factionsInRightPane factions) + sli itemKeys (show MFactions) + runDefAction keyDefsCommon (Right . RFactions) ekm + +factionsInRightPane :: MonadClientUI m + => [(FactionId, Faction)] + -> Int -> MenuSlot + -> m OKX +factionsInRightPane factions width slot = do + FontSetup{propFont} <- getFontSetup + (prompt, blurbs) <- factionCloseUp factions slot + let promptAS | T.null prompt = [] + | otherwise = textFgToAS Color.Brown $ prompt <> "\n\n" + splitText = splitAttrString width width + ov = attrLinesToFontMap + $ map (second $ concatMap splitText) + $ (propFont, [promptAS]) : blurbs + return (ov, []) + +runDefModes :: MonadClientUI m + => [(K.KM, DefItemKey m)] -> Text + -> m (Either Text ResultItemDialogMode) +runDefModes keyDefsCommon promptChosen = do + CCUI{coscreen=ScreenContent{rheight}} <- getsSession sccui + runDefMessage keyDefsCommon promptChosen + let itemKeys = map fst keyDefsCommon + keys = rights $ map (defLabel . snd) keyDefsCommon + okx <- modesOverlay + sli <- overlayToSlideshow (rheight - 2) keys okx + -- Modes would cover the whole screen, so we don't display in right pane. + -- But we display and highlight menu bullets. + ekm <- displayChoiceScreenWithDefItemKey + (\_ _ -> return emptyOKX) sli itemKeys (show MModes) + runDefAction keyDefsCommon (Right . RModes) ekm + +runDefInventory :: MonadClientUI m + => [(K.KM, DefItemKey m)] + -> Text + -> ActorId + -> ItemDialogMode + -> [(ItemId, ItemQuant)] + -> m (Either Text ResultItemDialogMode) +runDefInventory keyDefs promptChosen leader dmode iids = do + CCUI{coscreen=ScreenContent{rheight}} <- getsSession sccui + actorCurAndMaxSk <- getsState $ getActorMaxSkills leader + let meleeSkill = Ability.getSk Ability.SkHurtMelee actorCurAndMaxSk + slotDef :: MenuSlot -> Either Text ResultItemDialogMode + slotDef slot = + let iid = fst $ iids !! fromEnum slot + in Right $ case dmode of + MStore rstore -> RStore rstore [iid] + MOwned -> ROwned iid + MLore rlore -> RLore rlore slot iids + _ -> error $ "" `showFailure` dmode + promptFun _iid _itemFull _k = "" + -- TODO, e.g., if the party still owns any copies, if the actor + -- was ever killed by us or killed ours, etc. + -- This can be the same prompt or longer than what entering + -- the item screen shows. + runDefMessage keyDefs promptChosen + let itemKeys = map fst keyDefs + keys = rights $ map (defLabel . snd) keyDefs + okx <- itemOverlay iids dmode + sli <- overlayToSlideshow (rheight - 2) keys okx + ekm <- displayChoiceScreenWithDefItemKey + (okxItemLoreInline promptFun meleeSkill dmode iids) + sli itemKeys (show dmode) + runDefAction keyDefs slotDef ekm + +skillCloseUp :: MonadClientUI m => ActorId -> MenuSlot -> m (Text, AttrString) +skillCloseUp leader slot = do b <- getsState $ getActorBody leader bUI <- getsSession $ getActorUI leader actorCurAndMaxSk <- getsState $ getActorMaxSkills leader - let skill = skillSlots !! slotIndex + let skill = skillsInDisplayOrder !! fromEnum slot valueText = skillToDecorator skill b $ Ability.getSk skill actorCurAndMaxSk prompt = makeSentence @@ -685,12 +665,12 @@ placeCloseUp :: MonadClientUI m => [(ContentId PK.PlaceKind, (ES.EnumSet LevelId, Int, Int, Int))] -> Bool - -> Int - -> m (Text, [(DisplayFont, [Text])]) -placeCloseUp places sexposePlaces slotIndex = do + -> MenuSlot + -> m (Text, [(DisplayFont, [AttrString])]) +placeCloseUp places sexposePlaces slot = do COps{coplace} <- getsState scops FontSetup{..} <- getFontSetup - let (pk, (es, ne, na, _)) = places !! slotIndex + let (pk, (es, ne, na, _)) = places !! fromEnum slot pkind = okind coplace pk prompt = makeSentence ["you remember", MU.Text $ PK.pname pkind] freqsText = "Frequencies:" <+> T.intercalate " " @@ -709,10 +689,96 @@ ++ [MU.CarWs na "surrounding" | na > 0] partsSentence | null placeParts = [] | otherwise = [makeSentence placeParts, "\n"] - -- Ideally, place layout would be in SquareFont and the rest - -- in PropFont, but this is mostly a debug screen, so KISS. blurbs = [(propFont, partsSentence)] ++ [(monoFont, [freqsText, "\n"]) | sexposePlaces] ++ [(squareFont, PK.ptopLeft pkind ++ ["\n"]) | sexposePlaces] ++ [(propFont, onLevels)] - return (prompt, blurbs) + return (prompt, map (second $ map textToAS) blurbs) + +factionCloseUp :: MonadClientUI m + => [(FactionId, Faction)] + -> MenuSlot + -> m (Text, [(DisplayFont, [AttrString])]) +factionCloseUp factions slot = do + side <- getsClient sside + FontSetup{propFont} <- getFontSetup + factionD <- getsState sfactionD + let (fid, fact@Faction{gkind=FK.FactionKind{..}, ..}) = + factions !! fromEnum slot + (name, person) = if fhasGender -- but we ignore "Controlled", etc. + then (makePhrase [MU.Ws $ MU.Text fname], MU.PlEtc) + else (fname, MU.Sg3rd) + (youThey, prompt) = + if fid == side + then ("You", makeSentence ["you are the", MU.Text name]) + else ("They", makeSentence ["you are wary of the", MU.Text name]) + -- wary even if the faction is allied + ts1 = + -- Display only the main groups, not to spam. + case map fst $ filter ((>= 100) . snd) fgroups of + [] -> [] -- only initial actors in the faction? + [fgroup] -> + [makeSentence [ "the faction consists of" + , MU.Ws $ MU.Text $ displayGroupName fgroup ]] + grps -> [makeSentence + [ "the faction attracts members such as:" + , MU.WWandW $ map (MU.Text . displayGroupName) grps ]] + ++ [if fskillsOther == Ability.zeroSkills -- simplified + then youThey <+> "don't care about each other and crowd and stampede all at once, sometimes brutally colliding by accident." + else youThey <+> "pay attention to each other and take care to move one at a time."] + ++ [ if fcanEscape + then "The faction is able to take part in races to an area exit." + else "The faction doesn't escape areas of conflict and attempts to block exits instead."] + ++ [ "When all members are incapacitated, the faction dissolves." + | fneverEmpty ] + ++ [if fhasGender + then "Its members are known to have sexual dimorphism and use gender pronouns." + else "Its members seem to prefer naked ground for sleeping."] + ++ [ "Its ranks swell with time." + | fspawnsFast ] + ++ [ "The faction is able to maintain activity on a level on its own, with a pointman coordinating each tactical maneuver." + | fhasPointman ] + -- Changes to all of these have visibility @PosAll@, so the player + -- knows them fully, except for @gvictims@, which is coupled to tracking + -- other factions' actors and so only incremented when we've seen + -- their actor killed (mostly likely killed by us). + ts2 = -- reporting regardless of whether any of the factions are dead + let renderDiplGroup [] = error "renderDiplGroup: null" + renderDiplGroup ((fid2, diplomacy) : rest) = MU.Phrase + [ MU.Text $ tshowDiplomacy diplomacy + , "with" + , MU.WWandW $ map renderFact2 $ fid2 : map fst rest ] + renderFact2 fid2 = MU.Text $ Faction.gname (factionD EM.! fid2) + valid (fid2, diplomacy) = isJust (lookup fid2 factions) + && diplomacy /= Unknown + knownAssocsGroups = groupBy ((==) `on` snd) $ sortOn snd + $ filter valid $ EM.assocs gdipl + in [ makeSentence [ MU.SubjectVerb person MU.Yes (MU.Text name) "be" + , MU.WWandW $ map renderDiplGroup knownAssocsGroups ] + | not (null knownAssocsGroups) ] + ts3 = + case gquit of + Just Status{..} | not $ isHorrorFact fact -> + ["The faction has already" <+> FK.nameOutcomePast stOutcome + <+> "around level" <+> tshow (abs stDepth) <> "."] + _ -> [] + ++ let nkilled = sum $ EM.elems gvictims + personKilled = if nkilled == 1 then MU.Sg3rd else MU.PlEtc + in [ makeSentence $ + [ "so far," | isNothing gquit ] + ++ [ "at least" + , MU.CardinalWs nkilled "member" + , MU.SubjectVerb personKilled + MU.Yes + "of this faction" + "have been incapacitated" ] + | nkilled > 0 ] + ++ let adjective = if isNothing gquit then "current" else "last" + verb = if isNothing gquit then "is" else "was" + in ["Its" <+> adjective <+> "doctrine" <+> verb + <+> "'" <> Ability.nameDoctrine gdoctrine + <> "' (" <> Ability.describeDoctrine gdoctrine <> ")."] + -- Description of the score polynomial would go into a separate section, + -- but it's hard to make it sound non-technical enough. + blurbs = intersperse ["\n"] $ filter (not . null) [ts1, ts2, ts3] + return (prompt, map (\t -> (propFont, map textToAS t)) blurbs) diff --git a/engine-src/Game/LambdaHack/Client/UI/ItemDescription.hs b/engine-src/Game/LambdaHack/Client/UI/ItemDescription.hs --- a/engine-src/Game/LambdaHack/Client/UI/ItemDescription.hs +++ b/engine-src/Game/LambdaHack/Client/UI/ItemDescription.hs @@ -78,7 +78,7 @@ (orTs, powerTs, rangedDamage) = textAllPowers width detailLevel skipRecharging itemFull lsource = case jfid itemBase of - Just fid | IK.iname itemKind `elem` ["impressed"] -> + Just fid | IK.iname itemKind == "impressed" -> ["by" <+> if fid == side then "us" else gname (factionD EM.! fid)] @@ -172,7 +172,7 @@ (nub $ filter (not . T.null) $ map ppAnd $ unOr eff) onCombineTs = - filter (not . T.null) $ map ppOr $ map unCombine combineEffs + filter (not . T.null) $ map (ppOr . unCombine) combineEffs rechargingTs = T.intercalate " " $ [damageText | IK.idamage itemKind /= 0] ++ filter (not . T.null) @@ -394,10 +394,10 @@ in Color.attrChar2ToW32 color (displayContentSymbol $ IK.isymbol $ itemKind itemFull) -itemDesc :: Int -> Bool -> FactionId -> FactionDict -> Int -> CStore -> Time - -> LevelId -> ItemFull -> ItemQuant +itemDesc :: Int -> Bool -> FactionId -> FactionDict -> Int -> ItemDialogMode + -> Time -> LevelId -> ItemFull -> ItemQuant -> AttrString -itemDesc width markParagraphs side factionD aHurtMeleeOfOwner store localTime +itemDesc width markParagraphs side factionD aHurtMeleeOfOwner dmode localTime jlid itemFull@ItemFull{itemBase, itemKind, itemDisco, itemSuspect} kit = let (orTs, name, powers) = @@ -407,16 +407,32 @@ IK.ThrowMod{IK.throwVelocity, IK.throwLinger} = IA.aToThrow arItem speed = speedFromWeight (IK.iweight itemKind) throwVelocity range = rangeFromSpeedAndLinger speed throwLinger - tspeed | IA.checkFlag Ability.Condition arItem - || IK.iweight itemKind == 0 = "" - | speed < speedLimp = "When thrown, it drops at once." - | speed < speedWalk = "When thrown, it drops after one meter." + plausiblyThrown = + dmode `elem` [ MStore CGround, MStore CEqp, MStore CStash + , MOwned, MLore SItem ] + plausiblyFlies = dmode == MLore SBlast + tspeed | not (plausiblyThrown || plausiblyFlies) = "" + | speed < speedLimp = + if plausiblyThrown + then "When thrown, it drops at once." + else "When airborne, it drops at once." + | speed < speedWalk = + if plausiblyThrown + then "When thrown, it drops after one meter." + else "When airborne, it drops after one meter." | otherwise = - "Can be thrown at" + (if plausiblyThrown + then "Can be thrown at" + else "Travels at") <+> T.pack (displaySpeed $ fromSpeed speed) - <> if throwLinger /= 100 - then " dropping after" <+> tshow range <> "m." - else "." + <> (if throwLinger /= 100 + then let trange = if range == 0 + then "immediately" + else "after" <+> tshow range <> "m" + in " dropping" <+> trange + -- comma here is logical but looks bad + else "") + <> "." tsuspect = ["You are unsure what it does." | itemSuspect] (desc, aspectSentences, damageAnalysis) = let aspects = case itemDisco of @@ -431,7 +447,7 @@ meanDmg = ceiling $ Dice.meanDice (IK.idamage itemKind) dmgAn = if meanDmg <= 0 then "" else let multRaw = aHurtMeleeOfOwner - + if store `elem` [CEqp, COrgan] + + if dmode `elem` [MStore CEqp, MStore COrgan] then 0 else aHurtMeleeOfItem mult = 100 + min 100 (max (-95) multRaw) diff --git a/engine-src/Game/LambdaHack/Client/UI/ItemSlot.hs b/engine-src/Game/LambdaHack/Client/UI/ItemSlot.hs deleted file mode 100644 --- a/engine-src/Game/LambdaHack/Client/UI/ItemSlot.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} --- | Item slots for UI and AI item collections. -module Game.LambdaHack.Client.UI.ItemSlot - ( SlotChar(..), ItemSlots(..), SingleItemSlots - , allSlots, intSlots, slotLabel - , assignSlot, sortSlotMap, mergeItemSlots - ) where - -import Prelude () - -import Game.LambdaHack.Core.Prelude - -import Data.Binary -import Data.Bits (unsafeShiftL, unsafeShiftR) -import Data.Char -import qualified Data.EnumMap.Strict as EM -import qualified Data.Text as T - -import Game.LambdaHack.Common.Item -import Game.LambdaHack.Common.Types -import qualified Game.LambdaHack.Content.ItemKind as IK -import Game.LambdaHack.Definition.Defs - --- | Slot label. Usually just a character. Sometimes with a numerical prefix. -data SlotChar = SlotChar {slotPrefix :: Int, slotChar :: Char} - deriving (Show, Eq) - -instance Ord SlotChar where - compare = comparing fromEnum - -instance Binary SlotChar where - put = put . fromEnum - get = fmap toEnum get - -instance Enum SlotChar where - fromEnum (SlotChar n c) = - unsafeShiftL n 8 + ord c + (if isUpper c then 100 else 0) - toEnum e = - let n = unsafeShiftR e 8 - c0 = e - unsafeShiftL n 8 - c100 = c0 - if c0 > 150 then 100 else 0 - in SlotChar n (chr c100) - -type SingleItemSlots = EM.EnumMap SlotChar ItemId - --- | A collection of mappings from slot labels to item identifiers. -newtype ItemSlots = ItemSlots (EM.EnumMap SLore SingleItemSlots) - deriving (Show, Binary) - -allChars :: [Char] -allChars = ['a'..'z'] ++ ['A'..'Z'] - -allSlots :: [SlotChar] -allSlots = concatMap (\n -> map (SlotChar n) allChars) [0..] - -intSlots :: [SlotChar] -intSlots = map (`SlotChar` 'a') [0..] - -slotLabel :: SlotChar -> Text -slotLabel x = - T.snoc (if slotPrefix x == 0 then T.empty else tshow $ slotPrefix x) - (slotChar x) - <> ")" - --- | Assigns a slot to an item, e.g., for inclusion in equipment of a hero. --- At first, e.g., when item is spotted on the floor, the slot is --- not user-friendly. After any player's item manipulation action, --- slots are sorted and a fully human-readable slot is then assigned. --- Only then the slot can be viewed by the player. -assignSlot :: SingleItemSlots -> SlotChar -assignSlot lSlots = - let maxPrefix = case EM.maxViewWithKey lSlots of - Just ((lm, _), _) -> slotPrefix lm - Nothing -> 0 - in SlotChar (maxPrefix + 1) 'x' - -sortSlotMap :: (ItemId -> ItemFull) -> SingleItemSlots -> SingleItemSlots -sortSlotMap itemToF em = - -- If appearance and aspects the same, keep the order from before sort. - let kindAndAppearance iid = - let ItemFull{itemBase=Item{..}, ..} = itemToF iid - in ( not itemSuspect, itemKindId, itemDisco - , IK.isymbol itemKind, IK.iname itemKind - , jflavour, jfid ) - sortItemIds = sortOn kindAndAppearance - in EM.fromDistinctAscList $ zip allSlots $ sortItemIds $ EM.elems em - -mergeItemSlots :: (ItemId -> ItemFull) -> [SingleItemSlots] -> SingleItemSlots -mergeItemSlots itemToF ems = - let renumberSlot n SlotChar{slotPrefix, slotChar} = - SlotChar{slotPrefix = slotPrefix + n * 1000000, slotChar} - renumberMap n = EM.mapKeys (renumberSlot n) - rms = zipWith renumberMap [0..] ems - em = EM.unionsWith (\_ _ -> error "mergeItemSlots: duplicate keys") rms - in sortSlotMap itemToF em diff --git a/engine-src/Game/LambdaHack/Client/UI/Key.hs b/engine-src/Game/LambdaHack/Client/UI/Key.hs --- a/engine-src/Game/LambdaHack/Client/UI/Key.hs +++ b/engine-src/Game/LambdaHack/Client/UI/Key.hs @@ -8,8 +8,8 @@ , upKM, downKM, leftKM, rightKM , homeKM, endKM, backspaceKM, controlP , leftButtonReleaseKM, middleButtonReleaseKM, rightButtonReleaseKM - , dirAllKey, handleDir, moveBinding, mkKM, mkChar - , keyTranslate, keyTranslateWeb + , cardinalAllKM, dirAllKey, handleCardinal, handleDir, moveBinding + , mkKM, mkChar, keyTranslate, keyTranslateWeb , dirMoveNoModifier, dirRunNoModifier, dirRunControl, dirRunShift #ifdef EXPOSE_INTERNAL -- * Internal operations @@ -206,6 +206,9 @@ rightButtonReleaseKM :: KM rightButtonReleaseKM = KM NoModifier RightButtonRelease +cardinalKeypadKM :: [KM] +cardinalKeypadKM = map (KM NoModifier) [Up, Right, Down, Left] + dirKeypadKey :: [Key] dirKeypadKey = [Home, Up, PgUp, Right, PgDn, Down, End, Left] @@ -215,12 +218,18 @@ dirKeypadShiftKey :: [Key] dirKeypadShiftKey = map KP dirKeypadShiftChar +cardinalLeftHandKM :: [KM] +cardinalLeftHandKM = map (KM NoModifier . Char) ['w', 'd', 'x', 'a'] + dirLeftHandKey :: [Key] dirLeftHandKey = map Char ['q', 'w', 'e', 'd', 'c', 'x', 'z', 'a'] dirLeftHandShiftKey :: [Key] dirLeftHandShiftKey = map Char ['Q', 'W', 'E', 'D', 'C', 'X', 'Z', 'A'] +cardinalViKM :: [KM] +cardinalViKM = map (KM NoModifier . Char) ['k', 'l', 'j', 'h'] + dirViChar :: [Char] dirViChar = ['y', 'k', 'u', 'l', 'n', 'j', 'b', 'h'] @@ -248,12 +257,23 @@ dirRunShift :: [Key] dirRunShift = dirRunControl +cardinalAllKM :: Bool -> Bool -> [KM] +cardinalAllKM uVi uLeftHand = concat $ + [cardinalKeypadKM] + ++ [cardinalViKM | uVi] + ++ [cardinalLeftHandKM | uLeftHand] + dirAllKey :: Bool -> Bool -> [Key] dirAllKey uVi uLeftHand = dirMoveNoModifier uVi uLeftHand ++ dirRunNoModifier uVi uLeftHand ++ dirRunControl +handleCardinal :: [KM] -> KM -> Maybe Vector +handleCardinal dirKeys key = + let assocs = zip dirKeys $ cycle movesCardinal + in lookup key assocs + -- | Configurable event handler for the direction keys. -- Used for directed commands such as close door. handleDir :: [Key] -> KM -> Maybe Vector @@ -266,11 +286,11 @@ moveBinding :: Bool -> Bool -> (Vector -> a) -> (Vector -> a) -> [(KM, a)] moveBinding uVi uLeftHand move run = - let assign f (km, dir) = (km, f dir) + let assign f km dir = (km, f dir) mapMove modifier keys = - map (assign move) (zip (map (KM modifier) keys) $ cycle moves) + zipWith (assign move) (map (KM modifier) keys) (cycle moves) mapRun modifier keys = - map (assign run) (zip (map (KM modifier) keys) $ cycle moves) + zipWith (assign run) (map (KM modifier) keys) (cycle moves) in mapMove NoModifier (dirMoveNoModifier uVi uLeftHand) ++ mapRun NoModifier (dirRunNoModifier uVi uLeftHand) ++ mapRun Control dirRunControl diff --git a/engine-src/Game/LambdaHack/Client/UI/MonadClientUI.hs b/engine-src/Game/LambdaHack/Client/UI/MonadClientUI.hs --- a/engine-src/Game/LambdaHack/Client/UI/MonadClientUI.hs +++ b/engine-src/Game/LambdaHack/Client/UI/MonadClientUI.hs @@ -38,7 +38,6 @@ import Data.Time.LocalTime import qualified Data.Vector.Unboxed as U import qualified NLP.Miniutter.English as MU -import System.FilePath import System.IO (hFlush, stdout) import Web.Browser (openBrowser) @@ -64,7 +63,6 @@ import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.ClientOptions import Game.LambdaHack.Common.Faction -import Game.LambdaHack.Common.File import qualified Game.LambdaHack.Common.HighScore as HighScore import Game.LambdaHack.Common.Item import Game.LambdaHack.Common.Kind @@ -76,8 +74,8 @@ import Game.LambdaHack.Common.State import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Types +import Game.LambdaHack.Content.FactionKind import Game.LambdaHack.Content.ModeKind -import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Core.Random -- Assumes no interleaving with other clients, because each UI client @@ -349,9 +347,6 @@ let fact = factionD EM.! fid table = HighScore.getTable gameModeId scoreDict gameModeName = mname gameMode - chal | fhasUI $ gplayer fact = curChalSer - | otherwise = curChalSer - {cdiff = difficultyInverse (cdiff curChalSer)} theirVic (fi, fa) | isFoe fid fact fi && not (isHorrorFact fa) = Just $ gvictims fa | otherwise = Nothing @@ -360,12 +355,12 @@ | otherwise = Nothing ourVictims = EM.unionsWith (+) $ mapMaybe ourVic $ EM.assocs factionD (worthMentioning, (ntable, pos)) = - HighScore.register table total dungeonTotal time status date chal + HighScore.register table total dungeonTotal time status date curChalSer (T.unwords $ tail $ T.words $ gname fact) ourVictims theirVictims - (fhiCondPoly $ gplayer fact) + (fhiCondPoly $ gkind fact) fontSetup <- getFontSetup - let sli = highSlideshow fontSetup rwidth (rheight - 1) ntable pos + let sli = highSlideshow fontSetup False rwidth (rheight - 1) ntable pos gameModeName tz return $! if worthMentioning then sli @@ -428,7 +423,7 @@ <+> "Average clips per second:" <+> tshow cps <> "." <+> "Average FPS:" <+> tshow fps <> "." --- TODO: for speed and resolutiion use +-- TODO: for speed and resolution use -- https://hackage.haskell.org/package/chronos -- or the number_of_nanonseconds functionality -- in Data.Time.Clock.System, once it arrives there @@ -490,12 +485,7 @@ side <- getsClient sside prefix <- getsClient $ ssavePrefixCli . soptions let fileName = prefix <> Save.saveNameCli corule side - res <- liftIO $ Save.restoreGame corule clientOptions fileName - let cfgUIName = rcfgUIName corule - (configString, _) = rcfgUIDefault corule - dataDir <- liftIO appDataDir - liftIO $ tryWriteFile (dataDir cfgUIName) configString - return res + liftIO $ Save.restoreGame corule clientOptions fileName -- | Invoke pseudo-random computation with the generator kept in the session. rndToActionUI :: MonadClientUI m => Rnd a -> m a diff --git a/engine-src/Game/LambdaHack/Client/UI/Msg.hs b/engine-src/Game/LambdaHack/Client/UI/Msg.hs --- a/engine-src/Game/LambdaHack/Client/UI/Msg.hs +++ b/engine-src/Game/LambdaHack/Client/UI/Msg.hs @@ -147,7 +147,6 @@ | MsgPointmanSwap | MsgFactionIntel | MsgFinalOutcome - | MsgPlotExposition | MsgBackdropInfo | MsgTerrainReveal | MsgItemDiscovery @@ -330,7 +329,6 @@ MsgPointmanSwap -> Color.cBoring MsgFactionIntel -> Color.cMeta -- good or bad MsgFinalOutcome -> Color.cGameOver - MsgPlotExposition -> Color.cBoring MsgBackdropInfo -> Color.cBoring MsgTerrainReveal -> Color.cIdentification MsgItemDiscovery -> Color.cIdentification diff --git a/engine-src/Game/LambdaHack/Client/UI/Overlay.hs b/engine-src/Game/LambdaHack/Client/UI/Overlay.hs --- a/engine-src/Game/LambdaHack/Client/UI/Overlay.hs +++ b/engine-src/Game/LambdaHack/Client/UI/Overlay.hs @@ -72,6 +72,7 @@ , monoFont :: DisplayFont , propFont :: DisplayFont } + deriving (Eq, Show) -- for unit tests multiFontSetup :: FontSetup multiFontSetup = FontSetup SquareFont MonoFont PropFont @@ -161,7 +162,7 @@ attrStringToAL s = #ifdef WITH_EXPENSIVE_ASSERTIONS assert (allB (\ac -> Color.charFromW32 ac /= '\n') s) $ -- expensive in menus - assert (length s == 0 || last s /= Color.spaceAttrW32 + assert (null s || last s /= Color.spaceAttrW32 `blame` map Color.charFromW32 s) $ -- only expensive for menus, but often violated by code changes, so disabled -- outside test runs @@ -181,7 +182,7 @@ s = T.foldr f [] t in AttrLine $ #ifdef WITH_EXPENSIVE_ASSERTIONS - assert (length s == 0 || last s /= Color.spaceAttrW32 `blame` t) + assert (null s || last s /= Color.spaceAttrW32 `blame` t) #endif s @@ -196,7 +197,7 @@ s = T.foldr f [] t in AttrLine $ #ifdef WITH_EXPENSIVE_ASSERTIONS - assert (length s == 0 || last s /= Color.spaceAttrW32 `blame` t) + assert (null s || last s /= Color.spaceAttrW32 `blame` t) #endif s @@ -229,7 +230,7 @@ x : xs -> splitAttrPhrase w0 w1 x ++ concatMap (splitAttrPhrase w1 w1) xs indentSplitAttrString :: DisplayFont -> Int -> AttrString -> [AttrLine] -indentSplitAttrString font w l = +indentSplitAttrString font w l = assert (w > 4) $ -- Sadly this depends on how wide the space is in propotional font, -- which varies wildly, so we err on the side of larger indent. let nspaces = case font of @@ -257,8 +258,8 @@ (([], preRev), rest) _ -> (breakAtSpace preRev, postRaw) in if all (== Color.spaceAttrW32) ppost - then AttrLine (reverse $ dropWhile (== Color.spaceAttrW32) preRev) : - splitAttrPhrase w1 w1 (AttrLine post) + then AttrLine (reverse $ dropWhile (== Color.spaceAttrW32) preRev) + : splitAttrPhrase w1 w1 (AttrLine post) else AttrLine (reverse $ dropWhile (== Color.spaceAttrW32) ppost) : splitAttrPhrase w1 w1 (AttrLine $ reverse ppre ++ post) @@ -285,15 +286,14 @@ ytranslateOverlay = xytranslateOverlay 0 offsetOverlay :: [AttrLine] -> Overlay -offsetOverlay l = map (first $ PointUI 0) $ zip [0..] l +offsetOverlay = zipWith (curry (first $ PointUI 0)) [0..] offsetOverlayX :: [(Int, AttrLine)] -> Overlay -offsetOverlayX l = - map (\(y, (x, al)) -> (PointUI x y, al)) $ zip [0..] l +offsetOverlayX = zipWith (\y (x, al) -> (PointUI x y, al)) [0..] typesetXY :: (Int, Int) -> [AttrLine] -> Overlay typesetXY (xoffset, yoffset) = - map (\(y, al) -> (PointUI xoffset (y + yoffset), al)) . zip [0..] + zipWith (\y al -> (PointUI xoffset (y + yoffset), al)) [0..] -- @f@ should not enlarge the line beyond screen width nor introduce linebreaks. updateLine :: Int -> (Int -> AttrString -> AttrString) -> Overlay -> Overlay @@ -315,9 +315,10 @@ labDescOverlay labFont width as = let (tLab, tDesc) = span (/= Color.spaceAttrW32) as labLen = textSize labFont tLab + len = max 0 $ width - length tLab -- not labLen; TODO: type more strictly ovLab = offsetOverlay [attrStringToAL tLab] ovDesc = offsetOverlayX $ - case splitAttrString (width - labLen) width tDesc of + case splitAttrString len width tDesc of [] -> [] l : ls -> (labLen, l) : map (0,) ls in (ovLab, ovDesc) diff --git a/engine-src/Game/LambdaHack/Client/UI/SessionUI.hs b/engine-src/Game/LambdaHack/Client/UI/SessionUI.hs --- a/engine-src/Game/LambdaHack/Client/UI/SessionUI.hs +++ b/engine-src/Game/LambdaHack/Client/UI/SessionUI.hs @@ -1,8 +1,8 @@ {-# LANGUAGE DeriveGeneric, GeneralizedNewtypeDeriving #-} -- | The client UI session state. module Game.LambdaHack.Client.UI.SessionUI - ( SessionUI(..), ReqDelay(..), ItemDictUI, AimMode(..), KeyMacro(..) - , KeyMacroFrame(..), RunParams(..), ChosenLore(..) + ( SessionUI(..), ReqDelay(..), ItemDictUI, ItemRoles(..), AimMode(..) + , KeyMacro(..), KeyMacroFrame(..), RunParams(..), ChosenLore(..) , emptySessionUI, emptyMacroFrame , cycleMarkVision, toggleMarkSmell, cycleOverrideTut, getActorUI ) where @@ -26,20 +26,23 @@ import Game.LambdaHack.Client.UI.ContentClientUI import Game.LambdaHack.Client.UI.EffectDescription (DetailLevel (..)) import Game.LambdaHack.Client.UI.Frontend -import Game.LambdaHack.Client.UI.ItemSlot import qualified Game.LambdaHack.Client.UI.Key as K import Game.LambdaHack.Client.UI.Msg import Game.LambdaHack.Client.UI.PointUI import Game.LambdaHack.Client.UI.UIOptions import Game.LambdaHack.Common.Actor +import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Types +import Game.LambdaHack.Content.ModeKind (ModeKind) import Game.LambdaHack.Definition.Defs --- | The information that is used across a client playing session, --- including many consecutive games in a single session. --- Some of it is saved, some is reset when a new playing session starts. +-- | The information that is used across a human player playing session, +-- including many consecutive games in a single session, +-- including playing different teams. Some of it is saved, some is reset +-- when a new playing session starts. Nothing is tied to a faction/team, +-- but instead all to UI configuration and UI input and display history. -- An important component is the frontend session. data SessionUI = SessionUI { sreqPending :: Maybe RequestUI @@ -54,7 +57,7 @@ , sxhairGoTo :: Maybe Target -- ^ xhair set for last GoTo , sactorUI :: ActorDictUI -- ^ assigned actor UI presentations , sitemUI :: ItemDictUI -- ^ assigned item first seen level - , sslots :: ItemSlots -- ^ map from slots to items + , sroles :: ItemRoles -- ^ assignment of roles to items , slastItemMove :: Maybe (CStore, CStore) -- ^ last item move stores , schanF :: ChanFrontend -- ^ connection with the frontend @@ -70,6 +73,11 @@ , srunning :: Maybe RunParams -- ^ parameters of the current run, if any , shistory :: History -- ^ history of messages + , svictories :: EM.EnumMap (ContentId ModeKind) (M.Map Challenge Int) + -- ^ the number of games won by the UI faction per game mode + -- and per difficulty level + , scampings :: ES.EnumSet (ContentId ModeKind) -- ^ camped games + , srestarts :: ES.EnumSet (ContentId ModeKind) -- ^ restarted games , spointer :: PointUI -- ^ mouse pointer position , sautoYes :: Bool -- ^ whether to auto-clear prompts , smacroFrame :: KeyMacroFrame -- ^ the head of the key macro stack @@ -124,6 +132,11 @@ -- but never read from, except when the user requests item details. type ItemDictUI = EM.EnumMap ItemId LevelId +-- | A collection of item identifier sets indicating what roles (possibly many) +-- an item has assigned. +newtype ItemRoles = ItemRoles (EM.EnumMap SLore (ES.EnumSet ItemId)) + deriving (Show, Binary) + -- | Current aiming mode of a client. data AimMode = AimMode { aimLevelId :: LevelId @@ -168,8 +181,8 @@ , sxhairGoTo = Nothing , sactorUI = EM.empty , sitemUI = EM.empty - , sslots = ItemSlots $ EM.fromDistinctAscList - $ zip [minBound..maxBound] (repeat EM.empty) + , sroles = ItemRoles $ EM.fromDistinctAscList + $ zip [minBound..maxBound] (repeat ES.empty) , slastItemMove = Nothing , schanF = ChanFrontend $ const $ error $ "emptySessionUI: ChanFrontend" `showFailure` () @@ -181,6 +194,9 @@ , sselected = ES.empty , srunning = Nothing , shistory = emptyHistory 0 + , svictories = EM.empty + , scampings = ES.empty + , srestarts = ES.empty , spointer = PointUI 0 0 , sautoYes = False , smacroFrame = emptyMacroFrame @@ -212,17 +228,19 @@ emptyMacroFrame :: KeyMacroFrame emptyMacroFrame = KeyMacroFrame (Right mempty) mempty Nothing -cycleMarkVision :: SessionUI -> SessionUI -cycleMarkVision sess = sess {smarkVision = succ (smarkVision sess) `mod` 3} +cycleMarkVision :: Int -> SessionUI -> SessionUI +cycleMarkVision delta sess = + sess {smarkVision = (smarkVision sess + delta) `mod` 3} toggleMarkSmell :: SessionUI -> SessionUI toggleMarkSmell sess = sess {smarkSmell = not (smarkSmell sess)} -cycleOverrideTut :: SessionUI -> SessionUI -cycleOverrideTut sess = sess {soverrideTut = case soverrideTut sess of - Nothing -> Just False - Just False -> Just True - Just True -> Nothing} +cycleOverrideTut :: Int -> SessionUI -> SessionUI +cycleOverrideTut delta sess = + let ordering = cycle [Nothing, Just False, Just True] + in sess {soverrideTut = + let ix = fromJust $ elemIndex (soverrideTut sess) ordering + in ordering !! (ix + delta)} getActorUI :: ActorId -> SessionUI -> ActorUI getActorUI aid sess = @@ -234,7 +252,7 @@ put sxhair put sactorUI put sitemUI - put sslots + put sroles put sUIOptions put saimMode put sitemSel @@ -242,6 +260,9 @@ put srunning put $ archiveReport shistory -- avoid displaying ending messages again at game start + put svictories + put scampings + put srestarts put smarkVision put smarkSmell put snxtScenario @@ -254,13 +275,16 @@ sxhair <- get sactorUI <- get sitemUI <- get - sslots <- get + sroles <- get sUIOptions <- get -- is overwritten ASAP, but useful for, e.g., crash debug saimMode <- get sitemSel <- get sselected <- get srunning <- get shistory <- get + svictories <- get + scampings <- get + srestarts <- get smarkVision <- get smarkSmell <- get snxtScenario <- get diff --git a/engine-src/Game/LambdaHack/Client/UI/Slideshow.hs b/engine-src/Game/LambdaHack/Client/UI/Slideshow.hs --- a/engine-src/Game/LambdaHack/Client/UI/Slideshow.hs +++ b/engine-src/Game/LambdaHack/Client/UI/Slideshow.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | Slideshows. module Game.LambdaHack.Client.UI.Slideshow ( FontOverlayMap, maxYofFontOverlayMap - , KeyOrSlot, ButtonWidth(..) + , KeyOrSlot, MenuSlot, natSlots + , ButtonWidth(..) , KYX, xytranslateKXY, xtranslateKXY, ytranslateKXY, yrenumberKXY , OKX, emptyOKX, xytranslateOKX, sideBySideOKX, labDescOKX , Slideshow(slideshow), emptySlideshow, unsnoc, toSlideshow @@ -17,10 +19,10 @@ import Game.LambdaHack.Core.Prelude +import Data.Binary import qualified Data.EnumMap.Strict as EM import Data.Time.LocalTime -import Game.LambdaHack.Client.UI.ItemSlot import qualified Game.LambdaHack.Client.UI.Key as K import Game.LambdaHack.Client.UI.Msg import Game.LambdaHack.Client.UI.Overlay @@ -33,8 +35,15 @@ maxYofFontOverlayMap :: FontOverlayMap -> Int maxYofFontOverlayMap ovs = maximum (0 : map maxYofOverlay (EM.elems ovs)) -type KeyOrSlot = Either K.KM SlotChar +type KeyOrSlot = Either K.KM MenuSlot +newtype MenuSlot = MenuSlot Int + deriving (Show, Eq, Ord, Binary, Enum) + +natSlots :: [MenuSlot] +{-# INLINE natSlots #-} +natSlots = [MenuSlot 0 ..] + -- TODO: probably best merge the PointUI into that and represent -- the position as characters, too, translating to UI positions as needed. -- The problem is that then I need to do a lot of reverse translation @@ -46,7 +55,7 @@ , buttonWidth :: Int } deriving (Show, Eq) --- | A key or an item slot label at a given position on the screen. +-- | A key or a menu slot at a given position on the screen. type KYX = (KeyOrSlot, (PointUI, ButtonWidth)) xytranslateKXY :: Int -> Int -> KYX -> KYX @@ -115,14 +124,19 @@ [] -> Nothing okx : rest -> Just (Slideshow $ reverse rest, okx) -toSlideshow :: FontSetup -> [OKX] -> Slideshow -toSlideshow FontSetup{..} okxs = Slideshow $ addFooters False okxs +toSlideshow :: FontSetup -> Bool -> [OKX] -> Slideshow +toSlideshow FontSetup{..}displayTutorialHints okxs = + Slideshow $ addFooters False okxs where atEnd = flip (++) appendToFontOverlayMap :: FontOverlayMap -> String -> (FontOverlayMap, PointUI, DisplayFont, Int) - appendToFontOverlayMap ovs msg = - let maxYminXofOverlay ov = + appendToFontOverlayMap ovs msgPrefix = + let msg | displayTutorialHints = + msgPrefix + ++ " (ESC to exit, PGUP, HOME, mouse, wheel, arrows, etc.)" + | otherwise = msgPrefix + maxYminXofOverlay ov = let ymxOfOverlay (PointUI x y, _) = (- y, x) in minimum $ maxBound : map ymxOfOverlay ov -- @sortOn@ less efficient here, because function cheap. @@ -166,7 +180,7 @@ attrLinesToFontMap blurb = let zipAttrLines :: Int -> [AttrLine] -> (Overlay, Int) zipAttrLines start als = - ( map (first $ PointUI 0) $ zip [start ..] als + ( zipWith (curry (first $ PointUI 0)) [start ..] als , start + length als ) addOverlay :: (FontOverlayMap, Int) -> (DisplayFont, [AttrLine]) -> (FontOverlayMap, Int) @@ -188,7 +202,7 @@ let overlayLineFromStrings :: Int -> Int -> [String] -> (PointUI, AttrLine) overlayLineFromStrings xlineStart y strings = let p = PointUI xlineStart y - in (p, stringToAL $ intercalate " " (reverse strings)) + in (p, stringToAL $ unwords (reverse strings)) f :: ((Int, Int), (Int, [String], Overlay, [KYX])) -> (K.KM, String) -> ((Int, Int), (Int, [String], Overlay, [KYX])) f ((y, x), (xlineStart, kL, kV, kX)) (key, s) = @@ -218,20 +232,24 @@ -- The font argument is for the report and keys overlay. Others already have -- assigned fonts. -splitOverlay :: FontSetup -> Int -> Int -> Int -> Report -> [K.KM] -> OKX +splitOverlay :: FontSetup -> Bool -> Int -> Int -> Int -> Report -> [K.KM] + -> OKX -> Slideshow -splitOverlay fontSetup width height wrap report keys (ls0, kxs0) = +splitOverlay fontSetup displayTutorialHints + width height wrap report keys (ls0, kxs0) = let renderedReport = renderReport True report reportAS = foldr (<\:>) [] renderedReport - in toSlideshow fontSetup $ splitOKX fontSetup False width height wrap - reportAS keys (ls0, kxs0) + in toSlideshow fontSetup displayTutorialHints $ + splitOKX fontSetup False width height wrap reportAS keys (ls0, kxs0) -- Note that we only split wrt @White@ space, nothing else. splitOKX :: FontSetup -> Bool -> Int -> Int -> Int -> AttrString -> [K.KM] -> OKX -> [OKX] splitOKX FontSetup{..} msgLong width height wrap reportAS keys (ls0, kxs0) = - assert (height > 2) $ + assert (width > 2 && height > 2) $ + -- if the strings to split are long these minimums won't be enough, + -- but content validation ensures larger values (perhaps large enough?) let reportParagraphs = linesAttr reportAS -- TODO: until SDL support for measuring prop font text is released, -- we have to use MonoFont for the paragraph that ends with buttons. @@ -351,6 +369,7 @@ -- | Generate a slideshow with the current and previous scores. highSlideshow :: FontSetup + -> Bool -> Int -- ^ width of the display area -> Int -- ^ height of the display area -> HighScore.ScoreTable -- ^ current score table @@ -358,8 +377,8 @@ -> Text -- ^ the name of the game mode -> TimeZone -- ^ the timezone where the game is run -> Slideshow -highSlideshow fontSetup@FontSetup{monoFont} width height table pos - gameModeName tz = +highSlideshow fontSetup@FontSetup{monoFont} displayTutorialHints + width height table pos gameModeName tz = let entries = (height - 3) `div` 3 msg = HighScore.showAward entries table pos gameModeName tts = map offsetOverlay $ showNearbyScores tz pos table entries @@ -367,7 +386,7 @@ splitScreen ts = splitOKX fontSetup False width height width al [K.spaceKM, K.escKM] (EM.singleton monoFont ts, []) - in toSlideshow fontSetup $ concat $ map splitScreen tts + in toSlideshow fontSetup displayTutorialHints $ concatMap splitScreen tts -- | Show a screenful of the high scores table. -- Parameter @entries@ is the number of (3-line) scores to be shown. diff --git a/engine-src/Game/LambdaHack/Client/UI/SlideshowM.hs b/engine-src/Game/LambdaHack/Client/UI/SlideshowM.hs --- a/engine-src/Game/LambdaHack/Client/UI/SlideshowM.hs +++ b/engine-src/Game/LambdaHack/Client/UI/SlideshowM.hs @@ -2,11 +2,15 @@ module Game.LambdaHack.Client.UI.SlideshowM ( overlayToSlideshow, reportToSlideshow, reportToSlideshowKeepHalt , displaySpaceEsc, displayMore, displayMoreKeep, displayYesNo, getConfirms - , displayChoiceScreen, displayChoiceScreenWithRightPane + , displayChoiceScreen + , displayChoiceScreenWithRightPane + , displayChoiceScreenWithDefItemKey + , displayChoiceScreenWithRightPaneKMKM + , pushFrame, pushReportFrame #ifdef EXPOSE_INTERNAL -- * Internal operations , getMenuIx, saveMenuIx, stepChoiceScreen, navigationKeys, findKYX - , drawHighlight + , drawHighlight, basicFrameWithoutReport #endif ) where @@ -14,11 +18,14 @@ import Game.LambdaHack.Core.Prelude +import qualified Data.Char as Char import Data.Either import qualified Data.EnumMap.Strict as EM import qualified Data.Map.Strict as M import qualified Data.Text as T +import Game.LambdaHack.Client.MonadClient +import Game.LambdaHack.Client.State import Game.LambdaHack.Client.UI.Content.Screen import Game.LambdaHack.Client.UI.ContentClientUI import Game.LambdaHack.Client.UI.Frame @@ -32,6 +39,12 @@ import Game.LambdaHack.Client.UI.SessionUI import Game.LambdaHack.Client.UI.Slideshow import Game.LambdaHack.Client.UI.UIOptions +import Game.LambdaHack.Common.ClientOptions +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.MonadStateRead +import Game.LambdaHack.Common.State +import Game.LambdaHack.Common.Types +import Game.LambdaHack.Common.Vector import qualified Game.LambdaHack.Definition.Color as Color -- | Add current report to the overlay, split the result and produce, @@ -44,7 +57,11 @@ report <- getReportUI True recordHistory -- report will be shown soon, remove it to history fontSetup <- getFontSetup - return $! splitOverlay fontSetup rwidth y uMsgWrapColumn report keys okx + curTutorial <- getsSession scurTutorial + overrideTut <- getsSession soverrideTut + let displayTutorialHints = fromMaybe curTutorial overrideTut + return $! splitOverlay fontSetup displayTutorialHints + rwidth y uMsgWrapColumn report keys okx -- | Split current report into a slideshow. reportToSlideshow :: MonadClientUI m => [K.KM] -> m Slideshow @@ -66,7 +83,11 @@ -- Don't do @recordHistory@; the message is important, but related -- to the messages that come after, so should be shown together. fontSetup <- getFontSetup - return $! splitOverlay fontSetup rwidth (rheight - 2) uMsgWrapColumn + curTutorial <- getsSession scurTutorial + overrideTut <- getsSession soverrideTut + let displayTutorialHints = fromMaybe curTutorial overrideTut + return $! splitOverlay fontSetup displayTutorialHints + rwidth (rheight - 2) uMsgWrapColumn report keys emptyOKX -- | Display a message. Return value indicates if the player wants to continue. @@ -110,7 +131,7 @@ return $! either id (error $ "" `showFailure` ekm) ekm -- | Display a, potentially, multi-screen menu and return the chosen --- key or item slot label (and save the index in the whole menu so that the cursor +-- key or menu slot (and save the index in the whole menu so that the cursor -- can again be placed at that spot next time menu is displayed). -- -- This function is one of only two sources of menus and so, @@ -118,11 +139,11 @@ displayChoiceScreen :: forall m . MonadClientUI m => String -> ColorMode -> Bool -> Slideshow -> [K.KM] -> m KeyOrSlot -displayChoiceScreen = - displayChoiceScreenWithRightPane $ const $ return emptyOKX +displayChoiceScreen = do + displayChoiceScreenWithRightPane (const $ return emptyOKX) False -- | Display a, potentially, multi-screen menu and return the chosen --- key or item slot label (and save the index in the whole menu so that the cursor +-- key or menu slot (and save the index in the whole menu so that the cursor -- can again be placed at that spot next time menu is displayed). -- Additionally, display something on the right half of the screen, -- depending on which menu item is currently highlighted @@ -132,19 +153,59 @@ displayChoiceScreenWithRightPane :: forall m . MonadClientUI m => (KeyOrSlot -> m OKX) - -> String -> ColorMode -> Bool -> Slideshow -> [K.KM] + -> Bool -> String -> ColorMode -> Bool -> Slideshow -> [K.KM] -> m KeyOrSlot displayChoiceScreenWithRightPane displayInRightPane - menuName dm sfBlank frsX extraKeys = do - (maxIx, initIx, clearIx, m) <- - stepChoiceScreen menuName dm sfBlank frsX extraKeys - let loop :: Int -> KeyOrSlot -> m (KeyOrSlot, Int) + highlightBullet menuName dm sfBlank + frsX extraKeys = do + kmkm <- displayChoiceScreenWithRightPaneKMKM + displayInRightPane + highlightBullet menuName dm sfBlank + frsX extraKeys + return $! case kmkm of + Left (km, _) -> Left km + Right slot -> Right slot + +-- | A specialized variant of 'displayChoiceScreenWithRightPane'. +displayChoiceScreenWithDefItemKey :: MonadClientUI m + => (Int -> MenuSlot -> m OKX) + -> Slideshow + -> [K.KM] + -> String + -> m KeyOrSlot +displayChoiceScreenWithDefItemKey f sli itemKeys menuName = do + CCUI{coscreen=ScreenContent{rwidth}} <- getsSession sccui + FontSetup{propFont} <- getFontSetup + let g ekm = case ekm of + Left{} -> return emptyOKX + Right slot -> do + if isSquareFont propFont + then return emptyOKX + else f (rwidth - 2) slot + displayChoiceScreenWithRightPane + g True menuName ColorFull False sli itemKeys + +-- | A variant providing for a keypress the information about the label +-- of the menu slot which was selected during the keypress. +displayChoiceScreenWithRightPaneKMKM + :: forall m . MonadClientUI m + => (KeyOrSlot -> m OKX) + -> Bool -> String -> ColorMode -> Bool -> Slideshow -> [K.KM] + -> m (Either (K.KM, KeyOrSlot) MenuSlot) +displayChoiceScreenWithRightPaneKMKM displayInRightPane + highlightBullet menuName dm sfBlank + frsX extraKeys = do + (maxIx, initIx, clearIx, m) + <- stepChoiceScreen highlightBullet dm sfBlank frsX extraKeys + let loop :: Int -> KeyOrSlot -> m (Either (K.KM, KeyOrSlot) MenuSlot, Int) loop pointer km = do okxRight <- displayInRightPane km - (final, km1, pointer1) <- m pointer okxRight + (final, kmkm1, pointer1) <- m pointer okxRight if final - then return (km1, pointer1) - else loop pointer1 km1 + then return (kmkm1, pointer1) + else loop pointer1 $ case kmkm1 of + Left (km1, _) -> Left km1 + Right slot -> Right slot pointer0 <- getMenuIx menuName maxIx initIx clearIx let km0 = case findKYX pointer0 $ slideshow frsX of Nothing -> error $ "no menu keys" `showFailure` frsX @@ -181,20 +242,20 @@ -- argument need to be contained in the @[K.KM]@ argument. Otherwise -- they are not accepted. stepChoiceScreen :: forall m . MonadClientUI m - => String -> ColorMode -> Bool -> Slideshow -> [K.KM] + => Bool -> ColorMode -> Bool -> Slideshow -> [K.KM] -> m ( Int, Int, Int - , Int -> OKX -> m (Bool, KeyOrSlot, Int) ) -stepChoiceScreen menuName dm sfBlank frsX extraKeys = do + , Int -> OKX + -> m (Bool, Either (K.KM, KeyOrSlot) MenuSlot, Int) ) +stepChoiceScreen highlightBullet dm sfBlank frsX extraKeys = do CCUI{coscreen=ScreenContent{rwidth, rheight}} <- getsSession sccui FontSetup{..} <- getFontSetup + UIOptions{uVi, uLeftHand} <- getsSession sUIOptions let !_A = assert (K.escKM `elem` extraKeys) () frs = slideshow frsX keys = concatMap (lefts . map fst . snd) frs ++ extraKeys - legalKeys = keys - ++ navigationKeys - ++ (if menuName == "help" - then [K.mkChar '?', K.mkKM "F1"] - else []) -- a hack + cardinalKeys = K.cardinalAllKM uVi uLeftHand + handleDir = K.handleCardinal cardinalKeys + legalKeys = keys ++ navigationKeys ++ cardinalKeys allOKX = concatMap snd frs maxIx = length allOKX - 1 initIx = case findIndex (isRight . fst) allOKX of @@ -206,14 +267,17 @@ trimmedY = canvasLength - 1 - 2 -- will be translated down 2 lines trimmedAlert = ( PointUI 0 trimmedY , stringToAL "--a portion of the text trimmed--" ) - page :: Int -> OKX -> m (Bool, KeyOrSlot, Int) + page :: Int -> OKX -> m (Bool, Either (K.KM, KeyOrSlot) MenuSlot, Int) page pointer (ovsRight0, kyxsRight) = assert (pointer >= 0) $ case findKYX pointer frs of Nothing -> error $ "no menu keys" `showFailure` frs - Just ( (ovs0, kyxs1) + Just ( (ovs0, kyxs2) , (ekm, (PointUI x1 y, buttonWidth)) , ixOnPage ) -> do let ovs1 = EM.map (updateLine y $ drawHighlight x1 buttonWidth) ovs0 + ovs2 = if highlightBullet + then EM.map (highBullet kyxs2) ovs1 + else ovs1 -- We add spaces in proportional font under the report rendered -- in mono font and the right pane text in prop font, -- but over menu lines in proportional font that can be @@ -250,12 +314,15 @@ (EM.map (xytranslateOverlay 2 2) ovsRight1) (ovs, kyxs) = if EM.null ovsRight0 - then (ovs1, kyxs1) - else sideBySideOKX rwidth 0 (ovs1, kyxs1) (ovsRight, kyxsRight) + then (ovs2, kyxs2) + else sideBySideOKX rwidth 0 (ovs2, kyxs2) (ovsRight, kyxsRight) + kmkm ekm2 = case ekm2 of + Left km -> Left (km, ekm2) + Right slot -> Right slot tmpResult pointer1 = case findKYX pointer1 frs of Nothing -> error $ "no menu keys" `showFailure` frs - Just (_, (ekm1, _), _) -> return (False, ekm1, pointer1) - ignoreKey = return (False, ekm, pointer) + Just (_, (ekm1, _), _) -> return (False, kmkm ekm1, pointer1) + ignoreKey = return (False, kmkm ekm, pointer) pageLen = length kyxs xix :: KYX -> Bool xix (_, (PointUI x1' _, _)) = x1' <= x1 + 2 && x1' >= x1 - 2 @@ -265,7 +332,8 @@ firstItemOfNextPage = case findIndex (isRight . fst) restOKX of Just p -> p + firstRowOfNextPage _ -> firstRowOfNextPage - interpretKey :: K.KM -> m (Bool, KeyOrSlot, Int) + interpretKey :: K.KM + -> m (Bool, Either (K.KM, KeyOrSlot) MenuSlot, Int) interpretKey ikm = case K.key ikm of _ | ikm == K.controlP -> do @@ -274,8 +342,8 @@ ignoreKey K.Return -> case ekm of Left km -> - if K.key km == K.Return && km `elem` keys - then return (True, Left km, pointer) + if K.key km == K.Return + then return (True, Left (km, ekm), pointer) else interpretKey km Right c -> return (True, Right c, pointer) K.LeftButtonRelease -> do @@ -286,45 +354,51 @@ in my == cy && mx >= cx && mx < cx + blen case find onChoice kyxs of Nothing | ikm `elem` keys -> - return (True, Left ikm, pointer) - Nothing -> if K.spaceKM `elem` keys - then return (True, Left K.spaceKM, pointer) - else ignoreKey + return (True, Left (ikm, ekm), pointer) + Nothing -> + if K.spaceKM `elem` keys + then return (True, Left (K.spaceKM, ekm), pointer) + else ignoreKey Just (ckm, _) -> case ckm of Left km -> if K.key km == K.Return && km `elem` keys - then return (True, Left km, pointer) + then return (True, Left (km, ekm), pointer) else interpretKey km Right c -> return (True, Right c, pointer) K.RightButtonRelease -> - if | ikm `elem` keys -> return (True, Left ikm, pointer) - | K.escKM `elem` keys -> - return (True, Left K.escKM, pointer) - | otherwise -> ignoreKey + if ikm `elem` keys + then return (True, Left (ikm, ekm), pointer) + else return (True, Left (K.escKM, ekm), pointer) K.Space | firstItemOfNextPage <= maxIx -> tmpResult firstItemOfNextPage - _ | K.key ikm `elem` [K.Char '?', K.Fun 1] - && firstItemOfNextPage <= maxIx - && menuName == "help" -> -- a hack - tmpResult firstItemOfNextPage K.Unknown "SAFE_SPACE" -> if firstItemOfNextPage <= maxIx then tmpResult firstItemOfNextPage else tmpResult clearIx _ | ikm `elem` keys -> - return (True, Left ikm, pointer) - _ | K.key ikm `elem` [K.Up, K.WheelNorth] -> + return (True, Left (ikm, ekm), pointer) + _ | K.key ikm == K.WheelNorth + || handleDir ikm == Just (Vector 0 (-1)) -> case findIndex xix $ reverse $ take ixOnPage kyxs of - Nothing -> interpretKey ikm{K.key=K.Left} + Nothing -> if pointer == 0 then tmpResult maxIx + else tmpResult (max 0 (pointer - 1)) Just ix -> tmpResult (max 0 (pointer - ix - 1)) - _ | K.key ikm `elem` [K.Down, K.WheelSouth] -> + _ | K.key ikm == K.WheelSouth + || handleDir ikm == Just (Vector 0 1) -> case findIndex xix $ drop (ixOnPage + 1) kyxs of - Nothing -> interpretKey ikm{K.key=K.Right} + Nothing -> if pointer == maxIx then tmpResult 0 + else tmpResult (min maxIx (pointer + 1)) Just ix -> tmpResult (pointer + ix + 1) - K.Left -> if pointer == 0 then tmpResult maxIx - else tmpResult (max 0 (pointer - 1)) - K.Right -> if pointer == maxIx then tmpResult 0 - else tmpResult (min maxIx (pointer + 1)) + _ | handleDir ikm == Just (Vector (-1) 0) -> + case findKYX (max 0 (pointer - 1)) frs of + Just (_, (_, (PointUI _ y2, _)), _) | y2 == y -> + tmpResult (max 0 (pointer - 1)) + _ -> ignoreKey + _ | handleDir ikm == Just (Vector 1 0) -> + case findKYX (min maxIx (pointer + 1)) frs of + Just (_, (_, (PointUI _ y2, _)), _) | y2 == y -> + tmpResult (min maxIx (pointer + 1)) + _ -> ignoreKey K.Home -> tmpResult clearIx K.End -> tmpResult maxIx K.PgUp -> @@ -334,18 +408,24 @@ -- and menu non-empty, but that scenario is rare, so OK, -- arrow keys may be used instead. tmpResult (min maxIx firstItemOfNextPage) - K.Space -> if pointer == maxIx - then tmpResult clearIx - else tmpResult maxIx + K.Space -> ignoreKey + _ | K.key ikm `elem` [K.Char '?', K.Fun 1] -> do + -- Clear macros and invoke the help macro. + modifySession $ \sess -> + sess { smacroFrame = + emptyMacroFrame {keyPending = + KeyMacro [K.mkKM "F1"]} + , smacroStack = [] } + return (True, Left (K.escKM, ekm), pointer) _ -> error $ "unknown key" `showFailure` ikm pkm <- promptGetKey dm ovs sfBlank legalKeys interpretKey pkm m pointer okxRight = if null frs - then return (True, Left K.escKM, pointer) + then return (True, Left (K.escKM, Left K.escKM), pointer) else do (final, km, pointer1) <- page pointer okxRight - let !_A1 = assert (either (`elem` keys) (const True) km) () + let !_A1 = assert (either ((`elem` keys) . fst) (const True) km) () -- Pointer at a button included, hence greater than 0, not @clearIx@. let !_A2 = assert (0 <= pointer1 && pointer1 <= maxIx `blame` (pointer1, maxIx)) () @@ -354,10 +434,9 @@ navigationKeys :: [K.KM] navigationKeys = [ K.leftButtonReleaseKM, K.rightButtonReleaseKM - , K.returnKM, K.spaceKM - , K.upKM, K.downKM, K.wheelNorthKM, K.wheelSouthKM - , K.leftKM, K.rightKM, K.pgupKM, K.pgdnKM - , K.homeKM, K.endKM, K.controlP ] + , K.returnKM, K.spaceKM, K.wheelNorthKM, K.wheelSouthKM + , K.pgupKM, K.pgdnKM, K.homeKM, K.endKM, K.controlP + , K.mkChar '?', K.mkKM "F1" ] -- | Find a position in a menu. -- The arguments go from first menu line and menu page to the last, @@ -385,7 +464,10 @@ (Color.acAttr c) {Color.fg = Color.BrWhite}} cursorAttr c = c {Color.acAttr = (Color.acAttr c) - {Color.bg = Color.HighlightNoneCursor}} + {Color.bg = Color.HighlightNoneCursor}} + noCursorAttr c = c {Color.acAttr = + (Color.acAttr c) + {Color.bg = Color.HighlightNone}} -- This also highlights dull white item symbols, but who cares. lenUI = if isSquareFont font then len * 2 else len x1MinusXStartChars = if isSquareFont font @@ -393,15 +475,107 @@ else x1 - xstart (as1, asRest) = splitAt x1MinusXStartChars as (as2, as3) = splitAt len asRest - highW32 = Color.attrCharToW32 - . highAttr - . Color.attrCharFromW32 - cursorW32 = Color.attrCharToW32 - . cursorAttr - . Color.attrCharFromW32 - as2High = case map highW32 as2 of + highW32 = Color.attrCharToW32 . highAttr . Color.attrCharFromW32 + as2High = map highW32 as2 + cursorW32 = Color.attrCharToW32 . cursorAttr . Color.attrCharFromW32 + (nonAlpha, alpha) = break (Char.isAlphaNum . Color.charFromW32) as2High + as2Cursor = case alpha of [] -> [] ch : chrest -> cursorW32 ch : chrest + noCursorW32 = Color.attrCharToW32 . noCursorAttr . Color.attrCharFromW32 in if x1 + lenUI < xstart then as - else as1 ++ as2High ++ as3 + else as1 ++ map noCursorW32 nonAlpha ++ as2Cursor ++ as3 + +drawBullet :: Int -> ButtonWidth -> Int -> AttrString -> AttrString +drawBullet x1 (ButtonWidth font len) xstart as0 = + let diminishChar '-' = ' ' + diminishChar '^' = '^' + diminishChar '"' = '"' + diminishChar _ = '·' + highableAttr = Color.defAttr {Color.bg = Color.HighlightNoneCursor} + highW32 ac32 = + let ac = Color.attrCharFromW32 ac32 + ch = diminishChar $ Color.acChar ac + in if | Color.acAttr ac /= highableAttr -> ac32 + | Color.acChar ac == ' ' -> + error $ "drawBullet: HighlightNoneCursor space forbidden" + `showFailure` (ac, map Color.charFromW32 as0) + | ch == ' ' -> Color.spaceAttrW32 + | otherwise -> + Color.attrCharToW32 + $ ac { Color.acAttr = Color.defAttr {Color.fg = Color.BrBlack} + , Color.acChar = ch } + lenUI = if isSquareFont font then len * 2 else len + x1MinusXStartChars = if isSquareFont font + then (x1 - xstart) `div` 2 + else x1 - xstart + (as1, asRest) = splitAt x1MinusXStartChars as0 + (as2, as3) = splitAt len asRest + highAs = \case + toHighlight : rest -> highW32 toHighlight : rest + [] -> [] + in if x1 + lenUI < xstart + then as0 + else as1 ++ highAs as2 ++ as3 + +highBullet :: [KYX] -> Overlay -> Overlay +highBullet kyxs ov0 = + let f (_, (PointUI x1 y, buttonWidth)) = + updateLine y $ drawBullet x1 buttonWidth + in foldr f ov0 kyxs + +-- This is not our turn, so we can't obstruct screen with messages +-- and message reformatting causes distraction, so there's no point +-- trying to squeeze the report into the single available line, +-- except when it's not our turn permanently, because AI runs UI. +-- +-- The only real drawback of this is that when resting for longer time +-- I can't see the boring messages accumulate until a non-boring interrupts me. +basicFrameWithoutReport :: MonadClientUI m + => LevelId -> Maybe Bool -> m PreFrame3 +basicFrameWithoutReport arena forceReport = do + FontSetup{propFont} <- getFontSetup + sbenchMessages <- getsClient $ sbenchMessages . soptions + side <- getsClient sside + fact <- getsState $ (EM.! side) . sfactionD + truncRep <- + if | sbenchMessages -> do + slides <- reportToSlideshowKeepHalt False [] + case slideshow slides of + [] -> return EM.empty + (ov, _) : _ -> do + -- See @stepQueryUI@. This strips either "--end-" or "--more-". + let ovProp = ov EM.! propFont + return $! + EM.singleton propFont + $ if EM.size ov > 1 then ovProp else init ovProp + | fromMaybe (gunderAI fact) forceReport -> do + report <- getReportUI False + let par1 = firstParagraph $ foldr (<+:>) [] $ renderReport True report + return $! EM.fromList [(propFont, [(PointUI 0 0, par1)])] + | otherwise -> return EM.empty + drawOverlay ColorFull False truncRep arena + +-- | Push the frame depicting the current level to the frame queue. +-- Only one line of the report is shown, as in animations, +-- because it may not be our turn, so we can't clear the message +-- to see what is underneath. +pushFrame :: MonadClientUI m => Bool -> m () +pushFrame delay = do + -- The delay before reaction to keypress was too long in case of many + -- projectiles flying and ending flight, so frames need to be skipped. + keyPressed <- anyKeyPressed + unless keyPressed $ do + lidV <- viewedLevelUI + frame <- basicFrameWithoutReport lidV Nothing + -- Pad with delay before and after to let player see, e.g., door being + -- opened a few ticks after it came into vision, the same turn. + displayFrames lidV $ + if delay then [Nothing, Just frame, Nothing] else [Just frame] + +pushReportFrame :: MonadClientUI m => m () +pushReportFrame = do + lidV <- viewedLevelUI + frame <- basicFrameWithoutReport lidV (Just True) + displayFrames lidV [Just frame] diff --git a/engine-src/Game/LambdaHack/Client/UI/UIOptionsParse.hs b/engine-src/Game/LambdaHack/Client/UI/UIOptionsParse.hs --- a/engine-src/Game/LambdaHack/Client/UI/UIOptionsParse.hs +++ b/engine-src/Game/LambdaHack/Client/UI/UIOptionsParse.hs @@ -107,7 +107,7 @@ mkUIOptions corule clientOptions = do let benchmark = sbenchmark clientOptions cfgUIName = rcfgUIName corule - (configString, cfgUIDefault) = rcfgUIDefault corule + (configText, cfgUIDefault) = rcfgUIDefault corule dataDir <- appDataDir let path bkp = dataDir bkp <> cfgUIName cfgUser <- if benchmark then return Ini.emptyConfig else do @@ -147,7 +147,9 @@ then "The config file and savefiles have been moved aside." else "The config file has been moved aside." delayPrint msg - tryWriteFile (path "") configString + dataDirExists <- doesFileExist dataDir + when dataDirExists $ -- may not exist, e.g., when testing + tryWriteFile (path "") configText let confDefault = parseConfig cfgUIDefault return confDefault @@ -167,5 +169,4 @@ (\opts -> opts {stitle = stitle opts `mplus` Just (rtitle corule)}) . (\opts -> opts {sfonts = uFonts uioptions}) . - (\opts -> opts {sfontsets = uFontsets uioptions}) . - id + (\opts -> opts {sfontsets = uFontsets uioptions}) diff --git a/engine-src/Game/LambdaHack/Client/UI/Watch/WatchCommonM.hs b/engine-src/Game/LambdaHack/Client/UI/Watch/WatchCommonM.hs --- a/engine-src/Game/LambdaHack/Client/UI/Watch/WatchCommonM.hs +++ b/engine-src/Game/LambdaHack/Client/UI/Watch/WatchCommonM.hs @@ -1,13 +1,11 @@ -- | Common code for displaying atomic update and SFX commands. module Game.LambdaHack.Client.UI.Watch.WatchCommonM - ( pushFrame, pushReportFrame, fadeOutOrIn, markDisplayNeeded - , lookAtMove, stopAtMove + ( fadeOutOrIn, markDisplayNeeded, lookAtMove, stopAtMove , aidVerbMU, aidVerbDuplicateMU, itemVerbMUGeneral, itemVerbMU , itemVerbMUShort, itemAidVerbMU, mitemAidVerbMU, itemAidDistinctMU , manyItemsAidVerbMU #ifdef EXPOSE_INTERNAL -- * Internal operations - , basicFrameWithoutReport #endif ) where @@ -24,21 +22,15 @@ import Game.LambdaHack.Client.UI.Animation import Game.LambdaHack.Client.UI.Content.Screen import Game.LambdaHack.Client.UI.ContentClientUI -import Game.LambdaHack.Client.UI.Frame import Game.LambdaHack.Client.UI.FrameM import Game.LambdaHack.Client.UI.HandleHelperM import Game.LambdaHack.Client.UI.ItemDescription import Game.LambdaHack.Client.UI.MonadClientUI import Game.LambdaHack.Client.UI.Msg import Game.LambdaHack.Client.UI.MsgM -import Game.LambdaHack.Client.UI.Overlay -import Game.LambdaHack.Client.UI.PointUI import Game.LambdaHack.Client.UI.SessionUI -import Game.LambdaHack.Client.UI.Slideshow -import Game.LambdaHack.Client.UI.SlideshowM import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState -import Game.LambdaHack.Common.ClientOptions import Game.LambdaHack.Common.Faction import Game.LambdaHack.Common.Item import qualified Game.LambdaHack.Common.ItemAspect as IA @@ -47,62 +39,6 @@ import Game.LambdaHack.Common.State import Game.LambdaHack.Common.Types import qualified Game.LambdaHack.Definition.Ability as Ability - --- This is not our turn, so we can't obstruct screen with messages --- and message reformatting causes distraction, so there's no point --- trying to squeeze the report into the single available line, --- except when it's not our turn permanently, because AI runs UI. --- --- The only real drawback of this is that when resting for longer time --- I can't see the boring messages accumulate until a non-boring interrupts me. -basicFrameWithoutReport :: MonadClientUI m - => LevelId -> Maybe Bool -> m PreFrame3 -basicFrameWithoutReport arena forceReport = do - FontSetup{propFont} <- getFontSetup - sbenchMessages <- getsClient $ sbenchMessages . soptions - side <- getsClient sside - fact <- getsState $ (EM.! side) . sfactionD - let underAI = isAIFact fact - truncRep <- - if | sbenchMessages -> do - slides <- reportToSlideshowKeepHalt False [] - case slideshow slides of - [] -> return EM.empty - (ov, _) : _ -> do - -- See @stepQueryUI@. This strips either "--end-" or "--more-". - let ovProp = ov EM.! propFont - return $! - EM.singleton propFont - $ if EM.size ov > 1 then ovProp else init ovProp - | fromMaybe underAI forceReport -> do - report <- getReportUI False - let par1 = firstParagraph $ foldr (<+:>) [] $ renderReport True report - return $! EM.fromList [(propFont, [(PointUI 0 0, par1)])] - | otherwise -> return EM.empty - drawOverlay ColorFull False truncRep arena - --- | Push the frame depicting the current level to the frame queue. --- Only one line of the report is shown, as in animations, --- because it may not be our turn, so we can't clear the message --- to see what is underneath. -pushFrame :: MonadClientUI m => Bool -> m () -pushFrame delay = do - -- The delay before reaction to keypress was too long in case of many - -- projectiles flying and ending flight, so frames need to be skipped. - keyPressed <- anyKeyPressed - unless keyPressed $ do - lidV <- viewedLevelUI - frame <- basicFrameWithoutReport lidV Nothing - -- Pad with delay before and after to let player see, e.g., door being - -- opened a few ticks after it came into vision, the same turn. - displayFrames lidV $ - if delay then [Nothing, Just frame, Nothing] else [Just frame] - -pushReportFrame :: MonadClientUI m => m () -pushReportFrame = do - lidV <- viewedLevelUI - frame <- basicFrameWithoutReport lidV (Just True) - displayFrames lidV [Just frame] fadeOutOrIn :: MonadClientUI m => Bool -> m () fadeOutOrIn out = do diff --git a/engine-src/Game/LambdaHack/Client/UI/Watch/WatchQuitM.hs b/engine-src/Game/LambdaHack/Client/UI/Watch/WatchQuitM.hs --- a/engine-src/Game/LambdaHack/Client/UI/Watch/WatchQuitM.hs +++ b/engine-src/Game/LambdaHack/Client/UI/Watch/WatchQuitM.hs @@ -5,7 +5,7 @@ #ifdef EXPOSE_INTERNAL -- * Internal operations , displayGameOverLoot, displayGameOverAnalytics, displayGameOverLore - , viewLoreItems + , viewFinalLore #endif ) where @@ -14,6 +14,8 @@ import Game.LambdaHack.Core.Prelude import qualified Data.EnumMap.Strict as EM +import qualified Data.EnumSet as ES +import qualified Data.Map.Strict as M import qualified NLP.Miniutter.English as MU import Game.LambdaHack.Client.MonadClient @@ -24,16 +26,13 @@ import Game.LambdaHack.Client.UI.EffectDescription import Game.LambdaHack.Client.UI.Frame import Game.LambdaHack.Client.UI.HandleHelperM -import Game.LambdaHack.Client.UI.ItemSlot import qualified Game.LambdaHack.Client.UI.Key as K import Game.LambdaHack.Client.UI.MonadClientUI import Game.LambdaHack.Client.UI.Msg import Game.LambdaHack.Client.UI.MsgM -import Game.LambdaHack.Client.UI.Overlay import Game.LambdaHack.Client.UI.SessionUI import Game.LambdaHack.Client.UI.Slideshow import Game.LambdaHack.Client.UI.SlideshowM -import Game.LambdaHack.Client.UI.Watch.WatchCommonM import Game.LambdaHack.Common.Actor import Game.LambdaHack.Common.ActorState import Game.LambdaHack.Common.Analytics @@ -46,6 +45,7 @@ import Game.LambdaHack.Common.MonadStateRead import Game.LambdaHack.Common.State import Game.LambdaHack.Common.Types +import Game.LambdaHack.Content.FactionKind import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind import qualified Game.LambdaHack.Definition.Ability as Ability @@ -56,13 +56,28 @@ -> Maybe (FactionAnalytics, GenerationAnalytics) -> m () quitFactionUI fid toSt manalytics = do + side <- getsClient sside + gameModeId <- getsState sgameModeId + when (side == fid) $ case toSt of + Just Status{stOutcome=Camping} -> + modifySession $ \sess -> + sess {scampings = ES.insert gameModeId $ scampings sess} + Just Status{stOutcome=Restart} -> + modifySession $ \sess -> + sess {srestarts = ES.insert gameModeId $ srestarts sess} + Just Status{stOutcome} | stOutcome `elem` victoryOutcomes -> do + scurChal <- getsClient scurChal + let sing = M.singleton scurChal 1 + f = M.unionWith (+) + g = EM.insertWith f gameModeId sing + modifySession $ \sess -> sess {svictories = g $ svictories sess} + _ -> return () ClientOptions{sexposeItems} <- getsClient soptions fact <- getsState $ (EM.! fid) . sfactionD let fidName = MU.Text $ gname fact - person = if fhasGender $ gplayer fact then MU.PlEtc else MU.Sg3rd + person = if fhasGender $ gkind fact then MU.PlEtc else MU.Sg3rd horror = isHorrorFact fact camping = maybe True ((== Camping) . stOutcome) toSt - side <- getsClient sside when (fid == side && not camping) $ do tellGameClipPS resetGameStart @@ -111,12 +126,12 @@ let getTrunkFull (aid, b) = (aid, itemToF $ btrunk b) ourTrunks <- getsState $ map getTrunkFull . fidActorNotProjGlobalAssocs side - let smartFaction fact2 = fleaderMode (gplayer fact2) /= Nothing + let smartFaction fact2 = fhasPointman (gkind fact2) canBeSmart = any (smartFaction . snd) canBeOurFaction = any (\(fid2, _) -> fid2 == side) smartEnemy trunkFull = let possible = - possibleActorFactions (itemKind trunkFull) factionD + possibleActorFactions [] (itemKind trunkFull) factionD in not (canBeOurFaction possible) && canBeSmart possible smartEnemiesOurs = filter (smartEnemy . snd) ourTrunks uniqueActor trunkFull = IA.checkFlag Ability.Unique @@ -186,27 +201,23 @@ epilogue _ -> when (isJust startingPart && (stOutcome <$> toSt) == Just Killed) $ do - msgAdd MsgTutorialHint "When a whole faction gets eliminated, no new members of the party will ever appear and its stashed belongings may remain far off, unclaimed and undefended. While some adventures require elimination a faction (to be verified in the adventure description screen in the help menu), for others it's an optional task, if possible at all. Instead, finding an exit may be necessary to win. It's enough if one character finds and triggers the exit. Others automatically follow, duly hauling all common belongings." + msgAdd MsgTutorialHint "When a whole faction gets eliminated, no new members of the party will ever appear and its stashed belongings may remain far off, unclaimed and undefended. While some adventures require elimination a faction (to be verified in the adventure description screen in the help menu), for others it's an optional task, if possible at all. Instead, finding an exit may be necessary to win. It's enough if one character finds and triggers the exit. Others automatically follow, duly hauling all common belongings. Similarly, if eliminating foes ends a challenge, it happens immediately, with no need to move party members anywhere." -- Needed not to overlook the competitor dying in raid scenario. - displayMore ColorFull "" + displayMore ColorFull "This is grave news. What now?" displayGameOverLoot :: MonadClientUI m => (ItemBag, Int) -> GenerationAnalytics -> m K.KM displayGameOverLoot (heldBag, total) generationAn = do ClientOptions{sexposeItems} <- getsClient soptions COps{coitem} <- getsState scops - ItemSlots itemSlots <- getsSession sslots -- We assume "gold grain", not "grain" with label "of gold": let currencyName = IK.iname $ okind coitem $ ouniqGroup coitem IK.S_CURRENCY - lSlotsRaw = EM.filter (`EM.member` heldBag) $ itemSlots EM.! SItem generationItem = generationAn EM.! SItem - (itemBag, lSlots) = + itemBag = if sexposeItems then let generationBag = EM.map (\k -> (-k, [])) generationItem - bag = heldBag `EM.union` generationBag - slots = EM.fromDistinctAscList $ zip allSlots $ EM.keys bag - in (bag, slots) - else (heldBag, lSlotsRaw) + in heldBag `EM.union` generationBag + else heldBag promptFun iid itemFull2 k = let worth = itemPrice 1 $ itemKind itemFull2 lootMsg = if worth == 0 then "" else @@ -240,7 +251,7 @@ <+> (if sexposeItems then "Non-positive count means none held but this many generated." else "") - viewLoreItems "GameOverLoot" lSlots itemBag prompt promptFun True + viewFinalLore "GameOverLoot" itemBag prompt promptFun (MLore SItem) displayGameOverAnalytics :: MonadClientUI m => FactionAnalytics -> GenerationAnalytics @@ -248,24 +259,22 @@ displayGameOverAnalytics factionAn generationAn = do ClientOptions{sexposeActors} <- getsClient soptions side <- getsClient sside - ItemSlots itemSlots <- getsSession sslots + ItemRoles itemRoles <- getsSession sroles let ourAn = akillCounts $ EM.findWithDefault emptyAnalytics side factionAn - foesAn = EM.unionsWith (+) - $ concatMap EM.elems $ catMaybes - $ map (`EM.lookup` ourAn) [KillKineticMelee .. KillOtherPush] - trunkBagRaw = EM.map (, []) foesAn - lSlotsRaw = EM.filter (`EM.member` trunkBagRaw) $ itemSlots EM.! STrunk - killedBag = EM.fromList $ map (\iid -> (iid, trunkBagRaw EM.! iid)) - (EM.elems lSlotsRaw) + foesAn = EM.unionsWith (+) $ concatMap EM.elems + $ mapMaybe (`EM.lookup` ourAn) + [KillKineticMelee .. KillOtherPush] + killedBagIncludingProjectiles = EM.map (, []) foesAn + killedBag = EM.filterWithKey + (\iid _ -> iid `ES.member` (itemRoles EM.! STrunk)) + killedBagIncludingProjectiles generationTrunk = generationAn EM.! STrunk - (trunkBag, lSlots) = + trunkBag = if sexposeActors then let generationBag = EM.map (\k -> (-k, [])) generationTrunk - bag = killedBag `EM.union` generationBag - slots = EM.fromDistinctAscList $ zip allSlots $ EM.keys bag - in (bag, slots) - else (killedBag, lSlotsRaw) + in killedBag `EM.union` generationBag + else killedBag total = sum $ filter (> 0) $ map fst $ EM.elems trunkBag -- Not just "killed 1 out of 4", because it's sometimes "2 out of 1", -- if an enemy was revived. @@ -281,85 +290,64 @@ <+> (if sexposeActors then "Non-positive count means none killed but this many reported." else "") - viewLoreItems "GameOverAnalytics" lSlots trunkBag prompt promptFun False + viewFinalLore "GameOverAnalytics" trunkBag prompt promptFun (MLore STrunk) displayGameOverLore :: MonadClientUI m => SLore -> Bool -> GenerationAnalytics -> m K.KM displayGameOverLore slore exposeCount generationAn = do - let generationLore = generationAn EM.! slore + itemD <- getsState sitemD + let -- In @sexposeItems@ mode this filtering passes all through + -- thanks to @revealItems@. + generationLore = EM.filterWithKey (\iid _ -> iid `EM.member` itemD) + $ generationAn EM.! slore generationBag = EM.map (\k -> (if exposeCount then k else 1, [])) generationLore total = sum $ map fst $ EM.elems generationBag - slots = EM.fromDistinctAscList $ zip allSlots $ EM.keys generationBag promptFun :: ItemId -> ItemFull-> Int -> Text promptFun _ _ k = makeSentence [ "this", MU.Text (ppSLore slore), "manifested during your quest" , MU.CarWs k "time" ] verb = if | slore `elem` [SCondition, SBlast] -> "experienced" - | slore == SEmbed -> "strived through" + | slore == SEmbed -> "ambled among" | otherwise -> "lived among" prompt = case total of 0 -> makeSentence [ "you didn't experience any" , MU.Ws $ MU.Text (headingSLore slore) , "this time" ] - 1 -> makeSentence [ "you", verb, "the following" + 1 -> makeSentence [ "you saw the following" , MU.Text (headingSLore slore) ] _ -> makeSentence [ "you", verb, "the following variety of" , MU.CarWs total $ MU.Text (headingSLore slore) ] - displayRanged = slore `notElem` [SOrgan, STrunk] - viewLoreItems ("GameOverLore" ++ show slore) - slots generationBag prompt promptFun displayRanged + viewFinalLore ("GameOverLore" ++ show slore) + generationBag prompt promptFun (MLore slore) -viewLoreItems :: forall m . MonadClientUI m - => String -> SingleItemSlots -> ItemBag -> Text +viewFinalLore :: forall m . MonadClientUI m + => String -> ItemBag -> Text -> (ItemId -> ItemFull -> Int -> Text) - -> Bool + -> ItemDialogMode -> m K.KM -viewLoreItems menuName lSlotsRaw trunkBag prompt promptFun displayRanged = do - CCUI{coscreen=ScreenContent{rwidth, rheight}} <- getsSession sccui - FontSetup{..} <- getFontSetup - arena <- getArenaUI +viewFinalLore menuName trunkBag prompt promptFun dmode = do + CCUI{coscreen=ScreenContent{rheight}} <- getsSession sccui itemToF <- getsState $ flip itemToFull - let keysPre = [K.spaceKM, K.mkChar '<', K.mkChar '>', K.escKM] - lSlots = sortSlotMap itemToF lSlotsRaw - msgAdd MsgPromptGeneric prompt - io <- itemOverlay lSlots arena trunkBag displayRanged - itemSlides <- overlayToSlideshow (rheight - 2) keysPre io - let keyOfEKM (Left km) = km - keyOfEKM (Right SlotChar{slotChar}) = K.mkChar slotChar - allOKX = concatMap snd $ slideshow itemSlides - keysMain = keysPre ++ map (keyOfEKM . fst) allOKX - displayInRightPane :: KeyOrSlot -> m OKX - displayInRightPane ekm = case ekm of - _ | isSquareFont propFont -> return emptyOKX - Left{} -> return emptyOKX - Right slot -> do - let ix0 = fromMaybe (error $ show slot) - (elemIndex slot $ EM.keys lSlots) - -- Mono font used, because lots of numbers in these blurbs - -- and because some prop fonts wider than mono (e.g., in the - -- dejavuBold font set). - -- Lower width, to permit extra vertical space at the start, - -- because gameover menu prompts are sometimes wide and/or long. - okxItemLorePointedAt - monoFont (rwidth - 2) True trunkBag 0 promptFun ix0 lSlots - viewAtSlot :: SlotChar -> m K.KM + let iids = sortIids itemToF $ EM.assocs trunkBag + viewAtSlot :: MenuSlot -> m K.KM viewAtSlot slot = do - let ix0 = fromMaybe (error $ show slot) - (elemIndex slot $ EM.keys lSlots) - km <- displayItemLore trunkBag 0 promptFun ix0 lSlots False + let renderOneItem = okxItemLoreMsg promptFun 0 dmode iids + extraKeys = [] + slotBound = length iids - 1 + km <- displayOneMenuItem renderOneItem extraKeys slotBound slot case K.key km of - K.Space -> viewLoreItems menuName lSlots trunkBag prompt - promptFun displayRanged + K.Space -> viewFinalLore menuName trunkBag prompt promptFun dmode K.Esc -> return km _ -> error $ "" `showFailure` km - ekm <- displayChoiceScreenWithRightPane displayInRightPane - menuName ColorFull False itemSlides keysMain + msgAdd MsgPromptGeneric prompt + let keys = [K.spaceKM, K.mkChar '<', K.mkChar '>', K.escKM] + okx <- itemOverlay iids dmode + sli <- overlayToSlideshow (rheight - 2) keys okx + ekm <- displayChoiceScreenWithDefItemKey + (okxItemLoreInline promptFun 0 dmode iids) sli keys menuName case ekm of - Left km | km `elem` [K.spaceKM, K.mkChar '<', K.mkChar '>', K.escKM] -> - return km - Left K.KM{key=K.Char l} -> viewAtSlot $ SlotChar 0 l - -- other prefixes are not accessible via keys; tough luck; waste of effort + Left km | km `elem` keys -> return km Left km -> error $ "" `showFailure` km Right slot -> viewAtSlot slot diff --git a/engine-src/Game/LambdaHack/Client/UI/Watch/WatchSfxAtomicM.hs b/engine-src/Game/LambdaHack/Client/UI/Watch/WatchSfxAtomicM.hs --- a/engine-src/Game/LambdaHack/Client/UI/Watch/WatchSfxAtomicM.hs +++ b/engine-src/Game/LambdaHack/Client/UI/Watch/WatchSfxAtomicM.hs @@ -312,9 +312,9 @@ IK.DropItem{} -> -- rare enough mitemAidVerbMU MsgEffectMedium aid "be stripped" iid (Just "with") IK.Recharge{} | not isAlive -> return () - IK.Recharge{} -> aidVerbMU MsgEffectMedium aid "heat up" + IK.Recharge{} -> aidVerbMU MsgEffectMedium aid "charge up" IK.Discharge{} | not isAlive -> return () - IK.Discharge{} -> aidVerbMU MsgEffectMedium aid "cool down" + IK.Discharge{} -> aidVerbMU MsgEffectMedium aid "lose charges" IK.PolyItem -> do subject <- partActorLeader aid let ppstore = MU.Text $ ppCStoreIn CGround @@ -417,8 +417,10 @@ msgAdd MsgActionWarning $ makePhrase [MU.Capitalize $ MU.SubjectVerbSg subject $ MU.Text verb] <> ending - SfxItemApplied iid c -> - itemVerbMU MsgInnerWorkSpam iid (1, []) "have been triggered" c + SfxItemApplied verbose iid c -> do + if verbose + then itemVerbMU MsgActionMinor iid (1, []) "have got activated" c + else itemVerbMU MsgInnerWorkSpam iid (1, []) "have been triggered" c SfxMsgFid _ sfxMsg -> do mleader <- getsClient sleader case mleader of diff --git a/engine-src/Game/LambdaHack/Client/UI/Watch/WatchUpdAtomicM.hs b/engine-src/Game/LambdaHack/Client/UI/Watch/WatchUpdAtomicM.hs --- a/engine-src/Game/LambdaHack/Client/UI/Watch/WatchUpdAtomicM.hs +++ b/engine-src/Game/LambdaHack/Client/UI/Watch/WatchUpdAtomicM.hs @@ -3,7 +3,7 @@ ( watchRespUpdAtomicUI #ifdef EXPOSE_INTERNAL -- * Internal operations - , updateItemSlot, Threat, createActorUI, destroyActorUI, spotItemBag + , assignItemRole, Threat, createActorUI, destroyActorUI, spotItemBag , recordItemLid, moveActor, displaceActorUI, moveItemUI , discover, ppHearMsg, ppHearDistanceAdjective, ppHearDistanceAdverb #endif @@ -19,7 +19,6 @@ import qualified Data.EnumSet as ES import qualified Data.Map.Strict as M import qualified Data.Text as T -import Data.Tuple import GHC.Exts (inline) import qualified NLP.Miniutter.English as MU @@ -35,7 +34,6 @@ import Game.LambdaHack.Client.UI.FrameM import Game.LambdaHack.Client.UI.HandleHelperM import Game.LambdaHack.Client.UI.ItemDescription -import Game.LambdaHack.Client.UI.ItemSlot import qualified Game.LambdaHack.Client.UI.Key as K import Game.LambdaHack.Client.UI.MonadClientUI import Game.LambdaHack.Client.UI.Msg @@ -60,6 +58,7 @@ import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Types import Game.LambdaHack.Content.CaveKind (cdesc) +import Game.LambdaHack.Content.FactionKind import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind import qualified Game.LambdaHack.Content.ModeKind as MK @@ -85,8 +84,8 @@ UpdDestroyActor aid body _ -> destroyActorUI True aid body UpdCreateItem verbose iid _ kit@(kAdd, _) c -> do recordItemLid iid c - updateItemSlot c iid - if verbose then case c of + assignItemRole c iid + when verbose $ case c of CActor aid store -> do b <- getsState $ getActorBody aid case store of @@ -147,18 +146,15 @@ wown <- ppContainerWownW partActorLeader True c itemVerbMU MsgItemCreation iid kit (MU.Text $ makePhrase $ "appear" : wown) c - CEmbed lid _ -> markDisplayNeeded lid + CEmbed{} -> return () -- not visible so can't delay even if important CFloor lid _ -> do factionD <- getsState sfactionD itemVerbMU MsgItemCreation iid kit (MU.Text $ "appear" <+> ppContainer factionD c) c markDisplayNeeded lid CTrunk{} -> return () - else do - lid <- getsState $ lidFromC c - markDisplayNeeded lid UpdDestroyItem verbose iid _ kit c -> - if verbose then case c of + when verbose $ case c of CActor aid _ -> do b <- getsState $ getActorBody aid if bproj b then @@ -167,16 +163,13 @@ ownW <- ppContainerWownW partActorLeader False c let verb = MU.Text $ makePhrase $ "vanish from" : ownW itemVerbMUShort MsgItemRuination iid kit verb c - CEmbed lid _ -> markDisplayNeeded lid + CEmbed{} -> return () -- not visible so can't delay even if important CFloor lid _ -> do factionD <- getsState sfactionD itemVerbMUShort MsgItemRuination iid kit (MU.Text $ "break" <+> ppContainer factionD c) c markDisplayNeeded lid CTrunk{} -> return () - else do - lid <- getsState $ lidFromC c - markDisplayNeeded lid UpdSpotActor aid body -> createActorUI False aid body UpdLoseActor aid body -> destroyActorUI False aid body UpdSpotItem verbose iid kit c -> spotItemBag verbose c $ EM.singleton iid kit @@ -359,7 +352,7 @@ when (mtgt /= mleader) $ do fact <- getsState $ (EM.! fid) . sfactionD lidV <- viewedLevelUI - when (isAIFact fact) $ markDisplayNeeded lidV + when (gunderAI fact) $ markDisplayNeeded lidV -- This faction can't run with multiple actors, so this is not -- a leader change while running, but rather server changing -- their leader, which the player should be alerted to. @@ -385,12 +378,8 @@ UpdDiplFaction fid1 fid2 _ toDipl -> do name1 <- getsState $ gname . (EM.! fid1) . sfactionD name2 <- getsState $ gname . (EM.! fid2) . sfactionD - let showDipl Unknown = "unknown to each other" - showDipl Neutral = "in neutral diplomatic relations" - showDipl Alliance = "allied" - showDipl War = "at war" msgAdd MsgFactionIntel $ - name1 <+> "and" <+> name2 <+> "are now" <+> showDipl toDipl <> "." + name1 <+> "and" <+> name2 <+> "are now" <+> tshowDiplomacy toDipl <> "." UpdDoctrineFaction{} -> return () UpdAutoFaction fid b -> do side <- getsClient sside @@ -427,7 +416,7 @@ mactorAtPos <- getsState $ posToBig p lid mleader <- getsClient sleader when (unexpected || isJust mactorAtPos && mactorAtPos /= mleader) $ do - -- Player notices @fromTile can't be altered into @toTIle@, + -- Faction notices @fromTile@ can't be altered into @toTIle@, -- which is uncanny, so we produce a message. -- This happens when the player missed an earlier search of the tile -- performed by another faction. @@ -492,13 +481,13 @@ UpdRestart fid _ _ _ _ srandom -> do cops@COps{cocave, comode, corule} <- getsState scops oldSess <- getSession - svictories <- getsClient svictories snxtChal <- getsClient snxtChal + noConfirmsGame <- isNoConfirmsGame let uiOptions = sUIOptions oldSess f !acc _p !i _a = i : acc modes = zip [0..] $ ofoldlGroup' comode CAMPAIGN_SCENARIO f [] g :: (Int, ContentId ModeKind) -> Int - g (_, mode) = case EM.lookup mode svictories of + g (_, mode) = case EM.lookup mode (svictories oldSess) of Nothing -> 0 Just cm -> fromMaybe 0 (M.lookup snxtChal cm) (snxtScenario, _) = minimumBy (comparing g) modes @@ -508,10 +497,14 @@ { schanF = schanF oldSess , sccui = sccui oldSess , shistory = shistory oldSess + , svictories = svictories oldSess + , scampings = scampings oldSess + , srestarts = srestarts oldSess , smarkVision = smarkVision oldSess , smarkSmell = smarkSmell oldSess , snxtScenario - , scurTutorial = snxtTutorial oldSess -- quite random for screensavers + , scurTutorial = noConfirmsGame || snxtTutorial oldSess + -- make sure a newbie interrupting a screensaver has ample help , snxtTutorial = nxtGameTutorial , soverrideTut = soverrideTut oldSess , sstart = sstart oldSess @@ -523,11 +516,11 @@ } when (sstart oldSess == 0) resetSessionStart when (lengthHistory (shistory oldSess) == 0) $ do - let title = T.pack $ rtitle corule - msgAdd MsgBookKeeping $ "Welcome to" <+> title <> "!" -- Generate initial history. Only for UI clients. shistory <- defaultHistory modifySession $ \sess -> sess {shistory} + let title = T.pack $ rtitle corule + msgAdd MsgBookKeeping $ "Welcome to" <+> title <> "!" recordHistory -- to ensure EOL even at creation of history lid <- getArenaUI lvl <- getLevel lid @@ -540,9 +533,13 @@ _ -> False msgAdd MsgBookKeeping "-------------------------------------------------" recordHistory + msgAdd MsgPromptGeneric + "A grand story starts right here! (Press '?' for mode description and help.)" + if lengthHistory (shistory oldSess) > 1 + then fadeOutOrIn False + else pushReportFrame -- show anything ASAP msgAdd MsgActionWarning ("New game started in" <+> mname gameMode <+> "mode.") - msgAdd MsgPlotExposition $ mdesc gameMode let desc = cdesc $ okind cocave $ lkind lvl unless (T.null desc) $ do msgLnAdd MsgBackdropFocus "You take in your surroundings." @@ -562,34 +559,27 @@ msgLnAdd MsgBadMiscEvent blurb -- being here is a bad turn of events when (cwolf curChal && not loneMode) $ msgAdd MsgActionWarning "Being a lone wolf, you begin without companions." - when (lengthHistory (shistory oldSess) > 1) $ - fadeOutOrIn False - setFrontAutoYes $ isAIFact fact + setFrontAutoYes $ gunderAI fact -- Forget the furious keypresses when dying in the previous game. resetPressedKeys - -- Help newbies when actors obscured by text and no obvious key to press: - displayMore ColorFull "\nAre you up for the challenge?" - msgAdd MsgPromptGeneric - "A grand story starts right here! (Press '?' for context and help.)" UpdRestartServer{} -> return () UpdResume fid _ -> do COps{cocave} <- getsState scops resetSessionStart fact <- getsState $ (EM.! fid) . sfactionD - setFrontAutoYes $ isAIFact fact - unless (isAIFact fact) $ do + setFrontAutoYes $ gunderAI fact + unless (gunderAI fact) $ do lid <- getArenaUI lvl <- getLevel lid gameMode <- getGameMode - msgAdd MsgActionAlert $ "Continuing" <+> mname gameMode <> "." - msgAdd MsgPromptGeneric $ mdesc gameMode + msgAdd MsgPromptGeneric + "Welcome back! (Press '?' for mode description and help.)" + pushReportFrame -- show anything ASAP + msgAdd MsgActionAlert $ "Continuing" <+> mname gameMode <+> "mode." let desc = cdesc $ okind cocave $ lkind lvl unless (T.null desc) $ do msgLnAdd MsgPromptFocus "You remember your surroundings." msgAdd MsgPromptGeneric desc - displayMore ColorFull "\nAre you up for the challenge?" - msgAdd MsgPromptGeneric - "Prove yourself! (Press '?' for context and help.)" UpdResumeServer{} -> return () UpdKillExit{} -> do #ifdef USE_JSFILE @@ -634,19 +624,19 @@ UpdMuteMessages _ smuteMessages -> modifySession $ \sess -> sess {smuteMessages} -updateItemSlot :: MonadClientUI m => Container -> ItemId -> m () -updateItemSlot c iid = do +assignItemRole :: MonadClientUI m => Container -> ItemId -> m () +assignItemRole c iid = do arItem <- getsState $ aspectRecordFromIid iid - ItemSlots itemSlots <- getsSession sslots - let slore = IA.loreFromContainer arItem c - lSlots = itemSlots EM.! slore - case lookup iid $ map swap $ EM.assocs lSlots of - Nothing -> do - let l = assignSlot lSlots - f = EM.insert l iid - newSlots = ItemSlots $ EM.adjust f slore itemSlots - modifySession $ \sess -> sess {sslots = newSlots} - Just _l -> return () -- slot already assigned + let assignSingleRole lore = do + ItemRoles itemRoles <- getsSession sroles + let itemRole = itemRoles EM.! lore + unless (iid `ES.member` itemRole) $ do + let newRoles = ItemRoles $ EM.adjust (ES.insert iid) lore itemRoles + modifySession $ \sess -> sess {sroles = newRoles} + slore = IA.loreFromContainer arItem c + assignSingleRole slore + when (slore `elem` [SOrgan, STrunk, SCondition]) $ + assignSingleRole SBody data Threat = ThreatNone @@ -671,15 +661,15 @@ let baseColor = flavourToColor $ jflavour itemBase basePronoun | not (bproj body) && IK.isymbol itemKind == '@' - && fhasGender (gplayer fact) = "he" + && fhasGender (gkind fact) = "he" | otherwise = "it" nameFromNumber fn k = if k == 0 then makePhrase [MU.Ws $ MU.Text fn, "Captain"] else fn <+> tshow k heroNamePronoun k = if gcolor fact /= Color.BrWhite - then (nameFromNumber (fname $ gplayer fact) k, "he") - else fromMaybe (nameFromNumber (fname $ gplayer fact) k, "he") + then (nameFromNumber (fname $ gkind fact) k, "he") + else fromMaybe (nameFromNumber (fname $ gkind fact) k, "he") $ lookup k uHeroNames (n, bsymbol) = if | bproj body -> (0, if IA.checkFlag Ability.Blast arItem @@ -717,7 +707,7 @@ let c = if not (bproj body) && iid == btrunk body then CTrunk (bfid body) (blid body) (bpos body) else CActor aid store - updateItemSlot c iid + assignItemRole c iid recordItemLid iid c) ((btrunk body, CEqp) -- store will be overwritten, unless projectile : filter ((/= btrunk body) . fst) (getCarriedIidCStore body)) @@ -841,7 +831,7 @@ localTime <- getsState $ getLocalTime lid factionD <- getsState sfactionD -- Queried just once, so many copies of a new item can be reported. OK. - ItemSlots itemSlots <- getsSession sslots + ItemRoles itemRoles <- getsSession sroles sxhairOld <- getsSession sxhair let resetXhair = case c of CFloor _ p -> case sxhairOld of @@ -870,19 +860,19 @@ itemFull <- getsState $ itemToFull iid let arItem = aspectRecordFull itemFull slore = IA.loreFromContainer arItem c - case lookup iid $ map swap $ EM.assocs $ itemSlots EM.! slore of - Nothing -> do -- never seen or would have a slot - updateItemSlot c iid - case c of - CFloor{} -> do - let subjectShort = partItemWsShortest rwidth side factionD k - localTime itemFull kit - subjectLong = partItemWsLong rwidth side factionD k - localTime itemFull kit - return $ Just (k, subjectShort, subjectLong) - _ -> return Nothing - _ -> return Nothing -- this item or another with the same @iid@ - -- seen already (has a slot assigned); old news + if iid `ES.member` (itemRoles EM.! slore) + then return Nothing -- this item or another with the same @iid@ + -- seen already (has a role assigned); old news + else do -- never seen or would have a role + assignItemRole c iid + case c of + CFloor{} -> do + let subjectShort = partItemWsShortest rwidth side factionD k + localTime itemFull kit + subjectLong = partItemWsLong rwidth side factionD k + localTime itemFull kit + return $ Just (k, subjectShort, subjectLong) + _ -> return Nothing -- @SortOn@ less efficient here, because function cheap. sortItems = sortOn (getKind . fst) sortedAssocs = sortItems $ EM.assocs bag @@ -910,9 +900,8 @@ let verb = MU.Text $ verbCStore store b <- getsState $ getActorBody aid fact <- getsState $ (EM.! bfid b) . sfactionD - let underAI = isAIFact fact mleader <- getsClient sleader - if Just aid == mleader && not underAI then + if Just aid == mleader && not (gunderAI fact) then manyItemsAidVerbMU MsgItemMovement aid verb sortedAssocs Right else when (not (bproj b) && bhp b > 0) $ -- don't announce death drops manyItemsAidVerbMU MsgItemMovement aid verb sortedAssocs (Left . Just) @@ -977,19 +966,16 @@ let verb = MU.Text $ verbCStore cstore2 b <- getsState $ getActorBody aid fact <- getsState $ (EM.! bfid b) . sfactionD - let underAI = isAIFact fact mleader <- getsClient sleader - ItemSlots itemSlots <- getsSession sslots - case lookup iid $ map swap $ EM.assocs $ itemSlots EM.! SItem of - Just _l -> - -- So far organs can't be put into stash, so no need to call - -- @updateItemSlot@ to add or reassign lore category. - if cstore1 == CGround && Just aid == mleader && not underAI then - itemAidVerbMU MsgActionMajor aid verb iid (Right k) - else when (not (bproj b) && bhp b > 0) $ -- don't announce death drops - itemAidVerbMU MsgActionMajor aid verb iid (Left k) - Nothing -> error $ - "" `showFailure` (iid, k, aid, cstore1, cstore2) + ItemRoles itemRoles <- getsSession sroles + if iid `ES.member` (itemRoles EM.! SItem) then + -- So far organs can't be put into stash, so no need to call + -- @assignItemRole@ to add or reassign lore category. + if cstore1 == CGround && Just aid == mleader && not (gunderAI fact) then + itemAidVerbMU MsgActionMajor aid verb iid (Right k) + else when (not (bproj b) && bhp b > 0) $ -- don't announce death drops + itemAidVerbMU MsgActionMajor aid verb iid (Left k) + else error $ "" `showFailure` (iid, k, aid, cstore1, cstore2) -- The item may be used up already and so not present in the container, -- e.g., if the item destroyed itself. This is OK. Message is still needed. diff --git a/engine-src/Game/LambdaHack/Common/Actor.hs b/engine-src/Game/LambdaHack/Common/Actor.hs --- a/engine-src/Game/LambdaHack/Common/Actor.hs +++ b/engine-src/Game/LambdaHack/Common/Actor.hs @@ -274,19 +274,20 @@ monsterGenChance (Dice.AbsDepth ldepth) (Dice.AbsDepth totalDepth) lvlSpawned actorCoeff = assert (totalDepth > 0 && ldepth > 0) $ -- ensured by content validation - -- Heroes have to endure a level-depth-proportional wave of immediate - -- spawners for each level. Then the monsters start + -- Heroes have to endure a level-depth-proportional wave of almost + -- immediate spawners for each level. Then the monsters start -- to trickle more and more slowly, at the speed dictated - -- by @actorCoeff@ specified in cave kind. Finally, spawning flattens out. + -- by @actorCoeff@ specified in cave kind. Finally, spawning flattens out + -- to ensure that camping is never safe. let scaledDepth = ldepth * 10 `div` totalDepth - -- Never spawn too rarely so that camping is never safe. - maxCoeff = 100 * 30 -- spawning on a level with benign @actorCoeff@ - -- flattens out after 30 spawns - coeff = max 1 $ min maxCoeff $ actorCoeff * (lvlSpawned - scaledDepth - 2) + maxCoeff = 100 * 30 + -- spawning on a level with benign @actorCoeff@ flattens out + -- after 30+depth spawns and on a level with fast spawning + -- flattens out later, but ending at the same level + coeff = max 1 $ min maxCoeff + $ actorCoeff * (lvlSpawned - scaledDepth - 2) million = 1000000 - in 2 * million `div` coeff - -- @2@ added to compensate for monsters generated asleep, - -- without decreasing each @actorCoeff@ in content + in 10 * million `div` coeff -- | How long until an actor's smell vanishes from a tile. smellTimeout :: Delta Time diff --git a/engine-src/Game/LambdaHack/Common/ActorState.hs b/engine-src/Game/LambdaHack/Common/ActorState.hs --- a/engine-src/Game/LambdaHack/Common/ActorState.hs +++ b/engine-src/Game/LambdaHack/Common/ActorState.hs @@ -5,8 +5,7 @@ , fidActorRegularIds, foeRegularAssocs, foeRegularList , friendRegularAssocs, friendRegularList, bagAssocs, bagAssocsK , posToBig, posToBigAssoc, posToProjs, posToProjAssocs - , posToAids, posToAidAssocs, calculateTotal, itemPrice, findIid - , combinedGround, combinedOrgan, combinedEqp, combinedItems + , posToAids, posToAidAssocs, calculateTotal, itemPrice, findIid, combinedItems , getActorBody, getActorMaxSkills, actorCurrentSkills, canTraverse , getCarriedAssocsAndTrunk, getContainerBag , getFloorBag, getEmbedBag, getBodyStoreBag, getFactionStashBag @@ -41,7 +40,7 @@ import Game.LambdaHack.Common.Types import Game.LambdaHack.Common.Vector import qualified Game.LambdaHack.Content.ItemKind as IK -import Game.LambdaHack.Content.ModeKind +import Game.LambdaHack.Content.FactionKind import qualified Game.LambdaHack.Content.TileKind as TK import qualified Game.LambdaHack.Definition.Ability as Ability import Game.LambdaHack.Definition.Defs @@ -152,24 +151,7 @@ items = concatMap itemsOfActor actors in map snd $ filter ((== iid) . fst) items -combinedGround :: FactionId -> State -> ItemBag -combinedGround fid s = - let bs = inline fidActorNotProjGlobalAssocs fid s - in EM.unionsWith mergeItemQuant - $ map (\(_, b) -> getFloorBag (blid b) (bpos b) s) bs - -- Trunk not considered (if stolen). -combinedOrgan :: FactionId -> State -> ItemBag -combinedOrgan fid s = - let bs = inline fidActorNotProjGlobalAssocs fid s - in EM.unionsWith mergeItemQuant $ map (borgan . snd) bs - -combinedEqp :: FactionId -> State -> ItemBag -combinedEqp fid s = - let bs = inline fidActorNotProjGlobalAssocs fid s - in EM.unionsWith mergeItemQuant $ map (beqp . snd) bs - --- Trunk not considered (if stolen). combinedItems :: FactionId -> State -> ItemBag combinedItems fid s = let stashBag = getFactionStashBag fid s @@ -194,11 +176,12 @@ actorCurrentSkills mleader aid s = let body = getActorBody aid s actorMaxSk = getActorMaxSkills aid s - player = gplayer . (EM.! bfid body) . sfactionD $ s - skillsFromDoctrine = Ability.doctrineSkills $ fdoctrine player + fact = (EM.! bfid body) . sfactionD $ s + skillsFromDoctrine = Ability.doctrineSkills $ gdoctrine fact factionSkills | Just aid == mleader = Ability.zeroSkills - | otherwise = fskillsOther player `Ability.addSkills` skillsFromDoctrine + | otherwise = fskillsOther (gkind fact) + `Ability.addSkills` skillsFromDoctrine in actorMaxSk `Ability.addSkills` factionSkills -- Check that the actor can move, also between levels and through doors. diff --git a/engine-src/Game/LambdaHack/Common/Faction.hs b/engine-src/Game/LambdaHack/Common/Faction.hs --- a/engine-src/Game/LambdaHack/Common/Faction.hs +++ b/engine-src/Game/LambdaHack/Common/Faction.hs @@ -1,12 +1,12 @@ -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric, TupleSections #-} -- | Factions taking part in the game, e.g., a hero faction, a monster faction -- and an animal faction. module Game.LambdaHack.Common.Faction ( FactionDict, Faction(..), Diplomacy(..) , Status(..), Challenge(..) - , tshowChallenge, gleader, isHorrorFact, noRunWithMulti, isAIFact - , autoDungeonLevel, automatePlayer, isFoe, isFriend - , difficultyBound, difficultyDefault, difficultyCoeff, difficultyInverse + , tshowDiplomacy, tshowChallenge, gleader, isHorrorFact, noRunWithMulti + , bannedPointmanSwitchBetweenLevels, isFoe, isFriend + , difficultyBound, difficultyDefault, difficultyCoeff , defaultChallenge, possibleActorFactions, ppContainer #ifdef EXPOSE_INTERNAL -- * Internal operations @@ -20,15 +20,16 @@ import Data.Binary import qualified Data.EnumMap.Strict as EM -import qualified Data.IntMap.Strict as IM import qualified Data.Text as T import GHC.Generics (Generic) import Game.LambdaHack.Common.Point import Game.LambdaHack.Common.Types +import Game.LambdaHack.Content.FactionKind import Game.LambdaHack.Content.ItemKind (ItemKind) import qualified Game.LambdaHack.Content.ItemKind as IK -import Game.LambdaHack.Content.ModeKind +import Game.LambdaHack.Content.ModeKind (ModeKind) +import Game.LambdaHack.Core.Frequency import qualified Game.LambdaHack.Definition.Ability as Ability import qualified Game.LambdaHack.Definition.Color as Color import Game.LambdaHack.Definition.Defs @@ -38,12 +39,19 @@ -- | The faction datatype. data Faction = Faction - { gname :: Text -- ^ individual name - , gcolor :: Color.Color -- ^ color of actors or their frames - , gplayer :: Player -- ^ the player spec for this faction - , gteamCont :: Maybe TeamContinuity - -- ^ identity of this faction across games - -- and scenarios + { gkind :: FactionKind + -- ^ the player spec for this faction, do not update! + -- it is morally read-only, but not represented + -- as @ContentId FactionKind@, because it's very small + -- and it's looked up often enough in the code and during runtime; + -- a side-effect is that if content changes mid-game, this stays; + -- if we ever have thousands of factions in a single game, + -- e.g., one for each separately spawned herd of animals, change this + , gname :: Text -- ^ individual name + , gcolor :: Color.Color -- ^ color of numbered actors + , gdoctrine :: Ability.Doctrine + -- ^ non-pointmen behave according to this + , gunderAI :: Bool -- ^ whether the faction is under AI control , ginitial :: [(Int, Int, GroupName ItemKind)] -- ^ initial actors , gdipl :: Dipl -- ^ diplomatic standing , gquit :: Maybe Status -- ^ cause of game end/exit @@ -53,9 +61,6 @@ -- ^ level and position of faction's -- shared inventory stash , gvictims :: EM.EnumMap (ContentId ItemKind) Int -- ^ members killed - , gvictimsD :: EM.EnumMap (ContentId ModeKind) - (IM.IntMap (EM.EnumMap (ContentId ItemKind) Int)) - -- ^ members killed in the past, by game mode and difficulty level } deriving (Show, Eq, Generic) @@ -67,7 +72,7 @@ | Neutral | Alliance | War - deriving (Show, Eq, Enum, Generic) + deriving (Show, Eq, Ord, Enum, Generic) instance Binary Diplomacy @@ -97,6 +102,12 @@ instance Binary Challenge +tshowDiplomacy :: Diplomacy -> Text +tshowDiplomacy Unknown = "unknown to each other" +tshowDiplomacy Neutral = "in neutral diplomatic relations" +tshowDiplomacy Alliance = "allied" +tshowDiplomacy War = "at war" + tshowChallenge :: Challenge -> Text tshowChallenge Challenge{..} = "(" @@ -119,7 +130,7 @@ -- In every game, either all factions for which summoning items exist -- should be present or a horror player should be added to host them. isHorrorFact :: Faction -> Bool -isHorrorFact fact = IK.HORROR `elem` fgroups (gplayer fact) +isHorrorFact fact = fromMaybe 0 (lookup IK.HORROR $ fgroups $ gkind fact) > 0 -- A faction where other actors move at once or where some of leader change -- is automatic can't run with multiple actors at once. That would be @@ -131,22 +142,13 @@ -- by the UI user. noRunWithMulti :: Faction -> Bool noRunWithMulti fact = - let skillsOther = fskillsOther $ gplayer fact + let skillsOther = fskillsOther $ gkind fact in Ability.getSk Ability.SkMove skillsOther >= 0 - || case fleaderMode (gplayer fact) of - Nothing -> True - Just AutoLeader{..} -> autoDungeon || autoLevel - -isAIFact :: Faction -> Bool -isAIFact fact = funderAI (gplayer fact) - -autoDungeonLevel :: Faction -> (Bool, Bool) -autoDungeonLevel fact = case fleaderMode (gplayer fact) of - Nothing -> (False, False) - Just AutoLeader{..} -> (autoDungeon, autoLevel) + || bannedPointmanSwitchBetweenLevels fact + || not (fhasPointman (gkind fact)) -automatePlayer :: Bool -> Player -> Player -automatePlayer funderAI pl = pl {funderAI} +bannedPointmanSwitchBetweenLevels :: Faction -> Bool +bannedPointmanSwitchBetweenLevels = fspawnsFast . gkind -- | Check if factions are at war. Assumes symmetry. isFoe :: FactionId -> Faction -> FactionId -> Bool @@ -173,10 +175,6 @@ difficultyCoeff :: Int -> Int difficultyCoeff n = difficultyDefault - n --- The function is its own inverse. -difficultyInverse :: Int -> Int -difficultyInverse n = difficultyBound + 1 - n - defaultChallenge :: Challenge defaultChallenge = Challenge { cdiff = difficultyDefault , cfish = False @@ -184,14 +182,25 @@ , cwolf = False , ckeeper = False } -possibleActorFactions :: ItemKind -> FactionDict -> [(FactionId, Faction)] -possibleActorFactions itemKind factionD = - let freqNames = map fst $ IK.ifreq itemKind - f (_, fact) = any (`elem` fgroups (gplayer fact)) freqNames - fidFactsRaw = filter f $ EM.assocs factionD - in if null fidFactsRaw - then filter (isHorrorFact . snd) $ EM.assocs factionD -- fall back - else fidFactsRaw +possibleActorFactions :: [GroupName ItemKind] -> ItemKind -> FactionDict + -> Frequency (FactionId, Faction) +possibleActorFactions itemGroups itemKind factionD = + let candidatesFromGroups grps = + let h (fid, fact) = + let f grp (grp2, n) = [(n, (fid, fact)) | grp == grp2] + g grp = concatMap (f grp) (fgroups (gkind fact)) + in concatMap g grps + in concatMap h $ EM.assocs factionD + allCandidates = + [ candidatesFromGroups itemGroups -- when origin known/matters + , candidatesFromGroups $ map fst $ IK.ifreq itemKind -- otherwise + , map (1,) $ filter (isHorrorFact . snd) + $ EM.assocs factionD -- fall back + , map (1,) $ EM.assocs factionD -- desperate fall back + ] + in case filter (not . null) allCandidates of + [] -> error "possibleActorFactions: no faction found for an actor" + candidates : _ -> toFreq "possibleActorFactions" candidates ppContainer :: FactionDict -> Container -> Text ppContainer factionD (CFloor lid p) = diff --git a/engine-src/Game/LambdaHack/Common/HSFile.hs b/engine-src/Game/LambdaHack/Common/HSFile.hs --- a/engine-src/Game/LambdaHack/Common/HSFile.hs +++ b/engine-src/Game/LambdaHack/Common/HSFile.hs @@ -16,11 +16,21 @@ import qualified Control.Exception as Ex import Data.Binary import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text.IO as T import Data.Version import System.Directory import System.FilePath -import System.IO (IOMode (..), hClose, openBinaryFile, readFile, - withBinaryFile, writeFile) +import System.IO + ( IOMode (..) + , hClose + , hSetEncoding + , localeEncoding + , openBinaryFile + , readFile + , utf8 + , withBinaryFile + , withFile + ) -- | Serialize and save data. -- Note that LBS.writeFile opens the file in binary mode. @@ -68,11 +78,18 @@ (createDirectory dir) -- | Try to write a file, given content, if the file not already there. --- We catch exceptions in case many clients try to do the same thing --- at the same time. -tryWriteFile :: FilePath -> String -> IO () +-- We catch exceptions in case many clients and/or the server try to do +-- the same thing at the same time. Using `Text.IO` to avoid UTF conflicts +-- with OS or filesystem. +tryWriteFile :: FilePath -> Text -> IO () tryWriteFile path content = do fileExists <- doesFileExist path - unless fileExists $ - Ex.handle (\(_ :: Ex.IOException) -> return ()) - (writeFile path content) + unless fileExists $ do + -- With some luck, locale was already corrected in Main.hs, but just + -- in case, we make sure not to save UTF files in too primitve encodings. + let enc = localeEncoding + Ex.handle (\(ex :: Ex.IOException) -> print $ show ex) $ + withFile path WriteMode $ \h -> do + when (show enc `elem` ["ASCII", "ISO-8859-1", "ISO-8859-2"]) $ + hSetEncoding h utf8 + T.hPutStr h content diff --git a/engine-src/Game/LambdaHack/Common/HighScore.hs b/engine-src/Game/LambdaHack/Common/HighScore.hs --- a/engine-src/Game/LambdaHack/Common/HighScore.hs +++ b/engine-src/Game/LambdaHack/Common/HighScore.hs @@ -27,6 +27,7 @@ import Game.LambdaHack.Common.Time import Game.LambdaHack.Content.ItemKind (ItemKind) import Game.LambdaHack.Content.ModeKind +import Game.LambdaHack.Content.FactionKind import Game.LambdaHack.Definition.Defs -- | A single score record. Records are ordered in the highscore table, @@ -37,7 +38,7 @@ , date :: POSIXTime -- ^ date of the last game interruption , status :: Status -- ^ reason of the game interruption , challenge :: Challenge -- ^ challenge setup of the game - , gplayerName :: Text -- ^ name of the faction's gplayer + , gkindName :: Text -- ^ name of the faction's gkind , ourVictims :: EM.EnumMap (ContentId ItemKind) Int -- ^ allies lost , theirVictims :: EM.EnumMap (ContentId ItemKind) Int -- ^ foes killed } @@ -75,13 +76,13 @@ -> Status -- ^ reason of the game interruption -> POSIXTime -- ^ current date -> Challenge -- ^ challenge setup - -> Text -- ^ name of the faction's gplayer + -> Text -- ^ name of the faction's gkind -> EM.EnumMap (ContentId ItemKind) Int -- ^ allies lost -> EM.EnumMap (ContentId ItemKind) Int -- ^ foes killed -> HiCondPoly -> (Bool, (ScoreTable, Int)) register table total dungeonTotal time status@Status{stOutcome} - date challenge gplayerName ourVictims theirVictims hiCondPoly = + date challenge gkindName ourVictims theirVictims hiCondPoly = let turnsSpent = intToDouble $ timeFitUp time timeTurn hiInValue (hi, c) = assert (total <= dungeonTotal) $ case hi of HiConst -> c @@ -107,7 +108,8 @@ * 1.5 ^^ (- (difficultyCoeff (cdiff challenge))) negTime = absoluteTimeNegate time score = ScoreRecord{..} - in (points > 0, insertPos score table) + in (points > 0 || turnsSpent > 100, insertPos score table) + -- even if stash looted and all gold lost, count highscore if long game -- | Show a single high score, from the given ranking in the high score table. showScore :: TimeZone -> Int -> ScoreRecord -> [Text] @@ -129,7 +131,7 @@ chalText | challenge score == defaultChallenge = "" | otherwise = tshowChallenge (challenge score) tturns = makePhrase [MU.CarWs turns "turn"] - in [ tpos <> "." <+> tscore <+> gplayerName score + in [ tpos <> "." <+> tscore <+> gkindName score <+> died <> "," <+> victims <> "," , " " <> "after" <+> tturns <+> chalText <+> "on" <+> curDate <> "." @@ -170,12 +172,12 @@ ("your valiant exploits", MU.PlEtc, "") Conquer -> ("your ruthless victory", MU.Sg3rd, - if pos <= height + if pos <= height && length (unTable table) > 3 then "among the best" -- "greatest heroes" doesn't fit else "(bonus included)") Escape -> ("your dashing coup", MU.Sg3rd, - if pos <= height + if pos <= height && length (unTable table) > 3 then "among the best" else "(bonus included)") Restart -> diff --git a/engine-src/Game/LambdaHack/Common/Item.hs b/engine-src/Game/LambdaHack/Common/Item.hs --- a/engine-src/Game/LambdaHack/Common/Item.hs +++ b/engine-src/Game/LambdaHack/Common/Item.hs @@ -10,7 +10,8 @@ , deltaOfItemTimer, charging, ncharges, hasCharge , strongestMelee, unknownMeleeBonus, unknownSpeedBonus , conditionMeleeBonus, conditionSpeedBonus, armorHurtCalculation - , mergeItemQuant, listToolsToConsume, subtractIidfromGrps + , mergeItemQuant, listToolsToConsume, subtractIidfromGrps, sortIids + , TileAction (..), parseTileAction #ifdef EXPOSE_INTERNAL -- * Internal operations , valueAtEqpSlot, unknownAspect, countIidConsumed @@ -33,6 +34,7 @@ import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Types import qualified Game.LambdaHack.Content.ItemKind as IK +import qualified Game.LambdaHack.Content.TileKind as TK import qualified Game.LambdaHack.Core.Dice as Dice import Game.LambdaHack.Definition.Ability (EqpSlot (..)) import qualified Game.LambdaHack.Definition.Ability as Ability @@ -453,3 +455,52 @@ removedBags bagsToLose1 , replicate nToApply (store, (iid, itemFull)) ++ iidsToApply1 , grps2 ) + +sortIids :: (ItemId -> ItemFull) + -> [(ItemId, ItemQuant)] + -> [(ItemId, ItemQuant)] +sortIids itemToF = + -- If appearance and aspects the same, keep the order from before sort. + let kindAndAppearance (iid, _) = + let ItemFull{itemBase=Item{..}, ..} = itemToF iid + in ( not itemSuspect, itemKindId, itemDisco + , IK.isymbol itemKind, IK.iname itemKind + , jflavour, jfid ) + in sortOn kindAndAppearance + +data TileAction = + EmbedAction (ItemId, ItemQuant) + | ToAction (GroupName TK.TileKind) + | WithAction [(Int, GroupName IK.ItemKind)] (GroupName TK.TileKind) + deriving Show + +parseTileAction :: Bool -> Bool -> [(IK.ItemKind, (ItemId, ItemQuant))] + -> TK.Feature + -> Maybe TileAction +parseTileAction bproj underFeet embedKindList feat = case feat of + TK.Embed igroup -> + -- Greater or equal 0 to also cover template UNKNOWN items + -- not yet identified by the client. + let f (itemKind, _) = + fromMaybe (-1) (lookup igroup $ IK.ifreq itemKind) >= 0 + in case find f embedKindList of + Nothing -> Nothing + Just (_, iidkit) -> Just $ EmbedAction iidkit + TK.OpenTo tgroup | not (underFeet || bproj) -> Just $ ToAction tgroup + TK.CloseTo tgroup | not (underFeet || bproj) -> Just $ ToAction tgroup + TK.ChangeTo tgroup | not bproj -> Just $ ToAction tgroup + TK.OpenWith proj grps tgroup | not underFeet -> + if proj == TK.ProjNo && bproj + then Nothing + else Just $ WithAction grps tgroup + TK.CloseWith proj grps tgroup | not underFeet -> + -- Not when standing on tile, not to autoclose doors under actor + -- or close via dropping an item inside. + if proj == TK.ProjNo && bproj + then Nothing + else Just $ WithAction grps tgroup + TK.ChangeWith proj grps tgroup -> + if proj == TK.ProjNo && bproj + then Nothing + else Just $ WithAction grps tgroup + _ -> Nothing diff --git a/engine-src/Game/LambdaHack/Common/ItemAspect.hs b/engine-src/Game/LambdaHack/Common/ItemAspect.hs --- a/engine-src/Game/LambdaHack/Common/ItemAspect.hs +++ b/engine-src/Game/LambdaHack/Common/ItemAspect.hs @@ -5,7 +5,7 @@ , emptyAspectRecord, addMeanAspect, castAspect, aspectsRandom , aspectRecordToList, rollAspectRecord, getSkill, checkFlag, meanAspect , onlyMinorEffects, itemTrajectory, totalRange, isHumanTrinket - , goesIntoEqp, loreFromMode, loreFromContainer + , goesIntoEqp, loreFromContainer #ifdef EXPOSE_INTERNAL -- * Internal operations , ceilingMeanDice @@ -137,7 +137,7 @@ | (sk, n) <- Ability.skillsToList aSkills ] ++ [IK.SetFlag feat | feat <- ES.elems $ Ability.flags aFlags] ++ [IK.ELabel aELabel | not $ T.null aELabel] - ++ [IK.ToThrow aToThrow | not $ aToThrow == IK.ThrowMod 100 100 1] + ++ [IK.ToThrow aToThrow | aToThrow /= IK.ThrowMod 100 100 1] ++ maybe [] (\ha -> [IK.PresentAs ha]) aPresentAs ++ maybe [] (\slot -> [IK.EqpSlot slot]) aEqpSlot @@ -168,7 +168,7 @@ onlyMinorEffects :: AspectRecord -> IK.ItemKind -> Bool onlyMinorEffects ar kind = checkFlag Ability.MinorEffects ar -- override - || not (any (not . IK.alwaysDudEffect) $ IK.ieffects kind) + || all IK.alwaysDudEffect (IK.ieffects kind) -- exhibits no major effects itemTrajectory :: AspectRecord -> IK.ItemKind -> [Point] @@ -188,17 +188,6 @@ goesIntoEqp :: AspectRecord -> Bool goesIntoEqp ar = checkFlag Ability.Equipable ar || checkFlag Ability.Meleeable ar - -loreFromMode :: ItemDialogMode -> SLore -loreFromMode c = case c of - MStore COrgan -> SOrgan - MStore _ -> SItem - MOrgans -> undefined -- slots from many lore kinds - MOwned -> SItem - MSkills -> undefined -- artificial slots - MLore slore -> slore - MPlaces -> undefined -- artificial slots - MModes -> undefined -- artificial slots loreFromContainer :: AspectRecord -> Container -> SLore loreFromContainer arItem c = case c of diff --git a/engine-src/Game/LambdaHack/Common/JSFile.hs b/engine-src/Game/LambdaHack/Common/JSFile.hs --- a/engine-src/Game/LambdaHack/Common/JSFile.hs +++ b/engine-src/Game/LambdaHack/Common/JSFile.hs @@ -16,6 +16,7 @@ import Data.Binary import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.Text as T import Data.Text.Encoding (decodeLatin1) import Data.Version @@ -84,7 +85,7 @@ mitem <- getItem storage path let fileExists = isJust (mitem :: Maybe String) unless fileExists $ - setItem storage path content + setItem storage path $ T.unpack content readFile :: FilePath -> IO String readFile path = flip runDOM undefined $ do diff --git a/engine-src/Game/LambdaHack/Common/Kind.hs b/engine-src/Game/LambdaHack/Common/Kind.hs --- a/engine-src/Game/LambdaHack/Common/Kind.hs +++ b/engine-src/Game/LambdaHack/Common/Kind.hs @@ -1,14 +1,20 @@ +{-# LANGUAGE TupleSections #-} -- | General content types and operations. module Game.LambdaHack.Common.Kind - ( ContentData, COps(..) + ( ContentData -- re-exported without some operations + , COps(..) , emptyCOps , ItemSpeedup - , emptyItemSpeedup, getKindMean, speedupItem - , TileSpeedup(..), Tab(..) - , emptyTileSpeedup, emptyTab + , getKindMean, speedupItem , okind, omemberGroup, oisSingletonGroup, ouniqGroup, opick , ofoldlWithKey', ofoldlGroup', omapVector, oimapVector , olength, linearInterpolation +#ifdef EXPOSE_INTERNAL + , emptyMultiGroupItem, emptyUnknownTile + , emptyUIFactionGroupName, emptyMultiGroupMode +#endif + -- * Operations both internal and used in unit tests + , emptyUIFaction ) where import Prelude () @@ -16,30 +22,44 @@ import Game.LambdaHack.Core.Prelude import qualified Data.Vector as V -import qualified Data.Vector.Unboxed as U -import Data.Word (Word8) import qualified Game.LambdaHack.Common.ItemAspect as IA -import Game.LambdaHack.Content.CaveKind -import Game.LambdaHack.Content.ItemKind (ItemKind) +import qualified Game.LambdaHack.Common.Tile as Tile +import qualified Game.LambdaHack.Content.CaveKind as CK +import qualified Game.LambdaHack.Content.FactionKind as FK import qualified Game.LambdaHack.Content.ItemKind as IK -import Game.LambdaHack.Content.ModeKind -import Game.LambdaHack.Content.PlaceKind -import Game.LambdaHack.Content.RuleKind -import Game.LambdaHack.Content.TileKind (TileKind) +import qualified Game.LambdaHack.Content.ModeKind as MK +import qualified Game.LambdaHack.Content.PlaceKind as PK +import qualified Game.LambdaHack.Content.RuleKind as RK +import qualified Game.LambdaHack.Content.TileKind as TK +import qualified Game.LambdaHack.Definition.Ability as Ability +import qualified Game.LambdaHack.Definition.Color as Color import Game.LambdaHack.Definition.ContentData import Game.LambdaHack.Definition.Defs +import Game.LambdaHack.Definition.DefsInternal + (GroupName (GroupName), toContentSymbol) +import Game.LambdaHack.Definition.Flavour (dummyFlavour) -- | Operations for all content types, gathered together. +-- +-- Warning: this type is not abstract, but its values should not be +-- created ad hoc, even for unit tests, but should be constructed +-- with @makeData@ for each particular content kind, which includes validation, +-- and with @speedupItem@, etc., to ensure internal consistency. +-- +-- The @emptyCOps@ is one such valid by construction value of this type, +-- except for the @cocave@ field. It's suitable for bootstrapping +-- and for tests not involving dungeon generation from cave templates. data COps = COps - { cocave :: ContentData CaveKind -- server only - , coitem :: ContentData ItemKind - , comode :: ContentData ModeKind -- server only - , coplace :: ContentData PlaceKind -- server only, so far - , corule :: RuleContent - , cotile :: ContentData TileKind + { cocave :: ContentData CK.CaveKind -- server only + , cofact :: ContentData FK.FactionKind + , coitem :: ContentData IK.ItemKind + , comode :: ContentData MK.ModeKind -- server only + , coplace :: ContentData PK.PlaceKind -- server only, so far + , corule :: RK.RuleContent + , cotile :: ContentData TK.TileKind , coItemSpeedup :: ItemSpeedup - , coTileSpeedup :: TileSpeedup + , coTileSpeedup :: Tile.TileSpeedup } instance Show COps where @@ -48,24 +68,98 @@ instance Eq COps where (==) _ _ = True -emptyCOps :: COps -emptyCOps = COps - { cocave = emptyContentData - , coitem = emptyContentData - , comode = emptyContentData - , coplace = emptyContentData - , corule = emptyRuleContent - , cotile = emptyContentData - , coItemSpeedup = emptyItemSpeedup - , coTileSpeedup = emptyTileSpeedup +emptyMultiGroupItem :: IK.ItemKind +emptyMultiGroupItem = IK.ItemKind + { isymbol = toContentSymbol 'E' + , iname = "emptyCOps item" + , ifreq = map (, 1) $ IK.mandatoryGroups ++ IK.mandatoryGroupsSingleton + , iflavour = [dummyFlavour] + , icount = 0 + , irarity = [] + , iverbHit = "" + , iweight = 0 + , idamage = 0 + , iaspects = [] + , ieffects = [] + , idesc = "" + , ikit = [] } +emptyUnknownTile :: TK.TileKind +emptyUnknownTile = TK.TileKind -- needs to have index 0 and alter 1 + { tsymbol = 'E' + , tname = "unknown space" -- name checked in validation + , tfreq = map (, 1) $ TK.mandatoryGroups ++ TK.mandatoryGroupsSingleton + , tcolor = Color.BrMagenta + , tcolor2 = Color.BrMagenta + , talter = 1 + , tfeature = [] + } + +emptyUIFactionGroupName :: GroupName FK.FactionKind +emptyUIFactionGroupName = GroupName "emptyUIFaction" + +emptyUIFaction :: FK.FactionKind +emptyUIFaction = FK.FactionKind + { fname = "emptyUIFaction" + , ffreq = [(emptyUIFactionGroupName, 1)] + , fteam = FK.TeamContinuity 999 -- must be > 0 + , fgroups = [] + , fskillsOther = Ability.zeroSkills + , fcanEscape = False + , fneverEmpty = True -- to keep the dungeon alive + , fhiCondPoly = [] + , fhasGender = False + , finitDoctrine = Ability.TBlock + , fspawnsFast = False + , fhasPointman = False + , fhasUI = True -- to own the UI frontend + , finitUnderAI = False + , fenemyTeams = [] + , falliedTeams = [] + } + +emptyMultiGroupMode :: MK.ModeKind +emptyMultiGroupMode = MK.ModeKind + { mname = "emptyMultiGroupMode" + , mfreq = map (, 1) MK.mandatoryGroups + , mtutorial = False + , mattract = False + , mroster = [(emptyUIFactionGroupName, [])] + , mcaves = [] + , mendMsg = [] + , mrules = "" + , mdesc = "" + , mreason = "" + , mhint = "" + } + +-- | This is as empty, as possible, but still valid content, except for +-- @cocave@ which is empty and not valid (making it valid would require +-- bloating most other contents). +emptyCOps :: COps +emptyCOps = + let corule = RK.emptyRuleContent + coitem = IK.makeData (RK.ritemSymbols corule) [emptyMultiGroupItem] [] [] + cotile = TK.makeData [emptyUnknownTile] [] [] + cofact = FK.makeData [emptyUIFaction] [emptyUIFactionGroupName] [] + in COps + { cocave = emptyContentData -- not valid! beware when testing! + -- to make valid cave content, we'd need to define a single cave kind, + -- which involves creating and validating tile and place kinds, etc. + , cofact + , coitem + , comode = MK.makeData cofact [emptyMultiGroupMode] [] [] + , coplace = PK.makeData cotile [] [] [] + , corule + , cotile + , coItemSpeedup = speedupItem coitem + , coTileSpeedup = Tile.speedupTile False cotile + } + -- | Map from an item kind identifier to the mean aspect value for the kind. newtype ItemSpeedup = ItemSpeedup (V.Vector IA.KindMean) -emptyItemSpeedup :: ItemSpeedup -emptyItemSpeedup = ItemSpeedup V.empty - getKindMean :: ContentId IK.ItemKind -> ItemSpeedup -> IA.KindMean getKindMean kindId (ItemSpeedup is) = is V.! contentIdIndex kindId @@ -76,48 +170,3 @@ kmConst = not $ IA.aspectsRandom (IK.iaspects kind) in IA.KindMean{..} in ItemSpeedup $ omapVector coitem f - --- | A lot of tabulated maps from tile kind identifier to a property --- of the tile kind. -data TileSpeedup = TileSpeedup - { isClearTab :: Tab Bool - , isLitTab :: Tab Bool - , isHideoutTab :: Tab Bool - , isWalkableTab :: Tab Bool - , isDoorTab :: Tab Bool - , isOpenableTab :: Tab Bool - , isClosableTab :: Tab Bool - , isChangableTab :: Tab Bool - , isModifiableWithTab :: Tab Bool - , isSuspectTab :: Tab Bool - , isHideAsTab :: Tab Bool - , consideredByAITab :: Tab Bool - , isVeryOftenItemTab :: Tab Bool - , isCommonItemTab :: Tab Bool - , isOftenActorTab :: Tab Bool - , isNoItemTab :: Tab Bool - , isNoActorTab :: Tab Bool - , isEasyOpenTab :: Tab Bool - , isEmbedTab :: Tab Bool - , isAquaticTab :: Tab Bool - , alterMinSkillTab :: Tab Word8 - , alterMinWalkTab :: Tab Word8 - } - --- Vectors of booleans can be slower than arrays, because they are not packed, --- but with growing cache sizes they may as well turn out faster at some point. --- The advantage of vectors are exposed internals, in particular unsafe --- indexing. Also, in JS, bool arrays are obviously not packed. --- An option: https://github.com/Bodigrim/bitvec --- | A map morally indexed by @ContentId TileKind@. -newtype Tab a = Tab (U.Vector a) - -emptyTileSpeedup :: TileSpeedup -emptyTileSpeedup = TileSpeedup emptyTab emptyTab emptyTab emptyTab emptyTab - emptyTab emptyTab emptyTab emptyTab emptyTab - emptyTab emptyTab emptyTab emptyTab emptyTab - emptyTab emptyTab emptyTab emptyTab emptyTab - emptyTab emptyTab - -emptyTab :: U.Unbox a => Tab a -emptyTab = Tab $! U.empty diff --git a/engine-src/Game/LambdaHack/Common/MonadStateRead.hs b/engine-src/Game/LambdaHack/Common/MonadStateRead.hs --- a/engine-src/Game/LambdaHack/Common/MonadStateRead.hs +++ b/engine-src/Game/LambdaHack/Common/MonadStateRead.hs @@ -9,6 +9,7 @@ import Game.LambdaHack.Core.Prelude +import Data.Either import qualified Data.EnumMap.Strict as EM import Game.LambdaHack.Common.Actor @@ -48,7 +49,7 @@ isNoConfirmsGame :: MonadStateRead m => m Bool isNoConfirmsGame = do gameMode <- getGameMode - return $! maybe False (> 0) $ lookup NO_CONFIRMS $ mfreq gameMode + return $! mattract gameMode getEntryArena :: MonadStateRead m => Faction -> m LevelId getEntryArena fact = do @@ -69,7 +70,7 @@ let calmE = calmEnough sb actorMaxSk forced = bproj sb permitted = permittedPrecious forced calmE - preferredPrecious = either (const False) id . permitted + preferredPrecious = fromRight False . permitted permAssocs = filter (preferredPrecious . fst . snd) kitAss strongest = strongestMelee ignoreCharges mdiscoBenefit localTime permAssocs diff --git a/engine-src/Game/LambdaHack/Common/Point.hs b/engine-src/Game/LambdaHack/Common/Point.hs --- a/engine-src/Game/LambdaHack/Common/Point.hs +++ b/engine-src/Game/LambdaHack/Common/Point.hs @@ -2,12 +2,12 @@ -- | Basic operations on 2D points represented as linear offsets. module Game.LambdaHack.Common.Point ( Point(..), PointI - , chessDist, euclidDistSq, adjacent, bla, fromTo + , chessDist, euclidDistSq, adjacent, bresenhamsLineAlgorithm, fromTo , originPoint, insideP , speedupHackXSize #ifdef EXPOSE_INTERNAL -- * Internal operations - , blaXY, balancedWord + , bresenhamsLineAlgorithmBegin, balancedWord #endif ) where @@ -93,7 +93,7 @@ -- This is hidden from Haddock, but run by doctest: -- $ -- prop> (toEnum :: PointI -> Point) (fromEnum p) == p --- prop> (fromEnum :: Point -> PointI) (toEnum p) == p +-- prop> \ (NonNegative i) -> (fromEnum :: Point -> PointI) (toEnum i) == i -- | The distance between two points in the chessboard metric. -- @@ -131,16 +131,28 @@ -- not @PointI@, to permit aiming out of the level, e.g., to get -- uniform distributions of directions for explosions close to the edge -- of the level. -bla :: Int -> Point -> Point -> Maybe [Point] -bla eps source target = +-- +-- >>> bresenhamsLineAlgorithm 0 (Point 0 0) (Point 0 0) +-- Nothing +-- >>> take 3 $ fromJust $ bresenhamsLineAlgorithm 0 (Point 0 0) (Point 1 0) +-- [(1,0),(2,0),(3,0)] +-- >>> take 3 $ fromJust $ bresenhamsLineAlgorithm 0 (Point 0 0) (Point 0 1) +-- [(0,1),(0,2),(0,3)] +-- >>> take 3 $ fromJust $ bresenhamsLineAlgorithm 0 (Point 0 0) (Point 1 1) +-- [(1,1),(2,2),(3,3)] +bresenhamsLineAlgorithm :: Int -> Point -> Point -> Maybe [Point] +bresenhamsLineAlgorithm eps source target = if source == target then Nothing - else Just $ tail $ blaXY eps source target + else Just $ tail $ bresenhamsLineAlgorithmBegin eps source target -- | Bresenham's line algorithm generalized to arbitrary starting @eps@ -- (@eps@ value of 0 gives the standard BLA). Includes the source point -- and goes through the target point to infinity. -blaXY :: Int -> Point -> Point -> [Point] -blaXY eps (Point x0 y0) (Point x1 y1) = +-- +-- >>> take 4 $ bresenhamsLineAlgorithmBegin 0 (Point 0 0) (Point 2 0) +-- [(0,0),(1,0),(2,0),(3,0)] +bresenhamsLineAlgorithmBegin :: Int -> Point -> Point -> [Point] +bresenhamsLineAlgorithmBegin eps (Point x0 y0) (Point x1 y1) = let (dx, dy) = (x1 - x0, y1 - y0) xyStep b (x, y) = (x + signum dx, y + signum dy * b) yxStep b (x, y) = (x + signum dx * b, y + signum dy) @@ -157,6 +169,9 @@ -- | A list of all points on a straight vertical or straight horizontal line -- between two points. Fails if no such line exists. +-- +-- >>> fromTo (Point 0 0) (Point 2 0) +-- [(0,0),(1,0),(2,0)] fromTo :: Point -> Point -> [Point] fromTo (Point x0 y0) (Point x1 y1) = let fromTo1 :: Int -> Int -> [Int] diff --git a/engine-src/Game/LambdaHack/Common/PointArray.hs b/engine-src/Game/LambdaHack/Common/PointArray.hs --- a/engine-src/Game/LambdaHack/Common/PointArray.hs +++ b/engine-src/Game/LambdaHack/Common/PointArray.hs @@ -97,7 +97,7 @@ accessI :: UnboxRepClass c => Array c -> Int -> UnboxRep c {-# INLINE accessI #-} -accessI Array{..} p = avector `U.unsafeIndex` p +accessI Array{..} p = avector `vectorUnboxedUnsafeIndex` p -- | Construct an array updated with the association list. (//) :: UnboxRepClass c => Array c -> [(Point, c)] -> Array c diff --git a/engine-src/Game/LambdaHack/Common/Save.hs b/engine-src/Game/LambdaHack/Common/Save.hs --- a/engine-src/Game/LambdaHack/Common/Save.hs +++ b/engine-src/Game/LambdaHack/Common/Save.hs @@ -156,11 +156,8 @@ case words $ rtitle corule of w : _ -> w _ -> "Game" - n = fromEnum side -- we depend on the numbering hack to number saves in gameShortName - ++ (if n > 0 - then ".human_" ++ show n - else ".computer_" ++ show (-n)) + ++ ".team_" ++ show (fromEnum side) ++ ".sav" saveNameSer :: RuleContent -> String diff --git a/engine-src/Game/LambdaHack/Common/State.hs b/engine-src/Game/LambdaHack/Common/State.hs --- a/engine-src/Game/LambdaHack/Common/State.hs +++ b/engine-src/Game/LambdaHack/Common/State.hs @@ -17,8 +17,10 @@ , maxSkillsFromActor, maxSkillsInDungeon #ifdef EXPOSE_INTERNAL -- * Internal operations - , unknownLevel, unknownTileMap + , unknownLevel #endif + -- * Operations both internal and used in unit tests + , unknownTileMap ) where import Prelude () @@ -74,7 +76,8 @@ , _sfactionD :: FactionDict -- ^ remembered sides still in game , _stime :: Time -- ^ global game time, for UI display only - , _scops :: COps -- ^ remembered content + , _scops :: COps -- ^ remembered content; warning: use only + -- validated content, even for testing , _sgold :: Int -- ^ total value of human trinkets in dungeon , _shigh :: HighScore.ScoreDict -- ^ high score table , _sgameModeId :: ContentId ModeKind -- ^ current game mode @@ -183,6 +186,10 @@ , lnight } +-- | Create a map full of unknown tiles. +-- +-- >>> unknownTileMap (fromJust (toArea (0,0,0,0))) TK.unknownId 2 2 +-- PointArray.Array with size (2,2) unknownTileMap :: Area -> ContentId TileKind -> X -> Y -> TileMap unknownTileMap larea outerId rWidthMax rHeightMax = let unknownMap = PointArray.replicateA rWidthMax rHeightMax TK.unknownId diff --git a/engine-src/Game/LambdaHack/Common/Tile.hs b/engine-src/Game/LambdaHack/Common/Tile.hs --- a/engine-src/Game/LambdaHack/Common/Tile.hs +++ b/engine-src/Game/LambdaHack/Common/Tile.hs @@ -13,9 +13,9 @@ -- -- Actors at normal speed (2 m/s) take one turn to move one tile (1 m by 1 m). module Game.LambdaHack.Common.Tile - ( -- * Construction of tile property lookup speedup tables - speedupTile - -- * Sped up property lookups + ( -- * Tile property lookup speedup tables and their construction + TileSpeedup(..), Tab(..), speedupTile + -- * Speedup property lookups , isClear, isLit, isHideout, isWalkable, isDoor, isChangable , isSuspect, isHideAs, consideredByAI, isExplorable , isVeryOftenItem, isCommonItem, isOftenActor, isNoItem, isNoActor @@ -24,7 +24,6 @@ , kindHasFeature, openTo, closeTo, embeddedItems, revealAs , obscureAs, hideAs, buildAs , isEasyOpenKind, isOpenable, isClosable, isModifiable - , TileAction (..), parseTileAction #ifdef EXPOSE_INTERNAL -- * Internal operations , createTab, createTabWithKey, accessTab, alterMinSkillKind, alterMinWalkKind @@ -38,16 +37,48 @@ import qualified Data.Vector.Unboxed as U import Data.Word (Word8) -import Game.LambdaHack.Common.Item -import Game.LambdaHack.Common.Kind -import Game.LambdaHack.Common.Types import Game.LambdaHack.Content.ItemKind (ItemKind) -import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.TileKind (TileKind, isUknownSpace) import qualified Game.LambdaHack.Content.TileKind as TK import Game.LambdaHack.Core.Random +import Game.LambdaHack.Definition.ContentData import Game.LambdaHack.Definition.Defs +-- | A lot of tabulated maps from tile kind identifier to a property +-- of the tile kind. +data TileSpeedup = TileSpeedup + { isClearTab :: Tab Bool + , isLitTab :: Tab Bool + , isHideoutTab :: Tab Bool + , isWalkableTab :: Tab Bool + , isDoorTab :: Tab Bool + , isOpenableTab :: Tab Bool + , isClosableTab :: Tab Bool + , isChangableTab :: Tab Bool + , isModifiableWithTab :: Tab Bool + , isSuspectTab :: Tab Bool + , isHideAsTab :: Tab Bool + , consideredByAITab :: Tab Bool + , isVeryOftenItemTab :: Tab Bool + , isCommonItemTab :: Tab Bool + , isOftenActorTab :: Tab Bool + , isNoItemTab :: Tab Bool + , isNoActorTab :: Tab Bool + , isEasyOpenTab :: Tab Bool + , isEmbedTab :: Tab Bool + , isAquaticTab :: Tab Bool + , alterMinSkillTab :: Tab Word8 + , alterMinWalkTab :: Tab Word8 + } + +-- Vectors of booleans can be slower than arrays, because they are not packed, +-- but with growing cache sizes they may as well turn out faster at some point. +-- The advantage of vectors are exposed internals, in particular unsafe +-- indexing. Also, in JS, bool arrays are obviously not packed. +-- An option: https://github.com/Bodigrim/bitvec +-- | A map morally indexed by @ContentId TileKind@. +newtype Tab a = Tab (U.Vector a) + createTab :: U.Unbox a => ContentData TileKind -> (TileKind -> a) -> Tab a createTab cotile prop = Tab $ U.convert $ omapVector cotile prop @@ -61,17 +92,15 @@ -- with the newtype. accessTab :: U.Unbox a => Tab a -> ContentId TileKind -> a {-# INLINE accessTab #-} -accessTab (Tab tab) ki = tab `U.unsafeIndex` contentIdIndex ki +accessTab (Tab tab) ki = tab `vectorUnboxedUnsafeIndex` contentIdIndex ki speedupTile :: Bool -> ContentData TileKind -> TileSpeedup speedupTile allClear cotile = -- Vectors pack bools as Word8 by default. No idea if the extra memory -- taken makes random lookups more or less efficient, so not optimizing -- further, until I have benchmarks. - let isClearTab | allClear = createTab cotile - $ not . (== maxBound) . TK.talter - | otherwise = createTab cotile - $ kindHasFeature TK.Clear + let isClearTab | allClear = createTab cotile $ (/= maxBound) . TK.talter + | otherwise = createTab cotile $ kindHasFeature TK.Clear isLitTab = createTab cotile $ not . kindHasFeature TK.Dark isHideoutTab = createTab cotile $ \tk -> kindHasFeature TK.Walkable tk -- implies not unknown @@ -370,40 +399,3 @@ || isChangable coTileSpeedup t || isModifiableWith coTileSpeedup t || isSuspect coTileSpeedup t - -data TileAction = - EmbedAction (ItemId, ItemQuant) - | ToAction (GroupName TK.TileKind) - | WithAction [(Int, GroupName ItemKind)] (GroupName TK.TileKind) - deriving Show - -parseTileAction :: Bool -> Bool -> [(IK.ItemKind, (ItemId, ItemQuant))] - -> TK.Feature - -> Maybe TileAction -parseTileAction bproj underFeet embedKindList feat = case feat of - TK.Embed igroup -> - -- Greater or equal 0 to also cover template UNKNOWN items - -- not yet identified by the client. - let f (itemKind, _) = - fromMaybe (-1) (lookup igroup $ IK.ifreq itemKind) >= 0 - in case find f embedKindList of - Nothing -> Nothing - Just (_, iidkit) -> Just $ EmbedAction iidkit - TK.OpenTo tgroup | not (underFeet || bproj) -> Just $ ToAction tgroup - TK.CloseTo tgroup | not (underFeet || bproj) -> Just $ ToAction tgroup - TK.ChangeTo tgroup | not bproj -> Just $ ToAction tgroup - TK.OpenWith proj grps tgroup | not underFeet -> - if proj == TK.ProjNo && bproj - then Nothing - else Just $ WithAction grps tgroup - TK.CloseWith proj grps tgroup | not underFeet -> - -- Not when standing on tile, not to autoclose doors under actor - -- or close via dropping an item inside. - if proj == TK.ProjNo && bproj - then Nothing - else Just $ WithAction grps tgroup - TK.ChangeWith proj grps tgroup -> - if proj == TK.ProjNo && bproj - then Nothing - else Just $ WithAction grps tgroup - _ -> Nothing diff --git a/engine-src/Game/LambdaHack/Common/Types.hs b/engine-src/Game/LambdaHack/Common/Types.hs --- a/engine-src/Game/LambdaHack/Common/Types.hs +++ b/engine-src/Game/LambdaHack/Common/Types.hs @@ -23,7 +23,14 @@ newtype ItemId = ItemId Int deriving (Show, Eq, Ord, Enum, Binary) --- | A unique identifier of a faction in a game. +-- | A unique identifier of a faction in a game. It's assigned in the order +-- from game mode roster, starting from one. We keep the @FactionId@ +-- and @TeamContinuity@ types separate mostly to let @FactionId@ reflect +-- the order, which influences starting faction positions, etc. +-- We use @TeamContinuity@ for dictionaries containing teams that may +-- or may not be active factions in the current game, while @FactionId@ are +-- used only for factions in the game (in particular, because they vary +-- depending on order in game mode roster, while @TeamContinuity@ are stable). newtype FactionId = FactionId Int deriving (Show, Eq, Ord, Enum, Hashable, Binary) diff --git a/engine-src/Game/LambdaHack/Server/BroadcastAtomic.hs b/engine-src/Game/LambdaHack/Server/BroadcastAtomic.hs --- a/engine-src/Game/LambdaHack/Server/BroadcastAtomic.hs +++ b/engine-src/Game/LambdaHack/Server/BroadcastAtomic.hs @@ -117,7 +117,8 @@ -- which prevents changing leader just to get hearing -- intel. However, leader's position affects accuracy -- of the distance to noise hints. - return $ Just $ min 5 $ chessDist pos (bpos b) `div` 10 + return $ Just $ max 0 $ min 5 $ flip (-) 1 $ floor + $ sqrt $ intToDouble $ chessDist pos (bpos b) -- Projectiles never hear, for speed and simplicity, -- even though they sometimes see. There are flying cameras, -- but no microphones --- drones make too much noise themselves. @@ -198,9 +199,9 @@ b <- getsState $ getActorBody aid discoAspect <- getsState sdiscoAspect let arTrunk = discoAspect EM.! btrunk b - return $! ( False, if not (bproj b) || IA.checkFlag Ability.Blast arTrunk - then Nothing - else Just $ bpos b ) + return ( False, if not (bproj b) || IA.checkFlag Ability.Blast arTrunk + then Nothing + else Just $ bpos b ) UpdAlterTile _ p _ toTile -> return (not $ Tile.isDoor coTileSpeedup toTile, Just p) UpdAlterExplorable{} -> return (True, Nothing) diff --git a/engine-src/Game/LambdaHack/Server/Commandline.hs b/engine-src/Game/LambdaHack/Server/Commandline.hs --- a/engine-src/Game/LambdaHack/Server/Commandline.hs +++ b/engine-src/Game/LambdaHack/Server/Commandline.hs @@ -182,9 +182,9 @@ <> help "Keep factions automated after game over" ) newGameP :: Parser (Maybe Int) -newGameP = optional $ max 1 <$> min difficultyBound <$> +newGameP = optional $ max 1 . min difficultyBound <$> option auto ( long "newGame" - <> help "Start a new game, overwriting the save file, with difficulty for all UI players set to N" + <> help "Start a new game, overwriting the save file and often forgetting history, with difficulty for all UI players set to N" <> metavar "N" ) fullscreenModeP :: Parser (Maybe FullscreenMode) diff --git a/engine-src/Game/LambdaHack/Server/CommonM.hs b/engine-src/Game/LambdaHack/Server/CommonM.hs --- a/engine-src/Game/LambdaHack/Server/CommonM.hs +++ b/engine-src/Game/LambdaHack/Server/CommonM.hs @@ -45,9 +45,10 @@ import qualified Game.LambdaHack.Common.Tile as Tile import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Types +import qualified Game.LambdaHack.Content.CaveKind as CK +import Game.LambdaHack.Content.FactionKind import Game.LambdaHack.Content.ItemKind (ItemKind) import qualified Game.LambdaHack.Content.ItemKind as IK -import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Core.Random import qualified Game.LambdaHack.Definition.Ability as Ability import Game.LambdaHack.Definition.Defs @@ -86,9 +87,11 @@ discoverSample iid = do itemKindId <- getsState $ getIidKindIdServer iid let arItem = discoAspect EM.! iid - cdummy = CTrunk fid minLid originPoint -- only @fid@ matters here + cdummy = CTrunk fid minLid originPoint itemKind = okind coitem itemKindId - execUpdAtomic $ if keptSecret itemKind arItem -- a hack + -- Due to @cdummy@, the met and unmet secret things will appear + -- at gameover among actors in the debug mode. Tough luck. + execUpdAtomic $ if keptSecret itemKind arItem then UpdSpotItem False iid quantSingle cdummy else UpdDiscover cdummy iid itemKindId arItem generationAn <- getsServer sgenerationAn @@ -106,12 +109,12 @@ when (sexposeActors sclientOptions) $ -- Few, if any, need ID, but we can't rule out unusual content. mapM_ discoverSample $ EM.keys $ nonDupGen EM.! STrunk - when (sexposeItems sclientOptions) $ + when (sexposeItems sclientOptions) $ do mapM_ discoverSample $ EM.keys $ nonDupGen EM.! SItem - mapM_ discoverSample $ EM.keys $ nonDupGen EM.! SEmbed - mapM_ discoverSample $ EM.keys $ nonDupGen EM.! SOrgan - mapM_ discoverSample $ EM.keys $ nonDupGen EM.! SCondition - mapM_ discoverSample $ EM.keys $ nonDupGen EM.! SBlast + mapM_ discoverSample $ EM.keys $ nonDupGen EM.! SEmbed + mapM_ discoverSample $ EM.keys $ nonDupGen EM.! SOrgan + mapM_ discoverSample $ EM.keys $ nonDupGen EM.! SCondition + mapM_ discoverSample $ EM.keys $ nonDupGen EM.! SBlast revealAll :: MonadServerAtomic m => FactionId -> m () revealAll fid = do @@ -178,10 +181,10 @@ `swith` (stOutcome <$> oldSt, status, fid)) () -- This runs regardless of the _new_ status. manalytics <- - if fhasUI $ gplayer fact then do + if fhasUI $ gkind fact then do keepAutomated <- getsServer $ skeepAutomated . soptions -- Try to remove AI control of the UI faction, to show gameover info. - when (isAIFact fact && not keepAutomated) $ + when (gunderAI fact && not keepAutomated) $ execUpdAtomic $ UpdAutoFaction fid False revealAll fid -- Likely, by this time UI faction is no longer AI-controlled, @@ -202,7 +205,7 @@ error $ "no quitting to deduce" `showFailure` (fid0, status) deduceQuits fid0 status = do fact0 <- getsState $ (EM.! fid0) . sfactionD - let factHasUI = fhasUI . gplayer + let factHasUI = fhasUI . gkind quitFaction (stOutcome, (fid, _)) = quitF status{stOutcome} fid mapQuitF outfids = do let (withUI, withoutUI) = @@ -281,7 +284,7 @@ -- Don't verify perception in such cases. All the caches from which -- legal perception would be created at that point are legal and verified, -- which is almost as tight. - let gameOverUI fact = fhasUI (gplayer fact) + let gameOverUI fact = fhasUI (gkind fact) && maybe False ((/= Camping) . stOutcome) (gquit fact) isGameOverUI = any gameOverUI $ EM.elems factionD !_A7 = assert (sfovLitLid == fovLitLid @@ -313,8 +316,7 @@ -- So, leaderless factions and spawner factions do not keep an arena, -- even though the latter usually has a leader for most of the game. keepArenaFact :: Faction -> Bool -keepArenaFact fact = fleaderMode (gplayer fact) /= Nothing - && fneverEmpty (gplayer fact) +keepArenaFact fact = fhasPointman (gkind fact) && fneverEmpty (gkind fact) -- We assume the actor in the second argument has HP <= 0 or is going to be -- dominated right now. Even if the actor is to be dominated, @@ -323,9 +325,9 @@ deduceKilled aid = do body <- getsState $ getActorBody aid fact <- getsState $ (EM.! bfid body) . sfactionD - when (fneverEmpty $ gplayer fact) $ do + when (fneverEmpty $ gkind fact) $ do actorsAlive <- anyActorsAlive (bfid body) aid - when (not actorsAlive) $ + unless actorsAlive $ deduceQuits (bfid body) $ Status Killed (fromEnum $ blid body) Nothing anyActorsAlive :: MonadServer m => FactionId -> ActorId -> m Bool @@ -346,14 +348,13 @@ onThisLevel <- getsState $ fidActorRegularAssocs fid lid let candidates = filter (\(_, b) -> bwatch b /= WSleep) onThisLevel ++ awake ++ sleeping ++ negative - mleaderNew = - listToMaybe $ filter (/= aidToReplace) $ map fst candidates + mleaderNew = find (/= aidToReplace) $ map fst candidates execUpdAtomic $ UpdLeadFaction fid mleader mleaderNew setFreshLeader :: MonadServerAtomic m => FactionId -> ActorId -> m () setFreshLeader fid aid = do fact <- getsState $ (EM.! fid) . sfactionD - unless (fleaderMode (gplayer fact) == Nothing) $ do + when (fhasPointman (gkind fact)) $ do -- First update and send Perception so that the new leader -- may report his environment. b <- getsState $ getActorBody aid @@ -410,7 +411,7 @@ body <- getsState $ getActorBody origin let lid = blid body lvl <- getLevel lid - case bla eps oxy tpxy of + case bresenhamsLineAlgorithm eps oxy tpxy of Nothing -> return $ Just ProjectAimOnself Just [] -> error $ "projecting from the edge of level" `showFailure` (oxy, tpxy) @@ -502,7 +503,7 @@ m2 <- rollItemAspect freq ldepth case m2 of NoNewItem -> return Nothing - NewItem itemKnown itemFull itemQuant -> do + NewItem _ itemKnown itemFull itemQuant -> do let itemFullKit = (itemFull, itemQuant) Just <$> registerActor False itemKnown itemFullKit fid pos lid time @@ -512,6 +513,7 @@ -> m ActorId registerActor summoned (ItemKnown kindIx ar _) (itemFullRaw, kit) bfid pos lid time = do + COps{cocave} <- getsState scops let container = CTrunk bfid lid pos jfid = Just bfid itemKnown = ItemKnown kindIx ar jfid @@ -521,14 +523,17 @@ fact <- getsState $ (EM.! bfid) . sfactionD actorMaxSk <- getsState $ getActorMaxSkills aid condAnyFoeAdj <- getsState $ anyFoeAdj aid - when (canSleep actorMaxSk + Level{lkind} <- getLevel lid + let cinitSleep = CK.cinitSleep $ okind cocave lkind + when (cinitSleep /= CK.InitSleepBanned + && canSleep actorMaxSk && not condAnyFoeAdj && not summoned - && not (fhasGender (gplayer fact))) $ do -- heroes never start asleep + && not (fhasGender (gkind fact))) $ do -- heroes never start asleep -- A lot of actors will wake up at once anyway, so let most start sleeping. let sleepOdds = if prefersSleep actorMaxSk then 19%20 else 2%3 sleeps <- rndToAction $ chance sleepOdds - when sleeps $ addSleep aid + when (cinitSleep == CK.InitSleepAlways || sleeps) $ addSleep aid return aid addProjectile :: MonadServerAtomic m @@ -595,14 +600,14 @@ factionD <- getsState sfactionD curChalSer <- getsServer $ scurChalSer . soptions let fact = factionD EM.! fid - bnumberTeam <- case gteamCont fact of - Just teamContinuity | not bproj -> do + teamContinuityOurs = fteam (gkind fact) + bnumberTeam <- + if bproj then return Nothing else do stcounter <- getsServer stcounter - let number = EM.findWithDefault 0 teamContinuity stcounter + let number = EM.findWithDefault 0 teamContinuityOurs stcounter modifyServer $ \ser -> ser {stcounter = - EM.insert teamContinuity (succ number) stcounter} - return $ Just (number, teamContinuity) - _ -> return Nothing + EM.insert teamContinuityOurs (succ number) stcounter} + return $ Just (number, teamContinuityOurs) let bnumber = fst <$> bnumberTeam -- If difficulty is below standard, HP is added to the UI factions, -- otherwise HP is added to their enemies. @@ -618,10 +623,10 @@ -- in a hard to balance way (e.g., one bullet adds 10 SkMaxHP). boostFact = not bproj && if diffBonusCoeff > 0 - then any (fhasUI . gplayer . snd) + then any (fhasUI . gkind . snd) (filter (\(fi, fa) -> isFriend fi fa fid) (EM.assocs factionD)) - else any (fhasUI . gplayer . snd) + else any (fhasUI . gkind . snd) (filter (\(fi, fa) -> isFoe fi fa fid) (EM.assocs factionD)) finalHP | boostFact = min (xM 899) -- no more than UI can stand @@ -692,7 +697,7 @@ modifyServer $ \ser -> ser {steamGearCur = EM.alter alt teamContinuity steamGearCur} let itemKind2 = okind coitem itemKindId2 - freq = pure (itemKindId2, itemKind2) + freq = pure (ikGrp, itemKindId2, itemKind2) rollAndRegisterItem False ldepth freq container mk case mIidEtc of Nothing -> error $ "" `showFailure` (lid, ikGrp, container, mk) @@ -716,18 +721,22 @@ && not (IA.isHumanTrinket itemKind)) $ execUpdAtomic $ UpdDiscover c iid itemKindId arItem -pickWeaponServer :: MonadServer m => ActorId -> m (Maybe (ItemId, CStore)) -pickWeaponServer source = do +pickWeaponServer :: MonadServer m + => ActorId -> ActorId -> m (Maybe (ItemId, CStore)) +pickWeaponServer source target = do eqpAssocs <- getsState $ kitAssocs source [CEqp] bodyAssocs <- getsState $ kitAssocs source [COrgan] actorSk <- currentSkillsServer source sb <- getsState $ getActorBody source + tb <- getsState $ getActorBody target let kitAssRaw = eqpAssocs ++ bodyAssocs forced = bproj sb kitAss | forced = kitAssRaw -- for projectiles, anything is weapon | otherwise = filter (IA.checkFlag Ability.Meleeable . aspectRecordFull . fst . snd) kitAssRaw + benign itemFull = let arItem = aspectRecordFull itemFull + in IA.checkFlag Ability.Benign arItem -- Server ignores item effects or it would leak item discovery info. -- Hence, weapons with powerful burning or wouding are undervalued. -- In particular, it even uses weapons that would heal an opponent. @@ -736,6 +745,9 @@ strongest <- pickWeaponM False Nothing kitAss actorSk source case strongest of [] -> return Nothing + (_, _, _, _, _, (itemFull, _)) : _ | not forced + && benign itemFull && bproj tb -> + return Nothing -- if strongest is benign, don't waste fun on a projectile iis@((value1, hasEffect1, timeout1, _, _, _) : _) -> do let minIis = takeWhile (\(value, hasEffect, timeout, _, _, _) -> value == value1 diff --git a/engine-src/Game/LambdaHack/Server/DungeonGen.hs b/engine-src/Game/LambdaHack/Server/DungeonGen.hs --- a/engine-src/Game/LambdaHack/Server/DungeonGen.hs +++ b/engine-src/Game/LambdaHack/Server/DungeonGen.hs @@ -87,8 +87,6 @@ blocksVertical (Point x y) array = not (passes (Point x (y + 1)) array || passes (Point x (y - 1)) array) - xeven Point{..} = px `mod` 2 == 0 - yeven Point{..} = py `mod` 2 == 0 activeArea = fromMaybe (error $ "" `showFailure` darea) $ shrink darea connect included blocks walkableTile array = let g p c = if inside activeArea p @@ -100,15 +98,15 @@ else c in PointArray.imapA g array walkable2 <- pickPassable - let converted2 = connect xeven blocksHorizontal walkable2 converted1 + let converted2 = connect (even . px) blocksHorizontal walkable2 converted1 walkable3 <- pickPassable - let converted3 = connect yeven blocksVertical walkable3 converted2 + let converted3 = connect (even . py) blocksVertical walkable3 converted2 walkable4 <- pickPassable let converted4 = - connect (not . xeven) blocksHorizontal walkable4 converted3 + connect (odd . px) blocksHorizontal walkable4 converted3 walkable5 <- pickPassable let converted5 = - connect (not . yeven) blocksVertical walkable5 converted4 + connect (odd . py) blocksVertical walkable5 converted4 return converted5 buildTileMap :: COps -> Cave -> Rnd TileMap @@ -271,26 +269,29 @@ ry = 6 -- enough to fit smallest stairs wx = x1 - x0 + 1 wy = y1 - y0 + 1 - notInCorner Point{..} = + notInCornerEtc Point{..} = cornerPermitted || wx < 3 * rx + 3 || wy < 3 * ry + 3 -- everything is a corner || px > x0 + (wx - 3) `div` 3 && py > y0 + (wy - 3) `div` 3 + inCorner Point{..} = (px <= x0 + rx || px >= x1 - rx) + && (py <= y0 + ry || py >= y1 - ry) + gpreference = if cornerPermitted then inCorner else notInCornerEtc f p = case snapToStairList 0 ps p of Left{} -> Nothing Right np -> let nnp = either id id $ snapToStairList 0 boot np - in if notInCorner nnp then Just nnp else Nothing + in if notInCornerEtc nnp then Just nnp else Nothing g p = case snapToStairList 2 ps p of Left{} -> Nothing Right np -> let nnp = either id id $ snapToStairList 2 boot np - in if notInCorner nnp && dist cminStairDist nnp + in if gpreference nnp && dist cminStairDist nnp then Just nnp else Nothing focusArea = let d = if cfenceApart then 1 else 0 in fromMaybe (error $ "" `showFailure` darea) $ toArea ( x0 + 4 + d, y0 + 3 + d , x1 - 4 - d, y1 - anchorDown + 1 ) - mpos <- findPointInArea focusArea g 300 f + mpos <- findPointInArea focusArea g 500 f -- The message fits this debugging level: let !_ = if isNothing mpos && sdumpInitRngs serverOptions then unsafePerformIO $ do diff --git a/engine-src/Game/LambdaHack/Server/DungeonGen/AreaRnd.hs b/engine-src/Game/LambdaHack/Server/DungeonGen/AreaRnd.hs --- a/engine-src/Game/LambdaHack/Server/DungeonGen/AreaRnd.hs +++ b/engine-src/Game/LambdaHack/Server/DungeonGen/AreaRnd.hs @@ -54,7 +54,7 @@ return $! Point (x0 + px) (y0 + py) -- | Find a suitable position in the area, based on random points --- and a predicate. +-- and a preference predicate and fallback acceptability predicate. findPointInArea :: Area -> (Point -> Maybe Point) -> Int -> (Point -> Maybe Point) -> Rnd (Maybe Point) @@ -158,7 +158,7 @@ randomConnection (nx, ny) = assert (nx > 1 && ny > 0 || nx > 0 && ny > 1 `blame` (nx, ny)) $ do rb <- oneOf [False, True] - if rb && nx > 1 + if rb && nx > 1 || ny <= 1 then do rx <- randomR0 (nx - 2) ry <- randomR0 (ny - 1) @@ -319,9 +319,21 @@ (c2 : rest) f _ z1 _ prev [c1] = [(prev, z1, Just c1)] f _ _ _ _ [] = error $ "empty list of centers" `showFailure` fixedCenters - (xCenters, yCenters) = unzip $ map (px &&& py) $ EM.keys fixedCenters - xset = IS.fromList $ xCenters ++ map px boot - yset = IS.fromList $ yCenters ++ map py boot + (xCenters, yCenters) = IS.fromList *** IS.fromList + $ unzip $ map (px &&& py) $ EM.keys fixedCenters + distFromIS is z = + - minimum (maxBound : map (\i -> abs (i - z)) (IS.toList is)) + xboot = nub $ sortOn (distFromIS xCenters) + $ filter (`IS.notMember` xCenters) $ map px boot + yboot = nub $ sortOn (distFromIS yCenters) + $ filter (`IS.notMember` yCenters) $ map py boot + -- Don't let boots ignore cell size too much, esp. in small caves. + xcellsInArea = (x1 - x0 + 1) `div` fst cellSize + ycellsInArea = (y1 - y0 + 1) `div` snd cellSize + xbootN = assert (xcellsInArea > 0) $ xcellsInArea - IS.size xCenters + ybootN = assert (ycellsInArea > 0) $ ycellsInArea - IS.size yCenters + xset = xCenters `IS.union` IS.fromList (take xbootN xboot) + yset = yCenters `IS.union` IS.fromList (take ybootN yboot) xsize = IS.findMax xset - IS.findMin xset ysize = IS.findMax yset - IS.findMin yset -- This is precisely how the cave will be divided among places, diff --git a/engine-src/Game/LambdaHack/Server/DungeonGen/Cave.hs b/engine-src/Game/LambdaHack/Server/DungeonGen/Cave.hs --- a/engine-src/Game/LambdaHack/Server/DungeonGen/Cave.hs +++ b/engine-src/Game/LambdaHack/Server/DungeonGen/Cave.hs @@ -237,7 +237,7 @@ addedConnects <- do let cauxNum = round $ cauxConnects * (fromIntegralWrap :: Int -> Rational) - (fst lgrid * snd lgrid) + (uncurry (*) lgrid) cns <- map head . group . sort <$> replicateM cauxNum (randomConnection lgrid) -- This allows connections through a single void room, @@ -285,8 +285,8 @@ intersectionWithKeyMaybe combine = EM.mergeWithKey combine (const EM.empty) (const EM.empty) interCor = intersectionWithKeyMaybe mergeCor lplaces lplcorOuter -- fast - doorMap <- mapWithKeyM (pickOpening cops kc lplaces litCorTile dsecret) - interCor -- very small + doorMap <- foldlM' (pickOpening cops kc lplaces litCorTile dsecret) EM.empty + (EM.assocs interCor) -- very small let subArea = fromMaybe (error $ "" `showFailure` kc) $ shrink darea fence <- buildFenceRnd cops cfenceTileN cfenceTileE cfenceTileS cfenceTileW subArea @@ -318,14 +318,15 @@ -- order matters return $! Cave {..} -pickOpening :: COps -> CaveKind -> TileMapEM -> ContentId TileKind - -> Word32 -> Point - -> (ContentId TileKind, ContentId TileKind, ContentId PlaceKind) - -> Rnd (ContentId TileKind) +pickOpening :: COps -> CaveKind -> TileMapEM -> ContentId TileKind -> Word32 + -> EM.EnumMap Point (ContentId TileKind) + -> ( Point + , (ContentId TileKind, ContentId TileKind, ContentId PlaceKind) ) + -> Rnd (EM.EnumMap Point (ContentId TileKind)) pickOpening COps{cotile, coTileSpeedup} CaveKind{cdoorChance, copenChance, chidden} lplaces litCorTile dsecret - pos (pl, cor, _) = do + !acc (pos, (pl, cor, _)) = do let nicerCorridor = if Tile.isLit coTileSpeedup cor then cor else -- If any cardinally adjacent walkable room tile is lit, @@ -337,23 +338,29 @@ && Tile.isLit coTileSpeedup tile vic = vicinityCardinalUnsafe pos in if any roomTileLit vic then litCorTile else cor - -- Openings have a certain chance to be doors and doors have a certain - -- chance to be open. - rd <- chance cdoorChance - if rd then do - let hidden = Tile.buildAs cotile pl - doorTrappedId <- Tile.revealAs cotile hidden - let !_A = assert (Tile.buildAs cotile doorTrappedId == doorTrappedId) () - -- Not all solid tiles can hide a door (or any other openable tile), - -- so @doorTrappedId@ may in fact not be a door at all, hence the check. - if Tile.isOpenable coTileSpeedup doorTrappedId then do -- door created - ro <- chance copenChance - if ro - then Tile.openTo cotile doorTrappedId - else if isChancePos 1 chidden dsecret pos - then return $! doorTrappedId -- server will hide it - else do - doorOpenId <- Tile.openTo cotile doorTrappedId - Tile.closeTo cotile doorOpenId -- mail do nothing; OK - else return $! doorTrappedId -- assume this is what content enforces - else return $! nicerCorridor + vicAll = vicinityUnsafe pos + vicNewTiles = mapMaybe (`EM.lookup` acc) vicAll + newTile <- case vicNewTiles of + vicNewTile : _ -> return vicNewTile -- disallow a door beside an opening + [] -> do + -- Openings have a certain chance to be doors and doors have a certain + -- chance to be open. + rd <- chance cdoorChance + if rd then do + let hidden = Tile.buildAs cotile pl + doorTrappedId <- Tile.revealAs cotile hidden + let !_A = assert (Tile.buildAs cotile doorTrappedId == doorTrappedId) () + -- Not all solid tiles can hide a door (or any other openable tile), + -- so @doorTrappedId@ may in fact not be a door at all, hence the check. + if Tile.isOpenable coTileSpeedup doorTrappedId then do -- door created + ro <- chance copenChance + if ro + then Tile.openTo cotile doorTrappedId + else if isChancePos 1 chidden dsecret pos + then return doorTrappedId -- server will hide it + else do + doorOpenId <- Tile.openTo cotile doorTrappedId + Tile.closeTo cotile doorOpenId -- mail do nothing; OK + else return doorTrappedId -- assume this is what content enforces + else return nicerCorridor + return $! EM.insert pos newTile acc diff --git a/engine-src/Game/LambdaHack/Server/DungeonGen/Place.hs b/engine-src/Game/LambdaHack/Server/DungeonGen/Place.hs --- a/engine-src/Game/LambdaHack/Server/DungeonGen/Place.hs +++ b/engine-src/Game/LambdaHack/Server/DungeonGen/Place.hs @@ -325,7 +325,7 @@ let reflect :: Int -> [a] -> [a] reflect d pat = tileReflect d (cycle pat) return $! fillInterior reflect reflect - CVerbatim -> return $! fillInterior (flip const) (flip const) + CVerbatim -> return $! fillInterior (\ _ x -> x) (\ _ x -> x) CMirror -> do mirror1 <- oneOf [id, reverse] mirror2 <- oneOf [id, reverse] diff --git a/engine-src/Game/LambdaHack/Server/FovDigital.hs b/engine-src/Game/LambdaHack/Server/FovDigital.hs --- a/engine-src/Game/LambdaHack/Server/FovDigital.hs +++ b/engine-src/Game/LambdaHack/Server/FovDigital.hs @@ -253,7 +253,7 @@ General remarks: The FOV agrees with physical properties of tiles as diamonds and visibility from any point to any point. A diamond is denoted -by the left corner of it's encompassing tile. Hero is at (0, 0). +by the left corner of its encompassing tile. Hero is at (0, 0). Order of processing in the first quadrant rotated by 45 degrees is > 45678 diff --git a/engine-src/Game/LambdaHack/Server/HandleEffectM.hs b/engine-src/Game/LambdaHack/Server/HandleEffectM.hs --- a/engine-src/Game/LambdaHack/Server/HandleEffectM.hs +++ b/engine-src/Game/LambdaHack/Server/HandleEffectM.hs @@ -56,9 +56,9 @@ import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Types import Game.LambdaHack.Common.Vector +import Game.LambdaHack.Content.FactionKind import Game.LambdaHack.Content.ItemKind (ItemKind) import qualified Game.LambdaHack.Content.ItemKind as IK -import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Content.RuleKind import qualified Game.LambdaHack.Core.Dice as Dice import Game.LambdaHack.Core.Random @@ -148,7 +148,7 @@ when serious $ cutCalm target tb <- getsState $ getActorBody target fact <- getsState $ (EM.! bfid tb) . sfactionD - unless (bproj tb || fleaderMode (gplayer fact) == Nothing) $ + when (not (bproj tb) && fhasPointman (gkind fact)) $ -- If leader just lost all HP, change the leader early (not when destroying -- the actor), to let players rescue him, especially if he's slowed -- by the attackers. @@ -272,7 +272,7 @@ if not recharged then return UseDud else do let timeoutTurns = timeDeltaScale (Delta timeTurn) timeout newItemTimer = createItemTimer localTime timeoutTurns - it2 = if timeout /= 0 && recharged + it2 = if timeout > 0 && recharged then if effActivation == ActivationPeriodic && IA.checkFlag Ability.Fragile arItem then replicate (itemK - length it1) newItemTimer ++ it1 @@ -306,17 +306,18 @@ mEmbedPos = case container of CEmbed _ p -> Just p _ -> Nothing - -- Announce no effect, which is rare and wastes time, so noteworthy. if | triggered == UseUp && mEmbedPos /= Just (bpos sb) -- treading water, etc. && effActivation `notElem` [ActivationTrigger, ActivationMeleeable] -- do not repeat almost the same msg && (effActivation /= ActivationOnSmash -- only tells condition ends && effActivation /= ActivationPeriodic - || not (IA.checkFlag Ability.Condition arItem)) -> + || not (IA.checkFlag Ability.Condition arItem)) -> do -- Effects triggered; main feedback comes from them, -- but send info so that clients can log it. - execSfxAtomic $ SfxItemApplied iid container + let verbose = effActivation == ActivationUnderRanged + || effActivation == ActivationUnderMelee + execSfxAtomic $ SfxItemApplied verbose iid container | triggered /= UseUp && effActivation /= ActivationOnSmash && effActivation /= ActivationPeriodic @@ -326,12 +327,13 @@ -- and so do effects under attack && not (bproj sb) -- projectiles can be very numerous && isNothing mEmbedPos -> -- embeds may be just flavour + -- Announce no effect, which is rare and wastes time, so noteworthy. execSfxAtomic $ SfxMsgFid (bfid sb) $ if any IK.forApplyEffect effs then SfxFizzles iid container -- something didn't work despite promising effects else SfxNothingHappens iid container -- fully expected - | otherwise -> return () + | otherwise -> return () -- all the spam cases -- If none of item's effects nor a kinetic hit were performed, -- we recreate the item (assuming we deleted the item above). -- Regardless, we don't rewind the time, because some info is gained @@ -573,7 +575,7 @@ , flip Point (y + 12) $ x + fuzz , flip Point (y - 12) $ x - fuzz , flip Point (y + 12) $ x - fuzz ] - randomReverse = if veryRandom `mod` 2 == 0 then id else reverse + randomReverse = if even veryRandom then id else reverse ps = take k $ concat $ randomReverse [ zip (repeat True) -- diagonal particles don't reach that far @@ -625,15 +627,16 @@ fact <- getsState $ (EM.! bfid tb) . sfactionD let power = if power0 <= -1 then power0 else max 1 power0 -- avoid 0 deltaHP = xM power - if | cfish curChalSer && deltaHP > 0 - && fhasUI (gplayer fact) && bfid sb /= bfid tb -> do - execSfxAtomic $ SfxMsgFid (bfid tb) SfxColdFish - return UseId - | otherwise -> do - let reportedEffect = IK.RefillHP power - execSfxAtomic $ SfxEffect (bfid sb) target iid reportedEffect deltaHP - refillHP source target deltaHP - return UseUp + if cfish curChalSer && deltaHP > 0 + && fhasUI (gkind fact) && bfid sb /= bfid tb + then do + execSfxAtomic $ SfxMsgFid (bfid tb) SfxColdFish + return UseId + else do + let reportedEffect = IK.RefillHP power + execSfxAtomic $ SfxEffect (bfid sb) target iid reportedEffect deltaHP + refillHP source target deltaHP + return UseUp -- ** RefillCalm @@ -677,8 +680,7 @@ Just (hiImpressionFid, hiImpressionK) -> hiImpressionFid == bfid sb -- highest impression needs to be by us - && (fleaderMode (gplayer fact) /= Nothing - || hiImpressionK >= 10) + && (fhasPointman (gkind fact) || hiImpressionK >= 10) -- to tame/hack animal/robot, impress them a lot first if permitted then do b <- dominateFidSfx source target iid (bfid sb) @@ -1130,12 +1132,10 @@ -- Onlookers see somebody appear suddenly. The actor himself -- sees new surroundings and has to reset his perception. execUpdAtomic $ UpdSpotActor aid bNew - case mlead of - Nothing -> return () - Just leader -> - -- The leader is fresh in the sense that he's on a new level - -- and so doesn't have up to date Perception. - setFreshLeader side leader + forM_ mlead $ + -- The leader is fresh in the sense that he's on a new level + -- and so doesn't have up to date Perception. + setFreshLeader side -- ** Escape @@ -1149,7 +1149,7 @@ fact <- getsState $ (EM.! fid) . sfactionD if | bproj tb -> return UseDud -- basically a misfire - | not (fcanEscape $ gplayer fact) -> do + | not (fcanEscape $ gkind fact) -> do execSfxAtomic $ SfxMsgFid (bfid sb) SfxEscapeImpossible when (source /= target) $ execSfxAtomic $ SfxMsgFid (bfid tb) SfxEscapeImpossible @@ -1179,23 +1179,23 @@ power0 <- rndToAction $ castDice ldepth totalDepth nDm let power = max power0 1 -- KISS, avoid special case actorStasis <- getsServer sactorStasis - if | ES.member target actorStasis -> do - sb <- getsState $ getActorBody source - execSfxAtomic $ SfxMsgFid (bfid sb) SfxStasisProtects - when (source /= target) $ - execSfxAtomic $ SfxMsgFid (bfid tb) SfxStasisProtects - return UseId - | otherwise -> do - execSfx - let t = timeDeltaScale (Delta timeClip) power - -- Only the normal time, not the trajectory time, is affected. - modifyServer $ \ser -> - ser { sactorTime = ageActor (bfid tb) (blid tb) target t - $ sactorTime ser - , sactorStasis = ES.insert target (sactorStasis ser) } - -- actor's time warped, so he is in stasis, - -- immune to further warps - return UseUp + if ES.member target actorStasis then do + sb <- getsState $ getActorBody source + execSfxAtomic $ SfxMsgFid (bfid sb) SfxStasisProtects + when (source /= target) $ + execSfxAtomic $ SfxMsgFid (bfid tb) SfxStasisProtects + return UseId + else do + execSfx + let t = timeDeltaScale (Delta timeClip) power + -- Only the normal time, not the trajectory time, is affected. + modifyServer $ \ser -> + ser { sactorTime = ageActor (bfid tb) (blid tb) target t + $ sactorTime ser + , sactorStasis = ES.insert target (sactorStasis ser) } + -- actor's time warped, so he is in stasis, + -- immune to further warps + return UseUp -- ** ParalyzeInWater @@ -1357,7 +1357,7 @@ m2 <- rollItemAspect freq depth case m2 of NoNewItem -> return UseDud -- e.g., unique already generated - NewItem itemKnownRaw itemFullRaw (kRaw, itRaw) -> do + NewItem _ itemKnownRaw itemFullRaw (kRaw, itRaw) -> do -- Avoid too many different item identifiers (one for each faction) -- for blasts or common item generating tiles. Conditions are -- allowed to be duplicated, because they provide really useful info @@ -1445,14 +1445,14 @@ effectDestroyItem execSfx ngroup kcopy store target grp = do tb <- getsState $ getActorBody target is <- allGroupItems store grp target - if | null is -> return UseDud - | otherwise -> do - execSfx - urs <- mapM (uncurry (dropCStoreItem True True store target tb kcopy)) - (take ngroup is) - return $! case urs of - [] -> UseDud -- there was no effects - _ -> maximum urs + if null is then return UseDud + else do + execSfx + urs <- mapM (uncurry (dropCStoreItem True True store target tb kcopy)) + (take ngroup is) + return $! case urs of + [] -> UseDud -- there was no effects + _ -> maximum urs -- | Drop a single actor's item (though possibly multiple copies). -- Note that if there are multiple copies, at most one explodes @@ -1630,13 +1630,13 @@ if | bproj tb || null is -> return UseDud | ngroup == maxBound && kcopy == maxBound && store `elem` [CStash, CEqp] - && fhasGender (gplayer fact) -- hero in Allure's decontamination chamber - && (cdiff curChalSer == 1 -- at lowest difficulty for its faction - && any (fhasUI . gplayer . snd) + && fhasGender (gkind fact) -- hero in Allure's decontamination chamber + && (cdiff curChalSer == 1 -- at lowest difficulty for its faction + && any (fhasUI . gkind . snd) (filter (\(fi, fa) -> isFriend fi fa (bfid tb)) (EM.assocs factionD)) || cdiff curChalSer == difficultyBound - && any (fhasUI . gplayer . snd) + && any (fhasUI . gkind . snd) (filter (\(fi, fa) -> isFoe fi fa (bfid tb)) (EM.assocs factionD))) -> {- @@ -1782,32 +1782,32 @@ (iid, ( ItemFull{ itemBase, itemKindId, itemKind , itemDisco=ItemDiscoFull itemAspect } , (_, itemTimer) )) : _ -> - if | IA.kmConst $ getKindMean itemKindId coItemSpeedup -> do - execSfxAtomic $ SfxMsgFid (bfid tb) SfxRerollNotRandom - return UseId - | otherwise -> do - let c = CActor target cstore - kit = (1, take 1 itemTimer) -- prevent micromanagement - freq = pure (itemKindId, itemKind) - execSfx - identifyIid iid c itemKindId itemKind - execUpdAtomic $ UpdDestroyItem False iid itemBase kit c - totalDepth <- getsState stotalDepth - let roll100 :: Int -> m (ItemKnown, ItemFull) - roll100 n = do - -- Not only rerolled, but at highest depth possible, - -- resulting in highest potential for bonuses. - m2 <- rollItemAspect freq totalDepth - case m2 of - NoNewItem -> - error "effectRerollItem: can't create rerolled item" - NewItem itemKnown@(ItemKnown _ ar2 _) itemFull _ -> - if ar2 == itemAspect && n > 0 - then roll100 (n - 1) - else return (itemKnown, itemFull) - (itemKnown, itemFull) <- roll100 100 - void $ registerItem True (itemFull, kit) itemKnown c - return UseUp + if IA.kmConst $ getKindMean itemKindId coItemSpeedup then do + execSfxAtomic $ SfxMsgFid (bfid tb) SfxRerollNotRandom + return UseId + else do + let c = CActor target cstore + kit = (1, take 1 itemTimer) -- prevent micromanagement + freq = pure (IK.HORROR, itemKindId, itemKind) + execSfx + identifyIid iid c itemKindId itemKind + execUpdAtomic $ UpdDestroyItem False iid itemBase kit c + totalDepth <- getsState stotalDepth + let roll100 :: Int -> m (ItemKnown, ItemFull) + roll100 n = do + -- Not only rerolled, but at highest depth possible, + -- resulting in highest potential for bonuses. + m2 <- rollItemAspect freq totalDepth + case m2 of + NoNewItem -> + error "effectRerollItem: can't create rerolled item" + NewItem _ itemKnown@(ItemKnown _ ar2 _) itemFull _ -> + if ar2 == itemAspect && n > 0 + then roll100 (n - 1) + else return (itemKnown, itemFull) + (itemKnown, itemFull) <- roll100 100 + void $ registerItem True (itemFull, kit) itemKnown c + return UseUp _ -> error "effectRerollItem: server ignorant about an item" -- ** DupItem @@ -1939,7 +1939,7 @@ effectHasLoot (IK.OrEffect eff1 eff2) = effectHasLoot eff1 || effectHasLoot eff2 effectHasLoot (IK.SeqEffect effs) = - or $ map effectHasLoot effs + any effectHasLoot effs effectHasLoot (IK.When _ eff) = effectHasLoot eff effectHasLoot (IK.Unless _ eff) = effectHasLoot eff effectHasLoot (IK.IfThenElse _ eff1 eff2) = @@ -2054,7 +2054,7 @@ execSfxAtomic $ SfxMsgFid (bfid tb) $ SfxBracedImmune target return UseUp -- waste it to prevent repeated throwing at immobile actors else do - case bla eps (bpos tb) fpos of + case bresenhamsLineAlgorithm eps (bpos tb) fpos of Nothing -> error $ "" `showFailure` (fpos, tb) Just [] -> error $ "projecting from the edge of level" `showFailure` (fpos, tb) @@ -2187,7 +2187,7 @@ sb <- getsState $ getActorBody source curChalSer <- getsServer $ scurChalSer . soptions fact <- getsState $ (EM.! bfid sb) . sfactionD - if cgoods curChalSer && fhasUI (gplayer fact) then do + if cgoods curChalSer && fhasUI (gkind fact) then do execSfxAtomic $ SfxMsgFid (bfid sb) SfxReadyGoods return UseId else effectAndEffectSem recursiveCall eff1 eff2 @@ -2216,7 +2216,7 @@ fact <- getsState $ (EM.! fid) . sfactionD case eff1 of IK.AndEffect IK.ConsumeItems{} _ | cgoods curChalSer - && fhasUI (gplayer fact) -> do + && fhasUI (gkind fact) -> do -- Stop forbidden crafting ASAP to avoid spam. execSfxAtomic $ SfxMsgFid fid SfxReadyGoods return UseId diff --git a/engine-src/Game/LambdaHack/Server/HandleRequestM.hs b/engine-src/Game/LambdaHack/Server/HandleRequestM.hs --- a/engine-src/Game/LambdaHack/Server/HandleRequestM.hs +++ b/engine-src/Game/LambdaHack/Server/HandleRequestM.hs @@ -49,6 +49,7 @@ import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Types import Game.LambdaHack.Common.Vector +import Game.LambdaHack.Content.FactionKind import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind import qualified Game.LambdaHack.Content.TileKind as TK @@ -154,7 +155,7 @@ execUpdAtomic $ UpdWaitActor aid (WWait n) WWatch WSleep -> if mwait /= Just False -- lurk can't wake up regardless; too short - && (not (isJust mwait) -- not a wait + && (isNothing mwait -- not a wait || uneasy -- spooked || not (deltaBenign $ bhpDelta b)) -- any HP lost then execUpdAtomic $ UpdWaitActor aid WSleep WWake @@ -243,31 +244,31 @@ !_A2 = assert (bfid bPre == fid `blame` "client tries to move other faction actors" `swith` (aidNew, bPre, fid, fact)) () - let (autoDun, _) = autoDungeonLevel fact + let banned = bannedPointmanSwitchBetweenLevels fact arena <- case mleader of Nothing -> return $! blid bPre Just leader -> do b <- getsState $ getActorBody leader return $! blid b - if | blid bPre /= arena && autoDun -> - execFailure aidNew ReqWait{-hack-} NoChangeDunLeader - | otherwise -> do - execUpdAtomic $ UpdLeadFaction fid mleader (Just aidNew) - -- We exchange times of the old and new leader. - -- This permits an abuse, because a slow tank can be moved fast - -- by alternating between it and many fast actors (until all of them - -- get slowed down by this and none remain). But at least the sum - -- of all times of a faction is conserved. And we avoid double moves - -- against the UI player caused by his leader changes. There may still - -- happen double moves caused by AI leader changes, but that's rare. - -- The flip side is the possibility of multi-moves of the UI player - -- as in the case of the tank. - -- Warning: when the action is performed on the server, - -- the time of the actor is different than when client prepared that - -- action, so any client checks involving time should discount this. - case mleader of - Just aidOld | aidOld /= aidNew -> swapTime aidOld aidNew - _ -> return () + if blid bPre /= arena && banned -- catch the cheating clients + then execFailure aidNew ReqWait{-hack-} NoChangeDunLeader + else do + execUpdAtomic $ UpdLeadFaction fid mleader (Just aidNew) + -- We exchange times of the old and new leader. + -- This permits an abuse, because a slow tank can be moved fast + -- by alternating between it and many fast actors (until all of them + -- get slowed down by this and none remain). But at least the sum + -- of all times of a faction is conserved. And we avoid double moves + -- against the UI player caused by his leader changes. There may still + -- happen double moves caused by AI leader changes, but that's rare. + -- The flip side is the possibility of multi-moves of the UI player + -- as in the case of the tank. + -- Warning: when the action is performed on the server, + -- the time of the actor is different than when client prepared that + -- action, so any client checks involving time should discount this. + case mleader of + Just aidOld | aidOld /= aidNew -> swapTime aidOld aidNew + _ -> return () -- * ReqMove @@ -357,7 +358,7 @@ -- unless it's large enough or tends to explode (fragile and lobable). -- The actor in the way is visible or not; server sees him always. -- Below the only weapon (the only item) of projectiles is picked. - mweapon <- pickWeaponServer source + mweapon <- pickWeaponServer source target case mweapon of Just (wp, cstore) | abInSkill Ability.SkMelee -> reqMeleeChecked voluntary source target wp cstore @@ -629,7 +630,7 @@ -- If the character melees instead, the player can tell displace failed. -- As for the other failures, they are impossible and we don't -- verify here that they don't occur, for simplicity. - mweapon <- pickWeaponServer source + mweapon <- pickWeaponServer source target case mweapon of Just (wp, cstore) | abInSkill Ability.SkMelee -> reqMeleeChecked voluntary source target wp cstore @@ -854,20 +855,20 @@ else return False feats = TK.tfeature $ okind cotile serverTile tileActions = - mapMaybe (Tile.parseTileAction + mapMaybe (parseTileAction (bproj sb) (underFeet || blockedByItem) -- avoids AlterBlockItem embedKindList) feats groupWithFromAction action = case action of - Tile.WithAction grps _ | not bumping -> Just grps + WithAction grps _ | not bumping -> Just grps _ -> Nothing groupsToAlterWith = mapMaybe groupWithFromAction tileActions - processTileActions :: Maybe UseResult -> [Tile.TileAction] -> m Bool + processTileActions :: Maybe UseResult -> [TileAction] -> m Bool processTileActions museResult [] = return $! maybe False (/= UseDud) museResult processTileActions museResult (ta : rest) = case ta of - Tile.EmbedAction (iid, kit) -> + EmbedAction (iid, kit) -> -- Embeds are activated in the order in tile definition -- and never after the tile is changed. -- If any embedded item was present and processed, @@ -898,7 +899,7 @@ processTileActions (Just $ max useResult triggered) rest -- max means that even one activated embed is enough -- to alter terrain in a future action - Tile.ToAction tgroup -> assert (not (bproj sb)) $ + ToAction tgroup -> assert (not (bproj sb)) $ -- @parseTileAction@ ensures the above assertion -- so that projectiles never cause normal transitions and, -- e.g., mists douse fires or two flames thrown, first ignites, @@ -909,7 +910,7 @@ changeTo tgroup return True else processTileActions museResult rest - Tile.WithAction grps tgroup -> do + WithAction grps tgroup -> do -- Note that there is no skill check if the source actors -- is a projectile. Permission is conveyed in @ProjYes@ instead. groundBag2 <- getsState $ getBodyStoreBag sb CGround @@ -1052,7 +1053,7 @@ -- The effect of dropping previous items from this series may have -- increased or decreased the number of this item. let k = min kOld $ fst $ EM.findWithDefault (0, []) iid bagFrom - let !_A = if absentPermitted then True else k == kOld + let !_A = absentPermitted || k == kOld if | absentPermitted && k == 0 -> return () | k < 1 || fromCStore == toCStore -> execFailure aid req ItemNothing @@ -1109,7 +1110,7 @@ fact <- getsState $ (EM.! bfid b) . sfactionD actorMaxSk <- getsState $ getActorMaxSkills source let calmE = calmEnough b actorMaxSk - if | ckeeper curChalSer && fhasUI (gplayer fact) -> + if | ckeeper curChalSer && fhasUI (gkind fact) -> execFailure source req ProjectFinderKeeper | cstore == CEqp && not calmE -> execFailure source req ItemNotCalm | otherwise -> do @@ -1154,7 +1155,7 @@ reqGameRestart aid groupName scurChalSer = do noConfirmsGame <- isNoConfirmsGame factionD <- getsState sfactionD - let fidsUI = map fst $ filter (\(_, fact) -> fhasUI (gplayer fact)) + let fidsUI = map fst $ filter (\(_, fact) -> fhasUI (gkind fact)) (EM.assocs factionD) -- This call to `revealItems` and `revealPerception` is really needed, -- because the other happens only at natural game conclusion, @@ -1237,7 +1238,7 @@ reqDoctrine :: MonadServerAtomic m => FactionId -> Ability.Doctrine -> m () reqDoctrine fid toT = do - fromT <- getsState $ fdoctrine . gplayer . (EM.! fid) . sfactionD + fromT <- getsState $ gdoctrine . (EM.! fid) . sfactionD execUpdAtomic $ UpdDoctrineFaction fid toT fromT -- * ReqAutomate diff --git a/engine-src/Game/LambdaHack/Server/ItemM.hs b/engine-src/Game/LambdaHack/Server/ItemM.hs --- a/engine-src/Game/LambdaHack/Server/ItemM.hs +++ b/engine-src/Game/LambdaHack/Server/ItemM.hs @@ -139,7 +139,7 @@ computeRndTimeout :: Time -> ItemFull -> Rnd (Maybe ItemTimer) computeRndTimeout localTime ItemFull{itemDisco=ItemDiscoFull itemAspect} = do let t = IA.aTimeout itemAspect - if t /= 0 then do + if t > 0 then do rndT <- randomR0 t let rndTurns = timeDeltaScale (Delta timeTurn) (t + rndT) return $ Just $ createItemTimer localTime rndTurns @@ -204,7 +204,8 @@ prepareItemKind :: MonadServerAtomic m => Int -> Dice.AbsDepth -> Freqs ItemKind - -> m (Frequency (ContentId IK.ItemKind, ItemKind)) + -> m (Frequency + (GroupName ItemKind, ContentId IK.ItemKind, ItemKind)) prepareItemKind lvlSpawned ldepth itemFreq = do cops <- getsState scops uniqueSet <- getsServer suniqueSet @@ -212,7 +213,9 @@ return $! newItemKind cops uniqueSet itemFreq ldepth totalDepth lvlSpawned rollItemAspect :: MonadServerAtomic m - => Frequency (ContentId IK.ItemKind, ItemKind) -> Dice.AbsDepth + => Frequency + (GroupName ItemKind, ContentId IK.ItemKind, ItemKind) + -> Dice.AbsDepth -> m NewItem rollItemAspect freq ldepth = do cops <- getsState scops @@ -221,7 +224,7 @@ totalDepth <- getsState stotalDepth m2 <- rndToAction $ newItem cops freq flavour discoRev ldepth totalDepth case m2 of - NewItem (ItemKnown _ arItem _) ItemFull{itemKindId} _ -> do + NewItem _ (ItemKnown _ arItem _) ItemFull{itemKindId} _ -> do when (IA.checkFlag Ability.Unique arItem) $ modifyServer $ \ser -> ser {suniqueSet = ES.insert itemKindId (suniqueSet ser)} @@ -231,7 +234,8 @@ rollAndRegisterItem :: MonadServerAtomic m => Bool -> Dice.AbsDepth - -> Frequency (ContentId IK.ItemKind, ItemKind) + -> Frequency + (GroupName ItemKind, ContentId IK.ItemKind, ItemKind) -> Container -> Maybe Int -> m (Maybe (ItemId, ItemFullKit)) @@ -239,7 +243,7 @@ m2 <- rollItemAspect freq ldepth case m2 of NoNewItem -> return Nothing - NewItem itemKnown itemFull kit -> do + NewItem _ itemKnown itemFull kit -> do let f k = if k == 1 && null (snd kit) then quantSingle else (k, snd kit) @@ -263,15 +267,15 @@ Level{lfloor} <- getLevel lid -- Don't generate items around initial actors or in bunches. let distAndNotFloor !p _ = - let f !k b = chessDist p k > 4 && b - in p `EM.notMember` lfloor && foldr f True alPos - mpos <- rndToAction $ findPosTry2 20 lvl + let f !k = chessDist p k > 4 + in p `EM.notMember` lfloor && all f alPos + mpos <- rndToAction $ findPosTry2 10 lvl (\_ !t -> Tile.isWalkable coTileSpeedup t && not (Tile.isNoItem coTileSpeedup t)) [ \_ !t -> Tile.isVeryOftenItem coTileSpeedup t , \_ !t -> Tile.isCommonItem coTileSpeedup t ] distAndNotFloor - [distAndNotFloor, distAndNotFloor] + (replicate 10 distAndNotFloor) case mpos of Just pos -> do createCaveItem pos lid diff --git a/engine-src/Game/LambdaHack/Server/ItemRev.hs b/engine-src/Game/LambdaHack/Server/ItemRev.hs --- a/engine-src/Game/LambdaHack/Server/ItemRev.hs +++ b/engine-src/Game/LambdaHack/Server/ItemRev.hs @@ -56,7 +56,7 @@ instance Hashable ItemKnown data NewItem = - NewItem ItemKnown ItemFull ItemQuant + NewItem (GroupName ItemKind) ItemKnown ItemFull ItemQuant | NoNewItem -- | Reverse item map, for item creation, to keep items and item identifiers @@ -85,7 +85,7 @@ -- | Roll an item kind based on given @Freqs@ and kind rarities newItemKind :: COps -> UniqueSet -> Freqs ItemKind -> Dice.AbsDepth -> Dice.AbsDepth -> Int - -> Frequency (ContentId IK.ItemKind, ItemKind) + -> Frequency (GroupName ItemKind, ContentId IK.ItemKind, ItemKind) newItemKind COps{coitem, coItemSpeedup} uniqueSet itemFreq (Dice.AbsDepth ldepth) (Dice.AbsDepth totalDepth) lvlSpawned = assert (any (\(_, n) -> n > 0) itemFreq) $ @@ -94,8 +94,8 @@ -- each 10 spawns adds 5 depth. let numSpawnedCoeff = max 0 $ lvlSpawned `div` 2 - 5 ldSpawned = ldepth + numSpawnedCoeff - f _ acc _ ik _ | ik `ES.member` uniqueSet = acc - f !q !acc !p !ik !kind = + f _ _ acc _ ik _ | ik `ES.member` uniqueSet = acc + f !itemGroup !q !acc !p !ik !kind = -- Don't consider lvlSpawned for uniques, except those that have -- @Unique@ under @Odds@. let ld = if IA.checkFlag Ability.Unique @@ -104,14 +104,15 @@ else ldSpawned rarity = linearInterpolation ld totalDepth (IK.irarity kind) !fr = q * p * rarity - in (fr, (ik, kind)) : acc - g (!itemGroup, !q) = ofoldlGroup' coitem itemGroup (f q) [] + in (fr, (itemGroup, ik, kind)) : acc + g (!itemGroup, !q) = ofoldlGroup' coitem itemGroup (f itemGroup q) [] freqDepth = concatMap g itemFreq in toFreq "newItemKind" freqDepth -- | Given item kind frequency, roll item kind, generate item aspects -- based on level and put together the full item data set. -newItem :: COps -> Frequency (ContentId IK.ItemKind, ItemKind) +newItem :: COps + -> Frequency (GroupName ItemKind, ContentId IK.ItemKind, ItemKind) -> FlavourMap -> DiscoveryKindRev -> Dice.AbsDepth -> Dice.AbsDepth -> Rnd NewItem @@ -119,7 +120,7 @@ if nullFreq freq then return NoNewItem -- e.g., rare tile has a unique embed, only first time else do - (itemKindId, itemKind) <- frequency freq + (itemGroup, itemKindId, itemKind) <- frequency freq -- Number of new items/actors unaffected by number of spawned actors. itemN <- castDice levelDepth totalDepth (IK.icount itemKind) arItem <- IA.rollAspectRecord (IK.iaspects itemKind) levelDepth totalDepth @@ -136,7 +137,7 @@ itemQuant = if itemK == 1 && null itemTimer then quantSingle else (itemK, itemTimer) - return $! NewItem itemKnown itemFull itemQuant + return $! NewItem itemGroup itemKnown itemFull itemQuant -- | The reverse map to @DiscoveryKind@, needed for item creation. -- This is total and never changes, hence implemented as vector. @@ -158,10 +159,10 @@ (olength coitem) ixs let udiscoRev = U.fromListN (olength coitem) shuffled - f :: (ContentId ItemKind, Word16) -> (ItemKindIx, ContentId ItemKind) - f (ik, ikx) = (toItemKindIx ikx, ik) + f :: ContentId ItemKind -> Word16 -> (ItemKindIx, ContentId ItemKind) + f ik ikx = (toItemKindIx ikx, ik) -- Not @fromDistinctAscList@, because it's the reverse map. - discoS = EM.fromList $ map f $ zip [toEnum 0 ..] $ U.toList udiscoRev + discoS = EM.fromList $ zipWith f [toEnum 0 ..] $ U.toList udiscoRev return (discoS, DiscoveryKindRev udiscoRev) -- | Keep in a vector the information that is retained from playthrough diff --git a/engine-src/Game/LambdaHack/Server/LoopM.hs b/engine-src/Game/LambdaHack/Server/LoopM.hs --- a/engine-src/Game/LambdaHack/Server/LoopM.hs +++ b/engine-src/Game/LambdaHack/Server/LoopM.hs @@ -36,6 +36,7 @@ import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Types import Game.LambdaHack.Common.Vector +import Game.LambdaHack.Content.FactionKind import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind import Game.LambdaHack.Content.RuleKind @@ -66,7 +67,7 @@ modifyServer $ \ser -> ser { soptionsNxt = serverOptions , soptions = serverOptions } cops <- getsState scops - let updConn = updateConn executorClient + let updConn startsNewGame = updateConn $ executorClient startsNewGame restored <- tryRestore case restored of Just (sRaw, ser) | not $ snewGameSer serverOptions -> do -- a restored game @@ -80,7 +81,7 @@ $ sclientStates ser EM.! fid in execUpdAtomicFidCatch fid cmd mapM_ (void <$> f) $ EM.keys factionD - updConn + updConn False initPer pers <- getsServer sperFid let clear = const emptyPer @@ -105,11 +106,11 @@ modifyServer $ \ser -> ser { soptionsNxt = optionsBarRngs , soptions = optionsBarRngs } execUpdAtomic $ UpdRestartServer s - updConn + updConn True initPer reinitGame factionDold writeSaveAll False False - loopUpd updConn + loopUpd $ updConn True factionArena :: MonadStateRead m => Faction -> m (Maybe LevelId) factionArena fact = case gleader fact of @@ -229,14 +230,18 @@ endOrLoop loopUpdConn (restartGame updConn loopUpdConn) loopUpdConn = do factionD <- getsState sfactionD - -- Start handling actors with the single UI faction (positive ID), + -- Start handling actors with the single UI faction, -- to safely save/exit. Note that this hack fails if there are many UI -- factions (when we reenable multiplayer). Then players will request -- save&exit and others will vote on it and it will happen -- after the clip has ended, not at the start. -- Note that at most a single actor with a time-consuming action -- is processed per faction, so it's fair, but many loops are needed. - mapM_ handleFid $ EM.toDescList factionD + let hasUI (_, fact) = fhasUI (gkind fact) + (factionUI, factionsRest) = case break hasUI $ EM.assocs factionD of + (noUI1, ui : noUI2) -> (ui, noUI1 ++ noUI2) + _ -> error "no UI faction in the game" + mapM_ handleFid $ factionUI : factionsRest breakASAP <- getsServer sbreakASAP breakLoop <- getsServer sbreakLoop if breakASAP || breakLoop @@ -295,15 +300,16 @@ -- Perform periodic dungeon maintenance. when (clipN `mod` rleadLevelClips corule == 0) leadLevelSwitch case clipN `mod` clipsInTurn of - 2 -> + 0 -> + -- Spawn monsters at most once per 3 turns. + when (clipN `mod` (3 * clipsInTurn) == 0) + spawnMonster + 4 -> -- Periodic activation only once per turn, for speed, -- but on all active arenas. Calm updates and domination -- happen there as well. Once per turn is too rare for accurate -- expiration of short conditions, e.g., 1-turn haste. TODO. applyPeriodicLevel - 4 -> - -- Spawn monsters at most once per turn. - spawnMonster _ -> return () -- @applyPeriodicLevel@ might have, e.g., dominated actors, ending the game. -- It could not have unended the game, though. @@ -345,7 +351,7 @@ Nothing -> return False Just (hiImpressionFid, hiImpressionK) -> do fact <- getsState $ (EM.! bfid b) . sfactionD - if fleaderMode (gplayer fact) /= Nothing + if fhasPointman (gkind fact) -- animals/robots/human drones never Calm-dominated || hiImpressionK >= 10 -- unless very high impression, e.g., in a dominated hero @@ -498,7 +504,7 @@ case btrajectory b1 of Just (d : lv, speed) -> do let tpos = bpos b1 `shift` d -- target position - if | Tile.isWalkable coTileSpeedup $ lvl `at` tpos -> do + if Tile.isWalkable coTileSpeedup $ lvl `at` tpos then do -- Hit will clear trajectories in @reqMelee@, -- so no need to do that here. execUpdAtomic $ UpdTrajectory aid (btrajectory b1) (Just (lv, speed)) @@ -519,7 +525,7 @@ if null lv then reqDisp target else reqMoveHit (Just _, _) -> reqMoveHit -- can't displace multiple | otherwise -> reqMoveHit -- if not occupied, just move - | otherwise -> do + else do -- Will be removed from @strajTime@ in recursive call -- to @handleTrajectories@. unless (bproj b1) $ @@ -610,17 +616,16 @@ breakLoop <- getsServer sbreakLoop let mleader = gleader fact aidIsLeader = mleader == Just aid - mainUIactor = fhasUI (gplayer fact) - && (aidIsLeader - || fleaderMode (gplayer fact) == Nothing) + mainUIactor = fhasUI (gkind fact) + && (aidIsLeader || not (fhasPointman (gkind fact))) -- Checking @breakLoop@, to avoid doubly setting faction status to Camping -- in case AI-controlled UI client asks to exit game at exactly -- the same moment as natural game over was detected. - mainUIunderAI = mainUIactor && isAIFact fact && not breakLoop + mainUIunderAI = mainUIactor && gunderAI fact && not breakLoop when mainUIunderAI $ handleUIunderAI side aid factNew <- getsState $ (EM.! side) . sfactionD - let doQueryAI = not mainUIactor || isAIFact factNew + let doQueryAI = not mainUIactor || gunderAI factNew breakASAP <- getsServer sbreakASAP -- If breaking out of the game loop, pretend there was a non-wait move. -- we don't need additionally to check @sbreakLoop@, because it occurs alone diff --git a/engine-src/Game/LambdaHack/Server/MonadServer.hs b/engine-src/Game/LambdaHack/Server/MonadServer.hs --- a/engine-src/Game/LambdaHack/Server/MonadServer.hs +++ b/engine-src/Game/LambdaHack/Server/MonadServer.hs @@ -45,7 +45,7 @@ import qualified Game.LambdaHack.Common.Save as Save import Game.LambdaHack.Common.State import Game.LambdaHack.Common.Types -import Game.LambdaHack.Content.ModeKind +import Game.LambdaHack.Content.FactionKind import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Core.Random import Game.LambdaHack.Server.ServerOptions @@ -92,6 +92,7 @@ T.hPutStr stdout $! t <> "\n" -- hPutStrLn not atomic enough hFlush stdout +-- No moving savefiles aside, to debug more easily. debugPossiblyPrintAndExit :: MonadServer m => Text -> m () debugPossiblyPrintAndExit t = do debug <- getsServer $ sdbgMsgSer . soptions @@ -123,9 +124,9 @@ restoreScore COps{corule} = do benchmark <- getsServer $ sbenchmark . sclientOptions . soptions mscore <- if benchmark then return Nothing else do - let scoresFile = rscoresFile corule + let scoresFileName = rscoresFileName corule dataDir <- liftIO appDataDir - let path bkp = dataDir bkp <> scoresFile + let path bkp = dataDir bkp <> scoresFileName configExists <- liftIO $ doesFileExist (path "") res <- liftIO $ Ex.try $ if configExists then do @@ -160,7 +161,7 @@ registerScore status fid = do cops@COps{corule} <- getsState scops total <- getsState $ snd . calculateTotal fid - let scoresFile = rscoresFile corule + let scoresFileName = rscoresFileName corule dataDir <- liftIO appDataDir -- Re-read the table in case it's changed by a concurrent game. scoreDict <- restoreScore cops @@ -175,11 +176,11 @@ noConfirmsGame <- isNoConfirmsGame sbandSpawned <- getsServer sbandSpawned let fact = factionD EM.! fid - path = dataDir scoresFile + path = dataDir scoresFileName outputScore (worthMentioning, (ntable, pos)) = -- If testing or fooling around, dump instead of registering. -- In particular don't register score for the auto-* scenarios. - if bench || noConfirmsGame || isAIFact fact then + if bench || noConfirmsGame || gunderAI fact then debugPossiblyPrint $ T.intercalate "\n" $ HighScore.showScore tz pos (HighScore.getRecord pos ntable) ++ [" Spawned groups:" @@ -188,9 +189,6 @@ let nScoreDict = EM.insert gameModeId ntable scoreDict in when worthMentioning $ liftIO $ encodeEOF path Self.version (nScoreDict :: HighScore.ScoreDict) - chal | fhasUI $ gplayer fact = curChalSer - | otherwise = curChalSer - {cdiff = difficultyInverse (cdiff curChalSer)} theirVic (fi, fa) | isFoe fid fact fi && not (isHorrorFact fa) = Just $ gvictims fa | otherwise = Nothing @@ -200,10 +198,10 @@ ourVictims = EM.unionsWith (+) $ mapMaybe ourVic $ EM.assocs factionD table = HighScore.getTable gameModeId scoreDict registeredScore = - HighScore.register table total dungeonTotal time status date chal + HighScore.register table total dungeonTotal time status date curChalSer (T.unwords $ tail $ T.words $ gname fact) ourVictims theirVictims - (fhiCondPoly $ gplayer fact) + (fhiCondPoly $ gkind fact) outputScore registeredScore -- | Invoke pseudo-random computation with the generator kept in the state. diff --git a/engine-src/Game/LambdaHack/Server/PeriodicM.hs b/engine-src/Game/LambdaHack/Server/PeriodicM.hs --- a/engine-src/Game/LambdaHack/Server/PeriodicM.hs +++ b/engine-src/Game/LambdaHack/Server/PeriodicM.hs @@ -38,6 +38,7 @@ import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Types import qualified Game.LambdaHack.Content.CaveKind as CK +import Game.LambdaHack.Content.FactionKind import Game.LambdaHack.Content.ItemKind (ItemKind) import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind @@ -63,7 +64,7 @@ -- Do this on only one of the arenas to prevent micromanagement, -- e.g., spreading leaders across levels to bump monster generation. arena <- rndToAction $ oneOf $ ES.elems arenas - Level{lkind, ldepth, lbig} <- getLevel arena + Level{lkind, ldepth, lbig, ltime=localTime} <- getLevel arena let ck = okind cocave lkind if | CK.cactorCoeff ck == 0 || null (CK.cactorFreq ck) -> return () | EM.size lbig >= 300 -> -- probably not so rare, but debug anyway @@ -77,9 +78,9 @@ monsterGenChance ldepth totalDepth lvlSpawned (CK.cactorCoeff ck) million = 1000000 k <- rndToAction $ randomR (1, million) - when (k <= perMillion) $ do - let numToSpawn | 10 * k <= perMillion = 3 - | 4 * k <= perMillion = 2 + when (k <= perMillion && localTime > timeTurn) $ do + let numToSpawn | 25 * k <= perMillion = 3 + | 10 * k <= perMillion = 2 | otherwise = 1 alt Nothing = Just 1 alt (Just n) = Just $ n + 1 @@ -88,9 +89,8 @@ $ snumSpawned ser , sbandSpawned = IM.alter alt numToSpawn $ sbandSpawned ser } - localTime <- getsState $ getLocalTime arena - void $ addManyActors False lvlSpawned (CK.cactorFreq ck) arena localTime - Nothing numToSpawn + void $ addManyActors False lvlSpawned (CK.cactorFreq ck) arena + localTime Nothing numToSpawn addAnyActor :: MonadServerAtomic m => Bool -> Int -> Freqs ItemKind -> LevelId -> Time -> Maybe Point @@ -109,32 +109,37 @@ "Server: addAnyActor: trunk failed to roll" `showFailure` (summoned, lvlSpawned, actorFreq, freq, lid, time, mpos) return Nothing - NewItem itemKnownRaw itemFullRaw itemQuant -> do - (fid, _) <- rndToAction $ oneOf $ - possibleActorFactions (itemKind itemFullRaw) factionD - pers <- getsServer sperFid - let allPers = ES.unions $ map (totalVisible . (EM.! lid)) - $ EM.elems $ EM.delete fid pers -- expensive :( - -- Checking skill would be more accurate, but skills can be - -- inside organs, equipment, condition organs, created organs, etc. - freqNames = map fst $ IK.ifreq $ itemKind itemFullRaw - mobile = IK.MOBILE `elem` freqNames - aquatic = IK.AQUATIC `elem` freqNames - mrolledPos <- case mpos of - Just{} -> return mpos - Nothing -> do - rollPos <- - getsState $ rollSpawnPos cops allPers mobile aquatic lid lvl fid - rndToAction rollPos - case mrolledPos of - Just pos -> - Just . (\aid -> (aid, pos)) - <$> registerActor summoned itemKnownRaw (itemFullRaw, itemQuant) - fid pos lid time - Nothing -> do - debugPossiblyPrint - "Server: addAnyActor: failed to find any free position" - return Nothing + NewItem itemGroup itemKnownRaw itemFullRaw itemQuant -> do + (fid, _) <- rndToAction $ frequency $ + possibleActorFactions [itemGroup] (itemKind itemFullRaw) + factionD + let fact = factionD EM.! fid + if isJust $ gquit fact + then return Nothing -- the faction that spawns the monster is dead + else do + pers <- getsServer sperFid + let allPers = ES.unions $ map (totalVisible . (EM.! lid)) + $ EM.elems $ EM.delete fid pers -- expensive :( + -- Checking skill would be more accurate, but skills can be + -- inside organs, equipment, condition organs, created organs, etc. + freqNames = map fst $ IK.ifreq $ itemKind itemFullRaw + mobile = IK.MOBILE `elem` freqNames + aquatic = IK.AQUATIC `elem` freqNames + mrolledPos <- case mpos of + Just{} -> return mpos + Nothing -> do + rollPos <- + getsState $ rollSpawnPos cops allPers mobile aquatic lid lvl fid + rndToAction rollPos + case mrolledPos of + Just pos -> + Just . (\aid -> (aid, pos)) + <$> registerActor summoned itemKnownRaw (itemFullRaw, itemQuant) + fid pos lid time + Nothing -> do + debugPossiblyPrint + "Server: addAnyActor: failed to find any free position" + return Nothing addManyActors :: MonadServerAtomic m => Bool -> Int -> Freqs ItemKind -> LevelId -> Time -> Maybe Point @@ -175,11 +180,20 @@ rollSpawnPos COps{coTileSpeedup} visible mobile aquatic lid lvl@Level{larea} fid s = do let inhabitants = foeRegularList fid lid s - nearInh !df !p = all (\ !b -> df $ chessDist (bpos b) p) inhabitants + nearInh !d !p = any (\ !b -> chessDist (bpos b) p < d) inhabitants + farInh !d !p = all (\ !b -> chessDist (bpos b) p > d) inhabitants + (_, xspan, yspan) = spanArea larea + averageSpan = (xspan + yspan) `div` 2 distantMiddle !d !p = chessDist p (middlePoint larea) < d + -- Don't spawn very far from foes, to keep the player entertained, + -- but not too close, so that standing on positions with better + -- visibility does not influence the spawn places too often, + -- to avoid unnatural position micromanagement using AI predictability. condList | mobile = - [ nearInh (<= 50) -- don't spawn very far from foes - , nearInh (<= 100) + [ \p -> nearInh (max 15 $ averageSpan `div` 2) p + && farInh 10 p + , \p -> nearInh (max 15 $ 2 * averageSpan `div` 3) p + && farInh 5 p ] | otherwise = [ distantMiddle 8 @@ -197,12 +211,12 @@ && not (occupiedBigLvl p lvl) && not (occupiedProjLvl p lvl) ) (map (\f p _ -> f p) condList) - (\ !p t -> nearInh (> 4) p -- otherwise actors in dark rooms swarmed + (\ !p t -> farInh 3 p -- otherwise actors in dark rooms swarmed && not (p `ES.member` visible) -- visibility and plausibility && (not aquatic || Tile.isAquatic coTileSpeedup t)) - [ \ !p _ -> nearInh (> 3) p + [ \ !p _ -> farInh 3 p && not (p `ES.member` visible) - , \ !p _ -> nearInh (> 2) p -- otherwise actors hit on entering level + , \ !p _ -> farInh 2 p -- otherwise actors hit on entering level && not (p `ES.member` visible) , \ !p _ -> not (p `ES.member` visible) ] @@ -321,11 +335,19 @@ leadLevelSwitch = do COps{cocave} <- getsState scops factionD <- getsState sfactionD - let canSwitch fact = fst (autoDungeonLevel fact) - -- a hack to help AI, until AI client can switch levels - || funderAI (gplayer fact) - && isJust (fleaderMode (gplayer fact)) - flipFaction (_, fact) | not $ canSwitch fact = return () + -- Leader switching between levels can be done by the client + -- (e.g,. UI client of the human) or by the server + -- (the frequency of leader level switching done by the server + -- is controlled by @RuleKind.rleadLevelClips@). Regardless, the server + -- alwayw does a subset of the switching, e.g., when the old leader dies + -- and no other actor of the faction resides on his level. + -- Here we check if the server is permitted to handle the mundane cases. + let serverMaySwitch fact = + bannedPointmanSwitchBetweenLevels fact + -- client banned from switching, so the sever has to step in + || gunderAI fact + -- a hack to help AI, until AI client can switch levels + flipFaction (_, fact) | not $ serverMaySwitch fact = return () flipFaction (fid, fact) = case gleader fact of Nothing -> return () @@ -351,7 +373,7 @@ , let allSeen = lexpl lvl <= lseen lvl || CK.cactorCoeff (okind cocave $ lkind lvl) > 150 - && not (fhasGender $ gplayer fact) + && not (fhasGender $ gkind fact) ] (lvlsSeen, lvlsNotSeen) = partition (fst . snd) lvlsRaw -- Monster AI changes leadership mostly to move from level @@ -406,7 +428,7 @@ canHelpMelee = not leaderStuck && length oursCloseMelee >= 2 - && length foesClose >= 1 + && not (null foesClose) && not (all (\b -> any (adjacent (bpos b) . bpos) foes) oursCloseMelee) unless (closeToEnemyStash || canHelpMelee || null freqList) $ do diff --git a/engine-src/Game/LambdaHack/Server/ProtocolM.hs b/engine-src/Game/LambdaHack/Server/ProtocolM.hs --- a/engine-src/Game/LambdaHack/Server/ProtocolM.hs +++ b/engine-src/Game/LambdaHack/Server/ProtocolM.hs @@ -5,11 +5,11 @@ -- * The server-client communication monad , MonadServerComm ( getsDict -- exposed only to be implemented, not used - , modifyDict -- exposed only to be implemented, not used + , putDict -- exposed only to be implemented, not used , liftIO -- exposed only to be implemented, not used ) -- * Protocol - , putDict, sendUpdate, sendUpdateCheck, sendUpdNoState + , sendUpdate, sendUpdateCheck, sendUpdNoState , sendSfx, sendQueryAI, sendQueryUI -- * Assorted , killAllClients, childrenServer, updateConn, tryRestore @@ -26,7 +26,7 @@ import Control.Concurrent import Control.Concurrent.Async import qualified Data.EnumMap.Strict as EM -import Data.Key (mapWithKeyM, mapWithKeyM_) +import Data.Key (mapWithKeyM_) import System.FilePath import System.IO.Unsafe (unsafePerformIO) @@ -42,7 +42,7 @@ import Game.LambdaHack.Common.State import Game.LambdaHack.Common.Thread import Game.LambdaHack.Common.Types -import Game.LambdaHack.Content.ModeKind +import Game.LambdaHack.Content.FactionKind import Game.LambdaHack.Content.RuleKind import Game.LambdaHack.Server.DebugM import Game.LambdaHack.Server.MonadServer hiding (liftIO) @@ -81,16 +81,13 @@ -- | The server monad with the ability to communicate with clients. class MonadServer m => MonadServerComm m where - getsDict :: (ConnServerDict -> a) -> m a - modifyDict :: (ConnServerDict -> ConnServerDict) -> m () - liftIO :: IO a -> m a + getsDict :: (ConnServerDict -> a) -> m a + putDict :: ConnServerDict -> m () + liftIO :: IO a -> m a getDict :: MonadServerComm m => m ConnServerDict getDict = getsDict id -putDict :: MonadServerComm m => ConnServerDict -> m () -putDict s = modifyDict (const s) - -- | If the @AtomicFail@ conditions hold, send a command to client, -- otherwise do nothing. sendUpdate :: (MonadServerAtomic m, MonadServerComm m) @@ -175,7 +172,7 @@ -- Connect to clients in old or newly spawned threads -- that read and write directly to the channels. updateConn :: (MonadServerAtomic m, MonadServerComm m) - => (Bool -> FactionId -> ChanServer -> IO ()) + => (FactionId -> ChanServer -> IO ()) -> m () updateConn executorClient = do -- Prepare connections based on factions. @@ -184,36 +181,49 @@ mkChanServer fact = do responseS <- newQueue requestAIS <- newQueue - requestUIS <- if fhasUI $ gplayer fact - then Just <$> newQueue + requestUIS <- if fhasUI $ gkind fact + then assert (EM.null oldD) $ Just <$> newQueue else return Nothing - return $! ChanServer{..} - addConn :: FactionId -> Faction -> IO ChanServer - addConn fid fact = case EM.lookup fid oldD of - Just conns -> return conns -- share old conns and threads - Nothing | fromEnum fid < 0 -> mkChanServer fact - Nothing -> case filter (\(fidOld, _) -> fromEnum fidOld > 0) - $ EM.assocs oldD of - [] -> mkChanServer fact - (_, conns) : _ -> return conns -- re-use session to keep history + return ChanServer{..} + forkClient fid = forkChild childrenServer . executorClient fid factionD <- getsState sfactionD - d <- liftIO $ mapWithKeyM addConn factionD - let newD = d `EM.union` oldD -- never kill old clients - putDict newD - -- Spawn client threads. - let toSpawn = newD EM.\\ oldD - forkUI fid connS = - forkChild childrenServer $ executorClient True fid connS - forkAI fid connS = - forkChild childrenServer $ executorClient False fid connS - forkClient fid conn@ChanServer{requestUIS=Nothing} = - -- When a connection is reused, clients are not respawned, - -- even if UI status of a faction changes, but it works OK thanks to - -- UI faction clients distinguished by positive FactionId numbers. - forkAI fid conn - forkClient fid conn = when (EM.null oldD) $ - forkUI fid conn - liftIO $ mapWithKeyM_ forkClient toSpawn + if EM.null oldD then do + -- Easy case, nothing to recycle, frontend not spawned yet. + newD <- liftIO $ mapM mkChanServer factionD + putDict newD + liftIO $ mapWithKeyM_ forkClient newD + else do + -- Hard case, but we know there is exactly one UI connection in oldD, + -- so we can reuse it for any new UI faction (to keep history). + -- UI session (history in particular) is preserved even over game + -- save and reload. It gets saved with the savefile of the team + -- that is a UI faction and restored intact. However, when a new game + -- is started from commandline (@--newGame@), even if it's using the same + -- save prefix (@--savePrefix@), the session data is often lost. + -- AI factions don't care which client they use, so we don't always + -- preserve the old assignments either of factions or teams. + let -- Find the new UI faction. + (fidUI, _) = fromJust $ find (fhasUI . gkind . snd) $ EM.assocs factionD + -- Swap UI and AI connections around. + swappedD = case find (isJust . requestUIS . snd) + $ EM.assocs oldD of + Nothing -> error "updateConn: no UI connection found" + Just (fid, conn) -> + if fid == fidUI + then oldD -- UI connection at the same place; nothing to do + else let -- Move the AI connection that was at new UI faction spot, + -- to the freed old UI spot. + alt _ = EM.lookup fidUI oldD + in EM.alter alt fid $ EM.insert fidUI conn oldD + -- Add extra AI connections. + extraFacts = EM.filterWithKey (\fid _ -> EM.notMember fid swappedD) + factionD + extraD <- liftIO $ mapM mkChanServer extraFacts + let exclusiveUnion = EM.unionWith $ \_ _ -> error "forbidden duplicate" + newD = swappedD `exclusiveUnion` extraD + putDict newD + -- Spawn the extra AI client threads. + liftIO $ mapWithKeyM_ forkClient extraD tryRestore :: MonadServerComm m => m (Maybe (State, StateServer)) tryRestore = do @@ -225,7 +235,7 @@ fileName = prefix <> Save.saveNameSer corule res <- liftIO $ Save.restoreGame corule (sclientOptions soptions) fileName let cfgUIName = rcfgUIName corule - (configString, _) = rcfgUIDefault corule + (configText, _) = rcfgUIDefault corule dataDir <- liftIO appDataDir - liftIO $ tryWriteFile (dataDir cfgUIName) configString + liftIO $ tryWriteFile (dataDir cfgUIName) configText return $! res diff --git a/engine-src/Game/LambdaHack/Server/StartM.hs b/engine-src/Game/LambdaHack/Server/StartM.hs --- a/engine-src/Game/LambdaHack/Server/StartM.hs +++ b/engine-src/Game/LambdaHack/Server/StartM.hs @@ -15,12 +15,10 @@ import qualified Control.Monad.Trans.State.Strict as St import qualified Data.EnumMap.Strict as EM import qualified Data.EnumSet as ES -import qualified Data.IntMap.Strict as IM import Data.Key (mapWithKeyM_) import qualified Data.Map.Strict as M import qualified Data.Set as S import qualified Data.Text as T -import Data.Tuple (swap) import qualified NLP.Miniutter.English as MU import qualified System.Random.SplitMix32 as SM @@ -40,10 +38,12 @@ import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Types import qualified Game.LambdaHack.Content.CaveKind as CK +import Game.LambdaHack.Content.FactionKind import Game.LambdaHack.Content.ItemKind (ItemKind) import qualified Game.LambdaHack.Content.ItemKind as IK import Game.LambdaHack.Content.ModeKind import qualified Game.LambdaHack.Core.Dice as Dice +import Game.LambdaHack.Core.Frequency import Game.LambdaHack.Core.Random import qualified Game.LambdaHack.Definition.Ability as Ability import qualified Game.LambdaHack.Definition.Color as Color @@ -91,42 +91,35 @@ defLocal = updateDiscoKind (const discoKindFiltered) defL factionD <- getsState sfactionD clientStatesOld <- getsServer sclientStates - modifyServer $ \ser -> ser {sclientStates = EM.map (const defLocal) factionD} + metaBackupOld <- getsServer smetaBackup -- Some item kinds preserve their identity and flavour throughout - -- the whole metagame, until the savefiles is removed. - -- These are usually not man-made items, because these can be made + -- the whole meta-game, until the savefiles are removed. + -- These are usually not common man-made items, because these can be made -- in many flavours so it may be hard to recognize them. + -- Character backstories and rare artifacts are uncommon enough + -- to requiring learning their identify only once. -- However, the exact properties of even natural items may vary, -- so the random aspects of items, stored in @sdiscoAspect@ -- are not preserved (a lot of other state components would need -- to be partially preserved, too, both on server and clients). - -- - -- This is a terrible temporary hack until Player becomes content - -- and we persistently store Player information on the server. - let metaHolder factionDict = case find (\(_, fact) -> - gteamCont fact == Just (TeamContinuity 1)) - $ EM.assocs factionDict of - Nothing -> - fst <$> find (\(_, fact) -> isNothing (gteamCont fact)) - (EM.assocs factionDict) - Just (fid, _) -> Just fid - mmetaHolderOld = metaHolder factionDold - case mmetaHolderOld of - Just metaHolderOld -> do - let metaDiscoOld = - let sOld = clientStatesOld EM.! metaHolderOld - disco = sdiscoKind sOld - inMetaGame kindId = IK.SetFlag Ability.MetaGame - `elem` IK.iaspects (okind coitem kindId) - in EM.filter inMetaGame disco - defDiscoOld = updateDiscoKind (metaDiscoOld `EM.union`) defLocal - metaHolderNew = fromJust $ metaHolder factionD - modifyServer $ \ser -> - ser {sclientStates = EM.insert metaHolderNew defDiscoOld - $ sclientStates ser} - Nothing -> return () -- probably no previous games - -- Hack ends. - clientStatesNew <- getsServer sclientStates + let inMetaGame kindId = IK.SetFlag Ability.MetaGame + `elem` IK.iaspects (okind coitem kindId) + metaDiscoOldFid = + EM.map (EM.filter inMetaGame . sdiscoKind) clientStatesOld + fidToTeam :: FactionId -> TeamContinuity + fidToTeam fid = fteam $ gkind $ factionDold EM.! fid + metaDiscoOldTeam = + EM.fromList $ map (first fidToTeam) $ EM.assocs metaDiscoOldFid + exclusiveUnion = EM.unionWith $ \_ _ -> error "forbidden duplicate" + metaDiscoAll = metaDiscoOldTeam `exclusiveUnion` metaBackupOld + currentTeams = ES.fromList $ map (fteam . gkind) $ EM.elems factionD + metaBackupNew = EM.withoutKeys metaDiscoAll currentTeams + stateNew fact = case EM.lookup (fteam $ gkind fact) metaDiscoAll of + Nothing -> defLocal + Just disco -> updateDiscoKind (disco `EM.union`) defLocal + clientStatesNew = EM.map stateNew factionD + modifyServer $ \ser -> ser { sclientStates = clientStatesNew + , smetaBackup = metaBackupNew } let updRestart fid = UpdRestart fid (pers EM.! fid) (clientStatesNew EM.! fid) scurChalSer sclientOptions mapWithKeyM_ (\fid _ -> do @@ -172,16 +165,16 @@ Level{ldepth} <- getLevel minLid let regItem itemKindId = do let itemKind = okind coitem itemKindId - freq = pure (itemKindId, itemKind) - case possibleActorFactions itemKind factionD of - [] -> return Nothing - (fid, _) : _ -> do + freq = pure (IK.HORROR, itemKindId, itemKind) + case runFrequency $ possibleActorFactions [] itemKind factionD of + [] -> error "sampleTrunks: null faction frequency" + (_, (fid, _)) : _ -> do let c = CTrunk fid minLid originPoint jfid = Just fid m2 <- rollItemAspect freq ldepth case m2 of NoNewItem -> error "sampleTrunks: can't create actor trunk" - NewItem (ItemKnown kindIx ar _) itemFullRaw itemQuant -> do + NewItem _ (ItemKnown kindIx ar _) itemFullRaw itemQuant -> do let itemKnown = ItemKnown kindIx ar jfid itemFull = itemFullRaw {itemBase = (itemBase itemFullRaw) {jfid}} @@ -206,12 +199,12 @@ Level{ldepth} <- getLevel minLid let regItem itemKindId = do let itemKind = okind coitem itemKindId - freq = pure (itemKindId, itemKind) + freq = pure (IK.HORROR, itemKindId, itemKind) c = CFloor minLid originPoint m2 <- rollItemAspect freq ldepth case m2 of NoNewItem -> error "sampleItems: can't create sample item" - NewItem itemKnown itemFull _ -> + NewItem _ itemKnown itemFull _ -> Just <$> registerItem False (itemFull, (0, [])) itemKnown c miids <- mapM regItem itemKindIds return $! EM.singleton SItem @@ -225,12 +218,15 @@ in m2 `M.union` m1 in foldr fromFun M.empty -resetFactions :: FactionDict -> ContentId ModeKind -> Int -> Dice.AbsDepth - -> Roster +resetFactions :: ContentData FactionKind -> Dice.AbsDepth -> ModeKind -> Bool -> Rnd FactionDict -resetFactions factionDold gameModeIdOld curDiffSerOld totalDepth players = do - let rawCreate (ix, (gplayer@Player{..}, gteamCont, initialActors)) = do - let castInitialActors (ln, d, actorGroup) = do +resetFactions cofact totalDepth mode + automateAll = do + let rawCreate (fid, (fkGroup, initialActors)) = do + -- Validation of content guarantess the existence of such faction kind. + gkindId <- fromJust <$> opick cofact fkGroup (const True) + let gkind@FactionKind{..} = okind cofact gkindId + castInitialActors (ln, d, actorGroup) = do n <- castDice (Dice.AbsDepth $ abs ln) totalDepth d return (ln, n, actorGroup) ginitial <- mapM castInitialActors initialActors @@ -238,51 +234,50 @@ mapFromFuns Color.legalFgCol [colorToTeamName, colorToPlainName, colorToFancyName] colorName = T.toLower $ head $ T.words fname - prefix = case (fleaderMode, funderAI) of - (Nothing, False) -> "Uncoordinated" - (Nothing, True) -> "Loose" - (Just{}, False) -> "Autonomous" - (Just{}, True) -> "Controlled" + prefix = case (fhasPointman, finitUnderAI) of + (False, False) -> "Uncoordinated" + (False, True) -> "Loose" + (True, False) -> "Autonomous" + (True, True) -> "Controlled" gnameNew = prefix <+> if fhasGender then makePhrase [MU.Ws $ MU.Text fname] else fname gcolor = M.findWithDefault Color.BrWhite colorName cmap - gvictimsDnew = case find (\fact -> gname fact == gnameNew) - $ EM.elems factionDold of - Nothing -> EM.empty - Just fact -> - let sing = IM.singleton curDiffSerOld (gvictims fact) - f = IM.unionWith (EM.unionWith (+)) - in EM.insertWith f gameModeIdOld sing $ gvictimsD fact let gname = gnameNew + gdoctrine = finitDoctrine + gunderAI = finitUnderAI || mattract mode || automateAll gdipl = EM.empty -- fixed below gquit = Nothing _gleader = Nothing gvictims = EM.empty - gvictimsD = gvictimsDnew gstash = Nothing - return (toEnum $ if fhasUI then ix else -ix, Faction{..}) - lFs <- mapM rawCreate $ zip [1..] $ rosterList players - let swapIx l = - let findPlayerName name = find ((name ==) . fname . gplayer . snd) - f (name1, name2) = - case (findPlayerName name1 lFs, findPlayerName name2 lFs) of - (Just (ix1, _), Just (ix2, _)) -> (ix1, ix2) - _ -> error $ "unknown faction" - `showFailure` ((name1, name2), lFs) - ixs = map f l - -- Only symmetry is ensured, everything else is permitted, e.g., - -- a faction in alliance with two others that are at war. - in ixs ++ map swap ixs - mkDipl diplMode = + return (fid, Faction{..}) + lFs <- mapM rawCreate $ zip [toEnum 1 ..] $ mroster mode + let mkDipl diplMode = let f (ix1, ix2) = - let adj fact = fact {gdipl = EM.insert ix2 diplMode (gdipl fact)} - in EM.adjust adj ix1 + let adj1 fact = fact {gdipl = EM.insert ix2 diplMode (gdipl fact)} + in EM.adjust adj1 ix1 in foldr f + -- Only symmetry is ensured, everything else is permitted, + -- e.g., a faction in alliance with two others that are at war. + pairsFromFaction :: (FactionKind -> [TeamContinuity]) + -> (FactionId, Faction) + -> [(FactionId, FactionId)] + pairsFromFaction selector (fid, fact) = + let teams = selector $ gkind fact + hasTeam team (_, fact2) = team == fteam (gkind fact2) + pairsFromTeam team = case find (hasTeam team) lFs of + Just (fid2, _) -> [(fid, fid2), (fid2, fid)] + Nothing -> [] + in concatMap pairsFromTeam teams rawFs = EM.fromList lFs - -- War overrides alliance, so 'warFs' second. - allianceFs = mkDipl Alliance rawFs (swapIx (rosterAlly players)) - warFs = mkDipl War allianceFs (swapIx (rosterEnemy players)) + -- War overrides alliance, so 'warFs' second. Consequently, if a faction + -- is allied with a faction that is at war with them, they will be + -- symmetrically at war. + allianceFs = mkDipl Alliance rawFs + $ concatMap (pairsFromFaction falliedTeams) $ EM.assocs rawFs + warFs = mkDipl War allianceFs + $ concatMap (pairsFromFaction fenemyTeams) $ EM.assocs allianceFs return $! warFs gameReset :: MonadServer m @@ -291,19 +286,16 @@ gameReset serverOptions mGameMode mrandom = do -- Dungeon seed generation has to come first, to ensure item boosting -- is determined by the dungeon RNG. - cops@COps{comode} <- getsState scops + cops@COps{cofact, comode} <- getsState scops dungeonSeed <- getSetGen $ sdungeonRng serverOptions `mplus` mrandom srandom <- getSetGen $ smainRng serverOptions `mplus` mrandom let srngs = RNGs (Just dungeonSeed) (Just srandom) when (sdumpInitRngs serverOptions) $ dumpRngs srngs scoreTable <- restoreScore cops - factionDold <- getsState sfactionD - gameModeIdOld <- getsState sgameModeId teamGearOld <- getsServer steamGear flavourOld <- getsServer sflavour discoKindRevOld <- getsServer sdiscoKindRev clientStatesOld <- getsServer sclientStates - curChalSer <- getsServer $ scurChalSer . soptions let gameMode = fromMaybe INSERT_COIN $ mGameMode `mplus` sgameMode serverOptions rnd :: Rnd (FactionDict, FlavourMap, DiscoveryKind, DiscoveryKindRev, @@ -313,19 +305,11 @@ fromMaybe (error $ "Unknown game mode:" `showFailure` gameMode) <$> opick comode gameMode (const True) let mode = okind comode modeKindId - automatePS ps = ps {rosterList = - map (\(pl, tc, l) -> (automatePlayer True pl, tc, l)) - (rosterList ps)} - players = if sautomateAll serverOptions - then automatePS $ mroster mode - else mroster mode flavour <- dungeonFlavourMap cops flavourOld (discoKind, sdiscoKindRev) <- serverDiscos cops discoKindRevOld freshDng <- DungeonGen.dungeonGen cops serverOptions $ mcaves mode - factionD <- resetFactions factionDold gameModeIdOld - (cdiff curChalSer) - (DungeonGen.freshTotalDepth freshDng) - players + factionD <- resetFactions cofact (DungeonGen.freshTotalDepth freshDng) + mode (sautomateAll serverOptions) return ( factionD, flavour, discoKind , sdiscoKindRev, freshDng, modeKindId ) let ( factionD, sflavour, discoKind @@ -350,13 +334,13 @@ factionD <- getsState sfactionD curChalSer <- getsServer $ scurChalSer . soptions let nGt0 (_, n, _) = n > 0 - ginitialWolf fact1 = if cwolf curChalSer && fhasUI (gplayer fact1) + ginitialWolf fact1 = if cwolf curChalSer && fhasUI (gkind fact1) then case filter nGt0 $ ginitial fact1 of [] -> [] (ln, _, grp) : _ -> [(ln, 1, grp)] else ginitial fact1 -- Keep the same order of factions as in roster. - needInitialCrew = sortBy (comparing $ abs . fromEnum . fst) + needInitialCrew = sortBy (comparing fst) $ filter (not . null . ginitialWolf . snd) $ EM.assocs factionD getEntryLevels (_, fact) = diff --git a/engine-src/Game/LambdaHack/Server/State.hs b/engine-src/Game/LambdaHack/Server/State.hs --- a/engine-src/Game/LambdaHack/Server/State.hs +++ b/engine-src/Game/LambdaHack/Server/State.hs @@ -19,12 +19,13 @@ import qualified System.Random.SplitMix32 as SM import Game.LambdaHack.Common.Analytics +import Game.LambdaHack.Common.Item import Game.LambdaHack.Common.Perception import Game.LambdaHack.Common.State import Game.LambdaHack.Common.Time import Game.LambdaHack.Common.Types +import Game.LambdaHack.Content.FactionKind (TeamContinuity) import Game.LambdaHack.Content.ItemKind (ItemKind) -import Game.LambdaHack.Content.ModeKind (TeamContinuity) import Game.LambdaHack.Definition.Defs import Game.LambdaHack.Server.Fov import Game.LambdaHack.Server.ItemRev @@ -65,6 +66,8 @@ , sundo :: () -- [CmdAtomic] -- ^ atomic commands performed to date , sclientStates :: EM.EnumMap FactionId State -- ^ each faction state, as seen by clients + , smetaBackup :: EM.EnumMap TeamContinuity DiscoveryKind + -- ^ discovery info for absent factions , sperFid :: PerFid -- ^ perception of all factions , sperValidFid :: PerValidFid -- ^ perception validity for all factions , sperCacheFid :: PerCacheFid -- ^ perception cache of all factions @@ -122,6 +125,7 @@ , sbandSpawned = IM.fromList [(1, 0), (2, 0), (3, 0)] , sundo = () , sclientStates = EM.empty + , smetaBackup = EM.empty , sperFid = EM.empty , sperValidFid = EM.empty , sperCacheFid = EM.empty @@ -178,6 +182,7 @@ put snumSpawned put sbandSpawned put sclientStates + put smetaBackup put (show srandom) put srngs put soptions @@ -201,6 +206,7 @@ snumSpawned <- get sbandSpawned <- get sclientStates <- get + smetaBackup <- get g <- get srngs <- get soptions <- get diff --git a/test/ActorStateUnitTests.hs b/test/ActorStateUnitTests.hs new file mode 100644 --- /dev/null +++ b/test/ActorStateUnitTests.hs @@ -0,0 +1,25 @@ +module ActorStateUnitTests (actorStateUnitTests) where + +import Prelude () + +import Game.LambdaHack.Core.Prelude + +import Test.Tasty +import Test.Tasty.HUnit + +import Game.LambdaHack.Common.ActorState +import Game.LambdaHack.Definition.Ability as Ability + +import UnitTestHelpers + +actorStateUnitTests :: TestTree +actorStateUnitTests = testGroup "actorStateUnitTests" + [ testCase "getActorBody verify stubCliState has testActor" $ + getActorBody testActorId (cliState stubCliState) @?= testActor + , testCase "getActorMaxSkills verify stubCliState has zeroSkills" $ + getActorMaxSkills testActorId (cliState stubCliState) + @?= Ability.zeroSkills + , testCase "fidActorNotProjGlobalAssocs" $ + fidActorNotProjGlobalAssocs testFactionId (cliState testCliStateWithItem) + @?= [(testActorId, testActorWithItem)] + ] diff --git a/test/CommonMUnitTests.hs b/test/CommonMUnitTests.hs new file mode 100644 --- /dev/null +++ b/test/CommonMUnitTests.hs @@ -0,0 +1,53 @@ +module CommonMUnitTests (commonMUnitTests) where + +import Prelude () + +import Game.LambdaHack.Core.Prelude + +import qualified Data.EnumMap.Strict as EM +import Test.Tasty +import Test.Tasty.HUnit + +import Game.LambdaHack.Client.CommonM +import Game.LambdaHack.Common.Area +import Game.LambdaHack.Common.Kind +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.Perception +import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.State +import Game.LambdaHack.Common.Time +import Game.LambdaHack.Content.TileKind +import qualified Game.LambdaHack.Core.Dice as Dice + +import UnitTestHelpers + +testLevel :: Level +testLevel = Level + { lkind = toEnum 0 + , ldepth = Dice.AbsDepth 1 + , lfloor = EM.empty + , lembed = EM.empty + , lbig = EM.empty + , lproj = EM.empty + , ltile = unknownTileMap (fromJust (toArea (0,0,0,0))) unknownId 10 10 + , lentry = EM.empty + , larea = trivialArea (Point 0 0) + , lsmell = EM.empty + , lstair = ([],[]) + , lescape = [] + , lseen = 0 + , lexpl = 0 + , ltime = timeZero + , lnight = False + } + +commonMUnitTests :: TestTree +commonMUnitTests = testGroup "commonMUnitTests" + [ testCase "getPerFid stubCliState returns emptyPerception" $ do + result <- executorCli (getPerFid testLevelId) stubCliState + fst result @?= emptyPer + , testCase "makeLine, when actor stands at the target position, fails" $ + Nothing @?= makeLine False testActor (Point 0 0) 1 emptyCOps testLevel + , testCase "makeLine unknownTiles succeeds" $ + Just 1 @?= makeLine False testActor (Point 2 0) 1 emptyCOps testLevel + ] diff --git a/test/HandleHelperMUnitTests.hs b/test/HandleHelperMUnitTests.hs new file mode 100644 --- /dev/null +++ b/test/HandleHelperMUnitTests.hs @@ -0,0 +1,22 @@ +module HandleHelperMUnitTests (handleHelperMUnitTests) where + +import Prelude () + +import Game.LambdaHack.Core.Prelude + +import Test.Tasty +import Test.Tasty.HUnit + +import Game.LambdaHack.Client.UI.HandleHelperM + +import UnitTestHelpers + +handleHelperMUnitTests :: TestTree +handleHelperMUnitTests = testGroup "handleHelperMUnitTests" + [ testCase "partyAfterLeader" $ do + -- You've got to fight for your right to party! + let testFunc = partyAfterLeader testActorId + partyInMonad <- executorCli testFunc testCliStateWithItem + let party = fst partyInMonad + party @?= [] + ] diff --git a/test/HandleHumanLocalMUnitTests.hs b/test/HandleHumanLocalMUnitTests.hs new file mode 100644 --- /dev/null +++ b/test/HandleHumanLocalMUnitTests.hs @@ -0,0 +1,77 @@ +module HandleHumanLocalMUnitTests (handleHumanLocalMUnitTests) where + +import Prelude () + +import Game.LambdaHack.Core.Prelude + +import qualified Data.EnumMap.Strict as EM +import Test.Tasty +import Test.Tasty.HUnit + +import Game.LambdaHack.Client.UI.HandleHelperM +import Game.LambdaHack.Client.UI.HandleHumanLocalM +import qualified Game.LambdaHack.Client.UI.HumanCmd as HumanCmd +import Game.LambdaHack.Common.ActorState +import Game.LambdaHack.Common.Item +import Game.LambdaHack.Common.ItemAspect +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.PointArray as PointArray +import Game.LambdaHack.Common.ReqFailure +import Game.LambdaHack.Common.State +import Game.LambdaHack.Content.TileKind +import Game.LambdaHack.Definition.DefsInternal + (toContentId, toContentSymbol) +import Game.LambdaHack.Definition.Flavour + +import UnitTestHelpers + +stubItem :: Item +stubItem = Item { jkind = IdentityObvious (toContentId 0), jfid = Nothing, jflavour = dummyFlavour } + +testItemFull :: ItemFull +testItemFull = ItemFull { itemBase = stubItem, itemKindId = toContentId 0, itemKind = testItemKind, itemDisco = ItemDiscoFull emptyAspectRecord, itemSuspect = False } + +handleHumanLocalMUnitTests :: TestTree +handleHumanLocalMUnitTests = testGroup "handleHumanLocalMUnitTests" + [ testCase "verify stubLevel has tile element" $ + case EM.lookup testLevelId (sdungeon stubState) of + Nothing -> assertFailure "stubLevel lost in dungeon" + Just level -> ltile level ! Point 0 0 @?= unknownId + , testCase "verify stubCliState has actor" $ + getActorBody testActorId (cliState stubCliState) @?= testActor + , testCase "permittedProjectClient stubCliState returns ProjectUnskilled" $ do + let testFn = permittedProjectClient testActorId + permittedProjectClientResultFnInMonad <- executorCli testFn stubCliState + let ultimateResult = + fst permittedProjectClientResultFnInMonad testItemFull + ultimateResult @?= Left ProjectUnskilled + , testCase "chooseItemProjectHuman" $ do + let testFn = let triggerItems = + [ HumanCmd.TriggerItem {tiverb = "verb", tiobject = "object", tisymbols = [toContentSymbol 'a', toContentSymbol 'b']} + , HumanCmd.TriggerItem {tiverb = "verb2", tiobject = "object2", tisymbols = [toContentSymbol 'c']} + ] + in chooseItemProjectHuman testActorId triggerItems + result <- executorCli testFn testCliStateWithItem + showFailError (fromJust (fst result)) @?= "*aiming obstructed by terrain*" + , testCase "psuitReq" $ do + let testFn = psuitReq testActorId + mpsuitReqMonad <- executorCli testFn testCliStateWithItem + let mpsuitReq = fst mpsuitReqMonad + case mpsuitReq of + Left err -> do + err @?= "aiming obstructed by terrain" + -- TODO: I'd split the test into three tests, each taking a different branch and fail in the remaining two branches that the particular branch doesn't take. Here it takes the first branch, because unknown tiles are not walkable (regardless what I claimed previously) and so the player is surrounded by walls, basically, so aiming fails, because the projectiles wouldn't even leave the position of the actor. I think. + Right psuitReqFun -> + case psuitReqFun testItemFull of + Left reqFail -> do + reqFail @?= ProjectUnskilled + Right (pos, _) -> do + pos @?= Point 0 0 + , testCase "xhairLegalEps" $ do + let testFn = xhairLegalEps testActorId + result <- executorCli testFn testCliStateWithItem + fst result @?= Right 114 -- not a coincidence this matches testFactionId, + -- because @eps@ is initialized that way, + -- for "randomness" + ] diff --git a/test/InventoryMUnitTests.hs b/test/InventoryMUnitTests.hs new file mode 100644 --- /dev/null +++ b/test/InventoryMUnitTests.hs @@ -0,0 +1,49 @@ +-- TODO: at some point we'll want our unit test hierarchy to match the +-- main codebase file hierarchy +module InventoryMUnitTests (inventoryMUnitTests) where + +import Prelude () + +import Game.LambdaHack.Core.Prelude + +import Test.Tasty +import Test.Tasty.HUnit + +import Game.LambdaHack.Client.UI.InventoryM +import Game.LambdaHack.Definition.Defs + +import UnitTestHelpers + +inventoryMUnitTests :: TestTree +inventoryMUnitTests = testGroup "inventoryMUnitTests" + [ testCase "getFull no stores " $ do + let testFn = getFull testActorId + (return SuitsEverything) -- :: m Suitability + (\_ _ _ _ _ -> "specific prompt") + (\_ _ _ _ _ -> "generic prompt") + [] -- :: [CStore] + False + False + result <- executorCli testFn stubCliState + fst result @?= Left "no items" + , testCase "getFull no item in eqp store" $ do + let testFn = getFull testActorId + (return SuitsEverything) + (\_ _ _ _ _ -> "specific prompt") + (\_ _ _ _ _ -> "generic prompt") + [CEqp] + False + False + result <- executorCli testFn stubCliState + fst result @?= Left "no items in equipment outfit" + , testCase "getFull an item in eqp store" $ do + let testFn = getFull testActorId + (return SuitsEverything) + (\_ _ _ _ _ -> "specific prompt") + (\_ _ _ _ _ -> "generic prompt") + [CEqp] + False + False + result <- executorCli testFn testCliStateWithItem + fst result @?= Right (CEqp, [(testItemId, (1, []))]) + ] diff --git a/test/ItemDescriptionUnitTests.hs b/test/ItemDescriptionUnitTests.hs --- a/test/ItemDescriptionUnitTests.hs +++ b/test/ItemDescriptionUnitTests.hs @@ -5,9 +5,8 @@ import Game.LambdaHack.Core.Prelude import qualified Data.EnumMap.Strict as EM - -import Test.Tasty -import Test.Tasty.HUnit +import Test.Tasty +import Test.Tasty.HUnit import Game.LambdaHack.Client.UI.ItemDescription import Game.LambdaHack.Common.Item @@ -54,8 +53,8 @@ [ testCase "testItem_viewItem_Blackx" $ viewItem testItemFull @?= attrChar2ToW32 Green 'x' - , testCase "testItem!_viewItem_Black!" $ - viewItem testItemFull { itemKind = testItemKind { isymbol = '!' }} + , testCase "testItem_viewItem_Black!" $ + viewItem testItemFull {itemKind = testItemKind {isymbol = '!'}} @?= attrChar2ToW32 Green '!' , testCase "testItem_viewItemBenefitColored_isEquip_Greenx" $ viewItemBenefitColored (EM.singleton (toEnum 42) (Benefit True 0 0 0 0)) (toEnum 42) testItemFull diff --git a/test/ItemRevUnitTests.hs b/test/ItemRevUnitTests.hs --- a/test/ItemRevUnitTests.hs +++ b/test/ItemRevUnitTests.hs @@ -9,9 +9,8 @@ import qualified Data.EnumSet as ES import qualified Data.Vector.Unboxed as U import qualified System.Random.SplitMix32 as SM - -import Test.Tasty -import Test.Tasty.HUnit +import Test.Tasty +import Test.Tasty.HUnit import Game.LambdaHack.Content.ItemKind import Game.LambdaHack.Core.Dice @@ -52,7 +51,7 @@ in [ testCase "empty & default initializers -> first is single dummy result" $ let rndMapPair0 = return emptyIdToFlavourSymbolToFlavourSetPair - (mapPair1, _) = St.runState (rollFlavourMap U.empty rndMapPair0 (toContentId 0) testItemKind) $ SM.mkSMGen 1 + mapPair1 = St.evalState (rollFlavourMap U.empty rndMapPair0 (toContentId 0) testItemKind) $ SM.mkSMGen 1 in fst mapPair1 @?= EM.singleton (toContentId 0) dummyFlavour , testCase "empty & default initializers -> second is empty" $ let rndMapPair0 = return emptyIdToFlavourSymbolToFlavourSetPair diff --git a/test/LevelUnitTests.hs b/test/LevelUnitTests.hs new file mode 100644 --- /dev/null +++ b/test/LevelUnitTests.hs @@ -0,0 +1,62 @@ +module LevelUnitTests (levelUnitTests) where + +import Prelude () + +import Game.LambdaHack.Core.Prelude + +import qualified Data.EnumMap.Strict as EM +import Test.Tasty +import Test.Tasty.HUnit + +import Game.LambdaHack.Common.Area +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.PointArray as PointArray +import Game.LambdaHack.Common.State +import Game.LambdaHack.Common.Time +import qualified Game.LambdaHack.Core.Dice as Dice + +import UnitTestHelpers + +testLevel :: Level +testLevel = Level + { lkind = toEnum 0 + , ldepth = Dice.AbsDepth 1 + , lfloor = EM.empty + , lembed = EM.empty + , lbig = EM.empty + , lproj = EM.empty + , ltile = PointArray.empty + , lentry = EM.empty + , larea = trivialArea (Point 0 0) + , lsmell = EM.empty + , lstair = ([],[]) + , lescape = [] + , lseen = 0 + , lexpl = 0 + , ltime = timeZero + , lnight = False + } + +testDungeonWithLevel :: State +testDungeonWithLevel = + let singletonDungeonUpdate _ = EM.singleton testLevelId testLevel + unknownTileState = localFromGlobal emptyState + oneLevelDungeonState = + updateDungeon singletonDungeonUpdate unknownTileState + in oneLevelDungeonState + +levelUnitTests :: TestTree +levelUnitTests = testGroup "levelUnitTests" + [ testCase "testDungeonWithLevel has min level id" $ do + let ((minKey, _), _) = + fromJust $ EM.minViewWithKey (sdungeon testDungeonWithLevel) + minKey @?= testLevelId + , testCase "testDungeonWithLevel has max level id" $ do + let ((minKey, _), _) = + fromJust $ EM.maxViewWithKey (sdungeon testDungeonWithLevel) + minKey @?= testLevelId + , testCase "dungeonBounds testDungeonWithLevel returns (0,0)" $ do + let bounds = dungeonBounds (sdungeon testDungeonWithLevel) + bounds @?= (testLevelId, testLevelId) + ] diff --git a/test/MonadClientUIUnitTests.hs b/test/MonadClientUIUnitTests.hs new file mode 100644 --- /dev/null +++ b/test/MonadClientUIUnitTests.hs @@ -0,0 +1,31 @@ +module MonadClientUIUnitTests (monadClientUIUnitTests) where + +import Prelude () + +import Game.LambdaHack.Core.Prelude + +import Test.Tasty +import Test.Tasty.HUnit + +import Game.LambdaHack.Client.MonadClient +import Game.LambdaHack.Client.State +import Game.LambdaHack.Client.UI.MonadClientUI +import Game.LambdaHack.Client.UI.Overlay + +import UnitTestHelpers + +monadClientUIUnitTests :: TestTree +monadClientUIUnitTests = testGroup "handleHumanLocalMUnitTests" + [ testCase "getsClient sside" $ do + sideInMonad <- executorCli (getsClient sside) stubCliState + fst sideInMonad @?= testFactionId + , testCase "getArenaUI works in stub" $ do + levelIdInMonad <- executorCli getArenaUI stubCliState + fst levelIdInMonad @?= testLevelId + , testCase "viewedLevelUI works in stub" $ do + levelIdInMonad <- executorCli viewedLevelUI stubCliState + fst levelIdInMonad @?= testLevelId + , testCase "getFontSetup works in stub" $ do + fontSetupInMonad <- executorCli getFontSetup stubCliState + fst fontSetupInMonad @?= multiFontSetup + ] diff --git a/test/ReqFailureUnitTests.hs b/test/ReqFailureUnitTests.hs --- a/test/ReqFailureUnitTests.hs +++ b/test/ReqFailureUnitTests.hs @@ -52,26 +52,26 @@ } standardRules = Content.RuleKind.standardRules in - [ testCase "oneSkillAndxsymbol_permittedApply_FailureApplyFood" $ + [ testCase "permittedApply: One Skill and x symbol -> FailureApplyFood" $ permittedApply standardRules timeZero 1 True Nothing testItemFull quantSingle @?= Left ApplyFood - , testCase "oneSkillAnd,symbolAndCGround_permittedApply_True" $ + , testCase "permittedApply: One Skill and , symbol And CGround -> True" $ permittedApply standardRules timeZero 1 True (Just CGround) testItemFull {itemKind = testItemKind{isymbol = ','}} quantSingle @?= Right True - , testCase "oneSkillAnd\"symbol_permittedApply_True" $ + , testCase "permittedApply: One Skill and \" symbol -> True" $ permittedApply standardRules timeZero 1 True Nothing testItemFull {itemKind = testItemKind{isymbol = '"'}} quantSingle @?= Right True - , testCase "twoSkillAnd?symbol_permittedApply_FailureApplyRead" $ + , testCase "permittedApply: Two Skill and ? symbol -> FailureApplyRead" $ permittedApply standardRules timeZero 2 True Nothing testItemFull {itemKind = testItemKind{isymbol = '?'}} quantSingle @?= Left ApplyRead - , testCase "twoSkillAnd,symbol_premittedApply_True" $ + , testCase "permittedApply: Two Skill and , symbol -> True" $ permittedApply standardRules timeZero 2 True Nothing testItemFull {itemKind = testItemKind{isymbol = ','}} quantSingle diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -19,9 +19,16 @@ import qualified Content.RuleKind import TieKnot +import ActorStateUnitTests +import CommonMUnitTests +import HandleHelperMUnitTests +import HandleHumanLocalMUnitTests +import InventoryMUnitTests import ItemDescriptionUnitTests import ItemKindUnitTests import ItemRevUnitTests +import LevelUnitTests +import MonadClientUIUnitTests import ReqFailureUnitTests import SessionUIUnitTests @@ -29,12 +36,20 @@ main = defaultMain tests tests :: TestTree -tests = testGroup "Tests" [ itemDescriptionUnitTests +tests = testGroup "Tests" [ actorStateUnitTests + , commonMUnitTests + , handleHelperMUnitTests + , handleHumanLocalMUnitTests + , inventoryMUnitTests + , itemDescriptionUnitTests , itemKindUnitTests , itemRevUnitTests + , levelUnitTests , reqFailureUnitTests , macroTests - , integrationTests ] + , monadClientUIUnitTests + , integrationTests + ] integrationTests :: TestTree integrationTests = testGroup "integrationTests" $ @@ -49,8 +64,8 @@ ++ let corule = RK.makeData Content.RuleKind.standardRules uiOptions = unsafePerformIO $ mkUIOptions corule defClientOptions - testFontset :: (Int, String) -> TestTree - testFontset (n, fontsetName) = + testFontset :: Int -> String -> TestTree + testFontset n fontsetName = testCase ("SDL fronted; init only; " ++ fontsetName ++ " fontset") $ do -- This test only works when run from the same directory that -- the .cabal file is in. And this is what Debian needs, so OK. @@ -62,5 +77,5 @@ , "--fontset", fontsetName ] serverOptions2 <- handleParseResult $ execParserPure defaultPrefs serverOptionsPI args2 tieKnot serverOptions2 - in map testFontset $ zip [0..] $ map T.unpack $ map fst $ uFontsets uiOptions + in zipWith testFontset [0..] $ map (T.unpack . fst) $ uFontsets uiOptions #endif diff --git a/test/UnitTestHelpers.hs b/test/UnitTestHelpers.hs new file mode 100644 --- /dev/null +++ b/test/UnitTestHelpers.hs @@ -0,0 +1,376 @@ +{-# LANGUAGE GADTs, GeneralizedNewtypeDeriving #-} +-- | Monadic test harness and other stubs for unit tests. +module UnitTestHelpers + ( CliState(..) + , emptyCliState + , executorCli + , stubLevel + , stubState + , stubCliState + , testActor + , testActorId + , testActorWithItem + , testCliStateWithItem + , testFactionId + , testItemId + , testItemKind + , testLevelId +#ifdef EXPOSE_INTERNAL + -- * Internal operations + , CliMock(..) + , fchanFrontendStub +#endif + ) where + +import Prelude () + +import Game.LambdaHack.Core.Prelude + +import qualified Control.Monad.IO.Class as IO +import Control.Monad.Trans.State.Strict + (StateT (StateT, runStateT), gets, state) +import qualified Data.EnumMap.Strict as EM + +import Game.LambdaHack.Atomic (MonadStateWrite (..)) +import Game.LambdaHack.Client +import qualified Game.LambdaHack.Client.BfsM as BfsM +import Game.LambdaHack.Client.HandleResponseM +import Game.LambdaHack.Client.MonadClient +import Game.LambdaHack.Client.State +import Game.LambdaHack.Client.UI +import Game.LambdaHack.Client.UI.ActorUI +import Game.LambdaHack.Client.UI.Content.Screen +import Game.LambdaHack.Client.UI.ContentClientUI +import Game.LambdaHack.Client.UI.Frontend +import Game.LambdaHack.Client.UI.Key (KMP (..)) +import qualified Game.LambdaHack.Client.UI.Key as K +import Game.LambdaHack.Client.UI.PointUI +import Game.LambdaHack.Client.UI.UIOptions +import Game.LambdaHack.Common.Actor +import Game.LambdaHack.Common.Area +import Game.LambdaHack.Common.ClientOptions +import Game.LambdaHack.Common.Faction +import Game.LambdaHack.Common.Kind +import Game.LambdaHack.Common.Level +import Game.LambdaHack.Common.Misc +import Game.LambdaHack.Common.MonadStateRead +import Game.LambdaHack.Common.Perception +import Game.LambdaHack.Common.Point +import Game.LambdaHack.Common.State +import Game.LambdaHack.Common.Time +import Game.LambdaHack.Common.Types +import Game.LambdaHack.Content.ItemKind +import Game.LambdaHack.Content.RuleKind +import Game.LambdaHack.Content.TileKind +import qualified Game.LambdaHack.Core.Dice as Dice +import qualified Game.LambdaHack.Definition.Ability as Ability +import Game.LambdaHack.Definition.Color +import Game.LambdaHack.Definition.Flavour + +-- * UI frontend stub + +-- Read UI requests from the client and send them to the frontend, +fchanFrontendStub :: ChanFrontend +fchanFrontendStub = + ChanFrontend $ \case + FrontFrame _ -> putStr "FrontFrame" + FrontDelay _ -> putStr "FrontDelay" + FrontKey _ _ -> return KMP {kmpKeyMod = K.escKM, kmpPointer = PointUI 0 0} + FrontPressed -> return False + FrontDiscardKey -> putStr "FrontDiscardKey" + FrontResetKeys -> putStr "FrontResetKeys" + FrontShutdown -> putStr "FrontShutdown" + FrontPrintScreen -> putStr "FrontPrintScreen" + +-- * Mock client state implementation + +data CliState = CliState + { cliState :: State -- ^ current global state + , cliClient :: StateClient -- ^ current client state + , cliSession :: Maybe SessionUI -- ^ UI state, empty for AI clients + + -- Not needed for the mock monad (and blank line needed to avoid making this + -- comment a haddock for @cliSession@ field): + -- , cliDict :: ChanServer + -- , cliToSave :: Save.ChanSave (StateClient, Maybe SessionUI) + } + +-- * Option stubs + +stubUIOptions :: UIOptions +stubUIOptions = UIOptions + { uCommands = [] + , uHeroNames = [] + , uVi = False + , uLeftHand = False + , uChosenFontset = "" + , uAllFontsScale = 0.0 + , uFullscreenMode = NotFullscreen + , uhpWarningPercent = 0 + , uMsgWrapColumn = 0 + , uHistoryMax = 0 + , uMaxFps = 0.0 + , uNoAnim = False + , uOverrideCmdline = [] + , uFonts = [] + , uFontsets = [] + , uMessageColors = [] + } + +stubClientOptions :: ClientOptions +stubClientOptions = defClientOptions + { schosenFontset = Just "snoopy" + , sfontsets = + [("snoopy", FontSet { fontMapScalable = "scalable" + , fontMapBitmap = "bitmap" + , fontPropRegular = "propRegular" + , fontPropBold = "propBold" + , fontMono = "mono" })] + } + +-- * Stub identifiers + +-- Using different arbitrary numbers for these so that if tests fail +-- due to missing keys we'll have more of a clue. +testLevelId :: LevelId +testLevelId = toEnum 111 + +testActorId :: ActorId +testActorId = toEnum 112 + +testItemId :: ItemId +testItemId = toEnum 113 + +testFactionId :: FactionId +testFactionId = toEnum 114 + +-- * Game arena element stubs + +testArea :: Area +testArea = fromJust(toArea (0, 0, 0, 0)) + +testLevelDimension :: Int +testLevelDimension = 3 + +stubLevel :: Level +stubLevel = Level + { lkind = toEnum 0 + , ldepth = Dice.AbsDepth 1 + , lfloor = EM.empty + , lembed = EM.empty + , lbig = EM.empty + , lproj = EM.empty + , ltile = unknownTileMap testArea unknownId testLevelDimension testLevelDimension + , lentry = EM.empty + , larea = trivialArea (Point 0 0) + , lsmell = EM.empty + , lstair = ([],[]) + , lescape = [] + , lseen = 0 + , lexpl = 0 + , ltime = timeZero + , lnight = False + } + +testFaction :: Faction +testFaction = + Faction + { gkind = emptyUIFaction + , gname = "" + , gcolor = Black + , gdoctrine = Ability.TBlock + , gunderAI = True + , ginitial = [] + , gdipl = EM.empty + , gquit = Nothing + , _gleader = Nothing + , gstash = Nothing + , gvictims = EM.empty + } + +testActor :: Actor +testActor = Actor + { btrunk = testItemId + , bnumber = Nothing + , bhp = 0 + , bhpDelta = ResDelta (0,0) (0,0) + , bcalm = 0 + , bcalmDelta = ResDelta (0,0) (0,0) + , bpos = Point 0 0 + , boldpos = Nothing + , blid = testLevelId + , bfid = testFactionId + , btrajectory = Nothing + , borgan = EM.empty + , beqp = EM.empty + , bweapon = 0 + , bweapBenign = 0 + , bwatch = WWatch + , bproj = False + } + +testItemKind :: ItemKind +testItemKind = ItemKind + { isymbol = 'x' + , iname = "12345678901234567890123" + , ifreq = [ (UNREPORTED_INVENTORY, 1) ] + , iflavour = zipPlain [Green] + , icount = 1 + 1 `Dice.d` 2 + , irarity = [(1, 50), (10, 1)] + , iverbHit = "hit" + , iweight = 300 + , idamage = 1 `Dice.d` 1 + , iaspects = [ AddSkill Ability.SkHurtMelee $ -16 * 5 + , SetFlag Ability.Fragile + , toVelocity 70 ] + , ieffects = [] + , idesc = "A really cool test item." + , ikit = [] + } + +testActorWithItem :: Actor +testActorWithItem = + testActor { beqp = EM.singleton testItemId (1,[])} + +-- Stublike state that should barely function for testing. +stubState :: State +stubState = + let singletonFactionUpdate _ = EM.singleton testFactionId testFaction + singletonDungeonUpdate _ = EM.singleton testLevelId stubLevel + singletonActorDUpdate _ = EM.singleton testActorId testActor + singletonActorMaxSkillsUpdate _ = + EM.singleton testActorId Ability.zeroSkills + copsUpdate oldCOps = + oldCOps {corule = (corule oldCOps) + { rWidthMax = testLevelDimension + , rHeightMax = testLevelDimension }} + stateWithMaxLevelDimension = updateCOpsAndCachedData copsUpdate emptyState + stateWithFaction = + updateFactionD singletonFactionUpdate stateWithMaxLevelDimension + stateWithActorD = updateActorD singletonActorDUpdate stateWithFaction + stateWithActorMaxSkills = + updateActorMaxSkills singletonActorMaxSkillsUpdate stateWithActorD + stateWithDungeon = + updateDungeon singletonDungeonUpdate stateWithActorMaxSkills + in stateWithDungeon + +testStateWithItem :: State +testStateWithItem = + let swapToItemActor _ = EM.singleton testActorId testActorWithItem + in updateActorD swapToItemActor stubState + +emptyCliState :: CliState +emptyCliState = CliState + { cliState = emptyState + , cliClient = emptyStateClient testFactionId + , cliSession = Nothing + } + +stubSessionUI :: SessionUI +stubSessionUI = + let actorUI = ActorUI { bsymbol = 'j' + , bname = "Jamie" + , bpronoun = "he/him" + , bcolor = BrCyan } + in (emptySessionUI stubUIOptions) + { sactorUI = EM.singleton testActorId actorUI + , sccui = emptyCCUI { coscreen = emptyScreenContent + { rwidth = testLevelDimension + , rheight = testLevelDimension + 3 } } + , schanF = fchanFrontendStub + } + +stubCliState :: CliState +stubCliState = CliState + { cliState = stubState + , cliClient = (emptyStateClient testFactionId) + { soptions = stubClientOptions + , sfper = EM.singleton testLevelId emptyPer } + , cliSession = let target = TPoint TUnknown testLevelId (Point 1 0) + in Just (stubSessionUI {sxhair = Just target}) + } + +testCliStateWithItem :: CliState +testCliStateWithItem = stubCliState { cliState = testStateWithItem } + +-- * Monad harness mock + +-- | Client state transformation monad mock. +newtype CliMock a = CliMock + { runCliMock :: StateT CliState IO a } + -- we build off io so we can compile but we don't want to use it; + -- TODO: let's try to get rid of the IO. I can't see any problem right now. + -- We'd need to to define dummy liftIO in some monads, etc. + deriving (Monad, Functor, Applicative) + +instance MonadStateRead CliMock where + {-# INLINE getsState #-} + getsState f = CliMock $ gets $ f . cliState + +instance MonadStateWrite CliMock where + {-# INLINE modifyState #-} + modifyState f = CliMock $ state $ \cliS -> + let !newCliS = cliS {cliState = f $ cliState cliS} + in ((), newCliS) + {-# INLINE putState #-} + putState newCliState = CliMock $ state $ \cliS -> + let !newCliS = cliS {cliState = newCliState} + in ((), newCliS) + +instance MonadClientRead CliMock where + {-# INLINE getsClient #-} + getsClient f = CliMock $ gets $ f . cliClient + liftIO = CliMock . IO.liftIO + +instance MonadClient CliMock where + {-# INLINE modifyClient #-} + modifyClient f = CliMock $ state $ \cliS -> + let !newCliS = cliS {cliClient = f $ cliClient cliS} + in ((), newCliS) + +-- instance MonadClientSetup CliMock where +-- saveClient = CliMock $ do +-- --toSave <- gets cliToSave +-- cli <- gets cliClient +-- msess <- gets cliSession +-- IO.liftIO $ Save.saveToChan toSave (cli, msess) + +instance MonadClientUI CliMock where + {-# INLINE getsSession #-} + getsSession f = CliMock $ gets $ f . fromJust . cliSession + {-# INLINE modifySession #-} + modifySession f = CliMock $ state $ \cliS -> + let !newCliSession = f $ fromJust $ cliSession cliS + !newCliS = cliS {cliSession = Just newCliSession} + in ((), newCliS) + updateClientLeader aid = do + s <- getState + modifyClient $ updateLeader aid s + getCacheBfs = BfsM.getCacheBfs + getCachePath = BfsM.getCachePath + +-- instance MonadClientReadResponse CliMock where +-- receiveResponse = CliMock $ do +-- ChanServer{responseS} <- gets cliDict +-- IO.liftIO $ takeMVar responseS + +-- instance MonadClientWriteRequest CliMock where +-- sendRequestAI scmd = CliMock $ do +-- ChanServer{requestAIS} <- gets cliDict +-- IO.liftIO $ putMVar requestAIS scmd +-- sendRequestUI scmd = CliMock $ do +-- ChanServer{requestUIS} <- gets cliDict +-- IO.liftIO $ putMVar (fromJust requestUIS) scmd +-- clientHasUI = CliMock $ do +-- mSession <- gets cliSession +-- return $! isJust mSession + +instance MonadClientAtomic CliMock where + {-# INLINE execUpdAtomic #-} + execUpdAtomic _ = return () -- handleUpdAtomic, until needed, save resources + -- Don't catch anything; assume exceptions impossible. + {-# INLINE execPutState #-} + execPutState = putState + +executorCli :: CliMock a -> CliState -> IO (a, CliState) +executorCli = runStateT . runCliMock diff --git a/test/doctest-driver.hs b/test/doctest-driver.hs deleted file mode 100644 --- a/test/doctest-driver.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF doctest-driver-gen -optF --verbose -optF definition-src -optF engine-src -optF -XMonoLocalBinds -optF -XScopedTypeVariables -optF -XOverloadedStrings -optF -XBangPatterns -optF -XRecordWildCards -optF -XNamedFieldPuns -optF -XMultiWayIf -optF -XLambdaCase -optF -XDefaultSignatures -optF -XInstanceSigs -optF -XPatternSynonyms -optF -XStrictData -optF -XCPP -optF -XTypeApplications #-} - -- This needs to match @default-extensions@ of @common options@ - -- of LambdaHack.cabal. So far, there's no way to automate that. - -- This is slow, but @--fast@ doesn't help at all, so not enabled. - -- No slowdown from @--verbose@. - -- - -- After @--test-show-details@ is fixed for doctests, we can recommend - -- it in README and unify how normal tests and doctests are run, by setting - -- @write-ghc-environment-files: always@ in @cabal.project@ and dropping - -- @exec@.