Subversion Repositories spacemission

Compare Revisions

No changes between revisions

Regard whitespace Rev 3 → Rev 4

/VCL_DELPHIX_D6/DXReg_original.pas
File deleted
/VCL_DELPHIX_D6/DirectX.txt
File deleted
/VCL_DELPHIX_D6/Wave.pas
File deleted
/VCL_DELPHIX_D6/DXTexImg.pas
File deleted
/VCL_DELPHIX_D6/Colli3DX.dcr
Cannot display: file marked as a binary type.
svn:mime-type = application/octet-stream
Property changes:
Added: svn:mime-type
+application/octet-stream
\ No newline at end of property
/VCL_DELPHIX_D6/Colli3DX.pas
0,0 → 1,2383
unit colli3DX;
 
{$include DelphiXcfg.inc}
 
 
//*************************************************************************
//* *
//* TCollisionTester3DX vs 1.3 *
//* *
//*************************************************************************
//
// This Delphi 4, 5, 6 component is CopyRight:
//
// Henrik Fabricius, August 1999, March 2000, June 2002
// http://users.cybercity.dk/~bbl6194/delphi3dx.htm
// E-mail: henrik_og_bodil@vip.cybercity.dk
//
// You may use this component for free on the following conditions:
// 1) this text must remain part of the unit.
// 2) Any proposals for changes or improvements should be addressed directly to
// the copyright owner Henrik Fabricius
// 3) The use of this component is on your own risk. The software is provided
// as is without any garanties and warranty. The CopyRight Owner is not
// responsible for any damage or losses of any kind caused by the use of this
// software or the software it is intended to be used with.
//
// To place a link for down-loads of this component on your homepage
// please place a link to the Delphi3DX page where the latest version
// is available.
//
// To use this component you must have
// 1) Delphi 4, 5 or 6
// 2) MS-DirectX 6.0 or higher
// 3) the DelphiX components from Hori in Japan
//
// MS-DirectX is a trademark of the Microsoft Corporation
// Delphi 4, 5 and 6 is a trademark of the Inprise Corporation
//
// Use this component to check for collisions between 3D objects in
// Direct3D games.
// Place your 3D-objects in a world described by :
// - DXDrawUsed -
//
// Group the 3D-objects in series with different material
// or functional properties
// The 3D-object series are named by the property:
// - Indexof3DSeries -
// 3D-objects are named by the property :
// - Indexof3Dobject -
// A 3D-object consist of one or more 3D-elements named by the property :
// - Indexof3DElement -
//
// Surround each of your 3D elements by at least one collision object
// which must be a member of the following primitives :
// - box3D - sphere3D - ellipsoid3D - cylinder3D - conus3D -
// available CollOrientations are :
// - Symmetric_X - Symmetric_Y - Symmetric_Z -
// available material properties are :
// - solid3D - water3D - air3D
// the size of the small end of the conus is described by the property
// - PercentLeftatTop -
// a negative value means that the top is downwards
// available functional properties are :
// - Pickable - Shootable - Fixed3DObject
// Add each object by specifying :
// - FrameSeries - NextAddMesh - CoverWholeMesh -
// - IndexOf3DSeries - IndexOf3DObject - IndexOf3DElement -
// if coverWholeMesh is false then specify a box containing the part of the
// 3D object which should be covered by the coll object by the commands
// - BoxPartMin(x,y,z) - BoxPartMax(x,y,z) -
// Finally add the collision object by executing the command
// - AddCollisionObject -
//
// Bullets are described by the following properties :
// - BulletRadius - BulletRange - BulletFrame - LongShots -
// LongShots moves with a unlimited speed reaching the objects immediately
//
// The actor is described by :
// - FrontDistance - HeadRadius -
//
// The camera-frame and the bullet-frames move each time the move command
// is used in the main program.
// Execute the following commands prior to each move command :
// - GetOldEyePos - GetOldBulletPos -
// The collisionTester needs this information to test for a possible collision
// in between the starting and the ending points of the Eye/bullet
//
// Test for collision with the following function calls :
// - if CollisionTester3DX1.Collision then ..
// - if CollisionTester3DX1.BulletCollision then ..
// On collision read the HitLinkNr and the properties of the collision object
//
// Destroy 3D collisionObjects by specifying :
// - NextDestroyNr - IndexOf3DSeries -
// and the executing command DestroyCollisionObject
//
// Initialize the collisionTester with the command :
// - CollisionTester3DX1.ZeroSetIt -
// This must always be done when DXDraw is initialized
//
// To install the component:
// 1) place this unit and the dcr file in the same directory as DelphiX
// 2) In Delphi you must click on Component - Install Component
// 3) Select the colli3DX.pas file and choose the Samples package to install it
// 4) Rebuild the library
// 5) Look for a new icon with a bomb on the page named DelphiX
//
// Tutorial programs are available for down-load at
// http://users.cybercity.dk/~bbl6194/delphi3dx.htm
//
// Good Luck
// Henrik Fabricius
//
//
//****************************************************************************
 
 
 
interface
 
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, DXClass, DXDraws,
{$IfDef StandardDX}
DirectDraw, Direct3D, Direct3DRM;
{$Else}
DirectX;
{$EndIf}
 
Type
Tshapes3D = (box3D, sphere3D, ellipsoid3D, cylinder3D, conus3D);
Tmaterials3D = (solid3D, water3D, air3D);
TOrientation3D = (symmetric_x, symmetric_y, symmetric_z);
TFrames3D = Array of Array of IDirect3DRMFrame;
 
TCollisionTester3DX = class(TComponent)
private
{private declarations}
FDXDrawUsed : TDXDraw;
FFrameSeries : TFrames3D;
FNextAddMesh : IDirect3DRMMesh;
FBulletFrame : IDirect3DRMFrame;
FBoxPartMin : TD3DVector;
FBoxPartMax : TD3DVector;
FOldBulletPosition: TD3DVector;
FOldEyePosition : TD3DVector;
 
FNrOfSeries : integer;
FSeriesIndex : integer;
FSeriesNr : integer;
FOrientation3D : TOrientation3D;
Fshape3D : Tshapes3D;
Fmaterial3D : Tmaterials3D;
FPercentLeftAtTop : integer;
Fbullet_hitLinknr : integer;
FIndexOf3DObject : integer;
FIndexOf3DElement : integer;
FNextDestroyNr : integer;
FNextAllOfMesh : Boolean;
FFrontDistance : integer;
FBulletRange : integer;
FBulletRadius : integer;
FHeadRadius : integer;
FFixed3DObject : Boolean;
FShootable : Boolean;
FLongShots : Boolean;
FPickable : Boolean;
FCheckAllCollObj : Boolean;
 
Fcoll_Nr_Objects : Array of integer;
FSeriesIndex_for_SeriesNr : Array of integer;
 
FNrinFrameSeries : Array of Array of integer;
Fcoll_orientation : Array of Array of TOrientation3D;
Fcoll_shape : Array of Array of Tshapes3D;
Fcoll_material : Array of Array of Tmaterials3D;
Fcoll_box_min : Array of Array of TD3DVector;
Fcoll_box_max : Array of Array of TD3DVector;
Fcoll_radius : Array of Array of TD3DValue;
Fcoll_frac_at_top : Array of Array of TD3DValue;
Fcoll_shootable : Array of Array of boolean;
Fcoll_Pickable : Array of Array of boolean;
Fcoll_Fixed3D : Array of Array of boolean;
Fcoll_objectNr : Array of Array of integer;
 
procedure SetOrientation3D(Value : TOrientation3D);
procedure SetShape3D(Value: TShapes3D);
procedure SetMaterial3D(Value: Tmaterials3D);
procedure SetPercentLeftatTop(Value: integer);
procedure SetIndexOf3DObject(Value : integer);
procedure SetIndexOf3DElement(Value : integer);
procedure SetIndexOf3DSeries(Value : integer);
procedure SetNextDestroyNr(Value : Integer);
procedure SetBulletRadius(Value : Integer);
procedure SetHeadRadius(Value : Integer);
procedure SetFrontDistance(Value : Integer);
procedure SetBulletRange(Value : Integer);
function add_space_for_one_more : boolean;
procedure GetTheBox;
procedure AddBox;
procedure AddSphere;
procedure AddCylinder;
procedure AddConus;
procedure AddEllipsoid;
 
procedure MakeNewSeries;
procedure Destroy_empty_series(SeriesNr : integer);
function GetSeriesNr(Nr : integer): integer;
procedure remove_collision_object(seriesNr, Value : integer);
function CheckForSeriesIndex(indexnow : integer): boolean;
procedure ListDataForCollObject;
function coll_test_box(coll_nr : byte;
old_attacker_position, attacker_position : TD3DVector;
bullet_radius : TD3DValue; longshot : boolean): boolean;
function coll_test_cylinder(coll_nr : byte;
old_attacker_position, attacker_position : TD3DVector;
bullet_radius : TD3DValue; longshot : boolean): boolean;
function coll_test_sphere(coll_nr : byte;
old_attacker_position,
attacker_position : TD3DVector;
bullet_radius : TD3Dvalue; longshot : boolean): boolean;
function coll_test_ellipsoid(coll_nr : byte;
old_attacker_position, attacker_position : TD3DVector;
bullet_radius : TD3DValue; longshot : boolean): boolean;
function coll_test_conus(coll_nr : byte;
old_attacker_position, attacker_position : TD3DVector;
bullet_radius : TD3DValue; longshot : boolean): boolean;
 
protected
 
public
Constructor Create(AOwner : TComponent); override;
destructor Destroy; override;
 
property DXDrawUsed : TDXDraw write FDXDrawUsed stored false;
property FrameSeries : TFrames3D write FFrameSeries stored false;
property NextAddMesh : IDirect3DRMMesh write FNextAddMesh stored false;
property BulletFrame : IDirect3DRMFrame write FBulletFrame stored false;
 
procedure ZeroSetIt;
procedure BoxPartMin(xval, yval, zval: TD3DValue);
procedure BoxPartMax(xval, yval, zval: TD3DValue);
procedure GetOldBulletPos;
procedure GetOldEyePos;
 
function HitLinkNr: integer;
function DestroyCollisionObject: boolean;
procedure AddCollisionObject;
function Collision: boolean;
function Bulletcollision: boolean;
function BulletDead : boolean;
 
 
published
 
property BulletRadius : Integer read FBulletRadius write SetBulletRadius
default 0;
property BulletRange : Integer read FbulletRange write SetBulletRange
Default 100;
property CollisionCheckAll: Boolean read FCheckAllCollObj
write FCheckAllCollObj Default true;
property CollOrientation : TOrientation3D read FOrientation3D
write SetOrientation3D default symmetric_y;
property CollObjectType : Tshapes3D read Fshape3D write SetShape3D
default box3D;
property CollObjMaterial : Tmaterials3D read Fmaterial3D write SetMaterial3D
default solid3D;
property CoverWholeMesh : boolean read FNextAllOfMesh
write FNextAllOfMesh default true;
Property Fixed3DObject : boolean read FFixed3DObject
write FFixed3DObject default true;
property FrontDistance : Integer read FFrontDistance
write SetFrontDistance default 0;
property HeadRadius : integer read FHeadRadius write SetHeadRadius
default 0;
property IndexOf3DSeries : integer read FSeriesIndex
write SetIndexOf3DSeries default 0;
property IndexOf3DObject : integer read FIndexOf3DObject
write SetIndexOf3DObject default 0;
property IndexOf3DElement : integer read FIndexOf3DElement
write SetIndexOf3DElement default 0;
property NextDestroyNr : Integer read FNextDestroyNr
write SetNextDestroyNr default 0;
Property PercentLeftAtTop : integer read FPercentLeftAtTop
write SetPercentLeftAtTop default 0;
Property Pickable : Boolean read FPickable write FPickable
default false;
Property Shootable : boolean read FShootable write FShootable
Default false;
Property LongShots : boolean read FLongShots write FLongShots
Default false;
 
 
end; //end of Class
 
 
 
//Registering of the Component
Procedure Register;
 
 
implementation
 
 
 
procedure Register;
begin
//Register the component together with the DelphiX components from Hori
RegisterComponents('DelphiX', [TCollisionTester3DX]);
end; //end of Register
 
 
constructor TCollisionTester3DX.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
//The constructor always clears the storage it allocates for a new object
//Hence there is no need to initialize fields except to nonzero or nonempty
//values
FDXDrawUsed := nil;
FFrameSeries := nil;
FNextAddMesh := nil;
FBulletFrame := nil;
 
FOrientation3D := symmetric_y;
FShape3D := box3D;
FMaterial3D := solid3D;
FBulletRange := 100;
FNrOfSeries := 0;
setlength(FSeriesIndex_for_SeriesNr, 0);
setlength(FColl_nr_objects, 0);
setlength(FNrinFrameSeries, 0);
setlength(Fcoll_shape, 0);
setlength(Fcoll_box_min, 0);
setlength(Fcoll_box_max, 0);
setlength(Fcoll_radius, 0);
setlength(Fcoll_frac_at_top, 0);
setlength(Fcoll_objectnr, 0);
setlength(Fcoll_shootable, 0);
setlength(Fcoll_pickable, 0);
setlength(Fcoll_orientation, 0);
setlength(Fcoll_material, 0);
setlength(Fcoll_Fixed3D, 0);
 
end; //end of creation
 
 
 
 
 
 
 
destructor TCollisionTester3DX.Destroy;
begin
//destroy any embedded objects and free resources allocated by the objects
FnrinFrameSeries := nil;
Fcoll_shape := nil;
Fcoll_box_min := nil;
Fcoll_box_max := nil;
Fcoll_radius := nil;
Fcoll_frac_at_top := nil;
Fcoll_objectnr := nil;
Fcoll_shootable := nil;
Fcoll_pickable := nil;
Fcoll_orientation := nil;
Fcoll_material := nil;
Fcoll_Fixed3D := nil;
FSeriesIndex_for_SeriesNr := nil;
Fcoll_nr_objects := nil;
 
inherited Destroy;
end; //end of Destroy
 
 
 
 
procedure TCollisionTester3DX.ZeroSetIt;
begin
//initialises the dynamic arrays
FnrinFrameSeries := nil;
Fcoll_shape := nil;
Fcoll_box_min := nil;
Fcoll_box_max := nil;
Fcoll_radius := nil;
Fcoll_frac_at_top := nil;
Fcoll_objectnr := nil;
Fcoll_shootable := nil;
Fcoll_pickable := nil;
Fcoll_orientation := nil;
Fcoll_material := nil;
Fcoll_Fixed3D := nil;
FSeriesIndex_for_SeriesNr := nil;
Fcoll_nr_objects := nil;
 
FDXDrawUsed := nil;
FFrameSeries := nil;
FNextAddMesh := nil;
FBulletFrame := nil;
 
FOrientation3D := symmetric_y;
FShape3D := box3D;
FMaterial3D := solid3D;
FBulletRange := 100;
FNrOfSeries := 0;
setlength(FSeriesIndex_for_SeriesNr, 0);
setlength(FColl_nr_objects, 0);
setlength(FNrinFrameSeries, 0);
setlength(Fcoll_shape, 0);
setlength(Fcoll_box_min, 0);
setlength(Fcoll_box_max, 0);
setlength(Fcoll_radius, 0);
setlength(Fcoll_frac_at_top, 0);
setlength(Fcoll_objectnr, 0);
setlength(Fcoll_shootable, 0);
setlength(Fcoll_pickable, 0);
setlength(Fcoll_orientation, 0);
setlength(Fcoll_material, 0);
setlength(Fcoll_Fixed3D, 0);
 
end; //end of ZeroSetIt
 
 
 
 
function TcollisionTester3DX.HitLinkNr: integer;
begin
result := Fbullet_hitlinknr;
end; //end of HitLinkNr
 
 
 
procedure TCollisionTester3DX.ListDataForCollObject;
var
Nr : integer;
begin
Nr := FBullet_HitLinkNr;
 
CollObjectType := Fcoll_shape[FSeriesNr, Nr];
CollObjMaterial := Fcoll_material[FSeriesNr, Nr];
Fixed3DObject := Fcoll_Fixed3D[FSeriesNr, Nr];
CollOrientation := Fcoll_orientation[FSeriesNr, Nr];
IndexOf3DObject := Fcoll_objectNr[FSeriesNr, Nr];
IndexOf3DSeries := FSeriesIndex;
IndexOf3DElement := FNrinFrameSeries[FSeriesNr, Nr];
Pickable := Fcoll_pickable[FSeriesNr, Nr];
Shootable := Fcoll_shootable[FseriesNr, Nr];
 
end; //end of ListDataForCollObject
 
 
 
 
procedure TcollisionTester3DX.SetPercentLeftAtTop(Value : Integer);
begin
//value can not be negative
if (FPercentLeftAtTop <> Value) and (Value >= 0)
then
FPercentLeftAtTop := value;
end; //end of SetPercentLeftAtTop
 
 
 
 
procedure TcollisionTester3DX.SetOrientation3D(Value : TOrientation3D);
begin
if FOrientation3D <> Value
then
FOrientation3D := Value;
end; //end setorientation3D
 
 
procedure TcollisionTester3DX.SetShape3D(Value : Tshapes3D);
begin
if Fshape3D <> Value
then
Fshape3D := Value;
end; //end setshapes3D
 
 
 
procedure TcollisionTester3DX.SetMaterial3D(Value : Tmaterials3D);
begin
if Fmaterial3D <> Value
then
Fmaterial3D := Value;
end; //end setshapes3D
 
 
 
procedure TCollisionTester3DX.SetIndexOf3DObject(Value : integer);
begin
//Index can not be negative
if (FIndexOf3DObject <> Value) and (Value >= 0)
then
FIndexOf3DObject := value;
end; //end setIndexOf3DObject
 
 
procedure TCollisionTester3DX.SetIndexOf3DElement(Value : integer);
begin
//Index can not be negative
if (FIndexOf3DElement <> Value) and (Value >= 0)
then
FIndexOf3DElement := value;
end; //end setIndexOf3DElement
 
 
 
procedure TCollisionTester3DX.SetIndexOf3DSeries(Value : integer);
begin
//Index can not be negative
if (FSeriesIndex <> Value) and (Value >= 0)
then
FSeriesIndex := value;
end; //end of SetIndexOf3DSeries
 
 
 
 
procedure TCollisionTester3DX.SetNextDestroyNr(Value : integer);
begin
//Index can not be negative
if (FNextDestroyNr <> Value) and (Value >= 0)
then
FNextDestroyNr := value;
end; //end of SetNextDestroyNr
 
 
 
 
procedure TCollisionTester3DX.SetBulletRadius(Value : Integer);
begin
//Radius can not be negative
if (FBulletRadius <> Value) and (Value >= 0)
then
FBulletRadius := value;
end; //end of SetBulletRadius
 
 
 
procedure TCollisionTester3DX.SetHeadRadius(Value : Integer);
begin
//Radius can not be negative
if (FHeadRadius <> Value) and (Value >= 0)
then
FHeadRadius := value;
end; //end of SetHeadRadius
 
 
 
 
procedure TCollisionTester3DX.SetFrontDistance(Value : Integer);
begin
//FrontDistance can not be negative
if (FFrontDistance <> Value) and (Value >= 0)
then
FFrontDistance := value;
end; //end of SetFrontDistance
 
 
 
 
procedure TCollisionTester3DX.SetBulletRange(Value : Integer);
begin
//BulletRange can not be negative
if (FBulletRange <> Value) and (Value >= 0)
then
FBulletRange := value;
end; //end of SetBulletRange
 
 
 
 
function TcollisionTester3DX.Add_Space_For_One_More: boolean;
var
NewNr : integer;
begin
//add space for one more element in the present series
 
//length of Fcoll_nr_objects and FSeries_nIndex_for_SeriesNr are unchanged
NewNr := Fcoll_nr_objects[FseriesNr] + 1;
 
result := true;
 
try
SetLength(FNrinFrameSeries[FSeriesNr], NewNr);
SetLength(Fcoll_shape[FSeriesNr], NewNr);
SetLength(Fcoll_box_min[FSeriesNr], NewNr);
SetLength(Fcoll_box_max[FSeriesNr], NewNr);
SetLength(Fcoll_radius[FSeriesNr], NewNr);
SetLength(Fcoll_frac_at_top[FSeriesNr], NewNr);
SetLength(Fcoll_objectnr[FSeriesNr], NewNr);
SetLength(Fcoll_shootable[FSeriesNr], NewNr);
SetLength(Fcoll_pickable[FSeriesNr], NewNr);
SetLength(Fcoll_orientation[FSeriesNr], NewNr);
SetLength(Fcoll_material[FSeriesNr], NewNr);
SetLength(Fcoll_Fixed3D[FSeriesNr], NewNr);
 
except
on EOutOfMemory do
begin
//There is not enough memory available. Free some memory
dec(NewNr);
 
copy(FNrinFrameSeries[FseriesNr], 0, NewNr);
copy(Fcoll_shape[FseriesNr], 0, NewNr);
copy(Fcoll_box_min[FSeriesNr], 0, NewNr);
copy(Fcoll_box_max[FSeriesNr], 0, NewNr);
copy(Fcoll_radius[FSeriesNr], 0, NewNr);
copy(Fcoll_frac_at_top[FSeriesNr], 0, NewNr);
copy(Fcoll_objectnr[FSeriesNr], 0, NewNr);
copy(Fcoll_shootable[FSeriesNr], 0, NewNr);
copy(Fcoll_pickable[FSeriesNr], 0, NewNr);
copy(Fcoll_orientation[FSeriesNr], 0, NewNr);
copy(Fcoll_material[FSeriesNr], 0, NewNr);
copy(Fcoll_Fixed3D[FSeriesNr], 0, NewNr);
 
result := false;
end;
end;
 
//update count of objects in series
Fcoll_nr_objects[FseriesNr] := NewNr;
 
end; //end of Add_Space_For_One_More
 
 
 
 
procedure TcollisionTester3DX.MakeNewSeries;
begin
inc(FNrOfSeries);
 
SetLength(FSeriesIndex_for_SeriesNr, FNrOfSeries);
FSeriesIndex_for_SeriesNr[FNrOfSeries-1] := FSeriesIndex;
 
SetLength(Fcoll_nr_objects, FNrOfSeries);
Fcoll_nr_objects[FNrOfSeries-1] := 0;
 
SetLength(FNrinFrameSeries, FNrOfSeries);
SetLength(Fcoll_shape, FNrOfSeries);
SetLength(Fcoll_box_min, FNrOfSeries);
SetLength(Fcoll_box_max, FNrOfSeries);
SetLength(Fcoll_radius, FNrOfSeries);
SetLength(Fcoll_frac_at_top, FNrOfSeries);
SetLength(Fcoll_objectnr, FNrOfSeries);
SetLength(Fcoll_shootable, FNrOfSeries);
SetLength(Fcoll_pickable, FNrOfSeries);
SetLength(Fcoll_orientation, FNrOfSeries);
SetLength(Fcoll_material, FNrOfSeries);
SetLength(Fcoll_Fixed3D, FNrOfSeries);
end; //end of MakeNewSeries
 
 
 
 
procedure TcollisionTester3DX.Destroy_Empty_Series(SeriesNr : integer);
var
i, j : integer;
begin
if seriesNr < (FNrOfSeries - 1)
then
begin
for i := SeriesNr to (FNrOfSeries - 2) do
begin
FSeriesIndex_for_SeriesNr[i] := FSeriesIndex_for_SeriesNr[i+1];
 
SetLength(FNrinFrameSeries[i], Fcoll_Nr_objects[i+1]);
for j := 0 to (Fcoll_Nr_objects[i+1] - 1) do
FNrinFrameSeries[i, j] := FNrinFrameSeries[(i+1), j];
 
SetLength(Fcoll_shape[i], Fcoll_Nr_objects[i+1]);
for j := 0 to (Fcoll_Nr_objects[i+1] - 1) do
Fcoll_shape[i, j] := Fcoll_shape[(i+1), j];
 
SetLength(Fcoll_box_min[i], Fcoll_Nr_objects[i+1]);
for j := 0 to (Fcoll_Nr_objects[i+1] - 1) do
Fcoll_box_min[i, j] := Fcoll_box_min[(i+1), j];
 
SetLength(Fcoll_box_max[i], Fcoll_Nr_objects[i+1]);
for j := 0 to (Fcoll_Nr_objects[i+1] - 1) do
Fcoll_box_max[i, j] := Fcoll_box_max[(i+1), j];
 
SetLength(Fcoll_radius[i], Fcoll_Nr_objects[i+1]);
for j := 0 to (Fcoll_Nr_objects[i+1] - 1) do
Fcoll_radius[i, j] := Fcoll_radius[(i+1), j];
 
SetLength(Fcoll_frac_at_top[i], Fcoll_Nr_objects[i+1]);
for j := 0 to (Fcoll_Nr_objects[i+1] - 1) do
Fcoll_frac_at_top[i, j] := Fcoll_frac_at_top[(i+1), j];
 
SetLength(Fcoll_objectnr[i], Fcoll_Nr_objects[i+1]);
for j := 0 to (Fcoll_Nr_objects[i+1] - 1) do
Fcoll_objectNr[i, j] := Fcoll_objectNr[(i+1), j];
 
SetLength(Fcoll_shootable[i], Fcoll_Nr_objects[i+1]);
for j := 0 to (Fcoll_Nr_objects[i+1] - 1) do
Fcoll_shootable[i, j] := Fcoll_shootable[(i+1), j];
 
SetLength(Fcoll_pickable[i], Fcoll_Nr_objects[i+1]);
for j := 0 to (Fcoll_Nr_objects[i+1] - 1) do
Fcoll_pickable[i, j] := Fcoll_pickable[(i+1), j];
 
SetLength(Fcoll_orientation[i], Fcoll_Nr_objects[i+1]);
for j := 0 to (Fcoll_Nr_objects[i+1] - 1) do
Fcoll_orientation[i, j] := Fcoll_orientation[(i+1), j];
 
SetLength(Fcoll_material[i], Fcoll_Nr_objects[i+1]);
for j := 0 to (Fcoll_Nr_objects[i+1] - 1) do
Fcoll_material[i, j] := Fcoll_material[(i+1), j];
 
SetLength(Fcoll_Fixed3D[i], Fcoll_Nr_objects[i+1]);
for j := 0 to (Fcoll_Nr_objects[i+1] - 1) do
Fcoll_Fixed3D[i, j] := Fcoll_Fixed3D[(i+1), j];
 
Fcoll_nr_objects[i] := Fcoll_nr_objects[i+1];
 
end;
end;
 
dec(FNrOfSeries);
 
FSeriesIndex_For_SeriesNr := copy(FSeriesIndex_for_SeriesNr, 0, FNrOfSeries);
Fcoll_Nr_Objects := copy(Fcoll_Nr_Objects, 0, FNrOfSeries);
FNrinFrameSeries := copy(FNrinFrameSeries, 0, FNrOfSeries);
Fcoll_Shape := copy(Fcoll_Shape, 0, FNrOfSeries);
Fcoll_Box_Min := copy(Fcoll_Box_Min, 0, FNrOfSeries);
Fcoll_Box_Max := copy(Fcoll_Box_Max, 0, FNrOfSeries);
Fcoll_Radius := copy(Fcoll_Radius, 0, FNrOfSeries);
Fcoll_Frac_At_Top := copy(Fcoll_Frac_At_Top, 0, FNrOfSeries);
Fcoll_ObjectNr := copy(Fcoll_ObjectNr, 0, FNrOfSeries);
Fcoll_Shootable := copy(Fcoll_Shootable, 0, FNrOfSeries);
Fcoll_Pickable := copy(Fcoll_Pickable, 0, FNrOfSeries);
Fcoll_orientation := copy(Fcoll_orientation, 0, FNrOfSeries);
Fcoll_Material := copy(Fcoll_Material, 0, FNrOfSeries);
Fcoll_Fixed3D := copy(Fcoll_Fixed3D, 0, FNrOfSeries);
end; //end of Destroy_Empty_Series
 
 
 
 
 
 
 
procedure TcollisionTester3DX.Remove_Collision_Object(SeriesNr, Value : integer);
var
i : integer;
begin
//Elements in the series which have a higher index than the one removed
//gets a smaller index which is correct when the main program removes the object
for i := 0 to (FColl_nr_objects[SeriesNr] - 1) do
begin
if FNrinFrameSeries[SeriesNr, i] >= value
then
dec(FNrinFrameSeries[SeriesNr, i]);
end;
 
for i := Value to (Fcoll_nr_objects[SeriesNr] - 2) do
begin
FNrinFrameSeries[SeriesNr, i] := FNrinFrameSeries[SeriesNr, (i+1)];
Fcoll_shape[SeriesNr, i] := Fcoll_shape[SeriesNr, (i+1)];
Fcoll_box_min[SeriesNr, i] := Fcoll_box_min[SeriesNr, (i+1)];
Fcoll_box_max[SeriesNr, i] := Fcoll_box_max[SeriesNr, (i+1)];
Fcoll_radius[seriesNr, i] := Fcoll_radius[SeriesNr, (i+1)];
Fcoll_frac_at_top[SeriesNr, i] := Fcoll_frac_at_top[SeriesNr, (i+1)];
Fcoll_objectnr[SeriesNr, i] := Fcoll_objectnr[SeriesNr, (i+1)];
Fcoll_shootable[SeriesNr, i] := Fcoll_shootable[SeriesNr, (i+1)];
Fcoll_Pickable[SeriesNr, i] := Fcoll_Pickable[SeriesNr, (i+1)];
Fcoll_orientation[SeriesNr, i] := Fcoll_orientation[SeriesNr, (i+1)];
Fcoll_material[SeriesNr, i] := Fcoll_material[SeriesNr, (i+1)];
Fcoll_Fixed3D[SeriesNr, i] := Fcoll_Fixed3D[SeriesNr, (i+1)];
end;
 
dec(Fcoll_nr_objects[SeriesNr]);
 
//remember to reduce the length of Fcoll_frame
FNrinFrameSeries[SeriesNr] := copy(FNrinFrameSeries[SeriesNr], 0,
Fcoll_nr_objects[SeriesNr]);
Fcoll_shape[SeriesNr] := copy(Fcoll_shape[SeriesNr], 0,
Fcoll_nr_objects[SeriesNr]);
Fcoll_box_min[SeriesNr] := copy(Fcoll_box_min[SeriesNr], 0,
Fcoll_nr_objects[SeriesNr]);
Fcoll_box_max[SeriesNr] := copy(Fcoll_box_max[SeriesNr], 0,
Fcoll_nr_objects[SeriesNr]);
Fcoll_radius[SeriesNr] := copy(Fcoll_radius[SeriesNr], 0,
Fcoll_nr_objects[SeriesNr]);
Fcoll_frac_at_top[SeriesNr] := copy(Fcoll_frac_at_top[SeriesNr], 0,
Fcoll_nr_objects[SeriesNr]);
Fcoll_objectnr[SeriesNr] := copy(Fcoll_objectnr[SeriesNr], 0,
Fcoll_nr_objects[SeriesNr]);
Fcoll_shootable[SeriesNr] := copy(Fcoll_shootable[SeriesNr], 0,
Fcoll_nr_objects[SeriesNr]);
Fcoll_pickable[SeriesNr] := copy(Fcoll_pickable[SeriesNr], 0,
Fcoll_nr_objects[SeriesNr]);
Fcoll_material[SeriesNr] := copy(Fcoll_material[SeriesNr], 0,
Fcoll_nr_objects[FSeriesNr]);
Fcoll_orientation[SeriesNr] := copy(Fcoll_orientation[SeriesNr], 0,
Fcoll_nr_objects[FSeriesNr]);
Fcoll_fixed3D[SeriesNr] := copy(Fcoll_fixed3D[SeriesNr], 0,
Fcoll_nr_objects[SeriesNr]);
 
end; //end of Remove_Collision_Object
 
 
 
 
 
 
 
procedure TCollisionTester3DX.GetTheBox;
var
box: TD3DRMBOX;
begin
if FNextAllOfMesh
then
begin
FNextAddMesh.GetBox(box);
FColl_box_min[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := box.min;
FColl_box_max[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := box.max;
end
else
begin
FColl_box_min[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := FBoxPartMin;
FColl_box_max[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := FBoxPartMax;
end;
 
end; //end of GetTheBox
 
 
 
procedure TCollisionTester3DX.BoxPartMin(xval, yval, zval : TD3DValue);
begin
FBoxPartMin.x := xval;
FBoxPartMin.y := yval;
FBoxPartMin.z := zval;
end; //end of BoxPartMin
 
 
 
 
procedure TCollisionTester3DX.BoxPartMax(xval, yval, zval : TD3DValue);
begin
FBoxPartMax.x := xval;
FBoxPartMax.y := yval;
FBoxPartMax.z := zval;
end; //end of BoxPartMax
 
 
 
 
 
procedure TCollisionTester3DX.AddBox;
begin
if add_space_for_one_more
then
begin
GetTheBox;
 
Fcoll_objectnr[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := FIndexOf3DObject;
Fcoll_shape[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := box3D;
FNrinFrameSeries[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := FIndexof3Delement;
Fcoll_radius[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := 0; //not used
Fcoll_frac_at_top[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := 0; //not used
Fcoll_material[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := Fmaterial3D;
Fcoll_orientation[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := Forientation3D;
Fcoll_shootable[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] -1)] := Fshootable;
Fcoll_Pickable[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := Fpickable;
Fcoll_fixed3D[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := FFixed3DObject;
end;
end; //end of AddBox
 
 
 
 
procedure TCollisionTester3DX.AddSphere;
begin
if add_space_for_one_more
then
begin
GetTheBox;
Fcoll_objectnr[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := FIndexOf3DObject;
Fcoll_shape[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := sphere3D;
FNrinFrameSeries[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := FIndexof3Delement;
Fcoll_radius[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] :=
(FColl_box_max[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)].x
- FColl_box_min[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)].x
+ FColl_box_max[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)].y
- FColl_box_min[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)].y
+ FColl_box_max[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)].z
- FColl_box_min[FSeriesNr, (Fcoll_Nr_objects[FseriesNr] - 1)].z)/2/3;
Fcoll_frac_at_top[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := 0; //not used
Fcoll_orientation[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := Forientation3D;
Fcoll_material[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := Fmaterial3D;
Fcoll_shootable[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := Fshootable;
Fcoll_Pickable[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := Fpickable;
Fcoll_fixed3D[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := FFixed3DObject;
end;
 
end; //end of AddSphere
 
 
 
 
 
procedure TCollisionTester3DX.Addcylinder;
begin
//the sphere cowers whole of the 3D-object
if add_space_for_one_more
then
begin
GetTheBox;
 
Fcoll_objectnr[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := FIndexOf3DObject;
Fcoll_shape[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := cylinder3D;
FNrinFrameSeries[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := FIndexof3Delement;
case Forientation3D of
symmetric_x : Fcoll_radius[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] :=
(FColl_box_max[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)].y
- FColl_box_min[FSeriesNr, (Fcoll_Nr_objects[FseriesNr] - 1)].y
+ FColl_box_max[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)].z
- FColl_box_min[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)].z)/2/2;
symmetric_y : Fcoll_radius[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] :=
(FColl_box_max[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)].x
- FColl_box_min[FSeriesNr, (Fcoll_Nr_objects[FseriesNr] - 1)].x
+ FColl_box_max[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)].z
- FColl_box_min[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)].z)/2/2;
symmetric_z : Fcoll_radius[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] :=
(FColl_box_max[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)].x
- FColl_box_min[FSeriesNr, (Fcoll_Nr_objects[FseriesNr] - 1)].x
+ FColl_box_max[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)].y
- FColl_box_min[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)].y)/2/2;
end;
 
Fcoll_frac_at_top[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := 0; //not used
Fcoll_orientation[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := Forientation3D;
Fcoll_material[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := Fmaterial3D;
Fcoll_shootable[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := Fshootable;
Fcoll_Pickable[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := Fpickable;
Fcoll_fixed3D[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := FFixed3DObject;
end;
end; //end of Addcylinder
 
 
 
 
procedure TCollisionTester3DX.Addconus;
begin
//the conus cowers whole of or part of the 3D-object
//fraction_left_at_top = 0 if sharp tip
if add_space_for_one_more
then
begin
GettheBox;
 
Fcoll_objectnr[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := FIndexOf3DObject;
Fcoll_shape[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := conus3D;
FNrinFrameSeries[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := FIndexof3Delement;
Fcoll_radius[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] :=
(FColl_box_max[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)].x
- FColl_box_min[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)].x
+ FColl_box_max[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)].z
- FColl_box_min[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)].z)/2/2;
Fcoll_frac_at_top[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := FPercentLeftAtTop/100;
Fcoll_orientation[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := Forientation3D;
Fcoll_material[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := Fmaterial3D;
Fcoll_shootable[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] -1)] := Fshootable;
Fcoll_Pickable[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := Fpickable;
Fcoll_fixed3D[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := FFixed3DObject;
end;
end; //end of Addconus
 
 
 
 
procedure TCollisionTester3DX.AddEllipsoid;
begin
if add_space_for_one_more
then
begin
GetTheBox;
Fcoll_objectnr[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := FIndexOf3DObject;
Fcoll_shape[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := Ellipsoid3D;
FNrinFrameSeries[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := FIndexof3Delement;
Fcoll_radius[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := 0; //not used
Fcoll_frac_at_top[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := 0; //not used
Fcoll_orientation[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := Forientation3D;
Fcoll_material[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := Fmaterial3D;
Fcoll_shootable[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := Fshootable;
Fcoll_Pickable[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := Fpickable;
Fcoll_fixed3D[FSeriesNr, (Fcoll_Nr_objects[FSeriesNr] - 1)] := FFixed3DObject;
end;
end; //end of AddEllipsoid
 
 
 
 
 
 
 
function TcollisionTester3DX.GetSeriesNr(Nr : integer): integer;
var
NrNow, i : integer;
begin
 
if FNrOfSeries = 0
then
NrNow := 0
else
begin
NrNow := -1;
for i := 0 to (FNrOfSeries - 1) do
begin
if Nr = FSeriesIndex_for_SeriesNr[i]
then
NrNow := i;
end;
 
if NrNow = -1
then
NrNow := FNrOfSeries; //make new series
end;
 
if NrNow = FNrOfSeries
then
MakeNewSeries;
 
 
result := NrNow;
 
 
end; //end of GetSeriesNr
 
 
 
 
 
function TcollisionTester3DX.CheckForSeriesIndex(indexnow : integer): boolean;
var
i : integer;
begin
 
if FNrOfSeries = 0
then
result := false
else
begin
FSeriesNr := -1;
for i := 0 to (FNrOfSeries - 1) do
begin
if indexnow = FSeriesIndex_for_SeriesNr[i]
then
FSeriesNr := i;
end;
 
result := (FSeriesNr <> -1);
end;
 
end; //end of CheckForSeriesIndex
 
 
 
 
 
procedure TcollisionTester3DX.AddCollisionObject;
begin
FSeriesNr := GetSeriesNr(FSeriesIndex);
 
case Fshape3D of
box3D : AddBox;
sphere3D : AddSphere;
cylinder3D : AddCylinder;
ellipsoid3D: AddEllipsoid;
Conus3D : AddConus;
end;
 
end; //end of AddCollisionObject
 
 
 
 
 
function TCollisionTester3DX.DestroyCollisionObject: boolean;
var
test_nr : integer;
begin
//remove all collision objects connected with the 3D-object
//with the index FnextDestroyNr
 
//Check whether series index exists
if CheckForSeriesIndex(FSeriesIndex)
then
begin
//FSeriesNr was found
test_nr := 0;
 
while (test_nr <= (Fcoll_nr_objects[FSeriesNr] - 1)) do
begin
if Fcoll_objectnr[FSeriesNr, test_nr] = FnextDestroyNr
then
remove_collision_object(FSeriesNr, FnextDestroyNr)
else
inc(test_nr);
end; //end of while loop
 
//now we have to decrement all Fcoll_objectnr values larger than object_nr
//because the main program does a similar decrementation when the 3D-object
//is removed
 
if Fcoll_nr_objects[FSeriesNr] > 0
then
begin
//the series is not empty
for test_nr := 0 to (Fcoll_nr_objects[FSeriesNr] - 1) do
begin
if Fcoll_objectnr[FSeriesNr, test_nr] > FNextDestroyNr
then
dec(Fcoll_objectnr[FSeriesNr, test_nr]);
end;
end
else
destroy_empty_Series(FSeriesNr);
 
 
result := true; //collision object was destroyed
 
end //end of CheckForSeriesIndex...
else
result := false; //unable to destroy
 
end; //end of DestroyCollisionObject
 
 
 
 
 
 
function TcollisionTester3DX.coll_test_sphere(coll_nr : byte;
old_attacker_position, attacker_position : TD3DVector;
bullet_radius : TD3DValue; longshot : boolean): boolean;
var
new_eye, old_eye : TD3DVector;
dstep, step, center : TD3DVector;
radius, d0, d1, d2, rod, rod2, t1, t2 : TD3DValue;
begin
result := false;
//Get the coordinates of the old eye_position in the actual coll frame
FFrameSeries[FSeriesIndex, FNrinFrameSeries[FSeriesNr, coll_nr]].InverseTransform
(old_eye, old_attacker_position);
 
//Get the coordinates of the eye_position in the actual coll frame
FFrameSeries[FSeriesIndex, FNrinFrameSeries[FSeriesNr, coll_nr]].InverseTransform
(new_eye, attacker_position);
 
center.x := (Fcoll_box_max[FSeriesNr, coll_nr].x
+ Fcoll_box_min[FSeriesNr, coll_nr].x)/2;
center.y := (Fcoll_box_max[FSeriesNr, coll_nr].y
+ Fcoll_box_min[FSeriesNr, coll_nr].y)/2;
center.z := (Fcoll_box_max[FSeriesNr, coll_nr].z
+ Fcoll_box_min[FSeriesNr, coll_nr].z)/2;
 
//radius of sphere enlarged with the radius of the bullet
//to cover the space where a collision may occure
radius := Fcoll_radius[FSeriesNr, coll_nr] + bullet_radius;
 
//eye to center distance
dstep.x := old_eye.x - center.x;
dstep.y := old_eye.y - center.y;
dstep.z := old_eye.z - center.z;
 
//step in eye position
step.x := new_eye.x - old_eye.x;
step.y := new_eye.y - old_eye.y;
step.z := new_eye.z - old_eye.z;
 
//collision is only possible when something moves
if (abs(step.x) < 1e-3) and (abs(step.y) < 1e-3) and (abs(step.z) < 1e-3)
then
begin
result := false;
exit;
end;
 
 
//factors
d0 := sqr(dstep.x) + sqr(dstep.y) + sqr(dstep.z) - sqr(radius);
d1 := 2 * (step.x * dstep.x + step.y * dstep.y + step.z * dstep.z);
d2 := sqr(step.x) + sqr(step.y) + sqr(step.z);
 
//solving an equation of the second degree
rod := sqr(d1) - 4 * d2 * d0;
 
//d2 is never zero
if rod > 0
then
begin
rod2 := sqrt(rod);
t1 := (-d1 - rod2)/2/d2;
t2 := (-d1 + rod2)/2/d2;
 
// if longshot then look into all future
if longshot
then
result := (t1 >= 0) or (t2 >= 0)
else
begin
//collision in between the starting and the ending point if
result := ((t1 >= 0) and (t1 <= 1))
or ((t2 >= 0) and (t2 <= 1));
end;
end;
 
end; //end of coll_test_sphere
 
 
 
 
function TcollisionTester3DX.coll_test_ellipsoid(coll_nr : byte;
old_attacker_position, attacker_position : TD3DVector;
bullet_radius : TD3DValue; longshot : boolean): boolean;
var
new_eye, old_eye : TD3DVector;
dstep, step, center : TD3DVector;
d0, d1, d2, rod, rod2, t1, t2, a, b, c : TD3DValue;
begin
result := false;
 
//Get the coordinates of the old eye_position in the actual coll frame
FFrameSeries[FSeriesIndex, FNrinFrameSeries[FSeriesNr, coll_nr]].InverseTransform
(old_eye, old_attacker_position);
 
//Get the coordinates of the eye_position in the actual coll frame
FFrameSeries[FSeriesIndex, FNrinFrameSeries[FSeriesNr, coll_nr]].InverseTransform
(new_eye, attacker_position);
 
center.x := (Fcoll_box_max[FSeriesNr, coll_nr].x
+ Fcoll_box_min[FSeriesNr, coll_nr].x)/2;
center.y := (Fcoll_box_max[FSeriesNr, coll_nr].y
+ Fcoll_box_min[FSeriesNr, coll_nr].y)/2;
center.z := (Fcoll_box_max[FSeriesNr, coll_nr].z
+ Fcoll_box_min[FSeriesNr, coll_nr].z)/2;
 
//x, y and z radius of ellipsoid enlarged with the radius of the bullet
//to cover the space where a collision may occure
a := (Fcoll_box_max[FSeriesNr, coll_nr].x
- Fcoll_box_min[FSeriesNr, coll_nr].x)/2 + bullet_radius;
b := (Fcoll_box_max[FSeriesNr, coll_nr].y
- Fcoll_box_min[FSeriesNr, coll_nr].y)/2 + bullet_radius;
c := (Fcoll_box_max[FSeriesNr, coll_nr].z
- Fcoll_box_min[FSeriesNr, coll_nr].z)/2 + bullet_radius;
 
//eye to center distance
dstep.x := old_eye.x - center.x;
dstep.y := old_eye.y - center.y;
dstep.z := old_eye.z - center.z;
 
//step in eye position
step.x := new_eye.x - old_eye.x;
step.y := new_eye.y - old_eye.y;
step.z := new_eye.z - old_eye.z;
 
//collision is only possible when something moves
if (abs(step.x) < 1e-3) and (abs(step.y) < 1e-3) and (abs(step.z) < 1e-3)
then
begin
result := false;
exit;
end;
 
 
//factors
d0 := sqr(b * c * dstep.x) + sqr(a * c * dstep.y) + sqr(a * b * dstep.z)
- sqr(a * b * c);
d1 := 2 * (sqr(b * c) * step.x * dstep.x + sqr(a * c) * step.y * dstep.y
+ sqr(a * b) * step.z * dstep.z);
d2 := sqr(b * c * step.x) + sqr(a * c * step.y) + sqr(a * b * step.z);
 
//solving an equation of the second degree
rod := sqr(d1) - 4 * d2 * d0;
 
//d2 is never zero
if rod > 0
then
begin
rod2 := sqrt(rod);
t1 := (-d1 - rod2)/2/d2;
t2 := (-d1 + rod2)/2/d2;
 
// if longshot then look into all future
if longshot
then
result := (t1 >= 0) or (t2 >= 0)
else
begin
//collision in between the starting and the ending point if
result := ((t1 >= 0) and (t1 <= 1))
or ((t2 >= 0) and (t2 <= 1));
end;
end;
 
end; //end of coll_test_ellipsoid
 
 
 
 
 
function TcollisionTester3DX.coll_test_cylinder(coll_nr : byte;
old_attacker_position, attacker_position : TD3DVector;
bullet_radius : TD3DValue; longshot : boolean): boolean;
var
distance : TD3DValue;
new_eye, old_eye : TD3DVector;
dstep, step, center : TD3DVector;
radius, d0, d1, d2, rod, rod2, t1, t2, xc1, yc1, zc1, xc2, yc2, zc2 : TD3DValue;
begin
result := false;
 
 
//Get the coordinates of the old eye_position in the actual coll frame
FFrameSeries[FSeriesIndex, FNrinFrameSeries[FSeriesNr, coll_nr]].InverseTransform
(old_eye, old_attacker_position);
 
//Get the coordinates of the eye_position in the actual coll frame
FFrameSeries[FSeriesIndex, FNrinFrameSeries[FSeriesNr, coll_nr]].InverseTransform
(new_eye, attacker_position);
 
center.x := (Fcoll_box_max[FSeriesNr, coll_nr].x
+ Fcoll_box_min[FSeriesNr, coll_nr].x)/2;
center.y := (Fcoll_box_max[FSeriesNr, coll_nr].y
+ Fcoll_box_min[FSeriesNr, coll_nr].y)/2;
center.z := (Fcoll_box_max[FSeriesNr, coll_nr].z
+ Fcoll_box_min[FSeriesNr, coll_nr].z)/2;
 
//radius of sphere enlarged with the radius of the bullet
//to cover the space where a collision may occure
radius := Fcoll_radius[FSeriesNr, coll_nr] + bullet_radius;
 
//eye to center distance
dstep.x := old_eye.x - center.x;
dstep.y := old_eye.y - center.y;
dstep.z := old_eye.z - center.z;
 
//step in eye position
step.x := new_eye.x - old_eye.x;
step.y := new_eye.y - old_eye.y;
step.z := new_eye.z - old_eye.z;
 
//collision is only possible when something moves
if (abs(step.x) < 1e-3) and (abs(step.y) < 1e-3) and (abs(step.z) < 1e-3)
then
begin
result := false;
exit;
end;
 
d0 := 1; //just to avoid warnings
d1 := 1;
d2 := 1;
 
 
//The cylinder is alined parallel to the x, y or z axis
case FOrientation3D of
symmetric_x :
begin
//factors
d0 := sqr(dstep.y) + sqr(dstep.z) - sqr(radius);
d1 := 2 * (step.y * dstep.y + step.z * dstep.z);
d2 := sqr(step.y) + sqr(step.z);
end;
symmetric_y :
begin
//factors
d0 := sqr(dstep.x) + sqr(dstep.z) - sqr(radius);
d1 := 2 * (step.x * dstep.x + step.z * dstep.z);
d2 := sqr(step.x) + sqr(step.z);
end;
symmetric_z :
begin
//factors
d0 := sqr(dstep.x) + sqr(dstep.y) - sqr(radius);
d1 := 2 * (step.x * dstep.x + step.y * dstep.y);
d2 := sqr(step.x) + sqr(step.y);
end;
end; //end of case FOrientation3D of
 
 
//solving an equation of the second degree
rod := sqr(d1) - 4 * d2 * d0;
 
//d2 is never zero
if rod >= 0
then
begin
//only then is the collision possible
rod2 := sqrt(rod);
t1 := (-d1 - rod2)/2/d2;
t2 := (-d1 + rod2)/2/d2;
 
// if longshot then look into all future
if longshot
then
result := (t1 >= 0) or (t2 >= 0)
else
begin
//collision in between the starting and the ending point if
result := ((t1 >= 0) and (t1 <= 1))
or ((t2 >= 0) and (t2 <= 1));
end;
 
// however the collision also affords that we are within the length of the cylinder
if result then
begin
case FOrientation3D of
symmetric_x :
begin
xc1 := old_eye.x + t1 * step.x;
xc2 := old_eye.x + t2 * step.x;
 
 
if longshot
then
result :=
(result and (t1 >= 0) and
(xc1 >= (Fcoll_box_min[FseriesNr, coll_nr].x - bullet_radius)) and
(xc1 <= (Fcoll_box_max[FseriesNr, coll_nr].x + bullet_radius)) )
or
(result and (t2 >= 0) and
(xc2 >= (Fcoll_box_min[FseriesNr, coll_nr].x - bullet_radius)) and
(xc2 <= (Fcoll_box_max[FseriesNr, coll_nr].x + bullet_radius)) )
else
result :=
(result and (t1 >= 0) and (t1 <= 1) and
(xc1 >= (Fcoll_box_min[FseriesNr, coll_nr].x - bullet_radius)) and
(xc1 <= (Fcoll_box_max[FseriesNr, coll_nr].x + bullet_radius)) )
or
(result and (t2 >= 0) and (t2 <= 1) and
(xc2 >= (Fcoll_box_min[FseriesNr, coll_nr].x - bullet_radius)) and
(xc2 <= (Fcoll_box_max[FseriesNr, coll_nr].x + bullet_radius)) );
 
//if collision detected then exit now
if result then exit;
 
end;
symmetric_y :
begin
yc1 := old_eye.y + t1 * step.y;
yc2 := old_eye.y + t2 * step.y;
 
 
if longshot
then
result :=
(result and (t1 >= 0) and
(yc1 >= (Fcoll_box_min[FseriesNr, coll_nr].y - bullet_radius)) and
(yc1 <= (Fcoll_box_max[FseriesNr, coll_nr].y + bullet_radius)) )
or
(result and (t2 >= 0) and
(yc2 >= (Fcoll_box_min[FseriesNr, coll_nr].y - bullet_radius)) and
(yc2 <= (Fcoll_box_max[FseriesNr, coll_nr].y + bullet_radius)) )
else
result :=
(result and (t1 >= 0) and (t1 <= 1) and
(yc1 >= (Fcoll_box_min[FseriesNr, coll_nr].y - bullet_radius)) and
(yc1 <= (Fcoll_box_max[FseriesNr, coll_nr].y + bullet_radius)) )
or
(result and (t2 >= 0) and (t2 <= 1) and
(yc2 >= (Fcoll_box_min[FseriesNr, coll_nr].y - bullet_radius)) and
(yc2 <= (Fcoll_box_max[FseriesNr, coll_nr].y + bullet_radius)) );
 
//if collision detected then exit now
if result then exit;
 
 
end;
symmetric_z :
begin
zc1 := old_eye.z + t1 * step.z;
zc2 := old_eye.z + t2 * step.z;
 
 
if longshot
then
result :=
(result and (t1 >= 0) and
(zc1 >= (Fcoll_box_min[FseriesNr, coll_nr].z - bullet_radius)) and
(zc1 <= (Fcoll_box_max[FseriesNr, coll_nr].z + bullet_radius)) )
or
(result and (t2 >= 0) and
(zc2 >= (Fcoll_box_min[FseriesNr, coll_nr].z - bullet_radius)) and
(zc2 <= (Fcoll_box_max[FseriesNr, coll_nr].z + bullet_radius)) )
else
result :=
(result and (t1 >= 0) and (t1 <= 1) and
(zc1 >= (Fcoll_box_min[FseriesNr, coll_nr].z - bullet_radius)) and
(zc1 <= (Fcoll_box_max[FseriesNr, coll_nr].z + bullet_radius)) )
or
(result and (t2 >= 0) and (t2 <= 1) and
(zc2 >= (Fcoll_box_min[FseriesNr, coll_nr].z - bullet_radius)) and
(zc2 <= (Fcoll_box_max[FseriesNr, coll_nr].z + bullet_radius)) );
 
//if collision detected then exit now
if result then exit;
end;
 
end; //end of case
end;
 
//exit if a collision occured
if result then exit;
end;
 
 
//the collision may also occur with the end surfaces of the cylinder
case FOrientation3D of
symmetric_x :
begin
if step.x > 1e-6
then
begin
//1st end surface
t1 := (Fcoll_box_min[FseriesNr, coll_Nr].x - old_eye.x)/step.x;
yc1 := old_eye.y + t1 * step.y;
zc1 := old_eye.z + t1 * step.z;
 
distance := sqrt( sqr(yc1 - center.y) + sqr(zc1 - center.z) );
 
result := (distance < radius) and (t1 >= 0);
if not longshot then result := result and (t1 <= 1);
if result then exit;
 
//2nd end surface
t1 := (Fcoll_box_max[FseriesNr, coll_Nr].x - old_eye.x)/step.x;
yc1 := old_eye.y + t1 * step.y;
zc1 := old_eye.z + t1 * step.z;
 
distance := sqrt( sqr(yc1 - center.y) + sqr(zc1 - center.z) );
 
result := (distance < radius) and (t1 >= 0);
if not longshot then result := result and (t1 <= 1);
if result then exit;
end;
end;
symmetric_y :
begin
if step.y > 1e-6
then
begin
//1st end surface
t1 := (Fcoll_box_min[FseriesNr, coll_Nr].y - old_eye.y)/step.y;
xc1 := old_eye.x + t1 * step.x;
zc1 := old_eye.z + t1 * step.z;
 
distance := sqrt( sqr(xc1 - center.x) + sqr(zc1 - center.z) );
 
result := (distance < radius) and (t1 >= 0);
if not longshot then result := result and (t1 <= 1);
if result then exit;
 
//2nd end surface
t1 := (Fcoll_box_max[FseriesNr, coll_Nr].y - old_eye.y)/step.y;
xc1 := old_eye.x + t1 * step.x;
zc1 := old_eye.z + t1 * step.z;
 
distance := sqrt( sqr(xc1 - center.x) + sqr(zc1 - center.z) );
 
result := (distance < radius) and (t1 >= 0);
if not longshot then result := result and (t1 <= 1);
if result then exit;
end;
 
end;
symmetric_z :
begin
if step.z > 1e-6
then
begin
//1st end surface
t1 := (Fcoll_box_min[FseriesNr, coll_Nr].z - old_eye.z)/step.z;
xc1 := old_eye.x + t1 * step.x;
yc1 := old_eye.y + t1 * step.y;
 
distance := sqrt( sqr(xc1 - center.x) + sqr(yc1 - center.y) );
 
result := (distance < radius) and (t1 >= 0);
if not longshot then result := result and (t1 <= 1);
if result then exit;
 
//2nd end surface
t1 := (Fcoll_box_max[FseriesNr, coll_Nr].z - old_eye.z)/step.z;
xc1 := old_eye.x + t1 * step.x;
yc1 := old_eye.y + t1 * step.y;
 
distance := sqrt( sqr(xc1 - center.x) + sqr(yc1 - center.y) );
 
result := (distance < radius) and (t1 >= 0);
if not longshot then result := result and (t1 <= 1);
if result then exit;
end;
 
end;
 
 
end; //end of case
 
end; //end of coll_test_cylinder
 
 
 
 
 
function TcollisionTester3DX.coll_test_conus(coll_nr : byte;
old_attacker_position, attacker_position : TD3DVector;
bullet_radius : TD3DValue; longshot : boolean): boolean;
var
height3D, width3D : TD3DValue;
distance : TD3DValue;
new_eye, old_eye : TD3DVector;
dstep, step, center : TD3DVector;
radius, d0, d1, d2, rod, rod2, t1, t2, xc1, yc1, zc1, xc2, yc2, zc2 : TD3DValue;
xc, yc, zc, conusfact : TD3DValue;
begin
result := false;
 
//Get the coordinates of the old eye_position in the actual coll frame
FFrameSeries[FSeriesIndex, FNrinFrameSeries[FSeriesNr, coll_nr]].InverseTransform
(old_eye, old_attacker_position);
 
//Get the coordinates of the eye_position in the actual coll frame
FFrameSeries[FSeriesIndex, FNrinFrameSeries[FSeriesNr, coll_nr]].InverseTransform
(new_eye, attacker_position);
 
center.x := (Fcoll_box_max[FSeriesNr, coll_nr].x
+ Fcoll_box_min[FSeriesNr, coll_nr].x)/2;
center.y := (Fcoll_box_max[FSeriesNr, coll_nr].y
+ Fcoll_box_min[FSeriesNr, coll_nr].y)/2;
center.z := (Fcoll_box_max[FSeriesNr, coll_nr].z
+ Fcoll_box_min[FSeriesNr, coll_nr].z)/2;
 
 
//step in eye position
step.x := new_eye.x - old_eye.x;
step.y := new_eye.y - old_eye.y;
step.z := new_eye.z - old_eye.z;
 
//collision is only possible when something moves
if (abs(step.x) < 1e-3) and (abs(step.y) < 1e-3) and (abs(step.z) < 1e-3)
then
begin
result := false;
exit;
end;
 
//if FPercentLeftatTop is positiv then the conus is largest at the bottom
xc := center.x;
yc := center.y;
zc := center.z;
 
width3D := 10; //just to avoid warnings
height3D := 10;
 
case FOrientation3D of
symmetric_x :
begin
height3D := Fcoll_box_max[FSeriesNr, coll_nr].x
- Fcoll_box_min[FSeriesNr, coll_nr].x;
width3D := (Fcoll_box_max[FSeriesNr, coll_Nr].y
- Fcoll_box_min[FSeriesNr, coll_nr].y
+ Fcoll_box_max[FSeriesNr, coll_nr].z
- Fcoll_box_min[FSeriesNr, coll_nr].z)/2;
 
//the top of the conus is maller than the bottom of it
if FPercentLeftatTop >= 0
then
xc := center.x - height3D/2 + 100 * height3D/(100 - FpercentLeftatTop)
else
xc := center.x + height3D/2 - 100 * height3D/(100 + FpercentLeftatTop);
end; //end of symmetric_x
symmetric_y :
begin
height3D := Fcoll_box_max[FSeriesNr, coll_nr].y
- Fcoll_box_min[FSeriesNr, coll_nr].y;
width3D := (Fcoll_box_max[FSeriesNr, coll_Nr].x
- Fcoll_box_min[FSeriesNr, coll_nr].x
+ Fcoll_box_max[FSeriesNr, coll_nr].z
- Fcoll_box_min[FSeriesNr, coll_nr].z)/2;
 
//the top of the conus is maller than the bottom of it
if FPercentLeftatTop >= 0
then
yc := center.y - height3D/2 + 100 * height3D/(100 - FpercentLeftatTop)
else
yc := center.y + height3D/2 - 100 * height3D/(100 + FpercentLeftatTop);
end; //end of symmetric_y
symmetric_z :
begin
height3D := Fcoll_box_max[FSeriesNr, coll_nr].z
- Fcoll_box_min[FSeriesNr, coll_nr].z;
width3D := (Fcoll_box_max[FSeriesNr, coll_Nr].x
- Fcoll_box_min[FSeriesNr, coll_nr].x
+ Fcoll_box_max[FSeriesNr, coll_nr].y
- Fcoll_box_min[FSeriesNr, coll_nr].y)/2;
 
//the top of the conus is maller than the bottom of it
if FPercentLeftatTop >= 0
then
zc := center.z - height3D/2 + 100 * height3D/(100 - FpercentLeftatTop)
else
zc := center.z + height3D/2 - 100 * height3D/(100 + FpercentLeftatTop);
end; //end of symmetric_z
end; //end of case
 
//mathematically we need the conusfact describing the ratio between the radius of
//the large end of the conus and the height of the conus
if width3D > 0
then
conusfact := height3D/2/width3D
else
conusfact := 1e9;
 
//eye to the fictive tip of the conus distance
dstep.x := old_eye.x - xc;
dstep.y := old_eye.y - yc;
dstep.z := old_eye.z - zc;
 
d0 := 1; //just to avoid warnings
d1 := 1;
d2 := 1;
 
//The conus is aligned parallel to the x, y or z axis
case FOrientation3D of
symmetric_x :
begin
//factors
d0 := sqr(dstep.y) + sqr(dstep.z) - sqr(dstep.x * conusfact);
d1 := 2 * (step.y * dstep.y + step.z * dstep.z
- sqr(conusfact) * step.x * dstep.x);
d2 := sqr(step.y) + sqr(step.z) - sqr(conusfact * step.x);
end;
symmetric_y :
begin
//factors
d0 := sqr(dstep.x) + sqr(dstep.z) - sqr(dstep.y * conusfact);
d1 := 2 * (step.x * dstep.x + step.z * dstep.z
- sqr(conusfact) * step.y * dstep.y);
d2 := sqr(step.x) + sqr(step.z) - sqr(conusfact * step.y);
end;
symmetric_z :
begin
//factors
d0 := sqr(dstep.x) + sqr(dstep.y) - sqr(dstep.z * conusfact);
d1 := 2 * (step.x * dstep.x + step.y * dstep.y
- sqr(conusfact) * step.z * dstep.z);
d2 := sqr(step.x) + sqr(step.y) - sqr(conusfact * step.z);
end;
end; //end of case FOrientation3D of
 
 
//solving an equation of the second degree
rod := sqr(d1) - 4 * d2 * d0;
 
//d2 is never zero
if rod >= 0
then
begin
//only then is the collision possible
rod2 := sqrt(rod);
t1 := (-d1 - rod2)/2/d2;
t2 := (-d1 + rod2)/2/d2;
 
// if longshot then look into all future
if longshot
then
result := (t1 >= 0) or (t2 >= 0)
else
begin
//collision in between the starting and the ending point if
result := ((t1 >= 0) and (t1 <= 1))
or ((t2 >= 0) and (t2 <= 1));
end;
 
// however the collision also affords that we are within the length of the conus
if result then
begin
case FOrientation3D of
symmetric_x :
begin
xc1 := old_eye.x + t1 * step.x;
xc2 := old_eye.x + t2 * step.x;
 
 
if longshot
then
result :=
(result and (t1 >= 0) and
(xc1 >= (Fcoll_box_min[FseriesNr, coll_nr].x - bullet_radius)) and
(xc1 <= (Fcoll_box_max[FseriesNr, coll_nr].x + bullet_radius)) )
or
(result and (t2 >= 0) and
(xc2 >= (Fcoll_box_min[FseriesNr, coll_nr].x - bullet_radius)) and
(xc2 <= (Fcoll_box_max[FseriesNr, coll_nr].x + bullet_radius)) )
else
result :=
(result and (t1 >= 0) and (t1 <= 1) and
(xc1 >= (Fcoll_box_min[FseriesNr, coll_nr].x - bullet_radius)) and
(xc1 <= (Fcoll_box_max[FseriesNr, coll_nr].x + bullet_radius)) )
or
(result and (t2 >= 0) and (t2 <= 1) and
(xc2 >= (Fcoll_box_min[FseriesNr, coll_nr].x - bullet_radius)) and
(xc2 <= (Fcoll_box_max[FseriesNr, coll_nr].x + bullet_radius)) );
 
//if collision detected then exit now
if result then exit;
 
end;
symmetric_y :
begin
yc1 := old_eye.y + t1 * step.y;
yc2 := old_eye.y + t2 * step.y;
 
 
if longshot
then
result :=
(result and (t1 >= 0) and
(yc1 >= (Fcoll_box_min[FseriesNr, coll_nr].y - bullet_radius)) and
(yc1 <= (Fcoll_box_max[FseriesNr, coll_nr].y + bullet_radius)) )
or
(result and (t2 >= 0) and
(yc2 >= (Fcoll_box_min[FseriesNr, coll_nr].y - bullet_radius)) and
(yc2 <= (Fcoll_box_max[FseriesNr, coll_nr].y + bullet_radius)) )
else
result :=
(result and (t1 >= 0) and (t1 <= 1) and
(yc1 >= (Fcoll_box_min[FseriesNr, coll_nr].y - bullet_radius)) and
(yc1 <= (Fcoll_box_max[FseriesNr, coll_nr].y + bullet_radius)) )
or
(result and (t2 >= 0) and (t2 <= 1) and
(yc2 >= (Fcoll_box_min[FseriesNr, coll_nr].y - bullet_radius)) and
(yc2 <= (Fcoll_box_max[FseriesNr, coll_nr].y + bullet_radius)) );
 
//if collision detected then exit now
if result then exit;
 
 
end;
symmetric_z :
begin
zc1 := old_eye.z + t1 * step.z;
zc2 := old_eye.z + t2 * step.z;
 
 
if longshot
then
result :=
(result and (t1 >= 0) and
(zc1 >= (Fcoll_box_min[FseriesNr, coll_nr].z - bullet_radius)) and
(zc1 <= (Fcoll_box_max[FseriesNr, coll_nr].z + bullet_radius)) )
or
(result and (t2 >= 0) and
(zc2 >= (Fcoll_box_min[FseriesNr, coll_nr].z - bullet_radius)) and
(zc2 <= (Fcoll_box_max[FseriesNr, coll_nr].z + bullet_radius)) )
else
result :=
(result and (t1 >= 0) and (t1 <= 1) and
(zc1 >= (Fcoll_box_min[FseriesNr, coll_nr].z - bullet_radius)) and
(zc1 <= (Fcoll_box_max[FseriesNr, coll_nr].z + bullet_radius)) )
or
(result and (t2 >= 0) and (t2 <= 1) and
(zc2 >= (Fcoll_box_min[FseriesNr, coll_nr].z - bullet_radius)) and
(zc2 <= (Fcoll_box_max[FseriesNr, coll_nr].z + bullet_radius)) );
 
//if collision detected then exit now
if result then exit;
end;
 
end; //end of case
end;
 
//exit if a collision occured
if result then exit;
end;
 
 
//the collision may also occur with the end surfaces of the cylinder
case FOrientation3D of
symmetric_x :
begin
if step.x > 1e-6
then
begin
//1st end surface
t1 := (Fcoll_box_min[FseriesNr, coll_Nr].x - old_eye.x)/step.x;
yc1 := old_eye.y + t1 * step.y;
zc1 := old_eye.z + t1 * step.z;
 
distance := sqrt( sqr(yc1 - center.y) + sqr(zc1 - center.z) );
 
if FPercentLeftatTop >= 0
then
radius := width3D/2 //the large end of the conus is down
else
radius := -width3D/2 * FPercentLeftatTop;
 
radius := radius + bullet_radius;
 
result := (distance < radius) and (t1 >= 0);
if not longshot then result := result and (t1 <= 1);
if result then exit;
 
//2nd end surface
t1 := (Fcoll_box_max[FseriesNr, coll_Nr].x - old_eye.x)/step.x;
yc1 := old_eye.y + t1 * step.y;
zc1 := old_eye.z + t1 * step.z;
 
distance := sqrt( sqr(yc1 - center.y) + sqr(zc1 - center.z) );
 
if FPercentLeftatTop >= 0
then
radius := width3D/2 * FPercentLeftatTop //the small end of the conus is upwards
else
radius := width3D/2;
 
radius := radius + bullet_radius;
 
result := (distance < radius) and (t1 >= 0);
if not longshot then result := result and (t1 <= 1);
if result then exit;
end;
end;
symmetric_y :
begin
if step.y > 1e-6
then
begin
//1st end surface
t1 := (Fcoll_box_min[FseriesNr, coll_Nr].y - old_eye.y)/step.y;
xc1 := old_eye.x + t1 * step.x;
zc1 := old_eye.z + t1 * step.z;
 
distance := sqrt( sqr(xc1 - center.x) + sqr(zc1 - center.z) );
 
if FPercentLeftatTop >= 0
then
radius := width3D/2 //the large end of the conus is down
else
radius := -width3D/2 * FPercentLeftatTop;
 
radius := radius + bullet_radius;
 
result := (distance < radius) and (t1 >= 0);
if not longshot then result := result and (t1 <= 1);
if result then exit;
 
//2nd end surface
t1 := (Fcoll_box_max[FseriesNr, coll_Nr].y - old_eye.y)/step.y;
xc1 := old_eye.x + t1 * step.x;
zc1 := old_eye.z + t1 * step.z;
 
distance := sqrt( sqr(xc1 - center.x) + sqr(zc1 - center.z) );
 
if FPercentLeftatTop >= 0
then
radius := width3D/2 * FPercentLeftatTop //the small end of the conus is upwards
else
radius := width3D/2;
 
radius := radius + bullet_radius;
 
result := (distance < radius) and (t1 >= 0);
if not longshot then result := result and (t1 <= 1);
if result then exit;
end;
 
end;
symmetric_z :
begin
if step.z > 1e-6
then
begin
//1st end surface
t1 := (Fcoll_box_min[FseriesNr, coll_Nr].z - old_eye.z)/step.z;
xc1 := old_eye.x + t1 * step.x;
yc1 := old_eye.y + t1 * step.y;
 
distance := sqrt( sqr(xc1 - center.x) + sqr(yc1 - center.y) );
 
if FPercentLeftatTop >= 0
then
radius := width3D/2 //the large end of the conus is down
else
radius := width3D/2 * FPercentLeftatTop;
 
radius := radius + bullet_radius;
 
result := (distance < radius) and (t1 >= 0);
if not longshot then result := result and (t1 <= 1);
if result then exit;
 
//2nd end surface
t1 := (Fcoll_box_max[FseriesNr, coll_Nr].z - old_eye.z)/step.z;
xc1 := old_eye.x + t1 * step.x;
yc1 := old_eye.y + t1 * step.y;
 
distance := sqrt( sqr(xc1 - center.x) + sqr(yc1 - center.y) );
 
if FPercentLeftatTop >= 0
then
radius := -width3D/2 * FPercentLeftatTop //the small end of the conus is upwards
else
radius := width3D/2;
 
radius := radius + bullet_radius;
 
result := (distance < radius) and (t1 >= 0);
if not longshot then result := result and (t1 <= 1);
if result then exit;
end;
 
end;
 
 
end; //end of case
 
 
end; //end of coll_test_conus
 
 
 
 
function TcollisionTester3DX.coll_test_box(coll_nr : byte;
old_attacker_position, attacker_position : TD3DVector;
bullet_radius : TD3DValue; longshot : boolean): boolean;
var
new_eye, old_eye : TD3DVector;
step : TD3DVector;
t1, xc, yc, zc : TD3DValue;
begin
result := false;
 
//Get the coordinates of the old eye_position in the actual coll frame
FFrameSeries[FSeriesIndex, FNrinFrameSeries[FSeriesNr, coll_nr]].InverseTransform
(old_eye, old_attacker_position);
 
//Get the coordinates of the eye_position in the actual coll frame
FFrameSeries[FSeriesIndex, FNrinFrameSeries[FSeriesNr, coll_nr]].InverseTransform
(new_eye, attacker_position);
 
//step in eye position
step.x := new_eye.x - old_eye.x;
step.y := new_eye.y - old_eye.y;
step.z := new_eye.z - old_eye.z;
 
//collision is only possible when something moves
if (abs(step.x) < 1e-3) and (abs(step.y) < 1e-3) and (abs(step.z) < 1e-3)
then
begin
result := false;
exit;
end;
 
//check the surfaces which are normal to the x-axis
if abs(step.x) >= 1E-6
then
begin
//test 1st surface
t1 := (Fcoll_box_min[FseriesNr, coll_nr].x - old_eye.x)/step.x;
//collision point
zc := old_eye.z + t1 * step.z;
yc := old_eye.y + t1 * step.y;
 
//collision if the collision point is close enough to the surface
result :=
(zc >= (Fcoll_box_min[FseriesNr, coll_nr].z - bullet_radius)) and
(zc <= (Fcoll_box_max[FseriesNr, coll_nr].z + bullet_radius)) and
(yc >= (Fcoll_box_min[FseriesNr, coll_nr].y - bullet_radius)) and
(yc <= (Fcoll_box_max[FseriesNr, coll_nr].y + bullet_radius));
 
if longshot
then result := result and (t1 >= 0)
else result := result and (t1 >= 0) and (t1 <= 1);
 
//if collision detected then exit now
if result then exit;
 
//test 2nd surface
t1 := (Fcoll_box_max[FseriesNr, coll_nr].x - old_eye.x)/step.x;
//collision point
zc := old_eye.z + t1 * step.z;
yc := old_eye.y + t1 * step.y;
 
//collision if the collision point is close enough to the surface
result :=
(zc >= (Fcoll_box_min[FseriesNr, coll_nr].z - bullet_radius)) and
(zc <= (Fcoll_box_max[FseriesNr, coll_nr].z + bullet_radius)) and
(yc >= (Fcoll_box_min[FseriesNr, coll_nr].y - bullet_radius)) and
(yc <= (Fcoll_box_max[FseriesNr, coll_nr].y + bullet_radius));
 
if longshot
then result := result and (t1 >= 0)
else result := result and (t1 >= 0) and (t1 <= 1);
 
//if collision detected then exit now
if result then exit;
 
end; //end of step.x <> 0
 
 
//check the surfaces which are normal to the y-axis
if abs(step.y) >= 1E-6
then
begin
//test 1st surface
t1 := (Fcoll_box_min[FseriesNr, coll_nr].y - old_eye.y)/step.y;
//collision point
xc := old_eye.x + t1 * step.x;
zc := old_eye.z + t1 * step.z;
 
//collision if the collision point is close enough to the surface
result :=
(xc >= (Fcoll_box_min[FseriesNr, coll_nr].x - bullet_radius)) and
(xc <= (Fcoll_box_max[FseriesNr, coll_nr].x + bullet_radius)) and
(zc >= (Fcoll_box_min[FseriesNr, coll_nr].z - bullet_radius)) and
(zc <= (Fcoll_box_max[FseriesNr, coll_nr].z + bullet_radius));
 
if longshot
then result := result and (t1 >= 0)
else result := result and (t1 >= 0) and (t1 <= 1);
 
//if collision detected then exit now
if result then exit;
 
//test 2nd surface
t1 := (Fcoll_box_max[FseriesNr, coll_nr].y - old_eye.y)/step.y;
//collision point
xc := old_eye.x + t1 * step.x;
zc := old_eye.z + t1 * step.z;
 
//collision if the collision point is close enough to the surface
result :=
(xc >= (Fcoll_box_min[FseriesNr, coll_nr].x - bullet_radius)) and
(xc <= (Fcoll_box_max[FseriesNr, coll_nr].x + bullet_radius)) and
(zc >= (Fcoll_box_min[FseriesNr, coll_nr].z - bullet_radius)) and
(zc <= (Fcoll_box_max[FseriesNr, coll_nr].z + bullet_radius));
 
if longshot
then result := result and (t1 >= 0)
else result := result and (t1 >= 0) and (t1 <= 1);
 
//if collision detected then exit now
if result then exit;
 
end; //end of step.y <> 0
 
 
 
//check the surfaces which are normal to the z-axis
if abs(step.z) >= 1E-6
then
begin
//test 1st surface
t1 := (Fcoll_box_min[FseriesNr, coll_nr].z - old_eye.z)/step.z;
//collision point
xc := old_eye.x + t1 * step.x;
yc := old_eye.y + t1 * step.y;
 
//collision if the collision point is close enough to the surface
result :=
(xc >= (Fcoll_box_min[FseriesNr, coll_nr].x - bullet_radius)) and
(xc <= (Fcoll_box_max[FseriesNr, coll_nr].x + bullet_radius)) and
(yc >= (Fcoll_box_min[FseriesNr, coll_nr].y - bullet_radius)) and
(yc <= (Fcoll_box_max[FseriesNr, coll_nr].y + bullet_radius));
 
if longshot
then result := result and (t1 >= 0)
else result := result and (t1 >= 0) and (t1 <= 1);
 
//if collision detected then exit now
if result then exit;
 
//test 2nd surface
t1 := (Fcoll_box_max[FseriesNr, coll_nr].z - old_eye.z)/step.z;
//collision point
xc := old_eye.x + t1 * step.x;
yc := old_eye.y + t1 * step.y;
 
//collision if the collision point is close enough to the surface
result :=
(xc >= (Fcoll_box_min[FseriesNr, coll_nr].x - bullet_radius)) and
(xc <= (Fcoll_box_max[FseriesNr, coll_nr].x + bullet_radius)) and
(yc >= (Fcoll_box_min[FseriesNr, coll_nr].y - bullet_radius)) and
(yc <= (Fcoll_box_max[FseriesNr, coll_nr].y + bullet_radius));
 
if longshot
then result := result and (t1 >= 0)
else result := result and (t1 >= 0) and (t1 <= 1);
 
//if collision detected then exit now
if result then exit;
 
end; //end of step.z <> 0
 
 
end; //end of coll_test_box
 
 
 
 
 
 
function TCollisionTester3DX.BulletDead:boolean;
var
camera_position, bullet_position : TD3DVector;
Distance : TD3DValue;
begin
FBulletFrame.GetPosition(FDXDrawUsed.Scene, bullet_position);
FDXDrawUsed.Camera.GetPosition(FDXDrawUsed.Scene, camera_position);
 
Distance := sqr(Bullet_position.x - camera_position.x)
+ sqr(Bullet_position.y - camera_position.y)
+ sqr(Bullet_position.z - camera_position.z);
 
//remove the bullet if it is beyond the bulletrange or if it is a longshot
result := (sqrt(Distance) > FBulletRange) or FLongShots;
 
end; //end of BulletDead
 
 
 
 
//use this function to check whether the camera or an object in a distance of
// -from camera- from the camera collides with any collision object
function TCollisionTester3DX.collision: boolean;
var
i : integer;
camera_position, camera_direction, camera_up : TD3DVECTOR;
eye_position : TD3DVector;
begin
Result := false;
FBullet_HitlinkNr := -1;
 
if CheckForSeriesIndex(FSeriesIndex)
then
begin
//The series exists
if Fcoll_Nr_objects[FSeriesNr] > 0
then
begin
//The series is not empty
 
//Get the position of the camera
FDXDrawUsed.Camera.GetPosition(FDXDrawUsed.Scene, camera_position);
FDXDrawUsed.camera.GetOrientation(FDXDrawUsed.scene, camera_direction, camera_up);
//calculate the eye position
eye_position.x := camera_position.x + FFrontDistance * camera_direction.x;
eye_position.y := camera_position.y + FFrontDistance * camera_direction.y;
eye_position.z := camera_position.z + FFrontDistance * camera_direction.z;
 
//test whether the eye collides with any of the collision objects
i := 0;
while (not result) and (i < Fcoll_nr_objects[FSeriesNr]) do //0..
begin
case Fcoll_shape[FSeriesNr, i] of
box3D : Result := coll_test_box(i, FOldEyePosition,
eye_position, FHeadRadius, false);
sphere3D : Result := coll_test_sphere(i, FOldEyePosition,
eye_position, FHeadRadius, false);
cylinder3D : Result := coll_test_cylinder(i, FOldEyePosition,
eye_position, FHeadRadius, false);
ellipsoid3D: Result := coll_test_ellipsoid(i, FOldEyePosition,
eye_position, FHeadRadius, false);
conus3D : Result := coll_test_conus(i, FOldEyePosition,
eye_position, FHeadRadius, false);
end;
 
if result then Fbullet_hitLinkNr := Fcoll_objectnr[FseriesNr, i];
inc(i);
end;
end;
end; //end of if checkforseriesIndex
 
if result
then
ListDataForCollObject;
 
end; //end of collision
 
 
 
 
 
 
 
//use this function to check whether an object sent from the camera collides
//with any collision object
function TCollisionTester3DX.BulletCollision: boolean;
var
i: integer;
bullet_position : TD3DVector;
begin
Result := false;
FBullet_HitLinkNr := -1;
 
if checkForSeriesIndex(FSeriesIndex)
then
begin
//Series exists
 
//test whether eye collides with any of the collision objects
if Fcoll_Nr_objects[FSeriesNr] > 0
then
begin
//Get position of the bullet
FBulletFrame.GetPosition(FDXDrawUsed.Scene, bullet_position);
i := 0;
 
while (not result) and (i < Fcoll_Nr_objects[FSeriesNr]) do //0..
begin
if FColl_Shootable[FseriesNr, i] or
(FColl_material[FSeriesNr, i] = solid3D)
then
begin
case Fcoll_shape[FSeriesNr, i] of
box3D : result := coll_test_box(i, FOldBulletPosition,
bullet_position,
FBulletRadius, FLongShots);
sphere3D : result := coll_test_sphere(i, FOldBulletPosition,
bullet_position,
FBulletRadius, FLongShots);
cylinder3D : result := coll_test_cylinder(i, FOldBulletPosition,
bullet_position,
FBulletRadius, FLongShots);
ellipsoid3D: result := coll_test_ellipsoid(i, FOldBulletPosition,
bullet_position,
FBulletRadius, FLongShots);
conus3D : result := coll_test_conus(i, FOldBulletPosition,
bullet_position,
FBulletRadius, FLongShots);
end; //end case
end; //end of if..
 
if result
then
FBullet_HitLinkNr := Fcoll_ObjectNr[FSeriesNr, i];
 
inc(i);
end; //end of while
 
if result
then
ListDataForCollObject;
 
end; //end if Fcoll_Nr_ob....
end; //end if checkForSeriesIndex...
 
end; //end of bullet_collision
 
 
 
 
procedure TCollisionTester3DX.GetOldBulletPos;
begin
FbulletFrame.GetPosition(FDXDrawUsed.Scene, FOldBulletPosition);
end; //end of GetOldBulletPos
 
 
procedure TCollisionTester3DX.GetOldEyePos;
var
OldPos, camera_direction, camera_up : TD3DVector;
begin
FDXDrawUsed.Camera.GetPosition(FDXDrawUsed.Scene, OldPos);
FDXDrawUsed.Camera.GetOrientation(FDXDrawUsed.Scene, camera_direction, camera_up);
 
FOldEyePosition.x := OldPos.x + FFrontDistance * camera_direction.x;
FOldEyePosition.y := OldPos.y + FFrontDistance * camera_direction.y;
FOldEyePosition.z := OldPos.z + FFrontDistance * camera_direction.z;
 
end; //end of GetOldEyePos
 
 
 
 
 
 
end.
/VCL_DELPHIX_D6/D3DUtils.pas
0,0 → 1,1317
unit D3DUtils;
 
interface
 
{$INCLUDE DelphiXcfg.inc}
 
uses
Windows, Math,
{$IFDEF StandardDX}
{$IFDEF VER14UP} DXTypes, {$ENDIF} Direct3D, DirectDraw;
{$ELSE}
DirectX;
{$ENDIF}
 
const
g_PI = 3.14159265358979323846; // Pi
g_Uhel = g_PI / 180;
g_2_PI = 6.28318530717958623200; // 2 * Pi
g_PI_DIV_2 = 1.57079632679489655800; // Pi / 2
g_PI_DIV_4 = 0.78539816339744827900; // Pi / 4
g_INV_PI = 0.31830988618379069122; // 1 / Pi
g_DEGTORAD = 0.01745329251994329547; // Degrees to Radians
g_RADTODEG = 57.29577951308232286465; // Radians to Degrees
g_HUGE = 1.0E+38; // Huge number for FLOAT
g_EPSILON = 1.0E-5; // Tolerance for FLOATs
 
type
TD2DVector = packed record
X, Y: Single;
end;
TD3DHVector = packed record
X, Y, Z, W: Single;
end;
TQuaternion = packed record
case Integer of
0: (X, Y, Z, W: Single); //like TD3DHVector
1: (
V: TD3DVector;
);
end;
function ProjectionMatrix(near_plane, far_plane, fov_horiz, fov_vert: real): TD3DMatrix; {$IFDEF VER9UP}inline; {$ENDIF}
//--------------------------
// 3D Vector
//--------------------------
function MakeD3DVector(x, y, z: TD3DValue): TD3DVector; {$IFDEF VER9UP}inline; {$ENDIF}
function MakeD2DVector(x, y: TD3DValue): TD2DVector; {$IFDEF VER9UP}inline; {$ENDIF}
function MakeD3DVertex(hv, nv: TD3DVector; tu, tv: TD3DValue): TD3DVertex; overload; {$IFDEF VER9UP}inline; {$ENDIF}
function MakeD3DVertex(hx, hy, hz, nx, ny, nz, tu, tv: TD3DValue): TD3DVertex; overload; {$IFDEF VER9UP}inline; {$ENDIF}
function MakeD3DLVertex(hv: TD3DVector; col, sp: DWORD; tu, tv: TD3DValue): TD3DLVertex; overload; {$IFDEF VER9UP}inline; {$ENDIF}
function MakeD3DLVertex(hx, hy, hz: TD3DValue; col, sp: DWORD; tu, tv: TD3DValue): TD3DLVertex; overload; {$IFDEF VER9UP}inline; {$ENDIF}
function MakeD3DTLVertex(hx, hy, hz, rhw: TD3DValue; col, sp: DWORD; tu, tv: TD3DValue): TD3DTLVERTEX; overload; {$IFDEF VER9UP}inline; {$ENDIF}
function MakeD3DTLVertex(hv: TD3DVector; rhw: TD3DValue; col, sp: DWORD; tu, tv: TD3DValue): TD3DTLVERTEX; overload; {$IFDEF VER9UP}inline; {$ENDIF}
function Vector2RGBA(const v: TD3DVector; fHeight: Single): DWord; {$IFDEF VER9UP}inline; {$ENDIF}
function VectorToRGB(NormalVector: TD3DVector): DWORD; {$IFDEF VER9UP}inline; {$ENDIF}
//--------------------------
// 3D Vector
//--------------------------
function Quaternion(_w, _x, _y, _z: Single): TQuaternion;
function QuaternionLength(const a: TQuaternion): Single;
function QuaternionNormalize(const a: TQuaternion): TQuaternion;
 
function D3DMath_VecNormalize(const v: TD3DVector): TD3DVector; {$IFDEF VER9UP}inline; {$ENDIF}
function D3DMath_VecViewScreenize(const v: TD3DHVector): TD3DHVector; {$IFDEF VER9UP}inline; {$ENDIF}
function D3DMath_VecHeterogenize(const hv: TD3DHVector; _div: Boolean{$IFDEF VER4UP} = False{$ENDIF}): TD3DVector; {$IFDEF VER9UP}inline; {$ENDIF}
function D3DMath_VecHomogenize(const v: TD3DVector): TD3DHVector; {$IFDEF VER9UP}inline; {$ENDIF}
function D3DMath_VecTransform(const a: TD3DHVector; const m: TD3DMATRIX): TD3DHVector; overload; {$IFDEF VER9UP}inline; {$ENDIF}
function D3DMath_VecTransform(const a: TD3DVector; const m: TD3DMATRIX): TD3DVector; overload; {$IFDEF VER9UP}inline; {$ENDIF}
function D3DMath_Vec3Length(const v: TD3DVector): TD3DValue; {$IFDEF VER9UP}inline; {$ENDIF}
function D3DMath_Vec3LengthSq(const v: TD3DVector): TD3DValue; {$IFDEF VER9UP}inline; {$ENDIF}
function D3DMath_Vec3Dot(const v1, v2: TD3DVector): TD3DValue; {$IFDEF VER9UP}inline; {$ENDIF}
function D3DMath_Vec3Cross(const v1, v2: TD3DVector): TD3DVector; {$IFDEF VER9UP}inline; {$ENDIF}
function D3DMath_Vec3Add(const v1, v2: TD3DVector): TD3DVector; {$IFDEF VER9UP}inline; {$ENDIF}
function D3DMath_Vec3Subtract(const v1, v2: TD3DVector): TD3DVector; {$IFDEF VER9UP}inline; {$ENDIF}
function D3DMath_Vec3Minimize(const v1, v2: TD3DVector): TD3DVector; {$IFDEF VER9UP}inline; {$ENDIF}
function D3DMath_Vec3Maximize(const v1, v2: TD3DVector): TD3DVector; {$IFDEF VER9UP}inline; {$ENDIF}
function D3DMath_Vec3Scale(const v: TD3DVector; const s: TD3DValue): TD3DVector; {$IFDEF VER9UP}inline; {$ENDIF}
function D3DMath_Vec3Lerp(out vOut: TD3DVector; const v1, v2: TD3DVector; const s: TD3DValue): TD3DVector; {$IFDEF VER9UP}inline; {$ENDIF}
 
function D3DMath_IsZero(a: Double; fTol: Double { = g_EPSILON}): Boolean; {$IFDEF VER9UP}inline; {$ENDIF}
 
procedure D3DMath_QuaternionFromRotation(var x, y, z, w: Double; const v: TD3DVector; fTheta: Double); overload; {$IFDEF VER9UP}inline; {$ENDIF}
function D3DMath_QuaternionFromRotation(const axis: TD3DVector; const r: Double): TQuaternion; overload; {$IFDEF VER9UP}inline; {$ENDIF}
procedure D3DMath_RotationFromQuaternion(var v: TD3DVector; var fTheta: Double; x, y, z, w: Double); {$IFDEF VER9UP}inline; {$ENDIF}
procedure D3DMath_QuaternionFromAngles(var x, y, z, w: Double; fYaw, fPitch, fRoll: Double); {$IFDEF VER9UP}inline; {$ENDIF}
procedure D3DMath_MatrixFromQuaternion(var mat: TD3DMatrix; x, y, z, w: Double); overload; {$IFDEF VER9UP}inline; {$ENDIF}
function D3DMath_MatrixFromQuaternion(q: TQuaternion): TD3DMatrix; overload; {$IFDEF VER9UP}inline; {$ENDIF}
procedure D3DMath_QuaternionFromMatrix(var x, y, z, w: Double; var mat: TD3DMatrix); {$IFDEF VER9UP}inline; {$ENDIF}
procedure D3DMath_QuaternionMultiply(var Qx, Qy, Qz, Qw: Double; Ax, Ay, Az, Aw, Bx, By, Bz, Bw: Double); overload; {$IFDEF VER9UP}inline; {$ENDIF}
function D3DMath_QuaternionMultiply(a, b: TQuaternion): TQuaternion; overload; {$IFDEF VER9UP}inline; {$ENDIF}
procedure D3DMath_QuaternionSlerp(var Qx, Qy, Qz, Qw: Double; Ax, Ay, Az, Aw, Bx, By, Bz, Bw, fAlpha: Double); overload; {$IFDEF VER9UP}inline; {$ENDIF}
function D3DMath_QuaternionSlerp(A, B: TQuaternion; fAlpha: Double): TQuaternion; overload; {$IFDEF VER9UP}inline; {$ENDIF}
 
procedure D3DUtil_InitSurfaceDesc(var ddsd: TDDSurfaceDesc2; dwFlags, dwCaps: DWORD); {$IFDEF VER9UP}inline; {$ENDIF}
procedure D3DUtil_InitMaterial(var mtrl: TD3DMaterial7; r, g, b, a: Double); {$IFDEF VER9UP}inline; {$ENDIF}
procedure D3DUtil_InitLight(var light: TD3DLight7; ltType: TD3DLightType; x, y, z: Double); {$IFDEF VER9UP}inline; {$ENDIF}
 
procedure D3DMath_MatrixMultiply(var q: TD3DMatrix; const a, b: TD3DMatrix); overload;
function D3DMath_MatrixMultiply(const a, b: TD3DMatrix): TD3DMatrix; overload;
function D3DMath_MatrixInvert(var q: TD3DMatrix; const a: TD3DMatrix): HResult; overload; {$IFDEF VER9UP}inline; {$ENDIF}
function D3DMath_MatrixInvert(const a: TD3DMatrix): TD3DMatrix; overload; {$IFDEF VER9UP}inline; {$ENDIF}
function D3DMath_VectorMatrixMultiply(var vDest: TD3DVector; const vSrc: TD3DVector; const mat: TD3DMatrix): HResult; {$IFDEF VER9UP}inline; {$ENDIF}
function D3DMath_VertexMatrixMultiply(var vDest: TD3DVertex; const vSrc: TD3DVertex; const mat: TD3DMatrix): HResult; {$IFDEF VER9UP}inline; {$ENDIF}
procedure D3DUtil_SetIdentityMatrix(out m: TD3DMatrix); overload; {$IFDEF VER9UP}inline; {$ENDIF}
function D3DUtil_SetIdentityMatrix: TD3DMatrix; overload; {$IFDEF VER9UP}inline; {$ENDIF}
function D3DUtil_SetScaleMatrix(const x, y, z: Single): TD3DMatrix; {$IFDEF VER9UP}inline; {$ENDIF}
function D3DUtil_SetViewMatrix(var mat: TD3DMatrix; const vFrom, vAt, vWorldUp: TD3DVector): HResult; {$IFDEF VER9UP}inline; {$ENDIF}
function D3DUtil_SetProjectionMatrix(var mat: TD3DMatrix; fFOV, fAspect, fNearPlane, fFarPlane: Double): HResult; {$IFDEF VER9UP}inline; {$ENDIF}
procedure D3DUtil_SetRotateXMatrix(var mat: TD3DMatrix; fRads: Double); overload; {$IFDEF VER9UP}inline; {$ENDIF}
function D3DUtil_SetRotateXMatrix(fRads: Double): TD3DMatrix; overload; {$IFDEF VER9UP}inline; {$ENDIF}
procedure D3DUtil_SetRotateYMatrix(var mat: TD3DMatrix; fRads: Double); overload; {$IFDEF VER9UP}inline; {$ENDIF}
function D3DUtil_SetRotateYMatrix(fRads: Double): TD3DMatrix; overload; {$IFDEF VER9UP}inline; {$ENDIF}
procedure D3DUtil_SetRotateZMatrix(var mat: TD3DMatrix; fRads: Double); overload; {$IFDEF VER9UP}inline; {$ENDIF}
function D3DUtil_SetRotateZMatrix(fRads: Double): TD3DMatrix; overload; {$IFDEF VER9UP}inline; {$ENDIF}
procedure D3DUtil_SetRotationMatrix(var mat: TD3DMatrix; var vDir: TD3DVector; fRads: Double); {$IFDEF VER9UP}inline; {$ENDIF}
function D3DUtil_SetRotationMatrixByX(const a: TD3DVector; const r: Double): TD3DVector; {$IFDEF VER9UP}inline; {$ENDIF}
function D3DUtil_SetRotationMatrixByY(const a: TD3DVector; const r: Double): TD3DVector; {$IFDEF VER9UP}inline; {$ENDIF}
function D3DUtil_SetRotationMatrixByZ(const a: TD3DVector; const r: Double): TD3DVector; {$IFDEF VER9UP}inline; {$ENDIF}
 
function D3DCOLOR_ARGB(a, r, g, b: Cardinal): TD3DColor; {$IFDEF VER9UP}inline; {$ENDIF}
function D3DCOLOR_RGBA(r, g, b, a: Cardinal): TD3DColor; {$IFDEF VER9UP}inline; {$ENDIF}
function D3DCOLOR_XRGB(r, g, b: Cardinal): TD3DColor; {$IFDEF VER9UP}inline; {$ENDIF}
function D3DCOLOR_COLORVALUE(r, g, b, a: Single): TD3DColor; {$IFDEF VER9UP}inline; {$ENDIF}
 
// simple D2D operation
 
function D2DMath_VecAdd(const a: TD2DVector; const b: TD2DVector): TD2DVector; {$IFDEF VER9UP}inline; {$ENDIF}
function D2DMath_VecSub(const a: TD2DVector; const b: TD2DVector): TD2DVector; {$IFDEF VER9UP}inline; {$ENDIF}
function D2DMath_VecDotProduct(const a, b: TD2DVector): Single; {$IFDEF VER9UP}inline; {$ENDIF}
function D2DMath_VecDistance(const a, b: TD2DVector): Single; {$IFDEF VER9UP}inline; {$ENDIF}
function D2DMath_VecLength(const a: TD2DVector): Single; {$IFDEF VER9UP}inline; {$ENDIF}
function D2DMath_VecNormalize(const a: TD2DVector): TD2DVector; {$IFDEF VER9UP}inline; {$ENDIF}
function D2DMath_VecToAngle(const a: TD2DVector): Double; {$IFDEF VER9UP}inline; {$ENDIF}
function D2DMath_VecRot(const a: TD2DVector; const angle: Double): TD2DVector; {$IFDEF VER9UP}inline; {$ENDIF}
function D2DMath_VecScale(const a: TD2DVector; const scale: Double): TD2DVector; {$IFDEF VER9UP}inline; {$ENDIF}
function D2DMath_VecChangeLength(const a: TD2DVector; const k: Single): TD2DVector; {$IFDEF VER9UP}inline; {$ENDIF}
function D2DMath_VecLookAt(const pos: TD2DVector; const target: TD2DVector; const k: Single): TD2DVector; {$IFDEF VER9UP}inline; {$ENDIF}
function D2DMath_VecRandom2D(const k: Single): TD2DVector; {$IFDEF VER9UP}inline; {$ENDIF}
 
function D2DMath_VecLerp(const a: TD2DVector; const b: TD2DVector; const rate: Single): TD2DVector; {$IFDEF VER9UP}inline; {$ENDIF}
 
implementation
 
//function RSin(val: Integer): Double; {$IFDEF VER9UP}inline; {$ENDIF}
//begin
// Result := Sin(val / 2048.0 * Pi);
//end;
//
//function RCos(val: Integer): Double; {$IFDEF VER9UP}inline; {$ENDIF}
//begin
// Result := Cos(val / 2048.0 * Pi);
//end;
 
function Quaternion(_w, _x, _y, _z: Single): TQuaternion;
begin
Result.W := _w;
Result.X := _x;
Result.Y := _y;
Result.Z := _z;
end;
 
function QuaternionLength(const a: TQuaternion): Single;
begin
Result := Sqrt(a.w * a.w + a.x * a.x + a.y * a.y + a.z * a.z);
end;
 
function QuaternionNormalize(const a: TQuaternion): TQuaternion;
var
len: Single;
begin
len := QuaternionLength(a);
if len = 0.0 then
begin
Result := Quaternion(1, 0, 0, 0);
Exit;
end;
Result.x := a.X / len;
Result.y := a.Y / len;
Result.z := a.Z / len;
Result.w := a.W / len;
end;
 
function GetMatrixFromQuaternion(const a: TQuaternion): TD3DMatrix;
begin
 
end;
 
 
function D3DCOLOR_ARGB(a, r, g, b: Cardinal): TD3DColor;
begin
Result := (a shl 24) or (r shl 16) or (g shl 8) or b;
end;
 
function D3DCOLOR_RGBA(r, g, b, a: Cardinal): TD3DColor;
begin
Result := D3DCOLOR_ARGB(a, r, g, b);
end;
 
function D3DCOLOR_XRGB(r, g, b: Cardinal): TD3DColor;
begin
Result := D3DCOLOR_ARGB($FF, r, g, b);
end;
 
function D3DCOLOR_COLORVALUE(r, g, b, a: Single): TD3DColor;
begin
Result := D3DCOLOR_RGBA(Byte(Round(r * 255)), Byte(Round(g * 255)), Byte(Round(b * 255)), Byte(Round(a * 255)))
end;
 
function MakeD3DVector(x, y, z: TD3DValue): TD3DVector;
begin
Result.x := x;
Result.y := y;
Result.z := z;
end;
 
function MakeD2DVector(x, y: TD3DValue): TD2DVector;
begin
Result.x := x;
Result.y := y;
end;
 
function MakeD3DVertex(hv, nv: TD3DVector; tu, tv: TD3DValue): TD3DVertex;
begin
Result.x := hv.x;
Result.y := hv.y;
Result.z := hv.z;
Result.nx := nv.x;
Result.ny := nv.y;
Result.nz := nv.z;
Result.tu := tu;
Result.tv := tv;
end;
 
function MakeD3DVertex(hx, hy, hz, nx, ny, nz, tu, tv: TD3DValue): TD3DVertex;
begin
Result.x := hx;
Result.y := hy;
Result.z := hz;
Result.nx := nx;
Result.ny := ny;
Result.nz := nz;
Result.tu := tu;
Result.tv := tv;
end;
 
function MakeD3DLVertex(hv: TD3DVector; col, sp: DWORD; tu, tv: TD3DValue): TD3DLVertex;
begin
FillChar(Result, SizeOf(Result), 0);
Result.x := hv.x;
Result.y := hv.y;
Result.z := hv.z;
Result.color := col;
Result.specular := sp;
Result.tu := tu;
Result.tv := tv;
end;
 
function MakeD3DLVertex(hx, hy, hz: TD3DValue; col, sp: DWORD; tu, tv: TD3DValue): TD3DLVertex;
begin
FillChar(Result, SizeOf(Result), 0);
Result.x := hx;
Result.y := hy;
Result.z := hz;
Result.color := col;
Result.specular := sp;
Result.tu := tu;
Result.tv := tv;
end;
 
function MakeD3DTLVertex(hx, hy, hz, rhw: TD3DValue; col, sp: DWORD; tu, tv: TD3DValue): TD3DTLVERTEX;
begin
Result.sx := hx;
Result.sy := hy;
Result.sz := hz;
Result.dvRHW := rhw;
Result.color := col;
Result.specular := sp;
Result.tu := tu;
Result.tv := tv;
end;
 
function MakeD3DTLVertex(hv: TD3DVector; rhw: TD3DValue; col, sp: DWORD; tu, tv: TD3DValue): TD3DTLVERTEX;
begin
Result.sx := hv.x;
Result.sy := hv.y;
Result.sz := hv.z;
Result.dvRHW := rhw;
Result.color := col;
Result.specular := sp;
Result.tu := tu;
Result.tv := tv;
end;
 
function Vector2RGBA(const v: TD3DVector; fHeight: Single): DWord;
var
r, g, b, a: DWord;
begin
r := Round(127.0 * v.x + 128.0);
g := Round(127.0 * v.y + 128.0);
b := Round(127.0 * v.z + 128.0);
a := Round(255.0 * fHeight);
Result := ((a shl 24) + (r shl 16) + (g shl 8) + (b shl 0));
end;
 
function VectorToRGB(NormalVector: TD3DVector): DWORD;
var dwR, dwG, dwB: DWORD;
begin
dwR := Round(127 * NormalVector.x + 128);
dwG := Round(127 * NormalVector.y + 128);
dwB := Round(127 * NormalVector.z + 128);
Result := $FF000000 + dwR shl 16 + dwG shl 8 + dwB;
end;
 
function ProjectionMatrix(near_plane, // distance to near clipping plane
far_plane, // distance to far clipping plane
fov_horiz, // horizontal field of view angle, in radians
fov_vert: real): TD3DMatrix; // vertical field of view angle, in radians
var h, w, Q: real;
begin
Fov_horiz := g_Uhel * Fov_horiz;
Fov_Vert := g_Uhel * Fov_Vert;
 
w := cotan(fov_horiz * 0.5);
h := cotan(fov_vert * 0.5);
Q := far_plane / (far_plane - near_plane);
 
result._11 := w;
result._22 := h;
result._33 := Q;
result._43 := -Q * near_plane;
result._34 := 1;
end;
// end of ProjectionMatrix()
 
//--------------------------
// 3D Vector
//--------------------------
 
function D3DMath_VecNormalize(const v: TD3DVector): TD3DVector;
var
len: Single;
begin
len := D3DMath_Vec3Length(v);
if len = 0 then
FillChar(Result, SizeOf(Result), 0)
else
begin
Result.X := v.X / len;
Result.Y := v.Y / len;
Result.Z := v.Z / len;
end;
end;
 
function D3DMath_VecViewScreenize(const v: TD3DHVector): TD3DHVector;
begin
with Result do
begin
if v.W <> 0.0 then
begin
W := 1.0 / v.W;
X := v.X * W;
Y := v.Y * W;
Z := v.Z * W;
end;
end;
end;
 
function D3DMath_VecHeterogenize(const hv: TD3DHVector; _div: Boolean): TD3DVector;
var
d: Single;
begin
if not _div then
begin
Result.x := hv.X;
Result.y := hv.Y;
Result.z := hv.Z;
end
else
begin
d := 1.0 / hv.w;
Result.x := hv.x * d;
Result.y := hv.y * d;
Result.z := hv.z * d;
end;
end;
 
function D3DMath_VecHomogenize(const v: TD3DVector): TD3DHVector;
begin
Move(v, result, Sizeof(TD3DVector));
result.W := 1.0;
end;
 
function D3DMath_VecTransform(const a: TD3DHVector; const m: TD3DMATRIX): TD3DHVector;
begin
result.X := a.X * m._11 + a.Y * m._21 + a.Z * m._31 + a.W * m._41;
result.Y := a.X * m._12 + a.Y * m._22 + a.Z * m._32 + a.W * m._42;
result.Z := a.X * m._13 + a.Y * m._23 + a.Z * m._33 + a.W * m._43;
result.W := a.X * m._14 + a.Y * m._24 + a.Z * m._34 + a.W * m._44;
end;
 
function D3DMath_VecTransform(const a: TD3DVector; const m: TD3DMATRIX): TD3DVector;
begin
result.X := a.X * m._11 + a.Y * m._21 + a.Z * m._31 + m._41;
result.Y := a.X * m._12 + a.Y * m._22 + a.Z * m._32 + m._42;
result.Z := a.X * m._13 + a.Y * m._23 + a.Z * m._33 + m._43;
end;
 
function D3DMath_Vec3Length(const v: TD3DVector): TD3DValue;
begin
with v do Result := Sqrt(Sqr(x) + Sqr(y) + Sqr(z));
end;
 
function D3DMath_Vec3LengthSq(const v: TD3DVector): TD3DValue;
begin
with v do Result := Sqr(x) + Sqr(y) + Sqr(z);
end;
 
function D3DMath_Vec3Dot(const v1, v2: TD3DVector): TD3DValue;
begin
Result := v1.x * v2.x + v1.y * v2.y + v1.z * v2.z;
end;
 
function D3DMath_Vec3Cross(const v1, v2: TD3DVector): TD3DVector;
begin
Result.x := v1.y * v2.z - v1.z * v2.y;
Result.y := v1.z * v2.x - v1.x * v2.z;
Result.z := v1.x * v2.y - v1.y * v2.x;
end;
 
function D3DMath_Vec3Add(const v1, v2: TD3DVector): TD3DVector;
begin
Result.x := v1.x + v2.x;
Result.y := v1.y + v2.y;
Result.z := v1.z + v2.z;
end;
 
function D3DMath_Vec3Subtract(const v1, v2: TD3DVector): TD3DVector;
begin
Result.x := v1.x - v2.x;
Result.y := v1.y - v2.y;
Result.z := v1.z - v2.z;
end;
 
// Minimize each component. x = min(x1, x2), y = min(y1, y2)
 
function D3DMath_Vec3Minimize(const v1, v2: TD3DVector): TD3DVector;
begin
if v1.x < v2.x then Result.x := v1.x else Result.x := v2.x;
if v1.y < v2.y then Result.y := v1.y else Result.y := v2.y;
if v1.z < v2.z then Result.z := v1.z else Result.z := v2.z;
end;
 
// Maximize each component. x = max(x1, x2), y = max(y1, y2)
 
function D3DMath_Vec3Maximize(const v1, v2: TD3DVector): TD3DVector;
begin
if v1.x > v2.x then Result.x := v1.x else Result.x := v2.x;
if v1.y > v2.y then Result.y := v1.y else Result.y := v2.y;
if v1.z > v2.z then Result.z := v1.z else Result.z := v2.z;
end;
 
function D3DMath_Vec3Scale(const v: TD3DVector; const s: TD3DValue): TD3DVector;
begin
Result.x := v.x * s;
Result.y := v.y * s;
Result.z := v.z * s;
end;
 
// Linear interpolation. V1 + s(V2-V1)
 
function D3DMath_Vec3Lerp(out vOut: TD3DVector; const v1, v2: TD3DVector; const s: TD3DValue): TD3DVector;
begin
Result.x := v1.x + s * (v2.x - v1.x);
Result.y := v1.y + s * (v2.y - v1.y);
Result.z := v1.z + s * (v2.z - v1.z);
end;
 
//-----------------------------------------------------------------------------
// File: D3DMath.cpp
//
// Desc: Shortcut macros and functions for using DX objects
//
// Copyright (c) 1997-1999 Microsoft Corporation. All rights reserved
//-----------------------------------------------------------------------------
 
function D3DMath_IsZero(a: Double; fTol: Double { = g_EPSILON}): Boolean;
begin
if a < 0 then
Result := a >= -fTol
else
Result := a <= fTol;
end;
 
//-----------------------------------------------------------------------------
// Name: D3DMath_MatrixMultiply()
// Desc: Does the matrix operation: [Q] = [A] * [B]. Note that the order of
// this operation was changed from the previous version of the DXSDK.
//-----------------------------------------------------------------------------
 
procedure D3DMath_MatrixMultiply(var q: TD3DMatrix; const a, b: TD3DMatrix);
type
PArrayD3DValue = ^TArrayD3DValue;
TArrayD3DValue = array[0..15] of TD3DValue;
var
pA, pB, pQ: PArrayD3DValue;
i, j, k: Integer;
qq: TD3DMatrix;
begin
FillChar(qq, SizeOf(qq), 0);
 
pA := @a;
pB := @b;
pQ := @qq;
for i := 0 to 3 do
for j := 0 to 3 do
for k := 0 to 3 do
pQ[4 * i + j] := pQ[4 * i + j] + pA[4 * i + k] * pB[4 * k + j];
q := qq; {== protect of recurrence}
end;
 
function D3DMath_MatrixMultiply(const a, b: TD3DMatrix): TD3DMatrix;
begin
D3DMath_MatrixMultiply(Result, a, b);
end;
 
//-----------------------------------------------------------------------------
// Name: D3DMath_MatrixInvert()
// Desc: Does the matrix operation: [Q] = inv[A]. Note: this function only
// works for matrices with [0 0 0 1] for the 4th column.
//-----------------------------------------------------------------------------
 
function D3DMath_MatrixInvert(var q: TD3DMatrix; const a: TD3DMatrix): HResult;
var
fDetInv: Double;
begin
if (abs(a._44 - 1.0) > 0.001) or (abs(a._14) > 0.001) or (abs(a._24) > 0.001) or (abs(a._34) > 0.001) then
begin
Result := E_INVALIDARG;
Exit;
end;
 
fDetInv := 1.0 / (a._11 * (a._22 * a._33 - a._23 * a._32) -
a._12 * (a._21 * a._33 - a._23 * a._31) +
a._13 * (a._21 * a._32 - a._22 * a._31));
 
q._11 := fDetInv * (a._22 * a._33 - a._23 * a._32);
q._12 := -fDetInv * (a._12 * a._33 - a._13 * a._32);
q._13 := fDetInv * (a._12 * a._23 - a._13 * a._22);
q._14 := 0.0;
 
q._21 := -fDetInv * (a._21 * a._33 - a._23 * a._31);
q._22 := fDetInv * (a._11 * a._33 - a._13 * a._31);
q._23 := -fDetInv * (a._11 * a._23 - a._13 * a._21);
q._24 := 0.0;
 
q._31 := fDetInv * (a._21 * a._32 - a._22 * a._31);
q._32 := -fDetInv * (a._11 * a._32 - a._12 * a._31);
q._33 := fDetInv * (a._11 * a._22 - a._12 * a._21);
q._34 := 0.0;
 
q._41 := -(a._41 * q._11 + a._42 * q._21 + a._43 * q._31);
q._42 := -(a._41 * q._12 + a._42 * q._22 + a._43 * q._32);
q._43 := -(a._41 * q._13 + a._42 * q._23 + a._43 * q._33);
q._44 := 1.0;
 
Result := S_OK;
end;
 
function D3DMath_MatrixInvert(const a: TD3DMatrix): TD3DMatrix;
begin
if D3DMath_MatrixInvert(Result, a) <> S_OK then
FillChar(Result, SizeOf(Result), 0);
end;
 
//-----------------------------------------------------------------------------
// Name: D3DMath_VectorMatrixMultiply()
// Desc: Multiplies a vector by a matrix
//-----------------------------------------------------------------------------
 
function D3DMath_VectorMatrixMultiply(var vDest: TD3DVector; const vSrc: TD3DVector;
const mat: TD3DMatrix): HResult;
var
x, y, z, w: Double;
begin
x := vSrc.x * mat._11 + vSrc.y * mat._21 + vSrc.z * mat._31 + mat._41;
y := vSrc.x * mat._12 + vSrc.y * mat._22 + vSrc.z * mat._32 + mat._42;
z := vSrc.x * mat._13 + vSrc.y * mat._23 + vSrc.z * mat._33 + mat._43;
w := vSrc.x * mat._14 + vSrc.y * mat._24 + vSrc.z * mat._34 + mat._44;
 
if abs(w) < g_EPSILON then
begin
Result := E_INVALIDARG;
Exit;
end;
 
vDest.x := x / w;
vDest.y := y / w;
vDest.z := z / w;
 
Result := S_OK;
end;
 
//-----------------------------------------------------------------------------
// Name: D3DMath_VertexMatrixMultiply()
// Desc: Multiplies a vertex by a matrix
//-----------------------------------------------------------------------------
 
function D3DMath_VertexMatrixMultiply(var vDest: TD3DVertex; const vSrc: TD3DVertex;
const mat: TD3DMatrix): HResult;
var
pSrcVec, pDestVec: PD3DVector;
begin
pSrcVec := @vSrc.x;
pDestVec := @vDest.x;
 
Result := D3DMath_VectorMatrixMultiply(pDestVec^, pSrcVec^, mat);
if SUCCEEDED(Result) then
begin
pSrcVec := @vSrc.nx;
pDestVec := @vDest.nx;
Result := D3DMath_VectorMatrixMultiply(pDestVec^, pSrcVec^, mat);
end;
end;
 
//-----------------------------------------------------------------------------
// Name: D3DMath_QuaternionFromRotation()
// Desc: Converts a normalized axis and angle to a unit quaternion.
//-----------------------------------------------------------------------------
 
procedure D3DMath_QuaternionFromRotation(var x, y, z, w: Double;
const v: TD3DVector; fTheta: Double);
begin
x := sin(fTheta / 2.0) * v.x;
y := sin(fTheta / 2.0) * v.y;
z := sin(fTheta / 2.0) * v.z;
w := cos(fTheta / 2.0);
end;
 
function D3DMath_QuaternionFromRotation(const axis: TD3DVector; const r: Double): TQuaternion;
var
// r: Integer;
a: TD3DVector;
begin
// r := (t div 2) and $FFF;
a := VectorNormalize(axis);
Result.X := a.X * Sin(R);
Result.Y := a.Y * Sin(R);
Result.Z := a.Z * Sin(R);
Result.W := Cos(R);
end;
 
//-----------------------------------------------------------------------------
// Name: D3DMath_RotationFromQuaternion()
// Desc: Converts a normalized axis and angle to a unit quaternion.
//-----------------------------------------------------------------------------
 
procedure D3DMath_RotationFromQuaternion(var v: TD3DVector; var fTheta: Double;
x, y, z, w: Double);
begin
fTheta := ArcCos(w) * 2.0;
v.x := x / sin(fTheta / 2.0);
v.y := y / sin(fTheta / 2.0);
v.z := z / sin(fTheta / 2.0);
end;
 
//-----------------------------------------------------------------------------
// Name: D3DMath_QuaternionFromAngles()
// Desc: Converts euler angles to a unit quaternion.
//-----------------------------------------------------------------------------
 
procedure D3DMath_QuaternionFromAngles(var x, y, z, w: Double; fYaw, fPitch, fRoll: Double);
var
fSinYaw, fSinPitch, fSinRoll, fCosYaw, fCosPitch, fCosRoll: Double;
begin
fSinYaw := sin(fYaw / 2.0);
fSinPitch := sin(fPitch / 2.0);
fSinRoll := sin(fRoll / 2.0);
fCosYaw := cos(fYaw / 2.0);
fCosPitch := cos(fPitch / 2.0);
fCosRoll := cos(fRoll / 2.0);
 
x := fSinRoll * fCosPitch * fCosYaw - fCosRoll * fSinPitch * fSinYaw;
y := fCosRoll * fSinPitch * fCosYaw + fSinRoll * fCosPitch * fSinYaw;
z := fCosRoll * fCosPitch * fSinYaw - fSinRoll * fSinPitch * fCosYaw;
w := fCosRoll * fCosPitch * fCosYaw + fSinRoll * fSinPitch * fSinYaw;
end;
 
//-----------------------------------------------------------------------------
// Name: D3DMath_MatrixFromQuaternion()
// Desc: Converts a unit quaternion into a rotation matrix.
//-----------------------------------------------------------------------------
 
procedure D3DMath_MatrixFromQuaternion(var mat: TD3DMatrix; x, y, z, w: Double);
var
xx, yy, zz, xy, xz, yz, wx, wy, wz: Double;
begin
xx := x * x; yy := y * y; zz := z * z;
xy := x * y; xz := x * z; yz := y * z;
wx := w * x; wy := w * y; wz := w * z;
 
mat._11 := 1 - 2 * (yy + zz);
mat._12 := 2 * (xy - wz);
mat._13 := 2 * (xz + wy);
 
mat._21 := 2 * (xy + wz);
mat._22 := 1 - 2 * (xx + zz);
mat._23 := 2 * (yz - wx);
 
mat._31 := 2 * (xz - wy);
mat._32 := 2 * (yz + wx);
mat._33 := 1 - 2 * (xx + yy);
 
mat._14 := 0.0; mat._24 := 0.0; mat._34 := 0.0;
mat._41 := 0.0; mat._42 := 0.0; mat._43 := 0.0;
mat._44 := 1.0;
end;
 
function D3DMath_MatrixFromQuaternion(q: TQuaternion): TD3DMatrix;
begin
D3DMath_MatrixFromQuaternion(Result, q.X, q.Y, q.Z, q.W)
end;
 
//-----------------------------------------------------------------------------
// Name: D3DMath_QuaternionFromMatrix()
// Desc: Converts a rotation matrix into a unit quaternion.
//-----------------------------------------------------------------------------
 
procedure D3DMath_QuaternionFromMatrix(var x, y, z, w: Double; var mat: TD3DMatrix);
var
s: Double;
xx, yy, zz, xy, xz, yz, wx, wy, wz: Double;
begin
if (mat._11 + mat._22 + mat._33 > 0.0) then
begin
s := sqrt(mat._11 + mat._22 + mat._33 + mat._44);
 
x := (mat._23 - mat._32) / (2 * s);
y := (mat._31 - mat._13) / (2 * s);
z := (mat._12 - mat._21) / (2 * s);
w := 0.5 * s;
end;
 
xx := x * x; yy := y * y; zz := z * z;
xy := x * y; xz := x * z; yz := y * z;
wx := w * x; wy := w * y; wz := w * z;
 
mat._11 := 1 - 2 * (yy + zz);
mat._12 := 2 * (xy - wz);
mat._13 := 2 * (xz + wy);
 
mat._21 := 2 * (xy + wz);
mat._22 := 1 - 2 * (xx + zz);
mat._23 := 2 * (yz - wx);
 
mat._31 := 2 * (xz - wy);
mat._32 := 2 * (yz + wx);
mat._33 := 1 - 2 * (xx + yy);
 
mat._14 := 0.0; mat._24 := 0.0; mat._34 := 0.0;
mat._41 := 0.0; mat._42 := 0.0; mat._43 := 0.0;
mat._44 := 1.0;
end;
 
//-----------------------------------------------------------------------------
// Name: D3DMath_QuaternionMultiply()
// Desc: Mulitples two quaternions together as in {Q} = {A} * {B}.
//-----------------------------------------------------------------------------
 
procedure D3DMath_QuaternionMultiply(var Qx, Qy, Qz, Qw: Double;
Ax, Ay, Az, Aw, Bx, By, Bz, Bw: Double);
var
Dx, Dy, Dz, Dw: Double;
begin
Dx := Ax * Bw + Ay * Bz - Az * By + Aw * Bx;
Dy := -Ax * Bz + Ay * Bw + Az * Bx + Aw * By;
Dz := Ax * By - Ay * Bx + Az * Bw + Aw * Bz;
Dw := -Ax * Bx - Ay * By - Az * Bz + Aw * Bw;
 
Qx := Dx; Qy := Dy; Qz := Dz; Qw := Dw;
end;
 
function D3DMath_QuaternionMultiply(a, b: TQuaternion): TQuaternion;
var
Qx, Qy, Qz, Qw: Double;
begin
D3DMath_QuaternionMultiply(Qx, Qy, Qz, Qw, A.x, A.y, A.z, A.w, B.x, B.y, B.z, B.w);
Result.X := Qx;
Result.Y := Qy;
Result.Z := Qz;
Result.W := Qw;
end;
 
//-----------------------------------------------------------------------------
// Name: D3DMath_SlerpQuaternions()
// Desc: Compute a quaternion which is the spherical linear interpolation
// between two other quaternions by dvFraction.
//-----------------------------------------------------------------------------
 
procedure D3DMath_QuaternionSlerp(var Qx, Qy, Qz, Qw: Double;
Ax, Ay, Az, Aw, Bx, By, Bz, Bw, fAlpha: Double);
var
fCosTheta: Double;
fBeta: Double;
fTheta: Double;
begin
// Compute dot product (equal to cosine of the angle between quaternions)
fCosTheta := Ax * Bx + Ay * By + Az * Bz + Aw * Bw;
 
// Check angle to see if quaternions are in opposite hemispheres
if fCosTheta < 0.0 then
begin
// If so, flip one of the quaterions
fCosTheta := -fCosTheta;
Bx := -Bx; By := -By; Bz := -Bz; Bw := -Bw;
end;
 
// Set factors to do linear interpolation, as a special case where the
// quaternions are close together.
fBeta := 1.0 - fAlpha;
 
// If the quaternions aren't close, proceed with spherical interpolation
if 1.0 - fCosTheta > 0.001 then
begin
fTheta := arccos(fCosTheta);
 
fBeta := sin(fTheta * fBeta) / sin(fTheta);
fAlpha := sin(fTheta * fAlpha) / sin(fTheta);
end;
 
// Do the interpolation
Qx := fBeta * Ax + fAlpha * Bx;
Qy := fBeta * Ay + fAlpha * By;
Qz := fBeta * Az + fAlpha * Bz;
Qw := fBeta * Aw + fAlpha * Bw;
end;
 
function D3DMath_QuaternionSlerp(A, B: TQuaternion; fAlpha: Double): TQuaternion;
var
Qx, Qy, Qz, Qw: Double;
begin
D3DMath_QuaternionSlerp(Qx, Qy, Qz, Qw, A.x, A.y, A.z, A.w, B.x, B.y, B.z, B.w, fAlpha);
Result.X := Qx;
Result.Y := Qy;
Result.Z := Qz;
Result.W := Qw;
end;
 
//-----------------------------------------------------------------------------
// File: D3DUtil.cpp
//
// Desc: Shortcut macros and functions for using DX objects
//
//
// Copyright (c) 1997-1999 Microsoft Corporation. All rights reserved
//-----------------------------------------------------------------------------
 
//-----------------------------------------------------------------------------
// Name: D3DUtil_InitSurfaceDesc()
// Desc: Helper function called to build a DDSURFACEDESC2 structure,
// typically before calling CreateSurface() or GetSurfaceDesc()
//-----------------------------------------------------------------------------
 
procedure D3DUtil_InitSurfaceDesc(var ddsd: TDDSurfaceDesc2; dwFlags, dwCaps: DWORD);
begin
FillChar(ddsd, SizeOf(ddsd), 0);
ddsd.dwSize := SizeOf(ddsd);
ddsd.dwFlags := dwFlags;
ddsd.ddsCaps.dwCaps := dwCaps;
ddsd.ddpfPixelFormat.dwSize := SizeOf(ddsd.ddpfPixelFormat);
end;
 
//-----------------------------------------------------------------------------
// Name: D3DUtil_InitMaterial()
// Desc: Helper function called to build a D3DMATERIAL7 structure
//-----------------------------------------------------------------------------
 
procedure D3DUtil_InitMaterial(var mtrl: TD3DMaterial7; r, g, b, a: Double);
begin
FillChar(mtrl, SizeOf(mtrl), 0);
mtrl.dcvDiffuse.r := r; mtrl.dcvAmbient.r := r;
mtrl.dcvDiffuse.g := g; mtrl.dcvAmbient.g := g;
mtrl.dcvDiffuse.b := b; mtrl.dcvAmbient.b := b;
mtrl.dcvDiffuse.a := a; mtrl.dcvAmbient.a := a;
end;
 
//-----------------------------------------------------------------------------
// Name: D3DUtil_InitLight()
// Desc: Initializes a D3DLIGHT7 structure
//-----------------------------------------------------------------------------
 
procedure D3DUtil_InitLight(var light: TD3DLight7; ltType: TD3DLightType; x, y, z: Double);
begin
FillChar(light, SizeOf(light), 0);
light.dltType := ltType;
light.dcvDiffuse.r := 1.0;
light.dcvDiffuse.g := 1.0;
light.dcvDiffuse.b := 1.0;
light.dcvSpecular := light.dcvDiffuse;
light.dvPosition.x := x; light.dvDirection.x := x;
light.dvPosition.y := y; light.dvDirection.y := y;
light.dvPosition.z := z; light.dvDirection.z := z;
light.dvAttenuation0 := 1.0;
light.dvRange := D3DLIGHT_RANGE_MAX;
end;
 
procedure D3DUtil_SetIdentityMatrix(out m: TD3DMatrix);
begin
m._12 := 0; m._13 := 0; m._14 := 0; m._21 := 0; m._23 := 0; m._24 := 0;
m._31 := 0; m._32 := 0; m._34 := 0; m._41 := 0; m._42 := 0; m._43 := 0;
m._11 := 1; m._22 := 1; m._33 := 1; m._44 := 1;
end;
 
function D3DUtil_SetIdentityMatrix: TD3DMatrix;
begin
D3DUtil_SetIdentityMatrix(Result);
end;
 
function D3DUtil_SetScaleMatrix(const x, y, z: Single): TD3DMatrix;
begin
with Result do
begin
_11 := x; _12 := 0; _13 := 0; _14 := 0;
_21 := 0; _22 := y; _23 := 0; _24 := 0;
_31 := 0; _32 := 0; _33 := z; _34 := 0;
_41 := 0; _42 := 0; _43 := 0; _44 := 1;
end;
end;
 
//-----------------------------------------------------------------------------
// Name: D3DUtil_SetViewMatrix()
// Desc: Given an eye point, a lookat point, and an up vector, this
// function builds a 4x4 view matrix.
//-----------------------------------------------------------------------------
 
function D3DUtil_SetViewMatrix(var mat: TD3DMatrix; const vFrom, vAt, vWorldUp: TD3DVector): HResult;
var
vView: TD3DVector;
fLength: Double;
fDotProduct: Double;
vUp: TD3DVector;
vRight: TD3DVector;
begin
// Get the z basis vector, which points straight ahead. This is the
// difference from the eyepoint to the lookat point.
vView := VectorSub(vAt, vFrom);
 
fLength := VectorMagnitude(vView);
if fLength < 0.1E-6 then
begin
Result := E_INVALIDARG;
Exit;
end;
 
// Normalize the z basis vector
vView := VectorDivS(vView, fLength);
 
// Get the dot product, and calculate the projection of the z basis
// vector onto the up vector. The projection is the y basis vector.
fDotProduct := VectorDotProduct(vWorldUp, vView);
 
vUp := VectorSub(vWorldUp, VectorMulS(vView, fDotProduct));
 
// If this vector has near-zero length because the input specified a
// bogus up vector, let's try a default up vector
fLength := VectorMagnitude(vUp);
if 1E-6 > fLength then
begin
vUp := VectorSub(MakeD3DVector(0, 1, 0), VectorMulS(vView, vView.y));
 
// If we still have near-zero length, resort to a different axis.
fLength := VectorMagnitude(vUp);
if 1E-6 > fLength then
begin
vUp := VectorSub(MakeD3DVector(0, 0, 1), VectorMulS(vView, vView.z));
 
fLength := VectorMagnitude(vUp);
if 1E-6 > fLength then
begin
Result := E_INVALIDARG;
Exit;
end;
end;
end;
 
// Normalize the y basis vector
vUp := VectorDivS(vUp, fLength);
 
// The x basis vector is found simply with the cross product of the y
// and z basis vectors
vRight := VectorCrossProduct(vUp, vView);
 
// Start building the matrix. The first three rows contains the basis
// vectors used to rotate the view to point at the lookat point
D3DUtil_SetIdentityMatrix(mat);
mat._11 := vRight.x; mat._12 := vUp.x; mat._13 := vView.x;
mat._21 := vRight.y; mat._22 := vUp.y; mat._23 := vView.y;
mat._31 := vRight.z; mat._32 := vUp.z; mat._33 := vView.z;
 
// Do the translation values (rotations are still about the eyepoint)
mat._41 := -VectorDotProduct(vFrom, vRight);
mat._42 := -VectorDotProduct(vFrom, vUp);
mat._43 := -VectorDotProduct(vFrom, vView);
 
Result := S_OK;
end;
 
//-----------------------------------------------------------------------------
// Name: D3DUtil_SetProjectionMatrix()
// Desc: Sets the passed in 4x4 matrix to a perpsective projection matrix built
// from the field-of-view (fov, in y), aspect ratio, near plane (D),
// and far plane (F). Note that the projection matrix is normalized for
// element [3][4] to be 1.0. This is performed so that W-based range fog
// will work correctly.
//-----------------------------------------------------------------------------
 
function D3DUtil_SetProjectionMatrix(var mat: TD3DMatrix; fFOV, fAspect, fNearPlane, fFarPlane: Double): HResult;
var
w, h, Q: Double;
begin
if (abs(fFarPlane - fNearPlane) < 0.01) or (abs(sin(fFOV / 2)) < 0.01) then
begin
Result := E_INVALIDARG;
Exit;
end;
 
w := fAspect * (cos(fFOV / 2) / sin(fFOV / 2));
h := 1.0 * (cos(fFOV / 2) / sin(fFOV / 2));
Q := fFarPlane / (fFarPlane - fNearPlane);
 
FillChar(mat, SizeOf(mat), 0);
mat._11 := w;
mat._22 := h;
mat._33 := Q;
mat._34 := 1.0;
mat._43 := -Q * fNearPlane;
 
Result := S_OK;
end;
 
//-----------------------------------------------------------------------------
// Name: D3DUtil_SetRotateXMatrix()
// Desc: Create Rotation matrix about X axis
//-----------------------------------------------------------------------------
 
procedure D3DUtil_SetRotateXMatrix(var mat: TD3DMatrix; fRads: Double);
begin
D3DUtil_SetIdentityMatrix(mat);
mat._22 := cos(fRads);
mat._23 := sin(fRads);
mat._32 := -sin(fRads);
mat._33 := cos(fRads);
end;
 
function D3DUtil_SetRotateXMatrix(fRads: Double): TD3DMatrix;
begin
D3DUtil_SetRotateXMatrix(Result, fRads);
end;
 
//-----------------------------------------------------------------------------
// Name: D3DUtil_SetRotateYMatrix()
// Desc: Create Rotation matrix about Y axis
//-----------------------------------------------------------------------------
 
procedure D3DUtil_SetRotateYMatrix(var mat: TD3DMatrix; fRads: Double);
begin
D3DUtil_SetIdentityMatrix(mat);
mat._11 := cos(fRads);
mat._13 := -sin(fRads);
mat._31 := sin(fRads);
mat._33 := cos(fRads);
end;
 
function D3DUtil_SetRotateYMatrix(fRads: Double): TD3DMatrix;
begin
D3DUtil_SetRotateYMatrix(Result, fRads);
end;
 
//-----------------------------------------------------------------------------
// Name: D3DUtil_SetRotateZMatrix()
// Desc: Create Rotation matrix about Z axis
//-----------------------------------------------------------------------------
 
procedure D3DUtil_SetRotateZMatrix(var mat: TD3DMatrix; fRads: Double);
begin
D3DUtil_SetIdentityMatrix(mat);
mat._11 := cos(fRads);
mat._12 := sin(fRads);
mat._21 := -sin(fRads);
mat._22 := cos(fRads);
end;
 
function D3DUtil_SetRotateZMatrix(fRads: Double): TD3DMatrix;
begin
D3DUtil_SetRotateZMatrix(Result, fRads);
end;
 
//-----------------------------------------------------------------------------
// Name: D3DUtil_SetRotationMatrix
// Desc: Create a Rotation matrix about vector direction
//-----------------------------------------------------------------------------
 
procedure D3DUtil_SetRotationMatrix(var mat: TD3DMatrix; var vDir: TD3DVector; fRads: Double);
var
fCos, fSin: Double;
v: TD3DVector;
begin
fCos := cos(fRads);
fSin := sin(fRads);
v := VectorNormalize(vDir);
 
mat._11 := (v.x * v.x) * (1.0 - fCos) + fCos;
mat._12 := (v.x * v.y) * (1.0 - fCos) - (v.z * fSin);
mat._13 := (v.x * v.z) * (1.0 - fCos) + (v.y * fSin);
 
mat._21 := (v.y * v.x) * (1.0 - fCos) + (v.z * fSin);
mat._22 := (v.y * v.y) * (1.0 - fCos) + fCos;
mat._23 := (v.y * v.z) * (1.0 - fCos) - (v.x * fSin);
 
mat._31 := (v.z * v.x) * (1.0 - fCos) - (v.y * fSin);
mat._32 := (v.z * v.y) * (1.0 - fCos) + (v.x * fSin);
mat._33 := (v.z * v.z) * (1.0 - fCos) + fCos;
 
mat._14 := 0; mat._24 := 0; mat._34 := 0;
mat._41 := 0; mat._42 := 0; mat._43 := 0;
mat._44 := 1.0;
end;
 
function D3DUtil_SetRotationMatrixByX(const a: TD3DVector; const r: Double): TD3DVector;
begin
Result.X := a.X;
Result.Y := a.Y * Cos(r) + a.Z * Sin(r);
Result.Z := -a.Y * Sin(r) + a.Z * Cos(r);
end;
 
function D3DUtil_SetRotationMatrixByY(const a: TD3DVector; const r: Double): TD3DVector;
begin
Result.X := a.X * Cos(r) - a.Z * Sin(r);
Result.Y := a.Y;
Result.Z := a.X * Sin(r) + a.Z * Cos(r);
end;
 
function D3DUtil_SetRotationMatrixByZ(const a: TD3DVector; const r: Double): TD3DVector;
begin
Result.X := a.X * Cos(r) + a.Y * Sin(r);
Result.Y := -a.X * Sin(r) + a.Y * Cos(r);
Result.Z := a.Z;
end;
 
// simple D2D operation
 
function D2DMath_VecAdd(const a: TD2DVector; const b: TD2DVector): TD2DVector;
begin
Result.X := a.X + b.X;
Result.Y := a.Y + b.Y;
end;
 
function D2DMath_VecSub(const a: TD2DVector; const b: TD2DVector): TD2DVector;
begin
Result.X := a.X - b.X;
Result.Y := a.Y - b.Y;
end;
 
function D2DMath_VecDotProduct(const a, b: TD2DVector): Single;
begin
Result := a.X * b.X + a.Y * b.Y;
end;
 
function D2DMath_VecDistance(const a, b: TD2DVector): Single;
begin
Result := sqrt(SQR(a.X - b.X) + SQR(a.Y - b.Y));
end;
 
function D2DMath_VecLength(const a: TD2DVector): Single;
begin
Result := sqrt(SQR(a.X) + SQR(a.Y));
end;
 
function D2DMath_VecNormalize(const a: TD2DVector): TD2DVector;
var
len: Single;
begin
len := D2DMath_VecLength(a);
if len = 0 then
begin
result := MakeD2DVector(0, 0);
Exit;
end;
 
result.X := a.X / len;
result.Y := a.Y / len;
end;
 
function D2DMath_VecToAngle(const a: TD2DVector): Double;
var
v: TD2DVector;
sg: Integer;
hi, lo, mid: Integer;
begin
Result := 0.0;
 
v := D2DMath_VecNormalize(a);
 
if (v.y > 0) then
begin
if v.x > 0 then
sg := 1
else
begin
sg := 2;
v.x := -v.x;
end;
end
else
if (v.y < 0) then
begin
if v.x >= 0 then
sg := 4
else
begin
sg := 3;
v.x := -v.x;
end;
end
else
begin
if v.x >= 0 then
sg := 1
else
begin
sg := 3;
v.x := -v.x;
end;
end;
 
 
hi := 1023;
lo := 0;
mid := 511;
 
while hi > lo do
begin
if Cos(mid / 2048.0 * Pi) > v.x then
lo := mid + 1
else
hi := mid;
mid := (hi + lo) shr 1;
end;
 
case sg of
1: result := mid;
2: result := 2047 - mid;
3: result := 2048 + mid;
4: result := 4095 - mid;
end;
 
// to radians
Result := Result * Pi / 2048.0;
end;
 
function D2DMath_VecRot(const a: TD2DVector; const angle: Double): TD2DVector;
begin
Result.X := a.X * Cos(angle) - a.Y * Sin(angle);
Result.Y := a.X * Sin(angle) + a.Y * Cos(angle);
end;
 
 
function D2DMath_VecScale(const a: TD2DVector; const scale: Double): TD2DVector;
begin
Result.X := a.X * scale;
Result.Y := a.Y * scale;
end;
 
function D2DMath_VecChangeLength(const a: TD2DVector; const k: Single): TD2DVector;
var
len: Single;
begin
len := D2DMath_VecLength(a);
if len = 0 then
begin
Result := MakeD2DVector(0, 0);
Exit;
end;
 
Result.X := a.X * k / len;
Result.Y := a.Y * k / len;
end;
 
function D2DMath_VecLookAt(const pos: TD2DVector; const target: TD2DVector; const k: Single): TD2DVector;
var
sub: TD2DVector;
len: Single;
begin
sub := D2DMath_VecSub(target, pos);
len := D2DMath_VecLength(sub);
if len = 0 then
begin
Result := MakeD2DVector(0, 0);
Exit;
end;
 
Result.X := sub.X * k / len;
Result.Y := sub.Y * k / len;
end;
 
function D2DMath_VecRandom2D(const k: Single): TD2DVector;
begin
Result := D2DMath_VecChangeLength(MakeD2DVector(Random - 0.5, Random - 0.5), k);
end;
 
function D2DMath_VecLerp(const a: TD2DVector; const b: TD2DVector; const rate: Single): TD2DVector;
begin
Result.x := rate * b.x + (1.0 - rate) * a.x;
Result.y := rate * b.y + (1.0 - rate) * a.y;
end;
 
 
end.
 
/VCL_DELPHIX_D6/DAnim.pas
22,7 → 22,9
 
{$Z4}
{$A+}
{$IfNDef D7UP}
{$WEAKPACKAGEUNIT}
{$EndIf}
 
uses Windows, ActiveX, DirectX, DShow;
 
1109,18 → 1111,18
out lplpDDClipper: IDirectDrawClipper; pUnkOuter: IUnknown): HResult; stdcall;
function CreatePalette(dwFlags: DWORD; lpColorTable: PPaletteEntry;
out lplpDDPalette: IDirectDrawPalette; pUnkOuter: IUnknown): HResult;stdcall;
function CreateSurface(const lpDDSurfaceDesc: DDSURFACEDESC;
function CreateSurface(const lpDDSurfaceDesc: TDDSURFACEDESC;
out lplpDDSurface: IDirectDrawSurface; pUnkOuter: IUnknown): HResult; stdcall;
function DuplicateSurface(lpDDSurface: IDirectDrawSurface;
out lplpDupDDSurface: IDirectDrawSurface): HResult; stdcall;
function EnumDisplayModes(dwFlags: DWORD;
const lpDDSurfaceDesc: DDSURFACEDESC; lpContext: Pointer;
lpEnumModesCallback: LPDDENUMMODESCALLBACK): HResult; stdcall;
function EnumSurfaces(dwFlags: DWORD; const lpDDSD: DDSURFACEDESC;
lpContext: Pointer; lpEnumCallback: LPDDENUMSURFACESCALLBACK): HResult; stdcall;
const lpDDSurfaceDesc: TDDSURFACEDESC; lpContext: Pointer;
lpEnumModesCallback: {LPDDENUMMODESCALLBACK}TDDEnumModesCallback): HResult; stdcall;
function EnumSurfaces(dwFlags: DWORD; const lpDDSD: TDDSURFACEDESC;
lpContext: Pointer; lpEnumCallback: {LPDDENUMSURFACESCALLBACK}TDDEnumSurfacesCallback): HResult; stdcall;
function FlipToGDISurface: HResult; stdcall;
function GetCaps(var lpDDDriverCaps: DDCAPS; var lpDDHELCaps: DDCAPS): HResult; stdcall;
function GetDisplayMode(var lpDDSurfaceDesc: DDSURFACEDESC): HResult; stdcall;
function GetCaps(var lpDDDriverCaps: TDDCAPS; var lpDDHELCaps: TDDCAPS): HResult; stdcall;
function GetDisplayMode(var lpDDSurfaceDesc: TDDSURFACEDESC): HResult; stdcall;
function GetFourCCCodes(var lpNumCodes, lpCodes: DWORD): HResult; stdcall;
function GetGDISurface(out lplpGDIDDSSurface: IDirectDrawSurface): HResult; stdcall;
function GetMonitorFrequency(var lpdwFrequency: DWORD): HResult; stdcall;
1133,7 → 1135,7
dwFlags: DWORD): HResult; stdcall;
function WaitForVerticalBlank(dwFlags: DWORD; hEvent: THandle): HResult; stdcall;
// IDirectDraw2 methods
function GetAvailableVidMem(var lpDDSCaps: DDSCAPS;
function GetAvailableVidMem(var lpDDSCaps: TDDSCAPS;
var lpdwTotal, lpdwFree: DWORD): HResult; stdcall;
// IDirectDraw3 methods
function GetSurfaceFromDC(hdc: HDC; out ppSurface: IDirectDrawSurface): HResult; stdcall;
/VCL_DELPHIX_D6/DIB.pas
1,13 → 1,40
{*******************************************************}
{ }
{ DIB and PAINTBOX componets }
{ }
{ Copyright (C) 1997-2000 Hiroyuki Hori }
{ base components and effects }
{ Copyright (C) 2000 Keith Murray }
{ supernova effect }
{ Copyright (C) 2000 Michel Hibon }
{ new special effects added for DIB }
{ Copyright (C) 2001 Joakim Back }
{ conFusion effects (as DxFusion) }
{ Copyright (C) 2003 Babak Sateli }
{ 24-bit DIB effect as supplement ones }
{ Copyright (C) 2004-2012 Jaro Benes }
{ 32-bit DIB effect with alphachannel }
{ direct works with texture buffer }
{ modified and adapted all adopted functions }
{ }
{*******************************************************}
 
unit DIB;
 
interface
 
{$INCLUDE DelphiXcfg.inc}
{$DEFINE USE_SCANLINE}
 
uses
Windows, SysUtils, Classes, Graphics, Controls;
Windows, SysUtils, Classes, Graphics, Controls,
{$IFDEF VER17UP} Types, UITypes,{$ENDIF}
Math;
 
type
TColorLineStyle = (csSolid, csGradient, csRainbow);
TColorLinePixelGeometry = (pgPoint, pgCircular, pgRectangular);
PRGBQuads = ^TRGBQuads;
TRGBQuads = array[0..255] of TRGBQuad;
 
TPaletteEntries = array[0..255] of TPaletteEntry;
17,6 → 44,16
B, G, R: Byte;
end;
 
{ Added this type for New SPecial Effect }
TFilter = array[0..2, 0..2] of SmallInt;
TLines = array[0..0] of TBGR;
PLines = ^TLines;
TBytes = array[0..0] of Byte;
PBytes = ^TBytes;
TPBytes = array[0..0] of PBytes;
PPBytes = ^TPBytes;
{ End of type's }
 
PArrayBGR = ^TArrayBGR;
TArrayBGR = array[0..10000] of TBGR;
 
29,7 → 66,7
PArrayDWord = ^TArrayDWord;
TArrayDWord = array[0..10000] of DWord;
 
{ TDIB }
{ TDIBPixelFormat }
 
TDIBPixelFormat = record
RBitMask, GBitMask, BBitMask: DWORD;
38,6 → 75,8
RBitCount2, GBitCount2, BBitCount2: DWORD;
end;
 
{ TDIBSharedImage }
 
TDIBSharedImage = class(TSharedImage)
private
FBitCount: Integer;
64,7 → 103,7
constructor Create;
procedure NewImage(AWidth, AHeight, ABitCount: Integer;
const PixelFormat: TDIBPixelFormat; const ColorTable: TRGBQuads; MemoryImage, Compressed: Boolean);
procedure Duplicate(Source: TDIBSharedImage; MemoryImage: Boolean);
procedure Duplicate(Source: TDIBSharedImage; MemoryImage: Boolean); {$IFDEF VER9UP}inline;{$ENDIF}
procedure Compress(Source: TDIBSharedImage);
procedure Decompress(Source: TDIBSharedImage; MemoryImage: Boolean);
procedure ReadData(Stream: TStream; MemoryImage: Boolean);
76,6 → 115,33
destructor Destroy; override;
end;
 
{ TFilterTypeResample }
 
TFilterTypeResample = (ftrBox, ftrTriangle, ftrHermite, ftrBell, ftrBSpline,
ftrLanczos3, ftrMitchell);
 
TDistortType = (dtFast, dtSlow);
{DXFusion effect type}
TFilterMode = (fmNormal, fmMix50, fmMix25, fmMix75);
 
{ TLightSource }
 
TLightSource = record
X, Y: Integer;
Size1, Size2: Integer;
Color: TColor;
end;
 
{ TLightArray }
 
TLightArray = array{$IFNDEF VER4UP} [0..0]{$ENDIF} of TLightsource;
 
{ TMatrixSetting }
 
TMatrixSetting = array[0..9] of Integer;
 
{ TDIB }
 
TDIB = class(TGraphic)
private
FCanvas: TCanvas;
96,6 → 162,10
FTopPBits: Pointer;
FWidth: Integer;
FWidthBytes: Integer;
FLUTDist: array[0..255, 0..255] of Integer;
LG_COUNT: Integer;
LG_DETAIL: Integer;
FFreeList: TList;
procedure AllocHandle;
procedure CanvasChanging(Sender: TObject);
procedure Changing(MemoryImage: Boolean);
113,15 → 183,28
function GetTopPBits: Pointer;
function GetTopPBitsReadOnly: Pointer;
procedure SetBitCount(Value: Integer);
procedure SetImage(Value: TDIBSharedImage);
procedure SetImage(Value: TDIBSharedImage); {$IFDEF VER9UP}inline;{$ENDIF}
procedure SetNowPixelFormat(const Value: TDIBPixelFormat);
procedure SetPixel(X, Y: Integer; Value: DWORD);
procedure StartProgress(const Name: string);
procedure EndProgress;
procedure UpdateProgress(PercentY: Integer);
 
{ Added these 3 functions for New Specials Effects }
function Interval(iMin, iMax, iValue: Integer; iMark: Boolean): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
function IntToByte(i: Integer): Byte; {$IFDEF VER9UP}inline;{$ENDIF}
function TrimInt(i, Min, Max: Integer): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
{ End of 3 functions for New Special Effect }
 
procedure Darkness(Amount: Integer);
function GetAlphaChannel: TDIB;
procedure SetAlphaChannel(const Value: TDIB);
function GetClientRect: TRect;
function GetRGBChannel: TDIB;
procedure SetRGBChannel(const Value: TDIB);
protected
procedure DefineProperties(Filer: TFiler); override;
procedure Draw(ACanvas: TCanvas; const Rect: TRect); override;
procedure Draw(ACanvas: TCanvas; const ARect: TRect); override;
function GetEmpty: Boolean; override;
function GetHeight: Integer; override;
function GetPalette: HPalette; override;
141,6 → 224,9
procedure Compress;
procedure Decompress;
procedure FreeHandle;
function HasAlphaChannel: Boolean;
function AssignAlphaChannel(ALPHA: TDIB; ForceResize: Boolean{$IFDEF VER4UP} = False{$ENDIF}): Boolean;
procedure RetAlphaChannel(out oDIB: TDIB);
procedure LoadFromClipboardFormat(AFormat: Word; AData: THandle;
APalette: HPALETTE); override;
procedure LoadFromStream(Stream: TStream); override;
147,7 → 233,7
procedure SaveToClipboardFormat(var AFormat: Word; var AData: THandle;
var APalette: HPALETTE); override;
procedure SaveToStream(Stream: TStream); override;
procedure SetSize(AWidth, AHeight, ABitCount: Integer);
procedure SetSize(AWidth, AHeight, ABitCount: Integer); {$IFDEF VER5UP}reintroduce;{$ENDIF} //{$IFDEF VER9UP} overload;{$ENDIF}
procedure UpdatePalette;
{ Special effect }
procedure Blur(ABitCount: Integer; Radius: Integer);
155,6 → 241,160
procedure Mirror(MirrorX, MirrorY: Boolean);
procedure Negative;
 
{ Added New Special Effect }
procedure Spray(Amount: Integer);
procedure Emboss;
procedure AddMonoNoise(Amount: Integer);
procedure AddGradiantNoise(Amount: byte);
function Twist(bmp: TDIB; Amount: byte): Boolean;
function FishEye(bmp: TDIB): Boolean;
function SmoothRotateWrap(Bmp: TDIB; cx, cy: Integer; Degree: Extended): Boolean;
procedure Lightness(Amount: Integer);
procedure Saturation(Amount: Integer);
procedure Contrast(Amount: Integer);
procedure AddRGB(aR, aG, aB: Byte);
function Filter(Dest: TDIB; Filter: TFilter): Boolean;
procedure Sharpen(Amount: Integer);
function IntToColor(i: Integer): TBGR; {$IFDEF VER9UP}inline;{$ENDIF}
function Rotate(Dst: TDIB; cx, cy: Integer; Angle: Double): Boolean;
procedure SplitBlur(Amount: Integer);
procedure GaussianBlur(Bmp: TDIB; Amount: Integer);
{ End of New Special Effect }
{
New effect for TDIB
with Some Effects like AntiAlias, Contrast,
Lightness, Saturation, GaussianBlur, Mosaic,
Twist, Splitlight, Trace, Emboss, etc.
Works with 24bit color DIBs.
 
This component is based on TProEffectImage component version 1.0 by
Written By Babak Sateli (babak_sateli@yahoo.com, http://raveland.netfirms.com)
 
and modified by (c) 2004 Jaro Benes
for DelphiX use.
 
Demo was modified into DXForm with function like original
 
DISCLAIMER
This component is provided AS-IS without any warranty of any kind, either express or
implied. This component is freeware and can be used in any software product.
}
procedure DoInvert;
procedure DoAddColorNoise(Amount: Integer);
procedure DoAddMonoNoise(Amount: Integer);
procedure DoAntiAlias;
procedure DoContrast(Amount: Integer);
procedure DoFishEye(Amount: Integer);
procedure DoGrayScale;
procedure DoLightness(Amount: Integer);
procedure DoDarkness(Amount: Integer);
procedure DoSaturation(Amount: Integer);
procedure DoSplitBlur(Amount: Integer);
procedure DoGaussianBlur(Amount: Integer);
procedure DoMosaic(Size: Integer);
procedure DoTwist(Amount: Integer);
procedure DoSplitlight(Amount: Integer);
procedure DoTile(Amount: Integer);
procedure DoSpotLight(Amount: Integer; Spot: TRect);
procedure DoTrace(Amount: Integer);
procedure DoEmboss;
procedure DoSolorize(Amount: Integer);
procedure DoPosterize(Amount: Integer);
procedure DoBrightness(Amount: Integer);
procedure DoResample(AmountX, AmountY: Integer; TypeResample: TFilterTypeResample);
{rotate}
procedure DoSmoothRotate(Src: TDIB; cx, cy: Integer; Angle: Extended);
procedure DoColorize(ForeColor, BackColor: TColor);
{Simple explosion spoke effect}
procedure DoNovaEffect(sr, sg, sb, cx, cy, radius,
nspokes, randomhue, randomspok, randgauss: Integer; onProgress: TProgressEvent);
 
{Simple Mandelbrot-set drawing}
procedure DrawMandelbrot(ao, au: Integer; bo, bu: Double);
 
{Sephia effect}
procedure SephiaEffect(Depth: Integer{$IFDEF VER4UP} = 20{$ENDIF});
 
{Simple blend pixel}
procedure BlendPixel(const X, Y: Integer; aColor: Cardinal; Alpha: Byte); {$IFDEF VER9UP}inline;{$ENDIF}
{Line in polar system}
procedure LinePolar(x, y: Integer; AngleInDegree, Length: extended;
Color: cardinal);
 
{special version Dark/Light procedure in percent}
procedure Darker(Percent: Integer);
procedure Lighter(Percent: Integer);
 
{Simple graphical crypt}
procedure EncryptDecrypt(const Key: Integer);
 
{ Standalone DXFusion }
{--- c o n F u s i o n ---}
{By Joakim Back, www.back.mine.nu}
{Huge thanks to Ilkka Tuomioja for helping out with the project.}
 
{
modified by (c) 2005 Jaro Benes for DelphiX use.
}
 
procedure CreateDIBFromBitmap(const Bitmap: TBitmap);
{Drawing Methods.}
procedure DrawOn(Dest: TRect; DestCanvas: TCanvas;
Xsrc, Ysrc: Integer);
procedure DrawTo(SrcDIB: TDIB; X, Y, Width, Height, SourceX,
SourceY: Integer);
procedure DrawTransparent(SrcDIB: TDIB; const X, Y, Width, Height,
SourceX, SourceY: Integer; const Color: TColor); {$IFDEF VER5UP} reintroduce;{$ENDIF} //{$IFDEF VER9UP} overload;{$ENDIF}
procedure DrawShadow(SrcDIB: TDIB; X, Y, Width, Height, Frame: Integer;
FilterMode: TFilterMode);
procedure DrawShadows(SrcDIB: TDIB; X, Y, Width, Height, Frame: Integer;
Alpha: Byte);
procedure DrawDarken(SrcDIB: TDIB; X, Y, Width, Height,
Frame: Integer);
procedure DrawAdditive(SrcDIB: TDIB; X, Y, Width, Height: Integer; Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF};
Frame: Integer{$IFDEF VER4UP} = 0{$ENDIF});
procedure DrawQuickAlpha(SrcDIB: TDIB; const X, Y, Width, Height,
SourceX, SourceY: Integer; const Color: TColor;
FilterMode: TFilterMode);
procedure DrawTranslucent(SrcDIB: TDIB; const X, Y, Width, Height,
SourceX, SourceY: Integer; const Color: TColor);
procedure DrawMorphed(SrcDIB: TDIB; const X, Y, Width, Height, SourceX,
SourceY: Integer; const Color: TColor);
procedure DrawAlpha(SrcDIB: TDIB; const X, Y, Width, Height, SourceX,
SourceY, Alpha: Integer; const Color: TColor);
procedure DrawAlphaMask(SrcDIB, MaskDIB: TDIB; const X, Y, Width,
Height, SourceX, SourceY: Integer);
procedure DrawAntialias(SrcDIB: TDIB);
procedure Draw3x3Matrix(SrcDIB: TDIB; Setting: TMatrixSetting);
procedure DrawMono(SrcDIB: TDIB; const X, Y, Width, Height, SourceX,
SourceY: Integer; const TransColor, ForeColor, BackColor: TColor);
{One-color Filters.}
procedure FilterLine(X1, Y1, X2, Y2: Integer; Color: TColor;
FilterMode: TFilterMode); {$IFDEF VER9UP}inline;{$ENDIF}
procedure FilterRect(X, Y, Width, Height: Integer; Color: TColor;
FilterMode: TFilterMode); {$IFDEF VER9UP}inline;{$ENDIF}
{ Lightsource. }
procedure InitLight(Count, Detail: Integer);
procedure DrawLights(FLight: TLightArray; AmbientLight: TColor);
//
// effect for special purpose
//
procedure FadeOut(DIB2: TDIB; Step: Byte);
procedure DoZoom(DIB2: TDIB; ZoomRatio: Real);
procedure DoBlur(DIB2: TDIB);
procedure FadeIn(DIB2: TDIB; Step: Byte);
procedure FillDIB8(Color: Byte);
procedure DoRotate(DIB1: TDIB; cX, cY, Angle: Integer);
procedure Distort(DIB1: TDIB; dt: TDistortType; cX, cY, Angle: Integer; Factor: Real);
function Ink(DIB: TDIB; const SprayInit: Boolean; const AmountSpray: Integer): Boolean;
// lines
procedure AntialiasedLine(x1, y1, x2, y2: Integer; color: TColor); {$IFDEF VER9UP} inline; {$ENDIF}
function GetColorBetween(StartColor, EndColor: TColor; Pointvalue,
FromPoint, ToPoint: Extended): TColor;
procedure ColoredLine(const iStart, iEnd: TPoint; iColorStyle: TColorLineStyle;
iGradientFrom, iGradientTo: TColor; iPixelGeometry: TColorLinePixelGeometry;
iRadius: WORD);
// standard property
property BitCount: Integer read FBitCount write SetBitCount;
property BitmapInfo: PBitmapInfo read GetBitmapInfo;
property BitmapInfoSize: Integer read GetBitmapInfoSize;
174,8 → 414,15
property TopPBitsReadOnly: Pointer read GetTopPBitsReadOnly;
property Width: Integer read FWidth write SetWidth;
property WidthBytes: Integer read FWidthBytes;
property AlphaChannel: TDIB read GetAlphaChannel write SetAlphaChannel;
property RGBChannel: TDIB read GetRGBChannel write SetRGBChannel;
function CreateBitmapFromDIB: TBitmap;
procedure Fill(aColor: TColor);
property ClientRect: TRect read GetClientRect;
end;
 
{ TDIBitmap }
 
TDIBitmap = class(TDIB) end;
 
{ TCustomDXDIB }
235,10 → 482,10
 
TDXPaintBox = class(TCustomDXPaintBox)
published
{$IFDEF DelphiX_Spt4}property Anchors;{$ENDIF}
{$IFDEF VER4UP}property Anchors; {$ENDIF}
property AutoStretch;
property Center;
{$IFDEF DelphiX_Spt4}property Constraints;{$ENDIF}
{$IFDEF VER4UP}property Constraints; {$ENDIF}
property DIB;
property KeepAspect;
property Stretch;
261,34 → 508,105
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
{$IFDEF VER9UP}property OnMouseWheel; {$ENDIF}
{$IFDEF VER9UP}property OnResize; {$ENDIF}
{$IFDEF VER9UP}property OnCanResize; {$ENDIF}
{$IFDEF VER9UP}property OnContextPopup; {$ENDIF}
property OnStartDrag;
end;
 
function MakeDIBPixelFormat(RBitCount, GBitCount, BBitCount: Integer): TDIBPixelFormat;
function MakeDIBPixelFormatMask(RBitMask, GBitMask, BBitMask: Integer): TDIBPixelFormat;
function pfRGB(const PixelFormat: TDIBPixelFormat; R, G, B: Byte): DWORD;
procedure pfGetRGB(const PixelFormat: TDIBPixelFormat; Color: DWORD; var R, G, B: Byte);
function pfGetRValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte;
function pfGetGValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte;
function pfGetBValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte;
const
DefaultFilterRadius: array[TFilterTypeResample] of Single = (0.5, 1, 1, 1.5, 2, 3, 2);
 
function MakeDIBPixelFormat(RBitCount, GBitCount, BBitCount: Integer): TDIBPixelFormat; {$IFDEF VER9UP}inline;{$ENDIF}
function MakeDIBPixelFormatMask(RBitMask, GBitMask, BBitMask: Integer): TDIBPixelFormat; {$IFDEF VER9UP}inline;{$ENDIF}
function pfRGB(const PixelFormat: TDIBPixelFormat; R, G, B: Byte): DWORD; {$IFDEF VER9UP}inline;{$ENDIF}
procedure pfGetRGB(const PixelFormat: TDIBPixelFormat; Color: DWORD; var R, G, B: Byte); {$IFDEF VER9UP}inline;{$ENDIF}
function pfGetRValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte; {$IFDEF VER9UP}inline;{$ENDIF}
function pfGetGValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte; {$IFDEF VER9UP}inline;{$ENDIF}
function pfGetBValue(const PixelFormat: TDIBPixelFormat; Color: DWORD): Byte; {$IFDEF VER9UP}inline;{$ENDIF}
 
function GreyscaleColorTable: TRGBQuads;
 
function RGBQuad(R, G, B: Byte): TRGBQuad;
function PaletteEntryToRGBQuad(const Entry: TPaletteEntry): TRGBQuad;
function PaletteEntriesToRGBQuads(const Entries: TPaletteEntries): TRGBQuads;
function RGBQuadToPaletteEntry(const RGBQuad: TRGBQuad): TPaletteEntry;
function RGBQuadsToPaletteEntries(const RGBQuads: TRGBQuads): TPaletteEntries;
function RGBQuad(R, G, B: Byte): TRGBQuad; {$IFDEF VER9UP}inline;{$ENDIF}
function PaletteEntryToRGBQuad(const Entry: TPaletteEntry): TRGBQuad; {$IFDEF VER9UP}inline;{$ENDIF}
function PaletteEntriesToRGBQuads(const Entries: TPaletteEntries): TRGBQuads; {$IFDEF VER9UP}inline;{$ENDIF}
function RGBQuadToPaletteEntry(const RGBQuad: TRGBQuad): TPaletteEntry; {$IFDEF VER9UP}inline;{$ENDIF}
function RGBQuadsToPaletteEntries(const RGBQuads: TRGBQuads): TPaletteEntries; {$IFDEF VER9UP}inline;{$ENDIF}
 
function PosValue(Value: Integer): Integer;
 
type
TOC = 0..511;
function DSin(const C: TOC): Single; {$IFDEF VER9UP}inline; {$ENDIF}
function DCos(const C: TOC): Single; {$IFDEF VER9UP}inline; {$ENDIF}
 
{ Added Constants for TFilter Type }
const
EdgeFilter: TFilter = ((-1, -1, -1), (-1, 8, -1), (-1, -1, -1));
StrongOutlineFilter: TFilter = ((-100, 0, 0), (0, 0, 0), (0, 0, 100));
Enhance3DFilter: TFilter = ((-100, 5, 5), (5, 5, 5), (5, 5, 100));
LinearFilter: TFilter = ((-40, -40, -40), (-40, 255, -40), (-40, -40, -40));
GranularFilter: TFilter = ((-20, 5, 20), (5, -10, 5), (100, 5, -100));
SharpFilter: TFilter = ((-2, -2, -2), (-2, 20, -2), (-2, -2, -2));
{ End of constants }
 
{ Added Constants for DXFusion Type }
const
{ 3x3 Matrix Presets. }
msEmboss: TMatrixSetting = (-1, -1, 0, -1, 6, 1, 0, 1, 1, 6);
msHardEmboss: TMatrixSetting = (-4, -2, -1, -2, 10, 2, -1, 2, 4, 8);
msBlur: TMatrixSetting = (1, 2, 1, 2, 4, 2, 1, 2, 1, 16);
msSharpen: TMatrixSetting = (-1, -1, -1, -1, 15, -1, -1, -1, -1, 7);
msEdgeDetect: TMatrixSetting = (-1, -1, -1, -1, 8, -1, -1, -1, -1, 1);
 
{Proportionaly scale of size, for recountin image sizes}
function GetScale(SourceWidth, SourceHeight, TargetWidth, TargetHeight: Integer): Single; {$IFDEF VER9UP}inline;{$ENDIF}
 
procedure MakeDib(out DIB: TDIB; const iWidth, iHeight, iBitCount: Integer; iFillColor: TColor{$IFDEF VER4UP} = clBlack{$ENDIF}); {$IFDEF VER4UP}overload; {$ENDIF}
procedure{$IFDEF VER4UP}MakeDib{$ELSE}MakeDIB2{$ENDIF}(out DIB: TDIB; iBitmap: TBitmap); {$IFDEF VER4UP}overload; {$ENDIF}
 
implementation
 
uses DXConsts;
uses DXConsts, {$IFDEF PNG_GRAPHICS}pngimage,{$ENDIF} jpeg;
 
function GetScale(SourceWidth, SourceHeight, TargetWidth, TargetHeight: Integer): Single;
var
XScale, YScale: Single;
begin
XScale := 1;
YScale := 1;
if TargetWidth < SourceWidth then
XScale := TargetWidth / SourceWidth;
if TargetHeight < SourceHeight then
YScale := TargetHeight / SourceHeight;
Result := XScale;
if YScale < Result then
Result := YScale;
end;
 
{$IFNDEF VER4UP}
function Max(B1, B2: Integer): Integer;
begin
if B1>=B2 then Result := B1 else Result := B2;
end;
 
function Min(B1, B2: Integer): Integer;
begin
if B1 <= B2 then Result := B1 else Result := B2;
end;
{$ENDIF}
 
function DSin(const C: TOC): Single; {$IFDEF VER9UP}inline; {$ENDIF}
begin
Result := sin(((c * 360) / 511) * Pi / 180);
end;
 
function DCos(const C: TOC): Single; {$IFDEF VER9UP}inline; {$ENDIF}
begin
Result := cos(((c * 360) / 511) * Pi / 180);
end;
 
function MakeDIBPixelFormat(RBitCount, GBitCount, BBitCount: Integer): TDIBPixelFormat;
begin
Result.RBitMask := ((1 shl RBitCount)-1) shl (GBitCount+BBitCount);
305,9 → 623,7
Result.BShift := 8-BBitCount;
end;
 
function MakeDIBPixelFormatMask(RBitMask, GBitMask, BBitMask: Integer): TDIBPixelFormat;
 
function GetBitCount(b: Integer): Integer;
function GetBitCount(b: Integer): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
var
i: Integer;
begin
322,6 → 638,7
end;
end;
 
function MakeDIBPixelFormatMask(RBitMask, GBitMask, BBitMask: Integer): TDIBPixelFormat;
begin
Result := MakeDIBPixelFormat(GetBitCount(RBitMask), GetBitCount(GBitMask),
GetBitCount(BBitMask));
352,7 → 669,7
with PixelFormat do
begin
Result := (Color and RBitMask) shr RShift;
Result := Result or (Result shr RBitCount);
Result := Result or (Result shr RBitCount2);
end;
end;
 
361,7 → 678,7
with PixelFormat do
begin
Result := (Color and GBitMask) shr GShift;
Result := Result or (Result shr GBitCount);
Result := Result or (Result shr GBitCount2);
end;
end;
 
370,7 → 687,7
with PixelFormat do
begin
Result := (Color and BBitMask) shl BShift;
Result := Result or (Result shr BBitCount);
Result := Result or (Result shr BBitCount2);
end;
end;
 
447,6 → 764,8
RBitMask, GBitMask, BBitMask: DWORD;
end;
 
{ TPaletteItem }
 
TPaletteItem = class(TCollectionItem)
private
ID: Integer;
456,9 → 775,11
ColorTableCount: Integer;
destructor Destroy; override;
procedure AddRef;
procedure Release;
procedure Release; {$IFDEF VER17UP}reintroduce;{$ENDIF}
end;
 
{ TPaletteManager }
 
TPaletteManager = class
private
FList: TCollection;
468,6 → 789,8
procedure DeletePalette(var Palette: HPalette);
end;
 
{ TPaletteItem }
 
destructor TPaletteItem.Destroy;
begin
DeleteObject(Palette);
485,6 → 808,8
if RefCount<=0 then Free;
end;
 
{ TPaletteManager }
 
constructor TPaletteManager.Create;
begin
inherited Create;
577,6 → 902,8
Result := FPaletteManager;
end;
 
{ TDIBSharedImage }
 
constructor TDIBSharedImage.Create;
begin
inherited Create;
592,8 → 919,10
InfoOfs: Integer;
UsePixelFormat: Boolean;
begin
{$IFNDEF D17UP}
{self recreation is not allowed here}
Create;
 
{$ENDIF}
{ Pixel format check }
case ABitCount of
1 : if not ((PixelFormat.RBitMask=$FF0000) and (PixelFormat.GBitMask=$00FF00) and (PixelFormat.BBitMask=$0000FF)) then
602,16 → 931,19
raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
8 : if not ((PixelFormat.RBitMask=$FF0000) and (PixelFormat.GBitMask=$00FF00) and (PixelFormat.BBitMask=$0000FF)) then
raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
16: begin
16:
begin
if not (((PixelFormat.RBitMask=$7C00) and (PixelFormat.GBitMask=$03E0) and (PixelFormat.BBitMask=$001F)) or
((PixelFormat.RBitMask=$F800) and (PixelFormat.GBitMask=$07E0) and (PixelFormat.BBitMask=$001F))) then
raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
end;
24: begin
24:
begin
if not ((PixelFormat.RBitMask=$FF0000) and (PixelFormat.GBitMask=$00FF00) and (PixelFormat.BBitMask=$0000FF)) then
raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
end;
32: begin
32:
begin
if not ((PixelFormat.RBitMask=$FF0000) and (PixelFormat.GBitMask=$00FF00) and (PixelFormat.BBitMask=$0000FF)) then
raise EInvalidGraphicOperation.Create(SInvalidDIBPixelFormat);
end;
696,7 → 1028,8
FPBits := Pointer(GlobalAlloc(GMEM_FIXED, FSize));
if FPBits=nil then
OutOfMemoryError;
end else
end
else
begin
FDC := CreateCompatibleDC(0);
 
713,11 → 1046,17
 
procedure TDIBSharedImage.Duplicate(Source: TDIBSharedImage; MemoryImage: Boolean);
begin
if Source = nil then Exit; //no source
if Source.FSize=0 then
begin
{$IFNDEF D17UP}
{self recreation is not allowed here}
Create;
{$ENDIF}
FMemoryImage := MemoryImage;
end else
end
else
begin
NewImage(Source.FWidth, Source.FHeight, Source.FBitCount,
Source.FPixelFormat, Source.FColorTable, MemoryImage, Source.FCompressed);
726,7 → 1065,8
FBitmapInfo.bmiHeader.biSizeImage := Source.FBitmapInfo.bmiHeader.biSizeImage;
GetMem(FPBits, FBitmapInfo.bmiHeader.biSizeImage);
Move(Source.FPBits^, FPBits^, FBitmapInfo.bmiHeader.biSizeImage);
end else
end
else
begin
Move(Source.FPBits^, FPBits^, FBitmapInfo.bmiHeader.biSizeImage);
end;
789,7 → 1129,8
 
AllocByte^ := B1;
AllocByte^ := B2;
end else
end
else
if (Source.FWidth-x>5) and ((GetPixel(x)<>GetPixel(x+2)) or (GetPixel(x+1)<>GetPixel(x+3))) and
((GetPixel(x+2)=GetPixel(x+4)) and (GetPixel(x+3)=GetPixel(x+5))) then
begin
797,7 → 1138,8
AllocByte^ := 2;
AllocByte^ := (GetPixel(x) shl 4) or GetPixel(x+1);
Inc(x, 2);
end else
end
else
begin
if (Source.FWidth-x<4) then
begin
815,7 → 1157,8
AllocByte^ := GetPixel(x) shl 4;
Inc(x);
end;
end else
end
else
begin
{ Absolute mode }
PB1 := Size; AllocByte;
904,7 → 1247,8
 
AllocByte^ := B1;
AllocByte^ := B2;
end else
end
else
if (Source.FWidth-x>2) and (Src^<>PByte(Integer(Src)+1)^) and (PByte(Integer(Src)+1)^=PByte(Integer(Src)+2)^) then
begin
{ Encoding mode }
911,7 → 1255,8
AllocByte^ := 1;
AllocByte^ := Src^; Inc(Src);
Inc(x);
end else
end
else
begin
if (Source.FWidth-x<4) then
begin
924,13 → 1269,15
AllocByte^ := 1;
AllocByte^ := Src^; Inc(Src);
Inc(x, 2);
end else
end
else
begin
AllocByte^ := 1;
AllocByte^ := Src^; Inc(Src);
Inc(x);
end;
end else
end
else
begin
{ Absolute mode }
PB1 := Size; AllocByte;
979,7 → 1326,8
begin
if Source.FCompressed then
Duplicate(Source, Source.FMemoryImage)
else begin
else
begin
NewImage(Source.FWidth, Source.FHeight, Source.FBitCount,
Source.FPixelFormat, Source.FColorTable, True, True);
case FBitmapInfo.bmiHeader.biCompression of
1030,7 → 1378,8
if i and 1=0 then
begin
C := Src^; Inc(Src);
end else
end
else
begin
C := C shl 4;
end;
1044,7 → 1393,8
Inc(X);
end;
end;
end else
end
else
begin
{ Encoding mode }
Dest := Pointer(Longint(FPBits)+Y*FWidthBytes);
1101,7 → 1451,8
{ Absolute mode }
Move(Src^, Dest^, B2); Inc(Dest, B2); Inc(Src, B2);
end;
end else
end
else
begin
{ Encoding mode }
FillChar(Dest^, B1, B2); Inc(Dest, B1);
1115,7 → 1466,8
begin
if not Source.FCompressed then
Duplicate(Source, MemoryImage)
else begin
else
begin
NewImage(Source.FWidth, Source.FHeight, Source.FBitCount,
Source.FPixelFormat, Source.FColorTable, MemoryImage, False);
case Source.FBitmapInfo.bmiHeader.biCompression of
1136,6 → 1488,7
procedure LoadRLE4;
begin
FSize := BI.biSizeImage;
//GetMem(FPBits, FSize);
FPBits := GlobalAllocPtr(GMEM_FIXED, FSize);
FBitmapInfo.bmiHeader.biSizeImage := FSize;
Stream.ReadBuffer(FPBits^, FSize);
1144,6 → 1497,7
procedure LoadRLE8;
begin
FSize := BI.biSizeImage;
//GetMem(FPBits, FSize);
FPBits := GlobalAllocPtr(GMEM_FIXED, FSize);
FBitmapInfo.bmiHeader.biSizeImage := FSize;
Stream.ReadBuffer(FPBits^, FSize);
1157,7 → 1511,8
begin
for y:=0 to Abs(BI.biHeight)-1 do
Stream.ReadBuffer(Pointer(Integer(FTopPBits)+y*FNextLine)^, FWidthBytes);
end else
end
else
begin
Stream.ReadBuffer(FPBits^, FSize);
end;
1170,12 → 1525,17
AColorTable: TRGBQuads;
APixelFormat: TDIBPixelFormat;
begin
if not Assigned(Stream) then Exit;
{ Header size reading }
i := Stream.Read(BI.biSize, 4);
 
if i=0 then
begin
{$IFNDEF D17UP}
{self recreation is not allowed here}
Create;
{$ENDIF}
Exit;
end;
if i<>4 then
1216,7 → 1576,8
Stream.ReadBuffer(Localpf, SizeOf(Localpf));
with Localpf do
APixelFormat := MakeDIBPixelFormatMask(RBitMask, GBitMask, BBitMask);
end else
end
else
begin
if BI.biBitCount=16 then
APixelFormat := MakeDIBPixelFormat(5, 5, 5)
1243,13 → 1604,14
with BCRGB[i] do
AColorTable[i] := RGBQuad(rgbtRed, rgbtGreen, rgbtBlue);
end;
end else
end
else
begin
{ Windows type }
Stream.ReadBuffer(AColorTable, SizeOf(TRGBQuad)*PalCount);
end;
 
{ DIB ì¬ }
{ DIB compilation }
NewImage(BI.biWidth, Abs(BI.biHeight), BI.biBitCount, APixelFormat, AColorTable,
MemoryImage, BI.biCompression in [BI_RLE4, BI_RLE8]);
 
1270,7 → 1632,9
begin
if FOldHandle<>0 then SelectObject(FDC, FOldHandle);
DeleteObject(FHandle);
end else
end
else
// GlobalFree(THandle(FPBits));
begin
if FPBits<>nil then
GlobalFreePtr(FPBits);
1333,12 → 1697,26
begin
inherited Create;
SetImage(EmptyDIBImage);
 
FFreeList := TList.Create;
end;
 
destructor TDIB.Destroy;
var
D: TDIB;
begin
SetImage(EmptyDIBImage);
FCanvas.Free;
 
while FFreeList.Count > 0 do
try
D := TDIB(FFreeList[0]);
FFreeList.Remove(D);
D.Free;
except
end;
FFreeList.Free;
 
inherited Destroy;
end;
 
1372,12 → 1750,14
if DIBSectionRec^.dsBm.bmBitsPixel>=24 then
begin
PixelFormat := MakeDIBPixelFormat(8, 8, 8);
end else
end
else
if DIBSectionRec^.dsBm.bmBitsPixel>8 then
begin
PixelFormat := MakeDIBPixelFormat(DIBSectionRec^.dsBitfields[0],
PixelFormat := MakeDIBPixelFormatMask(DIBSectionRec^.dsBitfields[0], //correct I.Ceneff, thanks
DIBSectionRec^.dsBitfields[1], DIBSectionRec^.dsBitfields[2]);
end else
end
else
begin
PixelFormat := MakeDIBPixelFormat(8, 8, 8);
end;
1393,14 → 1773,64
end;
 
procedure AssignGraphic(Source: TGraphic);
{$IFDEF PNG_GRAPHICS}
var
alpha: TDIB;
png: {$IFDEF VER12UP}TPngImage{$ELSE}TPNGObject{$ENDIF};
i, j: Integer;
q: pByteArray;
{$ENDIF}
begin
{$IFDEF PNG_GRAPHICS}
if Source is {$IFDEF VER12UP}TPngImage{$ELSE}TPNGObject{$ENDIF} then
begin
alpha := TDIB.Create;
try
{png image}
png := {$IFDEF VER12UP}TPngImage{$ELSE}TPNGObject{$ENDIF}.Create;
try
png.Assign(Source);
if png.TransparencyMode = ptmPartial then
begin
Alpha.SetSize(png.Width, png.Height, 8);
{separate alpha}
for i := 0 to png.Height - 1 do
begin
q := png.AlphaScanline[i];
for j := 0 to png.Width - 1 do
alpha.Pixels[j,i] := q[j];
end;
end;
SetSize(png.Width, png.Height, 32);
FillChar(PBits^, Size, 0);
Canvas.Draw(0, 0, png);
Transparent := png.Transparent;
finally
png.Free;
end;
if not alpha.Empty then
AssignAlphaChannel(alpha);
finally
alpha.Free;
end;
end
else
{$ENDIF}
if Source is TBitmap then
AssignBitmap(TBitmap(Source))
else
begin
SetSize(Source.Width, Source.Height, 32);
FillChar(PBits^, Size, 0);
Canvas.Draw(0, 0, Source);
Transparent := Source.Transparent;
if not HasAlphaChannel then
begin
SetSize(Source.Width, Source.Height, 24);
FillChar(PBits^, Size, 0);
Canvas.Draw(0, 0, Source);
Transparent := Source.Transparent;
end
end;
end;
 
1425,7 → 1855,7
inherited Assign(Source);
end;
 
procedure TDIB.Draw(ACanvas: TCanvas; const Rect: TRect);
procedure TDIB.Draw(ACanvas: TCanvas; const ARect: TRect);
var
OldPalette: HPalette;
OldMode: Integer;
1436,7 → 1866,8
begin
OldPalette := SelectPalette(ACanvas.Handle, Palette, False);
RealizePalette(ACanvas.Handle);
end else
end
else
OldPalette := 0;
try
OldMode := SetStretchBltMode(ACanvas.Handle, COLORONCOLOR);
1444,14 → 1875,18
GdiFlush;
if FImage.FMemoryImage then
begin
with Rect do
StretchDIBits(ACanvas.Handle, Left, Top, Right - Left, Bottom - Top,
0, 0, Width, Height, FImage.FPBits, FImage.FBitmapInfo^, DIB_RGB_COLORS , ACanvas.CopyMode);
end else
with ARect do
begin
with Rect do
if StretchDIBits(ACanvas.Handle, Left, Top, Right - Left, Bottom - Top,
0, 0, Self.Width, Self.Height, FImage.FPBits, FImage.FBitmapInfo^, DIB_RGB_COLORS, ACanvas.CopyMode) = 0 then
MessageBeep(1);
end;
end
else
begin
with ARect do
StretchBlt(ACanvas.Handle, Left, Top, Right - Left, Bottom - Top,
FImage.FDC, 0, 0, Width, Height, ACanvas.CopyMode);
FImage.FDC, 0, 0, Self.Width, Self.Height, ACanvas.CopyMode);
end;
finally
SetStretchBltMode(ACanvas.Handle, OldMode);
1557,6 → 1992,161
end;
end;
 
type
PRGBA = ^TRGBA;
TRGBA = array[0..0] of Windows.TRGBQuad;
 
function TDIB.HasAlphaChannel: Boolean;
{give that DIB contain the alphachannel}
var
p: PRGBA;
X, Y: Integer;
begin
Result := True;
if BitCount = 32 then
for Y := 0 to Height - 1 do
begin
p := ScanLine[Y];
for X := 0 to Width - 1 do
begin
if p[X].rgbReserved <> $0 then Exit;
end
end;
Result := False;
end;
 
function TDIB.AssignAlphaChannel(ALPHA: TDIB; ForceResize: Boolean{$IFDEF VER4UP} = False{$ENDIF}): Boolean;
{copy alphachannel from other DIB or add from DIB8}
var
p32_0, p32_1: PRGBA;
p24: Pointer;
pB: PArrayByte;
X, Y: Integer;
tmpDIB, qAlpha: TDIB;
begin
Result := False;
if GetEmpty then Exit;
{Alphachannel can be copy into 32bit DIB only!}
if BitCount <> 32 then
begin
tmpDIB := TDIB.Create;
try
tmpDIB.Assign(Self);
Clear;
SetSize(tmpDIB.Width, tmpDIB.Height, 32);
Canvas.Draw(0, 0, tmpDIB);
finally
tmpDIB.Free;
end;
end;
qAlpha := TDIB.Create;
try
if not Assigned(Alpha) then Exit;
if ForceResize then
begin
{create temp}
tmpDIB := TDIB.Create;
try
{picture}
tmpDIB.Assign(ALPHA);
{resample size}
tmpDIB.DoResample(Width, Height, ftrBSpline);
{convert to greyscale}
tmpDIB.Greyscale(8);
{return picture to qAlpha}
qAlpha.Assign(tmpDIB);
finally
tmpDIB.Free;
end;
end
else
{Must be the same size!}
if not ((Width = ALPHA.Width) and (Height = ALPHA.Height)) then Exit
else qAlpha.Assign(ALPHA);
{It works now with qAlpha only}
case qAlpha.BitCount of
24:
begin
for Y := 0 to Height - 1 do
begin
p32_0 := ScanLine[Y];
p24 := qAlpha.ScanLine[Y];
for X := 0 to Width - 1 do with PBGR(p24)^ do
begin
p32_0[X].rgbReserved := Round(0.30 * R + 0.59 * G + 0.11 * B);
end
end;
end;
32:
begin
for Y := 0 to Height - 1 do
begin
p32_0 := ScanLine[Y];
p32_1 := qAlpha.ScanLine[Y];
for X := 0 to Width - 1 do
begin
p32_0[X].rgbReserved := p32_1[X].rgbReserved;
end
end;
end;
8:
begin
for Y := 0 to Height - 1 do
begin
p32_0 := ScanLine[Y];
pB := qAlpha.ScanLine[Y];
for X := 0 to Width - 1 do
begin
p32_0[X].rgbReserved := pB[X];
end
end;
end;
1:
begin
for Y := 0 to Height - 1 do
begin
p32_0 := ScanLine[Y];
pB := qAlpha.ScanLine[Y];
for X := 0 to Width - 1 do
begin
if pB[X] = 0 then
p32_0[X].rgbReserved := $FF
else
p32_0[X].rgbReserved := 0
end
end;
end;
else
Exit;
end;
Result := True;
finally
qAlpha.Free;
end;
end;
 
procedure TDIB.RetAlphaChannel(out oDIB: TDIB);
{Store alphachannel information into DIB8}
var
p0: PRGBA;
pB: PArrayByte;
X, Y: Integer;
begin
oDIB := nil;
if not HasAlphaChannel then exit;
oDIB := TDIB.Create;
oDIB.SetSize(Width, Height, 8);
for Y := 0 to Height - 1 do
begin
p0 := ScanLine[Y];
pB := oDIB.ScanLine[Y];
for X := 0 to Width - 1 do
begin
pB[X] := p0[X].rgbReserved;
end
end;
end;
 
function TDIB.GetBitmapInfo: PBitmapInfo;
begin
Result := FImage.FBitmapInfo;
1683,7 → 2273,7
begin
case FBitCount of
1 : Result := (PArrayByte(Integer(FTopPBits)+Y*FNextLine)[X shr 3] and Mask1[X and 7]) shr Shift1[X and 7];
4 : Result := (PArrayByte(Integer(FTopPBits)+Y*FNextLine)[X shr 1] and Mask4[X and 1]) shr Shift4[X and 1];
4: Result := ((PArrayByte(Integer(FTopPBits) + Y * FNextLine)[X shr 1] and Mask4[X and 1]) shr Shift4[X and 1]);
8 : Result := PArrayByte(Integer(FTopPBits)+Y*FNextLine)[X];
16: Result := PArrayWord(Integer(FTopPBits)+Y*FNextLine)[X];
24: with PArrayBGR(Integer(FTopPBits)+Y*FNextLine)[X] do
1693,6 → 2283,17
end;
end;
 
function TDIB.GetRGBChannel: TDIB;
{Store RGB channel information into DIB24}
begin
Result := nil;
if Self.Empty then Exit;
Result := TDIB.Create;
Result.SetSize(Width, Height, 24);
Self.DrawOn(Bounds(0,0, Self.Width, Self.Height), Result.Canvas, 0, 0);
FFreeList.Add(Result);
end;
 
procedure TDIB.SetPixel(X, Y: Integer; Value: DWORD);
var
P: PByte;
1707,8 → 2308,8
P^ := (P^ and Mask1n[X and 7]) or ((Value and 1) shl Shift1[X and 7]);
end;
4 : begin
P := @PArrayByte(Integer(FTopPBits)+Y*FNextLine)[X shr 3];
P^ := (P^ and Mask4n[X and 1]) or ((Value and 15) shl Shift4[X and 1]);
P := (@PArrayByte(Integer(FTopPBits) + Y * FNextLine)[X shr 3]);
P^ := ((P^ and Mask4n[X and 1]) or ((Value and 15) shl Shift4[X and 1]));
end;
8 : PArrayByte(Integer(FTopPBits)+Y*FNextLine)[X] := Value;
16: PArrayWord(Integer(FTopPBits)+Y*FNextLine)[X] := Value;
1723,6 → 2324,23
end;
end;
procedure TDIB.SetRGBChannel(const Value: TDIB);
var
alpha: TDIB;
begin
if Self.HasAlphaChannel then
try
RetAlphaChannel(alpha);
Self.SetSize(Value.Width, Value.Height, 32);
Value.DrawOn(Bounds(0,0,Value.Width, Value.Height), Self.Canvas, 0, 0);
Self.AssignAlphaChannel(alpha, True);
finally
alpha.Free;
end
else
Self.Assign(Value);
end;
 
procedure TDIB.DefineProperties(Filer: TFiler);
begin
inherited DefineProperties(Filer);
1731,6 → 2349,8
end;
 
type
{ TGlobalMemoryStream }
 
TGlobalMemoryStream = class(TMemoryStream)
private
FHandle: THandle;
1773,6 → 2393,7
var
BF: TBitmapFileHeader;
i: Integer;
ImageJPEG: TJPEGImage;
begin
{ File header reading }
i := Stream.Read(BF, SizeOf(TBitmapFileHeader));
1780,6 → 2401,30
if i<>SizeOf(TBitmapFileHeader) then
raise EInvalidGraphic.Create(SInvalidDIB);
 
{ Is the head jpeg ?}
 
if BF.bfType = $D8FF then
begin
ImageJPEG := TJPEGImage.Create;
try
try
Stream.Position := 0;
ImageJPEG.LoadFromStream(Stream);
except
on EInvalidGraphic do ImageJPEG := nil;
end;
if ImageJPEG <> nil then
begin
{set size and bitcount in natural units of jpeg}
SetSize(ImageJPEG.Width, ImageJPEG.Height, 24);
Canvas.Draw(0, 0, ImageJPEG);
Exit
end;
finally
ImageJPEG.Free;
end;
end
else
{ Is the head 'BM'? }
if BF.bfType<>BitmapFileType then
raise EInvalidGraphic.Create(SInvalidDIB);
1864,7 → 2509,8
if Empty then
begin
SetSize(Max(Width, 1), Max(Height, 1), Value)
end else
end
else
begin
ConvertBitCount(Value);
end;
2031,13 → 2677,16
for x:=0 to Width-1 do
begin
case Temp.BitCount of
1 : begin
1:
begin
i := (PArrayByte(SrcP)[X shr 3] and Mask1[X and 7]) shr Shift1[X and 7];
end;
4 : begin
4:
begin
i := (PArrayByte(SrcP)[X and 1] and Mask4[X and 1]) shr Shift4[X and 1];
end;
8 : begin
8:
begin
i := PByte(SrcP)^;
Inc(PByte(SrcP));
end;
2044,15 → 2693,18
end;
 
case BitCount of
1 : begin
1:
begin
P := @PArrayByte(DestP)[X shr 3];
P^ := (P^ and Mask1n[X and 7]) or (i shl Shift1[X shr 3]);
end;
4 : begin
4:
begin
P := @PArrayByte(DestP)[X shr 1];
P^ := (P^ and Mask4n[X and 1]) or (i shl Shift4[X and 1]);
end;
8 : begin
8:
begin
PByte(DestP)^ := i;
Inc(PByte(DestP));
end;
2079,7 → 2731,8
for x:=0 to Width-1 do
begin
case Temp.BitCount of
1 : begin
1:
begin
with Temp.ColorTable[(PArrayByte(SrcP)[X shr 3] and Mask1[X and 7]) shr Shift1[X and 7]] do
begin
cR := rgbRed;
2087,7 → 2740,8
cB := rgbBlue;
end;
end;
4 : begin
4:
begin
with Temp.ColorTable[(PArrayByte(SrcP)[X shr 1] and Mask4[X and 1]) shr Shift4[X and 1]] do
begin
cR := rgbRed;
2095,7 → 2749,8
cB := rgbBlue;
end;
end;
8 : begin
8:
begin
with Temp.ColorTable[PByte(SrcP)^] do
begin
cR := rgbRed;
2104,11 → 2759,13
end;
Inc(PByte(SrcP));
end;
16: begin
16:
begin
pfGetRGB(Temp.NowPixelFormat, PWord(SrcP)^, cR, cG, cB);
Inc(PWord(SrcP));
end;
24: begin
24:
begin
with PBGR(SrcP)^ do
begin
cR := R;
2118,7 → 2775,8
 
Inc(PBGR(SrcP));
end;
32: begin
32:
begin
pfGetRGB(Temp.NowPixelFormat, PDWORD(SrcP)^, cR, cG, cB);
Inc(PDWORD(SrcP));
end;
2125,11 → 2783,13
end;
 
case BitCount of
16: begin
16:
begin
PWord(DestP)^ := pfRGB(NowPixelFormat, cR, cG, cB);
Inc(PWord(DestP));
end;
24: begin
24:
begin
with PBGR(DestP)^ do
begin
R := cR;
2138,7 → 2798,8
end;
Inc(PBGR(DestP));
end;
32: begin
32:
begin
PDWORD(DestP)^ := pfRGB(NowPixelFormat, cR, cG, cB);
Inc(PDWORD(DestP));
end;
2163,7 → 2824,8
if Temp.BitCount<=BitCount then
begin
PaletteToPalette_Inc;
end else
end
else
begin
case BitCount of
1: begin
2177,12 → 2839,14
 
Canvas.Draw(0, 0, Temp);
end;
end else
end
else
if (Temp.BitCount<=8) and (BitCount>8) then
begin
{ The image is converted from the palette color image into the rgb color image. }
PaletteToRGB_or_RGBToRGB;
end else
end
else
if (Temp.BitCount>8) and (BitCount<=8) then
begin
{ The image is converted from the rgb color image into the palette color image. }
2197,7 → 2861,8
UpdatePalette;
 
Canvas.Draw(0, 0, Temp);
end else
end
else
if (Temp.BitCount>8) and (BitCount>8) then
begin
{ The image is converted from the rgb color image into the rgb color image. }
2251,6 → 2916,211
Inc(FProgressY);
end;
 
procedure TDIB.Mirror(MirrorX, MirrorY: Boolean);
var
x, y, Width2, c: Integer;
P1, P2, TempBuf: Pointer;
begin
if Empty then Exit;
if (not MirrorX) and (not MirrorY) then Exit;
 
if (not MirrorX) and (MirrorY) then
begin
GetMem(TempBuf, WidthBytes);
try
StartProgress('Mirror');
try
for y := 0 to Height shr 1 - 1 do
begin
P1 := ScanLine[y];
P2 := ScanLine[Height - y - 1];
 
Move(P1^, TempBuf^, WidthBytes);
Move(P2^, P1^, WidthBytes);
Move(TempBuf^, P2^, WidthBytes);
 
UpdateProgress(y * 2);
end;
finally
EndProgress;
end;
finally
FreeMem(TempBuf, WidthBytes);
end;
end
else
if (MirrorX) and (not MirrorY) then
begin
Width2 := Width shr 1;
 
StartProgress('Mirror');
try
for y := 0 to Height - 1 do
begin
P1 := ScanLine[y];
 
case BitCount of
1:
begin
for x := 0 to Width2 - 1 do
begin
c := Pixels[x, y];
Pixels[x, y] := Pixels[Width - x - 1, y];
Pixels[Width - x - 1, y] := c;
end;
end;
4:
begin
for x := 0 to Width2 - 1 do
begin
c := Pixels[x, y];
Pixels[x, y] := Pixels[Width - x - 1, y];
Pixels[Width - x - 1, y] := c;
end;
end;
8:
begin
P2 := Pointer(Integer(P1) + Width - 1);
for x := 0 to Width2 - 1 do
begin
PByte(@c)^ := PByte(P1)^;
PByte(P1)^ := PByte(P2)^;
PByte(P2)^ := PByte(@c)^;
Inc(PByte(P1));
Dec(PByte(P2));
end;
end;
16:
begin
P2 := Pointer(Integer(P1) + (Width - 1) * 2);
for x := 0 to Width2 - 1 do
begin
PWord(@c)^ := PWord(P1)^;
PWord(P1)^ := PWord(P2)^;
PWord(P2)^ := PWord(@c)^;
Inc(PWord(P1));
Dec(PWord(P2));
end;
end;
24:
begin
P2 := Pointer(Integer(P1) + (Width - 1) * 3);
for x := 0 to Width2 - 1 do
begin
PBGR(@c)^ := PBGR(P1)^;
PBGR(P1)^ := PBGR(P2)^;
PBGR(P2)^ := PBGR(@c)^;
Inc(PBGR(P1));
Dec(PBGR(P2));
end;
end;
32:
begin
P2 := Pointer(Integer(P1) + (Width - 1) * 4);
for x := 0 to Width2 - 1 do
begin
PDWORD(@c)^ := PDWORD(P1)^;
PDWORD(P1)^ := PDWORD(P2)^;
PDWORD(P2)^ := PDWORD(@c)^;
Inc(PDWORD(P1));
Dec(PDWORD(P2));
end;
end;
end;
 
UpdateProgress(y);
end;
finally
EndProgress;
end;
end
else
if (MirrorX) and (MirrorY) then
begin
StartProgress('Mirror');
try
for y := 0 to Height shr 1 - 1 do
begin
P1 := ScanLine[y];
P2 := ScanLine[Height - y - 1];
 
case BitCount of
1:
begin
for x := 0 to Width - 1 do
begin
c := Pixels[x, y];
Pixels[x, y] := Pixels[Width - x - 1, Height - y - 1];
Pixels[Width - x - 1, Height - y - 1] := c;
end;
end;
4:
begin
for x := 0 to Width - 1 do
begin
c := Pixels[x, y];
Pixels[x, y] := Pixels[Width - x - 1, Height - y - 1];
Pixels[Width - x - 1, Height - y - 1] := c;
end;
end;
8:
begin
P2 := Pointer(Integer(P2) + Width - 1);
for x := 0 to Width - 1 do
begin
PByte(@c)^ := PByte(P1)^;
PByte(P1)^ := PByte(P2)^;
PByte(P2)^ := PByte(@c)^;
Inc(PByte(P1));
Dec(PByte(P2));
end;
end;
16:
begin
P2 := Pointer(Integer(P2) + (Width - 1) * 2);
for x := 0 to Width - 1 do
begin
PWord(@c)^ := PWord(P1)^;
PWord(P1)^ := PWord(P2)^;
PWord(P2)^ := PWord(@c)^;
Inc(PWord(P1));
Dec(PWord(P2));
end;
end;
24:
begin
P2 := Pointer(Integer(P2) + (Width - 1) * 3);
for x := 0 to Width - 1 do
begin
PBGR(@c)^ := PBGR(P1)^;
PBGR(P1)^ := PBGR(P2)^;
PBGR(P2)^ := PBGR(@c)^;
Inc(PBGR(P1));
Dec(PBGR(P2));
end;
end;
32:
begin
P2 := Pointer(Integer(P2) + (Width - 1) * 4);
for x := 0 to Width - 1 do
begin
PDWORD(@c)^ := PDWORD(P1)^;
PDWORD(P1)^ := PDWORD(P2)^;
PDWORD(P2)^ := PDWORD(@c)^;
Inc(PDWORD(P1));
Dec(PDWORD(P2));
end;
end;
end;
 
UpdateProgress(y * 2);
end;
finally
EndProgress;
end;
end;
end;
 
procedure TDIB.Blur(ABitCount: Integer; Radius: Integer);
type
TAve = record
2270,7 → 3140,8
R, G, B: Byte;
begin
case Temp.BitCount of
1 : begin
1:
begin
SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
AveP := @Ave;
for x:=0 to XCount-1 do
2285,7 → 3156,8
Inc(AveP);
end;
end;
4 : begin
4:
begin
SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
AveP := @Ave;
for x:=0 to XCount-1 do
2300,7 → 3172,8
Inc(AveP);
end;
end;
8 : begin
8:
begin
SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
AveP := @Ave;
for x:=0 to XCount-1 do
2316,7 → 3189,8
Inc(AveP);
end;
end;
16: begin
16:
begin
SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
AveP := @Ave;
for x:=0 to XCount-1 do
2333,7 → 3207,8
Inc(AveP);
end;
end;
24: begin
24:
begin
SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
AveP := @Ave;
for x:=0 to XCount-1 do
2349,7 → 3224,8
Inc(AveP);
end;
end;
32: begin
32:
begin
SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
AveP := @Ave;
for x:=0 to XCount-1 do
2377,7 → 3253,8
R, G, B: Byte;
begin
case Temp.BitCount of
1 : begin
1:
begin
SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
AveP := @Ave;
for x:=0 to XCount-1 do
2392,7 → 3269,8
Inc(AveP);
end;
end;
4 : begin
4:
begin
SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
AveP := @Ave;
for x:=0 to XCount-1 do
2407,7 → 3285,8
Inc(AveP);
end;
end;
8 : begin
8:
begin
SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
AveP := @Ave;
for x:=0 to XCount-1 do
2423,7 → 3302,8
Inc(AveP);
end;
end;
16: begin
16:
begin
SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
AveP := @Ave;
for x:=0 to XCount-1 do
2440,7 → 3320,8
Inc(AveP);
end;
end;
24: begin
24:
begin
SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
AveP := @Ave;
for x:=0 to XCount-1 do
2456,7 → 3337,8
Inc(AveP);
end;
end;
32: begin
32:
begin
SrcP := Pointer(Integer(Temp.TopPBits)+Y*Temp.NextLine);
AveP := @Ave;
for x:=0 to XCount-1 do
2579,27 → 3461,32
 
{ The average is written. }
case BitCount of
1 : begin
1:
begin
P := @PArrayByte(DestP)[X shr 3];
with Ave do
P^ := (P^ and Mask1n[X and 7]) or (DWORD(Ord(((cR+cG+cB) div c) div 3>127)) shl Shift1[X and 7]);
end;
4 : begin
4:
begin
P := @PArrayByte(DestP)[X shr 1];
with Ave do
P^ := (P^ and Mask4n[X and 1]) or (((((cR+cG+cB) div c) div 3) shr 4) shl Shift4[X and 1]);
end;
8 : begin
8:
begin
with Ave do
PByte(DestP)^ := ((cR+cG+cB) div c) div 3;
Inc(PByte(DestP));
end;
16: begin
16:
begin
with Ave do
PWORD(DestP)^ := pfRGB(NowPixelFormat, cR div c, cG div c, cB div c);
Inc(PWORD(DestP));
end;
24: begin
24:
begin
with PBGR(DestP)^, Ave do
begin
R := cR div c;
2608,7 → 3495,8
end;
Inc(PBGR(DestP));
end;
32: begin
32:
begin
with Ave do
PDWORD(DestP)^ := pfRGB(NowPixelFormat, cR div c, cG div c, cB div c);
Inc(PDWORD(DestP));
2658,6 → 3546,64
end;
end;
 
procedure TDIB.Negative;
var
i, i2: Integer;
P: Pointer;
begin
if Empty then exit;
 
if BitCount <= 8 then
begin
for i := 0 to 255 do
with ColorTable[i] do
begin
rgbRed := 255 - rgbRed;
rgbGreen := 255 - rgbGreen;
rgbBlue := 255 - rgbBlue;
end;
UpdatePalette;
end else
begin
P := PBits;
i2 := Size;
asm
mov ecx,i2
mov eax,P
mov edx,ecx
 
{ Unit of DWORD. }
@@qword_skip:
shr ecx,2
jz @@dword_skip
 
dec ecx
@@dword_loop:
not dword ptr [eax+ecx*4]
dec ecx
jnl @@dword_loop
 
mov ecx,edx
shr ecx,2
add eax,ecx*4
 
{ Unit of Byte. }
@@dword_skip:
mov ecx,edx
and ecx,3
jz @@byte_skip
 
dec ecx
@@loop_byte:
not byte ptr [eax+ecx]
dec ecx
jnl @@loop_byte
 
@@byte_skip:
end;
end;
end;
 
procedure TDIB.Greyscale(ABitCount: Integer);
var
YTblR, YTblG, YTblB: array[0..255] of Byte;
2668,7 → 3614,7
DestP, SrcP: Pointer;
P: PByte;
begin
if Empty then exit;
if Empty then Exit;
 
Temp := TDIB.Create;
try
2706,30 → 3652,36
for x:=0 to Width-1 do
begin
case Temp.BitCount of
1 : begin
1:
begin
with Temp.ColorTable[(PArrayByte(SrcP)[X shr 3] and Mask1[X and 7]) shr Shift1[X and 7]] do
c := YTblR[rgbRed]+YTblG[rgbGreen]+YTblB[rgbBlue];
end;
4 : begin
4:
begin
with Temp.ColorTable[(PArrayByte(SrcP)[X shr 1] and Mask4[X and 1]) shr Shift4[X and 1]] do
c := YTblR[rgbRed]+YTblG[rgbGreen]+YTblB[rgbBlue];
end;
8 : begin
8:
begin
with Temp.ColorTable[PByte(SrcP)^] do
c := YTblR[rgbRed]+YTblG[rgbGreen]+YTblB[rgbBlue];
Inc(PByte(SrcP));
end;
16: begin
16:
begin
pfGetRGB(Temp.NowPixelFormat, PWord(SrcP)^, R, G, B);
c := YTblR[R]+YTblR[G]+YTblR[B];
Inc(PWord(SrcP));
end;
24: begin
24:
begin
with PBGR(SrcP)^ do
c := YTblR[R]+YTblG[G]+YTblB[B];
Inc(PBGR(SrcP));
end;
32: begin
32:
begin
pfGetRGB(Temp.NowPixelFormat, PDWORD(SrcP)^, R, G, B);
c := YTblR[R]+YTblR[G]+YTblR[B];
Inc(PDWORD(SrcP));
2737,23 → 3689,28
end;
 
case BitCount of
1 : begin
1:
begin
P := @PArrayByte(DestP)[X shr 3];
P^ := (P^ and Mask1n[X and 7]) or (DWORD(Ord(c>127)) shl Shift1[X and 7]);
end;
4 : begin
4:
begin
P := @PArrayByte(DestP)[X shr 1];
P^ := (P^ and Mask4n[X and 1]) or ((c shr 4) shl Shift4[X and 1]);
end;
8 : begin
8:
begin
PByte(DestP)^ := c;
Inc(PByte(DestP));
end;
16: begin
16:
begin
PWord(DestP)^ := pfRGB(NowPixelFormat, c, c, c);
Inc(PWord(DestP));
end;
24: begin
24:
begin
with PBGR(DestP)^ do
begin
R := c;
2762,7 → 3719,8
end;
Inc(PBGR(DestP));
end;
32: begin
32:
begin
PDWORD(DestP)^ := pfRGB(NowPixelFormat, c, c, c);
Inc(PDWORD(DestP));
end;
2779,253 → 3737,1574
end;
end;
 
procedure TDIB.Mirror(MirrorX, MirrorY: Boolean);
var
x, y, Width2, c: Integer;
P1, P2, TempBuf: Pointer;
//--------------------------------------------------------------------------------------------------
// Version : 0.1 - 26/06/2000 //
// Version : 0.2 - 04/07/2000 //
// At someone's request, i have added 3 news effects : //
// 1 - Rotate //
// 2 - SplitBlur //
// 3 - GaussianBlur //
//--------------------------------------------------------------------------------------------------
// - NEW SPECIAL EFFECT - (English) //
//--------------------------------------------------------------------------------------------------
// At the start, my idea was to create a component derived from TCustomDXDraw. Unfortunately, //
// it's impossible to run a graphic component (derived from TCustomDXDraw) in a conception's //
// mode (i don't success, but perhaps, somebody know how doing ! In that case, please help me !!!)//
// Then, i'm used the DIB's unit for my work, but this unit is poor in special effect. Knowing a //
// library with more effect, i'm undertaked to import this library in DIB's unit. You can see the //
// FastLib library at : //
// //
// -> Gordon Alex Cowie <gfody@jps.net> www.jps.net/gfody //
// //
// It was very difficult, because implementation's graphic was very different that DIB's unit. //
// Sometimes, i'm deserted the possibility of original effect, particularly in conversion of DIB //
// whith 256, 16 and 2 colors. If someone can implement this fonctionnality, thanks to tell me //
// how this miracle is possible !!! //
// All these procedures are translated and adapted by : //
// //
// -> Mickey (Michel HIBON) <mhibon@ifrance.com> http://mickey.tsx.org //
// //
// IMPORTANT : These procedures don't modify the DIB's unit structure //
// Nota Bene : I don't implement these type of graphics (32 and 16 bit per pixels), //
// for one reason : I haven't bitmaps of this type !!! //
//--------------------------------------------------------------------------------------------------
//--------------------------------------------------------------------------------------------------
// - NOUVEAUX EFFETS SPECIAUX - (Français) //
//--------------------------------------------------------------------------------------------------
// Au commencement, mon idée était de dériver un composant de TCustomDXDraw. Malheureusement, //
// c'est impossible de faire fonctionner un composant graphique (derivé de TCustomDXDraw) en mode //
// conception (je n'y suis pas parvenu, mais peut-être, que quelqu'un sait comment faire ! Dans //
// ce cas, vous seriez aimable de m'aider !!!) //
// Alors, j'ai utilisé l'unité DIB pour mon travail,mais celle-ci est pauvre en effet spéciaux. //
// Connaissant une librairie avec beaucoup plus d'effets spéciaux, j'ai entrepris d'importer //
// cette librairie dans l'unité DIB. Vous pouvez voir la librairie FastLib à : //
// //
// -> Gordon Alex Cowie <gfody@jps.net> www.jps.net/gfody //
// //
// C'était très difficile car l'implémentation graphique est très différente de l'unité DIB. //
// Parfois, j'ai abandonné les possibilités de l'effet original, particulièrement dans la //
// conversion des DIB avec 256, 16 et 2 couleurs. Si quelqu'un arrive à implémenter ces //
// fonctionnalités, merci de me dire comment ce miracle est possible !!! //
// Toutes ces procédures ont été traduites et adaptées par: //
// //
// -> Mickey (Michel HIBON) <mhibon@ifrance.com> http://mickey.tsx.org //
// //
// IMPORTANT : Ces procédures ne modifient pas la structure de l'unité DIB //
// Nota Bene : Je n'ai pas implémenté ces types de graphiques (32 et 16 bit par pixels), //
// pour une raison : je n'ai pas de bitmap de ce type !!! //
//--------------------------------------------------------------------------------------------------
 
function TDIB.IntToColor(i: Integer): TBGR;
begin
if Empty then exit;
if (not MirrorX) and (not MirrorY) then Exit;
Result.b := i shr 16;
Result.g := i shr 8;
Result.r := i;
end;
 
if (not MirrorX) and (MirrorY) then
function TDIB.Interval(iMin, iMax, iValue: Integer; iMark: Boolean): Integer;
begin
GetMem(TempBuf, WidthBytes);
try
StartProgress('Mirror');
try
for y:=0 to Height shr 1-1 do
if iMark then
begin
P1 := ScanLine[y];
P2 := ScanLine[Height-y-1];
if iValue < iMin then
Result := iMin
else
if iValue > iMax then
Result := iMax
else
Result := iValue;
end
else
begin
if iValue < iMin then
Result := iMin
else
if iValue > iMax then
Result := iMin
else
Result := iValue;
end;
end;
 
Move(P1^, TempBuf^, WidthBytes);
Move(P2^, P1^, WidthBytes);
Move(TempBuf^, P2^, WidthBytes);
procedure TDIB.Contrast(Amount: Integer);
var
x, y: Integer;
Table1: array[0..255] of Byte;
i: Byte;
S, D: pointer;
Temp1: TDIB;
color: DWORD;
P: PByte;
R, G, B: Byte;
begin
D := nil;
S := nil;
Temp1 := nil;
for i := 0 to 126 do
begin
y := (Abs(128 - i) * Amount) div 256;
Table1[i] := IntToByte(i - y);
end;
for i := 127 to 255 do
begin
y := (Abs(128 - i) * Amount) div 256;
Table1[i] := IntToByte(i + y);
end;
case BitCount of
32: Exit; // I haven't bitmap of this type ! Sorry
24: ; // nothing to do
16: ; // I have an artificial bitmap for this type ! i don't sure that it works
8, 4:
begin
Temp1 := TDIB.Create;
Temp1.Assign(self);
Temp1.SetSize(Width, Height, BitCount);
for i := 0 to 255 do
begin
with ColorTable[i] do
begin
rgbRed := IntToByte(Table1[rgbRed]);
rgbGreen := IntToByte(Table1[rgbGreen]);
rgbBlue := IntToByte(Table1[rgbBlue]);
end;
end;
UpdatePalette;
end;
else
// if the number of pixel is equal to 1 then exit of procedure
Exit;
end;
for y := 0 to Pred(Height) do
begin
case BitCount of
24, 16: D := ScanLine[y];
8, 4:
begin
D := Temp1.ScanLine[y];
S := Temp1.ScanLine[y];
end;
else
end;
for x := 0 to Pred(Width) do
begin
case BitCount of
32: ;
24:
begin
PBGR(D)^.B := Table1[PBGR(D)^.B];
PBGR(D)^.G := Table1[PBGR(D)^.G];
PBGR(D)^.R := Table1[PBGR(D)^.R];
Inc(PBGR(D));
end;
16:
begin
pfGetRGB(NowPixelFormat, PWord(D)^, R, G, B);
PWord(D)^ := Table1[R] + Table1[G] + Table1[B];
Inc(PWord(D));
end;
8:
begin
with Temp1.ColorTable[PByte(S)^] do
color := rgbRed + rgbGreen + rgbBlue;
Inc(PByte(S));
PByte(D)^ := color;
Inc(PByte(D));
end;
4:
begin
with Temp1.ColorTable[PByte(S)^] do
color := rgbRed + rgbGreen + rgbBlue;
Inc(PByte(S));
P := @PArrayByte(D)[X shr 1];
P^ := (P^ and Mask4n[X and 1]) or (color shl Shift4[X and 1]);
end;
else
end;
end;
end;
case BitCount of
8, 4: Temp1.Free;
else
end;
end;
 
UpdateProgress(y*2);
procedure TDIB.Saturation(Amount: Integer);
var
Grays: array[0..767] of Integer;
Alpha: array[0..255] of Word;
Gray, x, y: Integer;
i: Byte;
S, D: pointer;
Temp1: TDIB;
color: DWORD;
P: PByte;
R, G, B: Byte;
begin
D := nil;
S := nil;
Temp1 := nil;
for i := 0 to 255 do
Alpha[i] := (i * Amount) shr 8;
x := 0;
for i := 0 to 255 do
begin
Gray := i - Alpha[i];
Grays[x] := Gray;
Inc(x);
Grays[x] := Gray;
Inc(x);
Grays[x] := Gray;
Inc(x);
end;
finally
EndProgress;
case BitCount of
32: Exit; // I haven't bitmap of this type ! Sorry
24: ; // nothing to do
16: ; // I have an artificial bitmap for this type ! i don't sure that it works
8, 4:
begin
Temp1 := TDIB.Create;
Temp1.Assign(self);
Temp1.SetSize(Width, Height, BitCount);
for i := 0 to 255 do
begin
with ColorTable[i] do
begin
Gray := Grays[rgbRed + rgbGreen + rgbBlue];
rgbRed := IntToByte(Gray + Alpha[rgbRed]);
rgbGreen := IntToByte(Gray + Alpha[rgbGreen]);
rgbBlue := IntToByte(Gray + Alpha[rgbBlue]);
end;
finally
FreeMem(TempBuf, WidthBytes);
end;
end else if (MirrorX) and (not MirrorY) then
UpdatePalette;
end;
else
// if the number of pixel is equal to 1 then exit of procedure
Exit;
end;
for y := 0 to Pred(Height) do
begin
Width2 := Width shr 1;
case BitCount of
24, 16: D := ScanLine[y];
8, 4:
begin
D := Temp1.ScanLine[y];
S := Temp1.ScanLine[y];
end;
else
end;
for x := 0 to Pred(Width) do
begin
case BitCount of
32: ;
24:
begin
Gray := Grays[PBGR(D)^.R + PBGR(D)^.G + PBGR(D)^.B];
PBGR(D)^.B := IntToByte(Gray + Alpha[PBGR(D)^.B]);
PBGR(D)^.G := IntToByte(Gray + Alpha[PBGR(D)^.G]);
PBGR(D)^.R := IntToByte(Gray + Alpha[PBGR(D)^.R]);
Inc(PBGR(D));
end;
16:
begin
pfGetRGB(NowPixelFormat, PWord(D)^, R, G, B);
PWord(D)^ := IntToByte(Gray + Alpha[B]) + IntToByte(Gray + Alpha[G]) +
IntToByte(Gray + Alpha[R]);
Inc(PWord(D));
end;
8:
begin
with Temp1.ColorTable[PByte(S)^] do
color := rgbRed + rgbGreen + rgbBlue;
Inc(PByte(S));
PByte(D)^ := color;
Inc(PByte(D));
end;
4:
begin
with Temp1.ColorTable[PByte(S)^] do
color := rgbRed + rgbGreen + rgbBlue;
Inc(PByte(S));
P := @PArrayByte(D)[X shr 1];
P^ := (P^ and Mask4n[X and 1]) or (color shl Shift4[X and 1]);
end;
else
end;
end;
end;
case BitCount of
8, 4: Temp1.Free;
else
end;
end;
 
StartProgress('Mirror');
try
for y:=0 to Height-1 do
procedure TDIB.Lightness(Amount: Integer);
var
x, y: Integer;
Table1: array[0..255] of Byte;
i: Byte;
S, D: pointer;
Temp1: TDIB;
color: DWORD;
P: PByte;
R, G, B: Byte;
begin
P1 := ScanLine[y];
 
D := nil;
S := nil;
Temp1 := nil;
if Amount < 0 then
begin
Amount := -Amount;
for i := 0 to 255 do
Table1[i] := IntToByte(i - ((Amount * i) shr 8));
end
else
for i := 0 to 255 do
Table1[i] := IntToByte(i + ((Amount * (i xor 255)) shr 8));
case BitCount of
1 : begin
for x:=0 to Width2-1 do
32: Exit; // I haven't bitmap of this type ! Sorry
24: ; // nothing to do
16: ; // I have an artificial bitmap for this type ! i don't sure that it works
8, 4:
begin
c := Pixels[x, y];
Pixels[x, y] := Pixels[Width-x-1, y];
Pixels[Width-x-1, y] := c;
Temp1 := TDIB.Create;
Temp1.Assign(self);
Temp1.SetSize(Width, Height, BitCount);
for i := 0 to 255 do
begin
with ColorTable[i] do
begin
rgbRed := IntToByte(Table1[rgbRed]);
rgbGreen := IntToByte(Table1[rgbGreen]);
rgbBlue := IntToByte(Table1[rgbBlue]);
end;
end;
4 : begin
for x:=0 to Width2-1 do
UpdatePalette;
end;
else
// if the number of pixel is equal to 1 then exit of procedure
Exit;
end;
for y := 0 to Pred(Height) do
begin
c := Pixels[x, y];
Pixels[x, y] := Pixels[Width-x-1, y];
Pixels[Width-x-1, y] := c;
case BitCount of
24, 16: D := ScanLine[y];
8, 4:
begin
D := Temp1.ScanLine[y];
S := Temp1.ScanLine[y];
end;
else
end;
8 : begin
P2 := Pointer(Integer(P1)+Width-1);
for x:=0 to Width2-1 do
for x := 0 to Pred(Width) do
begin
PByte(@c)^ := PByte(P1)^;
PByte(P1)^ := PByte(P2)^;
PByte(P2)^ := PByte(@c)^;
Inc(PByte(P1));
Dec(PByte(P2));
case BitCount of
32: ;
24:
begin
PBGR(D)^.B := Table1[PBGR(D)^.B];
PBGR(D)^.G := Table1[PBGR(D)^.G];
PBGR(D)^.R := Table1[PBGR(D)^.R];
Inc(PBGR(D));
end;
16:
begin
pfGetRGB(NowPixelFormat, PWord(D)^, R, G, B);
PWord(D)^ := Table1[R] + Table1[G] + Table1[B];
Inc(PWord(D));
end;
16: begin
P2 := Pointer(Integer(P1)+(Width-1)*2);
for x:=0 to Width2-1 do
8:
begin
PWord(@c)^ := PWord(P1)^;
PWord(P1)^ := PWord(P2)^;
PWord(P2)^ := PWord(@c)^;
Inc(PWord(P1));
Dec(PWord(P2));
with Temp1.ColorTable[PByte(S)^] do
color := rgbRed + rgbGreen + rgbBlue;
Inc(PByte(S));
PByte(D)^ := color;
Inc(PByte(D));
end;
4:
begin
with Temp1.ColorTable[PByte(S)^] do
color := rgbRed + rgbGreen + rgbBlue;
Inc(PByte(S));
P := @PArrayByte(D)[X shr 1];
P^ := (P^ and Mask4n[X and 1]) or (color shl Shift4[X and 1]);
end;
24: begin
P2 := Pointer(Integer(P1)+(Width-1)*3);
for x:=0 to Width2-1 do
else
end;
end;
end;
case BitCount of
8, 4: Temp1.Free;
else
end;
end;
 
procedure TDIB.AddRGB(aR, aG, aB: Byte);
var
Table: array[0..255] of TBGR;
x, y: Integer;
i: Byte;
D: pointer;
P: PByte;
color: DWORD;
Temp1: TDIB;
R, G, B: Byte;
begin
PBGR(@c)^ := PBGR(P1)^;
PBGR(P1)^ := PBGR(P2)^;
PBGR(P2)^ := PBGR(@c)^;
Inc(PBGR(P1));
Dec(PBGR(P2));
color := 0;
D := nil;
Temp1 := nil;
case BitCount of
32: Exit; // I haven't bitmap of this type ! Sorry
24, 16:
begin
for i := 0 to 255 do
begin
Table[i].b := IntToByte(i + aB);
Table[i].g := IntToByte(i + aG);
Table[i].r := IntToByte(i + aR);
end;
end;
32: begin
P2 := Pointer(Integer(P1)+(Width-1)*4);
for x:=0 to Width2-1 do
8, 4:
begin
PDWORD(@c)^ := PDWORD(P1)^;
PDWORD(P1)^ := PDWORD(P2)^;
PDWORD(P2)^ := PDWORD(@c)^;
Inc(PDWORD(P1));
Dec(PDWORD(P2));
Temp1 := TDIB.Create;
Temp1.Assign(self);
Temp1.SetSize(Width, Height, BitCount);
for i := 0 to 255 do
begin
with ColorTable[i] do
begin
rgbRed := IntToByte(rgbRed + aR);
rgbGreen := IntToByte(rgbGreen + aG);
rgbBlue := IntToByte(rgbBlue + aB);
end;
end;
UpdatePalette;
end;
else
// if the number of pixel is equal to 1 then exit of procedure
Exit;
end;
for y := 0 to Pred(Height) do
begin
case BitCount of
24, 16: D := ScanLine[y];
8, 4:
begin
D := Temp1.ScanLine[y];
end;
else
end;
for x := 0 to Pred(Width) do
begin
case BitCount of
32: ; // I haven't bitmap of this type ! Sorry
24:
begin
PBGR(D)^.B := Table[PBGR(D)^.B].b;
PBGR(D)^.G := Table[PBGR(D)^.G].g;
PBGR(D)^.R := Table[PBGR(D)^.R].r;
Inc(PBGR(D));
end;
16:
begin
pfGetRGB(NowPixelFormat, PWord(D)^, R, G, B);
PWord(D)^ := Table[R].r + Table[G].g + Table[B].b;
Inc(PWord(D));
end;
8:
begin
Inc(PByte(D));
end;
4:
begin
P := @PArrayByte(D)[X shr 1];
P^ := (P^ and Mask4n[X and 1]) or (color shl Shift4[X and 1]);
end;
else
end;
end;
end;
case BitCount of
8, 4: Temp1.Free;
else
end;
end;
 
UpdateProgress(y);
function TDIB.Filter(Dest: TDIB; Filter: TFilter): Boolean;
var
Sum, r, g, b, x, y: Integer;
a, i, j: byte;
tmp: TBGR;
Col: PBGR;
D: Pointer;
begin
Result := True;
Sum := Filter[0, 0] + Filter[1, 0] + Filter[2, 0] +
Filter[0, 1] + Filter[1, 1] + Filter[2, 1] +
Filter[0, 2] + Filter[1, 2] + Filter[2, 2];
if Sum = 0 then
Sum := 1;
Col := PBits;
for y := 0 to Pred(Height) do
begin
D := Dest.ScanLine[y];
for x := 0 to Pred(Width) do
begin
r := 0; g := 0; b := 0;
case BitCount of
32, 16, 4, 1:
begin
Result := False;
Exit;
end;
finally
EndProgress;
24:
begin
for i := 0 to 2 do
begin
for j := 0 to 2 do
begin
Tmp := IntToColor(Pixels[Interval(0, Pred(Width), x + Pred(i), True),
Interval(0, Pred(Height), y + Pred(j), True)]);
Inc(b, Filter[i, j] * Tmp.b);
Inc(g, Filter[i, j] * Tmp.g);
Inc(r, Filter[i, j] * Tmp.r);
end;
end else if (MirrorX) and (MirrorY) then
end;
Col.b := IntToByte(b div Sum);
Col.g := IntToByte(g div Sum);
Col.r := IntToByte(r div Sum);
Dest.Pixels[x, y] := rgb(Col.r, Col.g, Col.b);
end;
8:
begin
StartProgress('Mirror');
try
for y:=0 to Height shr 1-1 do
for i := 0 to 2 do
begin
P1 := ScanLine[y];
P2 := ScanLine[Height-y-1];
for j := 0 to 2 do
begin
a := (Pixels[Interval(0, Pred(Width), x + Pred(i), True),
Interval(0, Pred(Height), y + Pred(j), True)]);
tmp.r := ColorTable[a].rgbRed;
tmp.g := ColorTable[a].rgbGreen;
tmp.b := ColorTable[a].rgbBlue;
Inc(b, Filter[i, j] * Tmp.b);
Inc(g, Filter[i, j] * Tmp.g);
Inc(r, Filter[i, j] * Tmp.r);
end;
end;
Col.b := IntToByte(b div Sum);
Col.g := IntToByte(g div Sum);
Col.r := IntToByte(r div Sum);
PByte(D)^ := rgb(Col.r, Col.g, Col.b);
Inc(PByte(D));
end;
end;
end;
end;
end;
 
procedure TDIB.Spray(Amount: Integer);
var
value, x, y: Integer;
D: Pointer;
color: DWORD;
P: PByte;
begin
for y := Pred(Height) downto 0 do
begin
D := ScanLine[y];
for x := 0 to Pred(Width) do
begin
value := Random(Amount);
color := Pixels[Interval(0, Pred(Width), x + (value - Random(value * 2)), True),
Interval(0, Pred(Height), y + (value - Random(value * 2)), True)];
case BitCount of
1 : begin
for x:=0 to Width-1 do
32:
begin
c := Pixels[x, y];
Pixels[x, y] := Pixels[Width-x-1, Height-y-1];
Pixels[Width-x-1, Height-y-1] := c;
PDWord(D)^ := color;
Inc(PDWord(D));
end;
24:
begin
PBGR(D)^ := IntToColor(color);
Inc(PBGR(D));
end;
4 : begin
for x:=0 to Width-1 do
16:
begin
c := Pixels[x, y];
Pixels[x, y] := Pixels[Width-x-1, Height-y-1];
Pixels[Width-x-1, Height-y-1] := c;
PWord(D)^ := color;
Inc(PWord(D));
end;
8:
begin
PByte(D)^ := color;
Inc(PByte(D));
end;
8 : begin
P2 := Pointer(Integer(P2)+Width-1);
for x:=0 to Width-1 do
4:
begin
PByte(@c)^ := PByte(P1)^;
PByte(P1)^ := PByte(P2)^;
PByte(P2)^ := PByte(@c)^;
Inc(PByte(P1));
Dec(PByte(P2));
P := @PArrayByte(D)[X shr 1];
P^ := (P^ and Mask4n[X and 1]) or (color shl Shift4[X and 1]);
end;
1:
begin
P := @PArrayByte(D)[X shr 3];
P^ := (P^ and Mask1n[X and 7]) or (color shl Shift1[X and 7]);
end;
16: begin
P2 := Pointer(Integer(P2)+(Width-1)*2);
for x:=0 to Width-1 do
else
end;
end;
end;
end;
 
procedure TDIB.Sharpen(Amount: Integer);
var
Lin0, Lin1, Lin2: PLines;
pc: PBGR;
cx, x, y: Integer;
Buf: array[0..8] of TBGR;
D: pointer;
c: DWORD;
i: byte;
P1: PByte;
Temp1: TDIB;
 
begin
PWord(@c)^ := PWord(P1)^;
PWord(P1)^ := PWord(P2)^;
PWord(P2)^ := PWord(@c)^;
Inc(PWord(P1));
Dec(PWord(P2));
D := nil;
GetMem(pc, SizeOf(TBGR));
c := 0;
Temp1 := nil;
case Bitcount of
32, 16, 1: Exit;
24:
begin
Temp1 := TDIB.Create;
Temp1.Assign(self);
Temp1.SetSize(Width, Height, bitCount);
end;
8:
begin
Temp1 := TDIB.Create;
Temp1.Assign(self);
Temp1.SetSize(Width, Height, bitCount);
for i := 0 to 255 do
begin
with Temp1.ColorTable[i] do
begin
Buf[0].B := ColorTable[i - Amount].rgbBlue;
Buf[0].G := ColorTable[i - Amount].rgbGreen;
Buf[0].R := ColorTable[i - Amount].rgbRed;
Buf[1].B := ColorTable[i].rgbBlue;
Buf[1].G := ColorTable[i].rgbGreen;
Buf[1].R := ColorTable[i].rgbRed;
Buf[2].B := ColorTable[i + Amount].rgbBlue;
Buf[2].G := ColorTable[i + Amount].rgbGreen;
Buf[2].R := ColorTable[i + Amount].rgbRed;
Buf[3].B := ColorTable[i - Amount].rgbBlue;
Buf[3].G := ColorTable[i - Amount].rgbGreen;
Buf[3].R := ColorTable[i - Amount].rgbRed;
Buf[4].B := ColorTable[i].rgbBlue;
Buf[4].G := ColorTable[i].rgbGreen;
Buf[4].R := ColorTable[i].rgbRed;
Buf[5].B := ColorTable[i + Amount].rgbBlue;
Buf[5].G := ColorTable[i + Amount].rgbGreen;
Buf[5].R := ColorTable[i + Amount].rgbRed;
Buf[6].B := ColorTable[i - Amount].rgbBlue;
Buf[6].G := ColorTable[i - Amount].rgbGreen;
Buf[6].R := ColorTable[i - Amount].rgbRed;
Buf[7].B := ColorTable[i].rgbBlue;
Buf[7].G := ColorTable[i].rgbGreen;
Buf[7].R := ColorTable[i].rgbRed;
Buf[8].B := ColorTable[i + Amount].rgbBlue;
Buf[8].G := ColorTable[i + Amount].rgbGreen;
Buf[8].R := ColorTable[i + Amount].rgbRed;
Temp1.colorTable[i].rgbBlue := IntToByte((256 * Buf[4].b - (Buf[0].b + Buf[1].b + Buf[2].b + Buf[3].b +
Buf[5].b + Buf[6].b + Buf[7].b + Buf[8].b) * 16) div 128);
Temp1.colorTable[i].rgbGreen := IntToByte((256 * Buf[4].g - (Buf[0].g + Buf[1].g + Buf[2].g + Buf[3].g +
Buf[5].g + Buf[6].g + Buf[7].g + Buf[8].g) * 16) div 128);
Temp1.colorTable[i].rgbRed := IntToByte((256 * Buf[4].r - (Buf[0].r + Buf[1].r + Buf[2].r + Buf[3].r +
Buf[5].r + Buf[6].r + Buf[7].r + Buf[8].r) * 16) div 128);
 
end;
24: begin
P2 := Pointer(Integer(P2)+(Width-1)*3);
for x:=0 to Width-1 do
end;
Temp1.UpdatePalette;
end;
4:
begin
PBGR(@c)^ := PBGR(P1)^;
PBGR(P1)^ := PBGR(P2)^;
PBGR(P2)^ := PBGR(@c)^;
Inc(PBGR(P1));
Dec(PBGR(P2));
Temp1 := TDIB.Create;
Temp1.Assign(self);
Temp1.SetSize(Width, Height, bitCount);
for i := 0 to 255 do
begin
with Temp1.ColorTable[i] do
begin
Buf[0].B := ColorTable[i - Amount].rgbBlue;
Buf[0].G := ColorTable[i - Amount].rgbGreen;
Buf[0].R := ColorTable[i - Amount].rgbRed;
Buf[1].B := ColorTable[i].rgbBlue;
Buf[1].G := ColorTable[i].rgbGreen;
Buf[1].R := ColorTable[i].rgbRed;
Buf[2].B := ColorTable[i + Amount].rgbBlue;
Buf[2].G := ColorTable[i + Amount].rgbGreen;
Buf[2].R := ColorTable[i + Amount].rgbRed;
Buf[3].B := ColorTable[i - Amount].rgbBlue;
Buf[3].G := ColorTable[i - Amount].rgbGreen;
Buf[3].R := ColorTable[i - Amount].rgbRed;
Buf[4].B := ColorTable[i].rgbBlue;
Buf[4].G := ColorTable[i].rgbGreen;
Buf[4].R := ColorTable[i].rgbRed;
Buf[5].B := ColorTable[i + Amount].rgbBlue;
Buf[5].G := ColorTable[i + Amount].rgbGreen;
Buf[5].R := ColorTable[i + Amount].rgbRed;
Buf[6].B := ColorTable[i - Amount].rgbBlue;
Buf[6].G := ColorTable[i - Amount].rgbGreen;
Buf[6].R := ColorTable[i - Amount].rgbRed;
Buf[7].B := ColorTable[i].rgbBlue;
Buf[7].G := ColorTable[i].rgbGreen;
Buf[7].R := ColorTable[i].rgbRed;
Buf[8].B := ColorTable[i + Amount].rgbBlue;
Buf[8].G := ColorTable[i + Amount].rgbGreen;
Buf[8].R := ColorTable[i + Amount].rgbRed;
colorTable[i].rgbBlue := IntToByte((256 * Buf[4].b - (Buf[0].b + Buf[1].b + Buf[2].b + Buf[3].b +
Buf[5].b + Buf[6].b + Buf[7].b + Buf[8].b) * 16) div 128);
colorTable[i].rgbGreen := IntToByte((256 * Buf[4].g - (Buf[0].g + Buf[1].g + Buf[2].g + Buf[3].g +
Buf[5].g + Buf[6].g + Buf[7].g + Buf[8].g) * 16) div 128);
colorTable[i].rgbRed := IntToByte((256 * Buf[4].r - (Buf[0].r + Buf[1].r + Buf[2].r + Buf[3].r +
Buf[5].r + Buf[6].r + Buf[7].r + Buf[8].r) * 16) div 128);
end;
end;
32: begin
P2 := Pointer(Integer(P2)+(Width-1)*4);
for x:=0 to Width-1 do
UpdatePalette;
end;
end;
for y := 0 to Pred(Height) do
begin
PDWORD(@c)^ := PDWORD(P1)^;
PDWORD(P1)^ := PDWORD(P2)^;
PDWORD(P2)^ := PDWORD(@c)^;
Inc(PDWORD(P1));
Dec(PDWORD(P2));
Lin0 := ScanLine[Interval(0, Pred(Height), y - Amount, True)];
Lin1 := ScanLine[y];
Lin2 := ScanLine[Interval(0, Pred(Height), y + Amount, True)];
case Bitcount of
24, 8, 4: D := Temp1.ScanLine[y];
end;
for x := 0 to Pred(Width) do
begin
case BitCount of
24:
begin
cx := Interval(0, Pred(Width), x - Amount, True);
Buf[0] := Lin0[cx];
Buf[1] := Lin1[cx];
Buf[2] := Lin2[cx];
Buf[3] := Lin0[x];
Buf[4] := Lin1[x];
Buf[5] := Lin2[x];
cx := Interval(0, Pred(Width), x + Amount, true);
Buf[6] := Lin0[cx];
Buf[7] := Lin1[cx];
Buf[8] := Lin0[cx];
pc.b := IntToByte((256 * Buf[4].b - (Buf[0].b + Buf[1].b + Buf[2].b + Buf[3].b +
Buf[5].b + Buf[6].b + Buf[7].b + Buf[8].b) * 16) div 128);
pc.g := IntToByte((256 * Buf[4].g - (Buf[0].g + Buf[1].g + Buf[2].g + Buf[3].g +
Buf[5].g + Buf[6].g + Buf[7].g + Buf[8].g) * 16) div 128);
pc.r := IntToByte((256 * Buf[4].r - (Buf[0].r + Buf[1].r + Buf[2].r + Buf[3].r +
Buf[5].r + Buf[6].r + Buf[7].r + Buf[8].r) * 16) div 128);
PBGR(D)^.B := pc.b;
PBGR(D)^.G := pc.g;
PBGR(D)^.R := pc.r;
Inc(PBGR(D));
end;
8:
begin
Inc(PByte(D));
end;
4:
begin
P1 := @PArrayByte(D)[X shr 1];
P1^ := ((P1^ and Mask4n[X and 1]) or ((c shl Shift4[X and 1])));
end;
end;
end;
end;
case BitCount of
24, 8:
begin
Assign(Temp1);
Temp1.Free;
end;
4: Temp1.Free;
end;
FreeMem(pc, SizeOf(TBGR));
end;
 
UpdateProgress(y*2);
procedure TDIB.Emboss;
var
x, y: longint;
D, D1, P: pointer;
color: TBGR;
c: DWORD;
P1: PByte;
 
begin
D := nil;
D1 := nil;
P := nil;
case BitCount of
32, 16, 1: Exit;
24:
begin
D := PBits;
D1 := Ptr(Integer(D) + 3);
end;
finally
EndProgress;
else
end;
for y := 0 to Pred(Height) do
begin
case Bitcount of
8, 4:
begin
P := ScanLine[y];
end;
end;
for x := 0 to Pred(Width) do
begin
case BitCount of
24:
begin
PBGR(D)^.B := ((PBGR(D)^.B + (PBGR(D1)^.B xor $FF)) shr 1);
PBGR(D)^.G := ((PBGR(D)^.G + (PBGR(D1)^.G xor $FF)) shr 1);
PBGR(D)^.R := ((PBGR(D)^.R + (PBGR(D1)^.R xor $FF)) shr 1);
Inc(PBGR(D));
if (y < Height - 2) and (x < Width - 2) then
Inc(PBGR(D1));
end;
8:
begin
color.R := (((Pixels[x, y] + (Pixels[x + 3, y] xor $FF)) shr 1) + 30) div 3;
color.G := (((Pixels[x, y] + (Pixels[x + 3, y] xor $FF)) shr 1) + 30) div 3;
color.B := (((Pixels[x, y] + (Pixels[x + 3, y] xor $FF)) shr 1) + 30) div 3;
c := (color.R + color.G + color.B) shr 1;
PByte(P)^ := c;
Inc(PByte(P));
end;
4:
begin
color.R := (((Pixels[x, y] + (Pixels[x + 3, y] xor $FF) + 1) shr 1) + 30) div 3;
color.G := (((Pixels[x, y] + (Pixels[x + 3, y] xor $FF) - 1) shr 1) + 30) div 3;
color.B := (((Pixels[x, y] + (Pixels[x + 3, y] xor $FF) + 1) shr 1) + 30) div 3;
c := (color.R + color.G + color.B) shr 1;
if c > 64 then
c := c - 8;
P1 := @PArrayByte(P)[X shr 1];
P1^ := (P1^ and Mask4n[X and 1]) or ((c) shl Shift4[X and 1]);
end;
else
end;
end;
case BitCount of
24:
begin
D := Ptr(Integer(D1));
if y < Height - 2 then
D1 := Ptr(Integer(D1) + 6)
else
D1 := Ptr(Integer(ScanLine[Pred(Height)]) + 3);
end;
else
end;
end;
end;
 
procedure TDIB.Negative;
procedure TDIB.AddMonoNoise(Amount: Integer);
var
i, i2: Integer;
P: Pointer;
value: cardinal;
x, y: longint;
a: byte;
D: pointer;
color: DWORD;
P: PByte;
begin
if Empty then exit;
for y := 0 to Pred(Height) do
begin
D := ScanLine[y];
for x := 0 to Pred(Width) do
begin
case BitCount of
32: Exit; // I haven't bitmap of this type ! Sorry
24:
begin
value := Random(Amount) - (Amount shr 1);
PBGR(D)^.B := IntToByte(PBGR(D)^.B + value);
PBGR(D)^.G := IntToByte(PBGR(D)^.G + value);
PBGR(D)^.R := IntToByte(PBGR(D)^.R + value);
Inc(PBGR(D));
end;
16: Exit; // I haven't bitmap of this type ! Sorry
8:
begin
a := ((Random(Amount shr 1) - (Amount div 4))) div 8;
color := Interval(0, 255, (pixels[x, y] - a), True);
PByte(D)^ := color;
Inc(PByte(D));
end;
4:
begin
a := ((Random(Amount shr 1) - (Amount div 4))) div 16;
color := Interval(0, 15, (pixels[x, y] - a), True);
P := @PArrayByte(D)[X shr 1];
P^ := ((P^ and Mask4n[X and 1]) or ((color shl Shift4[X and 1])));
end;
1:
begin
a := ((Random(Amount shr 1) - (Amount div 4))) div 32;
color := Interval(0, 1, (pixels[x, y] - a), True);
P := @PArrayByte(D)[X shr 3];
P^ := (P^ and Mask1n[X and 7]) or (color shl Shift1[X and 7]);
end;
else
end;
end;
end;
end;
 
if BitCount<=8 then
procedure TDIB.AddGradiantNoise(Amount: byte);
var
a, i: byte;
x, y: Integer;
Table: array[0..255] of TBGR;
S, D: pointer;
color: DWORD;
Temp1: TDIB;
P: PByte;
 
begin
D := nil;
S := nil;
Temp1 := nil;
case BitCount of
32: Exit; // I haven't bitmap of this type ! Sorry
24:
begin
for i:=0 to 255 do
begin
a := Random(Amount);
Table[i].b := IntToByte(i + a);
Table[i].g := IntToByte(i + a);
Table[i].r := IntToByte(i + a);
end;
end;
16: Exit; // I haven't bitmap of this type ! Sorry
8, 4:
begin
Temp1 := TDIB.Create;
Temp1.Assign(self);
Temp1.SetSize(Width, Height, BitCount);
for i := 0 to 255 do
begin
with ColorTable[i] do
begin
rgbRed := 255-rgbRed;
rgbGreen := 255-rgbGreen;
rgbBlue := 255-rgbBlue;
a := Random(Amount);
rgbRed := IntToByte(rgbRed + a);
rgbGreen := IntToByte(rgbGreen + a);
rgbBlue := IntToByte(rgbBlue + a);
end;
end;
UpdatePalette;
end else
end;
else
// if the number of pixel is equal to 1 then exit of procedure
Exit;
end;
for y := 0 to Pred(Height) do
begin
P := PBits;
i2 := Size;
asm
mov ecx,i2
mov eax,P
mov edx,ecx
case BitCount of
24: D := ScanLine[y];
8, 4:
begin
D := Temp1.ScanLine[y];
S := Temp1.ScanLine[y];
end;
else
end;
for x := 0 to Pred(Width) do
begin
case BitCount of
32: ; // I haven't bitmap of this type ! Sorry
24:
begin
PBGR(D)^.B := Table[PBGR(D)^.B].b;
PBGR(D)^.G := Table[PBGR(D)^.G].g;
PBGR(D)^.R := Table[PBGR(D)^.R].r;
Inc(PBGR(D));
end;
16: ; // I haven't bitmap of this type ! Sorry
8:
begin
with Temp1.ColorTable[PByte(S)^] do
color := rgbRed + rgbGreen + rgbBlue;
Inc(PByte(S));
PByte(D)^ := color;
Inc(PByte(D));
end;
4:
begin
with Temp1.ColorTable[PByte(S)^] do
color := rgbRed + rgbGreen + rgbBlue;
Inc(PByte(S));
P := @PArrayByte(D)[X shr 1];
P^ := (P^ and Mask4n[X and 1]) or (color shl Shift4[X and 1]);
end;
else
end;
end;
end;
case BitCount of
8, 4: Temp1.Free;
else
end;
end;
 
{ Unit of DWORD. }
@@qword_skip:
shr ecx,2
jz @@dword_skip
function TDIB.FishEye(bmp: TDIB): Boolean;
var
weight, xmid, ymid, fx, fy, r1, r2, dx, dy, rmax: Double;
Amount, ifx, ify, ty, tx, new_red, new_green, new_blue, ix, iy: Integer;
weight_x, weight_y: array[0..1] of Double;
total_red, total_green, total_blue: Double;
sli, slo: PLines;
D: Pointer;
begin
Result := True;
case BitCount of
32, 16, 8, 4, 1:
begin
Result := False;
Exit;
end;
end;
Amount := 1;
xmid := Width / 2;
ymid := Height / 2;
rmax := Max(Bmp.Width, Bmp.Height) * Amount;
for ty := 0 to Pred(Height) do
begin
for tx := 0 to Pred(Width) do
begin
dx := tx - xmid;
dy := ty - ymid;
r1 := Sqrt(Sqr(dx) + Sqr(dy));
if r1 <> 0 then
begin
r2 := rmax / 2 * (1 / (1 - r1 / rmax) - 1);
fx := dx * r2 / r1 + xmid;
fy := dy * r2 / r1 + ymid;
end
else
begin
fx := xmid;
fy := ymid;
end;
ify := Trunc(fy);
ifx := Trunc(fx);
if fy >= 0 then
begin
weight_y[1] := fy - ify;
weight_y[0] := 1 - weight_y[1];
end
else
begin
weight_y[0] := -(fy - ify);
weight_y[1] := 1 - weight_y[0];
end;
if fx >= 0 then
begin
weight_x[1] := fx - ifx;
weight_x[0] := 1 - weight_x[1];
end
else
begin
weight_x[0] := -(fx - ifx);
Weight_x[1] := 1 - weight_x[0];
end;
if ifx < 0 then
ifx := Pred(Width) - (-ifx mod Width)
else
if ifx > Pred(Width) then
ifx := ifx mod Width;
if ify < 0 then
ify := Pred(Height) - (-ify mod Height)
else
if ify > Pred(Height) then
ify := ify mod Height;
total_red := 0.0;
total_green := 0.0;
total_blue := 0.0;
for ix := 0 to 1 do
begin
for iy := 0 to 1 do
begin
if ify + iy < Height then
sli := ScanLine[ify + iy]
else
sli := ScanLine[Height - ify - iy];
if ifx + ix < Width then
begin
new_red := sli^[ifx + ix].r;
new_green := sli^[ifx + ix].g;
new_blue := sli^[ifx + ix].b;
end
else
begin
new_red := sli^[Width - ifx - ix].r;
new_green := sli^[Width - ifx - ix].g;
new_blue := sli^[Width - ifx - ix].b;
end;
weight := weight_x[ix] * weight_y[iy];
total_red := total_red + new_red * weight;
total_green := total_green + new_green * weight;
total_blue := total_blue + new_blue * weight;
end;
end;
case bitCount of
24:
begin
slo := Bmp.ScanLine[ty];
slo^[tx].r := Round(total_red);
slo^[tx].g := Round(total_green);
slo^[tx].b := Round(total_blue);
end;
else
// You can implement this procedure for 16,8,4,2 and 32 BitCount's DIB
Exit;
end;
end;
end;
end;
 
dec ecx
@@dword_loop:
not dword ptr [eax+ecx*4]
dec ecx
jnl @@dword_loop
function TDIB.SmoothRotateWrap(Bmp: TDIB; cx, cy: Integer; Degree: Extended): Boolean;
var
weight, Theta, cosTheta, sinTheta, sfrom_y, sfrom_x: Double;
ifrom_y, ifrom_x, xDiff, yDiff, to_y, to_x: Integer;
weight_x, weight_y: array[0..1] of Double;
ix, iy, new_red, new_green, new_blue: Integer;
total_red, total_green, total_blue: Double;
sli, slo: PLines;
begin
Result := True;
case BitCount of
32, 16, 8, 4, 1:
begin
Result := False;
Exit;
end;
end;
Theta := -Degree * Pi / 180;
sinTheta := Sin(Theta);
cosTheta := Cos(Theta);
xDiff := (Bmp.Width - Width) div 2;
yDiff := (Bmp.Height - Height) div 2;
for to_y := 0 to Pred(Bmp.Height) do
begin
for to_x := 0 to Pred(Bmp.Width) do
begin
sfrom_x := (cx + (to_x - cx) * cosTheta - (to_y - cy) * sinTheta) - xDiff;
ifrom_x := Trunc(sfrom_x);
sfrom_y := (cy + (to_x - cx) * sinTheta + (to_y - cy) * cosTheta) - yDiff;
ifrom_y := Trunc(sfrom_y);
if sfrom_y >= 0 then
begin
weight_y[1] := sfrom_y - ifrom_y;
weight_y[0] := 1 - weight_y[1];
end
else
begin
weight_y[0] := -(sfrom_y - ifrom_y);
weight_y[1] := 1 - weight_y[0];
end;
if sfrom_x >= 0 then
begin
weight_x[1] := sfrom_x - ifrom_x;
weight_x[0] := 1 - weight_x[1];
end
else
begin
weight_x[0] := -(sfrom_x - ifrom_x);
Weight_x[1] := 1 - weight_x[0];
end;
if ifrom_x < 0 then
ifrom_x := Pred(Width) - (-ifrom_x mod Width)
else
if ifrom_x > Pred(Width) then
ifrom_x := ifrom_x mod Width;
if ifrom_y < 0 then
ifrom_y := Pred(Height) - (-ifrom_y mod Height)
else
if ifrom_y > Pred(Height) then
ifrom_y := ifrom_y mod Height;
total_red := 0.0;
total_green := 0.0;
total_blue := 0.0;
for ix := 0 to 1 do
begin
for iy := 0 to 1 do
begin
if ifrom_y + iy < Height then
sli := ScanLine[ifrom_y + iy]
else
sli := ScanLine[Height - ifrom_y - iy];
if ifrom_x + ix < Width then
begin
new_red := sli^[ifrom_x + ix].r;
new_green := sli^[ifrom_x + ix].g;
new_blue := sli^[ifrom_x + ix].b;
end
else
begin
new_red := sli^[Width - ifrom_x - ix].r;
new_green := sli^[Width - ifrom_x - ix].g;
new_blue := sli^[Width - ifrom_x - ix].b;
end;
weight := weight_x[ix] * weight_y[iy];
total_red := total_red + new_red * weight;
total_green := total_green + new_green * weight;
total_blue := total_blue + new_blue * weight;
end;
end;
case bitCount of
24:
begin
slo := Bmp.ScanLine[to_y];
slo^[to_x].r := Round(total_red);
slo^[to_x].g := Round(total_green);
slo^[to_x].b := Round(total_blue);
end;
else
// You can implement this procedure for 16,8,4,2 and 32 BitCount's DIB
Exit;
end;
end;
end;
end;
 
mov ecx,edx
shr ecx,2
add eax,ecx*4
function TDIB.Rotate(Dst: TDIB; cx, cy: Integer; Angle: Double): Boolean;
var
x, y, dx, dy, sdx, sdy, xDiff, yDiff, isinTheta, icosTheta: Integer;
D, S: Pointer;
sinTheta, cosTheta, Theta: Double;
Col: TBGR;
i: byte;
color: DWORD;
P: PByte;
begin
D := nil;
S := nil;
Result := True;
dst.SetSize(Width, Height, Bitcount);
dst.Canvas.Brush.Color := clBlack;
Dst.Canvas.FillRect(Bounds(0, 0, Width, Height));
case BitCount of
32, 16:
begin
Result := False;
Exit;
end;
8, 4, 1:
begin
for i := 0 to 255 do
Dst.ColorTable[i] := ColorTable[i];
Dst.UpdatePalette;
end;
end;
Theta := -Angle * Pi / 180;
sinTheta := Sin(Theta);
cosTheta := Cos(Theta);
xDiff := (Dst.Width - Width) div 2;
yDiff := (Dst.Height - Height) div 2;
isinTheta := Round(sinTheta * $10000);
icosTheta := Round(cosTheta * $10000);
for y := 0 to Pred(Dst.Height) do
begin
case BitCount of
4, 1:
begin
D := Dst.ScanLine[y];
S := ScanLine[y];
end;
else
end;
sdx := Round(((cx + (-cx) * cosTheta - (y - cy) * sinTheta) - xDiff) * $10000);
sdy := Round(((cy + (-cy) * sinTheta + (y - cy) * cosTheta) - yDiff) * $10000);
for x := 0 to Pred(Dst.Width) do
begin
dx := (sdx shr 16);
dy := (sdy shr 16);
if (dx > -1) and (dx < Width) and (dy > -1) and (dy < Height) then
begin
case bitcount of
8, 24: Dst.pixels[x, y] := Pixels[dx, dy];
4:
begin
pfGetRGB(NowPixelFormat, Pixels[dx, dy], col.r, col.g, col.b);
color := col.r + col.g + col.b;
Inc(PByte(S));
P := @PArrayByte(D)[x shr 1];
P^ := (P^ and Mask4n[x and 1]) or (color shl Shift4[x and 1]);
end;
1:
begin
pfGetRGB(NowPixelFormat, Pixels[dx, dy], col.r, col.g, col.b);
color := col.r + col.g + col.b;
Inc(PByte(S));
P := @PArrayByte(D)[X shr 3];
P^ := (P^ and Mask1n[X and 7]) or (color shl Shift1[X and 7]);
end;
end;
end;
Inc(sdx, icosTheta);
Inc(sdy, isinTheta);
end;
end;
end;
 
{ Unit of Byte. }
@@dword_skip:
mov ecx,edx
and ecx,3
jz @@byte_skip
procedure TDIB.GaussianBlur(Bmp: TDIB; Amount: Integer);
var
i: Integer;
begin
for i := 1 to Amount do
Bmp.SplitBlur(i);
end;
 
dec ecx
@@loop_byte:
not byte ptr [eax+ecx]
dec ecx
jnl @@loop_byte
procedure TDIB.SplitBlur(Amount: Integer);
var
Lin1, Lin2: PLines;
cx, x, y: Integer;
Buf: array[0..3] of TBGR;
D: Pointer;
 
@@byte_skip:
begin
case Bitcount of
32, 16, 8, 4, 1: Exit;
end;
for y := 0 to Pred(Height) do
begin
Lin1 := ScanLine[TrimInt(y + Amount, 0, Pred(Height))];
Lin2 := ScanLine[TrimInt(y - Amount, 0, Pred(Height))];
D := ScanLine[y];
for x := 0 to Pred(Width) do
begin
cx := TrimInt(x + Amount, 0, Pred(Width));
Buf[0] := Lin1[cx];
Buf[1] := Lin2[cx];
cx := TrimInt(x - Amount, 0, Pred(Width));
Buf[2] := Lin1[cx];
Buf[3] := Lin2[cx];
PBGR(D)^.b := (Buf[0].b + Buf[1].b + Buf[2].b + Buf[3].b) shr 2;
PBGR(D)^.g := (Buf[0].g + Buf[1].g + Buf[2].g + Buf[3].g) shr 2;
PBGR(D)^.r := (Buf[0].r + Buf[1].r + Buf[2].r + Buf[3].r) shr 2;
Inc(PBGR(D));
end;
end;
end;
 
function TDIB.Twist(bmp: TDIB; Amount: byte): Boolean;
var
fxmid, fymid: Single;
txmid, tymid: Single;
fx, fy: Single;
tx2, ty2: Single;
r: Single;
theta: Single;
ifx, ify: Integer;
dx, dy: Single;
OFFSET: Single;
ty, tx, ix, iy: Integer;
weight_x, weight_y: array[0..1] of Single;
weight: Single;
new_red, new_green, new_blue: Integer;
total_red, total_green, total_blue: Single;
sli, slo: PLines;
 
function ArcTan2(xt, yt: Single): Single; {$IFDEF VER9UP}inline;{$ENDIF}
begin
if xt = 0 then
if yt > 0 then
Result := Pi / 2
else
Result := -(Pi / 2)
else
begin
Result := ArcTan(yt / xt);
if xt < 0 then
Result := Pi + ArcTan(yt / xt);
end;
end;
 
begin
Result := True;
case BitCount of
32, 16, 8, 4, 1:
begin
Result := False;
Exit;
end;
end;
if Amount = 0 then
Amount := 1;
OFFSET := -(Pi / 2);
dx := Pred(Width);
dy := Pred(Height);
r := Sqrt(dx * dx + dy * dy);
tx2 := r;
ty2 := r;
txmid := (Pred(Width)) / 2;
tymid := (Pred(Height)) / 2;
fxmid := (Pred(Width)) / 2;
fymid := (Pred(Height)) / 2;
if tx2 >= Width then
tx2 := Pred(Width);
if ty2 >= Height then
ty2 := Pred(Height);
for ty := 0 to Round(ty2) do
begin
for tx := 0 to Round(tx2) do
begin
dx := tx - txmid;
dy := ty - tymid;
r := Sqrt(dx * dx + dy * dy);
if r = 0 then
begin
fx := 0;
fy := 0;
end
else
begin
theta := ArcTan2(dx, dy) - r / Amount - OFFSET;
fx := r * Cos(theta);
fy := r * Sin(theta);
end;
fx := fx + fxmid;
fy := fy + fymid;
ify := Trunc(fy);
ifx := Trunc(fx);
if fy >= 0 then
begin
weight_y[1] := fy - ify;
weight_y[0] := 1 - weight_y[1];
end
else
begin
weight_y[0] := -(fy - ify);
weight_y[1] := 1 - weight_y[0];
end;
if fx >= 0 then
begin
weight_x[1] := fx - ifx;
weight_x[0] := 1 - weight_x[1];
end
else
begin
weight_x[0] := -(fx - ifx);
Weight_x[1] := 1 - weight_x[0];
end;
if ifx < 0 then
ifx := Pred(Width) - (-ifx mod Width)
else
if ifx > Pred(Width) then
ifx := ifx mod Width;
if ify < 0 then
ify := Pred(Height) - (-ify mod Height)
else
if ify > Pred(Height) then
ify := ify mod Height;
total_red := 0.0;
total_green := 0.0;
total_blue := 0.0;
for ix := 0 to 1 do
begin
for iy := 0 to 1 do
begin
if ify + iy < Height then
sli := ScanLine[ify + iy]
else
sli := ScanLine[Height - ify - iy];
if ifx + ix < Width then
begin
new_red := sli^[ifx + ix].r;
new_green := sli^[ifx + ix].g;
new_blue := sli^[ifx + ix].b;
end
else
begin
new_red := sli^[Width - ifx - ix].r;
new_green := sli^[Width - ifx - ix].g;
new_blue := sli^[Width - ifx - ix].b;
end;
weight := weight_x[ix] * weight_y[iy];
total_red := total_red + new_red * weight;
total_green := total_green + new_green * weight;
total_blue := total_blue + new_blue * weight;
end;
end;
case bitCount of
24:
begin
slo := bmp.ScanLine[ty];
slo^[tx].r := Round(total_red);
slo^[tx].g := Round(total_green);
slo^[tx].b := Round(total_blue);
end;
else
// You can implement this procedure for 16,8,4,2 and 32 BitCount's DIB
Exit;
end;
end;
end;
end;
 
function TDIB.TrimInt(i, Min, Max: Integer): Integer;
begin
if i > Max then
Result := Max
else
if i < Min then
Result := Min
else
Result := i;
end;
 
function TDIB.IntToByte(i: Integer): Byte;
begin
if i > 255 then
Result := 255
else
if i < 0 then
Result := 0
else
Result := i;
end;
 
//--------------------------------------------------------------------------------------------------
// End of these New Special Effect //
// Please contributes to add effects and filters to this collection //
// Please, work to implement 32,16,8,4,2 BitCount's DIB //
// Have fun - Mickey - Good job //
//--------------------------------------------------------------------------------------------------
 
function TDIB.GetAlphaChannel: TDIB;
begin
RetAlphaChannel(Result);
 
FFreeList.Add(Result);
end;
 
procedure TDIB.SetAlphaChannel(const Value: TDIB);
begin
if not AssignAlphaChannel(Value{$IFNDEF VER4UP}, False{$ENDIF}) then
Exception.Create('Cannot set alphachannel from DIB.');
end;
 
procedure TDIB.Fill(aColor: TColor);
begin
Canvas.Brush.Color := aColor;
Canvas.FillRect(ClientRect);
end;
 
function TDIB.GetClientRect: TRect;
begin
Result := Bounds(0, 0, Width, Height);
end;
 
{ TCustomDXDIB }
 
constructor TCustomDXDIB.Create(AOnwer: TComponent);
3078,17 → 5357,20
begin
inherited Canvas.StretchDraw(Bounds(-(Width-ClientWidth) div 2,
-(Height-ClientHeight) div 2, Width, Height), FDIB);
end else
end
else
begin
inherited Canvas.StretchDraw(Bounds(0, 0, Width, Height), FDIB);
end;
end else
end
else
begin
if FCenter then
begin
inherited Canvas.Draw(-(Width-ClientWidth) div 2, -(Height-ClientHeight) div 2,
FDIB);
end else
end
else
begin
inherited Canvas.Draw(0, 0, FDIB);
end;
3128,11 → 5410,14
if r>r2 then
r := r2;
Draw2(Round(r*ClientWidth), Round(r*ClientHeight));
end else
end
else
Draw2(ViewWidth2, ViewHeight2);
end else
end
else
Draw2(ViewWidth2, ViewHeight2);
end else
end
else
begin
if FAutoStretch then
begin
3143,9 → 5428,11
if r>r2 then
r := r2;
Draw2(Round(r*FDIB.Width), Round(r*FDIB.Height));
end else
end
else
Draw2(FDIB.Width, FDIB.Height);
end else
end
else
if FStretch then
begin
if FKeepAspect then
3155,9 → 5442,11
if r>r2 then
r := r2;
Draw2(Round(r*FDIB.Width), Round(r*FDIB.Height));
end else
end
else
Draw2(ClientWidth, ClientHeight);
end else
end
else
Draw2(FDIB.Width, FDIB.Height);
end;
end;
3228,6 → 5517,4382
end;
end;
 
{ DXFusion -> }
 
function PosValue(Value: Integer): Integer;
begin
if Value < 0 then result := 0 else result := Value;
end;
 
procedure TDIB.CreateDIBFromBitmap(const Bitmap: TBitmap);
var
pf: Integer;
begin
if Bitmap.PixelFormat = pf32bit then pf := 32 else pf := 24;
SetSize(Bitmap.Width, Bitmap.Height, pf); {always >=24}
Canvas.Draw(0, 0, Bitmap);
end;
 
function TDIB.CreateBitmapFromDIB: TBitmap;
//var
// X, Y: Integer;
begin
Result := TBitmap.Create;
if BitCount = 32 then
Result.PixelFormat := pf32bit
else if BitCount = 24 then
Result.PixelFormat := pf24bit
else if BitCount = 16 then
Result.PixelFormat := pf16bit
else if BitCount = 8 then
Result.PixelFormat := pf8bit
else Result.PixelFormat := pf24bit;
Result.Width := Width;
Result.Height := Height;
Result.Canvas.Draw(0, 0, Self);
// for Y := 0 to Height - 1 do
// for X := 0 to Width - 1 do
// Result.Canvas.Pixels[X, Y] := Canvas.Pixels[X, Y];
end;
 
procedure TDIB.DrawTo(SrcDIB: TDIB; X, Y, Width, Height,
SourceX, SourceY: Integer);
begin
SrcDIB.DrawOn(Rect(X, Y, Width, Height), Self.Canvas, SourceX, SourceY);
end;
 
procedure TDIB.DrawTransparent(SrcDIB: TDIB; const X, Y, Width, Height,
SourceX, SourceY: Integer; const Color: TColor);
var
i, j: Integer;
k1, k2: Integer;
n: Integer;
p1, p2: PByteArray;
 
Startk1, Startk2: Integer;
 
StartY: Integer;
EndY: Integer;
 
DestStartY: Integer;
begin
if Self.BitCount <> 24 then Exit;
if SrcDIB.BitCount <> 24 then Exit;
Startk1 := 3 * SourceX;
Startk2 := 3 * X;
 
DestStartY := Y - SourceY;
 
StartY := SourceY;
EndY := SourceY + Height;
 
if (StartY + DestStartY < 0) then
StartY := -DestStartY;
if (EndY + DestStartY > Self.Height) then
EndY := Self.Height - DestStartY;
 
if (StartY < 0) then
StartY := 0;
if (EndY > SrcDIB.Height) then
EndY := SrcDIB.Height;
 
for j := StartY to EndY - 1 do
begin
p1 := Self.Scanline[j + DestStartY];
p2 := SrcDIB.Scanline[j];
 
k1 := Startk1;
k2 := Startk2;
 
for i := SourceX to SourceX + Width - 1 do
begin
n := (p2[k1] shl 16) + (p2[k1 + 1] shl 8) + p2[k1 + 2];
 
if not (n = Color) then
begin
p1[k2] := p2[k1];
p1[k2 + 1] := p2[k1 + 1];
p1[k2 + 2] := p2[k1 + 2];
end;
 
k1 := k1 + 3;
k2 := k2 + 3;
end;
end;
end;
 
procedure TDIB.DrawShadow(SrcDIB: TDIB; X, Y, Width, Height,
Frame: Integer; FilterMode: TFilterMode);
var
i, j: Integer;
p1, p2: PByte;
FW: Integer;
begin
if Self.BitCount <> 24 then Exit;
if SrcDIB.BitCount <> 24 then Exit;
 
FW := Frame * Width;
for i := 1 to Height - 1 do
begin
p1 := Self.Scanline[i + Y];
p2 := SrcDIB.Scanline[i];
Inc(p1, 3 * (X + 1));
Inc(p2, 3 * (FW + 1));
for j := 1 to Width - 1 do
begin
if (p2^ = 0) then
begin
case FilterMode of
fmNormal, fmMix50:
begin
p1^ := p1^ shr 1; // Blue
Inc(p1);
p1^ := p1^ shr 1; // Green
Inc(p1);
p1^ := p1^ shr 1; // Red
Inc(p1);
end;
fmMix25:
begin
p1^ := p1^ - p1^ shr 2; // Blue
Inc(p1);
p1^ := p1^ - p1^ shr 2; // Green
Inc(p1);
p1^ := p1^ - p1^ shr 2; // Red
Inc(p1);
end;
fmMix75:
begin
p1^ := p1^ shr 2; // Blue
Inc(p1);
p1^ := p1^ shr 2; // Green
Inc(p1);
p1^ := p1^ shr 2; // Red
Inc(p1);
end;
end;
end
else
Inc(p1, 3); // Not in the loop...
Inc(p2, 3);
end;
end;
end;
 
procedure TDIB.DrawShadows(SrcDIB: TDIB; X, Y, Width, Height,
Frame: Integer; Alpha: Byte);
{plynule nastavovani stiny dle alpha}
type
P3ByteArray = ^T3ByteArray;
T3ByteArray = array[0..32767] of TBGR;
var
i, j, l1, l2: Integer;
p1, p2: P3ByteArray;
FW: Integer;
begin
if Self.BitCount <> 24 then Exit;
if SrcDIB.BitCount <> 24 then Exit;
 
FW := Frame * Width;
for i := 0 to Height - 1 do
begin
p1 := Self.Scanline[i + Y];
p2 := SrcDIB.Scanline[i];
l1 := X;
l2 := FW;
for j := 0 to Width - 1 do
begin
if (p2[j + l2].B = 0) and (p2[j + l2].G = 0) and (p2[j + l2].R = 0) then
begin
p1[J + l1].B := Round(p1[J + l1].B / $FF * Alpha);
p1[J + l1].G := Round(p1[J + l1].G / $FF * Alpha);
p1[J + l1].R := Round(p1[J + l1].R / $FF * Alpha);
end
end;
end;
end;
 
procedure TDIB.DrawDarken(SrcDIB: TDIB; X, Y, Width, Height,
Frame: Integer);
var
frameoffset, i, j: Integer;
p1, p2: pByte;
XOffset: Integer;
begin
if Self.BitCount <> 24 then Exit;
if SrcDIB.BitCount <> 24 then Exit;
 
frameoffset := 3 * (Frame * Width) + 3;
XOffset := 3 * X + 3;
for i := 1 to Height - 1 do
begin
p1 := Self.Scanline[i + Y];
p2 := SrcDIB.Scanline[i];
inc(p1, XOffset);
inc(p2, frameoffset);
for j := 1 to Width - 1 do
begin
p1^ := (p2^ * p1^) shr 8; // R
inc(p1);
inc(p2);
p1^ := (p2^ * p1^) shr 8; // G
inc(p1);
inc(p2);
p1^ := (p2^ * p1^) shr 8; // B
inc(p1);
inc(p2);
end;
end;
end;
 
procedure TDIB.DrawQuickAlpha(SrcDIB: TDIB; const X, Y, Width, Height,
SourceX, SourceY: Integer; const Color: TColor; FilterMode: TFilterMode);
var
i, j: Integer;
k1, k2: Integer;
n: Integer;
p1, p2: PByteArray;
BitSwitch1, BitSwitch2: Boolean;
 
Startk1, Startk2: Integer;
StartY: Integer;
EndY: Integer;
 
DestStartY: Integer;
begin
if Self.BitCount <> 24 then Exit;
if SrcDIB.BitCount <> 24 then Exit;
 
Startk1 := 3 * SourceX;
Startk2 := 3 * X;
 
DestStartY := Y - SourceY;
 
StartY := SourceY;
EndY := SourceY + Height;
 
if (StartY + DestStartY < 0) then
StartY := -DestStartY;
if (EndY + DestStartY > Self.Height) then
EndY := Self.Height - DestStartY;
 
if (StartY < 0) then
StartY := 0;
if (EndY > SrcDIB.Height) then
EndY := SrcDIB.Height;
 
if Odd(Y) then BitSwitch1 := true else BitSwitch1 := false;
if Odd(X) then BitSwitch2 := true else BitSwitch2 := false;
 
for j := StartY to EndY - 1 do
begin
BitSwitch1 := not BitSwitch1;
p1 := Self.Scanline[j + DestStartY];
p2 := SrcDIB.Scanline[j];
 
k1 := Startk1;
k2 := Startk2;
 
for i := SourceX to SourceX + Width - 1 do
begin
BitSwitch2 := not BitSwitch2;
 
n := (p2[k1] shl 16) + (p2[k1 + 1] shl 8) + p2[k1 + 2];
 
case FilterMode of
fmNormal, fmMix50: if not (n = Color) and (BitSwitch1 xor BitSwitch2) then
begin
p1[k2] := p2[k1];
p1[k2 + 1] := p2[k1 + 1];
p1[k2 + 2] := p2[k1 + 2];
end;
fmMix25: if not (n = Color) and (BitSwitch1 and BitSwitch2) then
begin
p1[k2] := p2[k1];
p1[k2 + 1] := p2[k1 + 1];
p1[k2 + 2] := p2[k1 + 2];
end;
fmMix75: if not (n = Color) and (BitSwitch1 or BitSwitch2) then
begin
p1[k2] := p2[k1];
p1[k2 + 1] := p2[k1 + 1];
p1[k2 + 2] := p2[k1 + 2];
end;
end;
 
k1 := k1 + 3;
k2 := k2 + 3;
end;
end;
end;
 
procedure TDIB.DrawAdditive(SrcDIB: TDIB; X, Y, Width, Height, Alpha, Frame:
Integer);
var
frameoffset, i, j, Wid: Integer;
p1, p2: pByte;
begin
if Self.BitCount <> 24 then Exit;
if SrcDIB.BitCount <> 24 then Exit;
 
if (Alpha < 1) or (Alpha > 256) then Exit;
Wid := Width shl 1 + Width;
frameoffset := Wid * Frame;
for i := 1 to Height - 1 do
begin
if (i + Y) > (Self.Height - 1) then Break; //add 25.5.2004 JB.
p1 := Self.Scanline[i + Y];
p2 := SrcDIB.Scanline[i];
inc(p1, X shl 1 + X + 3);
inc(p2, frameoffset + 3);
for j := 3 to Wid - 4 do
begin
inc(p1^, (Alpha - p1^) * p2^ shr 8);
inc(p1);
inc(p2);
end;
end;
end;
 
procedure TDIB.DrawTranslucent(SrcDIB: TDIB; const X, Y, Width, Height,
SourceX, SourceY: Integer; const Color: TColor);
var
i, j: Integer;
k1, k2: Integer;
n: Integer;
p1, p2: PByteArray;
 
Startk1, Startk2: Integer;
StartY: Integer;
EndY: Integer;
 
DestStartY: Integer;
begin
if Self.BitCount <> 24 then Exit;
if SrcDIB.BitCount <> 24 then Exit;
 
Startk1 := 3 * SourceX;
Startk2 := 3 * X;
 
DestStartY := Y - SourceY;
 
StartY := SourceY;
EndY := SourceY + Height;
 
if (StartY + DestStartY < 0) then
StartY := -DestStartY;
if (EndY + DestStartY > Self.Height) then
EndY := Self.Height - DestStartY;
 
if (StartY < 0) then
StartY := 0;
if (EndY > SrcDIB.Height) then
EndY := SrcDIB.Height;
 
for j := StartY to EndY - 1 do
begin
p1 := Self.Scanline[j + DestStartY];
p2 := SrcDIB.Scanline[j];
 
k1 := Startk1;
k2 := Startk2;
 
for i := SourceX to SourceX + Width - 1 do
begin
n := (p2[k1] shl 16) + (p2[k1 + 1] shl 8) + p2[k1 + 2];
 
if not (n = Color) then
begin
p1[k2] := (p1[k2] + p2[k1]) shr 1;
p1[k2 + 1] := (p1[k2 + 1] + p2[k1 + 1]) shr 1;
p1[k2 + 2] := (p1[k2 + 2] + p2[k1 + 2]) shr 1;
end;
 
k1 := k1 + 3;
k2 := k2 + 3;
end;
end;
end;
 
procedure TDIB.DrawAlpha(SrcDIB: TDIB; const X, Y, Width, Height,
SourceX, SourceY, Alpha: Integer; const Color: TColor);
var
i, j: Integer;
k1, k2: Integer;
n: Integer;
p1, p2: PByteArray;
 
Startk1, Startk2: Integer;
StartY: Integer;
EndY: Integer;
 
DestStartY: Integer;
begin
if Self.BitCount <> 24 then Exit;
if SrcDIB.BitCount <> 24 then Exit;
 
Startk1 := 3 * SourceX;
Startk2 := 3 * x;
 
DestStartY := Y - SourceY;
 
StartY := SourceY;
EndY := SourceY + Height;
 
if (EndY + DestStartY > Self.Height) then
EndY := Self.Height - DestStartY;
 
if (EndY > SrcDIB.Height) then
EndY := SrcDIB.Height;
 
if (StartY < 0) then
StartY := 0;
 
if (StartY + DestStartY < 0) then
StartY := DestStartY;
 
for j := StartY to EndY - 1 do
begin
p1 := Self.Scanline[j + DestStartY];
p2 := SrcDIB.Scanline[j];
 
k1 := Startk1;
k2 := Startk2;
 
for i := SourceX to SourceX + Width - 1 do
begin
n := (p2[k1] shl 16) + (p2[k1 + 1] shl 8) + p2[k1 + 2];
 
if not (n = Color) then
begin
p1[k2] := (p1[k2] * (256 - Alpha) + p2[k1] * Alpha) shr 8;
p1[k2 + 1] := (p1[k2 + 1] * (256 - Alpha) + p2[k1 + 1] * Alpha) shr 8;
p1[k2 + 2] := (p1[k2 + 2] * (256 - Alpha) + p2[k1 + 2] * Alpha) shr 8;
end;
 
k1 := k1 + 3;
k2 := k2 + 3;
end;
end;
end;
 
procedure TDIB.DrawAlphaMask(SrcDIB, MaskDIB: TDIB; const X, Y,
Width, Height, SourceX, SourceY: Integer);
var
i, j: Integer;
k1, k2, k3: Integer;
p1, p2, p3: PByteArray;
 
Startk1, Startk2: Integer;
StartY: Integer;
EndY: Integer;
 
DestStartY: Integer;
begin
if Self.BitCount <> 24 then Exit;
if SrcDIB.BitCount <> 24 then Exit;
 
Startk1 := 3 * SourceX;
Startk2 := 3 * x;
 
DestStartY := Y - SourceY;
 
StartY := SourceY;
EndY := SourceY + Height;
 
if (EndY + DestStartY > Self.Height) then
EndY := Self.Height - DestStartY;
 
if (EndY > SrcDIB.Height) then
EndY := SrcDIB.Height;
 
if (StartY < 0) then
StartY := 0;
 
if (StartY + DestStartY < 0) then
StartY := DestStartY;
 
for j := StartY to EndY - 1 do
begin
p1 := Self.Scanline[j + DestStartY];
p2 := SrcDIB.Scanline[j];
p3 := MaskDIB.Scanline[j];
 
k1 := Startk1;
k2 := Startk2;
k3 := 0;
 
for i := SourceX to SourceX + Width - 1 do
begin
p1[k2] := (p1[k2] * (256 - p3[k3]) + p2[k1] * p3[k3]) shr 8;
p1[k2 + 1] := (p1[k2 + 1] * (256 - p3[k3]) + p2[k1 + 1] * p3[k3]) shr 8;
p1[k2 + 2] := (p1[k2 + 2] * (256 - p3[k3]) + p2[k1 + 2] * p3[k3]) shr 8;
 
k1 := k1 + 3;
k2 := k2 + 3;
k3 := k3 + 3;
end;
end;
end;
 
procedure TDIB.DrawMorphed(SrcDIB: TDIB; const X, Y, Width, Height,
SourceX, SourceY: Integer; const Color: TColor);
var
i, j, r, g, b: Integer;
k1, k2: Integer;
n: Integer;
p1, p2: PByteArray;
 
Startk1, Startk2: Integer;
StartY: Integer;
EndY: Integer;
 
DestStartY: Integer;
begin
if Self.BitCount <> 24 then Exit;
if SrcDIB.BitCount <> 24 then Exit;
 
Startk1 := 3 * SourceX;
Startk2 := 3 * x;
 
DestStartY := Y - SourceY;
 
StartY := SourceY;
EndY := SourceY + Height;
 
if (EndY + DestStartY > Self.Height) then
EndY := Self.Height - DestStartY;
 
if (EndY > SrcDIB.Height) then
EndY := SrcDIB.Height;
 
if (StartY < 0) then
StartY := 0;
 
if (StartY + DestStartY < 0) then
StartY := DestStartY;
 
r := 0;
g := 0;
b := 0;
 
for j := StartY to EndY - 1 do
begin
p1 := Self.Scanline[j + DestStartY];
p2 := SrcDIB.Scanline[j];
 
k1 := Startk1;
k2 := Startk2;
 
for i := SourceX to SourceX + Width - 1 do
begin
n := (p2[k1] shl 16) + (p2[k1 + 1] shl 8) + p2[k1 + 2];
 
if Random(100) < 50 then
begin
b := p1[k2];
g := p1[k2 + 1];
r := p1[k2 + 2];
end;
 
if not (n = Color) then
begin
p1[k2] := b;
p1[k2 + 1] := g;
p1[k2 + 2] := r;
end;
 
k1 := k1 + 3;
k2 := k2 + 3;
end;
end;
end;
 
procedure TDIB.DrawMono(SrcDIB: TDIB; const X, Y, Width, Height,
SourceX, SourceY: Integer; const TransColor, ForeColor, BackColor: TColor);
var
i, j, r1, g1, b1, r2, g2, b2: Integer;
k1, k2: Integer;
n: Integer;
p1, p2: PByteArray;
Startk1, Startk2, StartY, EndY, DestStartY: Integer;
begin
if Self.BitCount <> 24 then Exit;
if SrcDIB.BitCount <> 24 then Exit;
 
Startk1 := 3 * SourceX;
Startk2 := 3 * x;
 
DestStartY := Y - SourceY;
 
StartY := SourceY;
EndY := SourceY + Height;
 
if (EndY + DestStartY > Self.Height) then
EndY := Self.Height - DestStartY;
 
if (EndY > SrcDIB.Height) then
EndY := SrcDIB.Height;
 
if (StartY < 0) then
StartY := 0;
 
if (StartY + DestStartY < 0) then
StartY := DestStartY;
 
r1 := GetRValue(BackColor);
g1 := GetGValue(BackColor);
b1 := GetBValue(BackColor);
 
r2 := GetRValue(ForeColor);
g2 := GetGValue(ForeColor);
b2 := GetBValue(ForeColor);
 
 
for j := StartY to EndY - 1 do
begin
p1 := Self.Scanline[j + DestStartY];
p2 := SrcDIB.Scanline[j];
 
k1 := Startk1;
k2 := Startk2;
 
for i := SourceX to SourceX + Width - 1 do
begin
n := (p2[k1] shl 16) + (p2[k1 + 1] shl 8) + p2[k1 + 2];
 
if (n = TransColor) then
begin
p1[k2] := b1;
p1[k2 + 1] := g1;
p1[k2 + 2] := r1;
end
else
begin
p1[k2] := b2;
p1[k2 + 1] := g2;
p1[k2 + 2] := r2;
end;
 
k1 := k1 + 3;
k2 := k2 + 3;
end;
end;
end;
 
procedure TDIB.Draw3x3Matrix(SrcDIB: TDIB; Setting: TMatrixSetting);
var i, j, k: Integer;
p1, p2, p3, p4: PByteArray;
begin
if Self.BitCount <> 24 then Exit;
if SrcDIB.BitCount <> 24 then Exit;
 
for i := 1 to SrcDIB.Height - 2 do
begin
p1 := SrcDIB.ScanLine[i - 1];
p2 := SrcDIB.ScanLine[i];
p3 := SrcDIB.ScanLine[i + 1];
p4 := Self.ScanLine[i];
for j := 3 to 3 * SrcDIB.Width - 4 do
begin
k := (p1[j - 3] * Setting[0] + p1[j] * Setting[1] + p1[j + 3] * Setting[2] +
p2[j - 3] * Setting[3] + p2[j] * Setting[4] + p2[j + 3] * Setting[5] +
p3[j - 3] * Setting[6] + p3[j] * Setting[7] + p3[j + 3] * Setting[8])
div Setting[9];
if k < 0 then k := 0;
if k > 255 then k := 255;
p4[j] := k;
end;
end;
end;
 
procedure TDIB.DrawAntialias(SrcDIB: TDIB);
var i, j, k, l, m: Integer;
p1, p2, p3: PByteArray;
begin
if Self.BitCount <> 24 then Exit;
if SrcDIB.BitCount <> 24 then Exit;
 
for i := 1 to Self.Height - 1 do
begin
k := i shl 1;
p1 := SrcDIB.Scanline[k];
p2 := SrcDIB.Scanline[k + 1];
p3 := Self.Scanline[i];
for j := 1 to Self.Width - 1 do
begin
m := 3 * j;
l := m shl 1;
p3[m] := (p1[l] + p1[l + 3] + p2[l] + p2[l + 3]) shr 2;
p3[m + 1] := (p1[l + 1] + p1[l + 4] + p2[l + 1] + p2[l + 4]) shr 2;
p3[m + 2] := (p1[l + 2] + p1[l + 5] + p2[l + 2] + p2[l + 5]) shr 2;
end;
end;
end;
 
procedure TDIB.FilterLine(X1, Y1, X2, Y2: Integer; Color: TColor;
FilterMode: TFilterMode);
var
i, j: Integer;
t: TColor;
r1, g1, b1, r2, g2, b2: Integer;
begin
j := ROUND(Sqrt(Sqr(ABS(X2 - X1)) + Sqr(ABS(Y2 - Y1))));
if j < 1 then Exit;
 
r1 := GetRValue(Color);
g1 := GetGValue(Color);
b1 := GetBValue(Color);
 
for i := 0 to j do
begin
t := Self.Pixels[X1 + ((X2 - X1) * i div j), Y1 + ((Y2 - Y1) * i div j)];
r2 := GetRValue(t);
g2 := GetGValue(t);
b2 := GetBValue(t);
case FilterMode of
fmNormal: t := RGB(r1 + (((256 - r1) * r2) shr 8),
g1 + (((256 - g1) * g2) shr 8),
b1 + (((256 - b1) * b2) shr 8));
fmMix25: t := RGB((r1 + r2 * 3) shr 2, (g1 + g2 * 3) shr 2, (b1 + b2 * 3) shr 2);
fmMix50: t := RGB((r1 + r2) shr 1, (g1 + g2) shr 1, (b1 + b2) shr 1);
fmMix75: t := RGB((r1 * 3 + r2) shr 2, (g1 * 3 + g2) shr 2, (b1 * 3 + b2) shr 2);
end;
Self.Pixels[X1 + ((X2 - X1) * i div j), Y1 + ((Y2 - Y1) * i div j)] := t;
end;
end;
 
procedure TDIB.FilterRect(X, Y, Width, Height: Integer;
Color: TColor; FilterMode: TFilterMode);
var
i, j, r, g, b, C1: Integer;
p1, p2, p3: pByte;
begin
if Self.BitCount <> 24 then Exit;
 
r := GetRValue(Color);
g := GetGValue(Color);
b := GetBValue(Color);
 
for i := 0 to Height - 1 do
begin
p1 := Self.Scanline[i + Y];
Inc(p1, (3 * X));
for j := 0 to Width - 1 do
begin
case FilterMode of
fmNormal:
begin
p2 := p1;
Inc(p2);
p3 := p2;
Inc(p3);
C1 := (p1^ + p2^ + p3^) div 3;
 
p1^ := (C1 * b) shr 8;
Inc(p1);
p1^ := (C1 * g) shr 8;
Inc(p1);
p1^ := (C1 * r) shr 8;
Inc(p1);
end;
fmMix25:
begin
p1^ := (3 * p1^ + b) shr 2;
Inc(p1);
p1^ := (3 * p1^ + g) shr 2;
Inc(p1);
p1^ := (3 * p1^ + r) shr 2;
Inc(p1);
end;
fmMix50:
begin
p1^ := (p1^ + b) shr 1;
Inc(p1);
p1^ := (p1^ + g) shr 1;
Inc(p1);
p1^ := (p1^ + r) shr 1;
Inc(p1);
end;
fmMix75:
begin
p1^ := (p1^ + 3 * b) shr 2;
Inc(p1);
p1^ := (p1^ + 3 * g) shr 2;
Inc(p1);
p1^ := (p1^ + 3 * r) shr 2;
Inc(p1);
end;
end;
end;
end;
end;
 
procedure TDIB.InitLight(Count, Detail: Integer);
var
i, j: Integer;
begin
LG_COUNT := Count;
LG_DETAIL := Detail;
 
for i := 0 to 255 do // Build Lightning LUT
for j := 0 to 255 do
FLUTDist[i, j] := ROUND(Sqrt(Sqr(i * 10) + Sqr(j * 10)));
end;
 
procedure TDIB.DrawLights(FLight: TLightArray;
AmbientLight: TColor);
var
i, j, l, m, n, o, q, D1, D2, R, G, B, AR, AG, AB: Integer;
P: array{$IFNDEF VER4UP} [0..4096]{$ENDIF} of PByteArray;
begin
if Self.BitCount <> 24 then Exit;
 
{$IFDEF VER4UP}
SetLength(P, LG_DETAIL);
{$ENDIF}
AR := GetRValue(AmbientLight);
AG := GetGValue(AmbientLight);
AB := GetBValue(AmbientLight);
 
for i := (Self.Height div (LG_DETAIL + 1)) downto 1 do
begin
for o := 0 to LG_DETAIL do
P[o] := Self.Scanline[(LG_DETAIL + 1) * i - o];
 
for j := (Self.Width div (LG_DETAIL + 1)) downto 1 do
begin
R := AR;
G := AG;
B := AB;
 
for l := LG_COUNT - 1 downto 0 do // Check the lightsources
begin
D1 := ABS(j * (LG_DETAIL + 1) - FLight[l].X) div FLight[l].Size1;
D2 := ABS(i * (LG_DETAIL + 1) - FLight[l].Y) div FLight[l].Size2;
if D1 > 255 then D1 := 255;
if D2 > 255 then D2 := 255;
 
m := 255 - FLUTDist[D1, D2];
if m < 0 then m := 0;
 
Inc(R, (PosValue(GetRValue(FLight[l].Color) - R) * m shr 8));
Inc(G, (PosValue(GetGValue(FLight[l].Color) - G) * m shr 8));
Inc(B, (PosValue(GetBValue(FLight[l].Color) - B) * m shr 8));
end;
 
for q := LG_DETAIL downto 0 do
begin
n := 3 * (j * (LG_DETAIL + 1) - q);
 
for o := LG_DETAIL downto 0 do
begin
P[o][n] := (P[o][n] * B) shr 8;
P[o][n + 1] := (P[o][n + 1] * G) shr 8;
P[o][n + 2] := (P[o][n + 2] * R) shr 8;
end;
end;
end;
end;
{$IFDEF VER4UP}
SetLength(P, 0);
{$ENDIF}
end;
 
procedure TDIB.DrawOn(Dest: TRect; DestCanvas: TCanvas; Xsrc, Ysrc: Integer);
{procedure is supplement of original TDIBUltra function}
begin
//if not AsSigned(SrcCanvas) then Exit;
if (Xsrc < 0) then
begin
Dec(Dest.Left, Xsrc);
Inc(Dest.Right {Width }, Xsrc);
Xsrc := 0
end;
if (Ysrc < 0) then
begin
Dec(Dest.Top, Ysrc);
Inc(Dest.Bottom {Height}, Ysrc);
Ysrc := 0
end;
BitBlt(DestCanvas.Handle, Dest.Left, Dest.Top, Dest.Right, Dest.Bottom, Self.Canvas.Handle, Xsrc, Ysrc, SRCCOPY);
end;
 
{ DXFusion <- }
 
{ added effect for DIB }
 
function IntToByte(i: Integer): Byte;
begin
if i > 255 then Result := 255
else if i < 0 then Result := 0
else Result := i;
end;
 
{standalone routine}
 
procedure TDIB.Darker(Percent: Integer);
{color to dark in percent}
var
p0: pbytearray;
r, g, b, x, y: Integer;
begin
if Self.BitCount <> 24 then Exit;
for y := 0 to Self.Height - 1 do
begin
p0 := Self.ScanLine[y];
for x := 0 to Self.Width - 1 do
begin
r := p0[x * 3];
g := p0[x * 3 + 1];
b := p0[x * 3 + 2];
p0[x * 3] := Round(R * Percent / 100);
p0[x * 3 + 1] := Round(G * Percent / 100);
p0[x * 3 + 2] := Round(B * Percent / 100);
end;
end;
end;
 
procedure TDIB.Lighter(Percent: Integer);
var
p0: pbytearray;
r, g, b, x, y: Integer;
begin
if Self.BitCount <> 24 then Exit;
for y := 0 to Self.Height - 1 do
begin
p0 := Self.ScanLine[y];
for x := 0 to Self.Width - 1 do
begin
r := p0[x * 3];
g := p0[x * 3 + 1];
b := p0[x * 3 + 2];
p0[x * 3] := Round(R * Percent / 100) + Round(255 - Percent / 100 * 255);
p0[x * 3 + 1] := Round(G * Percent / 100) + Round(255 - Percent / 100 * 255);
p0[x * 3 + 2] := Round(B * Percent / 100) + Round(255 - Percent / 100 * 255);
end;
end;
end;
 
procedure TDIB.Darkness(Amount: Integer);
var
p0: pbytearray;
r, g, b, x, y: Integer;
begin
if Self.BitCount <> 24 then Exit;
for y := 0 to Self.Height - 1 do
begin
p0 := Self.ScanLine[y];
for x := 0 to Self.Width - 1 do
begin
r := p0[x * 3];
g := p0[x * 3 + 1];
b := p0[x * 3 + 2];
p0[x * 3] := IntToByte(r - ((r) * Amount) div 255);
p0[x * 3 + 1] := IntToByte(g - ((g) * Amount) div 255);
p0[x * 3 + 2] := IntToByte(b - ((b) * Amount) div 255);
end;
end;
end;
 
function TrimInt(i, Min, Max: Integer): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
begin
if i > Max then Result := Max
else if i < Min then Result := Min
else Result := i;
end;
 
procedure TDIB.DoSmoothRotate(Src: TDIB; cx, cy: Integer; Angle: Extended);
var
Top, Bottom, Left, Right, eww, nsw, fx, fy, wx, wy: Extended;
cAngle, sAngle: Double;
xDiff, yDiff, ifx, ify, px, py, ix, iy, x, y: Integer;
nw, ne, sw, se: TBGR;
P1, P2, P3: Pbytearray;
begin
Angle := angle;
Angle := -Angle * Pi / 180;
sAngle := Sin(Angle);
cAngle := Cos(Angle);
xDiff := (Self.Width - Src.Width) div 2;
yDiff := (Self.Height - Src.Height) div 2;
for y := 0 to Self.Height - 1 do
begin
P3 := Self.scanline[y];
py := 2 * (y - cy) + 1;
for x := 0 to Self.Width - 1 do
begin
px := 2 * (x - cx) + 1;
fx := (((px * cAngle - py * sAngle) - 1) / 2 + cx) - xDiff;
fy := (((px * sAngle + py * cAngle) - 1) / 2 + cy) - yDiff;
ifx := Round(fx);
ify := Round(fy);
 
if (ifx > -1) and (ifx < Src.Width) and (ify > -1) and (ify < Src.Height) then
begin
eww := fx - ifx;
nsw := fy - ify;
iy := TrimInt(ify + 1, 0, Src.Height - 1);
ix := TrimInt(ifx + 1, 0, Src.Width - 1);
P1 := Src.scanline[ify];
P2 := Src.scanline[iy];
nw.r := P1[ifx * 3];
nw.g := P1[ifx * 3 + 1];
nw.b := P1[ifx * 3 + 2];
ne.r := P1[ix * 3];
ne.g := P1[ix * 3 + 1];
ne.b := P1[ix * 3 + 2];
sw.r := P2[ifx * 3];
sw.g := P2[ifx * 3 + 1];
sw.b := P2[ifx * 3 + 2];
se.r := P2[ix * 3];
se.g := P2[ix * 3 + 1];
se.b := P2[ix * 3 + 2];
 
Top := nw.b + eww * (ne.b - nw.b);
Bottom := sw.b + eww * (se.b - sw.b);
P3[x * 3 + 2] := IntToByte(Round(Top + nsw * (Bottom - Top)));
 
Top := nw.g + eww * (ne.g - nw.g);
Bottom := sw.g + eww * (se.g - sw.g);
P3[x * 3 + 1] := IntToByte(Round(Top + nsw * (Bottom - Top)));
 
Top := nw.r + eww * (ne.r - nw.r);
Bottom := sw.r + eww * (se.r - sw.r);
P3[x * 3] := IntToByte(Round(Top + nsw * (Bottom - Top)));
end;
end;
end;
end;
 
//----------------------
//--- 24 bit count routines ----------------------
//----------------------
 
procedure TDIB.DoInvert;
procedure PicInvert(src: TDIB);
var w, h, x, y: Integer;
p: pbytearray;
begin
w := src.width;
h := src.height;
src.BitCount := 24;
for y := 0 to h - 1 do
begin
p := src.scanline[y];
for x := 0 to w - 1 do
begin
p[x * 3] := not p[x * 3];
p[x * 3 + 1] := not p[x * 3 + 1];
p[x * 3 + 2] := not p[x * 3 + 2];
end;
end;
end;
begin
PicInvert(Self);
end;
 
procedure TDIB.DoAddColorNoise(Amount: Integer);
procedure AddColorNoise(var clip: TDIB; Amount: Integer);
var
p0: pbytearray;
x, y, r, g, b: Integer;
begin
for y := 0 to clip.Height - 1 do
begin
p0 := clip.ScanLine[y];
for x := 0 to clip.Width - 1 do
begin
r := p0[x * 3] + (Random(Amount) - (Amount shr 1));
g := p0[x * 3 + 1] + (Random(Amount) - (Amount shr 1));
b := p0[x * 3 + 2] + (Random(Amount) - (Amount shr 1));
p0[x * 3] := IntToByte(r);
p0[x * 3 + 1] := IntToByte(g);
p0[x * 3 + 2] := IntToByte(b);
end;
end;
end;
var BB: TDIB;
begin
BB := TDIB.Create;
BB.BitCount := 24;
BB.Assign(Self);
AddColorNoise(bb, Amount);
Self.Assign(BB);
BB.Free;
end;
 
procedure TDIB.DoAddMonoNoise(Amount: Integer);
procedure _AddMonoNoise(var clip: TDIB; Amount: Integer);
var
p0: pbytearray;
x, y, a, r, g, b: Integer;
begin
for y := 0 to clip.Height - 1 do
begin
p0 := clip.scanline[y];
for x := 0 to clip.Width - 1 do
begin
a := Random(Amount) - (Amount shr 1);
r := p0[x * 3] + a;
g := p0[x * 3 + 1] + a;
b := p0[x * 3 + 2] + a;
p0[x * 3] := IntToByte(r);
p0[x * 3 + 1] := IntToByte(g);
p0[x * 3 + 2] := IntToByte(b);
end;
end;
end;
var BB: TDIB;
begin
BB := TDIB.Create;
BB.BitCount := 24;
BB.Assign(Self);
_AddMonoNoise(bb, Amount);
Self.Assign(BB);
BB.Free;
end;
 
procedure TDIB.DoAntiAlias;
procedure AntiAlias(clip: TDIB);
procedure AntiAliasRect(clip: TDIB; XOrigin, YOrigin, XFinal, YFinal: Integer);
var Memo, x, y: Integer; (* Composantes primaires des points environnants *)
p0, p1, p2: pbytearray;
begin
if XFinal < XOrigin then begin Memo := XOrigin; XOrigin := XFinal; XFinal := Memo; end; (* Inversion des valeurs *)
if YFinal < YOrigin then begin Memo := YOrigin; YOrigin := YFinal; YFinal := Memo; end; (* si diff‚rence n‚gative*)
XOrigin := max(1, XOrigin);
YOrigin := max(1, YOrigin);
XFinal := min(clip.width - 2, XFinal);
YFinal := min(clip.height - 2, YFinal);
clip.BitCount := 24;
for y := YOrigin to YFinal do
begin
p0 := clip.ScanLine[y - 1];
p1 := clip.scanline[y];
p2 := clip.ScanLine[y + 1];
for x := XOrigin to XFinal do
begin
p1[x * 3] := (p0[x * 3] + p2[x * 3] + p1[(x - 1) * 3] + p1[(x + 1) * 3]) div 4;
p1[x * 3 + 1] := (p0[x * 3 + 1] + p2[x * 3 + 1] + p1[(x - 1) * 3 + 1] + p1[(x + 1) * 3 + 1]) div 4;
p1[x * 3 + 2] := (p0[x * 3 + 2] + p2[x * 3 + 2] + p1[(x - 1) * 3 + 2] + p1[(x + 1) * 3 + 2]) div 4;
end;
end;
end;
begin
AntiAliasRect(clip, 0, 0, clip.width, clip.height);
end;
begin
AntiAlias(Self);
end;
 
procedure TDIB.DoContrast(Amount: Integer);
procedure _Contrast(var clip: TDIB; Amount: Integer);
var
p0: pbytearray;
rg, gg, bg, r, g, b, x, y: Integer;
begin
for y := 0 to clip.Height - 1 do
begin
p0 := clip.scanline[y];
for x := 0 to clip.Width - 1 do
begin
r := p0[x * 3];
g := p0[x * 3 + 1];
b := p0[x * 3 + 2];
rg := (Abs(127 - r) * Amount) div 255;
gg := (Abs(127 - g) * Amount) div 255;
bg := (Abs(127 - b) * Amount) div 255;
if r > 127 then r := r + rg else r := r - rg;
if g > 127 then g := g + gg else g := g - gg;
if b > 127 then b := b + bg else b := b - bg;
p0[x * 3] := IntToByte(r);
p0[x * 3 + 1] := IntToByte(g);
p0[x * 3 + 2] := IntToByte(b);
end;
end;
end;
var BB: TDIB;
begin
BB := TDIB.Create;
BB.BitCount := 24;
BB.Assign(Self);
_Contrast(bb, Amount);
Self.Assign(BB);
BB.Free;
end;
 
procedure TDIB.DoFishEye(Amount: Integer);
procedure _FishEye(var Bmp, Dst: TDIB; Amount: Extended);
var
xmid, ymid: Single;
fx, fy: Single;
r1, r2: Single;
ifx, ify: Integer;
dx, dy: Single;
rmax: Single;
ty, tx: Integer;
weight_x, weight_y: array[0..1] of Single;
weight: Single;
new_red, new_green: Integer;
new_blue: Integer;
total_red, total_green: Single;
total_blue: Single;
ix, iy: Integer;
sli, slo: PByteArray;
begin
xmid := Bmp.Width / 2;
ymid := Bmp.Height / 2;
rmax := Dst.Width * Amount;
 
for ty := 0 to Dst.Height - 1 do
begin
for tx := 0 to Dst.Width - 1 do
begin
dx := tx - xmid;
dy := ty - ymid;
r1 := Sqrt(dx * dx + dy * dy);
if r1 = 0 then
begin
fx := xmid;
fy := ymid;
end
else
begin
r2 := rmax / 2 * (1 / (1 - r1 / rmax) - 1);
fx := dx * r2 / r1 + xmid;
fy := dy * r2 / r1 + ymid;
end;
ify := Trunc(fy);
ifx := Trunc(fx);
// Calculate the weights.
if fy >= 0 then
begin
weight_y[1] := fy - ify;
weight_y[0] := 1 - weight_y[1];
end
else
begin
weight_y[0] := -(fy - ify);
weight_y[1] := 1 - weight_y[0];
end;
if fx >= 0 then
begin
weight_x[1] := fx - ifx;
weight_x[0] := 1 - weight_x[1];
end
else
begin
weight_x[0] := -(fx - ifx);
Weight_x[1] := 1 - weight_x[0];
end;
 
if ifx < 0 then
ifx := Bmp.Width - 1 - (-ifx mod Bmp.Width)
else if ifx > Bmp.Width - 1 then
ifx := ifx mod Bmp.Width;
if ify < 0 then
ify := Bmp.Height - 1 - (-ify mod Bmp.Height)
else if ify > Bmp.Height - 1 then
ify := ify mod Bmp.Height;
 
total_red := 0.0;
total_green := 0.0;
total_blue := 0.0;
for ix := 0 to 1 do
begin
for iy := 0 to 1 do
begin
if ify + iy < Bmp.Height then
sli := Bmp.scanline[ify + iy]
else
sli := Bmp.scanline[Bmp.Height - ify - iy];
if ifx + ix < Bmp.Width then
begin
new_red := sli[(ifx + ix) * 3];
new_green := sli[(ifx + ix) * 3 + 1];
new_blue := sli[(ifx + ix) * 3 + 2];
end
else
begin
new_red := sli[(Bmp.Width - ifx - ix) * 3];
new_green := sli[(Bmp.Width - ifx - ix) * 3 + 1];
new_blue := sli[(Bmp.Width - ifx - ix) * 3 + 2];
end;
weight := weight_x[ix] * weight_y[iy];
total_red := total_red + new_red * weight;
total_green := total_green + new_green * weight;
total_blue := total_blue + new_blue * weight;
end;
end;
slo := Dst.scanline[ty];
slo[tx * 3] := Round(total_red);
slo[tx * 3 + 1] := Round(total_green);
slo[tx * 3 + 2] := Round(total_blue);
 
end;
end;
end;
var BB1, BB2: TDIB;
begin
BB1 := TDIB.Create;
BB1.BitCount := 24;
BB1.Assign(Self);
BB2 := TDIB.Create;
BB2.BitCount := 24;
BB2.Assign(BB1);
_FishEye(BB1, BB2, Amount);
Self.Assign(BB2);
BB1.Free;
BB2.Free;
end;
 
procedure TDIB.DoGrayScale;
procedure GrayScale(var clip: TDIB);
var
p0: pbytearray;
Gray, x, y: Integer;
begin
for y := 0 to clip.Height - 1 do
begin
p0 := clip.scanline[y];
for x := 0 to clip.Width - 1 do
begin
Gray := Round(p0[x * 3] * 0.3 + p0[x * 3 + 1] * 0.59 + p0[x * 3 + 2] * 0.11);
p0[x * 3] := Gray;
p0[x * 3 + 1] := Gray;
p0[x * 3 + 2] := Gray;
end;
end;
end;
var BB: TDIB;
begin
BB := TDIB.Create;
BB.BitCount := 24;
BB.Assign(Self);
GrayScale(BB);
Self.Assign(BB);
BB.Free;
end;
 
procedure TDIB.DoLightness(Amount: Integer);
procedure _Lightness(var clip: TDIB; Amount: Integer);
var
p0: pbytearray;
r, g, b, x, y: Integer;
begin
for y := 0 to clip.Height - 1 do
begin
p0 := clip.scanline[y];
for x := 0 to clip.Width - 1 do
begin
r := p0[x * 3];
g := p0[x * 3 + 1];
b := p0[x * 3 + 2];
p0[x * 3] := IntToByte(r + ((255 - r) * Amount) div 255);
p0[x * 3 + 1] := IntToByte(g + ((255 - g) * Amount) div 255);
p0[x * 3 + 2] := IntToByte(b + ((255 - b) * Amount) div 255);
end;
end;
end;
var BB: TDIB;
begin
BB := TDIB.Create;
BB.BitCount := 24;
BB.Assign(Self);
_Lightness(BB, Amount);
Self.Assign(BB);
BB.Free;
end;
 
procedure TDIB.DoDarkness(Amount: Integer);
var BB: TDIB;
begin
BB := TDIB.Create;
BB.BitCount := 24;
BB.Assign(Self);
BB.Darkness(Amount);
Self.Assign(BB);
BB.Free;
end;
 
procedure TDIB.DoSaturation(Amount: Integer);
procedure _Saturation(var clip: TDIB; Amount: Integer);
var
p0: pbytearray;
Gray, r, g, b, x, y: Integer;
begin
for y := 0 to clip.Height - 1 do
begin
p0 := clip.scanline[y];
for x := 0 to clip.Width - 1 do
begin
r := p0[x * 3];
g := p0[x * 3 + 1];
b := p0[x * 3 + 2];
Gray := (r + g + b) div 3;
p0[x * 3] := IntToByte(Gray + (((r - Gray) * Amount) div 255));
p0[x * 3 + 1] := IntToByte(Gray + (((g - Gray) * Amount) div 255));
p0[x * 3 + 2] := IntToByte(Gray + (((b - Gray) * Amount) div 255));
end;
end;
end;
var BB: TDIB;
begin
BB := TDIB.Create;
BB.BitCount := 24;
BB.Assign(Self);
_Saturation(BB, Amount);
Self.Assign(BB);
BB.Free;
end;
 
procedure TDIB.DoSplitBlur(Amount: Integer);
{NOTE: For a gaussian blur is amount 3}
procedure _SplitBlur(var clip: TDIB; Amount: Integer);
var
p0, p1, p2: pbytearray;
cx, x, y: Integer;
Buf: array[0..3, 0..2] of byte;
begin
if Amount = 0 then Exit;
for y := 0 to clip.Height - 1 do
begin
p0 := clip.scanline[y];
if y - Amount < 0 then p1 := clip.scanline[y]
else {y-Amount>0} p1 := clip.ScanLine[y - Amount];
if y + Amount < clip.Height then p2 := clip.ScanLine[y + Amount]
else {y+Amount>=Height} p2 := clip.ScanLine[clip.Height - y];
 
for x := 0 to clip.Width - 1 do
begin
if x - Amount < 0 then cx := x
else {x-Amount>0} cx := x - Amount;
Buf[0, 0] := p1[cx * 3];
Buf[0, 1] := p1[cx * 3 + 1];
Buf[0, 2] := p1[cx * 3 + 2];
Buf[1, 0] := p2[cx * 3];
Buf[1, 1] := p2[cx * 3 + 1];
Buf[1, 2] := p2[cx * 3 + 2];
if x + Amount < clip.Width then cx := x + Amount
else {x+Amount>=Width} cx := clip.Width - x;
Buf[2, 0] := p1[cx * 3];
Buf[2, 1] := p1[cx * 3 + 1];
Buf[2, 2] := p1[cx * 3 + 2];
Buf[3, 0] := p2[cx * 3];
Buf[3, 1] := p2[cx * 3 + 1];
Buf[3, 2] := p2[cx * 3 + 2];
p0[x * 3] := (Buf[0, 0] + Buf[1, 0] + Buf[2, 0] + Buf[3, 0]) shr 2;
p0[x * 3 + 1] := (Buf[0, 1] + Buf[1, 1] + Buf[2, 1] + Buf[3, 1]) shr 2;
p0[x * 3 + 2] := (Buf[0, 2] + Buf[1, 2] + Buf[2, 2] + Buf[3, 2]) shr 2;
end;
end;
end;
var BB: TDIB;
begin
BB := TDIB.Create;
BB.BitCount := 24;
BB.Assign(Self);
_SplitBlur(BB, Amount);
Self.Assign(BB);
BB.Free;
end;
 
procedure TDIB.DoGaussianBlur(Amount: Integer);
var BB: TDIB;
begin
BB := TDIB.Create;
BB.BitCount := 24;
BB.BitCount := 24;
BB.Assign(Self);
GaussianBlur(BB, Amount);
Self.Assign(BB);
BB.Free;
end;
 
procedure TDIB.DoMosaic(Size: Integer);
procedure Mosaic(var Bm: TDIB; size: Integer);
var
x, y, i, j: Integer;
p1, p2: pbytearray;
r, g, b: byte;
begin
y := 0;
repeat
p1 := bm.scanline[y];
repeat
j := 1;
repeat
p2 := bm.scanline[y];
x := 0;
repeat
r := p1[x * 3];
g := p1[x * 3 + 1];
b := p1[x * 3 + 2];
i := 1;
repeat
p2[x * 3] := r;
p2[x * 3 + 1] := g;
p2[x * 3 + 2] := b;
inc(x);
inc(i);
until (x >= bm.width) or (i > size);
until x >= bm.width;
inc(j);
inc(y);
until (y >= bm.height) or (j > size);
until (y >= bm.height) or (x >= bm.width);
until y >= bm.height;
end;
var BB: TDIB;
begin
BB := TDIB.Create;
BB.BitCount := 24;
BB.Assign(Self);
Mosaic(BB, Size);
Self.Assign(BB);
BB.Free;
end;
 
procedure TDIB.DoTwist(Amount: Integer);
procedure _Twist(var Bmp, Dst: TDIB; Amount: Integer);
var
fxmid, fymid: Single;
txmid, tymid: Single;
fx, fy: Single;
tx2, ty2: Single;
r: Single;
theta: Single;
ifx, ify: Integer;
dx, dy: Single;
OFFSET: Single;
ty, tx: Integer;
weight_x, weight_y: array[0..1] of Single;
weight: Single;
new_red, new_green: Integer;
new_blue: Integer;
total_red, total_green: Single;
total_blue: Single;
ix, iy: Integer;
sli, slo: PBytearray;
 
function ArcTan2(xt, yt: Single): Single; {$IFDEF VER9UP}inline;{$ENDIF}
begin
if xt = 0 then
if yt > 0 then
Result := Pi / 2
else
Result := -(Pi / 2)
else
begin
Result := ArcTan(yt / xt);
if xt < 0 then
Result := Pi + ArcTan(yt / xt);
end;
end;
 
begin
OFFSET := -(Pi / 2);
dx := Bmp.Width - 1;
dy := Bmp.Height - 1;
r := Sqrt(dx * dx + dy * dy);
tx2 := r;
ty2 := r;
txmid := (Bmp.Width - 1) / 2; //Adjust these to move center of rotation
tymid := (Bmp.Height - 1) / 2; //Adjust these to move ......
fxmid := (Bmp.Width - 1) / 2;
fymid := (Bmp.Height - 1) / 2;
if tx2 >= Bmp.Width then tx2 := Bmp.Width - 1;
if ty2 >= Bmp.Height then ty2 := Bmp.Height - 1;
 
for ty := 0 to Round(ty2) do
begin
for tx := 0 to Round(tx2) do
begin
dx := tx - txmid;
dy := ty - tymid;
r := Sqrt(dx * dx + dy * dy);
if r = 0 then
begin
fx := 0;
fy := 0;
end
else
begin
theta := ArcTan2(dx, dy) - r / Amount - OFFSET;
fx := r * Cos(theta);
fy := r * Sin(theta);
end;
fx := fx + fxmid;
fy := fy + fymid;
 
ify := Trunc(fy);
ifx := Trunc(fx);
// Calculate the weights.
if fy >= 0 then
begin
weight_y[1] := fy - ify;
weight_y[0] := 1 - weight_y[1];
end
else
begin
weight_y[0] := -(fy - ify);
weight_y[1] := 1 - weight_y[0];
end;
if fx >= 0 then
begin
weight_x[1] := fx - ifx;
weight_x[0] := 1 - weight_x[1];
end
else
begin
weight_x[0] := -(fx - ifx);
Weight_x[1] := 1 - weight_x[0];
end;
 
if ifx < 0 then
ifx := Bmp.Width - 1 - (-ifx mod Bmp.Width)
else if ifx > Bmp.Width - 1 then
ifx := ifx mod Bmp.Width;
if ify < 0 then
ify := Bmp.Height - 1 - (-ify mod Bmp.Height)
else if ify > Bmp.Height - 1 then
ify := ify mod Bmp.Height;
 
total_red := 0.0;
total_green := 0.0;
total_blue := 0.0;
for ix := 0 to 1 do
begin
for iy := 0 to 1 do
begin
if ify + iy < Bmp.Height then
sli := Bmp.scanline[ify + iy]
else
sli := Bmp.scanline[Bmp.Height - ify - iy];
if ifx + ix < Bmp.Width then
begin
new_red := sli[(ifx + ix) * 3];
new_green := sli[(ifx + ix) * 3 + 1];
new_blue := sli[(ifx + ix) * 3 + 2];
end
else
begin
new_red := sli[(Bmp.Width - ifx - ix) * 3];
new_green := sli[(Bmp.Width - ifx - ix) * 3 + 1];
new_blue := sli[(Bmp.Width - ifx - ix) * 3 + 2];
end;
weight := weight_x[ix] * weight_y[iy];
total_red := total_red + new_red * weight;
total_green := total_green + new_green * weight;
total_blue := total_blue + new_blue * weight;
end;
end;
slo := Dst.scanline[ty];
slo[tx * 3] := Round(total_red);
slo[tx * 3 + 1] := Round(total_green);
slo[tx * 3 + 2] := Round(total_blue);
end;
end;
end;
var BB1, BB2: TDIB;
begin
BB1 := TDIB.Create;
BB1.BitCount := 24;
BB1.Assign(Self);
BB2 := TDIB.Create;
BB2.BitCount := 24;
BB2.Assign(BB1);
_Twist(BB1, BB2, Amount);
Self.Assign(BB2);
BB1.Free;
BB2.Free;
end;
 
procedure TDIB.DoTrace(Amount: Integer);
procedure Trace(src: TDIB; intensity: Integer);
var
x, y, i: Integer;
P1, P2, P3, P4: PByteArray;
tb, TraceB: byte;
hasb: Boolean;
bitmap: TDIB;
begin
bitmap := TDIB.create;
bitmap.width := src.width;
bitmap.height := src.height;
bitmap.canvas.draw(0, 0, src);
bitmap.BitCount := 8;
src.BitCount := 24;
hasb := false;
TraceB := $00; tb := 0;
for i := 1 to Intensity do
begin
for y := 0 to BitMap.height - 2 do
begin
P1 := BitMap.ScanLine[y];
P2 := BitMap.scanline[y + 1];
P3 := src.scanline[y];
P4 := src.scanline[y + 1];
x := 0;
repeat
if p1[x] <> p1[x + 1] then
begin
if not hasb then
begin
tb := p1[x + 1];
hasb := true;
p3[x * 3] := TraceB;
p3[x * 3 + 1] := TraceB;
p3[x * 3 + 2] := TraceB;
end
else
begin
if p1[x] <> tb then
begin
p3[x * 3] := TraceB;
p3[x * 3 + 1] := TraceB;
p3[x * 3 + 2] := TraceB;
end
else
begin
p3[(x + 1) * 3] := TraceB;
p3[(x + 1) * 3 + 1] := TraceB;
p3[(x + 1) * 3 + 1] := TraceB;
end;
end;
end;
if p1[x] <> p2[x] then
begin
if not hasb then
begin
tb := p2[x];
hasb := true;
p3[x * 3] := TraceB;
p3[x * 3 + 1] := TraceB;
p3[x * 3 + 2] := TraceB;
end
else
begin
if p1[x] <> tb then
begin
p3[x * 3] := TraceB;
p3[x * 3 + 1] := TraceB;
p3[x * 3 + 2] := TraceB;
end
else
begin
p4[x * 3] := TraceB;
p4[x * 3 + 1] := TraceB;
p4[x * 3 + 2] := TraceB;
end;
end;
end;
inc(x);
until x >= (BitMap.width - 2);
end;
if i > 1 then
for y := BitMap.height - 1 downto 1 do
begin
P1 := BitMap.ScanLine[y];
P2 := BitMap.scanline[y - 1];
P3 := src.scanline[y];
P4 := src.scanline[y - 1];
x := Bitmap.width - 1;
repeat
if p1[x] <> p1[x - 1] then
begin
if not hasb then
begin
tb := p1[x - 1];
hasb := true;
p3[x * 3] := TraceB;
p3[x * 3 + 1] := TraceB;
p3[x * 3 + 2] := TraceB;
end
else
begin
if p1[x] <> tb then
begin
p3[x * 3] := TraceB;
p3[x * 3 + 1] := TraceB;
p3[x * 3 + 2] := TraceB;
end
else
begin
p3[(x - 1) * 3] := TraceB;
p3[(x - 1) * 3 + 1] := TraceB;
p3[(x - 1) * 3 + 2] := TraceB;
end;
end;
end;
if p1[x] <> p2[x] then
begin
if not hasb then
begin
tb := p2[x];
hasb := true;
p3[x * 3] := TraceB;
p3[x * 3 + 1] := TraceB;
p3[x * 3 + 2] := TraceB;
end
else
begin
if p1[x] <> tb then
begin
p3[x * 3] := TraceB;
p3[x * 3 + 1] := TraceB;
p3[x * 3 + 2] := TraceB;
end
else
begin
p4[x * 3] := TraceB;
p4[x * 3 + 1] := TraceB;
p4[x * 3 + 2] := TraceB;
end;
end;
end;
dec(x);
until x <= 1;
end;
end;
bitmap.free;
end;
var BB1, BB2: TDIB;
begin
BB1 := TDIB.Create;
BB1.BitCount := 24;
BB1.Assign(Self);
BB2 := TDIB.Create;
BB2.BitCount := 24;
BB2.Assign(BB1);
Trace(BB2, Amount);
Self.Assign(BB2);
BB1.Free;
BB2.Free;
end;
 
procedure TDIB.DoSplitlight(Amount: Integer);
procedure Splitlight(var clip: TDIB; amount: Integer);
var
x, y, i: Integer;
p1: pbytearray;
 
function sinpixs(a: Integer): Integer;
begin
result := variant(sin(a / 255 * pi / 2) * 255);
end;
begin
for i := 1 to amount do
for y := 0 to clip.height - 1 do
begin
p1 := clip.scanline[y];
for x := 0 to clip.width - 1 do
begin
p1[x * 3] := sinpixs(p1[x * 3]);
p1[x * 3 + 1] := sinpixs(p1[x * 3 + 1]);
p1[x * 3 + 2] := sinpixs(p1[x * 3 + 2]);
end;
end;
end;
var BB1 {,BB2}: TDIB;
begin
BB1 := TDIB.Create;
BB1.BitCount := 24;
BB1.Assign(Self);
// BB2 := TDIB.Create;
// BB2.BitCount := 24;
// BB2.Assign (BB1);
Splitlight(BB1, Amount);
Self.Assign(BB1);
BB1.Free;
// BB2.Free;
end;
 
procedure TDIB.DoTile(Amount: Integer);
procedure SmoothResize(var Src, Dst: TDIB);
var
x, y, xP, yP,
yP2, xP2: Integer;
Read, Read2: PByteArray;
t, z, z2, iz2: Integer;
pc: PBytearray;
w1, w2, w3, w4: Integer;
Col1r, col1g, col1b, Col2r, col2g, col2b: byte;
begin
xP2 := ((src.Width - 1) shl 15) div Dst.Width;
yP2 := ((src.Height - 1) shl 15) div Dst.Height;
yP := 0;
for y := 0 to Dst.Height - 1 do
begin
xP := 0;
Read := src.ScanLine[yP shr 15];
if yP shr 16 < src.Height - 1 then
Read2 := src.ScanLine[yP shr 15 + 1]
else
Read2 := src.ScanLine[yP shr 15];
pc := Dst.scanline[y];
z2 := yP and $7FFF;
iz2 := $8000 - z2;
for x := 0 to Dst.Width - 1 do
begin
t := xP shr 15;
Col1r := Read[t * 3];
Col1g := Read[t * 3 + 1];
Col1b := Read[t * 3 + 2];
Col2r := Read2[t * 3];
Col2g := Read2[t * 3 + 1];
Col2b := Read2[t * 3 + 2];
z := xP and $7FFF;
w2 := (z * iz2) shr 15;
w1 := iz2 - w2;
w4 := (z * z2) shr 15;
w3 := z2 - w4;
pc[x * 3 + 2] :=
(Col1b * w1 + Read[(t + 1) * 3 + 2] * w2 +
Col2b * w3 + Read2[(t + 1) * 3 + 2] * w4) shr 15;
pc[x * 3 + 1] :=
(Col1g * w1 + Read[(t + 1) * 3 + 1] * w2 +
Col2g * w3 + Read2[(t + 1) * 3 + 1] * w4) shr 15;
pc[x * 3] :=
(Col1r * w1 + Read2[(t + 1) * 3] * w2 +
Col2r * w3 + Read2[(t + 1) * 3] * w4) shr 15;
Inc(xP, xP2);
end;
Inc(yP, yP2);
end;
end;
procedure Tile(src, dst: TDIB; amount: Integer);
var
w, h, w2, h2, i, j: Integer;
bm: TDIB;
begin
w := src.width;
h := src.height;
dst.width := w;
dst.height := h;
dst.Canvas.draw(0, 0, src);
if (amount <= 0) or ((w div amount) < 5) or ((h div amount) < 5) then exit;
h2 := h div amount;
w2 := w div amount;
bm := TDIB.create;
bm.width := w2;
bm.height := h2;
bm.BitCount := 24;
smoothresize(src, bm);
for j := 0 to amount - 1 do
for i := 0 to amount - 1 do
dst.canvas.Draw(i * w2, j * h2, bm);
bm.free;
end;
var BB1, BB2: TDIB;
begin
BB1 := TDIB.Create;
BB1.BitCount := 24;
BB1.Assign(Self);
BB2 := TDIB.Create;
BB2.BitCount := 24;
BB2.Assign(BB1);
Tile(BB1, BB2, Amount);
Self.Assign(BB2);
BB1.Free;
BB2.Free;
end;
 
procedure TDIB.DoSpotLight(Amount: Integer; Spot: TRect);
procedure SpotLight(var src: TDIB; Amount: Integer; Spot: TRect);
var
bm, z: TDIB;
w, h: Integer;
begin
z := TDIB.Create;
try
z.SetSize(src.Width, src.Height, 24);
z.DrawTo(src, 0, 0, src.Width, src.Height, 0, 0);
w := z.Width;
h := z.Height;
bm := TDIB.create;
try
bm.Width := w;
bm.Height := h;
bm.Canvas.Brush.color := clblack;
bm.Canvas.FillRect(rect(0, 0, w, h));
bm.Canvas.Brush.Color := clwhite;
bm.Canvas.Ellipse(Spot.left, spot.top, spot.right, spot.bottom);
bm.Transparent := true;
z.Canvas.CopyMode := cmSrcAnd; {as transparentcolor for white}
z.Canvas.Draw(0, 0, src);
z.Canvas.Draw(0, 0, bm);
src.Darkness(Amount);
src.Canvas.CopyMode := cmSrcPaint;
src.DrawTransparent(z, 0, 0, z.Width, z.Height, 0, 0, clBlack);
finally
bm.Free;
end;
finally
z.Free
end;
end;
var BB1, BB2: TDIB;
begin
BB1 := TDIB.Create;
BB1.BitCount := 24;
BB1.Assign(Self);
BB2 := TDIB.Create;
BB2.BitCount := 24;
BB2.Assign(BB1);
SpotLight(BB2, Amount, Spot);
Self.Assign(BB2);
BB1.Free;
BB2.Free;
end;
 
procedure TDIB.DoEmboss;
procedure Emboss(var Bmp: TDIB);
var
x, y: Integer;
p1, p2: Pbytearray;
begin
for y := 0 to Bmp.Height - 2 do
begin
p1 := bmp.scanline[y];
p2 := bmp.scanline[y + 1];
for x := 0 to Bmp.Width - 4 do
begin
p1[x * 3] := (p1[x * 3] + (p2[(x + 3) * 3] xor $FF)) shr 1;
p1[x * 3 + 1] := (p1[x * 3 + 1] + (p2[(x + 3) * 3 + 1] xor $FF)) shr 1;
p1[x * 3 + 2] := (p1[x * 3 + 2] + (p2[(x + 3) * 3 + 2] xor $FF)) shr 1;
end;
end;
end;
var BB1, BB2: TDIB;
begin
BB1 := TDIB.Create;
BB1.BitCount := 24;
BB1.Assign(Self);
BB2 := TDIB.Create;
BB2.BitCount := 24;
BB2.Assign(BB1);
Emboss(BB2);
Self.Assign(BB2);
BB1.Free;
BB2.Free;
end;
 
procedure TDIB.DoSolorize(Amount: Integer);
procedure Solorize(src, dst: TDIB; amount: Integer);
var
w, h, x, y: Integer;
ps, pd: pbytearray;
c: Integer;
begin
w := src.width;
h := src.height;
src.BitCount := 24;
dst.BitCount := 24;
for y := 0 to h - 1 do
begin
ps := src.scanline[y];
pd := dst.scanline[y];
for x := 0 to w - 1 do
begin
c := (ps[x * 3] + ps[x * 3 + 1] + ps[x * 3 + 2]) div 3;
if c > amount then
begin
pd[x * 3] := 255 - ps[x * 3];
pd[x * 3 + 1] := 255 - ps[x * 3 + 1];
pd[x * 3 + 2] := 255 - ps[x * 3 + 2];
end
else
begin
pd[x * 3] := ps[x * 3];
pd[x * 3 + 1] := ps[x * 3 + 1];
pd[x * 3 + 2] := ps[x * 3 + 2];
end;
end;
end;
end;
var BB1, BB2: TDIB;
begin
BB1 := TDIB.Create;
BB1.BitCount := 24;
BB1.Assign(Self);
BB2 := TDIB.Create;
BB2.BitCount := 24;
BB2.Assign(BB1);
Solorize(BB1, BB2, Amount);
Self.Assign(BB2);
BB1.Free;
BB2.Free;
end;
 
procedure TDIB.DoPosterize(Amount: Integer);
procedure Posterize(src, dst: TDIB; amount: Integer);
var
w, h, x, y: Integer;
ps, pd: pbytearray;
begin
w := src.width;
h := src.height;
src.BitCount := 24;
dst.BitCount := 24;
for y := 0 to h - 1 do
begin
ps := src.scanline[y];
pd := dst.scanline[y];
for x := 0 to w - 1 do
begin
pd[x * 3] := round(ps[x * 3] / amount) * amount;
pd[x * 3 + 1] := round(ps[x * 3 + 1] / amount) * amount;
pd[x * 3 + 2] := round(ps[x * 3 + 2] / amount) * amount;
end;
end;
end;
var BB1, BB2: TDIB;
begin
BB1 := TDIB.Create;
BB1.BitCount := 24;
BB1.Assign(Self);
BB2 := TDIB.Create;
BB2.BitCount := 24;
BB2.Assign(BB1);
Posterize(BB1, BB2, Amount);
Self.Assign(BB2);
BB1.Free;
BB2.Free;
end;
 
procedure TDIB.DoBrightness(Amount: Integer);
procedure Brightness(src, dst: TDIB; level: Integer);
const
MaxPixelCount = 32768;
type
pRGBArray = ^TRGBArray;
TRGBArray = array[0..MaxPixelCount - 1] of TRGBTriple;
var
i, j, value: Integer;
OrigRow, DestRow: pRGBArray;
begin
// get brightness increment value
value := level;
src.BitCount := 24;
dst.BitCount := 24;
// for each row of pixels
for i := 0 to src.Height - 1 do
begin
OrigRow := src.ScanLine[i];
DestRow := dst.ScanLine[i];
// for each pixel in row
for j := 0 to src.Width - 1 do
begin
// add brightness value to pixel's RGB values
if value > 0 then
begin
// RGB values must be less than 256
DestRow[j].rgbtRed := Min(255, OrigRow[j].rgbtRed + value);
DestRow[j].rgbtGreen := Min(255, OrigRow[j].rgbtGreen + value);
DestRow[j].rgbtBlue := Min(255, OrigRow[j].rgbtBlue + value);
end
else
begin
// RGB values must be greater or equal than 0
DestRow[j].rgbtRed := Max(0, OrigRow[j].rgbtRed + value);
DestRow[j].rgbtGreen := Max(0, OrigRow[j].rgbtGreen + value);
DestRow[j].rgbtBlue := Max(0, OrigRow[j].rgbtBlue + value);
end;
end;
end;
end;
var BB1, BB2: TDIB;
begin
BB1 := TDIB.Create;
BB1.BitCount := 24;
BB1.Assign(Self);
BB2 := TDIB.Create;
BB2.BitCount := 24;
BB2.Assign(BB1);
Brightness(BB1, BB2, Amount);
Self.Assign(BB2);
BB1.Free;
BB2.Free;
end;
 
procedure TDIB.DoResample(AmountX, AmountY: Integer; TypeResample: TFilterTypeResample);
procedure Resample(Src, Dst: TDIB; filtertype: TFilterTypeResample; fwidth: single);
// -----------------------------------------------------------------------------
//
// Filter functions
//
// -----------------------------------------------------------------------------
 
// Hermite filter
function HermiteFilter(Value: Single): Single;
begin
// f(t) = 2|t|^3 - 3|t|^2 + 1, -1 <= t <= 1
if (Value < 0.0) then
Value := -Value;
if (Value < 1.0) then
Result := (2.0 * Value - 3.0) * Sqr(Value) + 1.0
else
Result := 0.0;
end;
 
// Box filter
// a.k.a. "Nearest Neighbour" filter
// anme: I have not been able to get acceptable
// results with this filter for subsampling.
function BoxFilter(Value: Single): Single;
begin
if (Value > -0.5) and (Value <= 0.5) then
Result := 1.0
else
Result := 0.0;
end;
 
// Triangle filter
// a.k.a. "Linear" or "Bilinear" filter
function TriangleFilter(Value: Single): Single;
begin
if (Value < 0.0) then
Value := -Value;
if (Value < 1.0) then
Result := 1.0 - Value
else
Result := 0.0;
end;
 
// Bell filter
function BellFilter(Value: Single): Single;
begin
if (Value < 0.0) then
Value := -Value;
if (Value < 0.5) then
Result := 0.75 - Sqr(Value)
else
if (Value < 1.5) then
begin
Value := Value - 1.5;
Result := 0.5 * Sqr(Value);
end
else
Result := 0.0;
end;
 
// B-spline filter
function SplineFilter(Value: Single): Single;
var
tt: single;
begin
if (Value < 0.0) then
Value := -Value;
if (Value < 1.0) then
begin
tt := Sqr(Value);
Result := 0.5 * tt * Value - tt + 2.0 / 3.0;
end
else
if (Value < 2.0) then
begin
Value := 2.0 - Value;
Result := 1.0 / 6.0 * Sqr(Value) * Value;
end
else
Result := 0.0;
end;
 
// Lanczos3 filter
function Lanczos3Filter(Value: Single): Single;
function SinC(Value: Single): Single;
begin
if (Value <> 0.0) then
begin
Value := Value * Pi;
Result := sin(Value) / Value
end
else
Result := 1.0;
end;
begin
if (Value < 0.0) then
Value := -Value;
if (Value < 3.0) then
Result := SinC(Value) * SinC(Value / 3.0)
else
Result := 0.0;
end;
 
function MitchellFilter(Value: Single): Single;
const
B = (1.0 / 3.0);
C = (1.0 / 3.0);
var
tt: single;
begin
if (Value < 0.0) then
Value := -Value;
tt := Sqr(Value);
if (Value < 1.0) then
begin
Value := (((12.0 - 9.0 * B - 6.0 * C) * (Value * tt))
+ ((-18.0 + 12.0 * B + 6.0 * C) * tt)
+ (6.0 - 2 * B));
Result := Value / 6.0;
end
else
if (Value < 2.0) then
begin
Value := (((-1.0 * B - 6.0 * C) * (Value * tt))
+ ((6.0 * B + 30.0 * C) * tt)
+ ((-12.0 * B - 48.0 * C) * Value)
+ (8.0 * B + 24 * C));
Result := Value / 6.0;
end
else
Result := 0.0;
end;
 
// -----------------------------------------------------------------------------
//
// Interpolator
//
// -----------------------------------------------------------------------------
type
// Contributor for a pixel
TContributor = record
pixel: Integer; // Source pixel
weight: single; // Pixel weight
end;
 
TContributorList = array[0..0] of TContributor;
PContributorList = ^TContributorList;
 
// List of source pixels contributing to a destination pixel
TCList = record
n: Integer;
p: PContributorList;
end;
 
TCListList = array[0..0] of TCList;
PCListList = ^TCListList;
 
TRGB = packed record
r, g, b: single;
end;
 
// Physical bitmap pixel
TColorRGB = packed record
r, g, b: BYTE;
end;
PColorRGB = ^TColorRGB;
 
// Physical bitmap scanline (row)
TRGBList = packed array[0..0] of TColorRGB;
PRGBList = ^TRGBList;
 
var
xscale, yscale: single; // Zoom scale factors
i, j, k: Integer; // Loop variables
center: single; // Filter calculation variables
width, fscale, weight: single; // Filter calculation variables
left, right: Integer; // Filter calculation variables
n: Integer; // Pixel number
Work: TDIB;
contrib: PCListList;
rgb: TRGB;
color: TColorRGB;
{$IFDEF USE_SCANLINE}
SourceLine,
DestLine: PRGBList;
SourcePixel,
DestPixel: PColorRGB;
Delta,
DestDelta: Integer;
{$ENDIF}
SrcWidth,
SrcHeight,
DstWidth,
DstHeight: Integer;
 
function Color2RGB(Color: TColor): TColorRGB;
begin
Result.r := Color and $000000FF;
Result.g := (Color and $0000FF00) shr 8;
Result.b := (Color and $00FF0000) shr 16;
end;
 
function RGB2Color(Color: TColorRGB): TColor;
begin
Result := Color.r or (Color.g shl 8) or (Color.b shl 16);
end;
 
begin
DstWidth := Dst.Width;
DstHeight := Dst.Height;
SrcWidth := Src.Width;
SrcHeight := Src.Height;
if (SrcWidth < 1) or (SrcHeight < 1) then
raise Exception.Create('Source bitmap too small');
 
// Create intermediate image to hold horizontal zoom
Work := TDIB.Create;
try
Work.Height := SrcHeight;
Work.Width := DstWidth;
// xscale := DstWidth / SrcWidth;
// yscale := DstHeight / SrcHeight;
// Improvement suggested by David Ullrich:
if (SrcWidth = 1) then
xscale := DstWidth / SrcWidth
else
xscale := (DstWidth - 1) / (SrcWidth - 1);
if (SrcHeight = 1) then
yscale := DstHeight / SrcHeight
else
yscale := (DstHeight - 1) / (SrcHeight - 1);
// This implementation only works on 24-bit images because it uses
// TDIB.Scanline
{$IFDEF USE_SCANLINE}
//Src.PixelFormat := pf24bit;
Src.BitCount := 24;
//Dst.PixelFormat := Src.PixelFormat;
dst.BitCount := 24;
//Work.PixelFormat := Src.PixelFormat;
work.BitCount := 24;
{$ENDIF}
 
// --------------------------------------------
// Pre-calculate filter contributions for a row
// -----------------------------------------------
GetMem(contrib, DstWidth * sizeof(TCList));
// Horizontal sub-sampling
// Scales from bigger to smaller width
if (xscale < 1.0) then
begin
width := fwidth / xscale;
fscale := 1.0 / xscale;
for i := 0 to DstWidth - 1 do
begin
contrib^[i].n := 0;
GetMem(contrib^[i].p, trunc(width * 2.0 + 1) * sizeof(TContributor));
center := i / xscale;
// Original code:
// left := ceil(center - width);
// right := floor(center + width);
left := floor(center - width);
right := ceil(center + width);
for j := left to right do
begin
case filtertype of
ftrBox: weight := boxfilter((center - j) / fscale) / fscale;
ftrTriangle: weight := trianglefilter((center - j) / fscale) / fscale;
ftrHermite: weight := hermitefilter((center - j) / fscale) / fscale;
ftrBell: weight := bellfilter((center - j) / fscale) / fscale;
ftrBSpline: weight := splinefilter((center - j) / fscale) / fscale;
ftrLanczos3: weight := Lanczos3filter((center - j) / fscale) / fscale;
ftrMitchell: weight := Mitchellfilter((center - j) / fscale) / fscale;
else
weight := 0
end;
if (weight = 0.0) then
continue;
if (j < 0) then
n := -j
else if (j >= SrcWidth) then
n := SrcWidth - j + SrcWidth - 1
else
n := j;
k := contrib^[i].n;
contrib^[i].n := contrib^[i].n + 1;
contrib^[i].p^[k].pixel := n;
contrib^[i].p^[k].weight := weight;
end;
end;
end
else
// Horizontal super-sampling
// Scales from smaller to bigger width
begin
for i := 0 to DstWidth - 1 do
begin
contrib^[i].n := 0;
GetMem(contrib^[i].p, trunc(fwidth * 2.0 + 1) * sizeof(TContributor));
center := i / xscale;
// Original code:
// left := ceil(center - fwidth);
// right := floor(center + fwidth);
left := floor(center - fwidth);
right := ceil(center + fwidth);
for j := left to right do
begin
case filtertype of
ftrBox: weight := boxfilter(center - j);
ftrTriangle: weight := trianglefilter(center - j);
ftrHermite: weight := hermitefilter(center - j);
ftrBell: weight := bellfilter(center - j);
ftrBSpline: weight := splinefilter(center - j);
ftrLanczos3: weight := Lanczos3filter(center - j);
ftrMitchell: weight := Mitchellfilter(center - j);
else
weight := 0
end;
if (weight = 0.0) then
continue;
if (j < 0) then
n := -j
else if (j >= SrcWidth) then
n := SrcWidth - j + SrcWidth - 1
else
n := j;
k := contrib^[i].n;
contrib^[i].n := contrib^[i].n + 1;
contrib^[i].p^[k].pixel := n;
contrib^[i].p^[k].weight := weight;
end;
end;
end;
 
// ----------------------------------------------------
// Apply filter to sample horizontally from Src to Work
// ----------------------------------------------------
for k := 0 to SrcHeight - 1 do
begin
{$IFDEF USE_SCANLINE}
SourceLine := Src.ScanLine[k];
DestPixel := Work.ScanLine[k];
{$ENDIF}
for i := 0 to DstWidth - 1 do
begin
rgb.r := 0.0;
rgb.g := 0.0;
rgb.b := 0.0;
for j := 0 to contrib^[i].n - 1 do
begin
{$IFDEF USE_SCANLINE}
color := SourceLine^[contrib^[i].p^[j].pixel];
{$ELSE}
color := Color2RGB(Src.Canvas.Pixels[contrib^[i].p^[j].pixel, k]);
{$ENDIF}
weight := contrib^[i].p^[j].weight;
if (weight = 0.0) then
continue;
rgb.r := rgb.r + color.r * weight;
rgb.g := rgb.g + color.g * weight;
rgb.b := rgb.b + color.b * weight;
end;
if (rgb.r > 255.0) then
color.r := 255
else if (rgb.r < 0.0) then
color.r := 0
else
color.r := round(rgb.r);
if (rgb.g > 255.0) then
color.g := 255
else if (rgb.g < 0.0) then
color.g := 0
else
color.g := round(rgb.g);
if (rgb.b > 255.0) then
color.b := 255
else if (rgb.b < 0.0) then
color.b := 0
else
color.b := round(rgb.b);
{$IFDEF USE_SCANLINE}
// Set new pixel value
DestPixel^ := color;
// Move on to next column
inc(DestPixel);
{$ELSE}
Work.Canvas.Pixels[i, k] := RGB2Color(color);
{$ENDIF}
end;
end;
 
// Free the memory allocated for horizontal filter weights
for i := 0 to DstWidth - 1 do
FreeMem(contrib^[i].p);
 
FreeMem(contrib);
 
// -----------------------------------------------
// Pre-calculate filter contributions for a column
// -----------------------------------------------
GetMem(contrib, DstHeight * sizeof(TCList));
// Vertical sub-sampling
// Scales from bigger to smaller height
if (yscale < 1.0) then
begin
width := fwidth / yscale;
fscale := 1.0 / yscale;
for i := 0 to DstHeight - 1 do
begin
contrib^[i].n := 0;
GetMem(contrib^[i].p, trunc(width * 2.0 + 1) * sizeof(TContributor));
center := i / yscale;
// Original code:
// left := ceil(center - width);
// right := floor(center + width);
left := floor(center - width);
right := ceil(center + width);
for j := left to right do
begin
case filtertype of
ftrBox: weight := boxfilter((center - j) / fscale) / fscale;
ftrTriangle: weight := trianglefilter((center - j) / fscale) / fscale;
ftrHermite: weight := hermitefilter((center - j) / fscale) / fscale;
ftrBell: weight := bellfilter((center - j) / fscale) / fscale;
ftrBSpline: weight := splinefilter((center - j) / fscale) / fscale;
ftrLanczos3: weight := Lanczos3filter((center - j) / fscale) / fscale;
ftrMitchell: weight := Mitchellfilter((center - j) / fscale) / fscale;
else
weight := 0
end;
if (weight = 0.0) then
continue;
if (j < 0) then
n := -j
else if (j >= SrcHeight) then
n := SrcHeight - j + SrcHeight - 1
else
n := j;
k := contrib^[i].n;
contrib^[i].n := contrib^[i].n + 1;
contrib^[i].p^[k].pixel := n;
contrib^[i].p^[k].weight := weight;
end;
end
end
else
// Vertical super-sampling
// Scales from smaller to bigger height
begin
for i := 0 to DstHeight - 1 do
begin
contrib^[i].n := 0;
GetMem(contrib^[i].p, trunc(fwidth * 2.0 + 1) * sizeof(TContributor));
center := i / yscale;
// Original code:
// left := ceil(center - fwidth);
// right := floor(center + fwidth);
left := floor(center - fwidth);
right := ceil(center + fwidth);
for j := left to right do
begin
case filtertype of
ftrBox: weight := boxfilter(center - j);
ftrTriangle: weight := trianglefilter(center - j);
ftrHermite: weight := hermitefilter(center - j);
ftrBell: weight := bellfilter(center - j);
ftrBSpline: weight := splinefilter(center - j);
ftrLanczos3: weight := Lanczos3filter(center - j);
ftrMitchell: weight := Mitchellfilter(center - j);
else
weight := 0
end;
if (weight = 0.0) then
continue;
if (j < 0) then
n := -j
else if (j >= SrcHeight) then
n := SrcHeight - j + SrcHeight - 1
else
n := j;
k := contrib^[i].n;
contrib^[i].n := contrib^[i].n + 1;
contrib^[i].p^[k].pixel := n;
contrib^[i].p^[k].weight := weight;
end;
end;
end;
 
// --------------------------------------------------
// Apply filter to sample vertically from Work to Dst
// --------------------------------------------------
{$IFDEF USE_SCANLINE}
SourceLine := Work.ScanLine[0];
Delta := Integer(Work.ScanLine[1]) - Integer(SourceLine);
DestLine := Dst.ScanLine[0];
DestDelta := Integer(Dst.ScanLine[1]) - Integer(DestLine);
{$ENDIF}
for k := 0 to DstWidth - 1 do
begin
{$IFDEF USE_SCANLINE}
DestPixel := pointer(DestLine);
{$ENDIF}
for i := 0 to DstHeight - 1 do
begin
rgb.r := 0;
rgb.g := 0;
rgb.b := 0;
// weight := 0.0;
for j := 0 to contrib^[i].n - 1 do
begin
{$IFDEF USE_SCANLINE}
color := PColorRGB(Integer(SourceLine) + contrib^[i].p^[j].pixel * Delta)^;
{$ELSE}
color := Color2RGB(Work.Canvas.Pixels[k, contrib^[i].p^[j].pixel]);
{$ENDIF}
weight := contrib^[i].p^[j].weight;
if (weight = 0.0) then
continue;
rgb.r := rgb.r + color.r * weight;
rgb.g := rgb.g + color.g * weight;
rgb.b := rgb.b + color.b * weight;
end;
if (rgb.r > 255.0) then
color.r := 255
else if (rgb.r < 0.0) then
color.r := 0
else
color.r := round(rgb.r);
if (rgb.g > 255.0) then
color.g := 255
else if (rgb.g < 0.0) then
color.g := 0
else
color.g := round(rgb.g);
if (rgb.b > 255.0) then
color.b := 255
else if (rgb.b < 0.0) then
color.b := 0
else
color.b := round(rgb.b);
{$IFDEF USE_SCANLINE}
DestPixel^ := color;
inc(Integer(DestPixel), DestDelta);
{$ELSE}
Dst.Canvas.Pixels[k, i] := RGB2Color(color);
{$ENDIF}
end;
{$IFDEF USE_SCANLINE}
Inc(SourceLine, 1);
Inc(DestLine, 1);
{$ENDIF}
end;
 
// Free the memory allocated for vertical filter weights
for i := 0 to DstHeight - 1 do
FreeMem(contrib^[i].p);
 
FreeMem(contrib);
 
finally
Work.Free;
end;
end;
var BB1, BB2: TDIB;
begin
BB1 := TDIB.Create;
BB1.BitCount := 24;
BB1.Assign(Self);
BB2 := TDIB.Create;
BB2.SetSize(AmountX, AmountY, 24);
Resample(BB1, BB2, TypeResample, DefaultFilterRadius[TypeResample]);
Self.Assign(BB2);
BB1.Free;
BB2.Free;
end;
 
procedure TDIB.DoColorize(ForeColor, BackColor: TColor);
procedure Colorize(src, dst: TDIB; iForeColor, iBackColor: TColor; iDither: Boolean{$IFDEF VER4UP} = False{$ENDIF});
{for monochromatic picture change colors}
procedure InvertBitmap(Bmp: TDIB);
begin
Bmp.Canvas.CopyMode := cmDstInvert;
Bmp.Canvas.CopyRect(rect(0, 0, Bmp.Width, Bmp.Height),
Bmp.Canvas, rect(0, 0, Bmp.Width, Bmp.Height));
end;
var
fForeColor: TColor;
fForeDither: Boolean;
lTempBitmap: TDIB;
lTempBitmap2: TDIB;
lDitherBitmap: TDIB;
lCRect: TRect;
x, y, w, h: Integer;
begin
{--}
//fColor := iBackColor; ;
fForeColor := iForeColor;
fForeDither := iDither;
w := src.Width;
h := src.Height;
lDitherBitmap := nil;
lTempBitmap := TDIB.Create;
lTempBitmap.SetSize(w, h, 24);
lTempBitmap2 := TDIB.Create;
lTempBitmap2.SetSize(w, h, 24);
lCRect := rect(0, 0, w, h);
with lTempBitmap.Canvas do
begin
Brush.Style := bsSolid;
Brush.Color := iBackColor;
FillRect(lCRect);
CopyMode := cmSrcInvert;
CopyRect(lCRect, src.Canvas, lCRect);
InvertBitmap(src);
CopyMode := cmSrcPaint;
CopyRect(lCRect, src.Canvas, lCRect);
InvertBitmap(lTempBitmap);
CopyMode := cmSrcInvert;
CopyRect(lCRect, src.Canvas, lCRect);
InvertBitmap(src);
end;
with lTempBitmap2.Canvas do
begin
Brush.Style := bsSolid;
Brush.Color := clBlack;
FillRect(lCRect);
if fForeDither then
begin
InvertBitmap(src);
lDitherBitmap := TDIB.Create;
lDitherBitmap.SetSize(8, 8, 24);
with lDitherBitmap.Canvas do
begin
for x := 0 to 7 do
for y := 0 to 7 do
if ((x mod 2 = 0) and (y mod 2 > 0)) or ((x mod 2 > 0) and (y mod 2 = 0)) then
pixels[x, y] := fForeColor
else
pixels[x, y] := iBackColor;
end;
Brush.Bitmap.Assign(lDitherBitmap);
end
else
begin
Brush.Style := bsSolid;
Brush.Color := fForeColor;
end;
if not fForeDither then
InvertBitmap(src);
CopyMode := cmPatPaint;
CopyRect(lCRect, src.Canvas, lCRect);
if fForeDither then
if Assigned(lDitherBitmap) then
lDitherBitmap.Free;
CopyMode := cmSrcInvert;
CopyRect(lCRect, src.Canvas, lCRect);
end;
lTempBitmap.Canvas.CopyMode := cmSrcInvert;
lTempBitmap.Canvas.Copyrect(lCRect, lTempBitmap2.Canvas, lCRect);
InvertBitmap(src);
lTempBitmap.Canvas.CopyMode := cmSrcErase;
lTempBitmap.Canvas.Copyrect(lCRect, src.Canvas, lCRect);
InvertBitmap(src);
lTempBitmap.Canvas.CopyMode := cmSrcInvert;
lTempBitmap.Canvas.Copyrect(lCRect, lTempBitmap2.Canvas, lCRect);
InvertBitmap(lTempBitmap);
InvertBitmap(src);
dst.Assign(lTempBitmap);
lTempBitmap.Free;
end;
var BB1, BB2: TDIB;
begin
BB1 := TDIB.Create;
BB1.BitCount := 24;
BB1.Assign(Self);
BB2 := TDIB.Create;
Colorize(BB1, BB2, ForeColor, BackColor{$IFNDEF VER4UP}, False{$ENDIF});
Self.Assign(BB2);
BB1.Free;
BB2.Free;
end;
 
{ procedure for special purpose }
 
procedure TDIB.FadeOut(DIB2: TDIB; Step: Byte);
var
P1, P2: PByteArray;
W, H: Integer;
begin
P1 := ScanLine[DIB2.Height - 1];
P2 := DIB2.ScanLine[DIB2.Height - 1];
W := WidthBytes;
H := Height;
asm
PUSH ESI
PUSH EDI
MOV ESI, P1
MOV EDI, P2
MOV EDX, W
MOV EAX, H
IMUL EDX
MOV ECX, EAX
@@1:
MOV AL, Step
MOV AH, [ESI]
CMP AL, AH
JA @@2
MOV AL, AH
@@2:
MOV [EDI], AL
INC ESI
INC EDI
DEC ECX
JNZ @@1
POP EDI
POP ESI
end;
end;
 
procedure TDIB.DoZoom(DIB2: TDIB; ZoomRatio: Real);
var
P1, P2: PByteArray;
W, H: Integer;
x, y: Integer;
xr, yr, xstep, ystep: real;
xstart: real;
begin
W := WidthBytes;
H := Height;
xstart := (W - (W * ZoomRatio)) / 2;
 
xr := xstart;
yr := (H - (H * ZoomRatio)) / 2;
xstep := ZoomRatio;
ystep := ZoomRatio;
 
for y := 1 to Height - 1 do
begin
P2 := DIB2.ScanLine[y];
if (yr >= 0) and (yr <= H) then
begin
P1 := ScanLine[Trunc(yr)];
for x := 1 to Width - 1 do
begin
if (xr >= 0) and (xr <= W) then
begin
P2[x] := P1[Trunc(xr)];
end
else
begin
P2[x] := 0;
end;
xr := xr + xstep;
end;
end
else
begin
for x := 1 to Width - 1 do
begin
P2[x] := 0;
end;
end;
xr := xstart;
yr := yr + ystep;
end;
end;
 
procedure TDIB.DoBlur(DIB2: TDIB);
var
P1, P2: PByteArray;
W: Integer;
x, y: Integer;
begin
W := WidthBytes;
for y := 1 to Height - 1 do
begin
P1 := ScanLine[y];
P2 := DIB2.ScanLine[y];
for x := 1 to Width - 1 do
begin
P2[x] := (P1[x] + P1[x - 1] + P1[x + 1] + P1[x + W] + P1[x - W]) div 5;
end;
end;
end;
 
procedure TDIB.FadeIn(DIB2: TDIB; Step: Byte);
var
P1, P2: PByteArray;
W, H: Integer;
begin
P1 := ScanLine[DIB2.Height - 1];
P2 := DIB2.ScanLine[DIB2.Height - 1];
W := WidthBytes;
H := Height;
asm
PUSH ESI
PUSH EDI
MOV ESI, P1
MOV EDI, P2
MOV EDX, W
MOV EAX, H
IMUL EDX
MOV ECX, EAX
@@1:
MOV AL, Step
MOV AH, [ESI]
CMP AL, AH
JB @@2
MOV AL, AH
@@2:
MOV [EDI], AL
INC ESI
INC EDI
DEC ECX
JNZ @@1
POP EDI
POP ESI
end;
end;
 
procedure TDIB.FillDIB8(Color: Byte);
var
P: PByteArray;
W, H: Integer;
begin
P := ScanLine[Height - 1];
W := WidthBytes;
H := Height;
asm
PUSH ESI
MOV ESI, P
MOV EDX, W
MOV EAX, H
IMUL EDX
MOV ECX, EAX
MOV AL, Color
@@1:
MOV [ESI], AL
INC ESI
DEC ECX
JNZ @@1
POP ESI
end;
end;
 
procedure TDIB.DoRotate(DIB1: TDIB; cX, cY, Angle: Integer);
type
T3Byte = array[0..2] of Byte;
P3ByteArray = ^T3ByteArray;
T3ByteArray = array[0..32767] of T3Byte;
PLongArray = ^TLongArray;
TLongArray = array[0..32767] of LongInt;
var
p, p2: PByteArray;
x, y, x2, y2, angled: Integer;
cosy, siny: real;
begin
angled := 384 + Angle;
for y := 0 to Height - 1 do
begin
p := DIB1.ScanLine[y];
cosy := (y - cY) * dcos(angled and $1FF);
siny := (y - cY) * dsin(angled and $1FF);
for x := 0 to Width - 1 do
begin
x2 := Trunc((x - cX) * dsin(angled and $1FF) + cosy) + cX;
y2 := Trunc((x - cX) * dcos(angled and $1FF) - siny) + cY;
case bitcount of
8:
begin
if (y2 >= 0) and (y2 < Height) and (x2 >= 0) and (x2 < Width) then
begin
p2 := ScanLine[y2];
p[x] := p2[Width - x2];
end
else
begin
if p[x] > 4 then
p[x] := p[x] - 4
else
p[x] := 0;
end;
end;
16:
begin
if (y2 >= 0) and (y2 < Height) and (x2 >= 0) and (x2 < Width) then
begin
PWordArray(p2) := ScanLine[y2];
PWordArray(p)[x] := PWordArray(p2)[Width - x2];
end
else
begin
if PWordArray(p)[x] > 4 then
PWordArray(p)[x] := PWordArray(p)[x] - 4
else
PWordArray(p)[x] := 0;
end;
end;
24:
begin
if (y2 >= 0) and (y2 < Height) and (x2 >= 0) and (x2 < Width) then
begin
P3ByteArray(p2) := ScanLine[y2];
P3ByteArray(p)[x] := P3ByteArray(p2)[Width - x2];
end
else
begin
if P3ByteArray(p)[x][0] > 4 then
P3ByteArray(p)[x][0] := P3ByteArray(p)[x][0] - 4
else if P3ByteArray(p)[x][1] > 4 then
P3ByteArray(p)[x][1] := P3ByteArray(p)[x][1] - 4
else if P3ByteArray(p)[x][2] > 4 then
P3ByteArray(p)[x][2] := P3ByteArray(p)[x][2] - 4
else
begin
P3ByteArray(p)[x][0] := 0;
P3ByteArray(p)[x][1] := 0;
P3ByteArray(p)[x][2] := 0;
end;
end;
end;
32: begin
if (y2 >= 0) and (y2 < Height) and (x2 >= 0) and (x2 < Width) then
begin
plongarray(p2) := ScanLine[y2];
plongarray(p)[x] := plongarray(p2)[Width - x2];
end
else
begin
if plongarray(p)[x] > 4 then
plongarray(p)[x] := plongarray(p)[x] - 4
else
plongarray(p)[x] := 0;
end;
end;
end
end;
end;
end;
 
function TDIB.Ink(DIB: TDIB; const SprayInit: Boolean; const AmountSpray: Integer): Boolean;
type
T3Byte = array[0..2] of Byte;
P3ByteArray = ^T3ByteArray;
T3ByteArray = array[0..32767] of T3Byte;
PLongArray = ^TLongArray;
TLongArray = array[0..32767] of LongInt;
function ColorToRGBTriple(const Color: TColor): TRGBTriple;
begin
with RESULT do
begin
rgbtRed := GetRValue(Color);
rgbtGreen := GetGValue(Color);
rgbtBlue := GetBValue(Color)
end
end {ColorToRGBTriple};
 
function TestQuad(T: T3Byte; Color: Integer): Boolean;
begin
Result := (T[0] > GetRValue(Color)) and
(T[1] > GetGValue(Color)) and
(T[2] > GetBValue(Color))
end;
var
p0, p, p2: PByteArray;
x, y, c: Integer;
z: Integer;
begin
if SprayInit then
begin
DIB.Assign(Self);
{ Spray seeds }
for c := 0 to AmountSpray do
begin
DIB.Pixels[Random(Width - 1), Random(Height - 1)] := 0;
end;
end;
Result := True; {all is black}
for y := 0 to DIB.Height - 1 do
begin
p := DIB.ScanLine[y];
for x := 0 to DIB.Width - 1 do
begin
case bitcount of
8:
begin
if p[x] < 16 then
begin
if p[x] > 0 then Result := False;
if y > 0 then
begin
p0 := DIB.ScanLine[y - 1];
if p0[x] > 4 then
p0[x] := p0[x] - 4
else
p0[x] := 0;
if x > 0 then
if p0[x - 1] > 2 then
p0[x - 1] := p0[x - 1] - 2
else
p0[x - 1] := 0;
if x < (DIB.Width - 1) then
if p0[x + 1] > 2 then
p0[x + 1] := p0[x + 1] - 2
else
p0[x + 1] := 0;
end;
if y < (DIB.Height - 1) then
begin
p2 := DIB.ScanLine[y + 1];
if p2[x] > 4 then
p2[x] := p2[x] - 4
else
p2[x] := 0;
if x > 0 then
if p2[x - 1] > 2 then
p2[x - 1] := p2[x - 1] - 2
else
p2[x - 1] := 0;
if x < (DIB.Width - 1) then
if p2[x + 1] > 2 then
p2[x + 1] := p2[x + 1] - 2
else
p2[x + 1] := 0;
end;
if p[x] > 8 then
p[x] := p[x] - 8
else
p[x] := 0;
if x > 0 then
if p[x - 1] > 4 then
p[x - 1] := p[x - 1] - 4
else
p[x - 1] := 0;
if x < (DIB.Width - 1) then
if p[x + 1] > 4 then
p[x + 1] := p[x + 1] - 4
else
p[x + 1] := 0;
end;
end;
16:
begin
if pwordarray(p)[x] < 16 then
begin
if pwordarray(p)[x] > 0 then Result := False;
if y > 0 then
begin
pwordarray(p0) := DIB.ScanLine[y - 1];
if pwordarray(p0)[x] > 4 then
pwordarray(p0)[x] := pwordarray(p0)[x] - 4
else
pwordarray(p0)[x] := 0;
if x > 0 then
if pwordarray(p0)[x - 1] > 2 then
pwordarray(p0)[x - 1] := pwordarray(p0)[x - 1] - 2
else
pwordarray(p0)[x - 1] := 0;
if x < (DIB.Width - 1) then
if pwordarray(p0)[x + 1] > 2 then
pwordarray(p0)[x + 1] := pwordarray(p0)[x + 1] - 2
else
pwordarray(p0)[x + 1] := 0;
end;
if y < (DIB.Height - 1) then
begin
pwordarray(p2) := DIB.ScanLine[y + 1];
if pwordarray(p2)[x] > 4 then
pwordarray(p2)[x] := pwordarray(p2)[x] - 4
else
pwordarray(p2)[x] := 0;
if x > 0 then
if pwordarray(p2)[x - 1] > 2 then
pwordarray(p2)[x - 1] := pwordarray(p2)[x - 1] - 2
else
pwordarray(p2)[x - 1] := 0;
if x < (DIB.Width - 1) then
if pwordarray(p2)[x + 1] > 2 then
pwordarray(p2)[x + 1] := pwordarray(p2)[x + 1] - 2
else
pwordarray(p2)[x + 1] := 0;
end;
if pwordarray(p)[x] > 8 then
pwordarray(p)[x] := pwordarray(p)[x] - 8
else
pwordarray(p)[x] := 0;
if x > 0 then
if pwordarray(p)[x - 1] > 4 then
pwordarray(p)[x - 1] := pwordarray(p)[x - 1] - 4
else
pwordarray(p)[x - 1] := 0;
if x < (DIB.Width - 1) then
if pwordarray(p)[x + 1] > 4 then
pwordarray(p)[x + 1] := pwordarray(p)[x + 1] - 4
else
pwordarray(p)[x + 1] := 0;
end;
end;
24:
begin
if not TestQuad(P3ByteArray(p)[x], 16) then
begin
if TestQuad(P3ByteArray(p)[x], 0) then Result := False;
if y > 0 then
begin
P3ByteArray(p0) := DIB.ScanLine[y - 1];
if TestQuad(P3ByteArray(p0)[x], 4) then
begin
for z := 0 to 2 do
if P3ByteArray(p0)[x][z] > 4 then
P3ByteArray(p0)[x][z] := P3ByteArray(p0)[x][z] - 4
end
else
for z := 0 to 2 do
P3ByteArray(p0)[x][z] := 0;
if x > 0 then
if TestQuad(P3ByteArray(p0)[x - 1], 2) then
begin
for z := 0 to 2 do
if P3ByteArray(p0)[x - 1][z] > 2 then
P3ByteArray(p0)[x - 1][z] := P3ByteArray(p0)[x - 1][z] - 2
end
else
for z := 0 to 2 do
P3ByteArray(p0)[x - 1][z] := 0;
if x < (DIB.Width - 1) then
if TestQuad(P3ByteArray(p0)[x + 1], 2) then
begin
for z := 0 to 2 do
if P3ByteArray(p0)[x + 1][z] > 2 then
P3ByteArray(p0)[x + 1][z] := P3ByteArray(p0)[x + 1][z] - 2
end
else
for z := 0 to 2 do
P3ByteArray(p0)[x + 1][z] := 0;
end;
if y < (DIB.Height - 1) then
begin
P3ByteArray(p2) := DIB.ScanLine[y + 1];
if TestQuad(P3ByteArray(p2)[x], 4) then
begin
for z := 0 to 2 do
if P3ByteArray(p2)[x][z] > 4 then
P3ByteArray(p2)[x][z] := P3ByteArray(p2)[x][z] - 4
end
else
for z := 0 to 2 do
P3ByteArray(p2)[x][z] := 0;
if x > 0 then
if TestQuad(P3ByteArray(p2)[x - 1], 2) then
begin
for z := 0 to 2 do
if P3ByteArray(p2)[x - 1][z] > 2 then
P3ByteArray(p2)[x - 1][z] := P3ByteArray(p2)[x - 1][z] - 2
end
else
for z := 0 to 2 do
P3ByteArray(p2)[x - 1][z] := 0;
if x < (DIB.Width - 1) then
if TestQuad(P3ByteArray(p2)[x + 1], 2) then
begin
for z := 0 to 2 do
if P3ByteArray(p2)[x + 1][z] > 2 then
P3ByteArray(p2)[x + 1][z] := P3ByteArray(p2)[x + 1][z] - 2
end
else
for z := 0 to 2 do
P3ByteArray(p2)[x + 1][z] := 0;
end;
if TestQuad(P3ByteArray(p)[x], 8) then
begin
for z := 0 to 2 do
if P3ByteArray(p)[x][z] > 8 then
P3ByteArray(p)[x][z] := P3ByteArray(p)[x][z] - 8
end
else
for z := 0 to 2 do
P3ByteArray(p)[x][z] := 0;
if x > 0 then
if TestQuad(P3ByteArray(p)[x - 1], 4) then
begin
for z := 0 to 2 do
if P3ByteArray(p)[x - 1][z] > 4 then
P3ByteArray(p)[x - 1][z] := P3ByteArray(p)[x - 1][z] - 4
end
else
for z := 0 to 2 do
P3ByteArray(p)[x - 1][z] := 0;
if x < (DIB.Width - 1) then
if TestQuad(P3ByteArray(p)[x + 1], 4) then
begin
for z := 0 to 2 do
if P3ByteArray(p)[x + 1][z] > 4 then
P3ByteArray(p)[x + 1][z] := P3ByteArray(p)[x + 1][z] - 4
end
else
for z := 0 to 2 do
P3ByteArray(p)[x + 1][z] := 0;
end;
end;
32:
begin
if plongarray(p)[x] < 16 then
begin
if plongarray(p)[x] > 0 then Result := False;
if y > 0 then
begin
plongarray(p0) := DIB.ScanLine[y - 1];
if plongarray(p0)[x] > 4 then
plongarray(p0)[x] := plongarray(p0)[x] - 4
else
plongarray(p0)[x] := 0;
if x > 0 then
if plongarray(p0)[x - 1] > 2 then
plongarray(p0)[x - 1] := plongarray(p0)[x - 1] - 2
else
plongarray(p0)[x - 1] := 0;
if x < (DIB.Width - 1) then
if plongarray(p0)[x + 1] > 2 then
plongarray(p0)[x + 1] := plongarray(p0)[x + 1] - 2
else
plongarray(p0)[x + 1] := 0;
end;
if y < (DIB.Height - 1) then
begin
plongarray(p2) := DIB.ScanLine[y + 1];
if plongarray(p2)[x] > 4 then
plongarray(p2)[x] := plongarray(p2)[x] - 4
else
plongarray(p2)[x] := 0;
if x > 0 then
if plongarray(p2)[x - 1] > 2 then
plongarray(p2)[x - 1] := plongarray(p2)[x - 1] - 2
else
plongarray(p2)[x - 1] := 0;
if x < (DIB.Width - 1) then
if plongarray(p2)[x + 1] > 2 then
plongarray(p2)[x + 1] := plongarray(p2)[x + 1] - 2
else
plongarray(p2)[x + 1] := 0;
end;
if plongarray(p)[x] > 8 then
plongarray(p)[x] := plongarray(p)[x] - 8
else
plongarray(p)[x] := 0;
if x > 0 then
if plongarray(p)[x - 1] > 4 then
plongarray(p)[x - 1] := plongarray(p)[x - 1] - 4
else
plongarray(p)[x - 1] := 0;
if x < (DIB.Width - 1) then
if plongarray(p)[x + 1] > 4 then
plongarray(p)[x + 1] := plongarray(p)[x + 1] - 4
else
plongarray(p)[x + 1] := 0;
end;
end;
end {case};
end;
end;
end;
 
procedure TDIB.Distort(DIB1: TDIB; dt: TDistortType; cX, cY, Angle: Integer; Factor: Real);
type
T3Byte = array[0..2] of Byte;
P3ByteArray = ^T3ByteArray;
T3ByteArray = array[0..32767] of T3Byte;
PLongArray = ^TLongArray;
TLongArray = array[0..32767] of LongInt;
var
p, p2: PByteArray;
x, y, x2, y2, angled, ysqr: Integer;
actdist, dist, cosy, siny: real;
begin
dist := Factor * sqrt(sqr(cX) + sqr(cY));
for y := 0 to DIB1.Height - 1 do
begin
p := DIB1.ScanLine[y];
ysqr := sqr(y - cY);
for x := 0 to (DIB1.Width) - 1 do
begin
actdist := (sqrt((sqr(x - cX) + ysqr)) / dist);
if dt = dtSlow then
actdist := dsin((Trunc(actdist * 1024)) and $1FF);
angled := 384 + Trunc((actdist) * Angle);
 
cosy := (y - cY) * dcos(angled and $1FF);
siny := (y - cY) * dsin(angled and $1FF);
 
x2 := Trunc((x - cX) * dsin(angled and $1FF) + cosy) + cX;
y2 := Trunc((x - cX) * dcos(angled and $1FF) - siny) + cY;
case bitcount of
8:
begin
if (y2 >= 0) and (y2 < Height) and (x2 >= 0) and (x2 < Width) then
begin
p2 := ScanLine[y2];
p[x] := p2[Width - x2];
end
else
begin
if p[x] > 2 then
p[x] := p[x] - 2
else
p[x] := 0;
end;
end;
16:
begin
if (y2 >= 0) and (y2 < Height) and (x2 >= 0) and (x2 < Width) then
begin
pwordarray(p2) := ScanLine[y2];
pwordarray(p)[x] := pwordarray(p2)[Width - x2];
end
else
begin
if pwordarray(p)[x] > 2 then
pwordarray(p)[x] := pwordarray(p)[x] - 2
else
pwordarray(p)[x] := 0;
end;
end;
24:
begin
if (y2 >= 0) and (y2 < Height) and (x2 >= 0) and (x2 < Width) then
begin
P3ByteArray(p2) := ScanLine[y2];
P3ByteArray(p)[x] := P3ByteArray(p2)[Width - x2];
end
else
begin
if P3ByteArray(p)[x][0] > 2 then
P3ByteArray(p)[x][0] := P3ByteArray(p)[x][0] - 2
else if P3ByteArray(p)[x][1] > 2 then
P3ByteArray(p)[x][1] := P3ByteArray(p)[x][1] - 2
else if P3ByteArray(p)[x][2] > 2 then
P3ByteArray(p)[x][2] := P3ByteArray(p)[x][2] - 2
else
begin
P3ByteArray(p)[x][0] := 0;
P3ByteArray(p)[x][1] := 0;
P3ByteArray(p)[x][2] := 0;
end;
end;
end;
32:
begin
if (y2 >= 0) and (y2 < Height) and (x2 >= 0) and (x2 < Width) then
begin
plongarray(p2) := ScanLine[y2];
plongarray(p)[x] := plongarray(p2)[Width - x2];
end
else
begin
if p[x] > 2 then
plongarray(p)[x] := plongarray(p)[x] - 2
else
plongarray(p)[x] := 0;
end;
end;
end {case}
end;
end;
end;
 
procedure TDIB.AntialiasedLine(x1, y1, x2, y2: Integer; color: TColor);
//anti-aliased line using the Wu algorithm by Peter Bone
var
dX, dY, X, Y, start, finish: Integer;
LM, LR: Integer;
dxi, dyi, dydxi: Integer;
P: PLines;
R, G, B: byte;
begin
R := GetRValue(Color);
G := GetGValue(Color);
B := GetBValue(Color);
dX := abs(x2 - x1); // Calculate deltax and deltay for initialisation
dY := abs(y2 - y1);
if (dX = 0) or (dY = 0) then
begin
Canvas.Pen.Color := (B shl 16) + (G shl 8) + R;
Canvas.MoveTo(x1, y1);
Canvas.LineTo(x2, y2);
exit;
end;
if dX > dY then
begin // horizontal or vertical
if y2 > y1 then // determine rise and run
dydxi := -dY shl 16 div dX
else
dydxi := dY shl 16 div dX;
if x2 < x1 then
begin
start := x2; // right to left
finish := x1;
dyi := y2 shl 16;
end
else
begin
start := x1; // left to right
finish := x2;
dyi := y1 shl 16;
dydxi := -dydxi; // inverse slope
end;
if finish >= Width then finish := Width - 1;
for X := start to finish do
begin
Y := dyi shr 16;
if (X < 0) or (Y < 0) or (Y > Height - 2) then
begin
Inc(dyi, dydxi);
Continue;
end;
LM := dyi - Y shl 16; // fractional part of dyi - in fixed-point
LR := 65536 - LM;
P := Scanline[Y];
P^[X].B := (B * LR + P^[X].B * LM) shr 16;
P^[X].G := (G * LR + P^[X].G * LM) shr 16;
P^[X].R := (R * LR + P^[X].R * LM) shr 16;
//Inc(Y);
P^[X].B := (B * LM + P^[X].B * LR) shr 16;
P^[X].G := (G * LM + P^[X].G * LR) shr 16;
P^[X].R := (R * LM + P^[X].R * LR) shr 16;
Inc(dyi, dydxi); // next point
end;
end
else
begin
if x2 > x1 then // determine rise and run
dydxi := -dX shl 16 div dY
else
dydxi := dX shl 16 div dY;
if y2 < y1 then
begin
start := y2; // right to left
finish := y1;
dxi := x2 shl 16;
end
else
begin
start := y1; // left to right
finish := y2;
dxi := x1 shl 16;
dydxi := -dydxi; // inverse slope
end;
if finish >= Height then finish := Height - 1;
for Y := start to finish do
begin
X := dxi shr 16;
if (Y < 0) or (X < 0) or (X > Width - 2) then
begin
Inc(dxi, dydxi);
Continue;
end;
LM := dxi - X shl 16;
LR := 65536 - LM;
P := Scanline[Y];
P^[X].B := (B * LR + P^[X].B * LM) shr 16;
P^[X].G := (G * LR + P^[X].G * LM) shr 16;
P^[X].R := (R * LR + P^[X].R * LM) shr 16;
Inc(X);
P^[X].B := (B * LM + P^[X].B * LR) shr 16;
P^[X].G := (G * LM + P^[X].G * LR) shr 16;
P^[X].R := (R * LM + P^[X].R * LR) shr 16;
Inc(dxi, dydxi); // next point
end;
end;
end;
 
function TDIB.GetColorBetween(StartColor, EndColor: TColor; Pointvalue,
FromPoint, ToPoint: Extended): TColor;
var F: Extended; r1, r2, r3, g1, g2, g3, b1, b2, b3: Byte;
function CalcColorBytes(fb1, fb2: Byte): Byte;
begin
result := fb1;
if fb1 < fb2 then Result := FB1 + Trunc(F * (fb2 - fb1));
if fb1 > fb2 then Result := FB1 - Trunc(F * (fb1 - fb2));
end;
begin
if Pointvalue <= FromPoint then
begin
result := StartColor;
exit;
end;
if Pointvalue >= ToPoint then
begin
result := EndColor;
exit;
end;
F := (Pointvalue - FromPoint) / (ToPoint - FromPoint);
asm
mov EAX, Startcolor
cmp EAX, EndColor
je @@exit //when equal then exit
mov r1, AL
shr EAX,8
mov g1, AL
shr EAX,8
mov b1, AL
mov EAX, Endcolor
mov r2, AL
shr EAX,8
mov g2, AL
shr EAX,8
mov b2, AL
push ebp
mov AL, r1
mov DL, r2
call CalcColorBytes
pop ECX
push EBP
Mov r3, AL
mov DL, g2
mov AL, g1
call CalcColorBytes
pop ECX
push EBP
mov g3, Al
mov DL, B2
mov Al, B1
call CalcColorBytes
pop ECX
mov b3, AL
XOR EAX,EAX
mov AL, B3
shl EAX,8
mov AL, G3
shl EAX,8
mov AL, R3
@@Exit:
mov @result, EAX
end;
end;
 
procedure TDIB.ColoredLine(const iStart, iEnd: TPoint; iColorStyle: TColorLineStyle;
iGradientFrom, iGradientTo: TColor; iPixelGeometry: TColorLinePixelGeometry; iRadius: Word);
var
tempColor: TColor;
const
WavelengthMinimum = 380;
WavelengthMaximum = 780;
 
procedure SetColor(Color: TColor);
begin
Canvas.Pen.Color := Color;
Canvas.Brush.Color := Color;
tempColor := Color
end {SetColor};
 
function WL2RGB(const Wavelength: Double): TColor; {$IFDEF VER9UP}inline;{$ENDIF}
const
Gamma = 0.80;
IntensityMax = 255;
var
Red, Blue, Green, Factor: Double;
 
function Adjust(const Color, Factor: Double): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
begin
if Color = 0.0 then Result := 0
else Result := Round(IntensityMax * Power(Color * Factor, Gamma))
end {Adjust};
begin
case Trunc(Wavelength) of
380..439:
begin
Red := -(Wavelength - 440) / (440 - 380);
Green := 0.0;
Blue := 1.0
end;
440..489:
begin
Red := 0.0;
Green := (Wavelength - 440) / (490 - 440);
Blue := 1.0
end;
490..509:
begin
Red := 0.0;
Green := 1.0;
Blue := -(Wavelength - 510) / (510 - 490)
end;
510..579:
begin
Red := (Wavelength - 510) / (580 - 510);
Green := 1.0;
Blue := 0.0
end;
580..644:
begin
Red := 1.0;
Green := -(Wavelength - 645) / (645 - 580);
Blue := 0.0
end;
645..780:
begin
Red := 1.0;
Green := 0.0;
Blue := 0.0
end;
else
Red := 0.0;
Green := 0.0;
Blue := 0.0
end;
case Trunc(Wavelength) of
380..419: factor := 0.3 + 0.7 * (Wavelength - 380) / (420 - 380);
420..700: factor := 1.0;
701..780: factor := 0.3 + 0.7 * (780 - Wavelength) / (780 - 700)
else
factor := 0.0
end;
Result := RGB(Adjust(Red, Factor), Adjust(Green, Factor), Adjust(Blue, Factor));
end;
 
function Rainbow(const fraction: Double): TColor; {$IFDEF VER9UP}inline;{$ENDIF}
begin
if (fraction < 0.0) or (fraction > 1.0) then Result := clBlack
else
Result := WL2RGB(WavelengthMinimum + Fraction * (WavelengthMaximum - WavelengthMinimum))
end {Raindbow};
 
function ColorInterpolate(const fraction: Double; const Color1, Color2: TColor): TColor; {$IFDEF VER9UP}inline;{$ENDIF}
var
complement: Double;
R1, R2, G1, G2, B1, B2: BYTE;
begin
if fraction <= 0 then Result := Color1
else
if fraction >= 1.0 then Result := Color2
else
begin
R1 := GetRValue(Color1);
G1 := GetGValue(Color1);
B1 := GetBValue(Color1);
R2 := GetRValue(Color2);
G2 := GetGValue(Color2);
B2 := GetBValue(Color2);
complement := 1.0 - fraction;
Result := RGB(Round(complement * R1 + fraction * R2),
Round(complement * G1 + fraction * G2),
Round(complement * B1 + fraction * B2))
end
end {ColorInterpolate};
 
// Conversion utility routines
function ColorToRGBTriple(const Color: TColor): TRGBTriple; {$IFDEF VER9UP}inline;{$ENDIF}
begin
with Result do
begin
rgbtRed := GetRValue(Color);
rgbtGreen := GetGValue(Color);
rgbtBlue := GetBValue(Color)
end
end {ColorToRGBTriple};
 
function RGBTripleToColor(const Triple: TRGBTriple): TColor; {$IFDEF VER9UP}inline;{$ENDIF}
begin
Result := RGB(Triple.rgbtRed, Triple.rgbtGreen, Triple.rgbtBlue)
end {RGBTripleToColor};
// Bresenham's Line Algorithm. Byte, March 1988, pp. 249-253.
var
a, b, d, diag_inc, dXdg, dXndg, dYdg, dYndg, i, nDginc, nDswap, x, y: Integer;
begin {DrawLine}
x := iStart.X;
y := iStart.Y;
a := iEnd.X - iStart.X;
b := iEnd.Y - iStart.Y;
if a < 0 then
begin
a := -a;
dXdg := -1
end
else dXdg := 1;
if b < 0 then
begin
b := -b;
dYdg := -1
end
else dYdg := 1;
if a < b then
begin
nDswap := a;
a := b;
b := nDswap;
dXndg := 0;
dYndg := dYdg
end
else
begin
dXndg := dXdg;
dYndg := 0
end;
d := b + b - a;
nDginc := b + b;
diag_inc := b + b - a - a;
for i := 0 to a do
begin
case iPixelGeometry of
pgPoint:
case iColorStyle of
csSolid:
Canvas.Pixels[x, y] := tempColor;
csGradient:
Canvas.Pixels[x, y] := ColorInterpolate(i / a, iGradientFrom, iGradientTo);
csRainbow:
Canvas.Pixels[x, y] := Rainbow(i / a)
end;
pgCircular:
begin
case iColorStyle of
csSolid: ;
csGradient: SetColor(ColorInterpolate(i / a, iGradientFrom, iGradientTo));
csRainbow: SetColor(Rainbow(i / a))
end;
Canvas.Ellipse(x - iRadius, y - iRadius, x + iRadius, y + iRadius)
end;
pgRectangular:
begin
case iColorStyle of
csSolid: ;
csGradient: SetColor(ColorInterpolate(i / a, iGradientFrom, iGradientTo));
csRainbow: SetColor(Rainbow(i / a))
end;
Canvas.Rectangle(x - iRadius, y - iRadius, x + iRadius, y + iRadius)
end
end;
if d < 0 then
begin
Inc(x, dXndg);
Inc(y, dYndg);
Inc(d, nDginc);
end
else
begin
Inc(x, dXdg);
Inc(y, dYdg);
Inc(d, diag_inc);
end
end
end {Line};
 
procedure TDIB.DoNovaEffect(sr, sg, sb, cx, cy, radius,
nspokes, randomhue, randomspok, randgauss: Integer; onProgress: TProgressEvent);
// Copyright (c) 2000 by Keith Murray (kmurray@hotfreeware.com)
// All rights reserved.
// Adapted for DIB by JB.
type
PByteArray = ^TByteArray;
TByteArray = array[0..32767] of Byte;
PDoubleArray = ^TDoubleArray;
TDoubleArray = array[0..32767] of Double;
PIntegerArray = ^TIntegerArray;
TIntegerArray = array[0..32767] of Integer;
type
TProgressEvent = procedure(progress: Integer; message: string;
var cancel: Boolean) of object;
const
M_PI = 3.14159265358979323846;
RAND_MAX = 2147483647;
 
function Gauss: double;
const magnitude = 6;
var
sum: double;
i: Integer;
begin
sum := 0;
for i := 1 to magnitude do
sum := sum + (randgauss / 2147483647);
result := sum / magnitude;
end;
 
function Clamp(i, l, h: double): double; {$IFDEF VER9UP}inline;{$ENDIF}
begin
if i < l then
result := l
else
if i > h then
result := h
else
result := i;
end;
 
function IClamp(i, l, h: Integer): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
begin
if i < l then
result := l
else if i > h then
result := h
else result := i;
end;
 
procedure rgb_to_hsl(r, g, b: Double; var h, s, l: Double); {$IFDEF VER9UP}inline;{$ENDIF}
{$IFNDEF VER4UP}
function Max(a, b: Double): Double;
begin
Result := a; if b > a then Result := b;
end;
function Min(a, b: Double): Double;
begin
Result := a; if b < a then Result := b;
end;
{$ENDIF}
var
v, m, vm: Double;
r2, g2, b2: Double;
begin
h := 0;
s := 0;
l := 0;
v := Max(r, g);
v := Max(v, b);
m := Min(r, g);
m := Min(m, b);
l := (m + v) / 2.0;
if l <= 0.0 then
exit;
vm := v - m;
s := vm;
if s > 0.0 then
begin
if l <= 0.5 then
s := s / (v + m)
else s := s / (2.0 - v - m);
end
else exit;
r2 := (v - 4) / vm;
g2 := (v - g) / vm;
b2 := (v - b) / vm;
if r = v then
begin
if g = m then
h := b2 + 5.0
else h := 1.0 - g2;
end
else if g = v then
begin
if b = m then
h := 1.0 + r2
else h := 3.0 - b2;
end
else
begin
if r = m then
h := 3.0 + g2
else h := 5.0 - r2;
end;
h := h / 6;
end;
 
procedure hsl_to_rgb(h, sl, l: Double; var r, g, b: Double); {$IFDEF VER9UP}inline;{$ENDIF}
var
v: Double;
m, sv: Double;
sextant: Integer;
fract, vsf, mid1, mid2: Double;
begin
if l <= 0.5 then
v := l * (1.0 + sl)
else v := l + sl - l * sl;
if v <= 0 then
begin
r := 0.0;
g := 0.0;
b := 0.0;
end
else
begin
m := l + l - v;
sv := (v - m) / v;
h := h * 6.0;
sextant := Trunc(h);
fract := h - sextant;
vsf := v * sv * fract;
mid1 := m + vsf;
mid2 := v - vsf;
case sextant of
0:
begin
r := v; g := mid1; b := m;
end;
1:
begin
r := mid2; g := v; b := m;
end;
2:
begin
r := m; g := v; b := mid1;
end;
3:
begin
r := m; g := mid2; b := v;
end;
4:
begin
r := mid1; g := m; b := v;
end;
5:
begin
r := v; g := m; b := mid2;
end;
end;
end;
end;
 
var
src_row, dest_row: PByte;
src, dest: PByteArray;
color, colors: array[0..3] of Integer;
SpokeColor: PIntegerArray;
spoke: PDoubleArray;
x1, y1, x2, y2, row, col, x, y, alpha, has_alpha, bpp, progress, max_progress, xc, yc, i, j: Integer;
u, v, l, l0, w, w1, c, nova_alpha, src_alpha, new_alpha, compl_ratio, ratio, r, g, b, h, s, lu, SpokeCol: Double;
dstDIB: TDIB;
begin
colors[0] := sr;
colors[1] := sg;
colors[2] := sb;
new_alpha := 0;
 
GetMem(spoke, NSpokes * sizeof(Double));
GetMem(spokecolor, NSpokes * sizeof(Integer) * 3);
dstDIB := TDIB.Create;
dstDIB.Assign(Self);
dstDIB.Canvas.Brush.Color := clBlack;
dstDIB.Canvas.FillRect(dstDIB.Canvas.ClipRect);
try
rgb_to_hsl(colors[0] / 255.0, colors[1] / 255.0, colors[2] / 255.0, h, s, lu);
 
for i := 0 to NSpokes - 1 do
begin
spoke[i] := gauss;
h := h + randomhue / 360.0 * ({Random(RAND_MAX)}RandomSpok / RAND_MAX - 0.5);
if h < 0 then
h := h + 1.0
else if h > 1.0 then
h := h - 1.0;
hsl_to_rgb(h, s, lu, r, g, b);
spokecolor[3 * i + 0] := Trunc(255 * r);
spokecolor[3 * i + 1] := Trunc(255 * g);
spokecolor[3 * i + 2] := Trunc(255 * b);
end;
 
xc := cx;
yc := cy;
l0 := (x2 - xc) / 4 + 1;
bpp := Self.BitCount div 8;
has_alpha := 0;
alpha := bpp;
y := 0;
for row := 0 to Self.Height - 1 do begin
src_row := Self.ScanLine[row];
dest_row := dstDIB.ScanLine[row];
src := Pointer(src_row);
dest := Pointer(dest_row);
x := 0;
for col := 0 to Self.Width - 1 do begin
u := (x - xc) / radius;
v := (y - yc) / radius;
l := sqrt((u * u) + (v * v));
c := (arctan2(u, v) / (2 * M_PI) + 0.51) * NSpokes;
i := floor(c);
c := c - i;
i := i mod NSpokes;
w1 := spoke[i] * (1 - c) + spoke[(i + 1) mod NSpokes] * c;
w1 := w1 * w1;
w := 1 / (l + 0.001) * 0.9;
nova_alpha := Clamp(w, 0.0, 1.0);
ratio := nova_alpha;
compl_ratio := 1.0 - ratio;
for j := 0 to alpha - 1 do
begin
spokecol := spokecolor[3 * i + j] * (1.0 - c) + spokecolor[3 * ((i + 1) mod nspokes) + j] * c;
if w > 1.0 then
color[j] := IClamp(Trunc(spokecol * w), 0, 255)
else
color[j] := Trunc(src[j] * compl_ratio + spokecol * ratio);
color[j] := Trunc(color[j] + 255 * Clamp(w1 * w, 0.0, 1.0));
dest[j] := IClamp(color[j], 0, 255);
end;
inc(Integer(src), bpp);
inc(Integer(dest), bpp);
inc(x);
end;
inc(y);
end;
finally
Self.Assign(dstDIB);
dstDIB.Free;
FreeMem(Spoke);
FreeMem(SpokeColor);
end;
end;
 
procedure TDIB.DrawMandelbrot(ao, au: Integer; bo, bu: Double);
var
c1, c2, z1, z2, tmp: Double;
i, j, Count: Integer;
dstDIB: TDIB;
X, Y: Double;
X2, Y2: Integer;
begin
dstDIB := TDIB.Create;
dstDIB.Assign(Self);
X2 := dstDIB.FWidth;
Y2 := dstDIB.FHeight;
{as Example
ao := 1;
au := -2;
bo := 1.5;
bu := -1.5;
}
X := (ao - au) / dstDIB.FWidth;
Y := (bo - bu) / dstDIB.FHeight;
try
c2 := bu;
for i := 10 to X2 do
begin
c1 := au;
for j := 0 to Y2 do
begin
z1 := 0;
z2 := 0;
Count := 0;
{count is deep of iteration of the mandelbrot set
if |z| >=2 then z is not a member of a mandelset}
while (((z1 * z1 + z2 * z2 < 4) and (Count <= 90))) do
begin
tmp := z1;
z1 := z1 * z1 - z2 * z2 + c1;
z2 := 2 * tmp * z2 + c2;
Inc(Count);
end;
//the color-palette depends on TColor(n*count mod t)
dstDIB.Canvas.Pixels[j, i] := (16 * Count mod 255);
c1 := c1 + X;
end;
c2 := c2 + Y;
end;
finally
Self.Assign(dstDIB);
dstDIB.Free;
end;
end;
 
procedure TDIB.SephiaEffect(Depth: Integer{$IFDEF VER4UP} = 20{$ENDIF});
{Note: when depth parameter set to 0 will produce black and white picture only}
var
color, color2: longint;
r, g, b, rr, gg: byte;
h, w: Integer;
p0: pbytearray;
x, y: Integer;
begin
if Self.BitCount = 24 then
begin
Self.DoGrayScale;
for y := 0 to Self.Height - 1 do
begin
p0 := Self.ScanLine[y];
for x := 0 to Self.Width - 1 do
begin
r := p0[x * 3];
g := p0[x * 3 + 1];
b := p0[x * 3 + 2];
rr := r + (depth * 2);
gg := g + depth;
if rr <= ((depth * 2) - 1) then
rr := 255;
if gg <= (depth - 1) then
gg := 255;
p0[x * 3] := rr;
p0[x * 3 + 1] := gg;
p0[x * 3 + 2] := b;
end;
end;
Exit
end;
{this alogorithm is slower because does not use scanline property}
for h := 0 to Self.Height-1 do
begin
for w := 0 to Self.Width-1 do
begin
//first convert the bitmap to greyscale
color := ColorToRGB(Self.Canvas.Pixels[w, h]);
r := GetRValue(color);
g := GetGValue(color);
b := GetBValue(color);
color2 := (r + g + b) div 3;
Self.Canvas.Pixels[w, h] := RGB(color2, color2, color2);
//then convert it to sepia
color := ColorToRGB(Self.Canvas.Pixels[w, h]);
r := GetRValue(color);
g := GetGValue(color);
b := GetBValue(color);
rr := r + (depth * 2);
gg := g + depth;
if rr <= ((depth * 2) - 1) then
rr := 255;
if gg <= (depth - 1) then
gg := 255;
Self.Canvas.Pixels[w, h] := RGB(rr, gg, b);
end;
end;
 
end;
 
procedure TDIB.EncryptDecrypt(const Key: Integer);
{for decript call it again}
var
BytesPorScan: Integer;
w, h: Integer;
p: pByteArray;
begin
try
BytesPorScan := Abs(Integer(Self.ScanLine[1]) -
Integer(Self.ScanLine[0]));
except
raise Exception.Create('Error ');
end;
RandSeed := Key;
for h := 0 to Self.Height - 1 do
begin
P := Self.ScanLine[h];
for w := 0 to BytesPorScan - 1 do
P^[w] := P^[w] xor Random(256);
end;
end;
 
procedure TDIB.LinePolar(x, y: Integer; AngleInDegree, Length: extended; Color: cardinal);
var
xp, yp: Integer;
begin
xp := Round(Sin(AngleInDegree * Pi / 180) * Length) + x;
yp := Round(Cos(AngleInDegree * Pi / 180) * Length) + y;
AntialiasedLine(x, y, xp, yp, Color);
end;
 
//y = 0.299*g + 0.587*b + 0.114*r;
 
procedure TDIB.BlendPixel(const X, Y: Integer; aColor: Cardinal; Alpha: byte);
var
cR, cG, cB: byte;
aR, aG, aB: byte;
dColor: Cardinal;
begin
aR := GetRValue(aColor);
aG := GetGValue(aColor);
aB := GetBValue(aColor);
dColor := Self.Canvas.Pixels[x, y];
cR := GetRValue(dColor);
cG := GetGValue(dColor);
cB := GetBValue(dColor);
Canvas.Pixels[x, y] := RGB((Alpha * (aR - cR) shr 8) + cR, // R alpha
(Alpha * (aG - cG) shr 8) + cG, // G alpha
(Alpha * (aB - cB) shr 8) + cB); // B alpha
end;
 
 
procedure MakeDib(out DIB: TDIB; const iWidth, iHeight, iBitCount: Integer; iFillColor: TColor{$IFDEF VER4UP} = clBlack{$ENDIF}); {$IFDEF VER4UP} overload; {$ENDIF}
begin
DIB := TDIB.Create;
DIB.SetSize(iWidth, iHeight, iBitCount);
DIB.Fill(iFillColor);
end;
 
procedure{$IFDEF VER4UP}MakeDib{$ELSE}MakeDib2{$ENDIF}(out DIB: TDIB; iBitmap: TBitmap); {$IFDEF VER4UP} overload; {$ENDIF}
begin
DIB := TDIB.Create;
if Assigned(iBitmap) then
DIB.CreateDIBFromBitmap(iBitmap)
else
DIB.Fill(clBlack);
end;
 
initialization
TPicture.RegisterClipBoardFormat(CF_DIB, TDIB);
TPicture.RegisterFileFormat('dib', 'Device Independent Bitmap', TDIB);
/VCL_DELPHIX_D6/DShow.pas
22,7 → 22,9
 
{$Z4}
{$A+}
{$IfNDef D7UP}
{$WEAKPACKAGEUNIT}
{$EndIf}
 
uses Windows, ActiveX, DirectX, MMSystem;
 
1887,10 → 1889,10
 
IDirectDrawMediaStream = interface(IMediaStream)
['{F4104FCE-9A70-11d0-8FDE-00C04FD9189D}']
function GetFormat(var pDDSDCurrent: DDSURFACEDESC;
function GetFormat(var pDDSDCurrent: TDDSURFACEDESC;
out ppDirectDrawPalette: IDirectDrawPalette;
var pDDSDDesired: DDSURFACEDESC; var pdwFlags: DWORD): HResult; stdcall;
function SetFormat(const pDDSurfaceDesc: DDSURFACEDESC;
var pDDSDDesired: TDDSURFACEDESC; var pdwFlags: DWORD): HResult; stdcall;
function SetFormat(const pDDSurfaceDesc: TDDSURFACEDESC;
pDirectDrawPalette: IDirectDrawPalette): HResult; stdcall;
function GetDirectDraw(out ppDirectDraw: IDirectDraw): HResult; stdcall;
function SetDirectDraw(pDirectDraw: IDirectDraw): HResult; stdcall;
2620,9 → 2622,9
// IDirectDrawVideo methods
function GetSwitches(var pSwitches: DWORD): HResult; stdcall;
function SetSwitches(pSwitches: DWORD): HResult; stdcall;
function GetCaps(var pCaps: DDCAPS): HResult; stdcall;
function GetEmulatedCaps(var pCaps: DDCAPS): HResult; stdcall;
function GetSurfaceDesc(var pSurfaceDesc: DDSURFACEDESC): HResult; stdcall;
function GetCaps(var pCaps: TDDCAPS): HResult; stdcall;
function GetEmulatedCaps(var pCaps: TDDCAPS): HResult; stdcall;
function GetSurfaceDesc(var pSurfaceDesc: TDDSURFACEDESC): HResult; stdcall;
function GetFourCCCodes(var pCount, pCodes: DWORD): HResult; stdcall;
function SetDirectDraw(pDirectDraw: IDirectDraw): HResult; stdcall;
function GetDirectDraw(out ppDirectDraw: IDirectDraw): HResult; stdcall;
3001,23 → 3003,23
// of structures. If the pointer to the array is NULL, first parameter
// returns the total number of formats supported.
function GetVideoFormats(var lpNumFormats: DWORD;
const lpddpfFormats: DDPIXELFORMAT): HResult; stdcall;
const lpddpfFormats: TDDPIXELFORMAT): HResult; stdcall;
 
// retrives maximum pixels per second rate expected for a given
// format and a given scaling factor. If decoder does not support
// those scaling factors, then it gives the rate and the nearest
// scaling factors.
function GetMaxPixelRate(const ddpfFormat: DDPIXELFORMAT;
function GetMaxPixelRate(const ddpfFormat: TDDPIXELFORMAT;
lpdwZoomHeight, lpdwZoomWidth: DWORD;
var lpdwMaxPixelsPerSecond: DWORD): HResult; stdcall;
 
// retrives various properties of the decoder for a given format
function GetVideoSignalInfo(const ddpfFormat: DDPIXELFORMAT;
function GetVideoSignalInfo(const ddpfFormat: TDDPIXELFORMAT;
var lpAMVideoSignalInfo: TAMVideoSignalInfo): HResult; stdcall;
 
// asks the decoder to ouput in this format. Return value should give
// appropriate error code
function SetVideoFormat(const ddpfFormat: DDPIXELFORMAT): HResult; stdcall;
function SetVideoFormat(const ddpfFormat: TDDPIXELFORMAT): HResult; stdcall;
 
// asks the decoder to treat even fields like odd fields and visa versa
function SetInvertPolarity: HResult; stdcall;
3185,13 → 3187,13
 
// informs the callee of the videoformats supported by the videoport
function InformVPInputFormats(dwNumFormats: DWORD;
const pDDPixelFormats: DDPIXELFORMAT): HResult; stdcall;
const pDDPixelFormats: TDDPIXELFORMAT): HResult; stdcall;
 
// gets the various formats supported by the decoder in an array
// of structures. If the pointer to the array is NULL, first parameter
// returns the total number of formats supported.
function GetVideoFormats(var pdwNumFormats: DWORD;
var pddPixelFormats: DDPIXELFORMAT): HResult; stdcall;
var pddPixelFormats: TDDPIXELFORMAT): HResult; stdcall;
 
// sets the format entry chosen (0, 1, .. ,(dwNumProposedEntries-1))
function SetVideoFormat(dwChosenEntry: DWORD): HResult; stdcall;
3269,10 → 3271,10
// this function gets the overlay surface that the mixer is using
function GetOverlaySurface(out ppOverlaySurface: IDirectDrawSurface): HResult; stdcall;
// this functions sets the color-controls, if the chip supports it.
function SetColorControls(const pColorControl: DDCOLORCONTROL): HResult; stdcall;
function SetColorControls(const pColorControl: TDDCOLORCONTROL): HResult; stdcall;
// this functions also returns the capability of the hardware in the dwFlags
// value of the struct.
function GetColorControls(var pColorControl: DDCOLORCONTROL): HResult; stdcall;
function GetColorControls(var pColorControl: TDDCOLORCONTROL): HResult; stdcall;
end;
 
// interface IVPVBINotify
/VCL_DELPHIX_D6/DXClass.pas
5,7 → 5,15
{$INCLUDE DelphiXcfg.inc}
 
uses
Windows, Messages, SysUtils, Classes, Controls, Forms, MMSystem, DirectX;
Windows, Messages, SysUtils, Classes, Controls, Forms, MMSystem, Graphics, {$IFDEF _DMO_}MultiMon,{$ENDIF}
{$IfDef StandardDX}
{$IfDef DX9}
Direct3D, DirectInput,
{$EndIf}
DirectDraw, DirectSound;
{$Else}
DirectX;
{$EndIf}
 
type
 
50,6 → 58,46
property Drivers[Index: Integer]: TDirectXDriver read GetDriver; default;
end;
 
{$IFDEF _DMO_}
{ TDirectXDriverEx }
 
TDirectXDriverEx = class(TCollectionItem)
private
FGUID: PGUID;
FGUID2: TGUID;
FDescription: string;
FDriverName: string;
FMonitor: HMonitor;
FMonitorInfo: TMonitorInfo;
procedure SetGUID(Value: PGUID);
function ConvertHMonitor(iMonitor: HMonitor): TMonitorInfo;
function GetMonitorInfo: TMonitorInfo;
function GetFlags: DWORD;
function GetTempSpace: TRect;
function GetWorkSpace: TRect;
public
property GUID: PGUID read FGUID write SetGUID;
property Monitor: HMonitor read FMonitor write FMonitor;
property MonitorInfo: TMonitorInfo read GetMonitorInfo;
published
property Description: string read FDescription write FDescription;
property DriverName: string read FDriverName write FDriverName;
property WorkSpace: TRect read GetWorkSpace;
property TempSpace: TRect read GetTempSpace;
property Flags: DWORD read GetFlags;
end;
 
{ TDirectXDriversEx }
 
TDirectXDriversEx = class(TCollection)
private
function GetDriver(Index: Integer): TDirectXDriverEx;
public
constructor Create;
property Drivers[Index: Integer]: TDirectXDriverEx read GetDriver; default;
end;
{$ENDIF}
{ TDXForm }
 
TDXForm = class(TForm)
170,20 → 218,137
function IndexOf(const Name: string): Integer;
end;
 
function Max(Val1, Val2: Integer): Integer;
function Min(Val1, Val2: Integer): Integer;
{Addapted from RXLib.PicClip}
 
{ TPicClip }
TCellRange = 1..MaxInt;
 
TDXPictureClip = class(TComponent)
private
FPicture: TPicture;
FRows: TCellRange;
FCols: TCellRange;
FBitmap: TBitmap;
FMasked: Boolean;
FMaskColor: TColor;
FOnChange: TNotifyEvent;
procedure CheckIndex(Index: Integer);
function GetCell(Col, Row: Cardinal): TBitmap;
function GetGraphicCell(Index: Integer): TBitmap;
function GetDefaultMaskColor: TColor;
function GetIsEmpty: Boolean;
function GetCount: Integer;
function GetHeight: Integer;
function GetWidth: Integer;
function IsMaskStored: Boolean;
procedure PictureChanged(Sender: TObject);
procedure SetHeight(Value: Integer);
procedure SetPicture(Value: TPicture);
procedure SetWidth(Value: Integer);
procedure SetMaskColor(Value: TColor);
protected
procedure AssignTo(Dest: TPersistent); override;
procedure Changed; dynamic;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
function GetIndex(Col, Row: Cardinal): Integer;
procedure Draw(Canvas: TCanvas; X, Y, Index: Integer);
procedure DrawCenter(Canvas: TCanvas; Rect: TRect; Index: Integer);
property Cells[Col, Row: Cardinal]: TBitmap read GetCell;
property GraphicCell[Index: Integer]: TBitmap read GetGraphicCell;
property IsEmpty: Boolean read GetIsEmpty;
property Count: Integer read GetCount;
published
property Cols: TCellRange read FCols write FCols default 1;
property Height: Integer read GetHeight write SetHeight stored False;
property Masked: Boolean read FMasked write FMasked default True;
property Rows: TCellRange read FRows write FRows default 1;
property Picture: TPicture read FPicture write SetPicture;
property MaskColor: TColor read FMaskColor write SetMaskColor stored IsMaskStored;
property Width: Integer read GetWidth write SetWidth stored False;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
end;
 
function Max(Val1, Val2: Integer): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
function Min(Val1, Val2: Integer): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
 
function Cos256(i: Integer): Double;
function Sin256(i: Integer): Double;
 
function PointInRect(const Point: TPoint; const Rect: TRect): Boolean;
function RectInRect(const Rect1, Rect2: TRect): Boolean;
function OverlapRect(const Rect1, Rect2: TRect): Boolean;
function PointInRect(const Point: TPoint; const Rect: TRect): Boolean; {$IFDEF VER9UP}inline;{$ENDIF}
function RectInRect(const Rect1, Rect2: TRect): Boolean; {$IFDEF VER9UP}inline;{$ENDIF}
function OverlapRect(const Rect1, Rect2: TRect): Boolean; {$IFDEF VER9UP}inline;{$ENDIF}
 
function WideRect(ALeft, ATop, AWidth, AHeight: Integer): TRect;
function WideRect(ALeft, ATop, AWidth, AHeight: Integer): TRect; {$IFDEF VER9UP}inline;{$ENDIF}
 
{ Transformations routines}
 
const
L_Curve = 0;//The left curve
R_Curve = 1;//The right curve
 
C_Add = 0;//Increase (BTC)
C_Dec = 1;//Decrease (ETC)
 
Type
TDblPoint = packed record
X, Y: Double;
end;
TSngPoint = packed record //SinglePoint
X, Y: Single;
end;
 
 
//Transformation matrix
T2DRowCol = Array[1..3] of Array[1..3] of Double;
T2DVector = Array[1..3] of Double;
//Distance between 2 points
function Get2PointRange(a,b: TDblPoint):Double;
//From vector angular calculation
function Get256(dX,dY: Double):Double;
//The angular calculation of the A from B
function GetARadFromB(A,B: TDblPoint):Double;
 
//It calculates the TDblPoint
function DblPoint(a,b:Double):TDblPoint;
//It converts the TDboPoint to the TPoint
function TruncDblPoint(DblPos: TDblPoint): TPoint;
 
function GetPointFromRangeAndAngle(SP: TDblPoint; Range,Angle: Double): TDblPoint;
 
function Ini2DRowCol: T2DRowCol;
function Trans2DRowCol(x,y:double):T2DRowCol;
function Scale2DRowCol(x,y:double):T2DRowCol;
function Rotate2DRowCol(Theta:double):T2DRowCol;
function RotateIntoX2DRowCol(x,y: double):T2DRowCol;
function Multiply2DRowCol(A,B:T2DRowCol):T2DRowCol;
function ScaleAt2DRowCol(x,y,Sx,Sy:double):T2DRowCol;
function ReflectAcross2DRowCol(x,y,dx,dy:Double): T2DRowCol;
function Apply2DVector(V:T2DVector; M:T2DRowCol): T2DVector;
function RotateAround2DRowCol(x,y,Theta:Double): T2DRowCol;
 
//Collision decision
function PointInCircle(PPos,CPos: TPoint; R: integer): Boolean;
function CircleInCircle(C1Pos,C2Pos: TPoint; R1,R2:Integer): Boolean;
function SegmentInCircle(SPos,EPos,CPos: TPoint; R: Integer): Boolean;
 
//If A is closer than B from starting point S, the True is returned.
function CheckNearAThanB(S,A,B: TDblPoint): Boolean;
 
//The Angle of 256 period is returned
function Angle256(Angle: Single): Single;
 
{ Support functions }
 
procedure ReleaseCom(out Com);
function DXLoadLibrary(const FileName, FuncName: string): TFarProc;
 
{ Simple helper }
 
procedure Log(const Co: string; const FName: string{$IFDEF VER4UP} = 'c:\logerr.txt'{$ENDIF});
 
implementation
 
uses DXConsts;
690,8 → 855,763
Result := -1;
end;
 
{ TDXPictureClip }
 
constructor TDXPictureClip.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FPicture := TPicture.Create;
FPicture.OnChange := PictureChanged;
FBitmap := TBitmap.Create;
FRows := 1;
FCols := 1;
FMaskColor := GetDefaultMaskColor;
FMasked := True;
end;
 
destructor TDXPictureClip.Destroy;
begin
FOnChange := nil;
FPicture.OnChange := nil;
FBitmap.Free;
FPicture.Free;
inherited Destroy;
end;
 
procedure TDXPictureClip.Assign(Source: TPersistent);
begin
if Source is TDXPictureClip then begin
with TDXPictureClip(Source) do begin
Self.FRows := Rows;
Self.FCols := Cols;
Self.FMasked := Masked;
Self.FMaskColor := MaskColor;
Self.FPicture.Assign(FPicture);
end;
end
else if (Source is TPicture) or (Source is TGraphic) then
FPicture.Assign(Source)
else inherited Assign(Source);
end;
 
type
THack = class(TImageList);
 
procedure TDXPictureClip.AssignTo(Dest: TPersistent);
var
I: Integer;
SaveChange: TNotifyEvent;
begin
if (Dest is TPicture) then Dest.Assign(FPicture)
else if (Dest is TImageList) and not IsEmpty then begin
with TImageList(Dest) do begin
SaveChange := OnChange;
try
OnChange := nil;
Clear;
Width := Self.Width;
Height := Self.Height;
for I := 0 to Self.Count - 1 do begin
if Self.Masked and (MaskColor <> clNone) then
TImageList(Dest).AddMasked(GraphicCell[I], MaskColor)
else TImageList(Dest).Add(GraphicCell[I], nil);
end;
Masked := Self.Masked;
finally
OnChange := SaveChange;
end;
THack(Dest).Change;
end;
end
else inherited AssignTo(Dest);
end;
 
procedure TDXPictureClip.Changed;
begin
if Assigned(FOnChange) then FOnChange(Self);
end;
 
function TDXPictureClip.GetIsEmpty: Boolean;
begin
Result := not Assigned(Picture) or Picture.Graphic.Empty;
end;
 
function TDXPictureClip.GetCount: Integer;
begin
if IsEmpty then Result := 0
else Result := Cols * Rows;
end;
const
{ TBitmap.GetTransparentColor from GRAPHICS.PAS uses this value }
PaletteMask = $02000000;
 
procedure TDXPictureClip.Draw(Canvas: TCanvas; X, Y, Index: Integer);
 
function PaletteColor(Color: TColor): Longint;
begin
Result := ColorToRGB(Color) or PaletteMask;
end;
procedure StretchBltTransparent(DstDC: HDC; DstX, DstY, DstW, DstH: Integer;
SrcDC: HDC; SrcX, SrcY, SrcW, SrcH: Integer; Palette: HPalette;
TransparentColor: TColorRef);
var
Color: TColorRef;
bmAndBack, bmAndObject, bmAndMem, bmSave: HBitmap;
bmBackOld, bmObjectOld, bmMemOld, bmSaveOld: HBitmap;
MemDC, BackDC, ObjectDC, SaveDC: HDC;
palDst, palMem, palSave, palObj: HPalette;
begin
{ Create some DCs to hold temporary data }
BackDC := CreateCompatibleDC(DstDC);
ObjectDC := CreateCompatibleDC(DstDC);
MemDC := CreateCompatibleDC(DstDC);
SaveDC := CreateCompatibleDC(DstDC);
{ Create a bitmap for each DC }
bmAndObject := CreateBitmap(SrcW, SrcH, 1, 1, nil);
bmAndBack := CreateBitmap(SrcW, SrcH, 1, 1, nil);
bmAndMem := CreateCompatibleBitmap(DstDC, DstW, DstH);
bmSave := CreateCompatibleBitmap(DstDC, SrcW, SrcH);
{ Each DC must select a bitmap object to store pixel data }
bmBackOld := SelectObject(BackDC, bmAndBack);
bmObjectOld := SelectObject(ObjectDC, bmAndObject);
bmMemOld := SelectObject(MemDC, bmAndMem);
bmSaveOld := SelectObject(SaveDC, bmSave);
{ Select palette }
palDst := 0; palMem := 0; palSave := 0; palObj := 0;
if Palette <> 0 then begin
palDst := SelectPalette(DstDC, Palette, True);
RealizePalette(DstDC);
palSave := SelectPalette(SaveDC, Palette, False);
RealizePalette(SaveDC);
palObj := SelectPalette(ObjectDC, Palette, False);
RealizePalette(ObjectDC);
palMem := SelectPalette(MemDC, Palette, True);
RealizePalette(MemDC);
end;
{ Set proper mapping mode }
SetMapMode(SrcDC, GetMapMode(DstDC));
SetMapMode(SaveDC, GetMapMode(DstDC));
{ Save the bitmap sent here }
BitBlt(SaveDC, 0, 0, SrcW, SrcH, SrcDC, SrcX, SrcY, SRCCOPY);
{ Set the background color of the source DC to the color, }
{ contained in the parts of the bitmap that should be transparent }
Color := SetBkColor(SaveDC, PaletteColor(TransparentColor));
{ Create the object mask for the bitmap by performing a BitBlt() }
{ from the source bitmap to a monochrome bitmap }
BitBlt(ObjectDC, 0, 0, SrcW, SrcH, SaveDC, 0, 0, SRCCOPY);
{ Set the background color of the source DC back to the original }
SetBkColor(SaveDC, Color);
{ Create the inverse of the object mask }
BitBlt(BackDC, 0, 0, SrcW, SrcH, ObjectDC, 0, 0, NOTSRCCOPY);
{ Copy the background of the main DC to the destination }
BitBlt(MemDC, 0, 0, DstW, DstH, DstDC, DstX, DstY, SRCCOPY);
{ Mask out the places where the bitmap will be placed }
StretchBlt(MemDC, 0, 0, DstW, DstH, ObjectDC, 0, 0, SrcW, SrcH, SRCAND);
{ Mask out the transparent colored pixels on the bitmap }
BitBlt(SaveDC, 0, 0, SrcW, SrcH, BackDC, 0, 0, SRCAND);
{ XOR the bitmap with the background on the destination DC }
StretchBlt(MemDC, 0, 0, DstW, DstH, SaveDC, 0, 0, SrcW, SrcH, SRCPAINT);
{ Copy the destination to the screen }
BitBlt(DstDC, DstX, DstY, DstW, DstH, MemDC, 0, 0,
SRCCOPY);
{ Restore palette }
if Palette <> 0 then begin
SelectPalette(MemDC, palMem, False);
SelectPalette(ObjectDC, palObj, False);
SelectPalette(SaveDC, palSave, False);
SelectPalette(DstDC, palDst, True);
end;
{ Delete the memory bitmaps }
DeleteObject(SelectObject(BackDC, bmBackOld));
DeleteObject(SelectObject(ObjectDC, bmObjectOld));
DeleteObject(SelectObject(MemDC, bmMemOld));
DeleteObject(SelectObject(SaveDC, bmSaveOld));
{ Delete the memory DCs }
DeleteDC(MemDC);
DeleteDC(BackDC);
DeleteDC(ObjectDC);
DeleteDC(SaveDC);
end;
procedure StretchBitmapTransparent(Dest: TCanvas; Bitmap: TBitmap;
TransparentColor: TColor; DstX, DstY, DstW, DstH, SrcX, SrcY,
SrcW, SrcH: Integer);
var
CanvasChanging: TNotifyEvent;
begin
if DstW <= 0 then DstW := Bitmap.Width;
if DstH <= 0 then DstH := Bitmap.Height;
if (SrcW <= 0) or (SrcH <= 0) then begin
SrcX := 0; SrcY := 0;
SrcW := Bitmap.Width;
SrcH := Bitmap.Height;
end;
if not Bitmap.Monochrome then
SetStretchBltMode(Dest.Handle, STRETCH_DELETESCANS);
CanvasChanging := Bitmap.Canvas.OnChanging;
Bitmap.Canvas.Lock;
try
Bitmap.Canvas.OnChanging := nil;
if TransparentColor = clNone then begin
StretchBlt(Dest.Handle, DstX, DstY, DstW, DstH, Bitmap.Canvas.Handle,
SrcX, SrcY, SrcW, SrcH, Dest.CopyMode);
end
else begin
if TransparentColor = clDefault then
TransparentColor := Bitmap.Canvas.Pixels[0, Bitmap.Height - 1];
if Bitmap.Monochrome then TransparentColor := clWhite
else TransparentColor := ColorToRGB(TransparentColor);
StretchBltTransparent(Dest.Handle, DstX, DstY, DstW, DstH,
Bitmap.Canvas.Handle, SrcX, SrcY, SrcW, SrcH, Bitmap.Palette,
TransparentColor);
end;
finally
Bitmap.Canvas.OnChanging := CanvasChanging;
Bitmap.Canvas.Unlock;
end;
end;
procedure DrawBitmapTransparent(Dest: TCanvas; DstX, DstY: Integer;
Bitmap: TBitmap; TransparentColor: TColor);
begin
StretchBitmapTransparent(Dest, Bitmap, TransparentColor, DstX, DstY,
Bitmap.Width, Bitmap.Height, 0, 0, Bitmap.Width, Bitmap.Height);
end;
var
Image: TGraphic;
begin
if Index < 0 then Image := Picture.Graphic
else Image := GraphicCell[Index];
if (Image <> nil) and not Image.Empty then begin
if FMasked and (FMaskColor <> clNone) and
(Picture.Graphic is TBitmap) then
DrawBitmapTransparent(Canvas, X, Y, TBitmap(Image), FMaskColor)
else Canvas.Draw(X, Y, Image);
end;
end;
 
procedure TDXPictureClip.DrawCenter(Canvas: TCanvas; Rect: TRect; Index: Integer);
var
X, Y: Integer;
begin
X := (Rect.Left + Rect.Right - Width) div 2;
Y := (Rect.Bottom + Rect.Top - Height) div 2;
Draw(Canvas, X, Y, Index);
end;
 
procedure TDXPictureClip.CheckIndex(Index: Integer);
begin
if (Index >= Cols * Rows) or (Index < 0) then
raise EListError.CreateFmt('%s (%d)', ['Load list error', Index]);
end;
 
function TDXPictureClip.GetIndex(Col, Row: Cardinal): Integer;
begin
Result := Col + (Row * Cols);
if (Result >= Cols * Rows) or IsEmpty then Result := -1;
end;
 
function TDXPictureClip.GetCell(Col, Row: Cardinal): TBitmap;
begin
Result := GetGraphicCell(GetIndex(Col, Row));
end;
 
function TDXPictureClip.GetGraphicCell(Index: Integer): TBitmap;
procedure AssignBitmapCell(Source: TGraphic; Dest: TBitmap; Cols, Rows,
Index: Integer);
var
CellWidth, CellHeight: Integer;
begin
if (Source <> nil) and (Dest <> nil) then begin
if Cols <= 0 then Cols := 1;
if Rows <= 0 then Rows := 1;
if Index < 0 then Index := 0;
CellWidth := Source.Width div Cols;
CellHeight := Source.Height div Rows;
with Dest do begin
Width := CellWidth; Height := CellHeight;
end;
if Source is TBitmap then begin
Dest.Canvas.CopyRect(Bounds(0, 0, CellWidth, CellHeight),
TBitmap(Source).Canvas, Bounds((Index mod Cols) * CellWidth,
(Index div Cols) * CellHeight, CellWidth, CellHeight));
Dest.TransparentColor := TBitmap(Source).TransparentColor;
end
else begin
Dest.Canvas.Brush.Color := clSilver;
Dest.Canvas.FillRect(Bounds(0, 0, CellWidth, CellHeight));
Dest.Canvas.Draw(-(Index mod Cols) * CellWidth,
-(Index div Cols) * CellHeight, Source);
end;
Dest.Transparent := Source.Transparent;
end;
end;
begin
CheckIndex(Index);
AssignBitmapCell(Picture.Graphic, FBitmap, Cols, Rows, Index);
if Picture.Graphic is TBitmap then
if FBitmap.PixelFormat <> pfDevice then
FBitmap.PixelFormat := TBitmap(Picture.Graphic).PixelFormat;
FBitmap.TransparentColor := FMaskColor or PaletteMask;
FBitmap.Transparent := (FMaskColor <> clNone) and Masked;
Result := FBitmap;
end;
 
function TDXPictureClip.GetDefaultMaskColor: TColor;
begin
Result := clOlive;
if (Picture.Graphic <> nil) and (Picture.Graphic is TBitmap) then
Result := TBitmap(Picture.Graphic).TransparentColor and
not PaletteMask;
end;
 
function TDXPictureClip.GetHeight: Integer;
begin
Result := Picture.Height div FRows;
end;
 
function TDXPictureClip.GetWidth: Integer;
begin
Result := Picture.Width div FCols;
end;
 
function TDXPictureClip.IsMaskStored: Boolean;
begin
Result := MaskColor <> GetDefaultMaskColor;
end;
 
procedure TDXPictureClip.SetMaskColor(Value: TColor);
begin
if Value <> FMaskColor then begin
FMaskColor := Value;
Changed;
end;
end;
 
procedure TDXPictureClip.PictureChanged(Sender: TObject);
begin
FMaskColor := GetDefaultMaskColor;
if not (csReading in ComponentState) then Changed;
end;
 
procedure TDXPictureClip.SetHeight(Value: Integer);
begin
if (Value > 0) and (Picture.Height div Value > 0) then
Rows := Picture.Height div Value;
end;
 
procedure TDXPictureClip.SetWidth(Value: Integer);
begin
if (Value > 0) and (Picture.Width div Value > 0) then
Cols := Picture.Width div Value;
end;
 
procedure TDXPictureClip.SetPicture(Value: TPicture);
begin
FPicture.Assign(Value);
end;
 
{ Transformations routines }
{ Authorisation: Mr. Takanori Kawasaki}
 
//Distance between 2 points is calculated
function Get2PointRange(a,b: TDblPoint):Double;
var
x,y: Double;
begin
x := a.X - b.X;
y := a.Y - b.Y;
Result := Sqrt(x*x+y*y);
end;
 
//Direction angle in the coordinate A which was seen from coordinate B is calculated
function GetARadFromB(A,B: TDblPoint):Double;
var
dX,dY: Double;
begin
dX := A.X - B.X;
dY := A.Y - B.Y;
Result := Get256(dX,dY);
end;
 
//Direction angle is returned with 0 - 255.
function Get256(dX,dY:Double):Double;
begin
Result := 0;
if dX > 0 then
begin//0-63
if dY > 0 then Result := ArcTan(dY / dX) // 0 < Res < 90
else//0
if dY = 0 then Result := 0 // 0
else//192-255
if dY < 0 then Result := 2*Pi + ArcTan(dY / dX) // 270 < Res < 360
end else
if dX = 0 then
begin//64
if dY > 0 then Result := 1 / 2 * Pi // 90
else//0
if dY = 0 then Result := 0 // 0
else//192
if dY < 0 then Result := 3 / 2 * Pi // 270
end else
if dX < 0 then
begin//64-127
if dY > 0 then Result := Pi + ArcTan(dY / dX) // 90 < Res < 180
else//128
if dY = 0 then Result := Pi // 180
else//128-191
if dY < 0 then Result := Pi + ArcTan(dY / dX) // 180 < Res < 270
end;
Result := 256 * Result / (2*Pi);
end;
 
//From the coordinate SP the Range it calculates the point which leaves with the angular Angle
function GetPointFromRangeAndAngle(SP: TDblPoint; Range,Angle: Double): TDblPoint;
begin
Result.X := SP.X + Range * Cos(Angle);
Result.Y := SP.Y + Range * Sin(Angle);
end;
 
//* As for coordinate transformation coordinate for mathematics is used
//Identity matrix for the 2d is returned.
function Ini2DRowCol: T2DRowCol;
var
i,ii:integer;
begin
for i := 1 to 3 do
for ii := 1 to 3 do
if i = ii then Result[i,ii] := 1 else Result[i,ii] := 0;
end;
 
//Transformation matrix of the portable quantity
//where the one for 2d is appointed is returned.
function Trans2DRowCol(x,y:double):T2DRowCol;
begin
Result := Ini2DRowCol;
Result[3,1] := x;
Result[3,2] := y;
end;
 
//Conversion coordinate of the expansion and contraction
//quantity where the one for 2d is appointed is returned.
function Scale2DRowCol(x,y:double):T2DRowCol;
begin
Result := Ini2DRowCol;
Result[1,1] := x;
Result[2,2] := y;
end;
 
//Coordinate transformation of the rotary quantity
//where the one for 2d is appointed is returned.
function Rotate2DRowCol(Theta:double):T2DRowCol;
begin
Result := Ini2DRowCol;
Result[1,1] := Cos256(Trunc(Theta));
Result[1,2] := Sin256(Trunc(Theta));
Result[2,1] := -1 * Result[1,2];
Result[2,2] := Result[1,1];
end;
 
//You apply two conversion coordinates and adjust.
function Multiply2DRowCol(A,B:T2DRowCol):T2DRowCol;
begin
Result[1,1] := A[1,1] * B[1,1] + A[1,2] * B[2,1];
Result[1,2] := A[1,1] * B[1,2] + A[1,2] * B[2,2];
Result[1,3] := 0;
Result[2,1] := A[2,1] * B[1,1] + A[2,2] * B[2,1];
Result[2,2] := A[2,1] * B[1,2] + A[2,2] * B[2,2];
Result[2,3] := 0;
Result[3,1] := A[3,1] * B[1,1] + A[3,2] * B[2,1] + B[3,1];
Result[3,2] := A[3,1] * B[1,2] + A[3,2] * B[2,2] + B[3,2];
Result[3,3] := 1;
end;
 
//Until coordinate (the X and the Y) comes on the X axis,
//the conversion coordinate which turns the position
//of the point is returned.
function RotateIntoX2DRowCol(x,y: double):T2DRowCol;
var
d: double;
begin
Result := Ini2DRowCol;
d := sqrt(x*x+y*y);
Result[1,1] := x / d;
Result[1,2] := y / d;
Result[2,1] := -1 * Result[1,2];
Result[2,2] := Result[1,1];
end;
 
//Coordinate (the X and the Y) as a center, the conversion
//coordinate which does the scaling of the magnification ratio
//which is appointed with the Sx and the Sy is returned.
function ScaleAt2DRowCol(x,y,Sx,Sy:double):T2DRowCol;
var
T,S,TInv,M:T2DRowCol;
begin
T := Trans2DRowCol(-x,-y);
TInv := Trans2DRowCol(x,y);
S := Scale2DRowCol(Sx,Sy);
M := Multiply2DRowCol(T,S);
Result := Multiply2DRowCol(M,T);
end;
 
//Coordinate (the X and the Y) it passes, comes hard and
//(DX and the dy) with the direction which is shown it
//returns the transformation matrix which does the reflected
//image conversion which centers the line which faces.
function ReflectAcross2DRowCol(x,y,dx,dy:Double): T2DRowCol;
var
T,R,S,RInv,TInv,M1,M2,M3: T2DRowCol;
begin
T := Trans2DRowCol(-x,-y);
TInv := Trans2DRowCol(x,y);
R := RotateIntoX2DRowCol(dx,dy);
RInv := RotateIntoX2DRowCol(dx,-dy);
S := Scale2DRowCol(1,-1);
M1 := Multiply2DRowCol(T,R);
M2 := Multiply2DRowCol(S,RInv);
M3 := Multiply2DRowCol(M1,M2);
Result := Multiply2DRowCol(M3,TInv);
end;
 
//Coordinate focusing on (the X and the Y) the transformation
//matrix which turns the position of the point with angle Theta is returned.
function RotateAround2DRowCol(x,y,Theta:Double): T2DRowCol;
var
T,R,TInv,M: T2DRowCol;
begin
T := Trans2DRowCol(-x,-y);
TInv := Trans2DRowCol(x,y);
R := Rotate2DRowCol(Theta);
M := Multiply2DRowCol(T,R);
Result := Multiply2DRowCol(M,TInv);
end;
 
//Transformation matrix is applied to the point.
function Apply2DVector(V:T2DVector; M:T2DRowCol): T2DVector;
begin
Result[1] := V[1] * M[1,1] + V[2] * M[2,1] + M[3,1];
Result[2] := V[1] * M[1,2] + V[2] * M[2,2] + M[3,2];
Result[3] := 1;
end;
 
//The TDblPoint is returned
function DblPoint(a,b:Double):TDblPoint;
begin
Result.X := a;
Result.Y := b;
end;
 
function TruncDblPoint(DblPos: TDblPoint): TPoint;
begin
Result.X := Trunc(DblPos.X);
Result.Y := Trunc(DblPos.Y);
end;
{
+-----------------------------------------------------------------------------+
|Collision decision |
+-----------------------------------------------------------------------------+}
 
//Point and circle
function PointInCircle(PPos,CPos: TPoint; R: integer): Boolean;
begin
Result := (PPos.X - CPos.X)*(PPos.X - CPos.X)+(PPos.Y - CPos.Y)*(PPos.Y - CPos.Y)<= R*R;
end;
 
//Circle and circle
function CircleInCircle(C1Pos,C2Pos: TPoint; R1,R2:Integer): Boolean;
begin
Result := (C1Pos.X - C2Pos.X)*(C1Pos.X - C2Pos.X)+(C1Pos.Y - C2Pos.Y)*(C1Pos.Y - C2Pos.Y) <= (R1+R2)*(R1+R2);
end;
 
//Circle and line segment
function SegmentInCircle(SPos,EPos,CPos: TPoint; R: Integer): Boolean;
var
V,C: TPoint;
VC,VV,CC:integer;
begin
Result := False;
V.X := EPos.X - SPos.X; V.Y := EPos.Y - SPos.Y;
C.X := CPos.X - SPos.X; C.Y := CPos.Y - SPos.Y;
VC := V.X * C.X + V.Y * C.Y;
if VC < 0 then
begin
Result := (C.X * C.X + C.Y * C.Y) <= R*R;
end
else
begin
VV := V.X * V.X + V.Y * V.Y;
if VC >= VV then
begin
Result := (EPos.X - CPos.X)*(EPos.X - CPos.X)+(EPos.Y - CPos.Y)*(EPos.Y - CPos.Y) <= R * R;
end
else
if VC < VV then
begin
CC := C.X * C.X + C.Y * C.Y;
Result := CC - (VC div VV)* VC <= R*R;
end;
end;
end;
 
//Angle recalc
function Angle256(Angle: Single): Single;
begin
Result := Angle;
While Result < 0 do Result := Result + 256;
While Result >= 256 do Result := Result -256;
end;
 
//If A is closer than B from starting point S, the True is returned.
function CheckNearAThanB(S,A,B: TDblPoint): Boolean;
begin
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);
end;
 
function CircumCenter3Pt(const x1, y1, x2, y2, x3, y3: Single; out Px, Py: Single): Boolean;
var
A,B,C,D,E,F,G: Single;
begin
A := x2 - x1;
B := y2 - y1;
C := x3 - x1;
D := y3 - y1;
E := A * (x1 + x2) + B * (y1 + y2);
F := C * (x1 + x3) + D * (y1 + y3);
G := 2.0 * (A * (y3 - y2) - B * (x3 - x2));
Result := G <> 0.0;
if Result then begin
Px := (D * E - B * F) / G;
Py := (A * F - C * E) / G;
end;
end;
 
function Distance(const x1, y1, x2, y2: Double): Double;
begin
Result := Sqrt(Sqr(y2 - y1) + Sqr(x2 - x1));
end;
 
procedure InCenter(const x1, y1, x2, y2, x3, y3: Double; out Px, Py: Double);
var
Perim: Double;
Side12: Double;
Side23: Double;
Side31: Double;
begin
Side12 := Distance(x1, y1, x2, y2);
Side23 := Distance(x2, y2, x3, y3);
Side31 := Distance(x3, y3, x1, y1);
{ Using Heron's S=UR }
Perim := 1.0 / (Side12 + Side23 + Side31);
Px := (Side23 * x1 + Side31 * x2 + Side12 * x3) * Perim;
Py := (Side23 * y1 + Side31 * y2 + Side12 * y3) * Perim;
end;
 
function PointInTriangle(const Px, Py, x1, y1, x2, y2, x3, y3: Double): Boolean;
function Orientation(const x1, y1, x2, y2, Px, Py: Double): Integer;
var
Orin: Double;
begin
(* Linear determinant of the 3 points *)
Orin := (x2 - x1) * (py - y1) - (px - x1) * (y2 - y1);
 
if Orin > 0.0 then
Result := +1 (* Orientaion is to the right-hand side *)
else if Orin < 0.0 then
Result := -1 (* Orientaion is to the left-hand side *)
else
Result := 0; (* Orientaion is neutral aka collinear *)
end;
var
Or1, Or2, Or3: Integer;
begin
Or1 := Orientation(x1, y1, x2, y2, Px, Py);
Or2 := Orientation(x2, y2, x3, y3, Px, Py);
Or3 := Orientation(x3, y3, x1, y1, Px, Py);
 
if (Or1 = Or2) and (Or2 = Or3) then
Result := True
else if Or1 = 0 then
Result := (Or2 = 0) or (Or3 = 0)
else if Or2 = 0 then
Result := (Or1 = 0) or (Or3 = 0)
else if Or3 = 0 then
Result := (Or2 = 0) or (Or1 = 0)
else
Result := False;
end;
 
procedure Log(const Co: string; const FName: string);
var F: Text; D: TDateTime;
Hour, Minute, Second, MSec: Word;
begin
AsSignFile(F, FName);
if FileExists(FName) then Append(F)
else ReWrite(F);
try
D := Now;
DecodeTime(D, Hour, Minute, Second, MSec);
WriteLn(F, DateToStr(D) + ' ' + IntToStr(Hour)+':'+IntToStr(Minute)+':'+IntToStr(Second)+ '.'+IntToStr(MSec) +' ' + Co);
finally
CloseFile(F);
end;
end;
 
{$IFDEF _DMO_}
 
{ TDirectXDriverEx }
 
function TDirectXDriverEx.ConvertHMonitor(iMonitor: HMonitor): TMonitorInfo;
begin
ZeroMemory(@Result, sizeof(Result));
Result.cbSize := SizeOf(Result);
MultiMon.GetMonitorInfo(iMonitor, @Result);
end;
 
function TDirectXDriverEx.GetFlags: DWORD;
begin
Result := ConvertHMonitor(FMonitor).dwFlags;
end;
 
function TDirectXDriverEx.GetMonitorInfo: TMonitorInfo;
begin
Result:= ConvertHMonitor(FMonitor);
end;
 
function TDirectXDriverEx.GetTempSpace: TRect;
begin
Result := ConvertHMonitor(FMonitor).rcWork
end;
 
function TDirectXDriverEx.GetWorkSpace: TRect;
begin
Result := ConvertHMonitor(FMonitor).rcMonitor
end;
 
procedure TDirectXDriverEx.SetGUID(Value: PGUID);
begin
if not IsBadHugeReadPtr(Value, SizeOf(TGUID)) then
begin
FGUID2 := Value^;
FGUID := @FGUID2;
end else
FGUID := Value;
end;
 
{ TDirectXDriversEx }
 
constructor TDirectXDriversEx.Create;
begin
inherited Create(TDirectXDriverEx);
end;
 
function TDirectXDriversEx.GetDriver(Index: Integer): TDirectXDriverEx;
begin
Result := (inherited Items[Index]) as TDirectXDriverEx;
end;
 
{$ENDIF}
 
initialization
InitCosinTable;
finalization
FreeLibList;
end.
end.
/VCL_DELPHIX_D6/DXConsts.pas
22,7 → 22,7
SSession = 'Session';
 
SNotMade = '%s not made';
SStreamNotOpend = 'Stream not opend';
SStreamNotOpend = 'Stream not opened';
SWaveStreamNotSet = 'WaveStream not set';
SCannotMade = '%s cannot be made';
SCannotInitialized = '%s cannot be initialized';
29,7 → 29,7
SCannotChanged = '%s cannot be changed';
SCannotLock = '%s cannot be locked';
SCannotOpened = '%s cannot be opened';
SDLLNotLoaded = '%s not loaded';
SDLLNotLoaded = '%s is not loaded';
SImageNotFound = 'Image ''%s'' not found';
SWaveNotFound = 'Wave ''%s'' not found';
SEffectNotFound = 'Effect ''%s'' not found';
36,32 → 36,32
SListIndexError = 'Index of the list exceeds the range. (%d)';
SScanline = 'Index of the scanning line exceeded the range. (%d)';
SNoForm = 'Form not found';
SSinceDirectX5 = 'Necessary since DirectX 5';
SSinceDirectX6 = 'Necessary since DirectX 6';
SSinceDirectX7 = 'Necessary since DirectX 7';
SSinceDirectX5 = 'Requires DirectX 5.0 or later';
SSinceDirectX6 = 'Requires DirectX 6.0 or later';
SSinceDirectX7 = 'Requires DirectX 7.0 or later';
S3DDeviceNotFound = '3D device not found';
SDisplayModeChange = 'Display mode cannot be changed (%dx%d %dbit)';
SDisplayModeCannotAcquired = 'A present display mode cannot be acquired';
SDisplayModeCannotAcquired = 'Display mode cannot be acquired';
SInvalidDIB = 'DIB is invalid';
SInvalidDIBBitCount = 'Bitcount in invalid (%d)';
SInvalidDIBPixelFormat = 'PixelFormat in invalid';
SInvalidWave = 'Wave is invalid';
SInvalidDisplayBitCount = 'It should be either of 8 or 16 or 24 or 32';
SInvalidDisplayBitCount = 'Display requires 8, 16, 24 or 32 bits';
SInvalidWaveFormat = 'Format is invalid';
SNotSupported = '%s not supported';
SStreamOpend = 'Stream has already been opened';
SNecessaryDirectInputUseMouse = 'DirectInput is necessary to use the mouse';
SStreamOpend = 'Stream is already open';
SNecessaryDirectInputUseMouse = 'DirectInput is required for mouse support';
 
{ DirectPlay }
SDXPlayNotConnectedNow = 'TDXPlay component is not connected now.';
SDXPlayNotConnectedNow = 'TDXPlay component is disconnected.';
SDXPlayProviderNotFound = 'Provider ''%s'' not found';
SDXPlayProviderSpecifiedGUIDNotFound = 'Provider of specified GUID is not found';
SDXPlayProviderSpecifiedGUIDNotFound = 'Provider''s specified GUID is not found';
SDXPlayModemListCannotBeAcquired = 'Modem list cannot be acquired';
SDXPlaySessionListCannotBeAcquired = 'Session list cannot be acquired';
SDXPlaySessionNotFound = 'Session ''%s'' not found';
SDXPlaySessionCannotOpened = 'Session %s cannot be opened';
SDXPlayPlayerNotFound = 'The player of specified ID is not found';
SDXPlayMessageIllegal = 'The message form is illegal';
SDXPlayPlayerNotFound = 'Player''s specified ID is not found';
SDXPlayMessageIllegal = 'Illegal message form';
SDXPlayPlayerNameIsNotSpecified = 'Player name is not specified';
SDXPlaySessionNameIsNotSpecified = 'Session name is not specified';
 
69,12 → 69,11
DXPlayFormComplete = 'Complete';
 
 
SNotSupportGraphicFile = 'Graphic format not suported';
SInvalidDXTFile = 'DXT file is invalid';
SCannotLoadGraphic = 'Can not load graphic';
SOverlay = 'Surface overlay not possible';
SNotSupportGraphicFile = 'This format graphic not suported';
SInvalidDXTFile = 'This DXT file is invalid';
SCannotLoadGraphic = 'Can''t Load this Graphic';
SOverlay = 'Not posible Overlay Surface';
 
const
SDIBSize = '(%dx%d)';
SDIBColor = '%d color';
/VCL_DELPHIX_D6/DXDIBEffectEdit.dfm
0,0 → 1,476
object TDelphiXDIBEffectEditForm: TTDelphiXDIBEffectEditForm
Left = 293
Top = 183
BorderStyle = bsDialog
Caption = 'Special effect'
ClientHeight = 368
ClientWidth = 504
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = True
Position = poScreenCenter
OnCreate = FormCreate
OnDestroy = FormDestroy
PixelsPerInch = 96
TextHeight = 13
object Bevel3: TBevel
Left = 8
Top = 8
Width = 489
Height = 321
Shape = bsFrame
end
object Panel1: TPanel
Left = 16
Top = 16
Width = 473
Height = 305
BevelOuter = bvNone
BorderStyle = bsSingle
TabOrder = 1
object Bevel1: TBevel
Left = 8
Top = 39
Width = 258
Height = 258
end
object Image1: TImage
Left = 9
Top = 40
Width = 32
Height = 32
AutoSize = True
end
object LSpokes: TLabel
Left = 8
Top = 8
Width = 36
Height = 13
Caption = 'Spokes'
FocusControl = Spokes
end
object LRaHUE: TLabel
Left = 160
Top = 8
Width = 66
Height = 13
Caption = 'Random HUE'
FocusControl = RaHUE
end
object LCentr: TLabel
Left = 312
Top = 8
Width = 57
Height = 13
Caption = 'Nova radius'
FocusControl = Centr
end
object Label4: TLabel
Left = 276
Top = 44
Width = 11
Height = 13
Caption = 'R:'
end
object Label5: TLabel
Left = 276
Top = 76
Width = 11
Height = 13
Caption = 'G:'
end
object Label6: TLabel
Left = 276
Top = 108
Width = 10
Height = 13
Caption = 'B:'
end
object Label7: TLabel
Left = 274
Top = 140
Width = 13
Height = 13
Hint = 'Random spoke...'
Caption = 'rS:'
FocusControl = randSpok
ParentShowHint = False
ShowHint = True
end
object Label8: TLabel
Left = 274
Top = 164
Width = 14
Height = 13
Hint = 'Random gauss...'
Caption = 'rG:'
FocusControl = RandGauss
ParentShowHint = False
ShowHint = True
end
object rS_max: TSpeedButton
Left = 334
Top = 136
Width = 36
Height = 21
Caption = 'max'
Spacing = -1
OnClick = rS_maxClick
end
object rG_max: TSpeedButton
Left = 334
Top = 160
Width = 36
Height = 21
Caption = 'max'
Spacing = -1
OnClick = rG_maxClick
end
object Bevel2: TBevel
Left = 272
Top = 187
Width = 192
Height = 65
end
object SpokesPlus: TSpeedButton
Left = 124
Top = 5
Width = 17
Height = 17
Glyph.Data = {
DE000000424DDE0000000000000076000000280000000D0000000D0000000100
0400000000006800000000000000000000001000000010000000000000000000
BF0000BF000000BFBF00BF000000BF00BF00BFBF0000C0C0C000808080000000
FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00777777777777
700077777777777770007777700077777000777770C077777000777770C07777
7000770000C000077000770CCCCCCC077000770000C000077000777770C07777
7000777770C07777700077777000777770007777777777777000777777777777
7000}
OnClick = SpokesPlusClick
end
object SpokesMinus: TSpeedButton
Left = 140
Top = 5
Width = 17
Height = 17
Glyph.Data = {
DE000000424DDE0000000000000076000000280000000D0000000D0000000100
0400000000006800000000000000000000001000000010000000000000000000
BF0000BF000000BFBF00BF000000BF00BF00BFBF0000C0C0C000808080000000
FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00777777777777
7000777777777777700077777777777770007777777777777000777777777777
70007700000000077000770CCCCCCC0770007700000000077000777777777777
7000777777777777700077777777777770007777777777777000777777777777
7000}
OnClick = SpokesMinusClick
end
object RaHUEPlus: TSpeedButton
Left = 276
Top = 5
Width = 17
Height = 17
Glyph.Data = {
DE000000424DDE0000000000000076000000280000000D0000000D0000000100
0400000000006800000000000000000000001000000010000000000000000000
BF0000BF000000BFBF00BF000000BF00BF00BFBF0000C0C0C000808080000000
FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00777777777777
700077777777777770007777700077777000777770C077777000777770C07777
7000770000C000077000770CCCCCCC077000770000C000077000777770C07777
7000777770C07777700077777000777770007777777777777000777777777777
7000}
OnClick = RaHUEPlusClick
end
object RaHUEMinus: TSpeedButton
Left = 292
Top = 5
Width = 17
Height = 17
Glyph.Data = {
DE000000424DDE0000000000000076000000280000000D0000000D0000000100
0400000000006800000000000000000000001000000010000000000000000000
BF0000BF000000BFBF00BF000000BF00BF00BFBF0000C0C0C000808080000000
FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00777777777777
7000777777777777700077777777777770007777777777777000777777777777
70007700000000077000770CCCCCCC0770007700000000077000777777777777
7000777777777777700077777777777770007777777777777000777777777777
7000}
OnClick = RaHUEMinusClick
end
object CentrPlus: TSpeedButton
Left = 428
Top = 5
Width = 17
Height = 17
Glyph.Data = {
DE000000424DDE0000000000000076000000280000000D0000000D0000000100
0400000000006800000000000000000000001000000010000000000000000000
BF0000BF000000BFBF00BF000000BF00BF00BFBF0000C0C0C000808080000000
FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00777777777777
700077777777777770007777700077777000777770C077777000777770C07777
7000770000C000077000770CCCCCCC077000770000C000077000777770C07777
7000777770C07777700077777000777770007777777777777000777777777777
7000}
OnClick = CentrPlusClick
end
object CentrMinus: TSpeedButton
Left = 444
Top = 5
Width = 17
Height = 17
Glyph.Data = {
DE000000424DDE0000000000000076000000280000000D0000000D0000000100
0400000000006800000000000000000000001000000010000000000000000000
BF0000BF000000BFBF00BF000000BF00BF00BFBF0000C0C0C000808080000000
FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00777777777777
7000777777777777700077777777777770007777777777777000777777777777
70007700000000077000770CCCCCCC0770007700000000077000777777777777
7000777777777777700077777777777770007777777777777000777777777777
7000}
OnClick = CentrMinusClick
end
object LName: TLabel
Left = 283
Top = 200
Width = 112
Height = 13
Caption = 'Picture name (required):'
FocusControl = eName
Font.Charset = DEFAULT_CHARSET
Font.Color = clPurple
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = [fsUnderline]
ParentFont = False
end
object eR: TEdit
Left = 289
Top = 40
Width = 35
Height = 21
TabOrder = 0
Text = '16'
OnChange = ImageChange
end
object eG: TEdit
Left = 289
Top = 72
Width = 35
Height = 21
TabOrder = 1
Text = '48'
OnChange = ImageChange
end
object eB: TEdit
Left = 289
Top = 104
Width = 35
Height = 21
TabOrder = 2
Text = '255'
OnChange = ImageChange
end
object randSpok: TEdit
Left = 289
Top = 136
Width = 44
Height = 21
TabOrder = 3
end
object RandGauss: TEdit
Left = 289
Top = 160
Width = 44
Height = 21
TabOrder = 4
end
object PictSize: TRadioGroup
Left = 385
Top = 44
Width = 73
Height = 121
Caption = ' Size: '
ItemIndex = 0
Items.Strings = (
'256x256'
'128x128'
'64x64'
'32x62'
'16x16'
'8x8')
TabOrder = 5
OnClick = ImageChange
end
object R_updown: TSpinButton
Left = 326
Top = 41
Width = 20
Height = 20
DownGlyph.Data = {
0E010000424D0E01000000000000360000002800000009000000060000000100
200000000000D800000000000000000000000000000000000000008080000080
8000008080000080800000808000008080000080800000808000008080000080
8000008080000080800000808000000000000080800000808000008080000080
8000008080000080800000808000000000000000000000000000008080000080
8000008080000080800000808000000000000000000000000000000000000000
0000008080000080800000808000000000000000000000000000000000000000
0000000000000000000000808000008080000080800000808000008080000080
800000808000008080000080800000808000}
TabOrder = 6
UpGlyph.Data = {
0E010000424D0E01000000000000360000002800000009000000060000000100
200000000000D800000000000000000000000000000000000000008080000080
8000008080000080800000808000008080000080800000808000008080000080
8000000000000000000000000000000000000000000000000000000000000080
8000008080000080800000000000000000000000000000000000000000000080
8000008080000080800000808000008080000000000000000000000000000080
8000008080000080800000808000008080000080800000808000000000000080
8000008080000080800000808000008080000080800000808000008080000080
800000808000008080000080800000808000}
OnDownClick = R_updownDownClick
OnUpClick = R_updownUpClick
end
object G_updown: TSpinButton
Left = 326
Top = 73
Width = 20
Height = 20
DownGlyph.Data = {
0E010000424D0E01000000000000360000002800000009000000060000000100
200000000000D800000000000000000000000000000000000000008080000080
8000008080000080800000808000008080000080800000808000008080000080
8000008080000080800000808000000000000080800000808000008080000080
8000008080000080800000808000000000000000000000000000008080000080
8000008080000080800000808000000000000000000000000000000000000000
0000008080000080800000808000000000000000000000000000000000000000
0000000000000000000000808000008080000080800000808000008080000080
800000808000008080000080800000808000}
TabOrder = 8
UpGlyph.Data = {
0E010000424D0E01000000000000360000002800000009000000060000000100
200000000000D800000000000000000000000000000000000000008080000080
8000008080000080800000808000008080000080800000808000008080000080
8000000000000000000000000000000000000000000000000000000000000080
8000008080000080800000000000000000000000000000000000000000000080
8000008080000080800000808000008080000000000000000000000000000080
8000008080000080800000808000008080000080800000808000000000000080
8000008080000080800000808000008080000080800000808000008080000080
800000808000008080000080800000808000}
OnDownClick = G_updownDownClick
OnUpClick = G_updownUpClick
end
object B_updown: TSpinButton
Left = 326
Top = 105
Width = 20
Height = 20
DownGlyph.Data = {
0E010000424D0E01000000000000360000002800000009000000060000000100
200000000000D800000000000000000000000000000000000000008080000080
8000008080000080800000808000008080000080800000808000008080000080
8000008080000080800000808000000000000080800000808000008080000080
8000008080000080800000808000000000000000000000000000008080000080
8000008080000080800000808000000000000000000000000000000000000000
0000008080000080800000808000000000000000000000000000000000000000
0000000000000000000000808000008080000080800000808000008080000080
800000808000008080000080800000808000}
TabOrder = 7
UpGlyph.Data = {
0E010000424D0E01000000000000360000002800000009000000060000000100
200000000000D800000000000000000000000000000000000000008080000080
8000008080000080800000808000008080000080800000808000008080000080
8000000000000000000000000000000000000000000000000000000000000080
8000008080000080800000000000000000000000000000000000000000000080
8000008080000080800000808000008080000000000000000000000000000080
8000008080000080800000808000008080000080800000808000000000000080
8000008080000080800000808000008080000080800000808000008080000080
800000808000008080000080800000808000}
OnDownClick = B_updownDownClick
OnUpClick = B_updownUpClick
end
object Spokes: TProgressBar
Left = 8
Top = 24
Width = 150
Height = 9
Min = 1
Max = 1024
Position = 255
TabOrder = 9
OnMouseMove = SpokesMouseMove
end
object RaHUE: TProgressBar
Left = 160
Top = 24
Width = 150
Height = 9
Min = 0
Max = 360
TabOrder = 10
OnMouseMove = RaHUEMouseMove
end
object Centr: TProgressBar
Left = 312
Top = 24
Width = 150
Height = 9
Min = 1
Max = 100
Position = 1
TabOrder = 11
OnMouseMove = CentrMouseMove
end
object eName: TEdit
Left = 283
Top = 216
Width = 161
Height = 21
TabOrder = 12
end
end
object Button1: TButton
Left = 264
Top = 336
Width = 75
Height = 25
Caption = 'Save as...'
TabOrder = 0
OnClick = Button1Click
end
object btnOK: TButton
Left = 344
Top = 336
Width = 75
Height = 25
Caption = 'OK'
ModalResult = 1
TabOrder = 2
OnClick = btnOKClick
end
object btnCancel: TButton
Left = 421
Top = 336
Width = 75
Height = 25
Caption = 'Cancel'
ModalResult = 2
TabOrder = 3
OnClick = btnCancelClick
end
object SavePictureDialog1: TSavePictureDialog
DefaultExt = '.bmp'
Filter =
'All (*.dib;*.jpg;*.jpeg;*.jpg;*.jpeg;*.bmp;*.ico;*.emf;*.wmf)|*.' +
'dib;*.jpg;*.jpeg;*.jpg;*.jpeg;*.bmp;*.ico;*.emf;*.wmf|Device Ind' +
'ependent Bitmap (*.dib)|*.dib|JPEG Image File (*.jpg)|*.jpg|JPEG' +
' Image File (*.jpeg)|*.jpeg|JPEG Image File (*.jpg)|*.jpg|JPEG I' +
'mage File (*.jpeg)|*.jpeg|Bitmaps (*.bmp)|*.bmp|Icons (*.ico)|*.' +
'ico|Enhanced Metafiles (*.emf)|*.emf|Metafiles (*.wmf)|*.wmf'
Title = 'Save NOVA picture effect'
Left = 160
Top = 304
end
end
/VCL_DELPHIX_D6/DXDIBEffectEdit.pas
0,0 → 1,373
unit DXDIBEffectEdit;
//(c)2007 Jaro Benes
//All Rights Reserved
 
{
Complex application for users of unDelphiX as component editor:
 
Supported:
a) create effect for store into dximagelist.
 
}
interface
 
{$INCLUDE DelphiXcfg.inc}
 
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, DIB, ExtCtrls, Math, ComCtrls, Buttons, ExtDlgs, Spin;
 
type
{injected class}
EInvalidTypeConvert = class(Exception);
TEdit = class(StdCtrls.TEdit)
private
procedure SetAsInteger(Value: Integer);
function GetAsInteger: Integer;
public
property AsInteger: Integer read GetAsInteger write SetAsInteger;
end;
TTDelphiXDIBEffectEditForm = class(TForm)
Button1: TButton;
Image1: TImage;
LSpokes: TLabel;
LRaHUE: TLabel;
LCentr: TLabel;
eR: TEdit;
eG: TEdit;
eB: TEdit;
Label4: TLabel;
Label5: TLabel;
Label6: TLabel;
randSpok: TEdit;
Label7: TLabel;
RandGauss: TEdit;
Label8: TLabel;
rS_max: TSpeedButton;
rG_max: TSpeedButton;
Bevel1: TBevel;
PictSize: TRadioGroup;
SavePictureDialog1: TSavePictureDialog;
Bevel2: TBevel;
R_updown: TSpinButton;
G_updown: TSpinButton;
B_updown: TSpinButton;
btnOK: TButton;
btnCancel: TButton;
Panel1: TPanel;
Bevel3: TBevel;
Spokes: TProgressBar;
RaHUE: TProgressBar;
Centr: TProgressBar;
SpokesPlus: TSpeedButton;
SpokesMinus: TSpeedButton;
RaHUEPlus: TSpeedButton;
RaHUEMinus: TSpeedButton;
CentrPlus: TSpeedButton;
CentrMinus: TSpeedButton;
LName: TLabel;
eName: TEdit;
procedure CentrMinusClick(Sender: TObject);
procedure CentrPlusClick(Sender: TObject);
procedure RaHUEMinusClick(Sender: TObject);
procedure RaHUEPlusClick(Sender: TObject);
procedure SpokesMinusClick(Sender: TObject);
procedure SpokesPlusClick(Sender: TObject);
procedure CentrMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure RaHUEMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure SpokesMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure FormDestroy(Sender: TObject);
procedure btnOKClick(Sender: TObject);
procedure btnCancelClick(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure ImageChange(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure rS_maxClick(Sender: TObject);
procedure rG_maxClick(Sender: TObject);
procedure R_updownUpClick(Sender: TObject);
procedure R_updownDownClick(Sender: TObject);
procedure G_updownUpClick(Sender: TObject);
procedure G_updownDownClick(Sender: TObject);
procedure B_updownUpClick(Sender: TObject);
procedure B_updownDownClick(Sender: TObject);
private
{ Private declarations }
FSpokes: Integer;
FRaHUE: Integer;
FCentr: Integer;
procedure Calculate;
public
{ Public declarations }
ResultDIB: TDIB;
end;
 
var
DelphiXDIBEffectEditForm: TTDelphiXDIBEffectEditForm;
 
implementation
 
{$R *.DFM}
 
{ TEdit }
 
{injected class functionality like in jbEdit.TPubEdit component}
 
procedure TEdit.SetAsInteger(Value: Integer);
begin
Text := IntToStr(Value)
end;
 
function TEdit.GetAsInteger: Integer;
begin
Result := 0;
if Text = '' then
Exit;
try
Result := StrToInt(Text);
except
raise EInvalidTypeConvert.Create('Expected integer value !');
end
end;
 
{ TTDelphiXDIBEffectEditForm }
 
procedure TTDelphiXDIBEffectEditForm.Calculate;
const
wSize: array[0..5] of Word = (256, 128, 64, 32, 16, 8);
begin
// call this
// cx,cy : center x and y
// radius : 1-100
// spokes : 1-1024
// randomhue : 0-360
ResultDIB.Clear;
ResultDIB.SetSize(wSize[PictSize.ItemIndex], wSize[PictSize.ItemIndex], 24);
ResultDIB.Canvas.Brush.Color := clBlack;
ResultDIB.Canvas.FillRect(ResultDIB.Canvas.ClipRect);
 
LSpokes.Caption := Format('Spokes (%d)', [FSpokes]);
LRaHUE.Caption := Format('Random HUE (%d)', [FRaHUE]);
LCentr.Caption := Format('Nova radius (%d)', [FCentr]);
 
ResultDIB.DoNovaEffect(eR.AsInteger, eG.AsInteger, eB.AsInteger, ResultDIB.Width div 2,
ResultDIB.Height div 2, FCentr, FSpokes, FRaHUE,
randSpok.AsInteger, randGauss.AsInteger, nil);
 
Image1.Picture.Assign(ResultDIB);
end;
 
procedure TTDelphiXDIBEffectEditForm.Button1Click(Sender: TObject);
begin
Calculate;
if SavePictureDialog1.Execute then
ResultDIB.SaveToFile(SavePictureDialog1.FileName);
end;
 
procedure TTDelphiXDIBEffectEditForm.FormCreate(Sender: TObject);
begin
Tag := 0;
ResultDIB := TDIB.Create;
Randomize;
randspok.AsInteger := Random(MAXSHORT);
randgauss.AsInteger := Random(MAXSHORT);
FSpokes := 255; Spokes.Position := FSpokes; {$IFDEF VER4UP} Spokes.Smooth := True; {$ENDIF}
FRaHUE := 1; RaHUE.Position := FRaHUE; {$IFDEF VER4UP} RaHUE.Smooth := True; {$ENDIF}
FCentr := 18; Centr.Position := FCentr; {$IFDEF VER4UP} Centr.Smooth := True; {$ENDIF}
LSpokes.Caption := Format('Spokes (%d)', [FSpokes]);
LRaHUE.Caption := Format('Random HUE (%d)', [FRaHUE]);
LCentr.Caption := Format('Nova radius (%d)', [FCentr]);
Calculate;
randSpok.OnChange := ImageChange;
randgauss.OnChange := ImageChange;
{$IFDEF VER4UP}
Spokes.Smooth := True;
RaHUE.Smooth := True;
Centr.Smooth := True;
{$ENDIF}
end;
 
procedure TTDelphiXDIBEffectEditForm.rS_maxClick(Sender: TObject);
begin
RandSpok.AsInteger := maxint;
Calculate;
end;
 
procedure TTDelphiXDIBEffectEditForm.rG_maxClick(Sender: TObject);
begin
RandGauss.AsInteger := maxint;
Calculate;
end;
 
procedure TTDelphiXDIBEffectEditForm.R_updownUpClick(Sender: TObject);
begin
if eR.AsInteger < 255 then eR.AsInteger := eR.AsInteger + 1;
Calculate;
end;
 
procedure TTDelphiXDIBEffectEditForm.R_updownDownClick(Sender: TObject);
begin
if eR.AsInteger > 0 then eR.AsInteger := eR.AsInteger - 1;
Calculate;
end;
 
procedure TTDelphiXDIBEffectEditForm.G_updownUpClick(Sender: TObject);
begin
if eG.AsInteger < 255 then eG.AsInteger := eG.AsInteger + 1;
Calculate;
end;
 
procedure TTDelphiXDIBEffectEditForm.G_updownDownClick(Sender: TObject);
begin
if eG.AsInteger > 0 then eG.AsInteger := eG.AsInteger - 1;
Calculate;
end;
 
procedure TTDelphiXDIBEffectEditForm.B_updownUpClick(Sender: TObject);
begin
if eB.AsInteger < 255 then eB.AsInteger := eB.AsInteger + 1;
Calculate;
end;
 
procedure TTDelphiXDIBEffectEditForm.B_updownDownClick(Sender: TObject);
begin
if eB.AsInteger > 0 then eB.AsInteger := eB.AsInteger - 1;
Calculate;
end;
 
procedure TTDelphiXDIBEffectEditForm.btnCancelClick(Sender: TObject);
begin
Close;
end;
 
procedure TTDelphiXDIBEffectEditForm.btnOKClick(Sender: TObject);
begin
if eName.Text <> '' then begin
Tag := 1;
Close;
end
else
MessageDlg('Image name required!', mtWarning, [mbOK], 0);;
end;
 
procedure TTDelphiXDIBEffectEditForm.FormDestroy(Sender: TObject);
begin
ResultDIB.Free;
end;
 
procedure TTDelphiXDIBEffectEditForm.ImageChange(Sender: TObject);
begin
Calculate;
end;
 
procedure TTDelphiXDIBEffectEditForm.SpokesMouseMove(Sender: TObject;
Shift: TShiftState; X, Y: Integer);
var
newPosition: integer;
begin
with Sender as TProgressBar do begin
if ssLeft in Shift then
begin
Cursor := crHSplit;
newPosition := Round(x * Max / ClientWidth);
Position := newPosition;
end
else
begin
Cursor := crDefault;
end;
FSpokes := Position;
LSpokes.Caption := Format('Spokes (%d)', [FSpokes]);
if ssLeft in Shift then Calculate;
end;
end;
 
procedure TTDelphiXDIBEffectEditForm.RaHUEMouseMove(Sender: TObject;
Shift: TShiftState; X, Y: Integer);
var
newPosition: integer;
begin
with Sender as TProgressBar do begin
if ssLeft in Shift then
begin
Cursor := crHSplit;
newPosition := Round(x * Max / ClientWidth);
Position := newPosition;
end
else
begin
Cursor := crDefault;
end;
FRaHUE := Position;
LRaHUE.Caption := Format('Random HUE (%d)', [FRaHUE]);
if ssLeft in Shift then Calculate;
end;
end;
 
procedure TTDelphiXDIBEffectEditForm.CentrMouseMove(Sender: TObject;
Shift: TShiftState; X, Y: Integer);
var
newPosition: integer;
begin
with Sender as TProgressBar do begin
if ssLeft in Shift then
begin
Cursor := crHSplit;
newPosition := Round(x * Max / ClientWidth);
Position := newPosition;
end
else
begin
Cursor := crDefault;
end;
FCentr := Position;
LCentr.Caption := Format('Nova radius (%d)', [FCentr]);
if ssLeft in Shift then Calculate;
end;
end;
 
procedure TTDelphiXDIBEffectEditForm.SpokesPlusClick(Sender: TObject);
begin
Inc(FSpokes); if FSpokes > 1024 then FSpokes := 1024;
Spokes.Position := FSpokes;
Calculate;
end;
 
procedure TTDelphiXDIBEffectEditForm.SpokesMinusClick(Sender: TObject);
begin
Dec(FSpokes); if FSpokes < 1 then FSpokes := 1;
Spokes.Position := FSpokes;
Calculate;
end;
 
procedure TTDelphiXDIBEffectEditForm.RaHUEPlusClick(Sender: TObject);
begin
Inc(FRaHUE); if FRaHUE > 360 then FRaHUE := 360;
RaHUE.Position := FRaHUE;
Calculate;
end;
 
procedure TTDelphiXDIBEffectEditForm.RaHUEMinusClick(Sender: TObject);
begin
Dec(FRaHUE); if FRaHUE < 0 then FRaHUE := 0;
RaHUE.Position := FRaHUE;
Calculate;
end;
 
procedure TTDelphiXDIBEffectEditForm.CentrPlusClick(Sender: TObject);
begin
Inc(FCentr); if FCentr > 100 then FCentr := 100;
Centr.Position := FCentr;
Calculate;
end;
 
procedure TTDelphiXDIBEffectEditForm.CentrMinusClick(Sender: TObject);
begin
Dec(FCentr); if FCentr < 1 then FCentr := 1;
Centr.Position := FCentr;
Calculate;
end;
 
end.
/VCL_DELPHIX_D6/DXDraws.pas
1,3 → 1,95
(*******************************************************************************
EXTEND UNIT DXDRAWS FROM DELPHIX PACK
 
* Copyright (c) 2004-2010 Jaro Benes
* All Rights Reserved
* Version 1.09
* D2D Hardware module
* web site: www.micrel.cz/Dx
* e-mail: delphix_d2d@micrel.cz
 
* Enhanced by User137
 
* DISCLAIMER:
This software is provided "as is" and is without warranty of any kind.
The author of this software does not warrant, guarantee or make any
representations regarding the use or results of use of this software
in terms of reliability, accuracy or fitness for purpose. You assume
the entire risk of direct or indirect, consequential or inconsequential
results from the correct or incorrect usage of this software even if the
author has been informed of the possibilities of such damage. Neither
the author nor anybody connected to this software in any way can assume
any responsibility.
 
Tested in Delphi 4, 5, 6, 7 and Delphi 2005/2006/2007/2009/2010
 
* FEATURES:
a) Implement Hardware acceleration for critical function like DrawAlpha {Blend},
DrawSub and DrawAdd for both way DXIMAGELIST and DIRECTDRAWSURFACE with rotation too.
b) Automatic adjustement for texture size different 2^n.
c) Minimum current source code change, all accelerated code added into:
DXDraw.BeginScene;
//code here
DXDraw.EndScene;
d) DelphiX facade continues using still.
 
* HOW TO USE
a) Design code like as DelphiX and drawing routine put into
DXDraw.BeginScene;
//code here
DXDraw.EndScene;
b) setup options in code or property for turn-on acceleration like:
DXDraw.Finalize; {done DXDraw}
If HardwareSwitch Then
{hardware}
Begin
if NOT (doDirectX7Mode in DXDraw.Options) then
DXDraw.Options := DXDraw.Options + [doDirectX7Mode];
if NOT (doHardware in DXDraw.Options) then
DXDraw.Options := DXDraw.Options + [doHardware];
if NOT (do3D in DXDraw.Options) then
DXDraw.Options := DXDraw.Options + [do3D];
if doSystemMemory in DXDraw.Options then
DXDraw.Options := DXDraw.Options - [doSystemMemory];
End
Else
{software}
Begin
if doDirectX7Mode in DXDraw.Options then
DXDraw.Options := DXDraw.Options - [doDirectX7Mode];
if do3D in DXDraw.Options then
DXDraw.Options := DXDraw.Options - [do3D];
if doHardware in DXDraw.Options then
DXDraw.Options := DXDraw.Options - [doHardware];
if NOT (doSystemMemory in DXDraw.Options) then
DXDraw.Options := DXDraw.Options + [doSystemMemory];
End;
{to fullscreen}
if doFullScreen in DXDraw.Options then
begin
RestoreWindow;
DXDraw.Cursor := crDefault;
BorderStyle := bsSingle;
DXDraw.Options := DXDraw.Options - [doFullScreen];
DXDraw.Options := DXDraw.Options + [doFlip];
end else
begin
StoreWindow;
DXDraw.Cursor := crNone;
BorderStyle := bsNone;
DXDraw.Options := DXDraw.Options + [doFullScreen];
DXDraw.Options := DXDraw.Options - [doFlip];
end;
DXDraw1.Initialize; {up DXDraw now}
 
* NOTE Main form has to declare like:
TForm1 = class(TDXForm)
 
* KNOWN BUGS OR RESTRICTION:
1/ Cannot be use DirectDrawSurface other from DXDraw.Surface in HW mode.
2/ New functions was not tested for two and more DXDraws on form. Sorry.
 
******************************************************************************)
unit DXDraws;
 
interface
6,10 → 98,56
 
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
DXClass, DIB, DXTexImg, DirectX;
{$IFDEF VER14UP}
DXTypes,
{$ENDIF}
{$IFDEF VER17UP}System.Types, System.UITypes,{$ENDIF}
{$IFDEF DXTextureImage_UseZLIB}
ZLIB,
{$ENDIF}
DXClass, DIB,
{$IFDEF StandardDX}
DirectDraw, DirectSound,
{$IFDEF DX7}
{$IFDEF D3DRM}
Direct3DRM,
{$ENDIF}
Direct3D;
{$ENDIF}
{$IFDEF DX9}
Direct3D9, Direct3D, D3DX9, {Direct3D8,} DX7toDX8;
{$ENDIF}
{$ELSE}
DirectX;
{$ENDIF}
 
const
maxTexBlock = 2048; {maximum textures}
maxVideoBlockSize: Integer = 2048; {maximum size block of one texture}
SurfaceDivWidth: Integer = 2048;
SurfaceDivHeight: Integer = 2048;
{This conditional is for force set square texture when use it alphachannel from DIB32}
{$DEFINE FORCE_SQUARE}
DXTextureImageGroupType_Normal = 0; // Normal group
DXTextureImageGroupType_Mipmap = 1; // Mipmap group
 
Alphabet = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ"at 0123456789<>=()-''!_+\/{}^&%.=$#ÅÖÄ?*';
PowerAlphabet = 'abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ`1234567890-=~!@#$%^&*()_+[];'',./\{}:"<>?|©®™ ';
ccDefaultSpecular = $FFFFFFFF;
 
ZeroRect: TRect = (Left: 0; Top: 0; Right: 0; Bottom: 0);
 
type
 
{ TRenderType }
 
TRenderType = (rtDraw, rtBlend, rtAdd, rtSub);
 
{ TRenderMirrorFlip }
 
TRenderMirrorFlip = (rmfMirror, rmfFlip);
TRenderMirrorFlipSet = set of TRenderMirrorFlip;
 
{ EDirectDrawError }
 
EDirectDrawError = class(EDirectXError);
25,8 → 163,10
 
TDirectDraw = class(TDirectX)
private
{$IFDEF D3D_deprecated}
FIDDraw: IDirectDraw;
FIDDraw4: IDirectDraw4;
{$ENDIF}
FIDDraw7: IDirectDraw7;
FDriverCaps: TDDCaps;
FHELCaps: TDDCaps;
35,12 → 175,16
FSurfaces: TList;
function GetClipper(Index: Integer): TDirectDrawClipper;
function GetClipperCount: Integer;
function GetDisplayMode: TDDSurfaceDesc;
function GetDisplayMode: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
{$IFDEF D3D_deprecated}
function GetIDDraw: IDirectDraw;
function GetIDDraw4: IDirectDraw4;
{$ENDIF}
function GetIDDraw7: IDirectDraw7;
{$IFDEF D3D_deprecated}
function GetIDraw: IDirectDraw;
function GetIDraw4: IDirectDraw4;
{$ENDIF}
function GetIDraw7: IDirectDraw7;
function GetPalette(Index: Integer): TDirectDrawPalette;
function GetPaletteCount: Integer;
51,16 → 195,21
constructor CreateEx(GUID: PGUID; DirectX7Mode: Boolean);
destructor Destroy; override;
class function Drivers: TDirectXDrivers;
{$IFDEF _DMO_}class function DriversEx: TDirectXDriversEx;{$ENDIF}
property ClipperCount: Integer read GetClipperCount;
property Clippers[Index: Integer]: TDirectDrawClipper read GetClipper;
property DisplayMode: TDDSurfaceDesc read GetDisplayMode;
property DisplayMode: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF} read GetDisplayMode;
property DriverCaps: TDDCaps read FDriverCaps;
property HELCaps: TDDCaps read FHELCaps;
{$IFDEF D3D_deprecated}
property IDDraw: IDirectDraw read GetIDDraw;
property IDDraw4: IDirectDraw4 read GetIDDraw4;
{$ENDIF}
property IDDraw7: IDirectDraw7 read GetIDDraw7;
{$IFDEF D3D_deprecated}
property IDraw: IDirectDraw read GetIDraw;
property IDraw4: IDirectDraw4 read GetIDraw4;
{$ENDIF}
property IDraw7: IDirectDraw7 read GetIDraw7;
property PaletteCount: Integer read GetPaletteCount;
property Palettes[Index: Integer]: TDirectDrawPalette read GetPalette;
135,35 → 284,63
FCanvas: TDirectDrawSurfaceCanvas;
FHasClipper: Boolean;
FDDraw: TDirectDraw;
{$IFDEF D3D_deprecated}
FIDDSurface: IDirectDrawSurface;
FIDDSurface4: IDirectDrawSurface4;
{$ENDIF}
FIDDSurface7: IDirectDrawSurface7;
FSystemMemory: Boolean;
FStretchDrawClipper: IDirectDrawClipper;
FSurfaceDesc: TDDSurfaceDesc;
FSurfaceDesc: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
FGammaControl: IDirectDrawGammaControl;
FLockSurfaceDesc: TDDSurfaceDesc;
FLockSurfaceDesc: {$IFDEF D3D_deprecated}TDDSurfaceDesc{$ELSE}TDDSurfaceDesc2{$ENDIF};
FLockCount: Integer;
FIsLocked: Boolean;
FModified: Boolean;
FCaption: TCaption;
DIB_COLMATCH: TDIB;
function GetBitCount: Integer;
function GetCanvas: TDirectDrawSurfaceCanvas;
function GetClientRect: TRect;
function GetHeight: Integer;
function GetIDDSurface: IDirectDrawSurface;
function GetIDDSurface4: IDirectDrawSurface4;
function GetIDDSurface7: IDirectDrawSurface7;
{$IFDEF D3D_deprecated}
function GetIDDSurface: IDirectDrawSurface; {$IFDEF VER9UP}inline;{$ENDIF}
function GetIDDSurface4: IDirectDrawSurface4; {$IFDEF VER9UP}inline;{$ENDIF}
{$ENDIF}
function GetIDDSurface7: IDirectDrawSurface7; {$IFDEF VER9UP}inline;{$ENDIF}
{$IFDEF D3D_deprecated}
function GetISurface: IDirectDrawSurface;
function GetISurface4: IDirectDrawSurface4;
{$ENDIF}
function GetISurface7: IDirectDrawSurface7;
function GetPixel(X, Y: Integer): Longint;
function GetWidth: Integer;
procedure SetClipper(Value: TDirectDrawClipper);
procedure SetColorKey(Flags: DWORD; const Value: TDDColorKey);
{$IFDEF D3D_deprecated}
procedure SetIDDSurface(Value: IDirectDrawSurface);
procedure SetIDDSurface4(Value: IDirectDrawSurface4);
{$ENDIF}
procedure SetIDDSurface7(Value: IDirectDrawSurface7);
procedure SetPalette(Value: TDirectDrawPalette);
procedure SetPixel(X, Y: Integer; Value: Longint);
procedure SetTransparentColor(Col: Longint);
{support RGB routines}
procedure LoadRGB(Color: cardinal; var R, G, B: Byte);
function SaveRGB(const R, G, B: Byte): cardinal;
{asm routine for direct surface by pixel}
{no clipping}
function GetPixel16(x, y: Integer): Integer; register;
function GetPixel24(x, y: Integer): Integer; register;
function GetPixel32(x, y: Integer): Integer; register;
function GetPixel8(x, y: Integer): Integer; register;
procedure PutPixel16(x, y, color: Integer); register;
procedure PutPixel24(x, y, color: Integer); register;
procedure PutPixel32(x, y, color: Integer); register;
procedure PutPixel8(x, y, color: Integer); register;
{routines calls asm pixel routine}
function Peek(X, Y: Integer): LongInt; {$IFDEF VER9UP} inline; {$ENDIF}
procedure Poke(X, Y: Integer; const Value: LongInt); {$IFDEF VER9UP} inline; {$ENDIF}
public
constructor Create(ADirectDraw: TDirectDraw);
destructor Destroy; override;
170,17 → 347,22
procedure Assign(Source: TPersistent); override;
procedure AssignTo(Dest: TPersistent); override;
function Blt(const DestRect, SrcRect: TRect; Flags: DWORD;
const DF: TDDBltFX; Source: TDirectDrawSurface): Boolean;
const DF: TDDBltFX; Source: TDirectDrawSurface): Boolean; {$IFDEF VER9UP}inline;{$ENDIF}
function BltFast(X, Y: Integer; const SrcRect: TRect;
Flags: DWORD; Source: TDirectDrawSurface): Boolean;
function ColorMatch(Col: TColor): Integer;
{$IFDEF DelphiX_Spt4}
function CreateSurface(const SurfaceDesc: TDDSurfaceDesc): Boolean; overload;
function CreateSurface(const SurfaceDesc: TDDSurfaceDesc2): Boolean; overload;
Flags: DWORD; Source: TDirectDrawSurface): Boolean; {$IFDEF VER9UP}inline;{$ENDIF}
function ColorMatch(Col: TColor): Integer; {$IFDEF VER9UP}inline;{$ENDIF}
{$IFDEF VER4UP}
{$IFDEF D3D_deprecated}
function CreateSurface(SurfaceDesc: TDDSurfaceDesc): Boolean; overload;
{$ENDIF}
function CreateSurface(SurfaceDesc: TDDSurfaceDesc2): Boolean; overload;
{$ELSE}
function CreateSurface(const SurfaceDesc: TDDSurfaceDesc): Boolean;
function CreateSurface(SurfaceDesc: TDDSurfaceDesc): Boolean;
{$ENDIF}
{$IFDEF DelphiX_Spt4}
 
procedure MirrorFlip(Value: TRenderMirrorFlipSet);
 
{$IFDEF VER4UP}
procedure Draw(X, Y: Integer; SrcRect: TRect; Source: TDirectDrawSurface; Transparent: Boolean=True); overload;
procedure Draw(X, Y: Integer; Source: TDirectDrawSurface; Transparent: Boolean=True); overload;
procedure StretchDraw(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
194,38 → 376,94
Transparent: Boolean);
{$ENDIF}
procedure DrawAdd(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
Transparent: Boolean; Alpha: Integer{$IFDEF DelphiX_Spt4}=255{$ENDIF});
Transparent: Boolean; Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
procedure DrawAlpha(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
Transparent: Boolean; Alpha: Integer);
procedure DrawSub(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
Transparent: Boolean; Alpha: Integer{$IFDEF DelphiX_Spt4}=255{$ENDIF});
Transparent: Boolean; Alpha: Integer{$IFDEF VER4UP} = 255{$ENDIF});
 
procedure DrawAddCol(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
Transparent: Boolean; Color, Alpha: Integer);
procedure DrawAlphaCol(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
Transparent: Boolean; Color, Alpha: Integer);
procedure DrawSubCol(const DestRect, SrcRect: TRect; Source: TDirectDrawSurface;
Transparent: Boolean; Color, Alpha: Integer);
 
{Rotate}
procedure DrawRotate(X, Y, Width, Height: Integer; const SrcRect: TRect;
Source: TDirectDrawSurface; CenterX, CenterY: Double; Transparent: Boolean; Angle: Integer);
Source: TDirectDrawSurface; CenterX, CenterY: Double; Transparent: Boolean; Angle: single);
procedure DrawRotateAdd(X, Y, Width, Height: Integer; const SrcRect: TRect;
Source: TDirectDrawSurface; CenterX, CenterY: Double; Transparent: Boolean; Angle: Integer;
Alpha: Integer{$IFDEF DelphiX_Spt4}=255{$ENDIF});
Source: TDir