unit LevelFunctions;
interface
uses
SysUtils, Dialogs, Functions, ExtCtrls, Classes, Math;
type
TCoord = record
X: integer;
Y: integer;
end;
TFieldType = (ftUndefined, ftFullSpace, ftEmpty, ftRed, ftYellow, ftGreen);
TFieldProperties = record
Typ: TFieldType;
Goal: Boolean;
end;
TGameMode = (gmUndefined, gmNormal, gmDiagonal);
TRow = record
Indent: integer;
Fields: array of TFieldProperties;
end;
TLevelArray = array of TRow;
TLevelError = (leUndefined, leNone, leInvalidElement, leEmptyBoard, leRowInvalidLength,
leUnsupportedVersion, leUnsupportedMode);
TLevel = class(TObject)
private
FStringList: TStringList;
procedure Load(ABoardFile: string);
function GetGameMode: TGameMode;
public
constructor Create(ABoardFile: string);
destructor Destroy; override;
function LevelStringToLevelArray(ShowErrors: boolean): TLevelArray;
function CheckLevelIntegrity: TLevelError; overload;
function CheckLevelIntegrity(ShowErrors: boolean): TLevelError; overload;
property GameMode: TGameMode read GetGameMode;
end;
TField = record
FieldType: TFieldType;
Goal: Boolean;
Panel: TPanel;
Stone: TImage;
end;
TGoalStatus = (gsUndefined, gsNoGoal, gsMultipleStonesRemaining, gsLastStoneInGoalRed, gsLastStoneInGoalYellow, gsLastStoneInGoalGreen, gsLastStoneOutsideGoal);
TFieldState = (fsUndefined, fsError, fsLocked, fsAvailable, fsStone);
TPlayGroundMatrix = record
Fields: array of array of TField;
public
procedure InitFieldArray(width, height: integer);
function MatrixHasGoal: boolean;
function GoalFieldType: TFieldType;
function MatrixWorth: integer;
procedure ClearMatrix(FreeVCL: boolean);
function CloneMatrix: TPlayGroundMatrix;
class function FieldState(t: TFieldType): TFieldState; overload; static;
function FieldState(f: TField): TFieldState; overload;
function FieldState(x, y: integer): TFieldState; overload;
function CanJump(SourceX, SourceY, DestX, DestY: integer; DiagonalOK: boolean): boolean; overload;
function CanJump(SourceX, SourceY: integer; DiagonalOK: boolean): boolean; overload;
function CanJump(DiagonalOK: boolean): boolean; overload;
function IndexToCoord(index: integer): TCoord;
function CoordToIndex(coord: TCoord): integer; overload;
function CoordToIndex(x, y: integer): integer; overload;
function Width: integer;
function Height: integer;
end;
function FieldTypeWorth(t: TFieldType): integer;
implementation
function FieldTypeWorth(t: TFieldType): integer;
begin
if t = ftGreen then result := 10
else if t = ftYellow then result := 20
else if t = ftRed then result := 30
else result := 0;
end;
{ TPlayGroundMatrix }
function TPlayGroundMatrix.MatrixHasGoal: boolean;
var
x, y: integer;
begin
result := false;
for x := Low(Fields) to High(Fields) do
begin
for y := Low(Fields[x]) to High(Fields[x]) do
begin
result := result or Fields[x,y].Goal;
end;
end;
end;
function TPlayGroundMatrix.GoalFieldType: TFieldType;
var
x, y: integer;
begin
result := ftEmpty; // Damit der Compiler nicht meckert
for x := Low(Fields) to High(Fields) do
begin
for y := Low(Fields[x]) to High(Fields[x]) do
begin
if Fields[x,y].Goal then result := Fields[x,y].FieldType
end;
end;
end;
function TPlayGroundMatrix.Height: integer;
begin
if Length(Fields) = 0 then
result := 0
else
result := Length(Fields[0]);
end;
function TPlayGroundMatrix.IndexToCoord(index: integer): TCoord;
begin
result.X := index mod Width;
result.Y := index div Width;
end;
procedure TPlayGroundMatrix.InitFieldArray(width, height: integer);
var
x, y: integer;
begin
SetLength(Fields, width, height);
for x := Low(Fields) to High(Fields) do
begin
for y := Low(Fields[x]) to High(Fields[x]) do
begin
Fields[x,y].FieldType := ftUndefined;
end;
end;
end;
function TPlayGroundMatrix.MatrixWorth: integer;
var
x, y: integer;
begin
result := 0;
for x := Low(Fields) to High(Fields) do
begin
for y := Low(Fields[x]) to High(Fields[x]) do
begin
Inc(result, FieldTypeWorth(Fields[x,y].FieldType));
end;
end;
end;
function TPlayGroundMatrix.Width: integer;
begin
result := Length(Fields);
end;
procedure TPlayGroundMatrix.ClearMatrix(FreeVCL: boolean);
var
x, y: integer;
begin
for x := Low(Fields) to High(Fields) do
begin
for y := Low(Fields[x]) to High(Fields[x]) do
begin
if FreeVCL then
begin
if Assigned(Fields[x,y].Stone) then Fields[x,y].Stone.Free;
if Assigned(Fields[x,y].Panel) then Fields[x,y].Panel.Free;
end;
end;
end;
SetLength(Fields, 0, 0);
end;
function TPlayGroundMatrix.CloneMatrix: TPlayGroundMatrix;
var
x, y: integer;
begin
SetLength(result.Fields, Length(Fields));
for x := Low(Fields) to High(Fields) do
begin
SetLength(result.Fields[x], Length(Fields[x]));
for y := Low(Fields[x]) to High(Fields[x]) do
begin
result.Fields[x,y].FieldType := Fields[x,y].FieldType;
result.Fields[x,y].Goal := Fields[x,y].Goal;
result.Fields[x,y].Panel := Fields[x,y].Panel;
result.Fields[x,y].Stone := Fields[x,y].Stone;
end;
end;
end;
function TPlayGroundMatrix.CoordToIndex(x, y: integer): integer;
var
c: TCoord;
begin
c.X := x;
c.Y := y;
result := CoordToIndex(c);
end;
function TPlayGroundMatrix.CoordToIndex(coord: TCoord): integer;
begin
result := coord.X + coord.Y * Width;
end;
class function TPlayGroundMatrix.FieldState(t: TFieldType): TFieldState;
begin
result := fsError;
case t of
ftFullSpace: result := fsLocked;
ftEmpty: result := fsAvailable;
ftGreen: result := fsStone;
ftYellow: result := fsStone;
ftRed: result := fsStone;
end;
end;
function TPlayGroundMatrix.FieldState(f: TField): TFieldState;
begin
result := FieldState(f.FieldType);
end;
function TPlayGroundMatrix.FieldState(x, y: integer): TFieldState;
begin
result := fsError;
if (x < Low(Fields)) or (x > High(Fields)) then exit;
if (y < Low(Fields[x])) or (y > High(Fields[x])) then exit;
result := FieldState(Fields[x,y]);
end;
function TPlayGroundMatrix.CanJump(SourceX, SourceY, DestX, DestY: integer; DiagonalOK: boolean): boolean;
begin
result := false;
// Check 1: Ist das Zielfeld überhaupt leer?
if FieldState(DestX, DestY) <> fsAvailable then exit;
// Check 2: Befindet sich ein Stein zwischen Source und Destination und ist der Abstand 2?
if DiagonalOK then
begin
if (SourceX-2 = DestX) and (SourceY-2 = DestY) and (FieldState(SourceX-1, SourceY-1) = fsStone) then result := true;
if (SourceX-2 = DestX) and (SourceY+2 = DestY) and (FieldState(SourceX-1, SourceY+1) = fsStone) then result := true;
if (SourceX+2 = DestX) and (SourceY-2 = DestY) and (FieldState(SourceX+1, SourceY-1) = fsStone) then result := true;
if (SourceX+2 = DestX) and (SourceY+2 = DestY) and (FieldState(SourceX+1, SourceY+1) = fsStone) then result := true;
end;
if (SourceX+2 = DestX) and (SourceY = DestY) and (FieldState(SourceX+1, SourceY ) = fsStone) then result := true;
if (SourceX-2 = DestX) and (SourceY = DestY) and (FieldState(SourceX-1, SourceY ) = fsStone) then result := true;
if (SourceX = DestX) and (SourceY+2 = DestY) and (FieldState(SourceX , SourceY+1) = fsStone) then result := true;
if (SourceX = DestX) and (SourceY-2 = DestY) and (FieldState(SourceX , SourceY-1) = fsStone) then result := true;
end;
function TPlayGroundMatrix.CanJump(SourceX, SourceY: integer; DiagonalOK: boolean): boolean;
begin
if FieldState(SourceX, SourceY) <> fsStone then
begin
result := false;
exit;
end;
result := true;
if CanJump(SourceX, SourceY, SourceX+2, SourceY, DiagonalOK) then exit;
if CanJump(SourceX, SourceY, SourceX-2, SourceY, DiagonalOK) then exit;
if CanJump(SourceX, SourceY, SourceX, SourceY+2, DiagonalOK) then exit;
if CanJump(SourceX, SourceY, SourceX, SourceY-2, DiagonalOK) then exit;
if DiagonalOK then
begin
if CanJump(SourceX, SourceY, SourceX-2, SourceY-2, DiagonalOK) then exit;
if CanJump(SourceX, SourceY, SourceX+2, SourceY-2, DiagonalOK) then exit;
if CanJump(SourceX, SourceY, SourceX-2, SourceY+2, DiagonalOK) then exit;
if CanJump(SourceX, SourceY, SourceX+2, SourceY+2, DiagonalOK) then exit;
end;
result := false;
end;
function TPlayGroundMatrix.CanJump(DiagonalOK: boolean): boolean;
var
x, y: integer;
begin
result := false;
for x := Low(Fields) to High(Fields) do
begin
for y := Low(Fields[x]) to High(Fields[x]) do
begin
if CanJump(x, y, DiagonalOK) then
begin
result := true;
break;
end;
if result then break;
end;
end;
end;
{ TLevel }
const NUM_HEADERS = 2;
constructor TLevel.Create(ABoardFile: string);
begin
inherited Create;
FStringList := TStringList.Create;
Load(ABoardFile);
end;
destructor TLevel.Destroy;
begin
FreeAndNil(FStringList);
inherited;
end;
function TLevel.GetGameMode: TGameMode;
begin
if LowerCase(FStringList.Strings[1]) = 'mode: normal' then
result := gmNormal
else if LowerCase(FStringList.Strings[1]) = 'mode: diagonal' then
result := gmDiagonal
else
result := gmUndefined;
end;
procedure TLevel.Load(ABoardFile: string);
var
i: Integer;
begin
FStringList.Clear;
FStringList.LoadFromFile(ABoardFile);
// Remove whitespaces and empty lines
for i := FStringList.Count-1 downto NUM_HEADERS do
begin
FStringList.Strings[i] := StringReplace(FStringList.Strings[i], ' ', '', [rfReplaceAll]);
if FStringList.Strings[i] = '' then FStringList.Delete(i);
end;
end;
function TLevel.LevelStringToLevelArray(ShowErrors: boolean): TLevelArray;
var
i: integer;
t: TFieldType;
err: TLevelError;
y: Integer;
x: Integer;
Line: string;
lch, uch: char;
ch: char;
begin
// Zuerst nach Fehlern suchen
err := CheckLevelIntegrity(ShowErrors);
if err <> leNone then exit;
// Nun Matrix aufbauen
SetLength(result, 0);
for i := NUM_HEADERS to FStringList.Count-1 do
begin
y := i - NUM_HEADERS;
SetLength(result, Length(result)+1); // add line to matrix
Line := FStringList.Strings[i];
result[y].Indent := DotsAtBeginning(Line) - DotsAtEnd(Line);
Line := StringReplace(Line, '.', '', [rfReplaceAll]);
SetLength(result[y].Fields, Length(Line));
for x := 0 to Length(Line)-1 do
begin
ch := Line[x+1];
lch := LowerCase(ch)[1];
uch := UpperCase(ch)[1];
t := ftUndefined;
case lch of
'*': t := ftFullSpace;
'e': t := ftEmpty;
'r': t := ftRed;
'y': t := ftYellow;
'g': t := ftGreen;
end;
result[y].Fields[x].Typ := t;
result[y].Fields[x].Goal := (ch = uch) and (ch <> lch);
end;
end;
end;
function TLevel.CheckLevelIntegrity(ShowErrors: boolean): TLevelError;
resourcestring
LNG_LVL_INVALID_ELEMENT = 'Level invalid: There are invalid elements in the file.'+#13#10#13#10+'Valid elements are r/R, y/Y, g/G, e/E, . and *.';
LNG_LVL_UNSUPPORTED_VERSION = 'Level format invalid: Version not supported.';
LNG_LVL_UNSUPPORTED_MODE = 'Level format invalid: Mode not supported.';
LNG_LVL_EMPTY_BOARD = 'Level invalid: Board is empty.';
LNG_LVL_INVALID_LENGTH = 'Level invalid: Lines don''t have an equal amount of elements.';
begin
result := CheckLevelIntegrity;
if ShowErrors then
begin
case result of
leNone: ;
leInvalidElement: MessageDlg(LNG_LVL_INVALID_ELEMENT, mtError, [mbOk], 0);
leUnsupportedVersion: MessageDlg(LNG_LVL_UNSUPPORTED_VERSION, mtError, [mbOk], 0);
leUnsupportedMode: MessageDlg(LNG_LVL_UNSUPPORTED_MODE, mtError, [mbOk], 0);
leEmptyBoard: MessageDlg(LNG_LVL_EMPTY_BOARD, mtError, [mbOk], 0);
leRowInvalidLength: MessageDlg(LNG_LVL_INVALID_LENGTH, mtError, [mbOk], 0);
end;
end;
end;
function TLevel.CheckLevelIntegrity: TLevelError;
var
tmp: string;
i: Integer;
Line: string;
firstLine: string;
thisLine: string;
begin
result := leNone;
// Check 1: Ist der Header OK?
if LowerCase(FStringList.Strings[0]) <> 'version 2' then
begin
result := leUnsupportedVersion;
exit;
end;
if ((LowerCase(FStringList.Strings[1]) <> 'mode: normal') and (LowerCase(FStringList.Strings[1]) <> 'mode: diagonal')) then
begin
result := leUnsupportedMode;
exit;
end;
// Check 2: Ist das Brett leer?
tmp := '';
for i := NUM_HEADERS to FStringList.Count-1 do tmp := tmp + FStringList.Strings[i];
if Trim(StringReplace(tmp, '.', '', [rfReplaceAll])) = '' then
begin
result := leEmptyBoard;
exit;
end;
// Check 3: Geht das Level nicht in einem Quadrat oder Rechteck auf?
firstLine := StringReplace(FStringList.Strings[NUM_HEADERS], '.', '', [rfReplaceAll]);
for i := NUM_HEADERS to FStringList.Count-1 do
begin
thisLine := StringReplace(FStringList.Strings[i], '.', '', [rfReplaceAll]);
if Length(thisLine) <> Length(firstLine) then
begin
result := leRowInvalidLength; // at row y-NUM_HEADERS
exit;
end;
end;
// Check 4: Gibt es ungültige Elemente in den Zeilen?
for i := NUM_HEADERS to FStringList.Count-1 do
begin
Line := FStringList.Strings[i];
Line := StringReplace(Line, '.', '', [rfReplaceAll]);
Line := StringReplace(Line, '*', '', [rfReplaceAll]);
Line := StringReplace(Line, 'r', '', [rfReplaceAll, rfIgnoreCase]);
Line := StringReplace(Line, 'y', '', [rfReplaceAll, rfIgnoreCase]);
Line := StringReplace(Line, 'g', '', [rfReplaceAll, rfIgnoreCase]);
Line := StringReplace(Line, 'e', '', [rfReplaceAll, rfIgnoreCase]);
if Length(Line) > 0 then
begin
result := leInvalidElement; // at row y-NUM_HEADERS
Exit;
end;
end;
// Check 5: Kann im Level gesprungen werden?
{ Wird hier nicht abgeprüft, da dafür zuerst der PlayGround gebaut sein muss.
Es ist außerdem eher ein logischer Fehler, kein Fehler in der Levelstruktur! }
end;
end.