--- a/CMakeLists.txt Fri Jul 13 16:39:20 2012 +0400
+++ b/CMakeLists.txt Thu Jul 26 21:56:47 2012 +0400
@@ -159,10 +159,19 @@
set(CMAKE_CXX_FLAGS_RELEASE ${CMAKE_C_FLAGS_RELEASE})
set(CMAKE_CXX_FLAGS_DEBUG ${CMAKE_C_FLAGS_DEBUG})
-separate_arguments(fpflags_full UNIX_COMMAND ${FPFLAGS})
+#parse additional parameters
+if(FPFLAGS OR GHFLAGS)
+ math(EXPR cmake_version "${CMAKE_MAJOR_VERSION}*10000 + ${CMAKE_MINOR_VERSION}*100 + ${CMAKE_PATCH_VERSION}")
+ if(cmake_version LESS "020800")
+ message(STATUS "FPFLAGS and GHFLAGS are available only from Cmake 2.8, ignoring...")
+ else()
+ separate_arguments(fpflags_full UNIX_COMMAND ${FPFLAGS})
+ separate_arguments(ghflags_full UNIX_COMMAND ${GHFLAGS})
+ endif()
+endif()
+
set(pascal_flags ${fpflags_full} "-B" "-FE../bin" "-Cs2000000" "-vewn" "-dDEBUGFILE" ${pascal_flags})
-separate_arguments(ghflags_full UNIX_COMMAND ${GHFLAGS})
-set(haskell_flags "-O2" ${haskell_flags} ${ghflags_full})
+set(haskell_flags "-O2" ${ghflags_full} ${haskell_flags})
if(Optz)
# set(pascal_flags "-O3" "-OpPENTIUM4" "-CfSSE3" "-Xs" "-Si" ${pascal_flags})
--- a/QTfrontend/binds.cpp Fri Jul 13 16:39:20 2012 +0400
+++ b/QTfrontend/binds.cpp Thu Jul 26 21:56:47 2012 +0400
@@ -62,6 +62,7 @@
{"confirm", "y", QT_TRANSLATE_NOOP("binds", "confirmation"), NULL, NULL},
{"+voldown", "9", QT_TRANSLATE_NOOP("binds", "volume down"), NULL, QT_TRANSLATE_NOOP("binds (descriptions)", "Modify the game's volume while playing:")},
{"+volup", "0", QT_TRANSLATE_NOOP("binds", "volume up"), NULL, NULL},
+ {"mute", "8", QT_TRANSLATE_NOOP("binds", "mute audio"), NULL, NULL},
{"fullscr", "f12", QT_TRANSLATE_NOOP("binds", "change mode"), NULL, QT_TRANSLATE_NOOP("binds (descriptions)", "Toggle fullscreen mode:")},
{"capture", "c", QT_TRANSLATE_NOOP("binds", "capture"), NULL, QT_TRANSLATE_NOOP("binds (descriptions)", "Take a screenshot:")},
{"rotmask", "delete", QT_TRANSLATE_NOOP("binds", "hedgehogs\ninfo"), NULL, QT_TRANSLATE_NOOP("binds (descriptions)", "Toggle labels above hedgehogs:")},
--- a/QTfrontend/model/ammoSchemeModel.h Fri Jul 13 16:39:20 2012 +0400
+++ b/QTfrontend/model/ammoSchemeModel.h Thu Jul 26 21:56:47 2012 +0400
@@ -47,8 +47,8 @@
public slots:
void Save();
- signals:
- void dataChanged(const QModelIndex & topLeft, const QModelIndex & bottomRight);
+// signals:
+// void dataChanged(const QModelIndex & topLeft, const QModelIndex & bottomRight);
protected:
QList< QList<QVariant> > schemes;
--- a/hedgewars/GSHandlers.inc Fri Jul 13 16:39:20 2012 +0400
+++ b/hedgewars/GSHandlers.inc Thu Jul 26 21:56:47 2012 +0400
@@ -116,12 +116,12 @@
if lastGearByUID = HH^.Gear then
lastGearByUID := nil;
-
- RemoveGearFromList(HH^.Gear);
+
+ HH^.Gear^.Message:= HH^.Gear^.Message or gmRemoveFromList;
with HH^.Gear^ do
begin
Z := cHHZ;
- Active := false;
+ HH^.Gear^.Active:= false;
State:= State and (not (gstHHDriven or gstAttacking or gstAttacked));
Message := Message and (not gmAttack);
end;
@@ -733,7 +733,14 @@
////////////////////////////////////////////////////////////////////////////////
procedure doStepGrave(Gear: PGear);
begin
+ if (Gear^.Message and gmDestroy) <> 0 then
+ begin
+ DeleteGear(Gear);
+ exit
+ end;
+
AllInactive := false;
+
if Gear^.dY.isNegative then
if TestCollisionY(Gear, -1) then
Gear^.dY := _0;
@@ -2080,6 +2087,7 @@
dX, dY: HWFloat;
hog: PHedgehog;
sparkles: PVisualGear;
+ gi: PGear;
begin
k := Gear^.Kind;
exBoom := false;
@@ -2114,6 +2122,23 @@
end
else
begin
+ if (Gear^.Pos <> posCaseHealth) and (GameTicks and $3FF = 0) then // stir it up every second or so
+ begin
+ gi := GearsList;
+ while gi <> nil do
+ begin
+ if gi^.Kind = gtGenericFaller then
+ begin
+ gi^.Active:= true;
+ gi^.X:= int2hwFloat(GetRandom(rightX-leftX)+leftX);
+ gi^.Y:= int2hwFloat(GetRandom(LAND_HEIGHT-topY)+topY);
+ gi^.dX:= _90-(GetRandomf*_360);
+ gi^.dY:= _90-(GetRandomf*_360)
+ end;
+ gi := gi^.NextGear
+ end
+ end;
+
if Gear^.Timer = 500 then
begin
(* Can't make sparkles team coloured without working out what the next team is going to be. This should be solved, really, since it also screws up
@@ -2381,7 +2406,7 @@
//DrawExplosion(gX, gY, 4);
if ((GameTicks and $7) = 0) and (Random(2) = 0) then
- for i:= 1 to Random(2)+1 do
+ for i:= Random(2) downto 0 do
AddVisualGear(gX - 3 + Random(6), gY - 2, vgtSmoke);
if Gear^.Health > 0 then
@@ -2395,7 +2420,7 @@
begin
DrawExplosion(gX, gY, 4);
- for i:= 0 to Random(3) do
+ for i:= Random(3) downto 0 do
AddVisualGear(gX - 3 + Random(6), gY - 2, vgtSmoke);
end;
@@ -2413,20 +2438,12 @@
if not sticky then
begin
if ((GameTicks and $3) = 0) and (Random(1) = 0) then
- begin
- for i:= 1 to Random(2)+1 do
- begin
+ for i:= Random(2) downto 0 do
AddVisualGear(gX - 3 + Random(6), gY - 2, vgtSmoke);
- end;
- end;
end
else
- begin
- for i:= 0 to Random(3) do
- begin
+ for i:= Random(3) downto 0 do
AddVisualGear(gX - 3 + Random(6), gY - 2, vgtSmoke);
- end;
- end;
DeleteGear(Gear)
end;
@@ -2775,10 +2792,9 @@
Gear^.Message := Gear^.Message and (not gmSwitch);
State := HHGear^.State;
HHGear^.State := 0;
+ HHGear^.Z := cHHZ;
HHGear^.Active := false;
- HHGear^.Z := cHHZ;
- RemoveGearFromList(HHGear);
- InsertGearToList(HHGear);
+ HHGear^.Message:= HHGear^.Message or gmRemoveFromList or gmAddToList;
PlaySound(sndSwitchHog);
@@ -2794,8 +2810,7 @@
HHGear^.Active := true;
FollowGear := HHGear;
HHGear^.Z := cCurrHHZ;
- RemoveGearFromList(HHGear);
- InsertGearToList(HHGear);
+ HHGear^.Message:= HHGear^.Message or gmRemoveFromList or gmAddToList;
Gear^.X := HHGear^.X;
Gear^.Y := HHGear^.Y
end;
@@ -2940,7 +2955,7 @@
end
end;
AfterAttack;
- DeleteGear(HHGear);
+ HHGear^.Message:= HHGear^.Message or gmDestroy;
DeleteGear(Gear);
end
else
@@ -2984,7 +2999,6 @@
////////////////////////////////////////////////////////////////////////////////
const cakeh = 27;
- cakeDmg = 75;
var
CakePoints: array[0..Pred(cakeh)] of record
x, y: hwFloat;
@@ -3068,6 +3082,19 @@
if Gear^.Tag < 7 then
exit;
+ dec(Gear^.Health);
+ Gear^.Timer := Gear^.Health*10;
+ if Gear^.Health mod 100 = 0 then
+ Gear^.PortalCounter:= 0;
+ // This is not seconds, but at least it is *some* feedback
+ if (Gear^.Health = 0) or ((Gear^.Message and gmAttack) <> 0) then
+ begin
+ FollowGear := Gear;
+ Gear^.RenderTimer := false;
+ Gear^.doStep := @doStepCakeDown;
+ exit
+ end;
+
cakeStep(Gear);
if Gear^.Tag = 0 then
@@ -3079,18 +3106,6 @@
CakePoints[CakeI].y := Gear^.Y;
Gear^.DirAngle := DxDy2Angle(tdx, tdy);
end;
-
- dec(Gear^.Health);
- Gear^.Timer := Gear^.Health*10;
- if Gear^.Health mod 100 = 0 then
- Gear^.PortalCounter:= 0;
- // This is not seconds, but at least it is *some* feedback
- if (Gear^.Health = 0) or ((Gear^.Message and gmAttack) <> 0) then
- begin
- FollowGear := Gear;
- Gear^.RenderTimer := false;
- Gear^.doStep := @doStepCakeDown
- end
end;
procedure doStepCakeUp(Gear: PGear);
@@ -4296,7 +4311,7 @@
and (CurAmmoGear^.Kind =gtRope) then
CurAmmoGear^.PortalCounter:= 1;
- if not isbullet
+ if not isbullet and (iterator^.State and gstInvisible = 0)
and (iterator^.Kind <> gtFlake) then
FollowGear := iterator;
@@ -4375,7 +4390,7 @@
Gear^.State := Gear^.State and (not gstMoving);
if (Land[y, x] and lfBouncy <> 0)
- or not CalcSlopeTangent(Gear, x, y, tx, ty, 255)
+ or (not CalcSlopeTangent(Gear, x, y, tx, ty, 255))
or (DistanceI(tx,ty) < _12) then // reject shots at too irregular terrain
begin
loadNewPortalBall(Gear, true);
@@ -4655,11 +4670,13 @@
// add some fire to the tunnel
if getRandom(6) = 0 then
- AddGear(x - Gear^.Radius + LongInt(getRandom(2 * Gear^.Radius)), y -
- getRandom(Gear^.Radius + 1), gtFlame, gsttmpFlag, _0, _0, 0);
+ begin
+ tmp:= GetRandom(2 * Gear^.Radius);
+ AddGear(x - Gear^.Radius + tmp, y - GetRandom(Gear^.Radius + 1), gtFlame, gsttmpFlag, _0, _0, 0)
+ end
end;
- if getRandom(100) = 0 then
+ if random(100) = 0 then
AddVisualGear(x, y, vgtSmokeTrace);
end
else dec(Gear^.Health, 5); // if underwater get additional damage
@@ -5069,6 +5086,7 @@
if (hh^.Gear^.Health = 0) and (hh^.Gear^.Damage = 0) then
hh^.Gear^.Damage:= 1;
RenderHealth(hh^);
+ RecountTeamHealth(hh^.Team);
inc(graves.ar^[Gear^.Tag]^.Health);
inc(Gear^.Tag)
{-for i:= 0 to High(graves) do begin
@@ -5088,12 +5106,13 @@
resgear^.Hedgehog := graves.ar^[i]^.Hedgehog;
resgear^.Health := graves.ar^[i]^.Health;
PHedgehog(graves.ar^[i]^.Hedgehog)^.Gear := resgear;
- DeleteGear(graves.ar^[i]);
+ graves.ar^[i]^.Message:= graves.ar^[i]^.Message or gmDestroy;
+ graves.ar^[i]^.Active:= true;
RenderHealth(resgear^.Hedgehog^);
RecountTeamHealth(resgear^.Hedgehog^.Team);
resgear^.Hedgehog^.Effects[heResurrected]:= 1;
// only make hat-less hedgehogs look like zombies, preserve existing hats
-
+
if resgear^.Hedgehog^.Hat = 'NoHat' then
LoadHedgehogHat(resgear, 'Reserved/Zombie');
end;
@@ -5532,3 +5551,41 @@
end
end;
end;
+
+procedure doStepAddAmmo(Gear: PGear);
+var a: TAmmoType;
+ gi: PGear;
+begin
+if Gear^.Timer > 0 then dec(Gear^.Timer)
+else
+ begin
+ if Gear^.Pos = posCaseUtility then
+ a:= GetUtility(Gear^.Hedgehog)
+ else
+ a:= GetAmmo(Gear^.Hedgehog);
+ CheckSum:= CheckSum xor GameTicks;
+ gi := GearsList;
+ while gi <> nil do
+ begin
+ with gi^ do CheckSum:= CheckSum xor X.round xor X.frac xor dX.round xor dX.frac xor Y.round xor Y.frac xor dY.round xor dY.frac;
+ AddRandomness(CheckSum);
+ gi := gi^.NextGear
+ end;
+ AddPickup(Gear^.Hedgehog^, a, Gear^.Power, hwRound(Gear^.X), hwRound(Gear^.Y));
+ DeleteGear(Gear)
+ end;
+end;
+
+procedure doStepGenericFaller(Gear: PGear);
+begin
+if Gear^.Timer < $FFFFFFFF then
+ if Gear^.Timer > 0 then
+ dec(Gear^.Timer)
+ else
+ begin
+ DeleteGear(Gear);
+ exit
+ end;
+
+doStepFallingGear(Gear);
+end;
--- a/hedgewars/hwengine.pas Fri Jul 13 16:39:20 2012 +0400
+++ b/hedgewars/hwengine.pas Thu Jul 26 21:56:47 2012 +0400
@@ -32,8 +32,6 @@
uses SDLh, uMisc, uConsole, uGame, uConsts, uLand, uAmmos, uVisualGears, uGears, uStore, uWorld, uInputHandler, uSound,
uScript, uTeams, uStats, uIO, uLocale, uChat, uAI, uAIMisc, uRandom, uLandTexture, uCollisions,
SysUtils, uTypes, uVariables, uCommands, uUtils, uCaptions, uDebug, uCommandHandlers, uLandPainted
- {$IFDEF USE_VIDEO_RECORDING}, uVideoRec {$ENDIF}
- {$IFDEF SDL13}, uTouch{$ENDIF}{$IFDEF ANDROID}, GLUnit{$ENDIF};
{$IFDEF HWLIBRARY}
procedure initEverything(complete:boolean);
@@ -461,6 +459,7 @@
uAI.initModule;
//uAIActions does not need initialization
//uAIAmmoTests does not need initialization
+ uAILandMarks.initModule;
uAIMisc.initModule;
uAmmos.initModule;
uChat.initModule;
@@ -492,6 +491,7 @@
begin
WriteLnToConsole('Freeing resources...');
uAI.freeModule;
+ uAILandMarks.freeModule;
uAIMisc.freeModule; //stub
uCaptions.freeModule;
uWorld.freeModule;
--- a/hedgewars/uAI.pas Fri Jul 13 16:39:20 2012 +0400
+++ b/hedgewars/uAI.pas Thu Jul 26 21:56:47 2012 +0400
@@ -31,7 +31,7 @@
implementation
uses uConsts, SDLh, uAIMisc, uAIAmmoTests, uAIActions,
uAmmos, SysUtils{$IFNDEF USE_SDLTHREADS} {$IFDEF UNIX}, cthreads{$ENDIF} {$ENDIF}, uTypes,
- uVariables, uCommands, uUtils, uDebug;
+ uVariables, uCommands, uUtils, uDebug, uAILandMarks;
var BestActions: TActions;
CanUseAmmo: array [TAmmoType] of boolean;
@@ -191,7 +191,14 @@
AddAction(BestActions, aia_attack, aim_push, 650 + random(300), 0, 0);
AddAction(BestActions, aia_attack, aim_release, ap.Power, 0, 0);
end;
-
+
+ if (Ammoz[a].Ammo.Propz and ammoprop_Track) <> 0 then
+ begin
+ AddAction(BestActions, aia_waitAmmoXY, 0, 12, ap.ExplX, ap.ExplY);
+ AddAction(BestActions, aia_attack, aim_push, 1, 0, 0);
+ AddAction(BestActions, aia_attack, aim_release, 7, 0, 0);
+ end;
+
if ap.ExplR > 0 then
AddAction(BestActions, aia_AwareExpl, ap.ExplR, 10, ap.ExplX, ap.ExplY);
end
@@ -205,7 +212,7 @@
end;
procedure Walk(Me: PGear; var Actions: TActions);
-const FallPixForBranching = cHHRadius * 2 + 8;
+const FallPixForBranching = cHHRadius;
var
ticks, maxticks, steps, tmp: Longword;
BaseRate, BestRate, Rate: integer;
@@ -268,6 +275,7 @@
if (BotLevel < 5) and (GoInfo.JumpType = jmpHJump) then // hjump support
if Push(ticks, Actions, AltMe, Me^.Message) then
+ begin
with Stack.States[Pred(Stack.Count)] do
begin
if Me^.dX.isNegative then
@@ -283,11 +291,21 @@
else
AddAction(MadeActions, aia_LookRight, 0, 200, 0, 0);
end;
+
+ // check if we could go backwards and maybe ljump over a gap after this hjump
+ Push(ticks, Stack.States[Pred(Stack.Count)].MadeActions, AltMe, Me^.Message xor 3)
+ end;
if (BotLevel < 3) and (GoInfo.JumpType = jmpLJump) then // ljump support
begin
- // push current position so we proceed from it after checking jump opportunities
+ // at final check where we go after jump walking backward
+ if Push(ticks, Actions, AltMe, Me^.Message xor 3) then
+ with Stack.States[Pred(Stack.Count)] do
+ AddAction(MadeActions, aia_LJump, 0, 305 + random(50), 0, 0);
+
+ // push current position so we proceed from it after checking jump+forward walk opportunities
if CanGo then Push(ticks, Actions, Me^, Me^.Message);
- // first check where we go after jump
+
+ // first check where we go after jump walking forward
if Push(ticks, Actions, AltMe, Me^.Message) then
with Stack.States[Pred(Stack.Count)] do
AddAction(MadeActions, aia_LJump, 0, 305 + random(50), 0, 0);
@@ -310,8 +328,16 @@
end
else if Rate < BestRate then
break;
+
if ((Me^.State and gstAttacked) = 0) and ((steps mod 4) = 0) then
+ begin
+ if (steps > 4) and checkMark(hwRound(Me^.X), hwRound(Me^.Y), markWasHere) then
+ break;
+ addMark(hwRound(Me^.X), hwRound(Me^.Y), markWasHere);
+
TestAmmos(Actions, Me, true);
+ end;
+
if GoInfo.FallPix >= FallPixForBranching then
Push(ticks, Actions, Me^, Me^.Message xor 3); // aia_Left xor 3 = aia_Right
end {while};
@@ -408,7 +434,7 @@
end
end;
-PGear(Me)^.State:= PGear(Me)^.State and not gstHHThinking;
+PGear(Me)^.State:= PGear(Me)^.State and (not gstHHThinking);
Think:= 0;
InterlockedDecrement(hasThread)
end;
@@ -419,7 +445,9 @@
or isInMultiShoot then
exit;
-//DeleteCI(Me); // this might break demo
+//DeleteCI(Me); // this will break demo/netplay
+clearAllMarks;
+
Me^.State:= Me^.State or gstHHThinking;
Me^.Message:= 0;
@@ -476,12 +504,11 @@
end else
begin
- (*
- if not scoreShown then
+ {if not scoreShown then
begin
if BestActions.Score > 0 then ParseCommand('/say Expected score = ' + inttostr(BestActions.Score div 1024), true);
scoreShown:= true
- end;*)
+ end;}
ProcessAction(BestActions, Gear)
end
else if ((GameTicks - StartTicks) > cMaxAIThinkTime)
--- a/hedgewars/uAIActions.pas Fri Jul 13 16:39:20 2012 +0400
+++ b/hedgewars/uAIActions.pas Thu Jul 26 21:56:47 2012 +0400
@@ -44,6 +44,7 @@
aia_Wait = $8009;
aia_Put = $800A;
aia_waitAngle = $800B;
+ aia_waitAmmoXY = $800C;
aim_push = $8000;
aim_release = $8001;
@@ -115,19 +116,19 @@
procedure AddAction(var Actions: TActions; Action: Longword; Param: LongInt; TimeDelta: Longword; X, Y: LongInt);
begin
-with Actions do
- begin
- actions[Count].Action:= Action;
- actions[Count].Param:= Param;
- actions[Count].X:= X;
- actions[Count].Y:= Y;
- if Count > 0 then
- actions[Count].Time:= TimeDelta
- else
- actions[Count].Time:= GameTicks + TimeDelta;
- inc(Count);
- TryDo(Count < MAXACTIONS, 'AI: actions overflow', true);
- end
+if Actions.Count < MAXACTIONS then
+ with Actions do
+ begin
+ actions[Count].Action:= Action;
+ actions[Count].Param:= Param;
+ actions[Count].X:= X;
+ actions[Count].Y:= Y;
+ if Count > 0 then
+ actions[Count].Time:= TimeDelta
+ else
+ actions[Count].Time:= GameTicks + TimeDelta;
+ inc(Count);
+ end
end;
procedure CheckHang(Me: PGear);
@@ -234,6 +235,10 @@
aia_waitAngle:
if Me^.Angle <> Abs(Param) then exit;
+
+ aia_waitAmmoXY:
+ if (CurAmmoGear <> nil) and ((hwRound(CurAmmoGear^.X) <> X) or (hwRound(CurAmmoGear^.Y) <> Y)) then exit;
+
end
else
begin
--- a/hedgewars/uAIAmmoTests.pas Fri Jul 13 16:39:20 2012 +0400
+++ b/hedgewars/uAIAmmoTests.pas Thu Jul 26 21:56:47 2012 +0400
@@ -50,6 +50,7 @@
function TestAirAttack(Me: PGear; Targ: TPoint; Level: LongInt; var ap: TAttackParams): LongInt;
function TestTeleport(Me: PGear; Targ: TPoint; Level: LongInt; var ap: TAttackParams): LongInt;
function TestHammer(Me: PGear; Targ: TPoint; Level: LongInt; var ap: TAttackParams): LongInt;
+function TestCake(Me: PGear; Targ: TPoint; Level: LongInt; var ap: TAttackParams): LongInt;
type TAmmoTestProc = function (Me: PGear; Targ: TPoint; Level: LongInt; var ap: TAttackParams): LongInt;
TAmmoTest = record
@@ -84,7 +85,7 @@
(proc: nil; flags: 0), // amSwitch
(proc: @TestMortar; flags: 0), // amMortar
(proc: nil; flags: 0), // amKamikaze
- (proc: nil; flags: 0), // amCake
+ (proc: @TestCake; flags: amtest_OnTurn or amtest_NoTarget), // amCake
(proc: nil; flags: 0), // amSeduction
(proc: @TestWatermelon; flags: 0), // amWatermelon
(proc: nil; flags: 0), // amHellishBomb
@@ -121,7 +122,7 @@
const BadTurn = Low(LongInt) div 4;
implementation
-uses uAIMisc, uVariables, uUtils;
+uses uAIMisc, uVariables, uUtils, uGearsHandlers, uCollisions;
function Metric(x1, y1, x2, y2: LongInt): LongInt; inline;
begin
@@ -708,19 +709,19 @@
x:= hwRound(Me^.X);
y:= hwRound(Me^.Y);
- a:= 0;
+ a:= cMaxAngle div 2;
valueResult:= 0;
- while a <= cMaxAngle div 2 do
+ while a >= 0 do
begin
dx:= sin(a / cMaxAngle * pi) * 0.5;
dy:= cos(a / cMaxAngle * pi) * 0.5;
- v1:= RateShove(Me, x - 10, y
- , 33, 30, 115
+ v1:= RateShove(Me, x - 10, y + 2
+ , 32, 30, 115
, -dx, -dy, trackFall);
- v2:= RateShove(Me, x + 10, y
- , 33, 30, 115
+ v2:= RateShove(Me, x + 10, y + 2
+ , 32, 30, 115
, dx, -dy, trackFall);
if (v1 > valueResult) or (v2 > valueResult) then
if (v2 > v1)
@@ -735,7 +736,7 @@
valueResult:= v1
end;
- a:= a + 15 + random(cMaxAngle div 16)
+ a:= a - 15 - random(cMaxAngle div 16)
end;
if valueResult <= 0 then
@@ -755,17 +756,17 @@
ap.Time:= 0;
ap.Power:= 1;
x:= hwRound(Me^.X);
- y:= hwRound(Me^.Y);
+ y:= hwRound(Me^.Y) + 4;
v1:= 0;
for i:= 0 to 8 do
begin
- v1:= v1 + RateShove(Me, x - 10, y - 10 * i
- , 18, 30, 40
+ v1:= v1 + RateShove(Me, x - 5, y - 10 * i
+ , 19, 30, 40
, -0.45, -0.9, trackFall or afSetSkip);
end;
- v1:= v1 + RateShove(Me, x - 10, y - 90
- , 18, 30, 40
+ v1:= v1 + RateShove(Me, x - 5, y - 90
+ , 19, 30, 40
, -0.45, -0.9, trackFall);
@@ -773,12 +774,12 @@
v2:= 0;
for i:= 0 to 8 do
begin
- v2:= v2 + RateShove(Me, x + 10, y - 10 * i
- , 18, 30, 40
+ v2:= v2 + RateShove(Me, x + 5, y - 10 * i
+ , 19, 30, 40
, 0.45, -0.9, trackFall or afSetSkip);
end;
- v2:= v2 + RateShove(Me, x + 10, y - 90
- , 18, 30, 40
+ v2:= v2 + RateShove(Me, x + 5, y - 90
+ , 19, 30, 40
, 0.45, -0.9, trackFall);
if (v2 > v1)
@@ -817,7 +818,7 @@
{first RateShove checks farthermost of two whip's AmmoShove attacks
to encourage distant attacks (damaged hog is excluded from view of second
RateShove call)}
- v1:= RateShove(Me, x - 15, y
+ v1:= RateShove(Me, x - 13, y
, 30, 30, 25
, -1, -0.8, trackFall or afSetSkip);
v1:= v1 +
@@ -825,7 +826,7 @@
, 30, 30, 25
, -1, -0.8, trackFall);
// now try opposite direction
- v2:= RateShove(Me, x + 15, y
+ v2:= RateShove(Me, x + 13, y
, 30, 30, 25
, 1, -0.8, trackFall or afSetSkip);
v2:= v2 +
@@ -981,4 +982,74 @@
end;
end;
+
+procedure checkCakeWalk(Me, Gear: PGear; var ap: TAttackParams);
+var i: Longword;
+ v: LongInt;
+begin
+while (not TestColl(hwRound(Gear^.X), hwRound(Gear^.Y), 6)) and (Gear^.Y.Round < LAND_HEIGHT) do
+ Gear^.Y:= Gear^.Y + _1;
+
+for i:= 0 to 2040 do
+ begin
+ cakeStep(Gear);
+ v:= RateExplosion(Me, hwRound(Gear^.X), hwRound(Gear^.Y), cakeDmg * 2, afTrackFall);
+ if v > ap.Power then
+ begin
+ ap.ExplX:= hwRound(Gear^.X);
+ ap.ExplY:= hwRound(Gear^.Y);
+ ap.Power:= v
+ end
+ end;
+end;
+
+function TestCake(Me: PGear; Targ: TPoint; Level: LongInt; var ap: TAttackParams): LongInt;
+var valueResult, v1, v2: LongInt;
+ x, y, trackFall: LongInt;
+ cake: TGear;
+begin
+ Level:= Level; // avoid compiler hint
+ ap.ExplR:= 0;
+ ap.Time:= 0;
+ ap.Power:= BadTurn; // use it as max score value in checkCakeWalk
+
+ FillChar(cake, sizeof(cake), 0);
+ cake.Radius:= 7;
+ cake.CollisionMask:= $FF7F;
+
+ // check left direction
+ cake.Angle:= 3;
+ cake.dX.isNegative:= true;
+ cake.X:= Me^.X - _3;
+ cake.Y:= Me^.Y;
+ checkCakeWalk(Me, @cake, ap);
+ v1:= ap.Power;
+
+ // now try opposite direction
+ cake.Angle:= 1;
+ cake.dX.isNegative:= false;
+ cake.X:= Me^.X + _3;
+ cake.Y:= Me^.Y;
+ checkCakeWalk(Me, @cake, ap);
+ v2:= ap.Power;
+
+ ap.Power:= 1;
+
+ if (v2 > v1) then
+ begin
+ ap.Angle:= 1;
+ valueResult:= v2
+ end
+ else
+ begin
+ ap.Angle:= -1;
+ valueResult:= v1
+ end;
+
+ if valueResult <= 0 then
+ valueResult:= BadTurn;
+
+ TestCake:= valueResult;
+end;
+
end.
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/hedgewars/uAILandMarks.pas Thu Jul 26 21:56:47 2012 +0400
@@ -0,0 +1,71 @@
+unit uAILandMarks;
+
+interface
+const markWasHere = $01;
+
+procedure addMark(X, Y: LongInt; mark: byte);
+function checkMark(X, Y: LongInt; mark: byte) : boolean;
+procedure clearAllMarks;
+procedure clearMarks(mark: byte);
+
+procedure initModule;
+procedure freeModule;
+
+implementation
+uses uVariables;
+
+const gr = 2;
+
+var marks: array of array of byte;
+ WIDTH, HEIGHT: Longword;
+
+procedure addMark(X, Y: LongInt; mark: byte);
+begin
+ if((X and LAND_WIDTH_MASK) = 0) and ((Y and LAND_HEIGHT_MASK) = 0) then
+ begin
+ X:= X shr gr;
+ Y:= Y shr gr;
+ marks[Y, X]:= marks[Y, X] or mark
+ end
+end;
+
+function checkMark(X, Y: LongInt; mark: byte) : boolean;
+begin
+ checkMark:= ((X and LAND_WIDTH_MASK) = 0)
+ and ((Y and LAND_HEIGHT_MASK) = 0)
+ and ((marks[Y shr gr, X shr gr] and mark) <> 0)
+end;
+
+procedure clearAllMarks;
+var
+ Y, X: Longword;
+begin
+ for Y:= 0 to Pred(HEIGHT) do
+ for X:= 0 to Pred(WIDTH) do
+ marks[Y, X]:= 0
+end;
+
+procedure clearMarks(mark: byte);
+var
+ Y, X: Longword;
+begin
+ for Y:= 0 to Pred(HEIGHT) do
+ for X:= 0 to Pred(WIDTH) do
+ marks[Y, X]:= marks[Y, X] and (not mark)
+end;
+
+
+procedure initModule;
+begin
+ WIDTH:= LAND_WIDTH shr gr;
+ HEIGHT:= LAND_HEIGHT shr gr;
+
+ SetLength(marks, HEIGHT, WIDTH);
+end;
+
+procedure freeModule;
+begin
+ SetLength(marks, 0, 0);
+end;
+
+end.
--- a/hedgewars/uAIMisc.pas Fri Jul 13 16:39:20 2012 +0400
+++ b/hedgewars/uAIMisc.pas Thu Jul 26 21:56:47 2012 +0400
@@ -170,7 +170,7 @@
begin
case Gear^.Kind of
gtCase:
- AddBonus(hwRound(Gear^.X), hwRound(Gear^.Y), 33, 25);
+ AddBonus(hwRound(Gear^.X), hwRound(Gear^.Y) + 3, 37, 25);
gtFlame:
if (Gear^.State and gsttmpFlag) <> 0 then
AddBonus(hwRound(Gear^.X), hwRound(Gear^.Y), 20, -50);
@@ -371,13 +371,13 @@
x:= x + dX;
y:= y + dY;
dY:= dY + cGravityf;
-(*
- if ((trunc(y) and LAND_HEIGHT_MASK) = 0) and ((trunc(x) and LAND_WIDTH_MASK) = 0) then
+
+{ if ((trunc(y) and LAND_HEIGHT_MASK) = 0) and ((trunc(x) and LAND_WIDTH_MASK) = 0) then
begin
LandPixels[trunc(y), trunc(x)]:= v;
UpdateLandTexture(trunc(X), 1, trunc(Y), 1, true);
- end;
-*)
+ end;}
+
// consider adding dX/dY calc here for fall damage
if TestCollExcludingObjects(trunc(x), trunc(y), cHHRadius) then
@@ -439,21 +439,21 @@
end;
if fallDmg < 0 then // drowning. score healthier hogs higher, since their death is more likely to benefit the AI
if Score > 0 then
- inc(rate, KillScore + Score div 10) // Add a bit of a bonus for bigger hog drownings
+ inc(rate, (KillScore + Score div 10) * 1024) // Add a bit of a bonus for bigger hog drownings
else
- dec(rate, KillScore * friendlyfactor div 100 - Score div 10) // and more of a punishment for drowning bigger friendly hogs
+ dec(rate, (KillScore * friendlyfactor div 100 - Score div 10) * 1024) // and more of a punishment for drowning bigger friendly hogs
else if (dmg+fallDmg) >= abs(Score) then
if Score > 0 then
- inc(rate, KillScore)
+ inc(rate, KillScore * 1024 + (dmg + fallDmg)) // tiny bonus for dealing more damage than needed to kill
else
- dec(rate, KillScore * friendlyfactor div 100)
+ dec(rate, KillScore * friendlyfactor div 100 * 1024)
else
if Score > 0 then
- inc(rate, dmg+fallDmg)
- else dec(rate, (dmg+fallDmg) * friendlyfactor div 100)
+ inc(rate, (dmg + fallDmg) * 1024)
+ else dec(rate, (dmg + fallDmg) * friendlyfactor div 100 * 1024)
end;
end;
-RateExplosion:= rate * 1024;
+RateExplosion:= rate;
end;
function RateShove(Me: PGear; x, y, r, power, kick: LongInt; gdX, gdY: real; Flags: LongWord): LongInt;
@@ -624,6 +624,12 @@
end;
repeat
+ {if ((hwRound(Gear^.Y) and LAND_HEIGHT_MASK) = 0) and ((hwRound(Gear^.X) and LAND_WIDTH_MASK) = 0) then
+ begin
+ LandPixels[hwRound(Gear^.Y), hwRound(Gear^.X)]:= Gear^.Hedgehog^.Team^.Clan^.Color;
+ UpdateLandTexture(hwRound(Gear^.X), 1, hwRound(Gear^.Y), 1, true);
+ end;}
+
if not (hwRound(Gear^.Y) + cHHRadius < cWaterLine) then
exit(false);
if (Gear^.State and gstMoving) <> 0 then
@@ -645,7 +651,7 @@
Gear^.Y:= Gear^.Y + Gear^.dY;
if (not Gear^.dY.isNegative) and (TestCollisionYwithGear(Gear, 1) <> 0) then
begin
- Gear^.State:= Gear^.State and not (gstMoving or gstHHJumping);
+ Gear^.State:= Gear^.State and (not (gstMoving or gstHHJumping));
Gear^.dY:= _0;
case JumpType of
jmpHJump:
@@ -673,6 +679,7 @@
var pX, pY, tY: LongInt;
begin
HHGo:= false;
+Gear^.CollisionMask:= $FF7F;
AltGear^:= Gear^;
GoInfo.Ticks:= 0;
@@ -680,6 +687,12 @@
GoInfo.JumpType:= jmpNone;
tY:= hwRound(Gear^.Y);
repeat
+ {if ((hwRound(Gear^.Y) and LAND_HEIGHT_MASK) = 0) and ((hwRound(Gear^.X) and LAND_WIDTH_MASK) = 0) then
+ begin
+ LandPixels[hwRound(Gear^.Y), hwRound(Gear^.X)]:= random($FFFFFFFF);//Gear^.Hedgehog^.Team^.Clan^.Color;
+ UpdateLandTexture(hwRound(Gear^.X), 1, hwRound(Gear^.Y), 1, true);
+ end;}
+
pX:= hwRound(Gear^.X);
pY:= hwRound(Gear^.Y);
if pY + cHHRadius >= cWaterLine then
@@ -696,7 +709,7 @@
Gear^.dY:= Gear^.dY + cGravity;
if Gear^.dY > _0_4 then
begin
- Goinfo.FallPix:= 0;
+ GoInfo.FallPix:= 0;
// try ljump instead of fall with damage
HHJump(AltGear, jmpLJump, GoInfo);
if AltGear^.Hedgehog^.BotLevel < 4 then
@@ -709,7 +722,7 @@
if TestCollisionYwithGear(Gear, 1) <> 0 then
begin
inc(GoInfo.Ticks, 410);
- Gear^.State:= Gear^.State and not (gstMoving or gstHHJumping);
+ Gear^.State:= Gear^.State and (not (gstMoving or gstHHJumping));
Gear^.dY:= _0;
// try ljump instead of fall
HHJump(AltGear, jmpLJump, GoInfo);
--- a/hedgewars/uAmmos.pas Fri Jul 13 16:39:20 2012 +0400
+++ b/hedgewars/uAmmos.pas Thu Jul 26 21:56:47 2012 +0400
@@ -374,7 +374,7 @@
with CurWeapon^ do
begin
s:= trammo[Ammoz[AmmoType].NameId];
- if (Count <> AMMO_INFINITE) and not (Hedgehog.Team^.ExtDriven or (Hedgehog.BotLevel > 0)) then
+ if (Count <> AMMO_INFINITE) and (not (Hedgehog.Team^.ExtDriven or (Hedgehog.BotLevel > 0))) then
s:= s + ' (' + IntToStr(Count) + ')';
if (Propz and ammoprop_Timerable) <> 0 then
s:= s + ', ' + IntToStr(Timer div 1000) + ' ' + trammo[sidSeconds];
@@ -386,7 +386,7 @@
end
else
begin
- if Gear <> nil then Gear^.State:= Gear^.State and not gstHHChooseTarget;
+ if Gear <> nil then Gear^.State:= Gear^.State and (not gstHHChooseTarget);
isCursorVisible:= false
end;
end
--- a/hedgewars/uCommandHandlers.pas Fri Jul 13 16:39:20 2012 +0400
+++ b/hedgewars/uCommandHandlers.pas Thu Jul 26 21:56:47 2012 +0400
@@ -413,18 +413,19 @@
end;
procedure chNextTurn(var s: shortstring);
-var checksum: Longword;
+var i: Longword;
gi: PGear;
begin
s:= s; // avoid compiler hint
TryDo(AllInactive, '/nextturn called when not all gears are inactive', true);
- checksum:= GameTicks;
+ CheckSum:= CheckSum xor GameTicks;
gi := GearsList;
while gi <> nil do
begin
- with gi^ do checksum:= checksum xor X.round xor X.frac xor dX.round xor dX.frac xor Y.round xor Y.frac xor dY.round xor dY.frac;
+ with gi^ do CheckSum:= CheckSum xor X.round xor X.frac xor dX.round xor dX.frac xor Y.round xor Y.frac xor dY.round xor dY.frac;
+ AddRandomness(CheckSum);
gi := gi^.NextGear
end;
@@ -432,11 +433,11 @@
begin
s[0]:= #5;
s[1]:= 'N';
- SDLNet_Write32(checksum, @s[2]);
+ SDLNet_Write32(CheckSum, @s[2]);
SendIPC(s)
end
else
- TryDo(checksum = lastTurnChecksum, 'Desync detected', true);
+ TryDo(CheckSum = lastTurnChecksum, 'Desync detected', true);
AddFileLog('Next turn: time '+inttostr(GameTicks));
end;
@@ -664,6 +665,7 @@
procedure chSpeedup_p(var s: shortstring);
begin
s:= s; // avoid compiler hint
+SpeedStart:= RealTicks;
isSpeed:= true
end;
@@ -776,7 +778,7 @@
procedure chGameFlags(var s: shortstring);
begin
GameFlags:= StrToInt(s);
-if GameFlags and gfSharedAmmo <> 0 then GameFlags:= GameFlags and not gfPerHogAmmo
+if GameFlags and gfSharedAmmo <> 0 then GameFlags:= GameFlags and (not gfPerHogAmmo)
end;
procedure chHedgehogTurnTime(var s: shortstring);
@@ -797,21 +799,21 @@
procedure initModule;
begin
//////// Begin top sorted by freq analysis not including chatmsg
- RegisterVariable('+right' , @chRight_p , false);
- RegisterVariable('-right' , @chRight_m , false);
- RegisterVariable('+up' , @chUp_p , false);
- RegisterVariable('-up' , @chUp_m , false);
- RegisterVariable('+left' , @chLeft_p , false);
- RegisterVariable('-left' , @chLeft_m , false);
+ RegisterVariable('+right' , @chRight_p , false, true);
+ RegisterVariable('-right' , @chRight_m , false, true);
+ RegisterVariable('+up' , @chUp_p , false, true);
+ RegisterVariable('-up' , @chUp_m , false, true);
+ RegisterVariable('+left' , @chLeft_p , false, true);
+ RegisterVariable('-left' , @chLeft_m , false, true);
RegisterVariable('+attack' , @chAttack_p , false);
- RegisterVariable('+down' , @chDown_p , false);
- RegisterVariable('-down' , @chDown_m , false);
- RegisterVariable('hjump' , @chHJump , false);
- RegisterVariable('ljump' , @chLJump , false);
+ RegisterVariable('+down' , @chDown_p , false, true);
+ RegisterVariable('-down' , @chDown_m , false, true);
+ RegisterVariable('hjump' , @chHJump , false, true);
+ RegisterVariable('ljump' , @chLJump , false, true);
RegisterVariable('nextturn', @chNextTurn , false);
RegisterVariable('-attack' , @chAttack_m , false);
RegisterVariable('slot' , @chSlot , false);
- RegisterVariable('setweap' , @chSetWeapon , false);
+ RegisterVariable('setweap' , @chSetWeapon , false, true);
//////// End top by freq analysis
RegisterVariable('gencmd' , @chGenCmd , false);
RegisterVariable('flag' , @chFlag , false);
@@ -857,10 +859,10 @@
RegisterVariable('zoomout' , @chZoomOut , true );
RegisterVariable('zoomreset',@chZoomReset , true );
RegisterVariable('ammomenu', @chAmmoMenu , true);
- RegisterVariable('+precise', @chPrecise_p , false);
- RegisterVariable('-precise', @chPrecise_m , false);
+ RegisterVariable('+precise', @chPrecise_p , false, true);
+ RegisterVariable('-precise', @chPrecise_m , false, true);
RegisterVariable('switch' , @chSwitch , false);
- RegisterVariable('timer' , @chTimer , false);
+ RegisterVariable('timer' , @chTimer , false, true);
RegisterVariable('taunt' , @chTaunt , false);
RegisterVariable('put' , @chPut , false);
RegisterVariable('+volup' , @chVol_p , true );
--- a/hedgewars/uCommands.pas Fri Jul 13 16:39:20 2012 +0400
+++ b/hedgewars/uCommands.pas Thu Jul 26 21:56:47 2012 +0400
@@ -27,26 +27,31 @@
procedure initModule;
procedure freeModule;
+procedure RegisterVariable(Name: shortstring; p: TCommandHandler; Trusted: boolean; Rand: boolean);
procedure RegisterVariable(Name: shortstring; p: TCommandHandler; Trusted: boolean);
procedure ParseCommand(CmdStr: shortstring; TrustedSource: boolean);
procedure ParseTeamCommand(s: shortstring);
procedure StopMessages(Message: Longword);
implementation
-uses uConsts, uVariables, uConsole, uUtils, uDebug;
+uses uConsts, uVariables, uConsole, uUtils, uDebug, SDLh;
type PVariable = ^TVariable;
TVariable = record
Next: PVariable;
Name: string[15];
Handler: TCommandHandler;
- Trusted: boolean;
+ Trusted, Rand: boolean;
end;
var
Variables: PVariable;
procedure RegisterVariable(Name: shortstring; p: TCommandHandler; Trusted: boolean);
+begin
+RegisterVariable(Name, p, Trusted, false);
+end;
+procedure RegisterVariable(Name: shortstring; p: TCommandHandler; Trusted: boolean; Rand: boolean);
var
value: PVariable;
begin
@@ -56,6 +61,7 @@
value^.Name:= Name;
value^.Handler:= p;
value^.Trusted:= Trusted;
+value^.Rand:= Rand;
if Variables = nil then
Variables:= value
@@ -81,13 +87,18 @@
s:= '';
SplitBySpace(CmdStr, s);
AddFileLog('[Cmd] ' + CmdStr + ' (' + inttostr(length(s)) + ')');
+
t:= Variables;
while t <> nil do
begin
if t^.Name = CmdStr then
begin
if TrustedSource or t^.Trusted then
+ begin
+ if t^.Rand and (not CheckNoTeamOrHH) then
+ CheckSum:= CheckSum xor LongWord(SDLNet_Read32(@CmdStr)) xor LongWord(s[0]) xor GameTicks;
t^.Handler(s);
+ end;
exit
end
else
--- a/hedgewars/uConsts.pas Fri Jul 13 16:39:20 2012 +0400
+++ b/hedgewars/uConsts.pas Thu Jul 26 21:56:47 2012 +0400
@@ -147,6 +147,7 @@
cBarrelHealth = 60;
cShotgunRadius = 22;
cBlowTorchC = 6;
+ cakeDmg = 75;
cKeyMaxIndex = 1023;
cKbdMaxIndex = 65536;//need more room for the modifier keys
@@ -228,20 +229,23 @@
gstHHGone = $00100000;
gstInvisible = $00200000;
- gmLeft = $00000001;
- gmRight = $00000002;
- gmUp = $00000004;
- gmDown = $00000008;
- gmSwitch = $00000010;
- gmAttack = $00000020;
- gmLJump = $00000040;
- gmHJump = $00000080;
- gmDestroy= $00000100;
- gmSlot = $00000200; // with param
- gmWeapon = $00000400; // with param
- gmTimer = $00000800; // with param
- gmAnimate= $00001000; // with param
- gmPrecise= $00002000;
+ gmLeft = $00000001;
+ gmRight = $00000002;
+ gmUp = $00000004;
+ gmDown = $00000008;
+ gmSwitch = $00000010;
+ gmAttack = $00000020;
+ gmLJump = $00000040;
+ gmHJump = $00000080;
+ gmDestroy = $00000100;
+ gmSlot = $00000200; // with param
+ gmWeapon = $00000400; // with param
+ gmTimer = $00000800; // with param
+ gmAnimate = $00001000; // with param
+ gmPrecise = $00002000;
+
+ gmRemoveFromList = $00004000;
+ gmAddToList = $00008000;
gmAllStoppable = gmLeft or gmRight or gmUp or gmDown or gmAttack or gmPrecise;
cMaxSlotIndex = 9;
@@ -264,6 +268,7 @@
ammoprop_NeedUpDown = $00008000;//Used by TouchInterface to show or hide up/down widgets
ammoprop_OscAim = $00010000;
ammoprop_NoMoveAfter = $00020000;
+ ammoprop_Track = $00040000;
ammoprop_NoRoundEnd = $10000000;
AMMO_INFINITE = 100;
--- a/hedgewars/uGame.pas Fri Jul 13 16:39:20 2012 +0400
+++ b/hedgewars/uGame.pas Thu Jul 26 21:56:47 2012 +0400
@@ -48,7 +48,14 @@
if (GameType = gmtDemo) then
if isSpeed then
- Lag:= Lag * 10
+ Lag:= Lag * 10
+ i:= RealTicks-SpeedStart;
+ if i < 2000 then Lag:= Lag*5
+ else if i < 4000 then Lag:= Lag*10
+ else if i < 6000 then Lag:= Lag*20
+ else if i < 8000 then Lag:= Lag*40
+ else Lag:= Lag*80;
+ end
else
if cOnlyStats then
Lag:= High(LongInt);
--- a/hedgewars/uGears.pas Fri Jul 13 16:39:20 2012 +0400
+++ b/hedgewars/uGears.pas Thu Jul 26 21:56:47 2012 +0400
@@ -182,7 +182,7 @@
end;
procedure ProcessGears;
-var Gear, t: PGear;
+var t: PGear;
i, AliveCount: LongInt;
s: shortstring;
begin
@@ -203,21 +203,29 @@
t:= GearsList;
while t <> nil do
begin
- Gear:= t;
- t:= Gear^.NextGear;
+ curHandledGear:= t;
+ t:= curHandledGear^.NextGear;
- if Gear^.Active then
+ if curHandledGear^.Message and gmRemoveFromList <> 0 then
begin
- if Gear^.RenderTimer and (Gear^.Timer > 500) and ((Gear^.Timer mod 1000) = 0) then
+ 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
- FreeTexture(Gear^.Tex);
- Gear^.Tex:= RenderStringTex(inttostr(Gear^.Timer div 1000), cWhiteColor, fntSmall);
+ FreeTexture(curHandledGear^.Tex);
+ curHandledGear^.Tex:= RenderStringTex(inttostr(curHandledGear^.Timer div 1000), cWhiteColor, fntSmall);
end;
- Gear^.doStep(Gear);
+ curHandledGear^.doStep(curHandledGear);
// might be useful later
//ScriptCall('onGearStep', Gear^.uid);
end
end;
+curHandledGear:= nil;
if AllInactive then
case step of
@@ -453,7 +461,7 @@
if (not CurrentTeam^.ExtDriven) or CurrentTeam^.hasGone then
inc(hiTicks) // we do not recieve a message for this
end;
-
+AddRandomness(CheckSum);
ScriptCall('onGameTick');
if GameTicks mod 20 = 0 then ScriptCall('onGameTick20');
inc(GameTicks)
@@ -580,7 +588,8 @@
end;
procedure AddMiscGears;
-var i: Longword;
+var i,rx, ry: Longword;
+ rdx, rdy: hwFloat;
Gear: PGear;
begin
AddGear(0, 0, gtATStartGame, 0, _0, _0, 2000);
@@ -625,6 +634,13 @@
if (GameFlags and gfArtillery) <> 0 then
cArtillery:= true;
+for i:= GetRandom(10)+30 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;
if not hasBorder and ((Theme = 'Snow') or (Theme = 'Christmas')) then
for i:= 0 to Pred(vobCount*2) do
@@ -1313,7 +1329,9 @@
@doStepStructure,
@doStepLandGun,
@doStepTardis,
- @doStepIceGun);
+ @doStepIceGun,
+ @doStepAddAmmo,
+ @doStepGenericFaller);
begin
doStepHandlers:= handlers;
@@ -1322,6 +1340,8 @@
CurAmmoGear:= nil;
GearsList:= nil;
+ curHandledGear:= nil;
+
KilledHHs:= 0;
SuddenDeath:= false;
SuddenDeathDmg:= false;
--- a/hedgewars/uGearsHandlers.pas Fri Jul 13 16:39:20 2012 +0400
+++ b/hedgewars/uGearsHandlers.pas Thu Jul 26 21:56:47 2012 +0400
@@ -29,16 +29,18 @@
uses SDLh, uFloat, uCollisions;
+
+
const dirs: array[0..3] of TPoint = ((X: 0; Y: -1), (X: 1; Y: 0),(X: 0; Y: 1),(X: -1; Y: 0));
procedure PrevAngle(Gear: PGear; dA: LongInt); inline;
begin
- Gear^.Angle := (LongInt(Gear^.Angle) + 4 - dA) mod 4
+ Gear^.Angle := (Gear^.Angle - dA) and 3
end;
procedure NextAngle(Gear: PGear; dA: LongInt); inline;
begin
- Gear^.Angle := (LongInt(Gear^.Angle) + 4 + dA) mod 4
+ Gear^.Angle := (Gear^.Angle + dA) and 3
end;
procedure cakeStep(Gear: PGear);
@@ -50,8 +52,8 @@
dA := hwSign(Gear^.dX);
xx := dirs[Gear^.Angle].x;
yy := dirs[Gear^.Angle].y;
- xxn := dirs[(LongInt(Gear^.Angle) + 4 + dA) mod 4].x;
- yyn := dirs[(LongInt(Gear^.Angle) + 4 + dA) mod 4].y;
+ xxn := dirs[(Gear^.Angle + dA) and 3].x;
+ yyn := dirs[(Gear^.Angle + dA) and 3].y;
if (xx = 0) then
if TestCollisionYwithGear(Gear, yy) <> 0 then
--- a/hedgewars/uGearsHedgehog.pas Fri Jul 13 16:39:20 2012 +0400
+++ b/hedgewars/uGearsHedgehog.pas Thu Jul 26 21:56:47 2012 +0400
@@ -28,6 +28,7 @@
procedure doStepHedgehogMoving(Gear: PGear);
procedure HedgehogChAngle(HHGear: PGear);
procedure PickUp(HH, Gear: PGear);
+procedure AddPickup(HH: THedgehog; ammo: TAmmoType; cnt, X, Y: LongWord);
implementation
uses uConsts, uVariables, uFloat, uAmmos, uSound, uCaptions,
@@ -565,15 +566,41 @@
end
end;
+procedure AddPickup(HH: THedgehog; ammo: TAmmoType; cnt, X, Y: LongWord);
+var s: shortstring;
+ vga: PVisualGear;
+begin
+ PlaySound(sndShotgunReload);
+ if cnt <> 0 then AddAmmo(HH, ammo, cnt)
+ else AddAmmo(HH, ammo);
+
+ if (not (HH.Team^.ExtDriven
+ or (HH.BotLevel > 0)))
+ or (HH.Team^.Clan^.ClanIndex = LocalClan)
+ or (GameType = gmtDemo) then
+ begin
+ if cnt <> 0 then
+ s:= trammo[Ammoz[ammo].NameId] + ' (+' + IntToStr(cnt) + ')'
+ else
+ s:= trammo[Ammoz[ammo].NameId] + ' (+' + IntToStr(Ammoz[ammo].NumberInCase) + ')';
+ AddCaption(s, HH.Team^.Clan^.Color, capgrpAmmoinfo);
+
+ // show ammo icon
+ vga:= AddVisualGear(X, Y, vgtAmmo);
+ if vga <> nil then
+ vga^.Frame:= Longword(ammo);
+ end;
+end;
+
////////////////////////////////////////////////////////////////////////////////
procedure PickUp(HH, Gear: PGear);
var s: shortstring;
a: TAmmoType;
i: LongInt;
vga: PVisualGear;
+ ag, gi: PGear;
begin
Gear^.Message:= gmDestroy;
-PlaySound(sndShotgunReload);
if (Gear^.Pos and posCaseExplode) <> 0 then
if (Gear^.Pos and posCasePoison) <> 0 then
doMakeExplosion(hwRound(Gear^.X), hwRound(Gear^.Y), 25, HH^.Hedgehog, EXPLAutoSound + EXPLPoisoned)
@@ -585,39 +612,36 @@
case Gear^.Pos of
posCaseUtility,
posCaseAmmo: begin
- if Gear^.AmmoType <> amNothing then a:= Gear^.AmmoType
+ if Gear^.AmmoType <> amNothing then
+ begin
+ AddPickup(HH^.Hedgehog^, Gear^.AmmoType, Gear^.Power, hwRound(Gear^.X), hwRound(Gear^.Y));
+ end
else
+ or (GameType = gmtDemo) then
begin
- for i:= 0 to GameTicks and $7F do
- GetRandom(2); // Burn some random numbers
- if Gear^.Pos = posCaseUtility then
- a:= GetUtility(HH^.Hedgehog)
- else
- a:= GetAmmo(HH^.Hedgehog)
+// Add spawning here...
+ AddRandomness(GameTicks);
+
+ gi := GearsList;
+ while gi <> nil do
+ begin
+ if gi^.Kind = gtGenericFaller then
+ begin
+ gi^.Active:= true;
+ gi^.X:= int2hwFloat(GetRandom(rightX-leftX)+leftX);
+ gi^.Y:= int2hwFloat(GetRandom(LAND_HEIGHT-topY)+topY);
+ gi^.dX:= _90-(GetRandomf*_360);
+ gi^.dY:= _90-(GetRandomf*_360)
+ end;
+ gi := gi^.NextGear
+ end;
+ ag:= AddGear(hwRound(Gear^.X), hwRound(Gear^.Y), gtAddAmmo, gstInvisible, _0, _0, GetRandom(200)+100);
+ ag^.Pos:= Gear^.Pos;
+ ag^.Power:= Gear^.Power
end;
- if Gear^.Power <> 0 then AddAmmo(HH^.Hedgehog^, a, Gear^.Power)
- else AddAmmo(HH^.Hedgehog^, a);
-// Possibly needs to check shared clan ammo game flag once added.
-// On the other hand, no obvious reason that clan members shouldn't know what ammo another clan member picked up
- if (not (HH^.Hedgehog^.Team^.ExtDriven
- or (HH^.Hedgehog^.BotLevel > 0)))
- or (HH^.Hedgehog^.Team^.Clan^.ClanIndex = LocalClan)
- or (GameType in [gmtDemo, gmtRecord]) then
- begin
- if Gear^.Power <> 0 then
- s:= trammo[Ammoz[a].NameId] + ' (+' + IntToStr(Gear^.Power) + ')'
- else
- s:= trammo[Ammoz[a].NameId] + ' (+' + IntToStr(Ammoz[a].NumberInCase) + ')';
- AddCaption(s, HH^.Hedgehog^.Team^.Clan^.Color, capgrpAmmoinfo);
-
- // show ammo icon
- vga:= AddVisualGear(hwRound(Gear^.X), hwRound(Gear^.Y), vgtAmmo);
- if vga <> nil then
- vga^.Frame:= Longword(a);
- end;
-
end;
posCaseHealth: begin
+ PlaySound(sndShotgunReload);
inc(HH^.Health, Gear^.Health);
HH^.Hedgehog^.Effects[hePoisoned] := 0;
str(Gear^.Health, s);
@@ -830,7 +854,7 @@
Gear^.State:= Gear^.State and (not gstMoving);
exit
end;
-isFalling:= (Gear^.dY.isNegative) or not TestCollisionYKick(Gear, 1);
+isFalling:= (Gear^.dY.isNegative) or (not TestCollisionYKick(Gear, 1));
if isFalling then
begin
if (Gear^.dY.isNegative) and TestCollisionYKick(Gear, -1) then
@@ -960,7 +984,7 @@
begin
Gear^.State:= Gear^.State and (not gstWinner);
Gear^.State:= Gear^.State and (not gstMoving);
- while (TestCollisionYWithGear(Gear,1) = 0) and not CheckGearDrowning(Gear) do
+ while (TestCollisionYWithGear(Gear,1) = 0) and (not CheckGearDrowning(Gear)) do
Gear^.Y:= Gear^.Y+_1;
SetLittle(Gear^.dX);
Gear^.dY:= _0
@@ -1224,6 +1248,7 @@
land: Word; *)
var slope: hwFloat;
begin
+CheckSum:= CheckSum xor Gear^.Hedgehog^.BotLevel;
if (Gear^.Message and gmDestroy) <> 0 then
begin
DeleteGear(Gear);
--- a/hedgewars/uGearsList.pas Fri Jul 13 16:39:20 2012 +0400
+++ b/hedgewars/uGearsList.pas Thu Jul 26 21:56:47 2012 +0400
@@ -27,11 +27,13 @@
procedure InsertGearToList(Gear: PGear);
procedure RemoveGearFromList(Gear: PGear);
+var curHandledGear: PGear;
+
implementation
uses uRandom, uUtils, uConsts, uVariables, uAmmos, uTeams, uStats,
uTextures, uScript, uRenderUtils, uAI, uCollisions,
- uGearsRender, uGearsUtils;
+ uGearsRender, uGearsUtils, uDebug;
var GCounter: LongWord = 0; // this does not get re-initialized, but should be harmless
@@ -63,8 +65,11 @@
end;
end;
+
procedure RemoveGearFromList(Gear: PGear);
begin
+TryDo((curHandledGear = nil) or (Gear = curHandledGear), 'You''re doing it wrong', true);
+
if Gear^.NextGear <> nil then
Gear^.NextGear^.PrevGear:= Gear^.PrevGear;
if Gear^.PrevGear <> nil then
@@ -72,7 +77,8 @@
else
GearsList:= Gear^.NextGear
end;
-
+
+
function AddGear(X, Y: LongInt; Kind: TGearType; State: Longword; dX, dY: hwFloat; Timer: LongWord): PGear;
var gear: PGear;
begin
@@ -92,16 +98,13 @@
gear^.doStep:= doStepHandlers[Kind];
gear^.CollisionIndex:= -1;
gear^.Timer:= Timer;
-gear^.FlightTime:= 0;
gear^.uid:= GCounter;
gear^.SoundChannel:= -1;
gear^.ImpactSound:= sndNone;
-gear^.nImpactSounds:= 0;
gear^.Density:= _1;
// Define ammo association, if any.
gear^.AmmoType:= GearKindAmmoTypeMap[Kind];
gear^.CollisionMask:= $FFFF;
-gear^.Power:= 0;
if CurrentHedgehog <> nil then gear^.Hedgehog:= CurrentHedgehog;
@@ -460,6 +463,13 @@
gear^.Pos:= 1;
end;
gtIceGun: gear^.Health:= 1000;
+gtGenericFaller:begin
+ gear^.AdvBounce:= 1;
+ gear^.Radius:= 1;
+ gear^.Elasticity:= _0_9;
+ gear^.Friction:= _0_995;
+ gear^.Density:= _1;
+ end;
end;
InsertGearToList(gear);
@@ -557,8 +567,10 @@
end
end;
with Gear^ do
+ begin
AddFileLog('Delete: #' + inttostr(uid) + ' (' + inttostr(hwRound(x)) + ',' + inttostr(hwRound(y)) + '), d(' + floattostr(dX) + ',' + floattostr(dY) + ') type = ' + EnumToStr(Kind));
-
+ AddRandomness(X.round xor X.frac xor dX.round xor dX.frac xor Y.round xor Y.frac xor dY.round xor dY.frac)
+ end;
if CurAmmoGear = Gear then
CurAmmoGear:= nil;
if FollowGear = Gear then
--- a/hedgewars/uGearsRender.pas Fri Jul 13 16:39:20 2012 +0400
+++ b/hedgewars/uGearsRender.pas Thu Jul 26 21:56:47 2012 +0400
@@ -21,7 +21,7 @@
unit uGearsRender;
interface
-uses uTypes, uConsts, GLunit, uFloat, SDLh;
+uses uTypes, uConsts, GLunit, uFloat, SDLh, uRandom;
procedure RenderGear(Gear: PGear; x, y: LongInt);
@@ -1213,9 +1213,8 @@
else DrawLine(hwRound(HHGear^.X), hwRound(HHGear^.Y), hwRound(Gear^.X), hwRound(Gear^.Y), 4.0, i, i, $FF, $40);
end
end
- end
-
-
+ end;
+ gtGenericFaller: DrawCircle(x, y, 3, 3, $FF, $00, $00, $FF); // debug
end;
if Gear^.RenderTimer and (Gear^.Tex <> nil) then
DrawTextureCentered(x + 8, y + 8, Gear^.Tex);
--- a/hedgewars/uGearsUtils.pas Fri Jul 13 16:39:20 2012 +0400
+++ b/hedgewars/uGearsUtils.pas Thu Jul 26 21:56:47 2012 +0400
@@ -343,6 +343,18 @@
Y:= hwRound(Gear^.Y);
if cWaterLine < Y + Gear^.Radius then
begin
+ if Gear^.State and gstInvisible <> 0 then
+ begin
+ if Gear^.Kind = gtGenericFaller then
+ begin
+ Gear^.X:= int2hwFloat(GetRandom(rightX-leftX)+leftX);
+ Gear^.Y:= int2hwFloat(GetRandom(LAND_HEIGHT-topY)+topY);
+ Gear^.dX:= _90-(GetRandomf*_360);
+ Gear^.dY:= _90-(GetRandomf*_360)
+ end
+ else DeleteGear(Gear);
+ exit
+ end;
isSubmersible:= (Gear = CurrentHedgehog^.Gear) and (CurAmmoGear <> nil) and (CurAmmoGear^.AmmoType = amJetpack);
skipSpeed := _0_25;
skipAngle := _1_9;
@@ -408,10 +420,9 @@
Scale:= hwFloat2Float(Gear^.Density / _3 * Gear^.dY);
if Scale > 1 then Scale:= power(Scale,0.3333)
else Scale:= Scale + ((1-Scale) / 2);
- if Scale > 1 then Timer:= round(max(Scale,3))
+ if Scale > 1 then Timer:= round(min(Scale*0.0005/cGravityf,4))
else Timer:= 1;
// Low Gravity
- Timer:=round(0.0005/cGravityf);
FrameTicks:= FrameTicks*Timer;
end;
--- a/hedgewars/uIO.pas Fri Jul 13 16:39:20 2012 +0400
+++ b/hedgewars/uIO.pas Thu Jul 26 21:56:47 2012 +0400
@@ -403,7 +403,7 @@
TargetPoint.Y:= putY
end;
AddFileLog('put: ' + inttostr(TargetPoint.X) + ', ' + inttostr(TargetPoint.Y));
- State:= State and not gstHHChooseTarget;
+ State:= State and (not gstHHChooseTarget);
if (Ammoz[CurAmmoType].Ammo.Propz and ammoprop_AttackingPut) <> 0 then
Message:= Message or (gmAttack and InputMask);
end
--- a/hedgewars/uInputHandler.pas Fri Jul 13 16:39:20 2012 +0400
+++ b/hedgewars/uInputHandler.pas Thu Jul 26 21:56:47 2012 +0400
@@ -25,8 +25,9 @@
procedure initModule;
procedure freeModule;
-function KeyNameToCode(name: shortstring; Modifier: shortstring = ''): LongInt;
-procedure MaskModifier(var code: LongInt; modifier: LongWord);
+function KeyNameToCode(name: shortstring): LongInt; inline;
+function KeyNameToCode(name: shortstring; Modifier: shortstring): LongInt;
+//procedure MaskModifier(var code: LongInt; modifier: LongWord);
procedure MaskModifier(Modifier: shortstring; var code: LongInt);
procedure ProcessMouse(event: TSDL_MouseButtonEvent; ButtonDown: boolean);
procedure ProcessKey(event: TSDL_KeyboardEvent); inline;
@@ -60,6 +61,11 @@
KeyNames: array [0..cKeyMaxIndex] of string[15];
CurrentBinds: TBinds;
+function KeyNameToCode(name: shortstring): LongInt; inline;
+begin
+ KeyNameToCode:= KeyNameToCode(name, '');
+end;
+
function KeyNameToCode(name: shortstring; Modifier: shortstring): LongInt;
var code: LongInt;
begin
@@ -70,7 +76,7 @@
MaskModifier(Modifier, code);
KeyNameToCode:= code;
end;
-
+(*
procedure MaskModifier(var code: LongInt; Modifier: LongWord);
begin
if(Modifier and KMOD_LSHIFT) <> 0 then code:= code or LSHIFT;
@@ -80,7 +86,7 @@
if(Modifier and KMOD_LCTRL) <> 0 then code:= code or LCTRL;
if(Modifier and KMOD_RCTRL) <> 0 then code:= code or LCTRL;
end;
-
+*)
procedure MaskModifier(Modifier: shortstring; var code: LongInt);
var mod_ : shortstring;
ModifierCount, i: LongInt;
@@ -133,7 +139,7 @@
if CurrentBinds[code][0] <> #0 then
begin
- if (code > 3) and KeyDown and not ((CurrentBinds[code] = 'put') or (CurrentBinds[code] = 'ammomenu') or (CurrentBinds[code] = '+cur_u') or (CurrentBinds[code] = '+cur_d') or (CurrentBinds[code] = '+cur_l') or (CurrentBinds[code] = '+cur_r')) then hideAmmoMenu:= true;
+ if (code > 3) and KeyDown and (not ((CurrentBinds[code] = 'put')) or (CurrentBinds[code] = 'ammomenu') or (CurrentBinds[code] = '+cur_u') or (CurrentBinds[code] = '+cur_d') or (CurrentBinds[code] = '+cur_l') or (CurrentBinds[code] = '+cur_r')) then hideAmmoMenu:= true;
if KeyDown then
begin
@@ -248,6 +254,7 @@
DefaultBinds[KeyNameToCode(_S'0')]:= '+volup';
DefaultBinds[KeyNameToCode(_S'9')]:= '+voldown';
+DefaultBinds[KeyNameToCode(_S'8')]:= 'mute';
DefaultBinds[KeyNameToCode(_S'c')]:= 'capture';
DefaultBinds[KeyNameToCode(_S'r')]:= 'record';
DefaultBinds[KeyNameToCode(_S'h')]:= 'findhh';
--- a/hedgewars/uRandom.pas Fri Jul 13 16:39:20 2012 +0400
+++ b/hedgewars/uRandom.pas Thu Jul 26 21:56:47 2012 +0400
@@ -35,15 +35,23 @@
procedure SetRandomSeed(Seed: shortstring); // Sets the seed that should be used for generating pseudo-random values.
function GetRandomf: hwFloat; overload; // Returns a pseudo-random hwFloat.
-function GetRandom(m: LongWord): LongWord; overload; // Returns a positive pseudo-random integer smaller than m.
+function GetRandom(m: LongWord): LongWord; overload; inline; // Returns a positive pseudo-random integer smaller than m.
+procedure AddRandomness(r: LongWord); inline;
function rndSign(num: hwFloat): hwFloat; // Returns num with a random chance of having a inverted sign.
+
implementation
var cirbuf: array[0..63] of Longword;
n: byte;
-function GetNext: Longword;
+procedure AddRandomness(r: LongWord); inline;
+begin
+n:= (n + 1) and $3F;
+cirbuf[n]:= cirbuf[n] xor r
+end;
+
+function GetNext: Longword; inline;
begin
n:= (n + 1) and $3F;
cirbuf[n]:=
@@ -79,7 +87,7 @@
GetRandomf.QWordValue:= GetNext
end;
-function GetRandom(m: LongWord): LongWord;
+function GetRandom(m: LongWord): LongWord; inline;
begin
GetNext;
GetRandom:= GetNext mod m
--- a/hedgewars/uScript.pas Fri Jul 13 16:39:20 2012 +0400
+++ b/hedgewars/uScript.pas Thu Jul 26 21:56:47 2012 +0400
@@ -981,10 +981,9 @@
begin
prevgear := CurrentHedgehog^.Gear;
prevgear^.Active := false;
- prevgear^.State:= prevgear^.State and not gstHHDriven;
+ prevgear^.State:= prevgear^.State and (not gstHHDriven);
prevgear^.Z := cHHZ;
- RemoveGearFromList(prevgear);
- InsertGearToList(prevgear);
+ prevgear^.Message:= prevgear^.Message or gmRemoveFromList or gmAddToList;
SwitchCurrentHedgehog(gear^.Hedgehog);
CurrentTeam:= CurrentHedgehog^.Team;
@@ -992,8 +991,7 @@
gear^.State:= gear^.State or gstHHDriven;
gear^.Active := true;
gear^.Z := cCurrHHZ;
- RemoveGearFromList(gear);
- InsertGearToList(gear);
+ gear^.Message:= gear^.Message or gmRemoveFromList or gmAddToList;
end
end;
lc_switchhog:= 0
--- a/hedgewars/uSound.pas Fri Jul 13 16:39:20 2012 +0400
+++ b/hedgewars/uSound.pas Thu Jul 26 21:56:47 2012 +0400
@@ -47,7 +47,7 @@
// Obvious music commands for music track
procedure SetMusic(enabled: boolean); // Enable/disable music.
-procedure SetMusicName(musicname: shortstring); // Enable/disable music and set name of musicfile to play.
+procedure SetMusicName(musicname: shortstring); // Enable/disable music and set name of the file to play.
procedure PlayMusic; // Play music from the start.
procedure PauseMusic; // Pause music.
procedure ResumeMusic; // Resume music from pause point.
@@ -82,6 +82,16 @@
procedure PlayNextVoice;
+// GLOBAL FUNCTIONS
+
+// Drastically lower the volume when we lose focus (and restore the previous value).
+procedure DampenAudio;
+procedure UndampenAudio;
+
+// Mute/Unmute audio
+procedure MuteAudio;
+
+
// MISC
// Set the initial volume
@@ -93,25 +103,22 @@
// Returns a pointer to the voicepack with the given name.
function AskForVoicepack(name: shortstring): Pointer;
-// Drastically lower the volume when we lose focus (and restore the previous value).
-procedure DampenAudio;
-procedure UndampenAudio;
implementation
uses uVariables, uConsole, uUtils, uCommands, uDebug;
const chanTPU = 32;
var Volume: LongInt;
+ cInitVolume: LongInt;
+ previousVolume: LongInt; // cached volume value
lastChan: array [TSound] of LongInt;
voicepacks: array[0..cMaxTeams] of TVoicepack;
defVoicepack: PVoicepack;
- Mus: PMixMusic = nil;
+ Mus: PMixMusic = nil; // music pointer
MusicFN: shortstring; // music file name
- previousVolume: LongInt; // cached volume value
isMusicEnabled: boolean;
isSoundEnabled: boolean;
isSEBackup: boolean;
- cInitVolume: LongInt;
function AskForVoicepack(name: shortstring): Pointer;
@@ -180,7 +187,7 @@
WriteLnToConsole(msgOK);
Mix_AllocateChannels(Succ(chanTPU));
- ChangeVolume(cInitVolume);
+ ChangeVolume(cInitVolume);
end;
procedure ResetSound;
@@ -446,7 +453,7 @@
function ChangeVolume(voldelta: LongInt): LongInt;
begin
ChangeVolume:= 0;
- if not isSoundEnabled then
+ if (not isSoundEnabled) or (voldelta = 0) then
exit;
inc(Volume, voldelta);
@@ -458,20 +465,52 @@
Volume:= Mix_Volume(-1, -1);
if isMusicEnabled then
Mix_VolumeMusic(Volume * 4 div 8);
- ChangeVolume:= Volume * 100 div MIX_MAX_VOLUME
+ ChangeVolume:= Volume * 100 div MIX_MAX_VOLUME;
+
+ if (isMusicEnabled) then
+ if (Volume = 0) then
+ PauseMusic
+ else
+ ResumeMusic;
+
+ isAudioMuted:= (Volume = 0);
end;
procedure DampenAudio;
begin
+ if (isAudioMuted) then
+ exit;
previousVolume:= Volume;
ChangeVolume(-Volume * 7 div 9);
end;
procedure UndampenAudio;
begin
+ if (isAudioMuted) then
+ exit;
ChangeVolume(previousVolume - Volume);
end;
+procedure MuteAudio;
+begin
+ if (not isSoundEnabled) then
+ exit;
+
+ if (isAudioMuted) then
+ begin
+ ResumeMusic;
+ ChangeVolume(previousVolume);
+ end
+ else
+ begin
+ PauseMusic;
+ previousVolume:= Volume;
+ ChangeVolume(-Volume);
+ end;
+
+ // isAudioMuted is updated in ChangeVolume
+end;
+
procedure SetMusic(enabled: boolean);
begin
isMusicEnabled:= enabled;
@@ -534,17 +573,22 @@
CurrentTeam^.voicepack:= AskForVoicepack(s)
end;
+procedure chMute(var s: shortstring);
+begin
+ s:= s; // avoid compiler hint
+ MuteAudio;
+end;
+
procedure initModule;
var t: LongInt;
i: TSound;
begin
RegisterVariable('voicepack', @chVoicepack, false);
+ RegisterVariable('mute' , @chMute , true );
MusicFN:='';
- isMusicEnabled:= true;
- isSoundEnabled:= true;
+ isAudioMuted:= false;
isSEBackup:= isSoundEnabled;
- cInitVolume:= 100;
Volume:= 0;
defVoicepack:= AskForVoicepack('Default');
@@ -568,6 +612,11 @@
begin
if isSoundEnabled then
ReleaseSound(true);
+ // koda still needs to fix this properly. when he rearranged things, he made these variables get
+ // reset after argparsers picks them up
+ isMusicEnabled:= true;
+ isSoundEnabled:= true;
+ cInitVolume:= 100;
end;
end.
--- a/hedgewars/uTeams.pas Fri Jul 13 16:39:20 2012 +0400
+++ b/hedgewars/uTeams.pas Thu Jul 26 21:56:47 2012 +0400
@@ -473,7 +473,7 @@
begin
Gear^.Invulnerable:= false;
Gear^.Damage:= Gear^.Health;
- Gear^.State:= (Gear^.State or gstHHGone) and not gstHHDriven
+ Gear^.State:= (Gear^.State or gstHHGone) and (not gstHHDriven)
end
end
end;
--- a/hedgewars/uTypes.pas Fri Jul 13 16:39:20 2012 +0400
+++ b/hedgewars/uTypes.pas Thu Jul 26 21:56:47 2012 +0400
@@ -102,7 +102,7 @@
gtSniperRifleShot, gtJetpack, gtMolotov, gtBirdy, // 44
gtEgg, gtPortal, gtPiano, gtGasBomb, gtSineGunShot, gtFlamethrower, // 50
gtSMine, gtPoisonCloud, gtHammer, gtHammerHit, gtResurrector, // 55
- gtNapalmBomb, gtSnowball, gtFlake, gtStructure, gtLandGun, gtTardis, gtIceGun); // 62
+ gtNapalmBomb, gtSnowball, gtFlake, gtStructure, gtLandGun, gtTardis, gtIceGun, gtAddAmmo, gtGenericFaller); // 62
// Gears that are _only_ of visual nature (e.g. background stuff, visual effects, speechbubbles, etc.)
TVisualGearType = (vgtFlake, vgtCloud, vgtExplPart, vgtExplPart2, vgtFire,
@@ -340,6 +340,8 @@
HatTex: PTexture;
Ammo: PHHAmmo;
CurAmmoType: TAmmoType;
+ PickUpType: LongWord;
+ PickUpDelay: LongInt;
AmmoStore: Longword;
Team: PTeam;
MultiShootAttacks: Longword;
@@ -404,24 +406,27 @@
sidHellishBomb, sidDrill, sidBallgun, sidNapalm, sidRCPlane,
sidLowGravity, sidExtraDamage, sidInvulnerable, sidExtraTime,
sidLaserSight, sidVampiric, sidSniperRifle, sidJetpack,
- sidMolotov, sidBirdy, sidPortalGun, sidPiano, sidGasBomb, sidSineGun, sidFlamethrower,
- sidSMine, sidHammer, sidResurrector, sidDrillStrike, sidSnowball, sidNothing, sidTardis,
- sidStructure, sidLandGun, sidIceGun);
+ sidMolotov, sidBirdy, sidPortalGun, sidPiano, sidGasBomb,
+ sidSineGun, sidFlamethrower,sidSMine, sidHammer, sidResurrector,
+ sidDrillStrike, sidSnowball, sidNothing, sidTardis,
+ sidStructure, sidLandGun, sidIceGun);
TMsgStrId = (sidStartFight, sidDraw, sidWinner, sidVolume, sidPaused,
sidConfirm, sidSuddenDeath, sidRemaining, sidFuel, sidSync,
sidNoEndTurn, sidNotYetAvailable, sidRoundSD, sidRoundsSD, sidReady,
- sidBounce1, sidBounce2, sidBounce3, sidBounce4, sidBounce5, sidBounce);
+ sidBounce1, sidBounce2, sidBounce3, sidBounce4, sidBounce5, sidBounce,
+ sidMute);
// Events that are important for the course of the game or at least interesting for other reasons
TEventId = (eidDied, eidDrowned, eidRoundStart, eidRoundWin, eidRoundDraw,
- eidNewHealthPack, eidNewAmmoPack, eidNewUtilityPack, eidTurnSkipped, eidHurtSelf,
- eidHomerun, eidGone);
+ eidNewHealthPack, eidNewAmmoPack, eidNewUtilityPack, eidTurnSkipped,
+ eidHurtSelf, eidHomerun, eidGone);
TGoalStrId = (gidCaption, gidSubCaption, gidForts, gidLowGravity, gidInvulnerable,
gidVampiric, gidKarma, gidKing, gidPlaceHog, gidArtillery,
- gidSolidLand, gidSharedAmmo, gidMineTimer, gidNoMineTimer, gidRandomMineTimer,
- gidDamageModifier, gidResetHealth, gidAISurvival, gidInfAttack, gidResetWeps, gidPerHogAmmo, gidTagTeam);
+ gidSolidLand, gidSharedAmmo, gidMineTimer, gidNoMineTimer,
+ gidRandomMineTimer, gidDamageModifier, gidResetHealth, gidAISurvival,
+ gidInfAttack, gidResetWeps, gidPerHogAmmo, gidTagTeam);
TLandArray = packed array of array of LongWord;
TCollisionArray = packed array of array of Word;
--- a/hedgewars/uVariables.pas Fri Jul 13 16:39:20 2012 +0400
+++ b/hedgewars/uVariables.pas Thu Jul 26 21:56:47 2012 +0400
@@ -69,11 +69,13 @@
isPaused : boolean;
isInMultiShoot : boolean;
isSpeed : boolean;
+ SpeedStart : LongWord;
fastUntilLag : boolean;
fastScrolling : boolean;
autoCameraOn : boolean;
+ CheckSum : LongWord;
GameTicks : LongWord;
GameState : TGameState;
GameType : TGameType;
@@ -108,6 +110,7 @@
cWaterLine : Word;
cGearScrEdgesDist: LongInt;
+ isAudioMuted : boolean;
// originally typed consts
ExplosionBorderColor: LongWord;
@@ -1453,7 +1456,8 @@
NumberInCase: 1;
Ammo: (Propz: ammoprop_ForwMsgs or
ammoprop_NoCrosshair or
- ammoprop_DontHold;
+ ammoprop_DontHold or
+ ammoprop_Track;
Count: 1;
NumPerTurn: 0;
Timer: 0;
@@ -2378,6 +2382,8 @@
(* gtLandGun *) , amLandGun
(* gtTardis *) , amTardis
(* gtIceGun *) , amIceGun
+(* gtAddAmmo *) , amNothing
+(* gtGenericFaller *) , amNothing
);
var
@@ -2544,6 +2550,7 @@
CursorMovementX := 0;
CursorMovementY := 0;
GameTicks := 0;
+ CheckSum := 0;
cWaterLine := LAND_HEIGHT;
cGearScrEdgesDist := 240;
@@ -2592,6 +2599,7 @@
isPaused := false;
isInMultiShoot := false;
isSpeed := false;
+ SpeedStart := 0;
fastUntilLag := false;
fastScrolling := false;
autoCameraOn := true;
--- a/hedgewars/uVisualGears.pas Fri Jul 13 16:39:20 2012 +0400
+++ b/hedgewars/uVisualGears.pas Thu Jul 26 21:56:47 2012 +0400
@@ -295,6 +295,8 @@
dy:= 0;
FrameTicks:= 740;
Frame:= 19;
+ Scale:= 0.75;
+ Timer:= 1;
end;
vgtDroplet:
begin
--- a/hedgewars/uWorld.pas Fri Jul 13 16:39:20 2012 +0400
+++ b/hedgewars/uWorld.pas Thu Jul 26 21:56:47 2012 +0400
@@ -1333,7 +1333,7 @@
r.w:= 3;
DrawTextureFromRect(TeamHealthBarWidth + 16, cScreenHeight + DrawHealthY + smallScreenOffset, @r, HealthTex);
- if not highlight and not hasGone and (TeamHealth > 1) then
+ if not highlight and (not hasGone) and (TeamHealth > 1) then
for i:= 0 to cMaxHHIndex do
if Hedgehogs[i].Gear <> nil then
begin
@@ -1530,14 +1530,16 @@
end;
if SoundTimerTicks >= 50 then
- begin
- SoundTimerTicks:= 0;
- if cVolumeDelta <> 0 then
- begin
- str(ChangeVolume(cVolumeDelta), s);
- AddCaption(Format(trmsg[sidVolume], s), cWhiteColor, capgrpVolume)
- end
- end;
+begin
+ SoundTimerTicks:= 0;
+ if cVolumeDelta <> 0 then
+ begin
+ str(ChangeVolume(cVolumeDelta), s);
+ AddCaption(Format(trmsg[sidVolume], s), cWhiteColor, capgrpVolume);
+ end;
+ if isAudioMuted then
+ AddCaption(trmsg[sidMute], cWhiteColor, capgrpVolume)
+end;
if GameState = gsConfirm then
DrawTextureCentered(0, (cScreenHeight shr 1), ConfirmTexture);
--- a/share/hedgewars/Data/Locale/en.txt Fri Jul 13 16:39:20 2012 +0400
+++ b/share/hedgewars/Data/Locale/en.txt Thu Jul 26 21:56:47 2012 +0400
@@ -79,6 +79,7 @@
01:18=High
01:19=Extreme
01:20=%1 Bounce
+01:21=Audio Muted
; Event messages
; Hog (%1) died
--- a/tools/PascalParser.hs Fri Jul 13 16:39:20 2012 +0400
+++ b/tools/PascalParser.hs Thu Jul 26 21:56:47 2012 +0400
@@ -19,7 +19,7 @@
pascalUnit = do
comments
- u <- choice [program, unit, systemUnit]
+ u <- choice [program, unit, systemUnit, redoUnit]
comments
return u
@@ -348,36 +348,46 @@
comments
return $ Implementation u (TypesAndVars tv)
-expression = buildExpressionParser table term <?> "expression"
+expression = do
+ buildExpressionParser table term <?> "expression"
where
term = comments >> choice [
builtInFunction expression >>= \(n, e) -> return $ BuiltInFunCall e (SimpleReference (Identifier n BTUnknown))
, try (parens pas $ expression >>= \e -> notFollowedBy (comments >> char '.') >> return e)
, brackets pas (commaSep pas iD) >>= return . SetExpression
- , try $ natural pas >>= \i -> notFollowedBy (char '.') >> (return . NumberLiteral . show) i
+ , try $ integer pas >>= \i -> notFollowedBy (char '.') >> (return . NumberLiteral . show) i
, float pas >>= return . FloatLiteral . show
- , natural pas >>= return . NumberLiteral . show
+ , try $ integer pas >>= return . NumberLiteral . show
, try (string "_S" >> stringLiteral pas) >>= return . StringLiteral
, try (string "_P" >> stringLiteral pas) >>= return . PCharLiteral
, stringLiteral pas >>= return . strOrChar
, try (string "#$") >> many hexDigit >>= \c -> comments >> return (HexCharCode c)
, char '#' >> many digit >>= \c -> comments >> return (CharCode c)
, char '$' >> many hexDigit >>= \h -> comments >> return (HexNumber h)
- , char '-' >> expression >>= return . PrefixOp "-"
+ --, char '-' >> expression >>= return . PrefixOp "-"
+ , char '-' >> reference >>= return . PrefixOp "-" . Reference
+ , try $ string "not" >> error "unexpected not in term"
, try $ string "nil" >> return Null
- , try $ string "not" >> expression >>= return . PrefixOp "not"
, reference >>= return . Reference
] <?> "simple expression"
- table = [
+ table = [
+ [ Prefix (try (string "not") >> return (PrefixOp "not"))
+ , Prefix (try (char '-') >> return (PrefixOp "-"))]
+ ,
[ Infix (char '*' >> return (BinOp "*")) AssocLeft
, Infix (char '/' >> return (BinOp "/")) AssocLeft
, Infix (try (string "div") >> return (BinOp "div")) AssocLeft
, Infix (try (string "mod") >> return (BinOp "mod")) AssocLeft
, Infix (try (string "in") >> return (BinOp "in")) AssocNone
+ , Infix (try $ string "and" >> return (BinOp "and")) AssocLeft
+ , Infix (try $ string "shl" >> return (BinOp "shl")) AssocLeft
+ , Infix (try $ string "shr" >> return (BinOp "shr")) AssocLeft
]
, [ Infix (char '+' >> return (BinOp "+")) AssocLeft
, Infix (char '-' >> return (BinOp "-")) AssocLeft
+ , Infix (try $ string "or" >> return (BinOp "or")) AssocLeft
+ , Infix (try $ string "xor" >> return (BinOp "xor")) AssocLeft
]
, [ Infix (try (string "<>") >> return (BinOp "<>")) AssocNone
, Infix (try (string "<=") >> return (BinOp "<=")) AssocNone
@@ -385,13 +395,13 @@
, Infix (char '<' >> return (BinOp "<")) AssocNone
, Infix (char '>' >> return (BinOp ">")) AssocNone
]
- , [ Infix (try $ string "shl" >> return (BinOp "shl")) AssocNone
- , Infix (try $ string "shr" >> return (BinOp "shr")) AssocNone
+ {-, [ Infix (try $ string "shl" >> return (BinOp "shl")) AssocNone
+ , Infix (try $ string "shr" >> return (BinOp "shr")) AssocNone
]
- , [ Infix (try $ string "and" >> return (BinOp "and")) AssocLeft
- , Infix (try $ string "or" >> return (BinOp "or")) AssocLeft
+ , [
+ Infix (try $ string "or" >> return (BinOp "or")) AssocLeft
, Infix (try $ string "xor" >> return (BinOp "xor")) AssocLeft
- ]
+ ]-}
, [
Infix (char '=' >> return (BinOp "=")) AssocNone
]
@@ -415,7 +425,7 @@
, switchCase
, withBlock
, forCycle
- , (try $ reference >>= \r -> string ":=" >> return r) >>= \r -> expression >>= return . Assignment r
+ , (try $ reference >>= \r -> string ":=" >> return r) >>= \r -> comments >> expression >>= return . Assignment r
, builtInFunction expression >>= \(n, e) -> return $ BuiltInFunctionCall e (SimpleReference (Identifier n BTUnknown))
, procCall
, char ';' >> comments >> return NOP
@@ -480,7 +490,12 @@
comments
e1 <- expression
comments
- choice [string "to", string "downto"]
+ up <- liftM (== Just "to") $
+ optionMaybe $ choice [
+ try $ string "to"
+ , try $ string "downto"
+ ]
+ --choice [string "to", string "downto"]
comments
e2 <- expression
comments
@@ -488,7 +503,7 @@
comments
p <- phrase
comments
- return $ ForCycle i e1 e2 p
+ return $ ForCycle i e1 e2 p up
switchCase = do
try $ string "case"
@@ -573,14 +588,20 @@
table = [
[
Prefix (char '-' >> return (InitPrefixOp "-"))
+ ,Prefix (try (string "not") >> return (InitPrefixOp "not"))
]
, [ Infix (char '*' >> return (InitBinOp "*")) AssocLeft
, Infix (char '/' >> return (InitBinOp "/")) AssocLeft
, Infix (try (string "div") >> return (InitBinOp "div")) AssocLeft
, Infix (try (string "mod") >> return (InitBinOp "mod")) AssocLeft
+ , Infix (try $ string "and" >> return (InitBinOp "and")) AssocLeft
+ , Infix (try $ string "shl" >> return (InitBinOp "shl")) AssocNone
+ , Infix (try $ string "shr" >> return (InitBinOp "shr")) AssocNone
]
, [ Infix (char '+' >> return (InitBinOp "+")) AssocLeft
, Infix (char '-' >> return (InitBinOp "-")) AssocLeft
+ , Infix (try $ string "or" >> return (InitBinOp "or")) AssocLeft
+ , Infix (try $ string "xor" >> return (InitBinOp "xor")) AssocLeft
]
, [ Infix (try (string "<>") >> return (InitBinOp "<>")) AssocNone
, Infix (try (string "<=") >> return (InitBinOp "<=")) AssocNone
@@ -589,14 +610,14 @@
, Infix (char '>' >> return (InitBinOp ">")) AssocNone
, Infix (char '=' >> return (InitBinOp "=")) AssocNone
]
- , [ Infix (try $ string "and" >> return (InitBinOp "and")) AssocLeft
+ {--, [ Infix (try $ string "and" >> return (InitBinOp "and")) AssocLeft
, Infix (try $ string "or" >> return (InitBinOp "or")) AssocLeft
, Infix (try $ string "xor" >> return (InitBinOp "xor")) AssocLeft
]
, [ Infix (try $ string "shl" >> return (InitBinOp "shl")) AssocNone
, Infix (try $ string "shr" >> return (InitBinOp "shr")) AssocNone
- ]
- , [Prefix (try (string "not") >> return (InitPrefixOp "not"))]
+ ]--}
+ --, [Prefix (try (string "not") >> return (InitPrefixOp "not"))]
]
itypeCast = do
@@ -621,3 +642,14 @@
string "var"
v <- varsDecl True
return $ System (t ++ v)
+
+redoUnit = do
+ string "redo;"
+ comments
+ string "type"
+ comments
+ t <- typesDecl
+ string "var"
+ v <- varsDecl True
+ return $ Redo (t ++ v)
+
--- a/tools/PascalPreprocessor.hs Fri Jul 13 16:39:20 2012 +0400
+++ b/tools/PascalPreprocessor.hs Thu Jul 26 21:56:47 2012 +0400
@@ -18,6 +18,8 @@
initDefines = Map.fromList [
("FPC", "")
, ("PAS2C", "")
+ , ("ENDIAN_LITTLE", "")
+ , ("S3D_DISABLED", "")
]
preprocess :: String -> IO String
--- a/tools/PascalUnitSyntaxTree.hs Fri Jul 13 16:39:20 2012 +0400
+++ b/tools/PascalUnitSyntaxTree.hs Thu Jul 26 21:56:47 2012 +0400
@@ -7,6 +7,7 @@
Program Identifier Implementation Phrase
| Unit Identifier Interface Implementation (Maybe Initialize) (Maybe Finalize)
| System [TypeVarDeclaration]
+ | Redo [TypeVarDeclaration]
deriving Show
data Interface = Interface Uses TypesAndVars
deriving Show
@@ -48,7 +49,7 @@
| IfThenElse Expression Phrase (Maybe Phrase)
| WhileCycle Expression Phrase
| RepeatCycle Expression [Phrase]
- | ForCycle Identifier Expression Expression Phrase
+ | ForCycle Identifier Expression Expression Phrase Bool -- The last Boolean indicates wether it's up or down counting
| WithBlock Reference Phrase
| Phrases [Phrase]
| SwitchCase Expression [([InitExpression], Phrase)] (Maybe [Phrase])
--- a/tools/pas2c.hs Fri Jul 13 16:39:20 2012 +0400
+++ b/tools/pas2c.hs Thu Jul 26 21:56:47 2012 +0400
@@ -71,13 +71,14 @@
escapeChar :: Char -> ShowS
escapeChar '"' s = "\\\"" ++ s
+escapeChar '\\' s = "\\\\" ++ s
escapeChar a s = a : s
strInit :: String -> Doc
strInit a = text "STRINIT" <> parens (doubleQuotes (text $ escapeStr a))
renderStringConsts :: State RenderState Doc
-renderStringConsts = liftM (vcat . map (\(a, b) -> text "const string255" <+> (text a) <+> text "=" <+> strInit b <> semi))
+renderStringConsts = liftM (vcat . map (\(a, b) -> text "static const string255" <+> (text a) <+> text "=" <+> strInit b <> semi))
$ gets stringConsts
docToLower :: Doc -> Doc
@@ -132,10 +133,16 @@
where
f = do
checkDuplicateFunDecls tvs
- mapM_ (tvar2C True) tvs
+ mapM_ (tvar2C True False True False) tvs
+ toNamespace nss (Redo tvs) = -- functions that are re-implemented, add prefix to all of them
+ currentScope $ execState f (emptyState nss){currentUnit = "fpcrtl_"}
+ where
+ f = do
+ checkDuplicateFunDecls tvs
+ mapM_ (tvar2C True False True False) tvs
toNamespace _ (Program {}) = Map.empty
toNamespace nss (Unit (Identifier i _) interface _ _ _) =
- currentScope $ execState (interface2C interface) (emptyState nss){currentUnit = map toLower i ++ "_"}
+ currentScope $ execState (interface2C interface True) (emptyState nss){currentUnit = map toLower i ++ "_"}
withState' :: (RenderState -> RenderState) -> State RenderState a -> State RenderState a
@@ -149,7 +156,6 @@
})
return a
-withLastIdNamespace :: State RenderState Doc -> State RenderState Doc
withLastIdNamespace f = do
li <- gets lastIdentifier
nss <- gets namespaces
@@ -165,49 +171,57 @@
toCFiles :: Map.Map String Records -> (String, PascalUnit) -> IO ()
toCFiles _ (_, System _) = return ()
+toCFiles _ (_, Redo _) = return ()
toCFiles ns p@(fn, pu) = do
hPutStrLn stdout $ "Rendering '" ++ fn ++ "'..."
toCFiles' p
where
- toCFiles' (fn, p@(Program {})) = writeFile (fn ++ ".c") $ (render2C initialState . pascal2C) p
+ toCFiles' (fn, p@(Program {})) = writeFile (fn ++ ".c") $ "#include \"fpcrtl.h\"\n" ++ (render2C initialState . pascal2C) p
toCFiles' (fn, (Unit unitId@(Identifier i _) interface implementation _ _)) = do
- let (a, s) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface) initialState{currentUnit = map toLower i ++ "_"}
+ let (a, s) = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface True) initialState{currentUnit = map toLower i ++ "_"}
+ (a', s') = runState (id2C IOInsert (setBaseType BTUnit unitId) >> interface2C interface False) initialState{currentUnit = map toLower i ++ "_"}
writeFile (fn ++ ".h") $ "#pragma once\n\n#include \"pas2c.h\"\n\n" ++ (render (a $+$ text ""))
- writeFile (fn ++ ".c") $ "#include \"" ++ fn ++ ".h\"\n" ++ (render2C s . implementation2C) implementation
+ writeFile (fn ++ ".c") $ "#include \"fpcrtl.h\"\n\n#include \"" ++ fn ++ ".h\"\n" ++ render (a' $+$ text "") ++ (render2C s . implementation2C) implementation
initialState = emptyState ns
render2C :: RenderState -> State RenderState Doc -> String
render2C a = render . ($+$ empty) . flip evalState a
+
usesFiles :: PascalUnit -> [String]
-usesFiles (Program _ (Implementation uses _) _) = "pas2cSystem" : uses2List uses
-usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = "pas2cSystem" : uses2List uses1 ++ uses2List uses2
+usesFiles (Program _ (Implementation uses _) _) = ["pas2cSystem", "pas2cRedo"] ++ uses2List uses
+usesFiles (Unit _ (Interface uses1 _) (Implementation uses2 _) _ _) = ["pas2cSystem", "pas2cRedo"] ++ uses2List uses1 ++ uses2List uses2
usesFiles (System {}) = []
-
+usesFiles (Redo {}) = []
pascal2C :: PascalUnit -> State RenderState Doc
pascal2C (Unit _ interface implementation init fin) =
- liftM2 ($+$) (interface2C interface) (implementation2C implementation)
+ liftM2 ($+$) (interface2C interface True) (implementation2C implementation)
pascal2C (Program _ implementation mainFunction) = do
impl <- implementation2C implementation
- [main] <- tvar2C True
- (FunctionDeclaration (Identifier "main" BTInt) (SimpleType $ Identifier "int" BTInt) [] (Just (TypesAndVars [], mainFunction)))
+ [main] <- tvar2C True False True True (FunctionDeclaration (Identifier "main" BTInt) (SimpleType $ Identifier "int" BTInt) [VarDeclaration False False ([Identifier "argc" BTInt], SimpleType (Identifier "Integer" BTInt)) Nothing, VarDeclaration False False ([Identifier "argv" BTUnknown], SimpleType (Identifier "PPChar" BTUnknown)) Nothing] (Just (TypesAndVars [], mainFunction)))
return $ impl $+$ main
-
-interface2C :: Interface -> State RenderState Doc
-interface2C (Interface uses tvars) = do
+-- the second bool indicates whether do normal interface translation or generate variable declarations
+-- that will be inserted into implementation files
+interface2C :: Interface -> Bool -> State RenderState Doc
+interface2C (Interface uses tvars) True = do
u <- uses2C uses
- tv <- typesAndVars2C True tvars
+ tv <- typesAndVars2C True True True tvars
r <- renderStringConsts
return (u $+$ r $+$ tv)
+interface2C (Interface uses tvars) False = do
+ u <- uses2C uses
+ tv <- typesAndVars2C True False False tvars
+ r <- renderStringConsts
+ return tv
implementation2C :: Implementation -> State RenderState Doc
implementation2C (Implementation uses tvars) = do
u <- uses2C uses
- tv <- typesAndVars2C True tvars
+ tv <- typesAndVars2C True False True tvars
r <- renderStringConsts
return (u $+$ r $+$ tv)
@@ -220,17 +234,22 @@
ins (FunctionDeclaration (Identifier i _) _ _ _) m = Map.insertWith (+) (map toLower i) 1 m
ins _ m = m
-typesAndVars2C :: Bool -> TypesAndVars -> State RenderState Doc
-typesAndVars2C b (TypesAndVars ts) = do
+-- the second bool indicates whether declare variable as extern or not
+-- the third bool indicates whether include types or not
+
+typesAndVars2C :: Bool -> Bool -> Bool -> TypesAndVars -> State RenderState Doc
+typesAndVars2C b externVar includeType(TypesAndVars ts) = do
checkDuplicateFunDecls ts
- liftM (vcat . map (<> semi) . concat) $ mapM (tvar2C b) ts
+ liftM (vcat . map (<> semi) . concat) $ mapM (tvar2C b externVar includeType False) ts
setBaseType :: BaseType -> Identifier -> Identifier
setBaseType bt (Identifier i _) = Identifier i bt
uses2C :: Uses -> State RenderState Doc
uses2C uses@(Uses unitIds) = do
+
mapM_ injectNamespace (Identifier "pas2cSystem" undefined : unitIds)
+ mapM_ injectNamespace (Identifier "pas2cRedo" undefined : unitIds)
mapM_ (id2C IOInsert . setBaseType BTUnit) unitIds
return $ vcat . map (\i -> text $ "#include \"" ++ i ++ ".h\"") $ uses2List uses
where
@@ -256,6 +275,7 @@
return $ text i'
where
n = map toLower i
+
id2C IOLookup i = id2CLookup head i
id2C IOLookupLast i = id2CLookup last i
id2C (IOLookupFunction params) (Identifier i t) = do
@@ -279,7 +299,7 @@
let vv = head $ fromJust v in modify (\s -> s{lastType = snd vv, lastIdentifier = fst vv}) >> (return . text . fst $ vv)
id2CLookup :: ([Record] -> Record) -> Identifier -> State RenderState Doc
-id2CLookup f (Identifier i _) = do
+id2CLookup f (Identifier i t) = do
let i' = map toLower i
v <- gets $ Map.lookup i' . currentScope
lt <- gets lastType
@@ -363,7 +383,7 @@
error $ "Dereferencing from non-pointer type " ++ show t ++ "\n" ++ s
-functionParams2C params = liftM (hcat . punctuate comma . concat) $ mapM (tvar2C False) params
+functionParams2C params = liftM (hcat . punctuate comma . concat) $ mapM (tvar2C False False True True) params
numberOfDeclarations :: [TypeVarDeclaration] -> Int
numberOfDeclarations = sum . map cnt
@@ -421,12 +441,15 @@
(p, ph) <- withState' (\st -> st{currentScope = Map.insertWith un (map toLower rv) [(render res, t')] $ currentScope st
, currentFunctionResult = if isVoid then [] else render res}) $ do
p <- functionParams2C params
- ph <- liftM2 ($+$) (typesAndVars2C False tvars) (phrase2C' phrase)
+ ph <- liftM2 ($+$) (typesAndVars2C False False True tvars) (phrase2C' phrase)
return (p, ph)
let phrasesBlock = if isVoid then ph else t empty <+> res <> semi $+$ ph $+$ text "return" <+> res <> semi
-
- return [(if notDeclared && hasVars then funWithVarsToDefine n params else empty) $+$
+ let define = if hasVars then text "#ifndef" <+> text n $+$ funWithVarsToDefine n params $+$ text "#endif" else empty
+ return [
+ define
+ $+$
+ --(if notDeclared && hasVars then funWithVarsToDefine n params else empty) $+$
t empty <+> text (if hasVars then n ++ "__vars" else n) <> parens p
$+$
text "{"
@@ -443,37 +466,69 @@
fun2C False _ (FunctionDeclaration (Identifier name _) _ _ _) = error $ "nested functions not allowed: " ++ name
fun2C _ tv _ = error $ "fun2C: I don't render " ++ show tv
-tvar2C :: Bool -> TypeVarDeclaration -> State RenderState [Doc]
-tvar2C b f@(FunctionDeclaration (Identifier name _) _ _ _) =
- fun2C b name f
-tvar2C _ td@(TypeDeclaration i' t) = do
+-- the second bool indicates whether declare variable as extern or not
+-- the third bool indicates whether include types or not
+-- the fourth bool indicates whether ignore initialization or not (basically for dynamic arrays since we cannot do initialization in function params)
+tvar2C :: Bool -> Bool -> Bool -> Bool -> TypeVarDeclaration -> State RenderState [Doc]
+tvar2C b _ includeType _ f@(FunctionDeclaration (Identifier name _) _ _ _) = do
+ t <- fun2C b name f
+ if includeType then return t else return []
+tvar2C _ _ includeType _ td@(TypeDeclaration i' t) = do
i <- id2CTyped t i'
tp <- type2C t
- return [text "typedef" <+> tp i]
+ return $ if includeType then [text "typedef" <+> tp i] else []
-tvar2C _ (VarDeclaration True _ (ids, t) Nothing) = do
+tvar2C _ _ _ _ (VarDeclaration True _ (ids, t) Nothing) = do
t' <- liftM ((empty <+>) . ) $ type2C t
liftM (map(\i -> t' i)) $ mapM (id2CTyped (VarParamType t)) ids
-tvar2C _ (VarDeclaration _ isConst (ids, t) mInitExpr) = do
- t' <- liftM (((if isConst then text "const" else empty) <+>) . ) $ type2C t
+tvar2C _ externVar includeType ignoreInit (VarDeclaration _ isConst (ids, t) mInitExpr) = do
+ t' <- liftM (((if isConst then text "static const" else if externVar
+ then text "extern"
+ else empty)
+ <+>) . ) $ type2C t
ie <- initExpr mInitExpr
lt <- gets lastType
case (isConst, lt, ids, mInitExpr) of
(True, BTInt, [i], Just _) -> do
i' <- id2CTyped t i
- return [text "enum" <> braces (i' <+> ie)]
+ return $ if includeType then [text "enum" <> braces (i' <+> ie)] else []
(True, BTFloat, [i], Just e) -> do
i' <- id2CTyped t i
ie <- initExpr2C e
- return [text "#define" <+> i' <+> parens ie <> text "\n"]
+ return $ if includeType then [text "#define" <+> i' <+> parens ie <> text "\n"] else []
(_, BTFunction{}, _, Nothing) -> liftM (map(\i -> t' i)) $ mapM (id2CTyped t) ids
- _ -> liftM (map(\i -> t' i <+> ie)) $ mapM (id2CTyped t) ids
+ (_, BTArray r _ _, [i], _) -> do
+ i' <- id2CTyped t i
+ ie' <- return $ case (r, mInitExpr, ignoreInit) of
+ (RangeInfinite, Nothing, False) -> text "= NULL" -- force dynamic array to be initialized as NULL if not initialized at all
+ (_, _, _) -> ie
+ result <- liftM (map(\i -> varDeclDecision isConst includeType (t' i) ie')) $ mapM (id2CTyped t) ids
+ case (r, ignoreInit) of
+ (RangeInfinite, False) ->
+ -- if the array is dynamic, add dimension info to it
+ return $ [dimDecl] ++ result
+ where
+ arrayDimStr = show $ arrayDimension t
+ arrayDimInitExp = text ("={" ++ ".dim = " ++ arrayDimStr ++ ", .a = {0, 0, 0, 0}}")
+ dimDecl = varDeclDecision isConst includeType (text "fpcrtl_dimension_t" <+> i' <> text "_dimension_info") arrayDimInitExp
+
+ (_, _) -> return result
+
+ _ -> liftM (map(\i -> varDeclDecision isConst includeType (t' i) ie)) $ mapM (id2CTyped t) ids
where
initExpr Nothing = return $ empty
initExpr (Just e) = liftM (text "=" <+>) (initExpr2C e)
+ varDeclDecision True True varStr expStr = varStr <+> expStr
+ varDeclDecision False True varStr expStr = if externVar then varStr else varStr <+> expStr
+ varDeclDecision False False varStr expStr = varStr <+> expStr
+ varDeclDecision True False varStr expStr = empty
+ arrayDimension a = case a of
+ ArrayDecl Nothing t -> let a = arrayDimension t in if a > 3 then error "Dynamic array with dimension > 4 is not supported." else 1 + arrayDimension t
+ ArrayDecl _ _ -> error "Mixed dynamic array and static array are not supported."
+ _ -> 0
-tvar2C f (OperatorDeclaration op (Identifier i _) ret params body) = do
+tvar2C f _ _ _ (OperatorDeclaration op (Identifier i _) ret params body) = do
r <- op2CTyped op (extractTypes params)
fun2C f i (FunctionDeclaration r ret params body)
@@ -489,6 +544,7 @@
"-" -> "sub"
"*" -> "mul"
"/" -> "div"
+ "/(float)" -> "div"
"=" -> "eq"
"<" -> "lt"
">" -> "gt"
@@ -591,7 +647,7 @@
_ -> return $ \a -> i' <+> text "*" <+> a
type2C' (PointerTo t) = liftM (\t a -> t (parens $ text "*" <> a)) $ type2C t
type2C' (RecordType tvs union) = do
- t <- withState' f $ mapM (tvar2C False) tvs
+ t <- withState' f $ mapM (tvar2C False False True False) tvs
u <- unions
return $ \i -> text "struct __" <> i <+> lbrace $+$ nest 4 ((vcat . map (<> semi) . concat $ t) $$ u) $+$ rbrace <+> i
where
@@ -602,7 +658,7 @@
structs <- mapM struct2C a
return $ text "union" $+$ braces (nest 4 $ vcat structs) <> semi
struct2C tvs = do
- t <- withState' f $ mapM (tvar2C False) tvs
+ t <- withState' f $ mapM (tvar2C False False True False) tvs
return $ text "struct" $+$ braces (nest 4 (vcat . map (<> semi) . concat $ t)) <> semi
type2C' (RangeType r) = return (text "int" <+>)
type2C' (Sequence ids) = do
@@ -615,7 +671,7 @@
t' <- type2C t
lt <- gets lastType
ft <- case lt of
- BTFunction {} -> type2C (PointerTo t)
+ -- BTFunction {} -> type2C (PointerTo t)
_ -> return t'
r' <- initExpr2C (InitRange r)
return $ \i -> ft i <> brackets r'
@@ -675,15 +731,26 @@
e <- expr2C expr
return $ r <+> text "=" <+> e <> semi
_ -> error $ "Assignment to string from " ++ show lt
- (BTArray _ _ _, _) -> phrase2C $
- ProcCall (FunCall
- [
- Reference $ Address ref
- , Reference $ Address $ RefExpression expr
- , Reference $ FunCall [expr] (SimpleReference (Identifier "sizeof" BTUnknown))
- ]
- (SimpleReference (Identifier "memcpy" BTUnknown))
- ) []
+ (BTArray _ _ _, _) -> do
+ case expr of
+ Reference er -> do
+ exprRef <- ref2C er
+ exprT <- gets lastType
+ case exprT of
+ BTArray RangeInfinite _ _ ->
+ return $ text "FIXME: assign a dynamic array to an array"
+ BTArray _ _ _ -> phrase2C $
+ ProcCall (FunCall
+ [
+ Reference $ ref
+ , Reference $ RefExpression expr
+ , Reference $ FunCall [expr] (SimpleReference (Identifier "sizeof" BTUnknown))
+ ]
+ (SimpleReference (Identifier "memcpy" BTUnknown))
+ ) []
+ _ -> return $ text "FIXME: assign a non-specific value to an array"
+
+ _ -> return $ text "FIXME: dynamic array assignment 2"
_ -> do
e <- expr2C expr
return $ r <+> text "=" <+> e <> semi
@@ -704,7 +771,7 @@
ph <- phrase2C p
return $
vcat (map (\i -> text "case" <+> i <> colon) . concat $ ies) <> nest 4 (ph $+$ text "break;")
- dflt | isNothing mphrase = return []
+ dflt | isNothing mphrase = return [text "default: break;"] -- avoid compiler warning
| otherwise = do
ph <- mapM phrase2C $ fromJust mphrase
return [text "default:" <+> nest 4 (vcat ph)]
@@ -716,13 +783,15 @@
(BTRecord _ rs) -> withRecordNamespace (render r ++ ".") rs $ phrase2C $ wrapPhrase p
a -> do
error $ "'with' block referencing non-record type " ++ show a ++ "\n" ++ show wb
-phrase2C (ForCycle i' e1' e2' p) = do
+phrase2C (ForCycle i' e1' e2' p up) = do
i <- id2C IOLookup i'
e1 <- expr2C e1'
e2 <- expr2C e2'
ph <- phrase2C (wrapPhrase p)
+ cmp <- return $ if up == True then "<=" else ">="
+ inc <- return $ if up == True then "++" else "--"
return $
- text "for" <> (parens . hsep . punctuate (char ';') $ [i <+> text "=" <+> e1, i <+> text "<=" <+> e2, text "++" <> i])
+ text "for" <> (parens . hsep . punctuate (char ';') $ [i <+> text "=" <+> parens e1, i <+> text cmp <+> parens e2, text inc <> i])
$$
ph
phrase2C (RepeatCycle e' p') = do
@@ -777,12 +846,23 @@
case expr2 of
SetExpression set -> do
ids <- mapM (id2C IOLookup) set
+ modify(\s -> s{lastType = BTBool})
return . parens . hcat . punctuate (text " || ") . map (\i -> parens $ e1 <+> text "==" <+> i) $ ids
_ -> error "'in' against not set expression"
(o, _, _) | o `elem` boolOps -> do
modify(\s -> s{lastType = BTBool})
return $ parens e1 <+> text o <+> parens e2
- | otherwise -> return $ parens e1 <+> text o <+> parens e2
+ | otherwise -> do
+ o' <- return $ case o of
+ "/(float)" -> text "/(float)" -- pascal returns real value
+ _ -> text o
+ e1' <- return $ case (o, t1, t2) of
+ ("-", BTInt, BTInt) -> parens $ text "(int64_t)" <+> parens e1
+ _ -> parens e1
+ e2' <- return $ case (o, t1, t2) of
+ ("-", BTInt, BTInt) -> parens $ text "(int64_t)" <+> parens e2
+ _ -> parens e2
+ return $ e1' <+> o' <+> e2'
where
boolOps = ["==", "!=", "<", ">", "<=", ">="]
expr2C (NumberLiteral s) = do
@@ -806,7 +886,12 @@
BTRecord t _ -> do
i <- op2CTyped op [SimpleType (Identifier t undefined)]
ref2C $ FunCall [expr] (SimpleReference i)
- _ -> return $ text (op2C op) <> e
+ BTBool -> do
+ o <- return $ case op of
+ "not" -> text "!"
+ _ -> text (op2C op)
+ return $ o <> parens e
+ _ -> return $ text (op2C op) <> parens e
expr2C Null = return $ text "NULL"
expr2C (CharCode a) = do
modify(\s -> s{lastType = BTChar})
@@ -835,13 +920,13 @@
_ -> error $ "BuiltInFunCall 'high' from " ++ show e ++ "\ntype: " ++ show lt
expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "ord" _))) = liftM parens $ expr2C e
expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "succ" _))) = liftM (<> text " + 1") $ expr2C e
-expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "pred" _))) = liftM (<> text " - 1") $ expr2C e
+expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "pred" _))) = liftM (<> text " - (int64_t)1") $ expr2C e
expr2C (BuiltInFunCall [e] (SimpleReference (Identifier "length" _))) = do
e' <- expr2C e
lt <- gets lastType
modify (\s -> s{lastType = BTInt})
case lt of
- BTString -> return $ text "Length" <> parens e'
+ BTString -> return $ text "fpcrtl_Length" <> parens e'
BTArray RangeInfinite _ _ -> error $ "length() called on variable size array " ++ show e'
BTArray (RangeFromTo _ n) _ _ -> initExpr2C (BuiltInFunction "succ" [n])
_ -> error $ "length() called on " ++ show lt
@@ -864,7 +949,7 @@
case t of
BTFunction _ _ rt -> do
modify(\s -> s{lastType = rt})
- return $ i <> parens empty
+ return $ i <> parens empty --xymeng: removed parens
_ -> return $ i
ref2CF r@(RecordField (SimpleReference _) (SimpleReference _)) = do
i <- ref2C r
@@ -962,7 +1047,7 @@
op2C :: String -> String
op2C "or" = "|"
op2C "and" = "&"
-op2C "not" = "!"
+op2C "not" = "~"
op2C "xor" = "^"
op2C "div" = "/"
op2C "mod" = "%"
@@ -970,5 +1055,6 @@
op2C "shr" = ">>"
op2C "<>" = "!="
op2C "=" = "=="
+op2C "/" = "/(float)"
op2C a = a