Файл типа TList

Советы » Файлы » Файл типа 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

.

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

Категории

Статьи

Советы

Copyright © 2022 - All Rights Reserved - www.delphirus.com