Файл типа 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
.

Другое по теме:

• Как скопировать все файлы вместе с подкаталогами
• Копирование файлов
• Удалить файл в корзину? Запросто!