adkutils.pas

N年前有个法国小组用Delphi写了一个2D网游（AD&D类型）

unit ADKUtils;

{
 projet ADK-ISO (c)2002-2003 Paul TOTH <[e-mail]>

 http://www.web-synergy.net/naug-land/

}

interface

uses
 Windows,Classes,SysUtils,Dialogs;

type
 TStreamedObject=class
 protected
  procedure LoadFromStream(AStream:TStream); virtual; abstract;
  procedure SaveToStream(AStream:TStream); virtual; abstract;
 public
  procedure LoadFromFile(AFileName:string);
  procedure SaveToFile(AFileName:string);
 end;

 TObjectList=class(TList)
 private
  function GetObject(Index:integer):TObject;
 public
  procedure Clear; override;
  property Objects[Index:integer]:TObject read GetObject;
 end;

procedure Error(s:string);
function OpenFileName(Dialog:TOpenDialog):string;

function getBoolean(s:TStream):boolean;
function getInteger(s:TStream):integer;
function getString(s:TStream):string;
procedure putBoolean(s:TStream; value:boolean);
procedure putInteger(s:TStream; value:integer);
procedure putString(s:TStream; value:string);

function DistanceColor(c1,c2:integer):single;

function ClipRect(const Client:TRect; x,y,w,h:integer; var Clipping:TRect):boolean;
procedure SwapRect(var Rect:TRect; Width:integer);
procedure FlipRect(var Rect:TRect; Height:integer);

implementation

procedure Error(s:string);
begin
 raise Exception.Create(s);
end;

function OpenFileName(Dialog:TOpenDialog):string;
begin
 Result:=Dialog.FileName;
 Dialog.InitialDir:=ExtractFilePath(Result);
 Dialog.FileName:=ExtractFileName(Result);
end;

function getBoolean(s:TStream):boolean;
begin
 s.ReadBuffer(Result,SizeOf(Result));
end;

function getInteger(s:TStream):integer;
begin
 s.ReadBuffer(Result,SizeOf(Result));
end;

function getString(s:TStream):string;
var
 l:integer;
begin
 l:=getInteger(s);
 if (l<0)or(l>512) then Error('Erreur de lecture d''une cha頽e !');
 SetLength(Result,l);
 s.ReadBuffer(Result[1],l);
end;

procedure putBoolean(s:TStream; value:boolean);
begin
 s.WriteBuffer(value,sizeof(value));
end;

procedure putInteger(s:TStream; value:integer);
begin
 s.WriteBuffer(value,sizeof(value));
end;

procedure putString(s:TStream; value:string);
var
 i:integer;
begin
 i:=length(value);
 s.WriteBuffer(i,sizeof(i));
 s.WriteBuffer(value[1],i);
end;

procedure TStreamedObject.LoadFromFile(AFileName:string);
var
 fs:TFileStream;
begin
 fs:=TFileStream.Create(AFileName,$40{fmOpenRead or fmShareDenyNone});
 try
  LoadFromStream(fs);
 finally
  fs.Free;
 end;
end;

procedure TStreamedObject.SaveToFile(AFileName:string);
var
 fs:TFileStream;
begin
 fs:=TFileStream.Create(AFileName,fmCreate);
 try
  SaveToStream(fs);
 finally
  fs.Free;
 end;
end;

function TObjectList.GetObject(Index:integer):TObject;
begin
 Result:=List[Index];
end;

procedure TObjectList.Clear;
var
 i:integer;
begin
 for i:=0 to Count-1 do TObject(List[i]).Free;
 inherited;
end;

function DistanceColor(c1,c2:integer):single;
var
 r,g,b:single;
begin
 r:=(c1 shr 16) and $ff-(c2 shr 16) and $ff;
 g:=(c1 shr  8) and $ff-(c2 shr  8) and $ff;
 b:=(c1       ) and $ff-(c2       ) and $ff;
 result:=r*r+g*g+b*b;
end;

function ClipRect(const Client:TRect; x,y,w,h:integer; var Clipping:TRect):boolean;
begin
 Result:=False;
 if x>=Client.Left then
  Clipping.Left:=0
 else begin
  Result:=True;
  Clipping.Left:=Client.Left-x;
 end;
 if y>=Client.Top then
  Clipping.Top:=0
 else begin
  Result:=True;
  Clipping.Top:=Client.Top-y;
 end;
 if x+w<Client.Right then
  Clipping.Right:=w
 else begin
  Result:=True;
  Clipping.Right:=Client.Right-x;
 end;
 if y+h<Client.Bottom then
  Clipping.Bottom:=h
 else begin
  Result:=True;
  Clipping.Bottom:=Client.Bottom-y;
 end;
end;

procedure SwapRect(var Rect:TRect; Width:integer);
var
 Left:integer;
begin
 Left:=Rect.Left;
 Rect.Left:=Width-Rect.Right;
 Rect.Right:=Width-Left;
end;

procedure FlipRect(var Rect:TRect; Height:integer);
var
 Top:integer;
begin
 Top:=Rect.Top;
 Rect.Top:=Height-Rect.Bottom;
 Rect.Bottom:=Height-Top;
end;

end.