meta.pas

一款RPG游戏的引擎可以自己制作一款RPG游戏的引擎可以自己制作

unit Meta;
{****************************************************************************
     The contents of this file are subject to the Mozilla Public License
     Version 1.1 (the "License"); you may not use this file except in
     compliance with the License. You may obtain a copy of the License at
     http://www.mozilla.org/MPL/

     Software distributed under the License is distributed on an "AS IS"
     basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
     License for the specific language governing rights and limitations
     under the License.

     The Original Code is IsoEditMdi.

     The Initial Developer of the Original Code is Crystal Software (Canada) Inc.
     and Chris Bruner. Portions created by Chris Bruner are Copyright
     (C) Crystal Software (Canada) Inc.  All Rights Reserved.

     Contributor(s): Chris Bruner of Crystal Software (Canada) Inc.
     (sign your name here)
******************************************************************************}

interface
  uses sysutils;

type

  TMetaImages = record
    ne,nw,se,sw,below : array of integer;
    Height : Integer;
    ExtraInfo : string;
  end;
  TMetaLevel = record
    Images : array of TMetaImages
  end;
  TMeta = class(tobject)
    Level : array of TMetaLevel;
    function GetInt(var s : string) : integer;
    procedure ReSize(L,I : integer);
    procedure AddNWNeighbor(L,I,Neighbor:integer);
    procedure AddNENeighbor(L,I,Neighbor:integer);
    procedure AddSWNeighbor(L,I,Neighbor:integer);
    procedure AddSENeighbor(L,I,Neighbor:integer);
    procedure AddBelowNeighbor(L,I,Neighbor : Integer);
    function IsCompatible(L,I,nw,ne,sw,se : Integer) : Boolean;
    function IsAnyCompatible(L,I,Neighbor : Integer) : Boolean;
    function IsCompatibleBelow(L,I,Neighbor : Integer) : Boolean;
    function IsCompatibleNW(L,I1,I2 : Integer) : Boolean;
    function IsCompatibleSW(L,I1,I2 : Integer) : Boolean;
    function IsCompatibleNE(L,I1,I2 : Integer) : Boolean;
    function IsCompatibleSE(L,I1,I2 : Integer) : Boolean;
    function GetCompatible(L,nw,ne,sw,se : Integer) : integer;
    function GetCompatibleAbove(L,Below : Integer) : Integer;
    function GetCompatibleNW(L,nw : integer) : integer;
    function GetCompatibleNE(L,ne : integer) : integer;
    function GetCompatibleSW(L,sw : integer) : integer;
    function GetCompatibleSE(L,se : integer) : integer;
    function GetImagestr(i : integer) : string;
    procedure SetImageStr(i : integer; s : string);
    function GetHeight(L,I : Integer) : Integer;
    function GetRandomImage(layer : integer) : Integer;
    procedure GetRandomNeighbors(Layer,Image : integer; var nw,ne,sw,se : integer);
    procedure CalculateHeights;
    procedure Reset;

  end;

implementation


{ TMeta }

procedure TMeta.AddNENeighbor(L, I, Neighbor: integer);
var j : Integer;
begin
  Resize(L,i);
  with(Level[L].Images[i]) do
  begin
    for j := 0 to Length(ne)-1 do
      if (ne[j] = Neighbor) then Exit;   // aready here
    j := Length(ne);
    SetLength(ne,j+1);
    ne[j] := Neighbor;
  end;
end;

procedure TMeta.AddNWNeighbor(L, I, Neighbor: integer);
var j : integer;
begin
  Resize(L,i);
  with(Level[L].Images[i]) do
  begin
    for j := 0 to Length(nw)-1 do
      if (nw[j] = Neighbor) then Exit;   // aready here
    j := Length(nw);
    SetLength(nw,j+1);
    nw[j] := Neighbor;
  end;
end;

procedure TMeta.AddSENeighbor(L, I, Neighbor: integer);
var j : integer;
begin
  Resize(L,i);
  with(Level[L].Images[i]) do
  begin
    for j := 0 to Length(se)-1 do
      if (se[j] = Neighbor) then Exit;   // aready here
    j := Length(se);
    SetLength(se,j+1);
    se[j] := Neighbor;
  end;
end;

procedure TMeta.AddSWNeighbor(L, I, Neighbor: integer);
var j : integer;
begin
  Resize(L,i);
  with(Level[L].Images[i]) do
  begin
    for j := 0 to Length(sw)-1 do
      if (sw[j] = Neighbor) then Exit;   // aready here
    j := Length(sw);
    SetLength(sw,j+1);
    sw[j] := Neighbor;
  end;
end;

function TMeta.GetInt(var s : string) : integer;
var  t : string;
begin
  Result := 0;
  s := trimleft(s);
  if (Length(s)=0) then exit;
  if (s[1] = '-') then
  begin
    t := '-';
    Delete(s,1,1);
  end
  else
    t := '0';
  while(s[1] in ['0'..'9']) and (length(s)>1) do
  begin
    t := t + s[1];
    delete(s,1,1);
  end;
  result := strtoint(t);
end;


procedure TMeta.SetImagestr( i: integer; s : string);
var CR,LF,TAB : string;
  l,layer : Integer;
function FindDel(find : string; var Value : string) : boolean;
var p : integer;
begin
  p := Pos(find,Value);
  Result := p >0;
  if Result then
    Delete(Value,p,Length(find));
end;

function DelTo(find : string; var Value : string) : boolean;
var p : integer;
begin
  p := Pos(find,Value);
  Result := p>0;
  if (Result) then
    Delete(Value,1,p + Length(find)-1);
end;


begin
  cr := #13; LF := #10;
  tab := #9;
  s:= stringreplace(s,cr,'',[rfReplaceAll]);
  s:=stringreplace(s,LF,'',[rfReplaceAll]);
  s:=stringreplace(s,tab,' ',[rfReplaceAll]);
  if not DelTo('<Meta>',s) then Exit;
  if not FindDel('Image ',s) then Exit;
  l := GetInt(s);
  if (l<>i) then Exit;
  while(s<>'</Meta>') and (length(s)>1) do
  begin
    if not DelTo('Layer ',s) then Exit;
    Layer := GetInt(s);
    s := TrimLeft(s);
    if (s[1]='n') and (s[2]='w') and (s[3]=' ') and (s[4]='=') then
    begin
      Delete(s,1,4);
      repeat
        s := TrimLeft(s);
        if (s[1] in ['0'..'9','-']) then
          AddNWNeighbor(Layer, I, GetInt(s))
        else delete(s,1,1); // is this garbage?!?
      until (s[1]<>' ') or not(s[2] in ['0'..'9','-']);
    end;
    s := TrimLeft(s);
    if (s[1]='n') and (s[2]='e') and (s[3]=' ') and (s[4]='=') then
    begin
      Delete(s,1,4);
      repeat
      s := TrimLeft(s);
      if s[1] in ['0'..'9','-'] then
        AddNENeighbor(Layer, I, GetInt(s))
      else delete(s,1,1);
      until (s[1]<>' ') or not(s[2] in ['0'..'9','-']);
    end;
    s := TrimLeft(s);
    if (s[1]='s') and (s[2]='w') and (s[3]=' ') and (s[4]='=') then
    begin
      Delete(s,1,4);
      repeat
        s := TrimLeft(s);
        if s[1] in ['0'..'9','-'] then
          AddSWNeighbor(Layer, I, GetInt(s))
        else delete(s,1,1);
      until (s[1]<>' ') or not(s[2] in ['0'..'9','-']);
    end;

    s := TrimLeft(s);
    if (s[1]='s') and (s[2]='e') and (s[3]=' ') and (s[4]='=') then
    begin
      Delete(s,1,4);
      repeat
        s := TrimLeft(s);
        if s[1] in ['0'..'9','-'] then
          AddSENeighbor(Layer, I, GetInt(s))
        else delete(s,1,1);
      until (s[1]<>' ') or not(s[2] in ['0'..'9','-']);
    end;
  end;
end;

function TMeta.GetImagestr( i: integer): string;
var s,CR,TAB : string;
  l,j : Integer;
begin
  cr := #13;
  tab := #9;

  s := CR + '<Meta>' + cr + 'Image ' + inttostr(i)+' ';
  for l := 0 to Length(level)-1 do
  begin
    s := s + 'Layer ' + IntToStr(l)+' ';
    if (Length(Level[l].Images)<=i) then
    begin
      s := s + '</Meta>';
      continue;
    end;
    s := s + cr + tab + 'nw = ';
    for j:=0 to Length(level[l].Images[i].Nw) -1 do
      s := s + inttostr(level[l].images[i].nw[j]) + ' ';
    s := s + cr + tab + 'ne = ';
    for j:=0 to Length(level[l].Images[i].Ne) -1 do
      s := s + inttostr(level[l].images[i].ne[j]) + ' ';
    s := s + cr + tab + 'sw = ';
    for j:=0 to Length(level[l].Images[i].sw) -1 do
      s := s + inttostr(level[l].images[i].sw[j]) + ' ';
    s := s + cr + tab + 'se = ';
    for j:=0 to Length(level[l].Images[i].se) -1 do
      s := s + inttostr(level[l].images[i].se[j]) + ' ';
    s := s + CR + TAB + 'below = ';
    for j:=0 to Length(level[l].Images[i].below)-1 do
      s := s + IntToStr(level[l].Images[i].below[j]) + ' ';
    s := s + CR + Tab + 'height = ' + IntToStr(level[l].Images[i].Height);
  end;
  result := AdjustLineBreaks(s + '</Meta>');