hedgewars/uFLGameConfig.pas
author unc0rr
Sat, 25 Oct 2014 00:31:10 +0400
branchqmlfrontend
changeset 10444 47a6231f1fc1
parent 10432 b0abef0ee78c
child 10446 7ae44f42a689
permissions -rw-r--r--
Teams widget now allows to add and remove teams (basic implementation, no checks performed, no colors, no hedgehogs)

unit uFLGameConfig;
interface
uses uFLTypes;

procedure resetGameConfig; cdecl;
procedure runQuickGame; cdecl;
procedure getPreview; cdecl;

procedure registerGUIMessagesCallback(p: pointer; f: TGUICallback); cdecl;

procedure setSeed(seed: PChar); cdecl;
function  getSeed: PChar; cdecl;

procedure tryAddTeam(teamName: PChar);
procedure tryRemoveTeam(teamName: PChar);

implementation
uses uFLIPC, hwengine, uFLUtils, uFLTeams;

var guiCallbackPointer: pointer;
    guiCallbackFunction: TGUICallback;

const
    MAXCONFIGS = 5;
    MAXARGS = 32;

type
    TGameConfig = record
            seed: shortstring;
            theme: shortstring;
            script: shortstring;
            mapgen: Longint;
            gameType: TGameType;
            teams: array[0..7] of TTeam;
            arguments: array[0..Pred(MAXARGS)] of shortstring;
            argv: array[0..Pred(MAXARGS)] of PChar;
            argumentsNumber: Longword;
            end;
    PGameConfig = ^TGameConfig;

var
    currentConfig: TGameConfig;


procedure sendConfig(config: PGameConfig);
var i: Longword;
begin
with config^ do
begin
    case gameType of
    gtPreview: begin
            ipcToEngine('eseed ' + seed);
            ipcToEngine('e$mapgen ' + intToStr(mapgen));
        end;
    gtLocal: begin
            ipcToEngine('eseed ' + seed);
            ipcToEngine('e$mapgen ' + intToStr(mapgen));
            i:= 0;
            while (i < 8) and (teams[i].hogsNumber > 0) do
                begin
                    ipcToEngine('eammloadt 93919294221991210322351110012000000002111001010111110001');
                    ipcToEngine('eammprob 04050405416006555465544647765766666661555101011154111111');
                    ipcToEngine('eammdelay 00000000000002055000000400070040000000002200000006000200');
                    ipcToEngine('eammreinf 13111103121111111231141111111111111112111111011111111111');
                    ipcToEngine('eammstore');
                    sendTeamConfig(teams[i]);
                    inc(i)
                end;
        end;
    end;

    ipcToEngine('!');
end;
end;

procedure queueExecution;
var pConfig: PGameConfig;
    i: Longword;
begin
    new(pConfig);
    pConfig^:= currentConfig;

    with pConfig^ do
        for i:= 0 to Pred(MAXARGS) do
        begin
            if arguments[i][0] = #255 then 
                arguments[i][255]:= #0
            else
                arguments[i][byte(arguments[i][0]) + 1]:= #0;
            argv[i]:= @arguments[i][1]
        end;

    RunEngine(pConfig^.argumentsNumber, @pConfig^.argv);

    sendConfig(pConfig)
end;

procedure resetGameConfig; cdecl;
begin
end;

procedure setSeed(seed: PChar); cdecl;
begin
    currentConfig.seed:= seed
end;

function getSeed: PChar; cdecl;
begin
    getSeed:= str2PChar(currentConfig.seed)
end;

procedure runQuickGame; cdecl;
begin
    with currentConfig do
    begin
        gameType:= gtLocal;
        arguments[0]:= '';
        arguments[1]:= '--internal';
        arguments[2]:= '--nosound';
        argumentsNumber:= 3;

        teams[0]:= createRandomTeam;
        teams[0].color:= '6341088';
        teams[1]:= createRandomTeam;
        teams[1].color:= '2113696';
        teams[1].botLevel:= 1;

        queueExecution;
    end;
end;

procedure getPreview; cdecl;
begin
    with currentConfig do
    begin
        gameType:= gtPreview;
        arguments[0]:= '';
        arguments[1]:= '--internal';
        arguments[2]:= '--landpreview';
        argumentsNumber:= 3;

        queueExecution;
    end;
end;

procedure engineMessageCallback(p: pointer; msg: PChar; len: Longword);
begin
    if len = 128 * 256 then guiCallbackFunction(guiCallbackPointer, mtPreview, msg, len)
end;

procedure registerGUIMessagesCallback(p: pointer; f: TGUICallback); cdecl;
begin
    guiCallbackPointer:= p;
    guiCallbackFunction:= f;

    registerIPCCallback(nil, @engineMessageCallback)
end;


procedure tryAddTeam(teamName: PChar);
var msg: ansistring;
begin
    msg:= '0' + #10 + teamName;

    guiCallbackFunction(guiCallbackPointer, mtAddPlayingTeam, @msg[1], length(msg));

    msg:= teamName;

    guiCallbackFunction(guiCallbackPointer, mtRemoveTeam, @msg[1], length(msg))
end;

procedure tryRemoveTeam(teamName: PChar);
var msg: ansistring;
begin
    msg:= teamName;

    guiCallbackFunction(guiCallbackPointer, mtRemovePlayingTeam, @msg[1], length(msg));
    guiCallbackFunction(guiCallbackPointer, mtAddTeam, @msg[1], length(msg))
end;

end.