WebSVN – spacemission – Blame – /VCL_DELPHIX_D6/DXClass.pas

Rev	Author	Line No.	Line
1	daniel-mar	1	unit DXClass;
		2
		3	interface
		4
		5	{$INCLUDE DelphiXcfg.inc}
		6
		7	uses
4	daniel-mar	8	Windows, Messages, SysUtils, Classes, Controls, Forms, MMSystem, Graphics, {$IFDEF _DMO_}MultiMon,{$ENDIF}
		9	{$IfDef StandardDX}
		10	{$IfDef DX9}
		11	Direct3D, DirectInput,
		12	{$EndIf}
		13	DirectDraw, DirectSound;
		14	{$Else}
		15	DirectX;
		16	{$EndIf}
1	daniel-mar	17
		18	type
		19
		20	{ EDirectDrawError }
		21
		22	EDirectXError = class(Exception);
		23
		24	{ TDirectX }
		25
		26	TDirectX = class(TPersistent)
		27	private
		28	procedure SetDXResult(Value: HRESULT);
		29	protected
		30	FDXResult: HRESULT;
		31	procedure Check; virtual;
		32	public
		33	property DXResult: HRESULT read FDXResult write SetDXResult;
		34	end;
		35
		36	{ TDirectXDriver }
		37
		38	TDirectXDriver = class(TCollectionItem)
		39	private
		40	FGUID: PGUID;
		41	FGUID2: TGUID;
		42	FDescription: string;
		43	FDriverName: string;
		44	procedure SetGUID(Value: PGUID);
		45	public
		46	property GUID: PGUID read FGUID write SetGUID;
		47	property Description: string read FDescription write FDescription;
		48	property DriverName: string read FDriverName write FDriverName;
		49	end;
		50
		51	{ TDirectXDrivers }
		52
		53	TDirectXDrivers = class(TCollection)
		54	private
		55	function GetDriver(Index: Integer): TDirectXDriver;
		56	public
		57	constructor Create;
		58	property Drivers[Index: Integer]: TDirectXDriver read GetDriver; default;
		59	end;
		60
4	daniel-mar	61	{$IFDEF _DMO_}
		62	{ TDirectXDriverEx }
		63
		64	TDirectXDriverEx = class(TCollectionItem)
		65	private
		66	FGUID: PGUID;
		67	FGUID2: TGUID;
		68	FDescription: string;
		69	FDriverName: string;
		70	FMonitor: HMonitor;
		71	FMonitorInfo: TMonitorInfo;
		72	procedure SetGUID(Value: PGUID);
		73	function ConvertHMonitor(iMonitor: HMonitor): TMonitorInfo;
		74	function GetMonitorInfo: TMonitorInfo;
		75	function GetFlags: DWORD;
		76	function GetTempSpace: TRect;
		77	function GetWorkSpace: TRect;
		78	public
		79	property GUID: PGUID read FGUID write SetGUID;
		80	property Monitor: HMonitor read FMonitor write FMonitor;
		81	property MonitorInfo: TMonitorInfo read GetMonitorInfo;
		82	published
		83	property Description: string read FDescription write FDescription;
		84	property DriverName: string read FDriverName write FDriverName;
		85	property WorkSpace: TRect read GetWorkSpace;
		86	property TempSpace: TRect read GetTempSpace;
		87	property Flags: DWORD read GetFlags;
		88	end;
		89
		90	{ TDirectXDriversEx }
		91
		92	TDirectXDriversEx = class(TCollection)
		93	private
		94	function GetDriver(Index: Integer): TDirectXDriverEx;
		95	public
		96	constructor Create;
		97	property Drivers[Index: Integer]: TDirectXDriverEx read GetDriver; default;
		98	end;
		99	{$ENDIF}
		100
1	daniel-mar	101	{ TDXForm }
		102
		103	TDXForm = class(TForm)
		104	private
		105	FStoreWindow: Boolean;
		106	FWindowPlacement: TWindowPlacement;
		107	procedure WMSYSCommand(var Msg: TWMSYSCommand); message WM_SYSCOMMAND;
		108	protected
		109	procedure CreateParams(var Params: TCreateParams); override;
		110	public
		111	constructor Create(AOnwer: TComponent); override;
		112	destructor Destroy; override;
		113	procedure RestoreWindow;
		114	procedure StoreWindow;
		115	end;
		116
		117	{ TCustomDXTimer }
		118
		119	TDXTimerEvent = procedure(Sender: TObject; LagCount: Integer) of object;
		120
		121	TCustomDXTimer = class(TComponent)
		122	private
		123	FActiveOnly: Boolean;
		124	FEnabled: Boolean;
		125	FFrameRate: Integer;
		126	FInitialized: Boolean;
		127	FInterval: Cardinal;
		128	FInterval2: Cardinal;
		129	FNowFrameRate: Integer;
		130	FOldTime: DWORD;
		131	FOldTime2: DWORD;
		132	FOnActivate: TNotifyEvent;
		133	FOnDeactivate: TNotifyEvent;
		134	FOnTimer: TDXTimerEvent;
		135	procedure AppIdle(Sender: TObject; var Done: Boolean);
		136	function AppProc(var Message: TMessage): Boolean;
		137	procedure Finalize;
		138	procedure Initialize;
		139	procedure Resume;
		140	procedure SetActiveOnly(Value: Boolean);
		141	procedure SetEnabled(Value: Boolean);
		142	procedure SetInterval(Value: Cardinal);
		143	procedure Suspend;
		144	protected
		145	procedure DoActivate; virtual;
		146	procedure DoDeactivate; virtual;
		147	procedure DoTimer(LagCount: Integer); virtual;
		148	procedure Loaded; override;
		149	public
		150	constructor Create(AOwner: TComponent); override;
		151	destructor Destroy; override;
		152	property ActiveOnly: Boolean read FActiveOnly write SetActiveOnly;
		153	property Enabled: Boolean read FEnabled write SetEnabled;
		154	property FrameRate: Integer read FFrameRate;
		155	property Interval: Cardinal read FInterval write SetInterval;
		156	property OnActivate: TNotifyEvent read FOnActivate write FOnActivate;
		157	property OnDeactivate: TNotifyEvent read FOnDeactivate write FOnDeactivate;
		158	property OnTimer: TDXTimerEvent read FOnTimer write FOnTimer;
		159	end;
		160
		161	{ TDXTimer }
		162
		163	TDXTimer = class(TCustomDXTimer)
		164	published
		165	property ActiveOnly;
		166	property Enabled;
		167	property Interval;
		168	property OnActivate;
		169	property OnDeactivate;
		170	property OnTimer;
		171	end;
		172
		173	{ TControlSubClass }
		174
		175	TControlSubClassProc = procedure(var Message: TMessage; DefWindowProc: TWndMethod) of object;
		176
		177	TControlSubClass = class
		178	private
		179	FControl: TControl;
		180	FDefWindowProc: TWndMethod;
		181	FWindowProc: TControlSubClassProc;
		182	procedure WndProc(var Message: TMessage);
		183	public
		184	constructor Create(Control: TControl; WindowProc: TControlSubClassProc);
		185	destructor Destroy; override;
		186	end;
		187
		188	{ THashCollectionItem }
		189
		190	THashCollectionItem = class(TCollectionItem)
		191	private
		192	FHashCode: Integer;
		193	FIndex: Integer;
		194	FName: string;
		195	FLeft: THashCollectionItem;
		196	FRight: THashCollectionItem;
		197	procedure SetName(const Value: string);
		198	procedure AddHash;
		199	procedure DeleteHash;
		200	protected
		201	function GetDisplayName: string; override;
		202	procedure SetIndex(Value: Integer); override;
		203	public
		204	constructor Create(Collection: TCollection); override;
		205	destructor Destroy; override;
		206	procedure Assign(Source: TPersistent); override;
		207	property Index: Integer read FIndex write SetIndex;
		208	published
		209	property Name: string read FName write SetName;
		210	end;
		211
		212	{ THashCollection }
		213
		214	THashCollection = class(TCollection)
		215	private
		216	FHash: array[0..255] of THashCollectionItem;
		217	public
		218	function IndexOf(const Name: string): Integer;
		219	end;
		220
4	daniel-mar	221	{Addapted from RXLib.PicClip}
1	daniel-mar	222
4	daniel-mar	223	{ TPicClip }
		224	TCellRange = 1..MaxInt;
		225
		226	TDXPictureClip = class(TComponent)
		227	private
		228	FPicture: TPicture;
		229	FRows: TCellRange;
		230	FCols: TCellRange;
		231	FBitmap: TBitmap;
		232	FMasked: Boolean;
		233	FMaskColor: TColor;
		234	FOnChange: TNotifyEvent;
		235	procedure CheckIndex(Index: Integer);
		236	function GetCell(Col, Row: Cardinal): TBitmap;
		237	function GetGraphicCell(Index: Integer): TBitmap;
		238	function GetDefaultMaskColor: TColor;
		239	function GetIsEmpty: Boolean;
		240	function GetCount: Integer;
		241	function GetHeight: Integer;
		242	function GetWidth: Integer;
		243	function IsMaskStored: Boolean;
		244	procedure PictureChanged(Sender: TObject);
		245	procedure SetHeight(Value: Integer);
		246	procedure SetPicture(Value: TPicture);
		247	procedure SetWidth(Value: Integer);
		248	procedure SetMaskColor(Value: TColor);
		249	protected
		250	procedure AssignTo(Dest: TPersistent); override;
		251	procedure Changed; dynamic;
		252	public
		253	constructor Create(AOwner: TComponent); override;
		254	destructor Destroy; override;
		255	procedure Assign(Source: TPersistent); override;
		256	function GetIndex(Col, Row: Cardinal): Integer;
		257	procedure Draw(Canvas: TCanvas; X, Y, Index: Integer);
		258	procedure DrawCenter(Canvas: TCanvas; Rect: TRect; Index: Integer);
		259	property Cells[Col, Row: Cardinal]: TBitmap read GetCell;
		260	property GraphicCell[Index: Integer]: TBitmap read GetGraphicCell;
		261	property IsEmpty: Boolean read GetIsEmpty;
		262	property Count: Integer read GetCount;
		263	published
		264	property Cols: TCellRange read FCols write FCols default 1;
		265	property Height: Integer read GetHeight write SetHeight stored False;
		266	property Masked: Boolean read FMasked write FMasked default True;
		267	property Rows: TCellRange read FRows write FRows default 1;
		268	property Picture: TPicture read FPicture write SetPicture;
		269	property MaskColor: TColor read FMaskColor write SetMaskColor stored IsMaskStored;
		270	property Width: Integer read GetWidth write SetWidth stored False;
		271	property OnChange: TNotifyEvent read FOnChange write FOnChange;
		272	end;
		273
		274	function Max(Val1, Val2: Integer): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
		275	function Min(Val1, Val2: Integer): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
		276
1	daniel-mar	277	function Cos256(i: Integer): Double;
		278	function Sin256(i: Integer): Double;
		279
4	daniel-mar	280	function PointInRect(const Point: TPoint; const Rect: TRect): Boolean; {$IFDEF VER9UP}inline;{$ENDIF}
		281	function RectInRect(const Rect1, Rect2: TRect): Boolean; {$IFDEF VER9UP}inline;{$ENDIF}
		282	function OverlapRect(const Rect1, Rect2: TRect): Boolean; {$IFDEF VER9UP}inline;{$ENDIF}
1	daniel-mar	283
4	daniel-mar	284	function WideRect(ALeft, ATop, AWidth, AHeight: Integer): TRect; {$IFDEF VER9UP}inline;{$ENDIF}
		285
		286	{ Transformations routines}
		287
		288	const
		289	L_Curve = 0;//The left curve
		290	R_Curve = 1;//The right curve
		291
		292	C_Add = 0;//Increase (BTC)
		293	C_Dec = 1;//Decrease (ETC)
		294
		295	Type
		296	TDblPoint = packed record
		297	X, Y: Double;
		298	end;
		299	TSngPoint = packed record //SinglePoint
		300	X, Y: Single;
		301	end;
		302
		303
		304	//Transformation matrix
		305	T2DRowCol = Array[1..3] of Array[1..3] of Double;
		306	T2DVector = Array[1..3] of Double;
		307	//Distance between 2 points
		308	function Get2PointRange(a,b: TDblPoint):Double;
		309	//From vector angular calculation
		310	function Get256(dX,dY: Double):Double;
		311	//The angular calculation of the A from B
		312	function GetARadFromB(A,B: TDblPoint):Double;
		313
		314	//It calculates the TDblPoint
		315	function DblPoint(a,b:Double):TDblPoint;
		316	//It converts the TDboPoint to the TPoint
		317	function TruncDblPoint(DblPos: TDblPoint): TPoint;
		318
		319	function GetPointFromRangeAndAngle(SP: TDblPoint; Range,Angle: Double): TDblPoint;
		320
		321	function Ini2DRowCol: T2DRowCol;
		322	function Trans2DRowCol(x,y:double):T2DRowCol;
		323	function Scale2DRowCol(x,y:double):T2DRowCol;
		324	function Rotate2DRowCol(Theta:double):T2DRowCol;
		325	function RotateIntoX2DRowCol(x,y: double):T2DRowCol;
		326	function Multiply2DRowCol(A,B:T2DRowCol):T2DRowCol;
		327	function ScaleAt2DRowCol(x,y,Sx,Sy:double):T2DRowCol;
		328	function ReflectAcross2DRowCol(x,y,dx,dy:Double): T2DRowCol;
		329	function Apply2DVector(V:T2DVector; M:T2DRowCol): T2DVector;
		330	function RotateAround2DRowCol(x,y,Theta:Double): T2DRowCol;
		331
		332	//Collision decision
		333	function PointInCircle(PPos,CPos: TPoint; R: integer): Boolean;
		334	function CircleInCircle(C1Pos,C2Pos: TPoint; R1,R2:Integer): Boolean;
		335	function SegmentInCircle(SPos,EPos,CPos: TPoint; R: Integer): Boolean;
		336
		337	//If A is closer than B from starting point S, the True is returned.
		338	function CheckNearAThanB(S,A,B: TDblPoint): Boolean;
		339
		340	//The Angle of 256 period is returned
		341	function Angle256(Angle: Single): Single;
		342
		343	{ Support functions }
		344
1	daniel-mar	345	procedure ReleaseCom(out Com);
		346	function DXLoadLibrary(const FileName, FuncName: string): TFarProc;
		347
4	daniel-mar	348	{ Simple helper }
		349
		350	procedure Log(const Co: string; const FName: string{$IFDEF VER4UP} = 'c:\logerr.txt'{$ENDIF});
		351
1	daniel-mar	352	implementation
		353
		354	uses DXConsts;
		355
		356	function Max(Val1, Val2: Integer): Integer;
		357	begin
		358	if Val1>=Val2 then Result := Val1 else Result := Val2;
		359	end;
		360
		361	function Min(Val1, Val2: Integer): Integer;
		362	begin
		363	if Val1<=Val2 then Result := Val1 else Result := Val2;
		364	end;
		365
		366	function PointInRect(const Point: TPoint; const Rect: TRect): Boolean;
		367	begin
		368	Result := (Point.X >= Rect.Left) and
		369	(Point.X <= Rect.Right) and
		370	(Point.Y >= Rect.Top) and
		371	(Point.Y <= Rect.Bottom);
		372	end;
		373
		374	function RectInRect(const Rect1, Rect2: TRect): Boolean;
		375	begin
		376	Result := (Rect1.Left >= Rect2.Left) and
		377	(Rect1.Right <= Rect2.Right) and
		378	(Rect1.Top >= Rect2.Top) and
		379	(Rect1.Bottom <= Rect2.Bottom);
		380	end;
		381
		382	function OverlapRect(const Rect1, Rect2: TRect): Boolean;
		383	begin
		384	Result := (Rect1.Left < Rect2.Right) and
		385	(Rect1.Right > Rect2.Left) and
		386	(Rect1.Top < Rect2.Bottom) and
		387	(Rect1.Bottom > Rect2.Top);
		388	end;
		389
		390	function WideRect(ALeft, ATop, AWidth, AHeight: Integer): TRect;
		391	begin
		392	with Result do
		393	begin
		394	Left := ALeft;
		395	Top := ATop;
		396	Right := ALeft+AWidth;
		397	Bottom := ATop+AHeight;
		398	end;
		399	end;
		400
		401	var
		402	CosinTable: array[0..255] of Double;
		403
		404	procedure InitCosinTable;
		405	var
		406	i: Integer;
		407	begin
		408	for i:=0 to 255 do
		409	CosinTable[i] := Cos((i/256)2PI);
		410	end;
		411
		412	function Cos256(i: Integer): Double;
		413	begin
		414	Result := CosinTable[i and 255];
		415	end;
		416
		417	function Sin256(i: Integer): Double;
		418	begin
		419	Result := CosinTable[(i+192) and 255];
		420	end;
		421
		422	procedure ReleaseCom(out Com);
		423	begin
		424	end;
		425
		426	var
		427	LibList: TStringList;
		428
		429	function DXLoadLibrary(const FileName, FuncName: string): Pointer;
		430	var
		431	i: Integer;
		432	h: THandle;
		433	begin
		434	if LibList=nil then
		435	LibList := TStringList.Create;
		436
		437	i := LibList.IndexOf(AnsiLowerCase(FileName));
		438	if i=-1 then
		439	begin
		440	{ DLL is loaded. }
		441	h := LoadLibrary(PChar(FileName));
		442	if h=0 then
		443	raise Exception.CreateFmt(SDLLNotLoaded, [FileName]);
		444	LibList.AddObject(AnsiLowerCase(FileName), Pointer(h));
		445	end else
		446	begin
		447	{ DLL has already been loaded. }
		448	h := THandle(LibList.Objects[i]);
		449	end;
		450
		451	Result := GetProcAddress(h, PChar(FuncName));
		452	if Result=nil then
		453	raise Exception.CreateFmt(SDLLNotLoaded, [FileName]);
		454	end;
		455
		456	procedure FreeLibList;
		457	var
		458	i: Integer;
		459	begin
		460	if LibList<>nil then
		461	begin
		462	for i:=0 to LibList.Count-1 do
		463	FreeLibrary(THandle(LibList.Objects[i]));
		464	LibList.Free;
		465	end;
		466	end;
		467
		468	{ TDirectX }
		469
		470	procedure TDirectX.Check;
		471	begin
		472	end;
		473
		474	procedure TDirectX.SetDXResult(Value: HRESULT);
		475	begin
		476	FDXResult := Value;
		477	if FDXResult<>0 then Check;
		478	end;
		479
		480	{ TDirectXDriver }
		481
		482	procedure TDirectXDriver.SetGUID(Value: PGUID);
		483	begin
		484	if not IsBadHugeReadPtr(Value, SizeOf(TGUID)) then
		485	begin
		486	FGUID2 := Value^;
		487	FGUID := @FGUID2;
		488	end else
		489	FGUID := Value;
		490	end;
		491
		492	{ TDirectXDrivers }
		493
		494	constructor TDirectXDrivers.Create;
		495	begin
		496	inherited Create(TDirectXDriver);
		497	end;
		498
		499	function TDirectXDrivers.GetDriver(Index: Integer): TDirectXDriver;
		500	begin
		501	Result := (inherited Items[Index]) as TDirectXDriver;
		502	end;
		503
		504	{ TDXForm }
		505
		506	var
		507	SetAppExStyleCount: Integer;
		508
		509	constructor TDXForm.Create(AOnwer: TComponent);
		510	var
		511	ExStyle: Integer;
		512	begin
		513	inherited Create(AOnwer);
		514	Inc(SetAppExStyleCount);
		515	ExStyle := GetWindowLong(Application.Handle, GWL_EXSTYLE);
		516	ExStyle := ExStyle or WS_EX_TOOLWINDOW;
		517	SetWindowLong(Application.Handle, GWL_EXSTYLE, ExStyle);
		518	end;
		519
		520	destructor TDXForm.Destroy;
		521	var
		522	ExStyle: Integer;
		523	begin
		524	Dec(SetAppExStyleCount);
		525	if SetAppExStyleCount=0 then
		526	begin
		527	ExStyle := GetWindowLong(Application.Handle, GWL_EXSTYLE);
		528	ExStyle := ExStyle and (not WS_EX_TOOLWINDOW);
		529	SetWindowLong(Application.Handle, GWL_EXSTYLE, ExStyle);
		530	end;
		531	inherited Destroy;
		532	end;
		533
		534	procedure TDXForm.CreateParams(var Params: TCreateParams);
		535	begin
		536	inherited CreateParams(Params);
		537	Params.ExStyle := Params.ExStyle or WS_EX_APPWINDOW;
		538	end;
		539
		540	procedure TDXForm.RestoreWindow;
		541	begin
		542	if FStoreWindow then
		543	begin
		544	SetWindowPlacement(Handle, @FWindowPlacement);
		545	FStoreWindow := False;
		546	end;
		547	end;
		548
		549	procedure TDXForm.StoreWindow;
		550	begin
		551	FWindowPlacement.Length := SizeOf(FWindowPlacement);
		552	FStoreWindow := GetWindowPlacement(Handle, @FWindowPlacement);
		553	end;
		554
		555	procedure TDXForm.WMSYSCommand(var Msg: TWMSYSCommand);
		556	begin
		557	if Msg.CmdType = SC_MINIMIZE then
		558	begin
		559	DefaultHandler(Msg);
		560	WindowState := wsMinimized;
		561	end else
		562	inherited;
		563	end;
		564
		565	{ TCustomDXTimer }
		566
		567	constructor TCustomDXTimer.Create(AOwner: TComponent);
		568	begin
		569	inherited Create(AOwner);
		570	FActiveOnly := True;
		571	FEnabled := True;
		572	Interval := 1000;
		573	Application.HookMainWindow(AppProc);
		574	end;
		575
		576	destructor TCustomDXTimer.Destroy;
		577	begin
		578	Finalize;
		579	Application.UnHookMainWindow(AppProc);
		580	inherited Destroy;
		581	end;
		582
		583	procedure TCustomDXTimer.AppIdle(Sender: TObject; var Done: Boolean);
		584	var
		585	t, t2: DWORD;
		586	LagCount, i: Integer;
		587	begin
		588	Done := False;
		589
		590	t := TimeGetTime;
		591	t2 := t-FOldTime;
		592	if t2>=FInterval then
		593	begin
		594	FOldTime := t;
		595
		596	LagCount := t2 div FInterval2;
		597	if LagCount<1 then LagCount := 1;
		598
		599	Inc(FNowFrameRate);
		600
		601	i := Max(t-FOldTime2, 1);
		602	if i>=1000 then
		603	begin
		604	FFrameRate := Round(FNowFrameRate*1000/i);
		605	FNowFrameRate := 0;
		606	FOldTime2 := t;
		607	end;
		608
		609	DoTimer(LagCount);
		610	end;
		611	end;
		612
		613	function TCustomDXTimer.AppProc(var Message: TMessage): Boolean;
		614	begin
		615	Result := False;
		616	case Message.Msg of
		617	CM_ACTIVATE:
		618	begin
		619	DoActivate;
		620	if FInitialized and FActiveOnly then Resume;
		621	end;
		622	CM_DEACTIVATE:
		623	begin
		624	DoDeactivate;
		625	if FInitialized and FActiveOnly then Suspend;
		626	end;
		627	end;
		628	end;
		629
		630	procedure TCustomDXTimer.DoActivate;
		631	begin
		632	if Assigned(FOnActivate) then FOnActivate(Self);
		633	end;
		634
		635	procedure TCustomDXTimer.DoDeactivate;
		636	begin
		637	if Assigned(FOnDeactivate) then FOnDeactivate(Self);
		638	end;
		639
		640	procedure TCustomDXTimer.DoTimer(LagCount: Integer);
		641	begin
		642	if Assigned(FOnTimer) then FOnTimer(Self, LagCount);
		643	end;
		644
		645	procedure TCustomDXTimer.Finalize;
		646	begin
		647	if FInitialized then
		648	begin
		649	Suspend;
		650	FInitialized := False;
		651	end;
		652	end;
		653
		654	procedure TCustomDXTimer.Initialize;
		655	begin
		656	Finalize;
		657
		658	if ActiveOnly then
		659	begin
		660	if Application.Active then
		661	Resume;
		662	end else
		663	Resume;
		664	FInitialized := True;
		665	end;
		666
		667	procedure TCustomDXTimer.Loaded;
		668	begin
		669	inherited Loaded;
		670	if (not (csDesigning in ComponentState)) and FEnabled then
		671	Initialize;
		672	end;
		673
		674	procedure TCustomDXTimer.Resume;
		675	begin
		676	FOldTime := TimeGetTime;
		677	FOldTime2 := TimeGetTime;
		678	Application.OnIdle := AppIdle;
		679	end;
		680
		681	procedure TCustomDXTimer.SetActiveOnly(Value: Boolean);
		682	begin
		683	if FActiveOnly<>Value then
		684	begin
		685	FActiveOnly := Value;
		686
		687	if Application.Active and FActiveOnly then
		688	if FInitialized and FActiveOnly then Suspend;
		689	end;
		690	end;
		691
		692	procedure TCustomDXTimer.SetEnabled(Value: Boolean);
		693	begin
		694	if FEnabled<>Value then
		695	begin
		696	FEnabled := Value;
		697	if ComponentState*[csReading, csLoading]=[] then
		698	if FEnabled then Initialize else Finalize;
		699	end;
		700	end;
		701
		702	procedure TCustomDXTimer.SetInterval(Value: Cardinal);
		703	begin
		704	if FInterval<>Value then
		705	begin
		706	FInterval := Max(Value, 0);
		707	FInterval2 := Max(Value, 1);
		708	end;
		709	end;
		710
		711	procedure TCustomDXTimer.Suspend;
		712	begin
		713	Application.OnIdle := nil;
		714	end;
		715
		716	{ TControlSubClass }
		717
		718	constructor TControlSubClass.Create(Control: TControl;
		719	WindowProc: TControlSubClassProc);
		720	begin
		721	inherited Create;
		722	FControl := Control;
		723	FDefWindowProc := FControl.WindowProc;
		724	FControl.WindowProc := WndProc;
		725	FWindowProc := WindowProc;
		726	end;
		727
		728	destructor TControlSubClass.Destroy;
		729	begin
		730	FControl.WindowProc := FDefWindowProc;
		731	inherited Destroy;
		732	end;
		733
		734	procedure TControlSubClass.WndProc(var Message: TMessage);
		735	begin
		736	FWindowProc(Message, FDefWindowProc);
		737	end;
		738
		739	{ THashCollectionItem }
		740
		741	function MakeHashCode(const Str: string): Integer;
		742	var
		743	s: string;
		744	begin
		745	s := AnsiLowerCase(Str);
		746	Result := Length(s)*16;
		747	if Length(s)>=2 then
		748	Result := Result + (Ord(s[1]) + Ord(s[Length(s)-1]));
		749	Result := Result and 255;
		750	end;
		751
		752	constructor THashCollectionItem.Create(Collection: TCollection);
		753	begin
		754	inherited Create(Collection);
		755	FIndex := inherited Index;
		756	AddHash;
		757	end;
		758
		759	destructor THashCollectionItem.Destroy;
		760	var
		761	i: Integer;
		762	begin
		763	for i:=FIndex+1 to Collection.Count-1 do
		764	Dec(THashCollectionItem(Collection.Items[i]).FIndex);
		765	DeleteHash;
		766	inherited Destroy;
		767	end;
		768
		769	procedure THashCollectionItem.Assign(Source: TPersistent);
		770	begin
		771	if Source is THashCollectionItem then
		772	begin
		773	Name := THashCollectionItem(Source).Name;
		774	end else
		775	inherited Assign(Source);
		776	end;
		777
		778	procedure THashCollectionItem.AddHash;
		779	var
		780	Item: THashCollectionItem;
		781	begin
		782	FHashCode := MakeHashCode(FName);
		783
		784	Item := THashCollection(Collection).FHash[FHashCode];
		785	if Item<>nil then
		786	begin
		787	Item.FLeft := Self;
		788	Self.FRight := Item;
		789	end;
		790
		791	THashCollection(Collection).FHash[FHashCode] := Self;
		792	end;
		793
		794	procedure THashCollectionItem.DeleteHash;
		795	begin
		796	if FLeft<>nil then
		797	begin
		798	FLeft.FRight := FRight;
		799	if FRight<>nil then
		800	FRight.FLeft := FLeft;
		801	end else
		802	begin
		803	if FHashCode<>-1 then
		804	begin
		805	THashCollection(Collection).FHash[FHashCode] := FRight;
		806	if FRight<>nil then
		807	FRight.FLeft := nil;
		808	end;
		809	end;
		810	FLeft := nil;
		811	FRight := nil;
		812	end;
		813
		814	function THashCollectionItem.GetDisplayName: string;
		815	begin
		816	Result := Name;
		817	if Result='' then Result := inherited GetDisplayName;
		818	end;
		819
		820	procedure THashCollectionItem.SetIndex(Value: Integer);
		821	begin
		822	if FIndex<>Value then
		823	begin
		824	FIndex := Value;
		825	inherited SetIndex(Value);
		826	end;
		827	end;
		828
		829	procedure THashCollectionItem.SetName(const Value: string);
		830	begin
		831	if FName<>Value then
		832	begin
		833	FName := Value;
		834	DeleteHash;
		835	AddHash;
		836	end;
		837	end;
		838
		839	{ THashCollection }
		840
		841	function THashCollection.IndexOf(const Name: string): Integer;
		842	var
		843	Item: THashCollectionItem;
		844	begin
		845	Item := FHash[MakeHashCode(Name)];
		846	while Item<>nil do
		847	begin
		848	if AnsiCompareText(Item.Name, Name)=0 then
		849	begin
		850	Result := Item.FIndex;
		851	Exit;
		852	end;
		853	Item := Item.FRight;
		854	end;
		855	Result := -1;
		856	end;
		857
4	daniel-mar	858	{ TDXPictureClip }
		859
		860	constructor TDXPictureClip.Create(AOwner: TComponent);
		861	begin
		862	inherited Create(AOwner);
		863	FPicture := TPicture.Create;
		864	FPicture.OnChange := PictureChanged;
		865	FBitmap := TBitmap.Create;
		866	FRows := 1;
		867	FCols := 1;
		868	FMaskColor := GetDefaultMaskColor;
		869	FMasked := True;
		870	end;
		871
		872	destructor TDXPictureClip.Destroy;
		873	begin
		874	FOnChange := nil;
		875	FPicture.OnChange := nil;
		876	FBitmap.Free;
		877	FPicture.Free;
		878	inherited Destroy;
		879	end;
		880
		881	procedure TDXPictureClip.Assign(Source: TPersistent);
		882	begin
		883	if Source is TDXPictureClip then begin
		884	with TDXPictureClip(Source) do begin
		885	Self.FRows := Rows;
		886	Self.FCols := Cols;
		887	Self.FMasked := Masked;
		888	Self.FMaskColor := MaskColor;
		889	Self.FPicture.Assign(FPicture);
		890	end;
		891	end
		892	else if (Source is TPicture) or (Source is TGraphic) then
		893	FPicture.Assign(Source)
		894	else inherited Assign(Source);
		895	end;
		896
		897	type
		898	THack = class(TImageList);
		899
		900	procedure TDXPictureClip.AssignTo(Dest: TPersistent);
		901	var
		902	I: Integer;
		903	SaveChange: TNotifyEvent;
		904	begin
		905	if (Dest is TPicture) then Dest.Assign(FPicture)
		906	else if (Dest is TImageList) and not IsEmpty then begin
		907	with TImageList(Dest) do begin
		908	SaveChange := OnChange;
		909	try
		910	OnChange := nil;
		911	Clear;
		912	Width := Self.Width;
		913	Height := Self.Height;
		914	for I := 0 to Self.Count - 1 do begin
		915	if Self.Masked and (MaskColor <> clNone) then
		916	TImageList(Dest).AddMasked(GraphicCell[I], MaskColor)
		917	else TImageList(Dest).Add(GraphicCell[I], nil);
		918	end;
		919	Masked := Self.Masked;
		920	finally
		921	OnChange := SaveChange;
		922	end;
		923	THack(Dest).Change;
		924	end;
		925	end
		926	else inherited AssignTo(Dest);
		927	end;
		928
		929	procedure TDXPictureClip.Changed;
		930	begin
		931	if Assigned(FOnChange) then FOnChange(Self);
		932	end;
		933
		934	function TDXPictureClip.GetIsEmpty: Boolean;
		935	begin
		936	Result := not Assigned(Picture) or Picture.Graphic.Empty;
		937	end;
		938
		939	function TDXPictureClip.GetCount: Integer;
		940	begin
		941	if IsEmpty then Result := 0
		942	else Result := Cols * Rows;
		943	end;
		944	const
		945	{ TBitmap.GetTransparentColor from GRAPHICS.PAS uses this value }
		946	PaletteMask = $02000000;
		947
		948	procedure TDXPictureClip.Draw(Canvas: TCanvas; X, Y, Index: Integer);
		949
		950	function PaletteColor(Color: TColor): Longint;
		951	begin
		952	Result := ColorToRGB(Color) or PaletteMask;
		953	end;
		954	procedure StretchBltTransparent(DstDC: HDC; DstX, DstY, DstW, DstH: Integer;
		955	SrcDC: HDC; SrcX, SrcY, SrcW, SrcH: Integer; Palette: HPalette;
		956	TransparentColor: TColorRef);
		957	var
		958	Color: TColorRef;
		959	bmAndBack, bmAndObject, bmAndMem, bmSave: HBitmap;
		960	bmBackOld, bmObjectOld, bmMemOld, bmSaveOld: HBitmap;
		961	MemDC, BackDC, ObjectDC, SaveDC: HDC;
		962	palDst, palMem, palSave, palObj: HPalette;
		963	begin
		964	{ Create some DCs to hold temporary data }
		965	BackDC := CreateCompatibleDC(DstDC);
		966	ObjectDC := CreateCompatibleDC(DstDC);
		967	MemDC := CreateCompatibleDC(DstDC);
		968	SaveDC := CreateCompatibleDC(DstDC);
		969	{ Create a bitmap for each DC }
		970	bmAndObject := CreateBitmap(SrcW, SrcH, 1, 1, nil);
		971	bmAndBack := CreateBitmap(SrcW, SrcH, 1, 1, nil);
		972	bmAndMem := CreateCompatibleBitmap(DstDC, DstW, DstH);
		973	bmSave := CreateCompatibleBitmap(DstDC, SrcW, SrcH);
		974	{ Each DC must select a bitmap object to store pixel data }
		975	bmBackOld := SelectObject(BackDC, bmAndBack);
		976	bmObjectOld := SelectObject(ObjectDC, bmAndObject);
		977	bmMemOld := SelectObject(MemDC, bmAndMem);
		978	bmSaveOld := SelectObject(SaveDC, bmSave);
		979	{ Select palette }
		980	palDst := 0; palMem := 0; palSave := 0; palObj := 0;
		981	if Palette <> 0 then begin
		982	palDst := SelectPalette(DstDC, Palette, True);
		983	RealizePalette(DstDC);
		984	palSave := SelectPalette(SaveDC, Palette, False);
		985	RealizePalette(SaveDC);
		986	palObj := SelectPalette(ObjectDC, Palette, False);
		987	RealizePalette(ObjectDC);
		988	palMem := SelectPalette(MemDC, Palette, True);
		989	RealizePalette(MemDC);
		990	end;
		991	{ Set proper mapping mode }
		992	SetMapMode(SrcDC, GetMapMode(DstDC));
		993	SetMapMode(SaveDC, GetMapMode(DstDC));
		994	{ Save the bitmap sent here }
		995	BitBlt(SaveDC, 0, 0, SrcW, SrcH, SrcDC, SrcX, SrcY, SRCCOPY);
		996	{ Set the background color of the source DC to the color, }
		997	{ contained in the parts of the bitmap that should be transparent }
		998	Color := SetBkColor(SaveDC, PaletteColor(TransparentColor));
		999	{ Create the object mask for the bitmap by performing a BitBlt() }
		1000	{ from the source bitmap to a monochrome bitmap }
		1001	BitBlt(ObjectDC, 0, 0, SrcW, SrcH, SaveDC, 0, 0, SRCCOPY);
		1002	{ Set the background color of the source DC back to the original }
		1003	SetBkColor(SaveDC, Color);
		1004	{ Create the inverse of the object mask }
		1005	BitBlt(BackDC, 0, 0, SrcW, SrcH, ObjectDC, 0, 0, NOTSRCCOPY);
		1006	{ Copy the background of the main DC to the destination }
		1007	BitBlt(MemDC, 0, 0, DstW, DstH, DstDC, DstX, DstY, SRCCOPY);
		1008	{ Mask out the places where the bitmap will be placed }
		1009	StretchBlt(MemDC, 0, 0, DstW, DstH, ObjectDC, 0, 0, SrcW, SrcH, SRCAND);
		1010	{ Mask out the transparent colored pixels on the bitmap }
		1011	BitBlt(SaveDC, 0, 0, SrcW, SrcH, BackDC, 0, 0, SRCAND);
		1012	{ XOR the bitmap with the background on the destination DC }
		1013	StretchBlt(MemDC, 0, 0, DstW, DstH, SaveDC, 0, 0, SrcW, SrcH, SRCPAINT);
		1014	{ Copy the destination to the screen }
		1015	BitBlt(DstDC, DstX, DstY, DstW, DstH, MemDC, 0, 0,
		1016	SRCCOPY);
		1017	{ Restore palette }
		1018	if Palette <> 0 then begin
		1019	SelectPalette(MemDC, palMem, False);
		1020	SelectPalette(ObjectDC, palObj, False);
		1021	SelectPalette(SaveDC, palSave, False);
		1022	SelectPalette(DstDC, palDst, True);
		1023	end;
		1024	{ Delete the memory bitmaps }
		1025	DeleteObject(SelectObject(BackDC, bmBackOld));
		1026	DeleteObject(SelectObject(ObjectDC, bmObjectOld));
		1027	DeleteObject(SelectObject(MemDC, bmMemOld));
		1028	DeleteObject(SelectObject(SaveDC, bmSaveOld));
		1029	{ Delete the memory DCs }
		1030	DeleteDC(MemDC);
		1031	DeleteDC(BackDC);
		1032	DeleteDC(ObjectDC);
		1033	DeleteDC(SaveDC);
		1034	end;
		1035	procedure StretchBitmapTransparent(Dest: TCanvas; Bitmap: TBitmap;
		1036	TransparentColor: TColor; DstX, DstY, DstW, DstH, SrcX, SrcY,
		1037	SrcW, SrcH: Integer);
		1038	var
		1039	CanvasChanging: TNotifyEvent;
		1040	begin
		1041	if DstW <= 0 then DstW := Bitmap.Width;
		1042	if DstH <= 0 then DstH := Bitmap.Height;
		1043	if (SrcW <= 0) or (SrcH <= 0) then begin
		1044	SrcX := 0; SrcY := 0;
		1045	SrcW := Bitmap.Width;
		1046	SrcH := Bitmap.Height;
		1047	end;
		1048	if not Bitmap.Monochrome then
		1049	SetStretchBltMode(Dest.Handle, STRETCH_DELETESCANS);
		1050	CanvasChanging := Bitmap.Canvas.OnChanging;
		1051	Bitmap.Canvas.Lock;
		1052	try
		1053	Bitmap.Canvas.OnChanging := nil;
		1054	if TransparentColor = clNone then begin
		1055	StretchBlt(Dest.Handle, DstX, DstY, DstW, DstH, Bitmap.Canvas.Handle,
		1056	SrcX, SrcY, SrcW, SrcH, Dest.CopyMode);
		1057	end
		1058	else begin
		1059	if TransparentColor = clDefault then
		1060	TransparentColor := Bitmap.Canvas.Pixels[0, Bitmap.Height - 1];
		1061	if Bitmap.Monochrome then TransparentColor := clWhite
		1062	else TransparentColor := ColorToRGB(TransparentColor);
		1063	StretchBltTransparent(Dest.Handle, DstX, DstY, DstW, DstH,
		1064	Bitmap.Canvas.Handle, SrcX, SrcY, SrcW, SrcH, Bitmap.Palette,
		1065	TransparentColor);
		1066	end;
		1067	finally
		1068	Bitmap.Canvas.OnChanging := CanvasChanging;
		1069	Bitmap.Canvas.Unlock;
		1070	end;
		1071	end;
		1072	procedure DrawBitmapTransparent(Dest: TCanvas; DstX, DstY: Integer;
		1073	Bitmap: TBitmap; TransparentColor: TColor);
		1074	begin
		1075	StretchBitmapTransparent(Dest, Bitmap, TransparentColor, DstX, DstY,
		1076	Bitmap.Width, Bitmap.Height, 0, 0, Bitmap.Width, Bitmap.Height);
		1077	end;
		1078	var
		1079	Image: TGraphic;
		1080	begin
		1081	if Index < 0 then Image := Picture.Graphic
		1082	else Image := GraphicCell[Index];
		1083	if (Image <> nil) and not Image.Empty then begin
		1084	if FMasked and (FMaskColor <> clNone) and
		1085	(Picture.Graphic is TBitmap) then
		1086	DrawBitmapTransparent(Canvas, X, Y, TBitmap(Image), FMaskColor)
		1087	else Canvas.Draw(X, Y, Image);
		1088	end;
		1089	end;
		1090
		1091	procedure TDXPictureClip.DrawCenter(Canvas: TCanvas; Rect: TRect; Index: Integer);
		1092	var
		1093	X, Y: Integer;
		1094	begin
		1095	X := (Rect.Left + Rect.Right - Width) div 2;
		1096	Y := (Rect.Bottom + Rect.Top - Height) div 2;
		1097	Draw(Canvas, X, Y, Index);
		1098	end;
		1099
		1100	procedure TDXPictureClip.CheckIndex(Index: Integer);
		1101	begin
		1102	if (Index >= Cols * Rows) or (Index < 0) then
		1103	raise EListError.CreateFmt('%s (%d)', ['Load list error', Index]);
		1104	end;
		1105
		1106	function TDXPictureClip.GetIndex(Col, Row: Cardinal): Integer;
		1107	begin
		1108	Result := Col + (Row * Cols);
		1109	if (Result >= Cols * Rows) or IsEmpty then Result := -1;
		1110	end;
		1111
		1112	function TDXPictureClip.GetCell(Col, Row: Cardinal): TBitmap;
		1113	begin
		1114	Result := GetGraphicCell(GetIndex(Col, Row));
		1115	end;
		1116
		1117	function TDXPictureClip.GetGraphicCell(Index: Integer): TBitmap;
		1118	procedure AssignBitmapCell(Source: TGraphic; Dest: TBitmap; Cols, Rows,
		1119	Index: Integer);
		1120	var
		1121	CellWidth, CellHeight: Integer;
		1122	begin
		1123	if (Source <> nil) and (Dest <> nil) then begin
		1124	if Cols <= 0 then Cols := 1;
		1125	if Rows <= 0 then Rows := 1;
		1126	if Index < 0 then Index := 0;
		1127	CellWidth := Source.Width div Cols;
		1128	CellHeight := Source.Height div Rows;
		1129	with Dest do begin
		1130	Width := CellWidth; Height := CellHeight;
		1131	end;
		1132	if Source is TBitmap then begin
		1133	Dest.Canvas.CopyRect(Bounds(0, 0, CellWidth, CellHeight),
		1134	TBitmap(Source).Canvas, Bounds((Index mod Cols) * CellWidth,
		1135	(Index div Cols) * CellHeight, CellWidth, CellHeight));
		1136	Dest.TransparentColor := TBitmap(Source).TransparentColor;
		1137	end
		1138	else begin
		1139	Dest.Canvas.Brush.Color := clSilver;
		1140	Dest.Canvas.FillRect(Bounds(0, 0, CellWidth, CellHeight));
		1141	Dest.Canvas.Draw(-(Index mod Cols) * CellWidth,
		1142	-(Index div Cols) * CellHeight, Source);
		1143	end;
		1144	Dest.Transparent := Source.Transparent;
		1145	end;
		1146	end;
		1147	begin
		1148	CheckIndex(Index);
		1149	AssignBitmapCell(Picture.Graphic, FBitmap, Cols, Rows, Index);
		1150	if Picture.Graphic is TBitmap then
		1151	if FBitmap.PixelFormat <> pfDevice then
		1152	FBitmap.PixelFormat := TBitmap(Picture.Graphic).PixelFormat;
		1153	FBitmap.TransparentColor := FMaskColor or PaletteMask;
		1154	FBitmap.Transparent := (FMaskColor <> clNone) and Masked;
		1155	Result := FBitmap;
		1156	end;
		1157
		1158	function TDXPictureClip.GetDefaultMaskColor: TColor;
		1159	begin
		1160	Result := clOlive;
		1161	if (Picture.Graphic <> nil) and (Picture.Graphic is TBitmap) then
		1162	Result := TBitmap(Picture.Graphic).TransparentColor and
		1163	not PaletteMask;
		1164	end;
		1165
		1166	function TDXPictureClip.GetHeight: Integer;
		1167	begin
		1168	Result := Picture.Height div FRows;
		1169	end;
		1170
		1171	function TDXPictureClip.GetWidth: Integer;
		1172	begin
		1173	Result := Picture.Width div FCols;
		1174	end;
		1175
		1176	function TDXPictureClip.IsMaskStored: Boolean;
		1177	begin
		1178	Result := MaskColor <> GetDefaultMaskColor;
		1179	end;
		1180
		1181	procedure TDXPictureClip.SetMaskColor(Value: TColor);
		1182	begin
		1183	if Value <> FMaskColor then begin
		1184	FMaskColor := Value;
		1185	Changed;
		1186	end;
		1187	end;
		1188
		1189	procedure TDXPictureClip.PictureChanged(Sender: TObject);
		1190	begin
		1191	FMaskColor := GetDefaultMaskColor;
		1192	if not (csReading in ComponentState) then Changed;
		1193	end;
		1194
		1195	procedure TDXPictureClip.SetHeight(Value: Integer);
		1196	begin
		1197	if (Value > 0) and (Picture.Height div Value > 0) then
		1198	Rows := Picture.Height div Value;
		1199	end;
		1200
		1201	procedure TDXPictureClip.SetWidth(Value: Integer);
		1202	begin
		1203	if (Value > 0) and (Picture.Width div Value > 0) then
		1204	Cols := Picture.Width div Value;
		1205	end;
		1206
		1207	procedure TDXPictureClip.SetPicture(Value: TPicture);
		1208	begin
		1209	FPicture.Assign(Value);
		1210	end;
		1211
		1212	{ Transformations routines }
		1213	{ Authorisation: Mr. Takanori Kawasaki}
		1214
		1215	//Distance between 2 points is calculated
		1216	function Get2PointRange(a,b: TDblPoint):Double;
		1217	var
		1218	x,y: Double;
		1219	begin
		1220	x := a.X - b.X;
		1221	y := a.Y - b.Y;
		1222	Result := Sqrt(xx+yy);
		1223	end;
		1224
		1225	//Direction angle in the coordinate A which was seen from coordinate B is calculated
		1226	function GetARadFromB(A,B: TDblPoint):Double;
		1227	var
		1228	dX,dY: Double;
		1229	begin
		1230	dX := A.X - B.X;
		1231	dY := A.Y - B.Y;
		1232	Result := Get256(dX,dY);
		1233	end;
		1234
		1235	//Direction angle is returned with 0 - 255.
		1236	function Get256(dX,dY:Double):Double;
		1237	begin
		1238	Result := 0;
		1239	if dX > 0 then
		1240	begin//0-63
		1241	if dY > 0 then Result := ArcTan(dY / dX) // 0 < Res < 90
		1242	else//0
		1243	if dY = 0 then Result := 0 // 0
		1244	else//192-255
		1245	if dY < 0 then Result := 2*Pi + ArcTan(dY / dX) // 270 < Res < 360
		1246	end else
		1247	if dX = 0 then
		1248	begin//64
		1249	if dY > 0 then Result := 1 / 2 * Pi // 90
		1250	else//0
		1251	if dY = 0 then Result := 0 // 0
		1252	else//192
		1253	if dY < 0 then Result := 3 / 2 * Pi // 270
		1254	end else
		1255	if dX < 0 then
		1256	begin//64-127
		1257	if dY > 0 then Result := Pi + ArcTan(dY / dX) // 90 < Res < 180
		1258	else//128
		1259	if dY = 0 then Result := Pi // 180
		1260	else//128-191
		1261	if dY < 0 then Result := Pi + ArcTan(dY / dX) // 180 < Res < 270
		1262	end;
		1263	Result := 256 * Result / (2*Pi);
		1264	end;
		1265
		1266	//From the coordinate SP the Range it calculates the point which leaves with the angular Angle
		1267	function GetPointFromRangeAndAngle(SP: TDblPoint; Range,Angle: Double): TDblPoint;
		1268	begin
		1269	Result.X := SP.X + Range * Cos(Angle);
		1270	Result.Y := SP.Y + Range * Sin(Angle);
		1271	end;
		1272
		1273	//* As for coordinate transformation coordinate for mathematics is used
		1274	//Identity matrix for the 2d is returned.
		1275	function Ini2DRowCol: T2DRowCol;
		1276	var
		1277	i,ii:integer;
		1278	begin
		1279	for i := 1 to 3 do
		1280	for ii := 1 to 3 do
		1281	if i = ii then Result[i,ii] := 1 else Result[i,ii] := 0;
		1282	end;
		1283
		1284	//Transformation matrix of the portable quantity
		1285	//where the one for 2d is appointed is returned.
		1286	function Trans2DRowCol(x,y:double):T2DRowCol;
		1287	begin
		1288	Result := Ini2DRowCol;
		1289	Result[3,1] := x;
		1290	Result[3,2] := y;
		1291	end;
		1292
		1293	//Conversion coordinate of the expansion and contraction
		1294	//quantity where the one for 2d is appointed is returned.
		1295	function Scale2DRowCol(x,y:double):T2DRowCol;
		1296	begin
		1297	Result := Ini2DRowCol;
		1298	Result[1,1] := x;
		1299	Result[2,2] := y;
		1300	end;
		1301
		1302	//Coordinate transformation of the rotary quantity
		1303	//where the one for 2d is appointed is returned.
		1304	function Rotate2DRowCol(Theta:double):T2DRowCol;
		1305	begin
		1306	Result := Ini2DRowCol;
		1307	Result[1,1] := Cos256(Trunc(Theta));
		1308	Result[1,2] := Sin256(Trunc(Theta));
		1309	Result[2,1] := -1 * Result[1,2];
		1310	Result[2,2] := Result[1,1];
		1311	end;
		1312
		1313	//You apply two conversion coordinates and adjust.
		1314	function Multiply2DRowCol(A,B:T2DRowCol):T2DRowCol;
		1315	begin
		1316	Result[1,1] := A[1,1] * B[1,1] + A[1,2] * B[2,1];
		1317	Result[1,2] := A[1,1] * B[1,2] + A[1,2] * B[2,2];
		1318	Result[1,3] := 0;
		1319	Result[2,1] := A[2,1] * B[1,1] + A[2,2] * B[2,1];
		1320	Result[2,2] := A[2,1] * B[1,2] + A[2,2] * B[2,2];
		1321	Result[2,3] := 0;
		1322	Result[3,1] := A[3,1] * B[1,1] + A[3,2] * B[2,1] + B[3,1];
		1323	Result[3,2] := A[3,1] * B[1,2] + A[3,2] * B[2,2] + B[3,2];
		1324	Result[3,3] := 1;
		1325	end;
		1326
		1327	//Until coordinate (the X and the Y) comes on the X axis,
		1328	//the conversion coordinate which turns the position
		1329	//of the point is returned.
		1330	function RotateIntoX2DRowCol(x,y: double):T2DRowCol;
		1331	var
		1332	d: double;
		1333	begin
		1334	Result := Ini2DRowCol;
		1335	d := sqrt(xx+yy);
		1336	Result[1,1] := x / d;
		1337	Result[1,2] := y / d;
		1338	Result[2,1] := -1 * Result[1,2];
		1339	Result[2,2] := Result[1,1];
		1340	end;
		1341
		1342	//Coordinate (the X and the Y) as a center, the conversion
		1343	//coordinate which does the scaling of the magnification ratio
		1344	//which is appointed with the Sx and the Sy is returned.
		1345	function ScaleAt2DRowCol(x,y,Sx,Sy:double):T2DRowCol;
		1346	var
		1347	T,S,TInv,M:T2DRowCol;
		1348	begin
		1349	T := Trans2DRowCol(-x,-y);
		1350	TInv := Trans2DRowCol(x,y);
		1351	S := Scale2DRowCol(Sx,Sy);
		1352	M := Multiply2DRowCol(T,S);
		1353	Result := Multiply2DRowCol(M,T);
		1354	end;
		1355
		1356	//Coordinate (the X and the Y) it passes, comes hard and
		1357	//(DX and the dy) with the direction which is shown it
		1358	//returns the transformation matrix which does the reflected
		1359	//image conversion which centers the line which faces.
		1360	function ReflectAcross2DRowCol(x,y,dx,dy:Double): T2DRowCol;
		1361	var
		1362	T,R,S,RInv,TInv,M1,M2,M3: T2DRowCol;
		1363	begin
		1364	T := Trans2DRowCol(-x,-y);
		1365	TInv := Trans2DRowCol(x,y);
		1366	R := RotateIntoX2DRowCol(dx,dy);
		1367	RInv := RotateIntoX2DRowCol(dx,-dy);
		1368	S := Scale2DRowCol(1,-1);
		1369	M1 := Multiply2DRowCol(T,R);
		1370	M2 := Multiply2DRowCol(S,RInv);
		1371	M3 := Multiply2DRowCol(M1,M2);
		1372	Result := Multiply2DRowCol(M3,TInv);
		1373	end;
		1374
		1375	//Coordinate focusing on (the X and the Y) the transformation
		1376	//matrix which turns the position of the point with angle Theta is returned.
		1377	function RotateAround2DRowCol(x,y,Theta:Double): T2DRowCol;
		1378	var
		1379	T,R,TInv,M: T2DRowCol;
		1380	begin
		1381	T := Trans2DRowCol(-x,-y);
		1382	TInv := Trans2DRowCol(x,y);
		1383	R := Rotate2DRowCol(Theta);
		1384	M := Multiply2DRowCol(T,R);
		1385	Result := Multiply2DRowCol(M,TInv);
		1386	end;
		1387
		1388	//Transformation matrix is applied to the point.
		1389	function Apply2DVector(V:T2DVector; M:T2DRowCol): T2DVector;
		1390	begin
		1391	Result[1] := V[1] * M[1,1] + V[2] * M[2,1] + M[3,1];
		1392	Result[2] := V[1] * M[1,2] + V[2] * M[2,2] + M[3,2];
		1393	Result[3] := 1;
		1394	end;
		1395
		1396	//The TDblPoint is returned
		1397	function DblPoint(a,b:Double):TDblPoint;
		1398	begin
		1399	Result.X := a;
		1400	Result.Y := b;
		1401	end;
		1402
		1403	function TruncDblPoint(DblPos: TDblPoint): TPoint;
		1404	begin
		1405	Result.X := Trunc(DblPos.X);
		1406	Result.Y := Trunc(DblPos.Y);
		1407	end;
		1408	{
		1409	+-----------------------------------------------------------------------------+
		1410	\|Collision decision \|
		1411	+-----------------------------------------------------------------------------+}
		1412
		1413	//Point and circle
		1414	function PointInCircle(PPos,CPos: TPoint; R: integer): Boolean;
		1415	begin
		1416	Result := (PPos.X - CPos.X)(PPos.X - CPos.X)+(PPos.Y - CPos.Y)(PPos.Y - CPos.Y)<= R*R;
		1417	end;
		1418
		1419	//Circle and circle
		1420	function CircleInCircle(C1Pos,C2Pos: TPoint; R1,R2:Integer): Boolean;
		1421	begin
		1422	Result := (C1Pos.X - C2Pos.X)(C1Pos.X - C2Pos.X)+(C1Pos.Y - C2Pos.Y)(C1Pos.Y - C2Pos.Y) <= (R1+R2)*(R1+R2);
		1423	end;
		1424
		1425	//Circle and line segment
		1426	function SegmentInCircle(SPos,EPos,CPos: TPoint; R: Integer): Boolean;
		1427	var
		1428	V,C: TPoint;
		1429	VC,VV,CC:integer;
		1430	begin
		1431	Result := False;
		1432	V.X := EPos.X - SPos.X; V.Y := EPos.Y - SPos.Y;
		1433	C.X := CPos.X - SPos.X; C.Y := CPos.Y - SPos.Y;
		1434	VC := V.X * C.X + V.Y * C.Y;
		1435	if VC < 0 then
		1436	begin
		1437	Result := (C.X * C.X + C.Y * C.Y) <= R*R;
		1438	end
		1439	else
		1440	begin
		1441	VV := V.X * V.X + V.Y * V.Y;
		1442	if VC >= VV then
		1443	begin
		1444	Result := (EPos.X - CPos.X)(EPos.X - CPos.X)+(EPos.Y - CPos.Y)(EPos.Y - CPos.Y) <= R * R;
		1445	end
		1446	else
		1447	if VC < VV then
		1448	begin
		1449	CC := C.X * C.X + C.Y * C.Y;
		1450	Result := CC - (VC div VV)* VC <= R*R;
		1451	end;
		1452	end;
		1453	end;
		1454
		1455	//Angle recalc
		1456	function Angle256(Angle: Single): Single;
		1457	begin
		1458	Result := Angle;
		1459	While Result < 0 do Result := Result + 256;
		1460	While Result >= 256 do Result := Result -256;
		1461	end;
		1462
		1463	//If A is closer than B from starting point S, the True is returned.
		1464	function CheckNearAThanB(S,A,B: TDblPoint): Boolean;
		1465	begin
		1466	Result := (S.X-A.X)(S.X-A.X)+(S.Y-A.Y)(S.Y-A.Y) <= (S.X-B.X)(S.X-B.X)+(S.Y-B.Y)(S.Y-B.Y);
		1467	end;
		1468
		1469	function CircumCenter3Pt(const x1, y1, x2, y2, x3, y3: Single; out Px, Py: Single): Boolean;
		1470	var
		1471	A,B,C,D,E,F,G: Single;
		1472	begin
		1473	A := x2 - x1;
		1474	B := y2 - y1;
		1475	C := x3 - x1;
		1476	D := y3 - y1;
		1477	E := A * (x1 + x2) + B * (y1 + y2);
		1478	F := C * (x1 + x3) + D * (y1 + y3);
		1479	G := 2.0 * (A * (y3 - y2) - B * (x3 - x2));
		1480	Result := G <> 0.0;
		1481	if Result then begin
		1482	Px := (D * E - B * F) / G;
		1483	Py := (A * F - C * E) / G;
		1484	end;
		1485	end;
		1486
		1487	function Distance(const x1, y1, x2, y2: Double): Double;
		1488	begin
		1489	Result := Sqrt(Sqr(y2 - y1) + Sqr(x2 - x1));
		1490	end;
		1491
		1492	procedure InCenter(const x1, y1, x2, y2, x3, y3: Double; out Px, Py: Double);
		1493	var
		1494	Perim: Double;
		1495	Side12: Double;
		1496	Side23: Double;
		1497	Side31: Double;
		1498	begin
		1499	Side12 := Distance(x1, y1, x2, y2);
		1500	Side23 := Distance(x2, y2, x3, y3);
		1501	Side31 := Distance(x3, y3, x1, y1);
		1502	{ Using Heron's S=UR }
		1503	Perim := 1.0 / (Side12 + Side23 + Side31);
		1504	Px := (Side23 * x1 + Side31 * x2 + Side12 * x3) * Perim;
		1505	Py := (Side23 * y1 + Side31 * y2 + Side12 * y3) * Perim;
		1506	end;
		1507
		1508	function PointInTriangle(const Px, Py, x1, y1, x2, y2, x3, y3: Double): Boolean;
		1509	function Orientation(const x1, y1, x2, y2, Px, Py: Double): Integer;
		1510	var
		1511	Orin: Double;
		1512	begin
		1513	(* Linear determinant of the 3 points *)
		1514	Orin := (x2 - x1) * (py - y1) - (px - x1) * (y2 - y1);
		1515
		1516	if Orin > 0.0 then
		1517	Result := +1 (* Orientaion is to the right-hand side *)
		1518	else if Orin < 0.0 then
		1519	Result := -1 (* Orientaion is to the left-hand side *)
		1520	else
		1521	Result := 0; (* Orientaion is neutral aka collinear *)
		1522	end;
		1523	var
		1524	Or1, Or2, Or3: Integer;
		1525	begin
		1526	Or1 := Orientation(x1, y1, x2, y2, Px, Py);
		1527	Or2 := Orientation(x2, y2, x3, y3, Px, Py);
		1528	Or3 := Orientation(x3, y3, x1, y1, Px, Py);
		1529
		1530	if (Or1 = Or2) and (Or2 = Or3) then
		1531	Result := True
		1532	else if Or1 = 0 then
		1533	Result := (Or2 = 0) or (Or3 = 0)
		1534	else if Or2 = 0 then
		1535	Result := (Or1 = 0) or (Or3 = 0)
		1536	else if Or3 = 0 then
		1537	Result := (Or2 = 0) or (Or1 = 0)
		1538	else
		1539	Result := False;
		1540	end;
		1541
		1542	procedure Log(const Co: string; const FName: string);
		1543	var F: Text; D: TDateTime;
		1544	Hour, Minute, Second, MSec: Word;
		1545	begin
		1546	AsSignFile(F, FName);
		1547	if FileExists(FName) then Append(F)
		1548	else ReWrite(F);
		1549	try
		1550	D := Now;
		1551	DecodeTime(D, Hour, Minute, Second, MSec);
		1552	WriteLn(F, DateToStr(D) + ' ' + IntToStr(Hour)+':'+IntToStr(Minute)+':'+IntToStr(Second)+ '.'+IntToStr(MSec) +' ' + Co);
		1553	finally
		1554	CloseFile(F);
		1555	end;
		1556	end;
		1557
		1558	{$IFDEF _DMO_}
		1559
		1560	{ TDirectXDriverEx }
		1561
		1562	function TDirectXDriverEx.ConvertHMonitor(iMonitor: HMonitor): TMonitorInfo;
		1563	begin
		1564	ZeroMemory(@Result, sizeof(Result));
		1565	Result.cbSize := SizeOf(Result);
		1566	MultiMon.GetMonitorInfo(iMonitor, @Result);
		1567	end;
		1568
		1569	function TDirectXDriverEx.GetFlags: DWORD;
		1570	begin
		1571	Result := ConvertHMonitor(FMonitor).dwFlags;
		1572	end;
		1573
		1574	function TDirectXDriverEx.GetMonitorInfo: TMonitorInfo;
		1575	begin
		1576	Result:= ConvertHMonitor(FMonitor);
		1577	end;
		1578
		1579	function TDirectXDriverEx.GetTempSpace: TRect;
		1580	begin
		1581	Result := ConvertHMonitor(FMonitor).rcWork
		1582	end;
		1583
		1584	function TDirectXDriverEx.GetWorkSpace: TRect;
		1585	begin
		1586	Result := ConvertHMonitor(FMonitor).rcMonitor
		1587	end;
		1588
		1589	procedure TDirectXDriverEx.SetGUID(Value: PGUID);
		1590	begin
		1591	if not IsBadHugeReadPtr(Value, SizeOf(TGUID)) then
		1592	begin
		1593	FGUID2 := Value^;
		1594	FGUID := @FGUID2;
		1595	end else
		1596	FGUID := Value;
		1597	end;
		1598
		1599	{ TDirectXDriversEx }
		1600
		1601	constructor TDirectXDriversEx.Create;
		1602	begin
		1603	inherited Create(TDirectXDriverEx);
		1604	end;
		1605
		1606	function TDirectXDriversEx.GetDriver(Index: Integer): TDirectXDriverEx;
		1607	begin
		1608	Result := (inherited Items[Index]) as TDirectXDriverEx;
		1609	end;
		1610
		1611	{$ENDIF}
		1612
1	daniel-mar	1613	initialization
		1614	InitCosinTable;
		1615	finalization
		1616	FreeLibList;
4	daniel-mar	1617	end.

Subversion Repositories spacemission

spacemission/VCL_DELPHIX_D6/DXClass.pas – Rev 4