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

[001680]

Содержание раздела