1 unit uFLGameConfig;

     2 interface

     3 uses uFLTypes;

     4 

     5 procedure resetGameConfig; cdecl;

     6 procedure runQuickGame; cdecl;

     7 procedure runLocalGame; cdecl;

     8 procedure getPreview; cdecl;

     9 

    10 procedure setSeed(seed: PChar); cdecl;

    11 function  getSeed: PChar; cdecl;

    12 procedure setTheme(themeName: PChar); cdecl;

    13 procedure setScript(scriptName: PChar); cdecl;

    14 procedure setScheme(schemeName: PChar); cdecl;

    15 procedure setAmmo(ammoName: PChar); cdecl;

    16 

    17 procedure tryAddTeam(teamName: PChar); cdecl;

    18 procedure tryRemoveTeam(teamName: PChar); cdecl;

    19 procedure changeTeamColor(teamName: PChar; dir: LongInt); cdecl;

    20 

    21 procedure netSetSeed(seed: shortstring);

    22 procedure netSetTheme(themeName: shortstring);

    23 procedure netSetScript(scriptName: shortstring);

    24 procedure netSetFeatureSize(fsize: LongInt);

    25 procedure netSetMapGen(mapgen: LongInt);

    26 procedure netSetMap(map: shortstring);

    27 procedure netSetMazeSize(mazesize: LongInt);

    28 procedure netSetTemplate(template: LongInt);

    29 procedure netSetAmmo(name: shortstring; definition: ansistring);

    30 procedure netSetScheme(scheme: TScheme);

    31 procedure netAddTeam(team: TTeam);

    32 procedure netAcceptedTeam(teamName: shortstring);

    33 procedure netSetTeamColor(team: shortstring; color: Longword);

    34 procedure netSetHedgehogsNumber(team: shortstring; hogsNumber: Longword);

    35 procedure netRemoveTeam(teamName: shortstring);

    36 procedure netDrawnData(data: ansistring);

    37 procedure netResetTeams();

    38 procedure updatePreviewIfNeeded;

    39 

    40 procedure sendConfig(config: PGameConfig);

    41 procedure runNetGame();

    42 

    43 implementation

    44 uses uFLIPC, uFLUtils, uFLTeams, uFLThemes, uFLSChemes, uFLAmmo

    45     , uFLUICallback, uFLRunQueue, uFLNet, uUtils, uFLDrawnMap

    46     , SDLh;

    47 

    48 var

    49     currentConfig: TGameConfig;

    50     previewNeedsUpdate: boolean;

    51 

    52 function getScriptPath(scriptName: shortstring): shortstring;

    53 begin

    54     getScriptPath:= '/Scripts/Multiplayer/' + scriptName + '.lua'

    55 end;

    56 

    57 procedure sendDrawnMap(config: PGameConfig);

    58 var i: Longword;

    59     data: PByteArray;

    60     dataLen: Longword;

    61     s: shortstring;

    62 begin

    63     decodeDrawnMap(config^.drawnData, config^.drawnDataSize, data, dataLen);

    64 

    65     i:= 0;

    66 

    67     s[0]:= #240;

    68     while i < dataLen do

    69     begin

    70         if dataLen - i > 240 then

    71         begin

    72             Move(data^[i], s[1], 240)

    73         end else

    74         begin

    75             Move(data^[i], s[1], dataLen - i);

    76             s[0]:= char(dataLen - i)

    77         end;

    78 

    79         ipcToEngine('edraw ' + s);

    80         inc(i, 240)

    81     end;

    82 

    83     if dataLen > 0 then

    84         FreeMem(data, dataLen);

    85 end;

    86 

    87 procedure sendConfig(config: PGameConfig);

    88 var i: Longword;

    89 begin

    90 with config^ do

    91 begin

    92     case gameType of

    93     gtPreview: begin

    94             if script <> 'Normal' then

    95                 ipcToEngine('escript ' + getScriptPath(script));

    96             ipcToEngine('eseed ' + seed);

    97             ipcToEngine('e$mapgen ' + intToStr(mapgen));

    98             if (mapgen = 1) or (mapgen = 2) then

    99                 ipcToEngine('e$maze_size ' + intToStr(mazeSize))

   100             else

   101                 ipcToEngine('e$template_filter ' + intToStr(template));

   102             ipcToEngine('e$feature_size ' + intToStr(featureSize));

   103             if mapgen = 3 then

   104                 sendDrawnMap(config);

   105         end;

   106 gtLocal, gtNet: begin

   107             if gameType = gtNet then

   108                 ipcToEngine('TN');

   109             if script <> 'Normal' then

   110                 ipcToEngine('escript ' + getScriptPath(script));

   111             ipcToEngine('eseed ' + seed);

   112             ipcToEngine('e$mapgen ' + intToStr(mapgen));

   113             if (mapgen = 1) or (mapgen = 2) then

   114                 ipcToEngine('e$maze_size ' + intToStr(mazeSize))

   115             else

   116                 ipcToEngine('e$template_filter ' + intToStr(template));

   117             ipcToEngine('e$feature_size ' + intToStr(featureSize));

   118             ipcToEngine('e$theme ' + theme);

   119             if mapgen = 3 then

   120                 sendDrawnMap(config);

   121 

   122             sendSchemeConfig(scheme);

   123 

   124             i:= 0;

   125             while (i < 8) and (teams[i].hogsNumber > 0) do

   126                 begin

   127                     sendTeamConfig(config^.scheme.health, teams[i]);

   128                     sendAmmoConfig(config^.ammo);

   129                     inc(i)

   130                 end;

   131         end;

   132     end;

   133 

   134     ipcToEngine('!');

   135 end;

   136 end;

   137 

   138 procedure resetGameConfig; cdecl;

   139 var i: Longword;

   140 begin

   141     with currentConfig do

   142     begin

   143         script:= 'Normal';

   144 

   145         for i:= 0 to 7 do

   146             teams[i].hogsNumber:= 0

   147     end

   148 end;

   149 

   150 procedure setSeed(seed: PChar); cdecl;

   151 begin

   152     sendUI(mtSeed, @seed[1], length(seed));

   153     currentConfig.seed:= seed

   154 end;

   155 

   156 function getSeed: PChar; cdecl;

   157 begin

   158     getSeed:= str2PChar(currentConfig.seed)

   159 end;

   160 

   161 function getUnusedColor: Longword;

   162 var i, c: Longword;

   163     fColorMatched: boolean;

   164 begin

   165     c:= 0;

   166     i:= 0;

   167     repeat

   168         repeat

   169             fColorMatched:= (currentConfig.teams[i].hogsNumber > 0) and (currentConfig.teams[i].color = c);

   170             inc(i)

   171         until (i >= 8) or (currentConfig.teams[i].hogsNumber = 0) or fColorMatched;

   172 

   173         if fColorMatched then

   174         begin

   175             i:= 0;

   176             inc(c)

   177         end;

   178     until not fColorMatched;

   179 

   180     getUnusedColor:= c

   181 end;

   182 

   183 procedure runQuickGame; cdecl;

   184 begin

   185     with currentConfig do

   186     begin

   187         gameType:= gtLocal;

   188         arguments[0]:= '';

   189         arguments[1]:= '--internal';

   190         arguments[2]:= '--nomusic';

   191         argumentsNumber:= 3;

   192 

   193         teams[0]:= createRandomTeam;

   194         teams[0].color:= 0;

   195         teams[1]:= createRandomTeam;

   196         teams[1].color:= 1;

   197         teams[1].botLevel:= 3;

   198 

   199         queueExecution(currentConfig);

   200     end;

   201 end;

   202 

   203 

   204 procedure getPreview; cdecl;

   205 begin

   206     previewNeedsUpdate:= false;

   207 

   208     with currentConfig do

   209     begin

   210         gameType:= gtPreview;

   211         arguments[0]:= '';

   212         arguments[1]:= '--internal';

   213         arguments[2]:= '--landpreview';

   214         argumentsNumber:= 3;

   215 

   216         queueExecution(currentConfig);

   217     end;

   218 end;

   219 

   220 procedure runLocalGame; cdecl;

   221 begin

   222     with currentConfig do

   223     begin

   224         gameType:= gtLocal;

   225         arguments[0]:= '';

   226         arguments[1]:= '--internal';

   227         arguments[2]:= '--nomusic';

   228         argumentsNumber:= 3;

   229 

   230         queueExecution(currentConfig);

   231     end;

   232 end;

   233 

   234 procedure runNetGame();

   235 begin

   236     with currentConfig do

   237     begin

   238         gameType:= gtNet;

   239         arguments[0]:= '';

   240         arguments[1]:= '--internal';

   241         arguments[2]:= '--nomusic';

   242         argumentsNumber:= 3;

   243 

   244         queueExecution(currentConfig);

   245     end;

   246 end;

   247 

   248 procedure tryAddTeam(teamName: PChar); cdecl;

   249 var msg: ansistring;

   250     i, hn, hedgehogsNumber: Longword;

   251     team: PTeam;

   252     c: Longword;

   253 begin

   254     team:= teamByName(teamName);

   255     if team = nil then exit;

   256 

   257     if isConnected then

   258         sendTeam(team^)

   259     else

   260     with currentConfig do

   261     begin

   262         hedgehogsNumber:= 0;

   263         i:= 0;

   264 

   265         while (i < 8) and (teams[i].hogsNumber > 0) do

   266         begin

   267             inc(i);

   268             inc(hedgehogsNumber, teams[i].hogsNumber)

   269         end;

   270 

   271         // no free space for a team or reached hogs number maximum

   272         if (i > 7) or (hedgehogsNumber >= 48) then exit;

   273 

   274         c:= getUnusedColor;

   275 

   276         teams[i]:= team^;

   277         teams[i].extDriven:= false;

   278 

   279         if i = 0 then hn:= 4 else hn:= teams[i - 1].hogsNumber;

   280         if hn > 48 - hedgehogsNumber then hn:= 48 - hedgehogsNumber;

   281         teams[i].hogsNumber:= hn;

   282 

   283         teams[i].color:= c;

   284 

   285         msg:= '0' + #10 + teamName;

   286         sendUI(mtAddPlayingTeam, @msg[1], length(msg));

   287 

   288         msg:= teamName + #10 + colorsSet[teams[i].color];

   289         sendUI(mtTeamColor, @msg[1], length(msg));

   290 

   291         msg:= teamName + #10 + IntToStr(hn);

   292         sendUI(mtHedgehogsNumber, @msg[1], length(msg));

   293 

   294         msg:= teamName;

   295         sendUI(mtRemoveTeam, @msg[1], length(msg))

   296     end

   297 end;

   298 

   299 

   300 procedure tryRemoveTeam(teamName: PChar); cdecl;

   301 var i: Longword;

   302     tn: shortstring;

   303     isLocal: boolean;

   304 begin

   305     with currentConfig do

   306     begin

   307         i:= 0;

   308         tn:= teamName;

   309         while (i < 8) and (teams[i].teamName <> tn) do

   310             inc(i);

   311 

   312         // team not found???

   313         if (i > 7) then exit;

   314 

   315         isLocal:= not teams[i].extDriven;

   316 

   317         if isConnected and not isLocal then

   318             exit; // we cannot remove this team

   319 

   320         while (i < 7) and (teams[i + 1].hogsNumber > 0) do

   321         begin

   322             teams[i]:= teams[i + 1];

   323             inc(i)

   324         end;

   325 

   326         teams[i].hogsNumber:= 0

   327     end;

   328 

   329     sendUI(mtRemovePlayingTeam, @tn[1], length(tn));

   330     if isConnected then

   331         removeTeam(tn);

   332     if isLocal then

   333         sendUI(mtAddTeam, @tn[1], length(tn))

   334 end;

   335 

   336 

   337 procedure changeTeamColor(teamName: PChar; dir: LongInt); cdecl;

   338 var i, dc: Longword;

   339     tn: shortstring;

   340     msg: ansistring;

   341 begin

   342     with currentConfig do

   343     begin

   344         i:= 0;

   345         tn:= teamName;

   346         while (i < 8) and (teams[i].teamName <> tn) do

   347             inc(i);

   348         // team not found???

   349         if (i > 7) then exit;

   350 

   351         if dir >= 0 then dc:= 1 else dc:= 8;

   352         teams[i].color:= (teams[i].color + dc) mod 9;

   353 

   354         msg:= tn + #10 + colorsSet[teams[i].color];

   355         sendUI(mtTeamColor, @msg[1], length(msg))

   356     end

   357 end;

   358 

   359 procedure setTheme(themeName: PChar); cdecl;

   360 begin

   361     currentConfig.theme:= themeName

   362 end;

   363 

   364 procedure setScript(scriptName: PChar); cdecl;

   365 begin

   366     currentConfig.script:= scriptName

   367 end;

   368 

   369 procedure setScheme(schemeName: PChar); cdecl;

   370 var scheme: PScheme;

   371 begin

   372     scheme:= schemeByName(schemeName);

   373 

   374     if scheme <> nil then

   375         currentConfig.scheme:= scheme^

   376 end;

   377 

   378 procedure setAmmo(ammoName: PChar); cdecl;

   379 var ammo: PAmmo;

   380 begin

   381     ammo:= ammoByName(ammoName);

   382 

   383     if ammo <> nil then

   384         currentConfig.ammo:= ammo^

   385 end;

   386 

   387 procedure netSetSeed(seed: shortstring);

   388 begin

   389     if seed <> currentConfig.seed then

   390     begin

   391         currentConfig.seed:= seed;

   392         sendUI(mtSeed, @seed[1], length(seed));

   393 

   394         getPreview()

   395     end

   396 end;

   397 

   398 procedure netSetTheme(themeName: shortstring);

   399 begin

   400     if themeName <> currentConfig.theme then

   401     begin

   402         currentConfig.theme:= themeName;

   403         sendUI(mtTheme, @themeName[1], length(themeName))

   404     end

   405 end;

   406 

   407 procedure netSetScript(scriptName: shortstring);

   408 begin

   409     if scriptName <> currentConfig.script then

   410     begin

   411         previewNeedsUpdate:= true;

   412         currentConfig.script:= scriptName;

   413         sendUI(mtScript, @scriptName[1], length(scriptName))

   414     end

   415 end;

   416 

   417 procedure netSetFeatureSize(fsize: LongInt);

   418 var s: shortstring;

   419 begin

   420     if fsize <> currentConfig.featureSize then

   421     begin

   422         previewNeedsUpdate:= true;

   423         currentConfig.featureSize:= fsize;

   424         s:= IntToStr(fsize);

   425         sendUI(mtFeatureSize, @s[1], length(s))

   426     end

   427 end;

   428 

   429 procedure netSetMapGen(mapgen: LongInt);

   430 var s: shortstring;

   431 begin

   432     if mapgen <> currentConfig.mapgen then

   433     begin

   434         previewNeedsUpdate:= true;

   435         currentConfig.mapgen:= mapgen;

   436         s:= IntToStr(mapgen);

   437         sendUI(mtMapGen, @s[1], length(s))

   438     end

   439 end;

   440 

   441 procedure netSetMap(map: shortstring);

   442 begin

   443     sendUI(mtMap, @map[1], length(map))

   444 end;

   445 

   446 procedure netSetMazeSize(mazesize: LongInt);

   447 var s: shortstring;

   448 begin

   449     if mazesize <> currentConfig.mazesize then

   450     begin

   451         previewNeedsUpdate:= true;

   452         currentConfig.mazesize:= mazesize;

   453         s:= IntToStr(mazesize);

   454         sendUI(mtMazeSize, @s[1], length(s))

   455     end

   456 end;

   457 

   458 procedure netSetTemplate(template: LongInt);

   459 var s: shortstring;

   460 begin

   461     if template <> currentConfig.template then

   462     begin

   463         previewNeedsUpdate:= true;

   464         currentConfig.template:= template;

   465         s:= IntToStr(template);

   466         sendUI(mtTemplate, @s[1], length(s))

   467     end

   468 end;

   469 

   470 procedure updatePreviewIfNeeded;

   471 begin

   472     if previewNeedsUpdate then

   473         getPreview

   474 end;

   475 

   476 procedure netSetAmmo(name: shortstring; definition: ansistring);

   477 var ammo: TAmmo;

   478     i: LongInt;

   479 begin

   480     ammo.ammoName:= name;

   481     i:= length(definition) div 4;

   482     ammo.a:= copy(definition, 1, i);

   483     ammo.b:= copy(definition, i + 1, i);

   484     ammo.c:= copy(definition, i * 2 + 1, i);

   485     ammo.d:= copy(definition, i * 3 + 1, i);

   486 

   487     currentConfig.ammo:= ammo;

   488     sendUI(mtAmmo, @name[1], length(name))

   489 end;

   490 

   491 procedure netSetScheme(scheme: TScheme);

   492 begin

   493     currentConfig.scheme:= scheme;

   494     sendUI(mtScheme, @scheme.schemeName[1], length(scheme.schemeName))

   495 end;

   496 

   497 procedure netAddTeam(team: TTeam);

   498 var msg: ansistring;

   499     i, hn, hedgehogsNumber: Longword;

   500     c: Longword;

   501 begin

   502     with currentConfig do

   503     begin

   504         hedgehogsNumber:= 0;

   505         i:= 0;

   506 

   507         while (i < 8) and (teams[i].hogsNumber > 0) do

   508         begin

   509             inc(i);

   510             inc(hedgehogsNumber, teams[i].hogsNumber)

   511         end;

   512 

   513         // no free space for a team - server bug???

   514         if (i > 7) or (hedgehogsNumber >= 48) then exit;

   515 

   516         c:= getUnusedColor;

   517 

   518         teams[i]:= team;

   519         teams[i].extDriven:= true;

   520 

   521         if i = 0 then hn:= 4 else hn:= teams[i - 1].hogsNumber;

   522         if hn > 48 - hedgehogsNumber then hn:= 48 - hedgehogsNumber;

   523         teams[i].hogsNumber:= hn;

   524 

   525         teams[i].color:= c;

   526 

   527         msg:= '0' + #10 + team.teamName;

   528         sendUI(mtAddPlayingTeam, @msg[1], length(msg));

   529 

   530         msg:= team.teamName + #10 + colorsSet[teams[i].color];

   531         sendUI(mtTeamColor, @msg[1], length(msg));

   532     end

   533 end;

   534 

   535 procedure netAcceptedTeam(teamName: shortstring);

   536 var msg: ansistring;

   537     i, hn, hedgehogsNumber: Longword;

   538     c: Longword;

   539     team: PTeam;

   540 begin

   541     with currentConfig do

   542     begin

   543         team:= teamByName(teamName);

   544         // no such team???

   545         if team = nil then exit;

   546 

   547         hedgehogsNumber:= 0;

   548         i:= 0;

   549 

   550         while (i < 8) and (teams[i].hogsNumber > 0) do

   551         begin

   552             inc(i);

   553             inc(hedgehogsNumber, teams[i].hogsNumber)

   554         end;

   555 

   556         // no free space for a team - server bug???

   557         if (i > 7) or (hedgehogsNumber >= 48) then exit;

   558 

   559         c:= getUnusedColor;

   560 

   561         teams[i]:= team^;

   562         teams[i].extDriven:= false;

   563 

   564         if i = 0 then hn:= 4 else hn:= teams[i - 1].hogsNumber;

   565         if hn > 48 - hedgehogsNumber then hn:= 48 - hedgehogsNumber;

   566         teams[i].hogsNumber:= hn;

   567 

   568         teams[i].color:= c;

   569 

   570         msg:= '0' + #10 + teamName;

   571         sendUI(mtAddPlayingTeam, @msg[1], length(msg));

   572 

   573         msg:= teamName + #10 + colorsSet[teams[i].color];

   574         sendUI(mtTeamColor, @msg[1], length(msg));

   575 

   576         msg:= teamName;

   577         sendUI(mtRemoveTeam, @msg[1], length(msg))        

   578     end

   579 end;

   580 

   581 procedure netRemoveTeam(teamName: shortstring);

   582 var msg: shortstring;

   583     i: Longword;

   584     tn: shortstring;

   585     isLocal: boolean;

   586 begin

   587     with currentConfig do

   588     begin

   589         i:= 0;

   590         tn:= teamName;

   591         while (i < 8) and (teams[i].teamName <> tn) do

   592             inc(i);

   593 

   594         // team not found???

   595         if (i > 7) then exit;

   596 

   597         isLocal:= not teams[i].extDriven;

   598 

   599         while (i < 7) and (teams[i + 1].hogsNumber > 0) do

   600         begin

   601             teams[i]:= teams[i + 1];

   602             inc(i)

   603         end;

   604 

   605         teams[i].hogsNumber:= 0

   606     end;

   607 

   608     msg:= teamName;

   609 

   610     sendUI(mtRemovePlayingTeam, @msg[1], length(msg));

   611     if isLocal then

   612         sendUI(mtAddTeam, @msg[1], length(msg))

   613 end;

   614 

   615 procedure netSetTeamColor(team: shortstring; color: Longword);

   616 var i: Longword;

   617     msg: ansistring;

   618 begin

   619     with currentConfig do

   620     begin

   621         i:= 0;

   622 

   623         while (i < 8) and (teams[i].teamName <> team) do

   624             inc(i);

   625         // team not found???

   626         if (i > 7) then exit;

   627 

   628         teams[i].color:= color mod 9;

   629 

   630         msg:= team + #10 + colorsSet[teams[i].color];

   631         sendUI(mtTeamColor, @msg[1], length(msg))

   632     end

   633 end;

   634 

   635 procedure netSetHedgehogsNumber(team: shortstring; hogsNumber: Longword);

   636 var i: Longword;

   637     msg: ansistring;

   638 begin

   639     if hogsNumber > 8 then exit;

   640 

   641     with currentConfig do

   642     begin

   643         i:= 0;

   644 

   645         while (i < 8) and (teams[i].teamName <> team) do

   646             inc(i);

   647         // team not found???

   648         if (i > 7) then exit;

   649 

   650         teams[i].hogsNumber:= hogsNumber;

   651 

   652         msg:= team + #10 + IntToStr(hogsNumber);

   653         sendUI(mtHedgehogsNumber, @msg[1], length(msg))

   654     end

   655 end;

   656 

   657 procedure netResetTeams();

   658 var msg: shortstring;

   659     i: Longword;

   660 begin

   661     with currentConfig do

   662     begin

   663         i:= 0;

   664 

   665         while (i < 8) and (teams[i].hogsNumber > 0) do

   666         begin

   667             msg:= teams[i].teamName;

   668 

   669             sendUI(mtRemovePlayingTeam, @msg[1], length(msg));

   670             if not teams[i].extDriven then 

   671                 sendUI(mtAddTeam, @msg[1], length(msg));

   672 

   673             teams[i].hogsNumber:= 0;

   674             inc(i)

   675         end;

   676 

   677     end;

   678 end;

   679 

   680 procedure netDrawnData(data: ansistring);

   681 begin

   682     currentConfig.drawnDataSize:= length(data);

   683     currentConfig.drawnData:= data;

   684 

   685     getPreview

   686 end;

   687 

   688 end.