aksdb
/
CentrED
1
0
Fork 0
Code Issues 2 Pull Requests Releases Wiki Activity

- Merged changes from Turley (elevate with random altitude) 

- Rearranged the TfrmElevateSettings dialog
- Fixed transparency settings of the images in the TfrmLogin dialog
- Fixed TfrmRegionControl to not react on mouse clicks if no region is selected
- Updated Vampyre Imaging Lib to recent SVN
- Added missing cedserver_config_2_3 project file
This commit is contained in:
Andreas Schneider 2008-08-29 12:09:26 +02:00
parent fcb7c8a794
commit 0e841f864d
24 changed files with 3203 additions and 1896 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

137
Client/Tools/UfrmElevateSettings.lfm
View File

@ -1,61 +1,120 @@
object frmElevateSettings: TfrmElevateSettings
Left = 290
Height = 65
Height = 115
Top = 171
Width = 131
HorzScrollBar.Page = 130
Width = 231
HorzScrollBar.Page = 230
HorzScrollBar.Range = 122
VertScrollBar.Page = 64
VertScrollBar.Page = 114
VertScrollBar.Range = 59
ActiveControl = rbRaise
AutoScroll = False
BorderIcons = []
BorderStyle = bsToolWindow
Caption = 'Elevate'
ClientHeight = 65
ClientWidth = 131
ClientHeight = 115
ClientWidth = 231
Font.Height = -11
OnClose = FormClose
OnDeactivate = FormDeactivate
LCLVersion = '0.9.25'
object rbRaise: TRadioButton
object Panel1: TPanel
Left = 8
Height = 21
Height = 67
Top = 8
Width = 58
Caption = 'Raise'
Checked = True
ParentFont = True
State = cbChecked
Width = 215
Align = alTop
BorderSpacing.Around = 8
BevelOuter = bvNone
ClientHeight = 67
ClientWidth = 215
TabOrder = 0
object Panel2: TPanel
Height = 67
Width = 162
Align = alClient
BevelOuter = bvNone
ClientHeight = 67
ClientWidth = 162
ParentFont = True
TabOrder = 0
object rbRaise: TRadioButton
Height = 21
Width = 162
Align = alTop
Caption = 'Raise'
Checked = True
State = cbChecked
TabOrder = 2
end
object rbLower: TRadioButton
Height = 21
Top = 21
Width = 162
Align = alTop
Caption = 'Lower'
ParentFont = True
TabOrder = 0
end
object rbSet: TRadioButton
Height = 21
Top = 42
Width = 162
Align = alTop
Caption = 'Set'
ParentFont = True
TabOrder = 1
end
end
object Panel3: TPanel
Left = 162
Height = 67
Width = 53
Align = alRight
BevelOuter = bvNone
ClientHeight = 67
ClientWidth = 53
TabOrder = 1
object seZ: TSpinEdit
Left = 7
Height = 23
Top = 20
Width = 47
MaxValue = 127
MinValue = -128
ParentFont = True
TabOrder = 0
Value = 1
end
end
end
object rbLower: TRadioButton
object Panel4: TPanel
Left = 8
Height = 21
Top = 24
Width = 59
Caption = 'Lower'
ParentFont = True
TabOrder = 1
end
object seZ: TSpinEdit
Left = 72
Height = 23
Top = 22
Width = 50
MaxValue = 127
MinValue = -128
ParentFont = True
TabOrder = 3
Value = 1
end
object rbSet: TRadioButton
Left = 8
Height = 21
Top = 40
Width = 43
Caption = 'Set'
ParentFont = True
TabOrder = 2
Top = 83
Width = 215
Align = alTop
BorderSpacing.Around = 8
BevelOuter = bvNone
ClientHeight = 23
ClientWidth = 215
TabOrder = 1
object cbRandomHeight: TCheckBox
Height = 23
Width = 168
Align = alClient
Caption = 'Add Random Altitude'
ParentFont = True
TabOrder = 0
end
object seRandomHeight: TSpinEdit
Left = 168
Height = 23
Width = 47
Align = alRight
OnChange = seRandomHeightChange
ParentFont = True
TabOrder = 1
end
end
end

174
Client/Tools/UfrmElevateSettings.pas
View File

@ -1,81 +1,93 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
unit UfrmElevateSettings;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, LMessages,
LCLIntf, StdCtrls, Spin;
type
{ TfrmElevateSettings }
TfrmElevateSettings = class(TForm)
rbSet: TRadioButton;
rbRaise: TRadioButton;
rbLower: TRadioButton;
seZ: TSpinEdit;
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormDeactivate(Sender: TObject);
protected
procedure MouseLeave(var msg: TLMessage); message CM_MouseLeave;
public
{ public declarations }
end;
var
frmElevateSettings: TfrmElevateSettings;
implementation
{ TfrmElevateSettings }
procedure TfrmElevateSettings.FormClose(Sender: TObject;
var CloseAction: TCloseAction);
begin
CloseAction := caHide;
end;
procedure TfrmElevateSettings.FormDeactivate(Sender: TObject);
begin
Close;
end;
procedure TfrmElevateSettings.MouseLeave(var msg: TLMessage);
begin
if not PtInRect(ClientRect, ScreenToClient(Mouse.CursorPos)) then
Close;
end;
initialization
{$I UfrmElevateSettings.lrs}
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2008 Andreas Schneider
*)
unit UfrmElevateSettings;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, LMessages,
LCLIntf, StdCtrls, Spin, ExtCtrls;
type
{ TfrmElevateSettings }
TfrmElevateSettings = class(TForm)
cbRandomHeight: TCheckBox;
Panel1: TPanel;
Panel2: TPanel;
Panel3: TPanel;
Panel4: TPanel;
rbRaise: TRadioButton;
rbLower: TRadioButton;
rbSet: TRadioButton;
seRandomHeight: TSpinEdit;
seZ: TSpinEdit;
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormDeactivate(Sender: TObject);
procedure seRandomHeightChange(Sender: TObject);
protected
procedure MouseLeave(var msg: TLMessage); message CM_MouseLeave;
public
{ public declarations }
end;
var
frmElevateSettings: TfrmElevateSettings;
implementation
{ TfrmElevateSettings }
procedure TfrmElevateSettings.FormClose(Sender: TObject;
var CloseAction: TCloseAction);
begin
CloseAction := caHide;
end;
procedure TfrmElevateSettings.FormDeactivate(Sender: TObject);
begin
Close;
end;
procedure TfrmElevateSettings.seRandomHeightChange(Sender: TObject);
begin
cbRandomHeight.Checked := True;
end;
procedure TfrmElevateSettings.MouseLeave(var msg: TLMessage);
begin
if not PtInRect(ClientRect, ScreenToClient(Mouse.CursorPos)) then
Close;
end;
initialization
{$I UfrmElevateSettings.lrs}
end.

2326
Client/ULandscape.pas
View File

File diff suppressed because it is too large Load Diff

492
Client/UOverlayUI.pas
View File

@ -1,246 +1,246 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
unit UOverlayUI;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Gl, GLU, ImagingTypes, ImagingClasses, ImagingOpenGL,
OpenGLContext, ImagingUtility;
type
{ TGLArrow }
TGLArrow = class(TObject)
constructor Create(AGraphic: TSingleImage);
destructor Destroy; override;
protected
FGraphic: TSingleImage;
FTexture: GLuint;
FRealWidth: Integer;
FRealHeight: Integer;
FWidth: Integer;
FHeight: Integer;
FCurrentX: Integer;
FCurrentY: Integer;
procedure UpdateTexture;
public
property Width: Integer read FWidth;
property Height: Integer read FHeight;
property CurrentX: Integer read FCurrentX;
property CurrentY: Integer read FCurrentY;
function HitTest(AX, AY: Integer): Boolean;
procedure DrawGL(AX, AY: Integer; AActive: Boolean = False);
end;
{ TOverlayUI }
TOverlayUI = class(TObject)
constructor Create;
destructor Destroy; override;
protected
FArrows: array[0..7] of TGLArrow;
FActiveArrow: Integer;
FVisible: Boolean;
public
property ActiveArrow: Integer read FActiveArrow write FActiveArrow;
property Visible: Boolean read FVisible write FVisible;
function HitTest(AX, AY: Integer): Integer;
procedure Draw(AContext: TOpenGLControl);
end;
implementation
uses
UResourceManager;
{ TGLArrow }
constructor TGLArrow.Create(AGraphic: TSingleImage);
var
caps: TGLTextureCaps;
begin
inherited Create;
FRealWidth := AGraphic.Width;
FRealHeight := AGraphic.Height;
GetGLTextureCaps(caps);
if caps.PowerOfTwo then
begin
if IsPow2(FRealWidth) then FWidth := FRealWidth else FWidth := NextPow2(FRealWidth);
if IsPow2(FRealHeight) then FHeight := FRealHeight else FHeight := NextPow2(FRealHeight);
end else
begin
FWidth := FRealHeight;
FHeight := FRealHeight;
end;
FGraphic := TSingleImage.CreateFromParams(FWidth, FHeight, ifA8R8G8B8);
AGraphic.CopyTo(0, 0, FRealWidth, FRealHeight, FGraphic, 0, 0);
FTexture := 0;
end;
destructor TGLArrow.Destroy;
begin
if FGraphic <> nil then FreeAndNil(FGraphic);
if FTexture <> 0 then glDeleteTextures(1, @FTexture);
inherited Destroy;
end;
procedure TGLArrow.UpdateTexture;
begin
if (FGraphic <> nil) and (FRealWidth > 0) and (FRealWidth > 0) then
begin
FTexture := CreateGLTextureFromImage(FGraphic.ImageDataPointer^, 0, 0, False);
glBindTexture(GL_TEXTURE_2D, FTexture);
glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST);
glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_NEAREST);
glTexParameterf(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP);
glTexParameterf(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP);
end;
end;
function TGLArrow.HitTest(AX, AY: Integer): Boolean;
begin
if (AX > -1) and (AX < FRealWidth) and (AY > -1) and (AY < FRealHeight) then
begin
Result := (FGraphic <> nil) and (Cardinal(PIntegerArray(FGraphic.Bits)^[AY * FWidth + AX] and $FF000000) > 0);
end else
Result := False;
end;
procedure TGLArrow.DrawGL(AX, AY: Integer; AActive: Boolean = False);
begin
FCurrentX := AX;
FCurrentY := AY;
if FTexture = 0 then UpdateTexture;
if FTexture <> 0 then
begin
if AActive then
begin
glEnable(GL_COLOR_LOGIC_OP);
glLogicOp(GL_COPY_INVERTED);
end;
glBindTexture(GL_TEXTURE_2D, FTexture);
glBegin(GL_QUADS);
glTexCoord2f(0, 0); glVertex2d(AX, AY);
glTexCoord2f(1, 0); glVertex2d(AX + FWidth, AY);
glTexCoord2f(1, 1); glVertex2d(AX + FWidth, AY + FHeight);
glTexCoord2f(0, 1); glVertex2d(AX, AY + FHeight);
glEnd;
if AActive then
glDisable(GL_COLOR_LOGIC_OP);
end;
end;
{ TOverlayUI }
constructor TOverlayUI.Create;
var
i: Integer;
arrow: TSingleImage;
begin
inherited Create;
FActiveArrow := -1;
FVisible := False;
arrow := TSingleImage.CreateFromStream(ResourceManager.GetResource(0));
for i := 0 to 3 do
begin
FArrows[2*i] := TGLArrow.Create(arrow);
arrow.Rotate(-90);
end;
arrow.Free;
arrow := TSingleImage.CreateFromStream(ResourceManager.GetResource(1));
for i := 0 to 3 do
begin
FArrows[2*i+1] := TGLArrow.Create(arrow);
arrow.Rotate(-90);
end;
arrow.Free;
end;
destructor TOverlayUI.Destroy;
var
i: Integer;
begin
for i := 0 to 7 do
if FArrows[i] <> nil then FreeAndNil(FArrows[i]);
inherited Destroy;
end;
function TOverlayUI.HitTest(AX, AY: Integer): Integer;
var
i: Integer;
begin
Result := -1;
i := 0;
while (i <= 7) and (Result = -1) do
begin
if FArrows[i].HitTest(AX - FArrows[i].CurrentX, AY - FArrows[i].CurrentY) then
Result := i;
Inc(i);
end;
end;
procedure TOverlayUI.Draw(AContext: TOpenGLControl);
begin
if FVisible then
begin
FArrows[0].DrawGL(10, 10, FActiveArrow = 0);
FArrows[1].DrawGL(AContext.Width div 2 - FArrows[1].Width div 2, 10,
FActiveArrow = 1);
FArrows[2].DrawGL(AContext.Width - 10 - FArrows[2].Width, 10,
FActiveArrow = 2);
FArrows[3].DrawGL(AContext.Width - 10 - FArrows[3].Width,
AContext.Height div 2 - FArrows[3].Height div 2,
FActiveArrow = 3);
FArrows[4].DrawGL(AContext.Width - 10 - FArrows[4].Width,
AContext.Height - 10 - FArrows[4].Height,
FActiveArrow = 4);
FArrows[5].DrawGL(AContext.Width div 2 - FArrows[5].Width div 2,
AContext.Height - 10 - FArrows[5].Height,
FActiveArrow = 5);
FArrows[6].DrawGL(10, AContext.Height - 10 - FArrows[6].Height,
FActiveArrow = 6);
FArrows[7].DrawGL(10, AContext.Height div 2 - FArrows[7].Height div 2,
FActiveArrow = 7);
end;
end;
end.
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
*)
unit UOverlayUI;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Gl, GLU, ImagingTypes, ImagingClasses, ImagingOpenGL,
OpenGLContext, ImagingUtility;
type
{ TGLArrow }
TGLArrow = class(TObject)
constructor Create(AGraphic: TSingleImage);
destructor Destroy; override;
protected
FGraphic: TSingleImage;
FTexture: GLuint;
FRealWidth: Integer;
FRealHeight: Integer;
FWidth: Integer;
FHeight: Integer;
FCurrentX: Integer;
FCurrentY: Integer;
procedure UpdateTexture;
public
property Width: Integer read FWidth;
property Height: Integer read FHeight;
property CurrentX: Integer read FCurrentX;
property CurrentY: Integer read FCurrentY;
function HitTest(AX, AY: Integer): Boolean;
procedure DrawGL(AX, AY: Integer; AActive: Boolean = False);
end;
{ TOverlayUI }
TOverlayUI = class(TObject)
constructor Create;
destructor Destroy; override;
protected
FArrows: array[0..7] of TGLArrow;
FActiveArrow: Integer;
FVisible: Boolean;
public
property ActiveArrow: Integer read FActiveArrow write FActiveArrow;
property Visible: Boolean read FVisible write FVisible;
function HitTest(AX, AY: Integer): Integer;
procedure Draw(AContext: TOpenGLControl);
end;
implementation
uses
UResourceManager;
{ TGLArrow }
constructor TGLArrow.Create(AGraphic: TSingleImage);
var
caps: TGLTextureCaps;
begin
inherited Create;
FRealWidth := AGraphic.Width;
FRealHeight := AGraphic.Height;
GetGLTextureCaps(caps);
if caps.NonPowerOfTwo then
begin
FWidth := FRealHeight;
FHeight := FRealHeight;
end else
begin
if IsPow2(FRealWidth) then FWidth := FRealWidth else FWidth := NextPow2(FRealWidth);
if IsPow2(FRealHeight) then FHeight := FRealHeight else FHeight := NextPow2(FRealHeight);
end;
FGraphic := TSingleImage.CreateFromParams(FWidth, FHeight, ifA8R8G8B8);
AGraphic.CopyTo(0, 0, FRealWidth, FRealHeight, FGraphic, 0, 0);
FTexture := 0;
end;
destructor TGLArrow.Destroy;
begin
if FGraphic <> nil then FreeAndNil(FGraphic);
if FTexture <> 0 then glDeleteTextures(1, @FTexture);
inherited Destroy;
end;
procedure TGLArrow.UpdateTexture;
begin
if (FGraphic <> nil) and (FRealWidth > 0) and (FRealWidth > 0) then
begin
FTexture := CreateGLTextureFromImage(FGraphic.ImageDataPointer^, 0, 0, False);
glBindTexture(GL_TEXTURE_2D, FTexture);
glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST);
glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_NEAREST);
glTexParameterf(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP);
glTexParameterf(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP);
end;
end;
function TGLArrow.HitTest(AX, AY: Integer): Boolean;
begin
if (AX > -1) and (AX < FRealWidth) and (AY > -1) and (AY < FRealHeight) then
begin
Result := (FGraphic <> nil) and (Cardinal(PIntegerArray(FGraphic.Bits)^[AY * FWidth + AX] and $FF000000) > 0);
end else
Result := False;
end;
procedure TGLArrow.DrawGL(AX, AY: Integer; AActive: Boolean = False);
begin
FCurrentX := AX;
FCurrentY := AY;
if FTexture = 0 then UpdateTexture;
if FTexture <> 0 then
begin
if AActive then
begin
glEnable(GL_COLOR_LOGIC_OP);
glLogicOp(GL_COPY_INVERTED);
end;
glBindTexture(GL_TEXTURE_2D, FTexture);
glBegin(GL_QUADS);
glTexCoord2f(0, 0); glVertex2d(AX, AY);
glTexCoord2f(1, 0); glVertex2d(AX + FWidth, AY);
glTexCoord2f(1, 1); glVertex2d(AX + FWidth, AY + FHeight);
glTexCoord2f(0, 1); glVertex2d(AX, AY + FHeight);
glEnd;
if AActive then
glDisable(GL_COLOR_LOGIC_OP);
end;
end;
{ TOverlayUI }
constructor TOverlayUI.Create;
var
i: Integer;
arrow: TSingleImage;
begin
inherited Create;
FActiveArrow := -1;
FVisible := False;
arrow := TSingleImage.CreateFromStream(ResourceManager.GetResource(0));
for i := 0 to 3 do
begin
FArrows[2*i] := TGLArrow.Create(arrow);
arrow.Rotate(-90);
end;
arrow.Free;
arrow := TSingleImage.CreateFromStream(ResourceManager.GetResource(1));
for i := 0 to 3 do
begin
FArrows[2*i+1] := TGLArrow.Create(arrow);
arrow.Rotate(-90);
end;
arrow.Free;
end;
destructor TOverlayUI.Destroy;
var
i: Integer;
begin
for i := 0 to 7 do
if FArrows[i] <> nil then FreeAndNil(FArrows[i]);
inherited Destroy;
end;
function TOverlayUI.HitTest(AX, AY: Integer): Integer;
var
i: Integer;
begin
Result := -1;
i := 0;
while (i <= 7) and (Result = -1) do
begin
if FArrows[i].HitTest(AX - FArrows[i].CurrentX, AY - FArrows[i].CurrentY) then
Result := i;
Inc(i);
end;
end;
procedure TOverlayUI.Draw(AContext: TOpenGLControl);
begin
if FVisible then
begin
FArrows[0].DrawGL(10, 10, FActiveArrow = 0);
FArrows[1].DrawGL(AContext.Width div 2 - FArrows[1].Width div 2, 10,
FActiveArrow = 1);
FArrows[2].DrawGL(AContext.Width - 10 - FArrows[2].Width, 10,
FActiveArrow = 2);
FArrows[3].DrawGL(AContext.Width - 10 - FArrows[3].Width,
AContext.Height div 2 - FArrows[3].Height div 2,
FActiveArrow = 3);
FArrows[4].DrawGL(AContext.Width - 10 - FArrows[4].Width,
AContext.Height - 10 - FArrows[4].Height,
FActiveArrow = 4);
FArrows[5].DrawGL(AContext.Width div 2 - FArrows[5].Width div 2,
AContext.Height - 10 - FArrows[5].Height,
FActiveArrow = 5);
FArrows[6].DrawGL(10, AContext.Height - 10 - FArrows[6].Height,
FActiveArrow = 6);
FArrows[7].DrawGL(10, AContext.Height div 2 - FArrows[7].Height div 2,
FActiveArrow = 7);
end;
end;
end.

11
Client/UfrmLogin.lfm
View File

@ -16,8 +16,8 @@ object frmLogin: TfrmLogin
ShowInTaskBar = stAlways
LCLVersion = '0.9.25'
object lblCopyright: TLabel
Height = 25
Top = 240
Height = 26
Top = 239
Width = 489
Align = alBottom
Alignment = taCenter
@ -151,6 +151,7 @@ object frmLogin: TfrmLogin
233023312332233323342335517451745174222C0A2251745174517451745174
51745174517451745174517451745174517451745174227D3B0A
}
Transparent = True
end
object imgUsername: TImage
Left = 6
@ -242,6 +243,7 @@ object frmLogin: TfrmLogin
233123322333233423355174517451745174222C0A2251745174517451745174
51745174517451745174517451745174517451745174227D3B0A
}
Transparent = True
end
object imgPassword: TImage
Left = 6
@ -323,6 +325,7 @@ object frmLogin: TfrmLogin
5174222C0A2251742349234A236E234B51745174517451745174517451745174
517451745174227D3B0A
}
Transparent = True
end
object edHost: TEdit
Left = 101
@ -432,11 +435,11 @@ object frmLogin: TfrmLogin
end
object GroupBox1: TGroupBox
Left = 336
Height = 84
Height = 88
Top = 112
Width = 145
Caption = 'Profiles'
ClientHeight = 69
ClientHeight = 73
ClientWidth = 141
ParentFont = True
TabOrder = 3

2
Client/UfrmMain.pas
View File

@ -619,6 +619,8 @@ begin
if tile is TMapCell then
begin
if frmElevateSettings.cbRandomHeight.Checked then
Inc(z, Random(frmElevateSettings.seRandomHeight.Value));
dmNetwork.Send(TDrawMapPacket.Create(tile.X, tile.Y,
z, tile.TileID));
end else

1
Client/UfrmRegionControl.lfm
View File

@ -12,6 +12,7 @@ object frmRegionControl: TfrmRegionControl
OnDestroy = FormDestroy
OnShow = FormShow
Position = poOwnerFormCenter
ShowInTaskBar = stAlways
LCLVersion = '0.9.25'
object Panel1: TPanel
Height = 359

2
Client/UfrmRegionControl.pas
View File

@ -345,6 +345,8 @@ var
areaInfo: PRect;
p: TPoint;
begin
if vstRegions.GetFirstSelected = nil then Exit;
FAreaMove := [];
p := Point(X * 8, Y * 8);
match := nil;

45
Imaging/Imaging.pas
View File

@ -1,5 +1,5 @@
{
$Id: Imaging.pas 99 2007-06-26 04:12:01Z galfar $
$Id: Imaging.pas 124 2008-04-21 09:47:07Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
@ -1573,6 +1573,8 @@ function GenerateMipMaps(const Image: TImageData; Levels: LongInt;
var MipMaps: TDynImageDataArray): Boolean;
var
Width, Height, I, Count: LongInt;
Info: TImageFormatInfo;
CompatibleCopy: TImageData;
begin
Result := False;
if TestImage(Image) then
@ -1585,6 +1587,20 @@ begin
if (Levels <= 0) or (Levels > Count) then
Levels := Count;
// If we have special format image we create copy to allow pixel access.
// This is also done in FillMipMapLevel which is called for each level
// but then the main big image would be converted to compatible
// for every level.
GetImageFormatInfo(Image.Format, Info);
if Info.IsSpecial then
begin
InitImage(CompatibleCopy);
CloneImage(Image, CompatibleCopy);
ConvertImage(CompatibleCopy, ifDefault);
end
else
CompatibleCopy := Image;
FreeImagesInArray(MipMaps);
SetLength(MipMaps, Levels);
CloneImage(Image, MipMaps[0]);
@ -1595,8 +1611,17 @@ begin
Height := Height shr 1;
if Width < 1 then Width := 1;
if Height < 1 then Height := 1;
FillMipMapLevel(MipMaps[I - 1], Width, Height, MipMaps[I]);
FillMipMapLevel(CompatibleCopy, Width, Height, MipMaps[I]);
end;
if CompatibleCopy.Format <> MipMaps[0].Format then
begin
// Must convert smaller levels to proper format
for I := 1 to High(MipMaps) do
ConvertImage(MipMaps[I], MipMaps[0].Format);
FreeImage(CompatibleCopy);
end;
Result := True;
except
RaiseImaging(SErrorGenerateMipMaps, [Levels, ImageToStr(Image)]);
@ -3262,15 +3287,13 @@ finalization
File Notes:
-- TODOS ----------------------------------------------------
- make searching for the closest color in palette much faster - MapImageToPal
- investigate CopyPixel and ComparePixels inline problems - line 550
- add to low level interface function
CreateImageFromRawData(W, H, Bpp, Data, Align, Flipped, Endian, ...)
and CreateRawDataFromImage() - use these in BMP loading (align)
and PNG loading (endian)
- add loading of multi images from file sequence
- do not load all frames when only one is required, possible?
(LoadImageFromFile on MNG/DDS)
- nothing now
-- 0.24.3 Changes/Bug Fixes ---------------------------------
- GenerateMipMaps now generates all smaller levels from
original big image (better results when using more advanced filters).
Also conversion to compatible image format is now done here not
in FillMipMapLevel (that is called for every mipmap level).
-- 0.23 Changes/Bug Fixes -----------------------------------
- MakePaletteForImages now works correctly for indexed and special format images

8
Imaging/ImagingBitmap.pas
View File

@ -1,5 +1,5 @@
{
$Id: ImagingBitmap.pas 94 2007-06-21 19:29:49Z galfar $
$Id: ImagingBitmap.pas 129 2008-08-06 20:01:30Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
@ -484,7 +484,7 @@ begin
FPalSize := 1 shl BI.BitCount;
Read(Handle, Palette, FPalSize * SizeOf(TColor32Rec));
end;
for I := 0 to FPalSize - 1 do
for I := 0 to Info.PaletteEntries - 1 do
Palette[I].A := $FF;
end;
@ -802,6 +802,10 @@ initialization
- nothing now
- Add option to choose to save V3 or V4 headers.
-- 0.25.0 Changes/Bug Fixes ---------------------------------
- Fixed problem with indexed BMP loading - some pal entries
could end up with alpha=0.
-- 0.23 Changes/Bug Fixes -----------------------------------
- Now saves bitmaps as bottom-up for better compatibility
(mainly Lazarus' TImage!).

618
Imaging/ImagingCanvases.pas
View File

@ -1,5 +1,5 @@
{
$Id: ImagingCanvases.pas 103 2007-09-15 01:11:14Z galfar $
$Id: ImagingCanvases.pas 131 2008-08-14 15:14:24Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
@ -62,8 +62,10 @@ const
pcDkGray = $FF808080;
MaxPenWidth = 256;
type
EImagingCanvasError = class(EImagingError);
EImagingCanvasBlendingError = class(EImagingError);
{ Fill mode used when drawing filled objects on canvas.}
TFillMode = (
@ -77,6 +79,26 @@ type
pmClear // No drawing done
);
{ Source and destination blending factors for drawing functions with blending.
Blending formula: SrcColor * SrcFactor + DestColor * DestFactor }
TBlendingFactor = (
bfIgnore, // Don't care
bfZero, // For Src and Dest, Factor = (0, 0, 0, 0)
bfOne, // For Src and Dest, Factor = (1, 1, 1, 1)
bfSrcAlpha, // For Src and Dest, Factor = (Src.A, Src.A, Src.A, Src.A)
bfOneMinusSrcAlpha, // For Src and Dest, Factor = (1 - Src.A, 1 - Src.A, 1 - Src.A, 1 - Src.A)
bfDstAlpha, // For Src and Dest, Factor = (Dest.A, Dest.A, Dest.A, Dest.A)
bfOneMinusDstAlpha, // For Src and Dest, Factor = (1 - Dest.A, 1 - Dest.A, 1 - Dest.A, 1 - Dest.A)
bfSrcColor, // For Dest, Factor = (Src.R, Src.R, Src.B, Src.A)
bfOneMinusSrcColor, // For Dest, Factor = (1 - Src.R, 1 - Src.G, 1 - Src.B, 1 - Src.A)
bfDstColor, // For Src, Factor = (Dest.R, Dest.G, Dest.B, Dest.A)
bfOneMinusDstColor // For Src, Factor = (1 - Dest.R, 1 - Dest.G, 1 - Dest.B, 1 - Dest.A)
);
{ Procedure for custom pixel write modes with blending.}
TPixelWriteProc = procedure(const SrcPix: TColorFPRec; DestPtr: PByte;
DestInfo: PImageFormatInfo; SrcFactor, DestFactor: TBlendingFactor);
{ Represents 3x3 convolution filter kernel.}
TConvolutionFilter3x3 = record
Kernel: array[0..2, 0..2] of LongInt;
@ -91,6 +113,13 @@ type
Bias: Single;
end;
TPointTransformFunction = function(const Pixel: TColorFPRec;
Param1, Param2, Param3: Single): TColorFPRec;
TDynFPPixelArray = array of TColorFPRec;
TSelectPixelFunction = function(var Pixels: TDynFPPixelArray): TColorFPRec;
{ Base canvas class for drawing objects, applying effects, and other.
Constructor takes TBaseImage (or pointer to TImageData). Source image
bits are not copied but referenced so all canvas functions affect
@ -104,11 +133,6 @@ type
can use one of fast canvas clases. These descendants of TImagingCanvas
work only for few select formats (or only one) but they are optimized thus
much faster.
--
Canvas in this Imaging version (0.20) is very basic and its purpose is to
act like sort of a preview of things to come.
Update 0.22: Some new stuff added but not much yet.
}
TImagingCanvas = class(TObject)
private
@ -125,6 +149,7 @@ type
procedure SetFillColor32(const Value: TColor32); {$IFDEF USE_INLINE}inline;{$ENDIF}
procedure SetFillColorFP(const Value: TColorFPRec); {$IFDEF USE_INLINE}inline;{$ENDIF}
procedure SetClipRect(const Value: TRect);
procedure CheckBeforeBlending(SrcFactor, DestFactor: TBlendingFactor; DestCanvas: TImagingCanvas);
protected
FPData: PImageData;
FClipRect: TRect;
@ -151,6 +176,11 @@ type
like ellipses and circles.}
procedure HorzLineInternal(X1, X2, Y: LongInt; Color: Pointer; Bpp: LongInt); virtual;
procedure CopyPixelInternal(X, Y: LongInt; Pixel: Pointer; Bpp: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
procedure DrawInternal(const SrcRect: TRect; DestCanvas: TImagingCanvas;
DestX, DestY: Integer; SrcFactor, DestFactor: TBlendingFactor; PixelWriteProc: TPixelWriteProc);
procedure StretchDrawInternal(const SrcRect: TRect; DestCanvas: TImagingCanvas;
const DestRect: TRect; SrcFactor, DestFactor: TBlendingFactor;
Filter: TResizeFilter; PixelWriteProc: TPixelWriteProc);
public
constructor CreateForData(ImageDataPointer: PImageData);
constructor CreateForImage(Image: TBaseImage);
@ -177,6 +207,8 @@ type
procedure FrameRect(const Rect: TRect);
{ Fills given rectangle with current fill settings.}
procedure FillRect(const Rect: TRect); virtual;
{ Fills given rectangle with current fill settings and pixel blending.}
procedure FillRectBlend(const Rect: TRect; SrcFactor, DestFactor: TBlendingFactor);
{ Draws rectangle which is outlined by using the current pen settings and
filled by using the current fill settings.}
procedure Rectangle(const Rect: TRect);
@ -185,6 +217,34 @@ type
of ellipse to be drawn.}
procedure Ellipse(const Rect: TRect);
{ Draws contents of this canvas onto another canvas with pixel blending.
Blending factors are chosen using TBlendingFactor parameters.
Resulting destination pixel color is:
SrcColor * SrcFactor + DstColor * DstFactor}
procedure DrawBlend(const SrcRect: TRect; DestCanvas: TImagingCanvas;
DestX, DestY: Integer; SrcFactor, DestFactor: TBlendingFactor);
{ Draws contents of this canvas onto another one with typical alpha
blending (Src 'over' Dest, factors are bfSrcAlpha and bfOneMinusSrcAlpha.)}
procedure DrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: Integer);
{ Draws contents of this canvas onto another one using additive blending
(source and dest factors are bfOne).}
procedure DrawAdd(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: Integer);
{ Draws stretched and filtered contents of this canvas onto another canvas
with pixel blending. Blending factors are chosen using TBlendingFactor parameters.
Resulting destination pixel color is:
SrcColor * SrcFactor + DstColor * DstFactor}
procedure StretchDrawBlend(const SrcRect: TRect; DestCanvas: TImagingCanvas;
const DestRect: TRect; SrcFactor, DestFactor: TBlendingFactor;
Filter: TResizeFilter = rfBilinear);
{ Draws contents of this canvas onto another one with typical alpha
blending (Src 'over' Dest, factors are bfSrcAlpha and bfOneMinusSrcAlpha.)}
procedure StretchDrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas;
const DestRect: TRect; Filter: TResizeFilter = rfBilinear);
{ Draws contents of this canvas onto another one using additive blending
(source and dest factors are bfOne).}
procedure StretchDrawAdd(const SrcRect: TRect; DestCanvas: TImagingCanvas;
const DestRect: TRect; Filter: TResizeFilter = rfBilinear);
{ Convolves canvas' image with given 3x3 filter kernel. You can use
predefined filter kernels or define your own.}
procedure ApplyConvolution3x3(const Filter: TConvolutionFilter3x3);
@ -201,6 +261,36 @@ type
procedure ApplyConvolution(Kernel: PLongInt; KernelSize, Divisor: LongInt;
Bias: Single = 0.0; ClampChannels: Boolean = True); virtual;
{ Applies custom non-linear filter. Filter size is diameter of pixel
neighborhood. Typical values are 3, 5, or 7. }
procedure ApplyNonLinearFilter(FilterSize: Integer; SelectFunc: TSelectPixelFunction);
{ Applies median non-linear filter with user defined pixel neighborhood.
Selects median pixel from the neighborhood as new pixel
(current implementation is quite slow).}
procedure ApplyMedianFilter(FilterSize: Integer);
{ Applies min non-linear filter with user defined pixel neighborhood.
Selects min pixel from the neighborhood as new pixel.}
procedure ApplyMinFilter(FilterSize: Integer);
{ Applies max non-linear filter with user defined pixel neighborhood.
Selects max pixel from the neighborhood as new pixel.}
procedure ApplyMaxFilter(FilterSize: Integer);
{ Transforms pixels one by one by given function. Pixel neighbors are
not taken into account. Param 1-3 are optional parameters
for transform function.}
procedure PointTransform(Transform: TPointTransformFunction;
Param1, Param2, Param3: Single);
{ Modifies image contrast and brightness. Parameters should be
in range <-100; 100>.}
procedure ModifyContrastBrightness(Contrast, Brightness: Single);
{ Gamma correction of individual color channels. Range is (0, +inf),
1.0 means no change.}
procedure GammaCorection(Red, Green, Blue: Single);
{ Inverts colors of all image pixels, makes negative image.}
procedure InvertColors;
{ Simple single level thresholding with threshold level for each color channel.}
procedure Threshold(Red, Green, Blue: Single);
{ Color used when drawing lines, frames, and outlines of objects.}
property PenColor32: TColor32 read FPenColor32 write SetPenColor32;
{ Color used when drawing lines, frames, and outlines of objects.}
@ -384,6 +474,7 @@ const
(-1, -2, -1));
Divisor: 4);
{ Kernel for 3x3 contour enhancement filter.}
FilterTraceControur3x3: TConvolutionFilter3x3 = (
Kernel: ((-6, -6, -2),
(-1, 32, -1),
@ -466,7 +557,173 @@ begin
Result := FindBestCanvasForImage(Image.Format);
end;
{ TImagingCanvas }
{ Canvas helper functions }
procedure PixelBlendProc(const SrcPix: TColorFPRec; DestPtr: PByte;
DestInfo: PImageFormatInfo; SrcFactor, DestFactor: TBlendingFactor);
var
DestPix, FSrc, FDst: TColorFPRec;
begin
// Get set pixel color
DestPix := DestInfo.GetPixelFP(DestPtr, DestInfo, nil);
// Determine current blending factors
case SrcFactor of
bfZero: FSrc := ColorFP(0, 0, 0, 0);
bfOne: FSrc := ColorFP(1, 1, 1, 1);
bfSrcAlpha: FSrc := ColorFP(SrcPix.A, SrcPix.A, SrcPix.A, SrcPix.A);
bfOneMinusSrcAlpha: FSrc := ColorFP(1 - SrcPix.A, 1 - SrcPix.A, 1 - SrcPix.A, 1 - SrcPix.A);
bfDstAlpha: FSrc := ColorFP(DestPix.A, DestPix.A, DestPix.A, DestPix.A);
bfOneMinusDstAlpha: FSrc := ColorFP(1 - DestPix.A, 1 - DestPix.A, 1 - DestPix.A, 1 - DestPix.A);
bfDstColor: FSrc := ColorFP(DestPix.A, DestPix.R, DestPix.G, DestPix.B);
bfOneMinusDstColor: FSrc := ColorFP(1 - DestPix.A, 1 - DestPix.R, 1 - DestPix.G, 1 - DestPix.B);
end;
case DestFactor of
bfZero: FDst := ColorFP(0, 0, 0, 0);
bfOne: FDst := ColorFP(1, 1, 1, 1);
bfSrcAlpha: FDst := ColorFP(SrcPix.A, SrcPix.A, SrcPix.A, SrcPix.A);
bfOneMinusSrcAlpha: FDst := ColorFP(1 - SrcPix.A, 1 - SrcPix.A, 1 - SrcPix.A, 1 - SrcPix.A);
bfDstAlpha: FDst := ColorFP(DestPix.A, DestPix.A, DestPix.A, DestPix.A);
bfOneMinusDstAlpha: FDst := ColorFP(1 - DestPix.A, 1 - DestPix.A, 1 - DestPix.A, 1 - DestPix.A);
bfSrcColor: FDst := ColorFP(SrcPix.A, SrcPix.R, SrcPix.G, SrcPix.B);
bfOneMinusSrcColor: FDst := ColorFP(1 - SrcPix.A, 1 - SrcPix.R, 1 - SrcPix.G, 1 - SrcPix.B);
end;
// Compute blending formula
DestPix.R := SrcPix.R * FSrc.R + DestPix.R * FDst.R;
DestPix.G := SrcPix.G * FSrc.G + DestPix.G * FDst.G;
DestPix.B := SrcPix.B * FSrc.B + DestPix.B * FDst.B;
DestPix.A := SrcPix.A * FSrc.A + DestPix.A * FDst.A;
// Write blended pixel
DestInfo.SetPixelFP(DestPtr, DestInfo, nil, DestPix);
end;
procedure PixelAlphaProc(const SrcPix: TColorFPRec; DestPtr: PByte;
DestInfo: PImageFormatInfo; SrcFactor, DestFactor: TBlendingFactor);
var
DestPix: TColorFPRec;
begin
DestPix := DestInfo.GetPixelFP(DestPtr, DestInfo, nil);
// Blend the two pixels (Src 'over' Dest alpha composition operation)
DestPix.R := SrcPix.R * SrcPix.A + DestPix.R * DestPix.A * (1.0 - SrcPix.A);
DestPix.G := SrcPix.G * SrcPix.A + DestPix.G * DestPix.A * (1.0 - SrcPix.A);
DestPix.B := SrcPix.B * SrcPix.A + DestPix.B * DestPix.A * (1.0 - SrcPix.A);
DestPix.A := SrcPix.A + DestPix.A * (1.0 - SrcPix.A);
// Write blended pixel
DestInfo.SetPixelFP(DestPtr, DestInfo, nil, DestPix);
end;
procedure PixelAddProc(const SrcPix: TColorFPRec; DestPtr: PByte;
DestInfo: PImageFormatInfo; SrcFactor, DestFactor: TBlendingFactor);
var
DestPix: TColorFPRec;
begin
// Just add Src and Dest
DestPix := DestInfo.GetPixelFP(DestPtr, DestInfo, nil);
DestPix.R := SrcPix.R + DestPix.R;
DestPix.G := SrcPix.G + DestPix.G;
DestPix.B := SrcPix.B + DestPix.B;
DestPix.A := SrcPix.A + DestPix.A;
DestInfo.SetPixelFP(DestPtr, DestInfo, nil, DestPix);
end;
function CompareColors(const C1, C2: TColorFPRec): Single; {$IFDEF USE_INLINE}inline;{$ENDIF}
begin
Result := (C1.R * GrayConv.R + C1.G * GrayConv.G + C1.B * GrayConv.B) -
(C2.R * GrayConv.R + C2.G * GrayConv.G + C2.B * GrayConv.B);
end;
function MedianSelect(var Pixels: TDynFPPixelArray): TColorFPRec;
procedure QuickSort(L, R: Integer);
var
I, J: Integer;
P, Temp: TColorFPRec;
begin
repeat
I := L;
J := R;
P := Pixels[(L + R) shr 1];
repeat
while CompareColors(Pixels[I], P) < 0 do Inc(I);
while CompareColors(Pixels[J], P) > 0 do Dec(J);
if I <= J then
begin
Temp := Pixels[I];
Pixels[I] := Pixels[J];
Pixels[J] := Temp;
Inc(I);
Dec(J);
end;
until I > J;
if L < J then
QuickSort(L, J);
L := I;
until I >= R;
end;
begin
// First sort pixels
QuickSort(0, High(Pixels));
// Select middle pixel
Result := Pixels[Length(Pixels) div 2];
end;
function MinSelect(var Pixels: TDynFPPixelArray): TColorFPRec;
var
I: Integer;
begin
Result := Pixels[0];
for I := 1 to High(Pixels) do
begin
if CompareColors(Pixels[I], Result) < 0 then
Result := Pixels[I];
end;
end;
function MaxSelect(var Pixels: TDynFPPixelArray): TColorFPRec;
var
I: Integer;
begin
Result := Pixels[0];
for I := 1 to High(Pixels) do
begin
if CompareColors(Pixels[I], Result) > 0 then
Result := Pixels[I];
end;
end;
function TransformContrastBrightness(const Pixel: TColorFPRec; C, B, Ignore: Single): TColorFPRec;
begin
Result.A := Pixel.A;
Result.R := Pixel.R * C + B;
Result.G := Pixel.G * C + B;
Result.B := Pixel.B * C + B;
end;
function TransformGamma(const Pixel: TColorFPRec; R, G, B: Single): TColorFPRec;
begin
Result.A := Pixel.A;
Result.R := Power(Pixel.R, 1.0 / R);
Result.G := Power(Pixel.G, 1.0 / G);
Result.B := Power(Pixel.B, 1.0 / B);
end;
function TransformInvert(const Pixel: TColorFPRec; A, B, C: Single): TColorFPRec;
begin
Result.A := Pixel.A;
Result.R := 1.0 - Pixel.R;
Result.G := 1.0 - Pixel.G;
Result.B := 1.0 - Pixel.B;
end;
function TransformThreshold(const Pixel: TColorFPRec; R, G, B: Single): TColorFPRec;
begin
Result.A := Pixel.A;
Result.R := IffFloat(Pixel.R >= R, 1.0, 0.0);
Result.G := IffFloat(Pixel.G >= G, 1.0, 0.0);
Result.B := IffFloat(Pixel.B >= B, 1.0, 0.0);
end;
{ TImagingCanvas class implementation }
constructor TImagingCanvas.CreateForData(ImageDataPointer: PImageData);
begin
@ -568,6 +825,17 @@ begin
IntersectRect(FClipRect, FClipRect, Rect(0, 0, FPData.Width, FPData.Height));
end;
procedure TImagingCanvas.CheckBeforeBlending(SrcFactor,
DestFactor: TBlendingFactor; DestCanvas: TImagingCanvas);
begin
if SrcFactor in [bfSrcColor, bfOneMinusSrcColor] then
raise EImagingCanvasBlendingError.Create('Invalid source blending factor. Check the documentation for TBlendingFactor.');
if DestFactor in [bfDstColor, bfOneMinusDstColor] then
raise EImagingCanvasBlendingError.Create('Invalid destination blending factor. Check the documentation for TBlendingFactor.');
if DestCanvas.FormatInfo.IsIndexed then
raise EImagingCanvasBlendingError.Create('Blending destination canvas cannot be in indexed mode.');
end;
function TImagingCanvas.GetPixelPointer(X, Y: LongInt): Pointer;
begin
Result := @PByteArray(FPData.Bits)[(Y * FPData.Width + X) * FFormatInfo.BytesPerPixel]
@ -810,6 +1078,28 @@ begin
end;
end;
procedure TImagingCanvas.FillRectBlend(const Rect: TRect; SrcFactor,
DestFactor: TBlendingFactor);
var
DstRect: TRect;
X, Y: Integer;
Line: PByte;
begin
if (FFillMode <> fmClear) and IntersectRect(DstRect, Rect, FClipRect) then
begin
CheckBeforeBlending(SrcFactor, DestFactor, Self);
for Y := DstRect.Top to DstRect.Bottom - 1 do
begin
Line := @PByteArray(FPData.Bits)[(Y * FPData.Width + DstRect.Left) * FFormatInfo.BytesPerPixel];
for X := DstRect.Left to DstRect.Right - 1 do
begin
PixelBlendProc(FFillColorFP, Line, @FFormatInfo, SrcFactor, DestFactor);
Inc(Line, FFormatInfo.BytesPerPixel);
end;
end;
end;
end;
procedure TImagingCanvas.Rectangle(const Rect: TRect);
begin
FillRect(Rect);
@ -885,6 +1175,186 @@ begin
end;
end;
procedure TImagingCanvas.DrawInternal(const SrcRect: TRect;
DestCanvas: TImagingCanvas; DestX, DestY: Integer; SrcFactor,
DestFactor: TBlendingFactor; PixelWriteProc: TPixelWriteProc);
var
X, Y, SrcX, SrcY, Width, Height, SrcBpp, DestBpp: Integer;
PSrc: TColorFPRec;
SrcPointer, DestPointer: PByte;
begin
CheckBeforeBlending(SrcFactor, DestFactor, DestCanvas);
SrcX := SrcRect.Left;
SrcY := SrcRect.Top;
Width := SrcRect.Right - SrcRect.Left;
Height := SrcRect.Bottom - SrcRect.Top;
SrcBpp := FFormatInfo.BytesPerPixel;
DestBpp := DestCanvas.FFormatInfo.BytesPerPixel;
// Clip src and dst rects
ClipCopyBounds(SrcX, SrcY, Width, Height, DestX, DestY,
FPData.Width, FPData.Height, DestCanvas.ClipRect);
for Y := 0 to Height - 1 do
begin
// Get src and dst scanlines
SrcPointer := @PByteArray(FPData.Bits)[((SrcY + Y) * FPData.Width + SrcX) * SrcBpp];
DestPointer := @PByteArray(DestCanvas.FPData.Bits)[((DestY + Y) * DestCanvas.FPData.Width + DestX) * DestBpp];
for X := 0 to Width - 1 do
begin
PSrc := FFormatInfo.GetPixelFP(SrcPointer, @FFormatInfo, FPData.Palette);
// Call pixel writer procedure - combine source and dest pixels
PixelWriteProc(PSrc, DestPointer, @DestCanvas.FFormatInfo, SrcFactor, DestFactor);
// Increment pixel pointers
Inc(SrcPointer, SrcBpp);
Inc(DestPointer, DestBpp);
end;
end;
end;
procedure TImagingCanvas.DrawBlend(const SrcRect: TRect; DestCanvas: TImagingCanvas;
DestX, DestY: Integer; SrcFactor, DestFactor: TBlendingFactor);
begin
DrawInternal(SrcRect, DestCanvas, DestX, DestY, SrcFactor, DestFactor, PixelBlendProc);
end;
procedure TImagingCanvas.DrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas;
DestX, DestY: Integer);
begin
DrawInternal(SrcRect, DestCanvas, DestX, DestY, bfIgnore, bfIgnore, PixelAlphaProc);
end;
procedure TImagingCanvas.DrawAdd(const SrcRect: TRect;
DestCanvas: TImagingCanvas; DestX, DestY: Integer);
begin
DrawInternal(SrcRect, DestCanvas, DestX, DestY, bfIgnore, bfIgnore, PixelAddProc);
end;
procedure TImagingCanvas.StretchDrawInternal(const SrcRect: TRect;
DestCanvas: TImagingCanvas; const DestRect: TRect;
SrcFactor, DestFactor: TBlendingFactor; Filter: TResizeFilter;
PixelWriteProc: TPixelWriteProc);
const
FilterMapping: array[TResizeFilter] of TSamplingFilter =
(sfNearest, sfLinear, DefaultCubicFilter);
var
X, Y, I, J, SrcX, SrcY, SrcWidth, SrcHeight: Integer;
DestX, DestY, DestWidth, DestHeight, SrcBpp, DestBpp: Integer;
SrcPix, PDest: TColorFPRec;
MapX, MapY: TMappingTable;
XMinimum, XMaximum: Integer;
LineBuffer: array of TColorFPRec;
ClusterX, ClusterY: TCluster;
Weight, AccumA, AccumR, AccumG, AccumB: Single;
DestLine: PByte;
FilterFunction: TFilterFunction;
Radius: Single;
begin
CheckBeforeBlending(SrcFactor, DestFactor, DestCanvas);
SrcX := SrcRect.Left;
SrcY := SrcRect.Top;
SrcWidth := SrcRect.Right - SrcRect.Left;
SrcHeight := SrcRect.Bottom - SrcRect.Top;
DestX := DestRect.Left;
DestY := DestRect.Top;
DestWidth := DestRect.Right - DestRect.Left;
DestHeight := DestRect.Bottom - DestRect.Top;
SrcBpp := FFormatInfo.BytesPerPixel;
DestBpp := DestCanvas.FFormatInfo.BytesPerPixel;
// Get actual resampling filter and radius
FilterFunction := SamplingFilterFunctions[FilterMapping[Filter]];
Radius := SamplingFilterRadii[FilterMapping[Filter]];
// Clip src and dst rects
ClipStretchBounds(SrcX, SrcY, SrcWidth, SrcHeight, DestX, DestY, DestWidth, DestHeight,
FPData.Width, FPData.Height, DestCanvas.ClipRect);
// Generate mapping tables
MapX := BuildMappingTable(DestX, DestX + DestWidth, SrcX, SrcX + SrcWidth,
FPData.Width, FilterFunction, Radius, False);
MapY := BuildMappingTable(DestY, DestY + DestHeight, SrcY, SrcY + SrcHeight,
FPData.Height, FilterFunction, Radius, False);
FindExtremes(MapX, XMinimum, XMaximum);
SetLength(LineBuffer, XMaximum - XMinimum + 1);
for J := 0 to DestHeight - 1 do
begin
ClusterY := MapY[J];
for X := XMinimum to XMaximum do
begin
AccumA := 0.0;
AccumR := 0.0;
AccumG := 0.0;
AccumB := 0.0;
for Y := 0 to Length(ClusterY) - 1 do
begin
Weight := ClusterY[Y].Weight;
SrcPix := FFormatInfo.GetPixelFP(@PByteArray(FPData.Bits)[(ClusterY[Y].Pos * FPData.Width + X) * SrcBpp],
@FFormatInfo, FPData.Palette);
AccumB := AccumB + SrcPix.B * Weight;
AccumG := AccumG + SrcPix.G * Weight;
AccumR := AccumR + SrcPix.R * Weight;
AccumA := AccumA + SrcPix.A * Weight;
end;
with LineBuffer[X - XMinimum] do
begin
A := AccumA;
R := AccumR;
G := AccumG;
B := AccumB;
end;
end;
DestLine := @PByteArray(DestCanvas.FPData.Bits)[((J + DestY) * DestCanvas.FPData.Width + DestX) * DestBpp];
for I := 0 to DestWidth - 1 do
begin
ClusterX := MapX[I];
AccumA := 0.0;
AccumR := 0.0;
AccumG := 0.0;
AccumB := 0.0;
for X := 0 to Length(ClusterX) - 1 do
begin
Weight := ClusterX[X].Weight;
with LineBuffer[ClusterX[X].Pos - XMinimum] do
begin
AccumB := AccumB + B * Weight;
AccumG := AccumG + G * Weight;
AccumR := AccumR + R * Weight;
AccumA := AccumA + A * Weight;
end;
end;
SrcPix.A := AccumA;
SrcPix.R := AccumR;
SrcPix.G := AccumG;
SrcPix.B := AccumB;
// Write resulting blended pixel
PixelWriteProc(SrcPix, DestLine, @DestCanvas.FFormatInfo, SrcFactor, DestFactor);
Inc(DestLine, DestBpp);
end;
end;
end;
procedure TImagingCanvas.StretchDrawBlend(const SrcRect: TRect;
DestCanvas: TImagingCanvas; const DestRect: TRect;
SrcFactor, DestFactor: TBlendingFactor; Filter: TResizeFilter);
begin
StretchDrawInternal(SrcRect, DestCanvas, DestRect, SrcFactor, DestFactor, Filter, PixelBlendProc);
end;
procedure TImagingCanvas.StretchDrawAlpha(const SrcRect: TRect;
DestCanvas: TImagingCanvas; const DestRect: TRect; Filter: TResizeFilter);
begin
StretchDrawInternal(SrcRect, DestCanvas, DestRect, bfIgnore, bfIgnore, Filter, PixelAlphaProc);
end;
procedure TImagingCanvas.StretchDrawAdd(const SrcRect: TRect;
DestCanvas: TImagingCanvas; const DestRect: TRect; Filter: TResizeFilter);
begin
StretchDrawInternal(SrcRect, DestCanvas, DestRect, bfIgnore, bfIgnore, Filter, PixelAddProc);
end;
procedure TImagingCanvas.ApplyConvolution(Kernel: PLongInt; KernelSize,
Divisor: LongInt; Bias: Single; ClampChannels: Boolean);
var
@ -917,11 +1387,11 @@ begin
for J := 0 to KernelSize - 1 do
begin
PosY := ClampInt(Y + J - SizeDiv2, FClipRect.Top, FClipRect.Bottom);
PosY := ClampInt(Y + J - SizeDiv2, FClipRect.Top, FClipRect.Bottom - 1);
for I := 0 to KernelSize - 1 do
begin
PosX := ClampInt(X + I - SizeDiv2, FClipRect.Left, FClipRect.Right);
PosX := ClampInt(X + I - SizeDiv2, FClipRect.Left, FClipRect.Right - 1);
SrcPointer := @PByteArray(TempImage.Bits)[PosY * WidthBytes + PosX * Bpp];
// Get pixels from neighbourhood of current pixel and add their
@ -966,12 +1436,126 @@ begin
ApplyConvolution(@Filter.Kernel, 5, Filter.Divisor, Filter.Bias, True);
end;
procedure TImagingCanvas.ApplyNonLinearFilter(FilterSize: Integer; SelectFunc: TSelectPixelFunction);
var
X, Y, I, J, PosY, PosX, SizeDiv2, WidthBytes, Bpp: LongInt;
Pixel: TColorFPRec;
TempImage: TImageData;
DstPointer, SrcPointer: PByte;
NeighPixels: TDynFPPixelArray;
begin
SizeDiv2 := FilterSize div 2;
Bpp := FFormatInfo.BytesPerPixel;
WidthBytes := FPData.Width * Bpp;
SetLength(NeighPixels, FilterSize * FilterSize);
InitImage(TempImage);
CloneImage(FPData^, TempImage);
try
// For every pixel in clip rect
for Y := FClipRect.Top to FClipRect.Bottom - 1 do
begin
DstPointer := @PByteArray(FPData.Bits)[Y * WidthBytes + FClipRect.Left * Bpp];
for X := FClipRect.Left to FClipRect.Right - 1 do
begin
for J := 0 to FilterSize - 1 do
begin
PosY := ClampInt(Y + J - SizeDiv2, FClipRect.Top, FClipRect.Bottom - 1);
for I := 0 to FilterSize - 1 do
begin
PosX := ClampInt(X + I - SizeDiv2, FClipRect.Left, FClipRect.Right - 1);
SrcPointer := @PByteArray(TempImage.Bits)[PosY * WidthBytes + PosX * Bpp];
// Get pixels from neighbourhood of current pixel and store them
Pixel := FFormatInfo.GetPixelFP(SrcPointer, @FFormatInfo, TempImage.Palette);
NeighPixels[J * FilterSize + I] := Pixel;
end;
end;
// Choose pixel using custom function
Pixel := SelectFunc(NeighPixels);
// Set resulting pixel color
FFormatInfo.SetPixelFP(DstPointer, @FFormatInfo, FPData.Palette, Pixel);
Inc(DstPointer, Bpp);
end;
end;
finally
FreeImage(TempImage);
end;
end;
procedure TImagingCanvas.ApplyMedianFilter(FilterSize: Integer);
begin
ApplyNonLinearFilter(FilterSize, MedianSelect);
end;
procedure TImagingCanvas.ApplyMinFilter(FilterSize: Integer);
begin
ApplyNonLinearFilter(FilterSize, MinSelect);
end;
procedure TImagingCanvas.ApplyMaxFilter(FilterSize: Integer);
begin
ApplyNonLinearFilter(FilterSize, MaxSelect);
end;
procedure TImagingCanvas.PointTransform(Transform: TPointTransformFunction;
Param1, Param2, Param3: Single);
var
X, Y, Bpp, WidthBytes: Integer;
PixPointer: PByte;
Pixel: TColorFPRec;
begin
Bpp := FFormatInfo.BytesPerPixel;
WidthBytes := FPData.Width * Bpp;
// For every pixel in clip rect
for Y := FClipRect.Top to FClipRect.Bottom - 1 do
begin
PixPointer := @PByteArray(FPData.Bits)[Y * WidthBytes + FClipRect.Left * Bpp];
for X := FClipRect.Left to FClipRect.Right - 1 do
begin
Pixel := FFormatInfo.GetPixelFP(PixPointer, @FFormatInfo, FPData.Palette);
FFormatInfo.SetPixelFP(PixPointer, @FFormatInfo, FPData.Palette,
Transform(Pixel, Param1, Param2, Param3));
Inc(PixPointer, Bpp);
end;
end;
end;
procedure TImagingCanvas.ModifyContrastBrightness(Contrast, Brightness: Single);
begin
PointTransform(TransformContrastBrightness, 1.0 + Contrast / 100,
Brightness / 100, 0.0);
end;
procedure TImagingCanvas.GammaCorection(Red, Green, Blue: Single);
begin
PointTransform(TransformGamma, Red, Green, Blue);
end;
procedure TImagingCanvas.InvertColors;
begin
PointTransform(TransformInvert, 0, 0, 0);
end;
procedure TImagingCanvas.Threshold(Red, Green, Blue: Single);
begin
PointTransform(TransformThreshold, Red, Green, Blue);
end;
class function TImagingCanvas.GetSupportedFormats: TImageFormats;
begin
Result := [ifIndex8..Pred(ifDXT1)];
end;
{ TFastARGB32Canvas }
destructor TFastARGB32Canvas.Destroy;
@ -1027,12 +1611,18 @@ finalization
File Notes:
-- TODOS ----------------------------------------------------
- more more more ...
- more more more ...
- implement pen width everywhere
- add blending (image and object drawing)
- add image drawing
- add blending (*image and object drawing)
- more objects (arc, polygon)
- add channel write/read masks (like apply conv only on Red channel,...)
-- 0.25.0 Changes/Bug Fixes ---------------------------------
- Fixed error that could cause AV in linear and nonlinear filters.
- Added blended rect filling function FillRectBlend.
- Added drawing function with blending (DrawAlpha, StretchDrawAlpha,
StretchDrawAdd, DrawBlend, StretchDrawBlend, ...)
- Added non-linear filters (min, max, median).
- Added point transforms (invert, contrast, gamma, brightness).
-- 0.21 Changes/Bug Fixes -----------------------------------
- Added some new filter kernels for convolution.

15
Imaging/ImagingClasses.pas
View File

@ -1,5 +1,5 @@
{
$Id: ImagingClasses.pas 94 2007-06-21 19:29:49Z galfar $
$Id: ImagingClasses.pas 124 2008-04-21 09:47:07Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
@ -231,6 +231,8 @@ type
procedure ExchangeImages(Index1, Index2: LongInt);
{ Deletes image at the given position in the image array.}
procedure DeleteImage(Index: LongInt);
{ Rearranges images so that the first image will become last and vice versa.}
procedure ReverseImages;
{ Converts all images to another image data format.}
procedure ConvertImages(Format: TImageFormat);
@ -886,6 +888,14 @@ begin
Imaging.ResizeImage(FDataArray[I], NewWidth, NewHeight, Filter);
end;
procedure TMultiImage.ReverseImages;
var
I: Integer;
begin
for I := 0 to GetImageCount div 2 do
ExchangeImages(I, GetImageCount - 1 - I);
end;
procedure TMultiImage.LoadFromFile(const FileName: string);
begin
if GetImageCount = 0 then
@ -931,6 +941,9 @@ end;
- put all low level stuff here like ReplaceColor etc, change
CopyTo to Copy, and add overload Copy(SrcRect, DstX, DstY) ...
-- 0.24.3 Changes/Bug Fixes ---------------------------------
- Added TMultiImage.ReverseImages method.
-- 0.23 Changes/Bug Fixes -----------------------------------
- Added SwapChannels method to TBaseImage.
- Added ReplaceColor method to TBaseImage.

23
Imaging/ImagingComponents.pas
View File

@ -1,5 +1,5 @@
{
$Id: ImagingComponents.pas 110 2007-11-18 21:23:59Z galfar $
$Id: ImagingComponents.pas 132 2008-08-27 20:37:38Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
@ -114,7 +114,8 @@ type
{ Returns file extensions of this graphic class.}
class function GetFileExtensions: string; override;
{ Returns default MIME type of this graphic class.}
function GetMimeType: string; override;
function GetMimeType: string; override; // uncomment for Laz 0.9.25 if you get error here
//function GetDefaultMimeType: string; override;
{$ENDIF}
{ Default (the most common) file extension of this graphic class.}
property DefaultFileExt: string read FDefaultFileExt;
@ -150,6 +151,7 @@ type
procedure SaveToStream(Stream: TStream); override;
class function GetFileFormat: TImageFileFormat; override;
{$IFDEF COMPONENT_SET_LCL}
//function GetMimeType: string; override; // uncomment for Laz 0.9.25 if you get error here
function GetDefaultMimeType: string; override;
{$ENDIF}
{ See ImagingJpegQuality option for details.}
@ -231,6 +233,7 @@ type
procedure SaveToStream(Stream: TStream); override;
class function GetFileFormat: TImageFileFormat; override;
{$IFDEF COMPONENT_SET_LCL}
//function GetMimeType: string; override; // uncomment for Laz 0.9.25 if you get error here
function GetDefaultMimeType: string; override;
{$ENDIF}
{ See ImagingMNGLossyCompression option for details.}
@ -637,7 +640,6 @@ var
{$IFDEF COMPONENT_SET_LCL}
RawImage: TRawImage;
LineLazBytes: LongInt;
rect: TRect;
{$ENDIF}
begin
{$IFDEF COMPONENT_SET_LCL}
@ -725,9 +727,8 @@ begin
{$ENDIF}
{$IFDEF COMPONENT_SET_LCL}
// Get raw image from bitmap (mask handle must be 0 or expect violations)
{ If you get complitation error here upgrade to Lazarus 0.9.24+ }
rect := Classes.Rect(0, 0, Data.Width, Data.Height);
if RawImage_FromBitmap(RawImage, Bitmap.Handle, 0, @rect) then
if RawImage_FromBitmap(RawImage, Bitmap.Handle, 0, nil) then // uncommnet for Laz 0.9.25 if you get error here
//if RawImage_FromBitmap(RawImage, Bitmap.Handle, 0, Classes.Rect(0, 0, Data.Width, Data.Height)) then
begin
LineLazBytes := GetBytesPerLine(Data.Width, RawImage.Description.BitsPerPixel,
RawImage.Description.LineEnd);
@ -826,10 +827,15 @@ end;
var
P: TPoint;
begin
// If you get compilation errors here with new Lazarus (rev 14368+)
// uncomment commented code and comment the active code below:
P := TGtkDeviceContext(Dest).Offset;
//P := GetDCOffset(TDeviceContext(Dest));
Inc(DstX, P.X);
Inc(DstY, P.Y);
gdk_draw_rgb_32_image(TGtkDeviceContext(Dest).Drawable, TGtkDeviceContext(Dest).GC,
//gdk_draw_rgb_32_image(TDeviceContext(Dest).Drawable, TDeviceContext(Dest).GC,
DstX, DstY, SrcWidth, SrcHeight, GDK_RGB_DITHER_NONE,
@PLongWordArray(ImageData.Bits)[SrcY * ImageData.Width + SrcX], ImageData.Width * 4);
end;
@ -1014,7 +1020,8 @@ begin
Result := StringReplace(GetFileFormat.Extensions.CommaText, ',', ';', [rfReplaceAll]);
end;
function TImagingGraphicForSave.GetMimeType: string;
function TImagingGraphicForSave.GetMimeType: string; // uncomment for Laz 0.9.25 if you get error here
//function TImagingGraphicForSave.GetDefaultMimeType: string;
begin
Result := 'image/' + FDefaultFileExt;
end;
@ -1061,6 +1068,7 @@ begin
end;
{$IFDEF COMPONENT_SET_LCL}
//function TImagingJpeg.GetMimeType: string; // uncomment for Laz 0.9.25 if you get error here
function TImagingJpeg.GetDefaultMimeType: string;
begin
Result := 'image/jpeg';
@ -1193,6 +1201,7 @@ begin
end;
{$IFDEF COMPONENT_SET_LCL}
//function TImagingMNG.GetMimeType: string; // uncomment for Laz 0.9.25 if you get error here
function TImagingMNG.GetDefaultMimeType: string;
begin
Result := 'video/mng';

15
Imaging/ImagingDds.pas
View File

@ -1,5 +1,5 @@
{
$Id: ImagingDds.pas 100 2007-06-28 21:09:52Z galfar $
$Id: ImagingDds.pas 129 2008-08-06 20:01:30Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
@ -102,7 +102,7 @@ const
DDSSupportedFormats: TImageFormats = [ifR8G8B8, ifA8R8G8B8, ifX8R8G8B8,
ifA1R5G5B5, ifA4R4G4B4, ifX1R5G5B5, ifX4R4G4B4, ifR5G6B5, ifA16B16G16R16,
ifR32F, ifA32B32G32R32F, ifR16F, ifA16B16G16R16F, ifR3G3B2, ifGray8, ifA8Gray8,
ifGray16, ifDXT1, ifDXT3, ifDXT5];
ifGray16, ifDXT1, ifDXT3, ifDXT5, ifATI1N, ifATI2N];
const
{ Four character codes.}
@ -114,6 +114,10 @@ const
(Byte('3') shl 24));
FOURCC_DXT5 = LongWord(Byte('D') or (Byte('X') shl 8) or (Byte('T') shl 16) or
(Byte('5') shl 24));
FOURCC_ATI1 = LongWord(Byte('A') or (Byte('T') shl 8) or (Byte('I') shl 16) or
(Byte('1') shl 24));
FOURCC_ATI2 = LongWord(Byte('A') or (Byte('T') shl 8) or (Byte('I') shl 16) or
(Byte('2') shl 24));
{ Some D3DFORMAT values used in DDS files as FourCC value.}
D3DFMT_A16B16G16R16 = 36;
@ -350,6 +354,8 @@ begin
FOURCC_DXT1: SrcFormat := ifDXT1;
FOURCC_DXT3: SrcFormat := ifDXT3;
FOURCC_DXT5: SrcFormat := ifDXT5;
FOURCC_ATI1: SrcFormat := ifATI1N;
FOURCC_ATI2: SrcFormat := ifATI2N;
end;
end
else if (Flags and DDPF_RGB) = DDPF_RGB then
@ -663,6 +669,8 @@ begin
ifDXT1: Desc.PixelFormat.FourCC := FOURCC_DXT1;
ifDXT3: Desc.PixelFormat.FourCC := FOURCC_DXT3;
ifDXT5: Desc.PixelFormat.FourCC := FOURCC_DXT5;
ifATI1N: Desc.PixelFormat.FourCC := FOURCC_ATI1;
ifATI2N: Desc.PixelFormat.FourCC := FOURCC_ATI2;
end;
end
else if FmtInfo.HasGrayChannel then
@ -815,6 +823,9 @@ initialization
-- TODOS ----------------------------------------------------
- nothing now
-- 0.25.0 Changes/Bug Fixes ---------------------------------
- Added support for 3Dc ATI1/2 formats.
-- 0.23 Changes/Bug Fixes -----------------------------------
- Saved DDS with mipmaps now correctly defineds COMPLEX flag.
- Fixed loading of RGB DDS files that use pitch and have mipmaps -

532
Imaging/ImagingFormats.pas
View File

@ -1,5 +1,5 @@
{
$Id: ImagingFormats.pas 94 2007-06-21 19:29:49Z galfar $
$Id: ImagingFormats.pas 129 2008-08-06 20:01:30Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
@ -76,6 +76,15 @@ type
sfGaussian, sfSpline, sfLanczos, sfMitchell, sfCatmullRom);
{ Type of custom sampling function}
TFilterFunction = function(Value: Single): Single;
const
{ Default resampling filter used for bicubic resizing.}
DefaultCubicFilter = sfCatmullRom;
var
{ Built-in filter functions.}
SamplingFilterFunctions: array[TSamplingFilter] of TFilterFunction;
{ Default radii of built-in filter functions.}
SamplingFilterRadii: array[TSamplingFilter] of Single;
{ Stretches rectangle in source image to rectangle in destination image
with resampling. One of built-in resampling filters defined by
Filter is used. Set WrapEdges to True for seamlessly tileable images.
@ -103,7 +112,7 @@ procedure FillMipMapLevel(const BiggerLevel: TImageData; Width, Height: LongInt;
var SmallerLevel: TImageData);
{ Various helper format support functions }
{ Various helper & support functions }
{ Copies Src pixel to Dest pixel. It is faster than System.Move procedure.}
procedure CopyPixel(Src, Dest: Pointer; BytesPerPixel: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
@ -163,6 +172,23 @@ function ColorHalfToFloat(ColorHF: TColorHFRec): TColorFPRec; {$IFDEF USE_INLINE
{ Converts single-precision floating point color to half float color.}
function ColorFloatToHalf(ColorFP: TColorFPRec): TColorHFRec; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Makes image PalEntries x 1 big where each pixel has color of one pal entry.}
procedure VisualizePalette(Pal: PPalette32; Entries: Integer; out PalImage: TImageData);
type
TPointRec = record
Pos: LongInt;
Weight: Single;
end;
TCluster = array of TPointRec;
TMappingTable = array of TCluster;
{ Helper function for resampling.}
function BuildMappingTable(DstLow, DstHigh, SrcLow, SrcHigh, SrcImageWidth: LongInt;
Filter: TFilterFunction; Radius: Single; WrapEdges: Boolean): TMappingTable;
{ Helper function for resampling.}
procedure FindExtremes(const Map: TMappingTable; var MinPos, MaxPos: LongInt);
{ Pixel readers/writers for different image formats }
@ -171,7 +197,7 @@ procedure ChannelGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
var Pix: TColor64Rec);
{ Sets pixel of image in any ARGB format. Channel values must be scaled to 16 bits.}
procedure ChannelSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
const Pix: TColor64Rec);
const Pix: TColor64Rec);
{ Returns pixel of image in any grayscale format. Gray value is scaled to 64 bits
and alpha to 16 bits.}
@ -275,6 +301,22 @@ procedure IndexToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
DstInfo: PImageFormatInfo; SrcPal: PPalette32);
{ Color constructor functions }
{ Constructs TColor24Rec color.}
function Color24(R, G, B: Byte): TColor24Rec; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Constructs TColor32Rec color.}
function Color32(A, R, G, B: Byte): TColor32Rec; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Constructs TColor48Rec color.}
function Color48(R, G, B: Word): TColor48Rec; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Constructs TColor64Rec color.}
function Color64(A, R, G, B: Word): TColor64Rec; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Constructs TColorFPRec color.}
function ColorFP(A, R, G, B: Single): TColorFPRec; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Constructs TColorHFRec color.}
function ColorHF(A, R, G, B: THalfFloat): TColorHFRec; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Special formats conversion functions }
{ Converts image to/from/between special image formats (dxtc, ...).}
@ -285,6 +327,14 @@ procedure ConvertSpecial(var Image: TImageData; SrcInfo,
{ Inits all image format information. Called internally on startup.}
procedure InitImageFormats(var Infos: TImageFormatInfoArray);
const
// Grayscale conversion channel weights
GrayConv: TColorFPRec = (B: 0.114; G: 0.587; R: 0.299; A: 0.0);
// Contants for converting integer colors to floating point
OneDiv8Bit: Single = 1.0 / 255.0;
OneDiv16Bit: Single = 1.0 / 65535.0;
implementation
{ TImageFormatInfo member functions }
@ -317,14 +367,6 @@ procedure SetPixelFPChannel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette:
function GetPixelFPFloat32(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec; forward;
procedure SetPixelFPFloat32(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec); forward;
const
// grayscale conversion channel weights
GrayConv: TColorFPRec = (B: 0.114; G: 0.587; R: 0.299; A: 0.0);
// contants for converting integer colors to floating point
OneDiv8Bit: Single = 1.0 / 255.0;
OneDiv16Bit: Single = 1.0 / 65535.0;
var
PFR3G3B2: TPixelFormatInfo;
PFX5R1G1B1: TPixelFormatInfo;
@ -759,6 +801,26 @@ var
CheckDimensions: CheckDXTDimensions;
SpecialNearestFormat: ifGray8);
ATI1NInfo: TImageFormatInfo = (
Format: ifATI1N;
Name: 'ATI1N';
ChannelCount: 1;
HasAlphaChannel: False;
IsSpecial: True;
GetPixelsSize: GetDXTPixelsSize;
CheckDimensions: CheckDXTDimensions;
SpecialNearestFormat: ifGray8);
ATI2NInfo: TImageFormatInfo = (
Format: ifATI2N;
Name: 'ATI2N';
ChannelCount: 2;
HasAlphaChannel: False;
IsSpecial: True;
GetPixelsSize: GetDXTPixelsSize;
CheckDimensions: CheckDXTDimensions;
SpecialNearestFormat: ifA8R8G8B8);
{$WARNINGS ON}
function PixelFormat(ABitCount, RBitCount, GBitCount, BBitCount: Byte): TPixelFormatInfo; forward;
@ -804,6 +866,8 @@ begin
Infos[ifDXT3] := @DXT3Info;
Infos[ifDXT5] := @DXT5Info;
Infos[ifBTC] := @BTCInfo;
Infos[ifATI1N] := @ATI1NInfo;
Infos[ifATI2N] := @ATI2NInfo;
PFR3G3B2 := PixelFormat(0, 3, 3, 2);
PFX5R1G1B1 := PixelFormat(0, 1, 1, 1);
@ -906,6 +970,57 @@ begin
end;
end;
{ Color constructor functions }
function Color24(R, G, B: Byte): TColor24Rec;
begin
Result.R := R;
Result.G := G;
Result.B := B;
end;
function Color32(A, R, G, B: Byte): TColor32Rec;
begin
Result.A := A;
Result.R := R;
Result.G := G;
Result.B := B;
end;
function Color48(R, G, B: Word): TColor48Rec;
begin
Result.R := R;
Result.G := G;
Result.B := B;
end;
function Color64(A, R, G, B: Word): TColor64Rec;
begin
Result.A := A;
Result.R := R;
Result.G := G;
Result.B := B;
end;
function ColorFP(A, R, G, B: Single): TColorFPRec;
begin
Result.A := A;
Result.R := R;
Result.G := G;
Result.B := B;
end;
function ColorHF(A, R, G, B: THalfFloat): TColorHFRec;
begin
Result.A := A;
Result.R := R;
Result.G := G;
Result.B := B;
end;
{ Additional image manipulation functions (usually used internally by Imaging unit) }
const
@ -1184,13 +1299,18 @@ procedure ReduceColorsMedianCut(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
begin
FillChar(DstPal^, SizeOf(TColor32Rec) * MaxColors, $FF);
for I := 0 to MaxColors - 1 do
begin
if I < Boxes then
with Box[I].Represented do
begin
DstPal[I].A := A;
DstPal[I].R := R;
DstPal[I].G := G;
DstPal[I].B := B;
end;
begin
DstPal[I].A := A;
DstPal[I].R := R;
DstPal[I].G := G;
DstPal[I].B := B;
end
else
DstPal[I].Color := $FF000000;
end;
end;
function MapColor(const Col: TColor32Rec) : LongInt;
@ -1439,37 +1559,21 @@ begin
Result := 0.0;
end;
const
// Some built-in filter functions adn their default radii
FilterFunctions: array[TSamplingFilter] of TFilterFunction = (
FilterNearest, FilterLinear, FilterCosine, FilterHermite, FilterQuadratic,
FilterGaussian, FilterSpline, FilterLanczos, FilterMitchell, FilterCatmullRom);
FilterRadii: array[TSamplingFilter] of Single = (
1.0, 1.0, 1.0, 1.0, 1.5,
1.25, 2.0, 3.0, 2.0, 2.0);
procedure StretchResample(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
DstHeight: LongInt; Filter: TSamplingFilter; WrapEdges: Boolean);
begin
// Calls the other function with filter function and radius defined by Filter
StretchResample(SrcImage, SrcX, SrcY, SrcWidth, SrcHeight, DstImage, DstX, DstY,
DstWidth, DstHeight, FilterFunctions[Filter], FilterRadii[Filter]);
DstWidth, DstHeight, SamplingFilterFunctions[Filter], SamplingFilterRadii[Filter],
WrapEdges);
end;
{ The following resampling code is modified and extended code from Graphics32
library by Alex A. Denisov.}
type
TPointRec = record
Pos: LongInt;
Weight: Single;
end;
TCluster = array of TPointRec;
TMappingTable = array of TCluster;
var
FullEdge: Boolean = True;
{ The following resampling code is modified and extended code from Graphics32
library by Alex A. Denisov.}
function BuildMappingTable(DstLow, DstHigh, SrcLow, SrcHigh, SrcImageWidth: LongInt;
Filter: TFilterFunction; Radius: Single; WrapEdges: Boolean): TMappingTable;
var
@ -1595,6 +1699,25 @@ begin
end;
end;
procedure FindExtremes(const Map: TMappingTable; var MinPos, MaxPos: LongInt);
var
I, J: LongInt;
begin
if Length(Map) > 0 then
begin
MinPos := Map[0][0].Pos;
MaxPos := MinPos;
for I := 0 to Length(Map) - 1 do
for J := 0 to Length(Map[I]) - 1 do
begin
if MinPos > Map[I][J].Pos then
MinPos := Map[I][J].Pos;
if MaxPos < Map[I][J].Pos then
MaxPos := Map[I][J].Pos;
end;
end;
end;
procedure StretchResample(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
DstHeight: LongInt; Filter: TFilterFunction; Radius: Single; WrapEdges: Boolean);
@ -1614,26 +1737,6 @@ var
BytesPerChannel: LongInt;
ChannelValueMax, InvChannelValueMax: Single;
UseOptimizedVersion: Boolean;
procedure FindExtremes(const Map: TMappingTable; var MinPos, MaxPos: LongInt);
var
I, J: LongInt;
begin
if Length(Map) > 0 then
begin
MinPos := Map[0][0].Pos;
MaxPos := MinPos;
for I := 0 to Length(Map) - 1 do
for J := 0 to Length(Map[I]) - 1 do
begin
if MinPos > Map[I][J].Pos then
MinPos := Map[I][J].Pos;
if MaxPos < Map[I][J].Pos then
MaxPos := Map[I][J].Pos;
end;
end;
end;
begin
GetImageFormatInfo(SrcImage.Format, Info);
Assert(SrcImage.Format = DstImage.Format);
@ -2237,6 +2340,21 @@ begin
Result.B := FloatToHalf(ColorFP.B);
end;
procedure VisualizePalette(Pal: PPalette32; Entries: Integer; out PalImage: TImageData);
var
I: Integer;
Pix: PColor32;
begin
InitImage(PalImage);
NewImage(Entries, 1, ifA8R8G8B8, PalImage);
Pix := PalImage.Bits;
for I := 0 to Entries - 1 do
begin
Pix^ := Pal[I].Color;
Inc(Pix);
end;
end;
{ Pixel readers/writers for different image formats }
@ -3234,6 +3352,31 @@ begin
end;
end;
procedure GetInterpolatedAlphas(var AlphaBlock: TDXTAlphaBlockInt);
begin
with AlphaBlock do
if Alphas[0] > Alphas[1] then
begin
// Interpolation of six alphas
Alphas[2] := (6 * Alphas[0] + 1 * Alphas[1] + 3) div 7;
Alphas[3] := (5 * Alphas[0] + 2 * Alphas[1] + 3) div 7;
Alphas[4] := (4 * Alphas[0] + 3 * Alphas[1] + 3) div 7;
Alphas[5] := (3 * Alphas[0] + 4 * Alphas[1] + 3) div 7;
Alphas[6] := (2 * Alphas[0] + 5 * Alphas[1] + 3) div 7;
Alphas[7] := (1 * Alphas[0] + 6 * Alphas[1] + 3) div 7;
end
else
begin
// Interpolation of four alphas, two alphas are set directly
Alphas[2] := (4 * Alphas[0] + 1 * Alphas[1] + 2) div 5;
Alphas[3] := (3 * Alphas[0] + 2 * Alphas[1] + 2) div 5;
Alphas[4] := (2 * Alphas[0] + 3 * Alphas[1] + 2) div 5;
Alphas[5] := (1 * Alphas[0] + 4 * Alphas[1] + 2) div 5;
Alphas[6] := 0;
Alphas[7] := $FF;
end;
end;
procedure DecodeDXT5(SrcBits, DestBits: PByte; Width, Height: LongInt);
var
Sel, X, Y, I, J, K: LongInt;
@ -3264,27 +3407,7 @@ begin
AMask[0] := PLongWord(@AlphaBlock.Alphas[2])^ and $00FFFFFF;
AMask[1] := PLongWord(@AlphaBlock.Alphas[5])^ and $00FFFFFF;
// alpha interpolation between two endpoint alphas
with AlphaBlock do
if Alphas[0] > Alphas[1] then
begin
// interpolation of six alphas
Alphas[2] := (6 * Alphas[0] + 1 * Alphas[1] + 3) div 7;
Alphas[3] := (5 * Alphas[0] + 2 * Alphas[1] + 3) div 7;
Alphas[4] := (4 * Alphas[0] + 3 * Alphas[1] + 3) div 7;
Alphas[5] := (3 * Alphas[0] + 4 * Alphas[1] + 3) div 7;
Alphas[6] := (2 * Alphas[0] + 5 * Alphas[1] + 3) div 7;
Alphas[7] := (1 * Alphas[0] + 6 * Alphas[1] + 3) div 7;
end
else
begin
// interpolation of four alphas, two alphas are set directly
Alphas[2] := (4 * Alphas[0] + 1 * Alphas[1] + 2) div 5;
Alphas[3] := (3 * Alphas[0] + 2 * Alphas[1] + 2) div 5;
Alphas[4] := (2 * Alphas[0] + 3 * Alphas[1] + 2) div 5;
Alphas[5] := (1 * Alphas[0] + 4 * Alphas[1] + 2) div 5;
Alphas[6] := 0;
Alphas[7] := $FF;
end;
GetInterpolatedAlphas(AlphaBlock);
// we distribute the dxt block colors and alphas
// across the 4x4 block of the destination image
@ -3307,7 +3430,7 @@ begin
end;
procedure GetBlock(var Block: TPixelBlock; SrcBits: Pointer; XPos, YPos,
Width, Height: LongInt);
Width, Height: LongInt);
var
X, Y, I: LongInt;
Src: PColor32Rec;
@ -3637,7 +3760,71 @@ begin
end;
end;
procedure DecodeBTC(SrcBits, DestBits: PByte; Width, Height: LongInt);
procedure GetOneChannelBlock(var Block: TPixelBlock; SrcBits: Pointer; XPos, YPos,
Width, Height, BytesPP, ChannelIdx: Integer);
var
X, Y, I: Integer;
Src: PByte;
begin
I := 0;
// 4x4 pixel block is filled with information about every pixel in the block,
// but only one channel value is stored in Alpha field
for Y := 0 to 3 do
for X := 0 to 3 do
begin
Src := @PByteArray(SrcBits)[(YPos * 4 + Y) * Width * BytesPP +
(XPos * 4 + X) * BytesPP + ChannelIdx];
Block[I].Alpha := Src^;
Inc(I);
end;
end;
procedure EncodeATI1N(SrcBits: Pointer; DestBits: PByte; Width, Height: Integer);
var
X, Y: Integer;
AlphaBlock: TDXTAlphaBlockInt;
Pixels: TPixelBlock;
begin
for Y := 0 to Height div 4 - 1 do
for X := 0 to Width div 4 - 1 do
begin
// Encode one channel
GetOneChannelBlock(Pixels, SrcBits, X, Y, Width, Height, 1, 0);
GetAlphaEndPoints(Pixels, AlphaBlock.Alphas[1], AlphaBlock.Alphas[0]);
GetAlphaMask(AlphaBlock.Alphas[0], AlphaBlock.Alphas[1], Pixels,
PByteArray(@AlphaBlock.Alphas[2]));
PDXTAlphaBlockInt(DestBits)^ := AlphaBlock;
Inc(DestBits, SizeOf(AlphaBlock));
end;
end;
procedure EncodeATI2N(SrcBits: Pointer; DestBits: PByte; Width, Height: Integer);
var
X, Y: Integer;
AlphaBlock: TDXTAlphaBlockInt;
Pixels: TPixelBlock;
begin
for Y := 0 to Height div 4 - 1 do
for X := 0 to Width div 4 - 1 do
begin
// Encode Red/X channel
GetOneChannelBlock(Pixels, SrcBits, X, Y, Width, Height, 4, ChannelRed);
GetAlphaEndPoints(Pixels, AlphaBlock.Alphas[1], AlphaBlock.Alphas[0]);
GetAlphaMask(AlphaBlock.Alphas[0], AlphaBlock.Alphas[1], Pixels,
PByteArray(@AlphaBlock.Alphas[2]));
PDXTAlphaBlockInt(DestBits)^ := AlphaBlock;
Inc(DestBits, SizeOf(AlphaBlock));
// Encode Green/Y channel
GetOneChannelBlock(Pixels, SrcBits, X, Y, Width, Height, 4, ChannelGreen);
GetAlphaEndPoints(Pixels, AlphaBlock.Alphas[1], AlphaBlock.Alphas[0]);
GetAlphaMask(AlphaBlock.Alphas[0], AlphaBlock.Alphas[1], Pixels,
PByteArray(@AlphaBlock.Alphas[2]));
PDXTAlphaBlockInt(DestBits)^ := AlphaBlock;
Inc(DestBits, SizeOf(AlphaBlock));
end;
end;
procedure DecodeBTC(SrcBits, DestBits: PByte; Width, Height: Integer);
var
X, Y, I, J, K: Integer;
Block: TBTCBlock;
@ -3665,25 +3852,101 @@ begin
end;
end;
procedure SpecialToUnSpecial(const SrcImage: TImageData; DestBits: Pointer;
SrcInfo, DstInfo: PImageFormatInfo);
procedure DecodeATI1N(SrcBits, DestBits: PByte; Width, Height: Integer);
var
X, Y, I, J: Integer;
AlphaBlock: TDXTAlphaBlockInt;
AMask: array[0..1] of LongWord;
begin
case SrcInfo.Format of
for Y := 0 to Height div 4 - 1 do
for X := 0 to Width div 4 - 1 do
begin
AlphaBlock := PDXTAlphaBlockInt(SrcBits)^;
Inc(SrcBits, SizeOf(AlphaBlock));
// 6 bit alpha mask is copied into two long words for
// easier usage
AMask[0] := PLongWord(@AlphaBlock.Alphas[2])^ and $00FFFFFF;
AMask[1] := PLongWord(@AlphaBlock.Alphas[5])^ and $00FFFFFF;
// alpha interpolation between two endpoint alphas
GetInterpolatedAlphas(AlphaBlock);
// we distribute the dxt block alphas
// across the 4x4 block of the destination image
for J := 0 to 3 do
for I := 0 to 3 do
begin
PByteArray(DestBits)[(Y shl 2 + J) * Width + (X shl 2 + I)] :=
AlphaBlock.Alphas[AMask[J shr 1] and 7];
AMask[J shr 1] := AMask[J shr 1] shr 3;
end;
end;
end;
procedure DecodeATI2N(SrcBits, DestBits: PByte; Width, Height: Integer);
var
X, Y, I, J: Integer;
Color: TColor32Rec;
AlphaBlock1, AlphaBlock2: TDXTAlphaBlockInt;
AMask1: array[0..1] of LongWord;
AMask2: array[0..1] of LongWord;
begin
for Y := 0 to Height div 4 - 1 do
for X := 0 to Width div 4 - 1 do
begin
// Read the first alpha block and get masks
AlphaBlock1 := PDXTAlphaBlockInt(SrcBits)^;
Inc(SrcBits, SizeOf(AlphaBlock1));
AMask1[0] := PLongWord(@AlphaBlock1.Alphas[2])^ and $00FFFFFF;
AMask1[1] := PLongWord(@AlphaBlock1.Alphas[5])^ and $00FFFFFF;
// Read the secind alpha block and get masks
AlphaBlock2 := PDXTAlphaBlockInt(SrcBits)^;
Inc(SrcBits, SizeOf(AlphaBlock2));
AMask2[0] := PLongWord(@AlphaBlock2.Alphas[2])^ and $00FFFFFF;
AMask2[1] := PLongWord(@AlphaBlock2.Alphas[5])^ and $00FFFFFF;
// alpha interpolation between two endpoint alphas
GetInterpolatedAlphas(AlphaBlock1);
GetInterpolatedAlphas(AlphaBlock2);
Color.A := $FF;
Color.B := 0;
// Distribute alpha block values across 4x4 pixel block,
// first alpha block represents Red channel, second is Green.
for J := 0 to 3 do
for I := 0 to 3 do
begin
Color.R := AlphaBlock1.Alphas[AMask1[J shr 1] and 7];
Color.G := AlphaBlock2.Alphas[AMask2[J shr 1] and 7];
PColor32RecArray(DestBits)[(Y shl 2 + J) * Width + (X shl 2 + I)] := Color;
AMask1[J shr 1] := AMask1[J shr 1] shr 3;
AMask2[J shr 1] := AMask2[J shr 1] shr 3;
end;
end;
end;
procedure SpecialToUnSpecial(const SrcImage: TImageData; DestBits: Pointer;
SpecialFormat: TImageFormat);
begin
case SpecialFormat of
ifDXT1: DecodeDXT1(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
ifDXT3: DecodeDXT3(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
ifDXT5: DecodeDXT5(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
ifBTC: DecodeBTC (SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
ifATI1N: DecodeATI1N(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
ifATI2N: DecodeATI2N(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
end;
end;
procedure UnSpecialToSpecial(const DestImage: TImageData; SrcBits: Pointer;
SrcInfo, DstInfo: PImageFormatInfo);
procedure UnSpecialToSpecial(SrcBits: Pointer; const DestImage: TImageData;
SpecialFormat: TImageFormat);
begin
case DstInfo.Format of
case SpecialFormat of
ifDXT1: EncodeDXT1(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
ifDXT3: EncodeDXT3(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
ifDXT5: EncodeDXT5(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
ifBTC: EncodeBTC (SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
ifATI1N: EncodeATI1N(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
ifATI2N: EncodeATI2N(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
end;
end;
@ -3691,35 +3954,58 @@ procedure ConvertSpecial(var Image: TImageData;
SrcInfo, DstInfo: PImageFormatInfo);
var
WorkImage: TImageData;
Width, Height: LongInt;
begin
// first convert image to default non-special format
if SrcInfo.IsSpecial then
procedure CheckSize(var Img: TImageData; Info: PImageFormatInfo);
var
Width, Height: Integer;
begin
Width := Img.Width;
Height := Img.Height;
DstInfo.CheckDimensions(Info.Format, Width, Height);
ResizeImage(Img, Width, Height, rfNearest);
end;
begin
if SrcInfo.IsSpecial and DstInfo.IsSpecial then
begin
// Convert source to nearest 'normal' format
InitImage(WorkImage);
NewImage(Image.Width, Image.Height, SrcInfo.SpecialNearestFormat, WorkImage);
SpecialToUnSpecial(Image, WorkImage.Bits, SrcInfo, DstInfo);
SpecialToUnSpecial(Image, WorkImage.Bits, SrcInfo.Format);
FreeImage(Image);
Image := WorkImage;
// Make sure output of SpecialToUnSpecial is the same as input of
// UnSpecialToSpecial
if SrcInfo.SpecialNearestFormat <> DstInfo.SpecialNearestFormat then
ConvertImage(WorkImage, DstInfo.SpecialNearestFormat);
// Convert work image to dest special format
CheckSize(WorkImage, DstInfo);
NewImage(WorkImage.Width, WorkImage.Height, DstInfo.Format, Image);
UnSpecialToSpecial(WorkImage.Bits, Image, DstInfo.Format);
FreeImage(WorkImage);
end
else
ConvertImage(Image, DstInfo.SpecialNearestFormat);
// we have now image in default non-special format and
// if dest format is special we will convert to this special format
if DstInfo.IsSpecial then
else if SrcInfo.IsSpecial and not DstInfo.IsSpecial then
begin
Width := Image.Width;
Height := Image.Height;
DstInfo.CheckDimensions(DstInfo.Format, Width, Height);
// Convert source to nearest 'normal' format
InitImage(WorkImage);
NewImage(Width, Height, DstInfo.Format, WorkImage);
ResizeImage(Image, Width, Height, rfNearest);
UnSpecialToSpecial(WorkImage, Image.Bits, SrcInfo, DstInfo);
NewImage(Image.Width, Image.Height, SrcInfo.SpecialNearestFormat, WorkImage);
SpecialToUnSpecial(Image, WorkImage.Bits, SrcInfo.Format);
FreeImage(Image);
// Now convert to dest format
ConvertImage(WorkImage, DstInfo.Format);
Image := WorkImage;
end
else
ConvertImage(Image, DstInfo.Format);
else if not SrcInfo.IsSpecial and DstInfo.IsSpecial then
begin
// Convert source to nearest format
WorkImage := Image;
ConvertImage(WorkImage, DstInfo.SpecialNearestFormat);
// Now convert from nearest to dest
CheckSize(WorkImage, DstInfo);
InitImage(Image);
NewImage(WorkImage.Width, WorkImage.Height, DstInfo.Format, Image);
UnSpecialToSpecial(WorkImage.Bits, Image, DstInfo.Format);
FreeImage(WorkImage);
end;
end;
function GetStdPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt;
@ -3740,7 +4026,7 @@ begin
// multiples of four
CheckDXTDimensions(Format, Width, Height);
Result := Width * Height;
if Format = ifDXT1 then
if Format in [ifDXT1, ifATI1N] then
Result := Result div 2;
end;
@ -3908,6 +4194,29 @@ begin
end;
end;
initialization
// Initialize default sampling filter function pointers and radii
SamplingFilterFunctions[sfNearest] := FilterNearest;
SamplingFilterFunctions[sfLinear] := FilterLinear;
SamplingFilterFunctions[sfCosine] := FilterCosine;
SamplingFilterFunctions[sfHermite] := FilterHermite;
SamplingFilterFunctions[sfQuadratic] := FilterQuadratic;
SamplingFilterFunctions[sfGaussian] := FilterGaussian;
SamplingFilterFunctions[sfSpline] := FilterSpline;
SamplingFilterFunctions[sfLanczos] := FilterLanczos;
SamplingFilterFunctions[sfMitchell] := FilterMitchell;
SamplingFilterFunctions[sfCatmullRom] := FilterCatmullRom;
SamplingFilterRadii[sfNearest] := 1.0;
SamplingFilterRadii[sfLinear] := 1.0;
SamplingFilterRadii[sfCosine] := 1.0;
SamplingFilterRadii[sfHermite] := 1.0;
SamplingFilterRadii[sfQuadratic] := 1.5;
SamplingFilterRadii[sfGaussian] := 1.25;
SamplingFilterRadii[sfSpline] := 2.0;
SamplingFilterRadii[sfLanczos] := 3.0;
SamplingFilterRadii[sfMitchell] := 2.0;
SamplingFilterRadii[sfCatmullRom] := 2.0;
{
File Notes:
@ -3915,6 +4224,17 @@ end;
- nothing now
- rewrite StretchRect for 8bit channels to use integer math?
-- 0.25.0 Changes/Bug Fixes -----------------------------------
- Made some resampling stuff public so that it can be used in canvas class.
- Added some color constructors.
- Added VisualizePalette helper function.
- Fixed ConvertSpecial, not very readable before and error when
converting special->special.
-- 0.24.3 Changes/Bug Fixes -----------------------------------
- Some refactorings a changes to DXT based formats.
- Added ifATI1N and ifATI2N image data formats support structures and functions.
-- 0.23 Changes/Bug Fixes -----------------------------------
- Added ifBTC image format support structures and functions.

74
Imaging/ImagingGif.pas
View File

@ -1,5 +1,5 @@
{
$Id: ImagingGif.pas 111 2007-12-02 23:25:44Z galfar $
$Id: ImagingGif.pas 132 2008-08-27 20:37:38Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
@ -34,7 +34,7 @@ unit ImagingGif;
interface
uses
SysUtils, Classes, Imaging, ImagingTypes, ImagingUtility;
SysUtils, Classes, Imaging, ImagingTypes, ImagingIO, ImagingUtility;
type
{ GIF (Graphics Interchange Format) loader/saver class. GIF was
@ -48,7 +48,7 @@ type
TGIFFileFormat = class(TImageFileFormat)
private
function InterlaceStep(Y, Height: Integer; var Pass: Integer): Integer;
procedure LZWDecompress(const IO: TIOFunctions; Handle: TImagingHandle;
procedure LZWDecompress(Stream: TStream; Handle: TImagingHandle;
Width, Height: Integer; Interlaced: Boolean; Data: Pointer);
procedure LZWCompress(const IO: TIOFunctions; Handle: TImagingHandle;
Width, Height, BitCount: Integer; Interlaced: Boolean; Data: Pointer);
@ -246,7 +246,7 @@ begin
end;
{ GIF LZW decompresion code is from JVCL JvGIF.pas unit.}
procedure TGIFFileFormat.LZWDecompress(const IO: TIOFunctions; Handle: TImagingHandle; Width, Height: Integer;
procedure TGIFFileFormat.LZWDecompress(Stream: TStream; Handle: TImagingHandle; Width, Height: Integer;
Interlaced: Boolean; Data: Pointer);
var
MinCodeSize: Byte;
@ -266,7 +266,8 @@ var
Bytes: Byte;
BytesToLose: Integer;
begin
while Context.Inx + Context.CodeSize > Context.Size do
while (Context.Inx + Context.CodeSize > Context.Size) and
(Stream.Position < Stream.Size) do
begin
// Not enough bits in buffer - refill it - Not very efficient, but infrequently called
BytesToLose := Context.Inx shr 3;
@ -274,16 +275,16 @@ var
Move(Context.Buf[Word(BytesToLose)], Context.Buf[0], 3);
Context.Inx := Context.Inx and 7;
Context.Size := Context.Size - (BytesToLose shl 3);
IO.Read(Handle, @Bytes, 1);
Stream.Read(Bytes, 1);
if Bytes > 0 then
IO.Read(Handle, @Context.Buf[Word(Context.Size shr 3)], Bytes);
Stream.Read(Context.Buf[Word(Context.Size shr 3)], Bytes);
Context.Size := Context.Size + (Bytes shl 3);
end;
ByteIndex := Context.Inx shr 3;
RawCode := Context.Buf[Word(ByteIndex)] +
(Word(Context.Buf[Word(ByteIndex + 1)]) shl 8);
if Context.CodeSize > 8 then
RawCode := RawCode + (Longint(Context.Buf[ByteIndex + 2]) shl 16);
RawCode := RawCode + (LongInt(Context.Buf[ByteIndex + 2]) shl 16);
RawCode := RawCode shr (Context.Inx and 7);
Context.Inx := Context.Inx + Byte(Context.CodeSize);
Result := RawCode and Context.ReadMask;
@ -345,7 +346,7 @@ begin
GetMem(Suffix, SizeOf(TIntCodeTable));
GetMem(OutCode, SizeOf(TIntCodeTable) + SizeOf(Word));
try
IO.Read(Handle, @MinCodeSize, 1);
Stream.Read(MinCodeSize, 1);
if (MinCodeSize < 2) or (MinCodeSize > 9) then
RaiseImaging(SGIFDecodingError, []);
// Initial read context
@ -690,20 +691,26 @@ var
end;
end;
procedure CopyFrameTransparent(const Image, Frame: TImageData; Left, Top, TransIndex: Integer);
procedure CopyFrameTransparent(const Image, Frame: TImageData; Left, Top,
TransIndex: Integer; Disposal: TDisposalMethod);
var
X, Y: Integer;
Src, Dst: PByte;
begin
Src := Frame.Bits;
// Copy all pixels from frame to log screen but ignore the transparent ones
// Copy all pixels from frame to log screen but ignore the transparent ones
for Y := 0 to Frame.Height - 1 do
begin
Dst := @PByteArray(Image.Bits)[(Top + Y) * Image.Width + Left];
for X := 0 to Frame.Width - 1 do
begin
if Src^ <> TransIndex then
// If disposal methos is undefined copy all pixels regardless of
// transparency (transparency of whole image will be determined by TranspIndex
// in image palette) - same effect as filling the image with trasp color
// instead of backround color beforehand.
// For other methods don't copy transparent pixels from frame to image.
if (Src^ <> TransIndex) or (Disposal = dmUndefined) then
Dst^ := Src^;
Inc(Src);
Inc(Dst);
@ -711,6 +718,28 @@ var
end;
end;
procedure CopyLZWData(Dest: TStream);
var
CodeSize, BlockSize: Byte;
InputSize: Integer;
Buff: array[Byte] of Byte;
begin
InputSize := ImagingIO.GetInputSize(GetIO, Handle);
// Copy codesize to stream
GetIO.Read(Handle, @CodeSize, 1);
Dest.Write(CodeSize, 1);
repeat
// Read and write data blocks, last is block term value of 0
GetIO.Read(Handle, @BlockSize, 1);
Dest.Write(BlockSize, 1);
if BlockSize > 0 then
begin
GetIO.Read(Handle, @Buff[0], BlockSize);
Dest.Write(Buff[0], BlockSize);
end;
until (BlockSize = 0) or (GetIO.Tell(Handle) >= InputSize);
end;
procedure ReadFrame;
var
ImageDesc: TImageDescriptor;
@ -719,6 +748,7 @@ var
LocalPal: TPalette32Size256;
BlockTerm: Byte;
Frame: TImageData;
LZWStream: TMemoryStream;
begin
Idx := Length(Images);
SetLength(Images, Idx + 1);
@ -806,15 +836,20 @@ var
@Header.BackgroundColorIndex);
end;
LZWStream := TMemoryStream.Create;
try
// Copy LZW data to temp stream, needed for correct decompression
CopyLZWData(LZWStream);
LZWStream.Position := 0;
// Data decompression finally
LZWDecompress(GetIO, Handle, ImageDesc.Width, ImageDesc.Height, Interlaced, Frame.Bits);
Read(Handle, @BlockTerm, SizeOf(BlockTerm));
LZWDecompress(LZWStream, Handle, ImageDesc.Width, ImageDesc.Height, Interlaced, Frame.Bits);
// Now copy frame to logical screen with skipping of transparent pixels (if enabled)
TransIndex := Iff(HasTransparency, GraphicExt.TransparentColorIndex, MaxInt);
CopyFrameTransparent(Images[Idx], Frame, ImageDesc.Left, ImageDesc.Top, TransIndex);
CopyFrameTransparent(Images[Idx], Frame, ImageDesc.Left, ImageDesc.Top,
TransIndex, Disposals[Idx]);
finally
FreeImage(Frame);
LZWStream.Free;
end;
end;
end;
@ -840,7 +875,6 @@ begin
Read(Handle, @GlobalPal[I].G, SizeOf(GlobalPal[I].G));
Read(Handle, @GlobalPal[I].B, SizeOf(GlobalPal[I].B));
end;
GlobalPal[Header.BackgroundColorIndex].A := 0;
end;
// Read ID of the first block
@ -973,6 +1007,14 @@ initialization
-- TODOS ----------------------------------------------------
- nothing now
-- 0.25.0 Changes/Bug Fixes ---------------------------------
- Fixed loading of some rare GIFs, problems with LZW
decompression.
-- 0.24.3 Changes/Bug Fixes ---------------------------------
- Better solution to transparency for some GIFs. Background not
transparent by default.
-- 0.24.1 Changes/Bug Fixes ---------------------------------
- Made backround color transparent by default (alpha = 0).

11
Imaging/ImagingJpeg.pas
View File

@ -1,5 +1,5 @@
{
$Id: ImagingJpeg.pas 103 2007-09-15 01:11:14Z galfar $
$Id: ImagingJpeg.pas 128 2008-07-23 11:57:36Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
@ -46,7 +46,7 @@ unit ImagingJpeg;
{ Automatically use FPC's PasJpeg when compiling with Lazarus.}
{$IFDEF LCL}
{ $UNDEF IMJPEGLIB}
{$UNDEF IMJPEGLIB}
{$DEFINE PASJPEG}
{$ENDIF}
@ -65,7 +65,7 @@ uses
{$IF Defined(FPC) and Defined(PASJPEG)}
{ When using FPC's pasjpeg in FPC the channel order is BGR instead of RGB}
{ $DEFINE RGBSWAPPED} // not needed now apparently
{$DEFINE RGBSWAPPED}
{$IFEND}
type
@ -375,10 +375,8 @@ var
Dest: PByte;
jc: TJpegContext;
Info: TImageFormatInfo;
Format: TImageFormat;
Col32: PColor32Rec;
{$IFDEF RGBSWAPPED}
I: LongInt;
Pix: PColor24Rec;
{$ENDIF}
begin
@ -556,6 +554,9 @@ initialization
-- TODOS ----------------------------------------------------
- nothing now
-- 0.25.0 Changes/Bug Fixes ---------------------------------
-- FPC's PasJpeg wasn't really used in last version, fixed.
-- 0.24.1 Changes/Bug Fixes ---------------------------------
- Fixed loading of CMYK jpeg images. Could cause heap corruption
and loaded image looked wrong.

92
Imaging/ImagingNetworkGraphics.pas
View File

@ -1,5 +1,5 @@
{
$Id: ImagingNetworkGraphics.pas 90 2007-06-18 22:09:16Z galfar $
$Id: ImagingNetworkGraphics.pas 122 2008-03-14 14:05:42Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
@ -299,6 +299,7 @@ type
GlobalPaletteEntries: LongInt;
GlobalTransparency: Pointer;
GlobalTransparencySize: LongInt;
destructor Destroy; override;
procedure Clear;
function GetLastFrame: TFrameInfo;
function AddFrameInfo: TFrameInfo;
@ -340,10 +341,6 @@ type
end;
{$ENDIF}
var
NGFileLoader: TNGFileLoader = nil;
NGFileSaver: TNGFileSaver = nil;
{ Helper routines }
function PaethPredictor(A, B, C: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
@ -455,6 +452,12 @@ end;
{ TNGFileHandler class implementation}
destructor TNGFileHandler.Destroy;
begin
Clear;
inherited Destroy;
end;
procedure TNGFileHandler.Clear;
var
I: LongInt;
@ -1865,8 +1868,11 @@ end;
function TPNGFileFormat.LoadData(Handle: TImagingHandle;
var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
var
NGFileLoader: TNGFileLoader;
begin
Result := False;
NGFileLoader := TNGFileLoader.Create;
try
// Use NG file parser to load file
if NGFileLoader.LoadFile(Handle) and (Length(NGFileLoader.Frames) > 0) then
@ -1881,7 +1887,7 @@ begin
Result := True;
end;
finally
NGFileLoader.Clear;
NGFileLoader.Free;
end;
end;
@ -1890,21 +1896,25 @@ function TPNGFileFormat.SaveData(Handle: TImagingHandle;
var
ImageToSave: TImageData;
MustBeFreed: Boolean;
NGFileSaver: TNGFileSaver;
begin
// Make image PNG compatible, store it in saver, and save it to file
Result := MakeCompatible(Images[Index], ImageToSave, MustBeFreed);
if Result then
with NGFileSaver do
try
FileType := ngPNG;
SetFileOptions(Self);
AddFrame(ImageToSave, False);
SaveFile(Handle);
finally
// Clear NG saver and compatible image
Clear;
if MustBeFreed then
FreeImage(ImageToSave);
begin
NGFileSaver := TNGFileSaver.Create;
with NGFileSaver do
try
FileType := ngPNG;
SetFileOptions(Self);
AddFrame(ImageToSave, False);
SaveFile(Handle);
finally
// Free NG saver and compatible image
NGFileSaver.Free;
if MustBeFreed then
FreeImage(ImageToSave);
end;
end;
end;
@ -1932,9 +1942,11 @@ end;
function TMNGFileFormat.LoadData(Handle: TImagingHandle;
var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
var
NGFileLoader: TNGFileLoader;
I, Len: LongInt;
begin
Result := False;
NGFileLoader := TNGFileLoader.Create;
try
// Use NG file parser to load file
if NGFileLoader.LoadFile(Handle) then
@ -1965,13 +1977,14 @@ begin
Result := True;
end;
finally
NGFileLoader.Clear;
NGFileLoader.Free;
end;
end;
function TMNGFileFormat.SaveData(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: LongInt): Boolean;
var
NGFileSaver: TNGFileSaver;
I, LargestWidth, LargestHeight: LongInt;
ImageToSave: TImageData;
MustBeFreed: Boolean;
@ -1980,6 +1993,7 @@ begin
LargestWidth := 0;
LargestHeight := 0;
NGFileSaver := TNGFileSaver.Create;
NGFileSaver.FileType := ngMNG;
NGFileSaver.SetFileOptions(Self);
@ -2016,7 +2030,7 @@ begin
SaveFile(Handle);
Result := True;
finally
Clear;
NGFileSaver.Free;
end;
end;
@ -2044,8 +2058,11 @@ end;
function TJNGFileFormat.LoadData(Handle: TImagingHandle;
var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
var
NGFileLoader: TNGFileLoader;
begin
Result := False;
NGFileLoader := TNGFileLoader.Create;
try
// Use NG file parser to load file
if NGFileLoader.LoadFile(Handle) and (Length(NGFileLoader.Frames) > 0) then
@ -2060,48 +2077,48 @@ begin
Result := True;
end;
finally
NGFileLoader.Clear;
NGFileLoader.Free;
end;
end;
function TJNGFileFormat.SaveData(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: LongInt): Boolean;
var
NGFileSaver: TNGFileSaver;
ImageToSave: TImageData;
MustBeFreed: Boolean;
begin
// Make image JNG compatible, store it in saver, and save it to file
Result := MakeCompatible(Images[Index], ImageToSave, MustBeFreed);
if Result then
with NGFileSaver do
try
FileType := ngJNG;
SetFileOptions(Self);
AddFrame(ImageToSave, True);
SaveFile(Handle);
finally
// Clear NG saver and compatible image
Clear;
if MustBeFreed then
FreeImage(ImageToSave);
begin
NGFileSaver := TNGFileSaver.Create;
with NGFileSaver do
try
FileType := ngJNG;
SetFileOptions(Self);
AddFrame(ImageToSave, True);
SaveFile(Handle);
finally
// Free NG saver and compatible image
NGFileSaver.Free;
if MustBeFreed then
FreeImage(ImageToSave);
end;
end;
end;
{$ENDIF}
initialization
NGFileLoader := TNGFileLoader.Create;
NGFileSaver := TNGFileSaver.Create;
RegisterImageFileFormat(TPNGFileFormat);
{$IFDEF LINK_MNG}
RegisterImageFileFormat(TMNGFileFormat);
{$ENDIF}
{$IFDEF LINK_JNG}
RegisterImageFileFormat(TJNGFileFormat);
{$ENDIF}
{$ENDIF}
finalization
FreeAndNil(NGFileLoader);
FreeAndNil(NGFileSaver);
{
File Notes:
@ -2109,6 +2126,9 @@ finalization
-- TODOS ----------------------------------------------------
- nothing now
-- 0.24.3 Changes/Bug Fixes ---------------------------------
- Changes for better thread safety.
-- 0.23 Changes/Bug Fixes -----------------------------------
- Added loading of global palettes and transparencies in MNG files
(and by doing so fixed crash when loading images with global PLTE or tRNS).

100
Imaging/ImagingOpenGL.pas
View File

@ -1,5 +1,5 @@
{
$Id: ImagingOpenGL.pas 106 2007-10-23 23:03:35Z galfar $
$Id: ImagingOpenGL.pas 128 2008-07-23 11:57:36Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
@ -33,7 +33,7 @@ unit ImagingOpenGL;
{$I ImagingOptions.inc}
{ Define this symbol if you want to use dglOpenGL header.}
{ $DEFINE USE_DGL_HEADERS}
{.$DEFINE USE_DGL_HEADERS}
interface
@ -49,12 +49,17 @@ uses
type
{ Various texture capabilities of installed OpenGL driver.}
TGLTextureCaps = record
MaxTextureSize: LongInt;
PowerOfTwo: Boolean;
DXTCompression: Boolean;
FloatTextures: Boolean;
MaxAnisotropy: LongInt;
MaxSimultaneousTextures: LongInt;
MaxTextureSize: LongInt; // Max size of texture in pixels supported by HW
NonPowerOfTwo: Boolean; // HW has full support for NPOT textures
DXTCompression: Boolean; // HW supports S3TC/DXTC compressed textures
ATI3DcCompression: Boolean; // HW supports ATI 3Dc compressed textures (ATI2N)
LATCCompression: Boolean; // HW supports LATC/RGTC compressed textures (ATI1N+ATI2N)
FloatTextures: Boolean; // HW supports floating point textures
MaxAnisotropy: LongInt; // Max anisotropy for aniso texture filtering
MaxSimultaneousTextures: LongInt; // Number of texture units
ClampToEdge: Boolean; // GL_EXT_texture_edge_clamp
TextureLOD: Boolean; // GL_SGIS_texture_lod
VertexTextureUnits: Integer; // Texture units accessible in vertex programs
end;
{ Returns texture capabilities of installed OpenGL driver.}
@ -71,7 +76,7 @@ function IsGLExtensionSupported(const Extension: string): Boolean;
supported by hardware using GetGLTextureCaps, ImageFormatToGL does not
check this.}
function ImageFormatToGL(Format: TImageFormat; var GLFormat: GLenum;
var GLType: GLenum; var GLInternal: GLint): Boolean;
var GLType: GLenum; var GLInternal: GLint; const Caps: TGLTextureCaps): Boolean;
{ All GL textures created by Imaging functions have default parameters set -
that means that no glTexParameter calls are made so default filtering,
@ -164,6 +169,14 @@ var
image->texture process (usually only pow2/nonpow2 stuff and when you
set custom Width & Height in CreateGLTextureFrom(Multi)Image).}
PasteNonPow2ImagesIntoPow2: Boolean = False;
{ Standard behaviur if GL_ARB_texture_non_power_of_two extension is not supported
is to rescale image to power of 2 dimensions. NPOT extension is exposed only
when HW has full support for NPOT textures but some cards
(ATI Radeons, some other maybe) have partial NPOT support. Namely Radeons
can use NPOT textures but not mipmapped. If you know what you are doing
you can disable NPOT support check so the image won't be rescaled to POT
by seting DisableNPOTSupportCheck to True.}
DisableNPOTSupportCheck: Boolean = False;
implementation
@ -239,6 +252,11 @@ const
GL_COMPRESSED_RGBA_S3TC_DXT1_EXT = $83F1;
GL_COMPRESSED_RGBA_S3TC_DXT3_EXT = $83F2;
GL_COMPRESSED_RGBA_S3TC_DXT5_EXT = $83F3;
GL_COMPRESSED_LUMINANCE_ALPHA_3DC_ATI = $8837;
GL_COMPRESSED_LUMINANCE_LATC1_EXT = $8C70;
GL_COMPRESSED_SIGNED_LUMINANCE_LATC1_EXT = $8C71;
GL_COMPRESSED_LUMINANCE_ALPHA_LATC2_EXT = $8C72;
GL_COMPRESSED_SIGNED_LUMINANCE_ALPHA_LATC2_EXT = $8C73;
// various GL extension constants
GL_MAX_TEXTURE_UNITS = $84E2;
@ -311,36 +329,49 @@ end;
function GetGLTextureCaps(var Caps: TGLTextureCaps): Boolean;
begin
// check DXTC support and load extension functions if necesary
// Check DXTC support and load extension functions if necesary
Caps.DXTCompression := IsGLExtensionSupported('GL_ARB_texture_compression') and
IsGLExtensionSupported('GL_EXT_texture_compression_s3tc');
if Caps.DXTCompression then
glCompressedTexImage2D := GetGLProcAddress('glCompressedTexImage2D');
Caps.DXTCompression := Caps.DXTCompression and (@glCompressedTexImage2D <> nil);
// check non power of 2 textures
Caps.PowerOfTwo := not IsGLExtensionSupported('GL_ARB_texture_non_power_of_two');
// check for floating point textures support
Caps.ATI3DcCompression := Caps.DXTCompression and
IsGLExtensionSupported('GL_ATI_texture_compression_3dc');
Caps.LATCCompression := Caps.DXTCompression and
IsGLExtensionSupported('GL_EXT_texture_compression_latc');
// Check non power of 2 textures
Caps.NonPowerOfTwo := IsGLExtensionSupported('GL_ARB_texture_non_power_of_two');
// Check for floating point textures support
Caps.FloatTextures := IsGLExtensionSupported('GL_ARB_texture_float');
// get max texture size
// Get max texture size
glGetIntegerv(GL_MAX_TEXTURE_SIZE, @Caps.MaxTextureSize);
// get max anisotropy
// Get max anisotropy
if IsGLExtensionSupported('GL_EXT_texture_filter_anisotropic') then
glGetIntegerv(GL_MAX_TEXTURE_MAX_ANISOTROPY_EXT, @Caps.MaxAnisotropy)
else
Caps.MaxAnisotropy := 0;
// get number of texture units
// Get number of texture units
if IsGLExtensionSupported('GL_ARB_multitexture') then
glGetIntegerv(GL_MAX_TEXTURE_UNITS, @Caps.MaxSimultaneousTextures)
else
Caps.MaxSimultaneousTextures := 1;
// get max texture size
// Get number of vertex texture units
if IsGLExtensionSupported('GL_ARB_vertex_shader') then
glGetIntegerv(GL_MAX_VERTEX_TEXTURE_IMAGE_UNITS, @Caps.VertexTextureUnits)
else
Caps.VertexTextureUnits := 1;
// Get max texture size
glGetIntegerv(GL_MAX_TEXTURE_SIZE, @Caps.MaxTextureSize);
// Clamp texture to edge?
Caps.ClampToEdge := IsGLExtensionSupported('GL_EXT_texture_edge_clamp');
// Texture LOD extension?
Caps.TextureLOD := IsGLExtensionSupported('GL_SGIS_texture_lod');
Result := True;
end;
function ImageFormatToGL(Format: TImageFormat; var GLFormat: GLenum;
var GLType: GLenum; var GLInternal: GLint): Boolean;
var GLType: GLenum; var GLInternal: GLint; const Caps: TGLTextureCaps): Boolean;
begin
GLFormat := 0;
GLType := 0;
@ -437,6 +468,13 @@ begin
ifDXT1: GLInternal := GL_COMPRESSED_RGBA_S3TC_DXT1_EXT;
ifDXT3: GLInternal := GL_COMPRESSED_RGBA_S3TC_DXT3_EXT;
ifDXT5: GLInternal := GL_COMPRESSED_RGBA_S3TC_DXT5_EXT;
ifATI1N: GLInternal := GL_COMPRESSED_LUMINANCE_LATC1_EXT;
ifATI2N:
begin
GLInternal := GL_COMPRESSED_LUMINANCE_ALPHA_LATC2_EXT;
if not Caps.LATCCompression and Caps.ATI3DcCompression then
GLInternal := GL_COMPRESSED_LUMINANCE_ALPHA_3DC_ATI;
end;
end;
Result := GLInternal <> 0;
end;
@ -500,7 +538,7 @@ function CreateGLTextureFromMultiImage(const Images: TDynImageDataArray;
Width, Height: LongInt; MipMaps: Boolean; MainLevelIndex: LongInt; OverrideFormat: TImageFormat;
CreatedWidth, CreatedHeight: PLongInt): GLuint;
const
CompressedFormats: TImageFormats = [ifDXT1, ifDXT3, ifDXT5];
BlockCompressedFormats: TImageFormats = [ifDXT1, ifDXT3, ifDXT5, ifATI1N, ifATI2N];
var
I, MipLevels, PossibleLevels, ExistingLevels, CurrentWidth, CurrentHeight: LongInt;
Caps: TGLTextureCaps;
@ -537,7 +575,7 @@ begin
// First check desired size and modify it if necessary
if Width <= 0 then Width := Images[MainLevelIndex].Width;
if Height <= 0 then Height := Images[MainLevelIndex].Height;
if Caps.PowerOfTwo then
if not Caps.NonPowerOfTwo and not DisableNPOTSupportCheck then
begin
// If device supports only power of 2 texture sizes
Width := NextPow2(Width);
@ -564,23 +602,27 @@ begin
else
Desired := OverrideFormat;
// Check if the hardware supports floating point and compressed textures
// Check if the hardware supports floating point and compressed textures
GetImageFormatInfo(Desired, Info);
if Info.IsFloatingPoint and not Caps.FloatTextures then
Desired := ifA8R8G8B8;
if (Desired in [ifDXT1, ifDXT3, ifDXT5]) and not Caps.DXTCompression then
Desired := ifA8R8G8B8;
if (Desired = ifATI1N) and not Caps.LATCCompression then
Desired := ifGray8;
if (Desired = ifATI2N) and not (Caps.ATI3DcCompression or Caps.LATCCompression) then
Desired := ifA8Gray8;
// Try to find GL format equivalent to image format and if it is not
// found use one of default formats
if not ImageFormatToGL(Desired, GLFormat, GLType, GLInternal) then
if not ImageFormatToGL(Desired, GLFormat, GLType, GLInternal, Caps) then
begin
GetImageFormatInfo(Desired, Info);
if Info.HasGrayChannel then
ConvTo := ifGray8
else
ConvTo := ifA8R8G8B8;
if not ImageFormatToGL(ConvTo, GLFormat, GLType, GLInternal) then
if not ImageFormatToGL(ConvTo, GLFormat, GLType, GLInternal, Caps) then
Exit;
end
else
@ -618,7 +660,7 @@ begin
// Check if input image for this mipmap level has the right
// size and format
NeedsConvert := not (Images[I].Format = ConvTo);
if ConvTo in CompressedFormats then
if ConvTo in BlockCompressedFormats then
begin
// Input images in DXTC will have min dimensions of 4, but we need
// current Width and Height to be lesser (for glCompressedTexImage2D)
@ -659,7 +701,7 @@ begin
FillMipMapLevel(LevelsArray[I - 1], CurrentWidth, CurrentHeight, LevelsArray[I]);
end;
if ConvTo in CompressedFormats then
if ConvTo in BlockCompressedFormats then
begin
// Note: GL DXTC texture snaller than 4x4 must have width and height
// as expected for non-DXTC texture (like 1x1 - we cannot
@ -838,6 +880,14 @@ initialization
not only A8R8G8B8
- support for cube and 3D maps
-- 0.25.0 Changes/Bug Fixes ---------------------------------
- Added 3Dc compressed texture formats support.
- Added detection of 3Dc formats to texture caps.
-- 0.24.3 Changes/Bug Fixes ---------------------------------
- Added DisableNPOTSupportCheck option and related functionality.
- Added some new texture caps detection.
-- 0.24.1 Changes/Bug Fixes ---------------------------------
- Added PasteNonPow2ImagesIntoPow2 option and related functionality.
- Better NeedsResize determination for small DXTC textures -

7
Imaging/ImagingOptions.inc
View File

@ -1,4 +1,4 @@
{ $Id: ImagingOptions.inc 100 2007-06-28 21:09:52Z galfar $ }
{ $Id: ImagingOptions.inc 132 2008-08-27 20:37:38Z galfar $ }
{
User Options
@ -212,11 +212,6 @@
{$PACKENUM 4} // Min enum size: 4 B
{$CALLING REGISTER} // default calling convention is register
{$IFDEF CPU86}
{$IFNDEF DYN_LIBRARY}
{$SMARTLINK ON} // smartlinking on, but not for dll/so -
// nothing gets exported from library when it is on
// in FPC 1.9.8
{$ENDIF}
{$ASMMODE INTEL} // intel assembler mode
{$ENDIF}
{$ENDIF}

272
Imaging/ImagingPortableMaps.pas
View File

@ -1,5 +1,5 @@
{
$Id: ImagingPortableMaps.pas 107 2007-11-06 23:37:48Z galfar $
$Id: ImagingPortableMaps.pas 127 2008-05-31 01:57:13Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
@ -65,11 +65,10 @@ type
protected
FIdNumbers: TChar2;
FSaveBinary: LongBool;
FMapInfo: TPortableMapInfo;
function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
OnlyFirstLevel: Boolean): Boolean; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
Index: LongInt): Boolean; override;
function SaveDataInternal(Handle: TImagingHandle; const Images: TDynImageDataArray;
Index: LongInt; var MapInfo: TPortableMapInfo): Boolean;
public
constructor Create; override;
function TestFormat(Handle: TImagingHandle): Boolean; override;
@ -203,6 +202,8 @@ var
PixelFP: TColorFPRec;
LineBuffer: array[0..LineBufferCapacity - 1] of Char;
LineEnd, LinePos: LongInt;
MapInfo: TPortableMapInfo;
LineBreak: string;
procedure CheckBuffer;
begin
@ -262,7 +263,7 @@ var
C := LineBuffer[LinePos];
Inc(LinePos);
until not (C in WhiteSpaces) or (LineEnd = 0);
// Dec pos, current is the beggining of the the string
// Dec pos, current is the begining of the the string
Dec(LinePos);
Result := S;
@ -273,6 +274,22 @@ var
Result := StrToInt(ReadString);
end;
procedure FindLineBreak;
var
C: Char;
begin
LineBreak := #10;
repeat
CheckBuffer;
C := LineBuffer[LinePos];
Inc(LinePos);
if C = #13 then
LineBreak := #13#10;
until C = #10;
end;
function ParseHeader: Boolean;
var
Id: TChar2;
@ -284,34 +301,37 @@ var
Result := False;
with GetIO do
begin
FillChar(FMapInfo, SizeOf(FMapInfo), 0);
FillChar(MapInfo, SizeOf(MapInfo), 0);
Read(Handle, @Id, SizeOf(Id));
FindLineBreak;
if Id[1] in ['1'..'6'] then
begin
// Read header for PBM, PGM, and PPM files
FMapInfo.Width := ReadIntValue;
FMapInfo.Height := ReadIntValue;
MapInfo.Width := ReadIntValue;
MapInfo.Height := ReadIntValue;
if Id[1] in ['1', '4'] then
begin
FMapInfo.MaxVal := 1;
FMapInfo.BitCount := 1
MapInfo.MaxVal := 1;
MapInfo.BitCount := 1
end
else
begin
// Read channel max value, <=255 for 8bit images, >255 for 16bit images
// but some programs think its max colors so put <=256 here
FMapInfo.MaxVal := ReadIntValue;
FMapInfo.BitCount := Iff(FMapInfo.MaxVal <= 256, 8, 16);
MapInfo.MaxVal := ReadIntValue;
MapInfo.BitCount := Iff(MapInfo.MaxVal <= 256, 8, 16);
end;
FMapInfo.Depth := 1;
MapInfo.Depth := 1;
case Id[1] of
'1', '4': FMapInfo.TupleType := ttBlackAndWhite;
'2', '5': FMapInfo.TupleType := ttGrayScale;
'1', '4': MapInfo.TupleType := ttBlackAndWhite;
'2', '5': MapInfo.TupleType := ttGrayScale;
'3', '6':
begin
FMapInfo.TupleType := ttRGB;
FMapInfo.Depth := 3;
MapInfo.TupleType := ttRGB;
MapInfo.Depth := 3;
end;
end;
end
@ -320,24 +340,24 @@ var
// Read values from PAM header
// WIDTH
if (ReadString <> SPAMWidth) then Exit;
FMapInfo.Width := ReadIntValue;
MapInfo.Width := ReadIntValue;
// HEIGHT
if (ReadString <> SPAMheight) then Exit;
FMapInfo.Height := ReadIntValue;
MapInfo.Height := ReadIntValue;
// DEPTH
if (ReadString <> SPAMDepth) then Exit;
FMapInfo.Depth := ReadIntValue;
MapInfo.Depth := ReadIntValue;
// MAXVAL
if (ReadString <> SPAMMaxVal) then Exit;
FMapInfo.MaxVal := ReadIntValue;
FMapInfo.BitCount := Iff(FMapInfo.MaxVal <= 256, 8, 16);
MapInfo.MaxVal := ReadIntValue;
MapInfo.BitCount := Iff(MapInfo.MaxVal <= 256, 8, 16);
// TUPLETYPE
if (ReadString <> SPAMTupleType) then Exit;
TupleTypeName := ReadString;
for I := Low(TTupleType) to High(TTupleType) do
if SameText(TupleTypeName, TupleTypeNames[I]) then
begin
FMapInfo.TupleType := I;
MapInfo.TupleType := I;
Break;
end;
// ENDHDR
@ -346,33 +366,42 @@ var
else if Id[1] in ['F', 'f'] then
begin
// Read header of PFM file
FMapInfo.Width := ReadIntValue;
FMapInfo.Height := ReadIntValue;
MapInfo.Width := ReadIntValue;
MapInfo.Height := ReadIntValue;
OldSeparator := DecimalSeparator;
DecimalSeparator := '.';
Scale := StrToFloatDef(ReadString, 0);
DecimalSeparator := OldSeparator;
FMapInfo.IsBigEndian := Scale > 0.0;
MapInfo.IsBigEndian := Scale > 0.0;
if Id[1] = 'F' then
FMapInfo.TupleType := ttRGBFP
MapInfo.TupleType := ttRGBFP
else
FMapInfo.TupleType := ttGrayScaleFP;
FMapInfo.Depth := Iff(FMapInfo.TupleType = ttRGBFP, 3, 1);
FMapInfo.BitCount := Iff(FMapInfo.TupleType = ttRGBFP, 96, 32);
MapInfo.TupleType := ttGrayScaleFP;
MapInfo.Depth := Iff(MapInfo.TupleType = ttRGBFP, 3, 1);
MapInfo.BitCount := Iff(MapInfo.TupleType = ttRGBFP, 96, 32);
end;
FixInputPos;
FMapInfo.Binary := (Id[1] in ['4', '5', '6', '7', 'F', 'f']);
MapInfo.Binary := (Id[1] in ['4', '5', '6', '7', 'F', 'f']);
if MapInfo.Binary and not (Id[1] in ['F', 'f']) then
begin
// Mimic the behaviour of Photoshop and other editors/viewers:
// If linenreaks in file are DOS CR/LF 16bit binary values are
// little endian, Unix LF only linebreak indicates big endian.
MapInfo.IsBigEndian := LineBreak = #10;
end;
// Check if values found in header are valid
Result := (FMapInfo.Width > 0) and (FMapInfo.Height > 0) and
(FMapInfo.BitCount in [1, 8, 16, 32, 96]) and (FMapInfo.TupleType <> ttInvalid);
Result := (MapInfo.Width > 0) and (MapInfo.Height > 0) and
(MapInfo.BitCount in [1, 8, 16, 32, 96]) and (MapInfo.TupleType <> ttInvalid);
// Now check if image has proper number of channels (PAM)
if Result then
case FMapInfo.TupleType of
ttBlackAndWhite, ttGrayScale: Result := FMapInfo.Depth = 1;
ttBlackAndWhiteAlpha, ttGrayScaleAlpha: Result := FMapInfo.Depth = 2;
ttRGB: Result := FMapInfo.Depth = 3;
ttRGBAlpha: Result := FMapInfo.Depth = 4;
case MapInfo.TupleType of
ttBlackAndWhite, ttGrayScale: Result := MapInfo.Depth = 1;
ttBlackAndWhiteAlpha, ttGrayScaleAlpha: Result := MapInfo.Depth = 2;
ttRGB: Result := MapInfo.Depth = 3;
ttRGBAlpha: Result := MapInfo.Depth = 4;
end;
end;
end;
@ -388,24 +417,24 @@ begin
// Try to parse file header
if not ParseHeader then Exit;
// Select appropriate data format based on values read from file header
case FMapInfo.TupleType of
case MapInfo.TupleType of
ttBlackAndWhite: Format := ifGray8;
ttBlackAndWhiteAlpha: Format := ifA8Gray8;
ttGrayScale: Format := IffFormat(FMapInfo.BitCount = 8, ifGray8, ifGray16);
ttGrayScaleAlpha: Format := IffFormat(FMapInfo.BitCount = 8, ifA8Gray8, ifA16Gray16);
ttRGB: Format := IffFormat(FMapInfo.BitCount = 8, ifR8G8B8, ifR16G16B16);
ttRGBAlpha: Format := IffFormat(FMapInfo.BitCount = 8, ifA8R8G8B8, ifA16R16G16B16);
ttGrayScale: Format := IffFormat(MapInfo.BitCount = 8, ifGray8, ifGray16);
ttGrayScaleAlpha: Format := IffFormat(MapInfo.BitCount = 8, ifA8Gray8, ifA16Gray16);
ttRGB: Format := IffFormat(MapInfo.BitCount = 8, ifR8G8B8, ifR16G16B16);
ttRGBAlpha: Format := IffFormat(MapInfo.BitCount = 8, ifA8R8G8B8, ifA16R16G16B16);
ttGrayScaleFP: Format := ifR32F;
ttRGBFP: Format := ifA32B32G32R32F;
end;
// Exit if no matching data format was found
if Format = ifUnknown then Exit;
NewImage(FMapInfo.Width, FMapInfo.Height, Format, Images[0]);
NewImage(MapInfo.Width, MapInfo.Height, Format, Images[0]);
Info := GetFormatInfo(Format);
// Now read pixels from file to dest image
if not FMapInfo.Binary then
if not MapInfo.Binary then
begin
Dest := Bits;
for I := 0 to Width * Height - 1 do
@ -414,7 +443,7 @@ begin
ifGray8:
begin
Dest^ := ReadIntValue;
if FMapInfo.BitCount = 1 then
if MapInfo.BitCount = 1 then
// If source is 1bit mono image (where 0=white, 1=black)
// we must scale it to 8bits
Dest^ := 255 - Dest^ * 255;
@ -440,9 +469,9 @@ begin
end
else
begin
if FMapInfo.BitCount > 1 then
if MapInfo.BitCount > 1 then
begin
if not (FMapInfo.TupleType in [ttGrayScaleFP, ttRGBFP]) then
if not (MapInfo.TupleType in [ttGrayScaleFP, ttRGBFP]) then
begin
// Just copy bytes from binary Portable Maps (non 1bit, non FP)
Read(Handle, Bits, Size);
@ -455,48 +484,43 @@ begin
// I will stick with Photoshops behaviour here
for I := 0 to Width * Height - 1 do
begin
Read(Handle, @PixelFP, FMapInfo.BitCount shr 3);
if FMapInfo.TupleType = ttRGBFP then
Read(Handle, @PixelFP, MapInfo.BitCount div 8);
if MapInfo.TupleType = ttRGBFP then
with PColorFPRec(Dest)^ do
begin
A := 1.0;
R := PixelFP.R;
G := PixelFP.G;
B := PixelFP.B;
if FMapInfo.IsBigEndian then
if MapInfo.IsBigEndian then
SwapEndianLongWord(PLongWord(Dest), 3);
end
else
begin
PSingle(Dest)^ := PixelFP.B;
if FMapInfo.IsBigEndian then
if MapInfo.IsBigEndian then
SwapEndianLongWord(PLongWord(Dest), 1);
end;
Inc(Dest, Info.BytesPerPixel);
end;
end;
if FMapInfo.TupleType in [ttBlackAndWhite, ttBlackAndWhiteAlpha] then
if MapInfo.TupleType in [ttBlackAndWhite, ttBlackAndWhiteAlpha] then
begin
// Black and white PAM files must be scaled to 8bits. Note that
// in PAM files 1=white, 0=black (reverse of PBM)
for I := 0 to Width * Height * Iff(FMapInfo.TupleType = ttBlackAndWhiteAlpha, 2, 1) - 1 do
for I := 0 to Width * Height * Iff(MapInfo.TupleType = ttBlackAndWhiteAlpha, 2, 1) - 1 do
PByteArray(Bits)[I] := PByteArray(Bits)[I] * 255;
end;
if FMapInfo.TupleType in [ttRGB, ttRGBAlpha] then
end
else if MapInfo.TupleType in [ttRGB, ttRGBAlpha] then
begin
// Swap channels of RGB/ARGB images. Binary RGB image files use BGR order.
SwapChannels(Images[0], ChannelBlue, ChannelRed);
end;
if FMapInfo.BitCount = 16 then
begin
Dest := Bits;
for I := 0 to Width * Height * Info.BytesPerPixel div SizeOf(Word) - 1 do
begin
PWord(Dest)^ := SwapEndianWord(PWord(Dest)^);
Inc(Dest, SizeOf(Word));
end;
end;
// Swap byte order if needed
if (MapInfo.BitCount = 16) and MapInfo.IsBigEndian then
SwapEndianWord(Bits, Width * Height * Info.BytesPerPixel div SizeOf(Word));
end
else
begin
@ -520,19 +544,19 @@ begin
FixInputPos;
if (FMapInfo.MaxVal <> Pow2Int(FMapInfo.BitCount) - 1) and
(FMapInfo.TupleType in [ttGrayScale, ttGrayScaleAlpha, ttRGB, ttRGBAlpha]) then
if (MapInfo.MaxVal <> Pow2Int(MapInfo.BitCount) - 1) and
(MapInfo.TupleType in [ttGrayScale, ttGrayScaleAlpha, ttRGB, ttRGBAlpha]) then
begin
Dest := Bits;
// Scale color values according to MaxVal we got from header
// if necessary.
for I := 0 to Width * Height * Info.BytesPerPixel div (FMapInfo.BitCount shr 3) - 1 do
for I := 0 to Width * Height * Info.BytesPerPixel div (MapInfo.BitCount shr 3) - 1 do
begin
if FMapInfo.BitCount = 8 then
Dest^ := Dest^ * 255 div FMapInfo.MaxVal
if MapInfo.BitCount = 8 then
Dest^ := Dest^ * 255 div MapInfo.MaxVal
else
PWord(Dest)^ := PWord(Dest)^ * 65535 div FMapInfo.MaxVal;
Inc(Dest, FMapInfo.BitCount shr 3);
PWord(Dest)^ := PWord(Dest)^ * 65535 div MapInfo.MaxVal;
Inc(Dest, MapInfo.BitCount shr 3);
end;
end;
@ -540,9 +564,12 @@ begin
end;
end;
function TPortableMapFileFormat.SaveData(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: Integer): Boolean;
function TPortableMapFileFormat.SaveDataInternal(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: Integer; var MapInfo: TPortableMapInfo): Boolean;
const
// Use Unix linebreak, for many viewers/editors it means that
// 16bit samples are stored as big endian - so we need to swap byte order
// before saving
LineDelimiter = #10;
PixelDelimiter = #32;
var
@ -567,14 +594,14 @@ var
var
OldSeparator: Char;
begin
WriteString('P' + FMapInfo.FormatId);
if not FMapInfo.HasPAMHeader then
WriteString('P' + MapInfo.FormatId);
if not MapInfo.HasPAMHeader then
begin
// Write header of PGM, PPM, and PFM files
WriteString(IntToStr(ImageToSave.Width));
WriteString(IntToStr(ImageToSave.Height));
case FMapInfo.TupleType of
ttGrayScale, ttRGB: WriteString(IntToStr(Pow2Int(FMapInfo.BitCount) - 1));
case MapInfo.TupleType of
ttGrayScale, ttRGB: WriteString(IntToStr(Pow2Int(MapInfo.BitCount) - 1));
ttGrayScaleFP, ttRGBFP:
begin
OldSeparator := DecimalSeparator;
@ -590,9 +617,9 @@ var
// Write PAM file header
WriteString(Format('%s %d', [SPAMWidth, ImageToSave.Width]));
WriteString(Format('%s %d', [SPAMHeight, ImageToSave.Height]));
WriteString(Format('%s %d', [SPAMDepth, FMapInfo.Depth]));
WriteString(Format('%s %d', [SPAMMaxVal, Pow2Int(FMapInfo.BitCount) - 1]));
WriteString(Format('%s %s', [SPAMTupleType, TupleTypeNames[FMapInfo.TupleType]]));
WriteString(Format('%s %d', [SPAMDepth, MapInfo.Depth]));
WriteString(Format('%s %d', [SPAMMaxVal, Pow2Int(MapInfo.BitCount) - 1]));
WriteString(Format('%s %s', [SPAMTupleType, TupleTypeNames[MapInfo.TupleType]]));
WriteString(SPAMEndHdr);
end;
end;
@ -605,29 +632,29 @@ begin
Info := GetFormatInfo(Format);
// Fill values of MapInfo record that were not filled by
// descendants in their SaveData methods
FMapInfo.BitCount := (Info.BytesPerPixel div Info.ChannelCount) * 8;
FMapInfo.Depth := Info.ChannelCount;
if FMapInfo.TupleType = ttInvalid then
MapInfo.BitCount := (Info.BytesPerPixel div Info.ChannelCount) * 8;
MapInfo.Depth := Info.ChannelCount;
if MapInfo.TupleType = ttInvalid then
begin
if Info.HasGrayChannel then
begin
if Info.HasAlphaChannel then
FMapInfo.TupleType := ttGrayScaleAlpha
MapInfo.TupleType := ttGrayScaleAlpha
else
FMapInfo.TupleType := ttGrayScale;
MapInfo.TupleType := ttGrayScale;
end
else
begin
if Info.HasAlphaChannel then
FMapInfo.TupleType := ttRGBAlpha
MapInfo.TupleType := ttRGBAlpha
else
FMapInfo.TupleType := ttRGB;
MapInfo.TupleType := ttRGB;
end;
end;
// Write file header
WriteHeader;
if not FMapInfo.Binary then
if not MapInfo.Binary then
begin
Src := Bits;
LineLength := 0;
@ -644,7 +671,7 @@ begin
with PColor48Rec(Src)^ do
WriteString(SysUtils.Format('%d %d %d', [R, G, B]), PixelDelimiter);
end;
// Lines in text PNM images should have length <70
// Lines in text PNM images should have length <70
if LineLength > 65 then
begin
LineLength := 0;
@ -656,12 +683,12 @@ begin
else
begin
// Write binary images
if not (FMapInfo.TupleType in [ttGrayScaleFP, ttRGBFP]) then
if not (MapInfo.TupleType in [ttGrayScaleFP, ttRGBFP]) then
begin
// Save integer binary images
if FMapInfo.BitCount = 8 then
if MapInfo.BitCount = 8 then
begin
if FMapInfo.TupleType in [ttGrayScale, ttGrayScaleAlpha] then
if MapInfo.TupleType in [ttGrayScale, ttGrayScaleAlpha] then
begin
// 8bit grayscale images can be written in one Write call
Write(Handle, Bits, Size);
@ -674,7 +701,7 @@ begin
for I := 0 to Width * Height - 1 do
with PColor32Rec(Src)^ do
begin
if FMapInfo.TupleType = ttRGBAlpha then
if MapInfo.TupleType = ttRGBAlpha then
Pixel32.A := A;
Pixel32.R := B;
Pixel32.G := G;
@ -688,7 +715,7 @@ begin
begin
// Images with 16bit channels: make sure that channel values are saved in big endian
Src := Bits;
if FMapInfo.TupleType in [ttGrayScale, ttGrayScaleAlpha] then
if MapInfo.TupleType in [ttGrayScale, ttGrayScaleAlpha] then
begin
// 16bit grayscale image
for I := 0 to Width * Height * Info.BytesPerPixel div SizeOf(Word) - 1 do
@ -704,7 +731,7 @@ begin
for I := 0 to Width * Height - 1 do
with PColor64Rec(Src)^ do
begin
if FMapInfo.TupleType = ttRGBAlpha then
if MapInfo.TupleType = ttRGBAlpha then
Pixel64.A := SwapEndianWord(A);
Pixel64.R := SwapEndianWord(B);
Pixel64.G := SwapEndianWord(G);
@ -713,13 +740,13 @@ begin
Inc(Src, Info.BytesPerPixel);
end;
end;
end;
end;
end
else
begin
// Floating point images (no need to swap endian here - little
// endian is specified in file header)
if FMapInfo.TupleType = ttGrayScaleFP then
if MapInfo.TupleType = ttGrayScaleFP then
begin
// Grayscale images can be written in one Write call
Write(Handle, Bits, Size);
@ -787,11 +814,13 @@ end;
function TPGMFileFormat.SaveData(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: Integer): Boolean;
var
MapInfo: TPortableMapInfo;
begin
FillChar(FMapInfo, SizeOf(FMapInfo), 0);
FMapInfo.FormatId := Iff(FSaveBinary, FIdNumbers[1], FIdNumbers[0]);
FMapInfo.Binary := FSaveBinary;
Result := inherited SaveData(Handle, Images, Index);
FillChar(MapInfo, SizeOf(MapInfo), 0);
MapInfo.FormatId := Iff(FSaveBinary, FIdNumbers[1], FIdNumbers[0]);
MapInfo.Binary := FSaveBinary;
Result := SaveDataInternal(Handle, Images, Index, MapInfo);
end;
procedure TPGMFileFormat.ConvertToSupported(var Image: TImageData;
@ -831,11 +860,13 @@ end;
function TPPMFileFormat.SaveData(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: Integer): Boolean;
var
MapInfo: TPortableMapInfo;
begin
FillChar(FMapInfo, SizeOf(FMapInfo), 0);
FMapInfo.FormatId := Iff(FSaveBinary, FIdNumbers[1], FIdNumbers[0]);
FMapInfo.Binary := FSaveBinary;
Result := inherited SaveData(Handle, Images, Index);
FillChar(MapInfo, SizeOf(MapInfo), 0);
MapInfo.FormatId := Iff(FSaveBinary, FIdNumbers[1], FIdNumbers[0]);
MapInfo.Binary := FSaveBinary;
Result := SaveDataInternal(Handle, Images, Index, MapInfo);
end;
procedure TPPMFileFormat.ConvertToSupported(var Image: TImageData;
@ -873,12 +904,14 @@ end;
function TPAMFileFormat.SaveData(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: Integer): Boolean;
var
MapInfo: TPortableMapInfo;
begin
FillChar(FMapInfo, SizeOf(FMapInfo), 0);
FMapInfo.FormatId := FIdNumbers[0];
FMapInfo.Binary := True;
FMapInfo.HasPAMHeader := True;
Result := inherited SaveData(Handle, Images, Index);
FillChar(MapInfo, SizeOf(MapInfo), 0);
MapInfo.FormatId := FIdNumbers[0];
MapInfo.Binary := True;
MapInfo.HasPAMHeader := True;
Result := SaveDataInternal(Handle, Images, Index, MapInfo);
end;
procedure TPAMFileFormat.ConvertToSupported(var Image: TImageData;
@ -915,16 +948,17 @@ function TPFMFileFormat.SaveData(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: Integer): Boolean;
var
Info: TImageFormatInfo;
MapInfo: TPortableMapInfo;
begin
FillChar(FMapInfo, SizeOf(FMapInfo), 0);
FillChar(MapInfo, SizeOf(MapInfo), 0);
Info := GetFormatInfo(Images[Index].Format);
if (Info.ChannelCount > 1) or Info.IsIndexed then
FMapInfo.TupleType := ttRGBFP
MapInfo.TupleType := ttRGBFP
else
FMapInfo.TupleType := ttGrayScaleFP;
FMapInfo.FormatId := Iff(FMapInfo.TupleType = ttGrayScaleFP, FIdNumbers[1], FIdNumbers[0]);
FMapInfo.Binary := True;
Result := inherited SaveData(Handle, Images, Index);
MapInfo.TupleType := ttGrayScaleFP;
MapInfo.FormatId := Iff(MapInfo.TupleType = ttGrayScaleFP, FIdNumbers[1], FIdNumbers[0]);
MapInfo.Binary := True;
Result := SaveDataInternal(Handle, Images, Index, MapInfo);
end;
procedure TPFMFileFormat.ConvertToSupported(var Image: TImageData;
@ -949,6 +983,10 @@ initialization
-- TODOS ----------------------------------------------------
- nothing now
-- 0.24.3 Changes/Bug Fixes -----------------------------------
- Improved compatibility of 16bit/component image loading.
- Changes for better thread safety.
-- 0.21 Changes/Bug Fixes -----------------------------------
- Made modifications to ASCII PNM loading to be more "stream-safe".
- Fixed bug: indexed images saved as grayscale in PFM.

23
Imaging/ImagingTypes.pas
View File

@ -1,5 +1,5 @@
{
$Id: ImagingTypes.pas 112 2007-12-11 19:43:15Z galfar $
$Id: ImagingTypes.pas 132 2008-08-27 20:37:38Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
@ -37,9 +37,9 @@ const
{ Current Major version of Imaging.}
ImagingVersionMajor = 0;
{ Current Minor version of Imaging.}
ImagingVersionMinor = 24;
ImagingVersionMinor = 26;
{ Current patch of Imaging.}
ImagingVersionPatch = 2;
ImagingVersionPatch = 0;
{ Imaging Option Ids whose values can be set/get by SetOption/
GetOption functions.}
@ -137,6 +137,11 @@ const
Allowed values are 0 (store as text - very! large files) and 1 (save binary).
Default value is 1.}
ImagingPPMSaveBinary = 51;
{ Boolean option that specifies whether GIF images with more frames
are animated by Imaging (according to frame disposal methods) or just
raw frames are loaded and sent to user (if you want to animate GIF yourself).
Default value is 1.}
ImagingGIFLoadAnimated = 56;
{ This option is used when reducing number of colors used in
@ -225,7 +230,9 @@ type
ifDXT1 = 220,
ifDXT3 = 221,
ifDXT5 = 222,
ifBTC = 223);
ifBTC = 223,
ifATI1N = 224,
ifATI2N = 225);
{ Color value for 32 bit images.}
TColor32 = LongWord;
@ -439,11 +446,9 @@ implementation
-- TODOS ----------------------------------------------------
- add lookup tables to pixel formats for fast conversions
- change TImageFormatInfo - add new fields that shoudl replace old chaos
like not knowing whether it is RGB without checking all other fields for False
(add something like FormatType = (ftIndexed, ftRGB, ftIntensity, ftCompressed,
ftFloatingPoint, ftRGBBitFields) and additional infos like HasAlphaChannel,
ChannelSize, ChannelCount, ...)
-- 0.24.3 Changes/Bug Fixes ---------------------------------
- Added ifATI1N and ifATI2N image data formats.
-- 0.23 Changes/Bug Fixes -----------------------------------
- Added ifBTC image format and SpecialNearestFormat field

43
Imaging/ImagingUtility.pas
View File

@ -1,5 +1,5 @@
{
$Id: ImagingUtility.pas 86 2007-06-12 22:39:08Z galfar $
$Id: ImagingUtility.pas 128 2008-07-23 11:57:36Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
@ -56,6 +56,9 @@ type
TBooleanArray = array[0..MaxInt - 1] of Boolean;
PBooleanArray = ^TBooleanArray;
TDynIntegerArray = array of Integer;
TDynBooleanArray = array of Boolean;
TWordRec = packed record
case Integer of
0: (WordValue: Word);
@ -119,8 +122,10 @@ procedure FreeMemNil(var P); {$IFDEF USE_INLINE}inline;{$ENDIF}
procedure FreeMem(P: Pointer); {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Returns current exception object. Do not call outside exception handler.}
function GetExceptObject: Exception; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Returns time value with microsecond resolution. Use for some time counters.}
{ Returns time value with microsecond resolution.}
function GetTimeMicroseconds: Int64;
{ Returns time value with milisecond resolution.}
function GetTimeMilliseconds: Int64;
{ Returns file extension (without "." dot)}
function GetFileExt(const FileName: string): string;
@ -128,7 +133,7 @@ function GetFileExt(const FileName: string): string;
function GetAppExe: string;
{ Returns directory where application's exceutable is located without
path delimiter at the end.}
function GetAppDir:string;
function GetAppDir: string;
{ Returns True if FileName matches given Mask with optional case sensitivity.
Mask can contain ? and * special characters: ? matches
one character, * matches zero or more characters.}
@ -151,6 +156,10 @@ function PosNoCase(const SubStr, S: string; Offset: LongInt = 1): LongInt; {$IFD
function StrToken(var S: string; Sep: Char): string;
{ Same as StrToken but searches from the end of S string.}
function StrTokenEnd(var S: string; Sep: Char): string;
{ Returns string representation of integer number (with digit grouping).}
function IntToStrFmt(const I: Int64): string;
{ Returns string representation of float number (with digit grouping).}
function FloatToStrFmt(const F: Double; Precision: Integer = 2): string;
{ Clamps integer value to range <Min, Max>}
function ClampInt(Number: LongInt; Min, Max: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
@ -235,6 +244,7 @@ procedure SwapEndianWord(P: PWordArray; Count: LongInt); overload;
function SwapEndianLongWord(Value: LongWord): LongWord; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Swaps byte order of multiple LongWord values.}
procedure SwapEndianLongWord(P: PLongWord; Count: LongInt); overload;
{ Calculates CRC32 for the given data.}
procedure CalcCrc32(var Crc: LongWord; Data: Pointer; Size: LongInt);
{ Fills given memory with given Byte value. Size is size of buffer in bytes.}
@ -385,6 +395,11 @@ asm
end;
{$ENDIF}
function GetTimeMilliseconds: Int64;
begin
Result := GetTimeMicroseconds div 1000;
end;
function GetFileExt(const FileName: string): string;
begin
Result := ExtractFileExt(FileName);
@ -418,7 +433,7 @@ begin
{$ENDIF}
end;
function GetAppDir:string;
function GetAppDir: string;
begin
Result := ExtractFileDir(GetAppExe);
end;
@ -760,6 +775,16 @@ begin
end;
end;
function IntToStrFmt(const I: Int64): string;
begin
Result := Format('%.0n', [I * 1.0]);
end;
function FloatToStrFmt(const F: Double; Precision: Integer): string;
begin
Result := Format('%.' + IntToStr(Precision) + 'n', [F]);
end;
function ClampInt(Number: LongInt; Min, Max: LongInt): LongInt;
begin
Result := Number;
@ -1371,8 +1396,7 @@ procedure ClipCopyBounds(var SrcX, SrcY, Width, Height, DstX, DstY: LongInt; Src
begin
Diff := DstClipMin - DstPos;
Size := Size - Diff;
if DstPos < SrcPos then
SrcPos := SrcPos + Diff;
SrcPos := SrcPos + Diff;
DstPos := DstClipMin;
end;
if SrcPos < 0 then
@ -1528,6 +1552,13 @@ initialization
-- TODOS ----------------------------------------------------
- nothing now
-- 0.25.0 Changes/Bug Fixes -----------------------------------
- Fixed error in ClipCopyBounds which was causing ... bad clipping!
-- 0.24.3 Changes/Bug Fixes -----------------------------------
- Added GetTimeMilliseconds function.
- Added IntToStrFmt and FloatToStrFmt helper functions.
-- 0.23 Changes/Bug Fixes -----------------------------------
- Added RectInRect and RectIntersects functions
- Added some string utils: StrToken, StrTokenEnd, PosEx, PosNoCase.

76
Tools/cedserver_config_2_3/cedserver_config_2_3.lpi Normal file
View File

@ -0,0 +1,76 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<PathDelim Value="/"/>
<Version Value="6"/>
<General>
<MainUnit Value="0"/>
<TargetFileExt Value=""/>
<ActiveEditorIndexAtStart Value="0"/>
</General>
<VersionInfo>
<ProjectVersion Value=""/>
<Language Value=""/>
<CharSet Value=""/>
</VersionInfo>
<PublishOptions>
<Version Value="2"/>
<IgnoreBinaries Value="False"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
<LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
</local>
</RunParams>
<Units Count="1">
<Unit0>
<Filename Value="cedserver_config_2_3.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="cedserver_config_2_3"/>
<CursorPos X="31" Y="72"/>
<TopLine Value="56"/>
<EditorIndex Value="0"/>
<UsageCount Value="20"/>
<Loaded Value="True"/>
</Unit0>
</Units>
<JumpHistory Count="3" HistoryIndex="2">
<Position1>
<Filename Value="cedserver_config_2_3.lpr"/>
<Caret Line="106" Column="3" TopLine="30"/>
</Position1>
<Position2>
<Filename Value="cedserver_config_2_3.lpr"/>
<Caret Line="51" Column="66" TopLine="21"/>
</Position2>
<Position3>
<Filename Value="cedserver_config_2_3.lpr"/>
<Caret Line="44" Column="39" TopLine="27"/>
</Position3>
</JumpHistory>
</ProjectOptions>
<CompilerOptions>
<Version Value="8"/>
<Parsing>
<SyntaxOptions>
<CStyleOperator Value="False"/>
</SyntaxOptions>
</Parsing>
<CodeGeneration>
<SmartLinkUnit Value="True"/>
</CodeGeneration>
<Linking>
<Debugging>
<UseLineInfoUnit Value="False"/>
<StripSymbols Value="True"/>
</Debugging>
<LinkSmart Value="True"/>
</Linking>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
</CONFIG>