Файл типа TList. Статьи по Delphi (017)…

Статьи по Delphi (017)…

Файл типа TList.

Ок, но это не так просто, как кажется. Тем не менее, с помощью некоторых людей из конференции, мне удалось сделать это и придать коду законченный вид. Ниже приведен исходный код для Toverheadmap...
Обратите внимание на методы объекта ReadData и WriteData, используемые для его записи на диск, и методы SaveToFile и LoadFromFile самого TList. Правильным было бы сделать их более совместимыми (общими), но на это пока у меня не хватило времени. (Т.е., TList должен был бы восстанавливать/сохранять любой объект с помощью метода readdata/writedata.).
unit Charactr;
interface
uses
  Graphics, StdCtrls, Classes, Sysutils, Winprocs, Ohmap, ohmstuff;
type
  TMapCharacterList = class(TList)
  private
    FMap: TOverHeadMap;
  public
    procedure RenderVisibleCharacters; virtual;
    procedure Savetofile(const filename: string);
    procedure Loadfromfile(const filename: string);
    procedure Clear;
    destructor Destroy; override;
    property MapDisp: TOverHeadMap read FMap write FMap;
  end;
  TFrameStore = class(TList)
    procedure WriteData(Writer: Twriter); virtual;
    procedure ReadData(Reader: TReader); virtual;
    procedure Clear;
  end;
  TMapCharacter = class(TPersistent)
  private
    FName: string;
    FMap: TOverHeadMap;
    FFrame: Integer;
    FFramebm, FFrameMask, FWorkBuf: TBitmap;
    FFrameStore, FMaskStore: TFrameStore;
    FXpos, FYpos, FZpos: Integer;
    FTransColor: TColor;
    FVisible, FFastMode, FIsClone, FRedrawBackground: Boolean;
    procedure SetFrame(num: Integer);
    function GetOnScreen: Boolean;
    procedure SetVisible(vis: Boolean);
    procedure MakeFrameMask(trColor: TColor);
    procedure MakeFrameMasks; {Для переключения в быстрый режим...}
    procedure ReplaceTransColor(trColor: TColor);
    procedure SetXPos(x: Integer);
    procedure SetYPos(y: Integer);
    procedure SetZPos(z: Integer);
    procedure SetFastMode(fast: Boolean);
  public
    constructor Create(ParentMap: TOverheadmap); virtual;
    destructor Destroy; override;
    property Name: string read FName write FName;
    property Fastmode: Boolean read FFastMode write SetFastMode;
    property FrameStore: TFrameStore read FFrameStore write FFramestore;
    property MaskStore: TFrameStore read FMaskStore write FMaskStore;
    property Frame: integer read FFrame write SetFrame;
    property Framebm: TBitmap read FFramebm;
    property FrameMask: TBitmap read FFrameMask;
    property TransColor: TColor read FTransColor write FTransColor;
    property Xpos: Integer read FXpos write SetXpos;
    property YPos: Integer read FYpos write SetYpos;
    property ZPos: Integer read FZpos write SetZpos;
    property Map: TOverHeadMap read FMap write FMap;
    property OnScreen: Boolean read GetOnScreen;
    property Visible: Boolean read FVisible write SetVisible;
    property IsClone: Boolean read FIsClone write FIsClone;
    property RedrawBackground: Boolean read FRedrawBackground write
      FRedrawBackground;
    procedure Render; virtual;
    procedure RenderCharacter(mapcoords: Boolean; cxpos, cypos: Integer; mask,
      bm,
      wb: TBitmap); virtual;
    procedure Clone(Source: TMapCharacter); virtual;
    procedure SetCharacterCoords(x, y, z: Integer); virtual;
    procedure WriteData(Writer: Twriter); virtual;
    procedure ReadData(Reader: TReader); virtual;
  end;
implementation
constructor TMapCharacter.Create(ParentMap: TOverheadmap);
begin
  inherited Create;
  FIsClone := False;
  FFramebm := TBitMap.create;
  FFrameMask := TBitmap.Create;
  FWorkbuf := TBitMap.Create;
  if not (FIsClone) then
    FFrameStore := TFrameStore.Create;
  FTransColor := clBlack;
  FFastMode := False;
  FMap := ParentMap;
end;
destructor TMapCharacter.Destroy;
var
  a, b: Integer;
begin
  FFramemask.free;
  FFramebm.free;
  FWorkBuf.Free;
  if not (FIsClone) then
  begin
    FFrameStore.Clear;
    FFrameStore.free;
  end;
  if (MaskStore <> nil) and not (FIsClone) then
  begin
    MaskStore.Clear;
    MaskStore.Free;
  end;
  inherited Destroy;
end;
{
Данная процедура копирует важную информацию из символа в себя
...
Стартуем невидимое клонирование, с нулевыми координатами карты.
}
procedure TMapCharacter.Clone(Source: TMapCharacter);
begin
  FName := Source.Name;
  FFastMode := Source.FastMode;
  FFrameStore := Source.FrameStore;
  FMaskStore := Source.MaskStore;
  FTransColor := Source.TransColor;
  FMap := Source.Map;
  FVisible := False;
  Frame := Source.Frame; {Ищем фрейм триггера.}
  FIsClone := True;
end;
procedure TMapCharacter.SetXPos(x: Integer);
begin
  Map.Redraw(xpos, ypos, zpos, -1);
  FXpos := x;
  Render;
end;
procedure TMapCharacter.SetYPos(y: Integer);
begin
  Map.Redraw(xpos, ypos, zpos, -1);
  FYPos := y;
  Render;
end;
procedure TMapCharacter.SetZPos(z: Integer);
begin
  Map.Redraw(xpos, ypos, zpos, -1);
  FZpos := z;
  Render;
end;
procedure TMapCharacter.SetCharacterCoords(x, y, z: Integer);
begin
  Map.Redraw(xpos, ypos, zpos, -1);
  Fxpos := x;
  Fypos := y;
  Fzpos := z;
  Render;
end;
procedure TMapCharacter.SetFrame(num: Integer);
begin
  if (num <= FFrameStore.count - 1) and (num > -1) then
  begin
    FFrame := num;
    FFramebm.Assign(TBitmap(FFrameStore.items[num]));
    if Ffastmode = false then
    begin
      FFrameMask.Width := FFramebm.width;
      FFrameMask.Height := FFramebm.height;
      FWorkBuf.Height := FFramebm.height;
      FWorkBuf.Width := FFramebm.width;
      makeframemask(TransColor);
      replacetranscolor(TransColor);
    end
    else
    begin
      FWorkBuf.Height := FFramebm.height;
      FWorkBuf.Width := FFramebm.width;
      FFrameMask.Assign(TBitmap(FMaskStore.items[num]));
    end;
  end;
end;
procedure TMapCharacter.MakeFrameMask(trColor: TColor);
var
  testbm1, testbm2: TBitmap;
  trColorInv: TColor;
begin
  testbm1 := TBitmap.Create;
  testbm1.width := 1;
  testbm1.height := 1;
  testbm2 := TBitmap.Create;
  testbm2.width := 1;
  testbm2.height := 1;
  testbm1.Canvas.Pixels[0, 0] := trColor;
  testbm2.Canvas.CopyMode := cmSrcInvert;
  testbm2.Canvas.Draw(0, 0, testbm1);
  trColorInv := testbm2.Canvas.Pixels[0, 0];
  testbm1.free;
  testbm2.free;
  with FFrameMask.Canvas do
  begin
    Brush.Color := trColorInv;
    BrushCopy(Rect(0, 0, FFrameMask.Width, FFrameMask.Height), FFramebm,
      Rect(0, 0, FFramebm.Width, FFramebm.Height), trColor);
    CopyMode := cmSrcInvert;
    Draw(0, 0, FFramebm);
  end;
end;
procedure TMapCharacter.ReplaceTransColor(trColor: TColor);
begin
  with FFramebm.Canvas do
  begin
    CopyMode := cmSrcCopy;
    Brush.Color := clBlack;
    BrushCopy(Rect(0, 0, FFramebm.Width, FFramebm.Height), FFramebm,
      Rect(0, 0, FFramebm.Width, FFramebm.Height), trColor);
  end;
end;
function TMapCharacter.GetOnScreen: Boolean;
var
  dispx, dispy: Integer;
begin
  dispx := Map.width div map.tilexdim;
  dispy := Map.height div map.tileydim;
  if (xpos >= Map.xpos) and (xpos <= map.xpos + dispx) and (ypos >= map.ypos)
    and
    (ypos >= map.ypos + dispy) then
    result := true;
end;
procedure TMapCharacter.SetVisible(vis: Boolean);
begin
  if vis and OnScreen then
    Render;
  FVisible := vis;
end;
procedure TMapCharacter.SetFastMode(fast: Boolean);
begin
  if fast <> FFastMode then
  begin
    if fast = true then
    begin
      FMaskStore := TFrameStore.Create;
      MakeFrameMasks;
      FFastMode := True;
      frame := 0;
    end
    else
    begin
      FMaskStore.Free;
      FFastMode := False;
    end;
  end;
end;
procedure TMapCharacter.MakeFrameMasks;
var
  a: Integer;
  bm: TBitMap;
begin
  if FFrameStore.count > 0 then
  begin
    for a := 0 to FFrameStore.Count - 1 do
    begin
      Frame := a;
      bm := TBitMap.create;
      bm.Assign(FFrameMask);
      FMaskStore.add(bm);
    end;
  end;
end;
procedure TMapCharacter.Render;
var
  x, y: Integer;
begin
  if visible and onscreen then
    RenderCharacter(true, xpos, ypos, FFramemask, FFramebm, FWorkbuf);
end;
procedure TMapCharacter.RenderCharacter(mapcoords: Boolean; cxpos, cypos:
  Integer; mask, bm, wb: TBitmap);
var
  x, y: Integer;
begin
  if map.ready then
  begin
    {
    Если пользователь определил это в mapcoords, то в первую
    очередь перерисовываем секцию(и). Если нет, делает это он.
    }
    if mapcoords then
    begin
      if FRedrawBackground then
        Map.redraw(cxpos, cypos, FMap.zpos, -1);
      wb.Canvas.Draw(0, 0, TMapIcon(FMap.Iconset[map.zoomlevel].items
        [FMap.Map.Iconat(cxpos, cypos, Map.zpos)]).image);
      x := (cxpos - Map.xpos) * FMap.tilexdim;
      y := (cypos - Map.ypos) * FMap.tileydim;
    end
    else
      wb.Canvas.Copyrect(rect(0, 0, FMap.tilexdim, FMap.tileydim), FMap.
        Screenbuffer.canvas, rect(x, y, x + FMap.tilexdim,
        y + FMap.tileydim));
    with wb do
    begin
      Map.Canvas.CopyMode := cmSrcAnd;
      Map.Canvas.Draw(0, 0, Mask);
      Map.Canvas.CopyMode := cmSrcPaint;
      Map.Canvas.Draw(0, 0, bm);
      Map.Canvas.Copymode := cmSrcCopy;
    end;
    Map.Canvas.CopyRect(Rect(x, y, x + FMap.tilexdim, y + FMap.tileydim), wb.
      canvas,
      Rect(0, 0, FMap.tilexdim, FMap.tileydim));
  end;
end;
procedure TMapCharacter.WriteData(Writer: TWriter);
begin
  with Writer do
  begin
    WriteListBegin;
    WriteString(FName);
    WriteBoolean(FFastMode);
    WriteInteger(TransColor);
    FFrameStore.WriteData(Writer);
    if FFastMode then
      FMaskStore.WriteData(Writer);
    WriteListEnd;
  end;
end;
procedure TMapCharacter.ReadData(Reader: TReader);
begin
  with Reader do
  begin
    ReadListBegin;
    Fname := ReadString;
    FFastMode := ReadBoolean;
    TransColor := ReadInteger;
    FFrameStore.ReadData(Reader);
    if FFastMode then
    begin
      FMaskStore := TFrameStore.Create;
      FMaskStore.ReadData(Reader);
    end;
    ReadListEnd;
  end;
end;
procedure TMapCharacterList.RenderVisibleCharacters;
var
  a: Integer;
begin
  for a := 0 to count - 1 do
    TMapCharacter(items[a]).render;
end;
procedure TMapCharacterList.clear;
var
  obj: TObject;
begin
  {Этот код освобождает все ресурсы, присутствующие в списке}
  if self.count > 0 then
  begin
    repeat
      obj := self.items[0];
      obj.free;
      self.remove(self.items[0]);
    until self.count = 0;
  end;
end;
destructor TMapCharacterList.Destroy;
var
  a: Integer;
begin
  if count > 0 then
    for a := 0 to count - 1 do
      TObject(items[a]).free;
  inherited destroy;
end;
procedure TMapCharacterList.loadfromfile(const filename: string);
var
  i: Integer;
  Reader: Treader;
  Stream: TFileStream;
  obj: TMapCharacter;
begin
  stream := TFileStream.create(filename, fmOpenRead);
  try
    reader := TReader.create(stream, $FF);
    try
      with reader do
      begin
        try
          ReadSignature;
          if ReadInteger <> $6667 then
            raise EReadError.Create('Не список сиволов.');
        except
          raise EReadError.Create('Неверный формат файла.');
        end;
        ReadListBegin;
        while not EndofList do
        begin
          obj := TMapCharacter.create(FMap);
          try
            obj.ReadData(reader);
          except
            obj.free;
            raise EReadError.Create('Ошибка в файле списка символов.');
          end;
          self.add(obj);
        end;
        ReadListEnd;
      end;
    finally
      reader.free;
    end;
  finally
    stream.free;
  end;
end;
procedure TMapCharacterList.savetofile(const filename: string);
var
  Stream: TFileStream;
  Writer: TWriter;
  i: Integer;
  obj: TMapCharacter;
begin
  stream := TFileStream.create(filename, fmCreate or fmOpenWrite);
  try
    writer := TWriter.create(stream, $FF);
    try
      with writer do
      begin
        WriteSignature;
        WriteInteger($6667);
        WriteListBegin;
        for i := 0 to self.count - 1 do
          TMapCharacter(self.items[i]).writedata(writer);
        WriteListEnd;
      end;
    finally
      writer.free;
    end;
  finally
    stream.free;
  end;
end;
procedure TFrameStore.WriteData(Writer: TWriter);
var
  mstream: TMemoryStream;
  a, size: Longint;
begin
  mstream := TMemoryStream.Create;
  try
    with writer do
    begin
      WriteListBegin;
      WriteInteger(count);
      for a := 0 to count - 1 do
      begin
        TBitmap(items[a]).savetostream(mstream);
        size := mstream.size;
        WriteInteger(size);
        Write(mstream.memory^, size);
        mstream.position := 0;
      end;
      WriteListEnd;
    end;
  finally
    Mstream.free;
  end;
end;
procedure TFrameStore.ReadData(Reader: TReader);
var
  mstream: TMemoryStream;
  a, listcount, size: Longint;
  newframe: TBitMap;
begin
  mstream := TMemoryStream.create;
  try
    with reader do
    begin
      ReadListBegin;
      Listcount := ReadInteger;
      for a := 1 to listcount do
      begin
        size := ReadInteger;
        mstream.setsize(size);
        read(mstream.Memory^, size);
        newframe := TBitmap.create;
        newframe.loadfromstream(mstream);
        add(newframe);
      end;
      ReadListEnd;
    end;
  finally
    Mstream.free;
  end;
end;
procedure TFrameStore.clear;
var
  Obj: TObject;
begin
  {{Этот код освобождает все ресурсы, присутствующие в списке}
  if self.count > 0 then
  begin
    repeat
      obj := self.items[0];
      obj.free;
      self.remove(self.items[0]);
    until self.count = 0;
  end;
end;
end.
Оглавление.