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.
|
