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

174
Client/Tools/UfrmElevateSettings.pas
View File

@ -1,81 +1,93 @@
(* (*
* CDDL HEADER START * CDDL HEADER START
* *
* The contents of this file are subject to the terms of the * The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only * Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance * (the "License"). You may not use this file except in compliance
* with the License. * with the License.
* *
* You can obtain a copy of the license at * You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php. * http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions * See the License for the specific language governing permissions
* and limitations under the License. * and limitations under the License.
* *
* When distributing Covered Code, include this CDDL HEADER in each * When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at * file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable, * http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed * add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information: * by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner] * Portions Copyright [yyyy] [name of copyright owner]
* *
* CDDL HEADER END * CDDL HEADER END
* *
* *
* Portions Copyright 2007 Andreas Schneider * Portions Copyright 2008 Andreas Schneider
*) *)
unit UfrmElevateSettings; unit UfrmElevateSettings;
{$mode objfpc}{$H+} {$mode objfpc}{$H+}
interface interface
uses uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, LMessages, Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, LMessages,
LCLIntf, StdCtrls, Spin; LCLIntf, StdCtrls, Spin, ExtCtrls;
type type
{ TfrmElevateSettings } { TfrmElevateSettings }
TfrmElevateSettings = class(TForm) TfrmElevateSettings = class(TForm)
rbSet: TRadioButton; cbRandomHeight: TCheckBox;
rbRaise: TRadioButton; Panel1: TPanel;
rbLower: TRadioButton; Panel2: TPanel;
seZ: TSpinEdit; Panel3: TPanel;
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction); Panel4: TPanel;
procedure FormDeactivate(Sender: TObject); rbRaise: TRadioButton;
protected rbLower: TRadioButton;
procedure MouseLeave(var msg: TLMessage); message CM_MouseLeave; rbSet: TRadioButton;
public seRandomHeight: TSpinEdit;
{ public declarations } seZ: TSpinEdit;
end; procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormDeactivate(Sender: TObject);
var procedure seRandomHeightChange(Sender: TObject);
frmElevateSettings: TfrmElevateSettings; protected
procedure MouseLeave(var msg: TLMessage); message CM_MouseLeave;
implementation public
{ public declarations }
{ TfrmElevateSettings } end;
procedure TfrmElevateSettings.FormClose(Sender: TObject; var
var CloseAction: TCloseAction); frmElevateSettings: TfrmElevateSettings;
begin
CloseAction := caHide; implementation
end;
{ TfrmElevateSettings }
procedure TfrmElevateSettings.FormDeactivate(Sender: TObject);
begin procedure TfrmElevateSettings.FormClose(Sender: TObject;
Close; var CloseAction: TCloseAction);
end; begin
CloseAction := caHide;
procedure TfrmElevateSettings.MouseLeave(var msg: TLMessage); end;
begin
if not PtInRect(ClientRect, ScreenToClient(Mouse.CursorPos)) then procedure TfrmElevateSettings.FormDeactivate(Sender: TObject);
Close; begin
end; Close;
end;
initialization
{$I UfrmElevateSettings.lrs} procedure TfrmElevateSettings.seRandomHeightChange(Sender: TObject);
begin
end. 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 * CDDL HEADER START
* *
* The contents of this file are subject to the terms of the * The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only * Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance * (the "License"). You may not use this file except in compliance
* with the License. * with the License.
* *
* You can obtain a copy of the license at * You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php. * http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions * See the License for the specific language governing permissions
* and limitations under the License. * and limitations under the License.
* *
* When distributing Covered Code, include this CDDL HEADER in each * When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at * file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable, * http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed * add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information: * by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner] * Portions Copyright [yyyy] [name of copyright owner]
* *
* CDDL HEADER END * CDDL HEADER END
* *
* *
* Portions Copyright 2007 Andreas Schneider * Portions Copyright 2007 Andreas Schneider
*) *)
unit UOverlayUI; unit UOverlayUI;
{$mode objfpc}{$H+} {$mode objfpc}{$H+}
interface interface
uses uses
Classes, SysUtils, Gl, GLU, ImagingTypes, ImagingClasses, ImagingOpenGL, Classes, SysUtils, Gl, GLU, ImagingTypes, ImagingClasses, ImagingOpenGL,
OpenGLContext, ImagingUtility; OpenGLContext, ImagingUtility;
type type
{ TGLArrow } { TGLArrow }
TGLArrow = class(TObject) TGLArrow = class(TObject)
constructor Create(AGraphic: TSingleImage); constructor Create(AGraphic: TSingleImage);
destructor Destroy; override; destructor Destroy; override;
protected protected
FGraphic: TSingleImage; FGraphic: TSingleImage;
FTexture: GLuint; FTexture: GLuint;
FRealWidth: Integer; FRealWidth: Integer;
FRealHeight: Integer; FRealHeight: Integer;
FWidth: Integer; FWidth: Integer;
FHeight: Integer; FHeight: Integer;
FCurrentX: Integer; FCurrentX: Integer;
FCurrentY: Integer; FCurrentY: Integer;
procedure UpdateTexture; procedure UpdateTexture;
public public
property Width: Integer read FWidth; property Width: Integer read FWidth;
property Height: Integer read FHeight; property Height: Integer read FHeight;
property CurrentX: Integer read FCurrentX; property CurrentX: Integer read FCurrentX;
property CurrentY: Integer read FCurrentY; property CurrentY: Integer read FCurrentY;
function HitTest(AX, AY: Integer): Boolean; function HitTest(AX, AY: Integer): Boolean;
procedure DrawGL(AX, AY: Integer; AActive: Boolean = False); procedure DrawGL(AX, AY: Integer; AActive: Boolean = False);
end; end;
{ TOverlayUI } { TOverlayUI }
TOverlayUI = class(TObject) TOverlayUI = class(TObject)
constructor Create; constructor Create;
destructor Destroy; override; destructor Destroy; override;
protected protected
FArrows: array[0..7] of TGLArrow; FArrows: array[0..7] of TGLArrow;
FActiveArrow: Integer; FActiveArrow: Integer;
FVisible: Boolean; FVisible: Boolean;
public public
property ActiveArrow: Integer read FActiveArrow write FActiveArrow; property ActiveArrow: Integer read FActiveArrow write FActiveArrow;
property Visible: Boolean read FVisible write FVisible; property Visible: Boolean read FVisible write FVisible;
function HitTest(AX, AY: Integer): Integer; function HitTest(AX, AY: Integer): Integer;
procedure Draw(AContext: TOpenGLControl); procedure Draw(AContext: TOpenGLControl);
end; end;
implementation implementation
uses uses
UResourceManager; UResourceManager;
{ TGLArrow } { TGLArrow }
constructor TGLArrow.Create(AGraphic: TSingleImage); constructor TGLArrow.Create(AGraphic: TSingleImage);
var var
caps: TGLTextureCaps; caps: TGLTextureCaps;
begin begin
inherited Create; inherited Create;
FRealWidth := AGraphic.Width; FRealWidth := AGraphic.Width;
FRealHeight := AGraphic.Height; FRealHeight := AGraphic.Height;
GetGLTextureCaps(caps); GetGLTextureCaps(caps);
if caps.PowerOfTwo then if caps.NonPowerOfTwo then
begin begin
if IsPow2(FRealWidth) then FWidth := FRealWidth else FWidth := NextPow2(FRealWidth); FWidth := FRealHeight;
if IsPow2(FRealHeight) then FHeight := FRealHeight else FHeight := NextPow2(FRealHeight); FHeight := FRealHeight;
end else end else
begin begin
FWidth := FRealHeight; if IsPow2(FRealWidth) then FWidth := FRealWidth else FWidth := NextPow2(FRealWidth);
FHeight := FRealHeight; if IsPow2(FRealHeight) then FHeight := FRealHeight else FHeight := NextPow2(FRealHeight);
end; end;
FGraphic := TSingleImage.CreateFromParams(FWidth, FHeight, ifA8R8G8B8); FGraphic := TSingleImage.CreateFromParams(FWidth, FHeight, ifA8R8G8B8);
AGraphic.CopyTo(0, 0, FRealWidth, FRealHeight, FGraphic, 0, 0); AGraphic.CopyTo(0, 0, FRealWidth, FRealHeight, FGraphic, 0, 0);
FTexture := 0; FTexture := 0;
end; end;
destructor TGLArrow.Destroy; destructor TGLArrow.Destroy;
begin begin
if FGraphic <> nil then FreeAndNil(FGraphic); if FGraphic <> nil then FreeAndNil(FGraphic);
if FTexture <> 0 then glDeleteTextures(1, @FTexture); if FTexture <> 0 then glDeleteTextures(1, @FTexture);
inherited Destroy; inherited Destroy;
end; end;
procedure TGLArrow.UpdateTexture; procedure TGLArrow.UpdateTexture;
begin begin
if (FGraphic <> nil) and (FRealWidth > 0) and (FRealWidth > 0) then if (FGraphic <> nil) and (FRealWidth > 0) and (FRealWidth > 0) then
begin begin
FTexture := CreateGLTextureFromImage(FGraphic.ImageDataPointer^, 0, 0, False); FTexture := CreateGLTextureFromImage(FGraphic.ImageDataPointer^, 0, 0, False);
glBindTexture(GL_TEXTURE_2D, FTexture); glBindTexture(GL_TEXTURE_2D, FTexture);
glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST); glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_NEAREST);
glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_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_S, GL_CLAMP);
glTexParameterf(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP); glTexParameterf(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP);
end; end;
end; end;
function TGLArrow.HitTest(AX, AY: Integer): Boolean; function TGLArrow.HitTest(AX, AY: Integer): Boolean;
begin begin
if (AX > -1) and (AX < FRealWidth) and (AY > -1) and (AY < FRealHeight) then if (AX > -1) and (AX < FRealWidth) and (AY > -1) and (AY < FRealHeight) then
begin begin
Result := (FGraphic <> nil) and (Cardinal(PIntegerArray(FGraphic.Bits)^[AY * FWidth + AX] and $FF000000) > 0); Result := (FGraphic <> nil) and (Cardinal(PIntegerArray(FGraphic.Bits)^[AY * FWidth + AX] and $FF000000) > 0);
end else end else
Result := False; Result := False;
end; end;
procedure TGLArrow.DrawGL(AX, AY: Integer; AActive: Boolean = False); procedure TGLArrow.DrawGL(AX, AY: Integer; AActive: Boolean = False);
begin begin
FCurrentX := AX; FCurrentX := AX;
FCurrentY := AY; FCurrentY := AY;
if FTexture = 0 then UpdateTexture; if FTexture = 0 then UpdateTexture;
if FTexture <> 0 then if FTexture <> 0 then
begin begin
if AActive then if AActive then
begin begin
glEnable(GL_COLOR_LOGIC_OP); glEnable(GL_COLOR_LOGIC_OP);
glLogicOp(GL_COPY_INVERTED); glLogicOp(GL_COPY_INVERTED);
end; end;
glBindTexture(GL_TEXTURE_2D, FTexture); glBindTexture(GL_TEXTURE_2D, FTexture);
glBegin(GL_QUADS); glBegin(GL_QUADS);
glTexCoord2f(0, 0); glVertex2d(AX, AY); glTexCoord2f(0, 0); glVertex2d(AX, AY);
glTexCoord2f(1, 0); glVertex2d(AX + FWidth, AY); glTexCoord2f(1, 0); glVertex2d(AX + FWidth, AY);
glTexCoord2f(1, 1); glVertex2d(AX + FWidth, AY + FHeight); glTexCoord2f(1, 1); glVertex2d(AX + FWidth, AY + FHeight);
glTexCoord2f(0, 1); glVertex2d(AX, AY + FHeight); glTexCoord2f(0, 1); glVertex2d(AX, AY + FHeight);
glEnd; glEnd;
if AActive then if AActive then
glDisable(GL_COLOR_LOGIC_OP); glDisable(GL_COLOR_LOGIC_OP);
end; end;
end; end;
{ TOverlayUI } { TOverlayUI }
constructor TOverlayUI.Create; constructor TOverlayUI.Create;
var var
i: Integer; i: Integer;
arrow: TSingleImage; arrow: TSingleImage;
begin begin
inherited Create; inherited Create;
FActiveArrow := -1; FActiveArrow := -1;
FVisible := False; FVisible := False;
arrow := TSingleImage.CreateFromStream(ResourceManager.GetResource(0)); arrow := TSingleImage.CreateFromStream(ResourceManager.GetResource(0));
for i := 0 to 3 do for i := 0 to 3 do
begin begin
FArrows[2*i] := TGLArrow.Create(arrow); FArrows[2*i] := TGLArrow.Create(arrow);
arrow.Rotate(-90); arrow.Rotate(-90);
end; end;
arrow.Free; arrow.Free;
arrow := TSingleImage.CreateFromStream(ResourceManager.GetResource(1)); arrow := TSingleImage.CreateFromStream(ResourceManager.GetResource(1));
for i := 0 to 3 do for i := 0 to 3 do
begin begin
FArrows[2*i+1] := TGLArrow.Create(arrow); FArrows[2*i+1] := TGLArrow.Create(arrow);
arrow.Rotate(-90); arrow.Rotate(-90);
end; end;
arrow.Free; arrow.Free;
end; end;
destructor TOverlayUI.Destroy; destructor TOverlayUI.Destroy;
var var
i: Integer; i: Integer;
begin begin
for i := 0 to 7 do for i := 0 to 7 do
if FArrows[i] <> nil then FreeAndNil(FArrows[i]); if FArrows[i] <> nil then FreeAndNil(FArrows[i]);
inherited Destroy; inherited Destroy;
end; end;
function TOverlayUI.HitTest(AX, AY: Integer): Integer; function TOverlayUI.HitTest(AX, AY: Integer): Integer;
var var
i: Integer; i: Integer;
begin begin
Result := -1; Result := -1;
i := 0; i := 0;
while (i <= 7) and (Result = -1) do while (i <= 7) and (Result = -1) do
begin begin
if FArrows[i].HitTest(AX - FArrows[i].CurrentX, AY - FArrows[i].CurrentY) then if FArrows[i].HitTest(AX - FArrows[i].CurrentX, AY - FArrows[i].CurrentY) then
Result := i; Result := i;
Inc(i); Inc(i);
end; end;
end; end;
procedure TOverlayUI.Draw(AContext: TOpenGLControl); procedure TOverlayUI.Draw(AContext: TOpenGLControl);
begin begin
if FVisible then if FVisible then
begin begin
FArrows[0].DrawGL(10, 10, FActiveArrow = 0); FArrows[0].DrawGL(10, 10, FActiveArrow = 0);
FArrows[1].DrawGL(AContext.Width div 2 - FArrows[1].Width div 2, 10, FArrows[1].DrawGL(AContext.Width div 2 - FArrows[1].Width div 2, 10,
FActiveArrow = 1); FActiveArrow = 1);
FArrows[2].DrawGL(AContext.Width - 10 - FArrows[2].Width, 10, FArrows[2].DrawGL(AContext.Width - 10 - FArrows[2].Width, 10,
FActiveArrow = 2); FActiveArrow = 2);
FArrows[3].DrawGL(AContext.Width - 10 - FArrows[3].Width, FArrows[3].DrawGL(AContext.Width - 10 - FArrows[3].Width,
AContext.Height div 2 - FArrows[3].Height div 2, AContext.Height div 2 - FArrows[3].Height div 2,
FActiveArrow = 3); FActiveArrow = 3);
FArrows[4].DrawGL(AContext.Width - 10 - FArrows[4].Width, FArrows[4].DrawGL(AContext.Width - 10 - FArrows[4].Width,
AContext.Height - 10 - FArrows[4].Height, AContext.Height - 10 - FArrows[4].Height,
FActiveArrow = 4); FActiveArrow = 4);
FArrows[5].DrawGL(AContext.Width div 2 - FArrows[5].Width div 2, FArrows[5].DrawGL(AContext.Width div 2 - FArrows[5].Width div 2,
AContext.Height - 10 - FArrows[5].Height, AContext.Height - 10 - FArrows[5].Height,
FActiveArrow = 5); FActiveArrow = 5);
FArrows[6].DrawGL(10, AContext.Height - 10 - FArrows[6].Height, FArrows[6].DrawGL(10, AContext.Height - 10 - FArrows[6].Height,
FActiveArrow = 6); FActiveArrow = 6);
FArrows[7].DrawGL(10, AContext.Height div 2 - FArrows[7].Height div 2, FArrows[7].DrawGL(10, AContext.Height div 2 - FArrows[7].Height div 2,
FActiveArrow = 7); FActiveArrow = 7);
end; end;
end; end;
end. end.

11
Client/UfrmLogin.lfm
View File

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

2
Client/UfrmMain.pas
View File

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

1
Client/UfrmRegionControl.lfm
View File

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

2
Client/UfrmRegionControl.pas
View File

@ -345,6 +345,8 @@ var
areaInfo: PRect; areaInfo: PRect;
p: TPoint; p: TPoint;
begin begin
if vstRegions.GetFirstSelected = nil then Exit;
FAreaMove := []; FAreaMove := [];
p := Point(X * 8, Y * 8); p := Point(X * 8, Y * 8);
match := nil; 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 Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net http://imaginglib.sourceforge.net
@ -1573,6 +1573,8 @@ function GenerateMipMaps(const Image: TImageData; Levels: LongInt;
var MipMaps: TDynImageDataArray): Boolean; var MipMaps: TDynImageDataArray): Boolean;
var var
Width, Height, I, Count: LongInt; Width, Height, I, Count: LongInt;
Info: TImageFormatInfo;
CompatibleCopy: TImageData;
begin begin
Result := False; Result := False;
if TestImage(Image) then if TestImage(Image) then
@ -1585,6 +1587,20 @@ begin
if (Levels <= 0) or (Levels > Count) then if (Levels <= 0) or (Levels > Count) then
Levels := Count; 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); FreeImagesInArray(MipMaps);
SetLength(MipMaps, Levels); SetLength(MipMaps, Levels);
CloneImage(Image, MipMaps[0]); CloneImage(Image, MipMaps[0]);
@ -1595,8 +1611,17 @@ begin
Height := Height shr 1; Height := Height shr 1;
if Width < 1 then Width := 1; if Width < 1 then Width := 1;
if Height < 1 then Height := 1; if Height < 1 then Height := 1;
FillMipMapLevel(MipMaps[I - 1], Width, Height, MipMaps[I]); FillMipMapLevel(CompatibleCopy, Width, Height, MipMaps[I]);
end; 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; Result := True;
except except
RaiseImaging(SErrorGenerateMipMaps, [Levels, ImageToStr(Image)]); RaiseImaging(SErrorGenerateMipMaps, [Levels, ImageToStr(Image)]);
@ -3262,15 +3287,13 @@ finalization
File Notes: File Notes:
-- TODOS ---------------------------------------------------- -- TODOS ----------------------------------------------------
- make searching for the closest color in palette much faster - MapImageToPal - nothing now
- investigate CopyPixel and ComparePixels inline problems - line 550
- add to low level interface function -- 0.24.3 Changes/Bug Fixes ---------------------------------
CreateImageFromRawData(W, H, Bpp, Data, Align, Flipped, Endian, ...) - GenerateMipMaps now generates all smaller levels from
and CreateRawDataFromImage() - use these in BMP loading (align) original big image (better results when using more advanced filters).
and PNG loading (endian) Also conversion to compatible image format is now done here not
- add loading of multi images from file sequence in FillMipMapLevel (that is called for every mipmap level).
- do not load all frames when only one is required, possible?
(LoadImageFromFile on MNG/DDS)
-- 0.23 Changes/Bug Fixes ----------------------------------- -- 0.23 Changes/Bug Fixes -----------------------------------
- MakePaletteForImages now works correctly for indexed and special format images - 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 Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net http://imaginglib.sourceforge.net
@ -484,7 +484,7 @@ begin
FPalSize := 1 shl BI.BitCount; FPalSize := 1 shl BI.BitCount;
Read(Handle, Palette, FPalSize * SizeOf(TColor32Rec)); Read(Handle, Palette, FPalSize * SizeOf(TColor32Rec));
end; end;
for I := 0 to FPalSize - 1 do for I := 0 to Info.PaletteEntries - 1 do
Palette[I].A := $FF; Palette[I].A := $FF;
end; end;
@ -802,6 +802,10 @@ initialization
- nothing now - nothing now
- Add option to choose to save V3 or V4 headers. - 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 ----------------------------------- -- 0.23 Changes/Bug Fixes -----------------------------------
- Now saves bitmaps as bottom-up for better compatibility - Now saves bitmaps as bottom-up for better compatibility
(mainly Lazarus' TImage!). (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 Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net http://imaginglib.sourceforge.net
@ -62,8 +62,10 @@ const
pcDkGray = $FF808080; pcDkGray = $FF808080;
MaxPenWidth = 256; MaxPenWidth = 256;
type type
EImagingCanvasError = class(EImagingError); EImagingCanvasError = class(EImagingError);
EImagingCanvasBlendingError = class(EImagingError);
{ Fill mode used when drawing filled objects on canvas.} { Fill mode used when drawing filled objects on canvas.}
TFillMode = ( TFillMode = (
@ -77,6 +79,26 @@ type
pmClear // No drawing done 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.} { Represents 3x3 convolution filter kernel.}
TConvolutionFilter3x3 = record TConvolutionFilter3x3 = record
Kernel: array[0..2, 0..2] of LongInt; Kernel: array[0..2, 0..2] of LongInt;
@ -91,6 +113,13 @@ type
Bias: Single; Bias: Single;
end; 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. { Base canvas class for drawing objects, applying effects, and other.
Constructor takes TBaseImage (or pointer to TImageData). Source image Constructor takes TBaseImage (or pointer to TImageData). Source image
bits are not copied but referenced so all canvas functions affect 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 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 work only for few select formats (or only one) but they are optimized thus
much faster. 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) TImagingCanvas = class(TObject)
private private
@ -125,6 +149,7 @@ type
procedure SetFillColor32(const Value: TColor32); {$IFDEF USE_INLINE}inline;{$ENDIF} procedure SetFillColor32(const Value: TColor32); {$IFDEF USE_INLINE}inline;{$ENDIF}
procedure SetFillColorFP(const Value: TColorFPRec); {$IFDEF USE_INLINE}inline;{$ENDIF} procedure SetFillColorFP(const Value: TColorFPRec); {$IFDEF USE_INLINE}inline;{$ENDIF}
procedure SetClipRect(const Value: TRect); procedure SetClipRect(const Value: TRect);
procedure CheckBeforeBlending(SrcFactor, DestFactor: TBlendingFactor; DestCanvas: TImagingCanvas);
protected protected
FPData: PImageData; FPData: PImageData;
FClipRect: TRect; FClipRect: TRect;
@ -151,6 +176,11 @@ type
like ellipses and circles.} like ellipses and circles.}
procedure HorzLineInternal(X1, X2, Y: LongInt; Color: Pointer; Bpp: LongInt); virtual; 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 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 public
constructor CreateForData(ImageDataPointer: PImageData); constructor CreateForData(ImageDataPointer: PImageData);
constructor CreateForImage(Image: TBaseImage); constructor CreateForImage(Image: TBaseImage);
@ -177,6 +207,8 @@ type
procedure FrameRect(const Rect: TRect); procedure FrameRect(const Rect: TRect);
{ Fills given rectangle with current fill settings.} { Fills given rectangle with current fill settings.}
procedure FillRect(const Rect: TRect); virtual; 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 { Draws rectangle which is outlined by using the current pen settings and
filled by using the current fill settings.} filled by using the current fill settings.}
procedure Rectangle(const Rect: TRect); procedure Rectangle(const Rect: TRect);
@ -185,6 +217,34 @@ type
of ellipse to be drawn.} of ellipse to be drawn.}
procedure Ellipse(const Rect: TRect); 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 { Convolves canvas' image with given 3x3 filter kernel. You can use
predefined filter kernels or define your own.} predefined filter kernels or define your own.}
procedure ApplyConvolution3x3(const Filter: TConvolutionFilter3x3); procedure ApplyConvolution3x3(const Filter: TConvolutionFilter3x3);
@ -201,6 +261,36 @@ type
procedure ApplyConvolution(Kernel: PLongInt; KernelSize, Divisor: LongInt; procedure ApplyConvolution(Kernel: PLongInt; KernelSize, Divisor: LongInt;
Bias: Single = 0.0; ClampChannels: Boolean = True); virtual; 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.} { Color used when drawing lines, frames, and outlines of objects.}
property PenColor32: TColor32 read FPenColor32 write SetPenColor32; property PenColor32: TColor32 read FPenColor32 write SetPenColor32;
{ Color used when drawing lines, frames, and outlines of objects.} { Color used when drawing lines, frames, and outlines of objects.}
@ -384,6 +474,7 @@ const
(-1, -2, -1)); (-1, -2, -1));
Divisor: 4); Divisor: 4);
{ Kernel for 3x3 contour enhancement filter.}
FilterTraceControur3x3: TConvolutionFilter3x3 = ( FilterTraceControur3x3: TConvolutionFilter3x3 = (
Kernel: ((-6, -6, -2), Kernel: ((-6, -6, -2),
(-1, 32, -1), (-1, 32, -1),
@ -466,7 +557,173 @@ begin
Result := FindBestCanvasForImage(Image.Format); Result := FindBestCanvasForImage(Image.Format);
end; 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); constructor TImagingCanvas.CreateForData(ImageDataPointer: PImageData);
begin begin
@ -568,6 +825,17 @@ begin
IntersectRect(FClipRect, FClipRect, Rect(0, 0, FPData.Width, FPData.Height)); IntersectRect(FClipRect, FClipRect, Rect(0, 0, FPData.Width, FPData.Height));
end; 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; function TImagingCanvas.GetPixelPointer(X, Y: LongInt): Pointer;
begin begin
Result := @PByteArray(FPData.Bits)[(Y * FPData.Width + X) * FFormatInfo.BytesPerPixel] Result := @PByteArray(FPData.Bits)[(Y * FPData.Width + X) * FFormatInfo.BytesPerPixel]
@ -810,6 +1078,28 @@ begin
end; end;
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); procedure TImagingCanvas.Rectangle(const Rect: TRect);
begin begin
FillRect(Rect); FillRect(Rect);
@ -885,6 +1175,186 @@ begin
end; end;
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, procedure TImagingCanvas.ApplyConvolution(Kernel: PLongInt; KernelSize,
Divisor: LongInt; Bias: Single; ClampChannels: Boolean); Divisor: LongInt; Bias: Single; ClampChannels: Boolean);
var var
@ -917,11 +1387,11 @@ begin
for J := 0 to KernelSize - 1 do for J := 0 to KernelSize - 1 do
begin 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 for I := 0 to KernelSize - 1 do
begin 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]; SrcPointer := @PByteArray(TempImage.Bits)[PosY * WidthBytes + PosX * Bpp];
// Get pixels from neighbourhood of current pixel and add their // Get pixels from neighbourhood of current pixel and add their
@ -966,12 +1436,126 @@ begin
ApplyConvolution(@Filter.Kernel, 5, Filter.Divisor, Filter.Bias, True); ApplyConvolution(@Filter.Kernel, 5, Filter.Divisor, Filter.Bias, True);
end; 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; class function TImagingCanvas.GetSupportedFormats: TImageFormats;
begin begin
Result := [ifIndex8..Pred(ifDXT1)]; Result := [ifIndex8..Pred(ifDXT1)];
end; end;
{ TFastARGB32Canvas } { TFastARGB32Canvas }
destructor TFastARGB32Canvas.Destroy; destructor TFastARGB32Canvas.Destroy;
@ -1027,12 +1611,18 @@ finalization
File Notes: File Notes:
-- TODOS ---------------------------------------------------- -- TODOS ----------------------------------------------------
- more more more ... - more more more ...
- implement pen width everywhere - implement pen width everywhere
- add blending (image and object drawing) - add blending (*image and object drawing)
- add image drawing
- more objects (arc, polygon) - 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 ----------------------------------- -- 0.21 Changes/Bug Fixes -----------------------------------
- Added some new filter kernels for convolution. - 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 Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net http://imaginglib.sourceforge.net
@ -231,6 +231,8 @@ type
procedure ExchangeImages(Index1, Index2: LongInt); procedure ExchangeImages(Index1, Index2: LongInt);
{ Deletes image at the given position in the image array.} { Deletes image at the given position in the image array.}
procedure DeleteImage(Index: LongInt); 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.} { Converts all images to another image data format.}
procedure ConvertImages(Format: TImageFormat); procedure ConvertImages(Format: TImageFormat);
@ -886,6 +888,14 @@ begin
Imaging.ResizeImage(FDataArray[I], NewWidth, NewHeight, Filter); Imaging.ResizeImage(FDataArray[I], NewWidth, NewHeight, Filter);
end; 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); procedure TMultiImage.LoadFromFile(const FileName: string);
begin begin
if GetImageCount = 0 then if GetImageCount = 0 then
@ -931,6 +941,9 @@ end;
- put all low level stuff here like ReplaceColor etc, change - put all low level stuff here like ReplaceColor etc, change
CopyTo to Copy, and add overload Copy(SrcRect, DstX, DstY) ... 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 ----------------------------------- -- 0.23 Changes/Bug Fixes -----------------------------------
- Added SwapChannels method to TBaseImage. - Added SwapChannels method to TBaseImage.
- Added ReplaceColor 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 Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net http://imaginglib.sourceforge.net
@ -114,7 +114,8 @@ type
{ Returns file extensions of this graphic class.} { Returns file extensions of this graphic class.}
class function GetFileExtensions: string; override; class function GetFileExtensions: string; override;
{ Returns default MIME type of this graphic class.} { 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} {$ENDIF}
{ Default (the most common) file extension of this graphic class.} { Default (the most common) file extension of this graphic class.}
property DefaultFileExt: string read FDefaultFileExt; property DefaultFileExt: string read FDefaultFileExt;
@ -150,6 +151,7 @@ type
procedure SaveToStream(Stream: TStream); override; procedure SaveToStream(Stream: TStream); override;
class function GetFileFormat: TImageFileFormat; override; class function GetFileFormat: TImageFileFormat; override;
{$IFDEF COMPONENT_SET_LCL} {$IFDEF COMPONENT_SET_LCL}
//function GetMimeType: string; override; // uncomment for Laz 0.9.25 if you get error here
function GetDefaultMimeType: string; override; function GetDefaultMimeType: string; override;
{$ENDIF} {$ENDIF}
{ See ImagingJpegQuality option for details.} { See ImagingJpegQuality option for details.}
@ -231,6 +233,7 @@ type
procedure SaveToStream(Stream: TStream); override; procedure SaveToStream(Stream: TStream); override;
class function GetFileFormat: TImageFileFormat; override; class function GetFileFormat: TImageFileFormat; override;
{$IFDEF COMPONENT_SET_LCL} {$IFDEF COMPONENT_SET_LCL}
//function GetMimeType: string; override; // uncomment for Laz 0.9.25 if you get error here
function GetDefaultMimeType: string; override; function GetDefaultMimeType: string; override;
{$ENDIF} {$ENDIF}
{ See ImagingMNGLossyCompression option for details.} { See ImagingMNGLossyCompression option for details.}
@ -637,7 +640,6 @@ var
{$IFDEF COMPONENT_SET_LCL} {$IFDEF COMPONENT_SET_LCL}
RawImage: TRawImage; RawImage: TRawImage;
LineLazBytes: LongInt; LineLazBytes: LongInt;
rect: TRect;
{$ENDIF} {$ENDIF}
begin begin
{$IFDEF COMPONENT_SET_LCL} {$IFDEF COMPONENT_SET_LCL}
@ -725,9 +727,8 @@ begin
{$ENDIF} {$ENDIF}
{$IFDEF COMPONENT_SET_LCL} {$IFDEF COMPONENT_SET_LCL}
// Get raw image from bitmap (mask handle must be 0 or expect violations) // 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+ } if RawImage_FromBitmap(RawImage, Bitmap.Handle, 0, nil) then // uncommnet for Laz 0.9.25 if you get error here
rect := Classes.Rect(0, 0, Data.Width, Data.Height); //if RawImage_FromBitmap(RawImage, Bitmap.Handle, 0, Classes.Rect(0, 0, Data.Width, Data.Height)) then
if RawImage_FromBitmap(RawImage, Bitmap.Handle, 0, @rect) then
begin begin
LineLazBytes := GetBytesPerLine(Data.Width, RawImage.Description.BitsPerPixel, LineLazBytes := GetBytesPerLine(Data.Width, RawImage.Description.BitsPerPixel,
RawImage.Description.LineEnd); RawImage.Description.LineEnd);
@ -826,10 +827,15 @@ end;
var var
P: TPoint; P: TPoint;
begin 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 := TGtkDeviceContext(Dest).Offset;
//P := GetDCOffset(TDeviceContext(Dest));
Inc(DstX, P.X); Inc(DstX, P.X);
Inc(DstY, P.Y); Inc(DstY, P.Y);
gdk_draw_rgb_32_image(TGtkDeviceContext(Dest).Drawable, TGtkDeviceContext(Dest).GC, 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, DstX, DstY, SrcWidth, SrcHeight, GDK_RGB_DITHER_NONE,
@PLongWordArray(ImageData.Bits)[SrcY * ImageData.Width + SrcX], ImageData.Width * 4); @PLongWordArray(ImageData.Bits)[SrcY * ImageData.Width + SrcX], ImageData.Width * 4);
end; end;
@ -1014,7 +1020,8 @@ begin
Result := StringReplace(GetFileFormat.Extensions.CommaText, ',', ';', [rfReplaceAll]); Result := StringReplace(GetFileFormat.Extensions.CommaText, ',', ';', [rfReplaceAll]);
end; 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 begin
Result := 'image/' + FDefaultFileExt; Result := 'image/' + FDefaultFileExt;
end; end;
@ -1061,6 +1068,7 @@ begin
end; end;
{$IFDEF COMPONENT_SET_LCL} {$IFDEF COMPONENT_SET_LCL}
//function TImagingJpeg.GetMimeType: string; // uncomment for Laz 0.9.25 if you get error here
function TImagingJpeg.GetDefaultMimeType: string; function TImagingJpeg.GetDefaultMimeType: string;
begin begin
Result := 'image/jpeg'; Result := 'image/jpeg';
@ -1193,6 +1201,7 @@ begin
end; end;
{$IFDEF COMPONENT_SET_LCL} {$IFDEF COMPONENT_SET_LCL}
//function TImagingMNG.GetMimeType: string; // uncomment for Laz 0.9.25 if you get error here
function TImagingMNG.GetDefaultMimeType: string; function TImagingMNG.GetDefaultMimeType: string;
begin begin
Result := 'video/mng'; 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 Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net http://imaginglib.sourceforge.net
@ -102,7 +102,7 @@ const
DDSSupportedFormats: TImageFormats = [ifR8G8B8, ifA8R8G8B8, ifX8R8G8B8, DDSSupportedFormats: TImageFormats = [ifR8G8B8, ifA8R8G8B8, ifX8R8G8B8,
ifA1R5G5B5, ifA4R4G4B4, ifX1R5G5B5, ifX4R4G4B4, ifR5G6B5, ifA16B16G16R16, ifA1R5G5B5, ifA4R4G4B4, ifX1R5G5B5, ifX4R4G4B4, ifR5G6B5, ifA16B16G16R16,
ifR32F, ifA32B32G32R32F, ifR16F, ifA16B16G16R16F, ifR3G3B2, ifGray8, ifA8Gray8, ifR32F, ifA32B32G32R32F, ifR16F, ifA16B16G16R16F, ifR3G3B2, ifGray8, ifA8Gray8,
ifGray16, ifDXT1, ifDXT3, ifDXT5]; ifGray16, ifDXT1, ifDXT3, ifDXT5, ifATI1N, ifATI2N];
const const
{ Four character codes.} { Four character codes.}
@ -114,6 +114,10 @@ const
(Byte('3') shl 24)); (Byte('3') shl 24));
FOURCC_DXT5 = LongWord(Byte('D') or (Byte('X') shl 8) or (Byte('T') shl 16) or FOURCC_DXT5 = LongWord(Byte('D') or (Byte('X') shl 8) or (Byte('T') shl 16) or
(Byte('5') shl 24)); (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.} { Some D3DFORMAT values used in DDS files as FourCC value.}
D3DFMT_A16B16G16R16 = 36; D3DFMT_A16B16G16R16 = 36;
@ -350,6 +354,8 @@ begin
FOURCC_DXT1: SrcFormat := ifDXT1; FOURCC_DXT1: SrcFormat := ifDXT1;
FOURCC_DXT3: SrcFormat := ifDXT3; FOURCC_DXT3: SrcFormat := ifDXT3;
FOURCC_DXT5: SrcFormat := ifDXT5; FOURCC_DXT5: SrcFormat := ifDXT5;
FOURCC_ATI1: SrcFormat := ifATI1N;
FOURCC_ATI2: SrcFormat := ifATI2N;
end; end;
end end
else if (Flags and DDPF_RGB) = DDPF_RGB then else if (Flags and DDPF_RGB) = DDPF_RGB then
@ -663,6 +669,8 @@ begin
ifDXT1: Desc.PixelFormat.FourCC := FOURCC_DXT1; ifDXT1: Desc.PixelFormat.FourCC := FOURCC_DXT1;
ifDXT3: Desc.PixelFormat.FourCC := FOURCC_DXT3; ifDXT3: Desc.PixelFormat.FourCC := FOURCC_DXT3;
ifDXT5: Desc.PixelFormat.FourCC := FOURCC_DXT5; ifDXT5: Desc.PixelFormat.FourCC := FOURCC_DXT5;
ifATI1N: Desc.PixelFormat.FourCC := FOURCC_ATI1;
ifATI2N: Desc.PixelFormat.FourCC := FOURCC_ATI2;
end; end;
end end
else if FmtInfo.HasGrayChannel then else if FmtInfo.HasGrayChannel then
@ -815,6 +823,9 @@ initialization
-- TODOS ---------------------------------------------------- -- TODOS ----------------------------------------------------
- nothing now - nothing now
-- 0.25.0 Changes/Bug Fixes ---------------------------------
- Added support for 3Dc ATI1/2 formats.
-- 0.23 Changes/Bug Fixes ----------------------------------- -- 0.23 Changes/Bug Fixes -----------------------------------
- Saved DDS with mipmaps now correctly defineds COMPLEX flag. - Saved DDS with mipmaps now correctly defineds COMPLEX flag.
- Fixed loading of RGB DDS files that use pitch and have mipmaps - - 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 Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net http://imaginglib.sourceforge.net
@ -76,6 +76,15 @@ type
sfGaussian, sfSpline, sfLanczos, sfMitchell, sfCatmullRom); sfGaussian, sfSpline, sfLanczos, sfMitchell, sfCatmullRom);
{ Type of custom sampling function} { Type of custom sampling function}
TFilterFunction = function(Value: Single): Single; 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 { Stretches rectangle in source image to rectangle in destination image
with resampling. One of built-in resampling filters defined by with resampling. One of built-in resampling filters defined by
Filter is used. Set WrapEdges to True for seamlessly tileable images. 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); 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.} { 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} 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.} { Converts single-precision floating point color to half float color.}
function ColorFloatToHalf(ColorFP: TColorFPRec): TColorHFRec; {$IFDEF USE_INLINE}inline;{$ENDIF} 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 } { Pixel readers/writers for different image formats }
@ -171,7 +197,7 @@ procedure ChannelGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
var Pix: TColor64Rec); var Pix: TColor64Rec);
{ Sets pixel of image in any ARGB format. Channel values must be scaled to 16 bits.} { Sets pixel of image in any ARGB format. Channel values must be scaled to 16 bits.}
procedure ChannelSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo; 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 { Returns pixel of image in any grayscale format. Gray value is scaled to 64 bits
and alpha to 16 bits.} and alpha to 16 bits.}
@ -275,6 +301,22 @@ procedure IndexToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
DstInfo: PImageFormatInfo; SrcPal: PPalette32); 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 } { Special formats conversion functions }
{ Converts image to/from/between special image formats (dxtc, ...).} { 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.} { Inits all image format information. Called internally on startup.}
procedure InitImageFormats(var Infos: TImageFormatInfoArray); 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 implementation
{ TImageFormatInfo member functions } { TImageFormatInfo member functions }
@ -317,14 +367,6 @@ procedure SetPixelFPChannel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette:
function GetPixelFPFloat32(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec; forward; function GetPixelFPFloat32(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec; forward;
procedure SetPixelFPFloat32(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: 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 var
PFR3G3B2: TPixelFormatInfo; PFR3G3B2: TPixelFormatInfo;
PFX5R1G1B1: TPixelFormatInfo; PFX5R1G1B1: TPixelFormatInfo;
@ -759,6 +801,26 @@ var
CheckDimensions: CheckDXTDimensions; CheckDimensions: CheckDXTDimensions;
SpecialNearestFormat: ifGray8); 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} {$WARNINGS ON}
function PixelFormat(ABitCount, RBitCount, GBitCount, BBitCount: Byte): TPixelFormatInfo; forward; function PixelFormat(ABitCount, RBitCount, GBitCount, BBitCount: Byte): TPixelFormatInfo; forward;
@ -804,6 +866,8 @@ begin
Infos[ifDXT3] := @DXT3Info; Infos[ifDXT3] := @DXT3Info;
Infos[ifDXT5] := @DXT5Info; Infos[ifDXT5] := @DXT5Info;
Infos[ifBTC] := @BTCInfo; Infos[ifBTC] := @BTCInfo;
Infos[ifATI1N] := @ATI1NInfo;
Infos[ifATI2N] := @ATI2NInfo;
PFR3G3B2 := PixelFormat(0, 3, 3, 2); PFR3G3B2 := PixelFormat(0, 3, 3, 2);
PFX5R1G1B1 := PixelFormat(0, 1, 1, 1); PFX5R1G1B1 := PixelFormat(0, 1, 1, 1);
@ -906,6 +970,57 @@ begin
end; end;
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) } { Additional image manipulation functions (usually used internally by Imaging unit) }
const const
@ -1184,13 +1299,18 @@ procedure ReduceColorsMedianCut(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
begin begin
FillChar(DstPal^, SizeOf(TColor32Rec) * MaxColors, $FF); FillChar(DstPal^, SizeOf(TColor32Rec) * MaxColors, $FF);
for I := 0 to MaxColors - 1 do for I := 0 to MaxColors - 1 do
begin
if I < Boxes then
with Box[I].Represented do with Box[I].Represented do
begin begin
DstPal[I].A := A; DstPal[I].A := A;
DstPal[I].R := R; DstPal[I].R := R;
DstPal[I].G := G; DstPal[I].G := G;
DstPal[I].B := B; DstPal[I].B := B;
end; end
else
DstPal[I].Color := $FF000000;
end;
end; end;
function MapColor(const Col: TColor32Rec) : LongInt; function MapColor(const Col: TColor32Rec) : LongInt;
@ -1439,37 +1559,21 @@ begin
Result := 0.0; Result := 0.0;
end; 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, procedure StretchResample(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth, SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
DstHeight: LongInt; Filter: TSamplingFilter; WrapEdges: Boolean); DstHeight: LongInt; Filter: TSamplingFilter; WrapEdges: Boolean);
begin begin
// Calls the other function with filter function and radius defined by Filter // Calls the other function with filter function and radius defined by Filter
StretchResample(SrcImage, SrcX, SrcY, SrcWidth, SrcHeight, DstImage, DstX, DstY, StretchResample(SrcImage, SrcX, SrcY, SrcWidth, SrcHeight, DstImage, DstX, DstY,
DstWidth, DstHeight, FilterFunctions[Filter], FilterRadii[Filter]); DstWidth, DstHeight, SamplingFilterFunctions[Filter], SamplingFilterRadii[Filter],
WrapEdges);
end; 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 var
FullEdge: Boolean = True; 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; function BuildMappingTable(DstLow, DstHigh, SrcLow, SrcHigh, SrcImageWidth: LongInt;
Filter: TFilterFunction; Radius: Single; WrapEdges: Boolean): TMappingTable; Filter: TFilterFunction; Radius: Single; WrapEdges: Boolean): TMappingTable;
var var
@ -1595,6 +1699,25 @@ begin
end; end;
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, procedure StretchResample(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth, SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
DstHeight: LongInt; Filter: TFilterFunction; Radius: Single; WrapEdges: Boolean); DstHeight: LongInt; Filter: TFilterFunction; Radius: Single; WrapEdges: Boolean);
@ -1614,26 +1737,6 @@ var
BytesPerChannel: LongInt; BytesPerChannel: LongInt;
ChannelValueMax, InvChannelValueMax: Single; ChannelValueMax, InvChannelValueMax: Single;
UseOptimizedVersion: Boolean; 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 begin
GetImageFormatInfo(SrcImage.Format, Info); GetImageFormatInfo(SrcImage.Format, Info);
Assert(SrcImage.Format = DstImage.Format); Assert(SrcImage.Format = DstImage.Format);
@ -2237,6 +2340,21 @@ begin
Result.B := FloatToHalf(ColorFP.B); Result.B := FloatToHalf(ColorFP.B);
end; 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 } { Pixel readers/writers for different image formats }
@ -3234,6 +3352,31 @@ begin
end; end;
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); procedure DecodeDXT5(SrcBits, DestBits: PByte; Width, Height: LongInt);
var var
Sel, X, Y, I, J, K: LongInt; Sel, X, Y, I, J, K: LongInt;
@ -3264,27 +3407,7 @@ begin
AMask[0] := PLongWord(@AlphaBlock.Alphas[2])^ and $00FFFFFF; AMask[0] := PLongWord(@AlphaBlock.Alphas[2])^ and $00FFFFFF;
AMask[1] := PLongWord(@AlphaBlock.Alphas[5])^ and $00FFFFFF; AMask[1] := PLongWord(@AlphaBlock.Alphas[5])^ and $00FFFFFF;
// alpha interpolation between two endpoint alphas // alpha interpolation between two endpoint alphas
with AlphaBlock do GetInterpolatedAlphas(AlphaBlock);
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;
// we distribute the dxt block colors and alphas // we distribute the dxt block colors and alphas
// across the 4x4 block of the destination image // across the 4x4 block of the destination image
@ -3307,7 +3430,7 @@ begin
end; end;
procedure GetBlock(var Block: TPixelBlock; SrcBits: Pointer; XPos, YPos, procedure GetBlock(var Block: TPixelBlock; SrcBits: Pointer; XPos, YPos,
Width, Height: LongInt); Width, Height: LongInt);
var var
X, Y, I: LongInt; X, Y, I: LongInt;
Src: PColor32Rec; Src: PColor32Rec;
@ -3637,7 +3760,71 @@ begin
end; end;
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 var
X, Y, I, J, K: Integer; X, Y, I, J, K: Integer;
Block: TBTCBlock; Block: TBTCBlock;
@ -3665,25 +3852,101 @@ begin
end; end;
end; end;
procedure SpecialToUnSpecial(const SrcImage: TImageData; DestBits: Pointer; procedure DecodeATI1N(SrcBits, DestBits: PByte; Width, Height: Integer);
SrcInfo, DstInfo: PImageFormatInfo); var
X, Y, I, J: Integer;
AlphaBlock: TDXTAlphaBlockInt;
AMask: array[0..1] of LongWord;
begin 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); ifDXT1: DecodeDXT1(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
ifDXT3: DecodeDXT3(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); ifDXT5: DecodeDXT5(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
ifBTC: DecodeBTC (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;
end; end;
procedure UnSpecialToSpecial(const DestImage: TImageData; SrcBits: Pointer; procedure UnSpecialToSpecial(SrcBits: Pointer; const DestImage: TImageData;
SrcInfo, DstInfo: PImageFormatInfo); SpecialFormat: TImageFormat);
begin begin
case DstInfo.Format of case SpecialFormat of
ifDXT1: EncodeDXT1(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height); ifDXT1: EncodeDXT1(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
ifDXT3: EncodeDXT3(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); ifDXT5: EncodeDXT5(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
ifBTC: EncodeBTC (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;
end; end;
@ -3691,35 +3954,58 @@ procedure ConvertSpecial(var Image: TImageData;
SrcInfo, DstInfo: PImageFormatInfo); SrcInfo, DstInfo: PImageFormatInfo);
var var
WorkImage: TImageData; WorkImage: TImageData;
Width, Height: LongInt;
begin procedure CheckSize(var Img: TImageData; Info: PImageFormatInfo);
// first convert image to default non-special format var
if SrcInfo.IsSpecial then Width, Height: Integer;
begin 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); InitImage(WorkImage);
NewImage(Image.Width, Image.Height, SrcInfo.SpecialNearestFormat, WorkImage); NewImage(Image.Width, Image.Height, SrcInfo.SpecialNearestFormat, WorkImage);
SpecialToUnSpecial(Image, WorkImage.Bits, SrcInfo, DstInfo); SpecialToUnSpecial(Image, WorkImage.Bits, SrcInfo.Format);
FreeImage(Image); 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 end
else else if SrcInfo.IsSpecial and not DstInfo.IsSpecial then
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
begin begin
Width := Image.Width; // Convert source to nearest 'normal' format
Height := Image.Height;
DstInfo.CheckDimensions(DstInfo.Format, Width, Height);
InitImage(WorkImage); InitImage(WorkImage);
NewImage(Width, Height, DstInfo.Format, WorkImage); NewImage(Image.Width, Image.Height, SrcInfo.SpecialNearestFormat, WorkImage);
ResizeImage(Image, Width, Height, rfNearest); SpecialToUnSpecial(Image, WorkImage.Bits, SrcInfo.Format);
UnSpecialToSpecial(WorkImage, Image.Bits, SrcInfo, DstInfo);
FreeImage(Image); FreeImage(Image);
// Now convert to dest format
ConvertImage(WorkImage, DstInfo.Format);
Image := WorkImage; Image := WorkImage;
end end
else else if not SrcInfo.IsSpecial and DstInfo.IsSpecial then
ConvertImage(Image, DstInfo.Format); 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; end;
function GetStdPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; function GetStdPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt;
@ -3740,7 +4026,7 @@ begin
// multiples of four // multiples of four
CheckDXTDimensions(Format, Width, Height); CheckDXTDimensions(Format, Width, Height);
Result := Width * Height; Result := Width * Height;
if Format = ifDXT1 then if Format in [ifDXT1, ifATI1N] then
Result := Result div 2; Result := Result div 2;
end; end;
@ -3908,6 +4194,29 @@ begin
end; end;
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: File Notes:
@ -3915,6 +4224,17 @@ end;
- nothing now - nothing now
- rewrite StretchRect for 8bit channels to use integer math? - 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 ----------------------------------- -- 0.23 Changes/Bug Fixes -----------------------------------
- Added ifBTC image format support structures and functions. - 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 Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net http://imaginglib.sourceforge.net
@ -34,7 +34,7 @@ unit ImagingGif;
interface interface
uses uses
SysUtils, Classes, Imaging, ImagingTypes, ImagingUtility; SysUtils, Classes, Imaging, ImagingTypes, ImagingIO, ImagingUtility;
type type
{ GIF (Graphics Interchange Format) loader/saver class. GIF was { GIF (Graphics Interchange Format) loader/saver class. GIF was
@ -48,7 +48,7 @@ type
TGIFFileFormat = class(TImageFileFormat) TGIFFileFormat = class(TImageFileFormat)
private private
function InterlaceStep(Y, Height: Integer; var Pass: Integer): Integer; 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); Width, Height: Integer; Interlaced: Boolean; Data: Pointer);
procedure LZWCompress(const IO: TIOFunctions; Handle: TImagingHandle; procedure LZWCompress(const IO: TIOFunctions; Handle: TImagingHandle;
Width, Height, BitCount: Integer; Interlaced: Boolean; Data: Pointer); Width, Height, BitCount: Integer; Interlaced: Boolean; Data: Pointer);
@ -246,7 +246,7 @@ begin
end; end;
{ GIF LZW decompresion code is from JVCL JvGIF.pas unit.} { 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); Interlaced: Boolean; Data: Pointer);
var var
MinCodeSize: Byte; MinCodeSize: Byte;
@ -266,7 +266,8 @@ var
Bytes: Byte; Bytes: Byte;
BytesToLose: Integer; BytesToLose: Integer;
begin begin
while Context.Inx + Context.CodeSize > Context.Size do while (Context.Inx + Context.CodeSize > Context.Size) and
(Stream.Position < Stream.Size) do
begin begin
// Not enough bits in buffer - refill it - Not very efficient, but infrequently called // Not enough bits in buffer - refill it - Not very efficient, but infrequently called
BytesToLose := Context.Inx shr 3; BytesToLose := Context.Inx shr 3;
@ -274,16 +275,16 @@ var
Move(Context.Buf[Word(BytesToLose)], Context.Buf[0], 3); Move(Context.Buf[Word(BytesToLose)], Context.Buf[0], 3);
Context.Inx := Context.Inx and 7; Context.Inx := Context.Inx and 7;
Context.Size := Context.Size - (BytesToLose shl 3); Context.Size := Context.Size - (BytesToLose shl 3);
IO.Read(Handle, @Bytes, 1); Stream.Read(Bytes, 1);
if Bytes > 0 then 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); Context.Size := Context.Size + (Bytes shl 3);
end; end;
ByteIndex := Context.Inx shr 3; ByteIndex := Context.Inx shr 3;
RawCode := Context.Buf[Word(ByteIndex)] + RawCode := Context.Buf[Word(ByteIndex)] +
(Word(Context.Buf[Word(ByteIndex + 1)]) shl 8); (Word(Context.Buf[Word(ByteIndex + 1)]) shl 8);
if Context.CodeSize > 8 then 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); RawCode := RawCode shr (Context.Inx and 7);
Context.Inx := Context.Inx + Byte(Context.CodeSize); Context.Inx := Context.Inx + Byte(Context.CodeSize);
Result := RawCode and Context.ReadMask; Result := RawCode and Context.ReadMask;
@ -345,7 +346,7 @@ begin
GetMem(Suffix, SizeOf(TIntCodeTable)); GetMem(Suffix, SizeOf(TIntCodeTable));
GetMem(OutCode, SizeOf(TIntCodeTable) + SizeOf(Word)); GetMem(OutCode, SizeOf(TIntCodeTable) + SizeOf(Word));
try try
IO.Read(Handle, @MinCodeSize, 1); Stream.Read(MinCodeSize, 1);
if (MinCodeSize < 2) or (MinCodeSize > 9) then if (MinCodeSize < 2) or (MinCodeSize > 9) then
RaiseImaging(SGIFDecodingError, []); RaiseImaging(SGIFDecodingError, []);
// Initial read context // Initial read context
@ -690,20 +691,26 @@ var
end; end;
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 var
X, Y: Integer; X, Y: Integer;
Src, Dst: PByte; Src, Dst: PByte;
begin begin
Src := Frame.Bits; 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 for Y := 0 to Frame.Height - 1 do
begin begin
Dst := @PByteArray(Image.Bits)[(Top + Y) * Image.Width + Left]; Dst := @PByteArray(Image.Bits)[(Top + Y) * Image.Width + Left];
for X := 0 to Frame.Width - 1 do for X := 0 to Frame.Width - 1 do
begin 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^; Dst^ := Src^;
Inc(Src); Inc(Src);
Inc(Dst); Inc(Dst);
@ -711,6 +718,28 @@ var
end; end;
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; procedure ReadFrame;
var var
ImageDesc: TImageDescriptor; ImageDesc: TImageDescriptor;
@ -719,6 +748,7 @@ var
LocalPal: TPalette32Size256; LocalPal: TPalette32Size256;
BlockTerm: Byte; BlockTerm: Byte;
Frame: TImageData; Frame: TImageData;
LZWStream: TMemoryStream;
begin begin
Idx := Length(Images); Idx := Length(Images);
SetLength(Images, Idx + 1); SetLength(Images, Idx + 1);
@ -806,15 +836,20 @@ var
@Header.BackgroundColorIndex); @Header.BackgroundColorIndex);
end; end;
LZWStream := TMemoryStream.Create;
try try
// Copy LZW data to temp stream, needed for correct decompression
CopyLZWData(LZWStream);
LZWStream.Position := 0;
// Data decompression finally // Data decompression finally
LZWDecompress(GetIO, Handle, ImageDesc.Width, ImageDesc.Height, Interlaced, Frame.Bits); LZWDecompress(LZWStream, Handle, ImageDesc.Width, ImageDesc.Height, Interlaced, Frame.Bits);
Read(Handle, @BlockTerm, SizeOf(BlockTerm));
// Now copy frame to logical screen with skipping of transparent pixels (if enabled) // Now copy frame to logical screen with skipping of transparent pixels (if enabled)
TransIndex := Iff(HasTransparency, GraphicExt.TransparentColorIndex, MaxInt); 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 finally
FreeImage(Frame); FreeImage(Frame);
LZWStream.Free;
end; end;
end; end;
end; end;
@ -840,7 +875,6 @@ begin
Read(Handle, @GlobalPal[I].G, SizeOf(GlobalPal[I].G)); Read(Handle, @GlobalPal[I].G, SizeOf(GlobalPal[I].G));
Read(Handle, @GlobalPal[I].B, SizeOf(GlobalPal[I].B)); Read(Handle, @GlobalPal[I].B, SizeOf(GlobalPal[I].B));
end; end;
GlobalPal[Header.BackgroundColorIndex].A := 0;
end; end;
// Read ID of the first block // Read ID of the first block
@ -973,6 +1007,14 @@ initialization
-- TODOS ---------------------------------------------------- -- TODOS ----------------------------------------------------
- nothing now - 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 --------------------------------- -- 0.24.1 Changes/Bug Fixes ---------------------------------
- Made backround color transparent by default (alpha = 0). - 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 Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net http://imaginglib.sourceforge.net
@ -46,7 +46,7 @@ unit ImagingJpeg;
{ Automatically use FPC's PasJpeg when compiling with Lazarus.} { Automatically use FPC's PasJpeg when compiling with Lazarus.}
{$IFDEF LCL} {$IFDEF LCL}
{ $UNDEF IMJPEGLIB} {$UNDEF IMJPEGLIB}
{$DEFINE PASJPEG} {$DEFINE PASJPEG}
{$ENDIF} {$ENDIF}
@ -65,7 +65,7 @@ uses
{$IF Defined(FPC) and Defined(PASJPEG)} {$IF Defined(FPC) and Defined(PASJPEG)}
{ When using FPC's pasjpeg in FPC the channel order is BGR instead of RGB} { When using FPC's pasjpeg in FPC the channel order is BGR instead of RGB}
{ $DEFINE RGBSWAPPED} // not needed now apparently {$DEFINE RGBSWAPPED}
{$IFEND} {$IFEND}
type type
@ -375,10 +375,8 @@ var
Dest: PByte; Dest: PByte;
jc: TJpegContext; jc: TJpegContext;
Info: TImageFormatInfo; Info: TImageFormatInfo;
Format: TImageFormat;
Col32: PColor32Rec; Col32: PColor32Rec;
{$IFDEF RGBSWAPPED} {$IFDEF RGBSWAPPED}
I: LongInt;
Pix: PColor24Rec; Pix: PColor24Rec;
{$ENDIF} {$ENDIF}
begin begin
@ -556,6 +554,9 @@ initialization
-- TODOS ---------------------------------------------------- -- TODOS ----------------------------------------------------
- nothing now - 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 --------------------------------- -- 0.24.1 Changes/Bug Fixes ---------------------------------
- Fixed loading of CMYK jpeg images. Could cause heap corruption - Fixed loading of CMYK jpeg images. Could cause heap corruption
and loaded image looked wrong. 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 Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net http://imaginglib.sourceforge.net
@ -299,6 +299,7 @@ type
GlobalPaletteEntries: LongInt; GlobalPaletteEntries: LongInt;
GlobalTransparency: Pointer; GlobalTransparency: Pointer;
GlobalTransparencySize: LongInt; GlobalTransparencySize: LongInt;
destructor Destroy; override;
procedure Clear; procedure Clear;
function GetLastFrame: TFrameInfo; function GetLastFrame: TFrameInfo;
function AddFrameInfo: TFrameInfo; function AddFrameInfo: TFrameInfo;
@ -340,10 +341,6 @@ type
end; end;
{$ENDIF} {$ENDIF}
var
NGFileLoader: TNGFileLoader = nil;
NGFileSaver: TNGFileSaver = nil;
{ Helper routines } { Helper routines }
function PaethPredictor(A, B, C: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} function PaethPredictor(A, B, C: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
@ -455,6 +452,12 @@ end;
{ TNGFileHandler class implementation} { TNGFileHandler class implementation}
destructor TNGFileHandler.Destroy;
begin
Clear;
inherited Destroy;
end;
procedure TNGFileHandler.Clear; procedure TNGFileHandler.Clear;
var var
I: LongInt; I: LongInt;
@ -1865,8 +1868,11 @@ end;
function TPNGFileFormat.LoadData(Handle: TImagingHandle; function TPNGFileFormat.LoadData(Handle: TImagingHandle;
var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
var
NGFileLoader: TNGFileLoader;
begin begin
Result := False; Result := False;
NGFileLoader := TNGFileLoader.Create;
try try
// Use NG file parser to load file // Use NG file parser to load file
if NGFileLoader.LoadFile(Handle) and (Length(NGFileLoader.Frames) > 0) then if NGFileLoader.LoadFile(Handle) and (Length(NGFileLoader.Frames) > 0) then
@ -1881,7 +1887,7 @@ begin
Result := True; Result := True;
end; end;
finally finally
NGFileLoader.Clear; NGFileLoader.Free;
end; end;
end; end;
@ -1890,21 +1896,25 @@ function TPNGFileFormat.SaveData(Handle: TImagingHandle;
var var
ImageToSave: TImageData; ImageToSave: TImageData;
MustBeFreed: Boolean; MustBeFreed: Boolean;
NGFileSaver: TNGFileSaver;
begin begin
// Make image PNG compatible, store it in saver, and save it to file // Make image PNG compatible, store it in saver, and save it to file
Result := MakeCompatible(Images[Index], ImageToSave, MustBeFreed); Result := MakeCompatible(Images[Index], ImageToSave, MustBeFreed);
if Result then if Result then
with NGFileSaver do begin
try NGFileSaver := TNGFileSaver.Create;
FileType := ngPNG; with NGFileSaver do
SetFileOptions(Self); try
AddFrame(ImageToSave, False); FileType := ngPNG;
SaveFile(Handle); SetFileOptions(Self);
finally AddFrame(ImageToSave, False);
// Clear NG saver and compatible image SaveFile(Handle);
Clear; finally
if MustBeFreed then // Free NG saver and compatible image
FreeImage(ImageToSave); NGFileSaver.Free;
if MustBeFreed then
FreeImage(ImageToSave);
end;
end; end;
end; end;
@ -1932,9 +1942,11 @@ end;
function TMNGFileFormat.LoadData(Handle: TImagingHandle; function TMNGFileFormat.LoadData(Handle: TImagingHandle;
var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
var var
NGFileLoader: TNGFileLoader;
I, Len: LongInt; I, Len: LongInt;
begin begin
Result := False; Result := False;
NGFileLoader := TNGFileLoader.Create;
try try
// Use NG file parser to load file // Use NG file parser to load file
if NGFileLoader.LoadFile(Handle) then if NGFileLoader.LoadFile(Handle) then
@ -1965,13 +1977,14 @@ begin
Result := True; Result := True;
end; end;
finally finally
NGFileLoader.Clear; NGFileLoader.Free;
end; end;
end; end;
function TMNGFileFormat.SaveData(Handle: TImagingHandle; function TMNGFileFormat.SaveData(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: LongInt): Boolean; const Images: TDynImageDataArray; Index: LongInt): Boolean;
var var
NGFileSaver: TNGFileSaver;
I, LargestWidth, LargestHeight: LongInt; I, LargestWidth, LargestHeight: LongInt;
ImageToSave: TImageData; ImageToSave: TImageData;
MustBeFreed: Boolean; MustBeFreed: Boolean;
@ -1980,6 +1993,7 @@ begin
LargestWidth := 0; LargestWidth := 0;
LargestHeight := 0; LargestHeight := 0;
NGFileSaver := TNGFileSaver.Create;
NGFileSaver.FileType := ngMNG; NGFileSaver.FileType := ngMNG;
NGFileSaver.SetFileOptions(Self); NGFileSaver.SetFileOptions(Self);
@ -2016,7 +2030,7 @@ begin
SaveFile(Handle); SaveFile(Handle);
Result := True; Result := True;
finally finally
Clear; NGFileSaver.Free;
end; end;
end; end;
@ -2044,8 +2058,11 @@ end;
function TJNGFileFormat.LoadData(Handle: TImagingHandle; function TJNGFileFormat.LoadData(Handle: TImagingHandle;
var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
var
NGFileLoader: TNGFileLoader;
begin begin
Result := False; Result := False;
NGFileLoader := TNGFileLoader.Create;
try try
// Use NG file parser to load file // Use NG file parser to load file
if NGFileLoader.LoadFile(Handle) and (Length(NGFileLoader.Frames) > 0) then if NGFileLoader.LoadFile(Handle) and (Length(NGFileLoader.Frames) > 0) then
@ -2060,48 +2077,48 @@ begin
Result := True; Result := True;
end; end;
finally finally
NGFileLoader.Clear; NGFileLoader.Free;
end; end;
end; end;
function TJNGFileFormat.SaveData(Handle: TImagingHandle; function TJNGFileFormat.SaveData(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: LongInt): Boolean; const Images: TDynImageDataArray; Index: LongInt): Boolean;
var var
NGFileSaver: TNGFileSaver;
ImageToSave: TImageData; ImageToSave: TImageData;
MustBeFreed: Boolean; MustBeFreed: Boolean;
begin begin
// Make image JNG compatible, store it in saver, and save it to file // Make image JNG compatible, store it in saver, and save it to file
Result := MakeCompatible(Images[Index], ImageToSave, MustBeFreed); Result := MakeCompatible(Images[Index], ImageToSave, MustBeFreed);
if Result then if Result then
with NGFileSaver do begin
try NGFileSaver := TNGFileSaver.Create;
FileType := ngJNG; with NGFileSaver do
SetFileOptions(Self); try
AddFrame(ImageToSave, True); FileType := ngJNG;
SaveFile(Handle); SetFileOptions(Self);
finally AddFrame(ImageToSave, True);
// Clear NG saver and compatible image SaveFile(Handle);
Clear; finally
if MustBeFreed then // Free NG saver and compatible image
FreeImage(ImageToSave); NGFileSaver.Free;
if MustBeFreed then
FreeImage(ImageToSave);
end;
end; end;
end; end;
{$ENDIF} {$ENDIF}
initialization initialization
NGFileLoader := TNGFileLoader.Create;
NGFileSaver := TNGFileSaver.Create;
RegisterImageFileFormat(TPNGFileFormat); RegisterImageFileFormat(TPNGFileFormat);
{$IFDEF LINK_MNG} {$IFDEF LINK_MNG}
RegisterImageFileFormat(TMNGFileFormat); RegisterImageFileFormat(TMNGFileFormat);
{$ENDIF} {$ENDIF}
{$IFDEF LINK_JNG} {$IFDEF LINK_JNG}
RegisterImageFileFormat(TJNGFileFormat); RegisterImageFileFormat(TJNGFileFormat);
{$ENDIF} {$ENDIF}
finalization finalization
FreeAndNil(NGFileLoader);
FreeAndNil(NGFileSaver);
{ {
File Notes: File Notes:
@ -2109,6 +2126,9 @@ finalization
-- TODOS ---------------------------------------------------- -- TODOS ----------------------------------------------------
- nothing now - nothing now
-- 0.24.3 Changes/Bug Fixes ---------------------------------
- Changes for better thread safety.
-- 0.23 Changes/Bug Fixes ----------------------------------- -- 0.23 Changes/Bug Fixes -----------------------------------
- Added loading of global palettes and transparencies in MNG files - Added loading of global palettes and transparencies in MNG files
(and by doing so fixed crash when loading images with global PLTE or tRNS). (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 Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net http://imaginglib.sourceforge.net
@ -33,7 +33,7 @@ unit ImagingOpenGL;
{$I ImagingOptions.inc} {$I ImagingOptions.inc}
{ Define this symbol if you want to use dglOpenGL header.} { Define this symbol if you want to use dglOpenGL header.}
{ $DEFINE USE_DGL_HEADERS} {.$DEFINE USE_DGL_HEADERS}
interface interface
@ -49,12 +49,17 @@ uses
type type
{ Various texture capabilities of installed OpenGL driver.} { Various texture capabilities of installed OpenGL driver.}
TGLTextureCaps = record TGLTextureCaps = record
MaxTextureSize: LongInt; MaxTextureSize: LongInt; // Max size of texture in pixels supported by HW
PowerOfTwo: Boolean; NonPowerOfTwo: Boolean; // HW has full support for NPOT textures
DXTCompression: Boolean; DXTCompression: Boolean; // HW supports S3TC/DXTC compressed textures
FloatTextures: Boolean; ATI3DcCompression: Boolean; // HW supports ATI 3Dc compressed textures (ATI2N)
MaxAnisotropy: LongInt; LATCCompression: Boolean; // HW supports LATC/RGTC compressed textures (ATI1N+ATI2N)
MaxSimultaneousTextures: LongInt; 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; end;
{ Returns texture capabilities of installed OpenGL driver.} { 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 supported by hardware using GetGLTextureCaps, ImageFormatToGL does not
check this.} check this.}
function ImageFormatToGL(Format: TImageFormat; var GLFormat: GLenum; 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 - { All GL textures created by Imaging functions have default parameters set -
that means that no glTexParameter calls are made so default filtering, 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 image->texture process (usually only pow2/nonpow2 stuff and when you
set custom Width & Height in CreateGLTextureFrom(Multi)Image).} set custom Width & Height in CreateGLTextureFrom(Multi)Image).}
PasteNonPow2ImagesIntoPow2: Boolean = False; 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 implementation
@ -239,6 +252,11 @@ const
GL_COMPRESSED_RGBA_S3TC_DXT1_EXT = $83F1; GL_COMPRESSED_RGBA_S3TC_DXT1_EXT = $83F1;
GL_COMPRESSED_RGBA_S3TC_DXT3_EXT = $83F2; GL_COMPRESSED_RGBA_S3TC_DXT3_EXT = $83F2;
GL_COMPRESSED_RGBA_S3TC_DXT5_EXT = $83F3; 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 // various GL extension constants
GL_MAX_TEXTURE_UNITS = $84E2; GL_MAX_TEXTURE_UNITS = $84E2;
@ -311,36 +329,49 @@ end;
function GetGLTextureCaps(var Caps: TGLTextureCaps): Boolean; function GetGLTextureCaps(var Caps: TGLTextureCaps): Boolean;
begin 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 Caps.DXTCompression := IsGLExtensionSupported('GL_ARB_texture_compression') and
IsGLExtensionSupported('GL_EXT_texture_compression_s3tc'); IsGLExtensionSupported('GL_EXT_texture_compression_s3tc');
if Caps.DXTCompression then if Caps.DXTCompression then
glCompressedTexImage2D := GetGLProcAddress('glCompressedTexImage2D'); glCompressedTexImage2D := GetGLProcAddress('glCompressedTexImage2D');
Caps.DXTCompression := Caps.DXTCompression and (@glCompressedTexImage2D <> nil); Caps.DXTCompression := Caps.DXTCompression and (@glCompressedTexImage2D <> nil);
// check non power of 2 textures Caps.ATI3DcCompression := Caps.DXTCompression and
Caps.PowerOfTwo := not IsGLExtensionSupported('GL_ARB_texture_non_power_of_two'); IsGLExtensionSupported('GL_ATI_texture_compression_3dc');
// check for floating point textures support 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'); Caps.FloatTextures := IsGLExtensionSupported('GL_ARB_texture_float');
// get max texture size // Get max texture size
glGetIntegerv(GL_MAX_TEXTURE_SIZE, @Caps.MaxTextureSize); glGetIntegerv(GL_MAX_TEXTURE_SIZE, @Caps.MaxTextureSize);
// get max anisotropy // Get max anisotropy
if IsGLExtensionSupported('GL_EXT_texture_filter_anisotropic') then if IsGLExtensionSupported('GL_EXT_texture_filter_anisotropic') then
glGetIntegerv(GL_MAX_TEXTURE_MAX_ANISOTROPY_EXT, @Caps.MaxAnisotropy) glGetIntegerv(GL_MAX_TEXTURE_MAX_ANISOTROPY_EXT, @Caps.MaxAnisotropy)
else else
Caps.MaxAnisotropy := 0; Caps.MaxAnisotropy := 0;
// get number of texture units // Get number of texture units
if IsGLExtensionSupported('GL_ARB_multitexture') then if IsGLExtensionSupported('GL_ARB_multitexture') then
glGetIntegerv(GL_MAX_TEXTURE_UNITS, @Caps.MaxSimultaneousTextures) glGetIntegerv(GL_MAX_TEXTURE_UNITS, @Caps.MaxSimultaneousTextures)
else else
Caps.MaxSimultaneousTextures := 1; 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); 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; Result := True;
end; end;
function ImageFormatToGL(Format: TImageFormat; var GLFormat: GLenum; 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 begin
GLFormat := 0; GLFormat := 0;
GLType := 0; GLType := 0;
@ -437,6 +468,13 @@ begin
ifDXT1: GLInternal := GL_COMPRESSED_RGBA_S3TC_DXT1_EXT; ifDXT1: GLInternal := GL_COMPRESSED_RGBA_S3TC_DXT1_EXT;
ifDXT3: GLInternal := GL_COMPRESSED_RGBA_S3TC_DXT3_EXT; ifDXT3: GLInternal := GL_COMPRESSED_RGBA_S3TC_DXT3_EXT;
ifDXT5: GLInternal := GL_COMPRESSED_RGBA_S3TC_DXT5_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; end;
Result := GLInternal <> 0; Result := GLInternal <> 0;
end; end;
@ -500,7 +538,7 @@ function CreateGLTextureFromMultiImage(const Images: TDynImageDataArray;
Width, Height: LongInt; MipMaps: Boolean; MainLevelIndex: LongInt; OverrideFormat: TImageFormat; Width, Height: LongInt; MipMaps: Boolean; MainLevelIndex: LongInt; OverrideFormat: TImageFormat;
CreatedWidth, CreatedHeight: PLongInt): GLuint; CreatedWidth, CreatedHeight: PLongInt): GLuint;
const const
CompressedFormats: TImageFormats = [ifDXT1, ifDXT3, ifDXT5]; BlockCompressedFormats: TImageFormats = [ifDXT1, ifDXT3, ifDXT5, ifATI1N, ifATI2N];
var var
I, MipLevels, PossibleLevels, ExistingLevels, CurrentWidth, CurrentHeight: LongInt; I, MipLevels, PossibleLevels, ExistingLevels, CurrentWidth, CurrentHeight: LongInt;
Caps: TGLTextureCaps; Caps: TGLTextureCaps;
@ -537,7 +575,7 @@ begin
// First check desired size and modify it if necessary // First check desired size and modify it if necessary
if Width <= 0 then Width := Images[MainLevelIndex].Width; if Width <= 0 then Width := Images[MainLevelIndex].Width;
if Height <= 0 then Height := Images[MainLevelIndex].Height; if Height <= 0 then Height := Images[MainLevelIndex].Height;
if Caps.PowerOfTwo then if not Caps.NonPowerOfTwo and not DisableNPOTSupportCheck then
begin begin
// If device supports only power of 2 texture sizes // If device supports only power of 2 texture sizes
Width := NextPow2(Width); Width := NextPow2(Width);
@ -564,23 +602,27 @@ begin
else else
Desired := OverrideFormat; 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); GetImageFormatInfo(Desired, Info);
if Info.IsFloatingPoint and not Caps.FloatTextures then if Info.IsFloatingPoint and not Caps.FloatTextures then
Desired := ifA8R8G8B8; Desired := ifA8R8G8B8;
if (Desired in [ifDXT1, ifDXT3, ifDXT5]) and not Caps.DXTCompression then if (Desired in [ifDXT1, ifDXT3, ifDXT5]) and not Caps.DXTCompression then
Desired := ifA8R8G8B8; 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 // Try to find GL format equivalent to image format and if it is not
// found use one of default formats // found use one of default formats
if not ImageFormatToGL(Desired, GLFormat, GLType, GLInternal) then if not ImageFormatToGL(Desired, GLFormat, GLType, GLInternal, Caps) then
begin begin
GetImageFormatInfo(Desired, Info); GetImageFormatInfo(Desired, Info);
if Info.HasGrayChannel then if Info.HasGrayChannel then
ConvTo := ifGray8 ConvTo := ifGray8
else else
ConvTo := ifA8R8G8B8; ConvTo := ifA8R8G8B8;
if not ImageFormatToGL(ConvTo, GLFormat, GLType, GLInternal) then if not ImageFormatToGL(ConvTo, GLFormat, GLType, GLInternal, Caps) then
Exit; Exit;
end end
else else
@ -618,7 +660,7 @@ begin
// Check if input image for this mipmap level has the right // Check if input image for this mipmap level has the right
// size and format // size and format
NeedsConvert := not (Images[I].Format = ConvTo); NeedsConvert := not (Images[I].Format = ConvTo);
if ConvTo in CompressedFormats then if ConvTo in BlockCompressedFormats then
begin begin
// Input images in DXTC will have min dimensions of 4, but we need // Input images in DXTC will have min dimensions of 4, but we need
// current Width and Height to be lesser (for glCompressedTexImage2D) // current Width and Height to be lesser (for glCompressedTexImage2D)
@ -659,7 +701,7 @@ begin
FillMipMapLevel(LevelsArray[I - 1], CurrentWidth, CurrentHeight, LevelsArray[I]); FillMipMapLevel(LevelsArray[I - 1], CurrentWidth, CurrentHeight, LevelsArray[I]);
end; end;
if ConvTo in CompressedFormats then if ConvTo in BlockCompressedFormats then
begin begin
// Note: GL DXTC texture snaller than 4x4 must have width and height // Note: GL DXTC texture snaller than 4x4 must have width and height
// as expected for non-DXTC texture (like 1x1 - we cannot // as expected for non-DXTC texture (like 1x1 - we cannot
@ -838,6 +880,14 @@ initialization
not only A8R8G8B8 not only A8R8G8B8
- support for cube and 3D maps - 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 --------------------------------- -- 0.24.1 Changes/Bug Fixes ---------------------------------
- Added PasteNonPow2ImagesIntoPow2 option and related functionality. - Added PasteNonPow2ImagesIntoPow2 option and related functionality.
- Better NeedsResize determination for small DXTC textures - - 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 User Options
@ -212,11 +212,6 @@
{$PACKENUM 4} // Min enum size: 4 B {$PACKENUM 4} // Min enum size: 4 B
{$CALLING REGISTER} // default calling convention is register {$CALLING REGISTER} // default calling convention is register
{$IFDEF CPU86} {$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 {$ASMMODE INTEL} // intel assembler mode
{$ENDIF} {$ENDIF}
{$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 Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net http://imaginglib.sourceforge.net
@ -65,11 +65,10 @@ type
protected protected
FIdNumbers: TChar2; FIdNumbers: TChar2;
FSaveBinary: LongBool; FSaveBinary: LongBool;
FMapInfo: TPortableMapInfo;
function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray; function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
OnlyFirstLevel: Boolean): Boolean; override; OnlyFirstLevel: Boolean): Boolean; override;
function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray; function SaveDataInternal(Handle: TImagingHandle; const Images: TDynImageDataArray;
Index: LongInt): Boolean; override; Index: LongInt; var MapInfo: TPortableMapInfo): Boolean;
public public
constructor Create; override; constructor Create; override;
function TestFormat(Handle: TImagingHandle): Boolean; override; function TestFormat(Handle: TImagingHandle): Boolean; override;
@ -203,6 +202,8 @@ var
PixelFP: TColorFPRec; PixelFP: TColorFPRec;
LineBuffer: array[0..LineBufferCapacity - 1] of Char; LineBuffer: array[0..LineBufferCapacity - 1] of Char;
LineEnd, LinePos: LongInt; LineEnd, LinePos: LongInt;
MapInfo: TPortableMapInfo;
LineBreak: string;
procedure CheckBuffer; procedure CheckBuffer;
begin begin
@ -262,7 +263,7 @@ var
C := LineBuffer[LinePos]; C := LineBuffer[LinePos];
Inc(LinePos); Inc(LinePos);
until not (C in WhiteSpaces) or (LineEnd = 0); 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); Dec(LinePos);
Result := S; Result := S;
@ -273,6 +274,22 @@ var
Result := StrToInt(ReadString); Result := StrToInt(ReadString);
end; 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; function ParseHeader: Boolean;
var var
Id: TChar2; Id: TChar2;
@ -284,34 +301,37 @@ var
Result := False; Result := False;
with GetIO do with GetIO do
begin begin
FillChar(FMapInfo, SizeOf(FMapInfo), 0); FillChar(MapInfo, SizeOf(MapInfo), 0);
Read(Handle, @Id, SizeOf(Id)); Read(Handle, @Id, SizeOf(Id));
FindLineBreak;
if Id[1] in ['1'..'6'] then if Id[1] in ['1'..'6'] then
begin begin
// Read header for PBM, PGM, and PPM files // Read header for PBM, PGM, and PPM files
FMapInfo.Width := ReadIntValue; MapInfo.Width := ReadIntValue;
FMapInfo.Height := ReadIntValue; MapInfo.Height := ReadIntValue;
if Id[1] in ['1', '4'] then if Id[1] in ['1', '4'] then
begin begin
FMapInfo.MaxVal := 1; MapInfo.MaxVal := 1;
FMapInfo.BitCount := 1 MapInfo.BitCount := 1
end end
else else
begin begin
// Read channel max value, <=255 for 8bit images, >255 for 16bit images // Read channel max value, <=255 for 8bit images, >255 for 16bit images
// but some programs think its max colors so put <=256 here // but some programs think its max colors so put <=256 here
FMapInfo.MaxVal := ReadIntValue; MapInfo.MaxVal := ReadIntValue;
FMapInfo.BitCount := Iff(FMapInfo.MaxVal <= 256, 8, 16); MapInfo.BitCount := Iff(MapInfo.MaxVal <= 256, 8, 16);
end; end;
FMapInfo.Depth := 1; MapInfo.Depth := 1;
case Id[1] of case Id[1] of
'1', '4': FMapInfo.TupleType := ttBlackAndWhite; '1', '4': MapInfo.TupleType := ttBlackAndWhite;
'2', '5': FMapInfo.TupleType := ttGrayScale; '2', '5': MapInfo.TupleType := ttGrayScale;
'3', '6': '3', '6':
begin begin
FMapInfo.TupleType := ttRGB; MapInfo.TupleType := ttRGB;
FMapInfo.Depth := 3; MapInfo.Depth := 3;
end; end;
end; end;
end end
@ -320,24 +340,24 @@ var
// Read values from PAM header // Read values from PAM header
// WIDTH // WIDTH
if (ReadString <> SPAMWidth) then Exit; if (ReadString <> SPAMWidth) then Exit;
FMapInfo.Width := ReadIntValue; MapInfo.Width := ReadIntValue;
// HEIGHT // HEIGHT
if (ReadString <> SPAMheight) then Exit; if (ReadString <> SPAMheight) then Exit;
FMapInfo.Height := ReadIntValue; MapInfo.Height := ReadIntValue;
// DEPTH // DEPTH
if (ReadString <> SPAMDepth) then Exit; if (ReadString <> SPAMDepth) then Exit;
FMapInfo.Depth := ReadIntValue; MapInfo.Depth := ReadIntValue;
// MAXVAL // MAXVAL
if (ReadString <> SPAMMaxVal) then Exit; if (ReadString <> SPAMMaxVal) then Exit;
FMapInfo.MaxVal := ReadIntValue; MapInfo.MaxVal := ReadIntValue;
FMapInfo.BitCount := Iff(FMapInfo.MaxVal <= 256, 8, 16); MapInfo.BitCount := Iff(MapInfo.MaxVal <= 256, 8, 16);
// TUPLETYPE // TUPLETYPE
if (ReadString <> SPAMTupleType) then Exit; if (ReadString <> SPAMTupleType) then Exit;
TupleTypeName := ReadString; TupleTypeName := ReadString;
for I := Low(TTupleType) to High(TTupleType) do for I := Low(TTupleType) to High(TTupleType) do
if SameText(TupleTypeName, TupleTypeNames[I]) then if SameText(TupleTypeName, TupleTypeNames[I]) then
begin begin
FMapInfo.TupleType := I; MapInfo.TupleType := I;
Break; Break;
end; end;
// ENDHDR // ENDHDR
@ -346,33 +366,42 @@ var
else if Id[1] in ['F', 'f'] then else if Id[1] in ['F', 'f'] then
begin begin
// Read header of PFM file // Read header of PFM file
FMapInfo.Width := ReadIntValue; MapInfo.Width := ReadIntValue;
FMapInfo.Height := ReadIntValue; MapInfo.Height := ReadIntValue;
OldSeparator := DecimalSeparator; OldSeparator := DecimalSeparator;
DecimalSeparator := '.'; DecimalSeparator := '.';
Scale := StrToFloatDef(ReadString, 0); Scale := StrToFloatDef(ReadString, 0);
DecimalSeparator := OldSeparator; DecimalSeparator := OldSeparator;
FMapInfo.IsBigEndian := Scale > 0.0; MapInfo.IsBigEndian := Scale > 0.0;
if Id[1] = 'F' then if Id[1] = 'F' then
FMapInfo.TupleType := ttRGBFP MapInfo.TupleType := ttRGBFP
else else
FMapInfo.TupleType := ttGrayScaleFP; MapInfo.TupleType := ttGrayScaleFP;
FMapInfo.Depth := Iff(FMapInfo.TupleType = ttRGBFP, 3, 1); MapInfo.Depth := Iff(MapInfo.TupleType = ttRGBFP, 3, 1);
FMapInfo.BitCount := Iff(FMapInfo.TupleType = ttRGBFP, 96, 32); MapInfo.BitCount := Iff(MapInfo.TupleType = ttRGBFP, 96, 32);
end; end;
FixInputPos; 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 // Check if values found in header are valid
Result := (FMapInfo.Width > 0) and (FMapInfo.Height > 0) and Result := (MapInfo.Width > 0) and (MapInfo.Height > 0) and
(FMapInfo.BitCount in [1, 8, 16, 32, 96]) and (FMapInfo.TupleType <> ttInvalid); (MapInfo.BitCount in [1, 8, 16, 32, 96]) and (MapInfo.TupleType <> ttInvalid);
// Now check if image has proper number of channels (PAM) // Now check if image has proper number of channels (PAM)
if Result then if Result then
case FMapInfo.TupleType of case MapInfo.TupleType of
ttBlackAndWhite, ttGrayScale: Result := FMapInfo.Depth = 1; ttBlackAndWhite, ttGrayScale: Result := MapInfo.Depth = 1;
ttBlackAndWhiteAlpha, ttGrayScaleAlpha: Result := FMapInfo.Depth = 2; ttBlackAndWhiteAlpha, ttGrayScaleAlpha: Result := MapInfo.Depth = 2;
ttRGB: Result := FMapInfo.Depth = 3; ttRGB: Result := MapInfo.Depth = 3;
ttRGBAlpha: Result := FMapInfo.Depth = 4; ttRGBAlpha: Result := MapInfo.Depth = 4;
end; end;
end; end;
end; end;
@ -388,24 +417,24 @@ begin
// Try to parse file header // Try to parse file header
if not ParseHeader then Exit; if not ParseHeader then Exit;
// Select appropriate data format based on values read from file header // Select appropriate data format based on values read from file header
case FMapInfo.TupleType of case MapInfo.TupleType of
ttBlackAndWhite: Format := ifGray8; ttBlackAndWhite: Format := ifGray8;
ttBlackAndWhiteAlpha: Format := ifA8Gray8; ttBlackAndWhiteAlpha: Format := ifA8Gray8;
ttGrayScale: Format := IffFormat(FMapInfo.BitCount = 8, ifGray8, ifGray16); ttGrayScale: Format := IffFormat(MapInfo.BitCount = 8, ifGray8, ifGray16);
ttGrayScaleAlpha: Format := IffFormat(FMapInfo.BitCount = 8, ifA8Gray8, ifA16Gray16); ttGrayScaleAlpha: Format := IffFormat(MapInfo.BitCount = 8, ifA8Gray8, ifA16Gray16);
ttRGB: Format := IffFormat(FMapInfo.BitCount = 8, ifR8G8B8, ifR16G16B16); ttRGB: Format := IffFormat(MapInfo.BitCount = 8, ifR8G8B8, ifR16G16B16);
ttRGBAlpha: Format := IffFormat(FMapInfo.BitCount = 8, ifA8R8G8B8, ifA16R16G16B16); ttRGBAlpha: Format := IffFormat(MapInfo.BitCount = 8, ifA8R8G8B8, ifA16R16G16B16);
ttGrayScaleFP: Format := ifR32F; ttGrayScaleFP: Format := ifR32F;
ttRGBFP: Format := ifA32B32G32R32F; ttRGBFP: Format := ifA32B32G32R32F;
end; end;
// Exit if no matching data format was found // Exit if no matching data format was found
if Format = ifUnknown then Exit; if Format = ifUnknown then Exit;
NewImage(FMapInfo.Width, FMapInfo.Height, Format, Images[0]); NewImage(MapInfo.Width, MapInfo.Height, Format, Images[0]);
Info := GetFormatInfo(Format); Info := GetFormatInfo(Format);
// Now read pixels from file to dest image // Now read pixels from file to dest image
if not FMapInfo.Binary then if not MapInfo.Binary then
begin begin
Dest := Bits; Dest := Bits;
for I := 0 to Width * Height - 1 do for I := 0 to Width * Height - 1 do
@ -414,7 +443,7 @@ begin
ifGray8: ifGray8:
begin begin
Dest^ := ReadIntValue; Dest^ := ReadIntValue;
if FMapInfo.BitCount = 1 then if MapInfo.BitCount = 1 then
// If source is 1bit mono image (where 0=white, 1=black) // If source is 1bit mono image (where 0=white, 1=black)
// we must scale it to 8bits // we must scale it to 8bits
Dest^ := 255 - Dest^ * 255; Dest^ := 255 - Dest^ * 255;
@ -440,9 +469,9 @@ begin
end end
else else
begin begin
if FMapInfo.BitCount > 1 then if MapInfo.BitCount > 1 then
begin begin
if not (FMapInfo.TupleType in [ttGrayScaleFP, ttRGBFP]) then if not (MapInfo.TupleType in [ttGrayScaleFP, ttRGBFP]) then
begin begin
// Just copy bytes from binary Portable Maps (non 1bit, non FP) // Just copy bytes from binary Portable Maps (non 1bit, non FP)
Read(Handle, Bits, Size); Read(Handle, Bits, Size);
@ -455,48 +484,43 @@ begin
// I will stick with Photoshops behaviour here // I will stick with Photoshops behaviour here
for I := 0 to Width * Height - 1 do for I := 0 to Width * Height - 1 do
begin begin
Read(Handle, @PixelFP, FMapInfo.BitCount shr 3); Read(Handle, @PixelFP, MapInfo.BitCount div 8);
if FMapInfo.TupleType = ttRGBFP then if MapInfo.TupleType = ttRGBFP then
with PColorFPRec(Dest)^ do with PColorFPRec(Dest)^ do
begin begin
A := 1.0; A := 1.0;
R := PixelFP.R; R := PixelFP.R;
G := PixelFP.G; G := PixelFP.G;
B := PixelFP.B; B := PixelFP.B;
if FMapInfo.IsBigEndian then if MapInfo.IsBigEndian then
SwapEndianLongWord(PLongWord(Dest), 3); SwapEndianLongWord(PLongWord(Dest), 3);
end end
else else
begin begin
PSingle(Dest)^ := PixelFP.B; PSingle(Dest)^ := PixelFP.B;
if FMapInfo.IsBigEndian then if MapInfo.IsBigEndian then
SwapEndianLongWord(PLongWord(Dest), 1); SwapEndianLongWord(PLongWord(Dest), 1);
end; end;
Inc(Dest, Info.BytesPerPixel); Inc(Dest, Info.BytesPerPixel);
end; end;
end; end;
if FMapInfo.TupleType in [ttBlackAndWhite, ttBlackAndWhiteAlpha] then if MapInfo.TupleType in [ttBlackAndWhite, ttBlackAndWhiteAlpha] then
begin begin
// Black and white PAM files must be scaled to 8bits. Note that // Black and white PAM files must be scaled to 8bits. Note that
// in PAM files 1=white, 0=black (reverse of PBM) // 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; PByteArray(Bits)[I] := PByteArray(Bits)[I] * 255;
end; end
if FMapInfo.TupleType in [ttRGB, ttRGBAlpha] then else if MapInfo.TupleType in [ttRGB, ttRGBAlpha] then
begin begin
// Swap channels of RGB/ARGB images. Binary RGB image files use BGR order. // Swap channels of RGB/ARGB images. Binary RGB image files use BGR order.
SwapChannels(Images[0], ChannelBlue, ChannelRed); SwapChannels(Images[0], ChannelBlue, ChannelRed);
end; end;
if FMapInfo.BitCount = 16 then
begin // Swap byte order if needed
Dest := Bits; if (MapInfo.BitCount = 16) and MapInfo.IsBigEndian then
for I := 0 to Width * Height * Info.BytesPerPixel div SizeOf(Word) - 1 do SwapEndianWord(Bits, Width * Height * Info.BytesPerPixel div SizeOf(Word));
begin
PWord(Dest)^ := SwapEndianWord(PWord(Dest)^);
Inc(Dest, SizeOf(Word));
end;
end;
end end
else else
begin begin
@ -520,19 +544,19 @@ begin
FixInputPos; FixInputPos;
if (FMapInfo.MaxVal <> Pow2Int(FMapInfo.BitCount) - 1) and if (MapInfo.MaxVal <> Pow2Int(MapInfo.BitCount) - 1) and
(FMapInfo.TupleType in [ttGrayScale, ttGrayScaleAlpha, ttRGB, ttRGBAlpha]) then (MapInfo.TupleType in [ttGrayScale, ttGrayScaleAlpha, ttRGB, ttRGBAlpha]) then
begin begin
Dest := Bits; Dest := Bits;
// Scale color values according to MaxVal we got from header // Scale color values according to MaxVal we got from header
// if necessary. // 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 begin
if FMapInfo.BitCount = 8 then if MapInfo.BitCount = 8 then
Dest^ := Dest^ * 255 div FMapInfo.MaxVal Dest^ := Dest^ * 255 div MapInfo.MaxVal
else else
PWord(Dest)^ := PWord(Dest)^ * 65535 div FMapInfo.MaxVal; PWord(Dest)^ := PWord(Dest)^ * 65535 div MapInfo.MaxVal;
Inc(Dest, FMapInfo.BitCount shr 3); Inc(Dest, MapInfo.BitCount shr 3);
end; end;
end; end;
@ -540,9 +564,12 @@ begin
end; end;
end; end;
function TPortableMapFileFormat.SaveData(Handle: TImagingHandle; function TPortableMapFileFormat.SaveDataInternal(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: Integer): Boolean; const Images: TDynImageDataArray; Index: Integer; var MapInfo: TPortableMapInfo): Boolean;
const 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; LineDelimiter = #10;
PixelDelimiter = #32; PixelDelimiter = #32;
var var
@ -567,14 +594,14 @@ var
var var
OldSeparator: Char; OldSeparator: Char;
begin begin
WriteString('P' + FMapInfo.FormatId); WriteString('P' + MapInfo.FormatId);
if not FMapInfo.HasPAMHeader then if not MapInfo.HasPAMHeader then
begin begin
// Write header of PGM, PPM, and PFM files // Write header of PGM, PPM, and PFM files
WriteString(IntToStr(ImageToSave.Width)); WriteString(IntToStr(ImageToSave.Width));
WriteString(IntToStr(ImageToSave.Height)); WriteString(IntToStr(ImageToSave.Height));
case FMapInfo.TupleType of case MapInfo.TupleType of
ttGrayScale, ttRGB: WriteString(IntToStr(Pow2Int(FMapInfo.BitCount) - 1)); ttGrayScale, ttRGB: WriteString(IntToStr(Pow2Int(MapInfo.BitCount) - 1));
ttGrayScaleFP, ttRGBFP: ttGrayScaleFP, ttRGBFP:
begin begin
OldSeparator := DecimalSeparator; OldSeparator := DecimalSeparator;
@ -590,9 +617,9 @@ var
// Write PAM file header // Write PAM file header
WriteString(Format('%s %d', [SPAMWidth, ImageToSave.Width])); WriteString(Format('%s %d', [SPAMWidth, ImageToSave.Width]));
WriteString(Format('%s %d', [SPAMHeight, ImageToSave.Height])); WriteString(Format('%s %d', [SPAMHeight, ImageToSave.Height]));
WriteString(Format('%s %d', [SPAMDepth, FMapInfo.Depth])); WriteString(Format('%s %d', [SPAMDepth, MapInfo.Depth]));
WriteString(Format('%s %d', [SPAMMaxVal, Pow2Int(FMapInfo.BitCount) - 1])); WriteString(Format('%s %d', [SPAMMaxVal, Pow2Int(MapInfo.BitCount) - 1]));
WriteString(Format('%s %s', [SPAMTupleType, TupleTypeNames[FMapInfo.TupleType]])); WriteString(Format('%s %s', [SPAMTupleType, TupleTypeNames[MapInfo.TupleType]]));
WriteString(SPAMEndHdr); WriteString(SPAMEndHdr);
end; end;
end; end;
@ -605,29 +632,29 @@ begin
Info := GetFormatInfo(Format); Info := GetFormatInfo(Format);
// Fill values of MapInfo record that were not filled by // Fill values of MapInfo record that were not filled by
// descendants in their SaveData methods // descendants in their SaveData methods
FMapInfo.BitCount := (Info.BytesPerPixel div Info.ChannelCount) * 8; MapInfo.BitCount := (Info.BytesPerPixel div Info.ChannelCount) * 8;
FMapInfo.Depth := Info.ChannelCount; MapInfo.Depth := Info.ChannelCount;
if FMapInfo.TupleType = ttInvalid then if MapInfo.TupleType = ttInvalid then
begin begin
if Info.HasGrayChannel then if Info.HasGrayChannel then
begin begin
if Info.HasAlphaChannel then if Info.HasAlphaChannel then
FMapInfo.TupleType := ttGrayScaleAlpha MapInfo.TupleType := ttGrayScaleAlpha
else else
FMapInfo.TupleType := ttGrayScale; MapInfo.TupleType := ttGrayScale;
end end
else else
begin begin
if Info.HasAlphaChannel then if Info.HasAlphaChannel then
FMapInfo.TupleType := ttRGBAlpha MapInfo.TupleType := ttRGBAlpha
else else
FMapInfo.TupleType := ttRGB; MapInfo.TupleType := ttRGB;
end; end;
end; end;
// Write file header // Write file header
WriteHeader; WriteHeader;
if not FMapInfo.Binary then if not MapInfo.Binary then
begin begin
Src := Bits; Src := Bits;
LineLength := 0; LineLength := 0;
@ -644,7 +671,7 @@ begin
with PColor48Rec(Src)^ do with PColor48Rec(Src)^ do
WriteString(SysUtils.Format('%d %d %d', [R, G, B]), PixelDelimiter); WriteString(SysUtils.Format('%d %d %d', [R, G, B]), PixelDelimiter);
end; end;
// Lines in text PNM images should have length <70 // Lines in text PNM images should have length <70
if LineLength > 65 then if LineLength > 65 then
begin begin
LineLength := 0; LineLength := 0;
@ -656,12 +683,12 @@ begin
else else
begin begin
// Write binary images // Write binary images
if not (FMapInfo.TupleType in [ttGrayScaleFP, ttRGBFP]) then if not (MapInfo.TupleType in [ttGrayScaleFP, ttRGBFP]) then
begin begin
// Save integer binary images // Save integer binary images
if FMapInfo.BitCount = 8 then if MapInfo.BitCount = 8 then
begin begin
if FMapInfo.TupleType in [ttGrayScale, ttGrayScaleAlpha] then if MapInfo.TupleType in [ttGrayScale, ttGrayScaleAlpha] then
begin begin
// 8bit grayscale images can be written in one Write call // 8bit grayscale images can be written in one Write call
Write(Handle, Bits, Size); Write(Handle, Bits, Size);
@ -674,7 +701,7 @@ begin
for I := 0 to Width * Height - 1 do for I := 0 to Width * Height - 1 do
with PColor32Rec(Src)^ do with PColor32Rec(Src)^ do
begin begin
if FMapInfo.TupleType = ttRGBAlpha then if MapInfo.TupleType = ttRGBAlpha then
Pixel32.A := A; Pixel32.A := A;
Pixel32.R := B; Pixel32.R := B;
Pixel32.G := G; Pixel32.G := G;
@ -688,7 +715,7 @@ begin
begin begin
// Images with 16bit channels: make sure that channel values are saved in big endian // Images with 16bit channels: make sure that channel values are saved in big endian
Src := Bits; Src := Bits;
if FMapInfo.TupleType in [ttGrayScale, ttGrayScaleAlpha] then if MapInfo.TupleType in [ttGrayScale, ttGrayScaleAlpha] then
begin begin
// 16bit grayscale image // 16bit grayscale image
for I := 0 to Width * Height * Info.BytesPerPixel div SizeOf(Word) - 1 do 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 for I := 0 to Width * Height - 1 do
with PColor64Rec(Src)^ do with PColor64Rec(Src)^ do
begin begin
if FMapInfo.TupleType = ttRGBAlpha then if MapInfo.TupleType = ttRGBAlpha then
Pixel64.A := SwapEndianWord(A); Pixel64.A := SwapEndianWord(A);
Pixel64.R := SwapEndianWord(B); Pixel64.R := SwapEndianWord(B);
Pixel64.G := SwapEndianWord(G); Pixel64.G := SwapEndianWord(G);
@ -713,13 +740,13 @@ begin
Inc(Src, Info.BytesPerPixel); Inc(Src, Info.BytesPerPixel);
end; end;
end; end;
end; end;
end end
else else
begin begin
// Floating point images (no need to swap endian here - little // Floating point images (no need to swap endian here - little
// endian is specified in file header) // endian is specified in file header)
if FMapInfo.TupleType = ttGrayScaleFP then if MapInfo.TupleType = ttGrayScaleFP then
begin begin
// Grayscale images can be written in one Write call // Grayscale images can be written in one Write call
Write(Handle, Bits, Size); Write(Handle, Bits, Size);
@ -787,11 +814,13 @@ end;
function TPGMFileFormat.SaveData(Handle: TImagingHandle; function TPGMFileFormat.SaveData(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: Integer): Boolean; const Images: TDynImageDataArray; Index: Integer): Boolean;
var
MapInfo: TPortableMapInfo;
begin begin
FillChar(FMapInfo, SizeOf(FMapInfo), 0); FillChar(MapInfo, SizeOf(MapInfo), 0);
FMapInfo.FormatId := Iff(FSaveBinary, FIdNumbers[1], FIdNumbers[0]); MapInfo.FormatId := Iff(FSaveBinary, FIdNumbers[1], FIdNumbers[0]);
FMapInfo.Binary := FSaveBinary; MapInfo.Binary := FSaveBinary;
Result := inherited SaveData(Handle, Images, Index); Result := SaveDataInternal(Handle, Images, Index, MapInfo);
end; end;
procedure TPGMFileFormat.ConvertToSupported(var Image: TImageData; procedure TPGMFileFormat.ConvertToSupported(var Image: TImageData;
@ -831,11 +860,13 @@ end;
function TPPMFileFormat.SaveData(Handle: TImagingHandle; function TPPMFileFormat.SaveData(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: Integer): Boolean; const Images: TDynImageDataArray; Index: Integer): Boolean;
var
MapInfo: TPortableMapInfo;
begin begin
FillChar(FMapInfo, SizeOf(FMapInfo), 0); FillChar(MapInfo, SizeOf(MapInfo), 0);
FMapInfo.FormatId := Iff(FSaveBinary, FIdNumbers[1], FIdNumbers[0]); MapInfo.FormatId := Iff(FSaveBinary, FIdNumbers[1], FIdNumbers[0]);
FMapInfo.Binary := FSaveBinary; MapInfo.Binary := FSaveBinary;
Result := inherited SaveData(Handle, Images, Index); Result := SaveDataInternal(Handle, Images, Index, MapInfo);
end; end;
procedure TPPMFileFormat.ConvertToSupported(var Image: TImageData; procedure TPPMFileFormat.ConvertToSupported(var Image: TImageData;
@ -873,12 +904,14 @@ end;
function TPAMFileFormat.SaveData(Handle: TImagingHandle; function TPAMFileFormat.SaveData(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: Integer): Boolean; const Images: TDynImageDataArray; Index: Integer): Boolean;
var
MapInfo: TPortableMapInfo;
begin begin
FillChar(FMapInfo, SizeOf(FMapInfo), 0); FillChar(MapInfo, SizeOf(MapInfo), 0);
FMapInfo.FormatId := FIdNumbers[0]; MapInfo.FormatId := FIdNumbers[0];
FMapInfo.Binary := True; MapInfo.Binary := True;
FMapInfo.HasPAMHeader := True; MapInfo.HasPAMHeader := True;
Result := inherited SaveData(Handle, Images, Index); Result := SaveDataInternal(Handle, Images, Index, MapInfo);
end; end;
procedure TPAMFileFormat.ConvertToSupported(var Image: TImageData; procedure TPAMFileFormat.ConvertToSupported(var Image: TImageData;
@ -915,16 +948,17 @@ function TPFMFileFormat.SaveData(Handle: TImagingHandle;
const Images: TDynImageDataArray; Index: Integer): Boolean; const Images: TDynImageDataArray; Index: Integer): Boolean;
var var
Info: TImageFormatInfo; Info: TImageFormatInfo;
MapInfo: TPortableMapInfo;
begin begin
FillChar(FMapInfo, SizeOf(FMapInfo), 0); FillChar(MapInfo, SizeOf(MapInfo), 0);
Info := GetFormatInfo(Images[Index].Format); Info := GetFormatInfo(Images[Index].Format);
if (Info.ChannelCount > 1) or Info.IsIndexed then if (Info.ChannelCount > 1) or Info.IsIndexed then
FMapInfo.TupleType := ttRGBFP MapInfo.TupleType := ttRGBFP
else else
FMapInfo.TupleType := ttGrayScaleFP; MapInfo.TupleType := ttGrayScaleFP;
FMapInfo.FormatId := Iff(FMapInfo.TupleType = ttGrayScaleFP, FIdNumbers[1], FIdNumbers[0]); MapInfo.FormatId := Iff(MapInfo.TupleType = ttGrayScaleFP, FIdNumbers[1], FIdNumbers[0]);
FMapInfo.Binary := True; MapInfo.Binary := True;
Result := inherited SaveData(Handle, Images, Index); Result := SaveDataInternal(Handle, Images, Index, MapInfo);
end; end;
procedure TPFMFileFormat.ConvertToSupported(var Image: TImageData; procedure TPFMFileFormat.ConvertToSupported(var Image: TImageData;
@ -949,6 +983,10 @@ initialization
-- TODOS ---------------------------------------------------- -- TODOS ----------------------------------------------------
- nothing now - 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 ----------------------------------- -- 0.21 Changes/Bug Fixes -----------------------------------
- Made modifications to ASCII PNM loading to be more "stream-safe". - Made modifications to ASCII PNM loading to be more "stream-safe".
- Fixed bug: indexed images saved as grayscale in PFM. - 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 Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net http://imaginglib.sourceforge.net
@ -37,9 +37,9 @@ const
{ Current Major version of Imaging.} { Current Major version of Imaging.}
ImagingVersionMajor = 0; ImagingVersionMajor = 0;
{ Current Minor version of Imaging.} { Current Minor version of Imaging.}
ImagingVersionMinor = 24; ImagingVersionMinor = 26;
{ Current patch of Imaging.} { Current patch of Imaging.}
ImagingVersionPatch = 2; ImagingVersionPatch = 0;
{ Imaging Option Ids whose values can be set/get by SetOption/ { Imaging Option Ids whose values can be set/get by SetOption/
GetOption functions.} GetOption functions.}
@ -137,6 +137,11 @@ const
Allowed values are 0 (store as text - very! large files) and 1 (save binary). Allowed values are 0 (store as text - very! large files) and 1 (save binary).
Default value is 1.} Default value is 1.}
ImagingPPMSaveBinary = 51; 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 { This option is used when reducing number of colors used in
@ -225,7 +230,9 @@ type
ifDXT1 = 220, ifDXT1 = 220,
ifDXT3 = 221, ifDXT3 = 221,
ifDXT5 = 222, ifDXT5 = 222,
ifBTC = 223); ifBTC = 223,
ifATI1N = 224,
ifATI2N = 225);
{ Color value for 32 bit images.} { Color value for 32 bit images.}
TColor32 = LongWord; TColor32 = LongWord;
@ -439,11 +446,9 @@ implementation
-- TODOS ---------------------------------------------------- -- TODOS ----------------------------------------------------
- add lookup tables to pixel formats for fast conversions - 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 -- 0.24.3 Changes/Bug Fixes ---------------------------------
(add something like FormatType = (ftIndexed, ftRGB, ftIntensity, ftCompressed, - Added ifATI1N and ifATI2N image data formats.
ftFloatingPoint, ftRGBBitFields) and additional infos like HasAlphaChannel,
ChannelSize, ChannelCount, ...)
-- 0.23 Changes/Bug Fixes ----------------------------------- -- 0.23 Changes/Bug Fixes -----------------------------------
- Added ifBTC image format and SpecialNearestFormat field - 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 Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net http://imaginglib.sourceforge.net
@ -56,6 +56,9 @@ type
TBooleanArray = array[0..MaxInt - 1] of Boolean; TBooleanArray = array[0..MaxInt - 1] of Boolean;
PBooleanArray = ^TBooleanArray; PBooleanArray = ^TBooleanArray;
TDynIntegerArray = array of Integer;
TDynBooleanArray = array of Boolean;
TWordRec = packed record TWordRec = packed record
case Integer of case Integer of
0: (WordValue: Word); 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} procedure FreeMem(P: Pointer); {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Returns current exception object. Do not call outside exception handler.} { Returns current exception object. Do not call outside exception handler.}
function GetExceptObject: Exception; {$IFDEF USE_INLINE}inline;{$ENDIF} 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; function GetTimeMicroseconds: Int64;
{ Returns time value with milisecond resolution.}
function GetTimeMilliseconds: Int64;
{ Returns file extension (without "." dot)} { Returns file extension (without "." dot)}
function GetFileExt(const FileName: string): string; function GetFileExt(const FileName: string): string;
@ -128,7 +133,7 @@ function GetFileExt(const FileName: string): string;
function GetAppExe: string; function GetAppExe: string;
{ Returns directory where application's exceutable is located without { Returns directory where application's exceutable is located without
path delimiter at the end.} path delimiter at the end.}
function GetAppDir:string; function GetAppDir: string;
{ Returns True if FileName matches given Mask with optional case sensitivity. { Returns True if FileName matches given Mask with optional case sensitivity.
Mask can contain ? and * special characters: ? matches Mask can contain ? and * special characters: ? matches
one character, * matches zero or more characters.} 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; function StrToken(var S: string; Sep: Char): string;
{ Same as StrToken but searches from the end of S string.} { Same as StrToken but searches from the end of S string.}
function StrTokenEnd(var S: string; Sep: Char): 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>} { Clamps integer value to range <Min, Max>}
function ClampInt(Number: LongInt; Min, Max: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} 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} function SwapEndianLongWord(Value: LongWord): LongWord; overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Swaps byte order of multiple LongWord values.} { Swaps byte order of multiple LongWord values.}
procedure SwapEndianLongWord(P: PLongWord; Count: LongInt); overload; procedure SwapEndianLongWord(P: PLongWord; Count: LongInt); overload;
{ Calculates CRC32 for the given data.} { Calculates CRC32 for the given data.}
procedure CalcCrc32(var Crc: LongWord; Data: Pointer; Size: LongInt); procedure CalcCrc32(var Crc: LongWord; Data: Pointer; Size: LongInt);
{ Fills given memory with given Byte value. Size is size of buffer in bytes.} { Fills given memory with given Byte value. Size is size of buffer in bytes.}
@ -385,6 +395,11 @@ asm
end; end;
{$ENDIF} {$ENDIF}
function GetTimeMilliseconds: Int64;
begin
Result := GetTimeMicroseconds div 1000;
end;
function GetFileExt(const FileName: string): string; function GetFileExt(const FileName: string): string;
begin begin
Result := ExtractFileExt(FileName); Result := ExtractFileExt(FileName);
@ -418,7 +433,7 @@ begin
{$ENDIF} {$ENDIF}
end; end;
function GetAppDir:string; function GetAppDir: string;
begin begin
Result := ExtractFileDir(GetAppExe); Result := ExtractFileDir(GetAppExe);
end; end;
@ -760,6 +775,16 @@ begin
end; end;
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; function ClampInt(Number: LongInt; Min, Max: LongInt): LongInt;
begin begin
Result := Number; Result := Number;
@ -1371,8 +1396,7 @@ procedure ClipCopyBounds(var SrcX, SrcY, Width, Height, DstX, DstY: LongInt; Src
begin begin
Diff := DstClipMin - DstPos; Diff := DstClipMin - DstPos;
Size := Size - Diff; Size := Size - Diff;
if DstPos < SrcPos then SrcPos := SrcPos + Diff;
SrcPos := SrcPos + Diff;
DstPos := DstClipMin; DstPos := DstClipMin;
end; end;
if SrcPos < 0 then if SrcPos < 0 then
@ -1528,6 +1552,13 @@ initialization
-- TODOS ---------------------------------------------------- -- TODOS ----------------------------------------------------
- nothing now - 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 ----------------------------------- -- 0.23 Changes/Bug Fixes -----------------------------------
- Added RectInRect and RectIntersects functions - Added RectInRect and RectIntersects functions
- Added some string utils: StrToken, StrTokenEnd, PosEx, PosNoCase. - 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>