bulk copy of latest physfs to our misc/libphysfs since this seems to fix an off-by-1 error reliably hit in readln read of 1 byte probably introduced in the addition of the buffered read. Whether this is excessive or whether libphysfs should even be maintained by us is another matter. But at least we shouldn't crash
(*
* Hedgewars, a free turn based strategy game
* Copyright (c) 2004-2015 Andrey Korotaev <unC0Rr@gmail.com>
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; version 2 of the License
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
*)
{$INCLUDE "options.inc"}
unit uGears;
(*
* This unit defines the behavior of gears.
*
* Gears are "things"/"objects" that may be visible to the player or not,
* but always have an effect on the course of the game.
*
* E.g.: weapons, hedgehogs, etc.
*
* Note: The visual appearance of gears is defined in the unit "uGearsRender".
*
* Note: Gears that do not have an effect on the game but are just visual
* effects are called "Visual Gears" and defined in the respective unit!
*)
interface
uses uConsts, uFloat, uTypes, uChat, uCollisions;
procedure initModule;
procedure freeModule;
function SpawnCustomCrateAt(x, y: LongInt; crate: TCrateType; content, cnt: Longword): PGear;
function SpawnFakeCrateAt(x, y: LongInt; crate: TCrateType; explode: boolean; poison: boolean ): PGear;
procedure ProcessGears;
procedure EndTurnCleanup;
procedure DrawGears;
procedure DrawGearsTimers;
procedure FreeGearsList;
procedure AddMiscGears;
procedure AssignHHCoords;
function GearByUID(uid : Longword) : PGear;
function IsClockRunning() : boolean;
implementation
uses uStore, uSound, uTeams, uRandom, uIO, uLandGraphics,
{$IFDEF USE_TOUCH_INTERFACE}uTouch,{$ENDIF}
uLocale, uAmmos, uStats, uVisualGears, uScript, uVariables,
uCommands, uUtils, uTextures, uRenderUtils, uGearsRender, uCaptions, uDebug,
uGearsHedgehog, uGearsUtils, uGearsList, uGearsHandlersRope
, uVisualGearsList, uGearsHandlersMess, uAI;
var skipFlag: boolean;
var delay: LongWord;
delay2: LongWord;
step: (stDelay, stChDmg, stSweep, stTurnReact,
stAfterDelay, stChWin, stWater, stChWin2, stHealth,
stSpawn, stNTurn);
NewTurnTick: LongWord;
//SDMusic: shortstring;
function CheckNoDamage: boolean; // returns TRUE in case of no damaged hhs
var Gear: PGear;
dmg: LongInt;
begin
CheckNoDamage:= true;
Gear:= GearsList;
while Gear <> nil do
begin
if (Gear^.Kind = gtHedgehog) and (((GameFlags and gfInfAttack) = 0) or ((Gear^.dX.QWordValue < _0_000004.QWordValue)
and (Gear^.dY.QWordValue < _0_000004.QWordValue))) then
begin
if (not isInMultiShoot) then
inc(Gear^.Damage, Gear^.Karma);
if (Gear^.Damage <> 0) and ((Gear^.Hedgehog^.Effects[heInvulnerable] = 0)) then
begin
CheckNoDamage:= false;
dmg:= Gear^.Damage;
if Gear^.Health < dmg then
begin
Gear^.Active:= true;
Gear^.Health:= 0
end
else
dec(Gear^.Health, dmg);
(*
This doesn't fit well w/ the new loser sprite which is cringing from an attack.
if (Gear^.Hedgehog^.Team = CurrentTeam) and (Gear^.Damage <> Gear^.Karma)
and (not Gear^.Hedgehog^.King) and (Gear^.Hedgehog^.Effects[hePoisoned] = 0) and (not SuddenDeathDmg) then
Gear^.State:= Gear^.State or gstLoser;
*)
spawnHealthTagForHH(Gear, dmg);
RenderHealth(Gear^.Hedgehog^);
RecountTeamHealth(Gear^.Hedgehog^.Team);
end;
if (not isInMultiShoot) then
Gear^.Karma:= 0;
Gear^.Damage:= 0
end;
Gear:= Gear^.NextGear
end;
end;
procedure HealthMachine;
var Gear: PGear;
team: PTeam;
i: LongWord;
flag: Boolean;
tmp: LongWord;
begin
Gear:= GearsList;
while Gear <> nil do
begin
if Gear^.Kind = gtHedgehog then
begin
tmp:= 0;
if (Gear^.Hedgehog^.Effects[hePoisoned] <> 0) and (Gear^.Hedgehog^.Effects[heFrozen] = 0) then
begin
inc(tmp, ModifyDamage(Gear^.Hedgehog^.Effects[hePoisoned], Gear));
if (GameFlags and gfResetHealth) <> 0 then
dec(Gear^.Hedgehog^.InitialHealth) // does not need a minimum check since <= 1 basically disables it
end;
if (TotalRounds > cSuddenDTurns - 1) then
begin
inc(tmp, cHealthDecrease);
if (GameFlags and gfResetHealth) <> 0 then
dec(Gear^.Hedgehog^.InitialHealth, cHealthDecrease)
end;
if Gear^.Hedgehog^.King then
begin
flag:= false;
team:= Gear^.Hedgehog^.Team;
for i:= 0 to Pred(team^.HedgehogsNumber) do
if (team^.Hedgehogs[i].Gear <> nil) and (not team^.Hedgehogs[i].King)
and (team^.Hedgehogs[i].Gear^.Health > team^.Hedgehogs[i].Gear^.Damage) then
flag:= true;
if not flag then
begin
inc(tmp, 5);
if (GameFlags and gfResetHealth) <> 0 then
dec(Gear^.Hedgehog^.InitialHealth, 5)
end
end;
if tmp > 0 then
begin
inc(Gear^.Damage, min(tmp, max(0,Gear^.Health - 1 - Gear^.Damage)));
HHHurt(Gear^.Hedgehog, dsPoison);
end
end;
Gear:= Gear^.NextGear
end;
end;
procedure ProcessGears;
var t: PGear;
i, AliveCount: LongInt;
s: ansistring;
prevtime: LongWord;
stirFallers: boolean;
begin
stirFallers:= false;
prevtime:= TurnTimeLeft;
ScriptCall('onGameTick');
if GameTicks mod 20 = 0 then ScriptCall('onGameTick20');
if GameTicks = NewTurnTick then
begin
ScriptCall('onNewTurn');
{$IFDEF USE_TOUCH_INTERFACE}
uTouch.NewTurnBeginning();
{$ENDIF}
end;
PrvInactive:= AllInactive;
AllInactive:= true;
if (StepSoundTimer > 0) and (StepSoundChannel < 0) then
StepSoundChannel:= LoopSound(sndSteps)
else if (StepSoundTimer = 0) and (StepSoundChannel > -1) then
begin
StopSoundChan(StepSoundChannel);
StepSoundChannel:= -1
end;
if StepSoundTimer > 0 then
dec(StepSoundTimer, 1);
t:= GearsList;
while t <> nil do
begin
curHandledGear:= t;
t:= curHandledGear^.NextGear;
if (GameTicks and $1FFF = 0) and (curHandledGear^.Kind = gtCase) and (curHandledGear^.Pos <> posCaseHealth) then
stirFallers := true;
if curHandledGear^.Message and gmDelete <> 0 then
DeleteGear(curHandledGear)
else
begin
if curHandledGear^.Message and gmRemoveFromList <> 0 then
begin
RemoveGearFromList(curHandledGear);
// since I can't think of any good reason this would ever be separate from a remove from list, going to keep it inside this block
if curHandledGear^.Message and gmAddToList <> 0 then InsertGearToList(curHandledGear);
curHandledGear^.Message:= curHandledGear^.Message and (not (gmRemoveFromList or gmAddToList))
end;
if curHandledGear^.Active then
begin
if curHandledGear^.RenderTimer and (curHandledGear^.Timer > 500) and ((curHandledGear^.Timer mod 1000) = 0) then
begin
FreeAndNilTexture(curHandledGear^.Tex);
curHandledGear^.Tex:= RenderStringTex(ansistring(inttostr(curHandledGear^.Timer div 1000)), cWhiteColor, fntSmall);
end;
curHandledGear^.doStep(curHandledGear);
// might be useful later
//ScriptCall('onGearStep', Gear^.uid);
end
end
end;
if stirFallers then
begin
t := GearsList;
while t <> nil do
begin
if t^.Kind = gtGenericFaller then
begin
t^.Active:= true;
t^.X:= int2hwFloat(GetRandom(rightX-leftX)+leftX);
t^.Y:= int2hwFloat(GetRandom(LAND_HEIGHT-topY)+topY);
t^.dX:= _90-(GetRandomf*_360);
t^.dY:= _90-(GetRandomf*_360)
end;
t := t^.NextGear
end
end;
curHandledGear:= nil;
if AllInactive then
case step of
stDelay:
begin
if delay = 0 then
delay:= cInactDelay
else
dec(delay);
if delay = 0 then
inc(step)
end;
stChDmg:
if CheckNoDamage then
inc(step)
else
step:= stDelay;
stSweep:
if SweepDirty then
begin
SetAllToActive;
step:= stChDmg
end
else
inc(step);
stTurnReact:
begin
if (not bBetweenTurns) and (not isInMultiShoot) then
begin
uStats.TurnReaction;
inc(step)
end
else
inc(step, 2);
end;
stAfterDelay:
begin
if delay = 0 then
delay:= cInactDelay
else
dec(delay);
if delay = 0 then
inc(step)
end;
stChWin:
begin
CheckForWin();
inc(step)
end;
stWater:
if (not bBetweenTurns) and (not isInMultiShoot) then
begin
if TotalRounds = cSuddenDTurns + 1 then
bWaterRising:= true;
if bWaterRising and (cWaterRise > 0) then
AddGear(0, 0, gtWaterUp, 0, _0, _0, 0)^.Tag:= cWaterRise;
inc(step)
end
else // since we are not raising the water, a second win-check isn't needed
inc(step,2);
stChWin2:
begin
CheckForWin;
inc(step)
end;
stHealth:
begin
if (cWaterRise <> 0) or (cHealthDecrease <> 0) then
begin
if (TotalRounds = cSuddenDTurns) and (not SuddenDeath) and (not isInMultiShoot) then
begin
SuddenDeath:= true;
if cHealthDecrease <> 0 then
begin
SuddenDeathDmg:= true;
// flash
ScreenFade:= sfFromWhite;
ScreenFadeValue:= sfMax;
ScreenFadeSpeed:= 1;
ChangeToSDClouds;
ChangeToSDFlakes;
SetSkyColor(SDSkyColor.r * (SDTint.r/255) / 255, SDSkyColor.g * (SDTint.r/255) / 255, SDSkyColor.b * (SDTint.b/255) / 255);
Ammoz[amTardis].SkipTurns:= 9999;
Ammoz[amTardis].Probability:= 0;
end;
AddCaption(trmsg[sidSuddenDeath], cWhiteColor, capgrpGameState);
ScriptCall('onSuddenDeath');
playSound(sndSuddenDeath);
StopMusic;
if SDMusicFN <> '' then PlayMusic
end
else if (TotalRounds < cSuddenDTurns) and (not isInMultiShoot) then
begin
i:= cSuddenDTurns - TotalRounds;
s:= ansistring(inttostr(i));
if i = 1 then
AddCaption(trmsg[sidRoundSD], cWhiteColor, capgrpGameState)
else if (i = 2) or ((i > 0) and ((i mod 50 = 0) or ((i <= 25) and (i mod 5 = 0)))) then
AddCaption(FormatA(trmsg[sidRoundsSD], s), cWhiteColor, capgrpGameState);
end;
end;
if bBetweenTurns
or isInMultiShoot
or (TotalRounds = -1) then
inc(step)
else
begin
bBetweenTurns:= true;
HealthMachine;
step:= stChDmg
end
end;
stSpawn:
begin
if not isInMultiShoot then
SpawnBoxOfSmth;
inc(step)
end;
stNTurn:
begin
if isInMultiShoot then
isInMultiShoot:= false
else
begin
// delayed till after 0.9.12
// reset to default zoom
//ZoomValue:= ZoomDefault;
with CurrentHedgehog^ do
if (Gear <> nil)
and ((Gear^.State and gstAttacked) = 0)
and (MultiShootAttacks > 0) then
OnUsedAmmo(CurrentHedgehog^);
EndTurnCleanup;
FreeActionsList; // could send -left, -right and similar commands, so should be called before /nextturn
ParseCommand('/nextturn', true);
SwitchHedgehog;
AfterSwitchHedgehog;
bBetweenTurns:= false;
NewTurnTick:= GameTicks + 1
end;
step:= Low(step)
end;
end
else if ((GameFlags and gfInfAttack) <> 0) then
begin
if delay2 = 0 then
delay2:= cInactDelay * 50
else
begin
dec(delay2);
if ((delay2 mod cInactDelay) = 0) and (CurrentHedgehog <> nil) and (CurrentHedgehog^.Gear <> nil)
and (not CurrentHedgehog^.Unplaced) then
begin
if (CurrentHedgehog^.Gear^.State and gstAttacked <> 0)
and (Ammoz[CurrentHedgehog^.CurAmmoType].Ammo.Propz and ammoprop_NeedTarget <> 0) then
begin
CurrentHedgehog^.Gear^.State:= CurrentHedgehog^.Gear^.State or gstChooseTarget;
isCursorVisible := true
end;
CurrentHedgehog^.Gear^.State:= CurrentHedgehog^.Gear^.State and (not gstAttacked);
end;
if delay2 = 0 then
begin
if (CurrentHedgehog^.Gear <> nil) and (CurrentHedgehog^.Gear^.State and gstAttacked = 0)
and (CurAmmoGear = nil) then
SweepDirty;
if (CurrentHedgehog^.Gear = nil) or (CurrentHedgehog^.Gear^.State and gstHHDriven = 0) or (CurrentHedgehog^.Gear^.Damage = 0) then
CheckNoDamage;
AliveCount:= 0; // shorter version of check for win to allow typical step activity to proceed
for i:= 0 to Pred(ClansCount) do
if ClansArray[i]^.ClanHealth > 0 then
inc(AliveCount);
if (AliveCount <= 1) and ((GameFlags and gfOneClanMode) = 0) then
begin
step:= stChDmg;
if TagTurnTimeLeft = 0 then
TagTurnTimeLeft:= TurnTimeLeft;
TurnTimeLeft:= 0
end
end
end
end;
if TurnTimeLeft > 0 then
if IsClockRunning() then
//(CurrentHedgehog^.CurAmmoType in [amShotgun, amDEagle, amSniperRifle])
begin
if (cHedgehogTurnTime >= 10000)
and (CurrentHedgehog^.Gear <> nil)
and ((CurrentHedgehog^.Gear^.State and gstAttacked) = 0)
and (not isGetAwayTime) then
if TurnTimeLeft = 5000 then
PlaySoundV(sndHurry, CurrentTeam^.voicepack)
else if TurnTimeLeft = 4000 then
PlaySound(sndCountdown4)
else if TurnTimeLeft = 3000 then
PlaySound(sndCountdown3)
else if TurnTimeLeft = 2000 then
PlaySound(sndCountdown2)
else if TurnTimeLeft = 1000 then
PlaySound(sndCountdown1);
if ReadyTimeLeft > 0 then
begin
if (ReadyTimeLeft = 2000) and (LastVoice.snd = sndNone) and (not PlacingHogs) then
AddVoice(sndComeonthen, CurrentTeam^.voicepack);
dec(ReadyTimeLeft)
end
else
dec(TurnTimeLeft)
end;
if skipFlag then
begin
if TagTurnTimeLeft = 0 then
TagTurnTimeLeft:= TurnTimeLeft;
TurnTimeLeft:= 0;
skipFlag:= false;
inc(CurrentHedgehog^.Team^.stats.TurnSkips);
end;
if ((GameTicks and $FFFF) = $FFFF) then
begin
if (not CurrentTeam^.ExtDriven) then
begin
SendIPC(_S'#');
AddFileLog('hiTicks increment message sent')
end;
if (not CurrentTeam^.ExtDriven) or CurrentTeam^.hasGone then
begin
AddFileLog('hiTicks increment (current team is local or gone)');
inc(hiTicks) // we do not recieve a message for this
end
end;
AddRandomness(CheckSum);
TurnClockActive:= prevtime <> TurnTimeLeft;
inc(GameTicks)
end;
//Purpose, to reset all transient attributes toggled by a utility and clean up various gears and effects at end of turn
//If any of these are set as permanent toggles in the frontend, that needs to be checked and skipped here.
procedure EndTurnCleanup;
var i: LongInt;
t: PGear;
begin
SpeechText:= ''; // in case it has not been consumed
if (GameFlags and gfLowGravity) = 0 then
begin
cGravity:= cMaxWindSpeed * 2;
cGravityf:= 0.00025 * 2;
cLowGravity:= false
end;
if (GameFlags and gfVampiric) = 0 then
cVampiric:= false;
cDamageModifier:= _1;
if (GameFlags and gfLaserSight) = 0 then
cLaserSighting:= false;
if (GameFlags and gfArtillery) = 0 then
cArtillery:= false;
// have to sweep *all* current team hedgehogs since it is theoretically possible if you have enough invulnerabilities and switch turns to make your entire team invulnerable
if (CurrentTeam <> nil) then
with CurrentTeam^ do
for i:= 0 to cMaxHHIndex do
with Hedgehogs[i] do
begin
(*
if (SpeechGear <> nil) then
begin
DeleteVisualGear(SpeechGear); // remove to restore persisting beyond end of turn. Tiy says was too much of a gameplay issue
SpeechGear:= nil
end;
*)
if (Gear <> nil) then
begin
if (GameFlags and gfInvulnerable) = 0 then
Gear^.Hedgehog^.Effects[heInvulnerable]:= 0;
end;
end;
t:= GearsList;
while t <> nil do
begin
t^.PortalCounter:= 0;
if ((GameFlags and gfResetHealth) <> 0) and (t^.Kind = gtHedgehog) and (t^.Health < t^.Hedgehog^.InitialHealth) then
begin
t^.Health:= t^.Hedgehog^.InitialHealth;
RenderHealth(t^.Hedgehog^);
end;
t:= t^.NextGear
end;
if ((GameFlags and gfResetWeps) <> 0) and (not PlacingHogs) then
ResetWeapons;
if (GameFlags and gfResetHealth) <> 0 then
for i:= 0 to Pred(TeamsCount) do
RecountTeamHealth(TeamsArray[i])
end;
procedure DrawGears;
var Gear: PGear;
x, y: LongInt;
begin
Gear:= GearsList;
while Gear <> nil do
begin
if (Gear^.State and gstInvisible = 0) and (Gear^.Message and gmRemoveFromList = 0) then
begin
x:= hwRound(Gear^.X) + WorldDx;
y:= hwRound(Gear^.Y) + WorldDy;
RenderGear(Gear, x, y);
end;
Gear:= Gear^.NextGear
end;
if SpeechHogNumber > 0 then
DrawHHOrder();
end;
procedure DrawGearsTimers;
var Gear: PGear;
x, y: LongInt;
begin
Gear:= GearsList;
while Gear <> nil do
begin
x:= hwRound(Gear^.X) + WorldDx;
y:= hwRound(Gear^.Y) + WorldDy;
RenderGearTimer(Gear, x, y);
Gear:= Gear^.NextGear
end;
end;
procedure FreeGearsList;
var t, tt: PGear;
begin
tt:= GearsList;
GearsList:= nil;
while tt <> nil do
begin
t:= tt;
tt:= tt^.NextGear;
Dispose(t)
end;
end;
procedure AddMiscGears;
var p,i,j,t,h,unplaced: Longword;
rx, ry: LongInt;
rdx, rdy: hwFloat;
Gear: PGear;
begin
AddGear(0, 0, gtATStartGame, 0, _0, _0, 2000);
i:= 0;
unplaced:= 0;
while (i < cLandMines) and (unplaced < 4) do
begin
Gear:= AddGear(0, 0, gtMine, 0, _0, _0, 0);
FindPlace(Gear, false, 0, LAND_WIDTH);
if Gear = nil then
inc(unplaced)
else
unplaced:= 0;
inc(i)
end;
i:= 0;
unplaced:= 0;
while (i < cExplosives) and (unplaced < 4) do
begin
Gear:= AddGear(0, 0, gtExplosives, 0, _0, _0, 0);
FindPlace(Gear, false, 0, LAND_WIDTH);
if Gear = nil then
inc(unplaced)
else
unplaced:= 0;
inc(i)
end;
i:= 0;
j:= 0;
p:= 0; // 0 searching, 1 bad position, 2 added.
unplaced:= 0;
if cAirMines > 0 then
Gear:= AddGear(0, 0, gtAirMine, 0, _0, _0, 0);
while (i < cAirMines) and (j < 1000*cAirMines) do
begin
p:= 0;
if hasBorder then
begin
rx:= leftX+GetRandom(rightX-leftX-16)+8;
ry:= topY+GetRandom(LAND_HEIGHT-topY-16)+8
end
else
begin
rx:= leftX+GetRandom(rightX-leftX+400)-200;
ry:= topY+GetRandom(LAND_HEIGHT-topY+400)-200
end;
Gear^.X:= int2hwFloat(rx);
Gear^.Y:= int2hwFloat(ry);
if CheckLandValue(rx, ry, $FFFF) and
(TestCollisionYwithGear(Gear,-1) = 0) and
(TestCollisionXwithGear(Gear, 1) = 0) and
(TestCollisionXwithGear(Gear,-1) = 0) and
(TestCollisionYwithGear(Gear, 1) = 0) then
begin
t:= 0;
while (t < TeamsCount) and (p = 0) do
begin
h:= 0;
with TeamsArray[t]^ do
while (h < cMaxHHIndex) and (p = 0) do
begin
if (Hedgehogs[h].Gear <> nil) then
begin
rdx:=Gear^.X-Hedgehogs[h].Gear^.X;
rdy:=Gear^.Y-Hedgehogs[h].Gear^.Y;
if (Gear^.Angle < $FFFFFFFF) and
((rdx.Round+rdy.Round < Gear^.Angle) and
(hwRound(hwSqr(rdx) + hwSqr(rdy)) < sqr(Gear^.Angle))) then
begin
// Debug line. Remove later
// AddFileLog('Too Close to Hog @ (' + inttostr(rx) + ',' + inttostr(ry) + ')');
p:= 1
end
end;
inc(h)
end;
inc(t)
end;
if p = 0 then
begin
inc(i);
AddFileLog('Placed Air Mine @ (' + inttostr(rx) + ',' + inttostr(ry) + ')');
if i < cAirMines then
Gear:= AddGear(0, 0, gtAirMine, 0, _0, _0, 0)
end
end;
inc(j)
end;
if p <> 0 then DeleteGear(Gear);
if (GameFlags and gfLowGravity) <> 0 then
begin
cGravity:= cMaxWindSpeed;
cGravityf:= 0.00025;
cLowGravity:= true
end;
if (GameFlags and gfVampiric) <> 0 then
cVampiric:= true;
Gear:= GearsList;
if (GameFlags and gfInvulnerable) <> 0 then
for p:= 0 to Pred(ClansCount) do
with ClansArray[p]^ do
for j:= 0 to Pred(TeamsNumber) do
with Teams[j]^ do
for i:= 0 to cMaxHHIndex do
with Hedgehogs[i] do
Effects[heInvulnerable]:= 1;
if (GameFlags and gfLaserSight) <> 0 then
cLaserSighting:= true;
if (GameFlags and gfArtillery) <> 0 then
cArtillery:= true;
for i:= (LAND_WIDTH*LAND_HEIGHT) div 524288+2 downto 0 do
begin
rx:= GetRandom(rightX-leftX)+leftX;
ry:= GetRandom(LAND_HEIGHT-topY)+topY;
rdx:= _90-(GetRandomf*_360);
rdy:= _90-(GetRandomf*_360);
AddGear(rx, ry, gtGenericFaller, gstInvisible, rdx, rdy, $FFFFFFFF);
end;
snowRight:= max(LAND_WIDTH,4096)+512;
snowLeft:= -(snowRight-LAND_WIDTH);
if (not hasBorder) and cSnow then
for i:= vobCount * Longword(max(LAND_WIDTH,4096)) div 2048 downto 1 do
begin
rx:=GetRandom(snowRight - snowLeft);
ry:=GetRandom(750);
AddGear(rx + snowLeft, LongInt(LAND_HEIGHT) + ry - 1300, gtFlake, 0, _0, _0, 0)
end
end;
// sort clans horizontally (bubble-sort, because why not)
procedure SortHHsByClan();
var n, newn, i, j, k, p: LongInt;
ar, clar: array[0..Pred(cMaxHHs)] of PHedgehog;
Count, clCount: Longword;
tmpX, tmpY: hwFloat;
hh1, hh2: PHedgehog;
begin
Count:= 0;
// add hedgehogs to the array in clan order
for p:= 0 to (ClansCount - 1) do
with SpawnClansArray[p]^ do
begin
// count hogs in this clan
clCount:= 0;
for j:= 0 to Pred(TeamsNumber) do
with Teams[j]^ do
for i:= 0 to cMaxHHIndex do
if Hedgehogs[i].Gear <> nil then
begin
clar[clCount]:= @Hedgehogs[i];
inc(clCount);
end;
// shuffle all hogs of this clan
for i:= 0 to clCount - 1 do
begin
j:= GetRandom(clCount);
k:= GetRandom(clCount);
if clar[j] <> clar[k] then
begin
hh1:= clar[j];
clar[j]:= clar[k];
clar[k]:= hh1;
end;
end;
// add clan's hog to sorting array
for i:= 0 to clCount - 1 do
begin
ar[Count]:= clar[i];
inc(Count);
end;
end;
// bubble-sort hog array
n:= Count - 1;
repeat
newn:= 0;
for i:= 1 to n do
begin
hh1:= ar[i-1];
hh2:= ar[i];
if hwRound(hh1^.Gear^.X) > hwRound(hh2^.Gear^.X) then
begin
tmpX:= hh1^.Gear^.X;
tmpY:= hh1^.Gear^.Y;
hh1^.Gear^.X:= hh2^.Gear^.X;
hh1^.Gear^.Y:= hh2^.Gear^.Y;
hh2^.Gear^.X:= tmpX;
hh2^.Gear^.Y:= tmpY;
newn:= i;
end;
end;
n:= newn;
until n = 0;
end;
procedure AssignHHCoords;
var i, t, p, j: LongInt;
ar: array[0..Pred(cMaxHHs)] of PHedgehog;
Count: Longword;
divide, sectionDivide: boolean;
begin
if (GameFlags and gfPlaceHog) <> 0 then
PlacingHogs:= true;
divide:= ((GameFlags and gfDivideTeams) <> 0);
(* sectionDivide will determine the mode of hog distribution
*
* On generated maps or maps not designed with divided mode in mind,
* using spawning sections can be problematic, because some sections may
* contain too little land surface for sensible spawning.
*
* if sectionDivide is true, the map will be sliced into equal-width sections
* and one team spawned in each
* if false, the hogs will be spawned normally and sorted by teams after
*
*)
// TODO: there might be a smarter way to decide if dividing clans into equal-width map sections makes sense
// e.g. by checking if there is enough spawn area in each section
sectionDivide:= divide and ((cMapGen = mgForts) or (ClansCount = 2));
// divide the map into equal-width sections and put each clan in one of them
if sectionDivide then
begin
t:= leftX;
for p:= 0 to (ClansCount - 1) do
begin
with SpawnClansArray[p]^ do
for j:= 0 to Pred(TeamsNumber) do
with Teams[j]^ do
for i:= 0 to cMaxHHIndex do
with Hedgehogs[i] do
if (Gear <> nil) and (Gear^.X.QWordValue = 0) then
begin
if PlacingHogs then
Unplaced:= true
else
FindPlace(Gear, false, t, t + playWidth div ClansCount, true);// could make Gear == nil;
if Gear <> nil then
begin
Gear^.Pos:= GetRandom(49);
// unless the world is wrapping, make outter teams face to map center
if (WorldEdge <> weWrap) and ((p = 0) or (p = ClansCount - 1)) then
Gear^.dX.isNegative:= (p <> 0)
else
Gear^.dX.isNegative:= (GetRandom(2) = 1);
end
end;
inc(t, playWidth div ClansCount);
end
end
else // mix hedgehogs
begin
Count:= 0;
for p:= 0 to Pred(TeamsCount) do
with TeamsArray[p]^ do
begin
for i:= 0 to cMaxHHIndex do
with Hedgehogs[i] do
if (Gear <> nil) and (Gear^.X.QWordValue = 0) then
begin
ar[Count]:= @Hedgehogs[i];
inc(Count)
end;
end;
while (Count > 0) do
begin
i:= GetRandom(Count);
if PlacingHogs then
ar[i]^.Unplaced:= true
else
FindPlace(ar[i]^.Gear, false, leftX, rightX, true);
if ar[i]^.Gear <> nil then
begin
ar[i]^.Gear^.dX.isNegative:= hwRound(ar[i]^.Gear^.X) > leftX + playWidth div 2;
ar[i]^.Gear^.Pos:= GetRandom(19)
end;
ar[i]:= ar[Count - 1];
dec(Count)
end
end;
for p:= 0 to Pred(TeamsCount) do
with TeamsArray[p]^ do
for i:= 0 to cMaxHHIndex do
with Hedgehogs[i] do
if (Gear <> nil) and (Gear^.State and gsttmpFlag <> 0) then
begin
DrawExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 50);
AddFileLog('Carved a hole for hog at coordinates (' + inttostr(hwRound(Gear^.X)) + ',' + inttostr(hwRound(Gear^.Y)) + ')')
end;
// place flowers after in case holes overlap (we shrink search distance if we are failing to place)
for p:= 0 to Pred(TeamsCount) do
with TeamsArray[p]^ do
for i:= 0 to cMaxHHIndex do
with Hedgehogs[i] do
if (Gear <> nil) and (Gear^.State and gsttmpFlag <> 0) then
begin
ForcePlaceOnLand(hwRound(Gear^.X) - SpritesData[sprTargetBee].Width div 2,
hwRound(Gear^.Y) - SpritesData[sprTargetBee].Height div 2,
sprTargetBee, 0, lfBasic, $FFFFFFFF, false, false, false);
Gear^.Y:= int2hwFloat(hwRound(Gear^.Y) - 16 - Gear^.Radius);
Gear^.State:= Gear^.State and (not gsttmpFlag);
AddFileLog('Placed flower for hog at coordinates (' + inttostr(hwRound(Gear^.X)) + ',' + inttostr(hwRound(Gear^.Y)) + ')')
end;
// divided teams: sort the hedgehogs from left to right by clan and shuffle clan members
if divide and (not sectionDivide) then
SortHHsByClan();
end;
{procedure AmmoFlameWork(Ammo: PGear);
var t: PGear;
begin
t:= GearsList;
while t <> nil do
begin
if (t^.Kind = gtHedgehog) and (t^.Y < Ammo^.Y) then
if not (hwSqr(Ammo^.X - t^.X) + hwSqr(Ammo^.Y - t^.Y - int2hwFloat(cHHRadius)) * 2 > _2) then
begin
ApplyDamage(t, 5);
t^.dX:= t^.dX + (t^.X - Ammo^.X) * _0_02;
t^.dY:= - _0_25;
t^.Active:= true;
DeleteCI(t);
FollowGear:= t
end;
t:= t^.NextGear
end;
end;}
function SpawnCustomCrateAt(x, y: LongInt; crate: TCrateType; content, cnt: Longword): PGear;
begin
FollowGear := AddGear(x, y, gtCase, 0, _0, _0, 0);
cCaseFactor := 0;
if (crate <> HealthCrate) and (content > ord(High(TAmmoType))) then
content := ord(High(TAmmoType));
FollowGear^.Power:= cnt;
case crate of
HealthCrate:
begin
FollowGear^.Pos := posCaseHealth;
// health crate is smaller than the other crates
FollowGear^.Radius := cCaseHealthRadius;
FollowGear^.Health := content;
AddCaption(GetEventString(eidNewHealthPack), cWhiteColor, capgrpAmmoInfo);
end;
AmmoCrate:
begin
FollowGear^.Pos := posCaseAmmo;
FollowGear^.AmmoType := TAmmoType(content);
AddCaption(GetEventString(eidNewAmmoPack), cWhiteColor, capgrpAmmoInfo);
end;
UtilityCrate:
begin
FollowGear^.Pos := posCaseUtility;
FollowGear^.AmmoType := TAmmoType(content);
AddCaption(GetEventString(eidNewUtilityPack), cWhiteColor, capgrpAmmoInfo);
end;
end;
if ( (x = 0) and (y = 0) ) then
FindPlace(FollowGear, true, 0, LAND_WIDTH);
SpawnCustomCrateAt := FollowGear;
end;
function SpawnFakeCrateAt(x, y: LongInt; crate: TCrateType; explode: boolean; poison: boolean): PGear;
begin
FollowGear := AddGear(x, y, gtCase, 0, _0, _0, 0);
cCaseFactor := 0;
FollowGear^.Pos := posCaseDummy;
if explode then
FollowGear^.Pos := FollowGear^.Pos + posCaseExplode;
if poison then
FollowGear^.Pos := FollowGear^.Pos + posCasePoison;
case crate of
HealthCrate:
begin
FollowGear^.Pos := FollowGear^.Pos + posCaseHealth;
// health crate is smaller than the other crates
FollowGear^.Radius := cCaseHealthRadius;
AddCaption(GetEventString(eidNewHealthPack), cWhiteColor, capgrpAmmoInfo);
end;
AmmoCrate:
begin
FollowGear^.Pos := FollowGear^.Pos + posCaseAmmo;
AddCaption(GetEventString(eidNewAmmoPack), cWhiteColor, capgrpAmmoInfo);
end;
UtilityCrate:
begin
FollowGear^.Pos := FollowGear^.Pos + posCaseUtility;
AddCaption(GetEventString(eidNewUtilityPack), cWhiteColor, capgrpAmmoInfo);
end;
end;
if ( (x = 0) and (y = 0) ) then
FindPlace(FollowGear, true, 0, LAND_WIDTH);
SpawnFakeCrateAt := FollowGear;
end;
function GearByUID(uid : Longword) : PGear;
var gear: PGear;
begin
GearByUID:= nil;
if uid = 0 then exit;
if (lastGearByUID <> nil) and (lastGearByUID^.uid = uid) then
begin
GearByUID:= lastGearByUID;
exit
end;
gear:= GearsList;
while gear <> nil do
begin
if gear^.uid = uid then
begin
lastGearByUID:= gear;
GearByUID:= gear;
exit
end;
gear:= gear^.NextGear
end
end;
function IsClockRunning() : boolean;
begin
IsClockRunning :=
(CurrentHedgehog^.Gear <> nil)
and (((CurrentHedgehog^.Gear^.State and gstAttacking) = 0)
or (Ammoz[CurrentHedgehog^.CurAmmoType].Ammo.Propz and ammoprop_DoesntStopTimerWhileAttacking <> 0)
or ((GameFlags and gfInfAttack) <> 0) and (Ammoz[CurrentHedgehog^.CurAmmoType].Ammo.Propz and ammoprop_DoesntStopTimerWhileAttackingInInfAttackMode <> 0)
or (CurrentHedgehog^.CurAmmoType = amSniperRifle))
and (not(isInMultiShoot and ((Ammoz[CurrentHedgehog^.CurAmmoType].Ammo.Propz and ammoprop_DoesntStopTimerInMultiShoot) <> 0)));
end;
procedure chSkip(var s: shortstring);
begin
s:= s; // avoid compiler hint
if not isExternalSource then
SendIPC(_S',');
uStats.Skipped;
skipFlag:= true
end;
procedure chHogSay(var s: shortstring);
var Gear: PVisualGear;
text: shortstring;
hh: PHedgehog;
i, x, t, h: byte;
c, j: LongInt;
begin
hh:= nil;
i:= 0;
t:= 0;
x:= byte(s[1]); // speech type
if x < 4 then
begin
t:= byte(s[2]); // team
if Length(s) > 2 then
h:= byte(s[3]) // target hog
else
h:= 0
end;
// allow targetting a hog by specifying a number as the first portion of the text
if (x < 4) and (h > byte('0')) and (h < byte('9')) then
i:= h - 48;
if i <> 0 then
text:= copy(s, 4, Length(s) - 1)
else if x < 4 then
text:= copy(s, 3, Length(s) - 1)
else text:= copy(s, 2, Length(s) - 1);
if text = '' then text:= '...';
(*
if CheckNoTeamOrHH then
begin
ParseCommand('say ' + text, true);
exit
end;
*)
if (x < 4) and (TeamsArray[t] <> nil) then
begin
// if team matches current hedgehog team, default to current hedgehog
if (i = 0) and (CurrentHedgehog <> nil) and (CurrentHedgehog^.Team = TeamsArray[t]) then
hh:= CurrentHedgehog
else
begin
// otherwise use the first living hog or the hog amongs the remaining ones indicated by i
j:= 0;
c:= 0;
while (j <= cMaxHHIndex) and (hh = nil) do
begin
if (TeamsArray[t]^.Hedgehogs[j].Gear <> nil) then
begin
inc(c);
if (i=0) or (i=c) then
hh:= @TeamsArray[t]^.Hedgehogs[j]
end;
inc(j)
end
end;
if hh <> nil then
begin
Gear:= AddVisualGear(0, 0, vgtSpeechBubble);
if Gear <> nil then
begin
Gear^.Hedgehog:= hh;
Gear^.Text:= text;
Gear^.FrameTicks:= x
end;
//ParseCommand('/say [' + hh^.Name + '] '+text, true)
AddChatString(#9+'[' + HH^.Name + '] '+text);
end
end
else if (x >= 4) then
begin
SpeechType:= x-3;
SpeechText:= text
end;
end;
procedure initModule;
const handlers: array[TGearType] of TGearStepProcedure = (
@doStepFlame,
@doStepHedgehog,
@doStepMine,
@doStepCase,
@doStepAirMine,
@doStepCase,
@doStepBomb,
@doStepShell,
@doStepGrave,
@doStepBee,
@doStepShotgunShot,
@doStepPickHammer,
@doStepRope,
@doStepDEagleShot,
@doStepDynamite,
@doStepBomb,
@doStepCluster,
@doStepShover,
@doStepFirePunch,
@doStepActionTimer,
@doStepActionTimer,
@doStepParachute,
@doStepAirAttack,
@doStepAirBomb,
@doStepBlowTorch,
@doStepGirder,
@doStepTeleport,
@doStepSwitcher,
@doStepTarget,
@doStepMortar,
@doStepWhip,
@doStepKamikaze,
@doStepCake,
@doStepSeduction,
@doStepBomb,
@doStepCluster,
@doStepBomb,
@doStepWaterUp,
@doStepDrill,
@doStepBallgun,
@doStepBomb,
@doStepRCPlane,
@doStepSniperRifleShot,
@doStepJetpack,
@doStepMolotov,
@doStepBirdy,
@doStepEggWork,
@doStepPortalShot,
@doStepPiano,
@doStepBomb,
@doStepSineGunShot,
@doStepFlamethrower,
@doStepSMine,
@doStepPoisonCloud,
@doStepHammer,
@doStepHammerHit,
@doStepResurrector,
@doStepNapalmBomb,
@doStepSnowball,
@doStepSnowflake,
//@doStepStructure,
@doStepLandGun,
@doStepTardis,
@doStepIceGun,
@doStepAddAmmo,
@doStepGenericFaller,
@doStepKnife,
@doStepDuck);
begin
doStepHandlers:= handlers;
RegisterVariable('skip', @chSkip, false);
RegisterVariable('hogsay', @chHogSay, true );
CurAmmoGear:= nil;
GearsList:= nil;
curHandledGear:= nil;
KilledHHs:= 0;
SuddenDeath:= false;
SuddenDeathDmg:= false;
SpeechType:= 1;
skipFlag:= false;
AllInactive:= false;
PrvInactive:= false;
//typed const
delay:= 0;
delay2:= 0;
step:= stDelay;
upd:= 0;
//SDMusic:= 'hell.ogg';
NewTurnTick:= $FFFFFFFF;
end;
procedure freeModule;
begin
FreeGearsList();
end;
end.