Файл типа TList Delphi , Файловая система , Файлы
Файл типа 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 .
Here is a translation of the provided content into Russian:
TMapCharacterList
type
TMapCharacterList = class ( TList )
private
FMap : TOverHeadMap ;
public
procedure RenderVisibleCharacters ; virtual ;
procedure SaveToFile ( const filename : string ) ;
procedure LoadFromFile ( const filename : string ) ;
procedure Clear ; virtual ;
end ;
procedure TMapCharacterList . RenderVisibleCharacters ;
var
a : Integer ;
begin
for a := 0 to Count - 1 do
TMapCharacter ( Items [ a ]) . Render ;
end ;
Это основной класс, который управляет списком объектов TMapCharacter. Он предоставляет методы для отображения всех видимых символов, сохранения и загрузки данных из файлов.
TMapCharacter
type
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 ;
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 ; {getters for other properties}
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 ; {find trigger frame}
FIsClone := True ;
end ;
Это класс, который представляет собой одиночный символ карты. Он имеет свойства для имени, быстром режиме, хранилище кадров, маски и других параметров. Метод Clone позволяет создать копию этого объекта.
Другие классы и процедуры
Есть несколько других классов и процедур в коде, включая:
TFrameStore: управляет списком битмаповTMapCharacterList.SaveToFile и LoadFromFile: сохранение и загрузка данных из файловTFrameStore.WriteData и ReadData: запись и чтение данных в/из потоки
Пожалуйста, дайте мне знать, если у вас есть какие-либо конкретные вопросы о коде или если есть что-то еще, что я могу помочь вам с!
Файл типа TList, содержащий классы для отображения символов на карте.
Комментарии и вопросы Получайте свежие новости и обновления по Object Pascal, Delphi и Lazarus прямо в свой смартфон. Подпишитесь на наш delphi_kansoftware и будьте в курсе последних тенденций в разработке под Linux, Windows, Android и iOS
Материалы статей собраны из открытых источников, владелец сайта не претендует на авторство. Там где авторство установить не удалось, материал подаётся без имени автора. В случае если Вы считаете, что Ваши права нарушены, пожалуйста, свяжитесь с владельцем сайта.
:: Главная :: Файлы ::
Telegram-канал