diff --git a/Client/CentrED.lpi b/Client/CentrED.lpi
index 6521cd7..7587483 100644
--- a/Client/CentrED.lpi
+++ b/Client/CentrED.lpi
@@ -1,497 +1,559 @@
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
\ No newline at end of file
diff --git a/Client/UPacketHandlers.pas b/Client/UPacketHandlers.pas
index f460a88..d42077a 100644
--- a/Client/UPacketHandlers.pas
+++ b/Client/UPacketHandlers.pas
@@ -141,6 +141,7 @@ initialization
//$06-$0B --> handled by TLandscape
//$0C --> ClientHandling, done by TfrmMain
//$0D --> RadarMapHandling, done by TfrmRadarMap
+ //$0E --> LargeScaleCommands, done by TfrmLargeScaleCommands
finalization
for i := 0 to $FF do
if PacketHandlers[i] <> nil then
diff --git a/Client/UPackets.pas b/Client/UPackets.pas
index bbd7c12..8d4a078 100644
--- a/Client/UPackets.pas
+++ b/Client/UPackets.pas
@@ -21,7 +21,7 @@
* CDDL HEADER END
*
*
- * Portions Copyright 2009 Andreas Schneider
+ * Portions Copyright 2013 Andreas Schneider
*)
unit UPackets;
@@ -133,6 +133,12 @@ type
TGotoClientPosPacket = class(TPacket)
constructor Create(AUsername: string);
end;
+
+ { TChangePasswordPacket }
+
+ TChangePasswordPacket = class(TPacket)
+ constructor Create(AOldPassword, ANewPassword: String);
+ end;
{ TRequestRadarChecksumPacket }
@@ -346,6 +352,16 @@ begin
FStream.WriteStringNull(AUsername);
end;
+{ TChangePasswordPacket }
+
+constructor TChangePasswordPacket.Create(AOldPassword, ANewPassword: String);
+begin
+ inherited Create($0C, 0);
+ FStream.WriteByte($08);
+ FStream.WriteStringNull(AOldPassword);
+ FStream.WriteStringNull(ANewPassword);
+end;
+
{ TRequestRadarChecksumPacket }
constructor TRequestRadarChecksumPacket.Create;
diff --git a/Client/UdmNetwork.pas b/Client/UdmNetwork.pas
index 0f5110c..565c8d4 100644
--- a/Client/UdmNetwork.pas
+++ b/Client/UdmNetwork.pas
@@ -78,7 +78,8 @@ uses
UGameResources, UfrmAccountControl, UfrmEditAccount, UfrmDrawSettings,
UfrmBoundaries, UfrmElevateSettings, UfrmConfirmation, UfrmMoveSettings,
UfrmAbout, UfrmHueSettings, UfrmRadar, UfrmLargeScaleCommand,
- UfrmVirtualLayer, UfrmFilter, UfrmRegionControl, UfrmLightlevel;
+ UfrmVirtualLayer, UfrmFilter, UfrmRegionControl, UfrmLightlevel,
+ UfrmChangePassword;
{$I version.inc}
@@ -212,6 +213,7 @@ begin
frmVirtualLayer := TfrmVirtualLayer.Create(frmMain);
frmLightlevel := TfrmLightlevel.Create(frmMain);
frmAbout := TfrmAbout.Create(frmMain);
+ frmChangePassword := TfrmChangePassword.Create(frmMain);
frmMain.Show;
frmInitialize.Hide;
tmNoOp.Enabled := True;
@@ -308,6 +310,7 @@ begin
FreeAndNil(frmLargeScaleCommand);
FreeAndNil(frmRadarMap);
FreeAndNil(frmLightlevel);
+ FreeAndNil(frmChangePassword);
if frmMain <> nil then
begin
diff --git a/Client/UfrmChangePassword.lfm b/Client/UfrmChangePassword.lfm
new file mode 100644
index 0000000..14dd4f8
--- /dev/null
+++ b/Client/UfrmChangePassword.lfm
@@ -0,0 +1,129 @@
+object frmChangePassword: TfrmChangePassword
+ Left = 283
+ Height = 145
+ Top = 193
+ Width = 315
+ BorderStyle = bsDialog
+ Caption = 'Change Password'
+ ClientHeight = 145
+ ClientWidth = 315
+ OnShow = FormShow
+ Position = poMainFormCenter
+ LCLVersion = '1.3'
+ object Label1: TLabel
+ AnchorSideTop.Control = edOldPwd
+ AnchorSideTop.Side = asrCenter
+ AnchorSideRight.Control = edOldPwd
+ Left = 32
+ Height = 15
+ Top = 13
+ Width = 88
+ Anchors = [akTop, akRight]
+ BorderSpacing.Right = 8
+ Caption = 'Old Password:'
+ ParentColor = False
+ end
+ object Label2: TLabel
+ AnchorSideTop.Control = edNewPwd
+ AnchorSideTop.Side = asrCenter
+ AnchorSideRight.Control = edNewPwd
+ Left = 26
+ Height = 15
+ Top = 46
+ Width = 94
+ Anchors = [akTop, akRight]
+ BorderSpacing.Right = 8
+ Caption = 'New Password:'
+ ParentColor = False
+ end
+ object lblNewPwdRepeat: TLabel
+ AnchorSideTop.Control = edNewPwdRepeat
+ AnchorSideTop.Side = asrCenter
+ AnchorSideRight.Control = edNewPwdRepeat
+ Left = 9
+ Height = 15
+ Top = 79
+ Width = 111
+ Anchors = [akTop, akRight]
+ BorderSpacing.Right = 8
+ Caption = 'Repeat Password:'
+ ParentColor = False
+ end
+ object edOldPwd: TEdit
+ Left = 128
+ Height = 25
+ Top = 8
+ Width = 176
+ EchoMode = emPassword
+ PasswordChar = '*'
+ TabOrder = 0
+ end
+ object edNewPwd: TEdit
+ AnchorSideLeft.Control = edOldPwd
+ AnchorSideTop.Control = edOldPwd
+ AnchorSideTop.Side = asrBottom
+ AnchorSideRight.Control = edOldPwd
+ AnchorSideRight.Side = asrBottom
+ Left = 128
+ Height = 25
+ Top = 41
+ Width = 176
+ Anchors = [akTop, akLeft, akRight]
+ BorderSpacing.Top = 8
+ EchoMode = emPassword
+ OnChange = edNewPwdChange
+ PasswordChar = '*'
+ TabOrder = 1
+ end
+ object edNewPwdRepeat: TEdit
+ AnchorSideLeft.Control = edNewPwd
+ AnchorSideTop.Control = edNewPwd
+ AnchorSideTop.Side = asrBottom
+ AnchorSideRight.Control = edNewPwd
+ AnchorSideRight.Side = asrBottom
+ Left = 128
+ Height = 25
+ Top = 74
+ Width = 176
+ Anchors = [akTop, akLeft, akRight]
+ BorderSpacing.Top = 8
+ EchoMode = emPassword
+ OnChange = edNewPwdChange
+ PasswordChar = '*'
+ TabOrder = 2
+ end
+ object btnOK: TButton
+ AnchorSideTop.Control = btnCancel
+ AnchorSideRight.Control = btnCancel
+ Left = 149
+ Height = 25
+ Top = 112
+ Width = 75
+ Anchors = [akTop, akRight]
+ BorderSpacing.Right = 8
+ Caption = '&OK'
+ Default = True
+ Enabled = False
+ ModalResult = 1
+ OnClick = btnOKClick
+ TabOrder = 3
+ end
+ object btnCancel: TButton
+ AnchorSideRight.Control = Owner
+ AnchorSideRight.Side = asrBottom
+ AnchorSideBottom.Control = Owner
+ AnchorSideBottom.Side = asrBottom
+ Left = 232
+ Height = 25
+ Top = 112
+ Width = 75
+ Anchors = [akRight, akBottom]
+ BorderSpacing.Right = 8
+ BorderSpacing.Bottom = 8
+ Cancel = True
+ Caption = 'Cancel'
+ ModalResult = 2
+ OnClick = btnCancelClick
+ TabOrder = 4
+ end
+end
diff --git a/Client/UfrmChangePassword.pas b/Client/UfrmChangePassword.pas
new file mode 100644
index 0000000..2518b11
--- /dev/null
+++ b/Client/UfrmChangePassword.pas
@@ -0,0 +1,81 @@
+unit UfrmChangePassword;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+ Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls;
+
+type
+
+ { TfrmChangePassword }
+
+ TfrmChangePassword = class(TForm)
+ btnOK: TButton;
+ btnCancel: TButton;
+ edOldPwd: TEdit;
+ edNewPwd: TEdit;
+ edNewPwdRepeat: TEdit;
+ Label1: TLabel;
+ Label2: TLabel;
+ lblNewPwdRepeat: TLabel;
+ procedure btnCancelClick(Sender: TObject);
+ procedure btnOKClick(Sender: TObject);
+ procedure edNewPwdChange(Sender: TObject);
+ procedure FormShow(Sender: TObject);
+ private
+ { private declarations }
+ public
+ { public declarations }
+ end;
+
+var
+ frmChangePassword: TfrmChangePassword;
+
+implementation
+
+uses
+ UdmNetwork, UPackets, UEnums;
+
+{$R *.lfm}
+
+{ TfrmChangePassword }
+
+procedure TfrmChangePassword.FormShow(Sender: TObject);
+begin
+ edOldPwd.Text := '';
+ edNewPwd.Text := '';
+ edNewPwdRepeat.Text := '';
+end;
+
+procedure TfrmChangePassword.btnCancelClick(Sender: TObject);
+begin
+ Close;
+end;
+
+procedure TfrmChangePassword.btnOKClick(Sender: TObject);
+begin
+ dmNetwork.Send(TChangePasswordPacket.Create(edOldPwd.Text,
+ edNewPwd.Text));
+end;
+
+procedure TfrmChangePassword.edNewPwdChange(Sender: TObject);
+var
+ pwdValid: Boolean;
+begin
+ if edNewPwd.Text <> edNewPwdRepeat.Text then
+ begin
+ pwdValid := False;
+ lblNewPwdRepeat.Font.Color := clRed;
+ end else
+ begin
+ pwdValid := True;
+ lblNewPwdRepeat.Font.Color := clDefault;
+ end;
+
+ btnOK.Enabled := (Length(edNewPwd.Text) > 0) and pwdValid;
+end;
+
+end.
+
diff --git a/Client/UfrmMain.lfm b/Client/UfrmMain.lfm
index b011972..98ba7aa 100644
--- a/Client/UfrmMain.lfm
+++ b/Client/UfrmMain.lfm
@@ -1,2731 +1,2737 @@
-object frmMain: TfrmMain
- Left = 257
- Height = 579
- Top = 141
- Width = 755
- ActiveControl = oglGameWindow
- Caption = 'UO CentrED'
- ClientHeight = 559
- ClientWidth = 755
- Constraints.MinHeight = 500
- Constraints.MinWidth = 750
- Font.Height = -11
- Menu = MainMenu1
- OnActivate = FormActivate
- OnClose = FormClose
- OnCreate = FormCreate
- OnDestroy = FormDestroy
- Position = poScreenCenter
- SessionProperties = 'acFlat.Checked;acNoDraw.Checked;Height;Left;mnuFlatShowHeight.Checked;mnuSecurityQuestion.Checked;mnuShowAnimations.Checked;spTileList.Top;tbStatics.Down;tbTerrain.Down;Top;Width;WindowState;mnuWhiteBackground.Checked'
- ShowInTaskBar = stAlways
- LCLVersion = '1.3'
- WindowState = wsMaximized
- object pnlBottom: TPanel
- Left = 0
- Height = 31
- Top = 528
- Width = 755
- Align = alBottom
- BevelOuter = bvNone
- ClientHeight = 31
- ClientWidth = 755
- TabOrder = 0
- object lblX: TLabel
- Left = 11
- Height = 13
- Top = 7
- Width = 9
- Caption = 'X:'
- ParentColor = False
- end
- object lblY: TLabel
- Left = 88
- Height = 13
- Top = 7
- Width = 8
- Caption = 'Y:'
- ParentColor = False
- end
- object lblTileInfo: TLabel
- Left = 240
- Height = 13
- Top = 7
- Width = 3
- Caption = ' '
- ParentColor = False
- end
- object lblTip: TLabel
- Left = 524
- Height = 31
- Top = 0
- Width = 223
- Align = alRight
- Alignment = taRightJustify
- BorderSpacing.Right = 8
- Caption = 'Right click shows a menu with all the tools.'
- Layout = tlCenter
- ParentColor = False
- end
- object lblTipC: TLabel
- Left = 502
- Height = 31
- Top = 0
- Width = 22
- Align = alRight
- Caption = 'Tip: '
- Font.Height = -11
- Font.Style = [fsBold]
- Layout = tlCenter
- ParentColor = False
- ParentFont = False
- end
- object edX: TSpinEdit
- Left = 24
- Height = 21
- Top = 3
- Width = 55
- MaxValue = 100000
- TabOrder = 0
- end
- object edY: TSpinEdit
- Left = 104
- Height = 21
- Top = 3
- Width = 52
- MaxValue = 100000
- TabOrder = 1
- end
- object btnGoTo: TButton
- Left = 168
- Height = 23
- Top = 3
- Width = 51
- BorderSpacing.InnerBorder = 4
- Caption = 'GoTo'
- OnClick = btnGoToClick
- TabOrder = 2
- end
- end
- object pcLeft: TPageControl
- Left = 0
- Height = 504
- Top = 24
- Width = 224
- ActivePage = tsTiles
- Align = alLeft
- TabIndex = 0
- TabOrder = 1
- object tsTiles: TTabSheet
- Caption = 'Tiles'
- ClientHeight = 478
- ClientWidth = 216
- object lblFilter: TLabel
- AnchorSideLeft.Control = cbTerrain
- AnchorSideLeft.Side = asrBottom
- AnchorSideTop.Control = cbTerrain
- Left = 75
- Height = 13
- Top = 8
- Width = 29
- BorderSpacing.Left = 16
- Caption = 'Filter:'
- ParentColor = False
- end
- object vdtTiles: TVirtualDrawTree
- Tag = 1
- AnchorSideLeft.Control = tsTiles
- AnchorSideTop.Control = cbStatics
- AnchorSideTop.Side = asrBottom
- AnchorSideRight.Control = tsTiles
- AnchorSideRight.Side = asrBottom
- AnchorSideBottom.Control = spTileList
- Left = 4
- Height = 240
- Hint = '-'
- Top = 50
- Width = 208
- Anchors = [akTop, akLeft, akRight, akBottom]
- BorderSpacing.Left = 4
- BorderSpacing.Top = 4
- BorderSpacing.Right = 4
- DefaultNodeHeight = 44
- DragMode = dmAutomatic
- DragOperations = []
- DragType = dtVCL
- Header.AutoSizeIndex = 2
- Header.Columns = <
- item
- Position = 0
- Text = 'ID'
- end
- item
- Position = 1
- Text = 'Tile'
- Width = 44
- end
- item
- Position = 2
- Text = 'Name'
- Width = 100
- end>
- Header.DefaultHeight = 17
- Header.MainColumn = 2
- Header.Options = [hoShowHint, hoVisible]
- Header.ParentFont = True
- Header.Style = hsFlatButtons
- HintMode = hmHint
- ParentShowHint = False
- PopupMenu = pmTileList
- ShowHint = True
- TabOrder = 0
- TreeOptions.AutoOptions = [toAutoScroll, toAutoScrollOnExpand, toAutoTristateTracking, toAutoDeleteMovedNodes]
- TreeOptions.MiscOptions = [toFullRepaintOnResize, toInitOnSave, toToggleOnDblClick, toWheelPanning, toFullRowDrag]
- TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toThemeAware, toUseBlendedImages, toStaticBackground]
- TreeOptions.SelectionOptions = [toFullRowSelect, toMultiSelect]
- OnClick = vdtTilesClick
- OnDrawHint = vdtTilesDrawHint
- OnDrawNode = vdtTilesDrawNode
- OnEnter = vdtTilesEnter
- OnGetHintSize = vdtTilesGetHintSize
- OnKeyPress = vdtTilesKeyPress
- OnScroll = vdtTilesScroll
- end
- object gbRandom: TGroupBox
- AnchorSideLeft.Control = tsTiles
- AnchorSideTop.Control = spTileList
- AnchorSideTop.Side = asrBottom
- AnchorSideRight.Control = tsTiles
- AnchorSideRight.Side = asrBottom
- AnchorSideBottom.Control = tsTiles
- AnchorSideBottom.Side = asrBottom
- Left = 0
- Height = 183
- Top = 295
- Width = 216
- Anchors = [akTop, akLeft, akRight, akBottom]
- Caption = 'Random pool'
- ClientHeight = 165
- ClientWidth = 212
- TabOrder = 1
- object btnAddRandom: TSpeedButton
- AnchorSideLeft.Control = gbRandom
- AnchorSideTop.Control = gbRandom
- Left = 4
- Height = 22
- Hint = 'Add'
- Top = 0
- Width = 23
- BorderSpacing.Left = 4
- Glyph.Data = {
- 36040000424D3604000000000000360000002800000010000000100000000100
- 2000000000000004000064000000640000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000003A8C44FF368940FF32873CFF2F84
- 37FF000000000000000000000000000000000000000000000000000000000000
- 00000000000000000000459653FF419950FF7DC28FFF96D0A6FF96CFA6FF78BE
- 89FF368D42FF2C8134FF00000000000000000000000000000000000000000000
- 0000000000004D9C5DFF64B478FFA8DBB5FF87CC98FF66BC7DFF64BA7CFF86CB
- 98FFA5D9B4FF58AA6BFF2C8134FF000000000000000000000000000000000000
- 000056A366FF6AB97DFFA8DBB2FF60BC77FF5CBA73FF59B870FF59B56FFF58B5
- 6FFF5BB774FFA5D9B3FF5AAA6CFF2C8234FF0000000000000000000000000000
- 000053AB68FFAADDB4FF64C179FF5FBE71FF60BC77FFFFFFFFFFFFFFFFFF59B8
- 70FF58B56EFF5CB774FFA6DAB4FF388F43FF00000000000000000000000061AC
- 75FF8ACC98FF89D396FF6BC67AFF63C170FF55AB65FFFFFFFFFFFFFFFFFF59B8
- 70FF59B870FF5BB972FF85CC97FF7BBE8DFF308539FF000000000000000065AF
- 7AFFA9DDB3FF7DCF8AFF75CC81FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
- FFFFFFFFFFFF59B870FF67BE7DFF9CD4ABFF34883DFF000000000000000069B2
- 7EFFB6E2BEFF8BD597FF7AC986FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
- FFFFFFFFFFFF59B870FF69C17EFF9DD4AAFF388B42FF00000000000000006DB5
- 83FFACDDB6FFA6DFAFFF81CB8CFF7CC986FF6EBD79FFFFFFFFFFFFFFFFFF5BAC
- 6AFF60BC77FF5CBA73FF8BD199FF80C592FF3C8E47FF00000000000000000000
- 000085C797FFD2EED7FF95D9A0FF8AD394FF7FC889FFFFFFFFFFFFFFFFFF79CD
- 85FF6BC37CFF6FC77EFFACDFB5FF459E57FF0000000000000000000000000000
- 000070B887FFAADAB7FFD8F1DCFF92D89DFF88CD93FF84CC8EFF8BD496FF8AD4
- 95FF83D28EFFAFE0B7FF6BB97DFF489856FF0000000000000000000000000000
- 00000000000070B887FFAFDCBBFFDCF2E0FFB6E4BDFF9BDBA5FF96D9A0FFA5DF
- AFFFC0E8C5FF79C28AFF509E5FFF000000000000000000000000000000000000
- 0000000000000000000071B887FF94CEA4FFC3E6CBFFCFEBD4FFC9E9CEFFAFDD
- B8FF6DB97FFF58A569FF00000000000000000000000000000000000000000000
- 0000000000000000000000000000000000006EB684FF6AB380FF67B17CFF63AE
- 77FF000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000
- }
- OnClick = btnAddRandomClick
- ShowHint = True
- ParentShowHint = False
- end
- object btnDeleteRandom: TSpeedButton
- AnchorSideLeft.Control = btnAddRandom
- AnchorSideLeft.Side = asrBottom
- AnchorSideTop.Control = btnAddRandom
- Left = 31
- Height = 22
- Hint = 'Delete'
- Top = 0
- Width = 23
- BorderSpacing.Left = 4
- Glyph.Data = {
- 36040000424D3604000000000000360000002800000010000000100000000100
- 2000000000000004000064000000640000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000003853BEFF3551BDFF304BBCFF2E4E
- B8FF000000000000000000000000000000000000000000000000000000000000
- 000000000000000000004255C6FF3C52CCFF757AE8FF8F92EEFF8F92EEFF7178
- E4FF334DC1FF2B4AB7FF00000000000000000000000000000000000000000000
- 0000000000004959CBFF5C65E0FFA1A6F5FF7E86EFFF5B63E9FF595DE7FF7D84
- EEFF9EA0F4FF515DD7FF2B4AB7FF000000000000000000000000000000000000
- 00005361CFFF616BE3FFA1ACF5FF545FECFF505CEAFF4D59E9FF4E59E6FF4C56
- E6FF5056E6FF9EA2F4FF5460D6FF2A4AB8FF0000000000000000000000000000
- 00004B56DBFFA2ABF6FF5664F0FF5266EEFF4D59E9FF4D59E9FF4D59E9FF4D59
- E9FF4C58E6FF525AE6FF9FA3F5FF3450C4FF0000000000000000000000005C62
- D7FF818CEEFF7E91F7FF5D73F3FF4D59E9FF4D59E9FF4D59E9FF4D59E9FF4D59
- E9FF4D59E9FF4F5BE9FF7B83F0FF757BE2FF2E4BBAFF00000000000000005F63
- DAFFA1ABF7FF7086F8FF6882F6FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
- FFFFFFFFFFFF4D59E9FF5C66EAFF969CF1FF3250BCFF00000000000000006469
- DBFFAFB9F9FF7F93FAFF7085F0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
- FFFFFFFFFFFF4D59E9FF5E6AEEFF969DF1FF364FBEFF0000000000000000676A
- DEFFA5AFF5FF9DABFAFF778CF0FF545FECFF545FECFF545FECFF545FECFF545F
- ECFF545FECFF6377F2FF818EF4FF787FE9FF3A53C0FF00000000000000000000
- 00007D83EAFFCDD4FCFF8B9DFAFF7E93F7FF758AEEFF6C84F6FF6C84F6FF6C84
- F6FF6C84F6FF6379F3FFA4AFF8FF3E4FD0FF0000000000000000000000000000
- 00006A69E0FFA3A7F3FFD4DBFDFF879AFAFF7F91F0FF7A8EF1FF7F94F8FF7E92
- F9FF768CF8FFA8B6F8FF636EE3FF4557C7FF0000000000000000000000000000
- 0000000000006A69E0FFAAADF2FFD8DCFDFFAEBAFAFF91A3FAFF8B9DFAFF9CA9
- FBFFBAC7FCFF707BE9FF4C5BCCFF000000000000000000000000000000000000
- 000000000000000000006A6ADFFF8E93EDFFBEC3F8FFCCD3F9FFC4CBF9FFAAB4
- F4FF6670E2FF535ED1FF00000000000000000000000000000000000000000000
- 000000000000000000000000000000000000686ADDFF6364DCFF6164DAFF5D63
- D9FF000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000
- }
- OnClick = btnDeleteRandomClick
- ShowHint = True
- ParentShowHint = False
- end
- object btnClearRandom: TSpeedButton
- AnchorSideLeft.Control = btnDeleteRandom
- AnchorSideLeft.Side = asrBottom
- AnchorSideTop.Control = btnDeleteRandom
- Left = 58
- Height = 22
- Hint = 'Clear'
- Top = 0
- Width = 23
- BorderSpacing.Left = 4
- Glyph.Data = {
- 36040000424D3604000000000000360000002800000010000000100000000100
- 2000000000000004000064000000640000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 000000000000000000000000F1FF0000F1FF0000F1FF0000F1FF0000EFFF0000
- EFFF0000EDFF0000EDFF00000000000000000000000000000000000000000000
- 0000000000000000F5FF1A20F5FF3C4CF9FF3A49F8FF3847F8FF3545F8FF3443
- F7FF3242F7FF141BF1FF0000EDFF000000000000000000000000000000000000
- 00000000F7FF1D23F9FF4453FAFF2429F9FF1212F7FF0F0FF6FF0C0CF5FF0909
- F5FF161BF5FF3343F7FF141BF1FF0000EDFF0000000000000000000000000000
- F9FF1F25FAFF4A58FBFF4247FBFFC9C9FDFF3B3BF9FF1313F7FF1010F6FF3333
- F7FFC5C5FDFF3035F7FF3444F7FF141BF2FF0000EDFF00000000000000000000
- FBFF4F5DFDFF3237FBFFCBCBFEFFF2F2FFFFEBEBFEFF3B3BF9FF3939F8FFEAEA
- FEFFF1F1FEFFC5C5FDFF181DF6FF3343F7FF0000EFFF00000000000000000000
- FDFF525FFDFF2828FCFF4747FCFFECECFFFFF2F2FFFFECECFFFFECECFEFFF1F1
- FFFFEAEAFEFF3434F7FF0B0BF5FF3545F8FF0000EFFF00000000000000000000
- FDFF5562FEFF2C2CFDFF2929FCFF4848FCFFEDEDFFFFF2F2FFFFF2F2FFFFECEC
- FEFF3A3AF9FF1212F7FF0F0FF6FF3848F8FF0000F1FF00000000000000000000
- FDFF5764FEFF3030FDFF2D2DFDFF4B4BFCFFEDEDFFFFF2F2FFFFF2F2FFFFECEC
- FFFF3D3DF9FF1616F8FF1313F7FF3C4BF8FF0000F1FF00000000000000000000
- FFFF5A67FEFF3333FEFF5050FDFFEDEDFFFFF3F3FFFFEDEDFFFFEDEDFFFFF2F2
- FFFFECECFEFF3E3EFAFF1717F8FF3F4EF9FF0000F1FF00000000000000000000
- FFFF5B68FFFF4347FEFFCFCFFFFFF3F3FFFFEDEDFFFF4C4CFCFF4A4AFCFFECEC
- FFFFF2F2FFFFCACAFEFF2A2FFAFF4251FAFF0000F3FF00000000000000000000
- FFFF262BFFFF5D6AFFFF585BFFFFCFCFFFFF5252FEFF2F2FFDFF2C2CFDFF4B4B
- FCFFCCCCFEFF484CFBFF4957FBFF1D23F9FF0000F5FF00000000000000000000
- 00000000FFFF262BFFFF5D6AFFFF4347FFFF3434FEFF3232FEFF3030FDFF2D2D
- FDFF383CFCFF4F5DFCFF1F25FAFF0000F7FF0000000000000000000000000000
- 0000000000000000FFFF262BFFFF5C69FFFF5B68FFFF5A67FEFF5865FEFF5663
- FEFF5461FEFF2227FCFF0000FBFF000000000000000000000000000000000000
- 000000000000000000000000FFFF0000FFFF0000FFFF0000FFFF0000FDFF0000
- FDFF0000FDFF0000FDFF00000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000
- }
- OnClick = btnClearRandomClick
- ShowHint = True
- ParentShowHint = False
- end
- object btnRandomPresetSave: TSpeedButton
- AnchorSideTop.Control = cbRandomPreset
- AnchorSideRight.Control = btnRandomPresetDelete
- Left = 160
- Height = 22
- Hint = 'Save Preset'
- Top = 140
- Width = 22
- Anchors = [akTop, akRight]
- BorderSpacing.Right = 4
- Glyph.Data = {
- 36040000424D3604000000000000360000002800000010000000100000000100
- 2000000000000004000064000000640000000000000000000000000000000000
- 000000000000000000000000000000000000BA6833FFC38458FFD38B68FFE18F
- 70FFDC8D6CFFDA8B6DFFD78A6EFFCD8B6CFFAB6D44FFA65F2EFF00000000BA65
- 30FFBB6631FFBA6630FFBA6630FFBA6530FFC68355FFEFCEBAFFDDFFFFFF87EE
- C7FFA2F4D7FFA2F6D7FF8CEEC7FFE0FFFFFFDDA285FFAB6A3EFFBC6933FFF8F1
- EAFFF7ECDFFFF6EADEFFF6EADCFFF6EADCFFC37F51FFEFB69AFFEAF3E8FF51BF
- 84FF6FC998FF71C999FF54BF84FFE4F4E9FFDD9C7BFFAA693AFFBF7138FFF5EB
- DFFFFDBF68FFFBBE65FFFCBE64FFFCBE64FFC48154FFEAB697FFF3F3EAFFEDF1
- E6FFEFF1E6FFEFF0E6FFEDF1E5FFF3F5EDFFD59C79FFB07044FFC1783CFFF7ED
- E3FFFDC26EFFFFD79EFFFFD69BFFFFD798FFC98B61FFE6B592FFE2A781FFE1A7
- 81FFDEA37DFFDCA17BFFDB9F79FFD99E77FFD49A73FFBB7E57FFC47C40FFF7F0
- E6FFF8B455FFF7B554FFF8B453FFF8B253FFCA8D65FFEAB899FFDDA57EFFDDA6
- 80FFDBA37CFFD9A07AFFD9A079FFD89F78FFD89E78FFBF845DFFC58245FFF8F2
- EBFFFEE7D6FFFDE7D6FFFDE7D6FFFDE6D5FFC8885DFFEFBFA1FFFDFCFAFFFEFC
- FBFFFEFDFDFFFEFDFCFFFDFBFAFFFDFCFBFFDDA885FFC17F53FFC68447FFF9F3
- ECFFFEE8D6FFFDE7D6FFFDE7D6FFFDE7D5FFC7865BFFEFC09EFFFFFFFFFFCC93
- 6EFFFFFFFFFFFFFFFFFFFFFBF7FFFFF8F1FFE4AF8CFFC78A61FFC68849FFF9F4
- EDFFFEE8D8FFFEE8D7FFFEE7D6FFFDE5D3FFCC8D65FFF3CDB0FFFFFFFFFFE3C7
- B3FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEABFA1FFC98960FFC6884AFFF9F4
- EFFFFEE7D7FFFDE7D5FFFDE6D4FFFCE6D2FFD4976EFFD49E7BFFD09871FFD6A4
- 82FFCD8E68FFCD9069FFD09A75FFD19973FFC88B62FF00000000C6894BFFF9F4
- F0FFFCE6D3FFFDE7D3FFFCE4D1FFFBE3CDFFFAE0C8FFF8DCC2FFF5D6BBFFF3D4
- B5FFF1D2B3FFF8F4F0FFC48246FF000000000000000000000000C6894BFFF9F5
- F1FFFCE3CFFFFCE4CFFFFCE3CDFFFAE1CAFFF9DDC4FFF6D9BCFFF4E9DFFFF7F2
- ECFFFBF7F3FFF5EFE9FFC27E45FF000000000000000000000000C6894CFFF9F5
- F1FFFCE3CDFFFBE3CDFFFBE2CBFFF9E0C8FFF8DCC2FFF5D6BAFFFDFBF8FFFCE6
- CDFFFAE5C9FFE2B684FFBF7942FF000000000000000000000000C5884BFFFAF6
- F2FFFAE0C7FFFBE2C9FFFBE0C8FFF9DFC5FFF8DBC1FFF4D6B8FFFFFBF8FFF6D8
- B4FFE1B07DFFDB9264FF00000000000000000000000000000000C48549FFF7F2
- ECFFF8F4EEFFF8F3EDFFF8F3EDFFF8F3EDFFF8F2ECFFF7F2ECFFF2E6D7FFE2B2
- 7DFFDB9465FF000000000000000000000000000000000000000000000000C88B
- 4DFFC88C4FFFC88C4FFFC88C4FFFC88D4FFFC98C4FFFC78B4FFFC5894BFFC476
- 3BFF000000000000000000000000000000000000000000000000
- }
- OnClick = btnRandomPresetSaveClick
- ShowCaption = False
- ShowHint = True
- ParentShowHint = False
- end
- object btnRandomPresetDelete: TSpeedButton
- AnchorSideTop.Control = btnRandomPresetSave
- AnchorSideRight.Control = gbRandom
- AnchorSideRight.Side = asrBottom
- Left = 186
- Height = 22
- Hint = 'Delete Preset'
- Top = 140
- Width = 22
- Anchors = [akTop, akRight]
- BorderSpacing.Right = 4
- Glyph.Data = {
- 36040000424D3604000000000000360000002800000010000000100000000100
- 2000000000000004000064000000640000000000000000000000000000000000
- 0000BA6530FFBB6631FFBA6630FFBA6630FFBA6630FFBA6530FFBA652FFFB965
- 2EFF6E5E76FF1949A8FF0542BBFF1348ADFF394E8FFF0000000000000000BC69
- 33FFF8F1EAFFF7ECDFFFF6EBDEFFF6EADEFFF6EADCFFF6EADCFFFAF3EBFF8AA5
- D7FF2866CAFF2177E6FF0579EAFF0164DDFF064DBBFF0000000000000000BF71
- 38FFF5EBDFFFFDBF68FFFCBD67FFFBBE65FFFCBE64FFFCBE64FFFCBD62FF1E52
- B0FF639DF4FF187FFFFF0076F8FF0076EEFF0368E1FF0345B9FF00000000C178
- 3CFFF7EDE3FFFDC26EFFFFD8A0FFFFD79EFFFFD69BFFFFD798FFFFD696FF0543
- BCFFAECDFEFFFFFFFFFFFFFFFFFFFFFFFFFF187FEFFF0442BCFF00000000C47C
- 40FFF7F0E6FFF8B455FFF7B456FFF7B554FFF8B453FFF8B253FFF7B352FF2453
- ABFF8DB5F6FF4D92FFFF1177FFFF2186FFFF408AEBFF0344B9FF00000000C580
- 42FFF8F1E8FFFEE5D5FFFDE5D3FFFDE5D3FFFCE5D3FFFCE5D3FFFCE4D1FF94A1
- C9FF3D76D1FF8DB5F7FFB8D6FEFF72A8F5FF2F6BC9FF0000000000000000C582
- 45FFF8F2EBFFFEE7D6FFFDE7D6FFFDE7D6FFFDE7D6FFFDE6D5FFFDE5D3FFFCE4
- D1FF94A1C9FF2A5EC1FF0543BCFF1F59BFFF686279FF0000000000000000C684
- 47FFF9F3ECFFFEE8D6FFFEE8D7FFFDE7D6FFFDE7D6FFFDE7D5FFFDE5D3FFFBE4
- D0FFFBE3CCFFFADFC7FFFADFC6FFFAF2EAFFC68042FF0000000000000000C688
- 49FFF9F4EDFFFEE8D8FFFEE8D8FFFEE8D7FFFEE7D6FFFDE5D3FFFCE4D1FFFBE1
- CCFFFAE0C7FFF9DDC3FFF8DCC2FFFAF4EDFFC68245FF0000000000000000C688
- 4AFFF9F4EFFFFEE7D7FFFDE7D6FFFDE7D5FFFDE6D4FFFCE6D2FFFBE1CCFFFADF
- C7FFF8DCC2FFF6DABDFFF6D8BBFFFAF4EFFFC68346FF0000000000000000C689
- 4BFFF9F4F0FFFCE6D3FFFCE6D4FFFDE7D3FFFCE4D1FFFBE3CDFFFAE0C8FFF8DC
- C2FFF5D6BBFFF3D4B5FFF1D2B3FFF8F4F0FFC48246FF0000000000000000C689
- 4BFFF9F5F1FFFCE3CFFFFBE4D0FFFCE4CFFFFCE3CDFFFAE1CAFFF9DDC4FFF6D9
- BCFFF4E9DFFFF7F2ECFFFBF7F3FFF5EFE9FFC27E45FF0000000000000000C689
- 4CFFF9F5F1FFFCE3CDFFFBE3CEFFFBE3CDFFFBE2CBFFF9E0C8FFF8DCC2FFF5D6
- BAFFFDFBF8FFFCE6CDFFFAE5C9FFE2B684FFBF7942FF0000000000000000C588
- 4BFFFAF6F2FFFAE0C7FFFBE1C9FFFBE2C9FFFBE0C8FFF9DFC5FFF8DBC1FFF4D6
- B8FFFFFBF8FFF6D8B4FFE1B07DFFDB9264FF000000000000000000000000C485
- 49FFF7F2ECFFF8F4EEFFF8F4EDFFF8F3EDFFF8F3EDFFF8F3EDFFF8F2ECFFF7F2
- ECFFF2E6D7FFE2B27DFFDB9465FF000000000000000000000000000000000000
- 0000C88B4DFFC88C4FFFC88C4FFFC88C4FFFC88C4FFFC88D4FFFC98C4FFFC78B
- 4FFFC5894BFFC4763BFF00000000000000000000000000000000
- }
- OnClick = btnRandomPresetDeleteClick
- ShowCaption = False
- ShowHint = True
- ParentShowHint = False
- end
- object vdtRandom: TVirtualDrawTree
- Tag = 1
- AnchorSideLeft.Control = gbRandom
- AnchorSideTop.Control = btnAddRandom
- AnchorSideTop.Side = asrBottom
- AnchorSideRight.Control = gbRandom
- AnchorSideRight.Side = asrBottom
- AnchorSideBottom.Control = cbRandomPreset
- Cursor = 63
- Left = 4
- Height = 112
- Top = 24
- Width = 204
- Anchors = [akTop, akLeft, akRight, akBottom]
- BorderSpacing.Left = 4
- BorderSpacing.Top = 2
- BorderSpacing.Right = 4
- BorderSpacing.Bottom = 4
- DefaultNodeHeight = 44
- DragType = dtVCL
- Header.AutoSizeIndex = 0
- Header.Columns = <
- item
- Position = 0
- Text = 'ID'
- end
- item
- Position = 1
- Text = 'Tile'
- Width = 44
- end
- item
- Position = 2
- Text = 'Name'
- Width = 100
- end>
- Header.DefaultHeight = 17
- Header.Options = [hoColumnResize, hoDrag, hoVisible]
- Header.ParentFont = True
- Header.Style = hsFlatButtons
- TabOrder = 0
- TreeOptions.AutoOptions = [toAutoDropExpand, toAutoScroll, toAutoScrollOnExpand, toAutoTristateTracking, toAutoDeleteMovedNodes]
- TreeOptions.PaintOptions = [toHideFocusRect, toShowButtons, toShowDropmark, toThemeAware, toUseBlendedImages]
- TreeOptions.SelectionOptions = [toFullRowSelect, toMultiSelect]
- OnClick = vdtRandomClick
- OnDragOver = vdtRandomDragOver
- OnDragDrop = vdtRandomDragDrop
- OnDrawNode = vdtTilesDrawNode
- OnLoadNode = vdtRandomLoadNode
- OnSaveNode = vdtRandomSaveNode
- OnUpdating = vdtRandomUpdating
- end
- object cbRandomPreset: TComboBox
- AnchorSideLeft.Control = gbRandom
- AnchorSideRight.Control = btnRandomPresetSave
- AnchorSideBottom.Control = gbRandom
- AnchorSideBottom.Side = asrBottom
- Left = 4
- Height = 21
- Top = 140
- Width = 152
- Anchors = [akLeft, akRight, akBottom]
- BorderSpacing.Left = 4
- BorderSpacing.Right = 4
- BorderSpacing.Bottom = 4
- ItemHeight = 13
- OnChange = cbRandomPresetChange
- Sorted = True
- Style = csDropDownList
- TabOrder = 1
- end
- end
- object spTileList: TSplitter
- AnchorSideLeft.Control = tsTiles
- AnchorSideRight.Control = tsTiles
- AnchorSideRight.Side = asrBottom
- Cursor = crVSplit
- Left = 0
- Height = 5
- Top = 290
- Width = 216
- Align = alNone
- Anchors = [akLeft, akRight, akBottom]
- ResizeAnchor = akBottom
- end
- object edSearchID: TEdit
- AnchorSideRight.Control = vdtTiles
- AnchorSideRight.Side = asrBottom
- AnchorSideBottom.Control = vdtTiles
- AnchorSideBottom.Side = asrBottom
- Left = 108
- Height = 21
- Hint = 'Append S or T to restrict the search to Statics or Terrain.'
- Top = 261
- Width = 96
- Anchors = [akRight, akBottom]
- BorderSpacing.Right = 8
- BorderSpacing.Bottom = 8
- CharCase = ecUppercase
- OnExit = edSearchIDExit
- OnKeyPress = edSearchIDKeyPress
- ParentShowHint = False
- ShowHint = True
- TabOrder = 2
- Visible = False
- end
- object edFilter: TEdit
- AnchorSideLeft.Control = lblFilter
- AnchorSideTop.Control = lblFilter
- AnchorSideTop.Side = asrBottom
- AnchorSideRight.Control = tsTiles
- AnchorSideRight.Side = asrBottom
- Left = 75
- Height = 21
- Top = 21
- Width = 125
- Anchors = [akTop, akLeft, akRight]
- BorderSpacing.Right = 16
- OnEditingDone = edFilterEditingDone
- TabOrder = 4
- end
- object cbStatics: TCheckBox
- AnchorSideLeft.Control = cbTerrain
- AnchorSideLeft.Side = asrCenter
- AnchorSideTop.Control = cbTerrain
- AnchorSideTop.Side = asrBottom
- Left = 5
- Height = 19
- Top = 27
- Width = 53
- Caption = 'Statics'
- Checked = True
- OnChange = cbStaticsChange
- State = cbChecked
- TabOrder = 5
- end
- object cbTerrain: TCheckBox
- AnchorSideLeft.Control = tsTiles
- AnchorSideTop.Control = tsTiles
- Left = 4
- Height = 19
- Top = 8
- Width = 55
- BorderSpacing.Left = 4
- BorderSpacing.Top = 8
- Caption = 'Terrain'
- Checked = True
- OnChange = cbTerrainChange
- State = cbChecked
- TabOrder = 6
- end
- end
- object tsClients: TTabSheet
- Caption = 'Clients'
- ClientHeight = 478
- ClientWidth = 216
- object lbClients: TListBox
- Left = 0
- Height = 478
- Top = 0
- Width = 216
- Align = alClient
- ItemHeight = 0
- OnDblClick = mnuGoToClientClick
- PopupMenu = pmClients
- Sorted = True
- TabOrder = 0
- end
- end
- object tsLocations: TTabSheet
- Caption = 'Locations'
- ClientHeight = 478
- ClientWidth = 216
- object btnClearLocations: TSpeedButton
- AnchorSideLeft.Control = btnDeleteLocation
- AnchorSideLeft.Side = asrBottom
- AnchorSideTop.Control = btnDeleteLocation
- Left = 125
- Height = 22
- Hint = 'Clear'
- Top = 452
- Width = 23
- BorderSpacing.Left = 4
- Glyph.Data = {
- 36040000424D3604000000000000360000002800000010000000100000000100
- 2000000000000004000064000000640000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 000000000000000000000000F1FF0000F1FF0000F1FF0000F1FF0000EFFF0000
- EFFF0000EDFF0000EDFF00000000000000000000000000000000000000000000
- 0000000000000000F5FF1A20F5FF3C4CF9FF3A49F8FF3847F8FF3545F8FF3443
- F7FF3242F7FF141BF1FF0000EDFF000000000000000000000000000000000000
- 00000000F7FF1D23F9FF4453FAFF2429F9FF1212F7FF0F0FF6FF0C0CF5FF0909
- F5FF161BF5FF3343F7FF141BF1FF0000EDFF0000000000000000000000000000
- F9FF1F25FAFF4A58FBFF4247FBFFC9C9FDFF3B3BF9FF1313F7FF1010F6FF3333
- F7FFC5C5FDFF3035F7FF3444F7FF141BF2FF0000EDFF00000000000000000000
- FBFF4F5DFDFF3237FBFFCBCBFEFFF2F2FFFFEBEBFEFF3B3BF9FF3939F8FFEAEA
- FEFFF1F1FEFFC5C5FDFF181DF6FF3343F7FF0000EFFF00000000000000000000
- FDFF525FFDFF2828FCFF4747FCFFECECFFFFF2F2FFFFECECFFFFECECFEFFF1F1
- FFFFEAEAFEFF3434F7FF0B0BF5FF3545F8FF0000EFFF00000000000000000000
- FDFF5562FEFF2C2CFDFF2929FCFF4848FCFFEDEDFFFFF2F2FFFFF2F2FFFFECEC
- FEFF3A3AF9FF1212F7FF0F0FF6FF3848F8FF0000F1FF00000000000000000000
- FDFF5764FEFF3030FDFF2D2DFDFF4B4BFCFFEDEDFFFFF2F2FFFFF2F2FFFFECEC
- FFFF3D3DF9FF1616F8FF1313F7FF3C4BF8FF0000F1FF00000000000000000000
- FFFF5A67FEFF3333FEFF5050FDFFEDEDFFFFF3F3FFFFEDEDFFFFEDEDFFFFF2F2
- FFFFECECFEFF3E3EFAFF1717F8FF3F4EF9FF0000F1FF00000000000000000000
- FFFF5B68FFFF4347FEFFCFCFFFFFF3F3FFFFEDEDFFFF4C4CFCFF4A4AFCFFECEC
- FFFFF2F2FFFFCACAFEFF2A2FFAFF4251FAFF0000F3FF00000000000000000000
- FFFF262BFFFF5D6AFFFF585BFFFFCFCFFFFF5252FEFF2F2FFDFF2C2CFDFF4B4B
- FCFFCCCCFEFF484CFBFF4957FBFF1D23F9FF0000F5FF00000000000000000000
- 00000000FFFF262BFFFF5D6AFFFF4347FFFF3434FEFF3232FEFF3030FDFF2D2D
- FDFF383CFCFF4F5DFCFF1F25FAFF0000F7FF0000000000000000000000000000
- 0000000000000000FFFF262BFFFF5C69FFFF5B68FFFF5A67FEFF5865FEFF5663
- FEFF5461FEFF2227FCFF0000FBFF000000000000000000000000000000000000
- 000000000000000000000000FFFF0000FFFF0000FFFF0000FFFF0000FDFF0000
- FDFF0000FDFF0000FDFF00000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000
- }
- OnClick = btnClearLocationsClick
- ShowHint = True
- ParentShowHint = False
- end
- object btnDeleteLocation: TSpeedButton
- AnchorSideLeft.Control = tsLocations
- AnchorSideLeft.Side = asrCenter
- AnchorSideBottom.Control = tsLocations
- AnchorSideBottom.Side = asrBottom
- Left = 98
- Height = 22
- Hint = 'Delete'
- Top = 452
- Width = 23
- Anchors = [akLeft, akBottom]
- BorderSpacing.Bottom = 4
- Glyph.Data = {
- 36040000424D3604000000000000360000002800000010000000100000000100
- 2000000000000004000064000000640000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000003853BEFF3551BDFF304BBCFF2E4E
- B8FF000000000000000000000000000000000000000000000000000000000000
- 000000000000000000004255C6FF3C52CCFF757AE8FF8F92EEFF8F92EEFF7178
- E4FF334DC1FF2B4AB7FF00000000000000000000000000000000000000000000
- 0000000000004959CBFF5C65E0FFA1A6F5FF7E86EFFF5B63E9FF595DE7FF7D84
- EEFF9EA0F4FF515DD7FF2B4AB7FF000000000000000000000000000000000000
- 00005361CFFF616BE3FFA1ACF5FF545FECFF505CEAFF4D59E9FF4E59E6FF4C56
- E6FF5056E6FF9EA2F4FF5460D6FF2A4AB8FF0000000000000000000000000000
- 00004B56DBFFA2ABF6FF5664F0FF5266EEFF4D59E9FF4D59E9FF4D59E9FF4D59
- E9FF4C58E6FF525AE6FF9FA3F5FF3450C4FF0000000000000000000000005C62
- D7FF818CEEFF7E91F7FF5D73F3FF4D59E9FF4D59E9FF4D59E9FF4D59E9FF4D59
- E9FF4D59E9FF4F5BE9FF7B83F0FF757BE2FF2E4BBAFF00000000000000005F63
- DAFFA1ABF7FF7086F8FF6882F6FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
- FFFFFFFFFFFF4D59E9FF5C66EAFF969CF1FF3250BCFF00000000000000006469
- DBFFAFB9F9FF7F93FAFF7085F0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
- FFFFFFFFFFFF4D59E9FF5E6AEEFF969DF1FF364FBEFF0000000000000000676A
- DEFFA5AFF5FF9DABFAFF778CF0FF545FECFF545FECFF545FECFF545FECFF545F
- ECFF545FECFF6377F2FF818EF4FF787FE9FF3A53C0FF00000000000000000000
- 00007D83EAFFCDD4FCFF8B9DFAFF7E93F7FF758AEEFF6C84F6FF6C84F6FF6C84
- F6FF6C84F6FF6379F3FFA4AFF8FF3E4FD0FF0000000000000000000000000000
- 00006A69E0FFA3A7F3FFD4DBFDFF879AFAFF7F91F0FF7A8EF1FF7F94F8FF7E92
- F9FF768CF8FFA8B6F8FF636EE3FF4557C7FF0000000000000000000000000000
- 0000000000006A69E0FFAAADF2FFD8DCFDFFAEBAFAFF91A3FAFF8B9DFAFF9CA9
- FBFFBAC7FCFF707BE9FF4C5BCCFF000000000000000000000000000000000000
- 000000000000000000006A6ADFFF8E93EDFFBEC3F8FFCCD3F9FFC4CBF9FFAAB4
- F4FF6670E2FF535ED1FF00000000000000000000000000000000000000000000
- 000000000000000000000000000000000000686ADDFF6364DCFF6164DAFF5D63
- D9FF000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000
- }
- OnClick = btnDeleteLocationClick
- ShowHint = True
- ParentShowHint = False
- end
- object btnAddLocation: TSpeedButton
- AnchorSideTop.Control = btnDeleteLocation
- AnchorSideRight.Control = btnDeleteLocation
- Left = 71
- Height = 22
- Hint = 'Add'
- Top = 452
- Width = 23
- Anchors = [akTop, akRight]
- BorderSpacing.Right = 4
- Glyph.Data = {
- 36040000424D3604000000000000360000002800000010000000100000000100
- 2000000000000004000064000000640000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000003A8C44FF368940FF32873CFF2F84
- 37FF000000000000000000000000000000000000000000000000000000000000
- 00000000000000000000459653FF419950FF7DC28FFF96D0A6FF96CFA6FF78BE
- 89FF368D42FF2C8134FF00000000000000000000000000000000000000000000
- 0000000000004D9C5DFF64B478FFA8DBB5FF87CC98FF66BC7DFF64BA7CFF86CB
- 98FFA5D9B4FF58AA6BFF2C8134FF000000000000000000000000000000000000
- 000056A366FF6AB97DFFA8DBB2FF60BC77FF5CBA73FF59B870FF59B56FFF58B5
- 6FFF5BB774FFA5D9B3FF5AAA6CFF2C8234FF0000000000000000000000000000
- 000053AB68FFAADDB4FF64C179FF5FBE71FF60BC77FFFFFFFFFFFFFFFFFF59B8
- 70FF58B56EFF5CB774FFA6DAB4FF388F43FF00000000000000000000000061AC
- 75FF8ACC98FF89D396FF6BC67AFF63C170FF55AB65FFFFFFFFFFFFFFFFFF59B8
- 70FF59B870FF5BB972FF85CC97FF7BBE8DFF308539FF000000000000000065AF
- 7AFFA9DDB3FF7DCF8AFF75CC81FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
- FFFFFFFFFFFF59B870FF67BE7DFF9CD4ABFF34883DFF000000000000000069B2
- 7EFFB6E2BEFF8BD597FF7AC986FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
- FFFFFFFFFFFF59B870FF69C17EFF9DD4AAFF388B42FF00000000000000006DB5
- 83FFACDDB6FFA6DFAFFF81CB8CFF7CC986FF6EBD79FFFFFFFFFFFFFFFFFF5BAC
- 6AFF60BC77FF5CBA73FF8BD199FF80C592FF3C8E47FF00000000000000000000
- 000085C797FFD2EED7FF95D9A0FF8AD394FF7FC889FFFFFFFFFFFFFFFFFF79CD
- 85FF6BC37CFF6FC77EFFACDFB5FF459E57FF0000000000000000000000000000
- 000070B887FFAADAB7FFD8F1DCFF92D89DFF88CD93FF84CC8EFF8BD496FF8AD4
- 95FF83D28EFFAFE0B7FF6BB97DFF489856FF0000000000000000000000000000
- 00000000000070B887FFAFDCBBFFDCF2E0FFB6E4BDFF9BDBA5FF96D9A0FFA5DF
- AFFFC0E8C5FF79C28AFF509E5FFF000000000000000000000000000000000000
- 0000000000000000000071B887FF94CEA4FFC3E6CBFFCFEBD4FFC9E9CEFFAFDD
- B8FF6DB97FFF58A569FF00000000000000000000000000000000000000000000
- 0000000000000000000000000000000000006EB684FF6AB380FF67B17CFF63AE
- 77FF000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000
- }
- OnClick = btnAddLocationClick
- ShowHint = True
- ParentShowHint = False
- end
- object vstLocations: TVirtualStringTree
- AnchorSideLeft.Control = tsLocations
- AnchorSideTop.Control = tsLocations
- AnchorSideRight.Control = tsLocations
- AnchorSideRight.Side = asrBottom
- AnchorSideBottom.Control = btnDeleteLocation
- Cursor = 63
- Left = 4
- Height = 444
- Top = 4
- Width = 208
- Anchors = [akTop, akLeft, akRight, akBottom]
- BorderSpacing.Around = 4
- DefaultText = 'Node'
- Header.AutoSizeIndex = 1
- Header.Columns = <
- item
- Position = 0
- Text = 'Coords'
- Width = 75
- end
- item
- Position = 1
- Text = 'Name'
- Width = 129
- end>
- Header.DefaultHeight = 17
- Header.Options = [hoAutoResize, hoColumnResize, hoDrag, hoVisible]
- Header.ParentFont = True
- Header.Style = hsFlatButtons
- TabOrder = 0
- TreeOptions.AutoOptions = [toAutoScrollOnExpand, toAutoTristateTracking, toAutoDeleteMovedNodes]
- TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toThemeAware, toUseBlendedImages]
- TreeOptions.SelectionOptions = [toFullRowSelect]
- OnDblClick = vstLocationsDblClick
- OnFreeNode = vstLocationsFreeNode
- OnGetText = vstLocationsGetText
- OnLoadNode = vstLocationsLoadNode
- OnNewText = vstLocationsNewText
- OnSaveNode = vstLocationsSaveNode
- end
- end
- end
- object tbMain: TToolBar
- Left = 0
- Height = 24
- Top = 0
- Width = 755
- Caption = 'tbMain'
- Images = ImageList1
- ParentShowHint = False
- ShowHint = True
- TabOrder = 2
- object tbDisconnect: TToolButton
- Left = 1
- Hint = 'Disconnect'
- Top = 2
- Caption = 'Disconnect'
- ImageIndex = 0
- OnClick = mnuDisconnectClick
- ParentShowHint = False
- ShowHint = True
- end
- object tbSeparator1: TToolButton
- Left = 24
- Top = 2
- Width = 5
- Style = tbsDivider
- end
- object tbSelect: TToolButton
- Left = 29
- Top = 2
- Action = acSelect
- Grouped = True
- ParentShowHint = False
- ShowHint = True
- Style = tbsCheck
- end
- object tbDrawTile: TToolButton
- Left = 52
- Top = 2
- Action = acDraw
- Grouped = True
- ParentShowHint = False
- ShowHint = True
- Style = tbsCheck
- end
- object tbMoveTile: TToolButton
- Left = 75
- Top = 2
- Action = acMove
- Grouped = True
- ParentShowHint = False
- ShowHint = True
- Style = tbsCheck
- end
- object tbElevateTile: TToolButton
- Left = 98
- Top = 2
- Action = acElevate
- Grouped = True
- ParentShowHint = False
- ShowHint = True
- Style = tbsCheck
- end
- object tbDeleteTile: TToolButton
- Left = 121
- Top = 2
- Action = acDelete
- Grouped = True
- ParentShowHint = False
- ShowHint = True
- Style = tbsCheck
- end
- object tbSetHue: TToolButton
- Left = 144
- Top = 2
- Action = acHue
- Grouped = True
- ParentShowHint = False
- ShowHint = True
- Style = tbsCheck
- end
- object tbSeparator3: TToolButton
- Left = 195
- Top = 2
- Width = 5
- Caption = 'tbSeparator3'
- Style = tbsDivider
- end
- object tbBoundaries: TToolButton
- Left = 200
- Top = 2
- Action = acBoundaries
- ParentShowHint = False
- ShowHint = True
- end
- object tbSeparator4: TToolButton
- Left = 269
- Top = 2
- Width = 5
- Caption = 'tbSeparator4'
- Style = tbsDivider
- end
- object tbTerrain: TToolButton
- Left = 274
- Hint = 'Show Terrain'
- Top = 2
- Caption = 'Terrain'
- Down = True
- ImageIndex = 10
- OnClick = tbTerrainClick
- ParentShowHint = False
- ShowHint = True
- Style = tbsCheck
- end
- object tbStatics: TToolButton
- Left = 297
- Hint = 'Show Statics'
- Top = 2
- Caption = 'Statics'
- Down = True
- ImageIndex = 11
- OnClick = tbStaticsClick
- ParentShowHint = False
- ShowHint = True
- Style = tbsCheck
- end
- object tbSeparator5: TToolButton
- Left = 424
- Top = 2
- Width = 5
- Caption = 'tbSeparator5'
- Style = tbsDivider
- end
- object tbRadarMap: TToolButton
- Left = 429
- Hint = 'Radar Map'
- Top = 2
- Caption = 'Radar Map'
- ImageIndex = 13
- OnClick = tbRadarMapClick
- ParentShowHint = False
- ShowHint = True
- end
- object tbVirtualLayer: TToolButton
- Left = 223
- Top = 2
- Action = acVirtualLayer
- end
- object tbFilter: TToolButton
- Left = 246
- Top = 2
- Action = acFilter
- OnMouseMove = tbFilterMouseMove
- Style = tbsCheck
- end
- object tbFlat: TToolButton
- Left = 389
- Top = 2
- Action = acFlat
- DropdownMenu = pmFlatViewSettings
- Style = tbsDropDown
- end
- object tbNoDraw: TToolButton
- Left = 320
- Top = 2
- Action = acNoDraw
- Style = tbsCheck
- end
- object tbSeparator2: TToolButton
- Left = 167
- Top = 2
- Width = 5
- Caption = 'tbSeparator2'
- Style = tbsDivider
- end
- object tbUndo: TToolButton
- Left = 172
- Top = 2
- Action = acUndo
- end
- object tbLightlevel: TToolButton
- Left = 366
- Top = 2
- Action = acLightlevel
- end
- object tbWalkable: TToolButton
- Left = 343
- Top = 2
- Action = acWalkable
- Style = tbsCheck
- end
- end
- object pnlChatHeader: TPanel
- AnchorSideLeft.Control = pnlChat
- AnchorSideTop.Control = spChat
- AnchorSideTop.Side = asrBottom
- AnchorSideRight.Control = pnlChat
- AnchorSideRight.Side = asrBottom
- AnchorSideBottom.Control = spChat
- Left = 224
- Height = 22
- Top = 392
- Width = 531
- Anchors = [akLeft, akRight, akBottom]
- BevelInner = bvRaised
- BevelOuter = bvLowered
- ClientHeight = 22
- ClientWidth = 531
- TabOrder = 3
- object lblChatHeaderCaption: TLabel
- Cursor = crHandPoint
- Left = 10
- Height = 18
- Top = 2
- Width = 100
- Align = alLeft
- BorderSpacing.Left = 8
- Caption = 'Chat and Messages'
- Layout = tlCenter
- ParentColor = False
- OnClick = lblChatHeaderCaptionClick
- OnMouseEnter = lblChatHeaderCaptionMouseEnter
- OnMouseLeave = lblChatHeaderCaptionMouseLeave
- end
- end
- object pnlChat: TPanel
- AnchorSideLeft.Control = pcLeft
- AnchorSideLeft.Side = asrBottom
- AnchorSideTop.Control = spChat
- AnchorSideTop.Side = asrBottom
- AnchorSideRight.Control = Owner
- AnchorSideRight.Side = asrBottom
- AnchorSideBottom.Control = pnlBottom
- Left = 224
- Height = 109
- Top = 419
- Width = 531
- Anchors = [akTop, akLeft, akRight, akBottom]
- BevelOuter = bvNone
- ClientHeight = 109
- ClientWidth = 531
- TabOrder = 4
- Visible = False
- object vstChat: TVirtualStringTree
- Cursor = 63
- Left = 0
- Height = 88
- Top = 0
- Width = 531
- Align = alClient
- DefaultText = 'Node'
- Header.AutoSizeIndex = 2
- Header.Columns = <
- item
- Position = 0
- Text = 'Time'
- Width = 75
- end
- item
- Position = 1
- Text = 'Sender'
- Width = 75
- end
- item
- Position = 2
- Text = 'Message'
- Width = 377
- end>
- Header.DefaultHeight = 17
- Header.MainColumn = 2
- Header.Options = [hoAutoResize, hoColumnResize, hoDrag, hoVisible]
- Header.ParentFont = True
- Header.Style = hsFlatButtons
- TabOrder = 0
- TreeOptions.AutoOptions = [toAutoDropExpand, toAutoScroll, toAutoScrollOnExpand, toAutoTristateTracking, toAutoDeleteMovedNodes]
- TreeOptions.MiscOptions = [toFullRepaintOnResize, toInitOnSave, toToggleOnDblClick, toWheelPanning]
- TreeOptions.PaintOptions = [toHideSelection, toShowButtons, toShowDropmark, toThemeAware, toUseBlendedImages]
- OnClick = vstChatClick
- OnFreeNode = vstChatFreeNode
- OnGetText = vstChatGetText
- OnPaintText = vstChatPaintText
- end
- object edChat: TEdit
- Left = 0
- Height = 21
- Top = 88
- Width = 531
- Align = alBottom
- OnKeyPress = edChatKeyPress
- TabOrder = 1
- end
- end
- object spChat: TSplitter
- AnchorSideLeft.Control = pcLeft
- AnchorSideLeft.Side = asrBottom
- AnchorSideRight.Control = Owner
- AnchorSideRight.Side = asrBottom
- Cursor = crVSplit
- Left = 224
- Height = 5
- Top = 414
- Width = 531
- Align = alNone
- Anchors = [akLeft, akRight, akBottom]
- AutoSnap = False
- ResizeAnchor = akBottom
- Visible = False
- end
- object oglGameWindow: TOpenGLControl
- AnchorSideLeft.Control = pcLeft
- AnchorSideLeft.Side = asrBottom
- AnchorSideTop.Control = tbMain
- AnchorSideTop.Side = asrBottom
- AnchorSideRight.Control = Owner
- AnchorSideRight.Side = asrBottom
- AnchorSideBottom.Control = pnlChatHeader
- Left = 224
- Height = 368
- Top = 24
- Width = 531
- Anchors = [akTop, akLeft, akRight, akBottom]
- OnDblClick = oglGameWindowDblClick
- OnKeyDown = oglGameWindowKeyDown
- OnMouseDown = oglGameWindowMouseDown
- OnMouseEnter = oglGameWindowMouseEnter
- OnMouseLeave = oglGameWindowMouseLeave
- OnMouseMove = oglGameWindowMouseMove
- OnMouseUp = oglGameWindowMouseUp
- OnMouseWheel = oglGameWindowMouseWheel
- OnPaint = oglGameWindowPaint
- OnResize = oglGameWindowResize
- end
- object MainMenu1: TMainMenu
- Images = ImageList1
- left = 232
- top = 33
- object mnuCentrED: TMenuItem
- Caption = '&CentrED'
- object mnuDisconnect: TMenuItem
- Caption = '&Disconnect'
- Bitmap.Data = {
- 36040000424D3604000000000000360000002800000010000000100000000100
- 200000000000000400006400000064000000000000000000000028415200AB66
- 3CFFA45D38FF2F4F6300509BB50053A3BE007CA9B700BDDADE00DCE4E30088B5
- C20080BCCC005D757F0034383A0034352E004E5F5800313D6200BA7C4AFFBF87
- 5CFFB97E56FFA7623AFFA3D3DD005594AC0060A1B50062A9BE00487E98004165
- 76003C4A48003B4C4700384740001A231E000102020000000000C4885AFFC692
- 68FFCDA280FFC59670FFB67B53FFAB6A46FFA35E3DFF9C5235FF91442CFF2737
- 39000B0F0D0000000000293B48002E47550028354300324953003D6A9500C68C
- 60FFD1A683FFCC9F7BFFCB9E7BFFC79974FFC3926CFFBE8D65FFA86945FF2C3A
- 42002A3138002D3A420074B9C8007FC5D5005F99AE0076B4C5002F3B35003B49
- 4900D0A17CFFD7AE8FFFC9976FFFC38F66FFBD885CFFC08C64FFBC8861FF8351
- 3CFF4F91AB0054889C0043718A004E6974003D4A4B0045779600000000000304
- 0400D7A682FFDCB699FFD0A17DFFCB9A73FFCFA482FFC79974FF896C58FF8787
- 87FF4E4E4EFF3D5F7B003A5C8600364E63002C2D2E00566E72003E7A8E004C95
- B000DDAE8CFFE2BEA4FFD8AB89FFD9B394FFCF9F7AFFA37858FF939393FFA9A9
- A9FF555555FF3C4E51002C322E002C3331001B1F1C00000000003F85B2004D9C
- C100E3B493FFE8C6ADFFE3C0A6FFDBB08FFFB48D71FF2F353300717171FF6767
- 67FF161B1700000000008F432BFF8B4128FF0203030016292F002E3A48003447
- 5200E7BB9CFFE8C0A3FFE5BFA3FFB59D8AFFAEAEAEFF838383FF000000000000
- 0000060A0B009F5734FFAD724CFFA25F3FFF8E4129FF365C8300020303000001
- 010000000000EABE9FFFCEAF9AFFB7B7B7FFBCBCBCFF8C8C8CFF496F7B00498D
- A600AE6D40FFBB835CFFC08F67FFBB8A60FF995033FF32424E00000000000000
- 00000000000004070700101819009E9E9EFF999999FF3C5B6A002A323500C386
- 57FFC9976FFFCB9F7CFFBC8559FFC3926BFFA6633EFF39434500000000004566
- A1004B697900545B8F004E5089003C40570029375400D9A781FFD9AB88FFDAB2
- 94FFD8B092FFCB9972FFC49068FFC89C78FFB2724AFF00000000000000000000
- 00000000000000000000000000000000000000000000E2B18FFFE7C1A8FFE0BA
- 9FFFD8AC8BFFD2A582FFCE9D77FFD1A684FFBE865CFF00000000000000000000
- 0000000000000000000000000000000000000000000000000000E8C0A4FFE9C8
- B0FFE5C3A9FFE1BDA2FFDCB699FFD5AB8AFFD0A482FFB57644FF000000000000
- 0000000000000000000000000000000000000000000000000000ECBEA1FFE7BB
- 9DFFE4B697FFE0B292FFDAAE8FFFDCB598FFCF9F7AFFC38657FFF0A3E30058BA
- 1500187D7C00D063B90000000000000000000000000000000000000000000000
- 0000000000000000000000000000D9A781FFD39E76FF00000000
- }
- ImageIndex = 0
- OnClick = mnuDisconnectClick
- end
- object mnuSeparator1: TMenuItem
- Caption = '-'
- end
- object mnuExit: TMenuItem
- Caption = 'E&xit'
- OnClick = mnuExitClick
- end
- end
- object mnuAdministration: TMenuItem
- Caption = '&Administration'
- object mnuFlush: TMenuItem
- Caption = '&Flush'
- Bitmap.Data = {
- 36040000424D3604000000000000360000002800000010000000100000000100
- 2000000000000004000064000000640000000000000000000000BA6A36FFB969
- 35FFB86935FFB76835FFB56835FFB46734FFB26634FFB06533FFAE6433FFAC63
- 32FFAA6232FFA96132FFA86031FFA76031FFA66031FFA86131FFBA6A35FFEBC6
- ADFFEAC5ADFFFEFBF8FFFEFBF8FFFEFBF8FFFEFBF8FFFEFBF8FFFEFBF8FFFEFB
- F8FFFEFBF8FFFEFBF8FFFEFBF8FFC89A7CFFC79879FFA76031FFBA6B37FFEDCA
- B3FFE0A27AFFFEFAF7FF62C088FF62C088FF62C088FF62C088FF62C088FF62C0
- 88FF62C088FF62C088FFFDF9F6FFCA8D65FFC99B7CFFA76031FFBB6C38FFEECC
- B6FFE1A27AFFFEFAF7FFBFDCC2FFBFDCC2FFBFDCC2FFBFDCC2FFBFDCC2FFBFDC
- C2FFBFDCC2FFBFDCC2FFFDF9F6FFCD9068FFCC9E81FFA86132FFBB6B38FFEFCE
- B8FFE1A279FFFEFAF7FF62C088FF62C088FF62C088FF62C088FF62C088FF62C0
- 88FF62C088FF62C088FFFDF9F6FFCF936AFFCEA384FFAA6132FFBA6A36FFEFD0
- BBFFE2A27AFFFEFBF8FFFEFBF8FFFEFBF8FFFEFBF8FFFEFBF8FFFEFBF8FFFEFB
- F8FFFEFBF8FFFEFBF8FFFEFBF8FFD3966DFFD2A78AFFAB6232FFBB6A36FFF0D2
- BEFFE2A37AFFE2A37AFFE1A37AFFE2A37BFFE1A37BFFE0A178FFDE9F77FFDD9F
- 76FFDC9D74FFD99B72FFD89971FFD69970FFD5AB8EFFAD6333FFBB6A36FFF2D5
- C2FFE3A37AFFE3A37AFFE2A37BFFE2A37BFFE2A47BFFE1A279FFE0A178FFDEA0
- 77FFDE9E75FFDC9D74FFDA9B73FFD99B73FFDAB095FFAF6433FFBB6A36FFF2D8
- C5FFE3A47BFFE3A37AFFE3A47AFFE2A47BFFE2A37BFFE1A37BFFE1A279FFDFA0
- 77FFDE9F76FFDD9E74FFDB9C72FFDC9D74FFDDB59AFFB16534FFBB6B36FFF4D9
- C7FFE6A67DFFC88C64FFC98D65FFC98E67FFCB926CFFCB926DFFCA9069FFC88C
- 65FFC88C64FFC88C64FFC88C64FFDA9C74FFE1BA9FFFB36634FFBB6B36FFF4DC
- C9FFE7A77DFFF9ECE1FFF9ECE1FFF9EDE3FFFCF4EEFFFDFAF7FFFDF7F3FFFAED
- E5FFF7E7DBFFF7E5D9FFF6E5D8FFDEA077FFE4BEA4FFB46734FFBC6B36FFF5DD
- CCFFE7A87EFFFAF0E8FFFAF0E8FFC98D66FFFAF0E9FFFDF8F3FFFEFAF8FFFCF4
- EFFFF9E9DFFFF7E7DBFFF7E5D9FFE0A278FFE7C2A9FFB66835FFBC6B36FFF6DF
- D0FFE8A87EFFFCF6F1FFFCF6F1FFC88C64FFFAF1E9FFFBF4EEFFFDFAF7FFFDF9
- F6FFFAF0E8FFF8E8DDFFF7E6DBFFE1A37AFFEFD5C3FFB76935FFBC6B36FFF6DF
- D1FFE9AA80FFFEFAF6FFFDFAF6FFC88C64FFFBF3EEFFFBF1EAFFFCF6F2FFFEFB
- F8FFFCF6F1FFF9ECE2FFF8E7DBFFEED0BAFFECD0BDFFBB703EFFBC6B36FFF6E0
- D1FFF7E0D1FFFEFBF8FFFEFBF7FFFDF9F6FFFCF5F0FFFAF0EAFFFBF2EDFFFDF9
- F6FFFDFAF7FFFBF1EBFFF8E9DFFFECD0BDFFC9895EFFCECFD100F0A3E300BC6B
- 36FFBC6B36FFBC6B36FFBC6B36FFBB6B36FFBB6B36FFBB6A36FFBB6A36FFBC6C
- 39FFBD6E3BFFBB6D3AFFBB6B38FFBB703EFFCECFD100CECFD100
- }
- ImageIndex = 1
- OnClick = mnuFlushClick
- end
- object mnuShutdown: TMenuItem
- Caption = '&Shutdown'
- Bitmap.Data = {
- 36040000424D3604000000000000360000002800000010000000100000000100
- 2000000000000004000064000000640000000000000000000000000000000000
- 000000000000E8E340000000000000000000080000000000000007CE03000000
- 000003CE0700FFFFFF0000000000000000000000000000000000000000000000
- 00000000000000000000E0000000444BD9FF474FDAFF434BD9FF4048D7FF3E47
- D8FF353ED5FF3E5B6800000000000400000020E44000D4E3400000000000C0FF
- 0700C0FF0700C0FF0700636CE4FF8997FAFF8495FFFF7F90FCFF7D8EFAFF7D8D
- F7FF7D8BF2FF5159DDFFC0FF0700C0FF0700000000000000000000F8FF000000
- 000000F8FF006C75E4FF96A5FAFF5A74FFFF3250FFFF304FFFFF2C49FEFF2542
- FAFF4860F9FF8694F4FF5159DDFF000000000000000000000000000000001800
- 18007981E7FF9FADFBFF6781FFFF405EFFFF405EFFFF3C59FFFF3755FFFF3350
- FFFF2846FDFF4A65FDFF8996F6FF545EDEFF0800000000000000000000007178
- E3FFA2B2FCFF738FFFFF4F70FFFF4F6EFFFF4B69FFFF4664FFFF415EFFFF3C5A
- FFFF3755FFFF2C4BFFFF4E67FFFF8493FAFF4048D8FF38394100000000007D84
- E5FFA6BBFFFF5F7FFFFF5F7EFFFF5A79FFFF5573FFFF506EFFFF4B69FFFF4664
- FFFF415EFFFF3B59FFFF314FFFFF8799FFFF4D55DBFFC0FF070008000000858A
- E6FFABBEFFFF6D8DFFFF6989FFFF6583FFFF5F7EFFFF5A79FFFF5574FFFF506F
- FFFF4B69FFFF4663FFFF3F5CFFFF8A9BFFFF535BDCFF00000000010001008B91
- E7FFB1C4FFFF7698FFFF7393FFFF6E8EFFFF6989FFFF6583FFFF5F7EFFFF5A79
- FFFF5573FFFF4F6EFFFF4867FFFF90A1FFFF5A62DEFF00000000C0FF07009298
- E9FFB8CDFFFF7DA0FFFF7C9DFFFF7899FFFF7393FFFF6E8EFFFF6989FFFF6583
- FFFF607EFFFF5978FFFF4F70FFFF98AAFFFF636AE0FFE000000000000000959A
- EAFFBCCDFCFF9CBBFFFF81A5FFFF81A2FFFF7C9EFFFF7899FFFF7493FFFF6F8E
- FFFF6989FFFF6080FFFF7893FFFF9EADFBFF656CE0FFC0FF070068E140001CE1
- 4000A5ACEFFFC1D1FCFFA0BFFFFF86AAFFFF85A7FFFF81A2FFFF7C9DFFFF7898
- FFFF6F90FFFF85A1FFFFACBAFBFF838BE8FF0000000000000000FEFF7F00FCFF
- 3F0000000000A6ADEEFFC4D4FCFFA3C2FFFF8BAFFFFF89ABFFFF84A7FFFF7EA0
- FFFF91AEFFFFB4C3FBFF8C93EAFF275B68000000000004000000000000000000
- 0000FCFF3F00FEFF7F00A9B1F0FFC2D3FCFFC1D6FFFFBDD1FFFFBBCFFFFFB9CE
- FFFFB7C8FCFF989FEDFFFEFF7F00FEFF7F00FEFF7F00FEFF7F00080000000000
- 00000000000000000000000000009EA3EBFFA0A5ECFF9DA2EBFF9BA0EBFF989E
- EAFF9297E9FF0000000000000000000000000000000000000000F0A3E300183A
- EE00187D7C00B81A1B000851A500225B6800000000000400000088E040003CE0
- 400000000000000000000000000050E040000000000000000000
- }
- ImageIndex = 2
- OnClick = mnuShutdownClick
- end
- object mnuSeparator2: TMenuItem
- Caption = '-'
- end
- object mnuAccountControl: TMenuItem
- Caption = '&Account Management'
- Bitmap.Data = {
- 36040000424D3604000000000000360000002800000010000000100000000100
- 2000000000000004000064000000640000000000000000000000000000000000
- 00000000000000000000366A820020B3F9000D8BD2000D629300526471000000
- 00000000000033606A00236889003173930047899F00458B9F004B8B9C00578D
- 9C00669BA6007BB1C400B35020FFA0401FFFAA4522FFAC4622FFAB4422FFA741
- 21FF9F3D1FFFB24F24FF00000000000000000000000000000000000000000000
- 00002579CDFF866161FFBF6035FFFEB961FFFEB962FFFEB962FFFEB962FFFEB9
- 61FFFEB961FFB14924FF7A646DFF2E7ECEFF6DA2D3FF418DA600638D9900297D
- D1FF82BAEEFF9F6658FFF5BB84FFFFAC5BFFFEA85AFFFEA257FFFE9C53FFFFA3
- 55FFFF9F50FFF8AE78FFA45E4AFF83BCEFFF2A77CAFF0000000000000000287C
- CEFF78B3EAFFB39E94FFFFB760FFFFB663FFFEB261FFFEAC5DFFFEA559FFFD9E
- 53FFFE974EFFFF8D43FFBC8F82FF7EB8EDFF2974C7FF5D8C9C004F889900638B
- 94008A5444FFFCC8ABFFFFD198FFFEC76DFFFEBF68FFFEB964FFFEB15EFFFEA8
- 59FFFDA054FFFFB77AFFFEA980FF885042FF00000000000000000A1129000000
- 000000000000C44C1FFFF6E4D6FFFFE4A4FFFFD472FFFFC969FFFFC063FFFFB6
- 5FFFFFC180FFF6D7C6FFC5491FFF197498003E869A004F899A00307793003F77
- 90004877860052849100BC481CFFF4E2D4FF4E7BA9FF4D7BA8FF4D7BA8FF4E7B
- A9FFF3D6C3FFBE461CFF000000000000000012121500202035002244C200171A
- 310000000000000000006A3C25FF346DA7FF9CCCF8FFAFD4F7FFAFD4F7FFA5CF
- F6FF3474AEFF683E2DFF176B92001F7399001C6A8F002E7C9C00153E6400153F
- 590010324A00204E5F002A5B92FFA6CAEEFFABCCEAFFA7D0F6FFA8D0F6FFABCC
- EAFFA7CDEEFF2D629AFF000000003E3D4C001B286B00222E8700013BF4005676
- DC0000000000000000001F5E9BFFD9E8F7FF97C5F1FF8EBBE5FF7FA9D1FF89B5
- DFFFCDDFEEFF2368A7FF3A7F9000417F8C002C587300164A7200546C8100657A
- 87007C8D9900899DA6000C3E87FF7C97B8FF8AB7E4FF719CC8FF15406EFF1944
- 72FF22456BFF113B66FF0000000052536800031F8600011B8F00093DF5006478
- C80000000000000000000F4B97FF12589FFF0F4A8AFF0F4B87FF114B87FF154C
- 85FF124175FF0F335CFF5C828500627B8100546C7E0050647B00736976007D70
- 78008A838A00908990009A929500114E96FF12589BFF125899FF115393FF0F4A
- 87FF0E3E71FF132E4BFF000000001B1B1B002B3C8B0001239F00071E6A000000
- 00000000000000000000000000000000000012488DFF104B90FF0F488AFF1142
- 7DFF15335BFF657174006B777D0057717E0061707D006C627200F0A3E30008E0
- 400000000000000000005D5C68005C637000686E7F0076889700BEC7CC004746
- 4500000000000000000000000000000000003E4560000E32B600
- }
- ImageIndex = 3
- OnClick = mnuAccountControlClick
- end
- object mnuRegionControl: TMenuItem
- Caption = '&Region Management'
- Bitmap.Data = {
- 36040000424D3604000000000000360000002800000010000000100000000100
- 2000000000000004000064000000640000000000000000000000454D47FF5F6A
- 61FF636F64FF646F64FF143F56FF295F86FF4988BCFF4A86A7FF5D7070FF646F
- 66FF646F66FF646F67FF646F67FF647067FF616C63FF474E48FF5F6A60FFEBF5
- ECFFD4EDD7FFD4EED7FF2E6784FF94C7F9FF91C9F9FF4185C9FF256BACFFB7D9
- D4FFD4E2ECFFCFE5D6FFD5EDD9FFD8EFDCFFD5EDD9FF616C63FF626E64FFEEF8
- EFFFA4DBBCFF8CCAA6FF4389AAFFE0F2FFFF549AD8FF1A7ABEFF4998C5FF3B86
- BFFF6074E7FF81C5A3FF8CD0A6FF85CAA0FFD2E9D7FF646F67FF616E64FFECF7
- EEFF96DBAFFF7FC99AFF63ADA5FF7AB6D5FF90B7D1FF55C9E4FF5BDFF5FF78D0
- EDFF4696D9FF76C1A1FF87D0A0FF80CA9AFFD6EEDAFF646F66FF616E63FFF7FB
- F8FF9BDEC4FF73C393FF80CF9FFF53AD9CFF73B9D5FFC2F6FDFF63DFF7FF5DE2
- F8FF79D3F0FF4395DAFF6CB8A4FF74C38FFFD7EFDAFF646F66FF616E63FFF8FC
- F9FFBCFBFBFF9DE7DFFF93E1BBFF77C997FF63BDAEFF77CBE7FFC7F7FDFF5EDC
- F5FF5AE1F7FF7BD4F1FF4395DDFF589BC3FFD0E9DBFF646F66FF606D63FFF8FC
- F8FFA4EBEDFF8DDFDFFF97EBEBFF72CFB7FF74CA99FF4790BDFF79D3EEFFC7F7
- FDFF5FDCF5FF5BE2F7FF7AD6F2FF4399DFFFB1D4D9FF646F66FF606D62FFF8FC
- F8FFAFFAFAFF94EBEBFFA2F9FAFF8AEAEBFF95EDF3FF595FEBFF6BCFE5FF7CD4
- EEFFC4F6FDFF6CDDF6FF6DCAEDFF63A3D7FF66A1D3FF617474FF606D61FFF8FC
- F8FF9FF1F1FF81DDDFFF8AEAEBFF75DEDEFF6591EEFF557EE2FF68DCDDFF5BBC
- C5FF80D5EDFFB2E3F9FF8BC0E7FFAED3F6FFC4E0FCFF669DD0FF5F6D61FFF8FC
- F8FFA6F9F9FF8BE9EAFF99F8FAFF78D3EBFF656BFFFF77DCEAFF70DFDEFFC1C5
- B5FFA8C8C8FF77BEE7FFB4D2F0FFE5F3FFFFACD2EFFF4A89BEFF5F6D61FFF8FC
- F8FF90EAEAFF78DDDEFF81E9EAFF4E6BE2FF639DEEFF5ED7D7FF5BCBC9FFD4B0
- 97FFE2BA9FFFA1ADA9FF58A5D8FF85B1DBFF469DD0FF4E7C8CFF5F6D61FFF7FC
- F8FF9FF9F9FF85E9EAFF84D3FAFF525AF0FF87F2F7FF60DAD7FF98D5CAFFE0B7
- 9CFFEDC7A9FFE0B394FFE6B898FFDEAE8CFFD7ECD6FF636E64FF5F6D60FFF7FC
- F8FF8AEAEAFF72DDDEFF5665F0FF569FDFFF73E8E8FF46C1C1FFBBBBA5FFD0A4
- 83FFDEB08EFFD19E7AFFD6A27AFFCF9871FFD7EBD5FF626E64FF5F6D60FFF7FC
- F8FF9DF9F9FF6CB4EDFF6271FEFF80E7E9FF8CF4F4FF52CDCDFFECC2A4FFDDAD
- 8AFFEBBA97FFDDA780FFE2AB83FFDAA075FFD9EAD4FF616E64FF5C6A5DFFFBFC
- FBFFFCFEFCFFF7FCF8FFF7FCF8FFF7FCF8FFF8FCF8FFF7FCF9FFF8FCF8FFF8FC
- F8FFECF7EEFFEDF7EEFFEFF6EDFFEEF4ECFFEBF4EBFF5E6A5FFF536876FF5C6A
- 5DFF5F6D60FF5F6D60FF5F6D60FF5F6D60FF5F6D61FF5F6D61FF5F6D61FF5F6D
- 61FF606D61FF606D62FF606D62FF606D63FF5E6A5FFF454E46FF
- }
- ImageIndex = 19
- OnClick = mnuRegionControlClick
- end
- object mnuLargeScaleCommands: TMenuItem
- Caption = 'Large Scale Commands'
- Bitmap.Data = {
- 36040000424D3604000000000000360000002800000010000000100000000100
- 2000000000000004000064000000640000000000000000000000000000000000
- 0000000000000000000000000000338037FF317D34FF2F7A32FF2F7A32FF2F7A
- 32FF2F7A32FF00000000000000000000FF00FF00000000000000000000000000
- 0000000000003D8F43FF3A8A3FFF9BC59DFFB3C29DFFBDC19CFFBEC39DFFB0D2
- B1FF7EC09AFF2F7A32FF2F7A32FF0000FF00FF00000000000000000000000000
- 0000469B4DFF70B786FFAEE8C7FFC0D2A0FFC5B381FFCAB47DFFCCAF78FFB9A7
- 78FF80CC95FFA0DABCFF66A87AFF2F7A32FFFF00000000000000000000004EA8
- 57FF76C08DFF99D7B3FF79C080FFBCC27EFFC6A96AFFD7B169FFD6AD65FFBC9B
- 5EFF60AD6AFF599768FF81C199FF67A97BFF2F7A32FF000000000000000053AF
- 5DFFB5EAD3FF69BC74FF6EBD71FFBEB66DFFC9A35BFFDFAB5BFFDDA858FFC192
- 4EFF9DA958FF78B166FF5A9667FFA6DCC0FF2F7A32FF000000005ABA66FF92D7
- AFFFA0DEB4FF84C670FFA8D080FFC5A55CFFD0A757FFE0AA56FFDAA651FFC798
- 4AFFB98C47FFB69B57FF819F65FF79BF90FF81BE9CFF2F7A32FF5EBF6AFFB0E9
- CFFF83D490FFBFDC8AFFC3CB82FFCCA256FFDAAF5CFFDCAF5BFFC99A4BFFBF86
- 43FFB78443FFB99A52FF96A562FF65A676FFA2D8BDFF2F7A32FF60C36DFFBEEF
- DDFF73D17DFF90D16CFFBCE09EFFC7A75EFFD3B05EFFC69953FFC6BC6EFFAFD1
- 7AFFB4C46DFFAFA95FFF7BA957FF5AA367FFB1E3CEFF317E35FF61C46EFFBEF0
- DCFF81D883FF77DB6DFFBFE59AFFCCDFA7FFCAA85DFFC2BD6CFFB8DA8BFFA6D8
- 60FF77D13FFF6AD046FF59BC50FF63AB6CFFB2E4CEFF358239FF61C46EFFB3EC
- D2FF9BE2A2FF9DEA8DFFD4EDB7FFD0EAC7FFCFB96EFFCCB166FFCBC975FF76DB
- 67FF66D94DFF65D74DFF6CD35DFF73BB7EFFA5DBC2FF39883EFF61C46EFF98DE
- B5FFB5EBCCFFB1EFA7FFC9EEA9FFD1EAC9FFD5CF8DFFD9CB8BFFCDB466FFBCBC
- 67FF9AD671FF82DE73FF7ADC71FF91D0A3FF88C8A4FF3D8F43FF0000000061C4
- 6EFFC0F3E2FFB5EFB4FFB5F0ACFFC1EDB7FFD4E3B7FFD9D89CFFDAD395FFCDB5
- 6DFFC7B36DFFB5CB84FF94DF9AFFAFE7CDFF469B4DFF000000000000000061C4
- 6EFF87D7A0FFC0F2DEFFC7F2D6FFD5EFD5FFD0E9CFFFD5DBA6FFDCDEABFFDBCD
- 90FFD7C88BFFC9C18EFFBDD5AFFF7AC791FF4AA353FF00000000FFFFFF00FFFF
- FF0061C46EFF8CD8A2FFCDF5E8FFD4EDDAFFCEEDD3FFCFDFAFFFD6DEB5FFD4D4
- A2FFCED0A1FFC4D0AAFF87C991FF53AF5DFFFF00000000000000080000003737
- 37003636360061C46EFF61C46EFFA5E1BBFFBAEACCFFC5E0BEFFC5DAB4FFBDD7
- B0FFA6D7ACFF5DBE69FF5ABA66FF00000000EFFFFF00FFFFFF00F0A3E300B8EB
- 760000000000000000000851A50061C46EFF61C46EFF61C46EFF61C46EFF61C4
- 6EFF61C46EFF000000000000000050E912000000000000000000
- }
- ImageIndex = 14
- OnClick = mnuLargeScaleCommandsClick
- end
- end
- object mnuSettings: TMenuItem
- Caption = '&Settings'
- object mnuShowAnimations: TMenuItem
- AutoCheck = True
- Caption = '&Animations'
- Checked = True
- Hint = 'Toggles whether to animate tiles or not.'
- OnClick = mnuShowAnimationsClick
- end
- object mnuSecurityQuestion: TMenuItem
- AutoCheck = True
- Caption = '&Security question'
- Checked = True
- Hint = 'Ask for permission before processing area commands.'
- end
- object mnuWhiteBackground: TMenuItem
- AutoCheck = True
- Caption = '&White Background'
- OnClick = mnuWhiteBackgroundClick
- end
- end
- object mnuHelp: TMenuItem
- Caption = '&?'
- object mnuAbout: TMenuItem
- Caption = '&About'
- OnClick = mnuAboutClick
- end
- end
- end
- object ImageList1: TImageList
- left = 264
- top = 32
- Bitmap = {
- 4C69170000001000000010000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000D9A781FFD39E76FF00000000000000000000000000000000000000000000
- 0000000000000000000000000000ECBEA1FFE7BB9DFFE4B697FFE0B292FFDAAE
- 8FFFDCB598FFCF9F7AFFC38657FF000000000000000000000000000000000000
- 0000000000000000000000000000E8C0A4FFE9C8B0FFE5C3A9FFE1BDA2FFDCB6
- 99FFD5AB8AFFD0A482FFB57644FF000000000000000000000000000000000000
- 00000000000000000000E2B18FFFE7C1A8FFE0BA9FFFD8AC8BFFD2A582FFCE9D
- 77FFD1A684FFBE865CFF00000000000000000000000000000000000000000000
- 00000000000000000000D9A781FFD9AB88FFDAB294FFD8B092FFCB9972FFC490
- 68FFC89C78FFB2724AFF00000000000000000000000000000000000000000000
- 00009E9E9EFF999999FF0000000000000000C38657FFC9976FFFCB9F7CFFBC85
- 59FFC3926BFFA6633EFF00000000000000000000000000000000EABE9FFFCEAF
- 9AFFB7B7B7FFBCBCBCFF8C8C8CFF0000000000000000AE6D40FFBB835CFFC08F
- 67FFBB8A60FF995033FF000000000000000000000000E7BB9CFFE8C0A3FFE5BF
- A3FFB59D8AFFAEAEAEFF838383FF0000000000000000000000009F5734FFAD72
- 4CFFA25F3FFF8E4129FF000000000000000000000000E3B493FFE8C6ADFFE3C0
- A6FFDBB08FFFB48D71FF00000000717171FF676767FF00000000000000008F43
- 2BFF8B4128FF00000000000000000000000000000000DDAE8CFFE2BEA4FFD8AB
- 89FFD9B394FFCF9F7AFFA37858FF939393FFA9A9A9FF555555FF000000000000
- 00000000000000000000000000000000000000000000D7A682FFDCB699FFD0A1
- 7DFFCB9A73FFCFA482FFC79974FF896C58FF878787FF4E4E4EFF000000000000
- 00000000000000000000000000000000000000000000D0A17CFFD7AE8FFFC997
- 6FFFC38F66FFBD885CFFC08C64FFBC8861FF83513CFF00000000000000000000
- 000000000000000000000000000000000000C68C60FFD1A683FFCC9F7BFFCB9E
- 7BFFC79974FFC3926CFFBE8D65FFA86945FF0000000000000000000000000000
- 0000000000000000000000000000C4885AFFC69268FFCDA280FFC59670FFB67B
- 53FFAB6A46FFA35E3DFF9C5235FF91442CFF0000000000000000000000000000
- 0000000000000000000000000000BA7C4AFFBF875CFFB97E56FFA7623AFF0000
- 0000000000000000000000000000000000000000000000000000000000000000
- 000000000000000000000000000000000000AB663CFFA45D38FF000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 000000000000000000000000000000000000BC6B36FFBC6B36FFBC6B36FFBC6B
- 36FFBB6B36FFBB6B36FFBB6A36FFBB6A36FFBC6C39FFBD6E3BFFBB6D3AFFBB6B
- 38FFBB703EFF0000000000000000BC6B36FFF6E0D1FFF7E0D1FFFEFBF8FFFEFB
- F7FFFDF9F6FFFCF5F0FFFAF0EAFFFBF2EDFFFDF9F6FFFDFAF7FFFBF1EBFFF8E9
- DFFFECD0BDFFC9895EFF00000000BC6B36FFF6DFD1FFE9AA80FFFEFAF6FFFDFA
- F6FFC88C64FFFBF3EEFFFBF1EAFFFCF6F2FFFEFBF8FFFCF6F1FFF9ECE2FFF8E7
- DBFFEED0BAFFECD0BDFFBB703EFFBC6B36FFF6DFD0FFE8A87EFFFCF6F1FFFCF6
- F1FFC88C64FFFAF1E9FFFBF4EEFFFDFAF7FFFDF9F6FFFAF0E8FFF8E8DDFFF7E6
- DBFFE1A37AFFEFD5C3FFB76935FFBC6B36FFF5DDCCFFE7A87EFFFAF0E8FFFAF0
- E8FFC98D66FFFAF0E9FFFDF8F3FFFEFAF8FFFCF4EFFFF9E9DFFFF7E7DBFFF7E5
- D9FFE0A278FFE7C2A9FFB66835FFBB6B36FFF4DCC9FFE7A77DFFF9ECE1FFF9EC
- E1FFF9EDE3FFFCF4EEFFFDFAF7FFFDF7F3FFFAEDE5FFF7E7DBFFF7E5D9FFF6E5
- D8FFDEA077FFE4BEA4FFB46734FFBB6B36FFF4D9C7FFE6A67DFFC88C64FFC98D
- 65FFC98E67FFCB926CFFCB926DFFCA9069FFC88C65FFC88C64FFC88C64FFC88C
- 64FFDA9C74FFE1BA9FFFB36634FFBB6A36FFF2D8C5FFE3A47BFFE3A37AFFE3A4
- 7AFFE2A47BFFE2A37BFFE1A37BFFE1A279FFDFA077FFDE9F76FFDD9E74FFDB9C
- 72FFDC9D74FFDDB59AFFB16534FFBB6A36FFF2D5C2FFE3A37AFFE3A37AFFE2A3
- 7BFFE2A37BFFE2A47BFFE1A279FFE0A178FFDEA077FFDE9E75FFDC9D74FFDA9B
- 73FFD99B73FFDAB095FFAF6433FFBB6A36FFF0D2BEFFE2A37AFFE2A37AFFE1A3
- 7AFFE2A37BFFE1A37BFFE0A178FFDE9F77FFDD9F76FFDC9D74FFD99B72FFD899
- 71FFD69970FFD5AB8EFFAD6333FFBA6A36FFEFD0BBFFE2A27AFFFEFBF8FFFEFB
- F8FFFEFBF8FFFEFBF8FFFEFBF8FFFEFBF8FFFEFBF8FFFEFBF8FFFEFBF8FFFEFB
- F8FFD3966DFFD2A78AFFAB6232FFBB6B38FFEFCEB8FFE1A279FFFEFAF7FF62C0
- 88FF62C088FF62C088FF62C088FF62C088FF62C088FF62C088FF62C088FFFDF9
- F6FFCF936AFFCEA384FFAA6132FFBB6C38FFEECCB6FFE1A27AFFFEFAF7FFBFDC
- C2FFBFDCC2FFBFDCC2FFBFDCC2FFBFDCC2FFBFDCC2FFBFDCC2FFBFDCC2FFFDF9
- F6FFCD9068FFCC9E81FFA86132FFBA6B37FFEDCAB3FFE0A27AFFFEFAF7FF62C0
- 88FF62C088FF62C088FF62C088FF62C088FF62C088FF62C088FF62C088FFFDF9
- F6FFCA8D65FFC99B7CFFA76031FFBA6A35FFEBC6ADFFEAC5ADFFFEFBF8FFFEFB
- F8FFFEFBF8FFFEFBF8FFFEFBF8FFFEFBF8FFFEFBF8FFFEFBF8FFFEFBF8FFFEFB
- F8FFC89A7CFFC79879FFA76031FFBA6A36FFB96935FFB86935FFB76835FFB568
- 35FFB46734FFB26634FFB06533FFAE6433FFAC6332FFAA6232FFA96132FFA860
- 31FFA76031FFA66031FFA86131FF000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 00009EA3EBFFA0A5ECFF9DA2EBFF9BA0EBFF989EEAFF9297E9FF000000000000
- 000000000000000000000000000000000000000000000000000000000000A9B1
- F0FFC2D3FCFFC1D6FFFFBDD1FFFFBBCFFFFFB9CEFFFFB7C8FCFF989FEDFF0000
- 0000000000000000000000000000000000000000000000000000A6ADEEFFC4D4
- FCFFA3C2FFFF8BAFFFFF89ABFFFF84A7FFFF7EA0FFFF91AEFFFFB4C3FBFF8C93
- EAFF0000000000000000000000000000000000000000A5ACEFFFC1D1FCFFA0BF
- FFFF86AAFFFF85A7FFFF81A2FFFF7C9DFFFF7898FFFF6F90FFFF85A1FFFFACBA
- FBFF838BE8FF000000000000000000000000959AEAFFBCCDFCFF9CBBFFFF81A5
- FFFF81A2FFFF7C9EFFFF7899FFFF7493FFFF6F8EFFFF6989FFFF6080FFFF7893
- FFFF9EADFBFF656CE0FF00000000000000009298E9FFB8CDFFFF7DA0FFFF7C9D
- FFFF7899FFFF7393FFFF6E8EFFFF6989FFFF6583FFFF607EFFFF5978FFFF4F70
- FFFF98AAFFFF636AE0FF00000000000000008B91E7FFB1C4FFFF7698FFFF7393
- FFFF6E8EFFFF6989FFFF6583FFFF5F7EFFFF5A79FFFF5573FFFF4F6EFFFF4867
- FFFF90A1FFFF5A62DEFF0000000000000000858AE6FFABBEFFFF6D8DFFFF6989
- FFFF6583FFFF5F7EFFFF5A79FFFF5574FFFF506FFFFF4B69FFFF4663FFFF3F5C
- FFFF8A9BFFFF535BDCFF00000000000000007D84E5FFA6BBFFFF5F7FFFFF5F7E
- FFFF5A79FFFF5573FFFF506EFFFF4B69FFFF4664FFFF415EFFFF3B59FFFF314F
- FFFF8799FFFF4D55DBFF00000000000000007178E3FFA2B2FCFF738FFFFF4F70
- FFFF4F6EFFFF4B69FFFF4664FFFF415EFFFF3C5AFFFF3755FFFF2C4BFFFF4E67
- FFFF8493FAFF4048D8FF0000000000000000000000007981E7FF9FADFBFF6781
- FFFF405EFFFF405EFFFF3C59FFFF3755FFFF3350FFFF2846FDFF4A65FDFF8996
- F6FF545EDEFF00000000000000000000000000000000000000006C75E4FF96A5
- FAFF5A74FFFF3250FFFF304FFFFF2C49FEFF2542FAFF4860F9FF8694F4FF5159
- DDFF00000000000000000000000000000000000000000000000000000000636C
- E4FF8997FAFF8495FFFF7F90FCFF7D8EFAFF7D8DF7FF7D8BF2FF5159DDFF0000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000444BD9FF474FDAFF434BD9FF4048D7FF3E47D8FF353ED5FF000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 00000000000012488DFF104B90FF0F488AFF11427DFF15335BFF000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000114E96FF12589BFF125899FF115393FF0F4A87FF0E3E71FF132E4BFF0000
- 0000000000000000000000000000000000000000000000000000000000000F4B
- 97FF12589FFF0F4A8AFF0F4B87FF114B87FF154C85FF124175FF0F335CFF0000
- 0000000000000000000000000000000000000000000000000000000000000C3E
- 87FF7C97B8FF8AB7E4FF719CC8FF15406EFF194472FF22456BFF113B66FF0000
- 0000000000000000000000000000000000000000000000000000000000001F5E
- 9BFFD9E8F7FF97C5F1FF8EBBE5FF7FA9D1FF89B5DFFFCDDFEEFF2368A7FF0000
- 0000000000000000000000000000000000000000000000000000000000002A5B
- 92FFA6CAEEFFABCCEAFFA7D0F6FFA8D0F6FFABCCEAFFA7CDEEFF2D629AFF0000
- 0000000000000000000000000000000000000000000000000000000000006A3C
- 25FF346DA7FF9CCCF8FFAFD4F7FFAFD4F7FFA5CFF6FF3474AEFF683E2DFF0000
- 000000000000000000000000000000000000000000000000000000000000BC48
- 1CFFF4E2D4FF4E7BA9FF4D7BA8FF4D7BA8FF4E7BA9FFF3D6C3FFBE461CFF0000
- 0000000000000000000000000000000000000000000000000000C44C1FFFF6E4
- D6FFFFE4A4FFFFD472FFFFC969FFFFC063FFFFB65FFFFFC180FFF6D7C6FFC549
- 1FFF00000000000000000000000000000000000000008A5444FFFCC8ABFFFFD1
- 98FFFEC76DFFFEBF68FFFEB964FFFEB15EFFFEA859FFFDA054FFFFB77AFFFEA9
- 80FF885042FF000000000000000000000000287CCEFF78B3EAFFB39E94FFFFB7
- 60FFFFB663FFFEB261FFFEAC5DFFFEA559FFFD9E53FFFE974EFFFF8D43FFBC8F
- 82FF7EB8EDFF2974C7FF0000000000000000297DD1FF82BAEEFF9F6658FFF5BB
- 84FFFFAC5BFFFEA85AFFFEA257FFFE9C53FFFFA355FFFF9F50FFF8AE78FFA45E
- 4AFF83BCEFFF2A77CAFF0000000000000000000000002579CDFF866161FFBF60
- 35FFFEB961FFFEB962FFFEB962FFFEB962FFFEB961FFFEB961FFB14924FF7A64
- 6DFF2E7ECEFF6DA2D3FF0000000000000000000000000000000000000000B350
- 20FFA0401FFFAA4522FFAC4622FFAB4422FFA74121FF9F3D1FFFB24F24FF0000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 000000000000000000000000000000000000000000000000000000000000C8C8
- C8FFC5C5C5FF0000000000000000000000000000000000000000000000000000
- 000000000000000000000000000000000000000000000000000000000000C4C4
- C4FFD9D9D9FFBEBEBEFF00000000000000000000000000000000000000000000
- 000000000000000000000000000000000000000000000000000000000000C1C1
- C1FFF7F7F7FFD5D5D5FFB6B6B6FF000000000000000000000000000000000000
- 000000000000000000000000000000000000000000000000000000000000BDBD
- BDFFF7F7F7FFEFEFEFFFD0D0D0FFAFAFAFFF0000000000000000000000000000
- 000000000000000000000000000000000000000000000000000000000000B9B9
- B9FFF4F4F4FFECECECFFEDEDEDFFCBCBCBFFA7A7A7FF00000000000000000000
- 000000000000000000000000000000000000000000000000000000000000B5B5
- B5FFF2F2F2FFE8E8E8FFE7E7E7FFEAEAEAFFC6C6C6FF9E9E9EFF000000000000
- 000000000000000000000000000000000000000000000000000000000000B1B1
- B1FFF0F0F0FFE4E4E4FFE2E2E2FFE2E2E2FFE7E7E7FFC1C1C1FF969696FF0000
- 000000000000000000000000000000000000000000000000000000000000ADAD
- ADFFEEEEEEFFE1E1E1FFDFDFDFFFE0E0E0FFE7E7E7FFE4E4E4FFBBBBBBFF8E8E
- 8EFF00000000000000000000000000000000000000000000000000000000A9A9
- A9FFF2F2F2FFE5E5E5FFE2E2E2FFE3E3E3FF959595FF919191FF8D8D8DFF8989
- 89FF868686FF000000000000000000000000000000000000000000000000A4A4
- A4FFD7D7D7FF9D9D9DFFD0D0D0FFEEEEEEFF919191FF00000000000000000000
- 000000000000000000000000000000000000000000000000000000000000A0A0
- A0FF9C9C9CFF00000000949494FFD9D9D9FFC1C1C1FF898989FF000000000000
- 0000000000000000000000000000000000000000000000000000000000009C9C
- 9CFF000000000000000000000000ADADADFFF2F2F2FF848484FF000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000888888FFDBDBDBFFB7B7B7FF7D7D7DFF0000
- 0000000000000000000000000000000000000000000000000000000000000000
- 000000000000000000000000000000000000AAAAAAFFDBDBDBFF797979FF0000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000007C7C7CFF787878FF757575FF0000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 00000000000000000000000000000000000000000000000000004FAADBFF5093
- CAFF4E90C8FF2F9DD2FF00000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000050A8D9FF6AA5D8FFC9E1
- F7FFCBE3F8FF4295CAFF3182C2FF000000000000000000000000000000000000
- 0000000000000000000000000000000000002FBAE4FFA7D4F4FFC5E1F8FFCCE3
- F9FFCCE3F9FFBDDBF7FF4F90C9FF000000000000000000000000000000000000
- 00000000000000000000000000002FBAE4FFC3EDF8FFA8E2F8FF6CAEDDFFA5CF
- F4FFA5CFF4FFBDDBF7FF5393CBFF000000000000000000000000000000000000
- 000000000000000000002FBAE4FFC3EDF8FFB3F4FCFF68D9F5FF6FCFF3FF599D
- D0FF73ABDDFF4F91C9FF00000000000000000000000000000000000000000000
- 0000000000002FBAE4FFC3EDF8FFB3F4FCFF60DCF5FF44D6F4FF8EEEFAFF5DB4
- E6FF3B8FD9FF0000000000000000000000000000000000000000000000000000
- 00002FBAE4FFC3EDF8FFB3F4FCFF60DCF5FF44D6F4FF8EEEFAFF5DB4E6FF3B8F
- D9FF000000000000000000000000000000000000000000000000000000002790
- BFFFC3EDF8FFB3F4FCFF60DCF5FF44D6F4FF8EEEFAFF5DB4E6FF3B8FD9FF0000
- 00000000000000000000000000000000000000000000000000002689B9FFBEE6
- F2FFB3F4FCFF60DCF5FF44D6F4FF8EEEFAFF5DB4E6FF3B8FD9FF000000000000
- 000000000000000000000000000000000000000000002689B9FFB0CBE1FF67A9
- C8FF60DCF5FF44D6F4FF8EEEFAFF5DB4E6FF3B8FD9FF00000000000000000000
- 0000000000000000000000000000000000001E6D93FFC8E1F2FFD1E7FAFF347D
- B5FF3199C3FF6DC4DCFF4A9CCFFF3483C7FF0000000000000000000000000000
- 0000000000000000000000000000000000001E6D93FFCBE3F9FF61AAECFF4098
- E8FF1567C2FF1660AAFF2C76B4FF000000000000000000000000000000000000
- 000000000000000000000000000000000000124259FF5D9CD4FFA6CFF5FFA9CF
- ECFF488BC1FF2C76B4FF00000000000000000000000000000000000000000000
- 000000000000000000000000000000000000134058FF15425EFF25699CFF2C76
- B4FF3B8BBAFF0000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 000000000000000000000000000068C774FF68C774FF67C673FF66C572FF65C3
- 71FF0000000000000000000000000000000000000000000000005CB666FF5BB4
- 64FF59B262FF58AF60FF56AD5EFF68C774FFA1D8A9FF9ED6A7FF65C371FF0000
- 0000000000000000000000000000000000000000000000000000000000005FB4
- 67FF8DC894FF8EC995FF54AA5CFF67C673FF9DD6A5FF92D19BFF7ECA87FF63C0
- 6EFF00000000000000000000000000000000000000000000000059B162FF76BD
- 7EFF7EC086FF8AC590FF52A85AFF66C472FF6BC575FF83CC8CFF9BD3A4FF7BC7
- 84FF60BC6BFF0000000000000000000000000000000059B161FF75BD7DFF8CC7
- 93FF6DB673FF52A759FF50A557FF65C370FF0000000063BF6DFF80C989FF79C4
- 82FF5FB969FF0000000000000000000000000000000057AE5FFF6EB875FF6CB5
- 73FF52A759FF000000004EA255FF00000000000000000000000060BB6AFF5EB9
- 68FF00000000000000000000000000000000000000000000000053A95BFF52A7
- 59FF000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 000000000000000000000000000000000000000000000000000057AE5FFF55AC
- 5DFF0000000000000000000000000000000000000000000000004A9C50FF4899
- 4EFF0000000000000000000000005AB363FF0000000057AE5FFF6CB673FF6AB4
- 71FF52A759FF000000000000000000000000000000004A9B4FFF5FA764FF62A8
- 67FF45954AFF00000000439147FF58B061FF57AE5FFF6CB673FF84C08AFF6EB5
- 74FF50A457FF0000000000000000000000000000000048994DFF5DA561FF75B3
- 79FF5FA463FF47944CFF418F45FF56AD5FFF83C08AFF73B77AFF6CB473FF50A4
- 57FF000000000000000000000000000000000000000000000000459449FF5AA0
- 5EFF5EA664FF6CAD70FF408D44FF54AB5CFF83BF89FF7DBB83FF54A65BFF0000
- 0000000000000000000000000000000000000000000000000000000000004290
- 46FF6DAD71FF6EAE73FF3F8C42FF53A85AFF51A658FF4FA356FF4EA154FF4C9F
- 52FF000000000000000000000000000000000000000000000000429046FF418E
- 45FF408D43FF3F8B42FF3E8A41FF000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000067C673FF65C270FF0000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 00000000000066C572FF7ECA88FF7BC885FF5DB868FF00000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 000066C472FF7CCA87FF9ED6A7FF9CD4A5FF73C07DFF55AC5EFF000000000000
- 00000000000000000000000000000000000000000000000000000000000065C3
- 71FF62BF6EFF79C683FF9AD4A3FF98D3A1FF7DC386FF4FA458FF4A9E53FF0000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000005BB465FF96D29FFF94D09CFF5DAC65FF00000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 00000000000056AD5FFF93CF9AFF90CE98FF489A50FF00000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 00000000000050A659FF8ECC95FF8BCB93FF42924AFF00000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000004A9E53FF8ACA91FF87C98EFF3C8A43FF00000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 00000000000045954CFF85C78CFF82C689FF36823DFF00000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000003F8D46FF81C587FF7EC385FF317A36FF00000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 00000000000039853FFF7DC282FF7AC180FF2B7230FF00000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 000000000000337D39FF79C07EFF76BF7CFF266B2BFF00000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000002D7533FF74BD7AFF72BD78FF226526FF00000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 000000000000286E2DFF256929FF216425FF1E6022FF00000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000A77B3EFF0000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000CBAE87FF0000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000D5BC9DFF0000000000000000000000000000
- 0000AE854CFF0000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000DEC8AEFF000000000000000000000000D1B6
- 93FFBB9767FF0000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000E6D4C0FF0000000000000000D3B999FFD3B8
- 97FF000000000000000000000000000000000000000000000000000000000000
- 00000000000000000000AF8750FFEDDECEFF00000000CEB38FFFE7D6C3FF0000
- 0000000000000000000000000000000000000000000000000000000000000000
- 00000000000000000000B28A54FFF1E2D3FFCFB38EFFF5E9DCFF000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 00000000000000000000B68F59FFF5E9DDFFE2CDB4FFB99461FF000000000000
- 0000000000000000000000000000000000000000000000000000000000009D69
- 32FFB17E42FF9E682CFFBC9767FFF0E0D0FFB6915FFF00000000000000000000
- 0000000000000000000000000000000000000000000000000000B17E42FFDCAA
- 60FFD09E54FFEAB365FFD8BA99FFF8EBE1FFAE8957FF00000000000000000000
- 000000000000000000000000000000000000000000009C6A32FFD6A55EFF0000
- 000000000000E4AD60FFDCBD9BFFEFCDA5FFEFB767FFD8A65DFF000000000000
- 00000000000000000000000000000000000000000000BE8A4AFFA87E41FF0000
- 0000966E32FFE7B066FFCAA274FFE5B167FF945E2DFFB88D4DFFAF703BFF0000
- 00000000000000000000000000000000000000000000B58244FFD6A45AFFAE82
- 41FFECB666FFA76E36FFAC6C37FFC49551FF0000000000000000B77840FF0000
- 0000000000000000000000000000000000000000000000000000C79751FFD8A6
- 5AFFA66C36FF00000000A86835FFD1A057FF000000008E6A36FFB4753FFF0000
- 0000000000000000000000000000000000000000000000000000000000000000
- 000000000000000000009F5E2FFFE7B263FFBF924FFFDDAB62FFA26232FF0000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000A06131FFB6763FFFA46534FF000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 000000000000000000000000000000000000898989FF888888FF878787FF0000
- 0000000000000000000000000000000000000000000000000000000000006B6B
- 6BFF666666FF626262FF0000000000000000898989FFD3D3D3FF848484FFE6B3
- 8CFFE5B28AFFE5B289FFE5AF86FFE5AE86FFE3AC85FFE3AB83FFE3A980FF6262
- 62FFC4C4C4FF585858FF0000000000000000868686FF838383FF968D87FFEBC4
- A5FFEBC2A4FFEBC2A3FFEAC0A2FFEABFA0FFEABE9FFFE8BC9EFFE8BB9CFF7E72
- 6AFF535353FF4F4F4FFF000000000000000000000000E5B289FFEBC3A5FFEBC2
- A3FFEBC0A2FFEABFA1FFEABEA0FFE9BD9EFFE8BB9DFFE8BA9BFFE7B899FFE6B6
- 97FFDE9D75FF00000000000000000000000000000000E5AF86FFEBC1A2FFEAC0
- A2FFEABEA0FFE9BD9EFFE8BC9DFFE8BA9BFFE7B899FFE6B698FFE6B596FFE5B3
- 94FFDC9A70FF00000000000000000000000000000000E3AC85FFEABFA0FFEABE
- 9FFFE8BC9DFFE8BA9CFFE8B99AFFE6B798FFE6B696FFE5B494FFE4B393FFE4B1
- 91FFDA966CFF00000000000000000000000000000000E3AA81FFE9BC9EFFE8BB
- 9CFFE8B99AFFE7B899FFE6B697FFE6B495FFE4B394FFE4B192FFE3AF90FFE3AE
- 8FFFD9926AFF00000000000000000000000000000000E1A67FFFE8BA9BFFE7B8
- 99FFE6B697FFE6B596FFE5B394FFE4B192FFE4AF91FFE3AE8FFFE3AD8DFFE2AB
- 8BFFD88E66FF00000000000000000000000000000000E1A27BFFE6B798FFE6B5
- 96FFE5B494FFE4B292FFE4B191FFE3AF8FFFE3AD8DFFE2AC8CFFE1AA8AFFE1A9
- 89FFD68C62FF00000000000000000000000000000000DE9F77FFE5B495FFE4B3
- 93FFE4B192FFE3AF90FFE3AE8EFFE2AC8DFFE1AA8BFFE1A989FFE0A787FFDFA6
- 86FFD5895FFF00000000000000000000000000000000DD9B73FFE4B192FFE4AF
- 91FFE3AE8FFFE3AC8DFFE1AB8BFFE1A989FFE1A888FFE0A786FFDFA585FFDFA3
- 84FFD4865DFF000000000000000000000000424242FF3D3D3DFF534B46FFE3AD
- 8DFFE2AB8BFFE1AA8AFFE1A888FFE0A787FFDFA585FFDFA484FFDEA383FF4233
- 2BFF0A0A0AFF070707FF00000000000000003A3A3AFFB7B7B7FF313030FFD890
- 66FFD88E64FFD68C62FFD58961FFD5895FFFD5865DFFD4855BFFD4855AFF0909
- 09FFA6A6A6FF030303FF0000000000000000323232FF2D2D2DFF282828FF0000
- 0000000000000000000000000000000000000000000000000000000000000404
- 04FF010101FF000000FF00000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 00000000000000000000063922FF0A3C24FF0000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 000000000000104F38FF0D4A2DFF093D22FF093A28FF00000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000063420FF0D3D2BFF0B4028FF0D4726FF0A3A26FF194833FF000000000000
- 0000000000000000000000000000000000000000000000000000000000000B48
- 23FF144C2FFF124631FF0B4029FF114B28FF073121FF0F452DFF114A32FF0000
- 000000000000000000000000000000000000000000000000000005291DFF0F51
- 31FF0F3924FF144A31FF0A3C28FF0D4224FF093D24FF0C4528FF0C3F29FF0F4D
- 38FF000000000000000000000000000000000000000014553FFF0B3A2AFF114F
- 32FF053220FF0E3E29FF08311CFF0C4426FF0F482CFF0D4A2EFF0D4326FF124E
- 39FF083F28FF000000000000000000000000093625FF104330FF083727FF0C45
- 2EFF073325FF154534FF0F4629FF0A4023FF0E4733FF0F4831FF0F4229FF0B43
- 2DFF0C472EFF072217FF000000000A3D2AFF062C1AFF124D2FFF0A3E24FF1049
- 33FF124735FF0C3626FF0D4224FF0E452FFF0A4030FF093927FF0C422AFF0D41
- 2EFF0A3623FF0B3E2AFF083D27FF012818FF093D29FF093923FF0E4226FF0F43
- 2AFF0E442AFF0D402FFF09392BFF0F452CFF11492FFF0C452FFF124B31FF0E42
- 2BFF0A3F24FF07301EFF0D3C2CFF00000000052F1DFF093726FF0F4A32FF0D41
- 29FF114A2CFF104532FF0E462BFF0C3C27FF0E4227FF0C4229FF0E422DFF0E45
- 27FF144D34FF083A24FF000000000000000000000000123F30FF0B3C2BFF1148
- 31FF0D4129FF05271AFF0B3F27FF0D3F2CFF134933FF144C34FF0E422EFF0C44
- 2EFF0C402DFF00000000000000000000000000000000000000000C4933FF104A
- 38FF0A3E25FF164B37FF0E432FFF063318FF134734FF093121FF0C3723FF0943
- 2CFF000000000000000000000000000000000000000000000000000000000632
- 20FF124D36FF0C3C28FF093C25FF104A25FF0F4B30FF0B4529FF062F19FF0000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000073E24FF083722FF0C4226FF0F472DFF0F4534FF052F1FFF000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 000000000000114D37FF0A3825FF0C432BFF05382AFF00000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000006301CFF10492EFF0000000000000000000000000000
- 00000000000000000000000000004D5563FF0000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 00000000000000000000323F54FF2B3953FF283143FF00000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000002A3646FF1B283DFF30426AFF26354BFF4B566CFF000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 00002B3745FF142232FF1D2944FF2F4267FF274161FF2B3D54FF2F3C4CFF0000
- 0000000000000000000000000000000000000000000000000000000000001E27
- 36FF1A2939FF122235FF192741FF304A69FF2C4E71FF214066FF273B4FFF4853
- 65FF0000000000000000000000000000000000000000000000001F2D3CFF1824
- 33FF1B2B43FF0F2237FF172543FF35476AFF2C496DFF203C61FF274B70FF283A
- 51FF2B3746FF000000000000000000000000000000001F2A3AFF18263CFF1A25
- 3AFF18253CFF0F1E34FF1E2744FF2F4267FF2D4569FF253F64FF2B4F78FF1C3A
- 5BFF2A364DFF404F62FF0000000000000000212D39FF101E2CFF1B2842FF1822
- 3BFF1D2A42FF112134FF1A2842FF2C4464FF2D4C6FFF22436AFF335680FF2544
- 64FF304669FF263547FF27333FFF1E2934FF1A293AFF101E33FF19273EFF1524
- 39FF1C2C43FF102337FF192642FF354760FF2A4A6CFF213F63FF2A4D71FF2744
- 63FF2D4466FF25374BFF2C3D53FF152431FF132740FF121D2FFF1D2946FF1926
- 3CFF19263DFF0D2033FF17253CFF00000000324A71FF243D62FF2B4E76FF233E
- 61FF33496DFF2C3F55FF31435FFF162033FF142846FF111F31FF1C2843FF1822
- 39FF18243BFF101D30FF000000000000000000000000224068FF2A4D76FF2643
- 65FF354D6FFF2C3F56FF2F425CFF121D2BFF1B2B45FF101E32FF19273FFF1524
- 39FF162637FF00000000000000000000000000000000000000002E507AFF2544
- 61FF2D4467FF28394FFF314461FF101C2BFF182841FF111C31FF1C2841FF1623
- 36FF000000000000000000000000000000000000000000000000000000002940
- 5AFF304566FF2A3B51FF30435EFF152032FF132945FF132031FF172841FF0000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000384F71FF2E4359FF2C3F5AFF141E2DFF1B2B44FF111E2EFF000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000002C4055FF273B57FF101C27FF1E3049FF00000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 00000000000000000000273D57FF131B2AFF0000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 000000000000000000005F93D4FF5C91D1FF598FCFFF558DCCFF000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 00006194D5FF77A4DCFF92B9E4FFA9CAECFFA6C7ECFF8EB6E2FF699BD2FF4A84
- C3FF000000000000000000000000000000000000000000000000000000006094
- D5FF8FB7E3FFBAD7F3FF5ED5FBFF2BD5FFFF42D1FBFFB4D2F2FFB2D0F1FF93B9
- E2FF6396CCFF3E7CB9FF0000000000000000000000006295D6FF86AFE1FF5BB3
- F9FF2CA4FFFF41AAFBFF31D3FEFF6DE2FFFF2CD5FFFF80B1E8FF7DAEE7FFAACA
- EFFFA6C6EDFF3878B6FF00000000000000006194D5FF87B0E1FFBAD7F3FF33A7
- FEFF6DC0FFFF2CA4FFFF67BFF0FF3BCEFBFF5BBFF1FF53B4A1FF3CB87AFF48B4
- 91FFA8C8EEFF78A6D6FF3072AFFF000000005D92D2FF93A5F5FF5A5BF6FF5287
- F4FF3CA7FBFF5DACF2FF7FB0E7FF7CAEE7FF79ABE6FF40B781FF61C898FF3CB8
- 7BFF7EADE7FF90B6E3FF2B6FABFF5C91D1FF93BAE5FF6F75F6FF8285F5FF4141
- F0FF91BCEBFFAFCDF0FFADCCF0FFABCAF0FF86B3E9FF5FAAC2FF45B48EFF57A9
- B7FF71A2E4FF98BBE8FF266BA7FF588ECEFFA9C9EDFF85A8EDFF596BEDFF6B8F
- E9FFAECDF0FF6E9ED2FF3F7DBAFF689ACEFFA6C6EEFF969B6AFFAE9827FF9E98
- 4EFF679CE2FF99BCEAFF2268A3FF538BCBFFAFCDF0FFB1CFF0FF99C0ECFF7FAF
- E7FFABCAEFFF3E7CB9FF000000003677B4FFA3C4EDFFA99832FFC5B65BFFAD98
- 27FF5C94DFFF99BCEBFF1D65A0FF4F88C7FF6598CFFF7CA9D9FF8EB5E2FFA4C5
- EDFFA8C7EEFF6598CDFF3576B3FF6094C9FFA0C1EDFF7997A4FF9F9749FF7D95
- 92FF8EB4E9FF7AA6D8FF19629DFF0000000000000000427FBDFF3F7DBAFF3B7A
- B8FF77A5D7FFA2C3EDFFA0C1EDFF9EC0EDFF75A4E4FF5B93DFFF5991DEFF7CA8
- E6FF93B7E8FF4480B8FF00000000000000000000000000000000000000000000
- 00003274B1FF9EC0ECFF6A9DE2FF5C94DFFF5992DFFF6095E0FF96B9EAFF87AE
- E1FF4A84BCFF145F99FF00000000000000000000000000000000000000000000
- 00002D70ADFF6E9ED1FF9ABDEBFF72A1E3FF97BAEAFF95B9EAFF6194CAFF1660
- 9AFF000000000000000000000000000000000000000000000000000000000000
- 000000000000256BA6FF87AEE1FF7FA9DCFF6093C9FF3173ACFF15609AFF0000
- 0000000000000000000000000000000000000000000000000000000000000000
- 000000000000000000001D65A0FF1A639EFF17619BFF00000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 000000000000000000000000000000000000CEB3A1FFCFB19FFFCDAB95FFCDA7
- 8EFFCDA78EFFCDA78EFFCDA78EFFCDA78EFFCDA68EFFCDA68EFFCDA68EFFCDA6
- 8EFFCDAA93FFCDAF9BFF0000000000000000CFB29FFFECECEBFFF4F4F3FFF7F5
- F4FFF7F5F4FFF7F5F4FFF7F5F4FFF7F5F4FFF7F5F4FFF7F5F4FFF7F5F4FFF7F3
- ECFFF2EFE9FFCEAD97FF0000000000000000CDAB95FFF4F3F2FFE3B495FFD0B4
- 8DFFA9B580FF93CCA1FF84D1AAFF82D0A6FF8BC294FF9A9E69FFC39D73FFD69D
- 77FFF7F2EBFFCFAB94FF0000000000000000CDA78FFFF7F5F4FFE3B597FFB8B7
- 87FF93CBA1FF74D2A8FF67CB9BFF63C897FF6AC998FF83BB8BFFA5996AFFD79F
- 7AFFF7F0E9FFCFAB94FF0000000000000000CDA78FFFF7F5F2FFE4B799FFA3B6
- 80FF82D0A7FF65C998FF5DC691FF59C28BFF58C187FF71C28EFF8C925FFFD9A2
- 7DFFF6F0E8FFCEAB94FF0000000000000000CDA78FFFF7F5F0FFE5B89BFFA1B3
- 7FFF7DCDA0FF5EC590FF56C087FF52BE81FF52BC7EFF6CBD87FF89905EFFDAA4
- 81FFF5EFE7FFCEAB94FF0000000000000000CDA78FFFF7F4EFFFE6B99DFFB6B3
- 87FF88C293FF63C58FFF53BE80FF4FBA7AFF58BD7FFF78B07CFFA3966AFFDCA7
- 84FFF6EEE7FFCEAB94FF0000000000000000CDA78FFFF7F3EEFFE7BB9FFFD1B6
- 93FF9FAA78FF6FB287FF65BD8AFF61BB87FF6BAB7BFF919364FFC5A27DFFDDA9
- 88FFF6EEE7FFCEAB94FF0000000000000000CDA78EFFF7F2EDFFE8BDA1FFE7BB
- 9FFFD0B392FF5E8276FF448E86FF418B87FF568380FFC7A682FFE0AE8EFFDEAC
- 8BFFF6EEE6FFCEAB94FF0000000000000000CDA78EFFF7F1ECFF4EAA7AFF4CA8
- 77FF4AA674FF357B9AFF549FD3FF549FD1FF3F86AFFF409A67FF3E9865FF3C96
- 63FFF6EEE6FFCEAB94FF0000000000000000CCA68DFFF7F1EDFFBFDCC2FFBFDC
- C2FFBFDCC2FFAFD3C5FF9CC8C9FF6EAFD1FFBAD9C3FFBFDCC2FFBFDCC2FFBFDC
- C2FFF6EDE6FFCEAA93FF0000000000000000CCA68EFFF6F1EDFFBFDCC2FFBFDC
- C2FFBFDCC2FFBFDCC2FFBFDCC2FFBFDCC2FFBFDCC2FFBFDCC2FFBFDCC2FFBFDC
- C2FFF7EDE6FFCEAA93FF0000000000000000CDAB96FFF1EFEDFFF7F3F1FFF8F4
- F1FFF8F4F0FFF7F4F0FFF7F3F0FFF7F3EFFFF7F3EFFFF7F3EFFFF7F3EFFFF8F3
- EFFFF2EFEBFFCFAD97FF0000000000000000CEAF9CFFCFAE9AFFCEAB94FFCEAA
- 93FFCEAA93FFCEAA93FFCEAA93FFCEAA93FFCEAA93FFCEAA93FFCEAA93FFCEAA
- 93FFCEAD97FFCEAF9CFF00000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 000061C46EFF61C46EFF61C46EFF61C46EFF61C46EFF61C46EFF000000000000
- 000000000000000000000000000000000000000000000000000061C46EFF61C4
- 6EFFA5E1BBFFBAEACCFFC5E0BEFFC5DAB4FFBDD7B0FFA6D7ACFF5DBE69FF5ABA
- 66FF000000000000000000000000000000000000000061C46EFF8CD8A2FFCDF5
- E8FFD4EDDAFFCEEDD3FFCFDFAFFFD6DEB5FFD4D4A2FFCED0A1FFC4D0AAFF87C9
- 91FF53AF5DFF00000000000000000000000061C46EFF87D7A0FFC0F2DEFFC7F2
- D6FFD5EFD5FFD0E9CFFFD5DBA6FFDCDEABFFDBCD90FFD7C88BFFC9C18EFFBDD5
- AFFF7AC791FF4AA353FF000000000000000061C46EFFC0F3E2FFB5EFB4FFB5F0
- ACFFC1EDB7FFD4E3B7FFD9D89CFFDAD395FFCDB56DFFC7B36DFFB5CB84FF94DF
- 9AFFAFE7CDFF469B4DFF0000000061C46EFF98DEB5FFB5EBCCFFB1EFA7FFC9EE
- A9FFD1EAC9FFD5CF8DFFD9CB8BFFCDB466FFBCBC67FF9AD671FF82DE73FF7ADC
- 71FF91D0A3FF88C8A4FF3D8F43FF61C46EFFB3ECD2FF9BE2A2FF9DEA8DFFD4ED
- B7FFD0EAC7FFCFB96EFFCCB166FFCBC975FF76DB67FF66D94DFF65D74DFF6CD3
- 5DFF73BB7EFFA5DBC2FF39883EFF61C46EFFBEF0DCFF81D883FF77DB6DFFBFE5
- 9AFFCCDFA7FFCAA85DFFC2BD6CFFB8DA8BFFA6D860FF77D13FFF6AD046FF59BC
- 50FF63AB6CFFB2E4CEFF358239FF60C36DFFBEEFDDFF73D17DFF90D16CFFBCE0
- 9EFFC7A75EFFD3B05EFFC69953FFC6BC6EFFAFD17AFFB4C46DFFAFA95FFF7BA9
- 57FF5AA367FFB1E3CEFF317E35FF5EBF6AFFB0E9CFFF83D490FFBFDC8AFFC3CB
- 82FFCCA256FFDAAF5CFFDCAF5BFFC99A4BFFBF8643FFB78443FFB99A52FF96A5
- 62FF65A676FFA2D8BDFF2F7A32FF5ABA66FF92D7AFFFA0DEB4FF84C670FFA8D0
- 80FFC5A55CFFD0A757FFE0AA56FFDAA651FFC7984AFFB98C47FFB69B57FF819F
- 65FF79BF90FF81BE9CFF2F7A32FF0000000053AF5DFFB5EAD3FF69BC74FF6EBD
- 71FFBEB66DFFC9A35BFFDFAB5BFFDDA858FFC1924EFF9DA958FF78B166FF5A96
- 67FFA6DCC0FF2F7A32FF00000000000000004EA857FF76C08DFF99D7B3FF79C0
- 80FFBCC27EFFC6A96AFFD7B169FFD6AD65FFBC9B5EFF60AD6AFF599768FF81C1
- 99FF67A97BFF2F7A32FF000000000000000000000000469B4DFF70B786FFAEE8
- C7FFC0D2A0FFC5B381FFCAB47DFFCCAF78FFB9A778FF80CC95FFA0DABCFF66A8
- 7AFF2F7A32FF00000000000000000000000000000000000000003D8F43FF3A8A
- 3FFF9BC59DFFB3C29DFFBDC19CFFBEC39DFFB0D2B1FF7EC09AFF2F7A32FF2F7A
- 32FF000000000000000000000000000000000000000000000000000000000000
- 0000338037FF317D34FF2F7A32FF2F7A32FF2F7A32FF2F7A32FF000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000068C774FF68C673FF65C2
- 71FF62BE6EFF5FBA6AFF5CB565FF58AF61FF53A95CFF4FA357FF46974DFF0000
- 0000000000000000000000000000000000000000000067C673FF000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 00003B8842FF0000000000000000000000000000000063C06EFF0000000067C6
- 73FF67C572FF64C170FF61BD6CFF5DB968FF5AB464FF56AE60FF50A659FF4DA2
- 56FF479A50FF46974EFF419149FF00000000000000005FBB6AFF0000000067C6
- 73FF0000000059B264FF57AE60FF54AB5DFF51A75AFF4DA256FF479950FF4697
- 4EFF408E47FF408F47FF3B8842FF00000000000000005BB565FF0000000064C1
- 6FFF5AB465FF57AF61FF54AB5EFF51A65AFF4CA156FF499B51FF43934AFF4090
- 47FF3B8741FF3A8741FF35803BFF000000000000000056AE60FF0000000060BC
- 6BFF58B062FF54AB5EFF51A659FF4CA055FF489A50FF43944BFF3D8B45FF3A87
- 41FF357F3BFF347F3AFF307835FF00000000000000004EA358FF000000005CB6
- 66FF52A85BFF4EA357FF4A9D52FF45974DFF419048FF3C8A43FF37833EFF357F
- 3BFF2F7835FF2F7734FF2A712FFF00000000000000004C9F54FF0000000057AF
- 61FF4FA559FF4B9E54FF46984EFF429148FF3D8A43FF38843EFF337D39FF2F77
- 34FF29702FFF296F2EFF256A2AFF000000000000000046974EFF419149FF51A7
- 5BFF499B51FF44944BFF3F8E46FF3B8741FF36813CFF317A37FF2D7532FF296F
- 2EFF256929FF256929FF216425FF000000000000000000000000000000004C9F
- 54FF47994FFF42924AFF3D8C45FF39853FFF347F3AFF307835FF2B7230FF276D
- 2CFF246828FF206324FF1D5F21FF000000000000000000000000000000004697
- 4EFF419149FF3C8A43FF38833EFF337D39FF2F7734FF2A712FFF266B2BFF2366
- 27FF206223FF1D5E20FF1A5B1EFF000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 000000000000000000000000000000000000000000000000000000000000009A
- FDFF0099FCFF000000000000000000000000000000000191F5FF018FF3FF0000
- 000000000000000000000000000000000000000000000000000016A4FDFF43B6
- FEFF4EBBFEFF0196F9FF00000000000000000191F5FF4BB8FDFF33A8F9FF028B
- EFFF0000000000000000000000000000000000000000000000001EA5FDFF5BC0
- FEFF63C4FFFF0F9BF8FF00000000000000001A9CF6FF54BCFFFF46B4FCFF0289
- EDFF000000000000000000000000000000000000000000000000000000002DAA
- FBFF61C4FFFF38AEFBFF0190F4FF018EF2FF37ABF9FF52BBFFFF249DF4FF0000
- 0000000000000000000000000000000000000000000000000000000000000193
- F7FF32ABFAFF5AC0FEFF018EF2FF38ACF9FF53BCFFFF2CA2F6FF0286EBFF0000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000018FF3FF56BDFEFF4EB9FEFF4EBAFFFF42B1FBFF0285EAFF000000000000
- 00000000000000000000000000000196F9FF179FF9FF0193F6FF0191F5FF018F
- F3FF018DF1FF45B4FCFF49B9FFFF47B7FFFF3FAFFBFF0283E8FF0381E6FF037E
- E4FF037CE2FF1186E6FF0477DDFF0194F8FF50BAFDFF6BC7FFFF53BBFDFF4AB5
- FBFF49B3FBFF52BDFFFF47B8FFFF43B5FFFF48B8FFFF43AFFAFF3BAAF8FF44B1
- FBFF4BB7FFFF36A5F6FF0471D8FF0192F6FF0190F4FF018EF3FF028DF1FF028B
- EFFF0289EDFF3EAEFAFF46B7FFFF42B5FFFF3CADFAFF037EE3FF037BE1FF0379
- DFFF0475DCFF0470D7FF056BD2FF000000000000000000000000000000000000
- 00000286EBFF50B9FEFF42B2FCFF46B7FFFF3CABF9FF037BE1FF000000000000
- 0000000000000000000000000000000000000000000000000000000000000286
- EBFF2EA1F4FF47B2FAFF037FE5FF32A2F3FF48B6FFFF2797EEFF0474DAFF0000
- 00000000000000000000000000000000000000000000000000000285EAFF289D
- F1FF55BDFFFF2598EFFF00000000037AE0FF2F9EF2FF42B4FFFF218CE6FF0000
- 00000000000000000000000000000000000000000000000000002198F0FF52BB
- FEFF4AB4FCFF037CE2FF00000000000000001885E2FF40B3FFFF3BAAF9FF1373
- D5FF0000000000000000000000000000000000000000000000000380E6FF32A1
- F3FF2A9AEFFF000000000000000000000000056CD3FF37A1F2FF2488E3FF065E
- C6FF00000000000000000000000000000000000000000000000000000000037B
- E1FF0379DFFF000000000000000000000000000000000662C9FF000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000001281827053222890732
- 20B50B3C2ABC0B3C2BBE0A4029BC0C4729BC0D4228BE0C412BBC0B442BB6073B
- 238D093B232C0000000000000000000000000A402D0408352363083925D30A3D
- 25FA0C4029FF0B3F2AFF093A27FF0B3A26FF0D3F28FF0C4127FF0B4125FA0A3E
- 25D40A3B27640836240400000000104231010C43302A0B402E9F0C412CEB0D42
- 2AFE0D422AFF0B3D29FF0C3D28FF0C4027FF0B4226FF0B4227FF0B4127FE0B41
- 28EB0E442CA110462E2A0831180106342301063220570B3F2BCF0B3F28F90833
- 20FF093723FF0B3E28FF0D422BFF0D442CFF0B422DFF0B422DFF0C452BFF0C44
- 28F90D462ED00E4B36580E4C3701073D2625093D26840A3E28E30B3E28FD0B3E
- 28FF0A3B24FF0B3E27FF0D422AFF0D432AFF0C432CFF0C422BFF0C412AFF0C41
- 2BFD0B442DE40A432C85083C26280D49324A0B3E28B50A3E26ED0B4226FD0D44
- 26FF0D4328FF0E412BFF10432EFF0F442EFF0D422CFF0D432AFF0C4028FF0A3C
- 25FD093924ED083623B50625185005321E74093924D30B4029F50D432DFD0D44
- 2EFB0B422AF80A3C25F90A3823FC0B3B26FC0B412BF90D442BF80D442BFB0B3E
- 26FD083520F6083925D5073A25790D442A5B0D442B8C083D2A89083B2A860635
- 258B05311F8F06321D8D08351F88083B258808402A8D0A402B8F0B3F2B8B0B3D
- 2786083724890B3A298C0B3B2A600E462C0B0D462D090A422F050B4332050632
- 230A042C1C0C03291809042B1804063D2604063E2809083D290C093C2A0A0C3F
- 2C05184B3605134432090D3D2C0B0E472D020B452E010B4533010B3F2F010630
- 2102042B1C01032616010000000000000000053E2701083D2901083C29020C3E
- 2D011A4F3B011A4D39010E3E2D02000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000000000000000000000FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
- FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
- FF00FFFFFF00FFFFFF00FFFFFF00000000000000000000000000000000000000
- 00000000000000000000000000FF000000FF0000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 000000000000000000FF000000FF000000FF000000FF00000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000FF000000FF000000FF000000FF000000FF000000FF000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 00FF000000FF000000FF000000FF000000FF000000FF000000FF000000FF0000
- 0000000000000000000000000000000000000000000000000000000000FF0000
- 00FF000000FF000000FF000000FF000000FF000000FF000000FF000000FF0000
- 00FF0000000000000000000000000000000000000000161616FF1D1D1DFF0F0F
- 0FFF070707FF282828FF0B0B0BFF282828FF121212FF040404FF0B0B0BFF0F0F
- 0FFF000000FF0000000000000000000000003B3B3BFF616161FF4F4F4FFF5151
- 51FF282828FF494949FF4D4D4DFF777777FF565656FF323232FF4B4B4BFF4848
- 48FF2E2E2EFF383838FF000000005A5A5AFF484848FF7B7B7BFF616161FF5151
- 51FF282828FF6A6A6AFF494949FF777777FF565656FF565656FF616161FF1111
- 11FF747474FF333333FF000000FF000000FF000000FF000000FF000000FF0000
- 00FF000000FF000000FF000000FF000000FF000000FF000000FF000000FF0000
- 00FF000000FF000000FF000000FF00000000000000FF000000FF000000FF0000
- 00FF000000FF000000FF000000FF000000FF000000FF000000FF000000FF0000
- 00FF000000FF000000FF000000000000000000000000000000FF000000FF0000
- 00FF000000FF000000FF000000FF000000FF000000FF000000FF000000FF0000
- 00FF000000FF0000000000000000000000000000000000000000000000FF0000
- 00FF000000FF000000FF000000FF000000FF000000FF000000FF000000FF0000
- 00FF000000000000000000000000000000000000000000000000000000000000
- 00FF000000FF000000FF000000FF000000FF000000FF000000FF000000FF0000
- 0000000000000000000000000000000000000000000000000000000000000000
- 0000000000FF000000FF000000FF000000FF000000FF000000FF000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 000000000000000000FF000000FF000000FF000000FF00000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 00000000000000000000000000FF000000FF0000000000000000000000000000
- 0000000000000000000000000000536876FF5C6A5DFF5F6D60FF5F6D60FF5F6D
- 60FF5F6D60FF5F6D61FF5F6D61FF5F6D61FF5F6D61FF606D61FF606D62FF606D
- 62FF606D63FF5E6A5FFF454E46FF5C6A5DFFFBFCFBFFFCFEFCFFF7FCF8FFF7FC
- F8FFF7FCF8FFF8FCF8FFF7FCF9FFF8FCF8FFF8FCF8FFECF7EEFFEDF7EEFFEFF6
- EDFFEEF4ECFFEBF4EBFF5E6A5FFF5F6D60FFF7FCF8FF9DF9F9FF6CB4EDFF6271
- FEFF80E7E9FF8CF4F4FF52CDCDFFECC2A4FFDDAD8AFFEBBA97FFDDA780FFE2AB
- 83FFDAA075FFD9EAD4FF616E64FF5F6D60FFF7FCF8FF8AEAEAFF72DDDEFF5665
- F0FF569FDFFF73E8E8FF46C1C1FFBBBBA5FFD0A483FFDEB08EFFD19E7AFFD6A2
- 7AFFCF9871FFD7EBD5FF626E64FF5F6D61FFF7FCF8FF9FF9F9FF85E9EAFF84D3
- FAFF525AF0FF87F2F7FF60DAD7FF98D5CAFFE0B79CFFEDC7A9FFE0B394FFE6B8
- 98FFDEAE8CFFD7ECD6FF636E64FF5F6D61FFF8FCF8FF90EAEAFF78DDDEFF81E9
- EAFF4E6BE2FF639DEEFF5ED7D7FF5BCBC9FFD4B097FFE2BA9FFFA1ADA9FF58A5
- D8FF85B1DBFF469DD0FF4E7C8CFF5F6D61FFF8FCF8FFA6F9F9FF8BE9EAFF99F8
- FAFF78D3EBFF656BFFFF77DCEAFF70DFDEFFC1C5B5FFA8C8C8FF77BEE7FFB4D2
- F0FFE5F3FFFFACD2EFFF4A89BEFF606D61FFF8FCF8FF9FF1F1FF81DDDFFF8AEA
- EBFF75DEDEFF6591EEFF557EE2FF68DCDDFF5BBCC5FF80D5EDFFB2E3F9FF8BC0
- E7FFAED3F6FFC4E0FCFF669DD0FF606D62FFF8FCF8FFAFFAFAFF94EBEBFFA2F9
- FAFF8AEAEBFF95EDF3FF595FEBFF6BCFE5FF7CD4EEFFC4F6FDFF6CDDF6FF6DCA
- EDFF63A3D7FF66A1D3FF617474FF606D63FFF8FCF8FFA4EBEDFF8DDFDFFF97EB
- EBFF72CFB7FF74CA99FF4790BDFF79D3EEFFC7F7FDFF5FDCF5FF5BE2F7FF7AD6
- F2FF4399DFFFB1D4D9FF646F66FF616E63FFF8FCF9FFBCFBFBFF9DE7DFFF93E1
- BBFF77C997FF63BDAEFF77CBE7FFC7F7FDFF5EDCF5FF5AE1F7FF7BD4F1FF4395
- DDFF589BC3FFD0E9DBFF646F66FF616E63FFF7FBF8FF9BDEC4FF73C393FF80CF
- 9FFF53AD9CFF73B9D5FFC2F6FDFF63DFF7FF5DE2F8FF79D3F0FF4395DAFF6CB8
- A4FF74C38FFFD7EFDAFF646F66FF616E64FFECF7EEFF96DBAFFF7FC99AFF63AD
- A5FF7AB6D5FF90B7D1FF55C9E4FF5BDFF5FF78D0EDFF4696D9FF76C1A1FF87D0
- A0FF80CA9AFFD6EEDAFF646F66FF626E64FFEEF8EFFFA4DBBCFF8CCAA6FF4389
- AAFFE0F2FFFF549AD8FF1A7ABEFF4998C5FF3B86BFFF6074E7FF81C5A3FF8CD0
- A6FF85CAA0FFD2E9D7FF646F67FF5F6A60FFEBF5ECFFD4EDD7FFD4EED7FF2E67
- 84FF94C7F9FF91C9F9FF4185C9FF256BACFFB7D9D4FFD4E2ECFFCFE5D6FFD5ED
- D9FFD8EFDCFFD5EDD9FF616C63FF454D47FF5F6A61FF636F64FF646F64FF143F
- 56FF295F86FF4988BCFF4A86A7FF5D7070FF646F66FF646F66FF646F67FF646F
- 67FF647067FF616C63FF474E48FFFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
- FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
- FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
- FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
- FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF0066C472FF64C270FF62BF
- 6EFF60BC6BFF5DB868FF5BB565FF58B162FD55AC5FEA52A85BB74FA358704B9F
- 541DFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF0064C170FFA6DBB0FFA6DA
- AFFFA3D9ADFFA2D8ABFF9FD7A8FF9CD5A5FF94D09DFF83C58CFF6CB474FF4799
- 50B044944C39FFFFFF00FFFFFF00FFFFFF00FFFFFF0062BE6DFFA5DAAEFFA2D8
- ACFFA1D8AAFF9ED6A7FF9CD5A5FF99D4A2FF97D29FFF8CCD95FF91CF99FF73B8
- 7BFF408F47B03C8A431DFFFFFF00FFFFFF00FFFFFF005FBA6AFF5CB667FF59B3
- 64FF56AE60FF53AA5DFF50A659FF4DA156FF68B170FF88C890FF8DCC95FF8BCB
- 92FF5DA564FF38853F70FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
- FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF0046974E8F42924AE281C388FF7DC4
- 85FF6EB375FF357F3BB7FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
- FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF003E8D458F64AB6BFF7FC4
- 86FF79BE81FF317A36EAFFFFFF00FFFFFF00FFFFFF00FFFFFF0052A85B034FA3
- 587BFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF003A87418F61A867FF7BC2
- 82FF76BC7CFF2D7532EAFFFFFF00FFFFFF00FFFFFF00FFFFFF004EA3579F4B9E
- 53D2FFFFFF00FFFFFF00FFFFFF00FFFFFF003A86408F36813CE275BB7BFF70BD
- 77FF63AB69FF2A702EB7FFFFFF00FFFFFF00FFFFFF004DA2569367B16FFF64AD
- 6BFF43944BFF408F47FF3C8A43FF398540FF549D5AFF74BA7AFF79C17FFF77BF
- 7DFF4A914FFF266B2B70FFFFFF00FFFFFF004DA1568A66B06EFF8ACA92FF89CA
- 90FF86C88DFF83C68AFF80C587FF7EC384FF7BC281FF6DBB74FF76BE7CFF59A0
- 5DFF266B2AB02367271DFFFFFF00FFFFFF00499C518462AC6AFF85C88DFF85C7
- 8BFF82C688FF7FC486FF7CC282FF79C180FF71B978FF5FA865FF49914EFF256A
- 2AB023662739FFFFFF00FFFFFF00FFFFFF00FFFFFF00429149905AA462FF58A1
- 5EFF37833EFF347E3AFF317A36FF2E7533FF2B712FEA286D2CB7256929702266
- 261DFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF003A87419C3782
- 3DD2FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
- FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF0036813C03337D
- 3978FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
- FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00B0E2
- F55CA7DCF5B59DD9F5E291D1F1F782CBF0F876C4EFED6DBFEDD177C3EE80FFFF
- FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00AFE0F619ADDEF6B7B7E4
- F8FFC7ECFBFFD7F3FCFFE1F7FDFFE2F8FEFFD8F0FCFFB6DFF8FF6BBBEDFF56AF
- E8DE77BEEC2CFFFFFF00FFFFFF00FFFFFF00B2E1F50BA2DBF4CAC3EBFAFFE2F9
- FDFFE0F9FDFFD5F7FDFFCFF6FDFFC9F4FCFFC7F4FCFFD6F9FDFFEBFAFEFF90CA
- F2FF43A2E4ED78BEE917FFFFFF00FFFFFF0098D6F489B4E3F8FFE5FAFEFFDBF8
- FDFFE4FAFEFFF0FCFEFFF9FEFFFFF9FEFFFFEFFCFEFFD2F6FDFFB4F1FBFFEDFD
- FFFF6BB3EAFF58A9E4B6FFFFFF00FFFFFF0088CDF1E4D2EFFBFFDBF9FEFFDFF9
- FDFFECFBFEFFEEFCFEFFEFFCFEFFEFFCFEFFEBFBFEFFE0F9FEFFB8F1FBFFA8F1
- FBFFCBE5F8FF3892DCF7FFFFFF00FFFFFF007BC5EEF9DFF6FDFFC8F5FCFFCDF6
- FCFFD6F7FDFFD3F4FCFFCFF2FCFFCAF1FBFFC4F0FCFFBAF2FBFF96EAF8FF72E5
- F7FFE2F4FDFF3189D8FEFFFFFF00FFFFFF006FBEECE3C9E9F9FFD4F9FDFF7CE3
- F7FF86E5F8FF60B1EFFF68B5EFFF63B4EFFF4CA6ECFF82E4F7FF59DCF5FF8AEB
- FAFFCBE2F7FF338BD9F7FFFFFF00FFFFFF0078C0EC888BC8EFFFECFCFEFF77E1
- F7FF2F99EAFF75E1F6FF74E1F6FF68DEF5FF73E1F6FF0986E6FF46D5F3FFDCFE
- FEFF6FAAE5FF4C99DEBFFFFFFF00FFFFFF0080C6F00468B5E9D8A5D4F3FFDCFA
- FEFF38A1EBFF74E1F6FF6AE4F6FF5DE2F5FF72E0F6FF1691E8FFC0F5FDFFACCE
- F1FF2780D6F86FAEE425FFFFFF00FFFFFF00FFFFFF0078BDEB2F5CACE7EBA6D3
- F3FF65AEF0FF74E1F6FF73E1F6FF72E0F6FF71E0F6FF4CA3ECFF9CC3EFFF297F
- D6FB65A8E25AFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF0075B9EA3461A7
- DEE7469DE6FF4BBEF7FF47E6FDFF41E5FDFF51C3FBFF167CDEFF3382D1F266AA
- E346FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF0085A7
- BF4B638195FA7A95A3FF3A8A98FF357F8CFF606E76FF2D4357FE7FA2BE40FFFF
- FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
- FF0068777DE2A6A5A2FFA8A2A2FF9D9998FF948F8BFF434B53EBFFFFFF00FFFF
- FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
- FF005F6E77C6BCBCBBFFEBEAEAFFCDCCCCFFA3A19FFF3F4C55DBFFFFFF00FFFF
- FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
- FF0088A7BB5D485055F5444545FE3F4141FE3F474AF67D9CB16AFFFFFF00FFFF
- FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
- FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
- FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
- FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
- FF006D9CD4896A9AD2FB6697CFEEFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
- FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00709ED6DB6D9C
- D4FF85B1DAFF5A91B9FF6093CBEAFFFFFF00FFFFFF00808080FF7E7E7EFF7C7C
- 7CFF7A7A7AFF777777FF757575FF727272FF719ED4FF6F9ED6FF87B2DCFFABD3
- E8FFA9D0E6FF5890B8FF598EC6EAFFFFFF00FFFFFF007D7D7DFF999999FF9999
- 99FF9A9A9AFF9A9A9AFF9B9B9BFF9B9B9BFF6F9DD3FFAAD1E7FFABD1E7FF98C7
- E1FF91C2DEFF568FB7FF5289C1EAFFFFFF00FFFFFF007A7A7AFF999999FF5291
- 59FF999A99FF9B9B9BFF9C9C9CFF9C9C9CFF6C9AD0FFA7CEE5FF8FC1DFFF89BD
- DCFF8BBDDCFF538DB6FF4B84BCEAFFFFFF00FFFFFF00777777FF9A9A9AFF3D8A
- 45FF498A4FFF9C9C9CFF9D9D9DFF9D9D9DFF6696CCFFA2CBE3FF89BDDCFF83B9
- DAFF84B9DAFF518BB5FF437EB6EA44944DFF42914BFF3F8D48FF3D8945FF5DA4
- 65FF5AA061FF45834BFF9E9E9EFF9E9E9EFF6092C9FF9EC7E2FF83B8DAFF7DB4
- D7FF7EB3D7FF4F89B4FF3B79B1EA41904AFF94D29FFF91D09AFF8DCD96FF89CB
- 92FF84C88DFF519858FF417C46FF9F9F9FFF5A8EC4FF98C3E0FF7CB3D7FF74AF
- D6FF5EC4EDFF4B88B3FF3473ABEA3E8B46FF8FCE99FF7DC687FF78C381FF73C0
- 7CFF74C07CFF79C281FF49904FFF547F57FF5489BFFF94BFDDFF75ADD4FF63B8
- E1FF4BD4FFFF428BB8FF2C6EA6EA3B8742FF89CB92FF84C88DFF80C688FF7BC3
- 83FF77C17FFF478F4DFF3B743FFFA1A1A1FF4C84BAFF8DBBDBFF6EA8D1FF66A6
- D1FF5FB4DFFF4785B1FF2569A1EA37823EFF347E3BFF317937FF2E7534FF4991
- 50FF468F4CFF39733DFFA1A1A1FFA2A2A2FF457EB4FF88B7D9FF67A3CFFF619E
- CCFF639FCCFF4583B1FF1F649CEAFFFFFF00FFFFFF00606060FFA0A0A0FF3D76
- 41FF367139FFA2A2A2FFA2A2A2FFA3A3A3FF3D79B0FF82B3D7FF629FCCFF5A9A
- C9FF5E9BCAFF4381AFFF196098EAFFFFFF00FFFFFF005C5C5CFFA1A1A1FF3C73
- 40FFA0A1A1FFA3A3A3FFA3A3A3FFA4A4A4FF3674AAFF7DAFD4FF5B9AC9FF5495
- C7FF5896C8FF4180AEFF135C94EAFFFFFF00FFFFFF00585858FFA2A2A2FFA2A2
- A2FFA3A3A3FFA4A4A4FFA4A4A4FFA5A5A5FF2F6FA5FF78ABD2FF78ABD3FF73A7
- D1FF69A0CDFF407FAEFF0F5991EA999999FF717171FF545454FF515151FF4F4F
- 4FFF4C4C4CFF4A4A4AFF474747FF454545FF25679DFF3274A8FF3D7CAFFF4784
- B5FF4E8ABAFF3E7EADFF0C578FEAFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
- FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF001D639B1619609839145D9562105A
- 92880D5890A4135C92FC0C578FED
- }
- end
- object pmTileList: TPopupMenu
- left = 184
- top = 128
- object mnuAddToRandom: TMenuItem
- Caption = 'Add to random pool'
- OnClick = btnAddRandomClick
- end
- end
- object ApplicationProperties1: TApplicationProperties
- OnIdle = ApplicationProperties1Idle
- OnShowHint = ApplicationProperties1ShowHint
- left = 295
- top = 33
- end
- object pmTools: TPopupMenu
- Images = ImageList1
- left = 328
- top = 33
- object mnuSelect: TMenuItem
- Action = acSelect
- Bitmap.Data = {
- 36040000424D3604000000000000360000002800000010000000100000000100
- 2000000000000004000064000000640000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000007C7C
- 7CFF787878FF757575FF000000000000FF00FF00000000000000000000000000
- 000000000000000000000000000000000000000000000000000000000000AAAA
- AAFFDBDBDBFF797979FF000000000000FF00FF00000000000000000000000000
- 0000000000000000000000000000000000000000000000000000888888FFDBDB
- DBFFB7B7B7FF7D7D7DFF000000000000FF00FF00000000000000000000000000
- 000000000000000000009C9C9CFF000000000000000000000000ADADADFFF2F2
- F2FF848484FF00000000000000000000FF00FF00000000000000000000000000
- 00000000000000000000A0A0A0FF9C9C9CFF00000000949494FFD9D9D9FFC1C1
- C1FF898989FF00000000000000000000FF00FF00000000000000000000000000
- 00000000000000000000A4A4A4FFD7D7D7FF9D9D9DFFD0D0D0FFEEEEEEFF9191
- 91FF0000000000000000000000000000FF00FF00000000000000000000000000
- 00000000000000000000A9A9A9FFF2F2F2FFE5E5E5FFE2E2E2FFE3E3E3FF9595
- 95FF919191FF8D8D8DFF898989FF868686FFFF00000000000000000000000000
- 00000000000000000000ADADADFFEEEEEEFFE1E1E1FFDFDFDFFFE0E0E0FFE7E7
- E7FFE4E4E4FFBBBBBBFF8E8E8EFF0000FF00FF00000000000000000000000000
- 00000000000000000000B1B1B1FFF0F0F0FFE4E4E4FFE2E2E2FFE2E2E2FFE7E7
- E7FFC1C1C1FF969696FF000000000000FF00FF00000000000000000000000000
- 00000000000000000000B5B5B5FFF2F2F2FFE8E8E8FFE7E7E7FFEAEAEAFFC6C6
- C6FF9E9E9EFF00000000000000000000FF00FF00000000000000000000000000
- 00000000000000000000B9B9B9FFF4F4F4FFECECECFFEDEDEDFFCBCBCBFFA7A7
- A7FF0000000000000000000000000000FF00FF00000000000000000000000000
- 00000000000000000000BDBDBDFFF7F7F7FFEFEFEFFFD0D0D0FFAFAFAFFF0000
- 00000000000000000000000000000000FF00FF00000000000000000000000000
- 00000000000000000000C1C1C1FFF7F7F7FFD5D5D5FFB6B6B6FF000000000000
- 00000000000000000000000000000000FF00FF00000000000000FFFFFF00FFFF
- FF00FFFFFF00FFFFFF00C4C4C4FFD9D9D9FFBEBEBEFFFFFFFF00FFFFFF00FFFF
- FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FF0000000000000008000000DB87
- 4100DB874100DB874100C8C8C8FFC5C5C5FF0000000000000000000000000000
- 000000000000000000000000000000000000EFFFFF00FFFFFF00F0A3E30008E9
- 120000000000000000000851A500F52E74000000000040000000F8040600AC04
- 0600000000000000000000000000C00406000000000000000000
- }
- GroupIndex = 1
- RadioItem = True
- OnClick = acSelectExecute
- end
- object mnuDraw: TMenuItem
- Action = acDraw
- Bitmap.Data = {
- 36040000424D3604000000000000360000002800000010000000100000000100
- 2000000000000004000064000000640000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 00000000000000000000000000000000FF00FF00000000000000000000001340
- 58FF15425EFF25699CFF2C76B4FF3B8BBAFF0000000000000000000000000000
- 00000000000000000000000000000000FF00FF00000000000000000000001242
- 59FF5D9CD4FFA6CFF5FFA9CFECFF488BC1FF2C76B4FF00000000000000000000
- 00000000000000000000000000000000FF00FF00000000000000000000001E6D
- 93FFCBE3F9FF61AAECFF4098E8FF1567C2FF1660AAFF2C76B4FF000000000000
- 00000000000000000000000000000000FF00FF00000000000000000000001E6D
- 93FFC8E1F2FFD1E7FAFF347DB5FF3199C3FF6DC4DCFF4A9CCFFF3483C7FF0000
- 00000000000000000000000000000000FF00FF00000000000000000000000000
- 00002689B9FFB0CBE1FF67A9C8FF60DCF5FF44D6F4FF8EEEFAFF5DB4E6FF3B8F
- D9FF0000000000000000000000000000FF00FF00000000000000000000000000
- 0000000000002689B9FFBEE6F2FFB3F4FCFF60DCF5FF44D6F4FF8EEEFAFF5DB4
- E6FF3B8FD9FF00000000000000000000FF00FF00000000000000000000000000
- 000000000000000000002790BFFFC3EDF8FFB3F4FCFF60DCF5FF44D6F4FF8EEE
- FAFF5DB4E6FF3B8FD9FF000000000000FF00FF00000000000000000000000000
- 00000000000000000000000000002FBAE4FFC3EDF8FFB3F4FCFF60DCF5FF44D6
- F4FF8EEEFAFF5DB4E6FF3B8FD9FF0000FF00FF00000000000000000000000000
- 0000000000000000000000000000000000002FBAE4FFC3EDF8FFB3F4FCFF60DC
- F5FF44D6F4FF8EEEFAFF5DB4E6FF3B8FD9FFFF00000000000000000000000000
- 000000000000000000000000000000000000000000002FBAE4FFC3EDF8FFB3F4
- FCFF68D9F5FF6FCFF3FF599DD0FF73ABDDFF4F91C9FF00000000000000000000
- 00000000000000000000000000000000000000000000000000002FBAE4FFC3ED
- F8FFA8E2F8FF6CAEDDFFA5CFF4FFA5CFF4FFBDDBF7FF5393CBFF000000000000
- 0000000000000000000000000000000000000000000000000000000000002FBA
- E4FFA7D4F4FFC5E1F8FFCCE3F9FFCCE3F9FFBDDBF7FF4F90C9FFFFFFFF00FFFF
- FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
- FF0050A8D9FF6AA5D8FFC9E1F7FFCBE3F8FF4295CAFF3182C2FF08000000FF33
- 3300FF333300FF333300FF333300FFFFFF000000000000000000000000000000
- 0000000000004FAADBFF5093CAFF4E90C8FF2F9DD2FFFFFFFF00F0A3E3007804
- 060000000000000000000851A5001E9B7000000000004000000028E62400DCE5
- 2400000000000000000000000000F0E524000000000000000000
- }
- GroupIndex = 1
- RadioItem = True
- OnClick = acDrawExecute
- end
- object mnuMove: TMenuItem
- Action = acMove
- Bitmap.Data = {
- 36040000424D3604000000000000360000002800000010000000100000000100
- 200000000000000400006400000064000000000000000000000053A85AFF51A6
- 58FF4FA356FF4EA154FF4C9F52FFA8AAAC00A5A7AA00A3A6A800A7A9AC00AEAF
- B100ABADB000429046FF418E45FF408D43FF3F8B42FF3E8A41FF54AB5CFF83BF
- 89FF7DBB83FF54A65BFFB2B4B500B0B2B300B7B8BA00B1B3B500ACAFB100AAAC
- AF00A8AAAC00A5A7AA00429046FF6DAD71FF6EAE73FF3F8C42FF56AD5FFF83C0
- 8AFF73B77AFF6CB473FF50A457FFA9ACAE00A7AAAB00ACAFB100B3B5B600B2B4
- B500B0B2B300459449FF5AA05EFF5EA664FF6CAD70FF408D44FF58B061FF57AE
- 5FFF6CB673FF84C08AFF6EB574FF50A457FFBEBFC100B2B5B600AFB2B300ADAF
- B10048994DFF5DA561FF75B379FF5FA463FF47944CFF418F45FF5AB363FFB9BC
- BD0057AE5FFF6CB673FF6AB471FF52A759FFB3B5B700BABDBE00B8BABC00B6B8
- B9004A9B4FFF5FA764FF62A867FF45954AFFB2B4B600439147FFB8BABC00C2C4
- C500BFC1C20057AE5FFF55AC5DFFC9CBCC00B9BCBD00B5B8BA00B2B4B600AFB1
- B300ABAEB0004A9C50FF48994EFFB8BABC00B6B8B900BEC0C200C0C1C300BABC
- BE00B7B9BB00B3B5B700AFB2B400B8BABC00C2C4C500BFC1C200BDBEBF00C4C5
- C600CED0D100C0C1C300BABCBE00B7B9BB00B3B5B700AFB2B400CACBCC00C7C9
- CB00C4C6C700CBCCCD00CED0D100C0C1C300BABCBE00B7B9BB00B3B5B700AFB2
- B400B8BABC00C2C4C500BFC1C200BDBEBF00C4C5C600CED0D100C1C3C500BEC0
- C200B9BBBD00B4B7B900BFC1C300CACBCC00C7C9CB00C4C6C700CBCCCD00D5D5
- D600C7C8CA00C1C3C500BEC0C200B9BBBD00B4B7B900BFC1C300CCCFD000CBCD
- CD00D0D1D200D5D5D600C7C8CA00C1C3C500BEC0C200B9BBBD00B4B7B900BFC1
- C300CACBCC00C7C9CB00C4C6C700CBCCCD00D5D5D600C7C8CA00C2C4C500BEC0
- C100B9BBBC0060BB6AFF5EB968FFCCCFD000CBCDCD00D0D1D200DADBDC00CCCF
- D000C7CACB0053A95BFF52A759FFB9BBBC00C5C7C900D0D1D10065C370FFD5D6
- D70063BF6DFF80C989FF79C482FF5FB969FFBEC0C100B9BBBC00C5C7C900D0D1
- D10057AE5FFF6EB875FF6CB573FF52A759FFCCCFD0004EA255FF66C472FF6BC5
- 75FF83CC8CFF9BD3A4FF7BC784FF60BC6BFFD5D6D700E1E1E200D4D5D600CDCF
- D10059B161FF75BD7DFF8CC793FF6DB673FF52A759FF50A557FF67C673FF9DD6
- A5FF92D19BFF7ECA87FF63C06EFFC2C5C700BEC0C100CBCCCE00D8D9D900D4D7
- D800D1D4D40059B162FF76BD7EFF7EC086FF8AC590FF52A85AFF68C774FFA1D8
- A9FF9ED6A7FF65C371FFD8DADA00D9DBDC00E5E6E700D9DBDC00D4D5D700CDD0
- D100C7C9CB00C2C5C6005FB467FF8DC894FF8EC995FF54AA5CFF68C774FF68C7
- 74FF67C673FF66C572FF65C371FFC2C5C600D0D2D300DEE0E000DADCDD00D8DA
- DA00D9DBDC005CB666FF5BB464FF59B262FF58AF60FF56AD5EFF
- }
- GroupIndex = 1
- RadioItem = True
- OnClick = acMoveExecute
- end
- object mnuElevate: TMenuItem
- Action = acElevate
- Bitmap.Data = {
- 36040000424D3604000000000000360000002800000010000000100000000100
- 20000000000000040000640000006400000000000000000000000000BD0000A5
- 9C00001A420000B5A00013C0F80028FC0000B3A50A00C9800000FC000000F800
- 0000EC5506003A9F0000B3A50A00C9800000FC000000F80016004BDB0000FC00
- 0000F80027000000280000000000FE1E0000286E2DFF256929FF216425FF1E60
- 22FF0028FC000028FC000000280000002800000028000028FC00000028000000
- 28000028FC000027F3000EFC0E00000000002D7533FF74BD7AFF72BD78FF2265
- 26FF4BDB0000FC000000F80000006500000000000000FE1E0000130000000000
- 0000FE0000002CF30000FC000000F8002800337D39FF79C07EFF76BF7CFF266B
- 2BFFFC0000000FFE1F0000004C000028FC000028FC00000028000028FC000028
- FC000000280000002800000028000028FC0039853FFF7DC282FF7AC180FF2B72
- 30FF002CF80028FC0000FE0000002CF30000FC000000F80011004CDB0000FF10
- 0000F20023000000000000000000FE1E00003F8D46FF81C587FF7EC385FF317A
- 36FF15000000FE1E00004CDB0000FC00000026FD000000002B00FC00000028FC
- 0000000028000028FC000028FF000000280045954CFF85C78CFF82C689FF3682
- 3DFF0BFB1D000039DF000EFE1C000049F80028FC0000FE1E000014C2F80028FC
- 0000B2A80A00CB7F0000FF810300C60010004A9E53FF8ACA91FF87C98EFF3C8A
- 43FFFF810300C60028000000280095060800B2A80A00CB7F000065E2BA0013AC
- F10090040000FC00000028FC00000000280050A659FF8ECC95FF8BCB93FF4292
- 4AFF830380000028FC000487C10000A2AC000CB3890000B4A300000B9A00F09D
- 08000016B600D86AF80028FC000013ACF10056AD5FFF93CF9AFF90CE98FF489A
- 50FF0000000013ACF10090040000FC6AEA003C00E600F4F45900000000000000
- 2800000000000000060000000000000000005BB465FF96D29FFF94D09CFF5DAC
- 65FFB728FC00E2BA280068E9E1006EE9E4000028FC000031F100000000000028
- FC000283CF000000000065C371FF62BF6EFF79C683FF9AD4A3FF98D3A1FF7DC3
- 86FF4FA458FF4A9E53FFED5706003E9F00000000000000000000CA5A00000000
- 000000000000000000000000280066C472FF7CCA87FF9ED6A7FF9CD4A5FF73C0
- 7DFF55AC5EFF000028000026FC00000000000006000000000000000000000000
- 000000000000000000000028FF00F5CE350066C572FF7ECA88FF7BC885FF5DB8
- 68FF00000000000000000000000000000000000000003CBBF000000000000000
- 0000000000000000000000000000000000000000000067C673FF65C270FF0000
- 00000000000000000000FC00000028FC000000002800000EFC00E8A3E300802E
- 6400000000000000000000000000000000000000000000000000000000000000
- 000000000000000000000000000026F000000000000000000000
- }
- GroupIndex = 1
- RadioItem = True
- OnClick = acElevateExecute
- end
- object mnuDelete: TMenuItem
- Action = acDelete
- Bitmap.Data = {
- 36040000424D3604000000000000360000002800000010000000100000000100
- 20000000000000040000640000006400000000000000000000000FFE1F000000
- 4C000028FC000028FC000000280000002800000028000009F100A06131FFB676
- 3FFFA46534FF0DFD1E0000000000FE1E00004BDB0000FF0600002CF30000FC00
- 0000F8002800000028000028FC000011FF00000000009F5E2FFFE7B263FFBF92
- 4FFFDDAB62FFA26232FF0028FC000000240000000000F30028001E000000DB00
- 280026FD0000C79751FFD8A65AFFA66C36FF00002800A86835FFD1A057FF0000
- 9D008E6A36FFB4753FFF0000000024FE000000000000FE00000000000000FE1E
- 0000B58244FFD6A45AFFAE8241FFECB666FFA76E36FFAC6C37FFC49551FF0000
- 0E001E000000B77840FF100031000028FC000028FF0000000E000028FF000608
- 0000BE8A4AFFA87E41FF28FC0000966E32FFE7B066FFCAA274FFE5B167FF945E
- 2DFFB88D4DFFAF703BFF0C00D500000EFD00000000000EFD1F000F04380000AD
- AD009C6A32FFD6A55EFFCB7F0000FC000000E4AD60FFDCBD9BFFEFCDA5FFEFB7
- 67FFD8A65DFF00000000A80A16007F002800810384000028FC006AEAE30000E6
- FF00F459FC00B17E42FFDCAA60FFD09E54FFEAB365FFD8BA99FFF8EBE1FFAE89
- 57FF06082800850380008303800000000100592AFA000000AD00AF80B0000000
- 1000EFF09F000010A4009D6932FFB17E42FF9E682CFFBC9767FFF0E0D0FFB691
- 5FFF00E6FF00F431CD000000000000000000ACF1EC0004002800000000000000
- 0000000000000028FC00000000000006000000000000B68F59FFF5E9DDFFE2CD
- B4FFB99461FFB728FC00E2BA280068E9E1006EE9E40000000000000000000000
- 0000F6DC510000000000000000000000000000000000B28A54FFF1E2D3FFCFB3
- 8EFFF5E9DCFF000000000028FC0000004200570602009F000000BBF0F4005A00
- 00000000000000000000000000000028FC0000000000AF8750FFEDDECEFF0000
- 2800CEB38FFFE7D6C3FF0026FC00000000000006000000000000000000000000
- 00000000000000000000C3EC0600000000000000000000000000E6D4C0FF0000
- 000000000000D3B999FFD3B897FF000000000028FC0000000000000000000000
- 0000000000000000000000000000000000000000000000000000DEC8AEFF0000
- 00000000000000002800D1B693FFBB9767FF000EFC000000000000007800F407
- 0000000000000000000000000000000000000000000000000000D5BC9DFF0000
- 0000000000000000000000000000AE854CFF0000000000000000080000000000
- 0000000000000000000000000000FFFFFF000000000000000000CBAE87FF0000
- 0000000000000000000000000000000000000000000000000000E8A3E3000022
- 780000000000000000000851A500E3AF75000000000078000000A77B3EFFA4F0
- 9D00000000000000000000000000B8F09D000000000000000000
- }
- GroupIndex = 1
- RadioItem = True
- OnClick = acDeleteExecute
- end
- object mnuSetHue: TMenuItem
- Action = acHue
- Bitmap.Data = {
- 36040000424D3604000000000000360000002800000010000000100000000100
- 2000000000000004000064000000640000000000000000000000000000000000
- 000000000000000000000000000000000000FF00000000000000000000000000
- 0000000000000000000000000000000000000000000000000000000000000000
- 000000000000000000000000000000000000000000001D65A0FF1A639EFF1761
- 9BFF000000000000000000000000000000000000000000000000000000000000
- 000000000000000000000000000000000000256BA6FF87AEE1FF7FA9DCFF6093
- C9FF3173ACFF15609AFF0000000000000000FF00000000000000000000000000
- 00000000000000000000000000002D70ADFF6E9ED1FF9ABDEBFF72A1E3FF97BA
- EAFF95B9EAFF6194CAFF16609AFF000000000000000000000000000000000000
- 00000000000000000000000000003274B1FF9EC0ECFF6A9DE2FF5C94DFFF5992
- DFFF6095E0FF96B9EAFF87AEE1FF4A84BCFF145F99FF00000000000000000000
- 0000427FBDFF3F7DBAFF3B7AB8FF77A5D7FFA2C3EDFFA0C1EDFF9EC0EDFF75A4
- E4FF5B93DFFF5991DEFF7CA8E6FF93B7E8FF4480B8FF000000004F88C7FF6598
- CFFF7CA9D9FF8EB5E2FFA4C5EDFFA8C7EEFF6598CDFF3576B3FF6094C9FFA0C1
- EDFF7997A4FF9F9749FF7D9592FF8EB4E9FF7AA6D8FF19629DFF538BCBFFAFCD
- F0FFB1CFF0FF99C0ECFF7FAFE7FFABCAEFFF3E7CB9FF000000003677B4FFA3C4
- EDFFA99832FFC5B65BFFAD9827FF5C94DFFF99BCEBFF1D65A0FF588ECEFFA9C9
- EDFF85A8EDFF596BEDFF6B8FE9FFAECDF0FF6E9ED2FF3F7DBAFF689ACEFFA6C6
- EEFF969B6AFFAE9827FF9E984EFF679CE2FF99BCEAFF2268A3FF5C91D1FF93BA
- E5FF6F75F6FF8285F5FF4141F0FF91BCEBFFAFCDF0FFADCCF0FFABCAF0FF86B3
- E9FF5FAAC2FF45B48EFF57A9B7FF71A2E4FF98BBE8FF266BA7FF000000005D92
- D2FF93A5F5FF5A5BF6FF5287F4FF3CA7FBFF5DACF2FF7FB0E7FF7CAEE7FF79AB
- E6FF40B781FF61C898FF3CB87BFF7EADE7FF90B6E3FF2B6FABFF000000006194
- D5FF87B0E1FFBAD7F3FF33A7FEFF6DC0FFFF2CA4FFFF67BFF0FF3BCEFBFF5BBF
- F1FF53B4A1FF3CB87AFF48B491FFA8C8EEFF78A6D6FF3072AFFFFFFFFF00FFFF
- FF006295D6FF86AFE1FF5BB3F9FF2CA4FFFF41AAFBFF31D3FEFF6DE2FFFF2CD5
- FFFF80B1E8FF7DAEE7FFAACAEFFFA6C6EDFF3878B6FF00000000FFFFFF00FFFF
- FF00FFFFFF00FFFFFF006094D5FF8FB7E3FFBAD7F3FF5ED5FBFF2BD5FFFF42D1
- FBFFB4D2F2FFB2D0F1FF93B9E2FF6396CCFF3E7CB9FFFFFFFF0008000000888A
- 8C00888A8C00888A8C00888A8C006194D5FF77A4DCFF92B9E4FFA9CAECFFA6C7
- ECFF8EB6E2FF699BD2FF4A84C3FF00000000EFFFFF00FFFFFF00E8A3E30070F0
- 9D0000000000000000000851A500D7AD7500000000005F93D4FF5C91D1FF598F
- CFFF558DCCFF000000000000000020B45F000000000000000000
- }
- GroupIndex = 1
- RadioItem = True
- OnClick = acHueExecute
- end
- object mnuSeparator3: TMenuItem
- Caption = '-'
- end
- object mnuBoundaries: TMenuItem
- Action = acBoundaries
- Bitmap.Data = {
- 36040000424D3604000000000000360000002800000010000000100000000100
- 200000000000000400006400000064000000000000000000000000B2AD000022
- CC000028FC000028FC00000028000000280000002800005AEE00181818008900
- AC000E04380000ACAA0004380000B3A50A00C9800000F25807004BDB00003232
- 32FF2D2D2DFF282828FF0027FC000000CD000000000000000E001E000000DB00
- 2800000028000027FC00040404FF010101FF000000FFDB002800000000003A3A
- 3AFFB7B7B7FF313030FFD89066FFD88E64FFD68C62FFD58961FFD5895FFFD586
- 5DFFD4855BFFD4855AFF090909FFA6A6A6FF030303FFFE1E0000000000004242
- 42FF3D3D3DFF534B46FFE3AD8DFFE2AB8BFFE1AA8AFFE1A888FFE0A787FFDFA5
- 85FFDFA484FFDEA383FF42332BFF0A0A0AFF070707FF000024000028FF000000
- 0E00DD9B73FFE4B192FFE4AF91FFE3AE8FFFE3AC8DFFE1AB8BFFE1A989FFE1A8
- 88FFE0A786FFDFA585FFDFA384FFD4865DFF0000000024FE0000000000000EFD
- 1F00DE9F77FFE5B495FFE4B393FFE4B192FFE3AF90FFE3AE8EFFE2AC8DFFE1AA
- 8BFFE1A989FFE0A787FFDFA686FFD5895FFF100031000028FC00810384000028
- FC00E1A27BFFE6B798FFE6B596FFE5B494FFE4B292FFE4B191FFE3AF8FFFE3AD
- 8DFFE2AC8CFFE1AA8AFFE1A989FFD68C62FF0C00D500000EFD00592AFA000000
- AD00E1A67FFFE8BA9BFFE7B899FFE6B697FFE6B596FFE5B394FFE4B192FFE4AF
- 91FFE3AE8FFFE3AD8DFFE2AB8BFFD88E66FFA80A16007F002800ACF1EC000400
- 2800E3AA81FFE9BC9EFFE8BB9CFFE8B99AFFE7B899FFE6B697FFE6B495FFE4B3
- 94FFE4B192FFE3AF90FFE3AE8FFFD9926AFF83038000000001006EE9E4000000
- 0000E3AC85FFEABFA0FFEABE9FFFE8BC9DFFE8BA9CFFE8B99AFFE6B798FFE6B6
- 96FFE5B494FFE4B393FFE4B191FFDA966CFF0000000000000000570602009F00
- 0000E5AF86FFEBC1A2FFEAC0A2FFEABEA0FFE9BD9EFFE8BC9DFFE8BA9BFFE7B8
- 99FFE6B698FFE6B596FFE5B394FFDC9A70FFE2BA280068E9E100000600000000
- 0000E5B289FFEBC3A5FFEBC2A3FFEBC0A2FFEABFA1FFEABEA0FFE9BD9EFFE8BB
- 9DFFE8BA9BFFE7B899FFE6B697FFDE9D75FF0028FC00000042000028FC008686
- 86FF838383FF968D87FFEBC4A5FFEBC2A4FFEBC2A3FFEAC0A2FFEABFA0FFEABE
- 9FFFE8BC9EFFE8BB9CFF7E726AFF535353FF4F4F4FFF00000000000EFC008989
- 89FFD3D3D3FF848484FFE6B38CFFE5B28AFFE5B289FFE5AF86FFE5AE86FFE3AC
- 85FFE3AB83FFE3A980FF626262FFC4C4C4FF585858FF00000000000000008989
- 89FF888888FF878787FF00000000000000000000000000000000000000000000
- 000000000000000000006B6B6BFF666666FF626262FF00002800C8A3E300C8A3
- E300A8182F00A8182F0000000000000000000000000000000000000000000000
- 0000000000000000000000000000000000000000000000000000
- }
- OnClick = acBoundariesExecute
- end
- object mnuVirtualLayer: TMenuItem
- Action = acVirtualLayer
- Bitmap.Data = {
- 36040000424D3604000000000000360000002800000010000000100000000100
- 200000000000000400006400000064000000000000000000000010A6F1009E00
- 0000A6F1EF0000001500F1ED920000006200DF6FF80028FC000028F8000093F1
- F000000000002900000070A1E30070A1E30020E55C0088A1E300FF1C00000011
- 9C00F4E181000028FC000028FC000000280000002800000028000028FF00F4F4
- F4000016B700D869F80028FC000093F1F0008D000000005AE500000000000000
- 0000000000000000000046974EFF419149FF3C8A43FF38833EFF337D39FF2F77
- 34FF2A712FFF266B2BFF236627FF206223FF1D5E20FF1A5B1EFF000000000000
- 000000000000000000004C9F54FF47994FFF42924AFF3D8C45FF39853FFF347F
- 3AFF307835FF2B7230FF276D2CFF246828FF206324FF1D5F21FF000000000000
- 000046974EFF419149FF51A75BFF499B51FF44944BFF3F8E46FF3B8741FF3681
- 3CFF317A37FF2D7532FF296F2EFF256929FF256929FF216425FF58FC00000028
- FF004C9F54FF28FFF40057AF61FF4FA559FF4B9E54FF46984EFF429148FF3D8A
- 43FF38843EFF337D39FF2F7734FF29702FFF296F2EFF256A2AFF0028FC000000
- 00004EA358FF1171F1005CB666FF52A85BFF4EA357FF4A9D52FF45974DFF4190
- 48FF3C8A43FF37833EFF357F3BFF2F7835FF2F7734FF2A712FFF000000000000
- 000056AE60FF0000000060BC6BFF58B062FF54AB5EFF51A659FF4CA055FF489A
- 50FF43944BFF3D8B45FF3A8741FF357F3BFF347F3AFF307835FFE81ADD00E81A
- DD005BB565FF0000000064C16FFF5AB465FF57AF61FF54AB5EFF51A65AFF4CA1
- 56FF499B51FF43934AFF409047FF3B8741FF3A8741FF35803BFF3FDE47000000
- 00005FBB6AFF0000000067C673FFDE3F6A0059B264FF57AE60FF54AB5DFF51A7
- 5AFF4DA256FF479950FF46974EFF408E47FF408F47FF3B8842FF000000000000
- 000063C06EFF00FFFF0067C673FF67C572FF64C170FF61BD6CFF5DB968FF5AB4
- 64FF56AE60FF50A659FF4DA256FF479A50FF46974EFF419149FF0000000000FF
- FF0067C673FF0000000000000000000000000000000000FFFF00FF0000000000
- 00000000000000000000000000003B8842FFFF00000000000000F90600000000
- 000068C774FF68C673FF65C271FF62BE6EFF5FBA6AFF5CB565FF58AF61FF53A9
- 5CFF4FA357FF46974DFFFF000000000000000000000000000000FFFFFF00FFFF
- FF00FFFFF9004E0009003FDE460000000000000000000000000000000600DE3F
- 7B00C63E0000000000000000000000000000000000003EC6D900080000000000
- 3C00F0F4CA000000000000000000FFFFFF000000000000000000000000000000
- 000000000000000000000000000000000000004ECB00FFFFFF00A8A3E300A8A3
- E3003019DD003019DD000851A50092B075000000000018000000B019DD006419
- DD000000000000000000000000007819DD000000000000000000
- }
- OnClick = acVirtualLayerExecute
- end
- end
- object pmClients: TPopupMenu
- left = 184
- top = 176
- object mnuGoToClient: TMenuItem
- Caption = 'GoTo'
- Default = True
- OnClick = mnuGoToClientClick
- end
- end
- object tmMovement: TTimer
- Enabled = False
- Interval = 500
- OnTimer = tmMovementTimer
- OnStartTimer = tmMovementTimer
- left = 232
- top = 80
- end
- object ActionList1: TActionList
- Images = ImageList1
- left = 264
- top = 80
- object acSelect: TAction
- Category = 'Tools'
- Caption = 'Select'
- Checked = True
- GroupIndex = 1
- Hint = 'Select'
- ImageIndex = 4
- OnExecute = acSelectExecute
- ShortCut = 112
- end
- object acDraw: TAction
- Category = 'Tools'
- Caption = 'Draw tiles'
- GroupIndex = 1
- Hint = 'Draw tiles'
- ImageIndex = 5
- OnExecute = acDrawExecute
- ShortCut = 113
- end
- object acMove: TAction
- Category = 'Tools'
- Caption = 'Move tiles'
- GroupIndex = 1
- Hint = 'Move tiles'
- ImageIndex = 6
- OnExecute = acMoveExecute
- ShortCut = 114
- end
- object acElevate: TAction
- Category = 'Tools'
- Caption = 'Elevate tiles'
- GroupIndex = 1
- Hint = 'Elevate tiles'
- ImageIndex = 7
- OnExecute = acElevateExecute
- ShortCut = 115
- end
- object acDelete: TAction
- Category = 'Tools'
- Caption = 'Delete tiles'
- GroupIndex = 1
- Hint = 'Delete tiles'
- ImageIndex = 8
- OnExecute = acDeleteExecute
- ShortCut = 116
- end
- object acHue: TAction
- Category = 'Tools'
- Caption = 'Hue tiles'
- GroupIndex = 1
- Hint = 'Hue tiles'
- ImageIndex = 12
- OnExecute = acHueExecute
- ShortCut = 117
- end
- object acBoundaries: TAction
- Category = 'Settings'
- Caption = 'Boundaries'
- Hint = 'Boundaries'
- ImageIndex = 9
- OnExecute = acBoundariesExecute
- ShortCut = 118
- end
- object acFilter: TAction
- Category = 'Settings'
- AutoCheck = True
- Caption = 'Filter'
- Hint = 'Filter'
- ImageIndex = 16
- OnExecute = acFilterExecute
- end
- object acVirtualLayer: TAction
- Category = 'Settings'
- Caption = 'Virtual Layer'
- Hint = 'Virtual Layer'
- ImageIndex = 15
- OnExecute = acVirtualLayerExecute
- ShortCut = 119
- end
- object acFlat: TAction
- Category = 'Settings'
- Caption = 'Flat view'
- Hint = 'Flat view'
- ImageIndex = 17
- OnExecute = acFlatExecute
- end
- object acNoDraw: TAction
- Category = 'Settings'
- Caption = 'NoDraw'
- Checked = True
- Hint = 'Display "No Draw" tiles'
- ImageIndex = 18
- OnExecute = acNoDrawExecute
- end
- object acUndo: TAction
- Category = 'Tools'
- Caption = 'Undo'
- Enabled = False
- Hint = 'Undo last set of changes'
- ImageIndex = 20
- OnExecute = acUndoExecute
- ShortCut = 16474
- end
- object acLightlevel: TAction
- Category = 'Settings'
- Caption = 'Lightlevel'
- Hint = 'Set Lightlevel'
- ImageIndex = 21
- OnExecute = acLightlevelExecute
- end
- object acWalkable: TAction
- Category = 'Settings'
- AutoCheck = True
- Caption = 'Walkable'
- Hint = 'Highlight (un)walkable surfaces'
- ImageIndex = 22
- OnExecute = acWalkableExecute
- ShortCut = 16471
- end
- end
- object tmGrabTileInfo: TTimer
- Enabled = False
- Interval = 250
- OnTimer = tmGrabTileInfoTimer
- left = 368
- top = 80
- end
- object pmGrabTileInfo: TPopupMenu
- OnPopup = pmGrabTileInfoPopup
- left = 368
- top = 33
- object mnuGrabTileID: TMenuItem
- Caption = 'Grab TileID'
- OnClick = mnuGrabTileIDClick
- end
- object mnuGrabHue: TMenuItem
- Caption = 'Grab Hue'
- OnClick = mnuGrabHueClick
- end
- end
- object pmFlatViewSettings: TPopupMenu
- left = 368
- top = 136
- object mnuFlatShowHeight: TMenuItem
- AutoCheck = True
- Caption = 'Show Height'
- OnClick = mnuFlatShowHeightClick
- end
- end
- object XMLPropStorage1: TXMLPropStorage
- StoredValues = <>
- RootNodePath = 'Forms/frmMain'
- Active = False
- OnRestoreProperties = XMLPropStorage1RestoreProperties
- left = 368
- top = 208
- end
-end
+object frmMain: TfrmMain
+ Left = 257
+ Height = 579
+ Top = 141
+ Width = 755
+ ActiveControl = oglGameWindow
+ Caption = 'UO CentrED'
+ ClientHeight = 558
+ ClientWidth = 755
+ Constraints.MinHeight = 500
+ Constraints.MinWidth = 750
+ Font.Height = -11
+ Menu = MainMenu1
+ OnActivate = FormActivate
+ OnClose = FormClose
+ OnCreate = FormCreate
+ OnDestroy = FormDestroy
+ Position = poScreenCenter
+ SessionProperties = 'acFlat.Checked;acNoDraw.Checked;Height;Left;mnuFlatShowHeight.Checked;mnuSecurityQuestion.Checked;mnuShowAnimations.Checked;spTileList.Top;tbStatics.Down;tbTerrain.Down;Top;Width;WindowState;mnuWhiteBackground.Checked'
+ ShowInTaskBar = stAlways
+ LCLVersion = '1.3'
+ WindowState = wsMaximized
+ object pnlBottom: TPanel
+ Left = 0
+ Height = 31
+ Top = 527
+ Width = 755
+ Align = alBottom
+ BevelOuter = bvNone
+ ClientHeight = 31
+ ClientWidth = 755
+ TabOrder = 0
+ object lblX: TLabel
+ Left = 11
+ Height = 13
+ Top = 7
+ Width = 11
+ Caption = 'X:'
+ ParentColor = False
+ end
+ object lblY: TLabel
+ Left = 88
+ Height = 13
+ Top = 7
+ Width = 10
+ Caption = 'Y:'
+ ParentColor = False
+ end
+ object lblTileInfo: TLabel
+ Left = 240
+ Height = 13
+ Top = 7
+ Width = 4
+ Caption = ' '
+ ParentColor = False
+ end
+ object lblTip: TLabel
+ Left = 501
+ Height = 31
+ Top = 0
+ Width = 246
+ Align = alRight
+ Alignment = taRightJustify
+ BorderSpacing.Right = 8
+ Caption = 'Right click shows a menu with all the tools.'
+ Layout = tlCenter
+ ParentColor = False
+ end
+ object lblTipC: TLabel
+ Left = 473
+ Height = 31
+ Top = 0
+ Width = 28
+ Align = alRight
+ Caption = 'Tip: '
+ Font.Height = -11
+ Font.Style = [fsBold]
+ Layout = tlCenter
+ ParentColor = False
+ ParentFont = False
+ end
+ object edX: TSpinEdit
+ Left = 24
+ Height = 25
+ Top = 3
+ Width = 55
+ MaxValue = 100000
+ TabOrder = 0
+ end
+ object edY: TSpinEdit
+ Left = 104
+ Height = 25
+ Top = 3
+ Width = 52
+ MaxValue = 100000
+ TabOrder = 1
+ end
+ object btnGoTo: TButton
+ Left = 168
+ Height = 23
+ Top = 3
+ Width = 51
+ BorderSpacing.InnerBorder = 4
+ Caption = 'GoTo'
+ OnClick = btnGoToClick
+ TabOrder = 2
+ end
+ end
+ object pcLeft: TPageControl
+ Left = 0
+ Height = 503
+ Top = 24
+ Width = 224
+ ActivePage = tsTiles
+ Align = alLeft
+ TabIndex = 0
+ TabOrder = 1
+ object tsTiles: TTabSheet
+ Caption = 'Tiles'
+ ClientHeight = 472
+ ClientWidth = 218
+ object lblFilter: TLabel
+ AnchorSideLeft.Control = cbTerrain
+ AnchorSideLeft.Side = asrBottom
+ AnchorSideTop.Control = cbTerrain
+ Left = 89
+ Height = 13
+ Top = 8
+ Width = 31
+ BorderSpacing.Left = 16
+ Caption = 'Filter:'
+ ParentColor = False
+ end
+ object vdtTiles: TVirtualDrawTree
+ Tag = 1
+ AnchorSideLeft.Control = tsTiles
+ AnchorSideTop.Control = cbStatics
+ AnchorSideTop.Side = asrBottom
+ AnchorSideRight.Control = tsTiles
+ AnchorSideRight.Side = asrBottom
+ AnchorSideBottom.Control = spTileList
+ Left = 4
+ Height = 224
+ Hint = '-'
+ Top = 60
+ Width = 210
+ Anchors = [akTop, akLeft, akRight, akBottom]
+ BorderSpacing.Left = 4
+ BorderSpacing.Top = 4
+ BorderSpacing.Right = 4
+ DefaultNodeHeight = 44
+ DragMode = dmAutomatic
+ DragOperations = []
+ DragType = dtVCL
+ Header.AutoSizeIndex = 2
+ Header.Columns = <
+ item
+ Position = 0
+ Text = 'ID'
+ end
+ item
+ Position = 1
+ Text = 'Tile'
+ Width = 44
+ end
+ item
+ Position = 2
+ Text = 'Name'
+ Width = 100
+ end>
+ Header.DefaultHeight = 17
+ Header.MainColumn = 2
+ Header.Options = [hoShowHint, hoVisible]
+ Header.ParentFont = True
+ Header.Style = hsFlatButtons
+ HintMode = hmHint
+ ParentShowHint = False
+ PopupMenu = pmTileList
+ ShowHint = True
+ TabOrder = 0
+ TreeOptions.AutoOptions = [toAutoScroll, toAutoScrollOnExpand, toAutoTristateTracking, toAutoDeleteMovedNodes]
+ TreeOptions.MiscOptions = [toFullRepaintOnResize, toInitOnSave, toToggleOnDblClick, toWheelPanning, toFullRowDrag]
+ TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toThemeAware, toUseBlendedImages, toStaticBackground]
+ TreeOptions.SelectionOptions = [toFullRowSelect, toMultiSelect]
+ OnClick = vdtTilesClick
+ OnDrawHint = vdtTilesDrawHint
+ OnDrawNode = vdtTilesDrawNode
+ OnEnter = vdtTilesEnter
+ OnGetHintSize = vdtTilesGetHintSize
+ OnKeyPress = vdtTilesKeyPress
+ OnScroll = vdtTilesScroll
+ end
+ object gbRandom: TGroupBox
+ AnchorSideLeft.Control = tsTiles
+ AnchorSideTop.Control = spTileList
+ AnchorSideTop.Side = asrBottom
+ AnchorSideRight.Control = tsTiles
+ AnchorSideRight.Side = asrBottom
+ AnchorSideBottom.Control = tsTiles
+ AnchorSideBottom.Side = asrBottom
+ Left = 0
+ Height = 183
+ Top = 289
+ Width = 218
+ Anchors = [akTop, akLeft, akRight, akBottom]
+ Caption = 'Random pool'
+ ClientHeight = 169
+ ClientWidth = 216
+ TabOrder = 1
+ object btnAddRandom: TSpeedButton
+ AnchorSideLeft.Control = gbRandom
+ AnchorSideTop.Control = gbRandom
+ Left = 4
+ Height = 22
+ Hint = 'Add'
+ Top = 0
+ Width = 23
+ BorderSpacing.Left = 4
+ Glyph.Data = {
+ 36040000424D3604000000000000360000002800000010000000100000000100
+ 2000000000000004000064000000640000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000003A8C44FF368940FF32873CFF2F84
+ 37FF000000000000000000000000000000000000000000000000000000000000
+ 00000000000000000000459653FF419950FF7DC28FFF96D0A6FF96CFA6FF78BE
+ 89FF368D42FF2C8134FF00000000000000000000000000000000000000000000
+ 0000000000004D9C5DFF64B478FFA8DBB5FF87CC98FF66BC7DFF64BA7CFF86CB
+ 98FFA5D9B4FF58AA6BFF2C8134FF000000000000000000000000000000000000
+ 000056A366FF6AB97DFFA8DBB2FF60BC77FF5CBA73FF59B870FF59B56FFF58B5
+ 6FFF5BB774FFA5D9B3FF5AAA6CFF2C8234FF0000000000000000000000000000
+ 000053AB68FFAADDB4FF64C179FF5FBE71FF60BC77FFFFFFFFFFFFFFFFFF59B8
+ 70FF58B56EFF5CB774FFA6DAB4FF388F43FF00000000000000000000000061AC
+ 75FF8ACC98FF89D396FF6BC67AFF63C170FF55AB65FFFFFFFFFFFFFFFFFF59B8
+ 70FF59B870FF5BB972FF85CC97FF7BBE8DFF308539FF000000000000000065AF
+ 7AFFA9DDB3FF7DCF8AFF75CC81FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
+ FFFFFFFFFFFF59B870FF67BE7DFF9CD4ABFF34883DFF000000000000000069B2
+ 7EFFB6E2BEFF8BD597FF7AC986FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
+ FFFFFFFFFFFF59B870FF69C17EFF9DD4AAFF388B42FF00000000000000006DB5
+ 83FFACDDB6FFA6DFAFFF81CB8CFF7CC986FF6EBD79FFFFFFFFFFFFFFFFFF5BAC
+ 6AFF60BC77FF5CBA73FF8BD199FF80C592FF3C8E47FF00000000000000000000
+ 000085C797FFD2EED7FF95D9A0FF8AD394FF7FC889FFFFFFFFFFFFFFFFFF79CD
+ 85FF6BC37CFF6FC77EFFACDFB5FF459E57FF0000000000000000000000000000
+ 000070B887FFAADAB7FFD8F1DCFF92D89DFF88CD93FF84CC8EFF8BD496FF8AD4
+ 95FF83D28EFFAFE0B7FF6BB97DFF489856FF0000000000000000000000000000
+ 00000000000070B887FFAFDCBBFFDCF2E0FFB6E4BDFF9BDBA5FF96D9A0FFA5DF
+ AFFFC0E8C5FF79C28AFF509E5FFF000000000000000000000000000000000000
+ 0000000000000000000071B887FF94CEA4FFC3E6CBFFCFEBD4FFC9E9CEFFAFDD
+ B8FF6DB97FFF58A569FF00000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000006EB684FF6AB380FF67B17CFF63AE
+ 77FF000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000
+ }
+ OnClick = btnAddRandomClick
+ ShowHint = True
+ ParentShowHint = False
+ end
+ object btnDeleteRandom: TSpeedButton
+ AnchorSideLeft.Control = btnAddRandom
+ AnchorSideLeft.Side = asrBottom
+ AnchorSideTop.Control = btnAddRandom
+ Left = 31
+ Height = 22
+ Hint = 'Delete'
+ Top = 0
+ Width = 23
+ BorderSpacing.Left = 4
+ Glyph.Data = {
+ 36040000424D3604000000000000360000002800000010000000100000000100
+ 2000000000000004000064000000640000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000003853BEFF3551BDFF304BBCFF2E4E
+ B8FF000000000000000000000000000000000000000000000000000000000000
+ 000000000000000000004255C6FF3C52CCFF757AE8FF8F92EEFF8F92EEFF7178
+ E4FF334DC1FF2B4AB7FF00000000000000000000000000000000000000000000
+ 0000000000004959CBFF5C65E0FFA1A6F5FF7E86EFFF5B63E9FF595DE7FF7D84
+ EEFF9EA0F4FF515DD7FF2B4AB7FF000000000000000000000000000000000000
+ 00005361CFFF616BE3FFA1ACF5FF545FECFF505CEAFF4D59E9FF4E59E6FF4C56
+ E6FF5056E6FF9EA2F4FF5460D6FF2A4AB8FF0000000000000000000000000000
+ 00004B56DBFFA2ABF6FF5664F0FF5266EEFF4D59E9FF4D59E9FF4D59E9FF4D59
+ E9FF4C58E6FF525AE6FF9FA3F5FF3450C4FF0000000000000000000000005C62
+ D7FF818CEEFF7E91F7FF5D73F3FF4D59E9FF4D59E9FF4D59E9FF4D59E9FF4D59
+ E9FF4D59E9FF4F5BE9FF7B83F0FF757BE2FF2E4BBAFF00000000000000005F63
+ DAFFA1ABF7FF7086F8FF6882F6FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
+ FFFFFFFFFFFF4D59E9FF5C66EAFF969CF1FF3250BCFF00000000000000006469
+ DBFFAFB9F9FF7F93FAFF7085F0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
+ FFFFFFFFFFFF4D59E9FF5E6AEEFF969DF1FF364FBEFF0000000000000000676A
+ DEFFA5AFF5FF9DABFAFF778CF0FF545FECFF545FECFF545FECFF545FECFF545F
+ ECFF545FECFF6377F2FF818EF4FF787FE9FF3A53C0FF00000000000000000000
+ 00007D83EAFFCDD4FCFF8B9DFAFF7E93F7FF758AEEFF6C84F6FF6C84F6FF6C84
+ F6FF6C84F6FF6379F3FFA4AFF8FF3E4FD0FF0000000000000000000000000000
+ 00006A69E0FFA3A7F3FFD4DBFDFF879AFAFF7F91F0FF7A8EF1FF7F94F8FF7E92
+ F9FF768CF8FFA8B6F8FF636EE3FF4557C7FF0000000000000000000000000000
+ 0000000000006A69E0FFAAADF2FFD8DCFDFFAEBAFAFF91A3FAFF8B9DFAFF9CA9
+ FBFFBAC7FCFF707BE9FF4C5BCCFF000000000000000000000000000000000000
+ 000000000000000000006A6ADFFF8E93EDFFBEC3F8FFCCD3F9FFC4CBF9FFAAB4
+ F4FF6670E2FF535ED1FF00000000000000000000000000000000000000000000
+ 000000000000000000000000000000000000686ADDFF6364DCFF6164DAFF5D63
+ D9FF000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000
+ }
+ OnClick = btnDeleteRandomClick
+ ShowHint = True
+ ParentShowHint = False
+ end
+ object btnClearRandom: TSpeedButton
+ AnchorSideLeft.Control = btnDeleteRandom
+ AnchorSideLeft.Side = asrBottom
+ AnchorSideTop.Control = btnDeleteRandom
+ Left = 58
+ Height = 22
+ Hint = 'Clear'
+ Top = 0
+ Width = 23
+ BorderSpacing.Left = 4
+ Glyph.Data = {
+ 36040000424D3604000000000000360000002800000010000000100000000100
+ 2000000000000004000064000000640000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 000000000000000000000000F1FF0000F1FF0000F1FF0000F1FF0000EFFF0000
+ EFFF0000EDFF0000EDFF00000000000000000000000000000000000000000000
+ 0000000000000000F5FF1A20F5FF3C4CF9FF3A49F8FF3847F8FF3545F8FF3443
+ F7FF3242F7FF141BF1FF0000EDFF000000000000000000000000000000000000
+ 00000000F7FF1D23F9FF4453FAFF2429F9FF1212F7FF0F0FF6FF0C0CF5FF0909
+ F5FF161BF5FF3343F7FF141BF1FF0000EDFF0000000000000000000000000000
+ F9FF1F25FAFF4A58FBFF4247FBFFC9C9FDFF3B3BF9FF1313F7FF1010F6FF3333
+ F7FFC5C5FDFF3035F7FF3444F7FF141BF2FF0000EDFF00000000000000000000
+ FBFF4F5DFDFF3237FBFFCBCBFEFFF2F2FFFFEBEBFEFF3B3BF9FF3939F8FFEAEA
+ FEFFF1F1FEFFC5C5FDFF181DF6FF3343F7FF0000EFFF00000000000000000000
+ FDFF525FFDFF2828FCFF4747FCFFECECFFFFF2F2FFFFECECFFFFECECFEFFF1F1
+ FFFFEAEAFEFF3434F7FF0B0BF5FF3545F8FF0000EFFF00000000000000000000
+ FDFF5562FEFF2C2CFDFF2929FCFF4848FCFFEDEDFFFFF2F2FFFFF2F2FFFFECEC
+ FEFF3A3AF9FF1212F7FF0F0FF6FF3848F8FF0000F1FF00000000000000000000
+ FDFF5764FEFF3030FDFF2D2DFDFF4B4BFCFFEDEDFFFFF2F2FFFFF2F2FFFFECEC
+ FFFF3D3DF9FF1616F8FF1313F7FF3C4BF8FF0000F1FF00000000000000000000
+ FFFF5A67FEFF3333FEFF5050FDFFEDEDFFFFF3F3FFFFEDEDFFFFEDEDFFFFF2F2
+ FFFFECECFEFF3E3EFAFF1717F8FF3F4EF9FF0000F1FF00000000000000000000
+ FFFF5B68FFFF4347FEFFCFCFFFFFF3F3FFFFEDEDFFFF4C4CFCFF4A4AFCFFECEC
+ FFFFF2F2FFFFCACAFEFF2A2FFAFF4251FAFF0000F3FF00000000000000000000
+ FFFF262BFFFF5D6AFFFF585BFFFFCFCFFFFF5252FEFF2F2FFDFF2C2CFDFF4B4B
+ FCFFCCCCFEFF484CFBFF4957FBFF1D23F9FF0000F5FF00000000000000000000
+ 00000000FFFF262BFFFF5D6AFFFF4347FFFF3434FEFF3232FEFF3030FDFF2D2D
+ FDFF383CFCFF4F5DFCFF1F25FAFF0000F7FF0000000000000000000000000000
+ 0000000000000000FFFF262BFFFF5C69FFFF5B68FFFF5A67FEFF5865FEFF5663
+ FEFF5461FEFF2227FCFF0000FBFF000000000000000000000000000000000000
+ 000000000000000000000000FFFF0000FFFF0000FFFF0000FFFF0000FDFF0000
+ FDFF0000FDFF0000FDFF00000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000
+ }
+ OnClick = btnClearRandomClick
+ ShowHint = True
+ ParentShowHint = False
+ end
+ object btnRandomPresetSave: TSpeedButton
+ AnchorSideTop.Control = cbRandomPreset
+ AnchorSideRight.Control = btnRandomPresetDelete
+ Left = 164
+ Height = 22
+ Hint = 'Save Preset'
+ Top = 138
+ Width = 22
+ Anchors = [akTop, akRight]
+ BorderSpacing.Right = 4
+ Glyph.Data = {
+ 36040000424D3604000000000000360000002800000010000000100000000100
+ 2000000000000004000064000000640000000000000000000000000000000000
+ 000000000000000000000000000000000000BA6833FFC38458FFD38B68FFE18F
+ 70FFDC8D6CFFDA8B6DFFD78A6EFFCD8B6CFFAB6D44FFA65F2EFF00000000BA65
+ 30FFBB6631FFBA6630FFBA6630FFBA6530FFC68355FFEFCEBAFFDDFFFFFF87EE
+ C7FFA2F4D7FFA2F6D7FF8CEEC7FFE0FFFFFFDDA285FFAB6A3EFFBC6933FFF8F1
+ EAFFF7ECDFFFF6EADEFFF6EADCFFF6EADCFFC37F51FFEFB69AFFEAF3E8FF51BF
+ 84FF6FC998FF71C999FF54BF84FFE4F4E9FFDD9C7BFFAA693AFFBF7138FFF5EB
+ DFFFFDBF68FFFBBE65FFFCBE64FFFCBE64FFC48154FFEAB697FFF3F3EAFFEDF1
+ E6FFEFF1E6FFEFF0E6FFEDF1E5FFF3F5EDFFD59C79FFB07044FFC1783CFFF7ED
+ E3FFFDC26EFFFFD79EFFFFD69BFFFFD798FFC98B61FFE6B592FFE2A781FFE1A7
+ 81FFDEA37DFFDCA17BFFDB9F79FFD99E77FFD49A73FFBB7E57FFC47C40FFF7F0
+ E6FFF8B455FFF7B554FFF8B453FFF8B253FFCA8D65FFEAB899FFDDA57EFFDDA6
+ 80FFDBA37CFFD9A07AFFD9A079FFD89F78FFD89E78FFBF845DFFC58245FFF8F2
+ EBFFFEE7D6FFFDE7D6FFFDE7D6FFFDE6D5FFC8885DFFEFBFA1FFFDFCFAFFFEFC
+ FBFFFEFDFDFFFEFDFCFFFDFBFAFFFDFCFBFFDDA885FFC17F53FFC68447FFF9F3
+ ECFFFEE8D6FFFDE7D6FFFDE7D6FFFDE7D5FFC7865BFFEFC09EFFFFFFFFFFCC93
+ 6EFFFFFFFFFFFFFFFFFFFFFBF7FFFFF8F1FFE4AF8CFFC78A61FFC68849FFF9F4
+ EDFFFEE8D8FFFEE8D7FFFEE7D6FFFDE5D3FFCC8D65FFF3CDB0FFFFFFFFFFE3C7
+ B3FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFEABFA1FFC98960FFC6884AFFF9F4
+ EFFFFEE7D7FFFDE7D5FFFDE6D4FFFCE6D2FFD4976EFFD49E7BFFD09871FFD6A4
+ 82FFCD8E68FFCD9069FFD09A75FFD19973FFC88B62FF00000000C6894BFFF9F4
+ F0FFFCE6D3FFFDE7D3FFFCE4D1FFFBE3CDFFFAE0C8FFF8DCC2FFF5D6BBFFF3D4
+ B5FFF1D2B3FFF8F4F0FFC48246FF000000000000000000000000C6894BFFF9F5
+ F1FFFCE3CFFFFCE4CFFFFCE3CDFFFAE1CAFFF9DDC4FFF6D9BCFFF4E9DFFFF7F2
+ ECFFFBF7F3FFF5EFE9FFC27E45FF000000000000000000000000C6894CFFF9F5
+ F1FFFCE3CDFFFBE3CDFFFBE2CBFFF9E0C8FFF8DCC2FFF5D6BAFFFDFBF8FFFCE6
+ CDFFFAE5C9FFE2B684FFBF7942FF000000000000000000000000C5884BFFFAF6
+ F2FFFAE0C7FFFBE2C9FFFBE0C8FFF9DFC5FFF8DBC1FFF4D6B8FFFFFBF8FFF6D8
+ B4FFE1B07DFFDB9264FF00000000000000000000000000000000C48549FFF7F2
+ ECFFF8F4EEFFF8F3EDFFF8F3EDFFF8F3EDFFF8F2ECFFF7F2ECFFF2E6D7FFE2B2
+ 7DFFDB9465FF000000000000000000000000000000000000000000000000C88B
+ 4DFFC88C4FFFC88C4FFFC88C4FFFC88D4FFFC98C4FFFC78B4FFFC5894BFFC476
+ 3BFF000000000000000000000000000000000000000000000000
+ }
+ OnClick = btnRandomPresetSaveClick
+ ShowCaption = False
+ ShowHint = True
+ ParentShowHint = False
+ end
+ object btnRandomPresetDelete: TSpeedButton
+ AnchorSideTop.Control = btnRandomPresetSave
+ AnchorSideRight.Control = gbRandom
+ AnchorSideRight.Side = asrBottom
+ Left = 190
+ Height = 22
+ Hint = 'Delete Preset'
+ Top = 138
+ Width = 22
+ Anchors = [akTop, akRight]
+ BorderSpacing.Right = 4
+ Glyph.Data = {
+ 36040000424D3604000000000000360000002800000010000000100000000100
+ 2000000000000004000064000000640000000000000000000000000000000000
+ 0000BA6530FFBB6631FFBA6630FFBA6630FFBA6630FFBA6530FFBA652FFFB965
+ 2EFF6E5E76FF1949A8FF0542BBFF1348ADFF394E8FFF0000000000000000BC69
+ 33FFF8F1EAFFF7ECDFFFF6EBDEFFF6EADEFFF6EADCFFF6EADCFFFAF3EBFF8AA5
+ D7FF2866CAFF2177E6FF0579EAFF0164DDFF064DBBFF0000000000000000BF71
+ 38FFF5EBDFFFFDBF68FFFCBD67FFFBBE65FFFCBE64FFFCBE64FFFCBD62FF1E52
+ B0FF639DF4FF187FFFFF0076F8FF0076EEFF0368E1FF0345B9FF00000000C178
+ 3CFFF7EDE3FFFDC26EFFFFD8A0FFFFD79EFFFFD69BFFFFD798FFFFD696FF0543
+ BCFFAECDFEFFFFFFFFFFFFFFFFFFFFFFFFFF187FEFFF0442BCFF00000000C47C
+ 40FFF7F0E6FFF8B455FFF7B456FFF7B554FFF8B453FFF8B253FFF7B352FF2453
+ ABFF8DB5F6FF4D92FFFF1177FFFF2186FFFF408AEBFF0344B9FF00000000C580
+ 42FFF8F1E8FFFEE5D5FFFDE5D3FFFDE5D3FFFCE5D3FFFCE5D3FFFCE4D1FF94A1
+ C9FF3D76D1FF8DB5F7FFB8D6FEFF72A8F5FF2F6BC9FF0000000000000000C582
+ 45FFF8F2EBFFFEE7D6FFFDE7D6FFFDE7D6FFFDE7D6FFFDE6D5FFFDE5D3FFFCE4
+ D1FF94A1C9FF2A5EC1FF0543BCFF1F59BFFF686279FF0000000000000000C684
+ 47FFF9F3ECFFFEE8D6FFFEE8D7FFFDE7D6FFFDE7D6FFFDE7D5FFFDE5D3FFFBE4
+ D0FFFBE3CCFFFADFC7FFFADFC6FFFAF2EAFFC68042FF0000000000000000C688
+ 49FFF9F4EDFFFEE8D8FFFEE8D8FFFEE8D7FFFEE7D6FFFDE5D3FFFCE4D1FFFBE1
+ CCFFFAE0C7FFF9DDC3FFF8DCC2FFFAF4EDFFC68245FF0000000000000000C688
+ 4AFFF9F4EFFFFEE7D7FFFDE7D6FFFDE7D5FFFDE6D4FFFCE6D2FFFBE1CCFFFADF
+ C7FFF8DCC2FFF6DABDFFF6D8BBFFFAF4EFFFC68346FF0000000000000000C689
+ 4BFFF9F4F0FFFCE6D3FFFCE6D4FFFDE7D3FFFCE4D1FFFBE3CDFFFAE0C8FFF8DC
+ C2FFF5D6BBFFF3D4B5FFF1D2B3FFF8F4F0FFC48246FF0000000000000000C689
+ 4BFFF9F5F1FFFCE3CFFFFBE4D0FFFCE4CFFFFCE3CDFFFAE1CAFFF9DDC4FFF6D9
+ BCFFF4E9DFFFF7F2ECFFFBF7F3FFF5EFE9FFC27E45FF0000000000000000C689
+ 4CFFF9F5F1FFFCE3CDFFFBE3CEFFFBE3CDFFFBE2CBFFF9E0C8FFF8DCC2FFF5D6
+ BAFFFDFBF8FFFCE6CDFFFAE5C9FFE2B684FFBF7942FF0000000000000000C588
+ 4BFFFAF6F2FFFAE0C7FFFBE1C9FFFBE2C9FFFBE0C8FFF9DFC5FFF8DBC1FFF4D6
+ B8FFFFFBF8FFF6D8B4FFE1B07DFFDB9264FF000000000000000000000000C485
+ 49FFF7F2ECFFF8F4EEFFF8F4EDFFF8F3EDFFF8F3EDFFF8F3EDFFF8F2ECFFF7F2
+ ECFFF2E6D7FFE2B27DFFDB9465FF000000000000000000000000000000000000
+ 0000C88B4DFFC88C4FFFC88C4FFFC88C4FFFC88C4FFFC88D4FFFC98C4FFFC78B
+ 4FFFC5894BFFC4763BFF00000000000000000000000000000000
+ }
+ OnClick = btnRandomPresetDeleteClick
+ ShowCaption = False
+ ShowHint = True
+ ParentShowHint = False
+ end
+ object vdtRandom: TVirtualDrawTree
+ Tag = 1
+ AnchorSideLeft.Control = gbRandom
+ AnchorSideTop.Control = btnAddRandom
+ AnchorSideTop.Side = asrBottom
+ AnchorSideRight.Control = gbRandom
+ AnchorSideRight.Side = asrBottom
+ AnchorSideBottom.Control = cbRandomPreset
+ Cursor = 63
+ Left = 4
+ Height = 110
+ Top = 24
+ Width = 208
+ Anchors = [akTop, akLeft, akRight, akBottom]
+ BorderSpacing.Left = 4
+ BorderSpacing.Top = 2
+ BorderSpacing.Right = 4
+ BorderSpacing.Bottom = 4
+ DefaultNodeHeight = 44
+ DragType = dtVCL
+ Header.AutoSizeIndex = 0
+ Header.Columns = <
+ item
+ Position = 0
+ Text = 'ID'
+ end
+ item
+ Position = 1
+ Text = 'Tile'
+ Width = 44
+ end
+ item
+ Position = 2
+ Text = 'Name'
+ Width = 100
+ end>
+ Header.DefaultHeight = 17
+ Header.Options = [hoColumnResize, hoDrag, hoVisible]
+ Header.ParentFont = True
+ Header.Style = hsFlatButtons
+ TabOrder = 0
+ TreeOptions.AutoOptions = [toAutoDropExpand, toAutoScroll, toAutoScrollOnExpand, toAutoTristateTracking, toAutoDeleteMovedNodes]
+ TreeOptions.PaintOptions = [toHideFocusRect, toShowButtons, toShowDropmark, toThemeAware, toUseBlendedImages]
+ TreeOptions.SelectionOptions = [toFullRowSelect, toMultiSelect]
+ OnClick = vdtRandomClick
+ OnDragOver = vdtRandomDragOver
+ OnDragDrop = vdtRandomDragDrop
+ OnDrawNode = vdtTilesDrawNode
+ OnLoadNode = vdtRandomLoadNode
+ OnSaveNode = vdtRandomSaveNode
+ OnUpdating = vdtRandomUpdating
+ end
+ object cbRandomPreset: TComboBox
+ AnchorSideLeft.Control = gbRandom
+ AnchorSideRight.Control = btnRandomPresetSave
+ AnchorSideBottom.Control = gbRandom
+ AnchorSideBottom.Side = asrBottom
+ Left = 4
+ Height = 27
+ Top = 138
+ Width = 156
+ Anchors = [akLeft, akRight, akBottom]
+ BorderSpacing.Left = 4
+ BorderSpacing.Right = 4
+ BorderSpacing.Bottom = 4
+ ItemHeight = 0
+ OnChange = cbRandomPresetChange
+ Sorted = True
+ Style = csDropDownList
+ TabOrder = 1
+ end
+ end
+ object spTileList: TSplitter
+ AnchorSideLeft.Control = tsTiles
+ AnchorSideRight.Control = tsTiles
+ AnchorSideRight.Side = asrBottom
+ Cursor = crVSplit
+ Left = 0
+ Height = 5
+ Top = 284
+ Width = 218
+ Align = alNone
+ Anchors = [akLeft, akRight, akBottom]
+ ResizeAnchor = akBottom
+ end
+ object edSearchID: TEdit
+ AnchorSideRight.Control = vdtTiles
+ AnchorSideRight.Side = asrBottom
+ AnchorSideBottom.Control = vdtTiles
+ AnchorSideBottom.Side = asrBottom
+ Left = 110
+ Height = 23
+ Hint = 'Append S or T to restrict the search to Statics or Terrain.'
+ Top = 253
+ Width = 96
+ Anchors = [akRight, akBottom]
+ BorderSpacing.Right = 8
+ BorderSpacing.Bottom = 8
+ CharCase = ecUppercase
+ OnExit = edSearchIDExit
+ OnKeyPress = edSearchIDKeyPress
+ ParentShowHint = False
+ ShowHint = True
+ TabOrder = 2
+ Visible = False
+ end
+ object edFilter: TEdit
+ AnchorSideLeft.Control = lblFilter
+ AnchorSideTop.Control = lblFilter
+ AnchorSideTop.Side = asrBottom
+ AnchorSideRight.Control = tsTiles
+ AnchorSideRight.Side = asrBottom
+ Left = 89
+ Height = 23
+ Top = 21
+ Width = 113
+ Anchors = [akTop, akLeft, akRight]
+ BorderSpacing.Right = 16
+ OnEditingDone = edFilterEditingDone
+ TabOrder = 4
+ end
+ object cbStatics: TCheckBox
+ AnchorSideLeft.Control = cbTerrain
+ AnchorSideLeft.Side = asrCenter
+ AnchorSideTop.Control = cbTerrain
+ AnchorSideTop.Side = asrBottom
+ Left = 3
+ Height = 24
+ Top = 32
+ Width = 71
+ Caption = 'Statics'
+ Checked = True
+ OnChange = cbStaticsChange
+ State = cbChecked
+ TabOrder = 5
+ end
+ object cbTerrain: TCheckBox
+ AnchorSideLeft.Control = tsTiles
+ AnchorSideTop.Control = tsTiles
+ Left = 4
+ Height = 24
+ Top = 8
+ Width = 69
+ BorderSpacing.Left = 4
+ BorderSpacing.Top = 8
+ Caption = 'Terrain'
+ Checked = True
+ OnChange = cbTerrainChange
+ State = cbChecked
+ TabOrder = 6
+ end
+ end
+ object tsClients: TTabSheet
+ Caption = 'Clients'
+ ClientHeight = 472
+ ClientWidth = 218
+ object lbClients: TListBox
+ Left = 0
+ Height = 478
+ Top = 0
+ Width = 216
+ Align = alClient
+ ItemHeight = 0
+ OnDblClick = mnuGoToClientClick
+ PopupMenu = pmClients
+ ScrollWidth = 214
+ Sorted = True
+ TabOrder = 0
+ TopIndex = -1
+ end
+ end
+ object tsLocations: TTabSheet
+ Caption = 'Locations'
+ ClientHeight = 472
+ ClientWidth = 218
+ object btnClearLocations: TSpeedButton
+ AnchorSideLeft.Control = btnDeleteLocation
+ AnchorSideLeft.Side = asrBottom
+ AnchorSideTop.Control = btnDeleteLocation
+ Left = 125
+ Height = 22
+ Hint = 'Clear'
+ Top = 452
+ Width = 23
+ BorderSpacing.Left = 4
+ Glyph.Data = {
+ 36040000424D3604000000000000360000002800000010000000100000000100
+ 2000000000000004000064000000640000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 000000000000000000000000F1FF0000F1FF0000F1FF0000F1FF0000EFFF0000
+ EFFF0000EDFF0000EDFF00000000000000000000000000000000000000000000
+ 0000000000000000F5FF1A20F5FF3C4CF9FF3A49F8FF3847F8FF3545F8FF3443
+ F7FF3242F7FF141BF1FF0000EDFF000000000000000000000000000000000000
+ 00000000F7FF1D23F9FF4453FAFF2429F9FF1212F7FF0F0FF6FF0C0CF5FF0909
+ F5FF161BF5FF3343F7FF141BF1FF0000EDFF0000000000000000000000000000
+ F9FF1F25FAFF4A58FBFF4247FBFFC9C9FDFF3B3BF9FF1313F7FF1010F6FF3333
+ F7FFC5C5FDFF3035F7FF3444F7FF141BF2FF0000EDFF00000000000000000000
+ FBFF4F5DFDFF3237FBFFCBCBFEFFF2F2FFFFEBEBFEFF3B3BF9FF3939F8FFEAEA
+ FEFFF1F1FEFFC5C5FDFF181DF6FF3343F7FF0000EFFF00000000000000000000
+ FDFF525FFDFF2828FCFF4747FCFFECECFFFFF2F2FFFFECECFFFFECECFEFFF1F1
+ FFFFEAEAFEFF3434F7FF0B0BF5FF3545F8FF0000EFFF00000000000000000000
+ FDFF5562FEFF2C2CFDFF2929FCFF4848FCFFEDEDFFFFF2F2FFFFF2F2FFFFECEC
+ FEFF3A3AF9FF1212F7FF0F0FF6FF3848F8FF0000F1FF00000000000000000000
+ FDFF5764FEFF3030FDFF2D2DFDFF4B4BFCFFEDEDFFFFF2F2FFFFF2F2FFFFECEC
+ FFFF3D3DF9FF1616F8FF1313F7FF3C4BF8FF0000F1FF00000000000000000000
+ FFFF5A67FEFF3333FEFF5050FDFFEDEDFFFFF3F3FFFFEDEDFFFFEDEDFFFFF2F2
+ FFFFECECFEFF3E3EFAFF1717F8FF3F4EF9FF0000F1FF00000000000000000000
+ FFFF5B68FFFF4347FEFFCFCFFFFFF3F3FFFFEDEDFFFF4C4CFCFF4A4AFCFFECEC
+ FFFFF2F2FFFFCACAFEFF2A2FFAFF4251FAFF0000F3FF00000000000000000000
+ FFFF262BFFFF5D6AFFFF585BFFFFCFCFFFFF5252FEFF2F2FFDFF2C2CFDFF4B4B
+ FCFFCCCCFEFF484CFBFF4957FBFF1D23F9FF0000F5FF00000000000000000000
+ 00000000FFFF262BFFFF5D6AFFFF4347FFFF3434FEFF3232FEFF3030FDFF2D2D
+ FDFF383CFCFF4F5DFCFF1F25FAFF0000F7FF0000000000000000000000000000
+ 0000000000000000FFFF262BFFFF5C69FFFF5B68FFFF5A67FEFF5865FEFF5663
+ FEFF5461FEFF2227FCFF0000FBFF000000000000000000000000000000000000
+ 000000000000000000000000FFFF0000FFFF0000FFFF0000FFFF0000FDFF0000
+ FDFF0000FDFF0000FDFF00000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000
+ }
+ OnClick = btnClearLocationsClick
+ ShowHint = True
+ ParentShowHint = False
+ end
+ object btnDeleteLocation: TSpeedButton
+ AnchorSideLeft.Control = tsLocations
+ AnchorSideLeft.Side = asrCenter
+ AnchorSideBottom.Control = tsLocations
+ AnchorSideBottom.Side = asrBottom
+ Left = 98
+ Height = 22
+ Hint = 'Delete'
+ Top = 452
+ Width = 23
+ Anchors = [akLeft, akBottom]
+ BorderSpacing.Bottom = 4
+ Glyph.Data = {
+ 36040000424D3604000000000000360000002800000010000000100000000100
+ 2000000000000004000064000000640000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000003853BEFF3551BDFF304BBCFF2E4E
+ B8FF000000000000000000000000000000000000000000000000000000000000
+ 000000000000000000004255C6FF3C52CCFF757AE8FF8F92EEFF8F92EEFF7178
+ E4FF334DC1FF2B4AB7FF00000000000000000000000000000000000000000000
+ 0000000000004959CBFF5C65E0FFA1A6F5FF7E86EFFF5B63E9FF595DE7FF7D84
+ EEFF9EA0F4FF515DD7FF2B4AB7FF000000000000000000000000000000000000
+ 00005361CFFF616BE3FFA1ACF5FF545FECFF505CEAFF4D59E9FF4E59E6FF4C56
+ E6FF5056E6FF9EA2F4FF5460D6FF2A4AB8FF0000000000000000000000000000
+ 00004B56DBFFA2ABF6FF5664F0FF5266EEFF4D59E9FF4D59E9FF4D59E9FF4D59
+ E9FF4C58E6FF525AE6FF9FA3F5FF3450C4FF0000000000000000000000005C62
+ D7FF818CEEFF7E91F7FF5D73F3FF4D59E9FF4D59E9FF4D59E9FF4D59E9FF4D59
+ E9FF4D59E9FF4F5BE9FF7B83F0FF757BE2FF2E4BBAFF00000000000000005F63
+ DAFFA1ABF7FF7086F8FF6882F6FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
+ FFFFFFFFFFFF4D59E9FF5C66EAFF969CF1FF3250BCFF00000000000000006469
+ DBFFAFB9F9FF7F93FAFF7085F0FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
+ FFFFFFFFFFFF4D59E9FF5E6AEEFF969DF1FF364FBEFF0000000000000000676A
+ DEFFA5AFF5FF9DABFAFF778CF0FF545FECFF545FECFF545FECFF545FECFF545F
+ ECFF545FECFF6377F2FF818EF4FF787FE9FF3A53C0FF00000000000000000000
+ 00007D83EAFFCDD4FCFF8B9DFAFF7E93F7FF758AEEFF6C84F6FF6C84F6FF6C84
+ F6FF6C84F6FF6379F3FFA4AFF8FF3E4FD0FF0000000000000000000000000000
+ 00006A69E0FFA3A7F3FFD4DBFDFF879AFAFF7F91F0FF7A8EF1FF7F94F8FF7E92
+ F9FF768CF8FFA8B6F8FF636EE3FF4557C7FF0000000000000000000000000000
+ 0000000000006A69E0FFAAADF2FFD8DCFDFFAEBAFAFF91A3FAFF8B9DFAFF9CA9
+ FBFFBAC7FCFF707BE9FF4C5BCCFF000000000000000000000000000000000000
+ 000000000000000000006A6ADFFF8E93EDFFBEC3F8FFCCD3F9FFC4CBF9FFAAB4
+ F4FF6670E2FF535ED1FF00000000000000000000000000000000000000000000
+ 000000000000000000000000000000000000686ADDFF6364DCFF6164DAFF5D63
+ D9FF000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000
+ }
+ OnClick = btnDeleteLocationClick
+ ShowHint = True
+ ParentShowHint = False
+ end
+ object btnAddLocation: TSpeedButton
+ AnchorSideTop.Control = btnDeleteLocation
+ AnchorSideRight.Control = btnDeleteLocation
+ Left = 71
+ Height = 22
+ Hint = 'Add'
+ Top = 452
+ Width = 23
+ Anchors = [akTop, akRight]
+ BorderSpacing.Right = 4
+ Glyph.Data = {
+ 36040000424D3604000000000000360000002800000010000000100000000100
+ 2000000000000004000064000000640000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000003A8C44FF368940FF32873CFF2F84
+ 37FF000000000000000000000000000000000000000000000000000000000000
+ 00000000000000000000459653FF419950FF7DC28FFF96D0A6FF96CFA6FF78BE
+ 89FF368D42FF2C8134FF00000000000000000000000000000000000000000000
+ 0000000000004D9C5DFF64B478FFA8DBB5FF87CC98FF66BC7DFF64BA7CFF86CB
+ 98FFA5D9B4FF58AA6BFF2C8134FF000000000000000000000000000000000000
+ 000056A366FF6AB97DFFA8DBB2FF60BC77FF5CBA73FF59B870FF59B56FFF58B5
+ 6FFF5BB774FFA5D9B3FF5AAA6CFF2C8234FF0000000000000000000000000000
+ 000053AB68FFAADDB4FF64C179FF5FBE71FF60BC77FFFFFFFFFFFFFFFFFF59B8
+ 70FF58B56EFF5CB774FFA6DAB4FF388F43FF00000000000000000000000061AC
+ 75FF8ACC98FF89D396FF6BC67AFF63C170FF55AB65FFFFFFFFFFFFFFFFFF59B8
+ 70FF59B870FF5BB972FF85CC97FF7BBE8DFF308539FF000000000000000065AF
+ 7AFFA9DDB3FF7DCF8AFF75CC81FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
+ FFFFFFFFFFFF59B870FF67BE7DFF9CD4ABFF34883DFF000000000000000069B2
+ 7EFFB6E2BEFF8BD597FF7AC986FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF
+ FFFFFFFFFFFF59B870FF69C17EFF9DD4AAFF388B42FF00000000000000006DB5
+ 83FFACDDB6FFA6DFAFFF81CB8CFF7CC986FF6EBD79FFFFFFFFFFFFFFFFFF5BAC
+ 6AFF60BC77FF5CBA73FF8BD199FF80C592FF3C8E47FF00000000000000000000
+ 000085C797FFD2EED7FF95D9A0FF8AD394FF7FC889FFFFFFFFFFFFFFFFFF79CD
+ 85FF6BC37CFF6FC77EFFACDFB5FF459E57FF0000000000000000000000000000
+ 000070B887FFAADAB7FFD8F1DCFF92D89DFF88CD93FF84CC8EFF8BD496FF8AD4
+ 95FF83D28EFFAFE0B7FF6BB97DFF489856FF0000000000000000000000000000
+ 00000000000070B887FFAFDCBBFFDCF2E0FFB6E4BDFF9BDBA5FF96D9A0FFA5DF
+ AFFFC0E8C5FF79C28AFF509E5FFF000000000000000000000000000000000000
+ 0000000000000000000071B887FF94CEA4FFC3E6CBFFCFEBD4FFC9E9CEFFAFDD
+ B8FF6DB97FFF58A569FF00000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000006EB684FF6AB380FF67B17CFF63AE
+ 77FF000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000
+ }
+ OnClick = btnAddLocationClick
+ ShowHint = True
+ ParentShowHint = False
+ end
+ object vstLocations: TVirtualStringTree
+ AnchorSideLeft.Control = tsLocations
+ AnchorSideTop.Control = tsLocations
+ AnchorSideRight.Control = tsLocations
+ AnchorSideRight.Side = asrBottom
+ AnchorSideBottom.Control = btnDeleteLocation
+ Cursor = 63
+ Left = 4
+ Height = 444
+ Top = 4
+ Width = 208
+ Anchors = [akTop, akLeft, akRight, akBottom]
+ BorderSpacing.Around = 4
+ DefaultText = 'Node'
+ Header.AutoSizeIndex = 1
+ Header.Columns = <
+ item
+ Position = 0
+ Text = 'Coords'
+ Width = 75
+ end
+ item
+ Position = 1
+ Text = 'Name'
+ Width = 129
+ end>
+ Header.DefaultHeight = 17
+ Header.Options = [hoAutoResize, hoColumnResize, hoDrag, hoVisible]
+ Header.ParentFont = True
+ Header.Style = hsFlatButtons
+ TabOrder = 0
+ TreeOptions.AutoOptions = [toAutoScrollOnExpand, toAutoTristateTracking, toAutoDeleteMovedNodes]
+ TreeOptions.PaintOptions = [toShowButtons, toShowDropmark, toThemeAware, toUseBlendedImages]
+ TreeOptions.SelectionOptions = [toFullRowSelect]
+ OnDblClick = vstLocationsDblClick
+ OnFreeNode = vstLocationsFreeNode
+ OnGetText = vstLocationsGetText
+ OnLoadNode = vstLocationsLoadNode
+ OnNewText = vstLocationsNewText
+ OnSaveNode = vstLocationsSaveNode
+ end
+ end
+ end
+ object tbMain: TToolBar
+ Left = 0
+ Height = 24
+ Top = 0
+ Width = 755
+ Caption = 'tbMain'
+ Images = ImageList1
+ ParentShowHint = False
+ ShowHint = True
+ TabOrder = 2
+ object tbDisconnect: TToolButton
+ Left = 1
+ Hint = 'Disconnect'
+ Top = 2
+ Caption = 'Disconnect'
+ ImageIndex = 0
+ OnClick = mnuDisconnectClick
+ ParentShowHint = False
+ ShowHint = True
+ end
+ object tbSeparator1: TToolButton
+ Left = 24
+ Top = 2
+ Width = 5
+ Style = tbsDivider
+ end
+ object tbSelect: TToolButton
+ Left = 29
+ Top = 2
+ Action = acSelect
+ Grouped = True
+ ParentShowHint = False
+ ShowHint = True
+ Style = tbsCheck
+ end
+ object tbDrawTile: TToolButton
+ Left = 52
+ Top = 2
+ Action = acDraw
+ Grouped = True
+ ParentShowHint = False
+ ShowHint = True
+ Style = tbsCheck
+ end
+ object tbMoveTile: TToolButton
+ Left = 75
+ Top = 2
+ Action = acMove
+ Grouped = True
+ ParentShowHint = False
+ ShowHint = True
+ Style = tbsCheck
+ end
+ object tbElevateTile: TToolButton
+ Left = 98
+ Top = 2
+ Action = acElevate
+ Grouped = True
+ ParentShowHint = False
+ ShowHint = True
+ Style = tbsCheck
+ end
+ object tbDeleteTile: TToolButton
+ Left = 121
+ Top = 2
+ Action = acDelete
+ Grouped = True
+ ParentShowHint = False
+ ShowHint = True
+ Style = tbsCheck
+ end
+ object tbSetHue: TToolButton
+ Left = 144
+ Top = 2
+ Action = acHue
+ Grouped = True
+ ParentShowHint = False
+ ShowHint = True
+ Style = tbsCheck
+ end
+ object tbSeparator3: TToolButton
+ Left = 195
+ Top = 2
+ Width = 5
+ Caption = 'tbSeparator3'
+ Style = tbsDivider
+ end
+ object tbBoundaries: TToolButton
+ Left = 200
+ Top = 2
+ Action = acBoundaries
+ ParentShowHint = False
+ ShowHint = True
+ end
+ object tbSeparator4: TToolButton
+ Left = 269
+ Top = 2
+ Width = 5
+ Caption = 'tbSeparator4'
+ Style = tbsDivider
+ end
+ object tbTerrain: TToolButton
+ Left = 274
+ Hint = 'Show Terrain'
+ Top = 2
+ Caption = 'Terrain'
+ Down = True
+ ImageIndex = 10
+ OnClick = tbTerrainClick
+ ParentShowHint = False
+ ShowHint = True
+ Style = tbsCheck
+ end
+ object tbStatics: TToolButton
+ Left = 297
+ Hint = 'Show Statics'
+ Top = 2
+ Caption = 'Statics'
+ Down = True
+ ImageIndex = 11
+ OnClick = tbStaticsClick
+ ParentShowHint = False
+ ShowHint = True
+ Style = tbsCheck
+ end
+ object tbSeparator5: TToolButton
+ Left = 424
+ Top = 2
+ Width = 5
+ Caption = 'tbSeparator5'
+ Style = tbsDivider
+ end
+ object tbRadarMap: TToolButton
+ Left = 429
+ Hint = 'Radar Map'
+ Top = 2
+ Caption = 'Radar Map'
+ ImageIndex = 13
+ OnClick = tbRadarMapClick
+ ParentShowHint = False
+ ShowHint = True
+ end
+ object tbVirtualLayer: TToolButton
+ Left = 223
+ Top = 2
+ Action = acVirtualLayer
+ end
+ object tbFilter: TToolButton
+ Left = 246
+ Top = 2
+ Action = acFilter
+ OnMouseMove = tbFilterMouseMove
+ Style = tbsCheck
+ end
+ object tbFlat: TToolButton
+ Left = 389
+ Top = 2
+ Action = acFlat
+ DropdownMenu = pmFlatViewSettings
+ Style = tbsDropDown
+ end
+ object tbNoDraw: TToolButton
+ Left = 320
+ Top = 2
+ Action = acNoDraw
+ Style = tbsCheck
+ end
+ object tbSeparator2: TToolButton
+ Left = 167
+ Top = 2
+ Width = 5
+ Caption = 'tbSeparator2'
+ Style = tbsDivider
+ end
+ object tbUndo: TToolButton
+ Left = 172
+ Top = 2
+ Action = acUndo
+ end
+ object tbLightlevel: TToolButton
+ Left = 366
+ Top = 2
+ Action = acLightlevel
+ end
+ object tbWalkable: TToolButton
+ Left = 343
+ Top = 2
+ Action = acWalkable
+ Style = tbsCheck
+ end
+ end
+ object pnlChatHeader: TPanel
+ AnchorSideLeft.Control = pnlChat
+ AnchorSideTop.Control = spChat
+ AnchorSideTop.Side = asrBottom
+ AnchorSideRight.Control = pnlChat
+ AnchorSideRight.Side = asrBottom
+ AnchorSideBottom.Control = spChat
+ Left = 224
+ Height = 22
+ Top = 391
+ Width = 531
+ Anchors = [akLeft, akRight, akBottom]
+ BevelInner = bvRaised
+ BevelOuter = bvLowered
+ ClientHeight = 22
+ ClientWidth = 531
+ TabOrder = 3
+ object lblChatHeaderCaption: TLabel
+ Cursor = crHandPoint
+ Left = 10
+ Height = 18
+ Top = 2
+ Width = 113
+ Align = alLeft
+ BorderSpacing.Left = 8
+ Caption = 'Chat and Messages'
+ Layout = tlCenter
+ ParentColor = False
+ OnClick = lblChatHeaderCaptionClick
+ OnMouseEnter = lblChatHeaderCaptionMouseEnter
+ OnMouseLeave = lblChatHeaderCaptionMouseLeave
+ end
+ end
+ object pnlChat: TPanel
+ AnchorSideLeft.Control = pcLeft
+ AnchorSideLeft.Side = asrBottom
+ AnchorSideTop.Control = spChat
+ AnchorSideTop.Side = asrBottom
+ AnchorSideRight.Control = Owner
+ AnchorSideRight.Side = asrBottom
+ AnchorSideBottom.Control = pnlBottom
+ Left = 224
+ Height = 109
+ Top = 418
+ Width = 531
+ Anchors = [akTop, akLeft, akRight, akBottom]
+ BevelOuter = bvNone
+ ClientHeight = 109
+ ClientWidth = 531
+ TabOrder = 4
+ Visible = False
+ object vstChat: TVirtualStringTree
+ Cursor = 63
+ Left = 0
+ Height = 86
+ Top = 0
+ Width = 531
+ Align = alClient
+ DefaultText = 'Node'
+ Header.AutoSizeIndex = 2
+ Header.Columns = <
+ item
+ Position = 0
+ Text = 'Time'
+ Width = 75
+ end
+ item
+ Position = 1
+ Text = 'Sender'
+ Width = 75
+ end
+ item
+ Position = 2
+ Text = 'Message'
+ Width = 379
+ end>
+ Header.DefaultHeight = 17
+ Header.MainColumn = 2
+ Header.Options = [hoAutoResize, hoColumnResize, hoDrag, hoVisible]
+ Header.ParentFont = True
+ Header.Style = hsFlatButtons
+ TabOrder = 0
+ TreeOptions.AutoOptions = [toAutoDropExpand, toAutoScroll, toAutoScrollOnExpand, toAutoTristateTracking, toAutoDeleteMovedNodes]
+ TreeOptions.MiscOptions = [toFullRepaintOnResize, toInitOnSave, toToggleOnDblClick, toWheelPanning]
+ TreeOptions.PaintOptions = [toHideSelection, toShowButtons, toShowDropmark, toThemeAware, toUseBlendedImages]
+ OnClick = vstChatClick
+ OnFreeNode = vstChatFreeNode
+ OnGetText = vstChatGetText
+ OnPaintText = vstChatPaintText
+ end
+ object edChat: TEdit
+ Left = 0
+ Height = 23
+ Top = 86
+ Width = 531
+ Align = alBottom
+ OnKeyPress = edChatKeyPress
+ TabOrder = 1
+ end
+ end
+ object spChat: TSplitter
+ AnchorSideLeft.Control = pcLeft
+ AnchorSideLeft.Side = asrBottom
+ AnchorSideRight.Control = Owner
+ AnchorSideRight.Side = asrBottom
+ Cursor = crVSplit
+ Left = 224
+ Height = 5
+ Top = 413
+ Width = 531
+ Align = alNone
+ Anchors = [akLeft, akRight, akBottom]
+ AutoSnap = False
+ ResizeAnchor = akBottom
+ Visible = False
+ end
+ object oglGameWindow: TOpenGLControl
+ AnchorSideLeft.Control = pcLeft
+ AnchorSideLeft.Side = asrBottom
+ AnchorSideTop.Control = tbMain
+ AnchorSideTop.Side = asrBottom
+ AnchorSideRight.Control = Owner
+ AnchorSideRight.Side = asrBottom
+ AnchorSideBottom.Control = pnlChatHeader
+ Left = 224
+ Height = 367
+ Top = 24
+ Width = 531
+ Anchors = [akTop, akLeft, akRight, akBottom]
+ OnDblClick = oglGameWindowDblClick
+ OnKeyDown = oglGameWindowKeyDown
+ OnMouseDown = oglGameWindowMouseDown
+ OnMouseEnter = oglGameWindowMouseEnter
+ OnMouseLeave = oglGameWindowMouseLeave
+ OnMouseMove = oglGameWindowMouseMove
+ OnMouseUp = oglGameWindowMouseUp
+ OnMouseWheel = oglGameWindowMouseWheel
+ OnPaint = oglGameWindowPaint
+ OnResize = oglGameWindowResize
+ end
+ object MainMenu1: TMainMenu
+ Images = ImageList1
+ left = 232
+ top = 33
+ object mnuCentrED: TMenuItem
+ Caption = '&CentrED'
+ object mnuChangePassword: TMenuItem
+ Caption = '&Change Password'
+ OnClick = mnuChangePasswordClick
+ end
+ object mnuSeparator1: TMenuItem
+ Caption = '-'
+ end
+ object mnuDisconnect: TMenuItem
+ Caption = '&Disconnect'
+ Bitmap.Data = {
+ 36040000424D3604000000000000360000002800000010000000100000000100
+ 200000000000000400006400000064000000000000000000000028415200AB66
+ 3CFFA45D38FF2F4F6300509BB50053A3BE007CA9B700BDDADE00DCE4E30088B5
+ C20080BCCC005D757F0034383A0034352E004E5F5800313D6200BA7C4AFFBF87
+ 5CFFB97E56FFA7623AFFA3D3DD005594AC0060A1B50062A9BE00487E98004165
+ 76003C4A48003B4C4700384740001A231E000102020000000000C4885AFFC692
+ 68FFCDA280FFC59670FFB67B53FFAB6A46FFA35E3DFF9C5235FF91442CFF2737
+ 39000B0F0D0000000000293B48002E47550028354300324953003D6A9500C68C
+ 60FFD1A683FFCC9F7BFFCB9E7BFFC79974FFC3926CFFBE8D65FFA86945FF2C3A
+ 42002A3138002D3A420074B9C8007FC5D5005F99AE0076B4C5002F3B35003B49
+ 4900D0A17CFFD7AE8FFFC9976FFFC38F66FFBD885CFFC08C64FFBC8861FF8351
+ 3CFF4F91AB0054889C0043718A004E6974003D4A4B0045779600000000000304
+ 0400D7A682FFDCB699FFD0A17DFFCB9A73FFCFA482FFC79974FF896C58FF8787
+ 87FF4E4E4EFF3D5F7B003A5C8600364E63002C2D2E00566E72003E7A8E004C95
+ B000DDAE8CFFE2BEA4FFD8AB89FFD9B394FFCF9F7AFFA37858FF939393FFA9A9
+ A9FF555555FF3C4E51002C322E002C3331001B1F1C00000000003F85B2004D9C
+ C100E3B493FFE8C6ADFFE3C0A6FFDBB08FFFB48D71FF2F353300717171FF6767
+ 67FF161B1700000000008F432BFF8B4128FF0203030016292F002E3A48003447
+ 5200E7BB9CFFE8C0A3FFE5BFA3FFB59D8AFFAEAEAEFF838383FF000000000000
+ 0000060A0B009F5734FFAD724CFFA25F3FFF8E4129FF365C8300020303000001
+ 010000000000EABE9FFFCEAF9AFFB7B7B7FFBCBCBCFF8C8C8CFF496F7B00498D
+ A600AE6D40FFBB835CFFC08F67FFBB8A60FF995033FF32424E00000000000000
+ 00000000000004070700101819009E9E9EFF999999FF3C5B6A002A323500C386
+ 57FFC9976FFFCB9F7CFFBC8559FFC3926BFFA6633EFF39434500000000004566
+ A1004B697900545B8F004E5089003C40570029375400D9A781FFD9AB88FFDAB2
+ 94FFD8B092FFCB9972FFC49068FFC89C78FFB2724AFF00000000000000000000
+ 00000000000000000000000000000000000000000000E2B18FFFE7C1A8FFE0BA
+ 9FFFD8AC8BFFD2A582FFCE9D77FFD1A684FFBE865CFF00000000000000000000
+ 0000000000000000000000000000000000000000000000000000E8C0A4FFE9C8
+ B0FFE5C3A9FFE1BDA2FFDCB699FFD5AB8AFFD0A482FFB57644FF000000000000
+ 0000000000000000000000000000000000000000000000000000ECBEA1FFE7BB
+ 9DFFE4B697FFE0B292FFDAAE8FFFDCB598FFCF9F7AFFC38657FFF0A3E30058BA
+ 1500187D7C00D063B90000000000000000000000000000000000000000000000
+ 0000000000000000000000000000D9A781FFD39E76FF00000000
+ }
+ ImageIndex = 0
+ OnClick = mnuDisconnectClick
+ end
+ object mnuExit: TMenuItem
+ Caption = 'E&xit'
+ OnClick = mnuExitClick
+ end
+ end
+ object mnuAdministration: TMenuItem
+ Caption = '&Administration'
+ object mnuFlush: TMenuItem
+ Caption = '&Flush'
+ Bitmap.Data = {
+ 36040000424D3604000000000000360000002800000010000000100000000100
+ 2000000000000004000064000000640000000000000000000000BA6A36FFB969
+ 35FFB86935FFB76835FFB56835FFB46734FFB26634FFB06533FFAE6433FFAC63
+ 32FFAA6232FFA96132FFA86031FFA76031FFA66031FFA86131FFBA6A35FFEBC6
+ ADFFEAC5ADFFFEFBF8FFFEFBF8FFFEFBF8FFFEFBF8FFFEFBF8FFFEFBF8FFFEFB
+ F8FFFEFBF8FFFEFBF8FFFEFBF8FFC89A7CFFC79879FFA76031FFBA6B37FFEDCA
+ B3FFE0A27AFFFEFAF7FF62C088FF62C088FF62C088FF62C088FF62C088FF62C0
+ 88FF62C088FF62C088FFFDF9F6FFCA8D65FFC99B7CFFA76031FFBB6C38FFEECC
+ B6FFE1A27AFFFEFAF7FFBFDCC2FFBFDCC2FFBFDCC2FFBFDCC2FFBFDCC2FFBFDC
+ C2FFBFDCC2FFBFDCC2FFFDF9F6FFCD9068FFCC9E81FFA86132FFBB6B38FFEFCE
+ B8FFE1A279FFFEFAF7FF62C088FF62C088FF62C088FF62C088FF62C088FF62C0
+ 88FF62C088FF62C088FFFDF9F6FFCF936AFFCEA384FFAA6132FFBA6A36FFEFD0
+ BBFFE2A27AFFFEFBF8FFFEFBF8FFFEFBF8FFFEFBF8FFFEFBF8FFFEFBF8FFFEFB
+ F8FFFEFBF8FFFEFBF8FFFEFBF8FFD3966DFFD2A78AFFAB6232FFBB6A36FFF0D2
+ BEFFE2A37AFFE2A37AFFE1A37AFFE2A37BFFE1A37BFFE0A178FFDE9F77FFDD9F
+ 76FFDC9D74FFD99B72FFD89971FFD69970FFD5AB8EFFAD6333FFBB6A36FFF2D5
+ C2FFE3A37AFFE3A37AFFE2A37BFFE2A37BFFE2A47BFFE1A279FFE0A178FFDEA0
+ 77FFDE9E75FFDC9D74FFDA9B73FFD99B73FFDAB095FFAF6433FFBB6A36FFF2D8
+ C5FFE3A47BFFE3A37AFFE3A47AFFE2A47BFFE2A37BFFE1A37BFFE1A279FFDFA0
+ 77FFDE9F76FFDD9E74FFDB9C72FFDC9D74FFDDB59AFFB16534FFBB6B36FFF4D9
+ C7FFE6A67DFFC88C64FFC98D65FFC98E67FFCB926CFFCB926DFFCA9069FFC88C
+ 65FFC88C64FFC88C64FFC88C64FFDA9C74FFE1BA9FFFB36634FFBB6B36FFF4DC
+ C9FFE7A77DFFF9ECE1FFF9ECE1FFF9EDE3FFFCF4EEFFFDFAF7FFFDF7F3FFFAED
+ E5FFF7E7DBFFF7E5D9FFF6E5D8FFDEA077FFE4BEA4FFB46734FFBC6B36FFF5DD
+ CCFFE7A87EFFFAF0E8FFFAF0E8FFC98D66FFFAF0E9FFFDF8F3FFFEFAF8FFFCF4
+ EFFFF9E9DFFFF7E7DBFFF7E5D9FFE0A278FFE7C2A9FFB66835FFBC6B36FFF6DF
+ D0FFE8A87EFFFCF6F1FFFCF6F1FFC88C64FFFAF1E9FFFBF4EEFFFDFAF7FFFDF9
+ F6FFFAF0E8FFF8E8DDFFF7E6DBFFE1A37AFFEFD5C3FFB76935FFBC6B36FFF6DF
+ D1FFE9AA80FFFEFAF6FFFDFAF6FFC88C64FFFBF3EEFFFBF1EAFFFCF6F2FFFEFB
+ F8FFFCF6F1FFF9ECE2FFF8E7DBFFEED0BAFFECD0BDFFBB703EFFBC6B36FFF6E0
+ D1FFF7E0D1FFFEFBF8FFFEFBF7FFFDF9F6FFFCF5F0FFFAF0EAFFFBF2EDFFFDF9
+ F6FFFDFAF7FFFBF1EBFFF8E9DFFFECD0BDFFC9895EFFCECFD100F0A3E300BC6B
+ 36FFBC6B36FFBC6B36FFBC6B36FFBB6B36FFBB6B36FFBB6A36FFBB6A36FFBC6C
+ 39FFBD6E3BFFBB6D3AFFBB6B38FFBB703EFFCECFD100CECFD100
+ }
+ ImageIndex = 1
+ OnClick = mnuFlushClick
+ end
+ object mnuShutdown: TMenuItem
+ Caption = '&Shutdown'
+ Bitmap.Data = {
+ 36040000424D3604000000000000360000002800000010000000100000000100
+ 2000000000000004000064000000640000000000000000000000000000000000
+ 000000000000E8E340000000000000000000080000000000000007CE03000000
+ 000003CE0700FFFFFF0000000000000000000000000000000000000000000000
+ 00000000000000000000E0000000444BD9FF474FDAFF434BD9FF4048D7FF3E47
+ D8FF353ED5FF3E5B6800000000000400000020E44000D4E3400000000000C0FF
+ 0700C0FF0700C0FF0700636CE4FF8997FAFF8495FFFF7F90FCFF7D8EFAFF7D8D
+ F7FF7D8BF2FF5159DDFFC0FF0700C0FF0700000000000000000000F8FF000000
+ 000000F8FF006C75E4FF96A5FAFF5A74FFFF3250FFFF304FFFFF2C49FEFF2542
+ FAFF4860F9FF8694F4FF5159DDFF000000000000000000000000000000001800
+ 18007981E7FF9FADFBFF6781FFFF405EFFFF405EFFFF3C59FFFF3755FFFF3350
+ FFFF2846FDFF4A65FDFF8996F6FF545EDEFF0800000000000000000000007178
+ E3FFA2B2FCFF738FFFFF4F70FFFF4F6EFFFF4B69FFFF4664FFFF415EFFFF3C5A
+ FFFF3755FFFF2C4BFFFF4E67FFFF8493FAFF4048D8FF38394100000000007D84
+ E5FFA6BBFFFF5F7FFFFF5F7EFFFF5A79FFFF5573FFFF506EFFFF4B69FFFF4664
+ FFFF415EFFFF3B59FFFF314FFFFF8799FFFF4D55DBFFC0FF070008000000858A
+ E6FFABBEFFFF6D8DFFFF6989FFFF6583FFFF5F7EFFFF5A79FFFF5574FFFF506F
+ FFFF4B69FFFF4663FFFF3F5CFFFF8A9BFFFF535BDCFF00000000010001008B91
+ E7FFB1C4FFFF7698FFFF7393FFFF6E8EFFFF6989FFFF6583FFFF5F7EFFFF5A79
+ FFFF5573FFFF4F6EFFFF4867FFFF90A1FFFF5A62DEFF00000000C0FF07009298
+ E9FFB8CDFFFF7DA0FFFF7C9DFFFF7899FFFF7393FFFF6E8EFFFF6989FFFF6583
+ FFFF607EFFFF5978FFFF4F70FFFF98AAFFFF636AE0FFE000000000000000959A
+ EAFFBCCDFCFF9CBBFFFF81A5FFFF81A2FFFF7C9EFFFF7899FFFF7493FFFF6F8E
+ FFFF6989FFFF6080FFFF7893FFFF9EADFBFF656CE0FFC0FF070068E140001CE1
+ 4000A5ACEFFFC1D1FCFFA0BFFFFF86AAFFFF85A7FFFF81A2FFFF7C9DFFFF7898
+ FFFF6F90FFFF85A1FFFFACBAFBFF838BE8FF0000000000000000FEFF7F00FCFF
+ 3F0000000000A6ADEEFFC4D4FCFFA3C2FFFF8BAFFFFF89ABFFFF84A7FFFF7EA0
+ FFFF91AEFFFFB4C3FBFF8C93EAFF275B68000000000004000000000000000000
+ 0000FCFF3F00FEFF7F00A9B1F0FFC2D3FCFFC1D6FFFFBDD1FFFFBBCFFFFFB9CE
+ FFFFB7C8FCFF989FEDFFFEFF7F00FEFF7F00FEFF7F00FEFF7F00080000000000
+ 00000000000000000000000000009EA3EBFFA0A5ECFF9DA2EBFF9BA0EBFF989E
+ EAFF9297E9FF0000000000000000000000000000000000000000F0A3E300183A
+ EE00187D7C00B81A1B000851A500225B6800000000000400000088E040003CE0
+ 400000000000000000000000000050E040000000000000000000
+ }
+ ImageIndex = 2
+ OnClick = mnuShutdownClick
+ end
+ object mnuSeparator2: TMenuItem
+ Caption = '-'
+ end
+ object mnuAccountControl: TMenuItem
+ Caption = '&Account Management'
+ Bitmap.Data = {
+ 36040000424D3604000000000000360000002800000010000000100000000100
+ 2000000000000004000064000000640000000000000000000000000000000000
+ 00000000000000000000366A820020B3F9000D8BD2000D629300526471000000
+ 00000000000033606A00236889003173930047899F00458B9F004B8B9C00578D
+ 9C00669BA6007BB1C400B35020FFA0401FFFAA4522FFAC4622FFAB4422FFA741
+ 21FF9F3D1FFFB24F24FF00000000000000000000000000000000000000000000
+ 00002579CDFF866161FFBF6035FFFEB961FFFEB962FFFEB962FFFEB962FFFEB9
+ 61FFFEB961FFB14924FF7A646DFF2E7ECEFF6DA2D3FF418DA600638D9900297D
+ D1FF82BAEEFF9F6658FFF5BB84FFFFAC5BFFFEA85AFFFEA257FFFE9C53FFFFA3
+ 55FFFF9F50FFF8AE78FFA45E4AFF83BCEFFF2A77CAFF0000000000000000287C
+ CEFF78B3EAFFB39E94FFFFB760FFFFB663FFFEB261FFFEAC5DFFFEA559FFFD9E
+ 53FFFE974EFFFF8D43FFBC8F82FF7EB8EDFF2974C7FF5D8C9C004F889900638B
+ 94008A5444FFFCC8ABFFFFD198FFFEC76DFFFEBF68FFFEB964FFFEB15EFFFEA8
+ 59FFFDA054FFFFB77AFFFEA980FF885042FF00000000000000000A1129000000
+ 000000000000C44C1FFFF6E4D6FFFFE4A4FFFFD472FFFFC969FFFFC063FFFFB6
+ 5FFFFFC180FFF6D7C6FFC5491FFF197498003E869A004F899A00307793003F77
+ 90004877860052849100BC481CFFF4E2D4FF4E7BA9FF4D7BA8FF4D7BA8FF4E7B
+ A9FFF3D6C3FFBE461CFF000000000000000012121500202035002244C200171A
+ 310000000000000000006A3C25FF346DA7FF9CCCF8FFAFD4F7FFAFD4F7FFA5CF
+ F6FF3474AEFF683E2DFF176B92001F7399001C6A8F002E7C9C00153E6400153F
+ 590010324A00204E5F002A5B92FFA6CAEEFFABCCEAFFA7D0F6FFA8D0F6FFABCC
+ EAFFA7CDEEFF2D629AFF000000003E3D4C001B286B00222E8700013BF4005676
+ DC0000000000000000001F5E9BFFD9E8F7FF97C5F1FF8EBBE5FF7FA9D1FF89B5
+ DFFFCDDFEEFF2368A7FF3A7F9000417F8C002C587300164A7200546C8100657A
+ 87007C8D9900899DA6000C3E87FF7C97B8FF8AB7E4FF719CC8FF15406EFF1944
+ 72FF22456BFF113B66FF0000000052536800031F8600011B8F00093DF5006478
+ C80000000000000000000F4B97FF12589FFF0F4A8AFF0F4B87FF114B87FF154C
+ 85FF124175FF0F335CFF5C828500627B8100546C7E0050647B00736976007D70
+ 78008A838A00908990009A929500114E96FF12589BFF125899FF115393FF0F4A
+ 87FF0E3E71FF132E4BFF000000001B1B1B002B3C8B0001239F00071E6A000000
+ 00000000000000000000000000000000000012488DFF104B90FF0F488AFF1142
+ 7DFF15335BFF657174006B777D0057717E0061707D006C627200F0A3E30008E0
+ 400000000000000000005D5C68005C637000686E7F0076889700BEC7CC004746
+ 4500000000000000000000000000000000003E4560000E32B600
+ }
+ ImageIndex = 3
+ OnClick = mnuAccountControlClick
+ end
+ object mnuRegionControl: TMenuItem
+ Caption = '&Region Management'
+ Bitmap.Data = {
+ 36040000424D3604000000000000360000002800000010000000100000000100
+ 2000000000000004000064000000640000000000000000000000454D47FF5F6A
+ 61FF636F64FF646F64FF143F56FF295F86FF4988BCFF4A86A7FF5D7070FF646F
+ 66FF646F66FF646F67FF646F67FF647067FF616C63FF474E48FF5F6A60FFEBF5
+ ECFFD4EDD7FFD4EED7FF2E6784FF94C7F9FF91C9F9FF4185C9FF256BACFFB7D9
+ D4FFD4E2ECFFCFE5D6FFD5EDD9FFD8EFDCFFD5EDD9FF616C63FF626E64FFEEF8
+ EFFFA4DBBCFF8CCAA6FF4389AAFFE0F2FFFF549AD8FF1A7ABEFF4998C5FF3B86
+ BFFF6074E7FF81C5A3FF8CD0A6FF85CAA0FFD2E9D7FF646F67FF616E64FFECF7
+ EEFF96DBAFFF7FC99AFF63ADA5FF7AB6D5FF90B7D1FF55C9E4FF5BDFF5FF78D0
+ EDFF4696D9FF76C1A1FF87D0A0FF80CA9AFFD6EEDAFF646F66FF616E63FFF7FB
+ F8FF9BDEC4FF73C393FF80CF9FFF53AD9CFF73B9D5FFC2F6FDFF63DFF7FF5DE2
+ F8FF79D3F0FF4395DAFF6CB8A4FF74C38FFFD7EFDAFF646F66FF616E63FFF8FC
+ F9FFBCFBFBFF9DE7DFFF93E1BBFF77C997FF63BDAEFF77CBE7FFC7F7FDFF5EDC
+ F5FF5AE1F7FF7BD4F1FF4395DDFF589BC3FFD0E9DBFF646F66FF606D63FFF8FC
+ F8FFA4EBEDFF8DDFDFFF97EBEBFF72CFB7FF74CA99FF4790BDFF79D3EEFFC7F7
+ FDFF5FDCF5FF5BE2F7FF7AD6F2FF4399DFFFB1D4D9FF646F66FF606D62FFF8FC
+ F8FFAFFAFAFF94EBEBFFA2F9FAFF8AEAEBFF95EDF3FF595FEBFF6BCFE5FF7CD4
+ EEFFC4F6FDFF6CDDF6FF6DCAEDFF63A3D7FF66A1D3FF617474FF606D61FFF8FC
+ F8FF9FF1F1FF81DDDFFF8AEAEBFF75DEDEFF6591EEFF557EE2FF68DCDDFF5BBC
+ C5FF80D5EDFFB2E3F9FF8BC0E7FFAED3F6FFC4E0FCFF669DD0FF5F6D61FFF8FC
+ F8FFA6F9F9FF8BE9EAFF99F8FAFF78D3EBFF656BFFFF77DCEAFF70DFDEFFC1C5
+ B5FFA8C8C8FF77BEE7FFB4D2F0FFE5F3FFFFACD2EFFF4A89BEFF5F6D61FFF8FC
+ F8FF90EAEAFF78DDDEFF81E9EAFF4E6BE2FF639DEEFF5ED7D7FF5BCBC9FFD4B0
+ 97FFE2BA9FFFA1ADA9FF58A5D8FF85B1DBFF469DD0FF4E7C8CFF5F6D61FFF7FC
+ F8FF9FF9F9FF85E9EAFF84D3FAFF525AF0FF87F2F7FF60DAD7FF98D5CAFFE0B7
+ 9CFFEDC7A9FFE0B394FFE6B898FFDEAE8CFFD7ECD6FF636E64FF5F6D60FFF7FC
+ F8FF8AEAEAFF72DDDEFF5665F0FF569FDFFF73E8E8FF46C1C1FFBBBBA5FFD0A4
+ 83FFDEB08EFFD19E7AFFD6A27AFFCF9871FFD7EBD5FF626E64FF5F6D60FFF7FC
+ F8FF9DF9F9FF6CB4EDFF6271FEFF80E7E9FF8CF4F4FF52CDCDFFECC2A4FFDDAD
+ 8AFFEBBA97FFDDA780FFE2AB83FFDAA075FFD9EAD4FF616E64FF5C6A5DFFFBFC
+ FBFFFCFEFCFFF7FCF8FFF7FCF8FFF7FCF8FFF8FCF8FFF7FCF9FFF8FCF8FFF8FC
+ F8FFECF7EEFFEDF7EEFFEFF6EDFFEEF4ECFFEBF4EBFF5E6A5FFF536876FF5C6A
+ 5DFF5F6D60FF5F6D60FF5F6D60FF5F6D60FF5F6D61FF5F6D61FF5F6D61FF5F6D
+ 61FF606D61FF606D62FF606D62FF606D63FF5E6A5FFF454E46FF
+ }
+ ImageIndex = 19
+ OnClick = mnuRegionControlClick
+ end
+ object mnuLargeScaleCommands: TMenuItem
+ Caption = 'Large Scale Commands'
+ Bitmap.Data = {
+ 36040000424D3604000000000000360000002800000010000000100000000100
+ 2000000000000004000064000000640000000000000000000000000000000000
+ 0000000000000000000000000000338037FF317D34FF2F7A32FF2F7A32FF2F7A
+ 32FF2F7A32FF00000000000000000000FF00FF00000000000000000000000000
+ 0000000000003D8F43FF3A8A3FFF9BC59DFFB3C29DFFBDC19CFFBEC39DFFB0D2
+ B1FF7EC09AFF2F7A32FF2F7A32FF0000FF00FF00000000000000000000000000
+ 0000469B4DFF70B786FFAEE8C7FFC0D2A0FFC5B381FFCAB47DFFCCAF78FFB9A7
+ 78FF80CC95FFA0DABCFF66A87AFF2F7A32FFFF00000000000000000000004EA8
+ 57FF76C08DFF99D7B3FF79C080FFBCC27EFFC6A96AFFD7B169FFD6AD65FFBC9B
+ 5EFF60AD6AFF599768FF81C199FF67A97BFF2F7A32FF000000000000000053AF
+ 5DFFB5EAD3FF69BC74FF6EBD71FFBEB66DFFC9A35BFFDFAB5BFFDDA858FFC192
+ 4EFF9DA958FF78B166FF5A9667FFA6DCC0FF2F7A32FF000000005ABA66FF92D7
+ AFFFA0DEB4FF84C670FFA8D080FFC5A55CFFD0A757FFE0AA56FFDAA651FFC798
+ 4AFFB98C47FFB69B57FF819F65FF79BF90FF81BE9CFF2F7A32FF5EBF6AFFB0E9
+ CFFF83D490FFBFDC8AFFC3CB82FFCCA256FFDAAF5CFFDCAF5BFFC99A4BFFBF86
+ 43FFB78443FFB99A52FF96A562FF65A676FFA2D8BDFF2F7A32FF60C36DFFBEEF
+ DDFF73D17DFF90D16CFFBCE09EFFC7A75EFFD3B05EFFC69953FFC6BC6EFFAFD1
+ 7AFFB4C46DFFAFA95FFF7BA957FF5AA367FFB1E3CEFF317E35FF61C46EFFBEF0
+ DCFF81D883FF77DB6DFFBFE59AFFCCDFA7FFCAA85DFFC2BD6CFFB8DA8BFFA6D8
+ 60FF77D13FFF6AD046FF59BC50FF63AB6CFFB2E4CEFF358239FF61C46EFFB3EC
+ D2FF9BE2A2FF9DEA8DFFD4EDB7FFD0EAC7FFCFB96EFFCCB166FFCBC975FF76DB
+ 67FF66D94DFF65D74DFF6CD35DFF73BB7EFFA5DBC2FF39883EFF61C46EFF98DE
+ B5FFB5EBCCFFB1EFA7FFC9EEA9FFD1EAC9FFD5CF8DFFD9CB8BFFCDB466FFBCBC
+ 67FF9AD671FF82DE73FF7ADC71FF91D0A3FF88C8A4FF3D8F43FF0000000061C4
+ 6EFFC0F3E2FFB5EFB4FFB5F0ACFFC1EDB7FFD4E3B7FFD9D89CFFDAD395FFCDB5
+ 6DFFC7B36DFFB5CB84FF94DF9AFFAFE7CDFF469B4DFF000000000000000061C4
+ 6EFF87D7A0FFC0F2DEFFC7F2D6FFD5EFD5FFD0E9CFFFD5DBA6FFDCDEABFFDBCD
+ 90FFD7C88BFFC9C18EFFBDD5AFFF7AC791FF4AA353FF00000000FFFFFF00FFFF
+ FF0061C46EFF8CD8A2FFCDF5E8FFD4EDDAFFCEEDD3FFCFDFAFFFD6DEB5FFD4D4
+ A2FFCED0A1FFC4D0AAFF87C991FF53AF5DFFFF00000000000000080000003737
+ 37003636360061C46EFF61C46EFFA5E1BBFFBAEACCFFC5E0BEFFC5DAB4FFBDD7
+ B0FFA6D7ACFF5DBE69FF5ABA66FF00000000EFFFFF00FFFFFF00F0A3E300B8EB
+ 760000000000000000000851A50061C46EFF61C46EFF61C46EFF61C46EFF61C4
+ 6EFF61C46EFF000000000000000050E912000000000000000000
+ }
+ ImageIndex = 14
+ OnClick = mnuLargeScaleCommandsClick
+ end
+ end
+ object mnuSettings: TMenuItem
+ Caption = '&Settings'
+ object mnuShowAnimations: TMenuItem
+ AutoCheck = True
+ Caption = '&Animations'
+ Checked = True
+ Hint = 'Toggles whether to animate tiles or not.'
+ OnClick = mnuShowAnimationsClick
+ end
+ object mnuSecurityQuestion: TMenuItem
+ AutoCheck = True
+ Caption = '&Security question'
+ Checked = True
+ Hint = 'Ask for permission before processing area commands.'
+ end
+ object mnuWhiteBackground: TMenuItem
+ AutoCheck = True
+ Caption = '&White Background'
+ OnClick = mnuWhiteBackgroundClick
+ end
+ end
+ object mnuHelp: TMenuItem
+ Caption = '&?'
+ object mnuAbout: TMenuItem
+ Caption = '&About'
+ OnClick = mnuAboutClick
+ end
+ end
+ end
+ object ImageList1: TImageList
+ left = 264
+ top = 32
+ Bitmap = {
+ 4C69170000001000000010000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000D9A781FFD39E76FF00000000000000000000000000000000000000000000
+ 0000000000000000000000000000ECBEA1FFE7BB9DFFE4B697FFE0B292FFDAAE
+ 8FFFDCB598FFCF9F7AFFC38657FF000000000000000000000000000000000000
+ 0000000000000000000000000000E8C0A4FFE9C8B0FFE5C3A9FFE1BDA2FFDCB6
+ 99FFD5AB8AFFD0A482FFB57644FF000000000000000000000000000000000000
+ 00000000000000000000E2B18FFFE7C1A8FFE0BA9FFFD8AC8BFFD2A582FFCE9D
+ 77FFD1A684FFBE865CFF00000000000000000000000000000000000000000000
+ 00000000000000000000D9A781FFD9AB88FFDAB294FFD8B092FFCB9972FFC490
+ 68FFC89C78FFB2724AFF00000000000000000000000000000000000000000000
+ 00009E9E9EFF999999FF0000000000000000C38657FFC9976FFFCB9F7CFFBC85
+ 59FFC3926BFFA6633EFF00000000000000000000000000000000EABE9FFFCEAF
+ 9AFFB7B7B7FFBCBCBCFF8C8C8CFF0000000000000000AE6D40FFBB835CFFC08F
+ 67FFBB8A60FF995033FF000000000000000000000000E7BB9CFFE8C0A3FFE5BF
+ A3FFB59D8AFFAEAEAEFF838383FF0000000000000000000000009F5734FFAD72
+ 4CFFA25F3FFF8E4129FF000000000000000000000000E3B493FFE8C6ADFFE3C0
+ A6FFDBB08FFFB48D71FF00000000717171FF676767FF00000000000000008F43
+ 2BFF8B4128FF00000000000000000000000000000000DDAE8CFFE2BEA4FFD8AB
+ 89FFD9B394FFCF9F7AFFA37858FF939393FFA9A9A9FF555555FF000000000000
+ 00000000000000000000000000000000000000000000D7A682FFDCB699FFD0A1
+ 7DFFCB9A73FFCFA482FFC79974FF896C58FF878787FF4E4E4EFF000000000000
+ 00000000000000000000000000000000000000000000D0A17CFFD7AE8FFFC997
+ 6FFFC38F66FFBD885CFFC08C64FFBC8861FF83513CFF00000000000000000000
+ 000000000000000000000000000000000000C68C60FFD1A683FFCC9F7BFFCB9E
+ 7BFFC79974FFC3926CFFBE8D65FFA86945FF0000000000000000000000000000
+ 0000000000000000000000000000C4885AFFC69268FFCDA280FFC59670FFB67B
+ 53FFAB6A46FFA35E3DFF9C5235FF91442CFF0000000000000000000000000000
+ 0000000000000000000000000000BA7C4AFFBF875CFFB97E56FFA7623AFF0000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 000000000000000000000000000000000000AB663CFFA45D38FF000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 000000000000000000000000000000000000BC6B36FFBC6B36FFBC6B36FFBC6B
+ 36FFBB6B36FFBB6B36FFBB6A36FFBB6A36FFBC6C39FFBD6E3BFFBB6D3AFFBB6B
+ 38FFBB703EFF0000000000000000BC6B36FFF6E0D1FFF7E0D1FFFEFBF8FFFEFB
+ F7FFFDF9F6FFFCF5F0FFFAF0EAFFFBF2EDFFFDF9F6FFFDFAF7FFFBF1EBFFF8E9
+ DFFFECD0BDFFC9895EFF00000000BC6B36FFF6DFD1FFE9AA80FFFEFAF6FFFDFA
+ F6FFC88C64FFFBF3EEFFFBF1EAFFFCF6F2FFFEFBF8FFFCF6F1FFF9ECE2FFF8E7
+ DBFFEED0BAFFECD0BDFFBB703EFFBC6B36FFF6DFD0FFE8A87EFFFCF6F1FFFCF6
+ F1FFC88C64FFFAF1E9FFFBF4EEFFFDFAF7FFFDF9F6FFFAF0E8FFF8E8DDFFF7E6
+ DBFFE1A37AFFEFD5C3FFB76935FFBC6B36FFF5DDCCFFE7A87EFFFAF0E8FFFAF0
+ E8FFC98D66FFFAF0E9FFFDF8F3FFFEFAF8FFFCF4EFFFF9E9DFFFF7E7DBFFF7E5
+ D9FFE0A278FFE7C2A9FFB66835FFBB6B36FFF4DCC9FFE7A77DFFF9ECE1FFF9EC
+ E1FFF9EDE3FFFCF4EEFFFDFAF7FFFDF7F3FFFAEDE5FFF7E7DBFFF7E5D9FFF6E5
+ D8FFDEA077FFE4BEA4FFB46734FFBB6B36FFF4D9C7FFE6A67DFFC88C64FFC98D
+ 65FFC98E67FFCB926CFFCB926DFFCA9069FFC88C65FFC88C64FFC88C64FFC88C
+ 64FFDA9C74FFE1BA9FFFB36634FFBB6A36FFF2D8C5FFE3A47BFFE3A37AFFE3A4
+ 7AFFE2A47BFFE2A37BFFE1A37BFFE1A279FFDFA077FFDE9F76FFDD9E74FFDB9C
+ 72FFDC9D74FFDDB59AFFB16534FFBB6A36FFF2D5C2FFE3A37AFFE3A37AFFE2A3
+ 7BFFE2A37BFFE2A47BFFE1A279FFE0A178FFDEA077FFDE9E75FFDC9D74FFDA9B
+ 73FFD99B73FFDAB095FFAF6433FFBB6A36FFF0D2BEFFE2A37AFFE2A37AFFE1A3
+ 7AFFE2A37BFFE1A37BFFE0A178FFDE9F77FFDD9F76FFDC9D74FFD99B72FFD899
+ 71FFD69970FFD5AB8EFFAD6333FFBA6A36FFEFD0BBFFE2A27AFFFEFBF8FFFEFB
+ F8FFFEFBF8FFFEFBF8FFFEFBF8FFFEFBF8FFFEFBF8FFFEFBF8FFFEFBF8FFFEFB
+ F8FFD3966DFFD2A78AFFAB6232FFBB6B38FFEFCEB8FFE1A279FFFEFAF7FF62C0
+ 88FF62C088FF62C088FF62C088FF62C088FF62C088FF62C088FF62C088FFFDF9
+ F6FFCF936AFFCEA384FFAA6132FFBB6C38FFEECCB6FFE1A27AFFFEFAF7FFBFDC
+ C2FFBFDCC2FFBFDCC2FFBFDCC2FFBFDCC2FFBFDCC2FFBFDCC2FFBFDCC2FFFDF9
+ F6FFCD9068FFCC9E81FFA86132FFBA6B37FFEDCAB3FFE0A27AFFFEFAF7FF62C0
+ 88FF62C088FF62C088FF62C088FF62C088FF62C088FF62C088FF62C088FFFDF9
+ F6FFCA8D65FFC99B7CFFA76031FFBA6A35FFEBC6ADFFEAC5ADFFFEFBF8FFFEFB
+ F8FFFEFBF8FFFEFBF8FFFEFBF8FFFEFBF8FFFEFBF8FFFEFBF8FFFEFBF8FFFEFB
+ F8FFC89A7CFFC79879FFA76031FFBA6A36FFB96935FFB86935FFB76835FFB568
+ 35FFB46734FFB26634FFB06533FFAE6433FFAC6332FFAA6232FFA96132FFA860
+ 31FFA76031FFA66031FFA86131FF000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 00009EA3EBFFA0A5ECFF9DA2EBFF9BA0EBFF989EEAFF9297E9FF000000000000
+ 000000000000000000000000000000000000000000000000000000000000A9B1
+ F0FFC2D3FCFFC1D6FFFFBDD1FFFFBBCFFFFFB9CEFFFFB7C8FCFF989FEDFF0000
+ 0000000000000000000000000000000000000000000000000000A6ADEEFFC4D4
+ FCFFA3C2FFFF8BAFFFFF89ABFFFF84A7FFFF7EA0FFFF91AEFFFFB4C3FBFF8C93
+ EAFF0000000000000000000000000000000000000000A5ACEFFFC1D1FCFFA0BF
+ FFFF86AAFFFF85A7FFFF81A2FFFF7C9DFFFF7898FFFF6F90FFFF85A1FFFFACBA
+ FBFF838BE8FF000000000000000000000000959AEAFFBCCDFCFF9CBBFFFF81A5
+ FFFF81A2FFFF7C9EFFFF7899FFFF7493FFFF6F8EFFFF6989FFFF6080FFFF7893
+ FFFF9EADFBFF656CE0FF00000000000000009298E9FFB8CDFFFF7DA0FFFF7C9D
+ FFFF7899FFFF7393FFFF6E8EFFFF6989FFFF6583FFFF607EFFFF5978FFFF4F70
+ FFFF98AAFFFF636AE0FF00000000000000008B91E7FFB1C4FFFF7698FFFF7393
+ FFFF6E8EFFFF6989FFFF6583FFFF5F7EFFFF5A79FFFF5573FFFF4F6EFFFF4867
+ FFFF90A1FFFF5A62DEFF0000000000000000858AE6FFABBEFFFF6D8DFFFF6989
+ FFFF6583FFFF5F7EFFFF5A79FFFF5574FFFF506FFFFF4B69FFFF4663FFFF3F5C
+ FFFF8A9BFFFF535BDCFF00000000000000007D84E5FFA6BBFFFF5F7FFFFF5F7E
+ FFFF5A79FFFF5573FFFF506EFFFF4B69FFFF4664FFFF415EFFFF3B59FFFF314F
+ FFFF8799FFFF4D55DBFF00000000000000007178E3FFA2B2FCFF738FFFFF4F70
+ FFFF4F6EFFFF4B69FFFF4664FFFF415EFFFF3C5AFFFF3755FFFF2C4BFFFF4E67
+ FFFF8493FAFF4048D8FF0000000000000000000000007981E7FF9FADFBFF6781
+ FFFF405EFFFF405EFFFF3C59FFFF3755FFFF3350FFFF2846FDFF4A65FDFF8996
+ F6FF545EDEFF00000000000000000000000000000000000000006C75E4FF96A5
+ FAFF5A74FFFF3250FFFF304FFFFF2C49FEFF2542FAFF4860F9FF8694F4FF5159
+ DDFF00000000000000000000000000000000000000000000000000000000636C
+ E4FF8997FAFF8495FFFF7F90FCFF7D8EFAFF7D8DF7FF7D8BF2FF5159DDFF0000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000444BD9FF474FDAFF434BD9FF4048D7FF3E47D8FF353ED5FF000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 00000000000012488DFF104B90FF0F488AFF11427DFF15335BFF000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000114E96FF12589BFF125899FF115393FF0F4A87FF0E3E71FF132E4BFF0000
+ 0000000000000000000000000000000000000000000000000000000000000F4B
+ 97FF12589FFF0F4A8AFF0F4B87FF114B87FF154C85FF124175FF0F335CFF0000
+ 0000000000000000000000000000000000000000000000000000000000000C3E
+ 87FF7C97B8FF8AB7E4FF719CC8FF15406EFF194472FF22456BFF113B66FF0000
+ 0000000000000000000000000000000000000000000000000000000000001F5E
+ 9BFFD9E8F7FF97C5F1FF8EBBE5FF7FA9D1FF89B5DFFFCDDFEEFF2368A7FF0000
+ 0000000000000000000000000000000000000000000000000000000000002A5B
+ 92FFA6CAEEFFABCCEAFFA7D0F6FFA8D0F6FFABCCEAFFA7CDEEFF2D629AFF0000
+ 0000000000000000000000000000000000000000000000000000000000006A3C
+ 25FF346DA7FF9CCCF8FFAFD4F7FFAFD4F7FFA5CFF6FF3474AEFF683E2DFF0000
+ 000000000000000000000000000000000000000000000000000000000000BC48
+ 1CFFF4E2D4FF4E7BA9FF4D7BA8FF4D7BA8FF4E7BA9FFF3D6C3FFBE461CFF0000
+ 0000000000000000000000000000000000000000000000000000C44C1FFFF6E4
+ D6FFFFE4A4FFFFD472FFFFC969FFFFC063FFFFB65FFFFFC180FFF6D7C6FFC549
+ 1FFF00000000000000000000000000000000000000008A5444FFFCC8ABFFFFD1
+ 98FFFEC76DFFFEBF68FFFEB964FFFEB15EFFFEA859FFFDA054FFFFB77AFFFEA9
+ 80FF885042FF000000000000000000000000287CCEFF78B3EAFFB39E94FFFFB7
+ 60FFFFB663FFFEB261FFFEAC5DFFFEA559FFFD9E53FFFE974EFFFF8D43FFBC8F
+ 82FF7EB8EDFF2974C7FF0000000000000000297DD1FF82BAEEFF9F6658FFF5BB
+ 84FFFFAC5BFFFEA85AFFFEA257FFFE9C53FFFFA355FFFF9F50FFF8AE78FFA45E
+ 4AFF83BCEFFF2A77CAFF0000000000000000000000002579CDFF866161FFBF60
+ 35FFFEB961FFFEB962FFFEB962FFFEB962FFFEB961FFFEB961FFB14924FF7A64
+ 6DFF2E7ECEFF6DA2D3FF0000000000000000000000000000000000000000B350
+ 20FFA0401FFFAA4522FFAC4622FFAB4422FFA74121FF9F3D1FFFB24F24FF0000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 000000000000000000000000000000000000000000000000000000000000C8C8
+ C8FFC5C5C5FF0000000000000000000000000000000000000000000000000000
+ 000000000000000000000000000000000000000000000000000000000000C4C4
+ C4FFD9D9D9FFBEBEBEFF00000000000000000000000000000000000000000000
+ 000000000000000000000000000000000000000000000000000000000000C1C1
+ C1FFF7F7F7FFD5D5D5FFB6B6B6FF000000000000000000000000000000000000
+ 000000000000000000000000000000000000000000000000000000000000BDBD
+ BDFFF7F7F7FFEFEFEFFFD0D0D0FFAFAFAFFF0000000000000000000000000000
+ 000000000000000000000000000000000000000000000000000000000000B9B9
+ B9FFF4F4F4FFECECECFFEDEDEDFFCBCBCBFFA7A7A7FF00000000000000000000
+ 000000000000000000000000000000000000000000000000000000000000B5B5
+ B5FFF2F2F2FFE8E8E8FFE7E7E7FFEAEAEAFFC6C6C6FF9E9E9EFF000000000000
+ 000000000000000000000000000000000000000000000000000000000000B1B1
+ B1FFF0F0F0FFE4E4E4FFE2E2E2FFE2E2E2FFE7E7E7FFC1C1C1FF969696FF0000
+ 000000000000000000000000000000000000000000000000000000000000ADAD
+ ADFFEEEEEEFFE1E1E1FFDFDFDFFFE0E0E0FFE7E7E7FFE4E4E4FFBBBBBBFF8E8E
+ 8EFF00000000000000000000000000000000000000000000000000000000A9A9
+ A9FFF2F2F2FFE5E5E5FFE2E2E2FFE3E3E3FF959595FF919191FF8D8D8DFF8989
+ 89FF868686FF000000000000000000000000000000000000000000000000A4A4
+ A4FFD7D7D7FF9D9D9DFFD0D0D0FFEEEEEEFF919191FF00000000000000000000
+ 000000000000000000000000000000000000000000000000000000000000A0A0
+ A0FF9C9C9CFF00000000949494FFD9D9D9FFC1C1C1FF898989FF000000000000
+ 0000000000000000000000000000000000000000000000000000000000009C9C
+ 9CFF000000000000000000000000ADADADFFF2F2F2FF848484FF000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000888888FFDBDBDBFFB7B7B7FF7D7D7DFF0000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 000000000000000000000000000000000000AAAAAAFFDBDBDBFF797979FF0000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000007C7C7CFF787878FF757575FF0000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 00000000000000000000000000000000000000000000000000004FAADBFF5093
+ CAFF4E90C8FF2F9DD2FF00000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000050A8D9FF6AA5D8FFC9E1
+ F7FFCBE3F8FF4295CAFF3182C2FF000000000000000000000000000000000000
+ 0000000000000000000000000000000000002FBAE4FFA7D4F4FFC5E1F8FFCCE3
+ F9FFCCE3F9FFBDDBF7FF4F90C9FF000000000000000000000000000000000000
+ 00000000000000000000000000002FBAE4FFC3EDF8FFA8E2F8FF6CAEDDFFA5CF
+ F4FFA5CFF4FFBDDBF7FF5393CBFF000000000000000000000000000000000000
+ 000000000000000000002FBAE4FFC3EDF8FFB3F4FCFF68D9F5FF6FCFF3FF599D
+ D0FF73ABDDFF4F91C9FF00000000000000000000000000000000000000000000
+ 0000000000002FBAE4FFC3EDF8FFB3F4FCFF60DCF5FF44D6F4FF8EEEFAFF5DB4
+ E6FF3B8FD9FF0000000000000000000000000000000000000000000000000000
+ 00002FBAE4FFC3EDF8FFB3F4FCFF60DCF5FF44D6F4FF8EEEFAFF5DB4E6FF3B8F
+ D9FF000000000000000000000000000000000000000000000000000000002790
+ BFFFC3EDF8FFB3F4FCFF60DCF5FF44D6F4FF8EEEFAFF5DB4E6FF3B8FD9FF0000
+ 00000000000000000000000000000000000000000000000000002689B9FFBEE6
+ F2FFB3F4FCFF60DCF5FF44D6F4FF8EEEFAFF5DB4E6FF3B8FD9FF000000000000
+ 000000000000000000000000000000000000000000002689B9FFB0CBE1FF67A9
+ C8FF60DCF5FF44D6F4FF8EEEFAFF5DB4E6FF3B8FD9FF00000000000000000000
+ 0000000000000000000000000000000000001E6D93FFC8E1F2FFD1E7FAFF347D
+ B5FF3199C3FF6DC4DCFF4A9CCFFF3483C7FF0000000000000000000000000000
+ 0000000000000000000000000000000000001E6D93FFCBE3F9FF61AAECFF4098
+ E8FF1567C2FF1660AAFF2C76B4FF000000000000000000000000000000000000
+ 000000000000000000000000000000000000124259FF5D9CD4FFA6CFF5FFA9CF
+ ECFF488BC1FF2C76B4FF00000000000000000000000000000000000000000000
+ 000000000000000000000000000000000000134058FF15425EFF25699CFF2C76
+ B4FF3B8BBAFF0000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 000000000000000000000000000068C774FF68C774FF67C673FF66C572FF65C3
+ 71FF0000000000000000000000000000000000000000000000005CB666FF5BB4
+ 64FF59B262FF58AF60FF56AD5EFF68C774FFA1D8A9FF9ED6A7FF65C371FF0000
+ 0000000000000000000000000000000000000000000000000000000000005FB4
+ 67FF8DC894FF8EC995FF54AA5CFF67C673FF9DD6A5FF92D19BFF7ECA87FF63C0
+ 6EFF00000000000000000000000000000000000000000000000059B162FF76BD
+ 7EFF7EC086FF8AC590FF52A85AFF66C472FF6BC575FF83CC8CFF9BD3A4FF7BC7
+ 84FF60BC6BFF0000000000000000000000000000000059B161FF75BD7DFF8CC7
+ 93FF6DB673FF52A759FF50A557FF65C370FF0000000063BF6DFF80C989FF79C4
+ 82FF5FB969FF0000000000000000000000000000000057AE5FFF6EB875FF6CB5
+ 73FF52A759FF000000004EA255FF00000000000000000000000060BB6AFF5EB9
+ 68FF00000000000000000000000000000000000000000000000053A95BFF52A7
+ 59FF000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 000000000000000000000000000000000000000000000000000057AE5FFF55AC
+ 5DFF0000000000000000000000000000000000000000000000004A9C50FF4899
+ 4EFF0000000000000000000000005AB363FF0000000057AE5FFF6CB673FF6AB4
+ 71FF52A759FF000000000000000000000000000000004A9B4FFF5FA764FF62A8
+ 67FF45954AFF00000000439147FF58B061FF57AE5FFF6CB673FF84C08AFF6EB5
+ 74FF50A457FF0000000000000000000000000000000048994DFF5DA561FF75B3
+ 79FF5FA463FF47944CFF418F45FF56AD5FFF83C08AFF73B77AFF6CB473FF50A4
+ 57FF000000000000000000000000000000000000000000000000459449FF5AA0
+ 5EFF5EA664FF6CAD70FF408D44FF54AB5CFF83BF89FF7DBB83FF54A65BFF0000
+ 0000000000000000000000000000000000000000000000000000000000004290
+ 46FF6DAD71FF6EAE73FF3F8C42FF53A85AFF51A658FF4FA356FF4EA154FF4C9F
+ 52FF000000000000000000000000000000000000000000000000429046FF418E
+ 45FF408D43FF3F8B42FF3E8A41FF000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000067C673FF65C270FF0000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 00000000000066C572FF7ECA88FF7BC885FF5DB868FF00000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 000066C472FF7CCA87FF9ED6A7FF9CD4A5FF73C07DFF55AC5EFF000000000000
+ 00000000000000000000000000000000000000000000000000000000000065C3
+ 71FF62BF6EFF79C683FF9AD4A3FF98D3A1FF7DC386FF4FA458FF4A9E53FF0000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000005BB465FF96D29FFF94D09CFF5DAC65FF00000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 00000000000056AD5FFF93CF9AFF90CE98FF489A50FF00000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 00000000000050A659FF8ECC95FF8BCB93FF42924AFF00000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000004A9E53FF8ACA91FF87C98EFF3C8A43FF00000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 00000000000045954CFF85C78CFF82C689FF36823DFF00000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000003F8D46FF81C587FF7EC385FF317A36FF00000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 00000000000039853FFF7DC282FF7AC180FF2B7230FF00000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 000000000000337D39FF79C07EFF76BF7CFF266B2BFF00000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000002D7533FF74BD7AFF72BD78FF226526FF00000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 000000000000286E2DFF256929FF216425FF1E6022FF00000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000A77B3EFF0000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000CBAE87FF0000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000D5BC9DFF0000000000000000000000000000
+ 0000AE854CFF0000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000DEC8AEFF000000000000000000000000D1B6
+ 93FFBB9767FF0000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000E6D4C0FF0000000000000000D3B999FFD3B8
+ 97FF000000000000000000000000000000000000000000000000000000000000
+ 00000000000000000000AF8750FFEDDECEFF00000000CEB38FFFE7D6C3FF0000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 00000000000000000000B28A54FFF1E2D3FFCFB38EFFF5E9DCFF000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 00000000000000000000B68F59FFF5E9DDFFE2CDB4FFB99461FF000000000000
+ 0000000000000000000000000000000000000000000000000000000000009D69
+ 32FFB17E42FF9E682CFFBC9767FFF0E0D0FFB6915FFF00000000000000000000
+ 0000000000000000000000000000000000000000000000000000B17E42FFDCAA
+ 60FFD09E54FFEAB365FFD8BA99FFF8EBE1FFAE8957FF00000000000000000000
+ 000000000000000000000000000000000000000000009C6A32FFD6A55EFF0000
+ 000000000000E4AD60FFDCBD9BFFEFCDA5FFEFB767FFD8A65DFF000000000000
+ 00000000000000000000000000000000000000000000BE8A4AFFA87E41FF0000
+ 0000966E32FFE7B066FFCAA274FFE5B167FF945E2DFFB88D4DFFAF703BFF0000
+ 00000000000000000000000000000000000000000000B58244FFD6A45AFFAE82
+ 41FFECB666FFA76E36FFAC6C37FFC49551FF0000000000000000B77840FF0000
+ 0000000000000000000000000000000000000000000000000000C79751FFD8A6
+ 5AFFA66C36FF00000000A86835FFD1A057FF000000008E6A36FFB4753FFF0000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 000000000000000000009F5E2FFFE7B263FFBF924FFFDDAB62FFA26232FF0000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000A06131FFB6763FFFA46534FF000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 000000000000000000000000000000000000898989FF888888FF878787FF0000
+ 0000000000000000000000000000000000000000000000000000000000006B6B
+ 6BFF666666FF626262FF0000000000000000898989FFD3D3D3FF848484FFE6B3
+ 8CFFE5B28AFFE5B289FFE5AF86FFE5AE86FFE3AC85FFE3AB83FFE3A980FF6262
+ 62FFC4C4C4FF585858FF0000000000000000868686FF838383FF968D87FFEBC4
+ A5FFEBC2A4FFEBC2A3FFEAC0A2FFEABFA0FFEABE9FFFE8BC9EFFE8BB9CFF7E72
+ 6AFF535353FF4F4F4FFF000000000000000000000000E5B289FFEBC3A5FFEBC2
+ A3FFEBC0A2FFEABFA1FFEABEA0FFE9BD9EFFE8BB9DFFE8BA9BFFE7B899FFE6B6
+ 97FFDE9D75FF00000000000000000000000000000000E5AF86FFEBC1A2FFEAC0
+ A2FFEABEA0FFE9BD9EFFE8BC9DFFE8BA9BFFE7B899FFE6B698FFE6B596FFE5B3
+ 94FFDC9A70FF00000000000000000000000000000000E3AC85FFEABFA0FFEABE
+ 9FFFE8BC9DFFE8BA9CFFE8B99AFFE6B798FFE6B696FFE5B494FFE4B393FFE4B1
+ 91FFDA966CFF00000000000000000000000000000000E3AA81FFE9BC9EFFE8BB
+ 9CFFE8B99AFFE7B899FFE6B697FFE6B495FFE4B394FFE4B192FFE3AF90FFE3AE
+ 8FFFD9926AFF00000000000000000000000000000000E1A67FFFE8BA9BFFE7B8
+ 99FFE6B697FFE6B596FFE5B394FFE4B192FFE4AF91FFE3AE8FFFE3AD8DFFE2AB
+ 8BFFD88E66FF00000000000000000000000000000000E1A27BFFE6B798FFE6B5
+ 96FFE5B494FFE4B292FFE4B191FFE3AF8FFFE3AD8DFFE2AC8CFFE1AA8AFFE1A9
+ 89FFD68C62FF00000000000000000000000000000000DE9F77FFE5B495FFE4B3
+ 93FFE4B192FFE3AF90FFE3AE8EFFE2AC8DFFE1AA8BFFE1A989FFE0A787FFDFA6
+ 86FFD5895FFF00000000000000000000000000000000DD9B73FFE4B192FFE4AF
+ 91FFE3AE8FFFE3AC8DFFE1AB8BFFE1A989FFE1A888FFE0A786FFDFA585FFDFA3
+ 84FFD4865DFF000000000000000000000000424242FF3D3D3DFF534B46FFE3AD
+ 8DFFE2AB8BFFE1AA8AFFE1A888FFE0A787FFDFA585FFDFA484FFDEA383FF4233
+ 2BFF0A0A0AFF070707FF00000000000000003A3A3AFFB7B7B7FF313030FFD890
+ 66FFD88E64FFD68C62FFD58961FFD5895FFFD5865DFFD4855BFFD4855AFF0909
+ 09FFA6A6A6FF030303FF0000000000000000323232FF2D2D2DFF282828FF0000
+ 0000000000000000000000000000000000000000000000000000000000000404
+ 04FF010101FF000000FF00000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 00000000000000000000063922FF0A3C24FF0000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 000000000000104F38FF0D4A2DFF093D22FF093A28FF00000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000063420FF0D3D2BFF0B4028FF0D4726FF0A3A26FF194833FF000000000000
+ 0000000000000000000000000000000000000000000000000000000000000B48
+ 23FF144C2FFF124631FF0B4029FF114B28FF073121FF0F452DFF114A32FF0000
+ 000000000000000000000000000000000000000000000000000005291DFF0F51
+ 31FF0F3924FF144A31FF0A3C28FF0D4224FF093D24FF0C4528FF0C3F29FF0F4D
+ 38FF000000000000000000000000000000000000000014553FFF0B3A2AFF114F
+ 32FF053220FF0E3E29FF08311CFF0C4426FF0F482CFF0D4A2EFF0D4326FF124E
+ 39FF083F28FF000000000000000000000000093625FF104330FF083727FF0C45
+ 2EFF073325FF154534FF0F4629FF0A4023FF0E4733FF0F4831FF0F4229FF0B43
+ 2DFF0C472EFF072217FF000000000A3D2AFF062C1AFF124D2FFF0A3E24FF1049
+ 33FF124735FF0C3626FF0D4224FF0E452FFF0A4030FF093927FF0C422AFF0D41
+ 2EFF0A3623FF0B3E2AFF083D27FF012818FF093D29FF093923FF0E4226FF0F43
+ 2AFF0E442AFF0D402FFF09392BFF0F452CFF11492FFF0C452FFF124B31FF0E42
+ 2BFF0A3F24FF07301EFF0D3C2CFF00000000052F1DFF093726FF0F4A32FF0D41
+ 29FF114A2CFF104532FF0E462BFF0C3C27FF0E4227FF0C4229FF0E422DFF0E45
+ 27FF144D34FF083A24FF000000000000000000000000123F30FF0B3C2BFF1148
+ 31FF0D4129FF05271AFF0B3F27FF0D3F2CFF134933FF144C34FF0E422EFF0C44
+ 2EFF0C402DFF00000000000000000000000000000000000000000C4933FF104A
+ 38FF0A3E25FF164B37FF0E432FFF063318FF134734FF093121FF0C3723FF0943
+ 2CFF000000000000000000000000000000000000000000000000000000000632
+ 20FF124D36FF0C3C28FF093C25FF104A25FF0F4B30FF0B4529FF062F19FF0000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000073E24FF083722FF0C4226FF0F472DFF0F4534FF052F1FFF000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 000000000000114D37FF0A3825FF0C432BFF05382AFF00000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000006301CFF10492EFF0000000000000000000000000000
+ 00000000000000000000000000004D5563FF0000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 00000000000000000000323F54FF2B3953FF283143FF00000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000002A3646FF1B283DFF30426AFF26354BFF4B566CFF000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 00002B3745FF142232FF1D2944FF2F4267FF274161FF2B3D54FF2F3C4CFF0000
+ 0000000000000000000000000000000000000000000000000000000000001E27
+ 36FF1A2939FF122235FF192741FF304A69FF2C4E71FF214066FF273B4FFF4853
+ 65FF0000000000000000000000000000000000000000000000001F2D3CFF1824
+ 33FF1B2B43FF0F2237FF172543FF35476AFF2C496DFF203C61FF274B70FF283A
+ 51FF2B3746FF000000000000000000000000000000001F2A3AFF18263CFF1A25
+ 3AFF18253CFF0F1E34FF1E2744FF2F4267FF2D4569FF253F64FF2B4F78FF1C3A
+ 5BFF2A364DFF404F62FF0000000000000000212D39FF101E2CFF1B2842FF1822
+ 3BFF1D2A42FF112134FF1A2842FF2C4464FF2D4C6FFF22436AFF335680FF2544
+ 64FF304669FF263547FF27333FFF1E2934FF1A293AFF101E33FF19273EFF1524
+ 39FF1C2C43FF102337FF192642FF354760FF2A4A6CFF213F63FF2A4D71FF2744
+ 63FF2D4466FF25374BFF2C3D53FF152431FF132740FF121D2FFF1D2946FF1926
+ 3CFF19263DFF0D2033FF17253CFF00000000324A71FF243D62FF2B4E76FF233E
+ 61FF33496DFF2C3F55FF31435FFF162033FF142846FF111F31FF1C2843FF1822
+ 39FF18243BFF101D30FF000000000000000000000000224068FF2A4D76FF2643
+ 65FF354D6FFF2C3F56FF2F425CFF121D2BFF1B2B45FF101E32FF19273FFF1524
+ 39FF162637FF00000000000000000000000000000000000000002E507AFF2544
+ 61FF2D4467FF28394FFF314461FF101C2BFF182841FF111C31FF1C2841FF1623
+ 36FF000000000000000000000000000000000000000000000000000000002940
+ 5AFF304566FF2A3B51FF30435EFF152032FF132945FF132031FF172841FF0000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000384F71FF2E4359FF2C3F5AFF141E2DFF1B2B44FF111E2EFF000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000002C4055FF273B57FF101C27FF1E3049FF00000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 00000000000000000000273D57FF131B2AFF0000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 000000000000000000005F93D4FF5C91D1FF598FCFFF558DCCFF000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 00006194D5FF77A4DCFF92B9E4FFA9CAECFFA6C7ECFF8EB6E2FF699BD2FF4A84
+ C3FF000000000000000000000000000000000000000000000000000000006094
+ D5FF8FB7E3FFBAD7F3FF5ED5FBFF2BD5FFFF42D1FBFFB4D2F2FFB2D0F1FF93B9
+ E2FF6396CCFF3E7CB9FF0000000000000000000000006295D6FF86AFE1FF5BB3
+ F9FF2CA4FFFF41AAFBFF31D3FEFF6DE2FFFF2CD5FFFF80B1E8FF7DAEE7FFAACA
+ EFFFA6C6EDFF3878B6FF00000000000000006194D5FF87B0E1FFBAD7F3FF33A7
+ FEFF6DC0FFFF2CA4FFFF67BFF0FF3BCEFBFF5BBFF1FF53B4A1FF3CB87AFF48B4
+ 91FFA8C8EEFF78A6D6FF3072AFFF000000005D92D2FF93A5F5FF5A5BF6FF5287
+ F4FF3CA7FBFF5DACF2FF7FB0E7FF7CAEE7FF79ABE6FF40B781FF61C898FF3CB8
+ 7BFF7EADE7FF90B6E3FF2B6FABFF5C91D1FF93BAE5FF6F75F6FF8285F5FF4141
+ F0FF91BCEBFFAFCDF0FFADCCF0FFABCAF0FF86B3E9FF5FAAC2FF45B48EFF57A9
+ B7FF71A2E4FF98BBE8FF266BA7FF588ECEFFA9C9EDFF85A8EDFF596BEDFF6B8F
+ E9FFAECDF0FF6E9ED2FF3F7DBAFF689ACEFFA6C6EEFF969B6AFFAE9827FF9E98
+ 4EFF679CE2FF99BCEAFF2268A3FF538BCBFFAFCDF0FFB1CFF0FF99C0ECFF7FAF
+ E7FFABCAEFFF3E7CB9FF000000003677B4FFA3C4EDFFA99832FFC5B65BFFAD98
+ 27FF5C94DFFF99BCEBFF1D65A0FF4F88C7FF6598CFFF7CA9D9FF8EB5E2FFA4C5
+ EDFFA8C7EEFF6598CDFF3576B3FF6094C9FFA0C1EDFF7997A4FF9F9749FF7D95
+ 92FF8EB4E9FF7AA6D8FF19629DFF0000000000000000427FBDFF3F7DBAFF3B7A
+ B8FF77A5D7FFA2C3EDFFA0C1EDFF9EC0EDFF75A4E4FF5B93DFFF5991DEFF7CA8
+ E6FF93B7E8FF4480B8FF00000000000000000000000000000000000000000000
+ 00003274B1FF9EC0ECFF6A9DE2FF5C94DFFF5992DFFF6095E0FF96B9EAFF87AE
+ E1FF4A84BCFF145F99FF00000000000000000000000000000000000000000000
+ 00002D70ADFF6E9ED1FF9ABDEBFF72A1E3FF97BAEAFF95B9EAFF6194CAFF1660
+ 9AFF000000000000000000000000000000000000000000000000000000000000
+ 000000000000256BA6FF87AEE1FF7FA9DCFF6093C9FF3173ACFF15609AFF0000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 000000000000000000001D65A0FF1A639EFF17619BFF00000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 000000000000000000000000000000000000CEB3A1FFCFB19FFFCDAB95FFCDA7
+ 8EFFCDA78EFFCDA78EFFCDA78EFFCDA78EFFCDA68EFFCDA68EFFCDA68EFFCDA6
+ 8EFFCDAA93FFCDAF9BFF0000000000000000CFB29FFFECECEBFFF4F4F3FFF7F5
+ F4FFF7F5F4FFF7F5F4FFF7F5F4FFF7F5F4FFF7F5F4FFF7F5F4FFF7F5F4FFF7F3
+ ECFFF2EFE9FFCEAD97FF0000000000000000CDAB95FFF4F3F2FFE3B495FFD0B4
+ 8DFFA9B580FF93CCA1FF84D1AAFF82D0A6FF8BC294FF9A9E69FFC39D73FFD69D
+ 77FFF7F2EBFFCFAB94FF0000000000000000CDA78FFFF7F5F4FFE3B597FFB8B7
+ 87FF93CBA1FF74D2A8FF67CB9BFF63C897FF6AC998FF83BB8BFFA5996AFFD79F
+ 7AFFF7F0E9FFCFAB94FF0000000000000000CDA78FFFF7F5F2FFE4B799FFA3B6
+ 80FF82D0A7FF65C998FF5DC691FF59C28BFF58C187FF71C28EFF8C925FFFD9A2
+ 7DFFF6F0E8FFCEAB94FF0000000000000000CDA78FFFF7F5F0FFE5B89BFFA1B3
+ 7FFF7DCDA0FF5EC590FF56C087FF52BE81FF52BC7EFF6CBD87FF89905EFFDAA4
+ 81FFF5EFE7FFCEAB94FF0000000000000000CDA78FFFF7F4EFFFE6B99DFFB6B3
+ 87FF88C293FF63C58FFF53BE80FF4FBA7AFF58BD7FFF78B07CFFA3966AFFDCA7
+ 84FFF6EEE7FFCEAB94FF0000000000000000CDA78FFFF7F3EEFFE7BB9FFFD1B6
+ 93FF9FAA78FF6FB287FF65BD8AFF61BB87FF6BAB7BFF919364FFC5A27DFFDDA9
+ 88FFF6EEE7FFCEAB94FF0000000000000000CDA78EFFF7F2EDFFE8BDA1FFE7BB
+ 9FFFD0B392FF5E8276FF448E86FF418B87FF568380FFC7A682FFE0AE8EFFDEAC
+ 8BFFF6EEE6FFCEAB94FF0000000000000000CDA78EFFF7F1ECFF4EAA7AFF4CA8
+ 77FF4AA674FF357B9AFF549FD3FF549FD1FF3F86AFFF409A67FF3E9865FF3C96
+ 63FFF6EEE6FFCEAB94FF0000000000000000CCA68DFFF7F1EDFFBFDCC2FFBFDC
+ C2FFBFDCC2FFAFD3C5FF9CC8C9FF6EAFD1FFBAD9C3FFBFDCC2FFBFDCC2FFBFDC
+ C2FFF6EDE6FFCEAA93FF0000000000000000CCA68EFFF6F1EDFFBFDCC2FFBFDC
+ C2FFBFDCC2FFBFDCC2FFBFDCC2FFBFDCC2FFBFDCC2FFBFDCC2FFBFDCC2FFBFDC
+ C2FFF7EDE6FFCEAA93FF0000000000000000CDAB96FFF1EFEDFFF7F3F1FFF8F4
+ F1FFF8F4F0FFF7F4F0FFF7F3F0FFF7F3EFFFF7F3EFFFF7F3EFFFF7F3EFFFF8F3
+ EFFFF2EFEBFFCFAD97FF0000000000000000CEAF9CFFCFAE9AFFCEAB94FFCEAA
+ 93FFCEAA93FFCEAA93FFCEAA93FFCEAA93FFCEAA93FFCEAA93FFCEAA93FFCEAA
+ 93FFCEAD97FFCEAF9CFF00000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 000061C46EFF61C46EFF61C46EFF61C46EFF61C46EFF61C46EFF000000000000
+ 000000000000000000000000000000000000000000000000000061C46EFF61C4
+ 6EFFA5E1BBFFBAEACCFFC5E0BEFFC5DAB4FFBDD7B0FFA6D7ACFF5DBE69FF5ABA
+ 66FF000000000000000000000000000000000000000061C46EFF8CD8A2FFCDF5
+ E8FFD4EDDAFFCEEDD3FFCFDFAFFFD6DEB5FFD4D4A2FFCED0A1FFC4D0AAFF87C9
+ 91FF53AF5DFF00000000000000000000000061C46EFF87D7A0FFC0F2DEFFC7F2
+ D6FFD5EFD5FFD0E9CFFFD5DBA6FFDCDEABFFDBCD90FFD7C88BFFC9C18EFFBDD5
+ AFFF7AC791FF4AA353FF000000000000000061C46EFFC0F3E2FFB5EFB4FFB5F0
+ ACFFC1EDB7FFD4E3B7FFD9D89CFFDAD395FFCDB56DFFC7B36DFFB5CB84FF94DF
+ 9AFFAFE7CDFF469B4DFF0000000061C46EFF98DEB5FFB5EBCCFFB1EFA7FFC9EE
+ A9FFD1EAC9FFD5CF8DFFD9CB8BFFCDB466FFBCBC67FF9AD671FF82DE73FF7ADC
+ 71FF91D0A3FF88C8A4FF3D8F43FF61C46EFFB3ECD2FF9BE2A2FF9DEA8DFFD4ED
+ B7FFD0EAC7FFCFB96EFFCCB166FFCBC975FF76DB67FF66D94DFF65D74DFF6CD3
+ 5DFF73BB7EFFA5DBC2FF39883EFF61C46EFFBEF0DCFF81D883FF77DB6DFFBFE5
+ 9AFFCCDFA7FFCAA85DFFC2BD6CFFB8DA8BFFA6D860FF77D13FFF6AD046FF59BC
+ 50FF63AB6CFFB2E4CEFF358239FF60C36DFFBEEFDDFF73D17DFF90D16CFFBCE0
+ 9EFFC7A75EFFD3B05EFFC69953FFC6BC6EFFAFD17AFFB4C46DFFAFA95FFF7BA9
+ 57FF5AA367FFB1E3CEFF317E35FF5EBF6AFFB0E9CFFF83D490FFBFDC8AFFC3CB
+ 82FFCCA256FFDAAF5CFFDCAF5BFFC99A4BFFBF8643FFB78443FFB99A52FF96A5
+ 62FF65A676FFA2D8BDFF2F7A32FF5ABA66FF92D7AFFFA0DEB4FF84C670FFA8D0
+ 80FFC5A55CFFD0A757FFE0AA56FFDAA651FFC7984AFFB98C47FFB69B57FF819F
+ 65FF79BF90FF81BE9CFF2F7A32FF0000000053AF5DFFB5EAD3FF69BC74FF6EBD
+ 71FFBEB66DFFC9A35BFFDFAB5BFFDDA858FFC1924EFF9DA958FF78B166FF5A96
+ 67FFA6DCC0FF2F7A32FF00000000000000004EA857FF76C08DFF99D7B3FF79C0
+ 80FFBCC27EFFC6A96AFFD7B169FFD6AD65FFBC9B5EFF60AD6AFF599768FF81C1
+ 99FF67A97BFF2F7A32FF000000000000000000000000469B4DFF70B786FFAEE8
+ C7FFC0D2A0FFC5B381FFCAB47DFFCCAF78FFB9A778FF80CC95FFA0DABCFF66A8
+ 7AFF2F7A32FF00000000000000000000000000000000000000003D8F43FF3A8A
+ 3FFF9BC59DFFB3C29DFFBDC19CFFBEC39DFFB0D2B1FF7EC09AFF2F7A32FF2F7A
+ 32FF000000000000000000000000000000000000000000000000000000000000
+ 0000338037FF317D34FF2F7A32FF2F7A32FF2F7A32FF2F7A32FF000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000068C774FF68C673FF65C2
+ 71FF62BE6EFF5FBA6AFF5CB565FF58AF61FF53A95CFF4FA357FF46974DFF0000
+ 0000000000000000000000000000000000000000000067C673FF000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 00003B8842FF0000000000000000000000000000000063C06EFF0000000067C6
+ 73FF67C572FF64C170FF61BD6CFF5DB968FF5AB464FF56AE60FF50A659FF4DA2
+ 56FF479A50FF46974EFF419149FF00000000000000005FBB6AFF0000000067C6
+ 73FF0000000059B264FF57AE60FF54AB5DFF51A75AFF4DA256FF479950FF4697
+ 4EFF408E47FF408F47FF3B8842FF00000000000000005BB565FF0000000064C1
+ 6FFF5AB465FF57AF61FF54AB5EFF51A65AFF4CA156FF499B51FF43934AFF4090
+ 47FF3B8741FF3A8741FF35803BFF000000000000000056AE60FF0000000060BC
+ 6BFF58B062FF54AB5EFF51A659FF4CA055FF489A50FF43944BFF3D8B45FF3A87
+ 41FF357F3BFF347F3AFF307835FF00000000000000004EA358FF000000005CB6
+ 66FF52A85BFF4EA357FF4A9D52FF45974DFF419048FF3C8A43FF37833EFF357F
+ 3BFF2F7835FF2F7734FF2A712FFF00000000000000004C9F54FF0000000057AF
+ 61FF4FA559FF4B9E54FF46984EFF429148FF3D8A43FF38843EFF337D39FF2F77
+ 34FF29702FFF296F2EFF256A2AFF000000000000000046974EFF419149FF51A7
+ 5BFF499B51FF44944BFF3F8E46FF3B8741FF36813CFF317A37FF2D7532FF296F
+ 2EFF256929FF256929FF216425FF000000000000000000000000000000004C9F
+ 54FF47994FFF42924AFF3D8C45FF39853FFF347F3AFF307835FF2B7230FF276D
+ 2CFF246828FF206324FF1D5F21FF000000000000000000000000000000004697
+ 4EFF419149FF3C8A43FF38833EFF337D39FF2F7734FF2A712FFF266B2BFF2366
+ 27FF206223FF1D5E20FF1A5B1EFF000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 000000000000000000000000000000000000000000000000000000000000009A
+ FDFF0099FCFF000000000000000000000000000000000191F5FF018FF3FF0000
+ 000000000000000000000000000000000000000000000000000016A4FDFF43B6
+ FEFF4EBBFEFF0196F9FF00000000000000000191F5FF4BB8FDFF33A8F9FF028B
+ EFFF0000000000000000000000000000000000000000000000001EA5FDFF5BC0
+ FEFF63C4FFFF0F9BF8FF00000000000000001A9CF6FF54BCFFFF46B4FCFF0289
+ EDFF000000000000000000000000000000000000000000000000000000002DAA
+ FBFF61C4FFFF38AEFBFF0190F4FF018EF2FF37ABF9FF52BBFFFF249DF4FF0000
+ 0000000000000000000000000000000000000000000000000000000000000193
+ F7FF32ABFAFF5AC0FEFF018EF2FF38ACF9FF53BCFFFF2CA2F6FF0286EBFF0000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000018FF3FF56BDFEFF4EB9FEFF4EBAFFFF42B1FBFF0285EAFF000000000000
+ 00000000000000000000000000000196F9FF179FF9FF0193F6FF0191F5FF018F
+ F3FF018DF1FF45B4FCFF49B9FFFF47B7FFFF3FAFFBFF0283E8FF0381E6FF037E
+ E4FF037CE2FF1186E6FF0477DDFF0194F8FF50BAFDFF6BC7FFFF53BBFDFF4AB5
+ FBFF49B3FBFF52BDFFFF47B8FFFF43B5FFFF48B8FFFF43AFFAFF3BAAF8FF44B1
+ FBFF4BB7FFFF36A5F6FF0471D8FF0192F6FF0190F4FF018EF3FF028DF1FF028B
+ EFFF0289EDFF3EAEFAFF46B7FFFF42B5FFFF3CADFAFF037EE3FF037BE1FF0379
+ DFFF0475DCFF0470D7FF056BD2FF000000000000000000000000000000000000
+ 00000286EBFF50B9FEFF42B2FCFF46B7FFFF3CABF9FF037BE1FF000000000000
+ 0000000000000000000000000000000000000000000000000000000000000286
+ EBFF2EA1F4FF47B2FAFF037FE5FF32A2F3FF48B6FFFF2797EEFF0474DAFF0000
+ 00000000000000000000000000000000000000000000000000000285EAFF289D
+ F1FF55BDFFFF2598EFFF00000000037AE0FF2F9EF2FF42B4FFFF218CE6FF0000
+ 00000000000000000000000000000000000000000000000000002198F0FF52BB
+ FEFF4AB4FCFF037CE2FF00000000000000001885E2FF40B3FFFF3BAAF9FF1373
+ D5FF0000000000000000000000000000000000000000000000000380E6FF32A1
+ F3FF2A9AEFFF000000000000000000000000056CD3FF37A1F2FF2488E3FF065E
+ C6FF00000000000000000000000000000000000000000000000000000000037B
+ E1FF0379DFFF000000000000000000000000000000000662C9FF000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000001281827053222890732
+ 20B50B3C2ABC0B3C2BBE0A4029BC0C4729BC0D4228BE0C412BBC0B442BB6073B
+ 238D093B232C0000000000000000000000000A402D0408352363083925D30A3D
+ 25FA0C4029FF0B3F2AFF093A27FF0B3A26FF0D3F28FF0C4127FF0B4125FA0A3E
+ 25D40A3B27640836240400000000104231010C43302A0B402E9F0C412CEB0D42
+ 2AFE0D422AFF0B3D29FF0C3D28FF0C4027FF0B4226FF0B4227FF0B4127FE0B41
+ 28EB0E442CA110462E2A0831180106342301063220570B3F2BCF0B3F28F90833
+ 20FF093723FF0B3E28FF0D422BFF0D442CFF0B422DFF0B422DFF0C452BFF0C44
+ 28F90D462ED00E4B36580E4C3701073D2625093D26840A3E28E30B3E28FD0B3E
+ 28FF0A3B24FF0B3E27FF0D422AFF0D432AFF0C432CFF0C422BFF0C412AFF0C41
+ 2BFD0B442DE40A432C85083C26280D49324A0B3E28B50A3E26ED0B4226FD0D44
+ 26FF0D4328FF0E412BFF10432EFF0F442EFF0D422CFF0D432AFF0C4028FF0A3C
+ 25FD093924ED083623B50625185005321E74093924D30B4029F50D432DFD0D44
+ 2EFB0B422AF80A3C25F90A3823FC0B3B26FC0B412BF90D442BF80D442BFB0B3E
+ 26FD083520F6083925D5073A25790D442A5B0D442B8C083D2A89083B2A860635
+ 258B05311F8F06321D8D08351F88083B258808402A8D0A402B8F0B3F2B8B0B3D
+ 2786083724890B3A298C0B3B2A600E462C0B0D462D090A422F050B4332050632
+ 230A042C1C0C03291809042B1804063D2604063E2809083D290C093C2A0A0C3F
+ 2C05184B3605134432090D3D2C0B0E472D020B452E010B4533010B3F2F010630
+ 2102042B1C01032616010000000000000000053E2701083D2901083C29020C3E
+ 2D011A4F3B011A4D39010E3E2D02000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000000000000000000000FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
+ FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
+ FF00FFFFFF00FFFFFF00FFFFFF00000000000000000000000000000000000000
+ 00000000000000000000000000FF000000FF0000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 000000000000000000FF000000FF000000FF000000FF00000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000FF000000FF000000FF000000FF000000FF000000FF000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 00FF000000FF000000FF000000FF000000FF000000FF000000FF000000FF0000
+ 0000000000000000000000000000000000000000000000000000000000FF0000
+ 00FF000000FF000000FF000000FF000000FF000000FF000000FF000000FF0000
+ 00FF0000000000000000000000000000000000000000161616FF1D1D1DFF0F0F
+ 0FFF070707FF282828FF0B0B0BFF282828FF121212FF040404FF0B0B0BFF0F0F
+ 0FFF000000FF0000000000000000000000003B3B3BFF616161FF4F4F4FFF5151
+ 51FF282828FF494949FF4D4D4DFF777777FF565656FF323232FF4B4B4BFF4848
+ 48FF2E2E2EFF383838FF000000005A5A5AFF484848FF7B7B7BFF616161FF5151
+ 51FF282828FF6A6A6AFF494949FF777777FF565656FF565656FF616161FF1111
+ 11FF747474FF333333FF000000FF000000FF000000FF000000FF000000FF0000
+ 00FF000000FF000000FF000000FF000000FF000000FF000000FF000000FF0000
+ 00FF000000FF000000FF000000FF00000000000000FF000000FF000000FF0000
+ 00FF000000FF000000FF000000FF000000FF000000FF000000FF000000FF0000
+ 00FF000000FF000000FF000000000000000000000000000000FF000000FF0000
+ 00FF000000FF000000FF000000FF000000FF000000FF000000FF000000FF0000
+ 00FF000000FF0000000000000000000000000000000000000000000000FF0000
+ 00FF000000FF000000FF000000FF000000FF000000FF000000FF000000FF0000
+ 00FF000000000000000000000000000000000000000000000000000000000000
+ 00FF000000FF000000FF000000FF000000FF000000FF000000FF000000FF0000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 0000000000FF000000FF000000FF000000FF000000FF000000FF000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 000000000000000000FF000000FF000000FF000000FF00000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 00000000000000000000000000FF000000FF0000000000000000000000000000
+ 0000000000000000000000000000536876FF5C6A5DFF5F6D60FF5F6D60FF5F6D
+ 60FF5F6D60FF5F6D61FF5F6D61FF5F6D61FF5F6D61FF606D61FF606D62FF606D
+ 62FF606D63FF5E6A5FFF454E46FF5C6A5DFFFBFCFBFFFCFEFCFFF7FCF8FFF7FC
+ F8FFF7FCF8FFF8FCF8FFF7FCF9FFF8FCF8FFF8FCF8FFECF7EEFFEDF7EEFFEFF6
+ EDFFEEF4ECFFEBF4EBFF5E6A5FFF5F6D60FFF7FCF8FF9DF9F9FF6CB4EDFF6271
+ FEFF80E7E9FF8CF4F4FF52CDCDFFECC2A4FFDDAD8AFFEBBA97FFDDA780FFE2AB
+ 83FFDAA075FFD9EAD4FF616E64FF5F6D60FFF7FCF8FF8AEAEAFF72DDDEFF5665
+ F0FF569FDFFF73E8E8FF46C1C1FFBBBBA5FFD0A483FFDEB08EFFD19E7AFFD6A2
+ 7AFFCF9871FFD7EBD5FF626E64FF5F6D61FFF7FCF8FF9FF9F9FF85E9EAFF84D3
+ FAFF525AF0FF87F2F7FF60DAD7FF98D5CAFFE0B79CFFEDC7A9FFE0B394FFE6B8
+ 98FFDEAE8CFFD7ECD6FF636E64FF5F6D61FFF8FCF8FF90EAEAFF78DDDEFF81E9
+ EAFF4E6BE2FF639DEEFF5ED7D7FF5BCBC9FFD4B097FFE2BA9FFFA1ADA9FF58A5
+ D8FF85B1DBFF469DD0FF4E7C8CFF5F6D61FFF8FCF8FFA6F9F9FF8BE9EAFF99F8
+ FAFF78D3EBFF656BFFFF77DCEAFF70DFDEFFC1C5B5FFA8C8C8FF77BEE7FFB4D2
+ F0FFE5F3FFFFACD2EFFF4A89BEFF606D61FFF8FCF8FF9FF1F1FF81DDDFFF8AEA
+ EBFF75DEDEFF6591EEFF557EE2FF68DCDDFF5BBCC5FF80D5EDFFB2E3F9FF8BC0
+ E7FFAED3F6FFC4E0FCFF669DD0FF606D62FFF8FCF8FFAFFAFAFF94EBEBFFA2F9
+ FAFF8AEAEBFF95EDF3FF595FEBFF6BCFE5FF7CD4EEFFC4F6FDFF6CDDF6FF6DCA
+ EDFF63A3D7FF66A1D3FF617474FF606D63FFF8FCF8FFA4EBEDFF8DDFDFFF97EB
+ EBFF72CFB7FF74CA99FF4790BDFF79D3EEFFC7F7FDFF5FDCF5FF5BE2F7FF7AD6
+ F2FF4399DFFFB1D4D9FF646F66FF616E63FFF8FCF9FFBCFBFBFF9DE7DFFF93E1
+ BBFF77C997FF63BDAEFF77CBE7FFC7F7FDFF5EDCF5FF5AE1F7FF7BD4F1FF4395
+ DDFF589BC3FFD0E9DBFF646F66FF616E63FFF7FBF8FF9BDEC4FF73C393FF80CF
+ 9FFF53AD9CFF73B9D5FFC2F6FDFF63DFF7FF5DE2F8FF79D3F0FF4395DAFF6CB8
+ A4FF74C38FFFD7EFDAFF646F66FF616E64FFECF7EEFF96DBAFFF7FC99AFF63AD
+ A5FF7AB6D5FF90B7D1FF55C9E4FF5BDFF5FF78D0EDFF4696D9FF76C1A1FF87D0
+ A0FF80CA9AFFD6EEDAFF646F66FF626E64FFEEF8EFFFA4DBBCFF8CCAA6FF4389
+ AAFFE0F2FFFF549AD8FF1A7ABEFF4998C5FF3B86BFFF6074E7FF81C5A3FF8CD0
+ A6FF85CAA0FFD2E9D7FF646F67FF5F6A60FFEBF5ECFFD4EDD7FFD4EED7FF2E67
+ 84FF94C7F9FF91C9F9FF4185C9FF256BACFFB7D9D4FFD4E2ECFFCFE5D6FFD5ED
+ D9FFD8EFDCFFD5EDD9FF616C63FF454D47FF5F6A61FF636F64FF646F64FF143F
+ 56FF295F86FF4988BCFF4A86A7FF5D7070FF646F66FF646F66FF646F67FF646F
+ 67FF647067FF616C63FF474E48FFFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
+ FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
+ FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
+ FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
+ FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF0066C472FF64C270FF62BF
+ 6EFF60BC6BFF5DB868FF5BB565FF58B162FD55AC5FEA52A85BB74FA358704B9F
+ 541DFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF0064C170FFA6DBB0FFA6DA
+ AFFFA3D9ADFFA2D8ABFF9FD7A8FF9CD5A5FF94D09DFF83C58CFF6CB474FF4799
+ 50B044944C39FFFFFF00FFFFFF00FFFFFF00FFFFFF0062BE6DFFA5DAAEFFA2D8
+ ACFFA1D8AAFF9ED6A7FF9CD5A5FF99D4A2FF97D29FFF8CCD95FF91CF99FF73B8
+ 7BFF408F47B03C8A431DFFFFFF00FFFFFF00FFFFFF005FBA6AFF5CB667FF59B3
+ 64FF56AE60FF53AA5DFF50A659FF4DA156FF68B170FF88C890FF8DCC95FF8BCB
+ 92FF5DA564FF38853F70FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
+ FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF0046974E8F42924AE281C388FF7DC4
+ 85FF6EB375FF357F3BB7FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
+ FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF003E8D458F64AB6BFF7FC4
+ 86FF79BE81FF317A36EAFFFFFF00FFFFFF00FFFFFF00FFFFFF0052A85B034FA3
+ 587BFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF003A87418F61A867FF7BC2
+ 82FF76BC7CFF2D7532EAFFFFFF00FFFFFF00FFFFFF00FFFFFF004EA3579F4B9E
+ 53D2FFFFFF00FFFFFF00FFFFFF00FFFFFF003A86408F36813CE275BB7BFF70BD
+ 77FF63AB69FF2A702EB7FFFFFF00FFFFFF00FFFFFF004DA2569367B16FFF64AD
+ 6BFF43944BFF408F47FF3C8A43FF398540FF549D5AFF74BA7AFF79C17FFF77BF
+ 7DFF4A914FFF266B2B70FFFFFF00FFFFFF004DA1568A66B06EFF8ACA92FF89CA
+ 90FF86C88DFF83C68AFF80C587FF7EC384FF7BC281FF6DBB74FF76BE7CFF59A0
+ 5DFF266B2AB02367271DFFFFFF00FFFFFF00499C518462AC6AFF85C88DFF85C7
+ 8BFF82C688FF7FC486FF7CC282FF79C180FF71B978FF5FA865FF49914EFF256A
+ 2AB023662739FFFFFF00FFFFFF00FFFFFF00FFFFFF00429149905AA462FF58A1
+ 5EFF37833EFF347E3AFF317A36FF2E7533FF2B712FEA286D2CB7256929702266
+ 261DFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF003A87419C3782
+ 3DD2FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
+ FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF0036813C03337D
+ 3978FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
+ FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00B0E2
+ F55CA7DCF5B59DD9F5E291D1F1F782CBF0F876C4EFED6DBFEDD177C3EE80FFFF
+ FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00AFE0F619ADDEF6B7B7E4
+ F8FFC7ECFBFFD7F3FCFFE1F7FDFFE2F8FEFFD8F0FCFFB6DFF8FF6BBBEDFF56AF
+ E8DE77BEEC2CFFFFFF00FFFFFF00FFFFFF00B2E1F50BA2DBF4CAC3EBFAFFE2F9
+ FDFFE0F9FDFFD5F7FDFFCFF6FDFFC9F4FCFFC7F4FCFFD6F9FDFFEBFAFEFF90CA
+ F2FF43A2E4ED78BEE917FFFFFF00FFFFFF0098D6F489B4E3F8FFE5FAFEFFDBF8
+ FDFFE4FAFEFFF0FCFEFFF9FEFFFFF9FEFFFFEFFCFEFFD2F6FDFFB4F1FBFFEDFD
+ FFFF6BB3EAFF58A9E4B6FFFFFF00FFFFFF0088CDF1E4D2EFFBFFDBF9FEFFDFF9
+ FDFFECFBFEFFEEFCFEFFEFFCFEFFEFFCFEFFEBFBFEFFE0F9FEFFB8F1FBFFA8F1
+ FBFFCBE5F8FF3892DCF7FFFFFF00FFFFFF007BC5EEF9DFF6FDFFC8F5FCFFCDF6
+ FCFFD6F7FDFFD3F4FCFFCFF2FCFFCAF1FBFFC4F0FCFFBAF2FBFF96EAF8FF72E5
+ F7FFE2F4FDFF3189D8FEFFFFFF00FFFFFF006FBEECE3C9E9F9FFD4F9FDFF7CE3
+ F7FF86E5F8FF60B1EFFF68B5EFFF63B4EFFF4CA6ECFF82E4F7FF59DCF5FF8AEB
+ FAFFCBE2F7FF338BD9F7FFFFFF00FFFFFF0078C0EC888BC8EFFFECFCFEFF77E1
+ F7FF2F99EAFF75E1F6FF74E1F6FF68DEF5FF73E1F6FF0986E6FF46D5F3FFDCFE
+ FEFF6FAAE5FF4C99DEBFFFFFFF00FFFFFF0080C6F00468B5E9D8A5D4F3FFDCFA
+ FEFF38A1EBFF74E1F6FF6AE4F6FF5DE2F5FF72E0F6FF1691E8FFC0F5FDFFACCE
+ F1FF2780D6F86FAEE425FFFFFF00FFFFFF00FFFFFF0078BDEB2F5CACE7EBA6D3
+ F3FF65AEF0FF74E1F6FF73E1F6FF72E0F6FF71E0F6FF4CA3ECFF9CC3EFFF297F
+ D6FB65A8E25AFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF0075B9EA3461A7
+ DEE7469DE6FF4BBEF7FF47E6FDFF41E5FDFF51C3FBFF167CDEFF3382D1F266AA
+ E346FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF0085A7
+ BF4B638195FA7A95A3FF3A8A98FF357F8CFF606E76FF2D4357FE7FA2BE40FFFF
+ FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
+ FF0068777DE2A6A5A2FFA8A2A2FF9D9998FF948F8BFF434B53EBFFFFFF00FFFF
+ FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
+ FF005F6E77C6BCBCBBFFEBEAEAFFCDCCCCFFA3A19FFF3F4C55DBFFFFFF00FFFF
+ FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
+ FF0088A7BB5D485055F5444545FE3F4141FE3F474AF67D9CB16AFFFFFF00FFFF
+ FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
+ FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
+ FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
+ FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
+ FF006D9CD4896A9AD2FB6697CFEEFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
+ FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00709ED6DB6D9C
+ D4FF85B1DAFF5A91B9FF6093CBEAFFFFFF00FFFFFF00808080FF7E7E7EFF7C7C
+ 7CFF7A7A7AFF777777FF757575FF727272FF719ED4FF6F9ED6FF87B2DCFFABD3
+ E8FFA9D0E6FF5890B8FF598EC6EAFFFFFF00FFFFFF007D7D7DFF999999FF9999
+ 99FF9A9A9AFF9A9A9AFF9B9B9BFF9B9B9BFF6F9DD3FFAAD1E7FFABD1E7FF98C7
+ E1FF91C2DEFF568FB7FF5289C1EAFFFFFF00FFFFFF007A7A7AFF999999FF5291
+ 59FF999A99FF9B9B9BFF9C9C9CFF9C9C9CFF6C9AD0FFA7CEE5FF8FC1DFFF89BD
+ DCFF8BBDDCFF538DB6FF4B84BCEAFFFFFF00FFFFFF00777777FF9A9A9AFF3D8A
+ 45FF498A4FFF9C9C9CFF9D9D9DFF9D9D9DFF6696CCFFA2CBE3FF89BDDCFF83B9
+ DAFF84B9DAFF518BB5FF437EB6EA44944DFF42914BFF3F8D48FF3D8945FF5DA4
+ 65FF5AA061FF45834BFF9E9E9EFF9E9E9EFF6092C9FF9EC7E2FF83B8DAFF7DB4
+ D7FF7EB3D7FF4F89B4FF3B79B1EA41904AFF94D29FFF91D09AFF8DCD96FF89CB
+ 92FF84C88DFF519858FF417C46FF9F9F9FFF5A8EC4FF98C3E0FF7CB3D7FF74AF
+ D6FF5EC4EDFF4B88B3FF3473ABEA3E8B46FF8FCE99FF7DC687FF78C381FF73C0
+ 7CFF74C07CFF79C281FF49904FFF547F57FF5489BFFF94BFDDFF75ADD4FF63B8
+ E1FF4BD4FFFF428BB8FF2C6EA6EA3B8742FF89CB92FF84C88DFF80C688FF7BC3
+ 83FF77C17FFF478F4DFF3B743FFFA1A1A1FF4C84BAFF8DBBDBFF6EA8D1FF66A6
+ D1FF5FB4DFFF4785B1FF2569A1EA37823EFF347E3BFF317937FF2E7534FF4991
+ 50FF468F4CFF39733DFFA1A1A1FFA2A2A2FF457EB4FF88B7D9FF67A3CFFF619E
+ CCFF639FCCFF4583B1FF1F649CEAFFFFFF00FFFFFF00606060FFA0A0A0FF3D76
+ 41FF367139FFA2A2A2FFA2A2A2FFA3A3A3FF3D79B0FF82B3D7FF629FCCFF5A9A
+ C9FF5E9BCAFF4381AFFF196098EAFFFFFF00FFFFFF005C5C5CFFA1A1A1FF3C73
+ 40FFA0A1A1FFA3A3A3FFA3A3A3FFA4A4A4FF3674AAFF7DAFD4FF5B9AC9FF5495
+ C7FF5896C8FF4180AEFF135C94EAFFFFFF00FFFFFF00585858FFA2A2A2FFA2A2
+ A2FFA3A3A3FFA4A4A4FFA4A4A4FFA5A5A5FF2F6FA5FF78ABD2FF78ABD3FF73A7
+ D1FF69A0CDFF407FAEFF0F5991EA999999FF717171FF545454FF515151FF4F4F
+ 4FFF4C4C4CFF4A4A4AFF474747FF454545FF25679DFF3274A8FF3D7CAFFF4784
+ B5FF4E8ABAFF3E7EADFF0C578FEAFFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
+ FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF001D639B1619609839145D9562105A
+ 92880D5890A4135C92FC0C578FED
+ }
+ end
+ object pmTileList: TPopupMenu
+ left = 184
+ top = 128
+ object mnuAddToRandom: TMenuItem
+ Caption = 'Add to random pool'
+ OnClick = btnAddRandomClick
+ end
+ end
+ object ApplicationProperties1: TApplicationProperties
+ OnIdle = ApplicationProperties1Idle
+ OnShowHint = ApplicationProperties1ShowHint
+ left = 295
+ top = 33
+ end
+ object pmTools: TPopupMenu
+ Images = ImageList1
+ left = 328
+ top = 33
+ object mnuSelect: TMenuItem
+ Action = acSelect
+ Bitmap.Data = {
+ 36040000424D3604000000000000360000002800000010000000100000000100
+ 2000000000000004000064000000640000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000007C7C
+ 7CFF787878FF757575FF000000000000FF00FF00000000000000000000000000
+ 000000000000000000000000000000000000000000000000000000000000AAAA
+ AAFFDBDBDBFF797979FF000000000000FF00FF00000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000888888FFDBDB
+ DBFFB7B7B7FF7D7D7DFF000000000000FF00FF00000000000000000000000000
+ 000000000000000000009C9C9CFF000000000000000000000000ADADADFFF2F2
+ F2FF848484FF00000000000000000000FF00FF00000000000000000000000000
+ 00000000000000000000A0A0A0FF9C9C9CFF00000000949494FFD9D9D9FFC1C1
+ C1FF898989FF00000000000000000000FF00FF00000000000000000000000000
+ 00000000000000000000A4A4A4FFD7D7D7FF9D9D9DFFD0D0D0FFEEEEEEFF9191
+ 91FF0000000000000000000000000000FF00FF00000000000000000000000000
+ 00000000000000000000A9A9A9FFF2F2F2FFE5E5E5FFE2E2E2FFE3E3E3FF9595
+ 95FF919191FF8D8D8DFF898989FF868686FFFF00000000000000000000000000
+ 00000000000000000000ADADADFFEEEEEEFFE1E1E1FFDFDFDFFFE0E0E0FFE7E7
+ E7FFE4E4E4FFBBBBBBFF8E8E8EFF0000FF00FF00000000000000000000000000
+ 00000000000000000000B1B1B1FFF0F0F0FFE4E4E4FFE2E2E2FFE2E2E2FFE7E7
+ E7FFC1C1C1FF969696FF000000000000FF00FF00000000000000000000000000
+ 00000000000000000000B5B5B5FFF2F2F2FFE8E8E8FFE7E7E7FFEAEAEAFFC6C6
+ C6FF9E9E9EFF00000000000000000000FF00FF00000000000000000000000000
+ 00000000000000000000B9B9B9FFF4F4F4FFECECECFFEDEDEDFFCBCBCBFFA7A7
+ A7FF0000000000000000000000000000FF00FF00000000000000000000000000
+ 00000000000000000000BDBDBDFFF7F7F7FFEFEFEFFFD0D0D0FFAFAFAFFF0000
+ 00000000000000000000000000000000FF00FF00000000000000000000000000
+ 00000000000000000000C1C1C1FFF7F7F7FFD5D5D5FFB6B6B6FF000000000000
+ 00000000000000000000000000000000FF00FF00000000000000FFFFFF00FFFF
+ FF00FFFFFF00FFFFFF00C4C4C4FFD9D9D9FFBEBEBEFFFFFFFF00FFFFFF00FFFF
+ FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FF0000000000000008000000DB87
+ 4100DB874100DB874100C8C8C8FFC5C5C5FF0000000000000000000000000000
+ 000000000000000000000000000000000000EFFFFF00FFFFFF00F0A3E30008E9
+ 120000000000000000000851A500F52E74000000000040000000F8040600AC04
+ 0600000000000000000000000000C00406000000000000000000
+ }
+ GroupIndex = 1
+ RadioItem = True
+ OnClick = acSelectExecute
+ end
+ object mnuDraw: TMenuItem
+ Action = acDraw
+ Bitmap.Data = {
+ 36040000424D3604000000000000360000002800000010000000100000000100
+ 2000000000000004000064000000640000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 00000000000000000000000000000000FF00FF00000000000000000000001340
+ 58FF15425EFF25699CFF2C76B4FF3B8BBAFF0000000000000000000000000000
+ 00000000000000000000000000000000FF00FF00000000000000000000001242
+ 59FF5D9CD4FFA6CFF5FFA9CFECFF488BC1FF2C76B4FF00000000000000000000
+ 00000000000000000000000000000000FF00FF00000000000000000000001E6D
+ 93FFCBE3F9FF61AAECFF4098E8FF1567C2FF1660AAFF2C76B4FF000000000000
+ 00000000000000000000000000000000FF00FF00000000000000000000001E6D
+ 93FFC8E1F2FFD1E7FAFF347DB5FF3199C3FF6DC4DCFF4A9CCFFF3483C7FF0000
+ 00000000000000000000000000000000FF00FF00000000000000000000000000
+ 00002689B9FFB0CBE1FF67A9C8FF60DCF5FF44D6F4FF8EEEFAFF5DB4E6FF3B8F
+ D9FF0000000000000000000000000000FF00FF00000000000000000000000000
+ 0000000000002689B9FFBEE6F2FFB3F4FCFF60DCF5FF44D6F4FF8EEEFAFF5DB4
+ E6FF3B8FD9FF00000000000000000000FF00FF00000000000000000000000000
+ 000000000000000000002790BFFFC3EDF8FFB3F4FCFF60DCF5FF44D6F4FF8EEE
+ FAFF5DB4E6FF3B8FD9FF000000000000FF00FF00000000000000000000000000
+ 00000000000000000000000000002FBAE4FFC3EDF8FFB3F4FCFF60DCF5FF44D6
+ F4FF8EEEFAFF5DB4E6FF3B8FD9FF0000FF00FF00000000000000000000000000
+ 0000000000000000000000000000000000002FBAE4FFC3EDF8FFB3F4FCFF60DC
+ F5FF44D6F4FF8EEEFAFF5DB4E6FF3B8FD9FFFF00000000000000000000000000
+ 000000000000000000000000000000000000000000002FBAE4FFC3EDF8FFB3F4
+ FCFF68D9F5FF6FCFF3FF599DD0FF73ABDDFF4F91C9FF00000000000000000000
+ 00000000000000000000000000000000000000000000000000002FBAE4FFC3ED
+ F8FFA8E2F8FF6CAEDDFFA5CFF4FFA5CFF4FFBDDBF7FF5393CBFF000000000000
+ 0000000000000000000000000000000000000000000000000000000000002FBA
+ E4FFA7D4F4FFC5E1F8FFCCE3F9FFCCE3F9FFBDDBF7FF4F90C9FFFFFFFF00FFFF
+ FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF
+ FF0050A8D9FF6AA5D8FFC9E1F7FFCBE3F8FF4295CAFF3182C2FF08000000FF33
+ 3300FF333300FF333300FF333300FFFFFF000000000000000000000000000000
+ 0000000000004FAADBFF5093CAFF4E90C8FF2F9DD2FFFFFFFF00F0A3E3007804
+ 060000000000000000000851A5001E9B7000000000004000000028E62400DCE5
+ 2400000000000000000000000000F0E524000000000000000000
+ }
+ GroupIndex = 1
+ RadioItem = True
+ OnClick = acDrawExecute
+ end
+ object mnuMove: TMenuItem
+ Action = acMove
+ Bitmap.Data = {
+ 36040000424D3604000000000000360000002800000010000000100000000100
+ 200000000000000400006400000064000000000000000000000053A85AFF51A6
+ 58FF4FA356FF4EA154FF4C9F52FFA8AAAC00A5A7AA00A3A6A800A7A9AC00AEAF
+ B100ABADB000429046FF418E45FF408D43FF3F8B42FF3E8A41FF54AB5CFF83BF
+ 89FF7DBB83FF54A65BFFB2B4B500B0B2B300B7B8BA00B1B3B500ACAFB100AAAC
+ AF00A8AAAC00A5A7AA00429046FF6DAD71FF6EAE73FF3F8C42FF56AD5FFF83C0
+ 8AFF73B77AFF6CB473FF50A457FFA9ACAE00A7AAAB00ACAFB100B3B5B600B2B4
+ B500B0B2B300459449FF5AA05EFF5EA664FF6CAD70FF408D44FF58B061FF57AE
+ 5FFF6CB673FF84C08AFF6EB574FF50A457FFBEBFC100B2B5B600AFB2B300ADAF
+ B10048994DFF5DA561FF75B379FF5FA463FF47944CFF418F45FF5AB363FFB9BC
+ BD0057AE5FFF6CB673FF6AB471FF52A759FFB3B5B700BABDBE00B8BABC00B6B8
+ B9004A9B4FFF5FA764FF62A867FF45954AFFB2B4B600439147FFB8BABC00C2C4
+ C500BFC1C20057AE5FFF55AC5DFFC9CBCC00B9BCBD00B5B8BA00B2B4B600AFB1
+ B300ABAEB0004A9C50FF48994EFFB8BABC00B6B8B900BEC0C200C0C1C300BABC
+ BE00B7B9BB00B3B5B700AFB2B400B8BABC00C2C4C500BFC1C200BDBEBF00C4C5
+ C600CED0D100C0C1C300BABCBE00B7B9BB00B3B5B700AFB2B400CACBCC00C7C9
+ CB00C4C6C700CBCCCD00CED0D100C0C1C300BABCBE00B7B9BB00B3B5B700AFB2
+ B400B8BABC00C2C4C500BFC1C200BDBEBF00C4C5C600CED0D100C1C3C500BEC0
+ C200B9BBBD00B4B7B900BFC1C300CACBCC00C7C9CB00C4C6C700CBCCCD00D5D5
+ D600C7C8CA00C1C3C500BEC0C200B9BBBD00B4B7B900BFC1C300CCCFD000CBCD
+ CD00D0D1D200D5D5D600C7C8CA00C1C3C500BEC0C200B9BBBD00B4B7B900BFC1
+ C300CACBCC00C7C9CB00C4C6C700CBCCCD00D5D5D600C7C8CA00C2C4C500BEC0
+ C100B9BBBC0060BB6AFF5EB968FFCCCFD000CBCDCD00D0D1D200DADBDC00CCCF
+ D000C7CACB0053A95BFF52A759FFB9BBBC00C5C7C900D0D1D10065C370FFD5D6
+ D70063BF6DFF80C989FF79C482FF5FB969FFBEC0C100B9BBBC00C5C7C900D0D1
+ D10057AE5FFF6EB875FF6CB573FF52A759FFCCCFD0004EA255FF66C472FF6BC5
+ 75FF83CC8CFF9BD3A4FF7BC784FF60BC6BFFD5D6D700E1E1E200D4D5D600CDCF
+ D10059B161FF75BD7DFF8CC793FF6DB673FF52A759FF50A557FF67C673FF9DD6
+ A5FF92D19BFF7ECA87FF63C06EFFC2C5C700BEC0C100CBCCCE00D8D9D900D4D7
+ D800D1D4D40059B162FF76BD7EFF7EC086FF8AC590FF52A85AFF68C774FFA1D8
+ A9FF9ED6A7FF65C371FFD8DADA00D9DBDC00E5E6E700D9DBDC00D4D5D700CDD0
+ D100C7C9CB00C2C5C6005FB467FF8DC894FF8EC995FF54AA5CFF68C774FF68C7
+ 74FF67C673FF66C572FF65C371FFC2C5C600D0D2D300DEE0E000DADCDD00D8DA
+ DA00D9DBDC005CB666FF5BB464FF59B262FF58AF60FF56AD5EFF
+ }
+ GroupIndex = 1
+ RadioItem = True
+ OnClick = acMoveExecute
+ end
+ object mnuElevate: TMenuItem
+ Action = acElevate
+ Bitmap.Data = {
+ 36040000424D3604000000000000360000002800000010000000100000000100
+ 20000000000000040000640000006400000000000000000000000000BD0000A5
+ 9C00001A420000B5A00013C0F80028FC0000B3A50A00C9800000FC000000F800
+ 0000EC5506003A9F0000B3A50A00C9800000FC000000F80016004BDB0000FC00
+ 0000F80027000000280000000000FE1E0000286E2DFF256929FF216425FF1E60
+ 22FF0028FC000028FC000000280000002800000028000028FC00000028000000
+ 28000028FC000027F3000EFC0E00000000002D7533FF74BD7AFF72BD78FF2265
+ 26FF4BDB0000FC000000F80000006500000000000000FE1E0000130000000000
+ 0000FE0000002CF30000FC000000F8002800337D39FF79C07EFF76BF7CFF266B
+ 2BFFFC0000000FFE1F0000004C000028FC000028FC00000028000028FC000028
+ FC000000280000002800000028000028FC0039853FFF7DC282FF7AC180FF2B72
+ 30FF002CF80028FC0000FE0000002CF30000FC000000F80011004CDB0000FF10
+ 0000F20023000000000000000000FE1E00003F8D46FF81C587FF7EC385FF317A
+ 36FF15000000FE1E00004CDB0000FC00000026FD000000002B00FC00000028FC
+ 0000000028000028FC000028FF000000280045954CFF85C78CFF82C689FF3682
+ 3DFF0BFB1D000039DF000EFE1C000049F80028FC0000FE1E000014C2F80028FC
+ 0000B2A80A00CB7F0000FF810300C60010004A9E53FF8ACA91FF87C98EFF3C8A
+ 43FFFF810300C60028000000280095060800B2A80A00CB7F000065E2BA0013AC
+ F10090040000FC00000028FC00000000280050A659FF8ECC95FF8BCB93FF4292
+ 4AFF830380000028FC000487C10000A2AC000CB3890000B4A300000B9A00F09D
+ 08000016B600D86AF80028FC000013ACF10056AD5FFF93CF9AFF90CE98FF489A
+ 50FF0000000013ACF10090040000FC6AEA003C00E600F4F45900000000000000
+ 2800000000000000060000000000000000005BB465FF96D29FFF94D09CFF5DAC
+ 65FFB728FC00E2BA280068E9E1006EE9E4000028FC000031F100000000000028
+ FC000283CF000000000065C371FF62BF6EFF79C683FF9AD4A3FF98D3A1FF7DC3
+ 86FF4FA458FF4A9E53FFED5706003E9F00000000000000000000CA5A00000000
+ 000000000000000000000000280066C472FF7CCA87FF9ED6A7FF9CD4A5FF73C0
+ 7DFF55AC5EFF000028000026FC00000000000006000000000000000000000000
+ 000000000000000000000028FF00F5CE350066C572FF7ECA88FF7BC885FF5DB8
+ 68FF00000000000000000000000000000000000000003CBBF000000000000000
+ 0000000000000000000000000000000000000000000067C673FF65C270FF0000
+ 00000000000000000000FC00000028FC000000002800000EFC00E8A3E300802E
+ 6400000000000000000000000000000000000000000000000000000000000000
+ 000000000000000000000000000026F000000000000000000000
+ }
+ GroupIndex = 1
+ RadioItem = True
+ OnClick = acElevateExecute
+ end
+ object mnuDelete: TMenuItem
+ Action = acDelete
+ Bitmap.Data = {
+ 36040000424D3604000000000000360000002800000010000000100000000100
+ 20000000000000040000640000006400000000000000000000000FFE1F000000
+ 4C000028FC000028FC000000280000002800000028000009F100A06131FFB676
+ 3FFFA46534FF0DFD1E0000000000FE1E00004BDB0000FF0600002CF30000FC00
+ 0000F8002800000028000028FC000011FF00000000009F5E2FFFE7B263FFBF92
+ 4FFFDDAB62FFA26232FF0028FC000000240000000000F30028001E000000DB00
+ 280026FD0000C79751FFD8A65AFFA66C36FF00002800A86835FFD1A057FF0000
+ 9D008E6A36FFB4753FFF0000000024FE000000000000FE00000000000000FE1E
+ 0000B58244FFD6A45AFFAE8241FFECB666FFA76E36FFAC6C37FFC49551FF0000
+ 0E001E000000B77840FF100031000028FC000028FF0000000E000028FF000608
+ 0000BE8A4AFFA87E41FF28FC0000966E32FFE7B066FFCAA274FFE5B167FF945E
+ 2DFFB88D4DFFAF703BFF0C00D500000EFD00000000000EFD1F000F04380000AD
+ AD009C6A32FFD6A55EFFCB7F0000FC000000E4AD60FFDCBD9BFFEFCDA5FFEFB7
+ 67FFD8A65DFF00000000A80A16007F002800810384000028FC006AEAE30000E6
+ FF00F459FC00B17E42FFDCAA60FFD09E54FFEAB365FFD8BA99FFF8EBE1FFAE89
+ 57FF06082800850380008303800000000100592AFA000000AD00AF80B0000000
+ 1000EFF09F000010A4009D6932FFB17E42FF9E682CFFBC9767FFF0E0D0FFB691
+ 5FFF00E6FF00F431CD000000000000000000ACF1EC0004002800000000000000
+ 0000000000000028FC00000000000006000000000000B68F59FFF5E9DDFFE2CD
+ B4FFB99461FFB728FC00E2BA280068E9E1006EE9E40000000000000000000000
+ 0000F6DC510000000000000000000000000000000000B28A54FFF1E2D3FFCFB3
+ 8EFFF5E9DCFF000000000028FC0000004200570602009F000000BBF0F4005A00
+ 00000000000000000000000000000028FC0000000000AF8750FFEDDECEFF0000
+ 2800CEB38FFFE7D6C3FF0026FC00000000000006000000000000000000000000
+ 00000000000000000000C3EC0600000000000000000000000000E6D4C0FF0000
+ 000000000000D3B999FFD3B897FF000000000028FC0000000000000000000000
+ 0000000000000000000000000000000000000000000000000000DEC8AEFF0000
+ 00000000000000002800D1B693FFBB9767FF000EFC000000000000007800F407
+ 0000000000000000000000000000000000000000000000000000D5BC9DFF0000
+ 0000000000000000000000000000AE854CFF0000000000000000080000000000
+ 0000000000000000000000000000FFFFFF000000000000000000CBAE87FF0000
+ 0000000000000000000000000000000000000000000000000000E8A3E3000022
+ 780000000000000000000851A500E3AF75000000000078000000A77B3EFFA4F0
+ 9D00000000000000000000000000B8F09D000000000000000000
+ }
+ GroupIndex = 1
+ RadioItem = True
+ OnClick = acDeleteExecute
+ end
+ object mnuSetHue: TMenuItem
+ Action = acHue
+ Bitmap.Data = {
+ 36040000424D3604000000000000360000002800000010000000100000000100
+ 2000000000000004000064000000640000000000000000000000000000000000
+ 000000000000000000000000000000000000FF00000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000000000000000
+ 000000000000000000000000000000000000000000001D65A0FF1A639EFF1761
+ 9BFF000000000000000000000000000000000000000000000000000000000000
+ 000000000000000000000000000000000000256BA6FF87AEE1FF7FA9DCFF6093
+ C9FF3173ACFF15609AFF0000000000000000FF00000000000000000000000000
+ 00000000000000000000000000002D70ADFF6E9ED1FF9ABDEBFF72A1E3FF97BA
+ EAFF95B9EAFF6194CAFF16609AFF000000000000000000000000000000000000
+ 00000000000000000000000000003274B1FF9EC0ECFF6A9DE2FF5C94DFFF5992
+ DFFF6095E0FF96B9EAFF87AEE1FF4A84BCFF145F99FF00000000000000000000
+ 0000427FBDFF3F7DBAFF3B7AB8FF77A5D7FFA2C3EDFFA0C1EDFF9EC0EDFF75A4
+ E4FF5B93DFFF5991DEFF7CA8E6FF93B7E8FF4480B8FF000000004F88C7FF6598
+ CFFF7CA9D9FF8EB5E2FFA4C5EDFFA8C7EEFF6598CDFF3576B3FF6094C9FFA0C1
+ EDFF7997A4FF9F9749FF7D9592FF8EB4E9FF7AA6D8FF19629DFF538BCBFFAFCD
+ F0FFB1CFF0FF99C0ECFF7FAFE7FFABCAEFFF3E7CB9FF000000003677B4FFA3C4
+ EDFFA99832FFC5B65BFFAD9827FF5C94DFFF99BCEBFF1D65A0FF588ECEFFA9C9
+ EDFF85A8EDFF596BEDFF6B8FE9FFAECDF0FF6E9ED2FF3F7DBAFF689ACEFFA6C6
+ EEFF969B6AFFAE9827FF9E984EFF679CE2FF99BCEAFF2268A3FF5C91D1FF93BA
+ E5FF6F75F6FF8285F5FF4141F0FF91BCEBFFAFCDF0FFADCCF0FFABCAF0FF86B3
+ E9FF5FAAC2FF45B48EFF57A9B7FF71A2E4FF98BBE8FF266BA7FF000000005D92
+ D2FF93A5F5FF5A5BF6FF5287F4FF3CA7FBFF5DACF2FF7FB0E7FF7CAEE7FF79AB
+ E6FF40B781FF61C898FF3CB87BFF7EADE7FF90B6E3FF2B6FABFF000000006194
+ D5FF87B0E1FFBAD7F3FF33A7FEFF6DC0FFFF2CA4FFFF67BFF0FF3BCEFBFF5BBF
+ F1FF53B4A1FF3CB87AFF48B491FFA8C8EEFF78A6D6FF3072AFFFFFFFFF00FFFF
+ FF006295D6FF86AFE1FF5BB3F9FF2CA4FFFF41AAFBFF31D3FEFF6DE2FFFF2CD5
+ FFFF80B1E8FF7DAEE7FFAACAEFFFA6C6EDFF3878B6FF00000000FFFFFF00FFFF
+ FF00FFFFFF00FFFFFF006094D5FF8FB7E3FFBAD7F3FF5ED5FBFF2BD5FFFF42D1
+ FBFFB4D2F2FFB2D0F1FF93B9E2FF6396CCFF3E7CB9FFFFFFFF0008000000888A
+ 8C00888A8C00888A8C00888A8C006194D5FF77A4DCFF92B9E4FFA9CAECFFA6C7
+ ECFF8EB6E2FF699BD2FF4A84C3FF00000000EFFFFF00FFFFFF00E8A3E30070F0
+ 9D0000000000000000000851A500D7AD7500000000005F93D4FF5C91D1FF598F
+ CFFF558DCCFF000000000000000020B45F000000000000000000
+ }
+ GroupIndex = 1
+ RadioItem = True
+ OnClick = acHueExecute
+ end
+ object mnuSeparator3: TMenuItem
+ Caption = '-'
+ end
+ object mnuBoundaries: TMenuItem
+ Action = acBoundaries
+ Bitmap.Data = {
+ 36040000424D3604000000000000360000002800000010000000100000000100
+ 200000000000000400006400000064000000000000000000000000B2AD000022
+ CC000028FC000028FC00000028000000280000002800005AEE00181818008900
+ AC000E04380000ACAA0004380000B3A50A00C9800000F25807004BDB00003232
+ 32FF2D2D2DFF282828FF0027FC000000CD000000000000000E001E000000DB00
+ 2800000028000027FC00040404FF010101FF000000FFDB002800000000003A3A
+ 3AFFB7B7B7FF313030FFD89066FFD88E64FFD68C62FFD58961FFD5895FFFD586
+ 5DFFD4855BFFD4855AFF090909FFA6A6A6FF030303FFFE1E0000000000004242
+ 42FF3D3D3DFF534B46FFE3AD8DFFE2AB8BFFE1AA8AFFE1A888FFE0A787FFDFA5
+ 85FFDFA484FFDEA383FF42332BFF0A0A0AFF070707FF000024000028FF000000
+ 0E00DD9B73FFE4B192FFE4AF91FFE3AE8FFFE3AC8DFFE1AB8BFFE1A989FFE1A8
+ 88FFE0A786FFDFA585FFDFA384FFD4865DFF0000000024FE0000000000000EFD
+ 1F00DE9F77FFE5B495FFE4B393FFE4B192FFE3AF90FFE3AE8EFFE2AC8DFFE1AA
+ 8BFFE1A989FFE0A787FFDFA686FFD5895FFF100031000028FC00810384000028
+ FC00E1A27BFFE6B798FFE6B596FFE5B494FFE4B292FFE4B191FFE3AF8FFFE3AD
+ 8DFFE2AC8CFFE1AA8AFFE1A989FFD68C62FF0C00D500000EFD00592AFA000000
+ AD00E1A67FFFE8BA9BFFE7B899FFE6B697FFE6B596FFE5B394FFE4B192FFE4AF
+ 91FFE3AE8FFFE3AD8DFFE2AB8BFFD88E66FFA80A16007F002800ACF1EC000400
+ 2800E3AA81FFE9BC9EFFE8BB9CFFE8B99AFFE7B899FFE6B697FFE6B495FFE4B3
+ 94FFE4B192FFE3AF90FFE3AE8FFFD9926AFF83038000000001006EE9E4000000
+ 0000E3AC85FFEABFA0FFEABE9FFFE8BC9DFFE8BA9CFFE8B99AFFE6B798FFE6B6
+ 96FFE5B494FFE4B393FFE4B191FFDA966CFF0000000000000000570602009F00
+ 0000E5AF86FFEBC1A2FFEAC0A2FFEABEA0FFE9BD9EFFE8BC9DFFE8BA9BFFE7B8
+ 99FFE6B698FFE6B596FFE5B394FFDC9A70FFE2BA280068E9E100000600000000
+ 0000E5B289FFEBC3A5FFEBC2A3FFEBC0A2FFEABFA1FFEABEA0FFE9BD9EFFE8BB
+ 9DFFE8BA9BFFE7B899FFE6B697FFDE9D75FF0028FC00000042000028FC008686
+ 86FF838383FF968D87FFEBC4A5FFEBC2A4FFEBC2A3FFEAC0A2FFEABFA0FFEABE
+ 9FFFE8BC9EFFE8BB9CFF7E726AFF535353FF4F4F4FFF00000000000EFC008989
+ 89FFD3D3D3FF848484FFE6B38CFFE5B28AFFE5B289FFE5AF86FFE5AE86FFE3AC
+ 85FFE3AB83FFE3A980FF626262FFC4C4C4FF585858FF00000000000000008989
+ 89FF888888FF878787FF00000000000000000000000000000000000000000000
+ 000000000000000000006B6B6BFF666666FF626262FF00002800C8A3E300C8A3
+ E300A8182F00A8182F0000000000000000000000000000000000000000000000
+ 0000000000000000000000000000000000000000000000000000
+ }
+ OnClick = acBoundariesExecute
+ end
+ object mnuVirtualLayer: TMenuItem
+ Action = acVirtualLayer
+ Bitmap.Data = {
+ 36040000424D3604000000000000360000002800000010000000100000000100
+ 200000000000000400006400000064000000000000000000000010A6F1009E00
+ 0000A6F1EF0000001500F1ED920000006200DF6FF80028FC000028F8000093F1
+ F000000000002900000070A1E30070A1E30020E55C0088A1E300FF1C00000011
+ 9C00F4E181000028FC000028FC000000280000002800000028000028FF00F4F4
+ F4000016B700D869F80028FC000093F1F0008D000000005AE500000000000000
+ 0000000000000000000046974EFF419149FF3C8A43FF38833EFF337D39FF2F77
+ 34FF2A712FFF266B2BFF236627FF206223FF1D5E20FF1A5B1EFF000000000000
+ 000000000000000000004C9F54FF47994FFF42924AFF3D8C45FF39853FFF347F
+ 3AFF307835FF2B7230FF276D2CFF246828FF206324FF1D5F21FF000000000000
+ 000046974EFF419149FF51A75BFF499B51FF44944BFF3F8E46FF3B8741FF3681
+ 3CFF317A37FF2D7532FF296F2EFF256929FF256929FF216425FF58FC00000028
+ FF004C9F54FF28FFF40057AF61FF4FA559FF4B9E54FF46984EFF429148FF3D8A
+ 43FF38843EFF337D39FF2F7734FF29702FFF296F2EFF256A2AFF0028FC000000
+ 00004EA358FF1171F1005CB666FF52A85BFF4EA357FF4A9D52FF45974DFF4190
+ 48FF3C8A43FF37833EFF357F3BFF2F7835FF2F7734FF2A712FFF000000000000
+ 000056AE60FF0000000060BC6BFF58B062FF54AB5EFF51A659FF4CA055FF489A
+ 50FF43944BFF3D8B45FF3A8741FF357F3BFF347F3AFF307835FFE81ADD00E81A
+ DD005BB565FF0000000064C16FFF5AB465FF57AF61FF54AB5EFF51A65AFF4CA1
+ 56FF499B51FF43934AFF409047FF3B8741FF3A8741FF35803BFF3FDE47000000
+ 00005FBB6AFF0000000067C673FFDE3F6A0059B264FF57AE60FF54AB5DFF51A7
+ 5AFF4DA256FF479950FF46974EFF408E47FF408F47FF3B8842FF000000000000
+ 000063C06EFF00FFFF0067C673FF67C572FF64C170FF61BD6CFF5DB968FF5AB4
+ 64FF56AE60FF50A659FF4DA256FF479A50FF46974EFF419149FF0000000000FF
+ FF0067C673FF0000000000000000000000000000000000FFFF00FF0000000000
+ 00000000000000000000000000003B8842FFFF00000000000000F90600000000
+ 000068C774FF68C673FF65C271FF62BE6EFF5FBA6AFF5CB565FF58AF61FF53A9
+ 5CFF4FA357FF46974DFFFF000000000000000000000000000000FFFFFF00FFFF
+ FF00FFFFF9004E0009003FDE460000000000000000000000000000000600DE3F
+ 7B00C63E0000000000000000000000000000000000003EC6D900080000000000
+ 3C00F0F4CA000000000000000000FFFFFF000000000000000000000000000000
+ 000000000000000000000000000000000000004ECB00FFFFFF00A8A3E300A8A3
+ E3003019DD003019DD000851A50092B075000000000018000000B019DD006419
+ DD000000000000000000000000007819DD000000000000000000
+ }
+ OnClick = acVirtualLayerExecute
+ end
+ end
+ object pmClients: TPopupMenu
+ left = 184
+ top = 176
+ object mnuGoToClient: TMenuItem
+ Caption = 'GoTo'
+ Default = True
+ OnClick = mnuGoToClientClick
+ end
+ end
+ object tmMovement: TTimer
+ Enabled = False
+ Interval = 500
+ OnTimer = tmMovementTimer
+ OnStartTimer = tmMovementTimer
+ left = 232
+ top = 80
+ end
+ object ActionList1: TActionList
+ Images = ImageList1
+ left = 264
+ top = 80
+ object acSelect: TAction
+ Category = 'Tools'
+ Caption = 'Select'
+ Checked = True
+ GroupIndex = 1
+ Hint = 'Select'
+ ImageIndex = 4
+ OnExecute = acSelectExecute
+ ShortCut = 112
+ end
+ object acDraw: TAction
+ Category = 'Tools'
+ Caption = 'Draw tiles'
+ GroupIndex = 1
+ Hint = 'Draw tiles'
+ ImageIndex = 5
+ OnExecute = acDrawExecute
+ ShortCut = 113
+ end
+ object acMove: TAction
+ Category = 'Tools'
+ Caption = 'Move tiles'
+ GroupIndex = 1
+ Hint = 'Move tiles'
+ ImageIndex = 6
+ OnExecute = acMoveExecute
+ ShortCut = 114
+ end
+ object acElevate: TAction
+ Category = 'Tools'
+ Caption = 'Elevate tiles'
+ GroupIndex = 1
+ Hint = 'Elevate tiles'
+ ImageIndex = 7
+ OnExecute = acElevateExecute
+ ShortCut = 115
+ end
+ object acDelete: TAction
+ Category = 'Tools'
+ Caption = 'Delete tiles'
+ GroupIndex = 1
+ Hint = 'Delete tiles'
+ ImageIndex = 8
+ OnExecute = acDeleteExecute
+ ShortCut = 116
+ end
+ object acHue: TAction
+ Category = 'Tools'
+ Caption = 'Hue tiles'
+ GroupIndex = 1
+ Hint = 'Hue tiles'
+ ImageIndex = 12
+ OnExecute = acHueExecute
+ ShortCut = 117
+ end
+ object acBoundaries: TAction
+ Category = 'Settings'
+ Caption = 'Boundaries'
+ Hint = 'Boundaries'
+ ImageIndex = 9
+ OnExecute = acBoundariesExecute
+ ShortCut = 118
+ end
+ object acFilter: TAction
+ Category = 'Settings'
+ AutoCheck = True
+ Caption = 'Filter'
+ Hint = 'Filter'
+ ImageIndex = 16
+ OnExecute = acFilterExecute
+ end
+ object acVirtualLayer: TAction
+ Category = 'Settings'
+ Caption = 'Virtual Layer'
+ Hint = 'Virtual Layer'
+ ImageIndex = 15
+ OnExecute = acVirtualLayerExecute
+ ShortCut = 119
+ end
+ object acFlat: TAction
+ Category = 'Settings'
+ Caption = 'Flat view'
+ Hint = 'Flat view'
+ ImageIndex = 17
+ OnExecute = acFlatExecute
+ end
+ object acNoDraw: TAction
+ Category = 'Settings'
+ Caption = 'NoDraw'
+ Checked = True
+ Hint = 'Display "No Draw" tiles'
+ ImageIndex = 18
+ OnExecute = acNoDrawExecute
+ end
+ object acUndo: TAction
+ Category = 'Tools'
+ Caption = 'Undo'
+ Enabled = False
+ Hint = 'Undo last set of changes'
+ ImageIndex = 20
+ OnExecute = acUndoExecute
+ ShortCut = 16474
+ end
+ object acLightlevel: TAction
+ Category = 'Settings'
+ Caption = 'Lightlevel'
+ Hint = 'Set Lightlevel'
+ ImageIndex = 21
+ OnExecute = acLightlevelExecute
+ end
+ object acWalkable: TAction
+ Category = 'Settings'
+ AutoCheck = True
+ Caption = 'Walkable'
+ Hint = 'Highlight (un)walkable surfaces'
+ ImageIndex = 22
+ OnExecute = acWalkableExecute
+ ShortCut = 16471
+ end
+ end
+ object tmGrabTileInfo: TTimer
+ Enabled = False
+ Interval = 250
+ OnTimer = tmGrabTileInfoTimer
+ left = 368
+ top = 80
+ end
+ object pmGrabTileInfo: TPopupMenu
+ OnPopup = pmGrabTileInfoPopup
+ left = 368
+ top = 33
+ object mnuGrabTileID: TMenuItem
+ Caption = 'Grab TileID'
+ OnClick = mnuGrabTileIDClick
+ end
+ object mnuGrabHue: TMenuItem
+ Caption = 'Grab Hue'
+ OnClick = mnuGrabHueClick
+ end
+ end
+ object pmFlatViewSettings: TPopupMenu
+ left = 368
+ top = 136
+ object mnuFlatShowHeight: TMenuItem
+ AutoCheck = True
+ Caption = 'Show Height'
+ OnClick = mnuFlatShowHeightClick
+ end
+ end
+ object XMLPropStorage1: TXMLPropStorage
+ StoredValues = <>
+ RootNodePath = 'Forms/frmMain'
+ Active = False
+ OnRestoreProperties = XMLPropStorage1RestoreProperties
+ left = 368
+ top = 208
+ end
+end
\ No newline at end of file
diff --git a/Client/UfrmMain.pas b/Client/UfrmMain.pas
index f5b58f5..3ce43ed 100644
--- a/Client/UfrmMain.pas
+++ b/Client/UfrmMain.pas
@@ -103,6 +103,7 @@ type
lblY: TLabel;
lbClients: TListBox;
MainMenu1: TMainMenu;
+ mnuChangePassword: TMenuItem;
mnuWhiteBackground: TMenuItem;
mnuSecurityQuestion: TMenuItem;
mnuShowAnimations: TMenuItem;
@@ -222,6 +223,7 @@ type
procedure lblChatHeaderCaptionClick(Sender: TObject);
procedure lblChatHeaderCaptionMouseEnter(Sender: TObject);
procedure lblChatHeaderCaptionMouseLeave(Sender: TObject);
+ procedure mnuChangePasswordClick(Sender: TObject);
procedure mnuAboutClick(Sender: TObject);
procedure mnuAccountControlClick(Sender: TObject);
procedure mnuDisconnectClick(Sender: TObject);
@@ -407,7 +409,7 @@ uses
UfrmBoundaries, UfrmElevateSettings, UfrmConfirmation, UfrmMoveSettings,
UfrmAbout, UPacketHandlers, UfrmHueSettings, UfrmRadar, UfrmLargeScaleCommand,
UfrmLogin, UResourceManager, UfrmVirtualLayer, UfrmFilter, UfrmRegionControl,
- Logging, LConvEncoding, LCLType, UfrmLightlevel;
+ Logging, LConvEncoding, LCLType, UfrmLightlevel, UfrmChangePassword;
type
TGLArrayf4 = array[0..3] of GLfloat;
@@ -1417,6 +1419,11 @@ begin
lblChatHeaderCaption.Font.Underline := False;
end;
+procedure TfrmMain.mnuChangePasswordClick(Sender: TObject);
+begin
+ frmChangePassword.ShowModal;
+end;
+
procedure TfrmMain.mnuAboutClick(Sender: TObject);
begin
frmAbout.ShowModal;
@@ -3060,6 +3067,7 @@ var
i: Integer;
accessLevel: TAccessLevel;
accessChangedListener: TAccessChangedListener;
+ pwdChangeStatus: TPasswordChangeStatus;
begin
case ABuffer.ReadByte of
$01: //client connected
@@ -3117,6 +3125,23 @@ begin
for accessChangedListener in FAccessChangedListeners.Reversed do
accessChangedListener(accessLevel);
end;
+ $08: //password change status
+ begin
+ pwdChangeStatus := TPasswordChangeStatus(ABuffer.ReadByte);
+ case pwdChangeStatus of
+ pcSuccess:
+ Messagedlg('Password Change', 'Your password has been changed', mtInformation, [mbOK], 0);
+ pcOldPwInvalid:
+ Messagedlg('Password Change', 'The old password is wrong.' + sLineBreak +
+ 'Your password has NOT been changed.', mtWarning, [mbOK], 0);
+ pcNewPwInvalid:
+ Messagedlg('Password Change', 'The new password is not allowed.' + sLineBreak +
+ 'Your password has NOT been changed.', mtWarning, [mbOK], 0);
+ pcIdentical:
+ Messagedlg('Password Change', 'The new password matched the old password.' + sLineBreak +
+ 'Your password has NOT been changed.', mtWarning, [mbOK], 0);
+ end;
+ end;
end;
end;
diff --git a/Imaging/ImagingBitmap.pas b/Imaging/ImagingBitmap.pas
index 37166e6..771a698 100644
--- a/Imaging/ImagingBitmap.pas
+++ b/Imaging/ImagingBitmap.pas
@@ -1,857 +1,857 @@
-{
- $Id: ImagingBitmap.pas 129 2008-08-06 20:01:30Z galfar $
- Vampyre Imaging Library
- by Marek Mauder
- http://imaginglib.sourceforge.net
-
- The contents of this file are used with permission, subject to the Mozilla
- Public License Version 1.1 (the "License"); you may not use this file except
- in compliance with the License. You may obtain a copy of the License at
- http://www.mozilla.org/MPL/MPL-1.1.html
-
- Software distributed under the License is distributed on an "AS IS" basis,
- WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
- the specific language governing rights and limitations under the License.
-
- Alternatively, the contents of this file may be used under the terms of the
- GNU Lesser General Public License (the "LGPL License"), in which case the
- provisions of the LGPL License are applicable instead of those above.
- If you wish to allow use of your version of this file only under the terms
- of the LGPL License and not to allow others to use your version of this file
- under the MPL, indicate your decision by deleting the provisions above and
- replace them with the notice and other provisions required by the LGPL
- License. If you do not delete the provisions above, a recipient may use
- your version of this file under either the MPL or the LGPL License.
-
- For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
-}
-
-{ This unit contains image format loader/saver for Windows Bitmap images.}
-unit ImagingBitmap;
-
-{$I ImagingOptions.inc}
-
-interface
-
-uses
- ImagingTypes, Imaging, ImagingUtility, ImagingFormats, ImagingIO;
-
-type
- { Class for loading and saving Windows Bitmap images.
- It can load/save 8bit indexed, 16, 24, 32 bit RGB or ARGB
- images with or without RLE compression. It can also load 1/4 bit
- indexed images and OS2 bitmaps.}
- TBitmapFileFormat = class(TImageFileFormat)
- protected
- FUseRLE: LongBool;
- function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
- OnlyFirstLevel: Boolean): Boolean; override;
- function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
- Index: LongInt): Boolean; override;
- procedure ConvertToSupported(var Image: TImageData;
- const Info: TImageFormatInfo); override;
- public
- constructor Create; override;
- function TestFormat(Handle: TImagingHandle): Boolean; override;
- published
- { Controls that RLE compression is used during saving. Accessible trough
- ImagingBitmapRLE option.}
- property UseRLE: LongBool read FUseRLE write FUseRLE;
- end;
-
-implementation
-
-const
- SBitmapFormatName = 'Windows Bitmap Image';
- SBitmapMasks = '*.bmp,*.dib';
- BitmapSupportedFormats: TImageFormats = [ifIndex8, ifA1R5G5B5, ifA4R4G4B4,
- ifR5G6B5, ifR8G8B8, ifA8R8G8B8, ifX1R5G5B5, ifX4R4G4B4, ifX8R8G8B8];
- BitmapDefaultRLE = True;
-
-const
- { Bitmap file identifier 'BM'.}
- BMMagic: Word = 19778;
-
- { Constants for the TBitmapInfoHeader.Compression field.}
- BI_RGB = 0;
- BI_RLE8 = 1;
- BI_RLE4 = 2;
- BI_BITFIELDS = 3;
-
- V3InfoHeaderSize = 40;
- V4InfoHeaderSize = 108;
-
-type
- { File Header for Windows/OS2 bitmap file.}
- TBitmapFileHeader = packed record
- ID: Word; // Is always 19778 : 'BM'
- Size: LongWord; // Filesize
- Reserved1: Word;
- Reserved2: Word;
- Offset: LongWord; // Offset from start pos to beginning of image bits
- end;
-
- { Info Header for Windows bitmap file version 4.}
- TBitmapInfoHeader = packed record
- Size: LongWord;
- Width: LongInt;
- Height: LongInt;
- Planes: Word;
- BitCount: Word;
- Compression: LongWord;
- SizeImage: LongWord;
- XPelsPerMeter: LongInt;
- YPelsPerMeter: LongInt;
- ClrUsed: LongInt;
- ClrImportant: LongInt;
- RedMask: LongWord;
- GreenMask: LongWord;
- BlueMask: LongWord;
- AlphaMask: LongWord;
- CSType: LongWord;
- EndPoints: array[0..8] of LongWord;
- GammaRed: LongWord;
- GammaGreen: LongWord;
- GammaBlue: LongWord;
- end;
-
- { Info Header for OS2 bitmaps.}
- TBitmapCoreHeader = packed record
- Size: LongWord;
- Width: Word;
- Height: Word;
- Planes: Word;
- BitCount: Word;
- end;
-
- { Used in RLE encoding and decoding.}
- TRLEOpcode = packed record
- Count: Byte;
- Command: Byte;
- end;
- PRLEOpcode = ^TRLEOpcode;
-
-{ TBitmapFileFormat class implementation }
-
-constructor TBitmapFileFormat.Create;
-begin
- inherited Create;
- FName := SBitmapFormatName;
- FCanLoad := True;
- FCanSave := True;
- FIsMultiImageFormat := False;
- FSupportedFormats := BitmapSupportedFormats;
-
- FUseRLE := BitmapDefaultRLE;
-
- AddMasks(SBitmapMasks);
- RegisterOption(ImagingBitmapRLE, @FUseRLE);
-end;
-
-function TBitmapFileFormat.LoadData(Handle: TImagingHandle;
- var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
-var
- BF: TBitmapFileHeader;
- BI: TBitmapInfoHeader;
- BC: TBitmapCoreHeader;
- IsOS2: Boolean;
- PalRGB: PPalette24;
- I, FPalSize, AlignedSize, StartPos, HeaderSize, AlignedWidthBytes, WidthBytes: LongInt;
- Info: TImageFormatInfo;
- Data: Pointer;
-
- procedure LoadRGB;
- var
- I: LongInt;
- LineBuffer: PByte;
- begin
- with Images[0], GetIO do
- begin
- // If BI.Height is < 0 then image data are stored non-flipped
- // but default in windows is flipped so if Height is positive we must
- // flip it
-
- if BI.BitCount < 8 then
- begin
- // For 1 and 4 bit images load aligned data, they will be converted to
- // 8 bit and unaligned later
- GetMem(Data, AlignedSize);
-
- if BI.Height < 0 then
- Read(Handle, Data, AlignedSize)
- else
- for I := Height - 1 downto 0 do
- Read(Handle, @PByteArray(Data)[I * AlignedWidthBytes], AlignedWidthBytes);
- end
- else
- begin
- // Images with pixels of size >= 1 Byte are read line by line and
- // copied to image bits without padding bytes
- GetMem(LineBuffer, AlignedWidthBytes);
- try
- if BI.Height < 0 then
- for I := 0 to Height - 1 do
- begin
- Read(Handle, LineBuffer, AlignedWidthBytes);
- Move(LineBuffer^, PByteArray(Bits)[I * WidthBytes], WidthBytes);
- end
- else
- for I := Height - 1 downto 0 do
- begin
- Read(Handle, LineBuffer, AlignedWidthBytes);
- Move(LineBuffer^, PByteArray(Bits)[I * WidthBytes], WidthBytes);
- end;
- finally
- FreeMemNil(LineBuffer);
- end;
- end;
- end;
- end;
-
- procedure LoadRLE4;
- var
- RLESrc: PByteArray;
- Row, Col, WriteRow, I: LongInt;
- SrcPos: LongWord;
- DeltaX, DeltaY, Low, High: Byte;
- Pixels: PByteArray;
- OpCode: TRLEOpcode;
- NegHeightBitmap: Boolean;
- begin
- GetMem(RLESrc, BI.SizeImage);
- GetIO.Read(Handle, RLESrc, BI.SizeImage);
- with Images[0] do
- try
- Low := 0;
- Pixels := Bits;
- SrcPos := 0;
- NegHeightBitmap := BI.Height < 0;
- Row := 0; // Current row in dest image
- Col := 0; // Current column in dest image
- // Row in dest image where actuall writting will be done
- WriteRow := Iff(NegHeightBitmap, Row, Height - 1 - Row);
- while (Row < Height) and (SrcPos < BI.SizeImage) do
- begin
- // Read RLE op-code
- OpCode := PRLEOpcode(@RLESrc[SrcPos])^;
- Inc(SrcPos, SizeOf(OpCode));
- if OpCode.Count = 0 then
- begin
- // A byte Count of zero means that this is a special
- // instruction.
- case OpCode.Command of
- 0:
- begin
- // Move to next row
- Inc(Row);
- WriteRow := Iff(NegHeightBitmap, Row, Height - 1 - Row);
- Col := 0;
- end ;
- 1: Break; // Image is finished
- 2:
- begin
- // Move to a new relative position
- DeltaX := RLESrc[SrcPos];
- DeltaY := RLESrc[SrcPos + 1];
- Inc(SrcPos, 2);
- Inc(Col, DeltaX);
- Inc(Row, DeltaY);
- end
- else
- // Do not read data after EOF
- if SrcPos + OpCode.Command > BI.SizeImage then
- OpCode.Command := BI.SizeImage - SrcPos;
- // Take padding bytes and nibbles into account
- if Col + OpCode.Command > Width then
- OpCode.Command := Width - Col;
- // Store absolute data. Command code is the
- // number of absolute bytes to store
- for I := 0 to OpCode.Command - 1 do
- begin
- if (I and 1) = 0 then
- begin
- High := RLESrc[SrcPos] shr 4;
- Low := RLESrc[SrcPos] and $F;
- Pixels[WriteRow * Width + Col] := High;
- Inc(SrcPos);
- end
- else
- Pixels[WriteRow * Width + Col] := Low;
- Inc(Col);
- end;
- // Odd number of bytes is followed by a pad byte
- if (OpCode.Command mod 4) in [1, 2] then
- Inc(SrcPos);
- end;
- end
- else
- begin
- // Take padding bytes and nibbles into account
- if Col + OpCode.Count > Width then
- OpCode.Count := Width - Col;
- // Store a run of the same color value
- for I := 0 to OpCode.Count - 1 do
- begin
- if (I and 1) = 0 then
- Pixels[WriteRow * Width + Col] := OpCode.Command shr 4
- else
- Pixels[WriteRow * Width + Col] := OpCode.Command and $F;
- Inc(Col);
- end;
- end;
- end;
- finally
- FreeMem(RLESrc);
- end;
- end;
-
- procedure LoadRLE8;
- var
- RLESrc: PByteArray;
- SrcCount, Row, Col, WriteRow: LongInt;
- SrcPos: LongWord;
- DeltaX, DeltaY: Byte;
- Pixels: PByteArray;
- OpCode: TRLEOpcode;
- NegHeightBitmap: Boolean;
- begin
- GetMem(RLESrc, BI.SizeImage);
- GetIO.Read(Handle, RLESrc, BI.SizeImage);
- with Images[0] do
- try
- Pixels := Bits;
- SrcPos := 0;
- NegHeightBitmap := BI.Height < 0;
- Row := 0; // Current row in dest image
- Col := 0; // Current column in dest image
- // Row in dest image where actuall writting will be done
- WriteRow := Iff(NegHeightBitmap, Row, Height - 1 - Row);
- while (Row < Height) and (SrcPos < BI.SizeImage) do
- begin
- // Read RLE op-code
- OpCode := PRLEOpcode(@RLESrc[SrcPos])^;
- Inc(SrcPos, SizeOf(OpCode));
- if OpCode.Count = 0 then
- begin
- // A byte Count of zero means that this is a special
- // instruction.
- case OpCode.Command of
- 0:
- begin
- // Move to next row
- Inc(Row);
- WriteRow := Iff(NegHeightBitmap, Row, Height - 1 - Row);
- Col := 0;
- end ;
- 1: Break; // Image is finished
- 2:
- begin
- // Move to a new relative position
- DeltaX := RLESrc[SrcPos];
- DeltaY := RLESrc[SrcPos + 1];
- Inc(SrcPos, 2);
- Inc(Col, DeltaX);
- Inc(Row, DeltaY);
- end
- else
- SrcCount := OpCode.Command;
- // Do not read data after EOF
- if SrcPos + OpCode.Command > BI.SizeImage then
- OpCode.Command := BI.SizeImage - SrcPos;
- // Take padding bytes into account
- if Col + OpCode.Command > Width then
- OpCode.Command := Width - Col;
- // Store absolute data. Command code is the
- // number of absolute bytes to store
- Move(RLESrc[SrcPos], Pixels[WriteRow * Width + Col], OpCode.Command);
- Inc(SrcPos, SrcCount);
- Inc(Col, OpCode.Command);
- // Odd number of bytes is followed by a pad byte
- if (SrcCount mod 2) = 1 then
- Inc(SrcPos);
- end;
- end
- else
- begin
- // Take padding bytes into account
- if Col + OpCode.Count > Width then
- OpCode.Count := Width - Col;
- // Store a run of the same color value. Count is number of bytes to store
- FillChar(Pixels [WriteRow * Width + Col], OpCode.Count, OpCode.Command);
- Inc(Col, OpCode.Count);
- end;
- end;
- finally
- FreeMem(RLESrc);
- end;
- end;
-
-begin
- Data := nil;
- SetLength(Images, 1);
- with GetIO, Images[0] do
- try
- FillChar(BI, SizeOf(BI), 0);
- StartPos := Tell(Handle);
- Read(Handle, @BF, SizeOf(BF));
- Read(Handle, @BI.Size, SizeOf(BI.Size));
- IsOS2 := BI.Size = SizeOf(TBitmapCoreHeader);
-
- // Bitmap Info reading
- if IsOS2 then
- begin
- // OS/2 type bitmap, reads info header without 4 already read bytes
- Read(Handle, @PByteArray(@BC)[SizeOf(BI.Size)],
- SizeOf(TBitmapCoreHeader) - SizeOf(BI.Size));
- with BI do
- begin
- ClrUsed := 0;
- Compression := BI_RGB;
- BitCount := BC.BitCount;
- Height := BC.Height;
- Width := BC.Width;
- end;
- end
- else
- begin
- // Windows type bitmap
- HeaderSize := Min(BI.Size - SizeOf(BI.Size), SizeOf(BI) - SizeOf(BI.Size)); // do not read more than size of BI!
- Read(Handle, @PByteArray(@BI)[SizeOf(BI.Size)], HeaderSize);
- // SizeImage can be 0 for BI_RGB images, but it is here because of:
- // I saved 8bit bitmap in Paint Shop Pro 8 as OS2 RLE compressed.
- // It wrote strange 64 Byte Info header with SizeImage set to 0
- // Some progs were able to open it, some were not.
- if BI.SizeImage = 0 then
- BI.SizeImage := BF.Size - BF.Offset;
- end;
- // Bit mask reading. Only read it if there is V3 header, V4 header has
- // masks laoded already (only masks for RGB in V3).
- if (BI.Compression = BI_BITFIELDS) and (BI.Size = V3InfoHeaderSize) then
- Read(Handle, @BI.RedMask, SizeOf(BI.RedMask) * 3);
-
- case BI.BitCount of
- 1, 4, 8: Format := ifIndex8;
- 16:
- if BI.RedMask = $0F00 then
- // Set XRGB4 or ARGB4 according to value of alpha mask
- Format := IffFormat(BI.AlphaMask = 0, ifX4R4G4B4, ifA4R4G4B4)
- else if BI.RedMask = $F800 then
- Format := ifR5G6B5
- else
- // R5G5B5 is default 16bit format (with Compression = BI_RGB or masks).
- // We set it to A1.. and later there is a check if there are any alpha values
- // and if not it is changed to X1R5G5B5
- Format := ifA1R5G5B5;
- 24: Format := ifR8G8B8;
- 32: Format := ifA8R8G8B8; // As with R5G5B5 there is alpha check later
- end;
-
- NewImage(BI.Width, Abs(BI.Height), Format, Images[0]);
- Info := GetFormatInfo(Format);
- WidthBytes := Width * Info.BytesPerPixel;
- AlignedWidthBytes := (((Width * BI.BitCount) + 31) shr 5) * 4;
- AlignedSize := Height * LongInt(AlignedWidthBytes);
-
- // Palette settings and reading
- if BI.BitCount <= 8 then
- begin
- // Seek to the begining of palette
- Seek(Handle, StartPos + SizeOf(TBitmapFileHeader) + LongInt(BI.Size),
- smFromBeginning);
- if IsOS2 then
- begin
- // OS/2 type
- FPalSize := 1 shl BI.BitCount;
- GetMem(PalRGB, FPalSize * SizeOf(TColor24Rec));
- try
- Read(Handle, PalRGB, FPalSize * SizeOf(TColor24Rec));
- for I := 0 to FPalSize - 1 do
- with PalRGB[I] do
- begin
- Palette[I].R := R;
- Palette[I].G := G;
- Palette[I].B := B;
- end;
- finally
- FreeMemNil(PalRGB);
- end;
- end
- else
- begin
- // Windows type
- FPalSize := BI.ClrUsed;
- if FPalSize = 0 then
- FPalSize := 1 shl BI.BitCount;
- Read(Handle, Palette, FPalSize * SizeOf(TColor32Rec));
- end;
- for I := 0 to Info.PaletteEntries - 1 do
- Palette[I].A := $FF;
- end;
-
- // Seek to the beginning of image bits
- Seek(Handle, StartPos + LongInt(BF.Offset), smFromBeginning);
-
- case BI.Compression of
- BI_RGB: LoadRGB;
- BI_RLE4: LoadRLE4;
- BI_RLE8: LoadRLE8;
- BI_BITFIELDS: LoadRGB;
- end;
-
- if BI.AlphaMask = 0 then
- begin
- // Alpha mask is not stored in file (V3) or not defined.
- // Check alpha channels of loaded images if they might contain them.
- if Format = ifA1R5G5B5 then
- begin
- // Check if there is alpha channel present in A1R5GB5 images, if it is not
- // change format to X1R5G5B5
- if not Has16BitImageAlpha(Width * Height, Bits) then
- Format := ifX1R5G5B5;
- end
- else if Format = ifA8R8G8B8 then
- begin
- // Check if there is alpha channel present in A8R8G8B8 images, if it is not
- // change format to X8R8G8B8
- if not Has32BitImageAlpha(Width * Height, Bits) then
- Format := ifX8R8G8B8;
- end;
- end;
-
- if BI.BitCount < 8 then
- begin
- // 1 and 4 bpp images are supported only for loading which is now
- // so we now convert them to 8bpp (and unalign scanlines).
- case BI.BitCount of
- 1: Convert1To8(Data, Bits, Width, Height, AlignedWidthBytes);
- 4:
- begin
- // RLE4 bitmaps are translated to 8bit during RLE decoding
- if BI.Compression <> BI_RLE4 then
- Convert4To8(Data, Bits, Width, Height, AlignedWidthBytes);
- end;
- end;
- // Enlarge palette
- ReallocMem(Palette, Info.PaletteEntries * SizeOf(TColor32Rec));
- end;
-
- Result := True;
- finally
- FreeMemNil(Data);
- end;
-end;
-
-function TBitmapFileFormat.SaveData(Handle: TImagingHandle;
- const Images: TDynImageDataArray; Index: LongInt): Boolean;
-var
- StartPos, EndPos, I, Pad, PadSize, WidthBytes: LongInt;
- BF: TBitmapFileHeader;
- BI: TBitmapInfoHeader;
- Info: TImageFormatInfo;
- ImageToSave: TImageData;
- MustBeFreed: Boolean;
-
- procedure SaveRLE8;
- const
- BufferSize = 8 * 1024;
- var
- X, Y, I, SrcPos: LongInt;
- DiffCount, SameCount: Byte;
- Pixels: PByteArray;
- Buffer: array[0..BufferSize - 1] of Byte;
- BufferPos: LongInt;
-
- procedure WriteByte(ByteToWrite: Byte);
- begin
- if BufferPos = BufferSize then
- begin
- // Flush buffer if necessary
- GetIO.Write(Handle, @Buffer, BufferPos);
- BufferPos := 0;
- end;
- Buffer[BufferPos] := ByteToWrite;
- Inc(BufferPos);
- end;
-
- begin
- BufferPos := 0;
- with GetIO, ImageToSave do
- begin
- for Y := Height - 1 downto 0 do
- begin
- X := 0;
- SrcPos := 0;
- Pixels := @PByteArray(Bits)[Y * Width];
-
- while X < Width do
- begin
- SameCount := 1;
- DiffCount := 0;
- // Determine run length
- while X + SameCount < Width do
- begin
- // If we reach max run length or byte with different value
- // we end this run
- if (SameCount = 255) or (Pixels[SrcPos + SameCount] <> Pixels[SrcPos]) then
- Break;
- Inc(SameCount);
- end;
-
- if SameCount = 1 then
- begin
- // If there are not some bytes with the same value we
- // compute how many different bytes are there
- while X + DiffCount < Width do
- begin
- // Stop diff byte counting if there two bytes with the same value
- // or DiffCount is too big
- if (DiffCount = 255) or (Pixels[SrcPos + DiffCount + 1] =
- Pixels[SrcPos + DiffCount]) then
- Break;
- Inc(DiffCount);
- end;
- end;
-
- // Now store absolute data (direct copy image->file) or
- // store RLE code only (number of repeats + byte to be repeated)
- if DiffCount > 2 then
- begin
- // Save 'Absolute Data' (0 + number of bytes) but only
- // if number is >2 because (0+1) and (0+2) are other special commands
- WriteByte(0);
- WriteByte(DiffCount);
- // Write absolute data to buffer
- for I := 0 to DiffCount - 1 do
- WriteByte(Pixels[SrcPos + I]);
- Inc(X, DiffCount);
- Inc(SrcPos, DiffCount);
- // Odd number of bytes must be padded
- if (DiffCount mod 2) = 1 then
- WriteByte(0);
- end
- else
- begin
- // Save number of repeats and byte that should be repeated
- WriteByte(SameCount);
- WriteByte(Pixels[SrcPos]);
- Inc(X, SameCount);
- Inc(SrcPos, SameCount);
- end;
- end;
- // Save 'End Of Line' command
- WriteByte(0);
- WriteByte(0);
- end;
- // Save 'End Of Bitmap' command
- WriteByte(0);
- WriteByte(1);
- // Flush buffer
- GetIO.Write(Handle, @Buffer, BufferPos);
- end;
- end;
-
-begin
- Result := False;
- if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then
- with GetIO, ImageToSave do
- try
- Info := GetFormatInfo(Format);
- StartPos := Tell(Handle);
- FillChar(BF, SizeOf(BF), 0);
- FillChar(BI, SizeOf(BI), 0);
- // Other fields will be filled later - we don't know all values now
- BF.ID := BMMagic;
- Write(Handle, @BF, SizeOf(BF));
- if Info.HasAlphaChannel and (Info.BytesPerPixel = 2){V4 temp hack} then
- // Save images with alpha in V4 format
- BI.Size := V4InfoHeaderSize
- else
- // Save images without alpha in V3 format - for better compatibility
- BI.Size := V3InfoHeaderSize;
- BI.Width := Width;
- BI.Height := Height;
- BI.Planes := 1;
- BI.BitCount := Info.BytesPerPixel * 8;
- BI.XPelsPerMeter := 2835; // 72 dpi
- BI.YPelsPerMeter := 2835; // 72 dpi
- // Set compression
- if (Info.BytesPerPixel = 1) and FUseRLE then
- BI.Compression := BI_RLE8
- else if (Info.HasAlphaChannel or
- ((BI.BitCount = 16) and (Format <> ifX1R5G5B5))) and (Info.BytesPerPixel = 2){V4 temp hack} then
- BI.Compression := BI_BITFIELDS
- else
- BI.Compression := BI_RGB;
- // Write header (first time)
- Write(Handle, @BI, BI.Size);
-
- // Write mask info
- if BI.Compression = BI_BITFIELDS then
- begin
- if BI.BitCount = 16 then
- with Info.PixelFormat^ do
- begin
- BI.RedMask := RBitMask;
- BI.GreenMask := GBitMask;
- BI.BlueMask := BBitMask;
- BI.AlphaMask := ABitMask;
- end
- else
- begin
- // Set masks for A8R8G8B8
- BI.RedMask := $00FF0000;
- BI.GreenMask := $0000FF00;
- BI.BlueMask := $000000FF;
- BI.AlphaMask := $FF000000;
- end;
- // If V3 header is used RGB masks must be written to file separately.
- // V4 header has embedded masks (V4 is default for formats with alpha).
- if BI.Size = V3InfoHeaderSize then
- Write(Handle, @BI.RedMask, SizeOf(BI.RedMask) * 3);
- end;
- // Write palette
- if Palette <> nil then
- Write(Handle, Palette, Info.PaletteEntries * SizeOf(TColor32Rec));
-
- BF.Offset := Tell(Handle) - StartPos;
-
- if BI.Compression <> BI_RLE8 then
- begin
- // Save uncompressed data, scanlines must be filled with pad bytes
- // to be multiples of 4, save as bottom-up (Windows native) bitmap
- Pad := 0;
- WidthBytes := Width * Info.BytesPerPixel;
- PadSize := ((Width * BI.BitCount + 31) div 32) * 4 - WidthBytes;
-
- for I := Height - 1 downto 0 do
- begin
- Write(Handle, @PByteArray(Bits)[I * WidthBytes], WidthBytes);
- if PadSize > 0 then
- Write(Handle, @Pad, PadSize);
- end;
- end
- else
- begin
- // Save data with RLE8 compression
- SaveRLE8;
- end;
-
- EndPos := Tell(Handle);
- Seek(Handle, StartPos, smFromBeginning);
- // Rewrite header with new values
- BF.Size := EndPos - StartPos;
- BI.SizeImage := BF.Size - BF.Offset;
- Write(Handle, @BF, SizeOf(BF));
- Write(Handle, @BI, BI.Size);
- Seek(Handle, EndPos, smFromBeginning);
-
- Result := True;
- finally
- if MustBeFreed then
- FreeImage(ImageToSave);
- end;
-end;
-
-procedure TBitmapFileFormat.ConvertToSupported(var Image: TImageData;
- const Info: TImageFormatInfo);
-var
- ConvFormat: TImageFormat;
-begin
- if Info.IsFloatingPoint then
- // Convert FP image to RGB/ARGB according to presence of alpha channel
- ConvFormat := IffFormat(Info.HasAlphaChannel, ifA8R8G8B8, ifR8G8B8)
- else if Info.HasGrayChannel or Info.IsIndexed then
- // Convert all grayscale and indexed images to Index8 unless they have alpha
- // (preserve it)
- ConvFormat := IffFormat(Info.HasAlphaChannel, ifA8R8G8B8, ifIndex8)
- else if Info.HasAlphaChannel then
- // Convert images with alpha channel to A8R8G8B8
- ConvFormat := ifA8R8G8B8
- else if Info.UsePixelFormat then
- // Convert 16bit RGB images (no alpha) to X1R5G5B5
- ConvFormat := ifX1R5G5B5
- else
- // Convert all other formats to R8G8B8
- ConvFormat := ifR8G8B8;
-
- ConvertImage(Image, ConvFormat);
-end;
-
-function TBitmapFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
-var
- Hdr: TBitmapFileHeader;
- ReadCount: LongInt;
-begin
- Result := False;
- if Handle <> nil then
- with GetIO do
- begin
- ReadCount := Read(Handle, @Hdr, SizeOf(Hdr));
- Seek(Handle, -ReadCount, smFromCurrent);
- Result := (Hdr.ID = BMMagic) and (ReadCount = SizeOf(Hdr));
- end;
-end;
-
-initialization
- RegisterImageFileFormat(TBitmapFileFormat);
-
-{
- File Notes:
-
- -- TODOS ----------------------------------------------------
- - nothing now
- - Add option to choose to save V3 or V4 headers.
-
- -- 0.25.0 Changes/Bug Fixes ---------------------------------
- - Fixed problem with indexed BMP loading - some pal entries
- could end up with alpha=0.
-
- -- 0.23 Changes/Bug Fixes -----------------------------------
- - Now saves bitmaps as bottom-up for better compatibility
- (mainly Lazarus' TImage!).
- - Fixed crash when loading bitmaps with headers larger than V4.
- - Temp hacks to disable V4 headers for 32bit images (compatibility with
- other soft).
-
- -- 0.21 Changes/Bug Fixes -----------------------------------
- - Removed temporary data allocation for image with aligned scanlines.
- They are now directly written to output so memory requirements are
- much lower now.
- - Now uses and recognizes BITMAPINFOHEADERV4 when loading/saving.
- Mainly for formats with alpha channels.
- - Added ifR5G6B5 to supported formats, changed converting to supported
- formats little bit.
- - Rewritten SaveRLE8 nested procedure. Old code was long and
- mysterious - new is short and much more readable.
- - MakeCompatible method moved to base class, put ConvertToSupported here.
- GetSupportedFormats removed, it is now set in constructor.
- - Rewritten LoadRLE4 and LoadRLE8 nested procedures.
- Should be less buggy an more readable (load inspired by Colosseum Builders' code).
- - Made public properties for options registered to SetOption/GetOption
- functions.
- - Addded alpha check to 32b bitmap loading too (teh same as in 16b
- bitmap loading).
- - Moved Convert1To8 and Convert4To8 to ImagingFormats
- - Changed extensions to filename masks.
- - Changed SaveData, LoadData, and MakeCompatible methods according
- to changes in base class in Imaging unit.
-
- -- 0.19 Changes/Bug Fixes -----------------------------------
- - fixed wrong const that caused A4R4G4B4 BMPs to load as A1R5G5B5
- - fixed the bug that caused 8bit RLE compressed bitmaps to load as
- whole black
-
- -- 0.17 Changes/Bug Fixes -----------------------------------
- - 16 bit images are usually without alpha but some has alpha
- channel and there is no indication of it - so I have added
- a check: if all pixels of image are with alpha = 0 image is treated
- as X1R5G5B5 otherwise as A1R5G5B5
-
- -- 0.13 Changes/Bug Fixes -----------------------------------
- - when loading 1/4 bit images with dword aligned dimensions
- there was ugly memory rewritting bug causing image corruption
-
-}
-
-end.
-
+{
+ $Id: ImagingBitmap.pas 129 2008-08-06 20:01:30Z galfar $
+ Vampyre Imaging Library
+ by Marek Mauder
+ http://imaginglib.sourceforge.net
+
+ The contents of this file are used with permission, subject to the Mozilla
+ Public License Version 1.1 (the "License"); you may not use this file except
+ in compliance with the License. You may obtain a copy of the License at
+ http://www.mozilla.org/MPL/MPL-1.1.html
+
+ Software distributed under the License is distributed on an "AS IS" basis,
+ WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
+ the specific language governing rights and limitations under the License.
+
+ Alternatively, the contents of this file may be used under the terms of the
+ GNU Lesser General Public License (the "LGPL License"), in which case the
+ provisions of the LGPL License are applicable instead of those above.
+ If you wish to allow use of your version of this file only under the terms
+ of the LGPL License and not to allow others to use your version of this file
+ under the MPL, indicate your decision by deleting the provisions above and
+ replace them with the notice and other provisions required by the LGPL
+ License. If you do not delete the provisions above, a recipient may use
+ your version of this file under either the MPL or the LGPL License.
+
+ For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
+}
+
+{ This unit contains image format loader/saver for Windows Bitmap images.}
+unit ImagingBitmap;
+
+{$I ImagingOptions.inc}
+
+interface
+
+uses
+ ImagingTypes, Imaging, ImagingUtility, ImagingFormats, ImagingIO;
+
+type
+ { Class for loading and saving Windows Bitmap images.
+ It can load/save 8bit indexed, 16, 24, 32 bit RGB or ARGB
+ images with or without RLE compression. It can also load 1/4 bit
+ indexed images and OS2 bitmaps.}
+ TBitmapFileFormat = class(TImageFileFormat)
+ protected
+ FUseRLE: LongBool;
+ function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
+ OnlyFirstLevel: Boolean): Boolean; override;
+ function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
+ Index: LongInt): Boolean; override;
+ procedure ConvertToSupported(var Image: TImageData;
+ const Info: TImageFormatInfo); override;
+ public
+ constructor Create; override;
+ function TestFormat(Handle: TImagingHandle): Boolean; override;
+ published
+ { Controls that RLE compression is used during saving. Accessible trough
+ ImagingBitmapRLE option.}
+ property UseRLE: LongBool read FUseRLE write FUseRLE;
+ end;
+
+implementation
+
+const
+ SBitmapFormatName = 'Windows Bitmap Image';
+ SBitmapMasks = '*.bmp,*.dib';
+ BitmapSupportedFormats: TImageFormats = [ifIndex8, ifA1R5G5B5, ifA4R4G4B4,
+ ifR5G6B5, ifR8G8B8, ifA8R8G8B8, ifX1R5G5B5, ifX4R4G4B4, ifX8R8G8B8];
+ BitmapDefaultRLE = True;
+
+const
+ { Bitmap file identifier 'BM'.}
+ BMMagic: Word = 19778;
+
+ { Constants for the TBitmapInfoHeader.Compression field.}
+ BI_RGB = 0;
+ BI_RLE8 = 1;
+ BI_RLE4 = 2;
+ BI_BITFIELDS = 3;
+
+ V3InfoHeaderSize = 40;
+ V4InfoHeaderSize = 108;
+
+type
+ { File Header for Windows/OS2 bitmap file.}
+ TBitmapFileHeader = packed record
+ ID: Word; // Is always 19778 : 'BM'
+ Size: LongWord; // Filesize
+ Reserved1: Word;
+ Reserved2: Word;
+ Offset: LongWord; // Offset from start pos to beginning of image bits
+ end;
+
+ { Info Header for Windows bitmap file version 4.}
+ TBitmapInfoHeader = packed record
+ Size: LongWord;
+ Width: LongInt;
+ Height: LongInt;
+ Planes: Word;
+ BitCount: Word;
+ Compression: LongWord;
+ SizeImage: LongWord;
+ XPelsPerMeter: LongInt;
+ YPelsPerMeter: LongInt;
+ ClrUsed: LongInt;
+ ClrImportant: LongInt;
+ RedMask: LongWord;
+ GreenMask: LongWord;
+ BlueMask: LongWord;
+ AlphaMask: LongWord;
+ CSType: LongWord;
+ EndPoints: array[0..8] of LongWord;
+ GammaRed: LongWord;
+ GammaGreen: LongWord;
+ GammaBlue: LongWord;
+ end;
+
+ { Info Header for OS2 bitmaps.}
+ TBitmapCoreHeader = packed record
+ Size: LongWord;
+ Width: Word;
+ Height: Word;
+ Planes: Word;
+ BitCount: Word;
+ end;
+
+ { Used in RLE encoding and decoding.}
+ TRLEOpcode = packed record
+ Count: Byte;
+ Command: Byte;
+ end;
+ PRLEOpcode = ^TRLEOpcode;
+
+{ TBitmapFileFormat class implementation }
+
+constructor TBitmapFileFormat.Create;
+begin
+ inherited Create;
+ FName := SBitmapFormatName;
+ FCanLoad := True;
+ FCanSave := True;
+ FIsMultiImageFormat := False;
+ FSupportedFormats := BitmapSupportedFormats;
+
+ FUseRLE := BitmapDefaultRLE;
+
+ AddMasks(SBitmapMasks);
+ RegisterOption(ImagingBitmapRLE, @FUseRLE);
+end;
+
+function TBitmapFileFormat.LoadData(Handle: TImagingHandle;
+ var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
+var
+ BF: TBitmapFileHeader;
+ BI: TBitmapInfoHeader;
+ BC: TBitmapCoreHeader;
+ IsOS2: Boolean;
+ PalRGB: PPalette24;
+ I, FPalSize, AlignedSize, StartPos, HeaderSize, AlignedWidthBytes, WidthBytes: LongInt;
+ Info: TImageFormatInfo;
+ Data: Pointer;
+
+ procedure LoadRGB;
+ var
+ I: LongInt;
+ LineBuffer: PByte;
+ begin
+ with Images[0], GetIO do
+ begin
+ // If BI.Height is < 0 then image data are stored non-flipped
+ // but default in windows is flipped so if Height is positive we must
+ // flip it
+
+ if BI.BitCount < 8 then
+ begin
+ // For 1 and 4 bit images load aligned data, they will be converted to
+ // 8 bit and unaligned later
+ GetMem(Data, AlignedSize);
+
+ if BI.Height < 0 then
+ Read(Handle, Data, AlignedSize)
+ else
+ for I := Height - 1 downto 0 do
+ Read(Handle, @PByteArray(Data)[I * AlignedWidthBytes], AlignedWidthBytes);
+ end
+ else
+ begin
+ // Images with pixels of size >= 1 Byte are read line by line and
+ // copied to image bits without padding bytes
+ GetMem(LineBuffer, AlignedWidthBytes);
+ try
+ if BI.Height < 0 then
+ for I := 0 to Height - 1 do
+ begin
+ Read(Handle, LineBuffer, AlignedWidthBytes);
+ Move(LineBuffer^, PByteArray(Bits)[I * WidthBytes], WidthBytes);
+ end
+ else
+ for I := Height - 1 downto 0 do
+ begin
+ Read(Handle, LineBuffer, AlignedWidthBytes);
+ Move(LineBuffer^, PByteArray(Bits)[I * WidthBytes], WidthBytes);
+ end;
+ finally
+ FreeMemNil(LineBuffer);
+ end;
+ end;
+ end;
+ end;
+
+ procedure LoadRLE4;
+ var
+ RLESrc: PByteArray;
+ Row, Col, WriteRow, I: LongInt;
+ SrcPos: LongWord;
+ DeltaX, DeltaY, Low, High: Byte;
+ Pixels: PByteArray;
+ OpCode: TRLEOpcode;
+ NegHeightBitmap: Boolean;
+ begin
+ GetMem(RLESrc, BI.SizeImage);
+ GetIO.Read(Handle, RLESrc, BI.SizeImage);
+ with Images[0] do
+ try
+ Low := 0;
+ Pixels := Bits;
+ SrcPos := 0;
+ NegHeightBitmap := BI.Height < 0;
+ Row := 0; // Current row in dest image
+ Col := 0; // Current column in dest image
+ // Row in dest image where actuall writting will be done
+ WriteRow := Iff(NegHeightBitmap, Row, Height - 1 - Row);
+ while (Row < Height) and (SrcPos < BI.SizeImage) do
+ begin
+ // Read RLE op-code
+ OpCode := PRLEOpcode(@RLESrc[SrcPos])^;
+ Inc(SrcPos, SizeOf(OpCode));
+ if OpCode.Count = 0 then
+ begin
+ // A byte Count of zero means that this is a special
+ // instruction.
+ case OpCode.Command of
+ 0:
+ begin
+ // Move to next row
+ Inc(Row);
+ WriteRow := Iff(NegHeightBitmap, Row, Height - 1 - Row);
+ Col := 0;
+ end ;
+ 1: Break; // Image is finished
+ 2:
+ begin
+ // Move to a new relative position
+ DeltaX := RLESrc[SrcPos];
+ DeltaY := RLESrc[SrcPos + 1];
+ Inc(SrcPos, 2);
+ Inc(Col, DeltaX);
+ Inc(Row, DeltaY);
+ end
+ else
+ // Do not read data after EOF
+ if SrcPos + OpCode.Command > BI.SizeImage then
+ OpCode.Command := BI.SizeImage - SrcPos;
+ // Take padding bytes and nibbles into account
+ if Col + OpCode.Command > Width then
+ OpCode.Command := Width - Col;
+ // Store absolute data. Command code is the
+ // number of absolute bytes to store
+ for I := 0 to OpCode.Command - 1 do
+ begin
+ if (I and 1) = 0 then
+ begin
+ High := RLESrc[SrcPos] shr 4;
+ Low := RLESrc[SrcPos] and $F;
+ Pixels[WriteRow * Width + Col] := High;
+ Inc(SrcPos);
+ end
+ else
+ Pixels[WriteRow * Width + Col] := Low;
+ Inc(Col);
+ end;
+ // Odd number of bytes is followed by a pad byte
+ if (OpCode.Command mod 4) in [1, 2] then
+ Inc(SrcPos);
+ end;
+ end
+ else
+ begin
+ // Take padding bytes and nibbles into account
+ if Col + OpCode.Count > Width then
+ OpCode.Count := Width - Col;
+ // Store a run of the same color value
+ for I := 0 to OpCode.Count - 1 do
+ begin
+ if (I and 1) = 0 then
+ Pixels[WriteRow * Width + Col] := OpCode.Command shr 4
+ else
+ Pixels[WriteRow * Width + Col] := OpCode.Command and $F;
+ Inc(Col);
+ end;
+ end;
+ end;
+ finally
+ FreeMem(RLESrc);
+ end;
+ end;
+
+ procedure LoadRLE8;
+ var
+ RLESrc: PByteArray;
+ SrcCount, Row, Col, WriteRow: LongInt;
+ SrcPos: LongWord;
+ DeltaX, DeltaY: Byte;
+ Pixels: PByteArray;
+ OpCode: TRLEOpcode;
+ NegHeightBitmap: Boolean;
+ begin
+ GetMem(RLESrc, BI.SizeImage);
+ GetIO.Read(Handle, RLESrc, BI.SizeImage);
+ with Images[0] do
+ try
+ Pixels := Bits;
+ SrcPos := 0;
+ NegHeightBitmap := BI.Height < 0;
+ Row := 0; // Current row in dest image
+ Col := 0; // Current column in dest image
+ // Row in dest image where actuall writting will be done
+ WriteRow := Iff(NegHeightBitmap, Row, Height - 1 - Row);
+ while (Row < Height) and (SrcPos < BI.SizeImage) do
+ begin
+ // Read RLE op-code
+ OpCode := PRLEOpcode(@RLESrc[SrcPos])^;
+ Inc(SrcPos, SizeOf(OpCode));
+ if OpCode.Count = 0 then
+ begin
+ // A byte Count of zero means that this is a special
+ // instruction.
+ case OpCode.Command of
+ 0:
+ begin
+ // Move to next row
+ Inc(Row);
+ WriteRow := Iff(NegHeightBitmap, Row, Height - 1 - Row);
+ Col := 0;
+ end ;
+ 1: Break; // Image is finished
+ 2:
+ begin
+ // Move to a new relative position
+ DeltaX := RLESrc[SrcPos];
+ DeltaY := RLESrc[SrcPos + 1];
+ Inc(SrcPos, 2);
+ Inc(Col, DeltaX);
+ Inc(Row, DeltaY);
+ end
+ else
+ SrcCount := OpCode.Command;
+ // Do not read data after EOF
+ if SrcPos + OpCode.Command > BI.SizeImage then
+ OpCode.Command := BI.SizeImage - SrcPos;
+ // Take padding bytes into account
+ if Col + OpCode.Command > Width then
+ OpCode.Command := Width - Col;
+ // Store absolute data. Command code is the
+ // number of absolute bytes to store
+ Move(RLESrc[SrcPos], Pixels[WriteRow * Width + Col], OpCode.Command);
+ Inc(SrcPos, SrcCount);
+ Inc(Col, OpCode.Command);
+ // Odd number of bytes is followed by a pad byte
+ if (SrcCount mod 2) = 1 then
+ Inc(SrcPos);
+ end;
+ end
+ else
+ begin
+ // Take padding bytes into account
+ if Col + OpCode.Count > Width then
+ OpCode.Count := Width - Col;
+ // Store a run of the same color value. Count is number of bytes to store
+ FillChar(Pixels [WriteRow * Width + Col], OpCode.Count, OpCode.Command);
+ Inc(Col, OpCode.Count);
+ end;
+ end;
+ finally
+ FreeMem(RLESrc);
+ end;
+ end;
+
+begin
+ Data := nil;
+ SetLength(Images, 1);
+ with GetIO, Images[0] do
+ try
+ FillChar(BI, SizeOf(BI), 0);
+ StartPos := Tell(Handle);
+ Read(Handle, @BF, SizeOf(BF));
+ Read(Handle, @BI.Size, SizeOf(BI.Size));
+ IsOS2 := BI.Size = SizeOf(TBitmapCoreHeader);
+
+ // Bitmap Info reading
+ if IsOS2 then
+ begin
+ // OS/2 type bitmap, reads info header without 4 already read bytes
+ Read(Handle, @PByteArray(@BC)[SizeOf(BI.Size)],
+ SizeOf(TBitmapCoreHeader) - SizeOf(BI.Size));
+ with BI do
+ begin
+ ClrUsed := 0;
+ Compression := BI_RGB;
+ BitCount := BC.BitCount;
+ Height := BC.Height;
+ Width := BC.Width;
+ end;
+ end
+ else
+ begin
+ // Windows type bitmap
+ HeaderSize := Min(BI.Size - SizeOf(BI.Size), SizeOf(BI) - SizeOf(BI.Size)); // do not read more than size of BI!
+ Read(Handle, @PByteArray(@BI)[SizeOf(BI.Size)], HeaderSize);
+ // SizeImage can be 0 for BI_RGB images, but it is here because of:
+ // I saved 8bit bitmap in Paint Shop Pro 8 as OS2 RLE compressed.
+ // It wrote strange 64 Byte Info header with SizeImage set to 0
+ // Some progs were able to open it, some were not.
+ if BI.SizeImage = 0 then
+ BI.SizeImage := BF.Size - BF.Offset;
+ end;
+ // Bit mask reading. Only read it if there is V3 header, V4 header has
+ // masks laoded already (only masks for RGB in V3).
+ if (BI.Compression = BI_BITFIELDS) and (BI.Size = V3InfoHeaderSize) then
+ Read(Handle, @BI.RedMask, SizeOf(BI.RedMask) * 3);
+
+ case BI.BitCount of
+ 1, 4, 8: Format := ifIndex8;
+ 16:
+ if BI.RedMask = $0F00 then
+ // Set XRGB4 or ARGB4 according to value of alpha mask
+ Format := IffFormat(BI.AlphaMask = 0, ifX4R4G4B4, ifA4R4G4B4)
+ else if BI.RedMask = $F800 then
+ Format := ifR5G6B5
+ else
+ // R5G5B5 is default 16bit format (with Compression = BI_RGB or masks).
+ // We set it to A1.. and later there is a check if there are any alpha values
+ // and if not it is changed to X1R5G5B5
+ Format := ifA1R5G5B5;
+ 24: Format := ifR8G8B8;
+ 32: Format := ifA8R8G8B8; // As with R5G5B5 there is alpha check later
+ end;
+
+ NewImage(BI.Width, Abs(BI.Height), Format, Images[0]);
+ Info := GetFormatInfo(Format);
+ WidthBytes := Width * Info.BytesPerPixel;
+ AlignedWidthBytes := (((Width * BI.BitCount) + 31) shr 5) * 4;
+ AlignedSize := Height * LongInt(AlignedWidthBytes);
+
+ // Palette settings and reading
+ if BI.BitCount <= 8 then
+ begin
+ // Seek to the begining of palette
+ Seek(Handle, StartPos + SizeOf(TBitmapFileHeader) + LongInt(BI.Size),
+ smFromBeginning);
+ if IsOS2 then
+ begin
+ // OS/2 type
+ FPalSize := 1 shl BI.BitCount;
+ GetMem(PalRGB, FPalSize * SizeOf(TColor24Rec));
+ try
+ Read(Handle, PalRGB, FPalSize * SizeOf(TColor24Rec));
+ for I := 0 to FPalSize - 1 do
+ with PalRGB[I] do
+ begin
+ Palette[I].R := R;
+ Palette[I].G := G;
+ Palette[I].B := B;
+ end;
+ finally
+ FreeMemNil(PalRGB);
+ end;
+ end
+ else
+ begin
+ // Windows type
+ FPalSize := BI.ClrUsed;
+ if FPalSize = 0 then
+ FPalSize := 1 shl BI.BitCount;
+ Read(Handle, Palette, FPalSize * SizeOf(TColor32Rec));
+ end;
+ for I := 0 to Info.PaletteEntries - 1 do
+ Palette[I].A := $FF;
+ end;
+
+ // Seek to the beginning of image bits
+ Seek(Handle, StartPos + LongInt(BF.Offset), smFromBeginning);
+
+ case BI.Compression of
+ BI_RGB: LoadRGB;
+ BI_RLE4: LoadRLE4;
+ BI_RLE8: LoadRLE8;
+ BI_BITFIELDS: LoadRGB;
+ end;
+
+ if BI.AlphaMask = 0 then
+ begin
+ // Alpha mask is not stored in file (V3) or not defined.
+ // Check alpha channels of loaded images if they might contain them.
+ if Format = ifA1R5G5B5 then
+ begin
+ // Check if there is alpha channel present in A1R5GB5 images, if it is not
+ // change format to X1R5G5B5
+ if not Has16BitImageAlpha(Width * Height, Bits) then
+ Format := ifX1R5G5B5;
+ end
+ else if Format = ifA8R8G8B8 then
+ begin
+ // Check if there is alpha channel present in A8R8G8B8 images, if it is not
+ // change format to X8R8G8B8
+ if not Has32BitImageAlpha(Width * Height, Bits) then
+ Format := ifX8R8G8B8;
+ end;
+ end;
+
+ if BI.BitCount < 8 then
+ begin
+ // 1 and 4 bpp images are supported only for loading which is now
+ // so we now convert them to 8bpp (and unalign scanlines).
+ case BI.BitCount of
+ 1: Convert1To8(Data, Bits, Width, Height, AlignedWidthBytes);
+ 4:
+ begin
+ // RLE4 bitmaps are translated to 8bit during RLE decoding
+ if BI.Compression <> BI_RLE4 then
+ Convert4To8(Data, Bits, Width, Height, AlignedWidthBytes);
+ end;
+ end;
+ // Enlarge palette
+ ReallocMem(Palette, Info.PaletteEntries * SizeOf(TColor32Rec));
+ end;
+
+ Result := True;
+ finally
+ FreeMemNil(Data);
+ end;
+end;
+
+function TBitmapFileFormat.SaveData(Handle: TImagingHandle;
+ const Images: TDynImageDataArray; Index: LongInt): Boolean;
+var
+ StartPos, EndPos, I, Pad, PadSize, WidthBytes: LongInt;
+ BF: TBitmapFileHeader;
+ BI: TBitmapInfoHeader;
+ Info: TImageFormatInfo;
+ ImageToSave: TImageData;
+ MustBeFreed: Boolean;
+
+ procedure SaveRLE8;
+ const
+ BufferSize = 8 * 1024;
+ var
+ X, Y, I, SrcPos: LongInt;
+ DiffCount, SameCount: Byte;
+ Pixels: PByteArray;
+ Buffer: array[0..BufferSize - 1] of Byte;
+ BufferPos: LongInt;
+
+ procedure WriteByte(ByteToWrite: Byte);
+ begin
+ if BufferPos = BufferSize then
+ begin
+ // Flush buffer if necessary
+ GetIO.Write(Handle, @Buffer, BufferPos);
+ BufferPos := 0;
+ end;
+ Buffer[BufferPos] := ByteToWrite;
+ Inc(BufferPos);
+ end;
+
+ begin
+ BufferPos := 0;
+ with GetIO, ImageToSave do
+ begin
+ for Y := Height - 1 downto 0 do
+ begin
+ X := 0;
+ SrcPos := 0;
+ Pixels := @PByteArray(Bits)[Y * Width];
+
+ while X < Width do
+ begin
+ SameCount := 1;
+ DiffCount := 0;
+ // Determine run length
+ while X + SameCount < Width do
+ begin
+ // If we reach max run length or byte with different value
+ // we end this run
+ if (SameCount = 255) or (Pixels[SrcPos + SameCount] <> Pixels[SrcPos]) then
+ Break;
+ Inc(SameCount);
+ end;
+
+ if SameCount = 1 then
+ begin
+ // If there are not some bytes with the same value we
+ // compute how many different bytes are there
+ while X + DiffCount < Width do
+ begin
+ // Stop diff byte counting if there two bytes with the same value
+ // or DiffCount is too big
+ if (DiffCount = 255) or (Pixels[SrcPos + DiffCount + 1] =
+ Pixels[SrcPos + DiffCount]) then
+ Break;
+ Inc(DiffCount);
+ end;
+ end;
+
+ // Now store absolute data (direct copy image->file) or
+ // store RLE code only (number of repeats + byte to be repeated)
+ if DiffCount > 2 then
+ begin
+ // Save 'Absolute Data' (0 + number of bytes) but only
+ // if number is >2 because (0+1) and (0+2) are other special commands
+ WriteByte(0);
+ WriteByte(DiffCount);
+ // Write absolute data to buffer
+ for I := 0 to DiffCount - 1 do
+ WriteByte(Pixels[SrcPos + I]);
+ Inc(X, DiffCount);
+ Inc(SrcPos, DiffCount);
+ // Odd number of bytes must be padded
+ if (DiffCount mod 2) = 1 then
+ WriteByte(0);
+ end
+ else
+ begin
+ // Save number of repeats and byte that should be repeated
+ WriteByte(SameCount);
+ WriteByte(Pixels[SrcPos]);
+ Inc(X, SameCount);
+ Inc(SrcPos, SameCount);
+ end;
+ end;
+ // Save 'End Of Line' command
+ WriteByte(0);
+ WriteByte(0);
+ end;
+ // Save 'End Of Bitmap' command
+ WriteByte(0);
+ WriteByte(1);
+ // Flush buffer
+ GetIO.Write(Handle, @Buffer, BufferPos);
+ end;
+ end;
+
+begin
+ Result := False;
+ if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then
+ with GetIO, ImageToSave do
+ try
+ Info := GetFormatInfo(Format);
+ StartPos := Tell(Handle);
+ FillChar(BF, SizeOf(BF), 0);
+ FillChar(BI, SizeOf(BI), 0);
+ // Other fields will be filled later - we don't know all values now
+ BF.ID := BMMagic;
+ Write(Handle, @BF, SizeOf(BF));
+ if Info.HasAlphaChannel and (Info.BytesPerPixel = 2){V4 temp hack} then
+ // Save images with alpha in V4 format
+ BI.Size := V4InfoHeaderSize
+ else
+ // Save images without alpha in V3 format - for better compatibility
+ BI.Size := V3InfoHeaderSize;
+ BI.Width := Width;
+ BI.Height := Height;
+ BI.Planes := 1;
+ BI.BitCount := Info.BytesPerPixel * 8;
+ BI.XPelsPerMeter := 2835; // 72 dpi
+ BI.YPelsPerMeter := 2835; // 72 dpi
+ // Set compression
+ if (Info.BytesPerPixel = 1) and FUseRLE then
+ BI.Compression := BI_RLE8
+ else if (Info.HasAlphaChannel or
+ ((BI.BitCount = 16) and (Format <> ifX1R5G5B5))) and (Info.BytesPerPixel = 2){V4 temp hack} then
+ BI.Compression := BI_BITFIELDS
+ else
+ BI.Compression := BI_RGB;
+ // Write header (first time)
+ Write(Handle, @BI, BI.Size);
+
+ // Write mask info
+ if BI.Compression = BI_BITFIELDS then
+ begin
+ if BI.BitCount = 16 then
+ with Info.PixelFormat^ do
+ begin
+ BI.RedMask := RBitMask;
+ BI.GreenMask := GBitMask;
+ BI.BlueMask := BBitMask;
+ BI.AlphaMask := ABitMask;
+ end
+ else
+ begin
+ // Set masks for A8R8G8B8
+ BI.RedMask := $00FF0000;
+ BI.GreenMask := $0000FF00;
+ BI.BlueMask := $000000FF;
+ BI.AlphaMask := $FF000000;
+ end;
+ // If V3 header is used RGB masks must be written to file separately.
+ // V4 header has embedded masks (V4 is default for formats with alpha).
+ if BI.Size = V3InfoHeaderSize then
+ Write(Handle, @BI.RedMask, SizeOf(BI.RedMask) * 3);
+ end;
+ // Write palette
+ if Palette <> nil then
+ Write(Handle, Palette, Info.PaletteEntries * SizeOf(TColor32Rec));
+
+ BF.Offset := Tell(Handle) - StartPos;
+
+ if BI.Compression <> BI_RLE8 then
+ begin
+ // Save uncompressed data, scanlines must be filled with pad bytes
+ // to be multiples of 4, save as bottom-up (Windows native) bitmap
+ Pad := 0;
+ WidthBytes := Width * Info.BytesPerPixel;
+ PadSize := ((Width * BI.BitCount + 31) div 32) * 4 - WidthBytes;
+
+ for I := Height - 1 downto 0 do
+ begin
+ Write(Handle, @PByteArray(Bits)[I * WidthBytes], WidthBytes);
+ if PadSize > 0 then
+ Write(Handle, @Pad, PadSize);
+ end;
+ end
+ else
+ begin
+ // Save data with RLE8 compression
+ SaveRLE8;
+ end;
+
+ EndPos := Tell(Handle);
+ Seek(Handle, StartPos, smFromBeginning);
+ // Rewrite header with new values
+ BF.Size := EndPos - StartPos;
+ BI.SizeImage := BF.Size - BF.Offset;
+ Write(Handle, @BF, SizeOf(BF));
+ Write(Handle, @BI, BI.Size);
+ Seek(Handle, EndPos, smFromBeginning);
+
+ Result := True;
+ finally
+ if MustBeFreed then
+ FreeImage(ImageToSave);
+ end;
+end;
+
+procedure TBitmapFileFormat.ConvertToSupported(var Image: TImageData;
+ const Info: TImageFormatInfo);
+var
+ ConvFormat: TImageFormat;
+begin
+ if Info.IsFloatingPoint then
+ // Convert FP image to RGB/ARGB according to presence of alpha channel
+ ConvFormat := IffFormat(Info.HasAlphaChannel, ifA8R8G8B8, ifR8G8B8)
+ else if Info.HasGrayChannel or Info.IsIndexed then
+ // Convert all grayscale and indexed images to Index8 unless they have alpha
+ // (preserve it)
+ ConvFormat := IffFormat(Info.HasAlphaChannel, ifA8R8G8B8, ifIndex8)
+ else if Info.HasAlphaChannel then
+ // Convert images with alpha channel to A8R8G8B8
+ ConvFormat := ifA8R8G8B8
+ else if Info.UsePixelFormat then
+ // Convert 16bit RGB images (no alpha) to X1R5G5B5
+ ConvFormat := ifX1R5G5B5
+ else
+ // Convert all other formats to R8G8B8
+ ConvFormat := ifR8G8B8;
+
+ ConvertImage(Image, ConvFormat);
+end;
+
+function TBitmapFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
+var
+ Hdr: TBitmapFileHeader;
+ ReadCount: LongInt;
+begin
+ Result := False;
+ if Handle <> nil then
+ with GetIO do
+ begin
+ ReadCount := Read(Handle, @Hdr, SizeOf(Hdr));
+ Seek(Handle, -ReadCount, smFromCurrent);
+ Result := (Hdr.ID = BMMagic) and (ReadCount = SizeOf(Hdr));
+ end;
+end;
+
+initialization
+ RegisterImageFileFormat(TBitmapFileFormat);
+
+{
+ File Notes:
+
+ -- TODOS ----------------------------------------------------
+ - nothing now
+ - Add option to choose to save V3 or V4 headers.
+
+ -- 0.25.0 Changes/Bug Fixes ---------------------------------
+ - Fixed problem with indexed BMP loading - some pal entries
+ could end up with alpha=0.
+
+ -- 0.23 Changes/Bug Fixes -----------------------------------
+ - Now saves bitmaps as bottom-up for better compatibility
+ (mainly Lazarus' TImage!).
+ - Fixed crash when loading bitmaps with headers larger than V4.
+ - Temp hacks to disable V4 headers for 32bit images (compatibility with
+ other soft).
+
+ -- 0.21 Changes/Bug Fixes -----------------------------------
+ - Removed temporary data allocation for image with aligned scanlines.
+ They are now directly written to output so memory requirements are
+ much lower now.
+ - Now uses and recognizes BITMAPINFOHEADERV4 when loading/saving.
+ Mainly for formats with alpha channels.
+ - Added ifR5G6B5 to supported formats, changed converting to supported
+ formats little bit.
+ - Rewritten SaveRLE8 nested procedure. Old code was long and
+ mysterious - new is short and much more readable.
+ - MakeCompatible method moved to base class, put ConvertToSupported here.
+ GetSupportedFormats removed, it is now set in constructor.
+ - Rewritten LoadRLE4 and LoadRLE8 nested procedures.
+ Should be less buggy an more readable (load inspired by Colosseum Builders' code).
+ - Made public properties for options registered to SetOption/GetOption
+ functions.
+ - Addded alpha check to 32b bitmap loading too (teh same as in 16b
+ bitmap loading).
+ - Moved Convert1To8 and Convert4To8 to ImagingFormats
+ - Changed extensions to filename masks.
+ - Changed SaveData, LoadData, and MakeCompatible methods according
+ to changes in base class in Imaging unit.
+
+ -- 0.19 Changes/Bug Fixes -----------------------------------
+ - fixed wrong const that caused A4R4G4B4 BMPs to load as A1R5G5B5
+ - fixed the bug that caused 8bit RLE compressed bitmaps to load as
+ whole black
+
+ -- 0.17 Changes/Bug Fixes -----------------------------------
+ - 16 bit images are usually without alpha but some has alpha
+ channel and there is no indication of it - so I have added
+ a check: if all pixels of image are with alpha = 0 image is treated
+ as X1R5G5B5 otherwise as A1R5G5B5
+
+ -- 0.13 Changes/Bug Fixes -----------------------------------
+ - when loading 1/4 bit images with dword aligned dimensions
+ there was ugly memory rewritting bug causing image corruption
+
+}
+
+end.
+
diff --git a/Imaging/ImagingCanvases.pas b/Imaging/ImagingCanvases.pas
index 62a170c..c7c238c 100644
--- a/Imaging/ImagingCanvases.pas
+++ b/Imaging/ImagingCanvases.pas
@@ -1,2177 +1,2177 @@
-{
- $Id: ImagingCanvases.pas 174 2009-09-08 09:37:59Z galfar $
- Vampyre Imaging Library
- by Marek Mauder
- http://imaginglib.sourceforge.net
-
- The contents of this file are used with permission, subject to the Mozilla
- Public License Version 1.1 (the "License"); you may not use this file except
- in compliance with the License. You may obtain a copy of the License at
- http://www.mozilla.org/MPL/MPL-1.1.html
-
- Software distributed under the License is distributed on an "AS IS" basis,
- WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
- the specific language governing rights and limitations under the License.
-
- Alternatively, the contents of this file may be used under the terms of the
- GNU Lesser General Public License (the "LGPL License"), in which case the
- provisions of the LGPL License are applicable instead of those above.
- If you wish to allow use of your version of this file only under the terms
- of the LGPL License and not to allow others to use your version of this file
- under the MPL, indicate your decision by deleting the provisions above and
- replace them with the notice and other provisions required by the LGPL
- License. If you do not delete the provisions above, a recipient may use
- your version of this file under either the MPL or the LGPL License.
-
- For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
-}
-
-{
- This unit contains canvas classes for drawing and applying effects.
-}
-unit ImagingCanvases;
-
-{$I ImagingOptions.inc}
-
-interface
-
-uses
- SysUtils, Types, Classes, ImagingTypes, Imaging, ImagingClasses,
- ImagingFormats, ImagingUtility;
-
-const
- { Color constants in ifA8R8G8B8 format.}
- pcClear = $00000000;
- pcBlack = $FF000000;
- pcWhite = $FFFFFFFF;
- pcMaroon = $FF800000;
- pcGreen = $FF008000;
- pcOlive = $FF808000;
- pcNavy = $FF000080;
- pcPurple = $FF800080;
- pcTeal = $FF008080;
- pcGray = $FF808080;
- pcSilver = $FFC0C0C0;
- pcRed = $FFFF0000;
- pcLime = $FF00FF00;
- pcYellow = $FFFFFF00;
- pcBlue = $FF0000FF;
- pcFuchsia = $FFFF00FF;
- pcAqua = $FF00FFFF;
- pcLtGray = $FFC0C0C0;
- pcDkGray = $FF808080;
-
- MaxPenWidth = 256;
-
-type
- EImagingCanvasError = class(EImagingError);
- EImagingCanvasBlendingError = class(EImagingError);
-
- { Fill mode used when drawing filled objects on canvas.}
- TFillMode = (
- fmSolid, // Solid fill using current fill color
- fmClear // No filling done
- );
-
- { Pen mode used when drawing lines, object outlines, and similar on canvas.}
- TPenMode = (
- pmSolid, // Draws solid lines using current pen color.
- pmClear // No drawing done
- );
-
- { Source and destination blending factors for drawing functions with blending.
- Blending formula: SrcColor * SrcFactor + DestColor * DestFactor }
- TBlendingFactor = (
- bfIgnore, // Don't care
- bfZero, // For Src and Dest, Factor = (0, 0, 0, 0)
- bfOne, // For Src and Dest, Factor = (1, 1, 1, 1)
- bfSrcAlpha, // For Src and Dest, Factor = (Src.A, Src.A, Src.A, Src.A)
- bfOneMinusSrcAlpha, // For Src and Dest, Factor = (1 - Src.A, 1 - Src.A, 1 - Src.A, 1 - Src.A)
- bfDstAlpha, // For Src and Dest, Factor = (Dest.A, Dest.A, Dest.A, Dest.A)
- bfOneMinusDstAlpha, // For Src and Dest, Factor = (1 - Dest.A, 1 - Dest.A, 1 - Dest.A, 1 - Dest.A)
- bfSrcColor, // For Dest, Factor = (Src.R, Src.R, Src.B, Src.A)
- bfOneMinusSrcColor, // For Dest, Factor = (1 - Src.R, 1 - Src.G, 1 - Src.B, 1 - Src.A)
- bfDstColor, // For Src, Factor = (Dest.R, Dest.G, Dest.B, Dest.A)
- bfOneMinusDstColor // For Src, Factor = (1 - Dest.R, 1 - Dest.G, 1 - Dest.B, 1 - Dest.A)
- );
-
- { Procedure for custom pixel write modes with blending.}
- TPixelWriteProc = procedure(const SrcPix: TColorFPRec; DestPtr: PByte;
- DestInfo: PImageFormatInfo; SrcFactor, DestFactor: TBlendingFactor);
-
- { Represents 3x3 convolution filter kernel.}
- TConvolutionFilter3x3 = record
- Kernel: array[0..2, 0..2] of LongInt;
- Divisor: LongInt;
- Bias: Single;
- end;
-
- { Represents 5x5 convolution filter kernel.}
- TConvolutionFilter5x5 = record
- Kernel: array[0..4, 0..4] of LongInt;
- Divisor: LongInt;
- Bias: Single;
- end;
-
- TPointTransformFunction = function(const Pixel: TColorFPRec;
- Param1, Param2, Param3: Single): TColorFPRec;
-
- TDynFPPixelArray = array of TColorFPRec;
-
- THistogramArray = array[Byte] of Integer;
-
- TSelectPixelFunction = function(var Pixels: TDynFPPixelArray): TColorFPRec;
-
- { Base canvas class for drawing objects, applying effects, and other.
- Constructor takes TBaseImage (or pointer to TImageData). Source image
- bits are not copied but referenced so all canvas functions affect
- source image and vice versa. When you change format or resolution of
- source image you must call UpdateCanvasState method (so canvas could
- recompute some data size related stuff).
-
- TImagingCanvas works for all image data formats except special ones
- (compressed). Because of this its methods are quite slow (they usually work
- with colors in ifA32R32G32B32F format). If you want fast drawing you
- can use one of fast canvas clases. These descendants of TImagingCanvas
- work only for few select formats (or only one) but they are optimized thus
- much faster.
- }
- TImagingCanvas = class(TObject)
- private
- FDataSizeOnUpdate: LongInt;
- FLineRecursion: Boolean;
- function GetPixel32(X, Y: LongInt): TColor32; virtual;
- function GetPixelFP(X, Y: LongInt): TColorFPRec; virtual;
- function GetValid: Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF}
- procedure SetPixel32(X, Y: LongInt; const Value: TColor32); virtual;
- procedure SetPixelFP(X, Y: LongInt; const Value: TColorFPRec); virtual;
- procedure SetPenColor32(const Value: TColor32); {$IFDEF USE_INLINE}inline;{$ENDIF}
- procedure SetPenColorFP(const Value: TColorFPRec); {$IFDEF USE_INLINE}inline;{$ENDIF}
- procedure SetPenWidth(const Value: LongInt); {$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 SetClipRect(const Value: TRect);
- procedure CheckBeforeBlending(SrcFactor, DestFactor: TBlendingFactor; DestCanvas: TImagingCanvas);
- protected
- FPData: PImageData;
- FClipRect: TRect;
- FPenColorFP: TColorFPRec;
- FPenColor32: TColor32;
- FPenMode: TPenMode;
- FPenWidth: LongInt;
- FFillColorFP: TColorFPRec;
- FFillColor32: TColor32;
- FFillMode: TFillMode;
- FNativeColor: TColorFPRec;
- FFormatInfo: TImageFormatInfo;
-
- { Returns pointer to pixel at given position.}
- function GetPixelPointer(X, Y: LongInt): Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF}
- { Translates given FP color to native format of canvas and stores it
- in FNativeColor field (its bit copy) or user pointer (in overloaded method).}
- procedure TranslateFPToNative(const Color: TColorFPRec); overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
- procedure TranslateFPToNative(const Color: TColorFPRec; Native: Pointer); overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
- { Clipping function used by horizontal and vertical line drawing functions.}
- function ClipAxisParallelLine(var A1, A2, B: LongInt;
- AStart, AStop, BStart, BStop: LongInt): Boolean;
- { Internal horizontal line drawer used mainly for filling inside of objects
- like ellipses and circles.}
- procedure HorzLineInternal(X1, X2, Y: LongInt; Color: Pointer; Bpp: LongInt); virtual;
- procedure CopyPixelInternal(X, Y: LongInt; Pixel: Pointer; Bpp: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
- procedure DrawInternal(const SrcRect: TRect; DestCanvas: TImagingCanvas;
- DestX, DestY: Integer; SrcFactor, DestFactor: TBlendingFactor; PixelWriteProc: TPixelWriteProc);
- procedure StretchDrawInternal(const SrcRect: TRect; DestCanvas: TImagingCanvas;
- const DestRect: TRect; SrcFactor, DestFactor: TBlendingFactor;
- Filter: TResizeFilter; PixelWriteProc: TPixelWriteProc);
- public
- constructor CreateForData(ImageDataPointer: PImageData);
- constructor CreateForImage(Image: TBaseImage);
- destructor Destroy; override;
-
- { Call this method when you change size or format of image this canvas
- operates on (like calling ResizeImage, ConvertImage, or changing Format
- property of TBaseImage descendants).}
- procedure UpdateCanvasState; virtual;
- { Resets clipping rectangle to Rect(0, 0, ImageWidth, ImageHeight).}
- procedure ResetClipRect;
-
- { Clears entire canvas with current fill color (ignores clipping rectangle
- and always uses fmSolid fill mode).}
- procedure Clear;
-
- { Draws horizontal line with current pen settings.}
- procedure HorzLine(X1, X2, Y: LongInt); virtual;
- { Draws vertical line with current pen settings.}
- procedure VertLine(X, Y1, Y2: LongInt); virtual;
- { Draws line from [X1, Y1] to [X2, Y2] with current pen settings.}
- procedure Line(X1, Y1, X2, Y2: LongInt); virtual;
- { Draws a rectangle using current pen settings.}
- procedure FrameRect(const Rect: TRect);
- { Fills given rectangle with current fill settings.}
- procedure FillRect(const Rect: TRect); virtual;
- { Fills given rectangle with current fill settings and pixel blending.}
- procedure FillRectBlend(const Rect: TRect; SrcFactor, DestFactor: TBlendingFactor);
- { Draws rectangle which is outlined by using the current pen settings and
- filled by using the current fill settings.}
- procedure Rectangle(const Rect: TRect);
- { Draws ellipse which is outlined by using the current pen settings and
- filled by using the current fill settings. Rect specifies bounding rectangle
- of ellipse to be drawn.}
- procedure Ellipse(const Rect: TRect);
- { Fills area of canvas with current fill color starting at point [X, Y] and
- coloring its neighbors. Default flood fill mode changes color of all
- neighbors with the same color as pixel [X, Y]. With BoundaryFillMode
- set to True neighbors are recolored regardless of their old color,
- but area which will be recolored has boundary (specified by current pen color).}
- procedure FloodFill(X, Y: Integer; BoundaryFillMode: Boolean = False);
-
- { 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); virtual;
- { 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); virtual;
- { Draws contents of this canvas onto another one using additive blending
- (source and dest factors are bfOne).}
- procedure StretchDrawAdd(const SrcRect: TRect; DestCanvas: TImagingCanvas;
- const DestRect: TRect; Filter: TResizeFilter = rfBilinear);
-
- { Convolves canvas' image with given 3x3 filter kernel. You can use
- predefined filter kernels or define your own.}
- procedure ApplyConvolution3x3(const Filter: TConvolutionFilter3x3);
- { Convolves canvas' image with given 5x5 filter kernel. You can use
- predefined filter kernels or define your own.}
- procedure ApplyConvolution5x5(const Filter: TConvolutionFilter5x5);
- { Computes 2D convolution of canvas' image and given filter kernel.
- Kernel is in row format and KernelSize must be odd number >= 3. Divisor
- is normalizing value based on Kernel (usually sum of all kernel's cells).
- The Bias number shifts each color value by a fixed amount (color values
- are usually in range [0, 1] during processing). If ClampChannels
- is True all output color values are clamped to [0, 1]. You can use
- predefined filter kernels or define your own.}
- procedure ApplyConvolution(Kernel: PLongInt; KernelSize, Divisor: LongInt;
- Bias: Single = 0.0; ClampChannels: Boolean = True); virtual;
-
- { Applies custom non-linear filter. Filter size is diameter of pixel
- neighborhood. Typical values are 3, 5, or 7. }
- procedure ApplyNonLinearFilter(FilterSize: Integer; SelectFunc: TSelectPixelFunction);
- { Applies median non-linear filter with user defined pixel neighborhood.
- Selects median pixel from the neighborhood as new pixel
- (current implementation is quite slow).}
- procedure ApplyMedianFilter(FilterSize: Integer);
- { Applies min non-linear filter with user defined pixel neighborhood.
- Selects min pixel from the neighborhood as new pixel.}
- procedure ApplyMinFilter(FilterSize: Integer);
- { Applies max non-linear filter with user defined pixel neighborhood.
- Selects max pixel from the neighborhood as new pixel.}
- procedure ApplyMaxFilter(FilterSize: Integer);
-
- { Transforms pixels one by one by given function. Pixel neighbors are
- not taken into account. Param 1-3 are optional parameters
- for transform function.}
- procedure PointTransform(Transform: TPointTransformFunction;
- Param1, Param2, Param3: Single);
- { Modifies image contrast and brightness. Parameters should be
- in range <-100; 100>.}
- procedure ModifyContrastBrightness(Contrast, Brightness: Single);
- { Gamma correction of individual color channels. Range is (0, +inf),
- 1.0 means no change.}
- procedure GammaCorection(Red, Green, Blue: Single);
- { Inverts colors of all image pixels, makes negative image. Ignores alpha channel.}
- procedure InvertColors; virtual;
- { Simple single level thresholding with threshold level (in range [0, 1])
- for each color channel.}
- procedure Threshold(Red, Green, Blue: Single);
- { Adjusts the color levels of the image by scaling the
- colors falling between specified white and black points to full [0, 1] range.
- The black point specifies the darkest color in the image, white point
- specifies the lightest color, and mid point is gamma aplied to image.
- Black and white point must be in range [0, 1].}
- procedure AdjustColorLevels(BlackPoint, WhitePoint: Single; MidPoint: Single = 1.0);
- { Premultiplies color channel values by alpha. Needed for some platforms/APIs
- to display images with alpha properly.}
- procedure PremultiplyAlpha;
- { Reverses PremultiplyAlpha operation.}
- procedure UnPremultiplyAlpha;
-
- { Calculates image histogram for each channel and also gray values. Each
- channel has 256 values available. Channel values of data formats with higher
- precision are scaled and rounded. Example: Red[126] specifies number of pixels
- in image with red channel = 126.}
- procedure GetHistogram(out Red, Green, Blue, Alpha, Gray: THistogramArray);
- { Fills image channel with given value leaving other channels intact.
- Use ChannelAlpha, ChannelRed, etc. constants from ImagingTypes as
- channel identifier.}
- procedure FillChannel(ChannelId: Integer; NewChannelValue: Byte); overload;
- { Fills image channel with given value leaving other channels intact.
- Use ChannelAlpha, ChannelRed, etc. constants from ImagingTypes as
- channel identifier.}
- procedure FillChannelFP(ChannelId: Integer; NewChannelValue: Single); overload;
-
- { Color used when drawing lines, frames, and outlines of objects.}
- property PenColor32: TColor32 read FPenColor32 write SetPenColor32;
- { Color used when drawing lines, frames, and outlines of objects.}
- property PenColorFP: TColorFPRec read FPenColorFP write SetPenColorFP;
- { Pen mode used when drawing lines, object outlines, and similar on canvas.}
- property PenMode: TPenMode read FPenMode write FPenMode;
- { Width with which objects like lines, frames, etc. (everything which uses
- PenColor) are drawn.}
- property PenWidth: LongInt read FPenWidth write SetPenWidth;
- { Color used for filling when drawing various objects.}
- property FillColor32: TColor32 read FFillColor32 write SetFillColor32;
- { Color used for filling when drawing various objects.}
- property FillColorFP: TColorFPRec read FFillColorFP write SetFillColorFP;
- { Fill mode used when drawing filled objects on canvas.}
- property FillMode: TFillMode read FFillMode write FFillMode;
- { Specifies the current color of the pixels of canvas. Native pixel is
- read from canvas and then translated to 32bit ARGB. Reverse operation
- is made when setting pixel color.}
- property Pixels32[X, Y: LongInt]: TColor32 read GetPixel32 write SetPixel32;
- { Specifies the current color of the pixels of canvas. Native pixel is
- read from canvas and then translated to FP ARGB. Reverse operation
- is made when setting pixel color.}
- property PixelsFP[X, Y: LongInt]: TColorFPRec read GetPixelFP write SetPixelFP;
- { Clipping rectangle of this canvas. No pixels outside this rectangle are
- altered by canvas methods if Clipping property is True. Clip rect gets
- reseted when UpdateCanvasState is called.}
- property ClipRect: TRect read FClipRect write SetClipRect;
- { Extended format information.}
- property FormatInfo: TImageFormatInfo read FFormatInfo;
- { Indicates that this canvas is in valid state. If False canvas oprations
- may crash.}
- property Valid: Boolean read GetValid;
-
- { Returns all formats supported by this canvas class.}
- class function GetSupportedFormats: TImageFormats; virtual;
- end;
-
- TImagingCanvasClass = class of TImagingCanvas;
-
- TScanlineArray = array[0..MaxInt div SizeOf(Pointer) - 1] of PColor32RecArray;
- PScanlineArray = ^TScanlineArray;
-
- { Fast canvas class for ifA8R8G8B8 format images.}
- TFastARGB32Canvas = class(TImagingCanvas)
- protected
- FScanlines: PScanlineArray;
- procedure AlphaBlendPixels(SrcPix, DestPix: PColor32Rec); {$IFDEF USE_INLINE}inline;{$ENDIF}
- function GetPixel32(X, Y: LongInt): TColor32; override;
- procedure SetPixel32(X, Y: LongInt; const Value: TColor32); override;
- public
- destructor Destroy; override;
-
- procedure UpdateCanvasState; override;
-
- procedure DrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: Integer); override;
- procedure StretchDrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas;
- const DestRect: TRect; Filter: TResizeFilter = rfBilinear); override;
- procedure InvertColors; override;
-
- property Scanlines: PScanlineArray read FScanlines;
-
- class function GetSupportedFormats: TImageFormats; override;
- end;
-
-const
- { Kernel for 3x3 average smoothing filter.}
- FilterAverage3x3: TConvolutionFilter3x3 = (
- Kernel: ((1, 1, 1),
- (1, 1, 1),
- (1, 1, 1));
- Divisor: 9);
-
- { Kernel for 5x5 average smoothing filter.}
- FilterAverage5x5: TConvolutionFilter5x5 = (
- Kernel: ((1, 1, 1, 1, 1),
- (1, 1, 1, 1, 1),
- (1, 1, 1, 1, 1),
- (1, 1, 1, 1, 1),
- (1, 1, 1, 1, 1));
- Divisor: 25);
-
- { Kernel for 3x3 Gaussian smoothing filter.}
- FilterGaussian3x3: TConvolutionFilter3x3 = (
- Kernel: ((1, 2, 1),
- (2, 4, 2),
- (1, 2, 1));
- Divisor: 16);
-
- { Kernel for 5x5 Gaussian smoothing filter.}
- FilterGaussian5x5: TConvolutionFilter5x5 = (
- Kernel: ((1, 4, 6, 4, 1),
- (4, 16, 24, 16, 4),
- (6, 24, 36, 24, 6),
- (4, 16, 24, 16, 4),
- (1, 4, 6, 4, 1));
- Divisor: 256);
-
- { Kernel for 3x3 Sobel horizontal edge detection filter (1st derivative approximation).}
- FilterSobelHorz3x3: TConvolutionFilter3x3 = (
- Kernel: (( 1, 2, 1),
- ( 0, 0, 0),
- (-1, -2, -1));
- Divisor: 1);
-
- { Kernel for 3x3 Sobel vertical edge detection filter (1st derivative approximation).}
- FilterSobelVert3x3: TConvolutionFilter3x3 = (
- Kernel: ((-1, 0, 1),
- (-2, 0, 2),
- (-1, 0, 1));
- Divisor: 1);
-
- { Kernel for 3x3 Prewitt horizontal edge detection filter.}
- FilterPrewittHorz3x3: TConvolutionFilter3x3 = (
- Kernel: (( 1, 1, 1),
- ( 0, 0, 0),
- (-1, -1, -1));
- Divisor: 1);
-
- { Kernel for 3x3 Prewitt vertical edge detection filter.}
- FilterPrewittVert3x3: TConvolutionFilter3x3 = (
- Kernel: ((-1, 0, 1),
- (-1, 0, 1),
- (-1, 0, 1));
- Divisor: 1);
-
- { Kernel for 3x3 Kirsh horizontal edge detection filter.}
- FilterKirshHorz3x3: TConvolutionFilter3x3 = (
- Kernel: (( 5, 5, 5),
- (-3, 0, -3),
- (-3, -3, -3));
- Divisor: 1);
-
- { Kernel for 3x3 Kirsh vertical edge detection filter.}
- FilterKirshVert3x3: TConvolutionFilter3x3 = (
- Kernel: ((5, -3, -3),
- (5, 0, -3),
- (5, -3, -3));
- Divisor: 1);
-
- { Kernel for 3x3 Laplace omni-directional edge detection filter
- (2nd derivative approximation).}
- FilterLaplace3x3: TConvolutionFilter3x3 = (
- Kernel: ((-1, -1, -1),
- (-1, 8, -1),
- (-1, -1, -1));
- Divisor: 1);
-
- { Kernel for 5x5 Laplace omni-directional edge detection filter
- (2nd derivative approximation).}
- FilterLaplace5x5: TConvolutionFilter5x5 = (
- Kernel: ((-1, -1, -1, -1, -1),
- (-1, -1, -1, -1, -1),
- (-1, -1, 24, -1, -1),
- (-1, -1, -1, -1, -1),
- (-1, -1, -1, -1, -1));
- Divisor: 1);
-
- { Kernel for 3x3 spharpening filter (Laplacian + original color).}
- FilterSharpen3x3: TConvolutionFilter3x3 = (
- Kernel: ((-1, -1, -1),
- (-1, 9, -1),
- (-1, -1, -1));
- Divisor: 1);
-
- { Kernel for 5x5 spharpening filter (Laplacian + original color).}
- FilterSharpen5x5: TConvolutionFilter5x5 = (
- Kernel: ((-1, -1, -1, -1, -1),
- (-1, -1, -1, -1, -1),
- (-1, -1, 25, -1, -1),
- (-1, -1, -1, -1, -1),
- (-1, -1, -1, -1, -1));
- Divisor: 1);
-
- { Kernel for 5x5 glow filter.}
- FilterGlow5x5: TConvolutionFilter5x5 = (
- Kernel: (( 1, 2, 2, 2, 1),
- ( 2, 0, 0, 0, 2),
- ( 2, 0, -20, 0, 2),
- ( 2, 0, 0, 0, 2),
- ( 1, 2, 2, 2, 1));
- Divisor: 8);
-
- { Kernel for 3x3 edge enhancement filter.}
- FilterEdgeEnhance3x3: TConvolutionFilter3x3 = (
- Kernel: ((-1, -2, -1),
- (-2, 16, -2),
- (-1, -2, -1));
- Divisor: 4);
-
- { Kernel for 3x3 contour enhancement filter.}
- FilterTraceControur3x3: TConvolutionFilter3x3 = (
- Kernel: ((-6, -6, -2),
- (-1, 32, -1),
- (-6, -2, -6));
- Divisor: 4;
- Bias: 240/255);
-
- { Kernel for filter that negates all images pixels.}
- FilterNegative3x3: TConvolutionFilter3x3 = (
- Kernel: ((0, 0, 0),
- (0, -1, 0),
- (0, 0, 0));
- Divisor: 1;
- Bias: 1);
-
- { Kernel for 3x3 horz/vert embossing filter.}
- FilterEmboss3x3: TConvolutionFilter3x3 = (
- Kernel: ((2, 0, 0),
- (0, -1, 0),
- (0, 0, -1));
- Divisor: 1;
- Bias: 0.5);
-
-
-{ You can register your own canvas class. List of registered canvases is used
- by FindBestCanvasForImage functions to find best canvas for given image.
- If two different canvases which support the same image data format are
- registered then the one that was registered later is returned (so you can
- override builtin Imaging canvases).}
-procedure RegisterCanvas(CanvasClass: TImagingCanvasClass);
-{ Returns best canvas for given TImageFormat.}
-function FindBestCanvasForImage(ImageFormat: TImageFormat): TImagingCanvasClass; overload;
-{ Returns best canvas for given TImageData.}
-function FindBestCanvasForImage(const ImageData: TImageData): TImagingCanvasClass; overload;
-{ Returns best canvas for given TBaseImage.}
-function FindBestCanvasForImage(Image: TBaseImage): TImagingCanvasClass; overload;
-
-implementation
-
-resourcestring
- SConstructorInvalidPointer = 'Invalid pointer (%p) to TImageData passed to TImagingCanvas constructor.';
- SConstructorInvalidImage = 'Invalid image data passed to TImagingCanvas constructor (%s).';
- SConstructorUnsupportedFormat = 'Image passed to TImagingCanvas constructor is in unsupported format (%s)';
-
-var
- // list with all registered TImagingCanvas classes
- CanvasClasses: TList = nil;
-
-procedure RegisterCanvas(CanvasClass: TImagingCanvasClass);
-begin
- Assert(CanvasClass <> nil);
- if CanvasClasses = nil then
- CanvasClasses := TList.Create;
- if CanvasClasses.IndexOf(CanvasClass) < 0 then
- CanvasClasses.Add(CanvasClass);
-end;
-
-function FindBestCanvasForImage(ImageFormat: TImageFormat): TImagingCanvasClass; overload;
-var
- I: LongInt;
-begin
- for I := CanvasClasses.Count - 1 downto 0 do
- begin
- if ImageFormat in TImagingCanvasClass(CanvasClasses[I]).GetSupportedFormats then
- begin
- Result := TImagingCanvasClass(CanvasClasses[I]);
- Exit;
- end;
- end;
- Result := TImagingCanvas;
-end;
-
-function FindBestCanvasForImage(const ImageData: TImageData): TImagingCanvasClass;
-begin
- Result := FindBestCanvasForImage(ImageData.Format);
-end;
-
-function FindBestCanvasForImage(Image: TBaseImage): TImagingCanvasClass;
-begin
- Result := FindBestCanvasForImage(Image.Format);
-end;
-
-{ 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;
- SrcAlpha, DestAlpha: Single;
-begin
- DestPix := DestInfo.GetPixelFP(DestPtr, DestInfo, nil);
- // Blend the two pixels (Src 'over' Dest alpha composition operation)
- DestPix.A := SrcPix.A + DestPix.A - SrcPix.A * DestPix.A;
- SrcAlpha := IffFloat(DestPix.A = 0, 0, SrcPix.A / DestPix.A);
- DestAlpha := 1.0 - SrcAlpha;
- DestPix.R := SrcPix.R * SrcAlpha + DestPix.R * DestAlpha;
- DestPix.G := SrcPix.G * SrcAlpha + DestPix.G * DestAlpha;
- DestPix.B := SrcPix.B * SrcAlpha + DestPix.B * DestAlpha;
- // 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, P3: 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; P1, P2, P3: 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;
-
-function TransformLevels(const Pixel: TColorFPRec; BlackPoint, WhitePoint, Exp: Single): TColorFPRec;
-begin
- Result.A := Pixel.A;
- if Pixel.R > BlackPoint then
- Result.R := Power((Pixel.R - BlackPoint) / (WhitePoint - BlackPoint), Exp)
- else
- Result.R := 0.0;
- if Pixel.G > BlackPoint then
- Result.G := Power((Pixel.G - BlackPoint) / (WhitePoint - BlackPoint), Exp)
- else
- Result.G := 0.0;
- if Pixel.B > BlackPoint then
- Result.B := Power((Pixel.B - BlackPoint) / (WhitePoint - BlackPoint), Exp)
- else
- Result.B := 0.0;
-end;
-
-function TransformPremultiplyAlpha(const Pixel: TColorFPRec; P1, P2, P3: Single): TColorFPRec;
-begin
- Result.A := Pixel.A;
- Result.R := Result.R * Pixel.A;
- Result.G := Result.G * Pixel.A;
- Result.B := Result.B * Pixel.A;
-end;
-
-function TransformUnPremultiplyAlpha(const Pixel: TColorFPRec; P1, P2, P3: Single): TColorFPRec;
-begin
- Result.A := Pixel.A;
- if Pixel.A <> 0.0 then
- begin
- Result.R := Result.R / Pixel.A;
- Result.G := Result.G / Pixel.A;
- Result.B := Result.B / Pixel.A;
- end
- else
- begin
- Result.R := 0;
- Result.G := 0;
- Result.B := 0;
- end;
-end;
-
-
-{ TImagingCanvas class implementation }
-
-constructor TImagingCanvas.CreateForData(ImageDataPointer: PImageData);
-begin
- if ImageDataPointer = nil then
- raise EImagingCanvasError.CreateFmt(SConstructorInvalidPointer, [ImageDataPointer]);
-
- if not TestImage(ImageDataPointer^) then
- raise EImagingCanvasError.CreateFmt(SConstructorInvalidImage, [Imaging.ImageToStr(ImageDataPointer^)]);
-
- if not (ImageDataPointer.Format in GetSupportedFormats) then
- raise EImagingCanvasError.CreateFmt(SConstructorUnsupportedFormat, [Imaging.ImageToStr(ImageDataPointer^)]);
-
- FPData := ImageDataPointer;
- FPenWidth := 1;
- SetPenColor32(pcWhite);
- SetFillColor32(pcBlack);
- FFillMode := fmSolid;
-
- UpdateCanvasState;
-end;
-
-constructor TImagingCanvas.CreateForImage(Image: TBaseImage);
-begin
- CreateForData(Image.ImageDataPointer);
-end;
-
-destructor TImagingCanvas.Destroy;
-begin
- inherited Destroy;
-end;
-
-function TImagingCanvas.GetPixel32(X, Y: LongInt): TColor32;
-begin
- Result := Imaging.GetPixel32(FPData^, X, Y).Color;
-end;
-
-function TImagingCanvas.GetPixelFP(X, Y: LongInt): TColorFPRec;
-begin
- Result := Imaging.GetPixelFP(FPData^, X, Y);
-end;
-
-function TImagingCanvas.GetValid: Boolean;
-begin
- Result := (FPData <> nil) and (FDataSizeOnUpdate = FPData.Size);
-end;
-
-procedure TImagingCanvas.SetPixel32(X, Y: LongInt; const Value: TColor32);
-begin
- if (X >= FClipRect.Left) and (Y >= FClipRect.Top) and
- (X < FClipRect.Right) and (Y < FClipRect.Bottom) then
- begin
- Imaging.SetPixel32(FPData^, X, Y, TColor32Rec(Value));
- end;
-end;
-
-procedure TImagingCanvas.SetPixelFP(X, Y: LongInt; const Value: TColorFPRec);
-begin
- if (X >= FClipRect.Left) and (Y >= FClipRect.Top) and
- (X < FClipRect.Right) and (Y < FClipRect.Bottom) then
- begin
- Imaging.SetPixelFP(FPData^, X, Y, TColorFPRec(Value));
- end;
-end;
-
-procedure TImagingCanvas.SetPenColor32(const Value: TColor32);
-begin
- FPenColor32 := Value;
- TranslatePixel(@FPenColor32, @FPenColorFP, ifA8R8G8B8, ifA32R32G32B32F, nil, nil);
-end;
-
-procedure TImagingCanvas.SetPenColorFP(const Value: TColorFPRec);
-begin
- FPenColorFP := Value;
- TranslatePixel(@FPenColorFP, @FPenColor32, ifA32R32G32B32F, ifA8R8G8B8, nil, nil);
-end;
-
-procedure TImagingCanvas.SetPenWidth(const Value: LongInt);
-begin
- FPenWidth := ClampInt(Value, 0, MaxPenWidth);
-end;
-
-procedure TImagingCanvas.SetFillColor32(const Value: TColor32);
-begin
- FFillColor32 := Value;
- TranslatePixel(@FFillColor32, @FFillColorFP, ifA8R8G8B8, ifA32R32G32B32F, nil, nil);
-end;
-
-procedure TImagingCanvas.SetFillColorFP(const Value: TColorFPRec);
-begin
- FFillColorFP := Value;
- TranslatePixel(@FFillColorFP, @FFillColor32, ifA32R32G32B32F, ifA8R8G8B8, nil, nil);
-end;
-
-procedure TImagingCanvas.SetClipRect(const Value: TRect);
-begin
- FClipRect := Value;
- SwapMin(FClipRect.Left, FClipRect.Right);
- SwapMin(FClipRect.Top, FClipRect.Bottom);
- IntersectRect(FClipRect, FClipRect, Rect(0, 0, FPData.Width, FPData.Height));
-end;
-
-procedure TImagingCanvas.CheckBeforeBlending(SrcFactor,
- DestFactor: TBlendingFactor; DestCanvas: TImagingCanvas);
-begin
- if SrcFactor in [bfSrcColor, bfOneMinusSrcColor] then
- raise EImagingCanvasBlendingError.Create('Invalid source blending factor. Check the documentation for TBlendingFactor.');
- if DestFactor in [bfDstColor, bfOneMinusDstColor] then
- raise EImagingCanvasBlendingError.Create('Invalid destination blending factor. Check the documentation for TBlendingFactor.');
- if DestCanvas.FormatInfo.IsIndexed then
- raise EImagingCanvasBlendingError.Create('Blending destination canvas cannot be in indexed mode.');
-end;
-
-function TImagingCanvas.GetPixelPointer(X, Y: LongInt): Pointer;
-begin
- Result := @PByteArray(FPData.Bits)[(Y * FPData.Width + X) * FFormatInfo.BytesPerPixel]
-end;
-
-procedure TImagingCanvas.TranslateFPToNative(const Color: TColorFPRec);
-begin
- TranslateFPToNative(Color, @FNativeColor);
-end;
-
-procedure TImagingCanvas.TranslateFPToNative(const Color: TColorFPRec;
- Native: Pointer);
-begin
- ImagingFormats.TranslatePixel(@Color, Native, ifA32R32G32B32F,
- FPData.Format, nil, FPData.Palette);
-end;
-
-procedure TImagingCanvas.UpdateCanvasState;
-begin
- FDataSizeOnUpdate := FPData.Size;
- ResetClipRect;
- Imaging.GetImageFormatInfo(FPData.Format, FFormatInfo)
-end;
-
-procedure TImagingCanvas.ResetClipRect;
-begin
- FClipRect := Rect(0, 0, FPData.Width, FPData.Height)
-end;
-
-procedure TImagingCanvas.Clear;
-begin
- TranslateFPToNative(FFillColorFP);
- Imaging.FillRect(FPData^, 0, 0, FPData.Width, FPData.Height, @FNativeColor);
-end;
-
-function TImagingCanvas.ClipAxisParallelLine(var A1, A2, B: LongInt;
- AStart, AStop, BStart, BStop: LongInt): Boolean;
-begin
- if (B >= BStart) and (B < BStop) then
- begin
- SwapMin(A1, A2);
- if A1 < AStart then A1 := AStart;
- if A2 >= AStop then A2 := AStop - 1;
- Result := True;
- end
- else
- Result := False;
-end;
-
-procedure TImagingCanvas.HorzLineInternal(X1, X2, Y: LongInt; Color: Pointer;
- Bpp: LongInt);
-var
- I, WidthBytes: LongInt;
- PixelPtr: PByte;
-begin
- if (Y >= FClipRect.Top) and (Y < FClipRect.Bottom) then
- begin
- SwapMin(X1, X2);
- X1 := Max(X1, FClipRect.Left);
- X2 := Min(X2, FClipRect.Right);
- PixelPtr := GetPixelPointer(X1, Y);
- WidthBytes := (X2 - X1) * Bpp;
- case Bpp of
- 1: FillMemoryByte(PixelPtr, WidthBytes, PByte(Color)^);
- 2: FillMemoryWord(PixelPtr, WidthBytes, PWord(Color)^);
- 4: FillMemoryLongWord(PixelPtr, WidthBytes, PLongWord(Color)^);
- else
- for I := X1 to X2 do
- begin
- ImagingFormats.CopyPixel(Color, PixelPtr, Bpp);
- Inc(PixelPtr, Bpp);
- end;
- end;
- end;
-end;
-
-procedure TImagingCanvas.CopyPixelInternal(X, Y: LongInt; Pixel: Pointer;
- Bpp: LongInt);
-begin
- if (X >= FClipRect.Left) and (Y >= FClipRect.Top) and
- (X < FClipRect.Right) and (Y < FClipRect.Bottom) then
- begin
- ImagingFormats.CopyPixel(Pixel, GetPixelPointer(X, Y), Bpp);
- end;
-end;
-
-procedure TImagingCanvas.HorzLine(X1, X2, Y: LongInt);
-var
- DstRect: TRect;
-begin
- if FPenMode = pmClear then Exit;
- SwapMin(X1, X2);
- if IntersectRect(DstRect, Rect(X1, Y - FPenWidth div 2, X2,
- Y + FPenWidth div 2 + FPenWidth mod 2), FClipRect) then
- begin
- TranslateFPToNative(FPenColorFP);
- Imaging.FillRect(FPData^, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left,
- DstRect.Bottom - DstRect.Top, @FNativeColor);
- end;
-end;
-
-procedure TImagingCanvas.VertLine(X, Y1, Y2: LongInt);
-var
- DstRect: TRect;
-begin
- if FPenMode = pmClear then Exit;
- SwapMin(Y1, Y2);
- if IntersectRect(DstRect, Rect(X - FPenWidth div 2, Y1,
- X + FPenWidth div 2 + FPenWidth mod 2, Y2), FClipRect) then
- begin
- TranslateFPToNative(FPenColorFP);
- Imaging.FillRect(FPData^, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left,
- DstRect.Bottom - DstRect.Top, @FNativeColor);
- end;
-end;
-
-procedure TImagingCanvas.Line(X1, Y1, X2, Y2: LongInt);
-var
- Steep: Boolean;
- Error, YStep, DeltaX, DeltaY, X, Y, I, Bpp, W1, W2, Code1, Code2: LongInt;
-begin
- if FPenMode = pmClear then Exit;
-
- // If line is vertical or horizontal just call appropriate method
- if X2 - X1 = 0 then
- begin
- HorzLine(X1, X2, Y1);
- Exit;
- end;
- if Y2 - Y1 = 0 then
- begin
- VertLine(X1, Y1, Y2);
- Exit;
- end;
-
- // Determine if line is steep (angle with X-axis > 45 degrees)
- Steep := Abs(Y2 - Y1) > Abs(X2 - X1);
-
- // If we need to draw thick line we just draw more 1 pixel lines around
- // the one we already drawn. Setting FLineRecursion assures that we
- // won't be doing recursions till the end of the world.
- if (FPenWidth > 1) and not FLineRecursion then
- begin
- FLineRecursion := True;
- W1 := FPenWidth div 2;
- W2 := W1;
- if FPenWidth mod 2 = 0 then
- Dec(W1);
- if Steep then
- begin
- // Add lines left/right
- for I := 1 to W1 do
- Line(X1, Y1 - I, X2, Y2 - I);
- for I := 1 to W2 do
- Line(X1, Y1 + I, X2, Y2 + I);
- end
- else
- begin
- // Add lines above/under
- for I := 1 to W1 do
- Line(X1 - I, Y1, X2 - I, Y2);
- for I := 1 to W2 do
- Line(X1 + I, Y1, X2 + I, Y2);
- end;
- FLineRecursion := False;
- end;
-
- with FClipRect do
- begin
- // Use part of Cohen-Sutherland line clipping to determine if any part of line
- // is in ClipRect
- Code1 := Ord(X1 < Left) + Ord(X1 > Right) shl 1 + Ord(Y1 < Top) shl 2 + Ord(Y1 > Bottom) shl 3;
- Code2 := Ord(X2 < Left) + Ord(X2 > Right) shl 1 + Ord(Y2 < Top) shl 2 + Ord(Y2 > Bottom) shl 3;
- end;
-
- if (Code1 and Code2) = 0 then
- begin
- TranslateFPToNative(FPenColorFP);
- Bpp := FFormatInfo.BytesPerPixel;
-
- // If line is steep swap X and Y coordinates so later we just have one loop
- // of two (where only one is used according to steepness).
- if Steep then
- begin
- SwapValues(X1, Y1);
- SwapValues(X2, Y2);
- end;
- if X1 > X2 then
- begin
- SwapValues(X1, X2);
- SwapValues(Y1, Y2);
- end;
-
- DeltaX := X2 - X1;
- DeltaY := Abs(Y2 - Y1);
- YStep := Iff(Y2 > Y1, 1, -1);
- Error := 0;
- Y := Y1;
-
- // Draw line using Bresenham algorithm. No real line clipping here,
- // just don't draw pixels outsize clip rect.
- for X := X1 to X2 do
- begin
- if Steep then
- CopyPixelInternal(Y, X, @FNativeColor, Bpp)
- else
- CopyPixelInternal(X, Y, @FNativeColor, Bpp);
- Error := Error + DeltaY;
- if Error * 2 >= DeltaX then
- begin
- Inc(Y, YStep);
- Dec(Error, DeltaX);
- end;
- end;
- end;
-end;
-
-procedure TImagingCanvas.FrameRect(const Rect: TRect);
-var
- HalfPen, PenMod: LongInt;
-begin
- if FPenMode = pmClear then Exit;
- HalfPen := FPenWidth div 2;
- PenMod := FPenWidth mod 2;
- HorzLine(Rect.Left - HalfPen, Rect.Right + HalfPen + PenMod - 1, Rect.Top);
- HorzLine(Rect.Left - HalfPen, Rect.Right + HalfPen + PenMod - 1, Rect.Bottom - 1);
- VertLine(Rect.Left, Rect.Top, Rect.Bottom);
- VertLine(Rect.Right - 1, Rect.Top, Rect.Bottom);
-end;
-
-procedure TImagingCanvas.FillRect(const Rect: TRect);
-var
- DstRect: TRect;
-begin
- if (FFillMode <> fmClear) and IntersectRect(DstRect, Rect, FClipRect) then
- begin
- TranslateFPToNative(FFillColorFP);
- Imaging.FillRect(FPData^, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left,
- DstRect.Bottom - DstRect.Top, @FNativeColor);
- end;
-end;
-
-procedure TImagingCanvas.FillRectBlend(const Rect: TRect; SrcFactor,
- DestFactor: TBlendingFactor);
-var
- DstRect: TRect;
- X, Y: Integer;
- Line: PByte;
-begin
- if (FFillMode <> fmClear) and IntersectRect(DstRect, Rect, FClipRect) then
- begin
- CheckBeforeBlending(SrcFactor, DestFactor, Self);
- for Y := DstRect.Top to DstRect.Bottom - 1 do
- begin
- Line := @PByteArray(FPData.Bits)[(Y * FPData.Width + DstRect.Left) * FFormatInfo.BytesPerPixel];
- for X := DstRect.Left to DstRect.Right - 1 do
- begin
- PixelBlendProc(FFillColorFP, Line, @FFormatInfo, SrcFactor, DestFactor);
- Inc(Line, FFormatInfo.BytesPerPixel);
- end;
- end;
- end;
-end;
-
-procedure TImagingCanvas.Rectangle(const Rect: TRect);
-begin
- FillRect(Rect);
- FrameRect(Rect);
-end;
-
-procedure TImagingCanvas.Ellipse(const Rect: TRect);
-var
- RadX, RadY, DeltaX, DeltaY, R, RX, RY: LongInt;
- X1, X2, Y1, Y2, Bpp, OldY: LongInt;
- Fill, Pen: TColorFPRec;
-begin
- // TODO: Use PenWidth
- X1 := Rect.Left;
- X2 := Rect.Right;
- Y1 := Rect.Top;
- Y2 := Rect.Bottom;
-
- TranslateFPToNative(FPenColorFP, @Pen);
- TranslateFPToNative(FFillColorFP, @Fill);
- Bpp := FFormatInfo.BytesPerPixel;
-
- SwapMin(X1, X2);
- SwapMin(Y1, Y2);
-
- RadX := (X2 - X1) div 2;
- RadY := (Y2 - Y1) div 2;
-
- Y1 := Y1 + RadY;
- Y2 := Y1;
- OldY := Y1;
-
- DeltaX := (RadX * RadX);
- DeltaY := (RadY * RadY);
- R := RadX * RadY * RadY;
- RX := R;
- RY := 0;
-
- if (FFillMode <> fmClear) then
- HorzLineInternal(X1, X2, Y1, @Fill, Bpp);
- CopyPixelInternal(X1, Y1, @Pen, Bpp);
- CopyPixelInternal(X2, Y1, @Pen, Bpp);
-
- while RadX > 0 do
- begin
- if R > 0 then
- begin
- Inc(Y1);
- Dec(Y2);
- Inc(RY, DeltaX);
- Dec(R, RY);
- end;
- if R <= 0 then
- begin
- Dec(RadX);
- Inc(X1);
- Dec(X2);
- Dec(RX, DeltaY);
- Inc(R, RX);
- end;
-
- if (OldY <> Y1) and (FFillMode <> fmClear) then
- begin
- HorzLineInternal(X1, X2, Y1, @Fill, Bpp);
- HorzLineInternal(X1, X2, Y2, @Fill, Bpp);
- end;
- OldY := Y1;
-
- CopyPixelInternal(X1, Y1, @Pen, Bpp);
- CopyPixelInternal(X2, Y1, @Pen, Bpp);
- CopyPixelInternal(X1, Y2, @Pen, Bpp);
- CopyPixelInternal(X2, Y2, @Pen, Bpp);
- end;
-end;
-
-procedure TImagingCanvas.FloodFill(X, Y: Integer; BoundaryFillMode: Boolean);
-var
- Stack: array of TPoint;
- StackPos, Y1: Integer;
- OldColor: TColor32;
- SpanLeft, SpanRight: Boolean;
-
- procedure Push(AX, AY: Integer);
- begin
- if StackPos < High(Stack) then
- begin
- Inc(StackPos);
- Stack[StackPos].X := AX;
- Stack[StackPos].Y := AY;
- end
- else
- begin
- SetLength(Stack, Length(Stack) + FPData.Width);
- Push(AX, AY);
- end;
- end;
-
- function Pop(out AX, AY: Integer): Boolean;
- begin
- if StackPos > 0 then
- begin
- AX := Stack[StackPos].X;
- AY := Stack[StackPos].Y;
- Dec(StackPos);
- Result := True;
- end
- else
- Result := False;
- end;
-
- function Compare(AX, AY: Integer): Boolean;
- var
- Color: TColor32;
- begin
- Color := GetPixel32(AX, AY);
- if BoundaryFillMode then
- Result := (Color <> FFillColor32) and (Color <> FPenColor32)
- else
- Result := Color = OldColor;
- end;
-
-begin
- // Scanline Floodfill Algorithm With Stack
- // http://student.kuleuven.be/~m0216922/CG/floodfill.html
-
- if not PtInRect(FClipRect, Point(X, Y)) then Exit;
-
- SetLength(Stack, FPData.Width * 4);
- StackPos := 0;
-
- OldColor := GetPixel32(X, Y);
-
- Push(X, Y);
-
- while Pop(X, Y) do
- begin
- Y1 := Y;
- while (Y1 >= FClipRect.Top) and Compare(X, Y1) do
- Dec(Y1);
-
- Inc(Y1);
- SpanLeft := False;
- SpanRight := False;
-
- while (Y1 < FClipRect.Bottom) and Compare(X, Y1) do
- begin
- SetPixel32(X, Y1, FFillColor32);
- if not SpanLeft and (X > FClipRect.Left) and Compare(X - 1, Y1) then
- begin
- Push(X - 1, Y1);
- SpanLeft := True;
- end
- else if SpanLeft and (X > FClipRect.Left) and not Compare(X - 1, Y1) then
- SpanLeft := False
- else if not SpanRight and (X < FClipRect.Right - 1) and Compare(X + 1, Y1)then
- begin
- Push(X + 1, Y1);
- SpanRight := True;
- end
- else if SpanRight and (X < FClipRect.Right - 1) and not Compare(X + 1, Y1) then
- SpanRight := False;
-
- Inc(Y1);
- 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,
- Divisor: LongInt; Bias: Single; ClampChannels: Boolean);
-var
- X, Y, I, J, PosY, PosX, SizeDiv2, KernelValue, WidthBytes, Bpp: LongInt;
- R, G, B, DivFloat: Single;
- Pixel: TColorFPRec;
- TempImage: TImageData;
- DstPointer, SrcPointer: PByte;
-begin
- SizeDiv2 := KernelSize div 2;
- DivFloat := IffFloat(Divisor > 1, 1.0 / Divisor, 1.0);
- Bpp := FFormatInfo.BytesPerPixel;
- WidthBytes := FPData.Width * Bpp;
-
- 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
- // Reset accumulators
- R := 0.0;
- G := 0.0;
- B := 0.0;
-
- for J := 0 to KernelSize - 1 do
- begin
- PosY := ClampInt(Y + J - SizeDiv2, FClipRect.Top, FClipRect.Bottom - 1);
-
- for I := 0 to KernelSize - 1 do
- begin
- PosX := ClampInt(X + I - SizeDiv2, FClipRect.Left, FClipRect.Right - 1);
- SrcPointer := @PByteArray(TempImage.Bits)[PosY * WidthBytes + PosX * Bpp];
-
- // Get pixels from neighbourhood of current pixel and add their
- // colors to accumulators weighted by filter kernel values
- Pixel := FFormatInfo.GetPixelFP(SrcPointer, @FFormatInfo, TempImage.Palette);
- KernelValue := PLongIntArray(Kernel)[J * KernelSize + I];
-
- R := R + Pixel.R * KernelValue;
- G := G + Pixel.G * KernelValue;
- B := B + Pixel.B * KernelValue;
- end;
- end;
-
- Pixel := FFormatInfo.GetPixelFP(DstPointer, @FFormatInfo, FPData.Palette);
-
- Pixel.R := R * DivFloat + Bias;
- Pixel.G := G * DivFloat + Bias;
- Pixel.B := B * DivFloat + Bias;
-
- if ClampChannels then
- ClampFloatPixel(Pixel);
-
- // Set resulting pixel color
- FFormatInfo.SetPixelFP(DstPointer, @FFormatInfo, FPData.Palette, Pixel);
-
- Inc(DstPointer, Bpp);
- end;
- end;
-
- finally
- FreeImage(TempImage);
- end;
-end;
-
-procedure TImagingCanvas.ApplyConvolution3x3(const Filter: TConvolutionFilter3x3);
-begin
- ApplyConvolution(@Filter.Kernel, 3, Filter.Divisor, Filter.Bias, True);
-end;
-
-procedure TImagingCanvas.ApplyConvolution5x5(const Filter: TConvolutionFilter5x5);
-begin
- ApplyConvolution(@Filter.Kernel, 5, Filter.Divisor, Filter.Bias, True);
-end;
-
-procedure TImagingCanvas.ApplyNonLinearFilter(FilterSize: Integer; SelectFunc: TSelectPixelFunction);
-var
- X, Y, I, J, PosY, PosX, SizeDiv2, WidthBytes, Bpp: LongInt;
- Pixel: TColorFPRec;
- TempImage: TImageData;
- DstPointer, SrcPointer: PByte;
- NeighPixels: TDynFPPixelArray;
-begin
- SizeDiv2 := FilterSize div 2;
- Bpp := FFormatInfo.BytesPerPixel;
- WidthBytes := FPData.Width * Bpp;
- SetLength(NeighPixels, FilterSize * FilterSize);
-
- InitImage(TempImage);
- CloneImage(FPData^, TempImage);
-
- try
- // For every pixel in clip rect
- for Y := FClipRect.Top to FClipRect.Bottom - 1 do
- begin
- DstPointer := @PByteArray(FPData.Bits)[Y * WidthBytes + FClipRect.Left * Bpp];
-
- for X := FClipRect.Left to FClipRect.Right - 1 do
- begin
- for J := 0 to FilterSize - 1 do
- begin
- PosY := ClampInt(Y + J - SizeDiv2, FClipRect.Top, FClipRect.Bottom - 1);
-
- for I := 0 to FilterSize - 1 do
- begin
- PosX := ClampInt(X + I - SizeDiv2, FClipRect.Left, FClipRect.Right - 1);
- SrcPointer := @PByteArray(TempImage.Bits)[PosY * WidthBytes + PosX * Bpp];
-
- // Get pixels from neighbourhood of current pixel and store them
- Pixel := FFormatInfo.GetPixelFP(SrcPointer, @FFormatInfo, TempImage.Palette);
- NeighPixels[J * FilterSize + I] := Pixel;
- end;
- end;
-
- // Choose pixel using custom function
- Pixel := SelectFunc(NeighPixels);
- // Set resulting pixel color
- FFormatInfo.SetPixelFP(DstPointer, @FFormatInfo, FPData.Palette, Pixel);
-
- Inc(DstPointer, Bpp);
- end;
- end;
-
- finally
- FreeImage(TempImage);
- end;
-end;
-
-procedure TImagingCanvas.ApplyMedianFilter(FilterSize: Integer);
-begin
- ApplyNonLinearFilter(FilterSize, MedianSelect);
-end;
-
-procedure TImagingCanvas.ApplyMinFilter(FilterSize: Integer);
-begin
- ApplyNonLinearFilter(FilterSize, MinSelect);
-end;
-
-procedure TImagingCanvas.ApplyMaxFilter(FilterSize: Integer);
-begin
- ApplyNonLinearFilter(FilterSize, MaxSelect);
-end;
-
-procedure TImagingCanvas.PointTransform(Transform: TPointTransformFunction;
- Param1, Param2, Param3: Single);
-var
- X, Y, Bpp, WidthBytes: Integer;
- PixPointer: PByte;
- Pixel: TColorFPRec;
-begin
- Bpp := FFormatInfo.BytesPerPixel;
- WidthBytes := FPData.Width * Bpp;
-
- // For every pixel in clip rect
- for Y := FClipRect.Top to FClipRect.Bottom - 1 do
- begin
- PixPointer := @PByteArray(FPData.Bits)[Y * WidthBytes + FClipRect.Left * Bpp];
- for X := FClipRect.Left to FClipRect.Right - 1 do
- begin
- Pixel := FFormatInfo.GetPixelFP(PixPointer, @FFormatInfo, FPData.Palette);
-
- FFormatInfo.SetPixelFP(PixPointer, @FFormatInfo, FPData.Palette,
- Transform(Pixel, Param1, Param2, Param3));
-
- Inc(PixPointer, Bpp);
- end;
- end;
-end;
-
-procedure TImagingCanvas.ModifyContrastBrightness(Contrast, Brightness: Single);
-begin
- PointTransform(TransformContrastBrightness, 1.0 + Contrast / 100,
- Brightness / 100, 0);
-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;
-
-procedure TImagingCanvas.AdjustColorLevels(BlackPoint, WhitePoint, MidPoint: Single);
-begin
- PointTransform(TransformLevels, BlackPoint, WhitePoint, 1.0 / MidPoint);
-end;
-
-procedure TImagingCanvas.PremultiplyAlpha;
-begin
- PointTransform(TransformPremultiplyAlpha, 0, 0, 0);
-end;
-
-procedure TImagingCanvas.UnPremultiplyAlpha;
-begin
- PointTransform(TransformUnPremultiplyAlpha, 0, 0, 0);
-end;
-
-procedure TImagingCanvas.GetHistogram(out Red, Green, Blue, Alpha,
- Gray: THistogramArray);
-var
- X, Y, Bpp: Integer;
- PixPointer: PByte;
- Color32: TColor32Rec;
-begin
- FillChar(Red, SizeOf(Red), 0);
- FillChar(Green, SizeOf(Green), 0);
- FillChar(Blue, SizeOf(Blue), 0);
- FillChar(Alpha, SizeOf(Alpha), 0);
- FillChar(Gray, SizeOf(Gray), 0);
-
- Bpp := FFormatInfo.BytesPerPixel;
-
- for Y := FClipRect.Top to FClipRect.Bottom - 1 do
- begin
- PixPointer := @PByteArray(FPData.Bits)[Y * FPData.Width * Bpp + FClipRect.Left * Bpp];
- for X := FClipRect.Left to FClipRect.Right - 1 do
- begin
- Color32 := FFormatInfo.GetPixel32(PixPointer, @FFormatInfo, FPData.Palette);
-
- Inc(Red[Color32.R]);
- Inc(Green[Color32.G]);
- Inc(Blue[Color32.B]);
- Inc(Alpha[Color32.A]);
- Inc(Gray[Round(GrayConv.R * Color32.R + GrayConv.G * Color32.G + GrayConv.B * Color32.B)]);
-
- Inc(PixPointer, Bpp);
- end;
- end;
-end;
-
-procedure TImagingCanvas.FillChannel(ChannelId: Integer; NewChannelValue: Byte);
-var
- X, Y, Bpp: Integer;
- PixPointer: PByte;
- Color32: TColor32Rec;
-begin
- Bpp := FFormatInfo.BytesPerPixel;
-
- for Y := FClipRect.Top to FClipRect.Bottom - 1 do
- begin
- PixPointer := @PByteArray(FPData.Bits)[Y * FPData.Width * Bpp + FClipRect.Left * Bpp];
- for X := FClipRect.Left to FClipRect.Right - 1 do
- begin
- Color32 := FFormatInfo.GetPixel32(PixPointer, @FFormatInfo, FPData.Palette);
- Color32.Channels[ChannelId] := NewChannelValue;
- FFormatInfo.SetPixel32(PixPointer, @FFormatInfo, FPData.Palette, Color32);
-
- Inc(PixPointer, Bpp);
- end;
- end;
-end;
-
-procedure TImagingCanvas.FillChannelFP(ChannelId: Integer; NewChannelValue: Single);
-var
- X, Y, Bpp: Integer;
- PixPointer: PByte;
- ColorFP: TColorFPRec;
-begin
- Bpp := FFormatInfo.BytesPerPixel;
-
- for Y := FClipRect.Top to FClipRect.Bottom - 1 do
- begin
- PixPointer := @PByteArray(FPData.Bits)[Y * FPData.Width * Bpp + FClipRect.Left * Bpp];
- for X := FClipRect.Left to FClipRect.Right - 1 do
- begin
- ColorFP := FFormatInfo.GetPixelFP(PixPointer, @FFormatInfo, FPData.Palette);
- ColorFP.Channels[ChannelId] := NewChannelValue;
- FFormatInfo.SetPixelFP(PixPointer, @FFormatInfo, FPData.Palette, ColorFP);
-
- Inc(PixPointer, Bpp);
- end;
- end;
-end;
-
-class function TImagingCanvas.GetSupportedFormats: TImageFormats;
-begin
- Result := [ifIndex8..Pred(ifDXT1)];
-end;
-
-{ TFastARGB32Canvas }
-
-destructor TFastARGB32Canvas.Destroy;
-begin
- FreeMem(FScanlines);
- inherited Destroy;
-end;
-
-procedure TFastARGB32Canvas.AlphaBlendPixels(SrcPix, DestPix: PColor32Rec);
-var
- SrcAlpha, DestAlpha, FinalAlpha: Integer;
-begin
- FinalAlpha := SrcPix.A + 1 + (DestPix.A * (256 - SrcPix.A)) shr 8;
- if FinalAlpha = 0 then
- SrcAlpha := 0
- else
- SrcAlpha := (SrcPix.A shl 8) div FinalAlpha;
- DestAlpha := 256 - SrcAlpha;
-
- DestPix.A := ClampToByte(FinalAlpha);
- DestPix.R := (SrcPix.R * SrcAlpha + DestPix.R * DestAlpha) shr 8;
- DestPix.G := (SrcPix.G * SrcAlpha + DestPix.G * DestAlpha) shr 8;
- DestPix.B := (SrcPix.B * SrcAlpha + DestPix.B * DestAlpha) shr 8;
-end;
-
-procedure TFastARGB32Canvas.DrawAlpha(const SrcRect: TRect;
- DestCanvas: TImagingCanvas; DestX, DestY: Integer);
-var
- X, Y, SrcX, SrcY, Width, Height: Integer;
- SrcPix, DestPix: PColor32Rec;
-begin
- if DestCanvas.ClassType <> Self.ClassType then
- begin
- inherited;
- Exit;
- end;
-
- SrcX := SrcRect.Left;
- SrcY := SrcRect.Top;
- Width := SrcRect.Right - SrcRect.Left;
- Height := SrcRect.Bottom - SrcRect.Top;
- ClipCopyBounds(SrcX, SrcY, Width, Height, DestX, DestY,
- FPData.Width, FPData.Height, DestCanvas.ClipRect);
-
- for Y := 0 to Height - 1 do
- begin
- SrcPix := @FScanlines[SrcY + Y, SrcX];
- DestPix := @TFastARGB32Canvas(DestCanvas).FScanlines[DestY + Y, DestX];
- for X := 0 to Width - 1 do
- begin
- AlphaBlendPixels(SrcPix, DestPix);
- Inc(SrcPix);
- Inc(DestPix);
- end;
- end;
-end;
-
-function TFastARGB32Canvas.GetPixel32(X, Y: LongInt): TColor32;
-begin
- Result := FScanlines[Y, X].Color;
-end;
-
-procedure TFastARGB32Canvas.SetPixel32(X, Y: LongInt; const Value: TColor32);
-begin
- if (X >= FClipRect.Left) and (Y >= FClipRect.Top) and
- (X < FClipRect.Right) and (Y < FClipRect.Bottom) then
- begin
- FScanlines[Y, X].Color := Value;
- end;
-end;
-
-procedure TFastARGB32Canvas.StretchDrawAlpha(const SrcRect: TRect;
- DestCanvas: TImagingCanvas; const DestRect: TRect; Filter: TResizeFilter);
-var
- X, Y, ScaleX, ScaleY, Yp, Xp, Weight1, Weight2, Weight3, Weight4,
- FracX, FracY, InvFracY, T1, T2: Integer;
- SrcX, SrcY, SrcWidth, SrcHeight: Integer;
- DestX, DestY, DestWidth, DestHeight: Integer;
- SrcLine, SrcLine2: PColor32RecArray;
- DestPix: PColor32Rec;
- Accum: TColor32Rec;
-begin
- if (Filter = rfBicubic) or (DestCanvas.ClassType <> Self.ClassType) then
- begin
- inherited;
- Exit;
- end;
-
- 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;
- // Clip src and dst rects
- ClipStretchBounds(SrcX, SrcY, SrcWidth, SrcHeight, DestX, DestY, DestWidth, DestHeight,
- FPData.Width, FPData.Height, DestCanvas.ClipRect);
- ScaleX := (SrcWidth shl 16) div DestWidth;
- ScaleY := (SrcHeight shl 16) div DestHeight;
-
- // Nearest and linear filtering using fixed point math
-
- if Filter = rfNearest then
- begin
- Yp := 0;
- for Y := DestY to DestY + DestHeight - 1 do
- begin
- Xp := 0;
- SrcLine := @FScanlines[SrcY + Yp shr 16, SrcX];
- DestPix := @TFastARGB32Canvas(DestCanvas).FScanlines[Y, DestX];
- for X := 0 to DestWidth - 1 do
- begin
- AlphaBlendPixels(@SrcLine[Xp shr 16], DestPix);
- Inc(DestPix);
- Inc(Xp, ScaleX);
- end;
- Inc(Yp, ScaleY);
- end;
- end
- else
- begin
- Yp := (ScaleY shr 1) - $8000;
- for Y := DestY to DestY + DestHeight - 1 do
- begin
- DestPix := @TFastARGB32Canvas(DestCanvas).FScanlines[Y, DestX];
- if Yp < 0 then
- begin
- T1 := 0;
- FracY := 0;
- InvFracY := $10000;
- end
- else
- begin
- T1 := Yp shr 16;
- FracY := Yp and $FFFF;
- InvFracY := (not Yp and $FFFF) + 1;
- end;
-
- T2 := Iff(T1 < SrcHeight - 1, T1 + 1, T1);
- SrcLine := @Scanlines[T1 + SrcY, SrcX];
- SrcLine2 := @Scanlines[T2 + SrcY, SrcX];
- Xp := (ScaleX shr 1) - $8000;
-
- for X := 0 to DestWidth - 1 do
- begin
- if Xp < 0 then
- begin
- T1 := 0;
- FracX := 0;
- end
- else
- begin
- T1 := Xp shr 16;
- FracX := Xp and $FFFF;
- end;
-
- T2 := Iff(T1 < SrcWidth - 1, T1 + 1, T1);
- Weight2:= (Cardinal(InvFracY) * FracX) shr 16; // cast to Card, Int can overflow gere
- Weight1:= InvFracY - Weight2;
- Weight4:= (Cardinal(FracY) * FracX) shr 16;
- Weight3:= FracY - Weight4;
-
- Accum.B := (SrcLine[T1].B * Weight1 + SrcLine[T2].B * Weight2 +
- SrcLine2[T1].B * Weight3 + SrcLine2[T2].B * Weight4 + $8000) shr 16;
- Accum.G := (SrcLine[T1].G * Weight1 + SrcLine[T2].G * Weight2 +
- SrcLine2[T1].G * Weight3 + SrcLine2[T2].G * Weight4 + $8000) shr 16;
- Accum.R := (SrcLine[T1].R * Weight1 + SrcLine[T2].R * Weight2 +
- SrcLine2[T1].R * Weight3 + SrcLine2[T2].R * Weight4 + $8000) shr 16;
- Accum.A := (SrcLine[T1].A * Weight1 + SrcLine[T2].A * Weight2 +
- SrcLine2[T1].A * Weight3 + SrcLine2[T2].A * Weight4 + $8000) shr 16;
-
- AlphaBlendPixels(@Accum, DestPix);
-
- Inc(Xp, ScaleX);
- Inc(DestPix);
- end;
- Inc(Yp, ScaleY);
- end;
- end;
- {
-
- // 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;
- AccumR := 0;
- AccumG := 0;
- AccumB := 0;
- for Y := 0 to Length(ClusterY) - 1 do
- begin
- Weight := Round(ClusterY[Y].Weight * 256);
- SrcColor := FScanlines[ClusterY[Y].Pos, X];
-
- AccumB := AccumB + SrcColor.B * Weight;
- AccumG := AccumG + SrcColor.G * Weight;
- AccumR := AccumR + SrcColor.R * Weight;
- AccumA := AccumA + SrcColor.A * Weight;
- end;
- with LineBuffer[X - XMinimum] do
- begin
- A := AccumA;
- R := AccumR;
- G := AccumG;
- B := AccumB;
- end;
- end;
-
- DestPtr := @TFastARGB32Canvas(DestCanvas).FScanlines[DestY + J, DestX];
-
- for I := 0 to DestWidth - 1 do
- begin
- ClusterX := MapX[I];
- AccumA := 0;
- AccumR := 0;
- AccumG := 0;
- AccumB := 0;
- for X := 0 to Length(ClusterX) - 1 do
- begin
- Weight := Round(ClusterX[X].Weight * 256);
- 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;
-
- AccumA := ClampInt(AccumA, 0, $00FF0000);
- AccumR := ClampInt(AccumR, 0, $00FF0000);
- AccumG := ClampInt(AccumG, 0, $00FF0000);
- AccumB := ClampInt(AccumB, 0, $00FF0000);
- SrcColor.Color := (Cardinal(AccumA and $00FF0000) shl 8) or
- (AccumR and $00FF0000) or ((AccumG and $00FF0000) shr 8) or ((AccumB and $00FF0000) shr 16);
-
- AlphaBlendPixels(@SrcColor, DestPtr);
-
- Inc(DestPtr);
- end;
- end; }
-end;
-
-procedure TFastARGB32Canvas.UpdateCanvasState;
-var
- I: LongInt;
- ScanPos: PLongWord;
-begin
- inherited UpdateCanvasState;
-
- // Realloc and update scanline array
- ReallocMem(FScanlines, FPData.Height * SizeOf(PColor32RecArray));
- ScanPos := FPData.Bits;
-
- for I := 0 to FPData.Height - 1 do
- begin
- FScanlines[I] := PColor32RecArray(ScanPos);
- Inc(ScanPos, FPData.Width);
- end;
-end;
-
-class function TFastARGB32Canvas.GetSupportedFormats: TImageFormats;
-begin
- Result := [ifA8R8G8B8];
-end;
-
-procedure TFastARGB32Canvas.InvertColors;
-var
- X, Y: Integer;
- PixPtr: PColor32Rec;
-begin
- for Y := FClipRect.Top to FClipRect.Bottom - 1 do
- begin
- PixPtr := @FScanlines[Y, FClipRect.Left];
- for X := FClipRect.Left to FClipRect.Right - 1 do
- begin
- PixPtr.R := not PixPtr.R;
- PixPtr.G := not PixPtr.G;
- PixPtr.B := not PixPtr.B;
- Inc(PixPtr);
- end;
- end;
-end;
-
-initialization
- RegisterCanvas(TFastARGB32Canvas);
-
-finalization
- FreeAndNil(CanvasClasses);
-
-{
- File Notes:
-
- -- TODOS ----------------------------------------------------
- - more more more ...
- - implement pen width everywhere
- - add blending (*image and object drawing)
- - more objects (arc, polygon)
-
- -- 0.26.3 Changes/Bug Fixes ---------------------------------
- - Added some methods to TFastARGB32Canvas (InvertColors, DrawAlpha/StretchDrawAlpha)
- - Fixed DrawAlpha/StretchDrawAlpha destination alpha calculation.
- - Added PremultiplyAlpha and UnPremultiplyAlpha methods.
-
- -- 0.26.1 Changes/Bug Fixes ---------------------------------
- - Added FillChannel methods.
- - Added FloodFill method.
- - Added GetHistogram method.
- - Fixed "Invalid FP operation" in AdjustColorLevels in FPC compiled exes
- (thanks to Carlos González).
- - Added TImagingCanvas.AdjustColorLevels method.
-
- -- 0.25.0 Changes/Bug Fixes ---------------------------------
- - Fixed error that could cause AV in linear and nonlinear filters.
- - Added blended rect filling function FillRectBlend.
- - Added drawing function with blending (DrawAlpha, StretchDrawAlpha,
- StretchDrawAdd, DrawBlend, StretchDrawBlend, ...)
- - Added non-linear filters (min, max, median).
- - Added point transforms (invert, contrast, gamma, brightness).
-
- -- 0.21 Changes/Bug Fixes -----------------------------------
- - Added some new filter kernels for convolution.
- - Added FillMode and PenMode properties.
- - Added FrameRect, Rectangle, Ellipse, and Line methods.
- - Removed HorzLine and VertLine from TFastARGB32Canvas - new versions
- in general canvas is now as fast as those in TFastARGB32Canvas
- (only in case of A8R8G8B8 images of course).
- - Added PenWidth property, updated HorzLine and VertLine to use it.
-
- -- 0.19 Changes/Bug Fixes -----------------------------------
- - added TFastARGB32Canvas
- - added convolutions, hline, vline
- - unit created, intial stuff added
-
-}
-
-end.
-
+{
+ $Id: ImagingCanvases.pas 174 2009-09-08 09:37:59Z galfar $
+ Vampyre Imaging Library
+ by Marek Mauder
+ http://imaginglib.sourceforge.net
+
+ The contents of this file are used with permission, subject to the Mozilla
+ Public License Version 1.1 (the "License"); you may not use this file except
+ in compliance with the License. You may obtain a copy of the License at
+ http://www.mozilla.org/MPL/MPL-1.1.html
+
+ Software distributed under the License is distributed on an "AS IS" basis,
+ WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
+ the specific language governing rights and limitations under the License.
+
+ Alternatively, the contents of this file may be used under the terms of the
+ GNU Lesser General Public License (the "LGPL License"), in which case the
+ provisions of the LGPL License are applicable instead of those above.
+ If you wish to allow use of your version of this file only under the terms
+ of the LGPL License and not to allow others to use your version of this file
+ under the MPL, indicate your decision by deleting the provisions above and
+ replace them with the notice and other provisions required by the LGPL
+ License. If you do not delete the provisions above, a recipient may use
+ your version of this file under either the MPL or the LGPL License.
+
+ For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
+}
+
+{
+ This unit contains canvas classes for drawing and applying effects.
+}
+unit ImagingCanvases;
+
+{$I ImagingOptions.inc}
+
+interface
+
+uses
+ SysUtils, Types, Classes, ImagingTypes, Imaging, ImagingClasses,
+ ImagingFormats, ImagingUtility;
+
+const
+ { Color constants in ifA8R8G8B8 format.}
+ pcClear = $00000000;
+ pcBlack = $FF000000;
+ pcWhite = $FFFFFFFF;
+ pcMaroon = $FF800000;
+ pcGreen = $FF008000;
+ pcOlive = $FF808000;
+ pcNavy = $FF000080;
+ pcPurple = $FF800080;
+ pcTeal = $FF008080;
+ pcGray = $FF808080;
+ pcSilver = $FFC0C0C0;
+ pcRed = $FFFF0000;
+ pcLime = $FF00FF00;
+ pcYellow = $FFFFFF00;
+ pcBlue = $FF0000FF;
+ pcFuchsia = $FFFF00FF;
+ pcAqua = $FF00FFFF;
+ pcLtGray = $FFC0C0C0;
+ pcDkGray = $FF808080;
+
+ MaxPenWidth = 256;
+
+type
+ EImagingCanvasError = class(EImagingError);
+ EImagingCanvasBlendingError = class(EImagingError);
+
+ { Fill mode used when drawing filled objects on canvas.}
+ TFillMode = (
+ fmSolid, // Solid fill using current fill color
+ fmClear // No filling done
+ );
+
+ { Pen mode used when drawing lines, object outlines, and similar on canvas.}
+ TPenMode = (
+ pmSolid, // Draws solid lines using current pen color.
+ pmClear // No drawing done
+ );
+
+ { Source and destination blending factors for drawing functions with blending.
+ Blending formula: SrcColor * SrcFactor + DestColor * DestFactor }
+ TBlendingFactor = (
+ bfIgnore, // Don't care
+ bfZero, // For Src and Dest, Factor = (0, 0, 0, 0)
+ bfOne, // For Src and Dest, Factor = (1, 1, 1, 1)
+ bfSrcAlpha, // For Src and Dest, Factor = (Src.A, Src.A, Src.A, Src.A)
+ bfOneMinusSrcAlpha, // For Src and Dest, Factor = (1 - Src.A, 1 - Src.A, 1 - Src.A, 1 - Src.A)
+ bfDstAlpha, // For Src and Dest, Factor = (Dest.A, Dest.A, Dest.A, Dest.A)
+ bfOneMinusDstAlpha, // For Src and Dest, Factor = (1 - Dest.A, 1 - Dest.A, 1 - Dest.A, 1 - Dest.A)
+ bfSrcColor, // For Dest, Factor = (Src.R, Src.R, Src.B, Src.A)
+ bfOneMinusSrcColor, // For Dest, Factor = (1 - Src.R, 1 - Src.G, 1 - Src.B, 1 - Src.A)
+ bfDstColor, // For Src, Factor = (Dest.R, Dest.G, Dest.B, Dest.A)
+ bfOneMinusDstColor // For Src, Factor = (1 - Dest.R, 1 - Dest.G, 1 - Dest.B, 1 - Dest.A)
+ );
+
+ { Procedure for custom pixel write modes with blending.}
+ TPixelWriteProc = procedure(const SrcPix: TColorFPRec; DestPtr: PByte;
+ DestInfo: PImageFormatInfo; SrcFactor, DestFactor: TBlendingFactor);
+
+ { Represents 3x3 convolution filter kernel.}
+ TConvolutionFilter3x3 = record
+ Kernel: array[0..2, 0..2] of LongInt;
+ Divisor: LongInt;
+ Bias: Single;
+ end;
+
+ { Represents 5x5 convolution filter kernel.}
+ TConvolutionFilter5x5 = record
+ Kernel: array[0..4, 0..4] of LongInt;
+ Divisor: LongInt;
+ Bias: Single;
+ end;
+
+ TPointTransformFunction = function(const Pixel: TColorFPRec;
+ Param1, Param2, Param3: Single): TColorFPRec;
+
+ TDynFPPixelArray = array of TColorFPRec;
+
+ THistogramArray = array[Byte] of Integer;
+
+ TSelectPixelFunction = function(var Pixels: TDynFPPixelArray): TColorFPRec;
+
+ { Base canvas class for drawing objects, applying effects, and other.
+ Constructor takes TBaseImage (or pointer to TImageData). Source image
+ bits are not copied but referenced so all canvas functions affect
+ source image and vice versa. When you change format or resolution of
+ source image you must call UpdateCanvasState method (so canvas could
+ recompute some data size related stuff).
+
+ TImagingCanvas works for all image data formats except special ones
+ (compressed). Because of this its methods are quite slow (they usually work
+ with colors in ifA32R32G32B32F format). If you want fast drawing you
+ can use one of fast canvas clases. These descendants of TImagingCanvas
+ work only for few select formats (or only one) but they are optimized thus
+ much faster.
+ }
+ TImagingCanvas = class(TObject)
+ private
+ FDataSizeOnUpdate: LongInt;
+ FLineRecursion: Boolean;
+ function GetPixel32(X, Y: LongInt): TColor32; virtual;
+ function GetPixelFP(X, Y: LongInt): TColorFPRec; virtual;
+ function GetValid: Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF}
+ procedure SetPixel32(X, Y: LongInt; const Value: TColor32); virtual;
+ procedure SetPixelFP(X, Y: LongInt; const Value: TColorFPRec); virtual;
+ procedure SetPenColor32(const Value: TColor32); {$IFDEF USE_INLINE}inline;{$ENDIF}
+ procedure SetPenColorFP(const Value: TColorFPRec); {$IFDEF USE_INLINE}inline;{$ENDIF}
+ procedure SetPenWidth(const Value: LongInt); {$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 SetClipRect(const Value: TRect);
+ procedure CheckBeforeBlending(SrcFactor, DestFactor: TBlendingFactor; DestCanvas: TImagingCanvas);
+ protected
+ FPData: PImageData;
+ FClipRect: TRect;
+ FPenColorFP: TColorFPRec;
+ FPenColor32: TColor32;
+ FPenMode: TPenMode;
+ FPenWidth: LongInt;
+ FFillColorFP: TColorFPRec;
+ FFillColor32: TColor32;
+ FFillMode: TFillMode;
+ FNativeColor: TColorFPRec;
+ FFormatInfo: TImageFormatInfo;
+
+ { Returns pointer to pixel at given position.}
+ function GetPixelPointer(X, Y: LongInt): Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF}
+ { Translates given FP color to native format of canvas and stores it
+ in FNativeColor field (its bit copy) or user pointer (in overloaded method).}
+ procedure TranslateFPToNative(const Color: TColorFPRec); overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
+ procedure TranslateFPToNative(const Color: TColorFPRec; Native: Pointer); overload; {$IFDEF USE_INLINE}inline;{$ENDIF}
+ { Clipping function used by horizontal and vertical line drawing functions.}
+ function ClipAxisParallelLine(var A1, A2, B: LongInt;
+ AStart, AStop, BStart, BStop: LongInt): Boolean;
+ { Internal horizontal line drawer used mainly for filling inside of objects
+ like ellipses and circles.}
+ procedure HorzLineInternal(X1, X2, Y: LongInt; Color: Pointer; Bpp: LongInt); virtual;
+ procedure CopyPixelInternal(X, Y: LongInt; Pixel: Pointer; Bpp: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
+ procedure DrawInternal(const SrcRect: TRect; DestCanvas: TImagingCanvas;
+ DestX, DestY: Integer; SrcFactor, DestFactor: TBlendingFactor; PixelWriteProc: TPixelWriteProc);
+ procedure StretchDrawInternal(const SrcRect: TRect; DestCanvas: TImagingCanvas;
+ const DestRect: TRect; SrcFactor, DestFactor: TBlendingFactor;
+ Filter: TResizeFilter; PixelWriteProc: TPixelWriteProc);
+ public
+ constructor CreateForData(ImageDataPointer: PImageData);
+ constructor CreateForImage(Image: TBaseImage);
+ destructor Destroy; override;
+
+ { Call this method when you change size or format of image this canvas
+ operates on (like calling ResizeImage, ConvertImage, or changing Format
+ property of TBaseImage descendants).}
+ procedure UpdateCanvasState; virtual;
+ { Resets clipping rectangle to Rect(0, 0, ImageWidth, ImageHeight).}
+ procedure ResetClipRect;
+
+ { Clears entire canvas with current fill color (ignores clipping rectangle
+ and always uses fmSolid fill mode).}
+ procedure Clear;
+
+ { Draws horizontal line with current pen settings.}
+ procedure HorzLine(X1, X2, Y: LongInt); virtual;
+ { Draws vertical line with current pen settings.}
+ procedure VertLine(X, Y1, Y2: LongInt); virtual;
+ { Draws line from [X1, Y1] to [X2, Y2] with current pen settings.}
+ procedure Line(X1, Y1, X2, Y2: LongInt); virtual;
+ { Draws a rectangle using current pen settings.}
+ procedure FrameRect(const Rect: TRect);
+ { Fills given rectangle with current fill settings.}
+ procedure FillRect(const Rect: TRect); virtual;
+ { Fills given rectangle with current fill settings and pixel blending.}
+ procedure FillRectBlend(const Rect: TRect; SrcFactor, DestFactor: TBlendingFactor);
+ { Draws rectangle which is outlined by using the current pen settings and
+ filled by using the current fill settings.}
+ procedure Rectangle(const Rect: TRect);
+ { Draws ellipse which is outlined by using the current pen settings and
+ filled by using the current fill settings. Rect specifies bounding rectangle
+ of ellipse to be drawn.}
+ procedure Ellipse(const Rect: TRect);
+ { Fills area of canvas with current fill color starting at point [X, Y] and
+ coloring its neighbors. Default flood fill mode changes color of all
+ neighbors with the same color as pixel [X, Y]. With BoundaryFillMode
+ set to True neighbors are recolored regardless of their old color,
+ but area which will be recolored has boundary (specified by current pen color).}
+ procedure FloodFill(X, Y: Integer; BoundaryFillMode: Boolean = False);
+
+ { 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); virtual;
+ { 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); virtual;
+ { Draws contents of this canvas onto another one using additive blending
+ (source and dest factors are bfOne).}
+ procedure StretchDrawAdd(const SrcRect: TRect; DestCanvas: TImagingCanvas;
+ const DestRect: TRect; Filter: TResizeFilter = rfBilinear);
+
+ { Convolves canvas' image with given 3x3 filter kernel. You can use
+ predefined filter kernels or define your own.}
+ procedure ApplyConvolution3x3(const Filter: TConvolutionFilter3x3);
+ { Convolves canvas' image with given 5x5 filter kernel. You can use
+ predefined filter kernels or define your own.}
+ procedure ApplyConvolution5x5(const Filter: TConvolutionFilter5x5);
+ { Computes 2D convolution of canvas' image and given filter kernel.
+ Kernel is in row format and KernelSize must be odd number >= 3. Divisor
+ is normalizing value based on Kernel (usually sum of all kernel's cells).
+ The Bias number shifts each color value by a fixed amount (color values
+ are usually in range [0, 1] during processing). If ClampChannels
+ is True all output color values are clamped to [0, 1]. You can use
+ predefined filter kernels or define your own.}
+ procedure ApplyConvolution(Kernel: PLongInt; KernelSize, Divisor: LongInt;
+ Bias: Single = 0.0; ClampChannels: Boolean = True); virtual;
+
+ { Applies custom non-linear filter. Filter size is diameter of pixel
+ neighborhood. Typical values are 3, 5, or 7. }
+ procedure ApplyNonLinearFilter(FilterSize: Integer; SelectFunc: TSelectPixelFunction);
+ { Applies median non-linear filter with user defined pixel neighborhood.
+ Selects median pixel from the neighborhood as new pixel
+ (current implementation is quite slow).}
+ procedure ApplyMedianFilter(FilterSize: Integer);
+ { Applies min non-linear filter with user defined pixel neighborhood.
+ Selects min pixel from the neighborhood as new pixel.}
+ procedure ApplyMinFilter(FilterSize: Integer);
+ { Applies max non-linear filter with user defined pixel neighborhood.
+ Selects max pixel from the neighborhood as new pixel.}
+ procedure ApplyMaxFilter(FilterSize: Integer);
+
+ { Transforms pixels one by one by given function. Pixel neighbors are
+ not taken into account. Param 1-3 are optional parameters
+ for transform function.}
+ procedure PointTransform(Transform: TPointTransformFunction;
+ Param1, Param2, Param3: Single);
+ { Modifies image contrast and brightness. Parameters should be
+ in range <-100; 100>.}
+ procedure ModifyContrastBrightness(Contrast, Brightness: Single);
+ { Gamma correction of individual color channels. Range is (0, +inf),
+ 1.0 means no change.}
+ procedure GammaCorection(Red, Green, Blue: Single);
+ { Inverts colors of all image pixels, makes negative image. Ignores alpha channel.}
+ procedure InvertColors; virtual;
+ { Simple single level thresholding with threshold level (in range [0, 1])
+ for each color channel.}
+ procedure Threshold(Red, Green, Blue: Single);
+ { Adjusts the color levels of the image by scaling the
+ colors falling between specified white and black points to full [0, 1] range.
+ The black point specifies the darkest color in the image, white point
+ specifies the lightest color, and mid point is gamma aplied to image.
+ Black and white point must be in range [0, 1].}
+ procedure AdjustColorLevels(BlackPoint, WhitePoint: Single; MidPoint: Single = 1.0);
+ { Premultiplies color channel values by alpha. Needed for some platforms/APIs
+ to display images with alpha properly.}
+ procedure PremultiplyAlpha;
+ { Reverses PremultiplyAlpha operation.}
+ procedure UnPremultiplyAlpha;
+
+ { Calculates image histogram for each channel and also gray values. Each
+ channel has 256 values available. Channel values of data formats with higher
+ precision are scaled and rounded. Example: Red[126] specifies number of pixels
+ in image with red channel = 126.}
+ procedure GetHistogram(out Red, Green, Blue, Alpha, Gray: THistogramArray);
+ { Fills image channel with given value leaving other channels intact.
+ Use ChannelAlpha, ChannelRed, etc. constants from ImagingTypes as
+ channel identifier.}
+ procedure FillChannel(ChannelId: Integer; NewChannelValue: Byte); overload;
+ { Fills image channel with given value leaving other channels intact.
+ Use ChannelAlpha, ChannelRed, etc. constants from ImagingTypes as
+ channel identifier.}
+ procedure FillChannelFP(ChannelId: Integer; NewChannelValue: Single); overload;
+
+ { Color used when drawing lines, frames, and outlines of objects.}
+ property PenColor32: TColor32 read FPenColor32 write SetPenColor32;
+ { Color used when drawing lines, frames, and outlines of objects.}
+ property PenColorFP: TColorFPRec read FPenColorFP write SetPenColorFP;
+ { Pen mode used when drawing lines, object outlines, and similar on canvas.}
+ property PenMode: TPenMode read FPenMode write FPenMode;
+ { Width with which objects like lines, frames, etc. (everything which uses
+ PenColor) are drawn.}
+ property PenWidth: LongInt read FPenWidth write SetPenWidth;
+ { Color used for filling when drawing various objects.}
+ property FillColor32: TColor32 read FFillColor32 write SetFillColor32;
+ { Color used for filling when drawing various objects.}
+ property FillColorFP: TColorFPRec read FFillColorFP write SetFillColorFP;
+ { Fill mode used when drawing filled objects on canvas.}
+ property FillMode: TFillMode read FFillMode write FFillMode;
+ { Specifies the current color of the pixels of canvas. Native pixel is
+ read from canvas and then translated to 32bit ARGB. Reverse operation
+ is made when setting pixel color.}
+ property Pixels32[X, Y: LongInt]: TColor32 read GetPixel32 write SetPixel32;
+ { Specifies the current color of the pixels of canvas. Native pixel is
+ read from canvas and then translated to FP ARGB. Reverse operation
+ is made when setting pixel color.}
+ property PixelsFP[X, Y: LongInt]: TColorFPRec read GetPixelFP write SetPixelFP;
+ { Clipping rectangle of this canvas. No pixels outside this rectangle are
+ altered by canvas methods if Clipping property is True. Clip rect gets
+ reseted when UpdateCanvasState is called.}
+ property ClipRect: TRect read FClipRect write SetClipRect;
+ { Extended format information.}
+ property FormatInfo: TImageFormatInfo read FFormatInfo;
+ { Indicates that this canvas is in valid state. If False canvas oprations
+ may crash.}
+ property Valid: Boolean read GetValid;
+
+ { Returns all formats supported by this canvas class.}
+ class function GetSupportedFormats: TImageFormats; virtual;
+ end;
+
+ TImagingCanvasClass = class of TImagingCanvas;
+
+ TScanlineArray = array[0..MaxInt div SizeOf(Pointer) - 1] of PColor32RecArray;
+ PScanlineArray = ^TScanlineArray;
+
+ { Fast canvas class for ifA8R8G8B8 format images.}
+ TFastARGB32Canvas = class(TImagingCanvas)
+ protected
+ FScanlines: PScanlineArray;
+ procedure AlphaBlendPixels(SrcPix, DestPix: PColor32Rec); {$IFDEF USE_INLINE}inline;{$ENDIF}
+ function GetPixel32(X, Y: LongInt): TColor32; override;
+ procedure SetPixel32(X, Y: LongInt; const Value: TColor32); override;
+ public
+ destructor Destroy; override;
+
+ procedure UpdateCanvasState; override;
+
+ procedure DrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: Integer); override;
+ procedure StretchDrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas;
+ const DestRect: TRect; Filter: TResizeFilter = rfBilinear); override;
+ procedure InvertColors; override;
+
+ property Scanlines: PScanlineArray read FScanlines;
+
+ class function GetSupportedFormats: TImageFormats; override;
+ end;
+
+const
+ { Kernel for 3x3 average smoothing filter.}
+ FilterAverage3x3: TConvolutionFilter3x3 = (
+ Kernel: ((1, 1, 1),
+ (1, 1, 1),
+ (1, 1, 1));
+ Divisor: 9);
+
+ { Kernel for 5x5 average smoothing filter.}
+ FilterAverage5x5: TConvolutionFilter5x5 = (
+ Kernel: ((1, 1, 1, 1, 1),
+ (1, 1, 1, 1, 1),
+ (1, 1, 1, 1, 1),
+ (1, 1, 1, 1, 1),
+ (1, 1, 1, 1, 1));
+ Divisor: 25);
+
+ { Kernel for 3x3 Gaussian smoothing filter.}
+ FilterGaussian3x3: TConvolutionFilter3x3 = (
+ Kernel: ((1, 2, 1),
+ (2, 4, 2),
+ (1, 2, 1));
+ Divisor: 16);
+
+ { Kernel for 5x5 Gaussian smoothing filter.}
+ FilterGaussian5x5: TConvolutionFilter5x5 = (
+ Kernel: ((1, 4, 6, 4, 1),
+ (4, 16, 24, 16, 4),
+ (6, 24, 36, 24, 6),
+ (4, 16, 24, 16, 4),
+ (1, 4, 6, 4, 1));
+ Divisor: 256);
+
+ { Kernel for 3x3 Sobel horizontal edge detection filter (1st derivative approximation).}
+ FilterSobelHorz3x3: TConvolutionFilter3x3 = (
+ Kernel: (( 1, 2, 1),
+ ( 0, 0, 0),
+ (-1, -2, -1));
+ Divisor: 1);
+
+ { Kernel for 3x3 Sobel vertical edge detection filter (1st derivative approximation).}
+ FilterSobelVert3x3: TConvolutionFilter3x3 = (
+ Kernel: ((-1, 0, 1),
+ (-2, 0, 2),
+ (-1, 0, 1));
+ Divisor: 1);
+
+ { Kernel for 3x3 Prewitt horizontal edge detection filter.}
+ FilterPrewittHorz3x3: TConvolutionFilter3x3 = (
+ Kernel: (( 1, 1, 1),
+ ( 0, 0, 0),
+ (-1, -1, -1));
+ Divisor: 1);
+
+ { Kernel for 3x3 Prewitt vertical edge detection filter.}
+ FilterPrewittVert3x3: TConvolutionFilter3x3 = (
+ Kernel: ((-1, 0, 1),
+ (-1, 0, 1),
+ (-1, 0, 1));
+ Divisor: 1);
+
+ { Kernel for 3x3 Kirsh horizontal edge detection filter.}
+ FilterKirshHorz3x3: TConvolutionFilter3x3 = (
+ Kernel: (( 5, 5, 5),
+ (-3, 0, -3),
+ (-3, -3, -3));
+ Divisor: 1);
+
+ { Kernel for 3x3 Kirsh vertical edge detection filter.}
+ FilterKirshVert3x3: TConvolutionFilter3x3 = (
+ Kernel: ((5, -3, -3),
+ (5, 0, -3),
+ (5, -3, -3));
+ Divisor: 1);
+
+ { Kernel for 3x3 Laplace omni-directional edge detection filter
+ (2nd derivative approximation).}
+ FilterLaplace3x3: TConvolutionFilter3x3 = (
+ Kernel: ((-1, -1, -1),
+ (-1, 8, -1),
+ (-1, -1, -1));
+ Divisor: 1);
+
+ { Kernel for 5x5 Laplace omni-directional edge detection filter
+ (2nd derivative approximation).}
+ FilterLaplace5x5: TConvolutionFilter5x5 = (
+ Kernel: ((-1, -1, -1, -1, -1),
+ (-1, -1, -1, -1, -1),
+ (-1, -1, 24, -1, -1),
+ (-1, -1, -1, -1, -1),
+ (-1, -1, -1, -1, -1));
+ Divisor: 1);
+
+ { Kernel for 3x3 spharpening filter (Laplacian + original color).}
+ FilterSharpen3x3: TConvolutionFilter3x3 = (
+ Kernel: ((-1, -1, -1),
+ (-1, 9, -1),
+ (-1, -1, -1));
+ Divisor: 1);
+
+ { Kernel for 5x5 spharpening filter (Laplacian + original color).}
+ FilterSharpen5x5: TConvolutionFilter5x5 = (
+ Kernel: ((-1, -1, -1, -1, -1),
+ (-1, -1, -1, -1, -1),
+ (-1, -1, 25, -1, -1),
+ (-1, -1, -1, -1, -1),
+ (-1, -1, -1, -1, -1));
+ Divisor: 1);
+
+ { Kernel for 5x5 glow filter.}
+ FilterGlow5x5: TConvolutionFilter5x5 = (
+ Kernel: (( 1, 2, 2, 2, 1),
+ ( 2, 0, 0, 0, 2),
+ ( 2, 0, -20, 0, 2),
+ ( 2, 0, 0, 0, 2),
+ ( 1, 2, 2, 2, 1));
+ Divisor: 8);
+
+ { Kernel for 3x3 edge enhancement filter.}
+ FilterEdgeEnhance3x3: TConvolutionFilter3x3 = (
+ Kernel: ((-1, -2, -1),
+ (-2, 16, -2),
+ (-1, -2, -1));
+ Divisor: 4);
+
+ { Kernel for 3x3 contour enhancement filter.}
+ FilterTraceControur3x3: TConvolutionFilter3x3 = (
+ Kernel: ((-6, -6, -2),
+ (-1, 32, -1),
+ (-6, -2, -6));
+ Divisor: 4;
+ Bias: 240/255);
+
+ { Kernel for filter that negates all images pixels.}
+ FilterNegative3x3: TConvolutionFilter3x3 = (
+ Kernel: ((0, 0, 0),
+ (0, -1, 0),
+ (0, 0, 0));
+ Divisor: 1;
+ Bias: 1);
+
+ { Kernel for 3x3 horz/vert embossing filter.}
+ FilterEmboss3x3: TConvolutionFilter3x3 = (
+ Kernel: ((2, 0, 0),
+ (0, -1, 0),
+ (0, 0, -1));
+ Divisor: 1;
+ Bias: 0.5);
+
+
+{ You can register your own canvas class. List of registered canvases is used
+ by FindBestCanvasForImage functions to find best canvas for given image.
+ If two different canvases which support the same image data format are
+ registered then the one that was registered later is returned (so you can
+ override builtin Imaging canvases).}
+procedure RegisterCanvas(CanvasClass: TImagingCanvasClass);
+{ Returns best canvas for given TImageFormat.}
+function FindBestCanvasForImage(ImageFormat: TImageFormat): TImagingCanvasClass; overload;
+{ Returns best canvas for given TImageData.}
+function FindBestCanvasForImage(const ImageData: TImageData): TImagingCanvasClass; overload;
+{ Returns best canvas for given TBaseImage.}
+function FindBestCanvasForImage(Image: TBaseImage): TImagingCanvasClass; overload;
+
+implementation
+
+resourcestring
+ SConstructorInvalidPointer = 'Invalid pointer (%p) to TImageData passed to TImagingCanvas constructor.';
+ SConstructorInvalidImage = 'Invalid image data passed to TImagingCanvas constructor (%s).';
+ SConstructorUnsupportedFormat = 'Image passed to TImagingCanvas constructor is in unsupported format (%s)';
+
+var
+ // list with all registered TImagingCanvas classes
+ CanvasClasses: TList = nil;
+
+procedure RegisterCanvas(CanvasClass: TImagingCanvasClass);
+begin
+ Assert(CanvasClass <> nil);
+ if CanvasClasses = nil then
+ CanvasClasses := TList.Create;
+ if CanvasClasses.IndexOf(CanvasClass) < 0 then
+ CanvasClasses.Add(CanvasClass);
+end;
+
+function FindBestCanvasForImage(ImageFormat: TImageFormat): TImagingCanvasClass; overload;
+var
+ I: LongInt;
+begin
+ for I := CanvasClasses.Count - 1 downto 0 do
+ begin
+ if ImageFormat in TImagingCanvasClass(CanvasClasses[I]).GetSupportedFormats then
+ begin
+ Result := TImagingCanvasClass(CanvasClasses[I]);
+ Exit;
+ end;
+ end;
+ Result := TImagingCanvas;
+end;
+
+function FindBestCanvasForImage(const ImageData: TImageData): TImagingCanvasClass;
+begin
+ Result := FindBestCanvasForImage(ImageData.Format);
+end;
+
+function FindBestCanvasForImage(Image: TBaseImage): TImagingCanvasClass;
+begin
+ Result := FindBestCanvasForImage(Image.Format);
+end;
+
+{ 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;
+ SrcAlpha, DestAlpha: Single;
+begin
+ DestPix := DestInfo.GetPixelFP(DestPtr, DestInfo, nil);
+ // Blend the two pixels (Src 'over' Dest alpha composition operation)
+ DestPix.A := SrcPix.A + DestPix.A - SrcPix.A * DestPix.A;
+ SrcAlpha := IffFloat(DestPix.A = 0, 0, SrcPix.A / DestPix.A);
+ DestAlpha := 1.0 - SrcAlpha;
+ DestPix.R := SrcPix.R * SrcAlpha + DestPix.R * DestAlpha;
+ DestPix.G := SrcPix.G * SrcAlpha + DestPix.G * DestAlpha;
+ DestPix.B := SrcPix.B * SrcAlpha + DestPix.B * DestAlpha;
+ // 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, P3: 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; P1, P2, P3: 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;
+
+function TransformLevels(const Pixel: TColorFPRec; BlackPoint, WhitePoint, Exp: Single): TColorFPRec;
+begin
+ Result.A := Pixel.A;
+ if Pixel.R > BlackPoint then
+ Result.R := Power((Pixel.R - BlackPoint) / (WhitePoint - BlackPoint), Exp)
+ else
+ Result.R := 0.0;
+ if Pixel.G > BlackPoint then
+ Result.G := Power((Pixel.G - BlackPoint) / (WhitePoint - BlackPoint), Exp)
+ else
+ Result.G := 0.0;
+ if Pixel.B > BlackPoint then
+ Result.B := Power((Pixel.B - BlackPoint) / (WhitePoint - BlackPoint), Exp)
+ else
+ Result.B := 0.0;
+end;
+
+function TransformPremultiplyAlpha(const Pixel: TColorFPRec; P1, P2, P3: Single): TColorFPRec;
+begin
+ Result.A := Pixel.A;
+ Result.R := Result.R * Pixel.A;
+ Result.G := Result.G * Pixel.A;
+ Result.B := Result.B * Pixel.A;
+end;
+
+function TransformUnPremultiplyAlpha(const Pixel: TColorFPRec; P1, P2, P3: Single): TColorFPRec;
+begin
+ Result.A := Pixel.A;
+ if Pixel.A <> 0.0 then
+ begin
+ Result.R := Result.R / Pixel.A;
+ Result.G := Result.G / Pixel.A;
+ Result.B := Result.B / Pixel.A;
+ end
+ else
+ begin
+ Result.R := 0;
+ Result.G := 0;
+ Result.B := 0;
+ end;
+end;
+
+
+{ TImagingCanvas class implementation }
+
+constructor TImagingCanvas.CreateForData(ImageDataPointer: PImageData);
+begin
+ if ImageDataPointer = nil then
+ raise EImagingCanvasError.CreateFmt(SConstructorInvalidPointer, [ImageDataPointer]);
+
+ if not TestImage(ImageDataPointer^) then
+ raise EImagingCanvasError.CreateFmt(SConstructorInvalidImage, [Imaging.ImageToStr(ImageDataPointer^)]);
+
+ if not (ImageDataPointer.Format in GetSupportedFormats) then
+ raise EImagingCanvasError.CreateFmt(SConstructorUnsupportedFormat, [Imaging.ImageToStr(ImageDataPointer^)]);
+
+ FPData := ImageDataPointer;
+ FPenWidth := 1;
+ SetPenColor32(pcWhite);
+ SetFillColor32(pcBlack);
+ FFillMode := fmSolid;
+
+ UpdateCanvasState;
+end;
+
+constructor TImagingCanvas.CreateForImage(Image: TBaseImage);
+begin
+ CreateForData(Image.ImageDataPointer);
+end;
+
+destructor TImagingCanvas.Destroy;
+begin
+ inherited Destroy;
+end;
+
+function TImagingCanvas.GetPixel32(X, Y: LongInt): TColor32;
+begin
+ Result := Imaging.GetPixel32(FPData^, X, Y).Color;
+end;
+
+function TImagingCanvas.GetPixelFP(X, Y: LongInt): TColorFPRec;
+begin
+ Result := Imaging.GetPixelFP(FPData^, X, Y);
+end;
+
+function TImagingCanvas.GetValid: Boolean;
+begin
+ Result := (FPData <> nil) and (FDataSizeOnUpdate = FPData.Size);
+end;
+
+procedure TImagingCanvas.SetPixel32(X, Y: LongInt; const Value: TColor32);
+begin
+ if (X >= FClipRect.Left) and (Y >= FClipRect.Top) and
+ (X < FClipRect.Right) and (Y < FClipRect.Bottom) then
+ begin
+ Imaging.SetPixel32(FPData^, X, Y, TColor32Rec(Value));
+ end;
+end;
+
+procedure TImagingCanvas.SetPixelFP(X, Y: LongInt; const Value: TColorFPRec);
+begin
+ if (X >= FClipRect.Left) and (Y >= FClipRect.Top) and
+ (X < FClipRect.Right) and (Y < FClipRect.Bottom) then
+ begin
+ Imaging.SetPixelFP(FPData^, X, Y, TColorFPRec(Value));
+ end;
+end;
+
+procedure TImagingCanvas.SetPenColor32(const Value: TColor32);
+begin
+ FPenColor32 := Value;
+ TranslatePixel(@FPenColor32, @FPenColorFP, ifA8R8G8B8, ifA32R32G32B32F, nil, nil);
+end;
+
+procedure TImagingCanvas.SetPenColorFP(const Value: TColorFPRec);
+begin
+ FPenColorFP := Value;
+ TranslatePixel(@FPenColorFP, @FPenColor32, ifA32R32G32B32F, ifA8R8G8B8, nil, nil);
+end;
+
+procedure TImagingCanvas.SetPenWidth(const Value: LongInt);
+begin
+ FPenWidth := ClampInt(Value, 0, MaxPenWidth);
+end;
+
+procedure TImagingCanvas.SetFillColor32(const Value: TColor32);
+begin
+ FFillColor32 := Value;
+ TranslatePixel(@FFillColor32, @FFillColorFP, ifA8R8G8B8, ifA32R32G32B32F, nil, nil);
+end;
+
+procedure TImagingCanvas.SetFillColorFP(const Value: TColorFPRec);
+begin
+ FFillColorFP := Value;
+ TranslatePixel(@FFillColorFP, @FFillColor32, ifA32R32G32B32F, ifA8R8G8B8, nil, nil);
+end;
+
+procedure TImagingCanvas.SetClipRect(const Value: TRect);
+begin
+ FClipRect := Value;
+ SwapMin(FClipRect.Left, FClipRect.Right);
+ SwapMin(FClipRect.Top, FClipRect.Bottom);
+ IntersectRect(FClipRect, FClipRect, Rect(0, 0, FPData.Width, FPData.Height));
+end;
+
+procedure TImagingCanvas.CheckBeforeBlending(SrcFactor,
+ DestFactor: TBlendingFactor; DestCanvas: TImagingCanvas);
+begin
+ if SrcFactor in [bfSrcColor, bfOneMinusSrcColor] then
+ raise EImagingCanvasBlendingError.Create('Invalid source blending factor. Check the documentation for TBlendingFactor.');
+ if DestFactor in [bfDstColor, bfOneMinusDstColor] then
+ raise EImagingCanvasBlendingError.Create('Invalid destination blending factor. Check the documentation for TBlendingFactor.');
+ if DestCanvas.FormatInfo.IsIndexed then
+ raise EImagingCanvasBlendingError.Create('Blending destination canvas cannot be in indexed mode.');
+end;
+
+function TImagingCanvas.GetPixelPointer(X, Y: LongInt): Pointer;
+begin
+ Result := @PByteArray(FPData.Bits)[(Y * FPData.Width + X) * FFormatInfo.BytesPerPixel]
+end;
+
+procedure TImagingCanvas.TranslateFPToNative(const Color: TColorFPRec);
+begin
+ TranslateFPToNative(Color, @FNativeColor);
+end;
+
+procedure TImagingCanvas.TranslateFPToNative(const Color: TColorFPRec;
+ Native: Pointer);
+begin
+ ImagingFormats.TranslatePixel(@Color, Native, ifA32R32G32B32F,
+ FPData.Format, nil, FPData.Palette);
+end;
+
+procedure TImagingCanvas.UpdateCanvasState;
+begin
+ FDataSizeOnUpdate := FPData.Size;
+ ResetClipRect;
+ Imaging.GetImageFormatInfo(FPData.Format, FFormatInfo)
+end;
+
+procedure TImagingCanvas.ResetClipRect;
+begin
+ FClipRect := Rect(0, 0, FPData.Width, FPData.Height)
+end;
+
+procedure TImagingCanvas.Clear;
+begin
+ TranslateFPToNative(FFillColorFP);
+ Imaging.FillRect(FPData^, 0, 0, FPData.Width, FPData.Height, @FNativeColor);
+end;
+
+function TImagingCanvas.ClipAxisParallelLine(var A1, A2, B: LongInt;
+ AStart, AStop, BStart, BStop: LongInt): Boolean;
+begin
+ if (B >= BStart) and (B < BStop) then
+ begin
+ SwapMin(A1, A2);
+ if A1 < AStart then A1 := AStart;
+ if A2 >= AStop then A2 := AStop - 1;
+ Result := True;
+ end
+ else
+ Result := False;
+end;
+
+procedure TImagingCanvas.HorzLineInternal(X1, X2, Y: LongInt; Color: Pointer;
+ Bpp: LongInt);
+var
+ I, WidthBytes: LongInt;
+ PixelPtr: PByte;
+begin
+ if (Y >= FClipRect.Top) and (Y < FClipRect.Bottom) then
+ begin
+ SwapMin(X1, X2);
+ X1 := Max(X1, FClipRect.Left);
+ X2 := Min(X2, FClipRect.Right);
+ PixelPtr := GetPixelPointer(X1, Y);
+ WidthBytes := (X2 - X1) * Bpp;
+ case Bpp of
+ 1: FillMemoryByte(PixelPtr, WidthBytes, PByte(Color)^);
+ 2: FillMemoryWord(PixelPtr, WidthBytes, PWord(Color)^);
+ 4: FillMemoryLongWord(PixelPtr, WidthBytes, PLongWord(Color)^);
+ else
+ for I := X1 to X2 do
+ begin
+ ImagingFormats.CopyPixel(Color, PixelPtr, Bpp);
+ Inc(PixelPtr, Bpp);
+ end;
+ end;
+ end;
+end;
+
+procedure TImagingCanvas.CopyPixelInternal(X, Y: LongInt; Pixel: Pointer;
+ Bpp: LongInt);
+begin
+ if (X >= FClipRect.Left) and (Y >= FClipRect.Top) and
+ (X < FClipRect.Right) and (Y < FClipRect.Bottom) then
+ begin
+ ImagingFormats.CopyPixel(Pixel, GetPixelPointer(X, Y), Bpp);
+ end;
+end;
+
+procedure TImagingCanvas.HorzLine(X1, X2, Y: LongInt);
+var
+ DstRect: TRect;
+begin
+ if FPenMode = pmClear then Exit;
+ SwapMin(X1, X2);
+ if IntersectRect(DstRect, Rect(X1, Y - FPenWidth div 2, X2,
+ Y + FPenWidth div 2 + FPenWidth mod 2), FClipRect) then
+ begin
+ TranslateFPToNative(FPenColorFP);
+ Imaging.FillRect(FPData^, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left,
+ DstRect.Bottom - DstRect.Top, @FNativeColor);
+ end;
+end;
+
+procedure TImagingCanvas.VertLine(X, Y1, Y2: LongInt);
+var
+ DstRect: TRect;
+begin
+ if FPenMode = pmClear then Exit;
+ SwapMin(Y1, Y2);
+ if IntersectRect(DstRect, Rect(X - FPenWidth div 2, Y1,
+ X + FPenWidth div 2 + FPenWidth mod 2, Y2), FClipRect) then
+ begin
+ TranslateFPToNative(FPenColorFP);
+ Imaging.FillRect(FPData^, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left,
+ DstRect.Bottom - DstRect.Top, @FNativeColor);
+ end;
+end;
+
+procedure TImagingCanvas.Line(X1, Y1, X2, Y2: LongInt);
+var
+ Steep: Boolean;
+ Error, YStep, DeltaX, DeltaY, X, Y, I, Bpp, W1, W2, Code1, Code2: LongInt;
+begin
+ if FPenMode = pmClear then Exit;
+
+ // If line is vertical or horizontal just call appropriate method
+ if X2 - X1 = 0 then
+ begin
+ HorzLine(X1, X2, Y1);
+ Exit;
+ end;
+ if Y2 - Y1 = 0 then
+ begin
+ VertLine(X1, Y1, Y2);
+ Exit;
+ end;
+
+ // Determine if line is steep (angle with X-axis > 45 degrees)
+ Steep := Abs(Y2 - Y1) > Abs(X2 - X1);
+
+ // If we need to draw thick line we just draw more 1 pixel lines around
+ // the one we already drawn. Setting FLineRecursion assures that we
+ // won't be doing recursions till the end of the world.
+ if (FPenWidth > 1) and not FLineRecursion then
+ begin
+ FLineRecursion := True;
+ W1 := FPenWidth div 2;
+ W2 := W1;
+ if FPenWidth mod 2 = 0 then
+ Dec(W1);
+ if Steep then
+ begin
+ // Add lines left/right
+ for I := 1 to W1 do
+ Line(X1, Y1 - I, X2, Y2 - I);
+ for I := 1 to W2 do
+ Line(X1, Y1 + I, X2, Y2 + I);
+ end
+ else
+ begin
+ // Add lines above/under
+ for I := 1 to W1 do
+ Line(X1 - I, Y1, X2 - I, Y2);
+ for I := 1 to W2 do
+ Line(X1 + I, Y1, X2 + I, Y2);
+ end;
+ FLineRecursion := False;
+ end;
+
+ with FClipRect do
+ begin
+ // Use part of Cohen-Sutherland line clipping to determine if any part of line
+ // is in ClipRect
+ Code1 := Ord(X1 < Left) + Ord(X1 > Right) shl 1 + Ord(Y1 < Top) shl 2 + Ord(Y1 > Bottom) shl 3;
+ Code2 := Ord(X2 < Left) + Ord(X2 > Right) shl 1 + Ord(Y2 < Top) shl 2 + Ord(Y2 > Bottom) shl 3;
+ end;
+
+ if (Code1 and Code2) = 0 then
+ begin
+ TranslateFPToNative(FPenColorFP);
+ Bpp := FFormatInfo.BytesPerPixel;
+
+ // If line is steep swap X and Y coordinates so later we just have one loop
+ // of two (where only one is used according to steepness).
+ if Steep then
+ begin
+ SwapValues(X1, Y1);
+ SwapValues(X2, Y2);
+ end;
+ if X1 > X2 then
+ begin
+ SwapValues(X1, X2);
+ SwapValues(Y1, Y2);
+ end;
+
+ DeltaX := X2 - X1;
+ DeltaY := Abs(Y2 - Y1);
+ YStep := Iff(Y2 > Y1, 1, -1);
+ Error := 0;
+ Y := Y1;
+
+ // Draw line using Bresenham algorithm. No real line clipping here,
+ // just don't draw pixels outsize clip rect.
+ for X := X1 to X2 do
+ begin
+ if Steep then
+ CopyPixelInternal(Y, X, @FNativeColor, Bpp)
+ else
+ CopyPixelInternal(X, Y, @FNativeColor, Bpp);
+ Error := Error + DeltaY;
+ if Error * 2 >= DeltaX then
+ begin
+ Inc(Y, YStep);
+ Dec(Error, DeltaX);
+ end;
+ end;
+ end;
+end;
+
+procedure TImagingCanvas.FrameRect(const Rect: TRect);
+var
+ HalfPen, PenMod: LongInt;
+begin
+ if FPenMode = pmClear then Exit;
+ HalfPen := FPenWidth div 2;
+ PenMod := FPenWidth mod 2;
+ HorzLine(Rect.Left - HalfPen, Rect.Right + HalfPen + PenMod - 1, Rect.Top);
+ HorzLine(Rect.Left - HalfPen, Rect.Right + HalfPen + PenMod - 1, Rect.Bottom - 1);
+ VertLine(Rect.Left, Rect.Top, Rect.Bottom);
+ VertLine(Rect.Right - 1, Rect.Top, Rect.Bottom);
+end;
+
+procedure TImagingCanvas.FillRect(const Rect: TRect);
+var
+ DstRect: TRect;
+begin
+ if (FFillMode <> fmClear) and IntersectRect(DstRect, Rect, FClipRect) then
+ begin
+ TranslateFPToNative(FFillColorFP);
+ Imaging.FillRect(FPData^, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left,
+ DstRect.Bottom - DstRect.Top, @FNativeColor);
+ end;
+end;
+
+procedure TImagingCanvas.FillRectBlend(const Rect: TRect; SrcFactor,
+ DestFactor: TBlendingFactor);
+var
+ DstRect: TRect;
+ X, Y: Integer;
+ Line: PByte;
+begin
+ if (FFillMode <> fmClear) and IntersectRect(DstRect, Rect, FClipRect) then
+ begin
+ CheckBeforeBlending(SrcFactor, DestFactor, Self);
+ for Y := DstRect.Top to DstRect.Bottom - 1 do
+ begin
+ Line := @PByteArray(FPData.Bits)[(Y * FPData.Width + DstRect.Left) * FFormatInfo.BytesPerPixel];
+ for X := DstRect.Left to DstRect.Right - 1 do
+ begin
+ PixelBlendProc(FFillColorFP, Line, @FFormatInfo, SrcFactor, DestFactor);
+ Inc(Line, FFormatInfo.BytesPerPixel);
+ end;
+ end;
+ end;
+end;
+
+procedure TImagingCanvas.Rectangle(const Rect: TRect);
+begin
+ FillRect(Rect);
+ FrameRect(Rect);
+end;
+
+procedure TImagingCanvas.Ellipse(const Rect: TRect);
+var
+ RadX, RadY, DeltaX, DeltaY, R, RX, RY: LongInt;
+ X1, X2, Y1, Y2, Bpp, OldY: LongInt;
+ Fill, Pen: TColorFPRec;
+begin
+ // TODO: Use PenWidth
+ X1 := Rect.Left;
+ X2 := Rect.Right;
+ Y1 := Rect.Top;
+ Y2 := Rect.Bottom;
+
+ TranslateFPToNative(FPenColorFP, @Pen);
+ TranslateFPToNative(FFillColorFP, @Fill);
+ Bpp := FFormatInfo.BytesPerPixel;
+
+ SwapMin(X1, X2);
+ SwapMin(Y1, Y2);
+
+ RadX := (X2 - X1) div 2;
+ RadY := (Y2 - Y1) div 2;
+
+ Y1 := Y1 + RadY;
+ Y2 := Y1;
+ OldY := Y1;
+
+ DeltaX := (RadX * RadX);
+ DeltaY := (RadY * RadY);
+ R := RadX * RadY * RadY;
+ RX := R;
+ RY := 0;
+
+ if (FFillMode <> fmClear) then
+ HorzLineInternal(X1, X2, Y1, @Fill, Bpp);
+ CopyPixelInternal(X1, Y1, @Pen, Bpp);
+ CopyPixelInternal(X2, Y1, @Pen, Bpp);
+
+ while RadX > 0 do
+ begin
+ if R > 0 then
+ begin
+ Inc(Y1);
+ Dec(Y2);
+ Inc(RY, DeltaX);
+ Dec(R, RY);
+ end;
+ if R <= 0 then
+ begin
+ Dec(RadX);
+ Inc(X1);
+ Dec(X2);
+ Dec(RX, DeltaY);
+ Inc(R, RX);
+ end;
+
+ if (OldY <> Y1) and (FFillMode <> fmClear) then
+ begin
+ HorzLineInternal(X1, X2, Y1, @Fill, Bpp);
+ HorzLineInternal(X1, X2, Y2, @Fill, Bpp);
+ end;
+ OldY := Y1;
+
+ CopyPixelInternal(X1, Y1, @Pen, Bpp);
+ CopyPixelInternal(X2, Y1, @Pen, Bpp);
+ CopyPixelInternal(X1, Y2, @Pen, Bpp);
+ CopyPixelInternal(X2, Y2, @Pen, Bpp);
+ end;
+end;
+
+procedure TImagingCanvas.FloodFill(X, Y: Integer; BoundaryFillMode: Boolean);
+var
+ Stack: array of TPoint;
+ StackPos, Y1: Integer;
+ OldColor: TColor32;
+ SpanLeft, SpanRight: Boolean;
+
+ procedure Push(AX, AY: Integer);
+ begin
+ if StackPos < High(Stack) then
+ begin
+ Inc(StackPos);
+ Stack[StackPos].X := AX;
+ Stack[StackPos].Y := AY;
+ end
+ else
+ begin
+ SetLength(Stack, Length(Stack) + FPData.Width);
+ Push(AX, AY);
+ end;
+ end;
+
+ function Pop(out AX, AY: Integer): Boolean;
+ begin
+ if StackPos > 0 then
+ begin
+ AX := Stack[StackPos].X;
+ AY := Stack[StackPos].Y;
+ Dec(StackPos);
+ Result := True;
+ end
+ else
+ Result := False;
+ end;
+
+ function Compare(AX, AY: Integer): Boolean;
+ var
+ Color: TColor32;
+ begin
+ Color := GetPixel32(AX, AY);
+ if BoundaryFillMode then
+ Result := (Color <> FFillColor32) and (Color <> FPenColor32)
+ else
+ Result := Color = OldColor;
+ end;
+
+begin
+ // Scanline Floodfill Algorithm With Stack
+ // http://student.kuleuven.be/~m0216922/CG/floodfill.html
+
+ if not PtInRect(FClipRect, Point(X, Y)) then Exit;
+
+ SetLength(Stack, FPData.Width * 4);
+ StackPos := 0;
+
+ OldColor := GetPixel32(X, Y);
+
+ Push(X, Y);
+
+ while Pop(X, Y) do
+ begin
+ Y1 := Y;
+ while (Y1 >= FClipRect.Top) and Compare(X, Y1) do
+ Dec(Y1);
+
+ Inc(Y1);
+ SpanLeft := False;
+ SpanRight := False;
+
+ while (Y1 < FClipRect.Bottom) and Compare(X, Y1) do
+ begin
+ SetPixel32(X, Y1, FFillColor32);
+ if not SpanLeft and (X > FClipRect.Left) and Compare(X - 1, Y1) then
+ begin
+ Push(X - 1, Y1);
+ SpanLeft := True;
+ end
+ else if SpanLeft and (X > FClipRect.Left) and not Compare(X - 1, Y1) then
+ SpanLeft := False
+ else if not SpanRight and (X < FClipRect.Right - 1) and Compare(X + 1, Y1)then
+ begin
+ Push(X + 1, Y1);
+ SpanRight := True;
+ end
+ else if SpanRight and (X < FClipRect.Right - 1) and not Compare(X + 1, Y1) then
+ SpanRight := False;
+
+ Inc(Y1);
+ 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,
+ Divisor: LongInt; Bias: Single; ClampChannels: Boolean);
+var
+ X, Y, I, J, PosY, PosX, SizeDiv2, KernelValue, WidthBytes, Bpp: LongInt;
+ R, G, B, DivFloat: Single;
+ Pixel: TColorFPRec;
+ TempImage: TImageData;
+ DstPointer, SrcPointer: PByte;
+begin
+ SizeDiv2 := KernelSize div 2;
+ DivFloat := IffFloat(Divisor > 1, 1.0 / Divisor, 1.0);
+ Bpp := FFormatInfo.BytesPerPixel;
+ WidthBytes := FPData.Width * Bpp;
+
+ 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
+ // Reset accumulators
+ R := 0.0;
+ G := 0.0;
+ B := 0.0;
+
+ for J := 0 to KernelSize - 1 do
+ begin
+ PosY := ClampInt(Y + J - SizeDiv2, FClipRect.Top, FClipRect.Bottom - 1);
+
+ for I := 0 to KernelSize - 1 do
+ begin
+ PosX := ClampInt(X + I - SizeDiv2, FClipRect.Left, FClipRect.Right - 1);
+ SrcPointer := @PByteArray(TempImage.Bits)[PosY * WidthBytes + PosX * Bpp];
+
+ // Get pixels from neighbourhood of current pixel and add their
+ // colors to accumulators weighted by filter kernel values
+ Pixel := FFormatInfo.GetPixelFP(SrcPointer, @FFormatInfo, TempImage.Palette);
+ KernelValue := PLongIntArray(Kernel)[J * KernelSize + I];
+
+ R := R + Pixel.R * KernelValue;
+ G := G + Pixel.G * KernelValue;
+ B := B + Pixel.B * KernelValue;
+ end;
+ end;
+
+ Pixel := FFormatInfo.GetPixelFP(DstPointer, @FFormatInfo, FPData.Palette);
+
+ Pixel.R := R * DivFloat + Bias;
+ Pixel.G := G * DivFloat + Bias;
+ Pixel.B := B * DivFloat + Bias;
+
+ if ClampChannels then
+ ClampFloatPixel(Pixel);
+
+ // Set resulting pixel color
+ FFormatInfo.SetPixelFP(DstPointer, @FFormatInfo, FPData.Palette, Pixel);
+
+ Inc(DstPointer, Bpp);
+ end;
+ end;
+
+ finally
+ FreeImage(TempImage);
+ end;
+end;
+
+procedure TImagingCanvas.ApplyConvolution3x3(const Filter: TConvolutionFilter3x3);
+begin
+ ApplyConvolution(@Filter.Kernel, 3, Filter.Divisor, Filter.Bias, True);
+end;
+
+procedure TImagingCanvas.ApplyConvolution5x5(const Filter: TConvolutionFilter5x5);
+begin
+ ApplyConvolution(@Filter.Kernel, 5, Filter.Divisor, Filter.Bias, True);
+end;
+
+procedure TImagingCanvas.ApplyNonLinearFilter(FilterSize: Integer; SelectFunc: TSelectPixelFunction);
+var
+ X, Y, I, J, PosY, PosX, SizeDiv2, WidthBytes, Bpp: LongInt;
+ Pixel: TColorFPRec;
+ TempImage: TImageData;
+ DstPointer, SrcPointer: PByte;
+ NeighPixels: TDynFPPixelArray;
+begin
+ SizeDiv2 := FilterSize div 2;
+ Bpp := FFormatInfo.BytesPerPixel;
+ WidthBytes := FPData.Width * Bpp;
+ SetLength(NeighPixels, FilterSize * FilterSize);
+
+ InitImage(TempImage);
+ CloneImage(FPData^, TempImage);
+
+ try
+ // For every pixel in clip rect
+ for Y := FClipRect.Top to FClipRect.Bottom - 1 do
+ begin
+ DstPointer := @PByteArray(FPData.Bits)[Y * WidthBytes + FClipRect.Left * Bpp];
+
+ for X := FClipRect.Left to FClipRect.Right - 1 do
+ begin
+ for J := 0 to FilterSize - 1 do
+ begin
+ PosY := ClampInt(Y + J - SizeDiv2, FClipRect.Top, FClipRect.Bottom - 1);
+
+ for I := 0 to FilterSize - 1 do
+ begin
+ PosX := ClampInt(X + I - SizeDiv2, FClipRect.Left, FClipRect.Right - 1);
+ SrcPointer := @PByteArray(TempImage.Bits)[PosY * WidthBytes + PosX * Bpp];
+
+ // Get pixels from neighbourhood of current pixel and store them
+ Pixel := FFormatInfo.GetPixelFP(SrcPointer, @FFormatInfo, TempImage.Palette);
+ NeighPixels[J * FilterSize + I] := Pixel;
+ end;
+ end;
+
+ // Choose pixel using custom function
+ Pixel := SelectFunc(NeighPixels);
+ // Set resulting pixel color
+ FFormatInfo.SetPixelFP(DstPointer, @FFormatInfo, FPData.Palette, Pixel);
+
+ Inc(DstPointer, Bpp);
+ end;
+ end;
+
+ finally
+ FreeImage(TempImage);
+ end;
+end;
+
+procedure TImagingCanvas.ApplyMedianFilter(FilterSize: Integer);
+begin
+ ApplyNonLinearFilter(FilterSize, MedianSelect);
+end;
+
+procedure TImagingCanvas.ApplyMinFilter(FilterSize: Integer);
+begin
+ ApplyNonLinearFilter(FilterSize, MinSelect);
+end;
+
+procedure TImagingCanvas.ApplyMaxFilter(FilterSize: Integer);
+begin
+ ApplyNonLinearFilter(FilterSize, MaxSelect);
+end;
+
+procedure TImagingCanvas.PointTransform(Transform: TPointTransformFunction;
+ Param1, Param2, Param3: Single);
+var
+ X, Y, Bpp, WidthBytes: Integer;
+ PixPointer: PByte;
+ Pixel: TColorFPRec;
+begin
+ Bpp := FFormatInfo.BytesPerPixel;
+ WidthBytes := FPData.Width * Bpp;
+
+ // For every pixel in clip rect
+ for Y := FClipRect.Top to FClipRect.Bottom - 1 do
+ begin
+ PixPointer := @PByteArray(FPData.Bits)[Y * WidthBytes + FClipRect.Left * Bpp];
+ for X := FClipRect.Left to FClipRect.Right - 1 do
+ begin
+ Pixel := FFormatInfo.GetPixelFP(PixPointer, @FFormatInfo, FPData.Palette);
+
+ FFormatInfo.SetPixelFP(PixPointer, @FFormatInfo, FPData.Palette,
+ Transform(Pixel, Param1, Param2, Param3));
+
+ Inc(PixPointer, Bpp);
+ end;
+ end;
+end;
+
+procedure TImagingCanvas.ModifyContrastBrightness(Contrast, Brightness: Single);
+begin
+ PointTransform(TransformContrastBrightness, 1.0 + Contrast / 100,
+ Brightness / 100, 0);
+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;
+
+procedure TImagingCanvas.AdjustColorLevels(BlackPoint, WhitePoint, MidPoint: Single);
+begin
+ PointTransform(TransformLevels, BlackPoint, WhitePoint, 1.0 / MidPoint);
+end;
+
+procedure TImagingCanvas.PremultiplyAlpha;
+begin
+ PointTransform(TransformPremultiplyAlpha, 0, 0, 0);
+end;
+
+procedure TImagingCanvas.UnPremultiplyAlpha;
+begin
+ PointTransform(TransformUnPremultiplyAlpha, 0, 0, 0);
+end;
+
+procedure TImagingCanvas.GetHistogram(out Red, Green, Blue, Alpha,
+ Gray: THistogramArray);
+var
+ X, Y, Bpp: Integer;
+ PixPointer: PByte;
+ Color32: TColor32Rec;
+begin
+ FillChar(Red, SizeOf(Red), 0);
+ FillChar(Green, SizeOf(Green), 0);
+ FillChar(Blue, SizeOf(Blue), 0);
+ FillChar(Alpha, SizeOf(Alpha), 0);
+ FillChar(Gray, SizeOf(Gray), 0);
+
+ Bpp := FFormatInfo.BytesPerPixel;
+
+ for Y := FClipRect.Top to FClipRect.Bottom - 1 do
+ begin
+ PixPointer := @PByteArray(FPData.Bits)[Y * FPData.Width * Bpp + FClipRect.Left * Bpp];
+ for X := FClipRect.Left to FClipRect.Right - 1 do
+ begin
+ Color32 := FFormatInfo.GetPixel32(PixPointer, @FFormatInfo, FPData.Palette);
+
+ Inc(Red[Color32.R]);
+ Inc(Green[Color32.G]);
+ Inc(Blue[Color32.B]);
+ Inc(Alpha[Color32.A]);
+ Inc(Gray[Round(GrayConv.R * Color32.R + GrayConv.G * Color32.G + GrayConv.B * Color32.B)]);
+
+ Inc(PixPointer, Bpp);
+ end;
+ end;
+end;
+
+procedure TImagingCanvas.FillChannel(ChannelId: Integer; NewChannelValue: Byte);
+var
+ X, Y, Bpp: Integer;
+ PixPointer: PByte;
+ Color32: TColor32Rec;
+begin
+ Bpp := FFormatInfo.BytesPerPixel;
+
+ for Y := FClipRect.Top to FClipRect.Bottom - 1 do
+ begin
+ PixPointer := @PByteArray(FPData.Bits)[Y * FPData.Width * Bpp + FClipRect.Left * Bpp];
+ for X := FClipRect.Left to FClipRect.Right - 1 do
+ begin
+ Color32 := FFormatInfo.GetPixel32(PixPointer, @FFormatInfo, FPData.Palette);
+ Color32.Channels[ChannelId] := NewChannelValue;
+ FFormatInfo.SetPixel32(PixPointer, @FFormatInfo, FPData.Palette, Color32);
+
+ Inc(PixPointer, Bpp);
+ end;
+ end;
+end;
+
+procedure TImagingCanvas.FillChannelFP(ChannelId: Integer; NewChannelValue: Single);
+var
+ X, Y, Bpp: Integer;
+ PixPointer: PByte;
+ ColorFP: TColorFPRec;
+begin
+ Bpp := FFormatInfo.BytesPerPixel;
+
+ for Y := FClipRect.Top to FClipRect.Bottom - 1 do
+ begin
+ PixPointer := @PByteArray(FPData.Bits)[Y * FPData.Width * Bpp + FClipRect.Left * Bpp];
+ for X := FClipRect.Left to FClipRect.Right - 1 do
+ begin
+ ColorFP := FFormatInfo.GetPixelFP(PixPointer, @FFormatInfo, FPData.Palette);
+ ColorFP.Channels[ChannelId] := NewChannelValue;
+ FFormatInfo.SetPixelFP(PixPointer, @FFormatInfo, FPData.Palette, ColorFP);
+
+ Inc(PixPointer, Bpp);
+ end;
+ end;
+end;
+
+class function TImagingCanvas.GetSupportedFormats: TImageFormats;
+begin
+ Result := [ifIndex8..Pred(ifDXT1)];
+end;
+
+{ TFastARGB32Canvas }
+
+destructor TFastARGB32Canvas.Destroy;
+begin
+ FreeMem(FScanlines);
+ inherited Destroy;
+end;
+
+procedure TFastARGB32Canvas.AlphaBlendPixels(SrcPix, DestPix: PColor32Rec);
+var
+ SrcAlpha, DestAlpha, FinalAlpha: Integer;
+begin
+ FinalAlpha := SrcPix.A + 1 + (DestPix.A * (256 - SrcPix.A)) shr 8;
+ if FinalAlpha = 0 then
+ SrcAlpha := 0
+ else
+ SrcAlpha := (SrcPix.A shl 8) div FinalAlpha;
+ DestAlpha := 256 - SrcAlpha;
+
+ DestPix.A := ClampToByte(FinalAlpha);
+ DestPix.R := (SrcPix.R * SrcAlpha + DestPix.R * DestAlpha) shr 8;
+ DestPix.G := (SrcPix.G * SrcAlpha + DestPix.G * DestAlpha) shr 8;
+ DestPix.B := (SrcPix.B * SrcAlpha + DestPix.B * DestAlpha) shr 8;
+end;
+
+procedure TFastARGB32Canvas.DrawAlpha(const SrcRect: TRect;
+ DestCanvas: TImagingCanvas; DestX, DestY: Integer);
+var
+ X, Y, SrcX, SrcY, Width, Height: Integer;
+ SrcPix, DestPix: PColor32Rec;
+begin
+ if DestCanvas.ClassType <> Self.ClassType then
+ begin
+ inherited;
+ Exit;
+ end;
+
+ SrcX := SrcRect.Left;
+ SrcY := SrcRect.Top;
+ Width := SrcRect.Right - SrcRect.Left;
+ Height := SrcRect.Bottom - SrcRect.Top;
+ ClipCopyBounds(SrcX, SrcY, Width, Height, DestX, DestY,
+ FPData.Width, FPData.Height, DestCanvas.ClipRect);
+
+ for Y := 0 to Height - 1 do
+ begin
+ SrcPix := @FScanlines[SrcY + Y, SrcX];
+ DestPix := @TFastARGB32Canvas(DestCanvas).FScanlines[DestY + Y, DestX];
+ for X := 0 to Width - 1 do
+ begin
+ AlphaBlendPixels(SrcPix, DestPix);
+ Inc(SrcPix);
+ Inc(DestPix);
+ end;
+ end;
+end;
+
+function TFastARGB32Canvas.GetPixel32(X, Y: LongInt): TColor32;
+begin
+ Result := FScanlines[Y, X].Color;
+end;
+
+procedure TFastARGB32Canvas.SetPixel32(X, Y: LongInt; const Value: TColor32);
+begin
+ if (X >= FClipRect.Left) and (Y >= FClipRect.Top) and
+ (X < FClipRect.Right) and (Y < FClipRect.Bottom) then
+ begin
+ FScanlines[Y, X].Color := Value;
+ end;
+end;
+
+procedure TFastARGB32Canvas.StretchDrawAlpha(const SrcRect: TRect;
+ DestCanvas: TImagingCanvas; const DestRect: TRect; Filter: TResizeFilter);
+var
+ X, Y, ScaleX, ScaleY, Yp, Xp, Weight1, Weight2, Weight3, Weight4,
+ FracX, FracY, InvFracY, T1, T2: Integer;
+ SrcX, SrcY, SrcWidth, SrcHeight: Integer;
+ DestX, DestY, DestWidth, DestHeight: Integer;
+ SrcLine, SrcLine2: PColor32RecArray;
+ DestPix: PColor32Rec;
+ Accum: TColor32Rec;
+begin
+ if (Filter = rfBicubic) or (DestCanvas.ClassType <> Self.ClassType) then
+ begin
+ inherited;
+ Exit;
+ end;
+
+ 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;
+ // Clip src and dst rects
+ ClipStretchBounds(SrcX, SrcY, SrcWidth, SrcHeight, DestX, DestY, DestWidth, DestHeight,
+ FPData.Width, FPData.Height, DestCanvas.ClipRect);
+ ScaleX := (SrcWidth shl 16) div DestWidth;
+ ScaleY := (SrcHeight shl 16) div DestHeight;
+
+ // Nearest and linear filtering using fixed point math
+
+ if Filter = rfNearest then
+ begin
+ Yp := 0;
+ for Y := DestY to DestY + DestHeight - 1 do
+ begin
+ Xp := 0;
+ SrcLine := @FScanlines[SrcY + Yp shr 16, SrcX];
+ DestPix := @TFastARGB32Canvas(DestCanvas).FScanlines[Y, DestX];
+ for X := 0 to DestWidth - 1 do
+ begin
+ AlphaBlendPixels(@SrcLine[Xp shr 16], DestPix);
+ Inc(DestPix);
+ Inc(Xp, ScaleX);
+ end;
+ Inc(Yp, ScaleY);
+ end;
+ end
+ else
+ begin
+ Yp := (ScaleY shr 1) - $8000;
+ for Y := DestY to DestY + DestHeight - 1 do
+ begin
+ DestPix := @TFastARGB32Canvas(DestCanvas).FScanlines[Y, DestX];
+ if Yp < 0 then
+ begin
+ T1 := 0;
+ FracY := 0;
+ InvFracY := $10000;
+ end
+ else
+ begin
+ T1 := Yp shr 16;
+ FracY := Yp and $FFFF;
+ InvFracY := (not Yp and $FFFF) + 1;
+ end;
+
+ T2 := Iff(T1 < SrcHeight - 1, T1 + 1, T1);
+ SrcLine := @Scanlines[T1 + SrcY, SrcX];
+ SrcLine2 := @Scanlines[T2 + SrcY, SrcX];
+ Xp := (ScaleX shr 1) - $8000;
+
+ for X := 0 to DestWidth - 1 do
+ begin
+ if Xp < 0 then
+ begin
+ T1 := 0;
+ FracX := 0;
+ end
+ else
+ begin
+ T1 := Xp shr 16;
+ FracX := Xp and $FFFF;
+ end;
+
+ T2 := Iff(T1 < SrcWidth - 1, T1 + 1, T1);
+ Weight2:= (Cardinal(InvFracY) * FracX) shr 16; // cast to Card, Int can overflow gere
+ Weight1:= InvFracY - Weight2;
+ Weight4:= (Cardinal(FracY) * FracX) shr 16;
+ Weight3:= FracY - Weight4;
+
+ Accum.B := (SrcLine[T1].B * Weight1 + SrcLine[T2].B * Weight2 +
+ SrcLine2[T1].B * Weight3 + SrcLine2[T2].B * Weight4 + $8000) shr 16;
+ Accum.G := (SrcLine[T1].G * Weight1 + SrcLine[T2].G * Weight2 +
+ SrcLine2[T1].G * Weight3 + SrcLine2[T2].G * Weight4 + $8000) shr 16;
+ Accum.R := (SrcLine[T1].R * Weight1 + SrcLine[T2].R * Weight2 +
+ SrcLine2[T1].R * Weight3 + SrcLine2[T2].R * Weight4 + $8000) shr 16;
+ Accum.A := (SrcLine[T1].A * Weight1 + SrcLine[T2].A * Weight2 +
+ SrcLine2[T1].A * Weight3 + SrcLine2[T2].A * Weight4 + $8000) shr 16;
+
+ AlphaBlendPixels(@Accum, DestPix);
+
+ Inc(Xp, ScaleX);
+ Inc(DestPix);
+ end;
+ Inc(Yp, ScaleY);
+ end;
+ end;
+ {
+
+ // 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;
+ AccumR := 0;
+ AccumG := 0;
+ AccumB := 0;
+ for Y := 0 to Length(ClusterY) - 1 do
+ begin
+ Weight := Round(ClusterY[Y].Weight * 256);
+ SrcColor := FScanlines[ClusterY[Y].Pos, X];
+
+ AccumB := AccumB + SrcColor.B * Weight;
+ AccumG := AccumG + SrcColor.G * Weight;
+ AccumR := AccumR + SrcColor.R * Weight;
+ AccumA := AccumA + SrcColor.A * Weight;
+ end;
+ with LineBuffer[X - XMinimum] do
+ begin
+ A := AccumA;
+ R := AccumR;
+ G := AccumG;
+ B := AccumB;
+ end;
+ end;
+
+ DestPtr := @TFastARGB32Canvas(DestCanvas).FScanlines[DestY + J, DestX];
+
+ for I := 0 to DestWidth - 1 do
+ begin
+ ClusterX := MapX[I];
+ AccumA := 0;
+ AccumR := 0;
+ AccumG := 0;
+ AccumB := 0;
+ for X := 0 to Length(ClusterX) - 1 do
+ begin
+ Weight := Round(ClusterX[X].Weight * 256);
+ 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;
+
+ AccumA := ClampInt(AccumA, 0, $00FF0000);
+ AccumR := ClampInt(AccumR, 0, $00FF0000);
+ AccumG := ClampInt(AccumG, 0, $00FF0000);
+ AccumB := ClampInt(AccumB, 0, $00FF0000);
+ SrcColor.Color := (Cardinal(AccumA and $00FF0000) shl 8) or
+ (AccumR and $00FF0000) or ((AccumG and $00FF0000) shr 8) or ((AccumB and $00FF0000) shr 16);
+
+ AlphaBlendPixels(@SrcColor, DestPtr);
+
+ Inc(DestPtr);
+ end;
+ end; }
+end;
+
+procedure TFastARGB32Canvas.UpdateCanvasState;
+var
+ I: LongInt;
+ ScanPos: PLongWord;
+begin
+ inherited UpdateCanvasState;
+
+ // Realloc and update scanline array
+ ReallocMem(FScanlines, FPData.Height * SizeOf(PColor32RecArray));
+ ScanPos := FPData.Bits;
+
+ for I := 0 to FPData.Height - 1 do
+ begin
+ FScanlines[I] := PColor32RecArray(ScanPos);
+ Inc(ScanPos, FPData.Width);
+ end;
+end;
+
+class function TFastARGB32Canvas.GetSupportedFormats: TImageFormats;
+begin
+ Result := [ifA8R8G8B8];
+end;
+
+procedure TFastARGB32Canvas.InvertColors;
+var
+ X, Y: Integer;
+ PixPtr: PColor32Rec;
+begin
+ for Y := FClipRect.Top to FClipRect.Bottom - 1 do
+ begin
+ PixPtr := @FScanlines[Y, FClipRect.Left];
+ for X := FClipRect.Left to FClipRect.Right - 1 do
+ begin
+ PixPtr.R := not PixPtr.R;
+ PixPtr.G := not PixPtr.G;
+ PixPtr.B := not PixPtr.B;
+ Inc(PixPtr);
+ end;
+ end;
+end;
+
+initialization
+ RegisterCanvas(TFastARGB32Canvas);
+
+finalization
+ FreeAndNil(CanvasClasses);
+
+{
+ File Notes:
+
+ -- TODOS ----------------------------------------------------
+ - more more more ...
+ - implement pen width everywhere
+ - add blending (*image and object drawing)
+ - more objects (arc, polygon)
+
+ -- 0.26.3 Changes/Bug Fixes ---------------------------------
+ - Added some methods to TFastARGB32Canvas (InvertColors, DrawAlpha/StretchDrawAlpha)
+ - Fixed DrawAlpha/StretchDrawAlpha destination alpha calculation.
+ - Added PremultiplyAlpha and UnPremultiplyAlpha methods.
+
+ -- 0.26.1 Changes/Bug Fixes ---------------------------------
+ - Added FillChannel methods.
+ - Added FloodFill method.
+ - Added GetHistogram method.
+ - Fixed "Invalid FP operation" in AdjustColorLevels in FPC compiled exes
+ (thanks to Carlos González).
+ - Added TImagingCanvas.AdjustColorLevels method.
+
+ -- 0.25.0 Changes/Bug Fixes ---------------------------------
+ - Fixed error that could cause AV in linear and nonlinear filters.
+ - Added blended rect filling function FillRectBlend.
+ - Added drawing function with blending (DrawAlpha, StretchDrawAlpha,
+ StretchDrawAdd, DrawBlend, StretchDrawBlend, ...)
+ - Added non-linear filters (min, max, median).
+ - Added point transforms (invert, contrast, gamma, brightness).
+
+ -- 0.21 Changes/Bug Fixes -----------------------------------
+ - Added some new filter kernels for convolution.
+ - Added FillMode and PenMode properties.
+ - Added FrameRect, Rectangle, Ellipse, and Line methods.
+ - Removed HorzLine and VertLine from TFastARGB32Canvas - new versions
+ in general canvas is now as fast as those in TFastARGB32Canvas
+ (only in case of A8R8G8B8 images of course).
+ - Added PenWidth property, updated HorzLine and VertLine to use it.
+
+ -- 0.19 Changes/Bug Fixes -----------------------------------
+ - added TFastARGB32Canvas
+ - added convolutions, hline, vline
+ - unit created, intial stuff added
+
+}
+
+end.
+
diff --git a/Imaging/ImagingClasses.pas b/Imaging/ImagingClasses.pas
index da80693..87f1d2a 100644
--- a/Imaging/ImagingClasses.pas
+++ b/Imaging/ImagingClasses.pas
@@ -1,997 +1,997 @@
-{
- $Id: ImagingClasses.pas 173 2009-09-04 17:05:52Z galfar $
- Vampyre Imaging Library
- by Marek Mauder
- http://imaginglib.sourceforge.net
-
- The contents of this file are used with permission, subject to the Mozilla
- Public License Version 1.1 (the "License"); you may not use this file except
- in compliance with the License. You may obtain a copy of the License at
- http://www.mozilla.org/MPL/MPL-1.1.html
-
- Software distributed under the License is distributed on an "AS IS" basis,
- WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
- the specific language governing rights and limitations under the License.
-
- Alternatively, the contents of this file may be used under the terms of the
- GNU Lesser General Public License (the "LGPL License"), in which case the
- provisions of the LGPL License are applicable instead of those above.
- If you wish to allow use of your version of this file only under the terms
- of the LGPL License and not to allow others to use your version of this file
- under the MPL, indicate your decision by deleting the provisions above and
- replace them with the notice and other provisions required by the LGPL
- License. If you do not delete the provisions above, a recipient may use
- your version of this file under either the MPL or the LGPL License.
-
- For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
-}
-
-{ This unit contains class based wrapper to Imaging library.}
-unit ImagingClasses;
-
-{$I ImagingOptions.inc}
-
-interface
-
-uses
- Types, Classes, ImagingTypes, Imaging, ImagingFormats, ImagingUtility;
-
-type
- { Base abstract high level class wrapper to low level Imaging structures and
- functions.}
- TBaseImage = class(TPersistent)
- protected
- FPData: PImageData;
- FOnDataSizeChanged: TNotifyEvent;
- FOnPixelsChanged: TNotifyEvent;
- function GetFormat: TImageFormat; {$IFDEF USE_INLINE}inline;{$ENDIF}
- function GetHeight: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
- function GetSize: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
- function GetWidth: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
- function GetBits: Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF}
- function GetPalette: PPalette32; {$IFDEF USE_INLINE}inline;{$ENDIF}
- function GetPaletteEntries: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
- function GetScanLine(Index: LongInt): Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF}
- function GetPixelPointer(X, Y: LongInt): Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF}
- function GetFormatInfo: TImageFormatInfo; {$IFDEF USE_INLINE}inline;{$ENDIF}
- function GetValid: Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF}
- function GetBoundsRect: TRect;
- procedure SetFormat(const Value: TImageFormat); {$IFDEF USE_INLINE}inline;{$ENDIF}
- procedure SetHeight(const Value: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
- procedure SetWidth(const Value: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
- procedure SetPointer; virtual; abstract;
- procedure DoDataSizeChanged; virtual;
- procedure DoPixelsChanged; virtual;
- published
- public
- constructor Create; virtual;
- constructor CreateFromImage(AImage: TBaseImage);
- destructor Destroy; override;
- { Returns info about current image.}
- function ToString: string;
-
- { Creates a new image data with the given size and format. Old image
- data is lost. Works only for the current image of TMultiImage.}
- procedure RecreateImageData(AWidth, AHeight: LongInt; AFormat: TImageFormat);
- { Resizes current image with optional resampling.}
- procedure Resize(NewWidth, NewHeight: LongInt; Filter: TResizeFilter);
- { Flips current image. Reverses the image along its horizontal axis the top
- becomes the bottom and vice versa.}
- procedure Flip;
- { Mirrors current image. Reverses the image along its vertical axis the left
- side becomes the right and vice versa.}
- procedure Mirror;
- { Rotates image by Angle degrees counterclockwise.}
- procedure Rotate(Angle: Single);
- { Copies rectangular part of SrcImage to DstImage. No blending is performed -
- alpha is simply copied to destination image. Operates also with
- negative X and Y coordinates.
- Note that copying is fastest for images in the same data format
- (and slowest for images in special formats).}
- procedure CopyTo(SrcX, SrcY, Width, Height: LongInt; DstImage: TBaseImage; DstX, DstY: LongInt);
- { Stretches the contents of the source rectangle to the destination rectangle
- with optional resampling. No blending is performed - alpha is
- simply copied/resampled to destination image. Note that stretching is
- fastest for images in the same data format (and slowest for
- images in special formats).}
- procedure StretchTo(SrcX, SrcY, SrcWidth, SrcHeight: LongInt; DstImage: TBaseImage; DstX, DstY, DstWidth, DstHeight: LongInt; Filter: TResizeFilter);
- { Replaces pixels with OldPixel in the given rectangle by NewPixel.
- OldPixel and NewPixel should point to the pixels in the same format
- as the given image is in.}
- procedure ReplaceColor(X, Y, Width, Height: LongInt; OldColor, NewColor: Pointer);
- { Swaps SrcChannel and DstChannel color or alpha channels of image.
- Use ChannelRed, ChannelBlue, ChannelGreen, ChannelAlpha constants to
- identify channels.}
- procedure SwapChannels(SrcChannel, DstChannel: LongInt);
-
- { Loads current image data from file.}
- procedure LoadFromFile(const FileName: string); virtual;
- { Loads current image data from stream.}
- procedure LoadFromStream(Stream: TStream); virtual;
-
- { Saves current image data to file.}
- procedure SaveToFile(const FileName: string);
- { Saves current image data to stream. Ext identifies desired image file
- format (jpg, png, dds, ...)}
- procedure SaveToStream(const Ext: string; Stream: TStream);
-
- { Width of current image in pixels.}
- property Width: LongInt read GetWidth write SetWidth;
- { Height of current image in pixels.}
- property Height: LongInt read GetHeight write SetHeight;
- { Image data format of current image.}
- property Format: TImageFormat read GetFormat write SetFormat;
- { Size in bytes of current image's data.}
- property Size: LongInt read GetSize;
- { Pointer to memory containing image bits.}
- property Bits: Pointer read GetBits;
- { Pointer to palette for indexed format images. It is nil for others.
- Max palette entry is at index [PaletteEntries - 1].}
- property Palette: PPalette32 read GetPalette;
- { Number of entries in image's palette}
- property PaletteEntries: LongInt read GetPaletteEntries;
- { Provides indexed access to each line of pixels. Does not work with special
- format images (like DXT).}
- property ScanLine[Index: LongInt]: Pointer read GetScanLine;
- { Returns pointer to image pixel at [X, Y] coordinates.}
- property PixelPointers[X, Y: LongInt]: Pointer read GetPixelPointer;
- { Extended image format information.}
- property FormatInfo: TImageFormatInfo read GetFormatInfo;
- { This gives complete access to underlying TImageData record.
- It can be used in functions that take TImageData as parameter
- (for example: ReduceColors(SingleImageInstance.ImageData^, 64)).}
- property ImageDataPointer: PImageData read FPData;
- { Indicates whether the current image is valid (proper format,
- allowed dimensions, right size, ...).}
- property Valid: Boolean read GetValid;
- {{ Specifies the bounding rectangle of the image.}
- property BoundsRect: TRect read GetBoundsRect;
- { This event occurs when the image data size has just changed. That means
- image width, height, or format has been changed.}
- property OnDataSizeChanged: TNotifyEvent read FOnDataSizeChanged write FOnDataSizeChanged;
- { This event occurs when some pixels of the image have just changed.}
- property OnPixelsChanged: TNotifyEvent read FOnPixelsChanged write FOnPixelsChanged;
- end;
-
- { Extension of TBaseImage which uses single TImageData record to
- store image. All methods inherited from TBaseImage work with this record.}
- TSingleImage = class(TBaseImage)
- protected
- FImageData: TImageData;
- procedure SetPointer; override;
- public
- constructor Create; override;
- constructor CreateFromParams(AWidth, AHeight: LongInt; AFormat: TImageFormat = ifDefault);
- constructor CreateFromData(const AData: TImageData);
- constructor CreateFromFile(const FileName: string);
- constructor CreateFromStream(Stream: TStream);
- destructor Destroy; override;
- { Assigns single image from another single image or multi image.}
- procedure Assign(Source: TPersistent); override;
- end;
-
- { Extension of TBaseImage which uses array of TImageData records to
- store multiple images. Images are independent on each other and they don't
- share any common characteristic. Each can have different size, format, and
- palette. All methods inherited from TBaseImage work only with
- active image (it could represent mipmap level, animation frame, or whatever).
- Methods whose names contain word 'Multi' work with all images in array
- (as well as other methods with obvious names).}
- TMultiImage = class(TBaseImage)
- protected
- FDataArray: TDynImageDataArray;
- FActiveImage: LongInt;
- procedure SetActiveImage(Value: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
- function GetImageCount: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
- procedure SetImageCount(Value: LongInt);
- function GetAllImagesValid: Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF}
- function GetImage(Index: LongInt): TImageData; {$IFDEF USE_INLINE}inline;{$ENDIF}
- procedure SetImage(Index: LongInt; Value: TImageData); {$IFDEF USE_INLINE}inline;{$ENDIF}
- procedure SetPointer; override;
- function PrepareInsert(Index, Count: LongInt): Boolean;
- procedure DoInsertImages(Index: LongInt; const Images: TDynImageDataArray);
- procedure DoInsertNew(Index: LongInt; AWidth, AHeight: LongInt; AFormat: TImageFormat);
- public
- constructor Create; override;
- constructor CreateFromParams(AWidth, AHeight: LongInt; AFormat: TImageFormat; Images: LongInt);
- constructor CreateFromArray(ADataArray: TDynImageDataArray);
- constructor CreateFromFile(const FileName: string);
- constructor CreateFromStream(Stream: TStream);
- destructor Destroy; override;
- { Assigns multi image from another multi image or single image.}
- procedure Assign(Source: TPersistent); override;
-
- { Adds new image at the end of the image array. }
- procedure AddImage(AWidth, AHeight: LongInt; AFormat: TImageFormat = ifDefault); overload;
- { Adds existing image at the end of the image array. }
- procedure AddImage(const Image: TImageData); overload;
- { Adds existing image (Active image of a TmultiImage)
- at the end of the image array. }
- procedure AddImage(Image: TBaseImage); overload;
- { Adds existing image array ((all images of a multi image))
- at the end of the image array. }
- procedure AddImages(const Images: TDynImageDataArray); overload;
- { Adds existing MultiImage images at the end of the image array. }
- procedure AddImages(Images: TMultiImage); overload;
-
- { Inserts new image image at the given position in the image array. }
- procedure InsertImage(Index, AWidth, AHeight: LongInt; AFormat: TImageFormat = ifDefault); overload;
- { Inserts existing image at the given position in the image array. }
- procedure InsertImage(Index: LongInt; const Image: TImageData); overload;
- { Inserts existing image (Active image of a TmultiImage)
- at the given position in the image array. }
- procedure InsertImage(Index: LongInt; Image: TBaseImage); overload;
- { Inserts existing image at the given position in the image array. }
- procedure InsertImages(Index: LongInt; const Images: TDynImageDataArray); overload;
- { Inserts existing images (all images of a TmultiImage) at
- the given position in the image array. }
- procedure InsertImages(Index: LongInt; Images: TMultiImage); overload;
-
- { Exchanges two images at the given positions in the image array. }
- procedure ExchangeImages(Index1, Index2: LongInt);
- { Deletes image at the given position in the image array.}
- procedure DeleteImage(Index: LongInt);
- { Rearranges images so that the first image will become last and vice versa.}
- procedure ReverseImages;
-
- { Converts all images to another image data format.}
- procedure ConvertImages(Format: TImageFormat);
- { Resizes all images.}
- procedure ResizeImages(NewWidth, NewHeight: LongInt; Filter: TResizeFilter);
-
- { Overloaded loading method that will add new image to multiimage if
- image array is empty bero loading. }
- procedure LoadFromFile(const FileName: string); override;
- { Overloaded loading method that will add new image to multiimage if
- image array is empty bero loading. }
- procedure LoadFromStream(Stream: TStream); override;
-
- { Loads whole multi image from file.}
- procedure LoadMultiFromFile(const FileName: string);
- { Loads whole multi image from stream.}
- procedure LoadMultiFromStream(Stream: TStream);
- { Saves whole multi image to file.}
- procedure SaveMultiToFile(const FileName: string);
- { Saves whole multi image to stream. Ext identifies desired
- image file format (jpg, png, dds, ...).}
- procedure SaveMultiToStream(const Ext: string; Stream: TStream);
-
- { Indicates active image of this multi image. All methods inherited
- from TBaseImage operate on this image only.}
- property ActiveImage: LongInt read FActiveImage write SetActiveImage;
- { Number of images of this multi image.}
- property ImageCount: LongInt read GetImageCount write SetImageCount;
- { This value is True if all images of this TMultiImage are valid.}
- property AllImagesValid: Boolean read GetAllImagesValid;
- { This gives complete access to underlying TDynImageDataArray.
- It can be used in functions that take TDynImageDataArray
- as parameter.}
- property DataArray: TDynImageDataArray read FDataArray;
- { Array property for accessing individual images of TMultiImage. When you
- set image at given index the old image is freed and the source is cloned.}
- property Images[Index: LongInt]: TImageData read GetImage write SetImage; default;
- end;
-
-implementation
-
-const
- DefaultWidth = 16;
- DefaultHeight = 16;
- DefaultImages = 1;
-
-function GetArrayFromImageData(const ImageData: TImageData): TDynImageDataArray;
-begin
- SetLength(Result, 1);
- Result[0] := ImageData;
-end;
-
-{ TBaseImage class implementation }
-
-constructor TBaseImage.Create;
-begin
- SetPointer;
-end;
-
-constructor TBaseImage.CreateFromImage(AImage: TBaseImage);
-begin
- Create;
- Assign(AImage);
-end;
-
-destructor TBaseImage.Destroy;
-begin
- inherited Destroy;
-end;
-
-function TBaseImage.GetWidth: LongInt;
-begin
- if Valid then
- Result := FPData.Width
- else
- Result := 0;
-end;
-
-function TBaseImage.GetHeight: LongInt;
-begin
- if Valid then
- Result := FPData.Height
- else
- Result := 0;
-end;
-
-function TBaseImage.GetFormat: TImageFormat;
-begin
- if Valid then
- Result := FPData.Format
- else
- Result := ifUnknown;
-end;
-
-function TBaseImage.GetScanLine(Index: LongInt): Pointer;
-var
- Info: TImageFormatInfo;
-begin
- if Valid then
- begin
- Info := GetFormatInfo;
- if not Info.IsSpecial then
- Result := ImagingFormats.GetScanLine(FPData.Bits, Info, FPData.Width, Index)
- else
- Result := FPData.Bits;
- end
- else
- Result := nil;
-end;
-
-function TBaseImage.GetPixelPointer(X, Y: LongInt): Pointer;
-begin
- if Valid then
- Result := @PByteArray(FPData.Bits)[(Y * FPData.Width + X) * GetFormatInfo.BytesPerPixel]
- else
- Result := nil;
-end;
-
-function TBaseImage.GetSize: LongInt;
-begin
- if Valid then
- Result := FPData.Size
- else
- Result := 0;
-end;
-
-function TBaseImage.GetBits: Pointer;
-begin
- if Valid then
- Result := FPData.Bits
- else
- Result := nil;
-end;
-
-function TBaseImage.GetPalette: PPalette32;
-begin
- if Valid then
- Result := FPData.Palette
- else
- Result := nil;
-end;
-
-function TBaseImage.GetPaletteEntries: LongInt;
-begin
- Result := GetFormatInfo.PaletteEntries;
-end;
-
-function TBaseImage.GetFormatInfo: TImageFormatInfo;
-begin
- if Valid then
- Imaging.GetImageFormatInfo(FPData.Format, Result)
- else
- FillChar(Result, SizeOf(Result), 0);
-end;
-
-function TBaseImage.GetValid: Boolean;
-begin
- Result := Assigned(FPData) and Imaging.TestImage(FPData^);
-end;
-
-function TBaseImage.GetBoundsRect: TRect;
-begin
- Result := Rect(0, 0, GetWidth, GetHeight);
-end;
-
-procedure TBaseImage.SetWidth(const Value: LongInt);
-begin
- Resize(Value, GetHeight, rfNearest);
-end;
-
-procedure TBaseImage.SetHeight(const Value: LongInt);
-begin
- Resize(GetWidth, Value, rfNearest);
-end;
-
-procedure TBaseImage.SetFormat(const Value: TImageFormat);
-begin
- if Valid and Imaging.ConvertImage(FPData^, Value) then
- DoDataSizeChanged;
-end;
-
-procedure TBaseImage.DoDataSizeChanged;
-begin
- if Assigned(FOnDataSizeChanged) then
- FOnDataSizeChanged(Self);
- DoPixelsChanged;
-end;
-
-procedure TBaseImage.DoPixelsChanged;
-begin
- if Assigned(FOnPixelsChanged) then
- FOnPixelsChanged(Self);
-end;
-
-procedure TBaseImage.RecreateImageData(AWidth, AHeight: LongInt; AFormat: TImageFormat);
-begin
- if Assigned(FPData) and Imaging.NewImage(AWidth, AHeight, AFormat, FPData^) then
- DoDataSizeChanged;
-end;
-
-procedure TBaseImage.Resize(NewWidth, NewHeight: LongInt; Filter: TResizeFilter);
-begin
- if Valid and Imaging.ResizeImage(FPData^, NewWidth, NewHeight, Filter) then
- DoDataSizeChanged;
-end;
-
-procedure TBaseImage.Flip;
-begin
- if Valid and Imaging.FlipImage(FPData^) then
- DoPixelsChanged;
-end;
-
-procedure TBaseImage.Mirror;
-begin
- if Valid and Imaging.MirrorImage(FPData^) then
- DoPixelsChanged;
-end;
-
-procedure TBaseImage.Rotate(Angle: Single);
-begin
- if Valid and Imaging.RotateImage(FPData^, Angle) then
- DoPixelsChanged;
-end;
-
-procedure TBaseImage.CopyTo(SrcX, SrcY, Width, Height: LongInt;
- DstImage: TBaseImage; DstX, DstY: LongInt);
-begin
- if Valid and Assigned(DstImage) and DstImage.Valid then
- begin
- Imaging.CopyRect(FPData^, SrcX, SrcY, Width, Height, DstImage.FPData^, DstX, DstY);
- DstImage.DoPixelsChanged;
- end;
-end;
-
-procedure TBaseImage.StretchTo(SrcX, SrcY, SrcWidth, SrcHeight: LongInt;
- DstImage: TBaseImage; DstX, DstY, DstWidth, DstHeight: LongInt; Filter: TResizeFilter);
-begin
- if Valid and Assigned(DstImage) and DstImage.Valid then
- begin
- Imaging.StretchRect(FPData^, SrcX, SrcY, SrcWidth, SrcHeight,
- DstImage.FPData^, DstX, DstY, DstWidth, DstHeight, Filter);
- DstImage.DoPixelsChanged;
- end;
-end;
-
-procedure TBaseImage.ReplaceColor(X, Y, Width, Height: Integer; OldColor,
- NewColor: Pointer);
-begin
- if Valid then
- begin
- Imaging.ReplaceColor(FPData^, X, Y, Width, Height, OldColor, NewColor);
- DoPixelsChanged;
- end;
-end;
-
-procedure TBaseImage.SwapChannels(SrcChannel, DstChannel: Integer);
-begin
- if Valid then
- begin
- Imaging.SwapChannels(FPData^, SrcChannel, DstChannel);
- DoPixelsChanged;
- end;
-end;
-
-function TBaseImage.ToString: string;
-begin
- Result := Iff(Valid, Imaging.ImageToStr(FPData^), 'empty image');
-end;
-
-procedure TBaseImage.LoadFromFile(const FileName: string);
-begin
- if Assigned(FPData) and Imaging.LoadImageFromFile(FileName, FPData^) then
- DoDataSizeChanged;
-end;
-
-procedure TBaseImage.LoadFromStream(Stream: TStream);
-begin
- if Assigned(FPData) and Imaging.LoadImageFromStream(Stream, FPData^) then
- DoDataSizeChanged;
-end;
-
-procedure TBaseImage.SaveToFile(const FileName: string);
-begin
- if Valid then
- Imaging.SaveImageToFile(FileName, FPData^);
-end;
-
-procedure TBaseImage.SaveToStream(const Ext: string; Stream: TStream);
-begin
- if Valid then
- Imaging.SaveImageToStream(Ext, Stream, FPData^);
-end;
-
-
-{ TSingleImage class implementation }
-
-constructor TSingleImage.Create;
-begin
- inherited Create;
- RecreateImageData(DefaultWidth, DefaultHeight, ifDefault);
-end;
-
-constructor TSingleImage.CreateFromParams(AWidth, AHeight: LongInt; AFormat: TImageFormat);
-begin
- inherited Create;
- RecreateImageData(AWidth, AHeight, AFormat);
-end;
-
-constructor TSingleImage.CreateFromData(const AData: TImageData);
-begin
- inherited Create;
- if Imaging.TestImage(AData) then
- begin
- Imaging.CloneImage(AData, FImageData);
- DoDataSizeChanged;
- end
- else
- Create;
-end;
-
-constructor TSingleImage.CreateFromFile(const FileName: string);
-begin
- inherited Create;
- LoadFromFile(FileName);
-end;
-
-constructor TSingleImage.CreateFromStream(Stream: TStream);
-begin
- inherited Create;
- LoadFromStream(Stream);
-end;
-
-destructor TSingleImage.Destroy;
-begin
- Imaging.FreeImage(FImageData);
- inherited Destroy;
-end;
-
-procedure TSingleImage.SetPointer;
-begin
- FPData := @FImageData;
-end;
-
-procedure TSingleImage.Assign(Source: TPersistent);
-begin
- if Source = nil then
- begin
- Create;
- end
- else if Source is TSingleImage then
- begin
- CreateFromData(TSingleImage(Source).FImageData);
- end
- else if Source is TMultiImage then
- begin
- if TMultiImage(Source).Valid then
- CreateFromData(TMultiImage(Source).FPData^)
- else
- Assign(nil);
- end
- else
- inherited Assign(Source);
-end;
-
-
-{ TMultiImage class implementation }
-
-constructor TMultiImage.Create;
-begin
- SetImageCount(DefaultImages);
- SetActiveImage(0);
-end;
-
-constructor TMultiImage.CreateFromParams(AWidth, AHeight: LongInt;
- AFormat: TImageFormat; Images: LongInt);
-var
- I: LongInt;
-begin
- Imaging.FreeImagesInArray(FDataArray);
- SetLength(FDataArray, Images);
- for I := 0 to GetImageCount - 1 do
- Imaging.NewImage(AWidth, AHeight, AFormat, FDataArray[I]);
- SetActiveImage(0);
-end;
-
-constructor TMultiImage.CreateFromArray(ADataArray: TDynImageDataArray);
-var
- I: LongInt;
-begin
- Imaging.FreeImagesInArray(FDataArray);
- SetLength(FDataArray, Length(ADataArray));
- for I := 0 to GetImageCount - 1 do
- begin
- // Clone only valid images
- if Imaging.TestImage(ADataArray[I]) then
- Imaging.CloneImage(ADataArray[I], FDataArray[I])
- else
- Imaging.NewImage(DefaultWidth, DefaultHeight, ifDefault, FDataArray[I]);
- end;
- SetActiveImage(0);
-end;
-
-constructor TMultiImage.CreateFromFile(const FileName: string);
-begin
- LoadMultiFromFile(FileName);
-end;
-
-constructor TMultiImage.CreateFromStream(Stream: TStream);
-begin
- LoadMultiFromStream(Stream);
-end;
-
-destructor TMultiImage.Destroy;
-begin
- Imaging.FreeImagesInArray(FDataArray);
- inherited Destroy;
-end;
-
-procedure TMultiImage.SetActiveImage(Value: LongInt);
-begin
- FActiveImage := Value;
- SetPointer;
-end;
-
-function TMultiImage.GetImageCount: LongInt;
-begin
- Result := Length(FDataArray);
-end;
-
-procedure TMultiImage.SetImageCount(Value: LongInt);
-var
- I, OldCount: LongInt;
-begin
- if Value > GetImageCount then
- begin
- // Create new empty images if array will be enlarged
- OldCount := GetImageCount;
- SetLength(FDataArray, Value);
- for I := OldCount to Value - 1 do
- Imaging.NewImage(DefaultWidth, DefaultHeight, ifDefault, FDataArray[I]);
- end
- else
- begin
- // Free images that exceed desired count and shrink array
- for I := Value to GetImageCount - 1 do
- Imaging.FreeImage(FDataArray[I]);
- SetLength(FDataArray, Value);
- end;
- SetPointer;
-end;
-
-function TMultiImage.GetAllImagesValid: Boolean;
-begin
- Result := (GetImageCount > 0) and TestImagesInArray(FDataArray);
-end;
-
-function TMultiImage.GetImage(Index: LongInt): TImageData;
-begin
- if (Index >= 0) and (Index < GetImageCount) then
- Result := FDataArray[Index];
-end;
-
-procedure TMultiImage.SetImage(Index: LongInt; Value: TImageData);
-begin
- if (Index >= 0) and (Index < GetImageCount) then
- Imaging.CloneImage(Value, FDataArray[Index]);
-end;
-
-procedure TMultiImage.SetPointer;
-begin
- if GetImageCount > 0 then
- begin
- FActiveImage := ClampInt(FActiveImage, 0, GetImageCount - 1);
- FPData := @FDataArray[FActiveImage];
- end
- else
- begin
- FActiveImage := -1;
- FPData := nil
- end;
-end;
-
-function TMultiImage.PrepareInsert(Index, Count: LongInt): Boolean;
-var
- I: LongInt;
-begin
- // Inserting to empty image will add image at index 0
- if GetImageCount = 0 then
- Index := 0;
-
- if (Index >= 0) and (Index <= GetImageCount) and (Count > 0) then
- begin
- SetLength(FDataArray, GetImageCount + Count);
- if Index < GetImageCount - 1 then
- begin
- // Move imges to new position
- System.Move(FDataArray[Index], FDataArray[Index + Count],
- (GetImageCount - Count - Index) * SizeOf(TImageData));
- // Null old images, not free them!
- for I := Index to Index + Count - 1 do
- InitImage(FDataArray[I]);
- end;
- Result := True;
- end
- else
- Result := False;
-end;
-
-procedure TMultiImage.DoInsertImages(Index: LongInt; const Images: TDynImageDataArray);
-var
- I, Len: LongInt;
-begin
- Len := Length(Images);
- if PrepareInsert(Index, Len) then
- begin
- for I := 0 to Len - 1 do
- Imaging.CloneImage(Images[I], FDataArray[Index + I]);
- end;
-end;
-
-procedure TMultiImage.DoInsertNew(Index, AWidth, AHeight: LongInt;
- AFormat: TImageFormat);
-begin
- if PrepareInsert(Index, 1) then
- Imaging.NewImage(AWidth, AHeight, AFormat, FDataArray[Index]);
-end;
-
-procedure TMultiImage.Assign(Source: TPersistent);
-var
- Arr: TDynImageDataArray;
-begin
- if Source = nil then
- begin
- Create;
- end
- else if Source is TMultiImage then
- begin
- CreateFromArray(TMultiImage(Source).FDataArray);
- SetActiveImage(TMultiImage(Source).ActiveImage);
- end
- else if Source is TSingleImage then
- begin
- SetLength(Arr, 1);
- Arr[0] := TSingleImage(Source).FImageData;
- CreateFromArray(Arr);
- Arr := nil;
- end
- else
- inherited Assign(Source);
-end;
-
-procedure TMultiImage.AddImage(AWidth, AHeight: LongInt; AFormat: TImageFormat);
-begin
- DoInsertNew(GetImageCount, AWidth, AHeight, AFormat);
-end;
-
-procedure TMultiImage.AddImage(const Image: TImageData);
-begin
- DoInsertImages(GetImageCount, GetArrayFromImageData(Image));
-end;
-
-procedure TMultiImage.AddImage(Image: TBaseImage);
-begin
- if Assigned(Image) and Image.Valid then
- DoInsertImages(GetImageCount, GetArrayFromImageData(Image.FPData^));
-end;
-
-procedure TMultiImage.AddImages(const Images: TDynImageDataArray);
-begin
- DoInsertImages(GetImageCount, Images);
-end;
-
-procedure TMultiImage.AddImages(Images: TMultiImage);
-begin
- DoInsertImages(GetImageCount, Images.FDataArray);
-end;
-
-procedure TMultiImage.InsertImage(Index, AWidth, AHeight: LongInt;
- AFormat: TImageFormat);
-begin
- DoInsertNew(Index, AWidth, AHeight, AFormat);
-end;
-
-procedure TMultiImage.InsertImage(Index: LongInt; const Image: TImageData);
-begin
- DoInsertImages(Index, GetArrayFromImageData(Image));
-end;
-
-procedure TMultiImage.InsertImage(Index: LongInt; Image: TBaseImage);
-begin
- if Assigned(Image) and Image.Valid then
- DoInsertImages(Index, GetArrayFromImageData(Image.FPData^));
-end;
-
-procedure TMultiImage.InsertImages(Index: LongInt;
- const Images: TDynImageDataArray);
-begin
- DoInsertImages(Index, FDataArray);
-end;
-
-procedure TMultiImage.InsertImages(Index: LongInt; Images: TMultiImage);
-begin
- DoInsertImages(Index, Images.FDataArray);
-end;
-
-procedure TMultiImage.ExchangeImages(Index1, Index2: LongInt);
-var
- TempData: TImageData;
-begin
- if (Index1 >= 0) and (Index1 < GetImageCount) and
- (Index2 >= 0) and (Index2 < GetImageCount) then
- begin
- TempData := FDataArray[Index1];
- FDataArray[Index1] := FDataArray[Index2];
- FDataArray[Index2] := TempData;
- end;
-end;
-
-procedure TMultiImage.DeleteImage(Index: LongInt);
-var
- I: LongInt;
-begin
- if (Index >= 0) and (Index < GetImageCount) then
- begin
- // Free image at index to be deleted
- Imaging.FreeImage(FDataArray[Index]);
- if Index < GetImageCount - 1 then
- begin
- // Move images to new indices if necessary
- for I := Index to GetImageCount - 2 do
- FDataArray[I] := FDataArray[I + 1];
- end;
- // Set new array length and update pointer to active image
- SetLength(FDataArray, GetImageCount - 1);
- SetPointer;
- end;
-end;
-
-procedure TMultiImage.ConvertImages(Format: TImageFormat);
-var
- I: LongInt;
-begin
- for I := 0 to GetImageCount - 1 do
- Imaging.ConvertImage(FDataArray[I], Format);
-end;
-
-procedure TMultiImage.ResizeImages(NewWidth, NewHeight: LongInt;
- Filter: TResizeFilter);
-var
- I: LongInt;
-begin
- for I := 0 to GetImageCount do
- Imaging.ResizeImage(FDataArray[I], NewWidth, NewHeight, Filter);
-end;
-
-procedure TMultiImage.ReverseImages;
-var
- I: Integer;
-begin
- for I := 0 to GetImageCount div 2 do
- ExchangeImages(I, GetImageCount - 1 - I);
-end;
-
-procedure TMultiImage.LoadFromFile(const FileName: string);
-begin
- if GetImageCount = 0 then
- ImageCount := 1;
- inherited LoadFromFile(FileName);
-end;
-
-procedure TMultiImage.LoadFromStream(Stream: TStream);
-begin
- if GetImageCount = 0 then
- ImageCount := 1;
- inherited LoadFromStream(Stream);
-end;
-
-procedure TMultiImage.LoadMultiFromFile(const FileName: string);
-begin
- Imaging.LoadMultiImageFromFile(FileName, FDataArray);
- SetActiveImage(0);
-end;
-
-procedure TMultiImage.LoadMultiFromStream(Stream: TStream);
-begin
- Imaging.LoadMultiImageFromStream(Stream, FDataArray);
- SetActiveImage(0);
-end;
-
-procedure TMultiImage.SaveMultiToFile(const FileName: string);
-begin
- Imaging.SaveMultiImageToFile(FileName, FDataArray);
-end;
-
-procedure TMultiImage.SaveMultiToStream(const Ext: string; Stream: TStream);
-begin
- Imaging.SaveMultiImageToStream(Ext, Stream, FDataArray);
-end;
-
-{
- File Notes:
-
- -- TODOS ----------------------------------------------------
- - nothing now
- - add SetPalette, create some pal wrapper first
- - put all low level stuff here like ReplaceColor etc, change
- CopyTo to Copy, and add overload Copy(SrcRect, DstX, DstY) ...
-
- -- 0.24.3 Changes/Bug Fixes ---------------------------------
- - Added TMultiImage.ReverseImages method.
-
- -- 0.23 Changes/Bug Fixes -----------------------------------
- - Added SwapChannels method to TBaseImage.
- - Added ReplaceColor method to TBaseImage.
- - Added ToString method to TBaseImage.
-
- -- 0.21 Changes/Bug Fixes -----------------------------------
- - Inserting images to empty MultiImage will act as Add method.
- - MultiImages with empty arrays will now create one image when
- LoadFromFile or LoadFromStream is called.
- - Fixed bug that caused AVs when getting props like Width, Height, asn Size
- and when inlining was off. There was call to Iff but with inlining disabled
- params like FPData.Size were evaluated and when FPData was nil => AV.
- - Added many FPData validity checks to many methods. There were AVs
- when calling most methods on empty TMultiImage.
- - Added AllImagesValid property to TMultiImage.
- - Fixed memory leak in TMultiImage.CreateFromParams.
-
- -- 0.19 Changes/Bug Fixes -----------------------------------
- - added ResizeImages method to TMultiImage
- - removed Ext parameter from various LoadFromStream methods, no
- longer needed
- - fixed various issues concerning ActiveImage of TMultiImage
- (it pointed to invalid location after some operations)
- - most of property set/get methods are now inline
- - added PixelPointers property to TBaseImage
- - added Images default array property to TMultiImage
- - renamed methods in TMultiImage to contain 'Image' instead of 'Level'
- - added canvas support
- - added OnDataSizeChanged and OnPixelsChanged event to TBaseImage
- - renamed TSingleImage.NewImage to RecreateImageData, made public, and
- moved to TBaseImage
-
- -- 0.17 Changes/Bug Fixes -----------------------------------
- - added props PaletteEntries and ScanLine to TBaseImage
- - aded new constructor to TBaseImage that take TBaseImage source
- - TMultiImage levels adding and inserting rewritten internally
- - added some new functions to TMultiImage: AddLevels, InsertLevels
- - added some new functions to TBaseImage: Flip, Mirror, Rotate,
- CopyRect, StretchRect
- - TBasicImage.Resize has now filter parameter
- - new stuff added to TMultiImage (DataArray prop, ConvertLevels)
-
- -- 0.13 Changes/Bug Fixes -----------------------------------
- - added AddLevel, InsertLevel, ExchangeLevels and DeleteLevel
- methods to TMultiImage
- - added TBaseImage, TSingleImage and TMultiImage with initial
- members
-}
-
-end.
-
+{
+ $Id: ImagingClasses.pas 173 2009-09-04 17:05:52Z galfar $
+ Vampyre Imaging Library
+ by Marek Mauder
+ http://imaginglib.sourceforge.net
+
+ The contents of this file are used with permission, subject to the Mozilla
+ Public License Version 1.1 (the "License"); you may not use this file except
+ in compliance with the License. You may obtain a copy of the License at
+ http://www.mozilla.org/MPL/MPL-1.1.html
+
+ Software distributed under the License is distributed on an "AS IS" basis,
+ WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
+ the specific language governing rights and limitations under the License.
+
+ Alternatively, the contents of this file may be used under the terms of the
+ GNU Lesser General Public License (the "LGPL License"), in which case the
+ provisions of the LGPL License are applicable instead of those above.
+ If you wish to allow use of your version of this file only under the terms
+ of the LGPL License and not to allow others to use your version of this file
+ under the MPL, indicate your decision by deleting the provisions above and
+ replace them with the notice and other provisions required by the LGPL
+ License. If you do not delete the provisions above, a recipient may use
+ your version of this file under either the MPL or the LGPL License.
+
+ For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
+}
+
+{ This unit contains class based wrapper to Imaging library.}
+unit ImagingClasses;
+
+{$I ImagingOptions.inc}
+
+interface
+
+uses
+ Types, Classes, ImagingTypes, Imaging, ImagingFormats, ImagingUtility;
+
+type
+ { Base abstract high level class wrapper to low level Imaging structures and
+ functions.}
+ TBaseImage = class(TPersistent)
+ protected
+ FPData: PImageData;
+ FOnDataSizeChanged: TNotifyEvent;
+ FOnPixelsChanged: TNotifyEvent;
+ function GetFormat: TImageFormat; {$IFDEF USE_INLINE}inline;{$ENDIF}
+ function GetHeight: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
+ function GetSize: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
+ function GetWidth: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
+ function GetBits: Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF}
+ function GetPalette: PPalette32; {$IFDEF USE_INLINE}inline;{$ENDIF}
+ function GetPaletteEntries: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
+ function GetScanLine(Index: LongInt): Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF}
+ function GetPixelPointer(X, Y: LongInt): Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF}
+ function GetFormatInfo: TImageFormatInfo; {$IFDEF USE_INLINE}inline;{$ENDIF}
+ function GetValid: Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF}
+ function GetBoundsRect: TRect;
+ procedure SetFormat(const Value: TImageFormat); {$IFDEF USE_INLINE}inline;{$ENDIF}
+ procedure SetHeight(const Value: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
+ procedure SetWidth(const Value: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
+ procedure SetPointer; virtual; abstract;
+ procedure DoDataSizeChanged; virtual;
+ procedure DoPixelsChanged; virtual;
+ published
+ public
+ constructor Create; virtual;
+ constructor CreateFromImage(AImage: TBaseImage);
+ destructor Destroy; override;
+ { Returns info about current image.}
+ function ToString: string;
+
+ { Creates a new image data with the given size and format. Old image
+ data is lost. Works only for the current image of TMultiImage.}
+ procedure RecreateImageData(AWidth, AHeight: LongInt; AFormat: TImageFormat);
+ { Resizes current image with optional resampling.}
+ procedure Resize(NewWidth, NewHeight: LongInt; Filter: TResizeFilter);
+ { Flips current image. Reverses the image along its horizontal axis the top
+ becomes the bottom and vice versa.}
+ procedure Flip;
+ { Mirrors current image. Reverses the image along its vertical axis the left
+ side becomes the right and vice versa.}
+ procedure Mirror;
+ { Rotates image by Angle degrees counterclockwise.}
+ procedure Rotate(Angle: Single);
+ { Copies rectangular part of SrcImage to DstImage. No blending is performed -
+ alpha is simply copied to destination image. Operates also with
+ negative X and Y coordinates.
+ Note that copying is fastest for images in the same data format
+ (and slowest for images in special formats).}
+ procedure CopyTo(SrcX, SrcY, Width, Height: LongInt; DstImage: TBaseImage; DstX, DstY: LongInt);
+ { Stretches the contents of the source rectangle to the destination rectangle
+ with optional resampling. No blending is performed - alpha is
+ simply copied/resampled to destination image. Note that stretching is
+ fastest for images in the same data format (and slowest for
+ images in special formats).}
+ procedure StretchTo(SrcX, SrcY, SrcWidth, SrcHeight: LongInt; DstImage: TBaseImage; DstX, DstY, DstWidth, DstHeight: LongInt; Filter: TResizeFilter);
+ { Replaces pixels with OldPixel in the given rectangle by NewPixel.
+ OldPixel and NewPixel should point to the pixels in the same format
+ as the given image is in.}
+ procedure ReplaceColor(X, Y, Width, Height: LongInt; OldColor, NewColor: Pointer);
+ { Swaps SrcChannel and DstChannel color or alpha channels of image.
+ Use ChannelRed, ChannelBlue, ChannelGreen, ChannelAlpha constants to
+ identify channels.}
+ procedure SwapChannels(SrcChannel, DstChannel: LongInt);
+
+ { Loads current image data from file.}
+ procedure LoadFromFile(const FileName: string); virtual;
+ { Loads current image data from stream.}
+ procedure LoadFromStream(Stream: TStream); virtual;
+
+ { Saves current image data to file.}
+ procedure SaveToFile(const FileName: string);
+ { Saves current image data to stream. Ext identifies desired image file
+ format (jpg, png, dds, ...)}
+ procedure SaveToStream(const Ext: string; Stream: TStream);
+
+ { Width of current image in pixels.}
+ property Width: LongInt read GetWidth write SetWidth;
+ { Height of current image in pixels.}
+ property Height: LongInt read GetHeight write SetHeight;
+ { Image data format of current image.}
+ property Format: TImageFormat read GetFormat write SetFormat;
+ { Size in bytes of current image's data.}
+ property Size: LongInt read GetSize;
+ { Pointer to memory containing image bits.}
+ property Bits: Pointer read GetBits;
+ { Pointer to palette for indexed format images. It is nil for others.
+ Max palette entry is at index [PaletteEntries - 1].}
+ property Palette: PPalette32 read GetPalette;
+ { Number of entries in image's palette}
+ property PaletteEntries: LongInt read GetPaletteEntries;
+ { Provides indexed access to each line of pixels. Does not work with special
+ format images (like DXT).}
+ property ScanLine[Index: LongInt]: Pointer read GetScanLine;
+ { Returns pointer to image pixel at [X, Y] coordinates.}
+ property PixelPointers[X, Y: LongInt]: Pointer read GetPixelPointer;
+ { Extended image format information.}
+ property FormatInfo: TImageFormatInfo read GetFormatInfo;
+ { This gives complete access to underlying TImageData record.
+ It can be used in functions that take TImageData as parameter
+ (for example: ReduceColors(SingleImageInstance.ImageData^, 64)).}
+ property ImageDataPointer: PImageData read FPData;
+ { Indicates whether the current image is valid (proper format,
+ allowed dimensions, right size, ...).}
+ property Valid: Boolean read GetValid;
+ {{ Specifies the bounding rectangle of the image.}
+ property BoundsRect: TRect read GetBoundsRect;
+ { This event occurs when the image data size has just changed. That means
+ image width, height, or format has been changed.}
+ property OnDataSizeChanged: TNotifyEvent read FOnDataSizeChanged write FOnDataSizeChanged;
+ { This event occurs when some pixels of the image have just changed.}
+ property OnPixelsChanged: TNotifyEvent read FOnPixelsChanged write FOnPixelsChanged;
+ end;
+
+ { Extension of TBaseImage which uses single TImageData record to
+ store image. All methods inherited from TBaseImage work with this record.}
+ TSingleImage = class(TBaseImage)
+ protected
+ FImageData: TImageData;
+ procedure SetPointer; override;
+ public
+ constructor Create; override;
+ constructor CreateFromParams(AWidth, AHeight: LongInt; AFormat: TImageFormat = ifDefault);
+ constructor CreateFromData(const AData: TImageData);
+ constructor CreateFromFile(const FileName: string);
+ constructor CreateFromStream(Stream: TStream);
+ destructor Destroy; override;
+ { Assigns single image from another single image or multi image.}
+ procedure Assign(Source: TPersistent); override;
+ end;
+
+ { Extension of TBaseImage which uses array of TImageData records to
+ store multiple images. Images are independent on each other and they don't
+ share any common characteristic. Each can have different size, format, and
+ palette. All methods inherited from TBaseImage work only with
+ active image (it could represent mipmap level, animation frame, or whatever).
+ Methods whose names contain word 'Multi' work with all images in array
+ (as well as other methods with obvious names).}
+ TMultiImage = class(TBaseImage)
+ protected
+ FDataArray: TDynImageDataArray;
+ FActiveImage: LongInt;
+ procedure SetActiveImage(Value: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
+ function GetImageCount: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
+ procedure SetImageCount(Value: LongInt);
+ function GetAllImagesValid: Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF}
+ function GetImage(Index: LongInt): TImageData; {$IFDEF USE_INLINE}inline;{$ENDIF}
+ procedure SetImage(Index: LongInt; Value: TImageData); {$IFDEF USE_INLINE}inline;{$ENDIF}
+ procedure SetPointer; override;
+ function PrepareInsert(Index, Count: LongInt): Boolean;
+ procedure DoInsertImages(Index: LongInt; const Images: TDynImageDataArray);
+ procedure DoInsertNew(Index: LongInt; AWidth, AHeight: LongInt; AFormat: TImageFormat);
+ public
+ constructor Create; override;
+ constructor CreateFromParams(AWidth, AHeight: LongInt; AFormat: TImageFormat; Images: LongInt);
+ constructor CreateFromArray(ADataArray: TDynImageDataArray);
+ constructor CreateFromFile(const FileName: string);
+ constructor CreateFromStream(Stream: TStream);
+ destructor Destroy; override;
+ { Assigns multi image from another multi image or single image.}
+ procedure Assign(Source: TPersistent); override;
+
+ { Adds new image at the end of the image array. }
+ procedure AddImage(AWidth, AHeight: LongInt; AFormat: TImageFormat = ifDefault); overload;
+ { Adds existing image at the end of the image array. }
+ procedure AddImage(const Image: TImageData); overload;
+ { Adds existing image (Active image of a TmultiImage)
+ at the end of the image array. }
+ procedure AddImage(Image: TBaseImage); overload;
+ { Adds existing image array ((all images of a multi image))
+ at the end of the image array. }
+ procedure AddImages(const Images: TDynImageDataArray); overload;
+ { Adds existing MultiImage images at the end of the image array. }
+ procedure AddImages(Images: TMultiImage); overload;
+
+ { Inserts new image image at the given position in the image array. }
+ procedure InsertImage(Index, AWidth, AHeight: LongInt; AFormat: TImageFormat = ifDefault); overload;
+ { Inserts existing image at the given position in the image array. }
+ procedure InsertImage(Index: LongInt; const Image: TImageData); overload;
+ { Inserts existing image (Active image of a TmultiImage)
+ at the given position in the image array. }
+ procedure InsertImage(Index: LongInt; Image: TBaseImage); overload;
+ { Inserts existing image at the given position in the image array. }
+ procedure InsertImages(Index: LongInt; const Images: TDynImageDataArray); overload;
+ { Inserts existing images (all images of a TmultiImage) at
+ the given position in the image array. }
+ procedure InsertImages(Index: LongInt; Images: TMultiImage); overload;
+
+ { Exchanges two images at the given positions in the image array. }
+ procedure ExchangeImages(Index1, Index2: LongInt);
+ { Deletes image at the given position in the image array.}
+ procedure DeleteImage(Index: LongInt);
+ { Rearranges images so that the first image will become last and vice versa.}
+ procedure ReverseImages;
+
+ { Converts all images to another image data format.}
+ procedure ConvertImages(Format: TImageFormat);
+ { Resizes all images.}
+ procedure ResizeImages(NewWidth, NewHeight: LongInt; Filter: TResizeFilter);
+
+ { Overloaded loading method that will add new image to multiimage if
+ image array is empty bero loading. }
+ procedure LoadFromFile(const FileName: string); override;
+ { Overloaded loading method that will add new image to multiimage if
+ image array is empty bero loading. }
+ procedure LoadFromStream(Stream: TStream); override;
+
+ { Loads whole multi image from file.}
+ procedure LoadMultiFromFile(const FileName: string);
+ { Loads whole multi image from stream.}
+ procedure LoadMultiFromStream(Stream: TStream);
+ { Saves whole multi image to file.}
+ procedure SaveMultiToFile(const FileName: string);
+ { Saves whole multi image to stream. Ext identifies desired
+ image file format (jpg, png, dds, ...).}
+ procedure SaveMultiToStream(const Ext: string; Stream: TStream);
+
+ { Indicates active image of this multi image. All methods inherited
+ from TBaseImage operate on this image only.}
+ property ActiveImage: LongInt read FActiveImage write SetActiveImage;
+ { Number of images of this multi image.}
+ property ImageCount: LongInt read GetImageCount write SetImageCount;
+ { This value is True if all images of this TMultiImage are valid.}
+ property AllImagesValid: Boolean read GetAllImagesValid;
+ { This gives complete access to underlying TDynImageDataArray.
+ It can be used in functions that take TDynImageDataArray
+ as parameter.}
+ property DataArray: TDynImageDataArray read FDataArray;
+ { Array property for accessing individual images of TMultiImage. When you
+ set image at given index the old image is freed and the source is cloned.}
+ property Images[Index: LongInt]: TImageData read GetImage write SetImage; default;
+ end;
+
+implementation
+
+const
+ DefaultWidth = 16;
+ DefaultHeight = 16;
+ DefaultImages = 1;
+
+function GetArrayFromImageData(const ImageData: TImageData): TDynImageDataArray;
+begin
+ SetLength(Result, 1);
+ Result[0] := ImageData;
+end;
+
+{ TBaseImage class implementation }
+
+constructor TBaseImage.Create;
+begin
+ SetPointer;
+end;
+
+constructor TBaseImage.CreateFromImage(AImage: TBaseImage);
+begin
+ Create;
+ Assign(AImage);
+end;
+
+destructor TBaseImage.Destroy;
+begin
+ inherited Destroy;
+end;
+
+function TBaseImage.GetWidth: LongInt;
+begin
+ if Valid then
+ Result := FPData.Width
+ else
+ Result := 0;
+end;
+
+function TBaseImage.GetHeight: LongInt;
+begin
+ if Valid then
+ Result := FPData.Height
+ else
+ Result := 0;
+end;
+
+function TBaseImage.GetFormat: TImageFormat;
+begin
+ if Valid then
+ Result := FPData.Format
+ else
+ Result := ifUnknown;
+end;
+
+function TBaseImage.GetScanLine(Index: LongInt): Pointer;
+var
+ Info: TImageFormatInfo;
+begin
+ if Valid then
+ begin
+ Info := GetFormatInfo;
+ if not Info.IsSpecial then
+ Result := ImagingFormats.GetScanLine(FPData.Bits, Info, FPData.Width, Index)
+ else
+ Result := FPData.Bits;
+ end
+ else
+ Result := nil;
+end;
+
+function TBaseImage.GetPixelPointer(X, Y: LongInt): Pointer;
+begin
+ if Valid then
+ Result := @PByteArray(FPData.Bits)[(Y * FPData.Width + X) * GetFormatInfo.BytesPerPixel]
+ else
+ Result := nil;
+end;
+
+function TBaseImage.GetSize: LongInt;
+begin
+ if Valid then
+ Result := FPData.Size
+ else
+ Result := 0;
+end;
+
+function TBaseImage.GetBits: Pointer;
+begin
+ if Valid then
+ Result := FPData.Bits
+ else
+ Result := nil;
+end;
+
+function TBaseImage.GetPalette: PPalette32;
+begin
+ if Valid then
+ Result := FPData.Palette
+ else
+ Result := nil;
+end;
+
+function TBaseImage.GetPaletteEntries: LongInt;
+begin
+ Result := GetFormatInfo.PaletteEntries;
+end;
+
+function TBaseImage.GetFormatInfo: TImageFormatInfo;
+begin
+ if Valid then
+ Imaging.GetImageFormatInfo(FPData.Format, Result)
+ else
+ FillChar(Result, SizeOf(Result), 0);
+end;
+
+function TBaseImage.GetValid: Boolean;
+begin
+ Result := Assigned(FPData) and Imaging.TestImage(FPData^);
+end;
+
+function TBaseImage.GetBoundsRect: TRect;
+begin
+ Result := Rect(0, 0, GetWidth, GetHeight);
+end;
+
+procedure TBaseImage.SetWidth(const Value: LongInt);
+begin
+ Resize(Value, GetHeight, rfNearest);
+end;
+
+procedure TBaseImage.SetHeight(const Value: LongInt);
+begin
+ Resize(GetWidth, Value, rfNearest);
+end;
+
+procedure TBaseImage.SetFormat(const Value: TImageFormat);
+begin
+ if Valid and Imaging.ConvertImage(FPData^, Value) then
+ DoDataSizeChanged;
+end;
+
+procedure TBaseImage.DoDataSizeChanged;
+begin
+ if Assigned(FOnDataSizeChanged) then
+ FOnDataSizeChanged(Self);
+ DoPixelsChanged;
+end;
+
+procedure TBaseImage.DoPixelsChanged;
+begin
+ if Assigned(FOnPixelsChanged) then
+ FOnPixelsChanged(Self);
+end;
+
+procedure TBaseImage.RecreateImageData(AWidth, AHeight: LongInt; AFormat: TImageFormat);
+begin
+ if Assigned(FPData) and Imaging.NewImage(AWidth, AHeight, AFormat, FPData^) then
+ DoDataSizeChanged;
+end;
+
+procedure TBaseImage.Resize(NewWidth, NewHeight: LongInt; Filter: TResizeFilter);
+begin
+ if Valid and Imaging.ResizeImage(FPData^, NewWidth, NewHeight, Filter) then
+ DoDataSizeChanged;
+end;
+
+procedure TBaseImage.Flip;
+begin
+ if Valid and Imaging.FlipImage(FPData^) then
+ DoPixelsChanged;
+end;
+
+procedure TBaseImage.Mirror;
+begin
+ if Valid and Imaging.MirrorImage(FPData^) then
+ DoPixelsChanged;
+end;
+
+procedure TBaseImage.Rotate(Angle: Single);
+begin
+ if Valid and Imaging.RotateImage(FPData^, Angle) then
+ DoPixelsChanged;
+end;
+
+procedure TBaseImage.CopyTo(SrcX, SrcY, Width, Height: LongInt;
+ DstImage: TBaseImage; DstX, DstY: LongInt);
+begin
+ if Valid and Assigned(DstImage) and DstImage.Valid then
+ begin
+ Imaging.CopyRect(FPData^, SrcX, SrcY, Width, Height, DstImage.FPData^, DstX, DstY);
+ DstImage.DoPixelsChanged;
+ end;
+end;
+
+procedure TBaseImage.StretchTo(SrcX, SrcY, SrcWidth, SrcHeight: LongInt;
+ DstImage: TBaseImage; DstX, DstY, DstWidth, DstHeight: LongInt; Filter: TResizeFilter);
+begin
+ if Valid and Assigned(DstImage) and DstImage.Valid then
+ begin
+ Imaging.StretchRect(FPData^, SrcX, SrcY, SrcWidth, SrcHeight,
+ DstImage.FPData^, DstX, DstY, DstWidth, DstHeight, Filter);
+ DstImage.DoPixelsChanged;
+ end;
+end;
+
+procedure TBaseImage.ReplaceColor(X, Y, Width, Height: Integer; OldColor,
+ NewColor: Pointer);
+begin
+ if Valid then
+ begin
+ Imaging.ReplaceColor(FPData^, X, Y, Width, Height, OldColor, NewColor);
+ DoPixelsChanged;
+ end;
+end;
+
+procedure TBaseImage.SwapChannels(SrcChannel, DstChannel: Integer);
+begin
+ if Valid then
+ begin
+ Imaging.SwapChannels(FPData^, SrcChannel, DstChannel);
+ DoPixelsChanged;
+ end;
+end;
+
+function TBaseImage.ToString: string;
+begin
+ Result := Iff(Valid, Imaging.ImageToStr(FPData^), 'empty image');
+end;
+
+procedure TBaseImage.LoadFromFile(const FileName: string);
+begin
+ if Assigned(FPData) and Imaging.LoadImageFromFile(FileName, FPData^) then
+ DoDataSizeChanged;
+end;
+
+procedure TBaseImage.LoadFromStream(Stream: TStream);
+begin
+ if Assigned(FPData) and Imaging.LoadImageFromStream(Stream, FPData^) then
+ DoDataSizeChanged;
+end;
+
+procedure TBaseImage.SaveToFile(const FileName: string);
+begin
+ if Valid then
+ Imaging.SaveImageToFile(FileName, FPData^);
+end;
+
+procedure TBaseImage.SaveToStream(const Ext: string; Stream: TStream);
+begin
+ if Valid then
+ Imaging.SaveImageToStream(Ext, Stream, FPData^);
+end;
+
+
+{ TSingleImage class implementation }
+
+constructor TSingleImage.Create;
+begin
+ inherited Create;
+ RecreateImageData(DefaultWidth, DefaultHeight, ifDefault);
+end;
+
+constructor TSingleImage.CreateFromParams(AWidth, AHeight: LongInt; AFormat: TImageFormat);
+begin
+ inherited Create;
+ RecreateImageData(AWidth, AHeight, AFormat);
+end;
+
+constructor TSingleImage.CreateFromData(const AData: TImageData);
+begin
+ inherited Create;
+ if Imaging.TestImage(AData) then
+ begin
+ Imaging.CloneImage(AData, FImageData);
+ DoDataSizeChanged;
+ end
+ else
+ Create;
+end;
+
+constructor TSingleImage.CreateFromFile(const FileName: string);
+begin
+ inherited Create;
+ LoadFromFile(FileName);
+end;
+
+constructor TSingleImage.CreateFromStream(Stream: TStream);
+begin
+ inherited Create;
+ LoadFromStream(Stream);
+end;
+
+destructor TSingleImage.Destroy;
+begin
+ Imaging.FreeImage(FImageData);
+ inherited Destroy;
+end;
+
+procedure TSingleImage.SetPointer;
+begin
+ FPData := @FImageData;
+end;
+
+procedure TSingleImage.Assign(Source: TPersistent);
+begin
+ if Source = nil then
+ begin
+ Create;
+ end
+ else if Source is TSingleImage then
+ begin
+ CreateFromData(TSingleImage(Source).FImageData);
+ end
+ else if Source is TMultiImage then
+ begin
+ if TMultiImage(Source).Valid then
+ CreateFromData(TMultiImage(Source).FPData^)
+ else
+ Assign(nil);
+ end
+ else
+ inherited Assign(Source);
+end;
+
+
+{ TMultiImage class implementation }
+
+constructor TMultiImage.Create;
+begin
+ SetImageCount(DefaultImages);
+ SetActiveImage(0);
+end;
+
+constructor TMultiImage.CreateFromParams(AWidth, AHeight: LongInt;
+ AFormat: TImageFormat; Images: LongInt);
+var
+ I: LongInt;
+begin
+ Imaging.FreeImagesInArray(FDataArray);
+ SetLength(FDataArray, Images);
+ for I := 0 to GetImageCount - 1 do
+ Imaging.NewImage(AWidth, AHeight, AFormat, FDataArray[I]);
+ SetActiveImage(0);
+end;
+
+constructor TMultiImage.CreateFromArray(ADataArray: TDynImageDataArray);
+var
+ I: LongInt;
+begin
+ Imaging.FreeImagesInArray(FDataArray);
+ SetLength(FDataArray, Length(ADataArray));
+ for I := 0 to GetImageCount - 1 do
+ begin
+ // Clone only valid images
+ if Imaging.TestImage(ADataArray[I]) then
+ Imaging.CloneImage(ADataArray[I], FDataArray[I])
+ else
+ Imaging.NewImage(DefaultWidth, DefaultHeight, ifDefault, FDataArray[I]);
+ end;
+ SetActiveImage(0);
+end;
+
+constructor TMultiImage.CreateFromFile(const FileName: string);
+begin
+ LoadMultiFromFile(FileName);
+end;
+
+constructor TMultiImage.CreateFromStream(Stream: TStream);
+begin
+ LoadMultiFromStream(Stream);
+end;
+
+destructor TMultiImage.Destroy;
+begin
+ Imaging.FreeImagesInArray(FDataArray);
+ inherited Destroy;
+end;
+
+procedure TMultiImage.SetActiveImage(Value: LongInt);
+begin
+ FActiveImage := Value;
+ SetPointer;
+end;
+
+function TMultiImage.GetImageCount: LongInt;
+begin
+ Result := Length(FDataArray);
+end;
+
+procedure TMultiImage.SetImageCount(Value: LongInt);
+var
+ I, OldCount: LongInt;
+begin
+ if Value > GetImageCount then
+ begin
+ // Create new empty images if array will be enlarged
+ OldCount := GetImageCount;
+ SetLength(FDataArray, Value);
+ for I := OldCount to Value - 1 do
+ Imaging.NewImage(DefaultWidth, DefaultHeight, ifDefault, FDataArray[I]);
+ end
+ else
+ begin
+ // Free images that exceed desired count and shrink array
+ for I := Value to GetImageCount - 1 do
+ Imaging.FreeImage(FDataArray[I]);
+ SetLength(FDataArray, Value);
+ end;
+ SetPointer;
+end;
+
+function TMultiImage.GetAllImagesValid: Boolean;
+begin
+ Result := (GetImageCount > 0) and TestImagesInArray(FDataArray);
+end;
+
+function TMultiImage.GetImage(Index: LongInt): TImageData;
+begin
+ if (Index >= 0) and (Index < GetImageCount) then
+ Result := FDataArray[Index];
+end;
+
+procedure TMultiImage.SetImage(Index: LongInt; Value: TImageData);
+begin
+ if (Index >= 0) and (Index < GetImageCount) then
+ Imaging.CloneImage(Value, FDataArray[Index]);
+end;
+
+procedure TMultiImage.SetPointer;
+begin
+ if GetImageCount > 0 then
+ begin
+ FActiveImage := ClampInt(FActiveImage, 0, GetImageCount - 1);
+ FPData := @FDataArray[FActiveImage];
+ end
+ else
+ begin
+ FActiveImage := -1;
+ FPData := nil
+ end;
+end;
+
+function TMultiImage.PrepareInsert(Index, Count: LongInt): Boolean;
+var
+ I: LongInt;
+begin
+ // Inserting to empty image will add image at index 0
+ if GetImageCount = 0 then
+ Index := 0;
+
+ if (Index >= 0) and (Index <= GetImageCount) and (Count > 0) then
+ begin
+ SetLength(FDataArray, GetImageCount + Count);
+ if Index < GetImageCount - 1 then
+ begin
+ // Move imges to new position
+ System.Move(FDataArray[Index], FDataArray[Index + Count],
+ (GetImageCount - Count - Index) * SizeOf(TImageData));
+ // Null old images, not free them!
+ for I := Index to Index + Count - 1 do
+ InitImage(FDataArray[I]);
+ end;
+ Result := True;
+ end
+ else
+ Result := False;
+end;
+
+procedure TMultiImage.DoInsertImages(Index: LongInt; const Images: TDynImageDataArray);
+var
+ I, Len: LongInt;
+begin
+ Len := Length(Images);
+ if PrepareInsert(Index, Len) then
+ begin
+ for I := 0 to Len - 1 do
+ Imaging.CloneImage(Images[I], FDataArray[Index + I]);
+ end;
+end;
+
+procedure TMultiImage.DoInsertNew(Index, AWidth, AHeight: LongInt;
+ AFormat: TImageFormat);
+begin
+ if PrepareInsert(Index, 1) then
+ Imaging.NewImage(AWidth, AHeight, AFormat, FDataArray[Index]);
+end;
+
+procedure TMultiImage.Assign(Source: TPersistent);
+var
+ Arr: TDynImageDataArray;
+begin
+ if Source = nil then
+ begin
+ Create;
+ end
+ else if Source is TMultiImage then
+ begin
+ CreateFromArray(TMultiImage(Source).FDataArray);
+ SetActiveImage(TMultiImage(Source).ActiveImage);
+ end
+ else if Source is TSingleImage then
+ begin
+ SetLength(Arr, 1);
+ Arr[0] := TSingleImage(Source).FImageData;
+ CreateFromArray(Arr);
+ Arr := nil;
+ end
+ else
+ inherited Assign(Source);
+end;
+
+procedure TMultiImage.AddImage(AWidth, AHeight: LongInt; AFormat: TImageFormat);
+begin
+ DoInsertNew(GetImageCount, AWidth, AHeight, AFormat);
+end;
+
+procedure TMultiImage.AddImage(const Image: TImageData);
+begin
+ DoInsertImages(GetImageCount, GetArrayFromImageData(Image));
+end;
+
+procedure TMultiImage.AddImage(Image: TBaseImage);
+begin
+ if Assigned(Image) and Image.Valid then
+ DoInsertImages(GetImageCount, GetArrayFromImageData(Image.FPData^));
+end;
+
+procedure TMultiImage.AddImages(const Images: TDynImageDataArray);
+begin
+ DoInsertImages(GetImageCount, Images);
+end;
+
+procedure TMultiImage.AddImages(Images: TMultiImage);
+begin
+ DoInsertImages(GetImageCount, Images.FDataArray);
+end;
+
+procedure TMultiImage.InsertImage(Index, AWidth, AHeight: LongInt;
+ AFormat: TImageFormat);
+begin
+ DoInsertNew(Index, AWidth, AHeight, AFormat);
+end;
+
+procedure TMultiImage.InsertImage(Index: LongInt; const Image: TImageData);
+begin
+ DoInsertImages(Index, GetArrayFromImageData(Image));
+end;
+
+procedure TMultiImage.InsertImage(Index: LongInt; Image: TBaseImage);
+begin
+ if Assigned(Image) and Image.Valid then
+ DoInsertImages(Index, GetArrayFromImageData(Image.FPData^));
+end;
+
+procedure TMultiImage.InsertImages(Index: LongInt;
+ const Images: TDynImageDataArray);
+begin
+ DoInsertImages(Index, FDataArray);
+end;
+
+procedure TMultiImage.InsertImages(Index: LongInt; Images: TMultiImage);
+begin
+ DoInsertImages(Index, Images.FDataArray);
+end;
+
+procedure TMultiImage.ExchangeImages(Index1, Index2: LongInt);
+var
+ TempData: TImageData;
+begin
+ if (Index1 >= 0) and (Index1 < GetImageCount) and
+ (Index2 >= 0) and (Index2 < GetImageCount) then
+ begin
+ TempData := FDataArray[Index1];
+ FDataArray[Index1] := FDataArray[Index2];
+ FDataArray[Index2] := TempData;
+ end;
+end;
+
+procedure TMultiImage.DeleteImage(Index: LongInt);
+var
+ I: LongInt;
+begin
+ if (Index >= 0) and (Index < GetImageCount) then
+ begin
+ // Free image at index to be deleted
+ Imaging.FreeImage(FDataArray[Index]);
+ if Index < GetImageCount - 1 then
+ begin
+ // Move images to new indices if necessary
+ for I := Index to GetImageCount - 2 do
+ FDataArray[I] := FDataArray[I + 1];
+ end;
+ // Set new array length and update pointer to active image
+ SetLength(FDataArray, GetImageCount - 1);
+ SetPointer;
+ end;
+end;
+
+procedure TMultiImage.ConvertImages(Format: TImageFormat);
+var
+ I: LongInt;
+begin
+ for I := 0 to GetImageCount - 1 do
+ Imaging.ConvertImage(FDataArray[I], Format);
+end;
+
+procedure TMultiImage.ResizeImages(NewWidth, NewHeight: LongInt;
+ Filter: TResizeFilter);
+var
+ I: LongInt;
+begin
+ for I := 0 to GetImageCount do
+ Imaging.ResizeImage(FDataArray[I], NewWidth, NewHeight, Filter);
+end;
+
+procedure TMultiImage.ReverseImages;
+var
+ I: Integer;
+begin
+ for I := 0 to GetImageCount div 2 do
+ ExchangeImages(I, GetImageCount - 1 - I);
+end;
+
+procedure TMultiImage.LoadFromFile(const FileName: string);
+begin
+ if GetImageCount = 0 then
+ ImageCount := 1;
+ inherited LoadFromFile(FileName);
+end;
+
+procedure TMultiImage.LoadFromStream(Stream: TStream);
+begin
+ if GetImageCount = 0 then
+ ImageCount := 1;
+ inherited LoadFromStream(Stream);
+end;
+
+procedure TMultiImage.LoadMultiFromFile(const FileName: string);
+begin
+ Imaging.LoadMultiImageFromFile(FileName, FDataArray);
+ SetActiveImage(0);
+end;
+
+procedure TMultiImage.LoadMultiFromStream(Stream: TStream);
+begin
+ Imaging.LoadMultiImageFromStream(Stream, FDataArray);
+ SetActiveImage(0);
+end;
+
+procedure TMultiImage.SaveMultiToFile(const FileName: string);
+begin
+ Imaging.SaveMultiImageToFile(FileName, FDataArray);
+end;
+
+procedure TMultiImage.SaveMultiToStream(const Ext: string; Stream: TStream);
+begin
+ Imaging.SaveMultiImageToStream(Ext, Stream, FDataArray);
+end;
+
+{
+ File Notes:
+
+ -- TODOS ----------------------------------------------------
+ - nothing now
+ - add SetPalette, create some pal wrapper first
+ - put all low level stuff here like ReplaceColor etc, change
+ CopyTo to Copy, and add overload Copy(SrcRect, DstX, DstY) ...
+
+ -- 0.24.3 Changes/Bug Fixes ---------------------------------
+ - Added TMultiImage.ReverseImages method.
+
+ -- 0.23 Changes/Bug Fixes -----------------------------------
+ - Added SwapChannels method to TBaseImage.
+ - Added ReplaceColor method to TBaseImage.
+ - Added ToString method to TBaseImage.
+
+ -- 0.21 Changes/Bug Fixes -----------------------------------
+ - Inserting images to empty MultiImage will act as Add method.
+ - MultiImages with empty arrays will now create one image when
+ LoadFromFile or LoadFromStream is called.
+ - Fixed bug that caused AVs when getting props like Width, Height, asn Size
+ and when inlining was off. There was call to Iff but with inlining disabled
+ params like FPData.Size were evaluated and when FPData was nil => AV.
+ - Added many FPData validity checks to many methods. There were AVs
+ when calling most methods on empty TMultiImage.
+ - Added AllImagesValid property to TMultiImage.
+ - Fixed memory leak in TMultiImage.CreateFromParams.
+
+ -- 0.19 Changes/Bug Fixes -----------------------------------
+ - added ResizeImages method to TMultiImage
+ - removed Ext parameter from various LoadFromStream methods, no
+ longer needed
+ - fixed various issues concerning ActiveImage of TMultiImage
+ (it pointed to invalid location after some operations)
+ - most of property set/get methods are now inline
+ - added PixelPointers property to TBaseImage
+ - added Images default array property to TMultiImage
+ - renamed methods in TMultiImage to contain 'Image' instead of 'Level'
+ - added canvas support
+ - added OnDataSizeChanged and OnPixelsChanged event to TBaseImage
+ - renamed TSingleImage.NewImage to RecreateImageData, made public, and
+ moved to TBaseImage
+
+ -- 0.17 Changes/Bug Fixes -----------------------------------
+ - added props PaletteEntries and ScanLine to TBaseImage
+ - aded new constructor to TBaseImage that take TBaseImage source
+ - TMultiImage levels adding and inserting rewritten internally
+ - added some new functions to TMultiImage: AddLevels, InsertLevels
+ - added some new functions to TBaseImage: Flip, Mirror, Rotate,
+ CopyRect, StretchRect
+ - TBasicImage.Resize has now filter parameter
+ - new stuff added to TMultiImage (DataArray prop, ConvertLevels)
+
+ -- 0.13 Changes/Bug Fixes -----------------------------------
+ - added AddLevel, InsertLevel, ExchangeLevels and DeleteLevel
+ methods to TMultiImage
+ - added TBaseImage, TSingleImage and TMultiImage with initial
+ members
+}
+
+end.
+
diff --git a/Imaging/ImagingColors.pas b/Imaging/ImagingColors.pas
index 340372f..941808b 100644
--- a/Imaging/ImagingColors.pas
+++ b/Imaging/ImagingColors.pas
@@ -1,245 +1,245 @@
-{
- $Id: ImagingColors.pas 173 2009-09-04 17:05:52Z galfar $
- Vampyre Imaging Library
- by Marek Mauder
- http://imaginglib.sourceforge.net
-
- The contents of this file are used with permission, subject to the Mozilla
- Public License Version 1.1 (the "License"); you may not use this file except
- in compliance with the License. You may obtain a copy of the License at
- http://www.mozilla.org/MPL/MPL-1.1.html
-
- Software distributed under the License is distributed on an "AS IS" basis,
- WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
- the specific language governing rights and limitations under the License.
-
- Alternatively, the contents of this file may be used under the terms of the
- GNU Lesser General Public License (the "LGPL License"), in which case the
- provisions of the LGPL License are applicable instead of those above.
- If you wish to allow use of your version of this file only under the terms
- of the LGPL License and not to allow others to use your version of this file
- under the MPL, indicate your decision by deleting the provisions above and
- replace them with the notice and other provisions required by the LGPL
- License. If you do not delete the provisions above, a recipient may use
- your version of this file under either the MPL or the LGPL License.
-
- For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
-}
-
-{ This unit contains functions for manipulating and converting color values.}
-unit ImagingColors;
-
-interface
-
-{$I ImagingOptions.inc}
-
-uses
- SysUtils, ImagingTypes, ImagingUtility;
-
-{ Converts RGB color to YUV.}
-procedure RGBToYUV(R, G, B: Byte; var Y, U, V: Byte);
-{ Converts YIV to RGB color.}
-procedure YUVToRGB(Y, U, V: Byte; var R, G, B: Byte);
-
-{ Converts RGB color to YCbCr as used in JPEG.}
-procedure RGBToYCbCr(R, G, B: Byte; var Y, Cb, Cr: Byte);
-{ Converts YCbCr as used in JPEG to RGB color.}
-procedure YCbCrToRGB(Y, Cb, Cr: Byte; var R, G, B: Byte);
-{ Converts RGB color to YCbCr as used in JPEG.}
-procedure RGBToYCbCr16(R, G, B: Word; var Y, Cb, Cr: Word);
-{ Converts YCbCr as used in JPEG to RGB color.}
-procedure YCbCrToRGB16(Y, Cb, Cr: Word; var R, G, B: Word);
-
-{ Converts RGB color to CMY.}
-procedure RGBToCMY(R, G, B: Byte; var C, M, Y: Byte);
-{ Converts CMY to RGB color.}
-procedure CMYToRGB(C, M, Y: Byte; var R, G, B: Byte);
-{ Converts RGB color to CMY.}
-procedure RGBToCMY16(R, G, B: Word; var C, M, Y: Word);
-{ Converts CMY to RGB color.}
-procedure CMYToRGB16(C, M, Y: Word; var R, G, B: Word);
-
-{ Converts RGB color to CMYK.}
-procedure RGBToCMYK(R, G, B: Byte; var C, M, Y, K: Byte);
-{ Converts CMYK to RGB color.}
-procedure CMYKToRGB(C, M, Y, K: Byte; var R, G, B: Byte);
-{ Converts RGB color to CMYK.}
-procedure RGBToCMYK16(R, G, B: Word; var C, M, Y, K: Word);
-{ Converts CMYK to RGB color.}
-procedure CMYKToRGB16(C, M, Y, K: Word; var R, G, B: Word);
-
-{ Converts RGB color to YCoCg.}
-procedure RGBToYCoCg(R, G, B: Byte; var Y, Co, Cg: Byte);
-{ Converts YCoCg to RGB color.}
-procedure YCoCgToRGB(Y, Co, Cg: Byte; var R, G, B: Byte);
-
-
-implementation
-
-procedure RGBToYUV(R, G, B: Byte; var Y, U, V: Byte);
-begin
- Y := ClampToByte(Round( 0.257 * R + 0.504 * G + 0.098 * B) + 16);
- V := ClampToByte(Round( 0.439 * R - 0.368 * G - 0.071 * B) + 128);
- U := ClampToByte(Round(-0.148 * R - 0.291 * G + 0.439 * B) + 128);
-end;
-
-procedure YUVToRGB(Y, U, V: Byte; var R, G, B: Byte);
-var
- CY, CU, CV: LongInt;
-begin
- CY := Y - 16;
- CU := U - 128;
- CV := V - 128;
- R := ClampToByte(Round(1.164 * CY - 0.002 * CU + 1.596 * CV));
- G := ClampToByte(Round(1.164 * CY - 0.391 * CU - 0.813 * CV));
- B := ClampToByte(Round(1.164 * CY + 2.018 * CU - 0.001 * CV));
-end;
-
-procedure RGBToYCbCr(R, G, B: Byte; var Y, Cb, Cr: Byte);
-begin
- Y := ClampToByte(Round( 0.29900 * R + 0.58700 * G + 0.11400 * B));
- Cb := ClampToByte(Round(-0.16874 * R - 0.33126 * G + 0.50000 * B + 128));
- Cr := ClampToByte(Round( 0.50000 * R - 0.41869 * G - 0.08131 * B + 128));
-end;
-
-procedure YCbCrToRGB(Y, Cb, Cr: Byte; var R, G, B: Byte);
-begin
- R := ClampToByte(Round(Y + 1.40200 * (Cr - 128)));
- G := ClampToByte(Round(Y - 0.34414 * (Cb - 128) - 0.71414 * (Cr - 128)));
- B := ClampToByte(Round(Y + 1.77200 * (Cb - 128)));
-end;
-
-procedure RGBToYCbCr16(R, G, B: Word; var Y, Cb, Cr: Word);
-begin
- Y := ClampToWord(Round( 0.29900 * R + 0.58700 * G + 0.11400 * B));
- Cb := ClampToWord(Round(-0.16874 * R - 0.33126 * G + 0.50000 * B + 32768));
- Cr := ClampToWord(Round( 0.50000 * R - 0.41869 * G - 0.08131 * B + 32768));
-end;
-
-procedure YCbCrToRGB16(Y, Cb, Cr: Word; var R, G, B: Word);
-begin
- R := ClampToWord(Round(Y + 1.40200 * (Cr - 32768)));
- G := ClampToWord(Round(Y - 0.34414 * (Cb - 32768) - 0.71414 * (Cr - 32768)));
- B := ClampToWord(Round(Y + 1.77200 * (Cb - 32768)));
-end;
-
-procedure RGBToCMY(R, G, B: Byte; var C, M, Y: Byte);
-begin
- C := 255 - R;
- M := 255 - G;
- Y := 255 - B;
-end;
-
-procedure CMYToRGB(C, M, Y: Byte; var R, G, B: Byte);
-begin
- R := 255 - C;
- G := 255 - M;
- B := 255 - Y;
-end;
-
-procedure RGBToCMY16(R, G, B: Word; var C, M, Y: Word);
-begin
- C := 65535 - R;
- M := 65535 - G;
- Y := 65535 - B;
-end;
-
-procedure CMYToRGB16(C, M, Y: Word; var R, G, B: Word);
-begin
- R := 65535 - C;
- G := 65535 - M;
- B := 65535 - Y;
-end;
-
-procedure RGBToCMYK(R, G, B: Byte; var C, M, Y, K: Byte);
-begin
- RGBToCMY(R, G, B, C, M, Y);
- K := Min(C, Min(M, Y));
- if K = 255 then
- begin
- C := 0;
- M := 0;
- Y := 0;
- end
- else
- begin
- C := ClampToByte(Round((C - K) / (255 - K) * 255));
- M := ClampToByte(Round((M - K) / (255 - K) * 255));
- Y := ClampToByte(Round((Y - K) / (255 - K) * 255));
- end;
-end;
-
-procedure CMYKToRGB(C, M, Y, K: Byte; var R, G, B: Byte);
-begin
- R := (255 - (C - MulDiv(C, K, 255) + K));
- G := (255 - (M - MulDiv(M, K, 255) + K));
- B := (255 - (Y - MulDiv(Y, K, 255) + K));
-end;
-
-procedure RGBToCMYK16(R, G, B: Word; var C, M, Y, K: Word);
-begin
- RGBToCMY16(R, G, B, C, M, Y);
- K := Min(C, Min(M, Y));
- if K = 65535 then
- begin
- C := 0;
- M := 0;
- Y := 0;
- end
- else
- begin
- C := ClampToWord(Round((C - K) / (65535 - K) * 65535));
- M := ClampToWord(Round((M - K) / (65535 - K) * 65535));
- Y := ClampToWord(Round((Y - K) / (65535 - K) * 65535));
- end;
-end;
-
-procedure CMYKToRGB16(C, M, Y, K: Word; var R, G, B: Word);
-begin
- R := 65535 - (C - MulDiv(C, K, 65535) + K);
- G := 65535 - (M - MulDiv(M, K, 65535) + K);
- B := 65535 - (Y - MulDiv(Y, K, 65535) + K);
-end;
-
-procedure RGBToYCoCg(R, G, B: Byte; var Y, Co, Cg: Byte);
-begin
- // C and Delphi's SHR behaviour differs for negative numbers, use div instead.
- Y := ClampToByte(( R + G shl 1 + B + 2) div 4);
- Co := ClampToByte(( R shl 1 - B shl 1 + 2) div 4 + 128);
- Cg := ClampToByte((-R + G shl 1 - B + 2) div 4 + 128);
-end;
-
-procedure YCoCgToRGB(Y, Co, Cg: Byte; var R, G, B: Byte);
-var
- CoInt, CgInt: Integer;
-begin
- CoInt := Co - 128;
- CgInt := Cg - 128;
- R := ClampToByte(Y + CoInt - CgInt);
- G := ClampToByte(Y + CgInt);
- B := ClampToByte(Y - CoInt - CgInt);
-end;
-
-{
- File Notes:
-
- -- TODOS ----------------------------------------------------
- - nothing now
-
- -- 0.26.3 Changes/Bug Fixes ---------------------------------
- - Added RGB<>YCoCg conversion functions.
- - Fixed RGB>>CMYK conversions.
-
- -- 0.23 Changes/Bug Fixes -----------------------------------
- - Added RGB<>CMY(K) converion functions for 16 bit channels
- (needed by PSD loading code).
-
- -- 0.21 Changes/Bug Fixes -----------------------------------
- - Added some color space conversion functions and LUTs
- (RGB/YUV/YCrCb/CMY/CMYK).
-
- -- 0.17 Changes/Bug Fixes -----------------------------------
- - unit created (empty!)
-}
-
-end.
+{
+ $Id: ImagingColors.pas 173 2009-09-04 17:05:52Z galfar $
+ Vampyre Imaging Library
+ by Marek Mauder
+ http://imaginglib.sourceforge.net
+
+ The contents of this file are used with permission, subject to the Mozilla
+ Public License Version 1.1 (the "License"); you may not use this file except
+ in compliance with the License. You may obtain a copy of the License at
+ http://www.mozilla.org/MPL/MPL-1.1.html
+
+ Software distributed under the License is distributed on an "AS IS" basis,
+ WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
+ the specific language governing rights and limitations under the License.
+
+ Alternatively, the contents of this file may be used under the terms of the
+ GNU Lesser General Public License (the "LGPL License"), in which case the
+ provisions of the LGPL License are applicable instead of those above.
+ If you wish to allow use of your version of this file only under the terms
+ of the LGPL License and not to allow others to use your version of this file
+ under the MPL, indicate your decision by deleting the provisions above and
+ replace them with the notice and other provisions required by the LGPL
+ License. If you do not delete the provisions above, a recipient may use
+ your version of this file under either the MPL or the LGPL License.
+
+ For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
+}
+
+{ This unit contains functions for manipulating and converting color values.}
+unit ImagingColors;
+
+interface
+
+{$I ImagingOptions.inc}
+
+uses
+ SysUtils, ImagingTypes, ImagingUtility;
+
+{ Converts RGB color to YUV.}
+procedure RGBToYUV(R, G, B: Byte; var Y, U, V: Byte);
+{ Converts YIV to RGB color.}
+procedure YUVToRGB(Y, U, V: Byte; var R, G, B: Byte);
+
+{ Converts RGB color to YCbCr as used in JPEG.}
+procedure RGBToYCbCr(R, G, B: Byte; var Y, Cb, Cr: Byte);
+{ Converts YCbCr as used in JPEG to RGB color.}
+procedure YCbCrToRGB(Y, Cb, Cr: Byte; var R, G, B: Byte);
+{ Converts RGB color to YCbCr as used in JPEG.}
+procedure RGBToYCbCr16(R, G, B: Word; var Y, Cb, Cr: Word);
+{ Converts YCbCr as used in JPEG to RGB color.}
+procedure YCbCrToRGB16(Y, Cb, Cr: Word; var R, G, B: Word);
+
+{ Converts RGB color to CMY.}
+procedure RGBToCMY(R, G, B: Byte; var C, M, Y: Byte);
+{ Converts CMY to RGB color.}
+procedure CMYToRGB(C, M, Y: Byte; var R, G, B: Byte);
+{ Converts RGB color to CMY.}
+procedure RGBToCMY16(R, G, B: Word; var C, M, Y: Word);
+{ Converts CMY to RGB color.}
+procedure CMYToRGB16(C, M, Y: Word; var R, G, B: Word);
+
+{ Converts RGB color to CMYK.}
+procedure RGBToCMYK(R, G, B: Byte; var C, M, Y, K: Byte);
+{ Converts CMYK to RGB color.}
+procedure CMYKToRGB(C, M, Y, K: Byte; var R, G, B: Byte);
+{ Converts RGB color to CMYK.}
+procedure RGBToCMYK16(R, G, B: Word; var C, M, Y, K: Word);
+{ Converts CMYK to RGB color.}
+procedure CMYKToRGB16(C, M, Y, K: Word; var R, G, B: Word);
+
+{ Converts RGB color to YCoCg.}
+procedure RGBToYCoCg(R, G, B: Byte; var Y, Co, Cg: Byte);
+{ Converts YCoCg to RGB color.}
+procedure YCoCgToRGB(Y, Co, Cg: Byte; var R, G, B: Byte);
+
+
+implementation
+
+procedure RGBToYUV(R, G, B: Byte; var Y, U, V: Byte);
+begin
+ Y := ClampToByte(Round( 0.257 * R + 0.504 * G + 0.098 * B) + 16);
+ V := ClampToByte(Round( 0.439 * R - 0.368 * G - 0.071 * B) + 128);
+ U := ClampToByte(Round(-0.148 * R - 0.291 * G + 0.439 * B) + 128);
+end;
+
+procedure YUVToRGB(Y, U, V: Byte; var R, G, B: Byte);
+var
+ CY, CU, CV: LongInt;
+begin
+ CY := Y - 16;
+ CU := U - 128;
+ CV := V - 128;
+ R := ClampToByte(Round(1.164 * CY - 0.002 * CU + 1.596 * CV));
+ G := ClampToByte(Round(1.164 * CY - 0.391 * CU - 0.813 * CV));
+ B := ClampToByte(Round(1.164 * CY + 2.018 * CU - 0.001 * CV));
+end;
+
+procedure RGBToYCbCr(R, G, B: Byte; var Y, Cb, Cr: Byte);
+begin
+ Y := ClampToByte(Round( 0.29900 * R + 0.58700 * G + 0.11400 * B));
+ Cb := ClampToByte(Round(-0.16874 * R - 0.33126 * G + 0.50000 * B + 128));
+ Cr := ClampToByte(Round( 0.50000 * R - 0.41869 * G - 0.08131 * B + 128));
+end;
+
+procedure YCbCrToRGB(Y, Cb, Cr: Byte; var R, G, B: Byte);
+begin
+ R := ClampToByte(Round(Y + 1.40200 * (Cr - 128)));
+ G := ClampToByte(Round(Y - 0.34414 * (Cb - 128) - 0.71414 * (Cr - 128)));
+ B := ClampToByte(Round(Y + 1.77200 * (Cb - 128)));
+end;
+
+procedure RGBToYCbCr16(R, G, B: Word; var Y, Cb, Cr: Word);
+begin
+ Y := ClampToWord(Round( 0.29900 * R + 0.58700 * G + 0.11400 * B));
+ Cb := ClampToWord(Round(-0.16874 * R - 0.33126 * G + 0.50000 * B + 32768));
+ Cr := ClampToWord(Round( 0.50000 * R - 0.41869 * G - 0.08131 * B + 32768));
+end;
+
+procedure YCbCrToRGB16(Y, Cb, Cr: Word; var R, G, B: Word);
+begin
+ R := ClampToWord(Round(Y + 1.40200 * (Cr - 32768)));
+ G := ClampToWord(Round(Y - 0.34414 * (Cb - 32768) - 0.71414 * (Cr - 32768)));
+ B := ClampToWord(Round(Y + 1.77200 * (Cb - 32768)));
+end;
+
+procedure RGBToCMY(R, G, B: Byte; var C, M, Y: Byte);
+begin
+ C := 255 - R;
+ M := 255 - G;
+ Y := 255 - B;
+end;
+
+procedure CMYToRGB(C, M, Y: Byte; var R, G, B: Byte);
+begin
+ R := 255 - C;
+ G := 255 - M;
+ B := 255 - Y;
+end;
+
+procedure RGBToCMY16(R, G, B: Word; var C, M, Y: Word);
+begin
+ C := 65535 - R;
+ M := 65535 - G;
+ Y := 65535 - B;
+end;
+
+procedure CMYToRGB16(C, M, Y: Word; var R, G, B: Word);
+begin
+ R := 65535 - C;
+ G := 65535 - M;
+ B := 65535 - Y;
+end;
+
+procedure RGBToCMYK(R, G, B: Byte; var C, M, Y, K: Byte);
+begin
+ RGBToCMY(R, G, B, C, M, Y);
+ K := Min(C, Min(M, Y));
+ if K = 255 then
+ begin
+ C := 0;
+ M := 0;
+ Y := 0;
+ end
+ else
+ begin
+ C := ClampToByte(Round((C - K) / (255 - K) * 255));
+ M := ClampToByte(Round((M - K) / (255 - K) * 255));
+ Y := ClampToByte(Round((Y - K) / (255 - K) * 255));
+ end;
+end;
+
+procedure CMYKToRGB(C, M, Y, K: Byte; var R, G, B: Byte);
+begin
+ R := (255 - (C - MulDiv(C, K, 255) + K));
+ G := (255 - (M - MulDiv(M, K, 255) + K));
+ B := (255 - (Y - MulDiv(Y, K, 255) + K));
+end;
+
+procedure RGBToCMYK16(R, G, B: Word; var C, M, Y, K: Word);
+begin
+ RGBToCMY16(R, G, B, C, M, Y);
+ K := Min(C, Min(M, Y));
+ if K = 65535 then
+ begin
+ C := 0;
+ M := 0;
+ Y := 0;
+ end
+ else
+ begin
+ C := ClampToWord(Round((C - K) / (65535 - K) * 65535));
+ M := ClampToWord(Round((M - K) / (65535 - K) * 65535));
+ Y := ClampToWord(Round((Y - K) / (65535 - K) * 65535));
+ end;
+end;
+
+procedure CMYKToRGB16(C, M, Y, K: Word; var R, G, B: Word);
+begin
+ R := 65535 - (C - MulDiv(C, K, 65535) + K);
+ G := 65535 - (M - MulDiv(M, K, 65535) + K);
+ B := 65535 - (Y - MulDiv(Y, K, 65535) + K);
+end;
+
+procedure RGBToYCoCg(R, G, B: Byte; var Y, Co, Cg: Byte);
+begin
+ // C and Delphi's SHR behaviour differs for negative numbers, use div instead.
+ Y := ClampToByte(( R + G shl 1 + B + 2) div 4);
+ Co := ClampToByte(( R shl 1 - B shl 1 + 2) div 4 + 128);
+ Cg := ClampToByte((-R + G shl 1 - B + 2) div 4 + 128);
+end;
+
+procedure YCoCgToRGB(Y, Co, Cg: Byte; var R, G, B: Byte);
+var
+ CoInt, CgInt: Integer;
+begin
+ CoInt := Co - 128;
+ CgInt := Cg - 128;
+ R := ClampToByte(Y + CoInt - CgInt);
+ G := ClampToByte(Y + CgInt);
+ B := ClampToByte(Y - CoInt - CgInt);
+end;
+
+{
+ File Notes:
+
+ -- TODOS ----------------------------------------------------
+ - nothing now
+
+ -- 0.26.3 Changes/Bug Fixes ---------------------------------
+ - Added RGB<>YCoCg conversion functions.
+ - Fixed RGB>>CMYK conversions.
+
+ -- 0.23 Changes/Bug Fixes -----------------------------------
+ - Added RGB<>CMY(K) converion functions for 16 bit channels
+ (needed by PSD loading code).
+
+ -- 0.21 Changes/Bug Fixes -----------------------------------
+ - Added some color space conversion functions and LUTs
+ (RGB/YUV/YCrCb/CMY/CMYK).
+
+ -- 0.17 Changes/Bug Fixes -----------------------------------
+ - unit created (empty!)
+}
+
+end.
diff --git a/Imaging/ImagingComponents.pas b/Imaging/ImagingComponents.pas
index 393ebf5..4c560c0 100644
--- a/Imaging/ImagingComponents.pas
+++ b/Imaging/ImagingComponents.pas
@@ -336,7 +336,7 @@ implementation
uses
{$IF Defined(LCL)}
{$IF Defined(LCLGTK2)}
- GLib2, GDK2, GTK2, GTKDef, GTKProc,
+ GLib2, GDK2, GTK2, Gtk2Def, Gtk2Proc,
{$ELSEIF Defined(LCLGTK)}
GDK, GTK, GTKDef, GTKProc,
{$IFEND}
diff --git a/Imaging/ImagingDds.pas b/Imaging/ImagingDds.pas
index 0b439a9..08090d7 100644
--- a/Imaging/ImagingDds.pas
+++ b/Imaging/ImagingDds.pas
@@ -1,864 +1,864 @@
-{
- $Id: ImagingDds.pas 129 2008-08-06 20:01:30Z galfar $
- Vampyre Imaging Library
- by Marek Mauder
- http://imaginglib.sourceforge.net
-
- The contents of this file are used with permission, subject to the Mozilla
- Public License Version 1.1 (the "License"); you may not use this file except
- in compliance with the License. You may obtain a copy of the License at
- http://www.mozilla.org/MPL/MPL-1.1.html
-
- Software distributed under the License is distributed on an "AS IS" basis,
- WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
- the specific language governing rights and limitations under the License.
-
- Alternatively, the contents of this file may be used under the terms of the
- GNU Lesser General Public License (the "LGPL License"), in which case the
- provisions of the LGPL License are applicable instead of those above.
- If you wish to allow use of your version of this file only under the terms
- of the LGPL License and not to allow others to use your version of this file
- under the MPL, indicate your decision by deleting the provisions above and
- replace them with the notice and other provisions required by the LGPL
- License. If you do not delete the provisions above, a recipient may use
- your version of this file under either the MPL or the LGPL License.
-
- For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
-}
-
-{ This unit contains image format loader/saver for DirectDraw Surface images.}
-unit ImagingDds;
-
-{$I ImagingOptions.inc}
-
-interface
-
-uses
- ImagingTypes, Imaging, ImagingUtility, ImagingFormats;
-
-type
- { Class for loading and saving Microsoft DirectDraw surfaces.
- It can load/save all D3D formats which have coresponding
- TImageFormat. It supports plain textures, cube textures and
- volume textures, all of these can have mipmaps. It can also
- load some formats which have no exact TImageFormat, but can be easily
- converted to one (bump map formats).
- You can get some information about last loaded DDS file by calling
- GetOption with ImagingDDSLoadedXXX options and you can set some
- saving options by calling SetOption with ImagingDDSSaveXXX or you can
- simply use properties of this class.
- Note that when saving cube maps and volumes input image array must contain
- at least number of images to build cube/volume based on current
- Depth and MipMapCount settings.}
- TDDSFileFormat = class(TImageFileFormat)
- protected
- FLoadedCubeMap: LongBool;
- FLoadedVolume: LongBool;
- FLoadedMipMapCount: LongInt;
- FLoadedDepth: LongInt;
- FSaveCubeMap: LongBool;
- FSaveVolume: LongBool;
- FSaveMipMapCount: LongInt;
- FSaveDepth: LongInt;
- procedure ComputeSubDimensions(Idx, Width, Height, MipMaps, Depth: LongInt;
- IsCubeMap, IsVolume: Boolean; var CurWidth, CurHeight: LongInt);
- function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
- OnlyFirstLevel: Boolean): Boolean; override;
- function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
- Index: LongInt): Boolean; override;
- procedure ConvertToSupported(var Image: TImageData;
- const Info: TImageFormatInfo); override;
- public
- constructor Create; override;
- function TestFormat(Handle: TImagingHandle): Boolean; override;
- procedure CheckOptionsValidity; override;
- published
- { True if last loaded DDS file was cube map.}
- property LoadedCubeMap: LongBool read FLoadedCubeMap write FLoadedCubeMap;
- { True if last loaded DDS file was volume texture.}
- property LoadedVolume: LongBool read FLoadedVolume write FLoadedVolume;
- { Number of mipmap levels of last loaded DDS image.}
- property LoadedMipMapCount: LongInt read FLoadedMipMapCount write FLoadedMipMapCount;
- { Depth (slices of volume texture or faces of cube map) of last loaded DDS image.}
- property LoadedDepth: LongInt read FLoadedDepth write FLoadedDepth;
- { True if next DDS file to be saved should be stored as cube map.}
- property SaveCubeMap: LongBool read FSaveCubeMap write FSaveCubeMap;
- { True if next DDS file to be saved should be stored as volume texture.}
- property SaveVolume: LongBool read FSaveVolume write FSaveVolume;
- { Sets the number of mipmaps which should be stored in the next saved DDS file.
- Only applies to cube maps and volumes, ordinary 2D textures save all
- levels present in input.}
- property SaveMipMapCount: LongInt read FSaveMipMapCount write FSaveMipMapCount;
- { Sets the depth (slices of volume texture or faces of cube map)
- of the next saved DDS file.}
- property SaveDepth: LongInt read FSaveDepth write FSaveDepth;
- end;
-
-implementation
-
-const
- SDDSFormatName = 'DirectDraw Surface';
- SDDSMasks = '*.dds';
- DDSSupportedFormats: TImageFormats = [ifR8G8B8, ifA8R8G8B8, ifX8R8G8B8,
- ifA1R5G5B5, ifA4R4G4B4, ifX1R5G5B5, ifX4R4G4B4, ifR5G6B5, ifA16B16G16R16,
- ifR32F, ifA32B32G32R32F, ifR16F, ifA16B16G16R16F, ifR3G3B2, ifGray8, ifA8Gray8,
- ifGray16, ifDXT1, ifDXT3, ifDXT5, ifATI1N, ifATI2N];
-
-const
- { Four character codes.}
- DDSMagic = LongWord(Byte('D') or (Byte('D') shl 8) or (Byte('S') shl 16) or
- (Byte(' ') shl 24));
- FOURCC_DXT1 = LongWord(Byte('D') or (Byte('X') shl 8) or (Byte('T') shl 16) or
- (Byte('1') shl 24));
- FOURCC_DXT3 = LongWord(Byte('D') or (Byte('X') shl 8) or (Byte('T') shl 16) or
- (Byte('3') shl 24));
- FOURCC_DXT5 = LongWord(Byte('D') or (Byte('X') shl 8) or (Byte('T') shl 16) or
- (Byte('5') shl 24));
- FOURCC_ATI1 = LongWord(Byte('A') or (Byte('T') shl 8) or (Byte('I') shl 16) or
- (Byte('1') shl 24));
- FOURCC_ATI2 = LongWord(Byte('A') or (Byte('T') shl 8) or (Byte('I') shl 16) or
- (Byte('2') shl 24));
-
- { Some D3DFORMAT values used in DDS files as FourCC value.}
- D3DFMT_A16B16G16R16 = 36;
- D3DFMT_R32F = 114;
- D3DFMT_A32B32G32R32F = 116;
- D3DFMT_R16F = 111;
- D3DFMT_A16B16G16R16F = 113;
-
- { Constans used by TDDSurfaceDesc2.Flags.}
- DDSD_CAPS = $00000001;
- DDSD_HEIGHT = $00000002;
- DDSD_WIDTH = $00000004;
- DDSD_PITCH = $00000008;
- DDSD_PIXELFORMAT = $00001000;
- DDSD_MIPMAPCOUNT = $00020000;
- DDSD_LINEARSIZE = $00080000;
- DDSD_DEPTH = $00800000;
-
- { Constans used by TDDSPixelFormat.Flags.}
- DDPF_ALPHAPIXELS = $00000001; // used by formats which contain alpha
- DDPF_FOURCC = $00000004; // used by DXT and large ARGB formats
- DDPF_RGB = $00000040; // used by RGB formats
- DDPF_LUMINANCE = $00020000; // used by formats like D3DFMT_L16
- DDPF_BUMPLUMINANCE = $00040000; // used by mixed signed-unsigned formats
- DDPF_BUMPDUDV = $00080000; // used by signed formats
-
- { Constans used by TDDSCaps.Caps1.}
- DDSCAPS_COMPLEX = $00000008;
- DDSCAPS_TEXTURE = $00001000;
- DDSCAPS_MIPMAP = $00400000;
-
- { Constans used by TDDSCaps.Caps2.}
- DDSCAPS2_CUBEMAP = $00000200;
- DDSCAPS2_POSITIVEX = $00000400;
- DDSCAPS2_NEGATIVEX = $00000800;
- DDSCAPS2_POSITIVEY = $00001000;
- DDSCAPS2_NEGATIVEY = $00002000;
- DDSCAPS2_POSITIVEZ = $00004000;
- DDSCAPS2_NEGATIVEZ = $00008000;
- DDSCAPS2_VOLUME = $00200000;
-
- { Flags for TDDSurfaceDesc2.Flags used when saving DDS file.}
- DDS_SAVE_FLAGS = DDSD_CAPS or DDSD_PIXELFORMAT or DDSD_WIDTH or
- DDSD_HEIGHT or DDSD_LINEARSIZE;
-
-type
- { Stores the pixel format information.}
- TDDPixelFormat = packed record
- Size: LongWord; // Size of the structure = 32 bytes
- Flags: LongWord; // Flags to indicate valid fields
- FourCC: LongWord; // Four-char code for compressed textures (DXT)
- BitCount: LongWord; // Bits per pixel if uncomp. usually 16,24 or 32
- RedMask: LongWord; // Bit mask for the Red component
- GreenMask: LongWord; // Bit mask for the Green component
- BlueMask: LongWord; // Bit mask for the Blue component
- AlphaMask: LongWord; // Bit mask for the Alpha component
- end;
-
- { Specifies capabilities of surface.}
- TDDSCaps = packed record
- Caps1: LongWord; // Should always include DDSCAPS_TEXTURE
- Caps2: LongWord; // For cubic environment maps
- Reserved: array[0..1] of LongWord; // Reserved
- end;
-
- { Record describing DDS file contents.}
- TDDSurfaceDesc2 = packed record
- Size: LongWord; // Size of the structure = 124 Bytes
- Flags: LongWord; // Flags to indicate valid fields
- Height: LongWord; // Height of the main image in pixels
- Width: LongWord; // Width of the main image in pixels
- PitchOrLinearSize: LongWord; // For uncomp formats number of bytes per
- // scanline. For comp it is the size in
- // bytes of the main image
- Depth: LongWord; // Only for volume text depth of the volume
- MipMaps: LongInt; // Total number of levels in the mipmap chain
- Reserved1: array[0..10] of LongWord; // Reserved
- PixelFormat: TDDPixelFormat; // Format of the pixel data
- Caps: TDDSCaps; // Capabilities
- Reserved2: LongWord; // Reserved
- end;
-
- { DDS file header.}
- TDDSFileHeader = packed record
- Magic: LongWord; // File format magic
- Desc: TDDSurfaceDesc2; // Surface description
- end;
-
-
-{ TDDSFileFormat class implementation }
-
-constructor TDDSFileFormat.Create;
-begin
- inherited Create;
- FName := SDDSFormatName;
- FCanLoad := True;
- FCanSave := True;
- FIsMultiImageFormat := True;
- FSupportedFormats := DDSSupportedFormats;
-
- FSaveCubeMap := False;
- FSaveVolume := False;
- FSaveMipMapCount := 1;
- FSaveDepth := 1;
-
- AddMasks(SDDSMasks);
-
- RegisterOption(ImagingDDSLoadedCubeMap, @FLoadedCubeMap);
- RegisterOption(ImagingDDSLoadedVolume, @FLoadedVolume);
- RegisterOption(ImagingDDSLoadedMipMapCount, @FLoadedMipMapCount);
- RegisterOption(ImagingDDSLoadedDepth, @FLoadedDepth);
- RegisterOption(ImagingDDSSaveCubeMap, @FSaveCubeMap);
- RegisterOption(ImagingDDSSaveVolume, @FSaveVolume);
- RegisterOption(ImagingDDSSaveMipMapCount, @FSaveMipMapCount);
- RegisterOption(ImagingDDSSaveDepth, @FSaveDepth);
-end;
-
-procedure TDDSFileFormat.CheckOptionsValidity;
-begin
- if FSaveCubeMap then
- FSaveVolume := False;
- if FSaveVolume then
- FSaveCubeMap := False;
- if FSaveDepth < 1 then
- FSaveDepth := 1;
- if FSaveMipMapCount < 1 then
- FSaveMipMapCount := 1;
-end;
-
-procedure TDDSFileFormat.ComputeSubDimensions(Idx, Width, Height, MipMaps, Depth: LongInt;
- IsCubeMap, IsVolume: Boolean; var CurWidth, CurHeight: LongInt);
-var
- I, Last, Shift: LongInt;
-begin
- CurWidth := Width;
- CurHeight := Height;
- if MipMaps > 1 then
- begin
- if not IsVolume then
- begin
- if IsCubeMap then
- begin
- // Cube maps are stored like this
- // Face 0 mimap 0
- // Face 0 mipmap 1
- // ...
- // Face 1 mipmap 0
- // Face 1 mipmap 1
- // ...
-
- // Modify index so later in for loop we iterate less times
- Idx := Idx - ((Idx div MipMaps) * MipMaps);
- end;
- for I := 0 to Idx - 1 do
- begin
- CurWidth := ClampInt(CurWidth shr 1, 1, CurWidth);
- CurHeight := ClampInt(CurHeight shr 1, 1, CurHeight);
- end;
- end
- else
- begin
- // Volume textures are stored in DDS files like this:
- // Slice 0 mipmap 0
- // Slice 1 mipmap 0
- // Slice 2 mipmap 0
- // Slice 3 mipmap 0
- // Slice 0 mipmap 1
- // Slice 1 mipmap 1
- // Slice 0 mipmap 2
- // Slice 0 mipmap 3 ...
- Shift := 0;
- Last := Depth;
- while Idx > Last - 1 do
- begin
- CurWidth := ClampInt(CurWidth shr 1, 1, CurWidth);
- CurHeight := ClampInt(CurHeight shr 1, 1, CurHeight);
- if (CurWidth = 1) and (CurHeight = 1) then
- Break;
- Inc(Shift);
- Inc(Last, ClampInt(Depth shr Shift, 1, Depth));
- end;
- end;
- end;
-end;
-
-function TDDSFileFormat.LoadData(Handle: TImagingHandle;
- var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
-var
- Hdr: TDDSFileHeader;
- SrcFormat: TImageFormat;
- FmtInfo: TImageFormatInfo;
- NeedsSwapChannels: Boolean;
- CurrentWidth, CurrentHeight, ImageCount, LoadSize, I, PitchOrLinear: LongInt;
- Data: PByte;
- UseAsPitch: Boolean;
- UseAsLinear: Boolean;
-
- function MasksEqual(const DDPF: TDDPixelFormat; PF: PPixelFormatInfo): Boolean;
- begin
- Result := (DDPF.AlphaMask = PF.ABitMask) and
- (DDPF.RedMask = PF.RBitMask) and (DDPF.GreenMask = PF.GBitMask) and
- (DDPF.BlueMask = PF.BBitMask);
- end;
-
-begin
- Result := False;
- ImageCount := 1;
- FLoadedMipMapCount := 1;
- FLoadedDepth := 1;
- FLoadedVolume := False;
- FLoadedCubeMap := False;
-
- with GetIO, Hdr, Hdr.Desc.PixelFormat do
- begin
- Read(Handle, @Hdr, SizeOF(Hdr));
- {
- // Set position to the end of the header (for possible future versions
- // ith larger header)
- Seek(Handle, Hdr.Desc.Size + SizeOf(Hdr.Magic) - SizeOf(Hdr),
- smFromCurrent);
- }
- SrcFormat := ifUnknown;
- NeedsSwapChannels := False;
- // Get image data format
- if (Flags and DDPF_FOURCC) = DDPF_FOURCC then
- begin
- // Handle FourCC and large ARGB formats
- case FourCC of
- D3DFMT_A16B16G16R16: SrcFormat := ifA16B16G16R16;
- D3DFMT_R32F: SrcFormat := ifR32F;
- D3DFMT_A32B32G32R32F: SrcFormat := ifA32B32G32R32F;
- D3DFMT_R16F: SrcFormat := ifR16F;
- D3DFMT_A16B16G16R16F: SrcFormat := ifA16B16G16R16F;
- FOURCC_DXT1: SrcFormat := ifDXT1;
- FOURCC_DXT3: SrcFormat := ifDXT3;
- FOURCC_DXT5: SrcFormat := ifDXT5;
- FOURCC_ATI1: SrcFormat := ifATI1N;
- FOURCC_ATI2: SrcFormat := ifATI2N;
- end;
- end
- else if (Flags and DDPF_RGB) = DDPF_RGB then
- begin
- // Handle RGB formats
- if (Flags and DDPF_ALPHAPIXELS) = DDPF_ALPHAPIXELS then
- begin
- // Handle RGB with alpha formats
- case BitCount of
- 16:
- begin
- if MasksEqual(Desc.PixelFormat,
- GetFormatInfo(ifA4R4G4B4).PixelFormat) then
- SrcFormat := ifA4R4G4B4;
- if MasksEqual(Desc.PixelFormat,
- GetFormatInfo(ifA1R5G5B5).PixelFormat) then
- SrcFormat := ifA1R5G5B5;
- end;
- 32:
- begin
- SrcFormat := ifA8R8G8B8;
- if BlueMask = $00FF0000 then
- NeedsSwapChannels := True;
- end;
- end;
- end
- else
- begin
- // Handle RGB without alpha formats
- case BitCount of
- 8:
- if MasksEqual(Desc.PixelFormat,
- GetFormatInfo(ifR3G3B2).PixelFormat) then
- SrcFormat := ifR3G3B2;
- 16:
- begin
- if MasksEqual(Desc.PixelFormat,
- GetFormatInfo(ifX4R4G4B4).PixelFormat) then
- SrcFormat := ifX4R4G4B4;
- if MasksEqual(Desc.PixelFormat,
- GetFormatInfo(ifX1R5G5B5).PixelFormat) then
- SrcFormat := ifX1R5G5B5;
- if MasksEqual(Desc.PixelFormat,
- GetFormatInfo(ifR5G6B5).PixelFormat) then
- SrcFormat := ifR5G6B5;
- end;
- 24: SrcFormat := ifR8G8B8;
- 32:
- begin
- SrcFormat := ifX8R8G8B8;
- if BlueMask = $00FF0000 then
- NeedsSwapChannels := True;
- end;
- end;
- end;
- end
- else if (Flags and DDPF_LUMINANCE) = DDPF_LUMINANCE then
- begin
- // Handle luminance formats
- if (Flags and DDPF_ALPHAPIXELS) = DDPF_ALPHAPIXELS then
- begin
- // Handle luminance with alpha formats
- if BitCount = 16 then
- SrcFormat := ifA8Gray8;
- end
- else
- begin
- // Handle luminance without alpha formats
- case BitCount of
- 8: SrcFormat := ifGray8;
- 16: SrcFormat := ifGray16;
- end;
- end;
- end
- else if (Flags and DDPF_BUMPLUMINANCE) = DDPF_BUMPLUMINANCE then
- begin
- // Handle mixed bump-luminance formats like D3DFMT_X8L8V8U8
- case BitCount of
- 32:
- if BlueMask = $00FF0000 then
- begin
- SrcFormat := ifX8R8G8B8; // D3DFMT_X8L8V8U8
- NeedsSwapChannels := True;
- end;
- end;
- end
- else if (Flags and DDPF_BUMPDUDV) = DDPF_BUMPDUDV then
- begin
- // Handle bumpmap formats like D3DFMT_Q8W8V8U8
- case BitCount of
- 16: SrcFormat := ifA8Gray8; // D3DFMT_V8U8
- 32:
- if AlphaMask = $FF000000 then
- begin
- SrcFormat := ifA8R8G8B8; // D3DFMT_Q8W8V8U8
- NeedsSwapChannels := True;
- end;
- 64: SrcFormat := ifA16B16G16R16; // D3DFMT_Q16W16V16U16
- end;
- end;
-
- // If DDS format is not supported we will exit
- if SrcFormat = ifUnknown then Exit;
-
- // File contains mipmaps for each subimage.
- { Some DDS writers ignore setting proper Caps and Flags so
- this check is not usable:
- if ((Desc.Caps.Caps1 and DDSCAPS_MIPMAP) = DDSCAPS_MIPMAP) and
- ((Desc.Flags and DDSD_MIPMAPCOUNT) = DDSD_MIPMAPCOUNT) then}
- if Desc.MipMaps > 1 then
- begin
- FLoadedMipMapCount := Desc.MipMaps;
- ImageCount := Desc.MipMaps;
- end;
-
- // File stores volume texture
- if ((Desc.Caps.Caps2 and DDSCAPS2_VOLUME) = DDSCAPS2_VOLUME) and
- ((Desc.Flags and DDSD_DEPTH) = DDSD_DEPTH) then
- begin
- FLoadedVolume := True;
- FLoadedDepth := Desc.Depth;
- ImageCount := GetVolumeLevelCount(Desc.Depth, ImageCount);
- end;
-
- // File stores cube texture
- if (Desc.Caps.Caps2 and DDSCAPS2_CUBEMAP) = DDSCAPS2_CUBEMAP then
- begin
- FLoadedCubeMap := True;
- I := 0;
- if (Desc.Caps.Caps2 and DDSCAPS2_POSITIVEX) = DDSCAPS2_POSITIVEX then Inc(I);
- if (Desc.Caps.Caps2 and DDSCAPS2_POSITIVEY) = DDSCAPS2_POSITIVEY then Inc(I);
- if (Desc.Caps.Caps2 and DDSCAPS2_POSITIVEZ) = DDSCAPS2_POSITIVEZ then Inc(I);
- if (Desc.Caps.Caps2 and DDSCAPS2_NEGATIVEX) = DDSCAPS2_NEGATIVEX then Inc(I);
- if (Desc.Caps.Caps2 and DDSCAPS2_NEGATIVEY) = DDSCAPS2_NEGATIVEY then Inc(I);
- if (Desc.Caps.Caps2 and DDSCAPS2_NEGATIVEZ) = DDSCAPS2_NEGATIVEZ then Inc(I);
- FLoadedDepth := I;
- ImageCount := ImageCount * I;
- end;
-
- // Allocate and load all images in file
- FmtInfo := GetFormatInfo(SrcFormat);
- SetLength(Images, ImageCount);
-
- // Compute the pitch or get if from file if present
- UseAsPitch := (Desc.Flags and DDSD_PITCH) = DDSD_PITCH;
- UseAsLinear := (Desc.Flags and DDSD_LINEARSIZE) = DDSD_LINEARSIZE;
- // Use linear as default if none is set
- if not UseAsPitch and not UseAsLinear then
- UseAsLinear := True;
- // Main image pitch or linear size
- PitchOrLinear := Desc.PitchOrLinearSize;
-
- for I := 0 to ImageCount - 1 do
- begin
- // Compute dimensions of surrent subimage based on texture type and
- // number of mipmaps
- ComputeSubDimensions(I, Desc.Width, Desc.Height, Desc.MipMaps, Desc.Depth,
- FloadedCubeMap, FLoadedVolume, CurrentWidth, CurrentHeight);
- NewImage(CurrentWidth, CurrentHeight, SrcFormat, Images[I]);
-
- if (I > 0) or (PitchOrLinear = 0) then
- begin
- // Compute pitch or linear size for mipmap levels, or even for main image
- // since some formats do not fill pitch nor size
- if UseAsLinear then
- PitchOrLinear := FmtInfo.GetPixelsSize(SrcFormat, CurrentWidth, CurrentHeight)
- else
- PitchOrLinear := (CurrentWidth * FmtInfo.BytesPerPixel + 3) div 4 * 4; // must be DWORD aligned
- end;
-
- if UseAsLinear then
- LoadSize := PitchOrLinear
- else
- LoadSize := CurrentHeight * PitchOrLinear;
-
- if UseAsLinear or (LoadSize = Images[I].Size) then
- begin
- // If DDS does not use Pitch we can simply copy data
- Read(Handle, Images[I].Bits, LoadSize)
- end
- else
- begin
- // If DDS uses Pitch we must load aligned scanlines
- // and then remove padding
- GetMem(Data, LoadSize);
- try
- Read(Handle, Data, LoadSize);
- RemovePadBytes(Data, Images[I].Bits, CurrentWidth, CurrentHeight,
- FmtInfo.BytesPerPixel, PitchOrLinear);
- finally
- FreeMem(Data);
- end;
- end;
-
- if NeedsSwapChannels then
- SwapChannels(Images[I], ChannelRed, ChannelBlue);
- end;
- Result := True;
- end;
-end;
-
-function TDDSFileFormat.SaveData(Handle: TImagingHandle;
- const Images: TDynImageDataArray; Index: LongInt): Boolean;
-var
- Hdr: TDDSFileHeader;
- MainImage, ImageToSave: TImageData;
- I, MainIdx, Len, ImageCount: LongInt;
- J: LongWord;
- FmtInfo: TImageFormatInfo;
- MustBeFreed: Boolean;
- Is2DTexture, IsCubeMap, IsVolume: Boolean;
- MipMapCount, CurrentWidth, CurrentHeight: LongInt;
- NeedsResize: Boolean;
- NeedsConvert: Boolean;
-begin
- Result := False;
- FillChar(Hdr, Sizeof(Hdr), 0);
-
- MainIdx := FFirstIdx;
- Len := FLastIdx - MainIdx + 1;
- // Some DDS saving rules:
- // 2D textures: Len is used as mipmap count (FSaveMipMapCount not used!).
- // Cube maps: FSaveDepth * FSaveMipMapCount images are used, if Len is
- // smaller than this file is saved as regular 2D texture.
- // Volume maps: GetVolumeLevelCount(FSaveDepth, FSaveMipMapCount) images are
- // used, if Len is smaller than this file is
- // saved as regular 2D texture.
-
- IsCubeMap := FSaveCubeMap;
- IsVolume := FSaveVolume;
- MipMapCount := FSaveMipMapCount;
-
- if IsCubeMap then
- begin
- // Check if we have enough images on Input to save cube map
- if Len < FSaveDepth * FSaveMipMapCount then
- IsCubeMap := False;
- end
- else if IsVolume then
- begin
- // Check if we have enough images on Input to save volume texture
- if Len < GetVolumeLevelCount(FSaveDepth, FSaveMipMapCount) then
- IsVolume := False;
- end;
-
- Is2DTexture := not IsCubeMap and not IsVolume;
- if Is2DTexture then
- begin
- // Get number of mipmaps used with 2D texture
- MipMapCount := Min(Len, GetNumMipMapLevels(Images[MainIdx].Width, Images[MainIdx].Height));
- end;
-
- // we create compatible main image and fill headers
- if MakeCompatible(Images[MainIdx], MainImage, MustBeFreed) then
- with GetIO, MainImage, Hdr do
- try
- FmtInfo := GetFormatInfo(Format);
- Magic := DDSMagic;
- Desc.Size := SizeOf(Desc);
- Desc.Width := Width;
- Desc.Height := Height;
- Desc.Flags := DDS_SAVE_FLAGS;
- Desc.Caps.Caps1 := DDSCAPS_TEXTURE;
- Desc.PixelFormat.Size := SizeOf(Desc.PixelFormat);
- Desc.PitchOrLinearSize := MainImage.Size;
- ImageCount := MipMapCount;
-
- if MipMapCount > 1 then
- begin
- // Set proper flags if we have some mipmaps to be saved
- Desc.Flags := Desc.Flags or DDSD_MIPMAPCOUNT;
- Desc.Caps.Caps1 := Desc.Caps.Caps1 or DDSCAPS_MIPMAP or DDSCAPS_COMPLEX;
- Desc.MipMaps := MipMapCount;
- end;
-
- if IsCubeMap then
- begin
- // Set proper cube map flags - number of stored faces is taken
- // from FSaveDepth
- Desc.Caps.Caps1 := Desc.Caps.Caps1 or DDSCAPS_COMPLEX;
- Desc.Caps.Caps2 := Desc.Caps.Caps2 or DDSCAPS2_CUBEMAP;
- J := DDSCAPS2_POSITIVEX;
- for I := 0 to FSaveDepth - 1 do
- begin
- Desc.Caps.Caps2 := Desc.Caps.Caps2 or J;
- J := J shl 1;
- end;
- ImageCount := FSaveDepth * FSaveMipMapCount;
- end
- else if IsVolume then
- begin
- // Set proper flags for volume texture
- Desc.Flags := Desc.Flags or DDSD_DEPTH;
- Desc.Caps.Caps1 := Desc.Caps.Caps1 or DDSCAPS_COMPLEX;
- Desc.Caps.Caps2 := Desc.Caps.Caps2 or DDSCAPS2_VOLUME;
- Desc.Depth := FSaveDepth;
- ImageCount := GetVolumeLevelCount(FSaveDepth, FSaveMipMapCount);
- end;
-
- // Now we set DDS pixel format for main image
- if FmtInfo.IsSpecial or FmtInfo.IsFloatingPoint or
- (FmtInfo.BytesPerPixel > 4) then
- begin
- Desc.PixelFormat.Flags := DDPF_FOURCC;
- case Format of
- ifA16B16G16R16: Desc.PixelFormat.FourCC := D3DFMT_A16B16G16R16;
- ifR32F: Desc.PixelFormat.FourCC := D3DFMT_R32F;
- ifA32B32G32R32F: Desc.PixelFormat.FourCC := D3DFMT_A32B32G32R32F;
- ifR16F: Desc.PixelFormat.FourCC := D3DFMT_R16F;
- ifA16B16G16R16F: Desc.PixelFormat.FourCC := D3DFMT_A16B16G16R16F;
- ifDXT1: Desc.PixelFormat.FourCC := FOURCC_DXT1;
- ifDXT3: Desc.PixelFormat.FourCC := FOURCC_DXT3;
- ifDXT5: Desc.PixelFormat.FourCC := FOURCC_DXT5;
- ifATI1N: Desc.PixelFormat.FourCC := FOURCC_ATI1;
- ifATI2N: Desc.PixelFormat.FourCC := FOURCC_ATI2;
- end;
- end
- else if FmtInfo.HasGrayChannel then
- begin
- Desc.PixelFormat.Flags := DDPF_LUMINANCE;
- Desc.PixelFormat.BitCount := FmtInfo.BytesPerPixel * 8;
- case Format of
- ifGray8: Desc.PixelFormat.RedMask := 255;
- ifGray16: Desc.PixelFormat.RedMask := 65535;
- ifA8Gray8:
- begin
- Desc.PixelFormat.Flags := Desc.PixelFormat.Flags or DDPF_ALPHAPIXELS;
- Desc.PixelFormat.RedMask := 255;
- Desc.PixelFormat.AlphaMask := 65280;
- end;
- end;
- end
- else
- begin
- Desc.PixelFormat.Flags := DDPF_RGB;
- Desc.PixelFormat.BitCount := FmtInfo.BytesPerPixel * 8;
- if FmtInfo.HasAlphaChannel then
- begin
- Desc.PixelFormat.Flags := Desc.PixelFormat.Flags or DDPF_ALPHAPIXELS;
- Desc.PixelFormat.AlphaMask := $FF000000;
- end;
- if FmtInfo.BytesPerPixel > 2 then
- begin
- Desc.PixelFormat.RedMask := $00FF0000;
- Desc.PixelFormat.GreenMask := $0000FF00;
- Desc.PixelFormat.BlueMask := $000000FF;
- end
- else
- begin
- Desc.PixelFormat.AlphaMask := FmtInfo.PixelFormat.ABitMask;
- Desc.PixelFormat.RedMask := FmtInfo.PixelFormat.RBitMask;
- Desc.PixelFormat.GreenMask := FmtInfo.PixelFormat.GBitMask;
- Desc.PixelFormat.BlueMask := FmtInfo.PixelFormat.BBitMask;
- end;
- end;
-
- // Header and main image are written to output
- Write(Handle, @Hdr, SizeOf(Hdr));
- Write(Handle, MainImage.Bits, MainImage.Size);
-
- // Write the rest of the images and convert them to
- // the same format as main image if necessary and ensure proper mipmap
- // simensions too.
- for I := MainIdx + 1 to MainIdx + ImageCount - 1 do
- begin
- // Get proper dimensions for this level
- ComputeSubDimensions(I, Desc.Width, Desc.Height, Desc.MipMaps, Desc.Depth,
- IsCubeMap, IsVolume, CurrentWidth, CurrentHeight);
-
- // Check if input image for this level has the right size and format
- NeedsResize := not ((Images[I].Width = CurrentWidth) and (Images[I].Height = CurrentHeight));
- NeedsConvert := not (Images[I].Format = Format);
-
- if NeedsResize or NeedsConvert then
- begin
- // Input image must be resized or converted to different format
- // to become valid mipmap level
- InitImage(ImageToSave);
- CloneImage(Images[I], ImageToSave);
- if NeedsConvert then
- ConvertImage(ImageToSave, Format);
- if NeedsResize then
- ResizeImage(ImageToSave, CurrentWidth, CurrentHeight, rfBilinear);
- end
- else
- // Input image can be used without any changes
- ImageToSave := Images[I];
-
- // Write level data and release temp image if necessary
- Write(Handle, ImageToSave.Bits, ImageToSave.Size);
- if Images[I].Bits <> ImageToSave.Bits then
- FreeImage(ImageToSave);
- end;
-
- Result := True;
- finally
- if MustBeFreed then
- FreeImage(MainImage);
- end;
-end;
-
-procedure TDDSFileFormat.ConvertToSupported(var Image: TImageData;
- const Info: TImageFormatInfo);
-var
- ConvFormat: TImageFormat;
-begin
- if Info.IsIndexed or Info.IsSpecial then
- // convert indexed and unsupported special formatd to A8R8G8B8
- ConvFormat := ifA8R8G8B8
- else if Info.IsFloatingPoint then
- begin
- if Info.Format = ifA16R16G16B16F then
- // only swap channels here
- ConvFormat := ifA16B16G16R16F
- else
- // convert other floating point formats to A32B32G32R32F
- ConvFormat := ifA32B32G32R32F
- end
- else if Info.HasGrayChannel then
- begin
- if Info.HasAlphaChannel then
- // convert grayscale with alpha to A8Gray8
- ConvFormat := ifA8Gray8
- else if Info.BytesPerPixel = 1 then
- // convert 8bit grayscale to Gray8
- ConvFormat := ifGray8
- else
- // convert 16-64bit grayscales to Gray16
- ConvFormat := ifGray16;
- end
- else if Info.BytesPerPixel > 4 then
- ConvFormat := ifA16B16G16R16
- else if Info.HasAlphaChannel then
- // convert the other images with alpha channel to A8R8G8B8
- ConvFormat := ifA8R8G8B8
- else
- // convert the other formats to X8R8G8B8
- ConvFormat := ifX8R8G8B8;
-
- ConvertImage(Image, ConvFormat);
-end;
-
-function TDDSFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
-var
- Hdr: TDDSFileHeader;
- ReadCount: LongInt;
-begin
- Result := False;
- if Handle <> nil then
- with GetIO do
- begin
- ReadCount := Read(Handle, @Hdr, SizeOf(Hdr));
- Seek(Handle, -ReadCount, smFromCurrent);
- Result := (Hdr.Magic = DDSMagic) and (ReadCount = SizeOf(Hdr)) and
- ((Hdr.Desc.Caps.Caps1 and DDSCAPS_TEXTURE) = DDSCAPS_TEXTURE);
- end;
-end;
-
-initialization
- RegisterImageFileFormat(TDDSFileFormat);
-
-{
- File Notes:
-
- -- TODOS ----------------------------------------------------
- - nothing now
-
- -- 0.25.0 Changes/Bug Fixes ---------------------------------
- - Added support for 3Dc ATI1/2 formats.
-
- -- 0.23 Changes/Bug Fixes -----------------------------------
- - Saved DDS with mipmaps now correctly defineds COMPLEX flag.
- - Fixed loading of RGB DDS files that use pitch and have mipmaps -
- mipmaps were loaded wrongly.
-
- -- 0.21 Changes/Bug Fixes -----------------------------------
- - Changed saving behaviour a bit: mipmaps are inlcuded automatically for
- 2D textures if input image array has more than 1 image (no need to
- set SaveMipMapCount manually).
- - Mipmap levels are now saved with proper dimensions when saving DDS files.
- - Made some changes to not be so strict when loading DDS files.
- Many programs seem to save them in non-standard format
- (by MS DDS File Reference).
- - Added missing ifX8R8G8B8 to SupportedFormats, MakeCompatible failed
- when image was converted to this format (inside).
- - MakeCompatible method moved to base class, put ConvertToSupported here.
- GetSupportedFormats removed, it is now set in constructor.
- - Fixed bug that sometimes saved non-standard DDS files and another
- one that caused crash when these files were loaded.
- - Changed extensions to filename masks.
- - Changed SaveData, LoadData, and MakeCompatible methods according
- to changes in base class in Imaging unit.
-
- -- 0.19 Changes/Bug Fixes -----------------------------------
- - added support for half-float image formats
- - change in LoadData to allow support for more images
- in one stream loading
-
- -- 0.17 Changes/Bug Fixes -----------------------------------
- - fixed bug in TestFormat which does not recognize many DDS files
- - changed pitch/linearsize handling in DDS loading code to
- load DDS files produced by NVidia's Photoshop plugin
-}
-
-end.
-
+{
+ $Id: ImagingDds.pas 129 2008-08-06 20:01:30Z galfar $
+ Vampyre Imaging Library
+ by Marek Mauder
+ http://imaginglib.sourceforge.net
+
+ The contents of this file are used with permission, subject to the Mozilla
+ Public License Version 1.1 (the "License"); you may not use this file except
+ in compliance with the License. You may obtain a copy of the License at
+ http://www.mozilla.org/MPL/MPL-1.1.html
+
+ Software distributed under the License is distributed on an "AS IS" basis,
+ WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
+ the specific language governing rights and limitations under the License.
+
+ Alternatively, the contents of this file may be used under the terms of the
+ GNU Lesser General Public License (the "LGPL License"), in which case the
+ provisions of the LGPL License are applicable instead of those above.
+ If you wish to allow use of your version of this file only under the terms
+ of the LGPL License and not to allow others to use your version of this file
+ under the MPL, indicate your decision by deleting the provisions above and
+ replace them with the notice and other provisions required by the LGPL
+ License. If you do not delete the provisions above, a recipient may use
+ your version of this file under either the MPL or the LGPL License.
+
+ For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
+}
+
+{ This unit contains image format loader/saver for DirectDraw Surface images.}
+unit ImagingDds;
+
+{$I ImagingOptions.inc}
+
+interface
+
+uses
+ ImagingTypes, Imaging, ImagingUtility, ImagingFormats;
+
+type
+ { Class for loading and saving Microsoft DirectDraw surfaces.
+ It can load/save all D3D formats which have coresponding
+ TImageFormat. It supports plain textures, cube textures and
+ volume textures, all of these can have mipmaps. It can also
+ load some formats which have no exact TImageFormat, but can be easily
+ converted to one (bump map formats).
+ You can get some information about last loaded DDS file by calling
+ GetOption with ImagingDDSLoadedXXX options and you can set some
+ saving options by calling SetOption with ImagingDDSSaveXXX or you can
+ simply use properties of this class.
+ Note that when saving cube maps and volumes input image array must contain
+ at least number of images to build cube/volume based on current
+ Depth and MipMapCount settings.}
+ TDDSFileFormat = class(TImageFileFormat)
+ protected
+ FLoadedCubeMap: LongBool;
+ FLoadedVolume: LongBool;
+ FLoadedMipMapCount: LongInt;
+ FLoadedDepth: LongInt;
+ FSaveCubeMap: LongBool;
+ FSaveVolume: LongBool;
+ FSaveMipMapCount: LongInt;
+ FSaveDepth: LongInt;
+ procedure ComputeSubDimensions(Idx, Width, Height, MipMaps, Depth: LongInt;
+ IsCubeMap, IsVolume: Boolean; var CurWidth, CurHeight: LongInt);
+ function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
+ OnlyFirstLevel: Boolean): Boolean; override;
+ function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
+ Index: LongInt): Boolean; override;
+ procedure ConvertToSupported(var Image: TImageData;
+ const Info: TImageFormatInfo); override;
+ public
+ constructor Create; override;
+ function TestFormat(Handle: TImagingHandle): Boolean; override;
+ procedure CheckOptionsValidity; override;
+ published
+ { True if last loaded DDS file was cube map.}
+ property LoadedCubeMap: LongBool read FLoadedCubeMap write FLoadedCubeMap;
+ { True if last loaded DDS file was volume texture.}
+ property LoadedVolume: LongBool read FLoadedVolume write FLoadedVolume;
+ { Number of mipmap levels of last loaded DDS image.}
+ property LoadedMipMapCount: LongInt read FLoadedMipMapCount write FLoadedMipMapCount;
+ { Depth (slices of volume texture or faces of cube map) of last loaded DDS image.}
+ property LoadedDepth: LongInt read FLoadedDepth write FLoadedDepth;
+ { True if next DDS file to be saved should be stored as cube map.}
+ property SaveCubeMap: LongBool read FSaveCubeMap write FSaveCubeMap;
+ { True if next DDS file to be saved should be stored as volume texture.}
+ property SaveVolume: LongBool read FSaveVolume write FSaveVolume;
+ { Sets the number of mipmaps which should be stored in the next saved DDS file.
+ Only applies to cube maps and volumes, ordinary 2D textures save all
+ levels present in input.}
+ property SaveMipMapCount: LongInt read FSaveMipMapCount write FSaveMipMapCount;
+ { Sets the depth (slices of volume texture or faces of cube map)
+ of the next saved DDS file.}
+ property SaveDepth: LongInt read FSaveDepth write FSaveDepth;
+ end;
+
+implementation
+
+const
+ SDDSFormatName = 'DirectDraw Surface';
+ SDDSMasks = '*.dds';
+ DDSSupportedFormats: TImageFormats = [ifR8G8B8, ifA8R8G8B8, ifX8R8G8B8,
+ ifA1R5G5B5, ifA4R4G4B4, ifX1R5G5B5, ifX4R4G4B4, ifR5G6B5, ifA16B16G16R16,
+ ifR32F, ifA32B32G32R32F, ifR16F, ifA16B16G16R16F, ifR3G3B2, ifGray8, ifA8Gray8,
+ ifGray16, ifDXT1, ifDXT3, ifDXT5, ifATI1N, ifATI2N];
+
+const
+ { Four character codes.}
+ DDSMagic = LongWord(Byte('D') or (Byte('D') shl 8) or (Byte('S') shl 16) or
+ (Byte(' ') shl 24));
+ FOURCC_DXT1 = LongWord(Byte('D') or (Byte('X') shl 8) or (Byte('T') shl 16) or
+ (Byte('1') shl 24));
+ FOURCC_DXT3 = LongWord(Byte('D') or (Byte('X') shl 8) or (Byte('T') shl 16) or
+ (Byte('3') shl 24));
+ FOURCC_DXT5 = LongWord(Byte('D') or (Byte('X') shl 8) or (Byte('T') shl 16) or
+ (Byte('5') shl 24));
+ FOURCC_ATI1 = LongWord(Byte('A') or (Byte('T') shl 8) or (Byte('I') shl 16) or
+ (Byte('1') shl 24));
+ FOURCC_ATI2 = LongWord(Byte('A') or (Byte('T') shl 8) or (Byte('I') shl 16) or
+ (Byte('2') shl 24));
+
+ { Some D3DFORMAT values used in DDS files as FourCC value.}
+ D3DFMT_A16B16G16R16 = 36;
+ D3DFMT_R32F = 114;
+ D3DFMT_A32B32G32R32F = 116;
+ D3DFMT_R16F = 111;
+ D3DFMT_A16B16G16R16F = 113;
+
+ { Constans used by TDDSurfaceDesc2.Flags.}
+ DDSD_CAPS = $00000001;
+ DDSD_HEIGHT = $00000002;
+ DDSD_WIDTH = $00000004;
+ DDSD_PITCH = $00000008;
+ DDSD_PIXELFORMAT = $00001000;
+ DDSD_MIPMAPCOUNT = $00020000;
+ DDSD_LINEARSIZE = $00080000;
+ DDSD_DEPTH = $00800000;
+
+ { Constans used by TDDSPixelFormat.Flags.}
+ DDPF_ALPHAPIXELS = $00000001; // used by formats which contain alpha
+ DDPF_FOURCC = $00000004; // used by DXT and large ARGB formats
+ DDPF_RGB = $00000040; // used by RGB formats
+ DDPF_LUMINANCE = $00020000; // used by formats like D3DFMT_L16
+ DDPF_BUMPLUMINANCE = $00040000; // used by mixed signed-unsigned formats
+ DDPF_BUMPDUDV = $00080000; // used by signed formats
+
+ { Constans used by TDDSCaps.Caps1.}
+ DDSCAPS_COMPLEX = $00000008;
+ DDSCAPS_TEXTURE = $00001000;
+ DDSCAPS_MIPMAP = $00400000;
+
+ { Constans used by TDDSCaps.Caps2.}
+ DDSCAPS2_CUBEMAP = $00000200;
+ DDSCAPS2_POSITIVEX = $00000400;
+ DDSCAPS2_NEGATIVEX = $00000800;
+ DDSCAPS2_POSITIVEY = $00001000;
+ DDSCAPS2_NEGATIVEY = $00002000;
+ DDSCAPS2_POSITIVEZ = $00004000;
+ DDSCAPS2_NEGATIVEZ = $00008000;
+ DDSCAPS2_VOLUME = $00200000;
+
+ { Flags for TDDSurfaceDesc2.Flags used when saving DDS file.}
+ DDS_SAVE_FLAGS = DDSD_CAPS or DDSD_PIXELFORMAT or DDSD_WIDTH or
+ DDSD_HEIGHT or DDSD_LINEARSIZE;
+
+type
+ { Stores the pixel format information.}
+ TDDPixelFormat = packed record
+ Size: LongWord; // Size of the structure = 32 bytes
+ Flags: LongWord; // Flags to indicate valid fields
+ FourCC: LongWord; // Four-char code for compressed textures (DXT)
+ BitCount: LongWord; // Bits per pixel if uncomp. usually 16,24 or 32
+ RedMask: LongWord; // Bit mask for the Red component
+ GreenMask: LongWord; // Bit mask for the Green component
+ BlueMask: LongWord; // Bit mask for the Blue component
+ AlphaMask: LongWord; // Bit mask for the Alpha component
+ end;
+
+ { Specifies capabilities of surface.}
+ TDDSCaps = packed record
+ Caps1: LongWord; // Should always include DDSCAPS_TEXTURE
+ Caps2: LongWord; // For cubic environment maps
+ Reserved: array[0..1] of LongWord; // Reserved
+ end;
+
+ { Record describing DDS file contents.}
+ TDDSurfaceDesc2 = packed record
+ Size: LongWord; // Size of the structure = 124 Bytes
+ Flags: LongWord; // Flags to indicate valid fields
+ Height: LongWord; // Height of the main image in pixels
+ Width: LongWord; // Width of the main image in pixels
+ PitchOrLinearSize: LongWord; // For uncomp formats number of bytes per
+ // scanline. For comp it is the size in
+ // bytes of the main image
+ Depth: LongWord; // Only for volume text depth of the volume
+ MipMaps: LongInt; // Total number of levels in the mipmap chain
+ Reserved1: array[0..10] of LongWord; // Reserved
+ PixelFormat: TDDPixelFormat; // Format of the pixel data
+ Caps: TDDSCaps; // Capabilities
+ Reserved2: LongWord; // Reserved
+ end;
+
+ { DDS file header.}
+ TDDSFileHeader = packed record
+ Magic: LongWord; // File format magic
+ Desc: TDDSurfaceDesc2; // Surface description
+ end;
+
+
+{ TDDSFileFormat class implementation }
+
+constructor TDDSFileFormat.Create;
+begin
+ inherited Create;
+ FName := SDDSFormatName;
+ FCanLoad := True;
+ FCanSave := True;
+ FIsMultiImageFormat := True;
+ FSupportedFormats := DDSSupportedFormats;
+
+ FSaveCubeMap := False;
+ FSaveVolume := False;
+ FSaveMipMapCount := 1;
+ FSaveDepth := 1;
+
+ AddMasks(SDDSMasks);
+
+ RegisterOption(ImagingDDSLoadedCubeMap, @FLoadedCubeMap);
+ RegisterOption(ImagingDDSLoadedVolume, @FLoadedVolume);
+ RegisterOption(ImagingDDSLoadedMipMapCount, @FLoadedMipMapCount);
+ RegisterOption(ImagingDDSLoadedDepth, @FLoadedDepth);
+ RegisterOption(ImagingDDSSaveCubeMap, @FSaveCubeMap);
+ RegisterOption(ImagingDDSSaveVolume, @FSaveVolume);
+ RegisterOption(ImagingDDSSaveMipMapCount, @FSaveMipMapCount);
+ RegisterOption(ImagingDDSSaveDepth, @FSaveDepth);
+end;
+
+procedure TDDSFileFormat.CheckOptionsValidity;
+begin
+ if FSaveCubeMap then
+ FSaveVolume := False;
+ if FSaveVolume then
+ FSaveCubeMap := False;
+ if FSaveDepth < 1 then
+ FSaveDepth := 1;
+ if FSaveMipMapCount < 1 then
+ FSaveMipMapCount := 1;
+end;
+
+procedure TDDSFileFormat.ComputeSubDimensions(Idx, Width, Height, MipMaps, Depth: LongInt;
+ IsCubeMap, IsVolume: Boolean; var CurWidth, CurHeight: LongInt);
+var
+ I, Last, Shift: LongInt;
+begin
+ CurWidth := Width;
+ CurHeight := Height;
+ if MipMaps > 1 then
+ begin
+ if not IsVolume then
+ begin
+ if IsCubeMap then
+ begin
+ // Cube maps are stored like this
+ // Face 0 mimap 0
+ // Face 0 mipmap 1
+ // ...
+ // Face 1 mipmap 0
+ // Face 1 mipmap 1
+ // ...
+
+ // Modify index so later in for loop we iterate less times
+ Idx := Idx - ((Idx div MipMaps) * MipMaps);
+ end;
+ for I := 0 to Idx - 1 do
+ begin
+ CurWidth := ClampInt(CurWidth shr 1, 1, CurWidth);
+ CurHeight := ClampInt(CurHeight shr 1, 1, CurHeight);
+ end;
+ end
+ else
+ begin
+ // Volume textures are stored in DDS files like this:
+ // Slice 0 mipmap 0
+ // Slice 1 mipmap 0
+ // Slice 2 mipmap 0
+ // Slice 3 mipmap 0
+ // Slice 0 mipmap 1
+ // Slice 1 mipmap 1
+ // Slice 0 mipmap 2
+ // Slice 0 mipmap 3 ...
+ Shift := 0;
+ Last := Depth;
+ while Idx > Last - 1 do
+ begin
+ CurWidth := ClampInt(CurWidth shr 1, 1, CurWidth);
+ CurHeight := ClampInt(CurHeight shr 1, 1, CurHeight);
+ if (CurWidth = 1) and (CurHeight = 1) then
+ Break;
+ Inc(Shift);
+ Inc(Last, ClampInt(Depth shr Shift, 1, Depth));
+ end;
+ end;
+ end;
+end;
+
+function TDDSFileFormat.LoadData(Handle: TImagingHandle;
+ var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
+var
+ Hdr: TDDSFileHeader;
+ SrcFormat: TImageFormat;
+ FmtInfo: TImageFormatInfo;
+ NeedsSwapChannels: Boolean;
+ CurrentWidth, CurrentHeight, ImageCount, LoadSize, I, PitchOrLinear: LongInt;
+ Data: PByte;
+ UseAsPitch: Boolean;
+ UseAsLinear: Boolean;
+
+ function MasksEqual(const DDPF: TDDPixelFormat; PF: PPixelFormatInfo): Boolean;
+ begin
+ Result := (DDPF.AlphaMask = PF.ABitMask) and
+ (DDPF.RedMask = PF.RBitMask) and (DDPF.GreenMask = PF.GBitMask) and
+ (DDPF.BlueMask = PF.BBitMask);
+ end;
+
+begin
+ Result := False;
+ ImageCount := 1;
+ FLoadedMipMapCount := 1;
+ FLoadedDepth := 1;
+ FLoadedVolume := False;
+ FLoadedCubeMap := False;
+
+ with GetIO, Hdr, Hdr.Desc.PixelFormat do
+ begin
+ Read(Handle, @Hdr, SizeOF(Hdr));
+ {
+ // Set position to the end of the header (for possible future versions
+ // ith larger header)
+ Seek(Handle, Hdr.Desc.Size + SizeOf(Hdr.Magic) - SizeOf(Hdr),
+ smFromCurrent);
+ }
+ SrcFormat := ifUnknown;
+ NeedsSwapChannels := False;
+ // Get image data format
+ if (Flags and DDPF_FOURCC) = DDPF_FOURCC then
+ begin
+ // Handle FourCC and large ARGB formats
+ case FourCC of
+ D3DFMT_A16B16G16R16: SrcFormat := ifA16B16G16R16;
+ D3DFMT_R32F: SrcFormat := ifR32F;
+ D3DFMT_A32B32G32R32F: SrcFormat := ifA32B32G32R32F;
+ D3DFMT_R16F: SrcFormat := ifR16F;
+ D3DFMT_A16B16G16R16F: SrcFormat := ifA16B16G16R16F;
+ FOURCC_DXT1: SrcFormat := ifDXT1;
+ FOURCC_DXT3: SrcFormat := ifDXT3;
+ FOURCC_DXT5: SrcFormat := ifDXT5;
+ FOURCC_ATI1: SrcFormat := ifATI1N;
+ FOURCC_ATI2: SrcFormat := ifATI2N;
+ end;
+ end
+ else if (Flags and DDPF_RGB) = DDPF_RGB then
+ begin
+ // Handle RGB formats
+ if (Flags and DDPF_ALPHAPIXELS) = DDPF_ALPHAPIXELS then
+ begin
+ // Handle RGB with alpha formats
+ case BitCount of
+ 16:
+ begin
+ if MasksEqual(Desc.PixelFormat,
+ GetFormatInfo(ifA4R4G4B4).PixelFormat) then
+ SrcFormat := ifA4R4G4B4;
+ if MasksEqual(Desc.PixelFormat,
+ GetFormatInfo(ifA1R5G5B5).PixelFormat) then
+ SrcFormat := ifA1R5G5B5;
+ end;
+ 32:
+ begin
+ SrcFormat := ifA8R8G8B8;
+ if BlueMask = $00FF0000 then
+ NeedsSwapChannels := True;
+ end;
+ end;
+ end
+ else
+ begin
+ // Handle RGB without alpha formats
+ case BitCount of
+ 8:
+ if MasksEqual(Desc.PixelFormat,
+ GetFormatInfo(ifR3G3B2).PixelFormat) then
+ SrcFormat := ifR3G3B2;
+ 16:
+ begin
+ if MasksEqual(Desc.PixelFormat,
+ GetFormatInfo(ifX4R4G4B4).PixelFormat) then
+ SrcFormat := ifX4R4G4B4;
+ if MasksEqual(Desc.PixelFormat,
+ GetFormatInfo(ifX1R5G5B5).PixelFormat) then
+ SrcFormat := ifX1R5G5B5;
+ if MasksEqual(Desc.PixelFormat,
+ GetFormatInfo(ifR5G6B5).PixelFormat) then
+ SrcFormat := ifR5G6B5;
+ end;
+ 24: SrcFormat := ifR8G8B8;
+ 32:
+ begin
+ SrcFormat := ifX8R8G8B8;
+ if BlueMask = $00FF0000 then
+ NeedsSwapChannels := True;
+ end;
+ end;
+ end;
+ end
+ else if (Flags and DDPF_LUMINANCE) = DDPF_LUMINANCE then
+ begin
+ // Handle luminance formats
+ if (Flags and DDPF_ALPHAPIXELS) = DDPF_ALPHAPIXELS then
+ begin
+ // Handle luminance with alpha formats
+ if BitCount = 16 then
+ SrcFormat := ifA8Gray8;
+ end
+ else
+ begin
+ // Handle luminance without alpha formats
+ case BitCount of
+ 8: SrcFormat := ifGray8;
+ 16: SrcFormat := ifGray16;
+ end;
+ end;
+ end
+ else if (Flags and DDPF_BUMPLUMINANCE) = DDPF_BUMPLUMINANCE then
+ begin
+ // Handle mixed bump-luminance formats like D3DFMT_X8L8V8U8
+ case BitCount of
+ 32:
+ if BlueMask = $00FF0000 then
+ begin
+ SrcFormat := ifX8R8G8B8; // D3DFMT_X8L8V8U8
+ NeedsSwapChannels := True;
+ end;
+ end;
+ end
+ else if (Flags and DDPF_BUMPDUDV) = DDPF_BUMPDUDV then
+ begin
+ // Handle bumpmap formats like D3DFMT_Q8W8V8U8
+ case BitCount of
+ 16: SrcFormat := ifA8Gray8; // D3DFMT_V8U8
+ 32:
+ if AlphaMask = $FF000000 then
+ begin
+ SrcFormat := ifA8R8G8B8; // D3DFMT_Q8W8V8U8
+ NeedsSwapChannels := True;
+ end;
+ 64: SrcFormat := ifA16B16G16R16; // D3DFMT_Q16W16V16U16
+ end;
+ end;
+
+ // If DDS format is not supported we will exit
+ if SrcFormat = ifUnknown then Exit;
+
+ // File contains mipmaps for each subimage.
+ { Some DDS writers ignore setting proper Caps and Flags so
+ this check is not usable:
+ if ((Desc.Caps.Caps1 and DDSCAPS_MIPMAP) = DDSCAPS_MIPMAP) and
+ ((Desc.Flags and DDSD_MIPMAPCOUNT) = DDSD_MIPMAPCOUNT) then}
+ if Desc.MipMaps > 1 then
+ begin
+ FLoadedMipMapCount := Desc.MipMaps;
+ ImageCount := Desc.MipMaps;
+ end;
+
+ // File stores volume texture
+ if ((Desc.Caps.Caps2 and DDSCAPS2_VOLUME) = DDSCAPS2_VOLUME) and
+ ((Desc.Flags and DDSD_DEPTH) = DDSD_DEPTH) then
+ begin
+ FLoadedVolume := True;
+ FLoadedDepth := Desc.Depth;
+ ImageCount := GetVolumeLevelCount(Desc.Depth, ImageCount);
+ end;
+
+ // File stores cube texture
+ if (Desc.Caps.Caps2 and DDSCAPS2_CUBEMAP) = DDSCAPS2_CUBEMAP then
+ begin
+ FLoadedCubeMap := True;
+ I := 0;
+ if (Desc.Caps.Caps2 and DDSCAPS2_POSITIVEX) = DDSCAPS2_POSITIVEX then Inc(I);
+ if (Desc.Caps.Caps2 and DDSCAPS2_POSITIVEY) = DDSCAPS2_POSITIVEY then Inc(I);
+ if (Desc.Caps.Caps2 and DDSCAPS2_POSITIVEZ) = DDSCAPS2_POSITIVEZ then Inc(I);
+ if (Desc.Caps.Caps2 and DDSCAPS2_NEGATIVEX) = DDSCAPS2_NEGATIVEX then Inc(I);
+ if (Desc.Caps.Caps2 and DDSCAPS2_NEGATIVEY) = DDSCAPS2_NEGATIVEY then Inc(I);
+ if (Desc.Caps.Caps2 and DDSCAPS2_NEGATIVEZ) = DDSCAPS2_NEGATIVEZ then Inc(I);
+ FLoadedDepth := I;
+ ImageCount := ImageCount * I;
+ end;
+
+ // Allocate and load all images in file
+ FmtInfo := GetFormatInfo(SrcFormat);
+ SetLength(Images, ImageCount);
+
+ // Compute the pitch or get if from file if present
+ UseAsPitch := (Desc.Flags and DDSD_PITCH) = DDSD_PITCH;
+ UseAsLinear := (Desc.Flags and DDSD_LINEARSIZE) = DDSD_LINEARSIZE;
+ // Use linear as default if none is set
+ if not UseAsPitch and not UseAsLinear then
+ UseAsLinear := True;
+ // Main image pitch or linear size
+ PitchOrLinear := Desc.PitchOrLinearSize;
+
+ for I := 0 to ImageCount - 1 do
+ begin
+ // Compute dimensions of surrent subimage based on texture type and
+ // number of mipmaps
+ ComputeSubDimensions(I, Desc.Width, Desc.Height, Desc.MipMaps, Desc.Depth,
+ FloadedCubeMap, FLoadedVolume, CurrentWidth, CurrentHeight);
+ NewImage(CurrentWidth, CurrentHeight, SrcFormat, Images[I]);
+
+ if (I > 0) or (PitchOrLinear = 0) then
+ begin
+ // Compute pitch or linear size for mipmap levels, or even for main image
+ // since some formats do not fill pitch nor size
+ if UseAsLinear then
+ PitchOrLinear := FmtInfo.GetPixelsSize(SrcFormat, CurrentWidth, CurrentHeight)
+ else
+ PitchOrLinear := (CurrentWidth * FmtInfo.BytesPerPixel + 3) div 4 * 4; // must be DWORD aligned
+ end;
+
+ if UseAsLinear then
+ LoadSize := PitchOrLinear
+ else
+ LoadSize := CurrentHeight * PitchOrLinear;
+
+ if UseAsLinear or (LoadSize = Images[I].Size) then
+ begin
+ // If DDS does not use Pitch we can simply copy data
+ Read(Handle, Images[I].Bits, LoadSize)
+ end
+ else
+ begin
+ // If DDS uses Pitch we must load aligned scanlines
+ // and then remove padding
+ GetMem(Data, LoadSize);
+ try
+ Read(Handle, Data, LoadSize);
+ RemovePadBytes(Data, Images[I].Bits, CurrentWidth, CurrentHeight,
+ FmtInfo.BytesPerPixel, PitchOrLinear);
+ finally
+ FreeMem(Data);
+ end;
+ end;
+
+ if NeedsSwapChannels then
+ SwapChannels(Images[I], ChannelRed, ChannelBlue);
+ end;
+ Result := True;
+ end;
+end;
+
+function TDDSFileFormat.SaveData(Handle: TImagingHandle;
+ const Images: TDynImageDataArray; Index: LongInt): Boolean;
+var
+ Hdr: TDDSFileHeader;
+ MainImage, ImageToSave: TImageData;
+ I, MainIdx, Len, ImageCount: LongInt;
+ J: LongWord;
+ FmtInfo: TImageFormatInfo;
+ MustBeFreed: Boolean;
+ Is2DTexture, IsCubeMap, IsVolume: Boolean;
+ MipMapCount, CurrentWidth, CurrentHeight: LongInt;
+ NeedsResize: Boolean;
+ NeedsConvert: Boolean;
+begin
+ Result := False;
+ FillChar(Hdr, Sizeof(Hdr), 0);
+
+ MainIdx := FFirstIdx;
+ Len := FLastIdx - MainIdx + 1;
+ // Some DDS saving rules:
+ // 2D textures: Len is used as mipmap count (FSaveMipMapCount not used!).
+ // Cube maps: FSaveDepth * FSaveMipMapCount images are used, if Len is
+ // smaller than this file is saved as regular 2D texture.
+ // Volume maps: GetVolumeLevelCount(FSaveDepth, FSaveMipMapCount) images are
+ // used, if Len is smaller than this file is
+ // saved as regular 2D texture.
+
+ IsCubeMap := FSaveCubeMap;
+ IsVolume := FSaveVolume;
+ MipMapCount := FSaveMipMapCount;
+
+ if IsCubeMap then
+ begin
+ // Check if we have enough images on Input to save cube map
+ if Len < FSaveDepth * FSaveMipMapCount then
+ IsCubeMap := False;
+ end
+ else if IsVolume then
+ begin
+ // Check if we have enough images on Input to save volume texture
+ if Len < GetVolumeLevelCount(FSaveDepth, FSaveMipMapCount) then
+ IsVolume := False;
+ end;
+
+ Is2DTexture := not IsCubeMap and not IsVolume;
+ if Is2DTexture then
+ begin
+ // Get number of mipmaps used with 2D texture
+ MipMapCount := Min(Len, GetNumMipMapLevels(Images[MainIdx].Width, Images[MainIdx].Height));
+ end;
+
+ // we create compatible main image and fill headers
+ if MakeCompatible(Images[MainIdx], MainImage, MustBeFreed) then
+ with GetIO, MainImage, Hdr do
+ try
+ FmtInfo := GetFormatInfo(Format);
+ Magic := DDSMagic;
+ Desc.Size := SizeOf(Desc);
+ Desc.Width := Width;
+ Desc.Height := Height;
+ Desc.Flags := DDS_SAVE_FLAGS;
+ Desc.Caps.Caps1 := DDSCAPS_TEXTURE;
+ Desc.PixelFormat.Size := SizeOf(Desc.PixelFormat);
+ Desc.PitchOrLinearSize := MainImage.Size;
+ ImageCount := MipMapCount;
+
+ if MipMapCount > 1 then
+ begin
+ // Set proper flags if we have some mipmaps to be saved
+ Desc.Flags := Desc.Flags or DDSD_MIPMAPCOUNT;
+ Desc.Caps.Caps1 := Desc.Caps.Caps1 or DDSCAPS_MIPMAP or DDSCAPS_COMPLEX;
+ Desc.MipMaps := MipMapCount;
+ end;
+
+ if IsCubeMap then
+ begin
+ // Set proper cube map flags - number of stored faces is taken
+ // from FSaveDepth
+ Desc.Caps.Caps1 := Desc.Caps.Caps1 or DDSCAPS_COMPLEX;
+ Desc.Caps.Caps2 := Desc.Caps.Caps2 or DDSCAPS2_CUBEMAP;
+ J := DDSCAPS2_POSITIVEX;
+ for I := 0 to FSaveDepth - 1 do
+ begin
+ Desc.Caps.Caps2 := Desc.Caps.Caps2 or J;
+ J := J shl 1;
+ end;
+ ImageCount := FSaveDepth * FSaveMipMapCount;
+ end
+ else if IsVolume then
+ begin
+ // Set proper flags for volume texture
+ Desc.Flags := Desc.Flags or DDSD_DEPTH;
+ Desc.Caps.Caps1 := Desc.Caps.Caps1 or DDSCAPS_COMPLEX;
+ Desc.Caps.Caps2 := Desc.Caps.Caps2 or DDSCAPS2_VOLUME;
+ Desc.Depth := FSaveDepth;
+ ImageCount := GetVolumeLevelCount(FSaveDepth, FSaveMipMapCount);
+ end;
+
+ // Now we set DDS pixel format for main image
+ if FmtInfo.IsSpecial or FmtInfo.IsFloatingPoint or
+ (FmtInfo.BytesPerPixel > 4) then
+ begin
+ Desc.PixelFormat.Flags := DDPF_FOURCC;
+ case Format of
+ ifA16B16G16R16: Desc.PixelFormat.FourCC := D3DFMT_A16B16G16R16;
+ ifR32F: Desc.PixelFormat.FourCC := D3DFMT_R32F;
+ ifA32B32G32R32F: Desc.PixelFormat.FourCC := D3DFMT_A32B32G32R32F;
+ ifR16F: Desc.PixelFormat.FourCC := D3DFMT_R16F;
+ ifA16B16G16R16F: Desc.PixelFormat.FourCC := D3DFMT_A16B16G16R16F;
+ ifDXT1: Desc.PixelFormat.FourCC := FOURCC_DXT1;
+ ifDXT3: Desc.PixelFormat.FourCC := FOURCC_DXT3;
+ ifDXT5: Desc.PixelFormat.FourCC := FOURCC_DXT5;
+ ifATI1N: Desc.PixelFormat.FourCC := FOURCC_ATI1;
+ ifATI2N: Desc.PixelFormat.FourCC := FOURCC_ATI2;
+ end;
+ end
+ else if FmtInfo.HasGrayChannel then
+ begin
+ Desc.PixelFormat.Flags := DDPF_LUMINANCE;
+ Desc.PixelFormat.BitCount := FmtInfo.BytesPerPixel * 8;
+ case Format of
+ ifGray8: Desc.PixelFormat.RedMask := 255;
+ ifGray16: Desc.PixelFormat.RedMask := 65535;
+ ifA8Gray8:
+ begin
+ Desc.PixelFormat.Flags := Desc.PixelFormat.Flags or DDPF_ALPHAPIXELS;
+ Desc.PixelFormat.RedMask := 255;
+ Desc.PixelFormat.AlphaMask := 65280;
+ end;
+ end;
+ end
+ else
+ begin
+ Desc.PixelFormat.Flags := DDPF_RGB;
+ Desc.PixelFormat.BitCount := FmtInfo.BytesPerPixel * 8;
+ if FmtInfo.HasAlphaChannel then
+ begin
+ Desc.PixelFormat.Flags := Desc.PixelFormat.Flags or DDPF_ALPHAPIXELS;
+ Desc.PixelFormat.AlphaMask := $FF000000;
+ end;
+ if FmtInfo.BytesPerPixel > 2 then
+ begin
+ Desc.PixelFormat.RedMask := $00FF0000;
+ Desc.PixelFormat.GreenMask := $0000FF00;
+ Desc.PixelFormat.BlueMask := $000000FF;
+ end
+ else
+ begin
+ Desc.PixelFormat.AlphaMask := FmtInfo.PixelFormat.ABitMask;
+ Desc.PixelFormat.RedMask := FmtInfo.PixelFormat.RBitMask;
+ Desc.PixelFormat.GreenMask := FmtInfo.PixelFormat.GBitMask;
+ Desc.PixelFormat.BlueMask := FmtInfo.PixelFormat.BBitMask;
+ end;
+ end;
+
+ // Header and main image are written to output
+ Write(Handle, @Hdr, SizeOf(Hdr));
+ Write(Handle, MainImage.Bits, MainImage.Size);
+
+ // Write the rest of the images and convert them to
+ // the same format as main image if necessary and ensure proper mipmap
+ // simensions too.
+ for I := MainIdx + 1 to MainIdx + ImageCount - 1 do
+ begin
+ // Get proper dimensions for this level
+ ComputeSubDimensions(I, Desc.Width, Desc.Height, Desc.MipMaps, Desc.Depth,
+ IsCubeMap, IsVolume, CurrentWidth, CurrentHeight);
+
+ // Check if input image for this level has the right size and format
+ NeedsResize := not ((Images[I].Width = CurrentWidth) and (Images[I].Height = CurrentHeight));
+ NeedsConvert := not (Images[I].Format = Format);
+
+ if NeedsResize or NeedsConvert then
+ begin
+ // Input image must be resized or converted to different format
+ // to become valid mipmap level
+ InitImage(ImageToSave);
+ CloneImage(Images[I], ImageToSave);
+ if NeedsConvert then
+ ConvertImage(ImageToSave, Format);
+ if NeedsResize then
+ ResizeImage(ImageToSave, CurrentWidth, CurrentHeight, rfBilinear);
+ end
+ else
+ // Input image can be used without any changes
+ ImageToSave := Images[I];
+
+ // Write level data and release temp image if necessary
+ Write(Handle, ImageToSave.Bits, ImageToSave.Size);
+ if Images[I].Bits <> ImageToSave.Bits then
+ FreeImage(ImageToSave);
+ end;
+
+ Result := True;
+ finally
+ if MustBeFreed then
+ FreeImage(MainImage);
+ end;
+end;
+
+procedure TDDSFileFormat.ConvertToSupported(var Image: TImageData;
+ const Info: TImageFormatInfo);
+var
+ ConvFormat: TImageFormat;
+begin
+ if Info.IsIndexed or Info.IsSpecial then
+ // convert indexed and unsupported special formatd to A8R8G8B8
+ ConvFormat := ifA8R8G8B8
+ else if Info.IsFloatingPoint then
+ begin
+ if Info.Format = ifA16R16G16B16F then
+ // only swap channels here
+ ConvFormat := ifA16B16G16R16F
+ else
+ // convert other floating point formats to A32B32G32R32F
+ ConvFormat := ifA32B32G32R32F
+ end
+ else if Info.HasGrayChannel then
+ begin
+ if Info.HasAlphaChannel then
+ // convert grayscale with alpha to A8Gray8
+ ConvFormat := ifA8Gray8
+ else if Info.BytesPerPixel = 1 then
+ // convert 8bit grayscale to Gray8
+ ConvFormat := ifGray8
+ else
+ // convert 16-64bit grayscales to Gray16
+ ConvFormat := ifGray16;
+ end
+ else if Info.BytesPerPixel > 4 then
+ ConvFormat := ifA16B16G16R16
+ else if Info.HasAlphaChannel then
+ // convert the other images with alpha channel to A8R8G8B8
+ ConvFormat := ifA8R8G8B8
+ else
+ // convert the other formats to X8R8G8B8
+ ConvFormat := ifX8R8G8B8;
+
+ ConvertImage(Image, ConvFormat);
+end;
+
+function TDDSFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
+var
+ Hdr: TDDSFileHeader;
+ ReadCount: LongInt;
+begin
+ Result := False;
+ if Handle <> nil then
+ with GetIO do
+ begin
+ ReadCount := Read(Handle, @Hdr, SizeOf(Hdr));
+ Seek(Handle, -ReadCount, smFromCurrent);
+ Result := (Hdr.Magic = DDSMagic) and (ReadCount = SizeOf(Hdr)) and
+ ((Hdr.Desc.Caps.Caps1 and DDSCAPS_TEXTURE) = DDSCAPS_TEXTURE);
+ end;
+end;
+
+initialization
+ RegisterImageFileFormat(TDDSFileFormat);
+
+{
+ File Notes:
+
+ -- TODOS ----------------------------------------------------
+ - nothing now
+
+ -- 0.25.0 Changes/Bug Fixes ---------------------------------
+ - Added support for 3Dc ATI1/2 formats.
+
+ -- 0.23 Changes/Bug Fixes -----------------------------------
+ - Saved DDS with mipmaps now correctly defineds COMPLEX flag.
+ - Fixed loading of RGB DDS files that use pitch and have mipmaps -
+ mipmaps were loaded wrongly.
+
+ -- 0.21 Changes/Bug Fixes -----------------------------------
+ - Changed saving behaviour a bit: mipmaps are inlcuded automatically for
+ 2D textures if input image array has more than 1 image (no need to
+ set SaveMipMapCount manually).
+ - Mipmap levels are now saved with proper dimensions when saving DDS files.
+ - Made some changes to not be so strict when loading DDS files.
+ Many programs seem to save them in non-standard format
+ (by MS DDS File Reference).
+ - Added missing ifX8R8G8B8 to SupportedFormats, MakeCompatible failed
+ when image was converted to this format (inside).
+ - MakeCompatible method moved to base class, put ConvertToSupported here.
+ GetSupportedFormats removed, it is now set in constructor.
+ - Fixed bug that sometimes saved non-standard DDS files and another
+ one that caused crash when these files were loaded.
+ - Changed extensions to filename masks.
+ - Changed SaveData, LoadData, and MakeCompatible methods according
+ to changes in base class in Imaging unit.
+
+ -- 0.19 Changes/Bug Fixes -----------------------------------
+ - added support for half-float image formats
+ - change in LoadData to allow support for more images
+ in one stream loading
+
+ -- 0.17 Changes/Bug Fixes -----------------------------------
+ - fixed bug in TestFormat which does not recognize many DDS files
+ - changed pitch/linearsize handling in DDS loading code to
+ load DDS files produced by NVidia's Photoshop plugin
+}
+
+end.
+
diff --git a/Imaging/ImagingExport.pas b/Imaging/ImagingExport.pas
index 222941b..daf5bf7 100644
--- a/Imaging/ImagingExport.pas
+++ b/Imaging/ImagingExport.pas
@@ -1,891 +1,891 @@
-{
- $Id: ImagingExport.pas 173 2009-09-04 17:05:52Z galfar $
- Vampyre Imaging Library
- by Marek Mauder
- http://imaginglib.sourceforge.net
-
- The contents of this file are used with permission, subject to the Mozilla
- Public License Version 1.1 (the "License"); you may not use this file except
- in compliance with the License. You may obtain a copy of the License at
- http://www.mozilla.org/MPL/MPL-1.1.html
-
- Software distributed under the License is distributed on an "AS IS" basis,
- WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
- the specific language governing rights and limitations under the License.
-
- Alternatively, the contents of this file may be used under the terms of the
- GNU Lesser General Public License (the "LGPL License"), in which case the
- provisions of the LGPL License are applicable instead of those above.
- If you wish to allow use of your version of this file only under the terms
- of the LGPL License and not to allow others to use your version of this file
- under the MPL, indicate your decision by deleting the provisions above and
- replace them with the notice and other provisions required by the LGPL
- License. If you do not delete the provisions above, a recipient may use
- your version of this file under either the MPL or the LGPL License.
-
- For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
-}
-
-{ This function contains functions exported from Imaging dynamic link library.
- All string are exported as PChars and all var parameters are exported
- as pointers. All posible exceptions getting out of dll are catched.}
-unit ImagingExport;
-
-{$I ImagingOptions.inc}
-
-interface
-
-uses
- ImagingTypes,
- Imaging;
-
-{ Returns version of Imaging library. }
-procedure ImGetVersion(var Major, Minor, Patch: LongInt); cdecl;
-{ Look at InitImage for details.}
-procedure ImInitImage(var Image: TImageData); cdecl;
-{ Look at NewImage for details.}
-function ImNewImage(Width, Height: LongInt; Format: TImageFormat;
- var Image: TImageData): Boolean; cdecl;
-{ Look at TestImage for details.}
-function ImTestImage(var Image: TImageData): Boolean; cdecl;
-{ Look at FreeImage for details.}
-function ImFreeImage(var Image: TImageData): Boolean; cdecl;
-{ Look at DetermineFileFormat for details. Ext should have enough space for
- result file extension.}
-function ImDetermineFileFormat(FileName, Ext: PAnsiChar): Boolean; cdecl;
-{ Look at DetermineMemoryFormat for details. Ext should have enough space for
- result file extension.}
-function ImDetermineMemoryFormat(Data: Pointer; Size: LongInt; Ext: PAnsiChar): Boolean; cdecl;
-{ Look at IsFileFormatSupported for details.}
-function ImIsFileFormatSupported(FileName: PAnsiChar): Boolean; cdecl;
-{ Look at EnumFileFormats for details.}
-function ImEnumFileFormats(var Index: LongInt; Name, DefaultExt, Masks: PAnsiChar;
- var CanSave, IsMultiImageFormat: Boolean): Boolean; cdecl;
-
-{ Inits image list.}
-function ImInitImageList(Size: LongInt; var ImageList: TImageDataList): Boolean; cdecl;
-{ Returns size of image list.}
-function ImGetImageListSize(ImageList: TImageDataList): LongInt; cdecl;
-{ Returns image list's element at given index. Output image is not cloned it's
- Bits point to Bits in list => do not free OutImage.}
-function ImGetImageListElement(ImageList: TImageDataList; Index: LongInt;
- var OutImage: TImageData): Boolean; cdecl;
-{ Sets size of image list.}
-function ImSetImageListSize(ImageList: TImageDataList; NewSize: LongInt): Boolean; cdecl;
-{ Sets image list element at given index. Input image is not cloned - image in
- list will point to InImage's Bits.}
-function ImSetImageListElement(ImageList: TImageDataList; Index: LongInt;
- const InImage: TImageData): Boolean; cdecl;
-{ Returns True if all images in list pass ImTestImage test. }
-function ImTestImagesInList(ImageList: TImageDataList): Boolean; cdecl;
-{ Frees image list and all images in it.}
-function ImFreeImageList(var ImageList: TImageDataList): Boolean; cdecl;
-
-{ Look at LoadImageFromFile for details.}
-function ImLoadImageFromFile(FileName: PAnsiChar; var Image: TImageData): Boolean; cdecl;
-{ Look at LoadImageFromMemory for details.}
-function ImLoadImageFromMemory(Data: Pointer; Size: LongInt; var Image: TImageData): Boolean; cdecl;
-{ Look at LoadMultiImageFromFile for details.}
-function ImLoadMultiImageFromFile(FileName: PAnsiChar; var ImageList: TImageDataList): Boolean; cdecl;
-{ Look at LoadMultiImageFromMemory for details.}
-function ImLoadMultiImageFromMemory(Data: Pointer; Size: LongInt;
- var ImageList: TImageDataList): Boolean; cdecl;
-
-{ Look at SaveImageToFile for details.}
-function ImSaveImageToFile(FileName: PAnsiChar; const Image: TImageData): Boolean; cdecl;
-{ Look at SaveImageToMemory for details.}
-function ImSaveImageToMemory(Ext: PAnsiChar; Data: Pointer; var Size: LongInt;
- const Image: TImageData): Boolean; cdecl;
-{ Look at SaveMultiImageToFile for details.}
-function ImSaveMultiImageToFile(FileName: PAnsiChar; ImageList: TImageDataList): Boolean; cdecl;
-{ Look at SaveMultiImageToMemory for details.}
-function ImSaveMultiImageToMemory(Ext: PAnsiChar; Data: Pointer; Size: PLongInt;
- ImageList: TImageDataList): Boolean; cdecl;
-
-{ Look at CloneImage for details.}
-function ImCloneImage(const Image: TImageData; var Clone: TImageData): Boolean; cdecl;
-{ Look at ConvertImage for details.}
-function ImConvertImage(var Image: TImageData; DestFormat: TImageFormat): Boolean; cdecl;
-{ Look at FlipImage for details.}
-function ImFlipImage(var Image: TImageData): Boolean; cdecl;
-{ Look at MirrorImage for details.}
-function ImMirrorImage(var Image: TImageData): Boolean; cdecl;
-{ Look at ResizeImage for details.}
-function ImResizeImage(var Image: TImageData; NewWidth, NewHeight: LongInt;
- Filter: TResizeFilter): Boolean; cdecl;
-{ Look at SwapChannels for details.}
-function ImSwapChannels(var Image: TImageData; SrcChannel, DstChannel: LongInt): Boolean; cdecl;
-{ Look at ReduceColors for details.}
-function ImReduceColors(var Image: TImageData; MaxColors: LongInt): Boolean; cdecl;
-{ Look at GenerateMipMaps for details.}
-function ImGenerateMipMaps(const Image: TImageData; Levels: LongInt;
- var MipMaps: TImageDataList): Boolean; cdecl;
-{ Look at MapImageToPalette for details.}
-function ImMapImageToPalette(var Image: TImageData; Pal: PPalette32;
- Entries: LongInt): Boolean; cdecl;
-{ Look at SplitImage for details.}
-function ImSplitImage(var Image: TImageData; var Chunks: TImageDataList;
- ChunkWidth, ChunkHeight: LongInt; var XChunks, YChunks: LongInt;
- PreserveSize: Boolean; Fill: Pointer): Boolean; cdecl;
-{ Look at MakePaletteForImages for details.}
-function ImMakePaletteForImages(Images: TImageDataList; Pal: PPalette32;
- MaxColors: LongInt; ConvertImages: Boolean): Boolean; cdecl;
-{ Look at RotateImage for details.}
-function ImRotateImage(var Image: TImageData; Angle: Single): Boolean; cdecl;
-
-{ Look at CopyRect for details.}
-function ImCopyRect(const SrcImage: TImageData; SrcX, SrcY, Width, Height: LongInt;
- var DstImage: TImageData; DstX, DstY: LongInt): Boolean; cdecl;
-{ Look at FillRect for details.}
-function ImFillRect(var Image: TImageData; X, Y, Width, Height: LongInt;
- Fill: Pointer): Boolean; cdecl;
-{ Look at ReplaceColor for details.}
-function ImReplaceColor(var Image: TImageData; X, Y, Width, Height: LongInt;
- OldPixel, NewPixel: Pointer): Boolean; cdecl;
-{ Look at StretchRect for details.}
-function ImStretchRect(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
- SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
- DstHeight: LongInt; Filter: TResizeFilter): Boolean; cdecl;
-{ Look at GetPixelDirect for details.}
-procedure ImGetPixelDirect(const Image: TImageData; X, Y: LongInt; Pixel: Pointer); cdecl;
-{ Look at SetPixelDirect for details.}
-procedure ImSetPixelDirect(const Image: TImageData; X, Y: LongInt; Pixel: Pointer); cdecl;
-{ Look at GetPixel32 for details.}
-function ImGetPixel32(const Image: TImageData; X, Y: LongInt): TColor32Rec; cdecl;
-{ Look at SetPixel32 for details.}
-procedure ImSetPixel32(const Image: TImageData; X, Y: LongInt; const Color: TColor32Rec); cdecl;
-{ Look at GetPixelFP for details.}
-function ImGetPixelFP(const Image: TImageData; X, Y: LongInt): TColorFPRec; cdecl;
-{ Look at SetPixelFP for details.}
-procedure ImSetPixelFP(const Image: TImageData; X, Y: LongInt; const Color: TColorFPRec); cdecl;
-
-{ Look at NewPalette for details.}
-function ImNewPalette(Entries: LongInt; var Pal: PPalette32): Boolean; cdecl;
-{ Look at FreePalette for details.}
-function ImFreePalette(var Pal: PPalette32): Boolean; cdecl;
-{ Look at CopyPalette for details.}
-function ImCopyPalette(SrcPal, DstPal: PPalette32; SrcIdx, DstIdx, Count: LongInt): Boolean; cdecl;
-{ Look at FindColor for details.}
-function ImFindColor(Pal: PPalette32; Entries: LongInt; Color: TColor32): LongInt; cdecl;
-{ Look at FillGrayscalePalette for details.}
-function ImFillGrayscalePalette(Pal: PPalette32; Entries: LongInt): Boolean; cdecl;
-{ Look at FillCustomPalette for details.}
-function ImFillCustomPalette(Pal: PPalette32; Entries: LongInt; RBits, GBits,
- BBits: Byte; Alpha: Byte): Boolean; cdecl;
-{ Look at SwapChannelsOfPalette for details.}
-function ImSwapChannelsOfPalette(Pal: PPalette32; Entries, SrcChannel,
- DstChannel: LongInt): Boolean; cdecl;
-
-{ Look at SetOption for details.}
-function ImSetOption(OptionId, Value: LongInt): Boolean; cdecl;
-{ Look at GetOption for details.}
-function ImGetOption(OptionId: LongInt): LongInt; cdecl;
-{ Look at PushOptions for details.}
-function ImPushOptions: Boolean; cdecl;
-{ Look at PopOptions for details.}
-function ImPopOptions: Boolean; cdecl;
-
-{ Look at GetImageFormatInfo for details.}
-function ImGetImageFormatInfo(Format: TImageFormat; var Info: TImageFormatInfo): Boolean; cdecl;
-{ Look at GetPixelsSize for details.}
-function ImGetPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; cdecl;
-
-{ Look at SetUserFileIO for details.}
-procedure ImSetUserFileIO(OpenReadProc: TOpenReadProc; OpenWriteProc:
- TOpenWriteProc; CloseProc: TCloseProc; EofProc: TEofProc; SeekProc: TSeekProc;
- TellProc: TTellProc; ReadProc: TReadProc; WriteProc: TWriteProc); cdecl;
-{ Look at ResetFileIO for details.}
-procedure ImResetFileIO; cdecl;
-
-{ These are only for documentation generation reasons.}
-{ Loads Imaging functions from dll/so library.}
-function ImLoadLibrary: Boolean;
-{ Frees Imaging functions loaded from dll/so and releases library.}
-function ImFreeLibrary: Boolean;
-
-implementation
-
-uses
- SysUtils,
- ImagingUtility;
-
-function ImLoadLibrary: Boolean; begin Result := True; end;
-function ImFreeLibrary: Boolean; begin Result := True; end;
-
-type
- TInternalList = record
- List: TDynImageDataArray;
- end;
- PInternalList = ^TInternalList;
-
-procedure ImGetVersion(var Major, Minor, Patch: LongInt);
-begin
- Major := ImagingVersionMajor;
- Minor := ImagingVersionMinor;
- Patch := ImagingVersionPatch;
-end;
-
-procedure ImInitImage(var Image: TImageData);
-begin
- try
- Imaging.InitImage(Image);
- except
- end;
-end;
-
-function ImNewImage(Width, Height: LongInt; Format: TImageFormat;
- var Image: TImageData): Boolean;
-begin
- try
- Result := Imaging.NewImage(Width, Height, Format, Image);
- except
- Result := False;
- end;
-end;
-
-function ImTestImage(var Image: TImageData): Boolean;
-begin
- try
- Result := Imaging.TestImage(Image);
- except
- Result := False;
- end;
-end;
-
-function ImFreeImage(var Image: TImageData): Boolean;
-begin
- try
- Imaging.FreeImage(Image);
- Result := True;
- except
- Result := False;
- end;
-end;
-
-function ImDetermineFileFormat(FileName, Ext: PAnsiChar): Boolean;
-var
- S: string;
-begin
- try
- S := Imaging.DetermineFileFormat(FileName);
- Result := S <> '';
- StrCopy(Ext, PAnsiChar(AnsiString(S)));
- except
- Result := False;
- end;
-end;
-
-function ImDetermineMemoryFormat(Data: Pointer; Size: LongInt; Ext: PAnsiChar): Boolean;
-var
- S: string;
-begin
- try
- S := Imaging.DetermineMemoryFormat(Data, Size);
- Result := S <> '';
- StrCopy(Ext, PAnsiChar(AnsiString(S)));
- except
- Result := False;
- end;
-end;
-
-function ImIsFileFormatSupported(FileName: PAnsiChar): Boolean;
-begin
- try
- Result := Imaging.IsFileFormatSupported(FileName);
- except
- Result := False;
- end;
-end;
-
-function ImEnumFileFormats(var Index: LongInt; Name, DefaultExt, Masks: PAnsiChar;
- var CanSave, IsMultiImageFormat: Boolean): Boolean;
-var
- StrName, StrDefaultExt, StrMasks: string;
-begin
- try
- Result := Imaging.EnumFileFormats(Index, StrName, StrDefaultExt, StrMasks, CanSave,
- IsMultiImageFormat);
- StrCopy(Name, PAnsiChar(AnsiString(StrName)));
- StrCopy(DefaultExt, PAnsiChar(AnsiString(StrDefaultExt)));
- StrCopy(Masks, PAnsiChar(AnsiString(StrMasks)));
- except
- Result := False;
- end;
-end;
-
-function ImInitImageList(Size: LongInt; var ImageList: TImageDataList): Boolean;
-var
- Int: PInternalList;
-begin
- try
- try
- ImFreeImageList(ImageList);
- except
- end;
- New(Int);
- SetLength(Int.List, Size);
- ImageList := TImageDataList(Int);
- Result := True;
- except
- Result := False;
- ImageList := nil;
- end;
-end;
-
-function ImGetImageListSize(ImageList: TImageDataList): LongInt;
-begin
- try
- Result := Length(PInternalList(ImageList).List);
- except
- Result := -1;
- end;
-end;
-
-function ImGetImageListElement(ImageList: TImageDataList; Index: LongInt;
- var OutImage: TImageData): Boolean;
-begin
- try
- Index := ClampInt(Index, 0, Length(PInternalList(ImageList).List) - 1);
- ImCloneImage(PInternalList(ImageList).List[Index], OutImage);
- Result := True;
- except
- Result := False;
- end;
-end;
-
-function ImSetImageListSize(ImageList: TImageDataList; NewSize: LongInt):
- Boolean;
-var
- I, OldSize: LongInt;
-begin
- try
- OldSize := Length(PInternalList(ImageList).List);
- if NewSize < OldSize then
- for I := NewSize to OldSize - 1 do
- Imaging.FreeImage(PInternalList(ImageList).List[I]);
- SetLength(PInternalList(ImageList).List, NewSize);
- Result := True;
- except
- Result := False;
- end;
-end;
-
-function ImSetImageListElement(ImageList: TImageDataList; Index: LongInt;
- const InImage: TImageData): Boolean;
-begin
- try
- Index := ClampInt(Index, 0, Length(PInternalList(ImageList).List) - 1);
- ImCloneImage(InImage, PInternalList(ImageList).List[Index]);
- Result := True;
- except
- Result := False;
- end;
-end;
-
-function ImTestImagesInList(ImageList: TImageDataList): Boolean;
-var
- I: LongInt;
- Arr: TDynImageDataArray;
-begin
- Arr := nil;
- try
- Arr := PInternalList(ImageList).List;
- Result := True;
- for I := 0 to Length(Arr) - 1 do
- begin
- Result := Result and Imaging.TestImage(Arr[I]);
- if not Result then Break;
- end;
- except
- Result := False;
- end;
-end;
-
-function ImFreeImageList(var ImageList: TImageDataList): Boolean;
-var
- Int: PInternalList;
-begin
- try
- if ImageList <> nil then
- begin
- Int := PInternalList(ImageList);
- FreeImagesInArray(Int.List);
- Dispose(Int);
- ImageList := nil;
- end;
- Result := True;
- except
- Result := False;
- end;
-end;
-
-function ImLoadImageFromFile(FileName: PAnsiChar; var Image: TImageData): Boolean;
-begin
- try
- Result := Imaging.LoadImageFromFile(FileName, Image);
- except
- Result := False;
- end;
-end;
-
-function ImLoadImageFromMemory(Data: Pointer; Size: LongInt; var Image: TImageData): Boolean;
-begin
- try
- Result := Imaging.LoadImageFromMemory(Data, Size, Image);
- except
- Result := False;
- end;
-end;
-
-function ImLoadMultiImageFromFile(FileName: PAnsiChar; var ImageList: TImageDataList):
- Boolean;
-begin
- try
- ImInitImageList(0, ImageList);
- Result := Imaging.LoadMultiImageFromFile(FileName,
- PInternalList(ImageList).List);
- except
- Result := False;
- end;
-end;
-
-function ImLoadMultiImageFromMemory(Data: Pointer; Size: LongInt;
- var ImageList: TImageDataList): Boolean;
-begin
- try
- ImInitImageList(0, ImageList);
- Result := Imaging.LoadMultiImageFromMemory(Data, Size, PInternalList(ImageList).List);
- except
- Result := False;
- end;
-end;
-
-function ImSaveImageToFile(FileName: PAnsiChar; const Image: TImageData): Boolean;
-begin
- try
- Result := Imaging.SaveImageToFile(FileName, Image);
- except
- Result := False;
- end;
-end;
-
-function ImSaveImageToMemory(Ext: PAnsiChar; Data: Pointer; var Size: LongInt;
- const Image: TImageData): Boolean;
-begin
- try
- Result := Imaging.SaveImageToMemory(Ext, Data, Size, Image);
- except
- Result := False;
- end;
-end;
-
-function ImSaveMultiImageToFile(FileName: PAnsiChar;
- ImageList: TImageDataList): Boolean;
-begin
- try
- Result := Imaging.SaveMultiImageToFile(FileName,
- PInternalList(ImageList).List);
- except
- Result := False;
- end;
-end;
-
-function ImSaveMultiImageToMemory(Ext: PAnsiChar; Data: Pointer; Size: PLongInt;
- ImageList: TImageDataList): Boolean;
-begin
- try
- Result := Imaging.SaveMultiImageToMemory(Ext, Data, Size^,
- PInternalList(ImageList).List);
- except
- Result := False;
- end;
-end;
-
-function ImCloneImage(const Image: TImageData; var Clone: TImageData): Boolean;
-begin
- try
- Result := Imaging.CloneImage(Image, Clone);
- except
- Result := False;
- end;
-end;
-
-function ImConvertImage(var Image: TImageData; DestFormat: TImageFormat): Boolean;
-begin
- try
- Result := Imaging.ConvertImage(Image, DestFormat);
- except
- Result := False;
- end;
-end;
-
-function ImFlipImage(var Image: TImageData): Boolean;
-begin
- try
- Result := Imaging.FlipImage(Image);
- except
- Result := False;
- end;
-end;
-
-function ImMirrorImage(var Image: TImageData): Boolean;
-begin
- try
- Result := Imaging.MirrorImage(Image);
- except
- Result := False;
- end;
-end;
-
-function ImResizeImage(var Image: TImageData; NewWidth, NewHeight: LongInt;
- Filter: TResizeFilter): Boolean;
-begin
- try
- Result := Imaging.ResizeImage(Image, NewWidth, NewHeight, Filter);
- except
- Result := False;
- end;
-end;
-
-function ImSwapChannels(var Image: TImageData; SrcChannel, DstChannel: LongInt):
- Boolean;
-begin
- try
- Result := Imaging.SwapChannels(Image, SrcChannel, DstChannel);
- except
- Result := False;
- end;
-end;
-
-function ImReduceColors(var Image: TImageData; MaxColors: LongInt): Boolean;
-begin
- try
- Result := Imaging.ReduceColors(Image, MaxColors);
- except
- Result := False;
- end;
-end;
-
-function ImGenerateMipMaps(const Image: TImageData; Levels: LongInt;
- var MipMaps: TImageDataList): Boolean;
-begin
- try
- ImInitImageList(0, MipMaps);
- Result := Imaging.GenerateMipMaps(Image, Levels,
- PInternalList(MipMaps).List);
- except
- Result := False;
- end;
-end;
-
-function ImMapImageToPalette(var Image: TImageData; Pal: PPalette32;
- Entries: LongInt): Boolean;
-begin
- try
- Result := Imaging.MapImageToPalette(Image, Pal, Entries);
- except
- Result := False;
- end;
-end;
-
-function ImSplitImage(var Image: TImageData; var Chunks: TImageDataList;
- ChunkWidth, ChunkHeight: LongInt; var XChunks, YChunks: LongInt;
- PreserveSize: Boolean; Fill: Pointer): Boolean;
-begin
- try
- ImInitImageList(0, Chunks);
- Result := Imaging.SplitImage(Image, PInternalList(Chunks).List,
- ChunkWidth, ChunkHeight, XChunks, YChunks, PreserveSize, Fill);
- except
- Result := False;
- end;
-end;
-
-function ImMakePaletteForImages(Images: TImageDataList; Pal: PPalette32;
- MaxColors: LongInt; ConvertImages: Boolean): Boolean;
-begin
- try
- Result := Imaging.MakePaletteForImages(PInternalList(Images).List,
- Pal, MaxColors, ConvertImages);
- except
- Result := False;
- end;
-end;
-
-function ImRotateImage(var Image: TImageData; Angle: Single): Boolean;
-begin
- try
- Result := Imaging.RotateImage(Image, Angle);
- except
- Result := False;
- end;
-end;
-
-function ImCopyRect(const SrcImage: TImageData; SrcX, SrcY, Width, Height: LongInt;
- var DstImage: TImageData; DstX, DstY: LongInt): Boolean; cdecl;
-begin
- try
- Result := Imaging.CopyRect(SrcImage, SrcX, SrcY, Width, Height,
- DstImage, DstX, DstY);
- except
- Result := False;
- end;
-end;
-
-function ImFillRect(var Image: TImageData; X, Y, Width, Height: LongInt;
- Fill: Pointer): Boolean;
-begin
- try
- Result := Imaging.FillRect(Image, X, Y, Width, Height, Fill);
- except
- Result := False;
- end;
-end;
-
-function ImReplaceColor(var Image: TImageData; X, Y, Width, Height: LongInt;
- OldPixel, NewPixel: Pointer): Boolean;
-begin
- try
- Result := Imaging.ReplaceColor(Image, X, Y, Width, Height, OldPixel, NewPixel);
- except
- Result := False;
- end;
-end;
-
-function ImStretchRect(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
- SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
- DstHeight: LongInt; Filter: TResizeFilter): Boolean; cdecl;
-begin
- try
- Result := Imaging.StretchRect(SrcImage, SrcX, SrcY, SrcWidth, SrcHeight,
- DstImage, DstX, DstY, DstWidth, DstHeight, Filter);
- except
- Result := False;
- end;
-end;
-
-procedure ImGetPixelDirect(const Image: TImageData; X, Y: LongInt; Pixel: Pointer);
-begin
- try
- Imaging.GetPixelDirect(Image, X, Y, Pixel);
- except
- end;
-end;
-
-procedure ImSetPixelDirect(const Image: TImageData; X, Y: LongInt; Pixel: Pointer);
-begin
- try
- Imaging.SetPixelDirect(Image, X, Y, Pixel);
- except
- end;
-end;
-
-function ImGetPixel32(const Image: TImageData; X, Y: LongInt): TColor32Rec; cdecl;
-begin
- try
- Result := Imaging.GetPixel32(Image, X, Y);
- except
- Result.Color := 0;
- end;
-end;
-
-procedure ImSetPixel32(const Image: TImageData; X, Y: LongInt; const Color: TColor32Rec);
-begin
- try
- Imaging.SetPixel32(Image, X, Y, Color);
- except
- end;
-end;
-
-function ImGetPixelFP(const Image: TImageData; X, Y: LongInt): TColorFPRec; cdecl;
-begin
- try
- Result := Imaging.GetPixelFP(Image, X, Y);
- except
- FillChar(Result, SizeOf(Result), 0);
- end;
-end;
-
-procedure ImSetPixelFP(const Image: TImageData; X, Y: LongInt; const Color: TColorFPRec);
-begin
- try
- Imaging.SetPixelFP(Image, X, Y, Color);
- except
- end;
-end;
-
-function ImNewPalette(Entries: LongInt; var Pal: PPalette32): Boolean;
-begin
- try
- Imaging.NewPalette(Entries, Pal);
- Result := True;
- except
- Result := False;
- end;
-end;
-
-function ImFreePalette(var Pal: PPalette32): Boolean;
-begin
- try
- Imaging.FreePalette(Pal);
- Result := True;
- except
- Result := False;
- end;
-end;
-
-function ImCopyPalette(SrcPal, DstPal: PPalette32; SrcIdx, DstIdx, Count: LongInt): Boolean;
-begin
- try
- Imaging.CopyPalette(SrcPal, DstPal, SrcIdx, DstIdx, Count);
- Result := True;
- except
- Result := False;
- end;
-end;
-
-function ImFindColor(Pal: PPalette32; Entries: LongInt; Color: TColor32): LongInt;
-begin
- try
- Result := Imaging.FindColor(Pal, Entries, Color);
- except
- Result := 0;
- end;
-end;
-
-function ImFillGrayscalePalette(Pal: PPalette32; Entries: LongInt): Boolean;
-begin
- try
- Imaging.FillGrayscalePalette(Pal, Entries);
- Result := True;
- except
- Result := False;
- end;
-end;
-
-function ImFillCustomPalette(Pal: PPalette32; Entries: LongInt; RBits, GBits,
- BBits: Byte; Alpha: Byte): Boolean;
-begin
- try
- Imaging.FillCustomPalette(Pal, Entries, RBits, GBits, BBits, Alpha);
- Result := True;
- except
- Result := False;
- end;
-end;
-
-function ImSwapChannelsOfPalette(Pal: PPalette32; Entries, SrcChannel,
- DstChannel: LongInt): Boolean;
-begin
- try
- Imaging.SwapChannelsOfPalette(Pal, Entries, SrcChannel, DstChannel);
- Result := True;
- except
- Result := False;
- end;
-end;
-
-function ImSetOption(OptionId, Value: LongInt): Boolean;
-begin
- try
- Result := Imaging.SetOption(OptionId, Value);
- except
- Result := False;
- end;
-end;
-
-function ImGetOption(OptionId: LongInt): LongInt;
-begin
- try
- Result := GetOption(OptionId);
- except
- Result := InvalidOption;
- end;
-end;
-
-function ImPushOptions: Boolean;
-begin
- try
- Result := Imaging.PushOptions;
- except
- Result := False;
- end;
-end;
-
-function ImPopOptions: Boolean;
-begin
- try
- Result := Imaging.PopOptions;
- except
- Result := False;
- end;
-end;
-
-function ImGetImageFormatInfo(Format: TImageFormat; var Info: TImageFormatInfo): Boolean;
-begin
- try
- Result := Imaging.GetImageFormatInfo(Format, Info);
- except
- Result := False;
- end;
-end;
-
-function ImGetPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt;
-begin
- try
- Result := Imaging.GetPixelsSize(Format, Width, Height);
- except
- Result := 0;
- end;
-end;
-
-procedure ImSetUserFileIO(OpenReadProc: TOpenReadProc; OpenWriteProc:
- TOpenWriteProc; CloseProc: TCloseProc; EofProc: TEofProc; SeekProc: TSeekProc;
- TellProc: TTellProc; ReadProc: TReadProc; WriteProc: TWriteProc);
-begin
- try
- Imaging.SetUserFileIO(OpenReadProc, OpenWriteProc, CloseProc, EofProc,
- SeekProc, TellProc, ReadProc, WriteProc);
- except
- end;
-end;
-
-procedure ImResetFileIO;
-begin
- try
- Imaging.ResetFileIO;
- except
- end;
-end;
-
-{
- Changes/Bug Fixes:
-
- -- TODOS ----------------------------------------------------
- - nothing now
-
- -- 0.26.3 ---------------------------------------------------
- - changed PChars to PAnsiChars and some more D2009 friendly
- casts.
-
- -- 0.19 -----------------------------------------------------
- - updated to reflect changes in low level interface (added pixel set/get, ...)
- - changed ImInitImage to procedure to reflect change in Imaging.pas
- - added ImIsFileFormatSupported
-
- -- 0.15 -----------------------------------------------------
- - behaviour of ImGetImageListElement and ImSetImageListElement
- has changed - list items are now cloned rather than referenced,
- because of this ImFreeImageListKeepImages was no longer needed
- and was removed
- - many function headers were changed - mainly pointers were
- replaced with var and const parameters
-
- -- 0.13 -----------------------------------------------------
- - added TestImagesInList function and new 0.13 functions
- - images were not freed when image list was resized in ImSetImageListSize
- - ImSaveMultiImageTo* recreated the input image list with size = 0
-
-}
-end.
-
+{
+ $Id: ImagingExport.pas 173 2009-09-04 17:05:52Z galfar $
+ Vampyre Imaging Library
+ by Marek Mauder
+ http://imaginglib.sourceforge.net
+
+ The contents of this file are used with permission, subject to the Mozilla
+ Public License Version 1.1 (the "License"); you may not use this file except
+ in compliance with the License. You may obtain a copy of the License at
+ http://www.mozilla.org/MPL/MPL-1.1.html
+
+ Software distributed under the License is distributed on an "AS IS" basis,
+ WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
+ the specific language governing rights and limitations under the License.
+
+ Alternatively, the contents of this file may be used under the terms of the
+ GNU Lesser General Public License (the "LGPL License"), in which case the
+ provisions of the LGPL License are applicable instead of those above.
+ If you wish to allow use of your version of this file only under the terms
+ of the LGPL License and not to allow others to use your version of this file
+ under the MPL, indicate your decision by deleting the provisions above and
+ replace them with the notice and other provisions required by the LGPL
+ License. If you do not delete the provisions above, a recipient may use
+ your version of this file under either the MPL or the LGPL License.
+
+ For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
+}
+
+{ This function contains functions exported from Imaging dynamic link library.
+ All string are exported as PChars and all var parameters are exported
+ as pointers. All posible exceptions getting out of dll are catched.}
+unit ImagingExport;
+
+{$I ImagingOptions.inc}
+
+interface
+
+uses
+ ImagingTypes,
+ Imaging;
+
+{ Returns version of Imaging library. }
+procedure ImGetVersion(var Major, Minor, Patch: LongInt); cdecl;
+{ Look at InitImage for details.}
+procedure ImInitImage(var Image: TImageData); cdecl;
+{ Look at NewImage for details.}
+function ImNewImage(Width, Height: LongInt; Format: TImageFormat;
+ var Image: TImageData): Boolean; cdecl;
+{ Look at TestImage for details.}
+function ImTestImage(var Image: TImageData): Boolean; cdecl;
+{ Look at FreeImage for details.}
+function ImFreeImage(var Image: TImageData): Boolean; cdecl;
+{ Look at DetermineFileFormat for details. Ext should have enough space for
+ result file extension.}
+function ImDetermineFileFormat(FileName, Ext: PAnsiChar): Boolean; cdecl;
+{ Look at DetermineMemoryFormat for details. Ext should have enough space for
+ result file extension.}
+function ImDetermineMemoryFormat(Data: Pointer; Size: LongInt; Ext: PAnsiChar): Boolean; cdecl;
+{ Look at IsFileFormatSupported for details.}
+function ImIsFileFormatSupported(FileName: PAnsiChar): Boolean; cdecl;
+{ Look at EnumFileFormats for details.}
+function ImEnumFileFormats(var Index: LongInt; Name, DefaultExt, Masks: PAnsiChar;
+ var CanSave, IsMultiImageFormat: Boolean): Boolean; cdecl;
+
+{ Inits image list.}
+function ImInitImageList(Size: LongInt; var ImageList: TImageDataList): Boolean; cdecl;
+{ Returns size of image list.}
+function ImGetImageListSize(ImageList: TImageDataList): LongInt; cdecl;
+{ Returns image list's element at given index. Output image is not cloned it's
+ Bits point to Bits in list => do not free OutImage.}
+function ImGetImageListElement(ImageList: TImageDataList; Index: LongInt;
+ var OutImage: TImageData): Boolean; cdecl;
+{ Sets size of image list.}
+function ImSetImageListSize(ImageList: TImageDataList; NewSize: LongInt): Boolean; cdecl;
+{ Sets image list element at given index. Input image is not cloned - image in
+ list will point to InImage's Bits.}
+function ImSetImageListElement(ImageList: TImageDataList; Index: LongInt;
+ const InImage: TImageData): Boolean; cdecl;
+{ Returns True if all images in list pass ImTestImage test. }
+function ImTestImagesInList(ImageList: TImageDataList): Boolean; cdecl;
+{ Frees image list and all images in it.}
+function ImFreeImageList(var ImageList: TImageDataList): Boolean; cdecl;
+
+{ Look at LoadImageFromFile for details.}
+function ImLoadImageFromFile(FileName: PAnsiChar; var Image: TImageData): Boolean; cdecl;
+{ Look at LoadImageFromMemory for details.}
+function ImLoadImageFromMemory(Data: Pointer; Size: LongInt; var Image: TImageData): Boolean; cdecl;
+{ Look at LoadMultiImageFromFile for details.}
+function ImLoadMultiImageFromFile(FileName: PAnsiChar; var ImageList: TImageDataList): Boolean; cdecl;
+{ Look at LoadMultiImageFromMemory for details.}
+function ImLoadMultiImageFromMemory(Data: Pointer; Size: LongInt;
+ var ImageList: TImageDataList): Boolean; cdecl;
+
+{ Look at SaveImageToFile for details.}
+function ImSaveImageToFile(FileName: PAnsiChar; const Image: TImageData): Boolean; cdecl;
+{ Look at SaveImageToMemory for details.}
+function ImSaveImageToMemory(Ext: PAnsiChar; Data: Pointer; var Size: LongInt;
+ const Image: TImageData): Boolean; cdecl;
+{ Look at SaveMultiImageToFile for details.}
+function ImSaveMultiImageToFile(FileName: PAnsiChar; ImageList: TImageDataList): Boolean; cdecl;
+{ Look at SaveMultiImageToMemory for details.}
+function ImSaveMultiImageToMemory(Ext: PAnsiChar; Data: Pointer; Size: PLongInt;
+ ImageList: TImageDataList): Boolean; cdecl;
+
+{ Look at CloneImage for details.}
+function ImCloneImage(const Image: TImageData; var Clone: TImageData): Boolean; cdecl;
+{ Look at ConvertImage for details.}
+function ImConvertImage(var Image: TImageData; DestFormat: TImageFormat): Boolean; cdecl;
+{ Look at FlipImage for details.}
+function ImFlipImage(var Image: TImageData): Boolean; cdecl;
+{ Look at MirrorImage for details.}
+function ImMirrorImage(var Image: TImageData): Boolean; cdecl;
+{ Look at ResizeImage for details.}
+function ImResizeImage(var Image: TImageData; NewWidth, NewHeight: LongInt;
+ Filter: TResizeFilter): Boolean; cdecl;
+{ Look at SwapChannels for details.}
+function ImSwapChannels(var Image: TImageData; SrcChannel, DstChannel: LongInt): Boolean; cdecl;
+{ Look at ReduceColors for details.}
+function ImReduceColors(var Image: TImageData; MaxColors: LongInt): Boolean; cdecl;
+{ Look at GenerateMipMaps for details.}
+function ImGenerateMipMaps(const Image: TImageData; Levels: LongInt;
+ var MipMaps: TImageDataList): Boolean; cdecl;
+{ Look at MapImageToPalette for details.}
+function ImMapImageToPalette(var Image: TImageData; Pal: PPalette32;
+ Entries: LongInt): Boolean; cdecl;
+{ Look at SplitImage for details.}
+function ImSplitImage(var Image: TImageData; var Chunks: TImageDataList;
+ ChunkWidth, ChunkHeight: LongInt; var XChunks, YChunks: LongInt;
+ PreserveSize: Boolean; Fill: Pointer): Boolean; cdecl;
+{ Look at MakePaletteForImages for details.}
+function ImMakePaletteForImages(Images: TImageDataList; Pal: PPalette32;
+ MaxColors: LongInt; ConvertImages: Boolean): Boolean; cdecl;
+{ Look at RotateImage for details.}
+function ImRotateImage(var Image: TImageData; Angle: Single): Boolean; cdecl;
+
+{ Look at CopyRect for details.}
+function ImCopyRect(const SrcImage: TImageData; SrcX, SrcY, Width, Height: LongInt;
+ var DstImage: TImageData; DstX, DstY: LongInt): Boolean; cdecl;
+{ Look at FillRect for details.}
+function ImFillRect(var Image: TImageData; X, Y, Width, Height: LongInt;
+ Fill: Pointer): Boolean; cdecl;
+{ Look at ReplaceColor for details.}
+function ImReplaceColor(var Image: TImageData; X, Y, Width, Height: LongInt;
+ OldPixel, NewPixel: Pointer): Boolean; cdecl;
+{ Look at StretchRect for details.}
+function ImStretchRect(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
+ SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
+ DstHeight: LongInt; Filter: TResizeFilter): Boolean; cdecl;
+{ Look at GetPixelDirect for details.}
+procedure ImGetPixelDirect(const Image: TImageData; X, Y: LongInt; Pixel: Pointer); cdecl;
+{ Look at SetPixelDirect for details.}
+procedure ImSetPixelDirect(const Image: TImageData; X, Y: LongInt; Pixel: Pointer); cdecl;
+{ Look at GetPixel32 for details.}
+function ImGetPixel32(const Image: TImageData; X, Y: LongInt): TColor32Rec; cdecl;
+{ Look at SetPixel32 for details.}
+procedure ImSetPixel32(const Image: TImageData; X, Y: LongInt; const Color: TColor32Rec); cdecl;
+{ Look at GetPixelFP for details.}
+function ImGetPixelFP(const Image: TImageData; X, Y: LongInt): TColorFPRec; cdecl;
+{ Look at SetPixelFP for details.}
+procedure ImSetPixelFP(const Image: TImageData; X, Y: LongInt; const Color: TColorFPRec); cdecl;
+
+{ Look at NewPalette for details.}
+function ImNewPalette(Entries: LongInt; var Pal: PPalette32): Boolean; cdecl;
+{ Look at FreePalette for details.}
+function ImFreePalette(var Pal: PPalette32): Boolean; cdecl;
+{ Look at CopyPalette for details.}
+function ImCopyPalette(SrcPal, DstPal: PPalette32; SrcIdx, DstIdx, Count: LongInt): Boolean; cdecl;
+{ Look at FindColor for details.}
+function ImFindColor(Pal: PPalette32; Entries: LongInt; Color: TColor32): LongInt; cdecl;
+{ Look at FillGrayscalePalette for details.}
+function ImFillGrayscalePalette(Pal: PPalette32; Entries: LongInt): Boolean; cdecl;
+{ Look at FillCustomPalette for details.}
+function ImFillCustomPalette(Pal: PPalette32; Entries: LongInt; RBits, GBits,
+ BBits: Byte; Alpha: Byte): Boolean; cdecl;
+{ Look at SwapChannelsOfPalette for details.}
+function ImSwapChannelsOfPalette(Pal: PPalette32; Entries, SrcChannel,
+ DstChannel: LongInt): Boolean; cdecl;
+
+{ Look at SetOption for details.}
+function ImSetOption(OptionId, Value: LongInt): Boolean; cdecl;
+{ Look at GetOption for details.}
+function ImGetOption(OptionId: LongInt): LongInt; cdecl;
+{ Look at PushOptions for details.}
+function ImPushOptions: Boolean; cdecl;
+{ Look at PopOptions for details.}
+function ImPopOptions: Boolean; cdecl;
+
+{ Look at GetImageFormatInfo for details.}
+function ImGetImageFormatInfo(Format: TImageFormat; var Info: TImageFormatInfo): Boolean; cdecl;
+{ Look at GetPixelsSize for details.}
+function ImGetPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; cdecl;
+
+{ Look at SetUserFileIO for details.}
+procedure ImSetUserFileIO(OpenReadProc: TOpenReadProc; OpenWriteProc:
+ TOpenWriteProc; CloseProc: TCloseProc; EofProc: TEofProc; SeekProc: TSeekProc;
+ TellProc: TTellProc; ReadProc: TReadProc; WriteProc: TWriteProc); cdecl;
+{ Look at ResetFileIO for details.}
+procedure ImResetFileIO; cdecl;
+
+{ These are only for documentation generation reasons.}
+{ Loads Imaging functions from dll/so library.}
+function ImLoadLibrary: Boolean;
+{ Frees Imaging functions loaded from dll/so and releases library.}
+function ImFreeLibrary: Boolean;
+
+implementation
+
+uses
+ SysUtils,
+ ImagingUtility;
+
+function ImLoadLibrary: Boolean; begin Result := True; end;
+function ImFreeLibrary: Boolean; begin Result := True; end;
+
+type
+ TInternalList = record
+ List: TDynImageDataArray;
+ end;
+ PInternalList = ^TInternalList;
+
+procedure ImGetVersion(var Major, Minor, Patch: LongInt);
+begin
+ Major := ImagingVersionMajor;
+ Minor := ImagingVersionMinor;
+ Patch := ImagingVersionPatch;
+end;
+
+procedure ImInitImage(var Image: TImageData);
+begin
+ try
+ Imaging.InitImage(Image);
+ except
+ end;
+end;
+
+function ImNewImage(Width, Height: LongInt; Format: TImageFormat;
+ var Image: TImageData): Boolean;
+begin
+ try
+ Result := Imaging.NewImage(Width, Height, Format, Image);
+ except
+ Result := False;
+ end;
+end;
+
+function ImTestImage(var Image: TImageData): Boolean;
+begin
+ try
+ Result := Imaging.TestImage(Image);
+ except
+ Result := False;
+ end;
+end;
+
+function ImFreeImage(var Image: TImageData): Boolean;
+begin
+ try
+ Imaging.FreeImage(Image);
+ Result := True;
+ except
+ Result := False;
+ end;
+end;
+
+function ImDetermineFileFormat(FileName, Ext: PAnsiChar): Boolean;
+var
+ S: string;
+begin
+ try
+ S := Imaging.DetermineFileFormat(FileName);
+ Result := S <> '';
+ StrCopy(Ext, PAnsiChar(AnsiString(S)));
+ except
+ Result := False;
+ end;
+end;
+
+function ImDetermineMemoryFormat(Data: Pointer; Size: LongInt; Ext: PAnsiChar): Boolean;
+var
+ S: string;
+begin
+ try
+ S := Imaging.DetermineMemoryFormat(Data, Size);
+ Result := S <> '';
+ StrCopy(Ext, PAnsiChar(AnsiString(S)));
+ except
+ Result := False;
+ end;
+end;
+
+function ImIsFileFormatSupported(FileName: PAnsiChar): Boolean;
+begin
+ try
+ Result := Imaging.IsFileFormatSupported(FileName);
+ except
+ Result := False;
+ end;
+end;
+
+function ImEnumFileFormats(var Index: LongInt; Name, DefaultExt, Masks: PAnsiChar;
+ var CanSave, IsMultiImageFormat: Boolean): Boolean;
+var
+ StrName, StrDefaultExt, StrMasks: string;
+begin
+ try
+ Result := Imaging.EnumFileFormats(Index, StrName, StrDefaultExt, StrMasks, CanSave,
+ IsMultiImageFormat);
+ StrCopy(Name, PAnsiChar(AnsiString(StrName)));
+ StrCopy(DefaultExt, PAnsiChar(AnsiString(StrDefaultExt)));
+ StrCopy(Masks, PAnsiChar(AnsiString(StrMasks)));
+ except
+ Result := False;
+ end;
+end;
+
+function ImInitImageList(Size: LongInt; var ImageList: TImageDataList): Boolean;
+var
+ Int: PInternalList;
+begin
+ try
+ try
+ ImFreeImageList(ImageList);
+ except
+ end;
+ New(Int);
+ SetLength(Int.List, Size);
+ ImageList := TImageDataList(Int);
+ Result := True;
+ except
+ Result := False;
+ ImageList := nil;
+ end;
+end;
+
+function ImGetImageListSize(ImageList: TImageDataList): LongInt;
+begin
+ try
+ Result := Length(PInternalList(ImageList).List);
+ except
+ Result := -1;
+ end;
+end;
+
+function ImGetImageListElement(ImageList: TImageDataList; Index: LongInt;
+ var OutImage: TImageData): Boolean;
+begin
+ try
+ Index := ClampInt(Index, 0, Length(PInternalList(ImageList).List) - 1);
+ ImCloneImage(PInternalList(ImageList).List[Index], OutImage);
+ Result := True;
+ except
+ Result := False;
+ end;
+end;
+
+function ImSetImageListSize(ImageList: TImageDataList; NewSize: LongInt):
+ Boolean;
+var
+ I, OldSize: LongInt;
+begin
+ try
+ OldSize := Length(PInternalList(ImageList).List);
+ if NewSize < OldSize then
+ for I := NewSize to OldSize - 1 do
+ Imaging.FreeImage(PInternalList(ImageList).List[I]);
+ SetLength(PInternalList(ImageList).List, NewSize);
+ Result := True;
+ except
+ Result := False;
+ end;
+end;
+
+function ImSetImageListElement(ImageList: TImageDataList; Index: LongInt;
+ const InImage: TImageData): Boolean;
+begin
+ try
+ Index := ClampInt(Index, 0, Length(PInternalList(ImageList).List) - 1);
+ ImCloneImage(InImage, PInternalList(ImageList).List[Index]);
+ Result := True;
+ except
+ Result := False;
+ end;
+end;
+
+function ImTestImagesInList(ImageList: TImageDataList): Boolean;
+var
+ I: LongInt;
+ Arr: TDynImageDataArray;
+begin
+ Arr := nil;
+ try
+ Arr := PInternalList(ImageList).List;
+ Result := True;
+ for I := 0 to Length(Arr) - 1 do
+ begin
+ Result := Result and Imaging.TestImage(Arr[I]);
+ if not Result then Break;
+ end;
+ except
+ Result := False;
+ end;
+end;
+
+function ImFreeImageList(var ImageList: TImageDataList): Boolean;
+var
+ Int: PInternalList;
+begin
+ try
+ if ImageList <> nil then
+ begin
+ Int := PInternalList(ImageList);
+ FreeImagesInArray(Int.List);
+ Dispose(Int);
+ ImageList := nil;
+ end;
+ Result := True;
+ except
+ Result := False;
+ end;
+end;
+
+function ImLoadImageFromFile(FileName: PAnsiChar; var Image: TImageData): Boolean;
+begin
+ try
+ Result := Imaging.LoadImageFromFile(FileName, Image);
+ except
+ Result := False;
+ end;
+end;
+
+function ImLoadImageFromMemory(Data: Pointer; Size: LongInt; var Image: TImageData): Boolean;
+begin
+ try
+ Result := Imaging.LoadImageFromMemory(Data, Size, Image);
+ except
+ Result := False;
+ end;
+end;
+
+function ImLoadMultiImageFromFile(FileName: PAnsiChar; var ImageList: TImageDataList):
+ Boolean;
+begin
+ try
+ ImInitImageList(0, ImageList);
+ Result := Imaging.LoadMultiImageFromFile(FileName,
+ PInternalList(ImageList).List);
+ except
+ Result := False;
+ end;
+end;
+
+function ImLoadMultiImageFromMemory(Data: Pointer; Size: LongInt;
+ var ImageList: TImageDataList): Boolean;
+begin
+ try
+ ImInitImageList(0, ImageList);
+ Result := Imaging.LoadMultiImageFromMemory(Data, Size, PInternalList(ImageList).List);
+ except
+ Result := False;
+ end;
+end;
+
+function ImSaveImageToFile(FileName: PAnsiChar; const Image: TImageData): Boolean;
+begin
+ try
+ Result := Imaging.SaveImageToFile(FileName, Image);
+ except
+ Result := False;
+ end;
+end;
+
+function ImSaveImageToMemory(Ext: PAnsiChar; Data: Pointer; var Size: LongInt;
+ const Image: TImageData): Boolean;
+begin
+ try
+ Result := Imaging.SaveImageToMemory(Ext, Data, Size, Image);
+ except
+ Result := False;
+ end;
+end;
+
+function ImSaveMultiImageToFile(FileName: PAnsiChar;
+ ImageList: TImageDataList): Boolean;
+begin
+ try
+ Result := Imaging.SaveMultiImageToFile(FileName,
+ PInternalList(ImageList).List);
+ except
+ Result := False;
+ end;
+end;
+
+function ImSaveMultiImageToMemory(Ext: PAnsiChar; Data: Pointer; Size: PLongInt;
+ ImageList: TImageDataList): Boolean;
+begin
+ try
+ Result := Imaging.SaveMultiImageToMemory(Ext, Data, Size^,
+ PInternalList(ImageList).List);
+ except
+ Result := False;
+ end;
+end;
+
+function ImCloneImage(const Image: TImageData; var Clone: TImageData): Boolean;
+begin
+ try
+ Result := Imaging.CloneImage(Image, Clone);
+ except
+ Result := False;
+ end;
+end;
+
+function ImConvertImage(var Image: TImageData; DestFormat: TImageFormat): Boolean;
+begin
+ try
+ Result := Imaging.ConvertImage(Image, DestFormat);
+ except
+ Result := False;
+ end;
+end;
+
+function ImFlipImage(var Image: TImageData): Boolean;
+begin
+ try
+ Result := Imaging.FlipImage(Image);
+ except
+ Result := False;
+ end;
+end;
+
+function ImMirrorImage(var Image: TImageData): Boolean;
+begin
+ try
+ Result := Imaging.MirrorImage(Image);
+ except
+ Result := False;
+ end;
+end;
+
+function ImResizeImage(var Image: TImageData; NewWidth, NewHeight: LongInt;
+ Filter: TResizeFilter): Boolean;
+begin
+ try
+ Result := Imaging.ResizeImage(Image, NewWidth, NewHeight, Filter);
+ except
+ Result := False;
+ end;
+end;
+
+function ImSwapChannels(var Image: TImageData; SrcChannel, DstChannel: LongInt):
+ Boolean;
+begin
+ try
+ Result := Imaging.SwapChannels(Image, SrcChannel, DstChannel);
+ except
+ Result := False;
+ end;
+end;
+
+function ImReduceColors(var Image: TImageData; MaxColors: LongInt): Boolean;
+begin
+ try
+ Result := Imaging.ReduceColors(Image, MaxColors);
+ except
+ Result := False;
+ end;
+end;
+
+function ImGenerateMipMaps(const Image: TImageData; Levels: LongInt;
+ var MipMaps: TImageDataList): Boolean;
+begin
+ try
+ ImInitImageList(0, MipMaps);
+ Result := Imaging.GenerateMipMaps(Image, Levels,
+ PInternalList(MipMaps).List);
+ except
+ Result := False;
+ end;
+end;
+
+function ImMapImageToPalette(var Image: TImageData; Pal: PPalette32;
+ Entries: LongInt): Boolean;
+begin
+ try
+ Result := Imaging.MapImageToPalette(Image, Pal, Entries);
+ except
+ Result := False;
+ end;
+end;
+
+function ImSplitImage(var Image: TImageData; var Chunks: TImageDataList;
+ ChunkWidth, ChunkHeight: LongInt; var XChunks, YChunks: LongInt;
+ PreserveSize: Boolean; Fill: Pointer): Boolean;
+begin
+ try
+ ImInitImageList(0, Chunks);
+ Result := Imaging.SplitImage(Image, PInternalList(Chunks).List,
+ ChunkWidth, ChunkHeight, XChunks, YChunks, PreserveSize, Fill);
+ except
+ Result := False;
+ end;
+end;
+
+function ImMakePaletteForImages(Images: TImageDataList; Pal: PPalette32;
+ MaxColors: LongInt; ConvertImages: Boolean): Boolean;
+begin
+ try
+ Result := Imaging.MakePaletteForImages(PInternalList(Images).List,
+ Pal, MaxColors, ConvertImages);
+ except
+ Result := False;
+ end;
+end;
+
+function ImRotateImage(var Image: TImageData; Angle: Single): Boolean;
+begin
+ try
+ Result := Imaging.RotateImage(Image, Angle);
+ except
+ Result := False;
+ end;
+end;
+
+function ImCopyRect(const SrcImage: TImageData; SrcX, SrcY, Width, Height: LongInt;
+ var DstImage: TImageData; DstX, DstY: LongInt): Boolean; cdecl;
+begin
+ try
+ Result := Imaging.CopyRect(SrcImage, SrcX, SrcY, Width, Height,
+ DstImage, DstX, DstY);
+ except
+ Result := False;
+ end;
+end;
+
+function ImFillRect(var Image: TImageData; X, Y, Width, Height: LongInt;
+ Fill: Pointer): Boolean;
+begin
+ try
+ Result := Imaging.FillRect(Image, X, Y, Width, Height, Fill);
+ except
+ Result := False;
+ end;
+end;
+
+function ImReplaceColor(var Image: TImageData; X, Y, Width, Height: LongInt;
+ OldPixel, NewPixel: Pointer): Boolean;
+begin
+ try
+ Result := Imaging.ReplaceColor(Image, X, Y, Width, Height, OldPixel, NewPixel);
+ except
+ Result := False;
+ end;
+end;
+
+function ImStretchRect(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
+ SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
+ DstHeight: LongInt; Filter: TResizeFilter): Boolean; cdecl;
+begin
+ try
+ Result := Imaging.StretchRect(SrcImage, SrcX, SrcY, SrcWidth, SrcHeight,
+ DstImage, DstX, DstY, DstWidth, DstHeight, Filter);
+ except
+ Result := False;
+ end;
+end;
+
+procedure ImGetPixelDirect(const Image: TImageData; X, Y: LongInt; Pixel: Pointer);
+begin
+ try
+ Imaging.GetPixelDirect(Image, X, Y, Pixel);
+ except
+ end;
+end;
+
+procedure ImSetPixelDirect(const Image: TImageData; X, Y: LongInt; Pixel: Pointer);
+begin
+ try
+ Imaging.SetPixelDirect(Image, X, Y, Pixel);
+ except
+ end;
+end;
+
+function ImGetPixel32(const Image: TImageData; X, Y: LongInt): TColor32Rec; cdecl;
+begin
+ try
+ Result := Imaging.GetPixel32(Image, X, Y);
+ except
+ Result.Color := 0;
+ end;
+end;
+
+procedure ImSetPixel32(const Image: TImageData; X, Y: LongInt; const Color: TColor32Rec);
+begin
+ try
+ Imaging.SetPixel32(Image, X, Y, Color);
+ except
+ end;
+end;
+
+function ImGetPixelFP(const Image: TImageData; X, Y: LongInt): TColorFPRec; cdecl;
+begin
+ try
+ Result := Imaging.GetPixelFP(Image, X, Y);
+ except
+ FillChar(Result, SizeOf(Result), 0);
+ end;
+end;
+
+procedure ImSetPixelFP(const Image: TImageData; X, Y: LongInt; const Color: TColorFPRec);
+begin
+ try
+ Imaging.SetPixelFP(Image, X, Y, Color);
+ except
+ end;
+end;
+
+function ImNewPalette(Entries: LongInt; var Pal: PPalette32): Boolean;
+begin
+ try
+ Imaging.NewPalette(Entries, Pal);
+ Result := True;
+ except
+ Result := False;
+ end;
+end;
+
+function ImFreePalette(var Pal: PPalette32): Boolean;
+begin
+ try
+ Imaging.FreePalette(Pal);
+ Result := True;
+ except
+ Result := False;
+ end;
+end;
+
+function ImCopyPalette(SrcPal, DstPal: PPalette32; SrcIdx, DstIdx, Count: LongInt): Boolean;
+begin
+ try
+ Imaging.CopyPalette(SrcPal, DstPal, SrcIdx, DstIdx, Count);
+ Result := True;
+ except
+ Result := False;
+ end;
+end;
+
+function ImFindColor(Pal: PPalette32; Entries: LongInt; Color: TColor32): LongInt;
+begin
+ try
+ Result := Imaging.FindColor(Pal, Entries, Color);
+ except
+ Result := 0;
+ end;
+end;
+
+function ImFillGrayscalePalette(Pal: PPalette32; Entries: LongInt): Boolean;
+begin
+ try
+ Imaging.FillGrayscalePalette(Pal, Entries);
+ Result := True;
+ except
+ Result := False;
+ end;
+end;
+
+function ImFillCustomPalette(Pal: PPalette32; Entries: LongInt; RBits, GBits,
+ BBits: Byte; Alpha: Byte): Boolean;
+begin
+ try
+ Imaging.FillCustomPalette(Pal, Entries, RBits, GBits, BBits, Alpha);
+ Result := True;
+ except
+ Result := False;
+ end;
+end;
+
+function ImSwapChannelsOfPalette(Pal: PPalette32; Entries, SrcChannel,
+ DstChannel: LongInt): Boolean;
+begin
+ try
+ Imaging.SwapChannelsOfPalette(Pal, Entries, SrcChannel, DstChannel);
+ Result := True;
+ except
+ Result := False;
+ end;
+end;
+
+function ImSetOption(OptionId, Value: LongInt): Boolean;
+begin
+ try
+ Result := Imaging.SetOption(OptionId, Value);
+ except
+ Result := False;
+ end;
+end;
+
+function ImGetOption(OptionId: LongInt): LongInt;
+begin
+ try
+ Result := GetOption(OptionId);
+ except
+ Result := InvalidOption;
+ end;
+end;
+
+function ImPushOptions: Boolean;
+begin
+ try
+ Result := Imaging.PushOptions;
+ except
+ Result := False;
+ end;
+end;
+
+function ImPopOptions: Boolean;
+begin
+ try
+ Result := Imaging.PopOptions;
+ except
+ Result := False;
+ end;
+end;
+
+function ImGetImageFormatInfo(Format: TImageFormat; var Info: TImageFormatInfo): Boolean;
+begin
+ try
+ Result := Imaging.GetImageFormatInfo(Format, Info);
+ except
+ Result := False;
+ end;
+end;
+
+function ImGetPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt;
+begin
+ try
+ Result := Imaging.GetPixelsSize(Format, Width, Height);
+ except
+ Result := 0;
+ end;
+end;
+
+procedure ImSetUserFileIO(OpenReadProc: TOpenReadProc; OpenWriteProc:
+ TOpenWriteProc; CloseProc: TCloseProc; EofProc: TEofProc; SeekProc: TSeekProc;
+ TellProc: TTellProc; ReadProc: TReadProc; WriteProc: TWriteProc);
+begin
+ try
+ Imaging.SetUserFileIO(OpenReadProc, OpenWriteProc, CloseProc, EofProc,
+ SeekProc, TellProc, ReadProc, WriteProc);
+ except
+ end;
+end;
+
+procedure ImResetFileIO;
+begin
+ try
+ Imaging.ResetFileIO;
+ except
+ end;
+end;
+
+{
+ Changes/Bug Fixes:
+
+ -- TODOS ----------------------------------------------------
+ - nothing now
+
+ -- 0.26.3 ---------------------------------------------------
+ - changed PChars to PAnsiChars and some more D2009 friendly
+ casts.
+
+ -- 0.19 -----------------------------------------------------
+ - updated to reflect changes in low level interface (added pixel set/get, ...)
+ - changed ImInitImage to procedure to reflect change in Imaging.pas
+ - added ImIsFileFormatSupported
+
+ -- 0.15 -----------------------------------------------------
+ - behaviour of ImGetImageListElement and ImSetImageListElement
+ has changed - list items are now cloned rather than referenced,
+ because of this ImFreeImageListKeepImages was no longer needed
+ and was removed
+ - many function headers were changed - mainly pointers were
+ replaced with var and const parameters
+
+ -- 0.13 -----------------------------------------------------
+ - added TestImagesInList function and new 0.13 functions
+ - images were not freed when image list was resized in ImSetImageListSize
+ - ImSaveMultiImageTo* recreated the input image list with size = 0
+
+}
+end.
+
diff --git a/Imaging/ImagingFormats.pas b/Imaging/ImagingFormats.pas
index 54b10b6..717e629 100644
--- a/Imaging/ImagingFormats.pas
+++ b/Imaging/ImagingFormats.pas
@@ -1,4288 +1,4288 @@
-{
- $Id: ImagingFormats.pas 174 2009-09-08 09:37:59Z galfar $
- Vampyre Imaging Library
- by Marek Mauder
- http://imaginglib.sourceforge.net
-
- The contents of this file are used with permission, subject to the Mozilla
- Public License Version 1.1 (the "License"); you may not use this file except
- in compliance with the License. You may obtain a copy of the License at
- http://www.mozilla.org/MPL/MPL-1.1.html
-
- Software distributed under the License is distributed on an "AS IS" basis,
- WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
- the specific language governing rights and limitations under the License.
-
- Alternatively, the contents of this file may be used under the terms of the
- GNU Lesser General Public License (the "LGPL License"), in which case the
- provisions of the LGPL License are applicable instead of those above.
- If you wish to allow use of your version of this file only under the terms
- of the LGPL License and not to allow others to use your version of this file
- under the MPL, indicate your decision by deleting the provisions above and
- replace them with the notice and other provisions required by the LGPL
- License. If you do not delete the provisions above, a recipient may use
- your version of this file under either the MPL or the LGPL License.
-
- For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
-}
-
-{ This unit manages information about all image data formats and contains
- low level format conversion, manipulation, and other related functions.}
-unit ImagingFormats;
-
-{$I ImagingOptions.inc}
-
-interface
-
-uses
- ImagingTypes, Imaging, ImagingUtility;
-
-type
- TImageFormatInfoArray = array[TImageFormat] of PImageFormatInfo;
- PImageFormatInfoArray = ^TImageFormatInfoArray;
-
-
-{ Additional image manipulation functions (usually used internally by Imaging unit) }
-
-type
- { Color reduction operations.}
- TReduceColorsAction = (raCreateHistogram, raUpdateHistogram, raMakeColorMap,
- raMapImage);
- TReduceColorsActions = set of TReduceColorsAction;
-const
- AllReduceColorsActions = [raCreateHistogram, raUpdateHistogram,
- raMakeColorMap, raMapImage];
-{ Reduces the number of colors of source. Src is bits of source image
- (ARGB or floating point) and Dst is in some indexed format. MaxColors
- is the number of colors to which reduce and DstPal is palette to which
- the resulting colors are written and it must be allocated to at least
- MaxColors entries. ChannelMask is 'anded' with every pixel's channel value
- when creating color histogram. If $FF is used all 8bits of color channels
- are used which can be slow for large images with many colors so you can
- use lower masks to speed it up.}
-procedure ReduceColorsMedianCut(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
- DstInfo: PImageFormatInfo; MaxColors: LongInt; ChannelMask: Byte;
- DstPal: PPalette32; Actions: TReduceColorsActions = AllReduceColorsActions);
-{ Stretches rectangle in source image to rectangle in destination image
- using nearest neighbor filtering. It is fast but results look blocky
- because there is no interpolation used. SrcImage and DstImage must be
- in the same data format. Works for all data formats except special formats.}
-procedure StretchNearest(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
- SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
- DstHeight: LongInt);
-type
- { Built-in sampling filters.}
- TSamplingFilter = (sfNearest, sfLinear, sfCosine, sfHermite, sfQuadratic,
- sfGaussian, sfSpline, sfLanczos, sfMitchell, sfCatmullRom);
- { Type of custom sampling function}
- TFilterFunction = function(Value: Single): Single;
-const
- { Default resampling filter used for bicubic resizing.}
- DefaultCubicFilter = sfCatmullRom;
-var
- { Built-in filter functions.}
- SamplingFilterFunctions: array[TSamplingFilter] of TFilterFunction;
- { Default radii of built-in filter functions.}
- SamplingFilterRadii: array[TSamplingFilter] of Single;
-
-{ Stretches rectangle in source image to rectangle in destination image
- with resampling. One of built-in resampling filters defined by
- Filter is used. Set WrapEdges to True for seamlessly tileable images.
- SrcImage and DstImage must be in the same data format.
- Works for all data formats except special and indexed formats.}
-procedure StretchResample(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
- SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
- DstHeight: LongInt; Filter: TSamplingFilter; WrapEdges: Boolean = False); overload;
-{ Stretches rectangle in source image to rectangle in destination image
- with resampling. You can use custom sampling function and filter radius.
- Set WrapEdges to True for seamlessly tileable images. SrcImage and DstImage
- must be in the same data format.
- Works for all data formats except special and indexed formats.}
-procedure StretchResample(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
- SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
- DstHeight: LongInt; Filter: TFilterFunction; Radius: Single;
- WrapEdges: Boolean = False); overload;
-{ Helper for functions that create mipmap levels. BiggerLevel is
- valid image and SmallerLevel is empty zeroed image. SmallerLevel is created
- with Width and Height dimensions and it is filled with pixels of BiggerLevel
- using resampling filter specified by ImagingMipMapFilter option.
- Uses StretchNearest and StretchResample internally so the same image data format
- limitations apply.}
-procedure FillMipMapLevel(const BiggerLevel: TImageData; Width, Height: LongInt;
- var SmallerLevel: TImageData);
-
-
-{ Various helper & support functions }
-
-{ Copies Src pixel to Dest pixel. It is faster than System.Move procedure.}
-procedure CopyPixel(Src, Dest: Pointer; BytesPerPixel: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
-{ Compares Src pixel and Dest pixel. It is faster than SysUtils.CompareMem function.}
-function ComparePixels(PixelA, PixelB: Pointer; BytesPerPixel: LongInt): Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF}
-{ Translates pixel color in SrcFormat to DstFormat.}
-procedure TranslatePixel(SrcPixel, DstPixel: Pointer; SrcFormat,
- DstFormat: TImageFormat; SrcPalette, DstPalette: PPalette32);
-{ Clamps floating point pixel channel values to [0.0, 1.0] range.}
-procedure ClampFloatPixel(var PixF: TColorFPRec); {$IFDEF USE_INLINE}inline;{$ENDIF}
-
-{ Adds padding bytes at the ends of scanlines. Bpp is the number of bytes per
- pixel of source and WidthBytes is the number of bytes per scanlines of dest.}
-procedure AddPadBytes(DataIn: Pointer; DataOut: Pointer; Width, Height,
- Bpp, WidthBytes: LongInt);
-{ Removes padding from image with scanlines that have aligned sizes. Bpp is
- the number of bytes per pixel of dest and WidthBytes is the number of bytes
- per scanlines of source.}
-procedure RemovePadBytes(DataIn: Pointer; DataOut: Pointer; Width, Height,
- Bpp, WidthBytes: LongInt);
-
-{ Converts 1bit image data to 8bit (without scaling). Used by file
- loaders for formats supporting 1bit images.}
-procedure Convert1To8(DataIn, DataOut: Pointer; Width, Height,
- WidthBytes: LongInt);
-{ Converts 2bit image data to 8bit (without scaling). Used by file
- loaders for formats supporting 2bit images.}
-procedure Convert2To8(DataIn, DataOut: Pointer; Width, Height,
- WidthBytes: LongInt);
-{ Converts 4bit image data to 8bit (without scaling). Used by file
- loaders for formats supporting 4bit images.}
-procedure Convert4To8(DataIn, DataOut: Pointer; Width, Height,
- WidthBytes: LongInt);
-
-{ Helper function for image file loaders. Some 15 bit images (targas, bitmaps)
- may contain 1 bit alpha but there is no indication of it. This function checks
- all 16 bit(should be X1R5G5B5 or A1R5G5B5 format) pixels and some of them have
- alpha bit set it returns True, otherwise False.}
-function Has16BitImageAlpha(NumPixels: LongInt; Data: PWord): Boolean;
-{ Helper function for image file loaders. This function checks is similar
- to Has16BitImageAlpha but works with A8R8G8B8 format.}
-function Has32BitImageAlpha(NumPixels: LongInt; Data: PLongWord): Boolean;
-{ Provides indexed access to each line of pixels. Does not work with special
- format images.}
-function GetScanLine(ImageBits: Pointer; const FormatInfo: TImageFormatInfo;
- LineWidth, Index: LongInt): Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF}
-{ Returns True if Format is valid image data format identifier.}
-function IsImageFormatValid(Format: TImageFormat): Boolean;
-
-{ Converts 16bit half floating point value to 32bit Single.}
-function HalfToFloat(Half: THalfFloat): Single;
-{ Converts 32bit Single to 16bit half floating point.}
-function FloatToHalf(Float: Single): THalfFloat;
-
-{ Converts half float color value to single-precision floating point color.}
-function ColorHalfToFloat(ColorHF: TColorHFRec): TColorFPRec; {$IFDEF USE_INLINE}inline;{$ENDIF}
-{ Converts single-precision floating point color to half float color.}
-function ColorFloatToHalf(ColorFP: TColorFPRec): TColorHFRec; {$IFDEF USE_INLINE}inline;{$ENDIF}
-
-{ Makes image PalEntries x 1 big where each pixel has color of one pal entry.}
-procedure VisualizePalette(Pal: PPalette32; Entries: Integer; out PalImage: TImageData);
-
-type
- TPointRec = record
- Pos: LongInt;
- Weight: Single;
- end;
- TCluster = array of TPointRec;
- TMappingTable = array of TCluster;
-
-{ Helper function for resampling.}
-function BuildMappingTable(DstLow, DstHigh, SrcLow, SrcHigh, SrcImageWidth: LongInt;
- Filter: TFilterFunction; Radius: Single; WrapEdges: Boolean): TMappingTable;
-{ Helper function for resampling.}
-procedure FindExtremes(const Map: TMappingTable; var MinPos, MaxPos: LongInt);
-
-
-{ Pixel readers/writers for different image formats }
-
-{ Returns pixel of image in any ARGB format. Channel values are scaled to 16 bits.}
-procedure ChannelGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
- var Pix: TColor64Rec);
-{ Sets pixel of image in any ARGB format. Channel values must be scaled to 16 bits.}
-procedure ChannelSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
- const Pix: TColor64Rec);
-
-{ Returns pixel of image in any grayscale format. Gray value is scaled to 64 bits
- and alpha to 16 bits.}
-procedure GrayGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
- var Gray: TColor64Rec; var Alpha: Word);
-{ Sets pixel of image in any grayscale format. Gray value must be scaled to 64 bits
- and alpha to 16 bits.}
-procedure GraySetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
- const Gray: TColor64Rec; Alpha: Word);
-
-{ Returns pixel of image in any floating point format. Channel values are
- in range <0.0, 1.0>.}
-procedure FloatGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
- var Pix: TColorFPRec);
-{ Sets pixel of image in any floating point format. Channel values must be
- in range <0.0, 1.0>.}
-procedure FloatSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
- const Pix: TColorFPRec);
-
-{ Returns pixel of image in any indexed format. Returned value is index to
- the palette.}
-procedure IndexGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
- var Index: LongWord);
-{ Sets pixel of image in any indexed format. Index is index to the palette.}
-procedure IndexSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
- Index: LongWord);
-
-
-{ Pixel readers/writers for 32bit and FP colors}
-
-{ Function for getting pixel colors. Native pixel is read from Image and
- then translated to 32 bit ARGB.}
-function GetPixel32Generic(Bits: Pointer; Info: PImageFormatInfo;
- Palette: PPalette32): TColor32Rec;
-{ Procedure for setting pixel colors. Input 32 bit ARGB color is translated to
- native format and then written to Image.}
-procedure SetPixel32Generic(Bits: Pointer; Info: PImageFormatInfo;
- Palette: PPalette32; const Color: TColor32Rec);
-{ Function for getting pixel colors. Native pixel is read from Image and
- then translated to FP ARGB.}
-function GetPixelFPGeneric(Bits: Pointer; Info: PImageFormatInfo;
- Palette: PPalette32): TColorFPRec;
-{ Procedure for setting pixel colors. Input FP ARGB color is translated to
- native format and then written to Image.}
-procedure SetPixelFPGeneric(Bits: Pointer; Info: PImageFormatInfo;
- Palette: PPalette32; const Color: TColorFPRec);
-
-
-{ Image format conversion functions }
-
-{ Converts any ARGB format to any ARGB format.}
-procedure ChannelToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
- DstInfo: PImageFormatInfo);
-{ Converts any ARGB format to any grayscale format.}
-procedure ChannelToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
- DstInfo: PImageFormatInfo);
-{ Converts any ARGB format to any floating point format.}
-procedure ChannelToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
- DstInfo: PImageFormatInfo);
-{ Converts any ARGB format to any indexed format.}
-procedure ChannelToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
- DstInfo: PImageFormatInfo; DstPal: PPalette32);
-
-{ Converts any grayscale format to any grayscale format.}
-procedure GrayToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
- DstInfo: PImageFormatInfo);
-{ Converts any grayscale format to any ARGB format.}
-procedure GrayToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
- DstInfo: PImageFormatInfo);
-{ Converts any grayscale format to any floating point format.}
-procedure GrayToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
- DstInfo: PImageFormatInfo);
-{ Converts any grayscale format to any indexed format.}
-procedure GrayToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
- DstInfo: PImageFormatInfo; DstPal: PPalette32);
-
-{ Converts any floating point format to any floating point format.}
-procedure FloatToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
- DstInfo: PImageFormatInfo);
-{ Converts any floating point format to any ARGB format.}
-procedure FloatToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
- DstInfo: PImageFormatInfo);
-{ Converts any floating point format to any grayscale format.}
-procedure FloatToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
- DstInfo: PImageFormatInfo);
-{ Converts any floating point format to any indexed format.}
-procedure FloatToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
- DstInfo: PImageFormatInfo; DstPal: PPalette32);
-
-{ Converts any indexed format to any indexed format.}
-procedure IndexToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
- DstInfo: PImageFormatInfo; SrcPal, DstPal: PPalette32);
-{ Converts any indexed format to any ARGB format.}
-procedure IndexToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
- DstInfo: PImageFormatInfo; SrcPal: PPalette32);
-{ Converts any indexed format to any grayscale format.}
-procedure IndexToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
- DstInfo: PImageFormatInfo; SrcPal: PPalette32);
-{ Converts any indexed format to any floating point format.}
-procedure IndexToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
- DstInfo: PImageFormatInfo; SrcPal: PPalette32);
-
-
-{ Color constructor functions }
-
-{ Constructs TColor24Rec color.}
-function Color24(R, G, B: Byte): TColor24Rec; {$IFDEF USE_INLINE}inline;{$ENDIF}
-{ Constructs TColor32Rec color.}
-function Color32(A, R, G, B: Byte): TColor32Rec; {$IFDEF USE_INLINE}inline;{$ENDIF}
-{ Constructs TColor48Rec color.}
-function Color48(R, G, B: Word): TColor48Rec; {$IFDEF USE_INLINE}inline;{$ENDIF}
-{ Constructs TColor64Rec color.}
-function Color64(A, R, G, B: Word): TColor64Rec; {$IFDEF USE_INLINE}inline;{$ENDIF}
-{ Constructs TColorFPRec color.}
-function ColorFP(A, R, G, B: Single): TColorFPRec; {$IFDEF USE_INLINE}inline;{$ENDIF}
-{ Constructs TColorHFRec color.}
-function ColorHF(A, R, G, B: THalfFloat): TColorHFRec; {$IFDEF USE_INLINE}inline;{$ENDIF}
-
-
-{ Special formats conversion functions }
-
-{ Converts image to/from/between special image formats (dxtc, ...).}
-procedure ConvertSpecial(var Image: TImageData; SrcInfo,
- DstInfo: PImageFormatInfo);
-
-
-{ Inits all image format information. Called internally on startup.}
-procedure InitImageFormats(var Infos: TImageFormatInfoArray);
-
-const
- // Grayscale conversion channel weights
- GrayConv: TColorFPRec = (B: 0.114; G: 0.587; R: 0.299; A: 0.0);
-
- // Contants for converting integer colors to floating point
- OneDiv8Bit: Single = 1.0 / 255.0;
- OneDiv16Bit: Single = 1.0 / 65535.0;
-
-implementation
-
-{ TImageFormatInfo member functions }
-
-{ Returns size in bytes of image in given standard format where
- Size = Width * Height * Bpp.}
-function GetStdPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; forward;
-{ Checks if Width and Height are valid for given standard format.}
-procedure CheckStdDimensions(Format: TImageFormat; var Width, Height: LongInt); forward;
-{ Returns size in bytes of image in given DXT format.}
-function GetDXTPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; forward;
-{ Checks if Width and Height are valid for given DXT format. If they are
- not valid, they are changed to pass the check.}
-procedure CheckDXTDimensions(Format: TImageFormat; var Width, Height: LongInt); forward;
-{ Returns size in bytes of image in BTC format.}
-function GetBTCPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; forward;
-
-{ Optimized pixel readers/writers for 32bit and FP colors to be stored in TImageFormatInfo }
-
-function GetPixel32ifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColor32Rec; forward;
-procedure SetPixel32ifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColor32Rec); forward;
-function GetPixelFPifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec; forward;
-procedure SetPixelFPifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec); forward;
-
-function GetPixel32Channel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColor32Rec; forward;
-procedure SetPixel32Channel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColor32Rec); forward;
-function GetPixelFPChannel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec; forward;
-procedure SetPixelFPChannel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec); forward;
-
-function GetPixelFPFloat32(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec; forward;
-procedure SetPixelFPFloat32(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec); forward;
-
-var
- PFR3G3B2: TPixelFormatInfo;
- PFX5R1G1B1: TPixelFormatInfo;
- PFR5G6B5: TPixelFormatInfo;
- PFA1R5G5B5: TPixelFormatInfo;
- PFA4R4G4B4: TPixelFormatInfo;
- PFX1R5G5B5: TPixelFormatInfo;
- PFX4R4G4B4: TPixelFormatInfo;
- FInfos: PImageFormatInfoArray;
-
-var
- // Free Pascal generates hundreds of warnings here
-{$WARNINGS OFF}
-
- // indexed formats
- Index8Info: TImageFormatInfo = (
- Format: ifIndex8;
- Name: 'Index8';
- BytesPerPixel: 1;
- ChannelCount: 1;
- PaletteEntries: 256;
- HasAlphaChannel: True;
- IsIndexed: True;
- GetPixelsSize: GetStdPixelsSize;
- CheckDimensions: CheckStdDimensions;
- GetPixel32: GetPixel32Generic;
- GetPixelFP: GetPixelFPGeneric;
- SetPixel32: SetPixel32Generic;
- SetPixelFP: SetPixelFPGeneric);
-
- // grayscale formats
- Gray8Info: TImageFormatInfo = (
- Format: ifGray8;
- Name: 'Gray8';
- BytesPerPixel: 1;
- ChannelCount: 1;
- HasGrayChannel: True;
- GetPixelsSize: GetStdPixelsSize;
- CheckDimensions: CheckStdDimensions;
- GetPixel32: GetPixel32Channel8Bit;
- GetPixelFP: GetPixelFPChannel8Bit;
- SetPixel32: SetPixel32Channel8Bit;
- SetPixelFP: SetPixelFPChannel8Bit);
-
- A8Gray8Info: TImageFormatInfo = (
- Format: ifA8Gray8;
- Name: 'A8Gray8';
- BytesPerPixel: 2;
- ChannelCount: 2;
- HasGrayChannel: True;
- HasAlphaChannel: True;
- GetPixelsSize: GetStdPixelsSize;
- CheckDimensions: CheckStdDimensions;
- GetPixel32: GetPixel32Channel8Bit;
- GetPixelFP: GetPixelFPChannel8Bit;
- SetPixel32: SetPixel32Channel8Bit;
- SetPixelFP: SetPixelFPChannel8Bit);
-
- Gray16Info: TImageFormatInfo = (
- Format: ifGray16;
- Name: 'Gray16';
- BytesPerPixel: 2;
- ChannelCount: 1;
- HasGrayChannel: True;
- GetPixelsSize: GetStdPixelsSize;
- CheckDimensions: CheckStdDimensions;
- GetPixel32: GetPixel32Generic;
- GetPixelFP: GetPixelFPGeneric;
- SetPixel32: SetPixel32Generic;
- SetPixelFP: SetPixelFPGeneric);
-
- Gray32Info: TImageFormatInfo = (
- Format: ifGray32;
- Name: 'Gray32';
- BytesPerPixel: 4;
- ChannelCount: 1;
- HasGrayChannel: True;
- GetPixelsSize: GetStdPixelsSize;
- CheckDimensions: CheckStdDimensions;
- GetPixel32: GetPixel32Generic;
- GetPixelFP: GetPixelFPGeneric;
- SetPixel32: SetPixel32Generic;
- SetPixelFP: SetPixelFPGeneric);
-
- Gray64Info: TImageFormatInfo = (
- Format: ifGray64;
- Name: 'Gray64';
- BytesPerPixel: 8;
- ChannelCount: 1;
- HasGrayChannel: True;
- GetPixelsSize: GetStdPixelsSize;
- CheckDimensions: CheckStdDimensions;
- GetPixel32: GetPixel32Generic;
- GetPixelFP: GetPixelFPGeneric;
- SetPixel32: SetPixel32Generic;
- SetPixelFP: SetPixelFPGeneric);
-
- A16Gray16Info: TImageFormatInfo = (
- Format: ifA16Gray16;
- Name: 'A16Gray16';
- BytesPerPixel: 4;
- ChannelCount: 2;
- HasGrayChannel: True;
- HasAlphaChannel: True;
- GetPixelsSize: GetStdPixelsSize;
- CheckDimensions: CheckStdDimensions;
- GetPixel32: GetPixel32Generic;
- GetPixelFP: GetPixelFPGeneric;
- SetPixel32: SetPixel32Generic;
- SetPixelFP: SetPixelFPGeneric);
-
- // ARGB formats
- X5R1G1B1Info: TImageFormatInfo = (
- Format: ifX5R1G1B1;
- Name: 'X5R1G1B1';
- BytesPerPixel: 1;
- ChannelCount: 3;
- UsePixelFormat: True;
- PixelFormat: @PFX5R1G1B1;
- GetPixelsSize: GetStdPixelsSize;
- CheckDimensions: CheckStdDimensions;
- GetPixel32: GetPixel32Generic;
- GetPixelFP: GetPixelFPGeneric;
- SetPixel32: SetPixel32Generic;
- SetPixelFP: SetPixelFPGeneric);
-
- R3G3B2Info: TImageFormatInfo = (
- Format: ifR3G3B2;
- Name: 'R3G3B2';
- BytesPerPixel: 1;
- ChannelCount: 3;
- UsePixelFormat: True;
- PixelFormat: @PFR3G3B2;
- GetPixelsSize: GetStdPixelsSize;
- CheckDimensions: CheckStdDimensions;
- GetPixel32: GetPixel32Generic;
- GetPixelFP: GetPixelFPGeneric;
- SetPixel32: SetPixel32Generic;
- SetPixelFP: SetPixelFPGeneric);
-
- R5G6B5Info: TImageFormatInfo = (
- Format: ifR5G6B5;
- Name: 'R5G6B5';
- BytesPerPixel: 2;
- ChannelCount: 3;
- UsePixelFormat: True;
- PixelFormat: @PFR5G6B5;
- GetPixelsSize: GetStdPixelsSize;
- CheckDimensions: CheckStdDimensions;
- GetPixel32: GetPixel32Generic;
- GetPixelFP: GetPixelFPGeneric;
- SetPixel32: SetPixel32Generic;
- SetPixelFP: SetPixelFPGeneric);
-
- A1R5G5B5Info: TImageFormatInfo = (
- Format: ifA1R5G5B5;
- Name: 'A1R5G5B5';
- BytesPerPixel: 2;
- ChannelCount: 4;
- HasAlphaChannel: True;
- UsePixelFormat: True;
- PixelFormat: @PFA1R5G5B5;
- GetPixelsSize: GetStdPixelsSize;
- CheckDimensions: CheckStdDimensions;
- GetPixel32: GetPixel32Generic;
- GetPixelFP: GetPixelFPGeneric;
- SetPixel32: SetPixel32Generic;
- SetPixelFP: SetPixelFPGeneric);
-
- A4R4G4B4Info: TImageFormatInfo = (
- Format: ifA4R4G4B4;
- Name: 'A4R4G4B4';
- BytesPerPixel: 2;
- ChannelCount: 4;
- HasAlphaChannel: True;
- UsePixelFormat: True;
- PixelFormat: @PFA4R4G4B4;
- GetPixelsSize: GetStdPixelsSize;
- CheckDimensions: CheckStdDimensions;
- GetPixel32: GetPixel32Generic;
- GetPixelFP: GetPixelFPGeneric;
- SetPixel32: SetPixel32Generic;
- SetPixelFP: SetPixelFPGeneric);
-
- X1R5G5B5Info: TImageFormatInfo = (
- Format: ifX1R5G5B5;
- Name: 'X1R5G5B5';
- BytesPerPixel: 2;
- ChannelCount: 3;
- UsePixelFormat: True;
- PixelFormat: @PFX1R5G5B5;
- GetPixelsSize: GetStdPixelsSize;
- CheckDimensions: CheckStdDimensions;
- GetPixel32: GetPixel32Generic;
- GetPixelFP: GetPixelFPGeneric;
- SetPixel32: SetPixel32Generic;
- SetPixelFP: SetPixelFPGeneric);
-
- X4R4G4B4Info: TImageFormatInfo = (
- Format: ifX4R4G4B4;
- Name: 'X4R4G4B4';
- BytesPerPixel: 2;
- ChannelCount: 3;
- UsePixelFormat: True;
- PixelFormat: @PFX4R4G4B4;
- GetPixelsSize: GetStdPixelsSize;
- CheckDimensions: CheckStdDimensions;
- GetPixel32: GetPixel32Generic;
- GetPixelFP: GetPixelFPGeneric;
- SetPixel32: SetPixel32Generic;
- SetPixelFP: SetPixelFPGeneric);
-
- R8G8B8Info: TImageFormatInfo = (
- Format: ifR8G8B8;
- Name: 'R8G8B8';
- BytesPerPixel: 3;
- ChannelCount: 3;
- GetPixelsSize: GetStdPixelsSize;
- CheckDimensions: CheckStdDimensions;
- GetPixel32: GetPixel32Channel8Bit;
- GetPixelFP: GetPixelFPChannel8Bit;
- SetPixel32: SetPixel32Channel8Bit;
- SetPixelFP: SetPixelFPChannel8Bit);
-
- A8R8G8B8Info: TImageFormatInfo = (
- Format: ifA8R8G8B8;
- Name: 'A8R8G8B8';
- BytesPerPixel: 4;
- ChannelCount: 4;
- HasAlphaChannel: True;
- GetPixelsSize: GetStdPixelsSize;
- CheckDimensions: CheckStdDimensions;
- GetPixel32: GetPixel32ifA8R8G8B8;
- GetPixelFP: GetPixelFPifA8R8G8B8;
- SetPixel32: SetPixel32ifA8R8G8B8;
- SetPixelFP: SetPixelFPifA8R8G8B8);
-
- X8R8G8B8Info: TImageFormatInfo = (
- Format: ifX8R8G8B8;
- Name: 'X8R8G8B8';
- BytesPerPixel: 4;
- ChannelCount: 3;
- GetPixelsSize: GetStdPixelsSize;
- CheckDimensions: CheckStdDimensions;
- GetPixel32: GetPixel32Channel8Bit;
- GetPixelFP: GetPixelFPChannel8Bit;
- SetPixel32: SetPixel32Channel8Bit;
- SetPixelFP: SetPixelFPChannel8Bit);
-
- R16G16B16Info: TImageFormatInfo = (
- Format: ifR16G16B16;
- Name: 'R16G16B16';
- BytesPerPixel: 6;
- ChannelCount: 3;
- RBSwapFormat: ifB16G16R16;
- GetPixelsSize: GetStdPixelsSize;
- CheckDimensions: CheckStdDimensions;
- GetPixel32: GetPixel32Generic;
- GetPixelFP: GetPixelFPGeneric;
- SetPixel32: SetPixel32Generic;
- SetPixelFP: SetPixelFPGeneric);
-
- A16R16G16B16Info: TImageFormatInfo = (
- Format: ifA16R16G16B16;
- Name: 'A16R16G16B16';
- BytesPerPixel: 8;
- ChannelCount: 4;
- HasAlphaChannel: True;
- RBSwapFormat: ifA16B16G16R16;
- GetPixelsSize: GetStdPixelsSize;
- CheckDimensions: CheckStdDimensions;
- GetPixel32: GetPixel32Generic;
- GetPixelFP: GetPixelFPGeneric;
- SetPixel32: SetPixel32Generic;
- SetPixelFP: SetPixelFPGeneric);
-
- B16G16R16Info: TImageFormatInfo = (
- Format: ifB16G16R16;
- Name: 'B16G16R16';
- BytesPerPixel: 6;
- ChannelCount: 3;
- IsRBSwapped: True;
- RBSwapFormat: ifR16G16B16;
- GetPixelsSize: GetStdPixelsSize;
- CheckDimensions: CheckStdDimensions;
- GetPixel32: GetPixel32Generic;
- GetPixelFP: GetPixelFPGeneric;
- SetPixel32: SetPixel32Generic;
- SetPixelFP: SetPixelFPGeneric);
-
- A16B16G16R16Info: TImageFormatInfo = (
- Format: ifA16B16G16R16;
- Name: 'A16B16G16R16';
- BytesPerPixel: 8;
- ChannelCount: 4;
- HasAlphaChannel: True;
- IsRBSwapped: True;
- RBSwapFormat: ifA16R16G16B16;
- GetPixelsSize: GetStdPixelsSize;
- CheckDimensions: CheckStdDimensions;
- GetPixel32: GetPixel32Generic;
- GetPixelFP: GetPixelFPGeneric;
- SetPixel32: SetPixel32Generic;
- SetPixelFP: SetPixelFPGeneric);
-
- // floating point formats
- R32FInfo: TImageFormatInfo = (
- Format: ifR32F;
- Name: 'R32F';
- BytesPerPixel: 4;
- ChannelCount: 1;
- IsFloatingPoint: True;
- GetPixelsSize: GetStdPixelsSize;
- CheckDimensions: CheckStdDimensions;
- GetPixel32: GetPixel32Generic;
- GetPixelFP: GetPixelFPFloat32;
- SetPixel32: SetPixel32Generic;
- SetPixelFP: SetPixelFPFloat32);
-
- A32R32G32B32FInfo: TImageFormatInfo = (
- Format: ifA32R32G32B32F;
- Name: 'A32R32G32B32F';
- BytesPerPixel: 16;
- ChannelCount: 4;
- HasAlphaChannel: True;
- IsFloatingPoint: True;
- RBSwapFormat: ifA32B32G32R32F;
- GetPixelsSize: GetStdPixelsSize;
- CheckDimensions: CheckStdDimensions;
- GetPixel32: GetPixel32Generic;
- GetPixelFP: GetPixelFPFloat32;
- SetPixel32: SetPixel32Generic;
- SetPixelFP: SetPixelFPFloat32);
-
- A32B32G32R32FInfo: TImageFormatInfo = (
- Format: ifA32B32G32R32F;
- Name: 'A32B32G32R32F';
- BytesPerPixel: 16;
- ChannelCount: 4;
- HasAlphaChannel: True;
- IsFloatingPoint: True;
- IsRBSwapped: True;
- RBSwapFormat: ifA32R32G32B32F;
- GetPixelsSize: GetStdPixelsSize;
- CheckDimensions: CheckStdDimensions;
- GetPixel32: GetPixel32Generic;
- GetPixelFP: GetPixelFPFloat32;
- SetPixel32: SetPixel32Generic;
- SetPixelFP: SetPixelFPFloat32);
-
- R16FInfo: TImageFormatInfo = (
- Format: ifR16F;
- Name: 'R16F';
- BytesPerPixel: 2;
- ChannelCount: 1;
- IsFloatingPoint: True;
- GetPixelsSize: GetStdPixelsSize;
- CheckDimensions: CheckStdDimensions;
- GetPixel32: GetPixel32Generic;
- GetPixelFP: GetPixelFPGeneric;
- SetPixel32: SetPixel32Generic;
- SetPixelFP: SetPixelFPGeneric);
-
- A16R16G16B16FInfo: TImageFormatInfo = (
- Format: ifA16R16G16B16F;
- Name: 'A16R16G16B16F';
- BytesPerPixel: 8;
- ChannelCount: 4;
- HasAlphaChannel: True;
- IsFloatingPoint: True;
- RBSwapFormat: ifA16B16G16R16F;
- GetPixelsSize: GetStdPixelsSize;
- CheckDimensions: CheckStdDimensions;
- GetPixel32: GetPixel32Generic;
- GetPixelFP: GetPixelFPGeneric;
- SetPixel32: SetPixel32Generic;
- SetPixelFP: SetPixelFPGeneric);
-
- A16B16G16R16FInfo: TImageFormatInfo = (
- Format: ifA16B16G16R16F;
- Name: 'A16B16G16R16F';
- BytesPerPixel: 8;
- ChannelCount: 4;
- HasAlphaChannel: True;
- IsFloatingPoint: True;
- IsRBSwapped: True;
- RBSwapFormat: ifA16R16G16B16F;
- GetPixelsSize: GetStdPixelsSize;
- CheckDimensions: CheckStdDimensions;
- GetPixel32: GetPixel32Generic;
- GetPixelFP: GetPixelFPGeneric;
- SetPixel32: SetPixel32Generic;
- SetPixelFP: SetPixelFPGeneric);
-
- // special formats
- DXT1Info: TImageFormatInfo = (
- Format: ifDXT1;
- Name: 'DXT1';
- ChannelCount: 4;
- HasAlphaChannel: True;
- IsSpecial: True;
- GetPixelsSize: GetDXTPixelsSize;
- CheckDimensions: CheckDXTDimensions;
- SpecialNearestFormat: ifA8R8G8B8);
-
- DXT3Info: TImageFormatInfo = (
- Format: ifDXT3;
- Name: 'DXT3';
- ChannelCount: 4;
- HasAlphaChannel: True;
- IsSpecial: True;
- GetPixelsSize: GetDXTPixelsSize;
- CheckDimensions: CheckDXTDimensions;
- SpecialNearestFormat: ifA8R8G8B8);
-
- DXT5Info: TImageFormatInfo = (
- Format: ifDXT5;
- Name: 'DXT5';
- ChannelCount: 4;
- HasAlphaChannel: True;
- IsSpecial: True;
- GetPixelsSize: GetDXTPixelsSize;
- CheckDimensions: CheckDXTDimensions;
- SpecialNearestFormat: ifA8R8G8B8);
-
- BTCInfo: TImageFormatInfo = (
- Format: ifBTC;
- Name: 'BTC';
- ChannelCount: 1;
- HasAlphaChannel: False;
- IsSpecial: True;
- GetPixelsSize: GetBTCPixelsSize;
- CheckDimensions: CheckDXTDimensions;
- SpecialNearestFormat: ifGray8);
-
- ATI1NInfo: TImageFormatInfo = (
- Format: ifATI1N;
- Name: 'ATI1N';
- ChannelCount: 1;
- HasAlphaChannel: False;
- IsSpecial: True;
- GetPixelsSize: GetDXTPixelsSize;
- CheckDimensions: CheckDXTDimensions;
- SpecialNearestFormat: ifGray8);
-
- ATI2NInfo: TImageFormatInfo = (
- Format: ifATI2N;
- Name: 'ATI2N';
- ChannelCount: 2;
- HasAlphaChannel: False;
- IsSpecial: True;
- GetPixelsSize: GetDXTPixelsSize;
- CheckDimensions: CheckDXTDimensions;
- SpecialNearestFormat: ifA8R8G8B8);
-
-{$WARNINGS ON}
-
-function PixelFormat(ABitCount, RBitCount, GBitCount, BBitCount: Byte): TPixelFormatInfo; forward;
-
-procedure InitImageFormats(var Infos: TImageFormatInfoArray);
-begin
- FInfos := @Infos;
-
- Infos[ifDefault] := @A8R8G8B8Info;
- // indexed formats
- Infos[ifIndex8] := @Index8Info;
- // grayscale formats
- Infos[ifGray8] := @Gray8Info;
- Infos[ifA8Gray8] := @A8Gray8Info;
- Infos[ifGray16] := @Gray16Info;
- Infos[ifGray32] := @Gray32Info;
- Infos[ifGray64] := @Gray64Info;
- Infos[ifA16Gray16] := @A16Gray16Info;
- // ARGB formats
- Infos[ifX5R1G1B1] := @X5R1G1B1Info;
- Infos[ifR3G3B2] := @R3G3B2Info;
- Infos[ifR5G6B5] := @R5G6B5Info;
- Infos[ifA1R5G5B5] := @A1R5G5B5Info;
- Infos[ifA4R4G4B4] := @A4R4G4B4Info;
- Infos[ifX1R5G5B5] := @X1R5G5B5Info;
- Infos[ifX4R4G4B4] := @X4R4G4B4Info;
- Infos[ifR8G8B8] := @R8G8B8Info;
- Infos[ifA8R8G8B8] := @A8R8G8B8Info;
- Infos[ifX8R8G8B8] := @X8R8G8B8Info;
- Infos[ifR16G16B16] := @R16G16B16Info;
- Infos[ifA16R16G16B16] := @A16R16G16B16Info;
- Infos[ifB16G16R16] := @B16G16R16Info;
- Infos[ifA16B16G16R16] := @A16B16G16R16Info;
- // floating point formats
- Infos[ifR32F] := @R32FInfo;
- Infos[ifA32R32G32B32F] := @A32R32G32B32FInfo;
- Infos[ifA32B32G32R32F] := @A32B32G32R32FInfo;
- Infos[ifR16F] := @R16FInfo;
- Infos[ifA16R16G16B16F] := @A16R16G16B16FInfo;
- Infos[ifA16B16G16R16F] := @A16B16G16R16FInfo;
- // special formats
- Infos[ifDXT1] := @DXT1Info;
- Infos[ifDXT3] := @DXT3Info;
- Infos[ifDXT5] := @DXT5Info;
- Infos[ifBTC] := @BTCInfo;
- Infos[ifATI1N] := @ATI1NInfo;
- Infos[ifATI2N] := @ATI2NInfo;
-
- PFR3G3B2 := PixelFormat(0, 3, 3, 2);
- PFX5R1G1B1 := PixelFormat(0, 1, 1, 1);
- PFR5G6B5 := PixelFormat(0, 5, 6, 5);
- PFA1R5G5B5 := PixelFormat(1, 5, 5, 5);
- PFA4R4G4B4 := PixelFormat(4, 4, 4, 4);
- PFX1R5G5B5 := PixelFormat(0, 5, 5, 5);
- PFX4R4G4B4 := PixelFormat(0, 4, 4, 4);
-end;
-
-
-{ Internal unit helper functions }
-
-function PixelFormat(ABitCount, RBitCount, GBitCount, BBitCount: Byte): TPixelFormatInfo;
-begin
- Result.ABitMask := ((1 shl ABitCount) - 1) shl (RBitCount + GBitCount +
- BBitCount);
- Result.RBitMask := ((1 shl RBitCount) - 1) shl (GBitCount + BBitCount);
- Result.GBitMask := ((1 shl GBitCount) - 1) shl (BBitCount);
- Result.BBitMask := (1 shl BBitCount) - 1;
- Result.ABitCount := ABitCount;
- Result.RBitCount := RBitCount;
- Result.GBitCount := GBitCount;
- Result.BBitCount := BBitCount;
- Result.AShift := RBitCount + GBitCount + BBitCount;
- Result.RShift := GBitCount + BBitCount;
- Result.GShift := BBitCount;
- Result.BShift := 0;
- Result.ARecDiv := Max(1, Pow2Int(Result.ABitCount) - 1);
- Result.RRecDiv := Max(1, Pow2Int(Result.RBitCount) - 1);
- Result.GRecDiv := Max(1, Pow2Int(Result.GBitCount) - 1);
- Result.BRecDiv := Max(1, Pow2Int(Result.BBitCount) - 1);
-end;
-
-function PixelFormatMask(ABitMask, RBitMask, GBitMask, BBitMask: LongWord): TPixelFormatInfo;
-
- function GetBitCount(B: LongWord): LongWord;
- var
- I: LongWord;
- begin
- I := 0;
- while (I < 31) and (((1 shl I) and B) = 0) do
- Inc(I);
- Result := 0;
- while ((1 shl I) and B) <> 0 do
- begin
- Inc(I);
- Inc(Result);
- end;
- end;
-
-begin
- Result := PixelFormat(GetBitCount(ABitMask), GetBitCount(RBitMask),
- GetBitCount(GBitMask), GetBitCount(BBitMask));
-end;
-
-function PFSetARGB(const PF: TPixelFormatInfo; A, R, G, B: Byte): TColor32;
-{$IFDEF USE_INLINE}inline;{$ENDIF}
-begin
- with PF do
- Result :=
- (A shl ABitCount shr 8 shl AShift) or
- (R shl RBitCount shr 8 shl RShift) or
- (G shl GBitCount shr 8 shl GShift) or
- (B shl BBitCount shr 8 shl BShift);
-end;
-
-procedure PFGetARGB(const PF: TPixelFormatInfo; Color: LongWord;
- var A, R, G, B: Byte); {$IFDEF USE_INLINE}inline;{$ENDIF}
-begin
- with PF do
- begin
- A := (Color and ABitMask shr AShift) * 255 div ARecDiv;
- R := (Color and RBitMask shr RShift) * 255 div RRecDiv;
- G := (Color and GBitMask shr GShift) * 255 div GRecDiv;
- B := (Color and BBitMask shl BShift) * 255 div BRecDiv;
- end;
-end;
-
-function PFSetColor(const PF: TPixelFormatInfo; ARGB: TColor32): LongWord;
-{$IFDEF USE_INLINE}inline;{$ENDIF}
-begin
- with PF do
- Result :=
- (Byte(ARGB shr 24) shl ABitCount shr 8 shl AShift) or
- (Byte(ARGB shr 16) shl RBitCount shr 8 shl RShift) or
- (Byte(ARGB shr 8) shl GBitCount shr 8 shl GShift) or
- (Byte(ARGB) shl BBitCount shr 8 shl BShift);
-end;
-
-function PFGetColor(const PF: TPixelFormatInfo; Color: LongWord): TColor32;
-{$IFDEF USE_INLINE}inline;{$ENDIF}
-begin
- with PF, TColor32Rec(Result) do
- begin
- A := (Color and ABitMask shr AShift) * 255 div ARecDiv;
- R := (Color and RBitMask shr RShift) * 255 div RRecDiv;
- G := (Color and GBitMask shr GShift) * 255 div GRecDiv;
- B := (Color and BBitMask shl BShift) * 255 div BRecDiv;
- end;
-end;
-
-
-{ Color constructor functions }
-
-
-function Color24(R, G, B: Byte): TColor24Rec;
-begin
- Result.R := R;
- Result.G := G;
- Result.B := B;
-end;
-
-function Color32(A, R, G, B: Byte): TColor32Rec;
-begin
- Result.A := A;
- Result.R := R;
- Result.G := G;
- Result.B := B;
-end;
-
-function Color48(R, G, B: Word): TColor48Rec;
-begin
- Result.R := R;
- Result.G := G;
- Result.B := B;
-end;
-
-function Color64(A, R, G, B: Word): TColor64Rec;
-begin
- Result.A := A;
- Result.R := R;
- Result.G := G;
- Result.B := B;
-end;
-
-function ColorFP(A, R, G, B: Single): TColorFPRec;
-begin
- Result.A := A;
- Result.R := R;
- Result.G := G;
- Result.B := B;
-end;
-
-function ColorHF(A, R, G, B: THalfFloat): TColorHFRec;
-begin
- Result.A := A;
- Result.R := R;
- Result.G := G;
- Result.B := B;
-end;
-
-
-{ Additional image manipulation functions (usually used internally by Imaging unit) }
-
-const
- MaxPossibleColors = 4096;
- HashSize = 32768;
- AlphaWeight = 1024;
- RedWeight = 612;
- GreenWeight = 1202;
- BlueWeight = 234;
-
-type
- PColorBin = ^TColorBin;
- TColorBin = record
- Color: TColor32Rec;
- Number: LongInt;
- Next: PColorBin;
- end;
-
- THashTable = array[0..HashSize - 1] of PColorBin;
-
- TColorBox = record
- AMin, AMax,
- RMin, RMax,
- GMin, GMax,
- BMin, BMax: LongInt;
- Total: LongInt;
- Represented: TColor32Rec;
- List: PColorBin;
- end;
-
-var
- Table: THashTable;
- Box: array[0..MaxPossibleColors - 1] of TColorBox;
- Boxes: LongInt;
- BoxesCreated: Boolean = False;
-
-procedure ReduceColorsMedianCut(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
- DstInfo: PImageFormatInfo; MaxColors: LongInt; ChannelMask: Byte;
- DstPal: PPalette32; Actions: TReduceColorsActions);
-
- procedure CreateHistogram (Src: PByte; SrcInfo: PImageFormatInfo;
- ChannelMask: Byte);
- var
- A, R, G, B: Byte;
- I, Addr: LongInt;
- PC: PColorBin;
- Col: TColor32Rec;
- begin
- for I := 0 to NumPixels - 1 do
- begin
- Col := GetPixel32Generic(Src, SrcInfo, nil);
- A := Col.A and ChannelMask;
- R := Col.R and ChannelMask;
- G := Col.G and ChannelMask;
- B := Col.B and ChannelMask;
-
- Addr := (A + 11 * B + 59 * R + 119 * G) mod HashSize;
- PC := Table[Addr];
-
- while (PC <> nil) and ((PC.Color.R <> R) or (PC.Color.G <> G) or
- (PC.Color.B <> B) or (PC.Color.A <> A)) do
- PC := PC.Next;
-
- if PC = nil then
- begin
- New(PC);
- PC.Color.R := R;
- PC.Color.G := G;
- PC.Color.B := B;
- PC.Color.A := A;
- PC.Number := 1;
- PC.Next := Table[Addr];
- Table[Addr] := PC;
- end
- else
- Inc(PC^.Number);
- Inc(Src, SrcInfo.BytesPerPixel);
- end;
- end;
-
- procedure InitBox (var Box : TColorBox);
- begin
- Box.AMin := 256;
- Box.RMin := 256;
- Box.GMin := 256;
- Box.BMin := 256;
- Box.AMax := -1;
- Box.RMax := -1;
- Box.GMax := -1;
- Box.BMax := -1;
- Box.Total := 0;
- Box.List := nil;
- end;
-
- procedure ChangeBox (var Box: TColorBox; const C: TColorBin);
- begin
- with C.Color do
- begin
- if A < Box.AMin then Box.AMin := A;
- if A > Box.AMax then Box.AMax := A;
- if B < Box.BMin then Box.BMin := B;
- if B > Box.BMax then Box.BMax := B;
- if G < Box.GMin then Box.GMin := G;
- if G > Box.GMax then Box.GMax := G;
- if R < Box.RMin then Box.RMin := R;
- if R > Box.RMax then Box.RMax := R;
- end;
- Inc(Box.Total, C.Number);
- end;
-
- procedure MakeColormap;
- var
- I, J: LongInt;
- CP, Pom: PColorBin;
- Cut, LargestIdx, Largest, Size, S: LongInt;
- CutA, CutR, CutG, CutB: Boolean;
- SumA, SumR, SumG, SumB: LongInt;
- Temp: TColorBox;
- begin
- I := 0;
- Boxes := 1;
- LargestIdx := 0;
- while (I < HashSize) and (Table[I] = nil) do
- Inc(i);
- if I < HashSize then
- begin
- // put all colors into Box[0]
- InitBox(Box[0]);
- repeat
- CP := Table[I];
- while CP.Next <> nil do
- begin
- ChangeBox(Box[0], CP^);
- CP := CP.Next;
- end;
- ChangeBox(Box[0], CP^);
- CP.Next := Box[0].List;
- Box[0].List := Table[I];
- Table[I] := nil;
- repeat
- Inc(I)
- until (I = HashSize) or (Table[I] <> nil);
- until I = HashSize;
- // now all colors are in Box[0]
- repeat
- // cut one color box
- Largest := 0;
- for I := 0 to Boxes - 1 do
- with Box[I] do
- begin
- Size := (AMax - AMin) * AlphaWeight;
- S := (RMax - RMin) * RedWeight;
- if S > Size then
- Size := S;
- S := (GMax - GMin) * GreenWeight;
- if S > Size then
- Size := S;
- S := (BMax - BMin) * BlueWeight;
- if S > Size then
- Size := S;
- if Size > Largest then
- begin
- Largest := Size;
- LargestIdx := I;
- end;
- end;
- if Largest > 0 then
- begin
- // cutting Box[LargestIdx] into Box[LargestIdx] and Box[Boxes]
- CutR := False;
- CutG := False;
- CutB := False;
- CutA := False;
- with Box[LargestIdx] do
- begin
- if (AMax - AMin) * AlphaWeight = Largest then
- begin
- Cut := (AMax + AMin) shr 1;
- CutA := True;
- end
- else
- if (RMax - RMin) * RedWeight = Largest then
- begin
- Cut := (RMax + RMin) shr 1;
- CutR := True;
- end
- else
- if (GMax - GMin) * GreenWeight = Largest then
- begin
- Cut := (GMax + GMin) shr 1;
- CutG := True;
- end
- else
- begin
- Cut := (BMax + BMin) shr 1;
- CutB := True;
- end;
- CP := List;
- end;
- InitBox(Box[LargestIdx]);
- InitBox(Box[Boxes]);
- repeat
- // distribute one color
- Pom := CP.Next;
- with CP.Color do
- begin
- if (CutA and (A <= Cut)) or (CutR and (R <= Cut)) or
- (CutG and (G <= Cut)) or (CutB and (B <= Cut)) then
- I := LargestIdx
- else
- I := Boxes;
- end;
- CP.Next := Box[i].List;
- Box[i].List := CP;
- ChangeBox(Box[i], CP^);
- CP := Pom;
- until CP = nil;
- Inc(Boxes);
- end;
- until (Boxes = MaxColors) or (Largest = 0);
- // compute box representation
- for I := 0 to Boxes - 1 do
- begin
- SumR := 0;
- SumG := 0;
- SumB := 0;
- SumA := 0;
- repeat
- CP := Box[I].List;
- Inc(SumR, CP.Color.R * CP.Number);
- Inc(SumG, CP.Color.G * CP.Number);
- Inc(SumB, CP.Color.B * CP.Number);
- Inc(SumA, CP.Color.A * CP.Number);
- Box[I].List := CP.Next;
- Dispose(CP);
- until Box[I].List = nil;
- with Box[I] do
- begin
- Represented.A := SumA div Total;
- Represented.R := SumR div Total;
- Represented.G := SumG div Total;
- Represented.B := SumB div Total;
- AMin := AMin and ChannelMask;
- RMin := RMin and ChannelMask;
- GMin := GMin and ChannelMask;
- BMin := BMin and ChannelMask;
- AMax := (AMax and ChannelMask) + (not ChannelMask);
- RMax := (RMax and ChannelMask) + (not ChannelMask);
- GMax := (GMax and ChannelMask) + (not ChannelMask);
- BMax := (BMax and ChannelMask) + (not ChannelMask);
- end;
- end;
- // sort color boxes
- for I := 0 to Boxes - 2 do
- begin
- Largest := 0;
- for J := I to Boxes - 1 do
- if Box[J].Total > Largest then
- begin
- Largest := Box[J].Total;
- LargestIdx := J;
- end;
- if LargestIdx <> I then
- begin
- Temp := Box[I];
- Box[I] := Box[LargestIdx];
- Box[LargestIdx] := Temp;
- end;
- end;
- end;
- end;
-
- procedure FillOutputPalette;
- var
- I: LongInt;
- begin
- FillChar(DstPal^, SizeOf(TColor32Rec) * MaxColors, $FF);
- for I := 0 to MaxColors - 1 do
- begin
- if I < Boxes then
- with Box[I].Represented do
- begin
- DstPal[I].A := A;
- DstPal[I].R := R;
- DstPal[I].G := G;
- DstPal[I].B := B;
- end
- else
- DstPal[I].Color := $FF000000;
- end;
- end;
-
- function MapColor(const Col: TColor32Rec) : LongInt;
- var
- I: LongInt;
- begin
- I := 0;
- with Col do
- while (I < Boxes) and ((Box[I].AMin > A) or (Box[I].AMax < A) or
- (Box[I].RMin > R) or (Box[I].RMax < R) or (Box[I].GMin > G) or
- (Box[I].GMax < G) or (Box[I].BMin > B) or (Box[I].BMax < B)) do
- Inc(I);
- if I = Boxes then
- MapColor := 0
- else
- MapColor := I;
- end;
-
- procedure MapImage(Src, Dst: PByte; SrcInfo, DstInfo: PImageFormatInfo);
- var
- I: LongInt;
- Col: TColor32Rec;
- begin
- for I := 0 to NumPixels - 1 do
- begin
- Col := GetPixel32Generic(Src, SrcInfo, nil);
- IndexSetDstPixel(Dst, DstInfo, MapColor(Col));
- Inc(Src, SrcInfo.BytesPerPixel);
- Inc(Dst, DstInfo.BytesPerPixel);
- end;
- end;
-
-begin
- MaxColors := ClampInt(MaxColors, 2, MaxPossibleColors);
-
- if (raUpdateHistogram in Actions) or (raMapImage in Actions) then
- begin
- Assert(not SrcInfo.IsSpecial);
- Assert(not SrcInfo.IsIndexed);
- end;
-
- if raCreateHistogram in Actions then
- FillChar(Table, SizeOf(Table), 0);
-
- if raUpdateHistogram in Actions then
- CreateHistogram(Src, SrcInfo, ChannelMask);
-
- if raMakeColorMap in Actions then
- begin
- MakeColorMap;
- FillOutputPalette;
- end;
-
- if raMapImage in Actions then
- MapImage(Src, Dst, SrcInfo, DstInfo);
-end;
-
-procedure StretchNearest(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
- SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
- DstHeight: LongInt);
-var
- Info: TImageFormatInfo;
- ScaleX, ScaleY, X, Y, Xp, Yp: LongInt;
- DstPixel, SrcLine: PByte;
-begin
- GetImageFormatInfo(SrcImage.Format, Info);
- Assert(SrcImage.Format = DstImage.Format);
- Assert(not Info.IsSpecial);
- // Use integers instead of floats for source image pixel coords
- // Xp and Yp coords must be shifted right to get read source image coords
- ScaleX := (SrcWidth shl 16) div DstWidth;
- ScaleY := (SrcHeight shl 16) div DstHeight;
- Yp := 0;
- for Y := 0 to DstHeight - 1 do
- begin
- Xp := 0;
- SrcLine := @PByteArray(SrcImage.Bits)[((SrcY + Yp shr 16) * SrcImage.Width + SrcX) * Info.BytesPerPixel];
- DstPixel := @PByteArray(DstImage.Bits)[((DstY + Y) * DstImage.Width + DstX) * Info.BytesPerPixel];
- for X := 0 to DstWidth - 1 do
- begin
- case Info.BytesPerPixel of
- 1: PByte(DstPixel)^ := PByteArray(SrcLine)[Xp shr 16];
- 2: PWord(DstPixel)^ := PWordArray(SrcLine)[Xp shr 16];
- 3: PColor24Rec(DstPixel)^ := PPalette24(SrcLine)[Xp shr 16];
- 4: PColor32(DstPixel)^ := PLongWordArray(SrcLine)[Xp shr 16];
- 6: PColor48Rec(DstPixel)^ := PColor48RecArray(SrcLine)[Xp shr 16];
- 8: PColor64(DstPixel)^ := PInt64Array(SrcLine)[Xp shr 16];
- 16: PColorFPRec(DstPixel)^ := PColorFPRecArray(SrcLine)[Xp shr 16];
- end;
- Inc(DstPixel, Info.BytesPerPixel);
- Inc(Xp, ScaleX);
- end;
- Inc(Yp, ScaleY);
- end;
-end;
-
-{ Filter function for nearest filtering. Also known as box filter.}
-function FilterNearest(Value: Single): Single;
-begin
- if (Value > -0.5) and (Value <= 0.5) then
- Result := 1
- else
- Result := 0;
-end;
-
-{ Filter function for linear filtering. Also known as triangle or Bartlett filter.}
-function FilterLinear(Value: Single): Single;
-begin
- if Value < 0.0 then
- Value := -Value;
- if Value < 1.0 then
- Result := 1.0 - Value
- else
- Result := 0.0;
-end;
-
-{ Cosine filter.}
-function FilterCosine(Value: Single): Single;
-begin
- Result := 0;
- if Abs(Value) < 1 then
- Result := (Cos(Value * Pi) + 1) / 2;
-end;
-
-{ f(t) = 2|t|^3 - 3|t|^2 + 1, -1 <= t <= 1 }
-function FilterHermite(Value: Single): Single;
-begin
- if Value < 0.0 then
- Value := -Value;
- if Value < 1 then
- Result := (2 * Value - 3) * Sqr(Value) + 1
- else
- Result := 0;
-end;
-
-{ Quadratic filter. Also known as Bell.}
-function FilterQuadratic(Value: Single): Single;
-begin
- if Value < 0.0 then
- Value := -Value;
- if Value < 0.5 then
- Result := 0.75 - Sqr(Value)
- else
- if Value < 1.5 then
- begin
- Value := Value - 1.5;
- Result := 0.5 * Sqr(Value);
- end
- else
- Result := 0.0;
-end;
-
-{ Gaussian filter.}
-function FilterGaussian(Value: Single): Single;
-begin
- Result := Exp(-2.0 * Sqr(Value)) * Sqrt(2.0 / Pi);
-end;
-
-{ 4th order (cubic) b-spline filter.}
-function FilterSpline(Value: Single): Single;
-var
- Temp: Single;
-begin
- if Value < 0.0 then
- Value := -Value;
- if Value < 1.0 then
- begin
- Temp := Sqr(Value);
- Result := 0.5 * Temp * Value - Temp + 2.0 / 3.0;
- end
- else
- if Value < 2.0 then
- begin
- Value := 2.0 - Value;
- Result := Sqr(Value) * Value / 6.0;
- end
- else
- Result := 0.0;
-end;
-
-{ Lanczos-windowed sinc filter.}
-function FilterLanczos(Value: Single): Single;
-
- function SinC(Value: Single): Single;
- begin
- if Value <> 0.0 then
- begin
- Value := Value * Pi;
- Result := Sin(Value) / Value;
- end
- else
- Result := 1.0;
- end;
-
-begin
- if Value < 0.0 then
- Value := -Value;
- if Value < 3.0 then
- Result := SinC(Value) * SinC(Value / 3.0)
- else
- Result := 0.0;
-end;
-
-{ Micthell cubic filter.}
-function FilterMitchell(Value: Single): Single;
-const
- B = 1.0 / 3.0;
- C = 1.0 / 3.0;
-var
- Temp: Single;
-begin
- if Value < 0.0 then
- Value := -Value;
- Temp := Sqr(Value);
- if Value < 1.0 then
- begin
- Value := (((12.0 - 9.0 * B - 6.0 * C) * (Value * Temp)) +
- ((-18.0 + 12.0 * B + 6.0 * C) * Temp) +
- (6.0 - 2.0 * B));
- Result := Value / 6.0;
- end
- else
- if Value < 2.0 then
- begin
- Value := (((-B - 6.0 * C) * (Value * Temp)) +
- ((6.0 * B + 30.0 * C) * Temp) +
- ((-12.0 * B - 48.0 * C) * Value) +
- (8.0 * B + 24.0 * C));
- Result := Value / 6.0;
- end
- else
- Result := 0.0;
-end;
-
-{ CatmullRom spline filter.}
-function FilterCatmullRom(Value: Single): Single;
-begin
- if Value < 0.0 then
- Value := -Value;
- if Value < 1.0 then
- Result := 0.5 * (2.0 + Sqr(Value) * (-5.0 + 3.0 * Value))
- else
- if Value < 2.0 then
- Result := 0.5 * (4.0 + Value * (-8.0 + Value * (5.0 - Value)))
- else
- Result := 0.0;
-end;
-
-procedure StretchResample(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
- SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
- DstHeight: LongInt; Filter: TSamplingFilter; WrapEdges: Boolean);
-begin
- // Calls the other function with filter function and radius defined by Filter
- StretchResample(SrcImage, SrcX, SrcY, SrcWidth, SrcHeight, DstImage, DstX, DstY,
- DstWidth, DstHeight, SamplingFilterFunctions[Filter], SamplingFilterRadii[Filter],
- WrapEdges);
-end;
-
-var
- FullEdge: Boolean = True;
-
-{ The following resampling code is modified and extended code from Graphics32
- library by Alex A. Denisov.}
-function BuildMappingTable(DstLow, DstHigh, SrcLow, SrcHigh, SrcImageWidth: LongInt;
- Filter: TFilterFunction; Radius: Single; WrapEdges: Boolean): TMappingTable;
-var
- I, J, K, N: LongInt;
- Left, Right, SrcWidth, DstWidth: LongInt;
- Weight, Scale, Center, Count: Single;
-begin
- Result := nil;
- K := 0;
- SrcWidth := SrcHigh - SrcLow;
- DstWidth := DstHigh - DstLow;
-
- // Check some special cases
- if SrcWidth = 1 then
- begin
- SetLength(Result, DstWidth);
- for I := 0 to DstWidth - 1 do
- begin
- SetLength(Result[I], 1);
- Result[I][0].Pos := 0;
- Result[I][0].Weight := 1.0;
- end;
- Exit;
- end
- else
- if (SrcWidth = 0) or (DstWidth = 0) then
- Exit;
-
- if FullEdge then
- Scale := DstWidth / SrcWidth
- else
- Scale := (DstWidth - 1) / (SrcWidth - 1);
-
- SetLength(Result, DstWidth);
-
- // Pre-calculate filter contributions for a row or column
- if Scale = 0.0 then
- begin
- Assert(Length(Result) = 1);
- SetLength(Result[0], 1);
- Result[0][0].Pos := (SrcLow + SrcHigh) div 2;
- Result[0][0].Weight := 1.0;
- end
- else if Scale < 1.0 then
- begin
- // Sub-sampling - scales from bigger to smaller
- Radius := Radius / Scale;
- for I := 0 to DstWidth - 1 do
- begin
- if FullEdge then
- Center := SrcLow - 0.5 + (I + 0.5) / Scale
- else
- Center := SrcLow + I / Scale;
- Left := Floor(Center - Radius);
- Right := Ceil(Center + Radius);
- Count := -1.0;
- for J := Left to Right do
- begin
- Weight := Filter((Center - J) * Scale) * Scale;
- if Weight <> 0.0 then
- begin
- Count := Count + Weight;
- K := Length(Result[I]);
- SetLength(Result[I], K + 1);
- Result[I][K].Pos := ClampInt(J, SrcLow, SrcHigh - 1);
- Result[I][K].Weight := Weight;
- end;
- end;
- if Length(Result[I]) = 0 then
- begin
- SetLength(Result[I], 1);
- Result[I][0].Pos := Floor(Center);
- Result[I][0].Weight := 1.0;
- end
- else if Count <> 0.0 then
- Result[I][K div 2].Weight := Result[I][K div 2].Weight - Count;
- end;
- end
- else // if Scale > 1.0 then
- begin
- // Super-sampling - scales from smaller to bigger
- Scale := 1.0 / Scale;
- for I := 0 to DstWidth - 1 do
- begin
- if FullEdge then
- Center := SrcLow - 0.5 + (I + 0.5) * Scale
- else
- Center := SrcLow + I * Scale;
- Left := Floor(Center - Radius);
- Right := Ceil(Center + Radius);
- Count := -1.0;
- for J := Left to Right do
- begin
- Weight := Filter(Center - J);
- if Weight <> 0.0 then
- begin
- Count := Count + Weight;
- K := Length(Result[I]);
- SetLength(Result[I], K + 1);
-
- if WrapEdges then
- begin
- if J < 0 then
- N := SrcImageWidth + J
- else if J >= SrcImageWidth then
- N := J - SrcImageWidth
- else
- N := ClampInt(J, SrcLow, SrcHigh - 1);
- end
- else
- N := ClampInt(J, SrcLow, SrcHigh - 1);
-
- Result[I][K].Pos := N;
- Result[I][K].Weight := Weight;
- end;
- end;
- if Count <> 0.0 then
- Result[I][K div 2].Weight := Result[I][K div 2].Weight - Count;
- 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,
- SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
- DstHeight: LongInt; Filter: TFilterFunction; Radius: Single; WrapEdges: Boolean);
-const
- Channel8BitMax: Single = 255.0;
-type
- TBufferItem = record
- A, R, G, B: Integer;
- end;
-var
- MapX, MapY: TMappingTable;
- I, J, X, Y: LongInt;
- XMinimum, XMaximum: LongInt;
- LineBufferFP: array of TColorFPRec;
- LineBufferInt: array of TBufferItem;
- ClusterX, ClusterY: TCluster;
- Weight, AccumA, AccumR, AccumG, AccumB: Single;
- IWeight, IAccumA, IAccumR, IAccumG, IAccumB: Integer;
- DstLine: PByte;
- SrcColor: TColor32Rec;
- SrcFloat: TColorFPRec;
- Info: TImageFormatInfo;
- BytesPerChannel: LongInt;
- ChannelValueMax, InvChannelValueMax: Single;
- UseOptimizedVersion: Boolean;
-begin
- GetImageFormatInfo(SrcImage.Format, Info);
- Assert(SrcImage.Format = DstImage.Format);
- Assert(not Info.IsSpecial and not Info.IsIndexed);
- BytesPerChannel := Info.BytesPerPixel div Info.ChannelCount;
- UseOptimizedVersion := (BytesPerChannel = 1) and not Info.UsePixelFormat;
-
- // Create horizontal and vertical mapping tables
- MapX := BuildMappingTable(DstX, DstX + DstWidth, SrcX, SrcX + SrcWidth,
- SrcImage.Width, Filter, Radius, WrapEdges);
- MapY := BuildMappingTable(DstY, DstY + DstHeight, SrcY, SrcY + SrcHeight,
- SrcImage.Height, Filter, Radius, WrapEdges);
-
- if (MapX = nil) or (MapY = nil) then
- Exit;
-
- ClusterX := nil;
- ClusterY := nil;
-
- try
- // Find min and max X coords of pixels that will contribute to target image
- FindExtremes(MapX, XMinimum, XMaximum);
-
- if not UseOptimizedVersion then
- begin
- SetLength(LineBufferFP, XMaximum - XMinimum + 1);
- // Following code works for the rest of data formats
- for J := 0 to DstHeight - 1 do
- begin
- // First for each pixel in the current line sample vertically
- // and store results in LineBuffer. Then sample horizontally
- // using values in LineBuffer.
- ClusterY := MapY[J];
- for X := XMinimum to XMaximum do
- begin
- // Clear accumulators
- AccumA := 0;
- AccumR := 0;
- AccumG := 0;
- AccumB := 0;
- // For each pixel in line compute weighted sum of pixels
- // in source column that will contribute to this pixel
- for Y := 0 to Length(ClusterY) - 1 do
- begin
- // Accumulate this pixel's weighted value
- Weight := ClusterY[Y].Weight;
- SrcFloat := Info.GetPixelFP(@PByteArray(SrcImage.Bits)[(ClusterY[Y].Pos * SrcImage.Width + X) * Info.BytesPerPixel], @Info, nil);
- AccumB := AccumB + SrcFloat.B * Weight;
- AccumG := AccumG + SrcFloat.G * Weight;
- AccumR := AccumR + SrcFloat.R * Weight;
- AccumA := AccumA + SrcFloat.A * Weight;
- end;
- // Store accumulated value for this pixel in buffer
- with LineBufferFP[X - XMinimum] do
- begin
- A := AccumA;
- R := AccumR;
- G := AccumG;
- B := AccumB;
- end;
- end;
-
- DstLine := @PByteArray(DstImage.Bits)[((J + DstY) * DstImage.Width + DstX) * Info.BytesPerPixel];
- // Now compute final colors for targte pixels in the current row
- // by sampling horizontally
- for I := 0 to DstWidth - 1 do
- begin
- ClusterX := MapX[I];
- // Clear accumulator
- AccumA := 0;
- AccumR := 0;
- AccumG := 0;
- AccumB := 0;
- // Compute weighted sum of values (which are already
- // computed weighted sums of pixels in source columns stored in LineBuffer)
- // that will contribute to the current target pixel
- for X := 0 to Length(ClusterX) - 1 do
- begin
- Weight := ClusterX[X].Weight;
- with LineBufferFP[ClusterX[X].Pos - XMinimum] do
- begin
- AccumB := AccumB + B * Weight;
- AccumG := AccumG + G * Weight;
- AccumR := AccumR + R * Weight;
- AccumA := AccumA + A * Weight;
- end;
- end;
-
- // Now compute final color to be written to dest image
- SrcFloat.A := AccumA;
- SrcFloat.R := AccumR;
- SrcFloat.G := AccumG;
- SrcFloat.B := AccumB;
-
- Info.SetPixelFP(DstLine, @Info, nil, SrcFloat);
- Inc(DstLine, Info.BytesPerPixel);
- end;
- end;
- end
- else
- begin
- SetLength(LineBufferInt, XMaximum - XMinimum + 1);
- // Following code is optimized for images with 8 bit channels
- for J := 0 to DstHeight - 1 do
- begin
- ClusterY := MapY[J];
- for X := XMinimum to XMaximum do
- begin
- IAccumA := 0;
- IAccumR := 0;
- IAccumG := 0;
- IAccumB := 0;
- for Y := 0 to Length(ClusterY) - 1 do
- begin
- IWeight := Round(256 * ClusterY[Y].Weight);
- CopyPixel(
- @PByteArray(SrcImage.Bits)[(ClusterY[Y].Pos * SrcImage.Width + X) * Info.BytesPerPixel],
- @SrcColor, Info.BytesPerPixel);
-
- IAccumB := IAccumB + SrcColor.B * IWeight;
- IAccumG := IAccumG + SrcColor.G * IWeight;
- IAccumR := IAccumR + SrcColor.R * IWeight;
- IAccumA := IAccumA + SrcColor.A * IWeight;
- end;
- with LineBufferInt[X - XMinimum] do
- begin
- A := IAccumA;
- R := IAccumR;
- G := IAccumG;
- B := IAccumB;
- end;
- end;
-
- DstLine := @PByteArray(DstImage.Bits)[((J + DstY) * DstImage.Width + DstX)* Info.BytesPerPixel];
-
- for I := 0 to DstWidth - 1 do
- begin
- ClusterX := MapX[I];
- IAccumA := 0;
- IAccumR := 0;
- IAccumG := 0;
- IAccumB := 0;
- for X := 0 to Length(ClusterX) - 1 do
- begin
- IWeight := Round(256 * ClusterX[X].Weight);
- with LineBufferInt[ClusterX[X].Pos - XMinimum] do
- begin
- IAccumB := IAccumB + B * IWeight;
- IAccumG := IAccumG + G * IWeight;
- IAccumR := IAccumR + R * IWeight;
- IAccumA := IAccumA + A * IWeight;
- end;
- end;
-
- SrcColor.B := ClampInt(IAccumB, 0, $00FF0000) shr 16;
- SrcColor.G := ClampInt(IAccumG, 0, $00FF0000) shr 16;
- SrcColor.R := ClampInt(IAccumR, 0, $00FF0000) shr 16;
- SrcColor.A := ClampInt(IAccumA, 0, $00FF0000) shr 16;
-
- CopyPixel(@SrcColor, DstLine, Info.BytesPerPixel);
- Inc(DstLine, Info.BytesPerPixel);
- end;
- end;
- end;
-
- finally
- MapX := nil;
- MapY := nil;
- end;
-end;
-
-procedure FillMipMapLevel(const BiggerLevel: TImageData; Width, Height: LongInt;
- var SmallerLevel: TImageData);
-var
- Filter: TSamplingFilter;
- Info: TImageFormatInfo;
- CompatibleCopy: TImageData;
-begin
- Assert(TestImage(BiggerLevel));
- Filter := TSamplingFilter(GetOption(ImagingMipMapFilter));
-
- // If we have special format image we must create copy to allow pixel access
- GetImageFormatInfo(BiggerLevel.Format, Info);
- if Info.IsSpecial then
- begin
- InitImage(CompatibleCopy);
- CloneImage(BiggerLevel, CompatibleCopy);
- ConvertImage(CompatibleCopy, ifDefault);
- end
- else
- CompatibleCopy := BiggerLevel;
-
- // Create new smaller image
- NewImage(Width, Height, CompatibleCopy.Format, SmallerLevel);
- GetImageFormatInfo(CompatibleCopy.Format, Info);
- // If input is indexed we must copy its palette
- if Info.IsIndexed then
- CopyPalette(CompatibleCopy.Palette, SmallerLevel.Palette, 0, 0, Info.PaletteEntries);
-
- if (Filter = sfNearest) or Info.IsIndexed then
- begin
- StretchNearest(CompatibleCopy, 0, 0, CompatibleCopy.Width, CompatibleCopy.Height,
- SmallerLevel, 0, 0, Width, Height);
- end
- else
- begin
- StretchResample(CompatibleCopy, 0, 0, CompatibleCopy.Width, CompatibleCopy.Height,
- SmallerLevel, 0, 0, Width, Height, Filter);
- end;
-
- // Free copy and convert result to special format if necessary
- if CompatibleCopy.Format <> BiggerLevel.Format then
- begin
- ConvertImage(SmallerLevel, BiggerLevel.Format);
- FreeImage(CompatibleCopy);
- end;
-end;
-
-
-{ Various format support functions }
-
-procedure CopyPixel(Src, Dest: Pointer; BytesPerPixel: LongInt);
-begin
- case BytesPerPixel of
- 1: PByte(Dest)^ := PByte(Src)^;
- 2: PWord(Dest)^ := PWord(Src)^;
- 3: PColor24Rec(Dest)^ := PColor24Rec(Src)^;
- 4: PLongWord(Dest)^ := PLongWord(Src)^;
- 6: PColor48Rec(Dest)^ := PColor48Rec(Src)^;
- 8: PInt64(Dest)^ := PInt64(Src)^;
- 16: PColorFPRec(Dest)^ := PColorFPRec(Src)^;
- end;
-end;
-
-function ComparePixels(PixelA, PixelB: Pointer; BytesPerPixel: LongInt): Boolean;
-begin
- case BytesPerPixel of
- 1: Result := PByte(PixelA)^ = PByte(PixelB)^;
- 2: Result := PWord(PixelA)^ = PWord(PixelB)^;
- 3: Result := (PWord(PixelA)^ = PWord(PixelB)^) and
- (PColor24Rec(PixelA).R = PColor24Rec(PixelB).R);
- 4: Result := PLongWord(PixelA)^ = PLongWord(PixelB)^;
- 6: Result := (PLongWord(PixelA)^ = PLongWord(PixelB)^) and
- (PColor48Rec(PixelA).R = PColor48Rec(PixelB).R);
- 8: Result := PInt64(PixelA)^ = PInt64(PixelB)^;
- 16: Result := (PFloatHelper(PixelA).Data2 = PFloatHelper(PixelB).Data2) and
- (PFloatHelper(PixelA).Data1 = PFloatHelper(PixelB).Data1);
- else
- Result := False;
- end;
-end;
-
-procedure TranslatePixel(SrcPixel, DstPixel: Pointer; SrcFormat,
- DstFormat: TImageFormat; SrcPalette, DstPalette: PPalette32);
-var
- SrcInfo, DstInfo: PImageFormatInfo;
- PixFP: TColorFPRec;
-begin
- SrcInfo := FInfos[SrcFormat];
- DstInfo := FInfos[DstFormat];
-
- PixFP := GetPixelFPGeneric(SrcPixel, SrcInfo, SrcPalette);
- SetPixelFPGeneric(DstPixel, DstInfo, DstPalette, PixFP);
-end;
-
-procedure ClampFloatPixel(var PixF: TColorFPRec);
-begin
- if PixF.A > 1.0 then
- PixF.A := 1.0;
- if PixF.R > 1.0 then
- PixF.R := 1.0;
- if PixF.G > 1.0 then
- PixF.G := 1.0;
- if PixF.B > 1.0 then
- PixF.B := 1.0;
-
- if PixF.A < 0.0 then
- PixF.A := 0.0;
- if PixF.R < 0.0 then
- PixF.R := 0.0;
- if PixF.G < 0.0 then
- PixF.G := 0.0;
- if PixF.B < 0.0 then
- PixF.B := 0.0;
-end;
-
-procedure AddPadBytes(DataIn: Pointer; DataOut: Pointer; Width, Height,
- Bpp, WidthBytes: LongInt);
-var
- I, W: LongInt;
-begin
- W := Width * Bpp;
- for I := 0 to Height - 1 do
- Move(PByteArray(DataIn)[I * W], PByteArray(DataOut)[I * WidthBytes], W);
-end;
-
-procedure RemovePadBytes(DataIn: Pointer; DataOut: Pointer; Width, Height,
- Bpp, WidthBytes: LongInt);
-var
- I, W: LongInt;
-begin
- W := Width * Bpp;
- for I := 0 to Height - 1 do
- Move(PByteArray(DataIn)[I * WidthBytes], PByteArray(DataOut)[I * W], W);
-end;
-
-procedure Convert1To8(DataIn, DataOut: Pointer; Width, Height,
- WidthBytes: LongInt);
-const
- Mask1: array[0..7] of Byte = ($80, $40, $20, $10, $08, $04, $02, $01);
- Shift1: array[0..7] of Byte = (7, 6, 5, 4, 3, 2, 1, 0);
-var
- X, Y: LongInt;
-begin
- for Y := 0 to Height - 1 do
- for X := 0 to Width - 1 do
- PByteArray(DataOut)[Y * Width + X] :=
- (PByteArray(DataIn)[Y * WidthBytes + X shr 3] and
- Mask1[X and 7]) shr Shift1[X and 7];
-end;
-
-procedure Convert2To8(DataIn, DataOut: Pointer; Width, Height,
- WidthBytes: LongInt);
-const
- Mask2: array[0..3] of Byte = ($C0, $30, $0C, $03);
- Shift2: array[0..3] of Byte = (6, 4, 2, 0);
-var
- X, Y: LongInt;
-begin
- for Y := 0 to Height - 1 do
- for X := 0 to Width - 1 do
- PByteArray(DataOut)[Y * Width + X] :=
- (PByteArray(DataIn)[X shr 2] and Mask2[X and 3]) shr
- Shift2[X and 3];
-end;
-
-procedure Convert4To8(DataIn, DataOut: Pointer; Width, Height,
- WidthBytes: LongInt);
-const
- Mask4: array[0..1] of Byte = ($F0, $0F);
- Shift4: array[0..1] of Byte = (4, 0);
-var
- X, Y: LongInt;
-begin
- for Y := 0 to Height - 1 do
- for X := 0 to Width - 1 do
- PByteArray(DataOut)[Y * Width + X] :=
- (PByteArray(DataIn)[Y * WidthBytes + X shr 1] and
- Mask4[X and 1]) shr Shift4[X and 1];
-end;
-
-function Has16BitImageAlpha(NumPixels: LongInt; Data: PWord): Boolean;
-var
- I: LongInt;
-begin
- Result := False;
- for I := 0 to NumPixels - 1 do
- begin
- if Data^ >= 1 shl 15 then
- begin
- Result := True;
- Exit;
- end;
- Inc(Data);
- end;
-end;
-
-function Has32BitImageAlpha(NumPixels: LongInt; Data: PLongWord): Boolean;
-var
- I: LongInt;
-begin
- Result := False;
- for I := 0 to NumPixels - 1 do
- begin
- if Data^ >= 1 shl 24 then
- begin
- Result := True;
- Exit;
- end;
- Inc(Data);
- end;
-end;
-
-function GetScanLine(ImageBits: Pointer; const FormatInfo: TImageFormatInfo;
- LineWidth, Index: LongInt): Pointer;
-var
- LineBytes: LongInt;
-begin
- Assert(not FormatInfo.IsSpecial);
- LineBytes := FormatInfo.GetPixelsSize(FormatInfo.Format, LineWidth, 1);
- Result := @PByteArray(ImageBits)[Index * LineBytes];
-end;
-
-function IsImageFormatValid(Format: TImageFormat): Boolean;
-begin
- Result := FInfos[Format] <> nil;
-end;
-
-const
- HalfMin: Single = 5.96046448e-08; // Smallest positive half
- HalfMinNorm: Single = 6.10351562e-05; // Smallest positive normalized half
- HalfMax: Single = 65504.0; // Largest positive half
- HalfEpsilon: Single = 0.00097656; // Smallest positive e for which half (1.0 + e) != half (1.0)
- HalfNaN: THalfFloat = 65535;
- HalfPosInf: THalfFloat = 31744;
- HalfNegInf: THalfFloat = 64512;
-
-
-{
-
- Half/Float conversions inspired by half class from OpenEXR library.
-
-
- Float (Pascal Single type) is an IEEE 754 single-precision
-
- floating point number.
-
- Bit layout of Single:
-
- 31 (msb)
- |
- | 30 23
- | | |
- | | | 22 0 (lsb)
- | | | | |
- X XXXXXXXX XXXXXXXXXXXXXXXXXXXXXXX
- s e m
-
- Bit layout of half:
-
- 15 (msb)
- |
- | 14 10
- | | |
- | | | 9 0 (lsb)
- | | | | |
- X XXXXX XXXXXXXXXX
- s e m
-
- S is the sign-bit, e is the exponent and m is the significand (mantissa).
-}
-
-
-function HalfToFloat(Half: THalfFloat): Single;
-var
- Dst, Sign, Mantissa: LongWord;
- Exp: LongInt;
-begin
- // extract sign, exponent, and mantissa from half number
- Sign := Half shr 15;
- Exp := (Half and $7C00) shr 10;
- Mantissa := Half and 1023;
-
- if (Exp > 0) and (Exp < 31) then
- begin
- // common normalized number
- Exp := Exp + (127 - 15);
- Mantissa := Mantissa shl 13;
- Dst := (Sign shl 31) or (LongWord(Exp) shl 23) or Mantissa;
- // Result := Power(-1, Sign) * Power(2, Exp - 15) * (1 + Mantissa / 1024);
- end
- else if (Exp = 0) and (Mantissa = 0) then
- begin
- // zero - preserve sign
- Dst := Sign shl 31;
- end
- else if (Exp = 0) and (Mantissa <> 0) then
- begin
- // denormalized number - renormalize it
- while (Mantissa and $00000400) = 0 do
- begin
- Mantissa := Mantissa shl 1;
- Dec(Exp);
- end;
- Inc(Exp);
- Mantissa := Mantissa and not $00000400;
- // now assemble normalized number
- Exp := Exp + (127 - 15);
- Mantissa := Mantissa shl 13;
- Dst := (Sign shl 31) or (LongWord(Exp) shl 23) or Mantissa;
- // Result := Power(-1, Sign) * Power(2, -14) * (Mantissa / 1024);
- end
- else if (Exp = 31) and (Mantissa = 0) then
- begin
- // +/- infinity
- Dst := (Sign shl 31) or $7F800000;
- end
- else //if (Exp = 31) and (Mantisa <> 0) then
- begin
- // not a number - preserve sign and mantissa
- Dst := (Sign shl 31) or $7F800000 or (Mantissa shl 13);
- end;
-
- // reinterpret LongWord as Single
- Result := PSingle(@Dst)^;
-end;
-
-function FloatToHalf(Float: Single): THalfFloat;
-var
- Src: LongWord;
- Sign, Exp, Mantissa: LongInt;
-begin
- Src := PLongWord(@Float)^;
- // extract sign, exponent, and mantissa from Single number
- Sign := Src shr 31;
- Exp := LongInt((Src and $7F800000) shr 23) - 127 + 15;
- Mantissa := Src and $007FFFFF;
-
- if (Exp > 0) and (Exp < 30) then
- begin
- // simple case - round the significand and combine it with the sign and exponent
- Result := (Sign shl 15) or (Exp shl 10) or ((Mantissa + $00001000) shr 13);
- end
- else if Src = 0 then
- begin
- // input float is zero - return zero
- Result := 0;
- end
- else
- begin
- // difficult case - lengthy conversion
- if Exp <= 0 then
- begin
- if Exp < -10 then
- begin
- // input float's value is less than HalfMin, return zero
- Result := 0;
- end
- else
- begin
- // Float is a normalized Single whose magnitude is less than HalfNormMin.
- // We convert it to denormalized half.
- Mantissa := (Mantissa or $00800000) shr (1 - Exp);
- // round to nearest
- if (Mantissa and $00001000) > 0 then
- Mantissa := Mantissa + $00002000;
- // assemble Sign and Mantissa (Exp is zero to get denotmalized number)
- Result := (Sign shl 15) or (Mantissa shr 13);
- end;
- end
- else if Exp = 255 - 127 + 15 then
- begin
- if Mantissa = 0 then
- begin
- // input float is infinity, create infinity half with original sign
- Result := (Sign shl 15) or $7C00;
- end
- else
- begin
- // input float is NaN, create half NaN with original sign and mantissa
- Result := (Sign shl 15) or $7C00 or (Mantissa shr 13);
- end;
- end
- else
- begin
- // Exp is > 0 so input float is normalized Single
-
- // round to nearest
- if (Mantissa and $00001000) > 0 then
- begin
- Mantissa := Mantissa + $00002000;
- if (Mantissa and $00800000) > 0 then
- begin
- Mantissa := 0;
- Exp := Exp + 1;
- end;
- end;
-
- if Exp > 30 then
- begin
- // exponent overflow - return infinity half
- Result := (Sign shl 15) or $7C00;
- end
- else
- // assemble normalized half
- Result := (Sign shl 15) or (Exp shl 10) or (Mantissa shr 13);
- end;
- end;
-end;
-
-function ColorHalfToFloat(ColorHF: TColorHFRec): TColorFPRec;
-begin
- Result.A := HalfToFloat(ColorHF.A);
- Result.R := HalfToFloat(ColorHF.R);
- Result.G := HalfToFloat(ColorHF.G);
- Result.B := HalfToFloat(ColorHF.B);
-end;
-
-function ColorFloatToHalf(ColorFP: TColorFPRec): TColorHFRec;
-begin
- Result.A := FloatToHalf(ColorFP.A);
- Result.R := FloatToHalf(ColorFP.R);
- Result.G := FloatToHalf(ColorFP.G);
- Result.B := FloatToHalf(ColorFP.B);
-end;
-
-procedure VisualizePalette(Pal: PPalette32; Entries: Integer; out PalImage: TImageData);
-var
- I: Integer;
- Pix: PColor32;
-begin
- InitImage(PalImage);
- NewImage(Entries, 1, ifA8R8G8B8, PalImage);
- Pix := PalImage.Bits;
- for I := 0 to Entries - 1 do
- begin
- Pix^ := Pal[I].Color;
- Inc(Pix);
- end;
-end;
-
-
-{ Pixel readers/writers for different image formats }
-
-procedure ChannelGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
- var Pix: TColor64Rec);
-var
- A, R, G, B: Byte;
-begin
- FillChar(Pix, SizeOf(Pix), 0);
- // returns 64 bit color value with 16 bits for each channel
- case SrcInfo.BytesPerPixel of
- 1:
- begin
- PFGetARGB(SrcInfo.PixelFormat^, Src^, A, R, G, B);
- Pix.A := A shl 8;
- Pix.R := R shl 8;
- Pix.G := G shl 8;
- Pix.B := B shl 8;
- end;
- 2:
- begin
- PFGetARGB(SrcInfo.PixelFormat^, PWord(Src)^, A, R, G, B);
- Pix.A := A shl 8;
- Pix.R := R shl 8;
- Pix.G := G shl 8;
- Pix.B := B shl 8;
- end;
- 3:
- with Pix do
- begin
- R := MulDiv(PColor24Rec(Src).R, 65535, 255);
- G := MulDiv(PColor24Rec(Src).G, 65535, 255);
- B := MulDiv(PColor24Rec(Src).B, 65535, 255);
- end;
- 4:
- with Pix do
- begin
- A := MulDiv(PColor32Rec(Src).A, 65535, 255);
- R := MulDiv(PColor32Rec(Src).R, 65535, 255);
- G := MulDiv(PColor32Rec(Src).G, 65535, 255);
- B := MulDiv(PColor32Rec(Src).B, 65535, 255);
- end;
- 6:
- with Pix do
- begin
- R := PColor48Rec(Src).R;
- G := PColor48Rec(Src).G;
- B := PColor48Rec(Src).B;
- end;
- 8: Pix.Color := PColor64(Src)^;
- end;
- // if src has no alpha, we set it to max (otherwise we would have to
- // test if dest has alpha or not in each ChannelToXXX function)
- if not SrcInfo.HasAlphaChannel then
- Pix.A := 65535;
-
- if SrcInfo.IsRBSwapped then
- SwapValues(Pix.R, Pix.B);
-end;
-
-procedure ChannelSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
- const Pix: TColor64Rec);
-var
- PixW: TColor64Rec;
-begin
- PixW := Pix;
- if DstInfo.IsRBSwapped then
- SwapValues(PixW.R, PixW.B);
- // Pix contains 64 bit color value with 16 bit for each channel
- case DstInfo.BytesPerPixel of
- 1: Dst^ := PFSetARGB(DstInfo.PixelFormat^, PixW.A shr 8,
- PixW.R shr 8, PixW.G shr 8, PixW.B shr 8);
- 2: PWord(Dst)^ := PFSetARGB(DstInfo.PixelFormat^, PixW.A shr 8,
- PixW.R shr 8, PixW.G shr 8, PixW.B shr 8);
- 3:
- with PColor24Rec(Dst)^ do
- begin
- R := MulDiv(PixW.R, 255, 65535);
- G := MulDiv(PixW.G, 255, 65535);
- B := MulDiv(PixW.B, 255, 65535);
- end;
- 4:
- with PColor32Rec(Dst)^ do
- begin
- A := MulDiv(PixW.A, 255, 65535);
- R := MulDiv(PixW.R, 255, 65535);
- G := MulDiv(PixW.G, 255, 65535);
- B := MulDiv(PixW.B, 255, 65535);
- end;
- 6:
- with PColor48Rec(Dst)^ do
- begin
- R := PixW.R;
- G := PixW.G;
- B := PixW.B;
- end;
- 8: PColor64(Dst)^ := PixW.Color;
- end;
-end;
-
-procedure GrayGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
- var Gray: TColor64Rec; var Alpha: Word);
-begin
- FillChar(Gray, SizeOf(Gray), 0);
- // Source alpha is scaled to 16 bits and stored in Alpha,
- // grayscale value is scaled to 64 bits and stored in Gray
- case SrcInfo.BytesPerPixel of
- 1: Gray.A := MulDiv(Src^, 65535, 255);
- 2:
- if SrcInfo.HasAlphaChannel then
- with PWordRec(Src)^ do
- begin
- Alpha := MulDiv(High, 65535, 255);
- Gray.A := MulDiv(Low, 65535, 255);
- end
- else
- Gray.A := PWord(Src)^;
- 4:
- if SrcInfo.HasAlphaChannel then
- with PLongWordRec(Src)^ do
- begin
- Alpha := High;
- Gray.A := Low;
- end
- else
- with PLongWordRec(Src)^ do
- begin
- Gray.A := High;
- Gray.R := Low;
- end;
- 8: Gray.Color := PColor64(Src)^;
- end;
- // if src has no alpha, we set it to max (otherwise we would have to
- // test if dest has alpha or not in each GrayToXXX function)
- if not SrcInfo.HasAlphaChannel then
- Alpha := 65535;
-end;
-
-procedure GraySetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
- const Gray: TColor64Rec; Alpha: Word);
-begin
- // Gray contains grayscale value scaled to 64 bits, Alpha contains
- // alpha value scaled to 16 bits
- case DstInfo.BytesPerPixel of
- 1: Dst^ := MulDiv(Gray.A, 255, 65535);
- 2:
- if DstInfo.HasAlphaChannel then
- with PWordRec(Dst)^ do
- begin
- High := MulDiv(Alpha, 255, 65535);
- Low := MulDiv(Gray.A, 255, 65535);
- end
- else
- PWord(Dst)^ := Gray.A;
- 4:
- if DstInfo.HasAlphaChannel then
- with PLongWordRec(Dst)^ do
- begin
- High := Alpha;
- Low := Gray.A;
- end
- else
- with PLongWordRec(Dst)^ do
- begin
- High := Gray.A;
- Low := Gray.R;
- end;
- 8: PColor64(Dst)^ := Gray.Color;
- end;
-end;
-
-procedure FloatGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
- var Pix: TColorFPRec);
-var
- PixHF: TColorHFRec;
-begin
- if SrcInfo.BytesPerPixel in [4, 16] then
- begin
- // IEEE 754 single-precision channels
- FillChar(Pix, SizeOf(Pix), 0);
- case SrcInfo.BytesPerPixel of
- 4: Pix.R := PSingle(Src)^;
- 16: Pix := PColorFPRec(Src)^;
- end;
- end
- else
- begin
- // half float channels
- FillChar(PixHF, SizeOf(PixHF), 0);
- case SrcInfo.BytesPerPixel of
- 2: PixHF.R := PHalfFloat(Src)^;
- 8: PixHF := PColorHFRec(Src)^;
- end;
- Pix := ColorHalfToFloat(PixHF);
- end;
- // if src has no alpha, we set it to max (otherwise we would have to
- // test if dest has alpha or not in each FloatToXXX function)
- if not SrcInfo.HasAlphaChannel then
- Pix.A := 1.0;
- if SrcInfo.IsRBSwapped then
- SwapValues(Pix.R, Pix.B);
-end;
-
-procedure FloatSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
- const Pix: TColorFPRec);
-var
- PixW: TColorFPRec;
- PixHF: TColorHFRec;
-begin
- PixW := Pix;
- if DstInfo.IsRBSwapped then
- SwapValues(PixW.R, PixW.B);
- if DstInfo.BytesPerPixel in [4, 16] then
- begin
- case DstInfo.BytesPerPixel of
- 4: PSingle(Dst)^ := PixW.R;
- 16: PColorFPRec(Dst)^ := PixW;
- end;
- end
- else
- begin
- PixHF := ColorFloatToHalf(PixW);
- case DstInfo.BytesPerPixel of
- 2: PHalfFloat(Dst)^ := PixHF.R;
- 8: PColorHFRec(Dst)^ := PixHF;
- end;
- end;
-end;
-
-procedure IndexGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
- var Index: LongWord);
-begin
- case SrcInfo.BytesPerPixel of
- 1: Index := Src^;
- end;
-end;
-
-procedure IndexSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
- Index: LongWord);
-begin
- case DstInfo.BytesPerPixel of
- 1: Dst^ := Byte(Index);
- 2: PWord(Dst)^ := Word(Index);
- 4: PLongWord(Dst)^ := Index;
- end;
-end;
-
-
-{ Pixel readers/writers for 32bit and FP colors}
-
-function GetPixel32Generic(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColor32Rec;
-var
- Pix64: TColor64Rec;
- PixF: TColorFPRec;
- Alpha: Word;
- Index: LongWord;
-begin
- if Info.Format = ifA8R8G8B8 then
- begin
- Result := PColor32Rec(Bits)^
- end
- else if Info.Format = ifR8G8B8 then
- begin
- PColor24Rec(@Result)^ := PColor24Rec(Bits)^;
- Result.A := $FF;
- end
- else if Info.IsFloatingPoint then
- begin
- FloatGetSrcPixel(Bits, Info, PixF);
- Result.A := ClampToByte(Round(PixF.A * 255.0));
- Result.R := ClampToByte(Round(PixF.R * 255.0));
- Result.G := ClampToByte(Round(PixF.G * 255.0));
- Result.B := ClampToByte(Round(PixF.B * 255.0));
- end
- else if Info.HasGrayChannel then
- begin
- GrayGetSrcPixel(Bits, Info, Pix64, Alpha);
- Result.A := MulDiv(Alpha, 255, 65535);
- Result.R := MulDiv(Pix64.A, 255, 65535);
- Result.G := MulDiv(Pix64.A, 255, 65535);
- Result.B := MulDiv(Pix64.A, 255, 65535);
- end
- else if Info.IsIndexed then
- begin
- IndexGetSrcPixel(Bits, Info, Index);
- Result := Palette[Index];
- end
- else
- begin
- ChannelGetSrcPixel(Bits, Info, Pix64);
- Result.A := MulDiv(Pix64.A, 255, 65535);
- Result.R := MulDiv(Pix64.R, 255, 65535);
- Result.G := MulDiv(Pix64.G, 255, 65535);
- Result.B := MulDiv(Pix64.B, 255, 65535);
- end;
-end;
-
-procedure SetPixel32Generic(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColor32Rec);
-var
- Pix64: TColor64Rec;
- PixF: TColorFPRec;
- Alpha: Word;
- Index: LongWord;
-begin
- if Info.Format = ifA8R8G8B8 then
- begin
- PColor32Rec(Bits)^ := Color
- end
- else if Info.Format = ifR8G8B8 then
- begin
- PColor24Rec(Bits)^ := Color.Color24Rec;
- end
- else if Info.IsFloatingPoint then
- begin
- PixF.A := Color.A * OneDiv8Bit;
- PixF.R := Color.R * OneDiv8Bit;
- PixF.G := Color.G * OneDiv8Bit;
- PixF.B := Color.B * OneDiv8Bit;
- FloatSetDstPixel(Bits, Info, PixF);
- end
- else if Info.HasGrayChannel then
- begin
- Alpha := MulDiv(Color.A, 65535, 255);
- Pix64.Color := 0;
- Pix64.A := MulDiv(Round(GrayConv.R * Color.R + GrayConv.G * Color.G +
- GrayConv.B * Color.B), 65535, 255);
- GraySetDstPixel(Bits, Info, Pix64, Alpha);
- end
- else if Info.IsIndexed then
- begin
- Index := FindColor(Palette, Info.PaletteEntries, Color.Color);
- IndexSetDstPixel(Bits, Info, Index);
- end
- else
- begin
- Pix64.A := MulDiv(Color.A, 65535, 255);
- Pix64.R := MulDiv(Color.R, 65535, 255);
- Pix64.G := MulDiv(Color.G, 65535, 255);
- Pix64.B := MulDiv(Color.B, 65535, 255);
- ChannelSetDstPixel(Bits, Info, Pix64);
- end;
-end;
-
-function GetPixelFPGeneric(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec;
-var
- Pix32: TColor32Rec;
- Pix64: TColor64Rec;
- Alpha: Word;
- Index: LongWord;
-begin
- if Info.IsFloatingPoint then
- begin
- FloatGetSrcPixel(Bits, Info, Result);
- end
- else if Info.HasGrayChannel then
- begin
- GrayGetSrcPixel(Bits, Info, Pix64, Alpha);
- Result.A := Alpha * OneDiv16Bit;
- Result.R := Pix64.A * OneDiv16Bit;
- Result.G := Pix64.A * OneDiv16Bit;
- Result.B := Pix64.A * OneDiv16Bit;
- end
- else if Info.IsIndexed then
- begin
- IndexGetSrcPixel(Bits, Info, Index);
- Pix32 := Palette[Index];
- Result.A := Pix32.A * OneDiv8Bit;
- Result.R := Pix32.R * OneDiv8Bit;
- Result.G := Pix32.G * OneDiv8Bit;
- Result.B := Pix32.B * OneDiv8Bit;
- end
- else
- begin
- ChannelGetSrcPixel(Bits, Info, Pix64);
- Result.A := Pix64.A * OneDiv16Bit;
- Result.R := Pix64.R * OneDiv16Bit;
- Result.G := Pix64.G * OneDiv16Bit;
- Result.B := Pix64.B * OneDiv16Bit;
- end;
-end;
-
-procedure SetPixelFPGeneric(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec);
-var
- Pix32: TColor32Rec;
- Pix64: TColor64Rec;
- Alpha: Word;
- Index: LongWord;
-begin
- if Info.IsFloatingPoint then
- begin
- FloatSetDstPixel(Bits, Info, Color);
- end
- else if Info.HasGrayChannel then
- begin
- Alpha := ClampToWord(Round(Color.A * 65535.0));
- Pix64.Color := 0;
- Pix64.A := ClampToWord(Round((GrayConv.R * Color.R + GrayConv.G * Color.G +
- GrayConv.B * Color.B) * 65535.0));
- GraySetDstPixel(Bits, Info, Pix64, Alpha);
- end
- else if Info.IsIndexed then
- begin
- Pix32.A := ClampToByte(Round(Color.A * 255.0));
- Pix32.R := ClampToByte(Round(Color.R * 255.0));
- Pix32.G := ClampToByte(Round(Color.G * 255.0));
- Pix32.B := ClampToByte(Round(Color.B * 255.0));
- Index := FindColor(Palette, Info.PaletteEntries, Pix32.Color);
- IndexSetDstPixel(Bits, Info, Index);
- end
- else
- begin
- Pix64.A := ClampToWord(Round(Color.A * 65535.0));
- Pix64.R := ClampToWord(Round(Color.R * 65535.0));
- Pix64.G := ClampToWord(Round(Color.G * 65535.0));
- Pix64.B := ClampToWord(Round(Color.B * 65535.0));
- ChannelSetDstPixel(Bits, Info, Pix64);
- end;
-end;
-
-
-{ Image format conversion functions }
-
-procedure ChannelToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
- DstInfo: PImageFormatInfo);
-var
- I: LongInt;
- Pix64: TColor64Rec;
-begin
- // two most common conversions (RGB->ARGB and ARGB->RGB for 24/32 bit
- // images) are made separately from general ARGB conversion to
- // make them faster
- if (SrcInfo.BytesPerPixel = 3) and (DstInfo.BytesPerPixel = 4) then
- for I := 0 to NumPixels - 1 do
- begin
- PColor24Rec(Dst)^ := PColor24Rec(Src)^;
- if DstInfo.HasAlphaChannel then
- PColor32Rec(Dst).A := 255;
- Inc(Src, SrcInfo.BytesPerPixel);
- Inc(Dst, DstInfo.BytesPerPixel);
- end
- else
- if (SrcInfo.BytesPerPixel = 4) and (DstInfo.BytesPerPixel = 3) then
- for I := 0 to NumPixels - 1 do
- begin
- PColor24Rec(Dst)^ := PColor24Rec(Src)^;
- Inc(Src, SrcInfo.BytesPerPixel);
- Inc(Dst, DstInfo.BytesPerPixel);
- end
- else
- for I := 0 to NumPixels - 1 do
- begin
- // general ARGB conversion
- ChannelGetSrcPixel(Src, SrcInfo, Pix64);
- ChannelSetDstPixel(Dst, DstInfo, Pix64);
- Inc(Src, SrcInfo.BytesPerPixel);
- Inc(Dst, DstInfo.BytesPerPixel);
- end;
-end;
-
-procedure ChannelToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
- DstInfo: PImageFormatInfo);
-var
- I: LongInt;
- Pix64: TColor64Rec;
- Alpha: Word;
-begin
- // two most common conversions (R8G8B8->Gray8 nad A8R8G8B8->Gray8)
- // are made separately from general conversions to make them faster
- if (SrcInfo.BytesPerPixel in [3, 4]) and (DstInfo.Format = ifGray8) then
- for I := 0 to NumPixels - 1 do
- begin
- Dst^ := Round(GrayConv.R * PColor24Rec(Src).R + GrayConv.G * PColor24Rec(Src).G +
- GrayConv.B * PColor24Rec(Src).B);
- Inc(Src, SrcInfo.BytesPerPixel);
- Inc(Dst, DstInfo.BytesPerPixel);
- end
- else
- for I := 0 to NumPixels - 1 do
- begin
- ChannelGetSrcPixel(Src, SrcInfo, Pix64);
-
- // alpha is saved from source pixel to Alpha,
- // Gray value is computed and set to highest word of Pix64 so
- // Pix64.Color contains grayscale value scaled to 64 bits
- Alpha := Pix64.A;
- with GrayConv do
- Pix64.A := Round(R * Pix64.R + G * Pix64.G + B * Pix64.B);
-
- GraySetDstPixel(Dst, DstInfo, Pix64, Alpha);
- Inc(Src, SrcInfo.BytesPerPixel);
- Inc(Dst, DstInfo.BytesPerPixel);
- end;
-end;
-
-procedure ChannelToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
- DstInfo: PImageFormatInfo);
-var
- I: LongInt;
- Pix64: TColor64Rec;
- PixF: TColorFPRec;
-begin
- for I := 0 to NumPixels - 1 do
- begin
- ChannelGetSrcPixel(Src, SrcInfo, Pix64);
-
- // floating point channel values are scaled to 1.0
- PixF.A := Pix64.A * OneDiv16Bit;
- PixF.R := Pix64.R * OneDiv16Bit;
- PixF.G := Pix64.G * OneDiv16Bit;
- PixF.B := Pix64.B * OneDiv16Bit;
-
- FloatSetDstPixel(Dst, DstInfo, PixF);
- Inc(Src, SrcInfo.BytesPerPixel);
- Inc(Dst, DstInfo.BytesPerPixel);
- end;
-end;
-
-procedure ChannelToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
- DstInfo: PImageFormatInfo; DstPal: PPalette32);
-begin
- ReduceColorsMedianCut(NumPixels, Src, Dst, SrcInfo, DstInfo, DstInfo.PaletteEntries,
- GetOption(ImagingColorReductionMask), DstPal);
-end;
-
-procedure GrayToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
- DstInfo: PImageFormatInfo);
-var
- I: LongInt;
- Gray: TColor64Rec;
- Alpha: Word;
-begin
- // two most common conversions (Gray8->Gray16 nad Gray16->Gray8)
- // are made separately from general conversions to make them faster
- if (SrcInfo.Format = ifGray8) and (DstInfo.Format = ifGray16) then
- begin
- for I := 0 to NumPixels - 1 do
- PWordArray(Dst)[I] := PByteArray(Src)[I] shl 8;
- end
- else
- if (DstInfo.Format = ifGray8) and (SrcInfo.Format = ifGray16) then
- begin
- for I := 0 to NumPixels - 1 do
- PByteArray(Dst)[I] := PWordArray(Src)[I] shr 8;
- end
- else
- for I := 0 to NumPixels - 1 do
- begin
- // general grayscale conversion
- GrayGetSrcPixel(Src, SrcInfo, Gray, Alpha);
- GraySetDstPixel(Dst, DstInfo, Gray, Alpha);
- Inc(Src, SrcInfo.BytesPerPixel);
- Inc(Dst, DstInfo.BytesPerPixel);
- end;
-end;
-
-procedure GrayToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
- DstInfo: PImageFormatInfo);
-var
- I: LongInt;
- Pix64: TColor64Rec;
- Alpha: Word;
-begin
- // two most common conversions (Gray8->R8G8B8 nad Gray8->A8R8G8B8)
- // are made separately from general conversions to make them faster
- if (DstInfo.BytesPerPixel in [3, 4]) and (SrcInfo.Format = ifGray8) then
- for I := 0 to NumPixels - 1 do
- begin
- PColor24Rec(Dst).R := Src^;
- PColor24Rec(Dst).G := Src^;
- PColor24Rec(Dst).B := Src^;
- if DstInfo.HasAlphaChannel then
- PColor32Rec(Dst).A := $FF;
- Inc(Src, SrcInfo.BytesPerPixel);
- Inc(Dst, DstInfo.BytesPerPixel);
- end
- else
- for I := 0 to NumPixels - 1 do
- begin
- GrayGetSrcPixel(Src, SrcInfo, Pix64, Alpha);
-
- // most significant word of grayscale value is used for
- // each channel and alpha channel is set to Alpha
- Pix64.R := Pix64.A;
- Pix64.G := Pix64.A;
- Pix64.B := Pix64.A;
- Pix64.A := Alpha;
-
- ChannelSetDstPixel(Dst, DstInfo, Pix64);
- Inc(Src, SrcInfo.BytesPerPixel);
- Inc(Dst, DstInfo.BytesPerPixel);
- end;
-end;
-
-procedure GrayToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
- DstInfo: PImageFormatInfo);
-var
- I: LongInt;
- Gray: TColor64Rec;
- PixF: TColorFPRec;
- Alpha: Word;
-begin
- for I := 0 to NumPixels - 1 do
- begin
- GrayGetSrcPixel(Src, SrcInfo, Gray, Alpha);
- // most significant word of grayscale value is used for
- // each channel and alpha channel is set to Alpha
- // then all is scaled to 0..1
- PixF.R := Gray.A * OneDiv16Bit;
- PixF.G := Gray.A * OneDiv16Bit;
- PixF.B := Gray.A * OneDiv16Bit;
- PixF.A := Alpha * OneDiv16Bit;
-
- FloatSetDstPixel(Dst, DstInfo, PixF);
- Inc(Src, SrcInfo.BytesPerPixel);
- Inc(Dst, DstInfo.BytesPerPixel);
- end;
-end;
-
-procedure GrayToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
- DstInfo: PImageFormatInfo; DstPal: PPalette32);
-var
- I: LongInt;
- Idx: LongWord;
- Gray: TColor64Rec;
- Alpha, Shift: Word;
-begin
- FillGrayscalePalette(DstPal, DstInfo.PaletteEntries);
- Shift := Log2Int(DstInfo.PaletteEntries);
- // most common conversion (Gray8->Index8)
- // is made separately from general conversions to make it faster
- if (SrcInfo.Format = ifGray8) and (DstInfo.Format = ifIndex8) then
- for I := 0 to NumPixels - 1 do
- begin
- Dst^ := Src^;
- Inc(Src, SrcInfo.BytesPerPixel);
- Inc(Dst, DstInfo.BytesPerPixel);
- end
- else
- for I := 0 to NumPixels - 1 do
- begin
- // gray value is read from src and index to precomputed
- // grayscale palette is computed and written to dst
- // (we assume here that there will be no more than 65536 palette
- // entries in dst format, gray value is shifted so the highest
- // gray value match the highest possible index in palette)
- GrayGetSrcPixel(Src, SrcInfo, Gray, Alpha);
- Idx := Gray.A shr (16 - Shift);
- IndexSetDstPixel(Dst, DstInfo, Idx);
- Inc(Src, SrcInfo.BytesPerPixel);
- Inc(Dst, DstInfo.BytesPerPixel);
- end;
-end;
-
-procedure FloatToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
- DstInfo: PImageFormatInfo);
-var
- I: LongInt;
- PixF: TColorFPRec;
-begin
- for I := 0 to NumPixels - 1 do
- begin
- // general floating point conversion
- FloatGetSrcPixel(Src, SrcInfo, PixF);
- FloatSetDstPixel(Dst, DstInfo, PixF);
- Inc(Src, SrcInfo.BytesPerPixel);
- Inc(Dst, DstInfo.BytesPerPixel);
- end;
-end;
-
-procedure FloatToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
- DstInfo: PImageFormatInfo);
-var
- I: LongInt;
- Pix64: TColor64Rec;
- PixF: TColorFPRec;
-begin
- for I := 0 to NumPixels - 1 do
- begin
- FloatGetSrcPixel(Src, SrcInfo, PixF);
- ClampFloatPixel(PixF);
-
- // floating point channel values are scaled to 1.0
- Pix64.A := ClampToWord(Round(PixF.A * 65535));
- Pix64.R := ClampToWord(Round(PixF.R * 65535));
- Pix64.G := ClampToWord(Round(PixF.G * 65535));
- Pix64.B := ClampToWord(Round(PixF.B * 65535));
-
- ChannelSetDstPixel(Dst, DstInfo, Pix64);
- Inc(Src, SrcInfo.BytesPerPixel);
- Inc(Dst, DstInfo.BytesPerPixel);
- end;
-end;
-
-procedure FloatToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
- DstInfo: PImageFormatInfo);
-var
- I: LongInt;
- PixF: TColorFPRec;
- Gray: TColor64Rec;
- Alpha: Word;
-begin
- for I := 0 to NumPixels - 1 do
- begin
- FloatGetSrcPixel(Src, SrcInfo, PixF);
- ClampFloatPixel(PixF);
-
- // alpha is saved from source pixel to Alpha,
- // Gray value is computed and set to highest word of Pix64 so
- // Pix64.Color contains grayscale value scaled to 64 bits
- Alpha := ClampToWord(Round(PixF.A * 65535.0));
- Gray.A := ClampToWord(Round((GrayConv.R * PixF.R + GrayConv.G * PixF.G +
- GrayConv.B * PixF.B) * 65535.0));
-
- GraySetDstPixel(Dst, DstInfo, Gray, Alpha);
- Inc(Src, SrcInfo.BytesPerPixel);
- Inc(Dst, DstInfo.BytesPerPixel);
- end;
-end;
-
-procedure FloatToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
- DstInfo: PImageFormatInfo; DstPal: PPalette32);
-begin
- ReduceColorsMedianCut(NumPixels, Src, Dst, SrcInfo, DstInfo, DstInfo.PaletteEntries,
- GetOption(ImagingColorReductionMask), DstPal);
-end;
-
-procedure IndexToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
- DstInfo: PImageFormatInfo; SrcPal, DstPal: PPalette32);
-var
- I: LongInt;
-begin
- // there is only one indexed format now, so it is just a copy
- for I := 0 to NumPixels - 1 do
- begin
- Dst^ := Src^;
- Inc(Src, SrcInfo.BytesPerPixel);
- Inc(Dst, DstInfo.BytesPerPixel);
- end;
- for I := 0 to SrcInfo.PaletteEntries - 1 do
- DstPal[I] := SrcPal[I];
-end;
-
-procedure IndexToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
- DstInfo: PImageFormatInfo; SrcPal: PPalette32);
-var
- I: LongInt;
- Pix64: TColor64Rec;
- Idx: LongWord;
-begin
- // two most common conversions (Index8->R8G8B8 nad Index8->A8R8G8B8)
- // are made separately from general conversions to make them faster
- if (SrcInfo.Format = ifIndex8) and (DstInfo.Format in [ifR8G8B8, ifA8R8G8B8]) then
- for I := 0 to NumPixels - 1 do
- begin
- with PColor24Rec(Dst)^ do
- begin
- R := SrcPal[Src^].R;
- G := SrcPal[Src^].G;
- B := SrcPal[Src^].B;
- end;
- if DstInfo.Format = ifA8R8G8B8 then
- PColor32Rec(Dst).A := SrcPal[Src^].A;
- Inc(Src, SrcInfo.BytesPerPixel);
- Inc(Dst, DstInfo.BytesPerPixel);
- end
- else
- for I := 0 to NumPixels - 1 do
- begin
- // index to palette is read from source and color
- // is retrieved from palette entry. Color is then
- // scaled to 16bits and written to dest
- IndexGetSrcPixel(Src, SrcInfo, Idx);
- with Pix64 do
- begin
- A := SrcPal[Idx].A shl 8;
- R := SrcPal[Idx].R shl 8;
- G := SrcPal[Idx].G shl 8;
- B := SrcPal[Idx].B shl 8;
- end;
- ChannelSetDstPixel(Dst, DstInfo, Pix64);
- Inc(Src, SrcInfo.BytesPerPixel);
- Inc(Dst, DstInfo.BytesPerPixel);
- end;
-end;
-
-procedure IndexToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
- DstInfo: PImageFormatInfo; SrcPal: PPalette32);
-var
- I: LongInt;
- Gray: TColor64Rec;
- Alpha: Word;
- Idx: LongWord;
-begin
- // most common conversion (Index8->Gray8)
- // is made separately from general conversions to make it faster
- if (SrcInfo.Format = ifIndex8) and (DstInfo.Format = ifGray8) then
- begin
- for I := 0 to NumPixels - 1 do
- begin
- Dst^ := Round(GrayConv.R * SrcPal[Src^].R + GrayConv.G * SrcPal[Src^].G +
- GrayConv.B * SrcPal[Src^].B);
- Inc(Src, SrcInfo.BytesPerPixel);
- Inc(Dst, DstInfo.BytesPerPixel);
- end
- end
- else
- for I := 0 to NumPixels - 1 do
- begin
- // index to palette is read from source and color
- // is retrieved from palette entry. Color is then
- // transformed to grayscale and assigned to the highest
- // byte of Gray value
- IndexGetSrcPixel(Src, SrcInfo, Idx);
- Alpha := SrcPal[Idx].A shl 8;
- Gray.A := MulDiv(Round(GrayConv.R * SrcPal[Idx].R + GrayConv.G * SrcPal[Idx].G +
- GrayConv.B * SrcPal[Idx].B), 65535, 255);
- GraySetDstPixel(Dst, DstInfo, Gray, Alpha);
- Inc(Src, SrcInfo.BytesPerPixel);
- Inc(Dst, DstInfo.BytesPerPixel);
- end;
-end;
-
-procedure IndexToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
- DstInfo: PImageFormatInfo; SrcPal: PPalette32);
-var
- I: LongInt;
- Idx: LongWord;
- PixF: TColorFPRec;
-begin
- for I := 0 to NumPixels - 1 do
- begin
- // index to palette is read from source and color
- // is retrieved from palette entry. Color is then
- // scaled to 0..1 and written to dest
- IndexGetSrcPixel(Src, SrcInfo, Idx);
- with PixF do
- begin
- A := SrcPal[Idx].A * OneDiv8Bit;
- R := SrcPal[Idx].R * OneDiv8Bit;
- G := SrcPal[Idx].G * OneDiv8Bit;
- B := SrcPal[Idx].B * OneDiv8Bit;
- end;
- FloatSetDstPixel(Dst, DstInfo, PixF);
- Inc(Src, SrcInfo.BytesPerPixel);
- Inc(Dst, DstInfo.BytesPerPixel);
- end;
-end;
-
-
-{ Special formats conversion functions }
-
-type
- // DXT RGB color block
- TDXTColorBlock = packed record
- Color0, Color1: Word;
- Mask: LongWord;
- end;
- PDXTColorBlock = ^TDXTColorBlock;
-
- // DXT explicit alpha for a block
- TDXTAlphaBlockExp = packed record
- Alphas: array[0..3] of Word;
- end;
- PDXTAlphaBlockExp = ^TDXTAlphaBlockExp;
-
- // DXT interpolated alpha for a block
- TDXTAlphaBlockInt = packed record
- Alphas: array[0..7] of Byte;
- end;
- PDXTAlphaBlockInt = ^TDXTAlphaBlockInt;
-
- TPixelInfo = record
- Color: Word;
- Alpha: Byte;
- Orig: TColor32Rec;
- end;
-
- TPixelBlock = array[0..15] of TPixelInfo;
-
-function DecodeCol(Color: Word): TColor32Rec;
-{$IFDEF USE_INLINE} inline; {$ENDIF}
-begin
- Result.A := $FF;
-{ Result.R := ((Color and $F800) shr 11) shl 3;
- Result.G := ((Color and $07E0) shr 5) shl 2;
- Result.B := (Color and $001F) shl 3;}
- // this color expansion is slower but gives better results
- Result.R := (Color shr 11) * 255 div 31;
- Result.G := ((Color shr 5) and $3F) * 255 div 63;
- Result.B := (Color and $1F) * 255 div 31;
-end;
-
-procedure DecodeDXT1(SrcBits, DestBits: PByte; Width, Height: LongInt);
-var
- Sel, X, Y, I, J, K: LongInt;
- Block: TDXTColorBlock;
- Colors: array[0..3] of TColor32Rec;
-begin
- for Y := 0 to Height div 4 - 1 do
- for X := 0 to Width div 4 - 1 do
- begin
- Block := PDXTColorBlock(SrcBits)^;
- Inc(SrcBits, SizeOf(Block));
- // we read and decode endpoint colors
- Colors[0] := DecodeCol(Block.Color0);
- Colors[1] := DecodeCol(Block.Color1);
- // and interpolate between them
- if Block.Color0 > Block.Color1 then
- begin
- // interpolation for block without alpha
- Colors[2].A := $FF;
- Colors[2].R := (Colors[0].R shl 1 + Colors[1].R + 1) div 3;
- Colors[2].G := (Colors[0].G shl 1 + Colors[1].G + 1) div 3;
- Colors[2].B := (Colors[0].B shl 1 + Colors[1].B + 1) div 3;
- Colors[3].A := $FF;
- Colors[3].R := (Colors[0].R + Colors[1].R shl 1 + 1) div 3;
- Colors[3].G := (Colors[0].G + Colors[1].G shl 1 + 1) div 3;
- Colors[3].B := (Colors[0].B + Colors[1].B shl 1 + 1) div 3;
- end
- else
- begin
- // interpolation for block with alpha
- Colors[2].A := $FF;
- Colors[2].R := (Colors[0].R + Colors[1].R) shr 1;
- Colors[2].G := (Colors[0].G + Colors[1].G) shr 1;
- Colors[2].B := (Colors[0].B + Colors[1].B) shr 1;
- Colors[3].A := 0;
- Colors[3].R := (Colors[0].R + Colors[1].R shl 1 + 1) div 3;
- Colors[3].G := (Colors[0].G + Colors[1].G shl 1 + 1) div 3;
- Colors[3].B := (Colors[0].B + Colors[1].B shl 1 + 1) div 3;
- end;
-
- // we distribute the dxt block colors across the 4x4 block of the
- // destination image accroding to the dxt block mask
- K := 0;
- for J := 0 to 3 do
- for I := 0 to 3 do
- begin
- Sel := (Block.Mask and (3 shl (K shl 1))) shr (K shl 1);
- if ((X shl 2 + I) < Width) and ((Y shl 2 + J) < Height) then
- PPalette32(DestBits)[(Y shl 2 + J) * Width + X shl 2 + I] :=
- Colors[Sel];
- Inc(K);
- end;
- end;
-end;
-
-procedure DecodeDXT3(SrcBits, DestBits: PByte; Width, Height: LongInt);
-var
- Sel, X, Y, I, J, K: LongInt;
- Block: TDXTColorBlock;
- AlphaBlock: TDXTAlphaBlockExp;
- Colors: array[0..3] of TColor32Rec;
- AWord: Word;
-begin
- for Y := 0 to Height div 4 - 1 do
- for X := 0 to Width div 4 - 1 do
- begin
- AlphaBlock := PDXTAlphaBlockExp(SrcBits)^;
- Inc(SrcBits, SizeOf(AlphaBlock));
- Block := PDXTColorBlock(SrcBits)^;
- Inc(SrcBits, SizeOf(Block));
- // we read and decode endpoint colors
- Colors[0] := DecodeCol(Block.Color0);
- Colors[1] := DecodeCol(Block.Color1);
- // and interpolate between them
- Colors[2].R := (Colors[0].R shl 1 + Colors[1].R + 1) div 3;
- Colors[2].G := (Colors[0].G shl 1 + Colors[1].G + 1) div 3;
- Colors[2].B := (Colors[0].B shl 1 + Colors[1].B + 1) div 3;
- Colors[3].R := (Colors[0].R + Colors[1].R shl 1 + 1) div 3;
- Colors[3].G := (Colors[0].G + Colors[1].G shl 1 + 1) div 3;
- Colors[3].B := (Colors[0].B + Colors[1].B shl 1 + 1) div 3;
-
- // we distribute the dxt block colors and alphas
- // across the 4x4 block of the destination image
- // accroding to the dxt block mask and alpha block
- K := 0;
- for J := 0 to 3 do
- begin
- AWord := AlphaBlock.Alphas[J];
- for I := 0 to 3 do
- begin
- Sel := (Block.Mask and (3 shl (K shl 1))) shr (K shl 1);
- if (X shl 2 + I < Width) and (Y shl 2 + J < Height) then
- begin
- Colors[Sel].A := AWord and $0F;
- Colors[Sel].A := Colors[Sel].A or (Colors[Sel].A shl 4);
- PPalette32(DestBits)[(Y shl 2 + J) * Width + X shl 2 + I] :=
- Colors[Sel];
- end;
- Inc(K);
- AWord := AWord shr 4;
- 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);
-var
- Sel, X, Y, I, J, K: LongInt;
- Block: TDXTColorBlock;
- AlphaBlock: TDXTAlphaBlockInt;
- Colors: array[0..3] of TColor32Rec;
- AMask: 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
- AlphaBlock := PDXTAlphaBlockInt(SrcBits)^;
- Inc(SrcBits, SizeOf(AlphaBlock));
- Block := PDXTColorBlock(SrcBits)^;
- Inc(SrcBits, SizeOf(Block));
- // we read and decode endpoint colors
- Colors[0] := DecodeCol(Block.Color0);
- Colors[1] := DecodeCol(Block.Color1);
- // and interpolate between them
- Colors[2].R := (Colors[0].R shl 1 + Colors[1].R + 1) div 3;
- Colors[2].G := (Colors[0].G shl 1 + Colors[1].G + 1) div 3;
- Colors[2].B := (Colors[0].B shl 1 + Colors[1].B + 1) div 3;
- Colors[3].R := (Colors[0].R + Colors[1].R shl 1 + 1) div 3;
- Colors[3].G := (Colors[0].G + Colors[1].G shl 1 + 1) div 3;
- Colors[3].B := (Colors[0].B + Colors[1].B shl 1 + 1) div 3;
- // 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 colors and alphas
- // across the 4x4 block of the destination image
- // accroding to the dxt block mask and alpha block mask
- K := 0;
- for J := 0 to 3 do
- for I := 0 to 3 do
- begin
- Sel := (Block.Mask and (3 shl (K shl 1))) shr (K shl 1);
- if ((X shl 2 + I) < Width) and ((Y shl 2 + J) < Height) then
- begin
- Colors[Sel].A := AlphaBlock.Alphas[AMask[J shr 1] and 7];
- PPalette32(DestBits)[(Y shl 2 + J) * Width + (X shl 2 + I)] :=
- Colors[Sel];
- end;
- Inc(K);
- AMask[J shr 1] := AMask[J shr 1] shr 3;
- end;
- end;
-end;
-
-procedure GetBlock(var Block: TPixelBlock; SrcBits: Pointer; XPos, YPos,
- Width, Height: LongInt);
-var
- X, Y, I: LongInt;
- Src: PColor32Rec;
-begin
- I := 0;
- // 4x4 pixel block is filled with information about every
- // pixel in the block: alpha, original color, 565 color
- for Y := 0 to 3 do
- for X := 0 to 3 do
- begin
- Src := @PPalette32(SrcBits)[(YPos shl 2 + Y) * Width + XPos shl 2 + X];
- Block[I].Color := ((Src.R shr 3) shl 11) or ((Src.G shr 2) shl 5) or
- (Src.B shr 3);
- Block[I].Alpha := Src.A;
- Block[I].Orig := Src^;
- Inc(I);
- end;
-end;
-
-function ColorDistance(const C1, C2: TColor32Rec): LongInt;
-{$IFDEF USE_INLINE} inline;{$ENDIF}
-begin
- Result := (C1.R - C2.R) * (C1.R - C2.R) +
- (C1.G - C2.G) * (C1.G - C2.G) + (C1.B - C2.B) * (C1.B - C2.B);
-end;
-
-procedure GetEndpoints(const Block: TPixelBlock; var Ep0, Ep1: Word);
-var
- I, J, Farthest, Dist: LongInt;
- Colors: array[0..15] of TColor32Rec;
-begin
- // we choose two colors from the pixel block which has the
- // largest distance between them
- for I := 0 to 15 do
- Colors[I] := Block[I].Orig;
- Farthest := -1;
- for I := 0 to 15 do
- for J := I + 1 to 15 do
- begin
- Dist := ColorDistance(Colors[I], Colors[J]);
- if Dist > Farthest then
- begin
- Farthest := Dist;
- Ep0 := Block[I].Color;
- Ep1 := Block[J].Color;
- end;
- end;
-end;
-
-procedure GetAlphaEndpoints(const Block: TPixelBlock; var Min, Max: Byte);
-var
- I: LongInt;
-begin
- Min := 255;
- Max := 0;
- // we choose the lowest and the highest alpha values
- for I := 0 to 15 do
- begin
- if Block[I].Alpha < Min then
- Min := Block[I].Alpha;
- if Block[I].Alpha > Max then
- Max := Block[I].Alpha;
- end;
-end;
-
-procedure FixEndpoints(var Ep0, Ep1: Word; HasAlpha: Boolean);
-var
- Temp: Word;
-begin
- // if dxt block has alpha information, Ep0 must be smaller
- // than Ep1, if the block has no alpha Ep1 must be smaller
- if HasAlpha then
- begin
- if Ep0 > Ep1 then
- begin
- Temp := Ep0;
- Ep0 := Ep1;
- Ep1 := Temp;
- end;
- end
- else
- if Ep0 < Ep1 then
- begin
- Temp := Ep0;
- Ep0 := Ep1;
- Ep1 := Temp;
- end;
-end;
-
-function GetColorMask(Ep0, Ep1: Word; NumCols: LongInt;
- const Block: TPixelBlock): LongWord;
-var
- I, J, Closest, Dist: LongInt;
- Colors: array[0..3] of TColor32Rec;
- Mask: array[0..15] of Byte;
-begin
- // we decode endpoint colors
- Colors[0] := DecodeCol(Ep0);
- Colors[1] := DecodeCol(Ep1);
- // and interpolate colors between (3 for DXT1 with alpha, 4 for the others)
- if NumCols = 3 then
- begin
- Colors[2].R := (Colors[0].R + Colors[1].R) shr 1;
- Colors[2].G := (Colors[0].G + Colors[1].G) shr 1;
- Colors[2].B := (Colors[0].B + Colors[1].B) shr 1;
- Colors[3].R := (Colors[0].R + Colors[1].R) shr 1;
- Colors[3].G := (Colors[0].G + Colors[1].G) shr 1;
- Colors[3].B := (Colors[0].B + Colors[1].B) shr 1;
- end
- else
- begin
- Colors[2].R := (Colors[0].R shl 1 + Colors[1].R + 1) div 3;
- Colors[2].G := (Colors[0].G shl 1 + Colors[1].G + 1) div 3;
- Colors[2].B := (Colors[0].B shl 1 + Colors[1].B + 1) div 3;
- Colors[3].R := (Colors[0].R + Colors[1].R shl 1 + 1) div 3;
- Colors[3].G := (Colors[0].G + Colors[1].G shl 1 + 1) div 3;
- Colors[3].B := (Colors[0].B + Colors[1].B shl 1 + 1) div 3;
- end;
-
- for I := 0 to 15 do
- begin
- // this is only for DXT1 with alpha
- if (Block[I].Alpha < 128) and (NumCols = 3) then
- begin
- Mask[I] := 3;
- Continue;
- end;
- // for each of the 16 input pixels the nearest color in the
- // 4 dxt colors is found
- Closest := MaxInt;
- for J := 0 to NumCols - 1 do
- begin
- Dist := ColorDistance(Block[I].Orig, Colors[J]);
- if Dist < Closest then
- begin
- Closest := Dist;
- Mask[I] := J;
- end;
- end;
- end;
-
- Result := 0;
- for I := 0 to 15 do
- Result := Result or (Mask[I] shl (I shl 1));
-end;
-
-procedure GetAlphaMask(Ep0, Ep1: Byte; var Block: TPixelBlock; Mask: PByteArray);
-var
- Alphas: array[0..7] of Byte;
- M: array[0..15] of Byte;
- I, J, Closest, Dist: LongInt;
-begin
- Alphas[0] := Ep0;
- Alphas[1] := Ep1;
- // interpolation between two given alpha endpoints
- // (I use 6 interpolated values mode)
- 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;
-
- // the closest interpolated values for each of the input alpha
- // is found
- for I := 0 to 15 do
- begin
- Closest := MaxInt;
- for J := 0 to 7 do
- begin
- Dist := Abs(Alphas[J] - Block[I].Alpha);
- if Dist < Closest then
- begin
- Closest := Dist;
- M[I] := J;
- end;
- end;
- end;
-
- Mask[0] := M[0] or (M[1] shl 3) or ((M[2] and 3) shl 6);
- Mask[1] := ((M[2] and 4) shr 2) or (M[3] shl 1) or (M[4] shl 4) or
- ((M[5] and 1) shl 7);
- Mask[2] := ((M[5] and 6) shr 1) or (M[6] shl 2) or (M[7] shl 5);
- Mask[3] := M[8] or (M[9] shl 3) or ((M[10] and 3) shl 6);
- Mask[4] := ((M[10] and 4) shr 2) or (M[11] shl 1) or (M[12] shl 4) or
- ((M[13] and 1) shl 7);
- Mask[5] := ((M[13] and 6) shr 1) or (M[14] shl 2) or (M[15] shl 5);
-end;
-
-
-procedure EncodeDXT1(SrcBits: PByte; DestBits: PByte; Width, Height: LongInt);
-var
- X, Y, I: LongInt;
- HasAlpha: Boolean;
- Block: TDXTColorBlock;
- Pixels: TPixelBlock;
-begin
- for Y := 0 to Height div 4 - 1 do
- for X := 0 to Width div 4 - 1 do
- begin
- GetBlock(Pixels, SrcBits, X, Y, Width, Height);
- HasAlpha := False;
- for I := 0 to 15 do
- if Pixels[I].Alpha < 128 then
- begin
- HasAlpha := True;
- Break;
- end;
- GetEndpoints(Pixels, Block.Color0, Block.Color1);
- FixEndpoints(Block.Color0, Block.Color1, HasAlpha);
- if HasAlpha then
- Block.Mask := GetColorMask(Block.Color0, Block.Color1, 3, Pixels)
- else
- Block.Mask := GetColorMask(Block.Color0, Block.Color1, 4, Pixels);
- PDXTColorBlock(DestBits)^ := Block;
- Inc(DestBits, SizeOf(Block));
- end;
-end;
-
-procedure EncodeDXT3(SrcBits: Pointer; DestBits: PByte; Width, Height: LongInt);
-var
- X, Y, I: LongInt;
- Block: TDXTColorBlock;
- AlphaBlock: TDXTAlphaBlockExp;
- Pixels: TPixelBlock;
-begin
- for Y := 0 to Height div 4 - 1 do
- for X := 0 to Width div 4 - 1 do
- begin
- GetBlock(Pixels, SrcBits, X, Y, Width, Height);
- for I := 0 to 7 do
- PByteArray(@AlphaBlock.Alphas)[I] :=
- (Pixels[I shl 1].Alpha shr 4) or ((Pixels[I shl 1 + 1].Alpha shr 4) shl 4);
- GetEndpoints(Pixels, Block.Color0, Block.Color1);
- FixEndpoints(Block.Color0, Block.Color1, False);
- Block.Mask := GetColorMask(Block.Color0, Block.Color1, 4, Pixels);
- PDXTAlphaBlockExp(DestBits)^ := AlphaBlock;
- Inc(DestBits, SizeOf(AlphaBlock));
- PDXTColorBlock(DestBits)^ := Block;
- Inc(DestBits, SizeOf(Block));
- end;
-end;
-
-procedure EncodeDXT5(SrcBits: Pointer; DestBits: PByte; Width, Height: LongInt);
-var
- X, Y: LongInt;
- Block: TDXTColorBlock;
- AlphaBlock: TDXTAlphaBlockInt;
- Pixels: TPixelBlock;
-begin
- for Y := 0 to Height div 4 - 1 do
- for X := 0 to Width div 4 - 1 do
- begin
- GetBlock(Pixels, SrcBits, X, Y, Width, Height);
- GetEndpoints(Pixels, Block.Color0, Block.Color1);
- FixEndpoints(Block.Color0, Block.Color1, False);
- Block.Mask := GetColorMask(Block.Color0, Block.Color1, 4, Pixels);
- 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));
- PDXTColorBlock(DestBits)^ := Block;
- Inc(DestBits, SizeOf(Block));
- end;
-end;
-
-type
- TBTCBlock = packed record
- MLower, MUpper: Byte;
- BitField: Word;
- end;
- PBTCBlock = ^TBTCBlock;
-
-procedure EncodeBTC(SrcBits: Pointer; DestBits: PByte; Width, Height: Integer);
-var
- X, Y, I, J: Integer;
- Block: TBTCBlock;
- M, MLower, MUpper, K: Integer;
- Pixels: array[0..15] of Byte;
-begin
- for Y := 0 to Height div 4 - 1 do
- for X := 0 to Width div 4 - 1 do
- begin
- M := 0;
- MLower := 0;
- MUpper := 0;
- FillChar(Block, SizeOf(Block), 0);
- K := 0;
-
- // Store 4x4 pixels and compute average, lower, and upper intensity levels
- for I := 0 to 3 do
- for J := 0 to 3 do
- begin
- Pixels[K] := PByteArray(SrcBits)[(Y shl 2 + I) * Width + X shl 2 + J];
- Inc(M, Pixels[K]);
- Inc(K);
- end;
-
- M := M div 16;
- K := 0;
-
- // Now compute upper and lower levels, number of upper pixels,
- // and update bit field (1 when pixel is above avg. level M)
- for I := 0 to 15 do
- begin
- if Pixels[I] > M then
- begin
- Inc(MUpper, Pixels[I]);
- Inc(K);
- Block.BitField := Block.BitField or (1 shl I);
- end
- else
- Inc(MLower, Pixels[I]);
- end;
-
- // Scale levels and save them to block
- if K > 0 then
- Block.MUpper := ClampToByte(MUpper div K)
- else
- Block.MUpper := 0;
- Block.MLower := ClampToByte(MLower div (16 - K));
-
- // Finally save block to dest data
- PBTCBlock(DestBits)^ := Block;
- Inc(DestBits, SizeOf(Block));
- end;
-end;
-
-procedure GetOneChannelBlock(var Block: TPixelBlock; SrcBits: Pointer; XPos, YPos,
- Width, Height, BytesPP, ChannelIdx: Integer);
-var
- X, Y, I: Integer;
- Src: PByte;
-begin
- I := 0;
- // 4x4 pixel block is filled with information about every pixel in the block,
- // but only one channel value is stored in Alpha field
- for Y := 0 to 3 do
- for X := 0 to 3 do
- begin
- Src := @PByteArray(SrcBits)[(YPos * 4 + Y) * Width * BytesPP +
- (XPos * 4 + X) * BytesPP + ChannelIdx];
- Block[I].Alpha := Src^;
- Inc(I);
- end;
-end;
-
-procedure EncodeATI1N(SrcBits: Pointer; DestBits: PByte; Width, Height: Integer);
-var
- X, Y: Integer;
- AlphaBlock: TDXTAlphaBlockInt;
- Pixels: TPixelBlock;
-begin
- for Y := 0 to Height div 4 - 1 do
- for X := 0 to Width div 4 - 1 do
- begin
- // Encode one channel
- GetOneChannelBlock(Pixels, SrcBits, X, Y, Width, Height, 1, 0);
- GetAlphaEndPoints(Pixels, AlphaBlock.Alphas[1], AlphaBlock.Alphas[0]);
- GetAlphaMask(AlphaBlock.Alphas[0], AlphaBlock.Alphas[1], Pixels,
- PByteArray(@AlphaBlock.Alphas[2]));
- PDXTAlphaBlockInt(DestBits)^ := AlphaBlock;
- Inc(DestBits, SizeOf(AlphaBlock));
- end;
-end;
-
-procedure EncodeATI2N(SrcBits: Pointer; DestBits: PByte; Width, Height: Integer);
-var
- X, Y: Integer;
- AlphaBlock: TDXTAlphaBlockInt;
- Pixels: TPixelBlock;
-begin
- for Y := 0 to Height div 4 - 1 do
- for X := 0 to Width div 4 - 1 do
- begin
- // Encode Red/X channel
- GetOneChannelBlock(Pixels, SrcBits, X, Y, Width, Height, 4, ChannelRed);
- GetAlphaEndPoints(Pixels, AlphaBlock.Alphas[1], AlphaBlock.Alphas[0]);
- GetAlphaMask(AlphaBlock.Alphas[0], AlphaBlock.Alphas[1], Pixels,
- PByteArray(@AlphaBlock.Alphas[2]));
- PDXTAlphaBlockInt(DestBits)^ := AlphaBlock;
- Inc(DestBits, SizeOf(AlphaBlock));
- // Encode Green/Y channel
- GetOneChannelBlock(Pixels, SrcBits, X, Y, Width, Height, 4, ChannelGreen);
- GetAlphaEndPoints(Pixels, AlphaBlock.Alphas[1], AlphaBlock.Alphas[0]);
- GetAlphaMask(AlphaBlock.Alphas[0], AlphaBlock.Alphas[1], Pixels,
- PByteArray(@AlphaBlock.Alphas[2]));
- PDXTAlphaBlockInt(DestBits)^ := AlphaBlock;
- Inc(DestBits, SizeOf(AlphaBlock));
- end;
-end;
-
-procedure DecodeBTC(SrcBits, DestBits: PByte; Width, Height: Integer);
-var
- X, Y, I, J, K: Integer;
- Block: TBTCBlock;
- Dest: PByte;
-begin
- for Y := 0 to Height div 4 - 1 do
- for X := 0 to Width div 4 - 1 do
- begin
- Block := PBTCBlock(SrcBits)^;
- Inc(SrcBits, SizeOf(Block));
- K := 0;
-
- // Just write MUpper when there is '1' in bit field and MLower
- // when there is '0'
- for I := 0 to 3 do
- for J := 0 to 3 do
- begin
- Dest := @PByteArray(DestBits)[(Y shl 2 + I) * Width + X shl 2 + J];
- if Block.BitField and (1 shl K) <> 0 then
- Dest^ := Block.MUpper
- else
- Dest^ := Block.MLower;
- Inc(K);
- end;
- end;
-end;
-
-procedure DecodeATI1N(SrcBits, DestBits: PByte; Width, Height: Integer);
-var
- X, Y, I, J: Integer;
- AlphaBlock: TDXTAlphaBlockInt;
- AMask: 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
- AlphaBlock := PDXTAlphaBlockInt(SrcBits)^;
- Inc(SrcBits, SizeOf(AlphaBlock));
- // 6 bit alpha mask is copied into two long words for
- // easier usage
- AMask[0] := PLongWord(@AlphaBlock.Alphas[2])^ and $00FFFFFF;
- AMask[1] := PLongWord(@AlphaBlock.Alphas[5])^ and $00FFFFFF;
- // alpha interpolation between two endpoint alphas
- GetInterpolatedAlphas(AlphaBlock);
-
- // we distribute the dxt block alphas
- // across the 4x4 block of the destination image
- for J := 0 to 3 do
- for I := 0 to 3 do
- begin
- PByteArray(DestBits)[(Y shl 2 + J) * Width + (X shl 2 + I)] :=
- AlphaBlock.Alphas[AMask[J shr 1] and 7];
- AMask[J shr 1] := AMask[J shr 1] shr 3;
- end;
- end;
-end;
-
-procedure DecodeATI2N(SrcBits, DestBits: PByte; Width, Height: Integer);
-var
- X, Y, I, J: Integer;
- Color: TColor32Rec;
- AlphaBlock1, AlphaBlock2: TDXTAlphaBlockInt;
- AMask1: array[0..1] of LongWord;
- AMask2: array[0..1] of LongWord;
-begin
- for Y := 0 to Height div 4 - 1 do
- for X := 0 to Width div 4 - 1 do
- begin
- // Read the first alpha block and get masks
- AlphaBlock1 := PDXTAlphaBlockInt(SrcBits)^;
- Inc(SrcBits, SizeOf(AlphaBlock1));
- AMask1[0] := PLongWord(@AlphaBlock1.Alphas[2])^ and $00FFFFFF;
- AMask1[1] := PLongWord(@AlphaBlock1.Alphas[5])^ and $00FFFFFF;
- // Read the secind alpha block and get masks
- AlphaBlock2 := PDXTAlphaBlockInt(SrcBits)^;
- Inc(SrcBits, SizeOf(AlphaBlock2));
- AMask2[0] := PLongWord(@AlphaBlock2.Alphas[2])^ and $00FFFFFF;
- AMask2[1] := PLongWord(@AlphaBlock2.Alphas[5])^ and $00FFFFFF;
- // alpha interpolation between two endpoint alphas
- GetInterpolatedAlphas(AlphaBlock1);
- GetInterpolatedAlphas(AlphaBlock2);
-
- Color.A := $FF;
- Color.B := 0;
-
- // Distribute alpha block values across 4x4 pixel block,
- // first alpha block represents Red channel, second is Green.
- for J := 0 to 3 do
- for I := 0 to 3 do
- begin
- Color.R := AlphaBlock1.Alphas[AMask1[J shr 1] and 7];
- Color.G := AlphaBlock2.Alphas[AMask2[J shr 1] and 7];
- PColor32RecArray(DestBits)[(Y shl 2 + J) * Width + (X shl 2 + I)] := Color;
- AMask1[J shr 1] := AMask1[J shr 1] shr 3;
- AMask2[J shr 1] := AMask2[J shr 1] shr 3;
- end;
- end;
-end;
-
-procedure SpecialToUnSpecial(const SrcImage: TImageData; DestBits: Pointer;
- SpecialFormat: TImageFormat);
-begin
- case SpecialFormat of
- ifDXT1: DecodeDXT1(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
- ifDXT3: DecodeDXT3(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
- ifDXT5: DecodeDXT5(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
- ifBTC: DecodeBTC (SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
- ifATI1N: DecodeATI1N(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
- ifATI2N: DecodeATI2N(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
- end;
-end;
-
-procedure UnSpecialToSpecial(SrcBits: Pointer; const DestImage: TImageData;
- SpecialFormat: TImageFormat);
-begin
- case SpecialFormat of
- ifDXT1: EncodeDXT1(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
- ifDXT3: EncodeDXT3(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
- ifDXT5: EncodeDXT5(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
- ifBTC: EncodeBTC (SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
- ifATI1N: EncodeATI1N(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
- ifATI2N: EncodeATI2N(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
- end;
-end;
-
-procedure ConvertSpecial(var Image: TImageData;
- SrcInfo, DstInfo: PImageFormatInfo);
-var
- WorkImage: TImageData;
-
- procedure CheckSize(var Img: TImageData; Info: PImageFormatInfo);
- var
- Width, Height: Integer;
- begin
- Width := Img.Width;
- Height := Img.Height;
- DstInfo.CheckDimensions(Info.Format, Width, Height);
- ResizeImage(Img, Width, Height, rfNearest);
- end;
-
-begin
- if SrcInfo.IsSpecial and DstInfo.IsSpecial then
- begin
- // Convert source to nearest 'normal' format
- InitImage(WorkImage);
- NewImage(Image.Width, Image.Height, SrcInfo.SpecialNearestFormat, WorkImage);
- SpecialToUnSpecial(Image, WorkImage.Bits, SrcInfo.Format);
- FreeImage(Image);
- // Make sure output of SpecialToUnSpecial is the same as input of
- // UnSpecialToSpecial
- if SrcInfo.SpecialNearestFormat <> DstInfo.SpecialNearestFormat then
- ConvertImage(WorkImage, DstInfo.SpecialNearestFormat);
- // Convert work image to dest special format
- CheckSize(WorkImage, DstInfo);
- NewImage(WorkImage.Width, WorkImage.Height, DstInfo.Format, Image);
- UnSpecialToSpecial(WorkImage.Bits, Image, DstInfo.Format);
- FreeImage(WorkImage);
- end
- else if SrcInfo.IsSpecial and not DstInfo.IsSpecial then
- begin
- // Convert source to nearest 'normal' format
- InitImage(WorkImage);
- NewImage(Image.Width, Image.Height, SrcInfo.SpecialNearestFormat, WorkImage);
- SpecialToUnSpecial(Image, WorkImage.Bits, SrcInfo.Format);
- FreeImage(Image);
- // Now convert to dest format
- ConvertImage(WorkImage, DstInfo.Format);
- Image := WorkImage;
- end
- else if not SrcInfo.IsSpecial and DstInfo.IsSpecial then
- begin
- // Convert source to nearest format
- WorkImage := Image;
- ConvertImage(WorkImage, DstInfo.SpecialNearestFormat);
- // Now convert from nearest to dest
- CheckSize(WorkImage, DstInfo);
- InitImage(Image);
- NewImage(WorkImage.Width, WorkImage.Height, DstInfo.Format, Image);
- UnSpecialToSpecial(WorkImage.Bits, Image, DstInfo.Format);
- FreeImage(WorkImage);
- end;
-end;
-
-function GetStdPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt;
-begin
- if FInfos[Format] <> nil then
- Result := Width * Height * FInfos[Format].BytesPerPixel
- else
- Result := 0;
-end;
-
-procedure CheckStdDimensions(Format: TImageFormat; var Width, Height: LongInt);
-begin
-end;
-
-function GetDXTPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt;
-begin
- // DXT can be used only for images with dimensions that are
- // multiples of four
- CheckDXTDimensions(Format, Width, Height);
- Result := Width * Height;
- if Format in [ifDXT1, ifATI1N] then
- Result := Result div 2;
-end;
-
-procedure CheckDXTDimensions(Format: TImageFormat; var Width, Height: LongInt);
-begin
- // DXT image dimensions must be multiples of four
- Width := (Width + 3) and not 3; // div 4 * 4;
- Height := (Height + 3) and not 3; // div 4 * 4;
-end;
-
-function GetBTCPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt;
-begin
- // BTC can be used only for images with dimensions that are
- // multiples of four
- CheckDXTDimensions(Format, Width, Height);
- Result := Width * Height div 4; // 2bits/pixel
-end;
-
-{ Optimized pixel readers/writers for 32bit and FP colors to be stored in TImageFormatInfo }
-
-function GetPixel32ifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColor32Rec;
-begin
- Result.Color := PLongWord(Bits)^;
-end;
-
-procedure SetPixel32ifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColor32Rec);
-begin
- PLongWord(Bits)^ := Color.Color;
-end;
-
-function GetPixelFPifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec;
-begin
- Result.A := PColor32Rec(Bits).A * OneDiv8Bit;
- Result.R := PColor32Rec(Bits).R * OneDiv8Bit;
- Result.G := PColor32Rec(Bits).G * OneDiv8Bit;
- Result.B := PColor32Rec(Bits).B * OneDiv8Bit;
-end;
-
-procedure SetPixelFPifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec);
-begin
- PColor32Rec(Bits).A := ClampToByte(Round(Color.A * 255.0));
- PColor32Rec(Bits).R := ClampToByte(Round(Color.R * 255.0));
- PColor32Rec(Bits).G := ClampToByte(Round(Color.G * 255.0));
- PColor32Rec(Bits).B := ClampToByte(Round(Color.B * 255.0));
-end;
-
-function GetPixel32Channel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColor32Rec;
-begin
- case Info.Format of
- ifR8G8B8, ifX8R8G8B8:
- begin
- Result.A := $FF;
- PColor24Rec(@Result)^ := PColor24Rec(Bits)^;
- end;
- ifGray8, ifA8Gray8:
- begin
- if Info.HasAlphaChannel then
- Result.A := PWordRec(Bits).High
- else
- Result.A := $FF;
- Result.R := PWordRec(Bits).Low;
- Result.G := PWordRec(Bits).Low;
- Result.B := PWordRec(Bits).Low;
- end;
- end;
-end;
-
-procedure SetPixel32Channel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColor32Rec);
-begin
- case Info.Format of
- ifR8G8B8, ifX8R8G8B8:
- begin
- PColor24Rec(Bits)^ := PColor24Rec(@Color)^;
- end;
- ifGray8, ifA8Gray8:
- begin
- if Info.HasAlphaChannel then
- PWordRec(Bits).High := Color.A;
- PWordRec(Bits).Low := Round(GrayConv.R * Color.R + GrayConv.G * Color.G +
- GrayConv.B * Color.B);
- end;
- end;
-end;
-
-function GetPixelFPChannel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec;
-begin
- case Info.Format of
- ifR8G8B8, ifX8R8G8B8:
- begin
- Result.A := 1.0;
- Result.R := PColor24Rec(Bits).R * OneDiv8Bit;
- Result.G := PColor24Rec(Bits).G * OneDiv8Bit;
- Result.B := PColor24Rec(Bits).B * OneDiv8Bit;
- end;
- ifGray8, ifA8Gray8:
- begin
- if Info.HasAlphaChannel then
- Result.A := PWordRec(Bits).High * OneDiv8Bit
- else
- Result.A := 1.0;
- Result.R := PWordRec(Bits).Low * OneDiv8Bit;
- Result.G := PWordRec(Bits).Low * OneDiv8Bit;
- Result.B := PWordRec(Bits).Low * OneDiv8Bit;
- end;
- end;
-end;
-
-procedure SetPixelFPChannel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec);
-begin
- case Info.Format of
- ifR8G8B8, ifX8R8G8B8:
- begin
- PColor24Rec(Bits).R := ClampToByte(Round(Color.R * 255.0));
- PColor24Rec(Bits).G := ClampToByte(Round(Color.G * 255.0));
- PColor24Rec(Bits).B := ClampToByte(Round(Color.B * 255.0));
- end;
- ifGray8, ifA8Gray8:
- begin
- if Info.HasAlphaChannel then
- PWordRec(Bits).High := ClampToByte(Round(Color.A * 255.0));
- PWordRec(Bits).Low := ClampToByte(Round((GrayConv.R * Color.R + GrayConv.G * Color.G +
- GrayConv.B * Color.B) * 255.0));
- end;
- end;
-end;
-
-function GetPixelFPFloat32(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec;
-begin
- case Info.Format of
- ifA32R32G32B32F:
- begin
- Result := PColorFPRec(Bits)^;
- end;
- ifA32B32G32R32F:
- begin
- Result := PColorFPRec(Bits)^;
- SwapValues(Result.R, Result.B);
- end;
- ifR32F:
- begin
- Result.A := 1.0;
- Result.R := PSingle(Bits)^;
- Result.G := 0.0;
- Result.B := 0.0;
- end;
- end;
-end;
-
-procedure SetPixelFPFloat32(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec);
-begin
- case Info.Format of
- ifA32R32G32B32F:
- begin
- PColorFPRec(Bits)^ := Color;
- end;
- ifA32B32G32R32F:
- begin
- PColorFPRec(Bits)^ := Color;
- SwapValues(PColorFPRec(Bits).R, PColorFPRec(Bits).B);
- end;
- ifR32F:
- begin
- PSingle(Bits)^ := Color.R;
- 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:
-
- -- TODOS ----------------------------------------------------
- - nothing now
-
- -- 0.26.3 Changes/Bug Fixes -----------------------------------
- - Filtered resampling ~10% faster now.
- - Fixed DXT3 alpha encoding.
- - ifIndex8 format now has HasAlphaChannel=True.
-
- -- 0.25.0 Changes/Bug Fixes -----------------------------------
- - Made some resampling stuff public so that it can be used in canvas class.
- - Added some color constructors.
- - Added VisualizePalette helper function.
- - Fixed ConvertSpecial, not very readable before and error when
- converting special->special.
-
- -- 0.24.3 Changes/Bug Fixes -----------------------------------
- - Some refactorings a changes to DXT based formats.
- - Added ifATI1N and ifATI2N image data formats support structures and functions.
-
- -- 0.23 Changes/Bug Fixes -----------------------------------
- - Added ifBTC image format support structures and functions.
-
- -- 0.21 Changes/Bug Fixes -----------------------------------
- - FillMipMapLevel now works well with indexed and special formats too.
- - Moved Convert1To8 and Convert4To8 functions from ImagingBitmaps here
- and created new Convert2To8 function. They are now used by more than one
- file format loader.
-
- -- 0.19 Changes/Bug Fixes -----------------------------------
- - StretchResample now uses pixel get/set functions stored in
- TImageFormatInfo so it is much faster for formats that override
- them with optimized ones
- - added pixel set/get functions optimized for various image formats
- (to be stored in TImageFormatInfo)
- - bug in ConvertSpecial caused problems when converting DXTC images
- to bitmaps in ImagingCoponents
- - bug in StretchRect caused that it didn't work with ifR32F and
- ifR16F formats
- - removed leftover code in FillMipMapLevel which disabled
- filtered resizing of images witch ChannelSize <> 8bits
- - added half float converting functions and support for half based
- image formats where needed
- - added TranslatePixel and IsImageFormatValid functions
- - fixed possible range overflows when converting from FP to integer images
- - added pixel set/get functions: GetPixel32Generic, GetPixelFPGeneric,
- SetPixel32Generic, SetPixelFPGeneric
- - fixed occasional range overflows in StretchResample
-
- -- 0.17 Changes/Bug Fixes -----------------------------------
- - added StretchNearest, StretchResample and some sampling functions
- - added ChannelCount values to TImageFormatInfo constants
- - added resolution validity check to GetDXTPixelsSize
-
- -- 0.15 Changes/Bug Fixes -----------------------------------
- - added RBSwapFormat values to some TImageFromatInfo definitions
- - fixed bug in ConvertSpecial (causing DXT images to convert only to 32bit)
- - added CopyPixel, ComparePixels helper functions
-
- -- 0.13 Changes/Bug Fixes -----------------------------------
- - replaced pixel format conversions for colors not to be
- darkened when converting from low bit counts
- - ReduceColorsMedianCut was updated to support creating one
- optimal palette for more images and it is somewhat faster
- now too
- - there was ugly bug in DXTC dimensions checking
-}
-
-end.
-
+{
+ $Id: ImagingFormats.pas 174 2009-09-08 09:37:59Z galfar $
+ Vampyre Imaging Library
+ by Marek Mauder
+ http://imaginglib.sourceforge.net
+
+ The contents of this file are used with permission, subject to the Mozilla
+ Public License Version 1.1 (the "License"); you may not use this file except
+ in compliance with the License. You may obtain a copy of the License at
+ http://www.mozilla.org/MPL/MPL-1.1.html
+
+ Software distributed under the License is distributed on an "AS IS" basis,
+ WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
+ the specific language governing rights and limitations under the License.
+
+ Alternatively, the contents of this file may be used under the terms of the
+ GNU Lesser General Public License (the "LGPL License"), in which case the
+ provisions of the LGPL License are applicable instead of those above.
+ If you wish to allow use of your version of this file only under the terms
+ of the LGPL License and not to allow others to use your version of this file
+ under the MPL, indicate your decision by deleting the provisions above and
+ replace them with the notice and other provisions required by the LGPL
+ License. If you do not delete the provisions above, a recipient may use
+ your version of this file under either the MPL or the LGPL License.
+
+ For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
+}
+
+{ This unit manages information about all image data formats and contains
+ low level format conversion, manipulation, and other related functions.}
+unit ImagingFormats;
+
+{$I ImagingOptions.inc}
+
+interface
+
+uses
+ ImagingTypes, Imaging, ImagingUtility;
+
+type
+ TImageFormatInfoArray = array[TImageFormat] of PImageFormatInfo;
+ PImageFormatInfoArray = ^TImageFormatInfoArray;
+
+
+{ Additional image manipulation functions (usually used internally by Imaging unit) }
+
+type
+ { Color reduction operations.}
+ TReduceColorsAction = (raCreateHistogram, raUpdateHistogram, raMakeColorMap,
+ raMapImage);
+ TReduceColorsActions = set of TReduceColorsAction;
+const
+ AllReduceColorsActions = [raCreateHistogram, raUpdateHistogram,
+ raMakeColorMap, raMapImage];
+{ Reduces the number of colors of source. Src is bits of source image
+ (ARGB or floating point) and Dst is in some indexed format. MaxColors
+ is the number of colors to which reduce and DstPal is palette to which
+ the resulting colors are written and it must be allocated to at least
+ MaxColors entries. ChannelMask is 'anded' with every pixel's channel value
+ when creating color histogram. If $FF is used all 8bits of color channels
+ are used which can be slow for large images with many colors so you can
+ use lower masks to speed it up.}
+procedure ReduceColorsMedianCut(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo; MaxColors: LongInt; ChannelMask: Byte;
+ DstPal: PPalette32; Actions: TReduceColorsActions = AllReduceColorsActions);
+{ Stretches rectangle in source image to rectangle in destination image
+ using nearest neighbor filtering. It is fast but results look blocky
+ because there is no interpolation used. SrcImage and DstImage must be
+ in the same data format. Works for all data formats except special formats.}
+procedure StretchNearest(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
+ SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
+ DstHeight: LongInt);
+type
+ { Built-in sampling filters.}
+ TSamplingFilter = (sfNearest, sfLinear, sfCosine, sfHermite, sfQuadratic,
+ sfGaussian, sfSpline, sfLanczos, sfMitchell, sfCatmullRom);
+ { Type of custom sampling function}
+ TFilterFunction = function(Value: Single): Single;
+const
+ { Default resampling filter used for bicubic resizing.}
+ DefaultCubicFilter = sfCatmullRom;
+var
+ { Built-in filter functions.}
+ SamplingFilterFunctions: array[TSamplingFilter] of TFilterFunction;
+ { Default radii of built-in filter functions.}
+ SamplingFilterRadii: array[TSamplingFilter] of Single;
+
+{ Stretches rectangle in source image to rectangle in destination image
+ with resampling. One of built-in resampling filters defined by
+ Filter is used. Set WrapEdges to True for seamlessly tileable images.
+ SrcImage and DstImage must be in the same data format.
+ Works for all data formats except special and indexed formats.}
+procedure StretchResample(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
+ SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
+ DstHeight: LongInt; Filter: TSamplingFilter; WrapEdges: Boolean = False); overload;
+{ Stretches rectangle in source image to rectangle in destination image
+ with resampling. You can use custom sampling function and filter radius.
+ Set WrapEdges to True for seamlessly tileable images. SrcImage and DstImage
+ must be in the same data format.
+ Works for all data formats except special and indexed formats.}
+procedure StretchResample(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
+ SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
+ DstHeight: LongInt; Filter: TFilterFunction; Radius: Single;
+ WrapEdges: Boolean = False); overload;
+{ Helper for functions that create mipmap levels. BiggerLevel is
+ valid image and SmallerLevel is empty zeroed image. SmallerLevel is created
+ with Width and Height dimensions and it is filled with pixels of BiggerLevel
+ using resampling filter specified by ImagingMipMapFilter option.
+ Uses StretchNearest and StretchResample internally so the same image data format
+ limitations apply.}
+procedure FillMipMapLevel(const BiggerLevel: TImageData; Width, Height: LongInt;
+ var SmallerLevel: TImageData);
+
+
+{ Various helper & support functions }
+
+{ Copies Src pixel to Dest pixel. It is faster than System.Move procedure.}
+procedure CopyPixel(Src, Dest: Pointer; BytesPerPixel: LongInt); {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Compares Src pixel and Dest pixel. It is faster than SysUtils.CompareMem function.}
+function ComparePixels(PixelA, PixelB: Pointer; BytesPerPixel: LongInt): Boolean; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Translates pixel color in SrcFormat to DstFormat.}
+procedure TranslatePixel(SrcPixel, DstPixel: Pointer; SrcFormat,
+ DstFormat: TImageFormat; SrcPalette, DstPalette: PPalette32);
+{ Clamps floating point pixel channel values to [0.0, 1.0] range.}
+procedure ClampFloatPixel(var PixF: TColorFPRec); {$IFDEF USE_INLINE}inline;{$ENDIF}
+
+{ Adds padding bytes at the ends of scanlines. Bpp is the number of bytes per
+ pixel of source and WidthBytes is the number of bytes per scanlines of dest.}
+procedure AddPadBytes(DataIn: Pointer; DataOut: Pointer; Width, Height,
+ Bpp, WidthBytes: LongInt);
+{ Removes padding from image with scanlines that have aligned sizes. Bpp is
+ the number of bytes per pixel of dest and WidthBytes is the number of bytes
+ per scanlines of source.}
+procedure RemovePadBytes(DataIn: Pointer; DataOut: Pointer; Width, Height,
+ Bpp, WidthBytes: LongInt);
+
+{ Converts 1bit image data to 8bit (without scaling). Used by file
+ loaders for formats supporting 1bit images.}
+procedure Convert1To8(DataIn, DataOut: Pointer; Width, Height,
+ WidthBytes: LongInt);
+{ Converts 2bit image data to 8bit (without scaling). Used by file
+ loaders for formats supporting 2bit images.}
+procedure Convert2To8(DataIn, DataOut: Pointer; Width, Height,
+ WidthBytes: LongInt);
+{ Converts 4bit image data to 8bit (without scaling). Used by file
+ loaders for formats supporting 4bit images.}
+procedure Convert4To8(DataIn, DataOut: Pointer; Width, Height,
+ WidthBytes: LongInt);
+
+{ Helper function for image file loaders. Some 15 bit images (targas, bitmaps)
+ may contain 1 bit alpha but there is no indication of it. This function checks
+ all 16 bit(should be X1R5G5B5 or A1R5G5B5 format) pixels and some of them have
+ alpha bit set it returns True, otherwise False.}
+function Has16BitImageAlpha(NumPixels: LongInt; Data: PWord): Boolean;
+{ Helper function for image file loaders. This function checks is similar
+ to Has16BitImageAlpha but works with A8R8G8B8 format.}
+function Has32BitImageAlpha(NumPixels: LongInt; Data: PLongWord): Boolean;
+{ Provides indexed access to each line of pixels. Does not work with special
+ format images.}
+function GetScanLine(ImageBits: Pointer; const FormatInfo: TImageFormatInfo;
+ LineWidth, Index: LongInt): Pointer; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Returns True if Format is valid image data format identifier.}
+function IsImageFormatValid(Format: TImageFormat): Boolean;
+
+{ Converts 16bit half floating point value to 32bit Single.}
+function HalfToFloat(Half: THalfFloat): Single;
+{ Converts 32bit Single to 16bit half floating point.}
+function FloatToHalf(Float: Single): THalfFloat;
+
+{ Converts half float color value to single-precision floating point color.}
+function ColorHalfToFloat(ColorHF: TColorHFRec): TColorFPRec; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Converts single-precision floating point color to half float color.}
+function ColorFloatToHalf(ColorFP: TColorFPRec): TColorHFRec; {$IFDEF USE_INLINE}inline;{$ENDIF}
+
+{ Makes image PalEntries x 1 big where each pixel has color of one pal entry.}
+procedure VisualizePalette(Pal: PPalette32; Entries: Integer; out PalImage: TImageData);
+
+type
+ TPointRec = record
+ Pos: LongInt;
+ Weight: Single;
+ end;
+ TCluster = array of TPointRec;
+ TMappingTable = array of TCluster;
+
+{ Helper function for resampling.}
+function BuildMappingTable(DstLow, DstHigh, SrcLow, SrcHigh, SrcImageWidth: LongInt;
+ Filter: TFilterFunction; Radius: Single; WrapEdges: Boolean): TMappingTable;
+{ Helper function for resampling.}
+procedure FindExtremes(const Map: TMappingTable; var MinPos, MaxPos: LongInt);
+
+
+{ Pixel readers/writers for different image formats }
+
+{ Returns pixel of image in any ARGB format. Channel values are scaled to 16 bits.}
+procedure ChannelGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
+ var Pix: TColor64Rec);
+{ Sets pixel of image in any ARGB format. Channel values must be scaled to 16 bits.}
+procedure ChannelSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
+ const Pix: TColor64Rec);
+
+{ Returns pixel of image in any grayscale format. Gray value is scaled to 64 bits
+ and alpha to 16 bits.}
+procedure GrayGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
+ var Gray: TColor64Rec; var Alpha: Word);
+{ Sets pixel of image in any grayscale format. Gray value must be scaled to 64 bits
+ and alpha to 16 bits.}
+procedure GraySetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
+ const Gray: TColor64Rec; Alpha: Word);
+
+{ Returns pixel of image in any floating point format. Channel values are
+ in range <0.0, 1.0>.}
+procedure FloatGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
+ var Pix: TColorFPRec);
+{ Sets pixel of image in any floating point format. Channel values must be
+ in range <0.0, 1.0>.}
+procedure FloatSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
+ const Pix: TColorFPRec);
+
+{ Returns pixel of image in any indexed format. Returned value is index to
+ the palette.}
+procedure IndexGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
+ var Index: LongWord);
+{ Sets pixel of image in any indexed format. Index is index to the palette.}
+procedure IndexSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
+ Index: LongWord);
+
+
+{ Pixel readers/writers for 32bit and FP colors}
+
+{ Function for getting pixel colors. Native pixel is read from Image and
+ then translated to 32 bit ARGB.}
+function GetPixel32Generic(Bits: Pointer; Info: PImageFormatInfo;
+ Palette: PPalette32): TColor32Rec;
+{ Procedure for setting pixel colors. Input 32 bit ARGB color is translated to
+ native format and then written to Image.}
+procedure SetPixel32Generic(Bits: Pointer; Info: PImageFormatInfo;
+ Palette: PPalette32; const Color: TColor32Rec);
+{ Function for getting pixel colors. Native pixel is read from Image and
+ then translated to FP ARGB.}
+function GetPixelFPGeneric(Bits: Pointer; Info: PImageFormatInfo;
+ Palette: PPalette32): TColorFPRec;
+{ Procedure for setting pixel colors. Input FP ARGB color is translated to
+ native format and then written to Image.}
+procedure SetPixelFPGeneric(Bits: Pointer; Info: PImageFormatInfo;
+ Palette: PPalette32; const Color: TColorFPRec);
+
+
+{ Image format conversion functions }
+
+{ Converts any ARGB format to any ARGB format.}
+procedure ChannelToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo);
+{ Converts any ARGB format to any grayscale format.}
+procedure ChannelToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo);
+{ Converts any ARGB format to any floating point format.}
+procedure ChannelToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo);
+{ Converts any ARGB format to any indexed format.}
+procedure ChannelToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo; DstPal: PPalette32);
+
+{ Converts any grayscale format to any grayscale format.}
+procedure GrayToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo);
+{ Converts any grayscale format to any ARGB format.}
+procedure GrayToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo);
+{ Converts any grayscale format to any floating point format.}
+procedure GrayToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo);
+{ Converts any grayscale format to any indexed format.}
+procedure GrayToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo; DstPal: PPalette32);
+
+{ Converts any floating point format to any floating point format.}
+procedure FloatToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo);
+{ Converts any floating point format to any ARGB format.}
+procedure FloatToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo);
+{ Converts any floating point format to any grayscale format.}
+procedure FloatToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo);
+{ Converts any floating point format to any indexed format.}
+procedure FloatToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo; DstPal: PPalette32);
+
+{ Converts any indexed format to any indexed format.}
+procedure IndexToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo; SrcPal, DstPal: PPalette32);
+{ Converts any indexed format to any ARGB format.}
+procedure IndexToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo; SrcPal: PPalette32);
+{ Converts any indexed format to any grayscale format.}
+procedure IndexToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo; SrcPal: PPalette32);
+{ Converts any indexed format to any floating point format.}
+procedure IndexToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo; SrcPal: PPalette32);
+
+
+{ Color constructor functions }
+
+{ Constructs TColor24Rec color.}
+function Color24(R, G, B: Byte): TColor24Rec; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Constructs TColor32Rec color.}
+function Color32(A, R, G, B: Byte): TColor32Rec; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Constructs TColor48Rec color.}
+function Color48(R, G, B: Word): TColor48Rec; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Constructs TColor64Rec color.}
+function Color64(A, R, G, B: Word): TColor64Rec; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Constructs TColorFPRec color.}
+function ColorFP(A, R, G, B: Single): TColorFPRec; {$IFDEF USE_INLINE}inline;{$ENDIF}
+{ Constructs TColorHFRec color.}
+function ColorHF(A, R, G, B: THalfFloat): TColorHFRec; {$IFDEF USE_INLINE}inline;{$ENDIF}
+
+
+{ Special formats conversion functions }
+
+{ Converts image to/from/between special image formats (dxtc, ...).}
+procedure ConvertSpecial(var Image: TImageData; SrcInfo,
+ DstInfo: PImageFormatInfo);
+
+
+{ Inits all image format information. Called internally on startup.}
+procedure InitImageFormats(var Infos: TImageFormatInfoArray);
+
+const
+ // Grayscale conversion channel weights
+ GrayConv: TColorFPRec = (B: 0.114; G: 0.587; R: 0.299; A: 0.0);
+
+ // Contants for converting integer colors to floating point
+ OneDiv8Bit: Single = 1.0 / 255.0;
+ OneDiv16Bit: Single = 1.0 / 65535.0;
+
+implementation
+
+{ TImageFormatInfo member functions }
+
+{ Returns size in bytes of image in given standard format where
+ Size = Width * Height * Bpp.}
+function GetStdPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; forward;
+{ Checks if Width and Height are valid for given standard format.}
+procedure CheckStdDimensions(Format: TImageFormat; var Width, Height: LongInt); forward;
+{ Returns size in bytes of image in given DXT format.}
+function GetDXTPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; forward;
+{ Checks if Width and Height are valid for given DXT format. If they are
+ not valid, they are changed to pass the check.}
+procedure CheckDXTDimensions(Format: TImageFormat; var Width, Height: LongInt); forward;
+{ Returns size in bytes of image in BTC format.}
+function GetBTCPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; forward;
+
+{ Optimized pixel readers/writers for 32bit and FP colors to be stored in TImageFormatInfo }
+
+function GetPixel32ifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColor32Rec; forward;
+procedure SetPixel32ifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColor32Rec); forward;
+function GetPixelFPifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec; forward;
+procedure SetPixelFPifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec); forward;
+
+function GetPixel32Channel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColor32Rec; forward;
+procedure SetPixel32Channel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColor32Rec); forward;
+function GetPixelFPChannel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec; forward;
+procedure SetPixelFPChannel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec); forward;
+
+function GetPixelFPFloat32(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec; forward;
+procedure SetPixelFPFloat32(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec); forward;
+
+var
+ PFR3G3B2: TPixelFormatInfo;
+ PFX5R1G1B1: TPixelFormatInfo;
+ PFR5G6B5: TPixelFormatInfo;
+ PFA1R5G5B5: TPixelFormatInfo;
+ PFA4R4G4B4: TPixelFormatInfo;
+ PFX1R5G5B5: TPixelFormatInfo;
+ PFX4R4G4B4: TPixelFormatInfo;
+ FInfos: PImageFormatInfoArray;
+
+var
+ // Free Pascal generates hundreds of warnings here
+{$WARNINGS OFF}
+
+ // indexed formats
+ Index8Info: TImageFormatInfo = (
+ Format: ifIndex8;
+ Name: 'Index8';
+ BytesPerPixel: 1;
+ ChannelCount: 1;
+ PaletteEntries: 256;
+ HasAlphaChannel: True;
+ IsIndexed: True;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPGeneric;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPGeneric);
+
+ // grayscale formats
+ Gray8Info: TImageFormatInfo = (
+ Format: ifGray8;
+ Name: 'Gray8';
+ BytesPerPixel: 1;
+ ChannelCount: 1;
+ HasGrayChannel: True;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Channel8Bit;
+ GetPixelFP: GetPixelFPChannel8Bit;
+ SetPixel32: SetPixel32Channel8Bit;
+ SetPixelFP: SetPixelFPChannel8Bit);
+
+ A8Gray8Info: TImageFormatInfo = (
+ Format: ifA8Gray8;
+ Name: 'A8Gray8';
+ BytesPerPixel: 2;
+ ChannelCount: 2;
+ HasGrayChannel: True;
+ HasAlphaChannel: True;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Channel8Bit;
+ GetPixelFP: GetPixelFPChannel8Bit;
+ SetPixel32: SetPixel32Channel8Bit;
+ SetPixelFP: SetPixelFPChannel8Bit);
+
+ Gray16Info: TImageFormatInfo = (
+ Format: ifGray16;
+ Name: 'Gray16';
+ BytesPerPixel: 2;
+ ChannelCount: 1;
+ HasGrayChannel: True;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPGeneric;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPGeneric);
+
+ Gray32Info: TImageFormatInfo = (
+ Format: ifGray32;
+ Name: 'Gray32';
+ BytesPerPixel: 4;
+ ChannelCount: 1;
+ HasGrayChannel: True;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPGeneric;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPGeneric);
+
+ Gray64Info: TImageFormatInfo = (
+ Format: ifGray64;
+ Name: 'Gray64';
+ BytesPerPixel: 8;
+ ChannelCount: 1;
+ HasGrayChannel: True;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPGeneric;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPGeneric);
+
+ A16Gray16Info: TImageFormatInfo = (
+ Format: ifA16Gray16;
+ Name: 'A16Gray16';
+ BytesPerPixel: 4;
+ ChannelCount: 2;
+ HasGrayChannel: True;
+ HasAlphaChannel: True;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPGeneric;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPGeneric);
+
+ // ARGB formats
+ X5R1G1B1Info: TImageFormatInfo = (
+ Format: ifX5R1G1B1;
+ Name: 'X5R1G1B1';
+ BytesPerPixel: 1;
+ ChannelCount: 3;
+ UsePixelFormat: True;
+ PixelFormat: @PFX5R1G1B1;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPGeneric;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPGeneric);
+
+ R3G3B2Info: TImageFormatInfo = (
+ Format: ifR3G3B2;
+ Name: 'R3G3B2';
+ BytesPerPixel: 1;
+ ChannelCount: 3;
+ UsePixelFormat: True;
+ PixelFormat: @PFR3G3B2;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPGeneric;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPGeneric);
+
+ R5G6B5Info: TImageFormatInfo = (
+ Format: ifR5G6B5;
+ Name: 'R5G6B5';
+ BytesPerPixel: 2;
+ ChannelCount: 3;
+ UsePixelFormat: True;
+ PixelFormat: @PFR5G6B5;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPGeneric;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPGeneric);
+
+ A1R5G5B5Info: TImageFormatInfo = (
+ Format: ifA1R5G5B5;
+ Name: 'A1R5G5B5';
+ BytesPerPixel: 2;
+ ChannelCount: 4;
+ HasAlphaChannel: True;
+ UsePixelFormat: True;
+ PixelFormat: @PFA1R5G5B5;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPGeneric;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPGeneric);
+
+ A4R4G4B4Info: TImageFormatInfo = (
+ Format: ifA4R4G4B4;
+ Name: 'A4R4G4B4';
+ BytesPerPixel: 2;
+ ChannelCount: 4;
+ HasAlphaChannel: True;
+ UsePixelFormat: True;
+ PixelFormat: @PFA4R4G4B4;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPGeneric;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPGeneric);
+
+ X1R5G5B5Info: TImageFormatInfo = (
+ Format: ifX1R5G5B5;
+ Name: 'X1R5G5B5';
+ BytesPerPixel: 2;
+ ChannelCount: 3;
+ UsePixelFormat: True;
+ PixelFormat: @PFX1R5G5B5;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPGeneric;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPGeneric);
+
+ X4R4G4B4Info: TImageFormatInfo = (
+ Format: ifX4R4G4B4;
+ Name: 'X4R4G4B4';
+ BytesPerPixel: 2;
+ ChannelCount: 3;
+ UsePixelFormat: True;
+ PixelFormat: @PFX4R4G4B4;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPGeneric;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPGeneric);
+
+ R8G8B8Info: TImageFormatInfo = (
+ Format: ifR8G8B8;
+ Name: 'R8G8B8';
+ BytesPerPixel: 3;
+ ChannelCount: 3;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Channel8Bit;
+ GetPixelFP: GetPixelFPChannel8Bit;
+ SetPixel32: SetPixel32Channel8Bit;
+ SetPixelFP: SetPixelFPChannel8Bit);
+
+ A8R8G8B8Info: TImageFormatInfo = (
+ Format: ifA8R8G8B8;
+ Name: 'A8R8G8B8';
+ BytesPerPixel: 4;
+ ChannelCount: 4;
+ HasAlphaChannel: True;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32ifA8R8G8B8;
+ GetPixelFP: GetPixelFPifA8R8G8B8;
+ SetPixel32: SetPixel32ifA8R8G8B8;
+ SetPixelFP: SetPixelFPifA8R8G8B8);
+
+ X8R8G8B8Info: TImageFormatInfo = (
+ Format: ifX8R8G8B8;
+ Name: 'X8R8G8B8';
+ BytesPerPixel: 4;
+ ChannelCount: 3;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Channel8Bit;
+ GetPixelFP: GetPixelFPChannel8Bit;
+ SetPixel32: SetPixel32Channel8Bit;
+ SetPixelFP: SetPixelFPChannel8Bit);
+
+ R16G16B16Info: TImageFormatInfo = (
+ Format: ifR16G16B16;
+ Name: 'R16G16B16';
+ BytesPerPixel: 6;
+ ChannelCount: 3;
+ RBSwapFormat: ifB16G16R16;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPGeneric;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPGeneric);
+
+ A16R16G16B16Info: TImageFormatInfo = (
+ Format: ifA16R16G16B16;
+ Name: 'A16R16G16B16';
+ BytesPerPixel: 8;
+ ChannelCount: 4;
+ HasAlphaChannel: True;
+ RBSwapFormat: ifA16B16G16R16;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPGeneric;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPGeneric);
+
+ B16G16R16Info: TImageFormatInfo = (
+ Format: ifB16G16R16;
+ Name: 'B16G16R16';
+ BytesPerPixel: 6;
+ ChannelCount: 3;
+ IsRBSwapped: True;
+ RBSwapFormat: ifR16G16B16;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPGeneric;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPGeneric);
+
+ A16B16G16R16Info: TImageFormatInfo = (
+ Format: ifA16B16G16R16;
+ Name: 'A16B16G16R16';
+ BytesPerPixel: 8;
+ ChannelCount: 4;
+ HasAlphaChannel: True;
+ IsRBSwapped: True;
+ RBSwapFormat: ifA16R16G16B16;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPGeneric;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPGeneric);
+
+ // floating point formats
+ R32FInfo: TImageFormatInfo = (
+ Format: ifR32F;
+ Name: 'R32F';
+ BytesPerPixel: 4;
+ ChannelCount: 1;
+ IsFloatingPoint: True;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPFloat32;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPFloat32);
+
+ A32R32G32B32FInfo: TImageFormatInfo = (
+ Format: ifA32R32G32B32F;
+ Name: 'A32R32G32B32F';
+ BytesPerPixel: 16;
+ ChannelCount: 4;
+ HasAlphaChannel: True;
+ IsFloatingPoint: True;
+ RBSwapFormat: ifA32B32G32R32F;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPFloat32;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPFloat32);
+
+ A32B32G32R32FInfo: TImageFormatInfo = (
+ Format: ifA32B32G32R32F;
+ Name: 'A32B32G32R32F';
+ BytesPerPixel: 16;
+ ChannelCount: 4;
+ HasAlphaChannel: True;
+ IsFloatingPoint: True;
+ IsRBSwapped: True;
+ RBSwapFormat: ifA32R32G32B32F;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPFloat32;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPFloat32);
+
+ R16FInfo: TImageFormatInfo = (
+ Format: ifR16F;
+ Name: 'R16F';
+ BytesPerPixel: 2;
+ ChannelCount: 1;
+ IsFloatingPoint: True;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPGeneric;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPGeneric);
+
+ A16R16G16B16FInfo: TImageFormatInfo = (
+ Format: ifA16R16G16B16F;
+ Name: 'A16R16G16B16F';
+ BytesPerPixel: 8;
+ ChannelCount: 4;
+ HasAlphaChannel: True;
+ IsFloatingPoint: True;
+ RBSwapFormat: ifA16B16G16R16F;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPGeneric;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPGeneric);
+
+ A16B16G16R16FInfo: TImageFormatInfo = (
+ Format: ifA16B16G16R16F;
+ Name: 'A16B16G16R16F';
+ BytesPerPixel: 8;
+ ChannelCount: 4;
+ HasAlphaChannel: True;
+ IsFloatingPoint: True;
+ IsRBSwapped: True;
+ RBSwapFormat: ifA16R16G16B16F;
+ GetPixelsSize: GetStdPixelsSize;
+ CheckDimensions: CheckStdDimensions;
+ GetPixel32: GetPixel32Generic;
+ GetPixelFP: GetPixelFPGeneric;
+ SetPixel32: SetPixel32Generic;
+ SetPixelFP: SetPixelFPGeneric);
+
+ // special formats
+ DXT1Info: TImageFormatInfo = (
+ Format: ifDXT1;
+ Name: 'DXT1';
+ ChannelCount: 4;
+ HasAlphaChannel: True;
+ IsSpecial: True;
+ GetPixelsSize: GetDXTPixelsSize;
+ CheckDimensions: CheckDXTDimensions;
+ SpecialNearestFormat: ifA8R8G8B8);
+
+ DXT3Info: TImageFormatInfo = (
+ Format: ifDXT3;
+ Name: 'DXT3';
+ ChannelCount: 4;
+ HasAlphaChannel: True;
+ IsSpecial: True;
+ GetPixelsSize: GetDXTPixelsSize;
+ CheckDimensions: CheckDXTDimensions;
+ SpecialNearestFormat: ifA8R8G8B8);
+
+ DXT5Info: TImageFormatInfo = (
+ Format: ifDXT5;
+ Name: 'DXT5';
+ ChannelCount: 4;
+ HasAlphaChannel: True;
+ IsSpecial: True;
+ GetPixelsSize: GetDXTPixelsSize;
+ CheckDimensions: CheckDXTDimensions;
+ SpecialNearestFormat: ifA8R8G8B8);
+
+ BTCInfo: TImageFormatInfo = (
+ Format: ifBTC;
+ Name: 'BTC';
+ ChannelCount: 1;
+ HasAlphaChannel: False;
+ IsSpecial: True;
+ GetPixelsSize: GetBTCPixelsSize;
+ CheckDimensions: CheckDXTDimensions;
+ SpecialNearestFormat: ifGray8);
+
+ ATI1NInfo: TImageFormatInfo = (
+ Format: ifATI1N;
+ Name: 'ATI1N';
+ ChannelCount: 1;
+ HasAlphaChannel: False;
+ IsSpecial: True;
+ GetPixelsSize: GetDXTPixelsSize;
+ CheckDimensions: CheckDXTDimensions;
+ SpecialNearestFormat: ifGray8);
+
+ ATI2NInfo: TImageFormatInfo = (
+ Format: ifATI2N;
+ Name: 'ATI2N';
+ ChannelCount: 2;
+ HasAlphaChannel: False;
+ IsSpecial: True;
+ GetPixelsSize: GetDXTPixelsSize;
+ CheckDimensions: CheckDXTDimensions;
+ SpecialNearestFormat: ifA8R8G8B8);
+
+{$WARNINGS ON}
+
+function PixelFormat(ABitCount, RBitCount, GBitCount, BBitCount: Byte): TPixelFormatInfo; forward;
+
+procedure InitImageFormats(var Infos: TImageFormatInfoArray);
+begin
+ FInfos := @Infos;
+
+ Infos[ifDefault] := @A8R8G8B8Info;
+ // indexed formats
+ Infos[ifIndex8] := @Index8Info;
+ // grayscale formats
+ Infos[ifGray8] := @Gray8Info;
+ Infos[ifA8Gray8] := @A8Gray8Info;
+ Infos[ifGray16] := @Gray16Info;
+ Infos[ifGray32] := @Gray32Info;
+ Infos[ifGray64] := @Gray64Info;
+ Infos[ifA16Gray16] := @A16Gray16Info;
+ // ARGB formats
+ Infos[ifX5R1G1B1] := @X5R1G1B1Info;
+ Infos[ifR3G3B2] := @R3G3B2Info;
+ Infos[ifR5G6B5] := @R5G6B5Info;
+ Infos[ifA1R5G5B5] := @A1R5G5B5Info;
+ Infos[ifA4R4G4B4] := @A4R4G4B4Info;
+ Infos[ifX1R5G5B5] := @X1R5G5B5Info;
+ Infos[ifX4R4G4B4] := @X4R4G4B4Info;
+ Infos[ifR8G8B8] := @R8G8B8Info;
+ Infos[ifA8R8G8B8] := @A8R8G8B8Info;
+ Infos[ifX8R8G8B8] := @X8R8G8B8Info;
+ Infos[ifR16G16B16] := @R16G16B16Info;
+ Infos[ifA16R16G16B16] := @A16R16G16B16Info;
+ Infos[ifB16G16R16] := @B16G16R16Info;
+ Infos[ifA16B16G16R16] := @A16B16G16R16Info;
+ // floating point formats
+ Infos[ifR32F] := @R32FInfo;
+ Infos[ifA32R32G32B32F] := @A32R32G32B32FInfo;
+ Infos[ifA32B32G32R32F] := @A32B32G32R32FInfo;
+ Infos[ifR16F] := @R16FInfo;
+ Infos[ifA16R16G16B16F] := @A16R16G16B16FInfo;
+ Infos[ifA16B16G16R16F] := @A16B16G16R16FInfo;
+ // special formats
+ Infos[ifDXT1] := @DXT1Info;
+ Infos[ifDXT3] := @DXT3Info;
+ Infos[ifDXT5] := @DXT5Info;
+ Infos[ifBTC] := @BTCInfo;
+ Infos[ifATI1N] := @ATI1NInfo;
+ Infos[ifATI2N] := @ATI2NInfo;
+
+ PFR3G3B2 := PixelFormat(0, 3, 3, 2);
+ PFX5R1G1B1 := PixelFormat(0, 1, 1, 1);
+ PFR5G6B5 := PixelFormat(0, 5, 6, 5);
+ PFA1R5G5B5 := PixelFormat(1, 5, 5, 5);
+ PFA4R4G4B4 := PixelFormat(4, 4, 4, 4);
+ PFX1R5G5B5 := PixelFormat(0, 5, 5, 5);
+ PFX4R4G4B4 := PixelFormat(0, 4, 4, 4);
+end;
+
+
+{ Internal unit helper functions }
+
+function PixelFormat(ABitCount, RBitCount, GBitCount, BBitCount: Byte): TPixelFormatInfo;
+begin
+ Result.ABitMask := ((1 shl ABitCount) - 1) shl (RBitCount + GBitCount +
+ BBitCount);
+ Result.RBitMask := ((1 shl RBitCount) - 1) shl (GBitCount + BBitCount);
+ Result.GBitMask := ((1 shl GBitCount) - 1) shl (BBitCount);
+ Result.BBitMask := (1 shl BBitCount) - 1;
+ Result.ABitCount := ABitCount;
+ Result.RBitCount := RBitCount;
+ Result.GBitCount := GBitCount;
+ Result.BBitCount := BBitCount;
+ Result.AShift := RBitCount + GBitCount + BBitCount;
+ Result.RShift := GBitCount + BBitCount;
+ Result.GShift := BBitCount;
+ Result.BShift := 0;
+ Result.ARecDiv := Max(1, Pow2Int(Result.ABitCount) - 1);
+ Result.RRecDiv := Max(1, Pow2Int(Result.RBitCount) - 1);
+ Result.GRecDiv := Max(1, Pow2Int(Result.GBitCount) - 1);
+ Result.BRecDiv := Max(1, Pow2Int(Result.BBitCount) - 1);
+end;
+
+function PixelFormatMask(ABitMask, RBitMask, GBitMask, BBitMask: LongWord): TPixelFormatInfo;
+
+ function GetBitCount(B: LongWord): LongWord;
+ var
+ I: LongWord;
+ begin
+ I := 0;
+ while (I < 31) and (((1 shl I) and B) = 0) do
+ Inc(I);
+ Result := 0;
+ while ((1 shl I) and B) <> 0 do
+ begin
+ Inc(I);
+ Inc(Result);
+ end;
+ end;
+
+begin
+ Result := PixelFormat(GetBitCount(ABitMask), GetBitCount(RBitMask),
+ GetBitCount(GBitMask), GetBitCount(BBitMask));
+end;
+
+function PFSetARGB(const PF: TPixelFormatInfo; A, R, G, B: Byte): TColor32;
+{$IFDEF USE_INLINE}inline;{$ENDIF}
+begin
+ with PF do
+ Result :=
+ (A shl ABitCount shr 8 shl AShift) or
+ (R shl RBitCount shr 8 shl RShift) or
+ (G shl GBitCount shr 8 shl GShift) or
+ (B shl BBitCount shr 8 shl BShift);
+end;
+
+procedure PFGetARGB(const PF: TPixelFormatInfo; Color: LongWord;
+ var A, R, G, B: Byte); {$IFDEF USE_INLINE}inline;{$ENDIF}
+begin
+ with PF do
+ begin
+ A := (Color and ABitMask shr AShift) * 255 div ARecDiv;
+ R := (Color and RBitMask shr RShift) * 255 div RRecDiv;
+ G := (Color and GBitMask shr GShift) * 255 div GRecDiv;
+ B := (Color and BBitMask shl BShift) * 255 div BRecDiv;
+ end;
+end;
+
+function PFSetColor(const PF: TPixelFormatInfo; ARGB: TColor32): LongWord;
+{$IFDEF USE_INLINE}inline;{$ENDIF}
+begin
+ with PF do
+ Result :=
+ (Byte(ARGB shr 24) shl ABitCount shr 8 shl AShift) or
+ (Byte(ARGB shr 16) shl RBitCount shr 8 shl RShift) or
+ (Byte(ARGB shr 8) shl GBitCount shr 8 shl GShift) or
+ (Byte(ARGB) shl BBitCount shr 8 shl BShift);
+end;
+
+function PFGetColor(const PF: TPixelFormatInfo; Color: LongWord): TColor32;
+{$IFDEF USE_INLINE}inline;{$ENDIF}
+begin
+ with PF, TColor32Rec(Result) do
+ begin
+ A := (Color and ABitMask shr AShift) * 255 div ARecDiv;
+ R := (Color and RBitMask shr RShift) * 255 div RRecDiv;
+ G := (Color and GBitMask shr GShift) * 255 div GRecDiv;
+ B := (Color and BBitMask shl BShift) * 255 div BRecDiv;
+ end;
+end;
+
+
+{ Color constructor functions }
+
+
+function Color24(R, G, B: Byte): TColor24Rec;
+begin
+ Result.R := R;
+ Result.G := G;
+ Result.B := B;
+end;
+
+function Color32(A, R, G, B: Byte): TColor32Rec;
+begin
+ Result.A := A;
+ Result.R := R;
+ Result.G := G;
+ Result.B := B;
+end;
+
+function Color48(R, G, B: Word): TColor48Rec;
+begin
+ Result.R := R;
+ Result.G := G;
+ Result.B := B;
+end;
+
+function Color64(A, R, G, B: Word): TColor64Rec;
+begin
+ Result.A := A;
+ Result.R := R;
+ Result.G := G;
+ Result.B := B;
+end;
+
+function ColorFP(A, R, G, B: Single): TColorFPRec;
+begin
+ Result.A := A;
+ Result.R := R;
+ Result.G := G;
+ Result.B := B;
+end;
+
+function ColorHF(A, R, G, B: THalfFloat): TColorHFRec;
+begin
+ Result.A := A;
+ Result.R := R;
+ Result.G := G;
+ Result.B := B;
+end;
+
+
+{ Additional image manipulation functions (usually used internally by Imaging unit) }
+
+const
+ MaxPossibleColors = 4096;
+ HashSize = 32768;
+ AlphaWeight = 1024;
+ RedWeight = 612;
+ GreenWeight = 1202;
+ BlueWeight = 234;
+
+type
+ PColorBin = ^TColorBin;
+ TColorBin = record
+ Color: TColor32Rec;
+ Number: LongInt;
+ Next: PColorBin;
+ end;
+
+ THashTable = array[0..HashSize - 1] of PColorBin;
+
+ TColorBox = record
+ AMin, AMax,
+ RMin, RMax,
+ GMin, GMax,
+ BMin, BMax: LongInt;
+ Total: LongInt;
+ Represented: TColor32Rec;
+ List: PColorBin;
+ end;
+
+var
+ Table: THashTable;
+ Box: array[0..MaxPossibleColors - 1] of TColorBox;
+ Boxes: LongInt;
+ BoxesCreated: Boolean = False;
+
+procedure ReduceColorsMedianCut(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo; MaxColors: LongInt; ChannelMask: Byte;
+ DstPal: PPalette32; Actions: TReduceColorsActions);
+
+ procedure CreateHistogram (Src: PByte; SrcInfo: PImageFormatInfo;
+ ChannelMask: Byte);
+ var
+ A, R, G, B: Byte;
+ I, Addr: LongInt;
+ PC: PColorBin;
+ Col: TColor32Rec;
+ begin
+ for I := 0 to NumPixels - 1 do
+ begin
+ Col := GetPixel32Generic(Src, SrcInfo, nil);
+ A := Col.A and ChannelMask;
+ R := Col.R and ChannelMask;
+ G := Col.G and ChannelMask;
+ B := Col.B and ChannelMask;
+
+ Addr := (A + 11 * B + 59 * R + 119 * G) mod HashSize;
+ PC := Table[Addr];
+
+ while (PC <> nil) and ((PC.Color.R <> R) or (PC.Color.G <> G) or
+ (PC.Color.B <> B) or (PC.Color.A <> A)) do
+ PC := PC.Next;
+
+ if PC = nil then
+ begin
+ New(PC);
+ PC.Color.R := R;
+ PC.Color.G := G;
+ PC.Color.B := B;
+ PC.Color.A := A;
+ PC.Number := 1;
+ PC.Next := Table[Addr];
+ Table[Addr] := PC;
+ end
+ else
+ Inc(PC^.Number);
+ Inc(Src, SrcInfo.BytesPerPixel);
+ end;
+ end;
+
+ procedure InitBox (var Box : TColorBox);
+ begin
+ Box.AMin := 256;
+ Box.RMin := 256;
+ Box.GMin := 256;
+ Box.BMin := 256;
+ Box.AMax := -1;
+ Box.RMax := -1;
+ Box.GMax := -1;
+ Box.BMax := -1;
+ Box.Total := 0;
+ Box.List := nil;
+ end;
+
+ procedure ChangeBox (var Box: TColorBox; const C: TColorBin);
+ begin
+ with C.Color do
+ begin
+ if A < Box.AMin then Box.AMin := A;
+ if A > Box.AMax then Box.AMax := A;
+ if B < Box.BMin then Box.BMin := B;
+ if B > Box.BMax then Box.BMax := B;
+ if G < Box.GMin then Box.GMin := G;
+ if G > Box.GMax then Box.GMax := G;
+ if R < Box.RMin then Box.RMin := R;
+ if R > Box.RMax then Box.RMax := R;
+ end;
+ Inc(Box.Total, C.Number);
+ end;
+
+ procedure MakeColormap;
+ var
+ I, J: LongInt;
+ CP, Pom: PColorBin;
+ Cut, LargestIdx, Largest, Size, S: LongInt;
+ CutA, CutR, CutG, CutB: Boolean;
+ SumA, SumR, SumG, SumB: LongInt;
+ Temp: TColorBox;
+ begin
+ I := 0;
+ Boxes := 1;
+ LargestIdx := 0;
+ while (I < HashSize) and (Table[I] = nil) do
+ Inc(i);
+ if I < HashSize then
+ begin
+ // put all colors into Box[0]
+ InitBox(Box[0]);
+ repeat
+ CP := Table[I];
+ while CP.Next <> nil do
+ begin
+ ChangeBox(Box[0], CP^);
+ CP := CP.Next;
+ end;
+ ChangeBox(Box[0], CP^);
+ CP.Next := Box[0].List;
+ Box[0].List := Table[I];
+ Table[I] := nil;
+ repeat
+ Inc(I)
+ until (I = HashSize) or (Table[I] <> nil);
+ until I = HashSize;
+ // now all colors are in Box[0]
+ repeat
+ // cut one color box
+ Largest := 0;
+ for I := 0 to Boxes - 1 do
+ with Box[I] do
+ begin
+ Size := (AMax - AMin) * AlphaWeight;
+ S := (RMax - RMin) * RedWeight;
+ if S > Size then
+ Size := S;
+ S := (GMax - GMin) * GreenWeight;
+ if S > Size then
+ Size := S;
+ S := (BMax - BMin) * BlueWeight;
+ if S > Size then
+ Size := S;
+ if Size > Largest then
+ begin
+ Largest := Size;
+ LargestIdx := I;
+ end;
+ end;
+ if Largest > 0 then
+ begin
+ // cutting Box[LargestIdx] into Box[LargestIdx] and Box[Boxes]
+ CutR := False;
+ CutG := False;
+ CutB := False;
+ CutA := False;
+ with Box[LargestIdx] do
+ begin
+ if (AMax - AMin) * AlphaWeight = Largest then
+ begin
+ Cut := (AMax + AMin) shr 1;
+ CutA := True;
+ end
+ else
+ if (RMax - RMin) * RedWeight = Largest then
+ begin
+ Cut := (RMax + RMin) shr 1;
+ CutR := True;
+ end
+ else
+ if (GMax - GMin) * GreenWeight = Largest then
+ begin
+ Cut := (GMax + GMin) shr 1;
+ CutG := True;
+ end
+ else
+ begin
+ Cut := (BMax + BMin) shr 1;
+ CutB := True;
+ end;
+ CP := List;
+ end;
+ InitBox(Box[LargestIdx]);
+ InitBox(Box[Boxes]);
+ repeat
+ // distribute one color
+ Pom := CP.Next;
+ with CP.Color do
+ begin
+ if (CutA and (A <= Cut)) or (CutR and (R <= Cut)) or
+ (CutG and (G <= Cut)) or (CutB and (B <= Cut)) then
+ I := LargestIdx
+ else
+ I := Boxes;
+ end;
+ CP.Next := Box[i].List;
+ Box[i].List := CP;
+ ChangeBox(Box[i], CP^);
+ CP := Pom;
+ until CP = nil;
+ Inc(Boxes);
+ end;
+ until (Boxes = MaxColors) or (Largest = 0);
+ // compute box representation
+ for I := 0 to Boxes - 1 do
+ begin
+ SumR := 0;
+ SumG := 0;
+ SumB := 0;
+ SumA := 0;
+ repeat
+ CP := Box[I].List;
+ Inc(SumR, CP.Color.R * CP.Number);
+ Inc(SumG, CP.Color.G * CP.Number);
+ Inc(SumB, CP.Color.B * CP.Number);
+ Inc(SumA, CP.Color.A * CP.Number);
+ Box[I].List := CP.Next;
+ Dispose(CP);
+ until Box[I].List = nil;
+ with Box[I] do
+ begin
+ Represented.A := SumA div Total;
+ Represented.R := SumR div Total;
+ Represented.G := SumG div Total;
+ Represented.B := SumB div Total;
+ AMin := AMin and ChannelMask;
+ RMin := RMin and ChannelMask;
+ GMin := GMin and ChannelMask;
+ BMin := BMin and ChannelMask;
+ AMax := (AMax and ChannelMask) + (not ChannelMask);
+ RMax := (RMax and ChannelMask) + (not ChannelMask);
+ GMax := (GMax and ChannelMask) + (not ChannelMask);
+ BMax := (BMax and ChannelMask) + (not ChannelMask);
+ end;
+ end;
+ // sort color boxes
+ for I := 0 to Boxes - 2 do
+ begin
+ Largest := 0;
+ for J := I to Boxes - 1 do
+ if Box[J].Total > Largest then
+ begin
+ Largest := Box[J].Total;
+ LargestIdx := J;
+ end;
+ if LargestIdx <> I then
+ begin
+ Temp := Box[I];
+ Box[I] := Box[LargestIdx];
+ Box[LargestIdx] := Temp;
+ end;
+ end;
+ end;
+ end;
+
+ procedure FillOutputPalette;
+ var
+ I: LongInt;
+ begin
+ FillChar(DstPal^, SizeOf(TColor32Rec) * MaxColors, $FF);
+ for I := 0 to MaxColors - 1 do
+ begin
+ if I < Boxes then
+ with Box[I].Represented do
+ begin
+ DstPal[I].A := A;
+ DstPal[I].R := R;
+ DstPal[I].G := G;
+ DstPal[I].B := B;
+ end
+ else
+ DstPal[I].Color := $FF000000;
+ end;
+ end;
+
+ function MapColor(const Col: TColor32Rec) : LongInt;
+ var
+ I: LongInt;
+ begin
+ I := 0;
+ with Col do
+ while (I < Boxes) and ((Box[I].AMin > A) or (Box[I].AMax < A) or
+ (Box[I].RMin > R) or (Box[I].RMax < R) or (Box[I].GMin > G) or
+ (Box[I].GMax < G) or (Box[I].BMin > B) or (Box[I].BMax < B)) do
+ Inc(I);
+ if I = Boxes then
+ MapColor := 0
+ else
+ MapColor := I;
+ end;
+
+ procedure MapImage(Src, Dst: PByte; SrcInfo, DstInfo: PImageFormatInfo);
+ var
+ I: LongInt;
+ Col: TColor32Rec;
+ begin
+ for I := 0 to NumPixels - 1 do
+ begin
+ Col := GetPixel32Generic(Src, SrcInfo, nil);
+ IndexSetDstPixel(Dst, DstInfo, MapColor(Col));
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end;
+ end;
+
+begin
+ MaxColors := ClampInt(MaxColors, 2, MaxPossibleColors);
+
+ if (raUpdateHistogram in Actions) or (raMapImage in Actions) then
+ begin
+ Assert(not SrcInfo.IsSpecial);
+ Assert(not SrcInfo.IsIndexed);
+ end;
+
+ if raCreateHistogram in Actions then
+ FillChar(Table, SizeOf(Table), 0);
+
+ if raUpdateHistogram in Actions then
+ CreateHistogram(Src, SrcInfo, ChannelMask);
+
+ if raMakeColorMap in Actions then
+ begin
+ MakeColorMap;
+ FillOutputPalette;
+ end;
+
+ if raMapImage in Actions then
+ MapImage(Src, Dst, SrcInfo, DstInfo);
+end;
+
+procedure StretchNearest(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
+ SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
+ DstHeight: LongInt);
+var
+ Info: TImageFormatInfo;
+ ScaleX, ScaleY, X, Y, Xp, Yp: LongInt;
+ DstPixel, SrcLine: PByte;
+begin
+ GetImageFormatInfo(SrcImage.Format, Info);
+ Assert(SrcImage.Format = DstImage.Format);
+ Assert(not Info.IsSpecial);
+ // Use integers instead of floats for source image pixel coords
+ // Xp and Yp coords must be shifted right to get read source image coords
+ ScaleX := (SrcWidth shl 16) div DstWidth;
+ ScaleY := (SrcHeight shl 16) div DstHeight;
+ Yp := 0;
+ for Y := 0 to DstHeight - 1 do
+ begin
+ Xp := 0;
+ SrcLine := @PByteArray(SrcImage.Bits)[((SrcY + Yp shr 16) * SrcImage.Width + SrcX) * Info.BytesPerPixel];
+ DstPixel := @PByteArray(DstImage.Bits)[((DstY + Y) * DstImage.Width + DstX) * Info.BytesPerPixel];
+ for X := 0 to DstWidth - 1 do
+ begin
+ case Info.BytesPerPixel of
+ 1: PByte(DstPixel)^ := PByteArray(SrcLine)[Xp shr 16];
+ 2: PWord(DstPixel)^ := PWordArray(SrcLine)[Xp shr 16];
+ 3: PColor24Rec(DstPixel)^ := PPalette24(SrcLine)[Xp shr 16];
+ 4: PColor32(DstPixel)^ := PLongWordArray(SrcLine)[Xp shr 16];
+ 6: PColor48Rec(DstPixel)^ := PColor48RecArray(SrcLine)[Xp shr 16];
+ 8: PColor64(DstPixel)^ := PInt64Array(SrcLine)[Xp shr 16];
+ 16: PColorFPRec(DstPixel)^ := PColorFPRecArray(SrcLine)[Xp shr 16];
+ end;
+ Inc(DstPixel, Info.BytesPerPixel);
+ Inc(Xp, ScaleX);
+ end;
+ Inc(Yp, ScaleY);
+ end;
+end;
+
+{ Filter function for nearest filtering. Also known as box filter.}
+function FilterNearest(Value: Single): Single;
+begin
+ if (Value > -0.5) and (Value <= 0.5) then
+ Result := 1
+ else
+ Result := 0;
+end;
+
+{ Filter function for linear filtering. Also known as triangle or Bartlett filter.}
+function FilterLinear(Value: Single): Single;
+begin
+ if Value < 0.0 then
+ Value := -Value;
+ if Value < 1.0 then
+ Result := 1.0 - Value
+ else
+ Result := 0.0;
+end;
+
+{ Cosine filter.}
+function FilterCosine(Value: Single): Single;
+begin
+ Result := 0;
+ if Abs(Value) < 1 then
+ Result := (Cos(Value * Pi) + 1) / 2;
+end;
+
+{ f(t) = 2|t|^3 - 3|t|^2 + 1, -1 <= t <= 1 }
+function FilterHermite(Value: Single): Single;
+begin
+ if Value < 0.0 then
+ Value := -Value;
+ if Value < 1 then
+ Result := (2 * Value - 3) * Sqr(Value) + 1
+ else
+ Result := 0;
+end;
+
+{ Quadratic filter. Also known as Bell.}
+function FilterQuadratic(Value: Single): Single;
+begin
+ if Value < 0.0 then
+ Value := -Value;
+ if Value < 0.5 then
+ Result := 0.75 - Sqr(Value)
+ else
+ if Value < 1.5 then
+ begin
+ Value := Value - 1.5;
+ Result := 0.5 * Sqr(Value);
+ end
+ else
+ Result := 0.0;
+end;
+
+{ Gaussian filter.}
+function FilterGaussian(Value: Single): Single;
+begin
+ Result := Exp(-2.0 * Sqr(Value)) * Sqrt(2.0 / Pi);
+end;
+
+{ 4th order (cubic) b-spline filter.}
+function FilterSpline(Value: Single): Single;
+var
+ Temp: Single;
+begin
+ if Value < 0.0 then
+ Value := -Value;
+ if Value < 1.0 then
+ begin
+ Temp := Sqr(Value);
+ Result := 0.5 * Temp * Value - Temp + 2.0 / 3.0;
+ end
+ else
+ if Value < 2.0 then
+ begin
+ Value := 2.0 - Value;
+ Result := Sqr(Value) * Value / 6.0;
+ end
+ else
+ Result := 0.0;
+end;
+
+{ Lanczos-windowed sinc filter.}
+function FilterLanczos(Value: Single): Single;
+
+ function SinC(Value: Single): Single;
+ begin
+ if Value <> 0.0 then
+ begin
+ Value := Value * Pi;
+ Result := Sin(Value) / Value;
+ end
+ else
+ Result := 1.0;
+ end;
+
+begin
+ if Value < 0.0 then
+ Value := -Value;
+ if Value < 3.0 then
+ Result := SinC(Value) * SinC(Value / 3.0)
+ else
+ Result := 0.0;
+end;
+
+{ Micthell cubic filter.}
+function FilterMitchell(Value: Single): Single;
+const
+ B = 1.0 / 3.0;
+ C = 1.0 / 3.0;
+var
+ Temp: Single;
+begin
+ if Value < 0.0 then
+ Value := -Value;
+ Temp := Sqr(Value);
+ if Value < 1.0 then
+ begin
+ Value := (((12.0 - 9.0 * B - 6.0 * C) * (Value * Temp)) +
+ ((-18.0 + 12.0 * B + 6.0 * C) * Temp) +
+ (6.0 - 2.0 * B));
+ Result := Value / 6.0;
+ end
+ else
+ if Value < 2.0 then
+ begin
+ Value := (((-B - 6.0 * C) * (Value * Temp)) +
+ ((6.0 * B + 30.0 * C) * Temp) +
+ ((-12.0 * B - 48.0 * C) * Value) +
+ (8.0 * B + 24.0 * C));
+ Result := Value / 6.0;
+ end
+ else
+ Result := 0.0;
+end;
+
+{ CatmullRom spline filter.}
+function FilterCatmullRom(Value: Single): Single;
+begin
+ if Value < 0.0 then
+ Value := -Value;
+ if Value < 1.0 then
+ Result := 0.5 * (2.0 + Sqr(Value) * (-5.0 + 3.0 * Value))
+ else
+ if Value < 2.0 then
+ Result := 0.5 * (4.0 + Value * (-8.0 + Value * (5.0 - Value)))
+ else
+ Result := 0.0;
+end;
+
+procedure StretchResample(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
+ SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
+ DstHeight: LongInt; Filter: TSamplingFilter; WrapEdges: Boolean);
+begin
+ // Calls the other function with filter function and radius defined by Filter
+ StretchResample(SrcImage, SrcX, SrcY, SrcWidth, SrcHeight, DstImage, DstX, DstY,
+ DstWidth, DstHeight, SamplingFilterFunctions[Filter], SamplingFilterRadii[Filter],
+ WrapEdges);
+end;
+
+var
+ FullEdge: Boolean = True;
+
+{ The following resampling code is modified and extended code from Graphics32
+ library by Alex A. Denisov.}
+function BuildMappingTable(DstLow, DstHigh, SrcLow, SrcHigh, SrcImageWidth: LongInt;
+ Filter: TFilterFunction; Radius: Single; WrapEdges: Boolean): TMappingTable;
+var
+ I, J, K, N: LongInt;
+ Left, Right, SrcWidth, DstWidth: LongInt;
+ Weight, Scale, Center, Count: Single;
+begin
+ Result := nil;
+ K := 0;
+ SrcWidth := SrcHigh - SrcLow;
+ DstWidth := DstHigh - DstLow;
+
+ // Check some special cases
+ if SrcWidth = 1 then
+ begin
+ SetLength(Result, DstWidth);
+ for I := 0 to DstWidth - 1 do
+ begin
+ SetLength(Result[I], 1);
+ Result[I][0].Pos := 0;
+ Result[I][0].Weight := 1.0;
+ end;
+ Exit;
+ end
+ else
+ if (SrcWidth = 0) or (DstWidth = 0) then
+ Exit;
+
+ if FullEdge then
+ Scale := DstWidth / SrcWidth
+ else
+ Scale := (DstWidth - 1) / (SrcWidth - 1);
+
+ SetLength(Result, DstWidth);
+
+ // Pre-calculate filter contributions for a row or column
+ if Scale = 0.0 then
+ begin
+ Assert(Length(Result) = 1);
+ SetLength(Result[0], 1);
+ Result[0][0].Pos := (SrcLow + SrcHigh) div 2;
+ Result[0][0].Weight := 1.0;
+ end
+ else if Scale < 1.0 then
+ begin
+ // Sub-sampling - scales from bigger to smaller
+ Radius := Radius / Scale;
+ for I := 0 to DstWidth - 1 do
+ begin
+ if FullEdge then
+ Center := SrcLow - 0.5 + (I + 0.5) / Scale
+ else
+ Center := SrcLow + I / Scale;
+ Left := Floor(Center - Radius);
+ Right := Ceil(Center + Radius);
+ Count := -1.0;
+ for J := Left to Right do
+ begin
+ Weight := Filter((Center - J) * Scale) * Scale;
+ if Weight <> 0.0 then
+ begin
+ Count := Count + Weight;
+ K := Length(Result[I]);
+ SetLength(Result[I], K + 1);
+ Result[I][K].Pos := ClampInt(J, SrcLow, SrcHigh - 1);
+ Result[I][K].Weight := Weight;
+ end;
+ end;
+ if Length(Result[I]) = 0 then
+ begin
+ SetLength(Result[I], 1);
+ Result[I][0].Pos := Floor(Center);
+ Result[I][0].Weight := 1.0;
+ end
+ else if Count <> 0.0 then
+ Result[I][K div 2].Weight := Result[I][K div 2].Weight - Count;
+ end;
+ end
+ else // if Scale > 1.0 then
+ begin
+ // Super-sampling - scales from smaller to bigger
+ Scale := 1.0 / Scale;
+ for I := 0 to DstWidth - 1 do
+ begin
+ if FullEdge then
+ Center := SrcLow - 0.5 + (I + 0.5) * Scale
+ else
+ Center := SrcLow + I * Scale;
+ Left := Floor(Center - Radius);
+ Right := Ceil(Center + Radius);
+ Count := -1.0;
+ for J := Left to Right do
+ begin
+ Weight := Filter(Center - J);
+ if Weight <> 0.0 then
+ begin
+ Count := Count + Weight;
+ K := Length(Result[I]);
+ SetLength(Result[I], K + 1);
+
+ if WrapEdges then
+ begin
+ if J < 0 then
+ N := SrcImageWidth + J
+ else if J >= SrcImageWidth then
+ N := J - SrcImageWidth
+ else
+ N := ClampInt(J, SrcLow, SrcHigh - 1);
+ end
+ else
+ N := ClampInt(J, SrcLow, SrcHigh - 1);
+
+ Result[I][K].Pos := N;
+ Result[I][K].Weight := Weight;
+ end;
+ end;
+ if Count <> 0.0 then
+ Result[I][K div 2].Weight := Result[I][K div 2].Weight - Count;
+ 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,
+ SrcHeight: LongInt; var DstImage: TImageData; DstX, DstY, DstWidth,
+ DstHeight: LongInt; Filter: TFilterFunction; Radius: Single; WrapEdges: Boolean);
+const
+ Channel8BitMax: Single = 255.0;
+type
+ TBufferItem = record
+ A, R, G, B: Integer;
+ end;
+var
+ MapX, MapY: TMappingTable;
+ I, J, X, Y: LongInt;
+ XMinimum, XMaximum: LongInt;
+ LineBufferFP: array of TColorFPRec;
+ LineBufferInt: array of TBufferItem;
+ ClusterX, ClusterY: TCluster;
+ Weight, AccumA, AccumR, AccumG, AccumB: Single;
+ IWeight, IAccumA, IAccumR, IAccumG, IAccumB: Integer;
+ DstLine: PByte;
+ SrcColor: TColor32Rec;
+ SrcFloat: TColorFPRec;
+ Info: TImageFormatInfo;
+ BytesPerChannel: LongInt;
+ ChannelValueMax, InvChannelValueMax: Single;
+ UseOptimizedVersion: Boolean;
+begin
+ GetImageFormatInfo(SrcImage.Format, Info);
+ Assert(SrcImage.Format = DstImage.Format);
+ Assert(not Info.IsSpecial and not Info.IsIndexed);
+ BytesPerChannel := Info.BytesPerPixel div Info.ChannelCount;
+ UseOptimizedVersion := (BytesPerChannel = 1) and not Info.UsePixelFormat;
+
+ // Create horizontal and vertical mapping tables
+ MapX := BuildMappingTable(DstX, DstX + DstWidth, SrcX, SrcX + SrcWidth,
+ SrcImage.Width, Filter, Radius, WrapEdges);
+ MapY := BuildMappingTable(DstY, DstY + DstHeight, SrcY, SrcY + SrcHeight,
+ SrcImage.Height, Filter, Radius, WrapEdges);
+
+ if (MapX = nil) or (MapY = nil) then
+ Exit;
+
+ ClusterX := nil;
+ ClusterY := nil;
+
+ try
+ // Find min and max X coords of pixels that will contribute to target image
+ FindExtremes(MapX, XMinimum, XMaximum);
+
+ if not UseOptimizedVersion then
+ begin
+ SetLength(LineBufferFP, XMaximum - XMinimum + 1);
+ // Following code works for the rest of data formats
+ for J := 0 to DstHeight - 1 do
+ begin
+ // First for each pixel in the current line sample vertically
+ // and store results in LineBuffer. Then sample horizontally
+ // using values in LineBuffer.
+ ClusterY := MapY[J];
+ for X := XMinimum to XMaximum do
+ begin
+ // Clear accumulators
+ AccumA := 0;
+ AccumR := 0;
+ AccumG := 0;
+ AccumB := 0;
+ // For each pixel in line compute weighted sum of pixels
+ // in source column that will contribute to this pixel
+ for Y := 0 to Length(ClusterY) - 1 do
+ begin
+ // Accumulate this pixel's weighted value
+ Weight := ClusterY[Y].Weight;
+ SrcFloat := Info.GetPixelFP(@PByteArray(SrcImage.Bits)[(ClusterY[Y].Pos * SrcImage.Width + X) * Info.BytesPerPixel], @Info, nil);
+ AccumB := AccumB + SrcFloat.B * Weight;
+ AccumG := AccumG + SrcFloat.G * Weight;
+ AccumR := AccumR + SrcFloat.R * Weight;
+ AccumA := AccumA + SrcFloat.A * Weight;
+ end;
+ // Store accumulated value for this pixel in buffer
+ with LineBufferFP[X - XMinimum] do
+ begin
+ A := AccumA;
+ R := AccumR;
+ G := AccumG;
+ B := AccumB;
+ end;
+ end;
+
+ DstLine := @PByteArray(DstImage.Bits)[((J + DstY) * DstImage.Width + DstX) * Info.BytesPerPixel];
+ // Now compute final colors for targte pixels in the current row
+ // by sampling horizontally
+ for I := 0 to DstWidth - 1 do
+ begin
+ ClusterX := MapX[I];
+ // Clear accumulator
+ AccumA := 0;
+ AccumR := 0;
+ AccumG := 0;
+ AccumB := 0;
+ // Compute weighted sum of values (which are already
+ // computed weighted sums of pixels in source columns stored in LineBuffer)
+ // that will contribute to the current target pixel
+ for X := 0 to Length(ClusterX) - 1 do
+ begin
+ Weight := ClusterX[X].Weight;
+ with LineBufferFP[ClusterX[X].Pos - XMinimum] do
+ begin
+ AccumB := AccumB + B * Weight;
+ AccumG := AccumG + G * Weight;
+ AccumR := AccumR + R * Weight;
+ AccumA := AccumA + A * Weight;
+ end;
+ end;
+
+ // Now compute final color to be written to dest image
+ SrcFloat.A := AccumA;
+ SrcFloat.R := AccumR;
+ SrcFloat.G := AccumG;
+ SrcFloat.B := AccumB;
+
+ Info.SetPixelFP(DstLine, @Info, nil, SrcFloat);
+ Inc(DstLine, Info.BytesPerPixel);
+ end;
+ end;
+ end
+ else
+ begin
+ SetLength(LineBufferInt, XMaximum - XMinimum + 1);
+ // Following code is optimized for images with 8 bit channels
+ for J := 0 to DstHeight - 1 do
+ begin
+ ClusterY := MapY[J];
+ for X := XMinimum to XMaximum do
+ begin
+ IAccumA := 0;
+ IAccumR := 0;
+ IAccumG := 0;
+ IAccumB := 0;
+ for Y := 0 to Length(ClusterY) - 1 do
+ begin
+ IWeight := Round(256 * ClusterY[Y].Weight);
+ CopyPixel(
+ @PByteArray(SrcImage.Bits)[(ClusterY[Y].Pos * SrcImage.Width + X) * Info.BytesPerPixel],
+ @SrcColor, Info.BytesPerPixel);
+
+ IAccumB := IAccumB + SrcColor.B * IWeight;
+ IAccumG := IAccumG + SrcColor.G * IWeight;
+ IAccumR := IAccumR + SrcColor.R * IWeight;
+ IAccumA := IAccumA + SrcColor.A * IWeight;
+ end;
+ with LineBufferInt[X - XMinimum] do
+ begin
+ A := IAccumA;
+ R := IAccumR;
+ G := IAccumG;
+ B := IAccumB;
+ end;
+ end;
+
+ DstLine := @PByteArray(DstImage.Bits)[((J + DstY) * DstImage.Width + DstX)* Info.BytesPerPixel];
+
+ for I := 0 to DstWidth - 1 do
+ begin
+ ClusterX := MapX[I];
+ IAccumA := 0;
+ IAccumR := 0;
+ IAccumG := 0;
+ IAccumB := 0;
+ for X := 0 to Length(ClusterX) - 1 do
+ begin
+ IWeight := Round(256 * ClusterX[X].Weight);
+ with LineBufferInt[ClusterX[X].Pos - XMinimum] do
+ begin
+ IAccumB := IAccumB + B * IWeight;
+ IAccumG := IAccumG + G * IWeight;
+ IAccumR := IAccumR + R * IWeight;
+ IAccumA := IAccumA + A * IWeight;
+ end;
+ end;
+
+ SrcColor.B := ClampInt(IAccumB, 0, $00FF0000) shr 16;
+ SrcColor.G := ClampInt(IAccumG, 0, $00FF0000) shr 16;
+ SrcColor.R := ClampInt(IAccumR, 0, $00FF0000) shr 16;
+ SrcColor.A := ClampInt(IAccumA, 0, $00FF0000) shr 16;
+
+ CopyPixel(@SrcColor, DstLine, Info.BytesPerPixel);
+ Inc(DstLine, Info.BytesPerPixel);
+ end;
+ end;
+ end;
+
+ finally
+ MapX := nil;
+ MapY := nil;
+ end;
+end;
+
+procedure FillMipMapLevel(const BiggerLevel: TImageData; Width, Height: LongInt;
+ var SmallerLevel: TImageData);
+var
+ Filter: TSamplingFilter;
+ Info: TImageFormatInfo;
+ CompatibleCopy: TImageData;
+begin
+ Assert(TestImage(BiggerLevel));
+ Filter := TSamplingFilter(GetOption(ImagingMipMapFilter));
+
+ // If we have special format image we must create copy to allow pixel access
+ GetImageFormatInfo(BiggerLevel.Format, Info);
+ if Info.IsSpecial then
+ begin
+ InitImage(CompatibleCopy);
+ CloneImage(BiggerLevel, CompatibleCopy);
+ ConvertImage(CompatibleCopy, ifDefault);
+ end
+ else
+ CompatibleCopy := BiggerLevel;
+
+ // Create new smaller image
+ NewImage(Width, Height, CompatibleCopy.Format, SmallerLevel);
+ GetImageFormatInfo(CompatibleCopy.Format, Info);
+ // If input is indexed we must copy its palette
+ if Info.IsIndexed then
+ CopyPalette(CompatibleCopy.Palette, SmallerLevel.Palette, 0, 0, Info.PaletteEntries);
+
+ if (Filter = sfNearest) or Info.IsIndexed then
+ begin
+ StretchNearest(CompatibleCopy, 0, 0, CompatibleCopy.Width, CompatibleCopy.Height,
+ SmallerLevel, 0, 0, Width, Height);
+ end
+ else
+ begin
+ StretchResample(CompatibleCopy, 0, 0, CompatibleCopy.Width, CompatibleCopy.Height,
+ SmallerLevel, 0, 0, Width, Height, Filter);
+ end;
+
+ // Free copy and convert result to special format if necessary
+ if CompatibleCopy.Format <> BiggerLevel.Format then
+ begin
+ ConvertImage(SmallerLevel, BiggerLevel.Format);
+ FreeImage(CompatibleCopy);
+ end;
+end;
+
+
+{ Various format support functions }
+
+procedure CopyPixel(Src, Dest: Pointer; BytesPerPixel: LongInt);
+begin
+ case BytesPerPixel of
+ 1: PByte(Dest)^ := PByte(Src)^;
+ 2: PWord(Dest)^ := PWord(Src)^;
+ 3: PColor24Rec(Dest)^ := PColor24Rec(Src)^;
+ 4: PLongWord(Dest)^ := PLongWord(Src)^;
+ 6: PColor48Rec(Dest)^ := PColor48Rec(Src)^;
+ 8: PInt64(Dest)^ := PInt64(Src)^;
+ 16: PColorFPRec(Dest)^ := PColorFPRec(Src)^;
+ end;
+end;
+
+function ComparePixels(PixelA, PixelB: Pointer; BytesPerPixel: LongInt): Boolean;
+begin
+ case BytesPerPixel of
+ 1: Result := PByte(PixelA)^ = PByte(PixelB)^;
+ 2: Result := PWord(PixelA)^ = PWord(PixelB)^;
+ 3: Result := (PWord(PixelA)^ = PWord(PixelB)^) and
+ (PColor24Rec(PixelA).R = PColor24Rec(PixelB).R);
+ 4: Result := PLongWord(PixelA)^ = PLongWord(PixelB)^;
+ 6: Result := (PLongWord(PixelA)^ = PLongWord(PixelB)^) and
+ (PColor48Rec(PixelA).R = PColor48Rec(PixelB).R);
+ 8: Result := PInt64(PixelA)^ = PInt64(PixelB)^;
+ 16: Result := (PFloatHelper(PixelA).Data2 = PFloatHelper(PixelB).Data2) and
+ (PFloatHelper(PixelA).Data1 = PFloatHelper(PixelB).Data1);
+ else
+ Result := False;
+ end;
+end;
+
+procedure TranslatePixel(SrcPixel, DstPixel: Pointer; SrcFormat,
+ DstFormat: TImageFormat; SrcPalette, DstPalette: PPalette32);
+var
+ SrcInfo, DstInfo: PImageFormatInfo;
+ PixFP: TColorFPRec;
+begin
+ SrcInfo := FInfos[SrcFormat];
+ DstInfo := FInfos[DstFormat];
+
+ PixFP := GetPixelFPGeneric(SrcPixel, SrcInfo, SrcPalette);
+ SetPixelFPGeneric(DstPixel, DstInfo, DstPalette, PixFP);
+end;
+
+procedure ClampFloatPixel(var PixF: TColorFPRec);
+begin
+ if PixF.A > 1.0 then
+ PixF.A := 1.0;
+ if PixF.R > 1.0 then
+ PixF.R := 1.0;
+ if PixF.G > 1.0 then
+ PixF.G := 1.0;
+ if PixF.B > 1.0 then
+ PixF.B := 1.0;
+
+ if PixF.A < 0.0 then
+ PixF.A := 0.0;
+ if PixF.R < 0.0 then
+ PixF.R := 0.0;
+ if PixF.G < 0.0 then
+ PixF.G := 0.0;
+ if PixF.B < 0.0 then
+ PixF.B := 0.0;
+end;
+
+procedure AddPadBytes(DataIn: Pointer; DataOut: Pointer; Width, Height,
+ Bpp, WidthBytes: LongInt);
+var
+ I, W: LongInt;
+begin
+ W := Width * Bpp;
+ for I := 0 to Height - 1 do
+ Move(PByteArray(DataIn)[I * W], PByteArray(DataOut)[I * WidthBytes], W);
+end;
+
+procedure RemovePadBytes(DataIn: Pointer; DataOut: Pointer; Width, Height,
+ Bpp, WidthBytes: LongInt);
+var
+ I, W: LongInt;
+begin
+ W := Width * Bpp;
+ for I := 0 to Height - 1 do
+ Move(PByteArray(DataIn)[I * WidthBytes], PByteArray(DataOut)[I * W], W);
+end;
+
+procedure Convert1To8(DataIn, DataOut: Pointer; Width, Height,
+ WidthBytes: LongInt);
+const
+ Mask1: array[0..7] of Byte = ($80, $40, $20, $10, $08, $04, $02, $01);
+ Shift1: array[0..7] of Byte = (7, 6, 5, 4, 3, 2, 1, 0);
+var
+ X, Y: LongInt;
+begin
+ for Y := 0 to Height - 1 do
+ for X := 0 to Width - 1 do
+ PByteArray(DataOut)[Y * Width + X] :=
+ (PByteArray(DataIn)[Y * WidthBytes + X shr 3] and
+ Mask1[X and 7]) shr Shift1[X and 7];
+end;
+
+procedure Convert2To8(DataIn, DataOut: Pointer; Width, Height,
+ WidthBytes: LongInt);
+const
+ Mask2: array[0..3] of Byte = ($C0, $30, $0C, $03);
+ Shift2: array[0..3] of Byte = (6, 4, 2, 0);
+var
+ X, Y: LongInt;
+begin
+ for Y := 0 to Height - 1 do
+ for X := 0 to Width - 1 do
+ PByteArray(DataOut)[Y * Width + X] :=
+ (PByteArray(DataIn)[X shr 2] and Mask2[X and 3]) shr
+ Shift2[X and 3];
+end;
+
+procedure Convert4To8(DataIn, DataOut: Pointer; Width, Height,
+ WidthBytes: LongInt);
+const
+ Mask4: array[0..1] of Byte = ($F0, $0F);
+ Shift4: array[0..1] of Byte = (4, 0);
+var
+ X, Y: LongInt;
+begin
+ for Y := 0 to Height - 1 do
+ for X := 0 to Width - 1 do
+ PByteArray(DataOut)[Y * Width + X] :=
+ (PByteArray(DataIn)[Y * WidthBytes + X shr 1] and
+ Mask4[X and 1]) shr Shift4[X and 1];
+end;
+
+function Has16BitImageAlpha(NumPixels: LongInt; Data: PWord): Boolean;
+var
+ I: LongInt;
+begin
+ Result := False;
+ for I := 0 to NumPixels - 1 do
+ begin
+ if Data^ >= 1 shl 15 then
+ begin
+ Result := True;
+ Exit;
+ end;
+ Inc(Data);
+ end;
+end;
+
+function Has32BitImageAlpha(NumPixels: LongInt; Data: PLongWord): Boolean;
+var
+ I: LongInt;
+begin
+ Result := False;
+ for I := 0 to NumPixels - 1 do
+ begin
+ if Data^ >= 1 shl 24 then
+ begin
+ Result := True;
+ Exit;
+ end;
+ Inc(Data);
+ end;
+end;
+
+function GetScanLine(ImageBits: Pointer; const FormatInfo: TImageFormatInfo;
+ LineWidth, Index: LongInt): Pointer;
+var
+ LineBytes: LongInt;
+begin
+ Assert(not FormatInfo.IsSpecial);
+ LineBytes := FormatInfo.GetPixelsSize(FormatInfo.Format, LineWidth, 1);
+ Result := @PByteArray(ImageBits)[Index * LineBytes];
+end;
+
+function IsImageFormatValid(Format: TImageFormat): Boolean;
+begin
+ Result := FInfos[Format] <> nil;
+end;
+
+const
+ HalfMin: Single = 5.96046448e-08; // Smallest positive half
+ HalfMinNorm: Single = 6.10351562e-05; // Smallest positive normalized half
+ HalfMax: Single = 65504.0; // Largest positive half
+ HalfEpsilon: Single = 0.00097656; // Smallest positive e for which half (1.0 + e) != half (1.0)
+ HalfNaN: THalfFloat = 65535;
+ HalfPosInf: THalfFloat = 31744;
+ HalfNegInf: THalfFloat = 64512;
+
+
+{
+
+ Half/Float conversions inspired by half class from OpenEXR library.
+
+
+ Float (Pascal Single type) is an IEEE 754 single-precision
+
+ floating point number.
+
+ Bit layout of Single:
+
+ 31 (msb)
+ |
+ | 30 23
+ | | |
+ | | | 22 0 (lsb)
+ | | | | |
+ X XXXXXXXX XXXXXXXXXXXXXXXXXXXXXXX
+ s e m
+
+ Bit layout of half:
+
+ 15 (msb)
+ |
+ | 14 10
+ | | |
+ | | | 9 0 (lsb)
+ | | | | |
+ X XXXXX XXXXXXXXXX
+ s e m
+
+ S is the sign-bit, e is the exponent and m is the significand (mantissa).
+}
+
+
+function HalfToFloat(Half: THalfFloat): Single;
+var
+ Dst, Sign, Mantissa: LongWord;
+ Exp: LongInt;
+begin
+ // extract sign, exponent, and mantissa from half number
+ Sign := Half shr 15;
+ Exp := (Half and $7C00) shr 10;
+ Mantissa := Half and 1023;
+
+ if (Exp > 0) and (Exp < 31) then
+ begin
+ // common normalized number
+ Exp := Exp + (127 - 15);
+ Mantissa := Mantissa shl 13;
+ Dst := (Sign shl 31) or (LongWord(Exp) shl 23) or Mantissa;
+ // Result := Power(-1, Sign) * Power(2, Exp - 15) * (1 + Mantissa / 1024);
+ end
+ else if (Exp = 0) and (Mantissa = 0) then
+ begin
+ // zero - preserve sign
+ Dst := Sign shl 31;
+ end
+ else if (Exp = 0) and (Mantissa <> 0) then
+ begin
+ // denormalized number - renormalize it
+ while (Mantissa and $00000400) = 0 do
+ begin
+ Mantissa := Mantissa shl 1;
+ Dec(Exp);
+ end;
+ Inc(Exp);
+ Mantissa := Mantissa and not $00000400;
+ // now assemble normalized number
+ Exp := Exp + (127 - 15);
+ Mantissa := Mantissa shl 13;
+ Dst := (Sign shl 31) or (LongWord(Exp) shl 23) or Mantissa;
+ // Result := Power(-1, Sign) * Power(2, -14) * (Mantissa / 1024);
+ end
+ else if (Exp = 31) and (Mantissa = 0) then
+ begin
+ // +/- infinity
+ Dst := (Sign shl 31) or $7F800000;
+ end
+ else //if (Exp = 31) and (Mantisa <> 0) then
+ begin
+ // not a number - preserve sign and mantissa
+ Dst := (Sign shl 31) or $7F800000 or (Mantissa shl 13);
+ end;
+
+ // reinterpret LongWord as Single
+ Result := PSingle(@Dst)^;
+end;
+
+function FloatToHalf(Float: Single): THalfFloat;
+var
+ Src: LongWord;
+ Sign, Exp, Mantissa: LongInt;
+begin
+ Src := PLongWord(@Float)^;
+ // extract sign, exponent, and mantissa from Single number
+ Sign := Src shr 31;
+ Exp := LongInt((Src and $7F800000) shr 23) - 127 + 15;
+ Mantissa := Src and $007FFFFF;
+
+ if (Exp > 0) and (Exp < 30) then
+ begin
+ // simple case - round the significand and combine it with the sign and exponent
+ Result := (Sign shl 15) or (Exp shl 10) or ((Mantissa + $00001000) shr 13);
+ end
+ else if Src = 0 then
+ begin
+ // input float is zero - return zero
+ Result := 0;
+ end
+ else
+ begin
+ // difficult case - lengthy conversion
+ if Exp <= 0 then
+ begin
+ if Exp < -10 then
+ begin
+ // input float's value is less than HalfMin, return zero
+ Result := 0;
+ end
+ else
+ begin
+ // Float is a normalized Single whose magnitude is less than HalfNormMin.
+ // We convert it to denormalized half.
+ Mantissa := (Mantissa or $00800000) shr (1 - Exp);
+ // round to nearest
+ if (Mantissa and $00001000) > 0 then
+ Mantissa := Mantissa + $00002000;
+ // assemble Sign and Mantissa (Exp is zero to get denotmalized number)
+ Result := (Sign shl 15) or (Mantissa shr 13);
+ end;
+ end
+ else if Exp = 255 - 127 + 15 then
+ begin
+ if Mantissa = 0 then
+ begin
+ // input float is infinity, create infinity half with original sign
+ Result := (Sign shl 15) or $7C00;
+ end
+ else
+ begin
+ // input float is NaN, create half NaN with original sign and mantissa
+ Result := (Sign shl 15) or $7C00 or (Mantissa shr 13);
+ end;
+ end
+ else
+ begin
+ // Exp is > 0 so input float is normalized Single
+
+ // round to nearest
+ if (Mantissa and $00001000) > 0 then
+ begin
+ Mantissa := Mantissa + $00002000;
+ if (Mantissa and $00800000) > 0 then
+ begin
+ Mantissa := 0;
+ Exp := Exp + 1;
+ end;
+ end;
+
+ if Exp > 30 then
+ begin
+ // exponent overflow - return infinity half
+ Result := (Sign shl 15) or $7C00;
+ end
+ else
+ // assemble normalized half
+ Result := (Sign shl 15) or (Exp shl 10) or (Mantissa shr 13);
+ end;
+ end;
+end;
+
+function ColorHalfToFloat(ColorHF: TColorHFRec): TColorFPRec;
+begin
+ Result.A := HalfToFloat(ColorHF.A);
+ Result.R := HalfToFloat(ColorHF.R);
+ Result.G := HalfToFloat(ColorHF.G);
+ Result.B := HalfToFloat(ColorHF.B);
+end;
+
+function ColorFloatToHalf(ColorFP: TColorFPRec): TColorHFRec;
+begin
+ Result.A := FloatToHalf(ColorFP.A);
+ Result.R := FloatToHalf(ColorFP.R);
+ Result.G := FloatToHalf(ColorFP.G);
+ Result.B := FloatToHalf(ColorFP.B);
+end;
+
+procedure VisualizePalette(Pal: PPalette32; Entries: Integer; out PalImage: TImageData);
+var
+ I: Integer;
+ Pix: PColor32;
+begin
+ InitImage(PalImage);
+ NewImage(Entries, 1, ifA8R8G8B8, PalImage);
+ Pix := PalImage.Bits;
+ for I := 0 to Entries - 1 do
+ begin
+ Pix^ := Pal[I].Color;
+ Inc(Pix);
+ end;
+end;
+
+
+{ Pixel readers/writers for different image formats }
+
+procedure ChannelGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
+ var Pix: TColor64Rec);
+var
+ A, R, G, B: Byte;
+begin
+ FillChar(Pix, SizeOf(Pix), 0);
+ // returns 64 bit color value with 16 bits for each channel
+ case SrcInfo.BytesPerPixel of
+ 1:
+ begin
+ PFGetARGB(SrcInfo.PixelFormat^, Src^, A, R, G, B);
+ Pix.A := A shl 8;
+ Pix.R := R shl 8;
+ Pix.G := G shl 8;
+ Pix.B := B shl 8;
+ end;
+ 2:
+ begin
+ PFGetARGB(SrcInfo.PixelFormat^, PWord(Src)^, A, R, G, B);
+ Pix.A := A shl 8;
+ Pix.R := R shl 8;
+ Pix.G := G shl 8;
+ Pix.B := B shl 8;
+ end;
+ 3:
+ with Pix do
+ begin
+ R := MulDiv(PColor24Rec(Src).R, 65535, 255);
+ G := MulDiv(PColor24Rec(Src).G, 65535, 255);
+ B := MulDiv(PColor24Rec(Src).B, 65535, 255);
+ end;
+ 4:
+ with Pix do
+ begin
+ A := MulDiv(PColor32Rec(Src).A, 65535, 255);
+ R := MulDiv(PColor32Rec(Src).R, 65535, 255);
+ G := MulDiv(PColor32Rec(Src).G, 65535, 255);
+ B := MulDiv(PColor32Rec(Src).B, 65535, 255);
+ end;
+ 6:
+ with Pix do
+ begin
+ R := PColor48Rec(Src).R;
+ G := PColor48Rec(Src).G;
+ B := PColor48Rec(Src).B;
+ end;
+ 8: Pix.Color := PColor64(Src)^;
+ end;
+ // if src has no alpha, we set it to max (otherwise we would have to
+ // test if dest has alpha or not in each ChannelToXXX function)
+ if not SrcInfo.HasAlphaChannel then
+ Pix.A := 65535;
+
+ if SrcInfo.IsRBSwapped then
+ SwapValues(Pix.R, Pix.B);
+end;
+
+procedure ChannelSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
+ const Pix: TColor64Rec);
+var
+ PixW: TColor64Rec;
+begin
+ PixW := Pix;
+ if DstInfo.IsRBSwapped then
+ SwapValues(PixW.R, PixW.B);
+ // Pix contains 64 bit color value with 16 bit for each channel
+ case DstInfo.BytesPerPixel of
+ 1: Dst^ := PFSetARGB(DstInfo.PixelFormat^, PixW.A shr 8,
+ PixW.R shr 8, PixW.G shr 8, PixW.B shr 8);
+ 2: PWord(Dst)^ := PFSetARGB(DstInfo.PixelFormat^, PixW.A shr 8,
+ PixW.R shr 8, PixW.G shr 8, PixW.B shr 8);
+ 3:
+ with PColor24Rec(Dst)^ do
+ begin
+ R := MulDiv(PixW.R, 255, 65535);
+ G := MulDiv(PixW.G, 255, 65535);
+ B := MulDiv(PixW.B, 255, 65535);
+ end;
+ 4:
+ with PColor32Rec(Dst)^ do
+ begin
+ A := MulDiv(PixW.A, 255, 65535);
+ R := MulDiv(PixW.R, 255, 65535);
+ G := MulDiv(PixW.G, 255, 65535);
+ B := MulDiv(PixW.B, 255, 65535);
+ end;
+ 6:
+ with PColor48Rec(Dst)^ do
+ begin
+ R := PixW.R;
+ G := PixW.G;
+ B := PixW.B;
+ end;
+ 8: PColor64(Dst)^ := PixW.Color;
+ end;
+end;
+
+procedure GrayGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
+ var Gray: TColor64Rec; var Alpha: Word);
+begin
+ FillChar(Gray, SizeOf(Gray), 0);
+ // Source alpha is scaled to 16 bits and stored in Alpha,
+ // grayscale value is scaled to 64 bits and stored in Gray
+ case SrcInfo.BytesPerPixel of
+ 1: Gray.A := MulDiv(Src^, 65535, 255);
+ 2:
+ if SrcInfo.HasAlphaChannel then
+ with PWordRec(Src)^ do
+ begin
+ Alpha := MulDiv(High, 65535, 255);
+ Gray.A := MulDiv(Low, 65535, 255);
+ end
+ else
+ Gray.A := PWord(Src)^;
+ 4:
+ if SrcInfo.HasAlphaChannel then
+ with PLongWordRec(Src)^ do
+ begin
+ Alpha := High;
+ Gray.A := Low;
+ end
+ else
+ with PLongWordRec(Src)^ do
+ begin
+ Gray.A := High;
+ Gray.R := Low;
+ end;
+ 8: Gray.Color := PColor64(Src)^;
+ end;
+ // if src has no alpha, we set it to max (otherwise we would have to
+ // test if dest has alpha or not in each GrayToXXX function)
+ if not SrcInfo.HasAlphaChannel then
+ Alpha := 65535;
+end;
+
+procedure GraySetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
+ const Gray: TColor64Rec; Alpha: Word);
+begin
+ // Gray contains grayscale value scaled to 64 bits, Alpha contains
+ // alpha value scaled to 16 bits
+ case DstInfo.BytesPerPixel of
+ 1: Dst^ := MulDiv(Gray.A, 255, 65535);
+ 2:
+ if DstInfo.HasAlphaChannel then
+ with PWordRec(Dst)^ do
+ begin
+ High := MulDiv(Alpha, 255, 65535);
+ Low := MulDiv(Gray.A, 255, 65535);
+ end
+ else
+ PWord(Dst)^ := Gray.A;
+ 4:
+ if DstInfo.HasAlphaChannel then
+ with PLongWordRec(Dst)^ do
+ begin
+ High := Alpha;
+ Low := Gray.A;
+ end
+ else
+ with PLongWordRec(Dst)^ do
+ begin
+ High := Gray.A;
+ Low := Gray.R;
+ end;
+ 8: PColor64(Dst)^ := Gray.Color;
+ end;
+end;
+
+procedure FloatGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
+ var Pix: TColorFPRec);
+var
+ PixHF: TColorHFRec;
+begin
+ if SrcInfo.BytesPerPixel in [4, 16] then
+ begin
+ // IEEE 754 single-precision channels
+ FillChar(Pix, SizeOf(Pix), 0);
+ case SrcInfo.BytesPerPixel of
+ 4: Pix.R := PSingle(Src)^;
+ 16: Pix := PColorFPRec(Src)^;
+ end;
+ end
+ else
+ begin
+ // half float channels
+ FillChar(PixHF, SizeOf(PixHF), 0);
+ case SrcInfo.BytesPerPixel of
+ 2: PixHF.R := PHalfFloat(Src)^;
+ 8: PixHF := PColorHFRec(Src)^;
+ end;
+ Pix := ColorHalfToFloat(PixHF);
+ end;
+ // if src has no alpha, we set it to max (otherwise we would have to
+ // test if dest has alpha or not in each FloatToXXX function)
+ if not SrcInfo.HasAlphaChannel then
+ Pix.A := 1.0;
+ if SrcInfo.IsRBSwapped then
+ SwapValues(Pix.R, Pix.B);
+end;
+
+procedure FloatSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
+ const Pix: TColorFPRec);
+var
+ PixW: TColorFPRec;
+ PixHF: TColorHFRec;
+begin
+ PixW := Pix;
+ if DstInfo.IsRBSwapped then
+ SwapValues(PixW.R, PixW.B);
+ if DstInfo.BytesPerPixel in [4, 16] then
+ begin
+ case DstInfo.BytesPerPixel of
+ 4: PSingle(Dst)^ := PixW.R;
+ 16: PColorFPRec(Dst)^ := PixW;
+ end;
+ end
+ else
+ begin
+ PixHF := ColorFloatToHalf(PixW);
+ case DstInfo.BytesPerPixel of
+ 2: PHalfFloat(Dst)^ := PixHF.R;
+ 8: PColorHFRec(Dst)^ := PixHF;
+ end;
+ end;
+end;
+
+procedure IndexGetSrcPixel(Src: PByte; SrcInfo: PImageFormatInfo;
+ var Index: LongWord);
+begin
+ case SrcInfo.BytesPerPixel of
+ 1: Index := Src^;
+ end;
+end;
+
+procedure IndexSetDstPixel(Dst: PByte; DstInfo: PImageFormatInfo;
+ Index: LongWord);
+begin
+ case DstInfo.BytesPerPixel of
+ 1: Dst^ := Byte(Index);
+ 2: PWord(Dst)^ := Word(Index);
+ 4: PLongWord(Dst)^ := Index;
+ end;
+end;
+
+
+{ Pixel readers/writers for 32bit and FP colors}
+
+function GetPixel32Generic(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColor32Rec;
+var
+ Pix64: TColor64Rec;
+ PixF: TColorFPRec;
+ Alpha: Word;
+ Index: LongWord;
+begin
+ if Info.Format = ifA8R8G8B8 then
+ begin
+ Result := PColor32Rec(Bits)^
+ end
+ else if Info.Format = ifR8G8B8 then
+ begin
+ PColor24Rec(@Result)^ := PColor24Rec(Bits)^;
+ Result.A := $FF;
+ end
+ else if Info.IsFloatingPoint then
+ begin
+ FloatGetSrcPixel(Bits, Info, PixF);
+ Result.A := ClampToByte(Round(PixF.A * 255.0));
+ Result.R := ClampToByte(Round(PixF.R * 255.0));
+ Result.G := ClampToByte(Round(PixF.G * 255.0));
+ Result.B := ClampToByte(Round(PixF.B * 255.0));
+ end
+ else if Info.HasGrayChannel then
+ begin
+ GrayGetSrcPixel(Bits, Info, Pix64, Alpha);
+ Result.A := MulDiv(Alpha, 255, 65535);
+ Result.R := MulDiv(Pix64.A, 255, 65535);
+ Result.G := MulDiv(Pix64.A, 255, 65535);
+ Result.B := MulDiv(Pix64.A, 255, 65535);
+ end
+ else if Info.IsIndexed then
+ begin
+ IndexGetSrcPixel(Bits, Info, Index);
+ Result := Palette[Index];
+ end
+ else
+ begin
+ ChannelGetSrcPixel(Bits, Info, Pix64);
+ Result.A := MulDiv(Pix64.A, 255, 65535);
+ Result.R := MulDiv(Pix64.R, 255, 65535);
+ Result.G := MulDiv(Pix64.G, 255, 65535);
+ Result.B := MulDiv(Pix64.B, 255, 65535);
+ end;
+end;
+
+procedure SetPixel32Generic(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColor32Rec);
+var
+ Pix64: TColor64Rec;
+ PixF: TColorFPRec;
+ Alpha: Word;
+ Index: LongWord;
+begin
+ if Info.Format = ifA8R8G8B8 then
+ begin
+ PColor32Rec(Bits)^ := Color
+ end
+ else if Info.Format = ifR8G8B8 then
+ begin
+ PColor24Rec(Bits)^ := Color.Color24Rec;
+ end
+ else if Info.IsFloatingPoint then
+ begin
+ PixF.A := Color.A * OneDiv8Bit;
+ PixF.R := Color.R * OneDiv8Bit;
+ PixF.G := Color.G * OneDiv8Bit;
+ PixF.B := Color.B * OneDiv8Bit;
+ FloatSetDstPixel(Bits, Info, PixF);
+ end
+ else if Info.HasGrayChannel then
+ begin
+ Alpha := MulDiv(Color.A, 65535, 255);
+ Pix64.Color := 0;
+ Pix64.A := MulDiv(Round(GrayConv.R * Color.R + GrayConv.G * Color.G +
+ GrayConv.B * Color.B), 65535, 255);
+ GraySetDstPixel(Bits, Info, Pix64, Alpha);
+ end
+ else if Info.IsIndexed then
+ begin
+ Index := FindColor(Palette, Info.PaletteEntries, Color.Color);
+ IndexSetDstPixel(Bits, Info, Index);
+ end
+ else
+ begin
+ Pix64.A := MulDiv(Color.A, 65535, 255);
+ Pix64.R := MulDiv(Color.R, 65535, 255);
+ Pix64.G := MulDiv(Color.G, 65535, 255);
+ Pix64.B := MulDiv(Color.B, 65535, 255);
+ ChannelSetDstPixel(Bits, Info, Pix64);
+ end;
+end;
+
+function GetPixelFPGeneric(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec;
+var
+ Pix32: TColor32Rec;
+ Pix64: TColor64Rec;
+ Alpha: Word;
+ Index: LongWord;
+begin
+ if Info.IsFloatingPoint then
+ begin
+ FloatGetSrcPixel(Bits, Info, Result);
+ end
+ else if Info.HasGrayChannel then
+ begin
+ GrayGetSrcPixel(Bits, Info, Pix64, Alpha);
+ Result.A := Alpha * OneDiv16Bit;
+ Result.R := Pix64.A * OneDiv16Bit;
+ Result.G := Pix64.A * OneDiv16Bit;
+ Result.B := Pix64.A * OneDiv16Bit;
+ end
+ else if Info.IsIndexed then
+ begin
+ IndexGetSrcPixel(Bits, Info, Index);
+ Pix32 := Palette[Index];
+ Result.A := Pix32.A * OneDiv8Bit;
+ Result.R := Pix32.R * OneDiv8Bit;
+ Result.G := Pix32.G * OneDiv8Bit;
+ Result.B := Pix32.B * OneDiv8Bit;
+ end
+ else
+ begin
+ ChannelGetSrcPixel(Bits, Info, Pix64);
+ Result.A := Pix64.A * OneDiv16Bit;
+ Result.R := Pix64.R * OneDiv16Bit;
+ Result.G := Pix64.G * OneDiv16Bit;
+ Result.B := Pix64.B * OneDiv16Bit;
+ end;
+end;
+
+procedure SetPixelFPGeneric(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec);
+var
+ Pix32: TColor32Rec;
+ Pix64: TColor64Rec;
+ Alpha: Word;
+ Index: LongWord;
+begin
+ if Info.IsFloatingPoint then
+ begin
+ FloatSetDstPixel(Bits, Info, Color);
+ end
+ else if Info.HasGrayChannel then
+ begin
+ Alpha := ClampToWord(Round(Color.A * 65535.0));
+ Pix64.Color := 0;
+ Pix64.A := ClampToWord(Round((GrayConv.R * Color.R + GrayConv.G * Color.G +
+ GrayConv.B * Color.B) * 65535.0));
+ GraySetDstPixel(Bits, Info, Pix64, Alpha);
+ end
+ else if Info.IsIndexed then
+ begin
+ Pix32.A := ClampToByte(Round(Color.A * 255.0));
+ Pix32.R := ClampToByte(Round(Color.R * 255.0));
+ Pix32.G := ClampToByte(Round(Color.G * 255.0));
+ Pix32.B := ClampToByte(Round(Color.B * 255.0));
+ Index := FindColor(Palette, Info.PaletteEntries, Pix32.Color);
+ IndexSetDstPixel(Bits, Info, Index);
+ end
+ else
+ begin
+ Pix64.A := ClampToWord(Round(Color.A * 65535.0));
+ Pix64.R := ClampToWord(Round(Color.R * 65535.0));
+ Pix64.G := ClampToWord(Round(Color.G * 65535.0));
+ Pix64.B := ClampToWord(Round(Color.B * 65535.0));
+ ChannelSetDstPixel(Bits, Info, Pix64);
+ end;
+end;
+
+
+{ Image format conversion functions }
+
+procedure ChannelToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo);
+var
+ I: LongInt;
+ Pix64: TColor64Rec;
+begin
+ // two most common conversions (RGB->ARGB and ARGB->RGB for 24/32 bit
+ // images) are made separately from general ARGB conversion to
+ // make them faster
+ if (SrcInfo.BytesPerPixel = 3) and (DstInfo.BytesPerPixel = 4) then
+ for I := 0 to NumPixels - 1 do
+ begin
+ PColor24Rec(Dst)^ := PColor24Rec(Src)^;
+ if DstInfo.HasAlphaChannel then
+ PColor32Rec(Dst).A := 255;
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end
+ else
+ if (SrcInfo.BytesPerPixel = 4) and (DstInfo.BytesPerPixel = 3) then
+ for I := 0 to NumPixels - 1 do
+ begin
+ PColor24Rec(Dst)^ := PColor24Rec(Src)^;
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end
+ else
+ for I := 0 to NumPixels - 1 do
+ begin
+ // general ARGB conversion
+ ChannelGetSrcPixel(Src, SrcInfo, Pix64);
+ ChannelSetDstPixel(Dst, DstInfo, Pix64);
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end;
+end;
+
+procedure ChannelToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo);
+var
+ I: LongInt;
+ Pix64: TColor64Rec;
+ Alpha: Word;
+begin
+ // two most common conversions (R8G8B8->Gray8 nad A8R8G8B8->Gray8)
+ // are made separately from general conversions to make them faster
+ if (SrcInfo.BytesPerPixel in [3, 4]) and (DstInfo.Format = ifGray8) then
+ for I := 0 to NumPixels - 1 do
+ begin
+ Dst^ := Round(GrayConv.R * PColor24Rec(Src).R + GrayConv.G * PColor24Rec(Src).G +
+ GrayConv.B * PColor24Rec(Src).B);
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end
+ else
+ for I := 0 to NumPixels - 1 do
+ begin
+ ChannelGetSrcPixel(Src, SrcInfo, Pix64);
+
+ // alpha is saved from source pixel to Alpha,
+ // Gray value is computed and set to highest word of Pix64 so
+ // Pix64.Color contains grayscale value scaled to 64 bits
+ Alpha := Pix64.A;
+ with GrayConv do
+ Pix64.A := Round(R * Pix64.R + G * Pix64.G + B * Pix64.B);
+
+ GraySetDstPixel(Dst, DstInfo, Pix64, Alpha);
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end;
+end;
+
+procedure ChannelToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo);
+var
+ I: LongInt;
+ Pix64: TColor64Rec;
+ PixF: TColorFPRec;
+begin
+ for I := 0 to NumPixels - 1 do
+ begin
+ ChannelGetSrcPixel(Src, SrcInfo, Pix64);
+
+ // floating point channel values are scaled to 1.0
+ PixF.A := Pix64.A * OneDiv16Bit;
+ PixF.R := Pix64.R * OneDiv16Bit;
+ PixF.G := Pix64.G * OneDiv16Bit;
+ PixF.B := Pix64.B * OneDiv16Bit;
+
+ FloatSetDstPixel(Dst, DstInfo, PixF);
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end;
+end;
+
+procedure ChannelToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo; DstPal: PPalette32);
+begin
+ ReduceColorsMedianCut(NumPixels, Src, Dst, SrcInfo, DstInfo, DstInfo.PaletteEntries,
+ GetOption(ImagingColorReductionMask), DstPal);
+end;
+
+procedure GrayToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo);
+var
+ I: LongInt;
+ Gray: TColor64Rec;
+ Alpha: Word;
+begin
+ // two most common conversions (Gray8->Gray16 nad Gray16->Gray8)
+ // are made separately from general conversions to make them faster
+ if (SrcInfo.Format = ifGray8) and (DstInfo.Format = ifGray16) then
+ begin
+ for I := 0 to NumPixels - 1 do
+ PWordArray(Dst)[I] := PByteArray(Src)[I] shl 8;
+ end
+ else
+ if (DstInfo.Format = ifGray8) and (SrcInfo.Format = ifGray16) then
+ begin
+ for I := 0 to NumPixels - 1 do
+ PByteArray(Dst)[I] := PWordArray(Src)[I] shr 8;
+ end
+ else
+ for I := 0 to NumPixels - 1 do
+ begin
+ // general grayscale conversion
+ GrayGetSrcPixel(Src, SrcInfo, Gray, Alpha);
+ GraySetDstPixel(Dst, DstInfo, Gray, Alpha);
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end;
+end;
+
+procedure GrayToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo);
+var
+ I: LongInt;
+ Pix64: TColor64Rec;
+ Alpha: Word;
+begin
+ // two most common conversions (Gray8->R8G8B8 nad Gray8->A8R8G8B8)
+ // are made separately from general conversions to make them faster
+ if (DstInfo.BytesPerPixel in [3, 4]) and (SrcInfo.Format = ifGray8) then
+ for I := 0 to NumPixels - 1 do
+ begin
+ PColor24Rec(Dst).R := Src^;
+ PColor24Rec(Dst).G := Src^;
+ PColor24Rec(Dst).B := Src^;
+ if DstInfo.HasAlphaChannel then
+ PColor32Rec(Dst).A := $FF;
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end
+ else
+ for I := 0 to NumPixels - 1 do
+ begin
+ GrayGetSrcPixel(Src, SrcInfo, Pix64, Alpha);
+
+ // most significant word of grayscale value is used for
+ // each channel and alpha channel is set to Alpha
+ Pix64.R := Pix64.A;
+ Pix64.G := Pix64.A;
+ Pix64.B := Pix64.A;
+ Pix64.A := Alpha;
+
+ ChannelSetDstPixel(Dst, DstInfo, Pix64);
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end;
+end;
+
+procedure GrayToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo);
+var
+ I: LongInt;
+ Gray: TColor64Rec;
+ PixF: TColorFPRec;
+ Alpha: Word;
+begin
+ for I := 0 to NumPixels - 1 do
+ begin
+ GrayGetSrcPixel(Src, SrcInfo, Gray, Alpha);
+ // most significant word of grayscale value is used for
+ // each channel and alpha channel is set to Alpha
+ // then all is scaled to 0..1
+ PixF.R := Gray.A * OneDiv16Bit;
+ PixF.G := Gray.A * OneDiv16Bit;
+ PixF.B := Gray.A * OneDiv16Bit;
+ PixF.A := Alpha * OneDiv16Bit;
+
+ FloatSetDstPixel(Dst, DstInfo, PixF);
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end;
+end;
+
+procedure GrayToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo; DstPal: PPalette32);
+var
+ I: LongInt;
+ Idx: LongWord;
+ Gray: TColor64Rec;
+ Alpha, Shift: Word;
+begin
+ FillGrayscalePalette(DstPal, DstInfo.PaletteEntries);
+ Shift := Log2Int(DstInfo.PaletteEntries);
+ // most common conversion (Gray8->Index8)
+ // is made separately from general conversions to make it faster
+ if (SrcInfo.Format = ifGray8) and (DstInfo.Format = ifIndex8) then
+ for I := 0 to NumPixels - 1 do
+ begin
+ Dst^ := Src^;
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end
+ else
+ for I := 0 to NumPixels - 1 do
+ begin
+ // gray value is read from src and index to precomputed
+ // grayscale palette is computed and written to dst
+ // (we assume here that there will be no more than 65536 palette
+ // entries in dst format, gray value is shifted so the highest
+ // gray value match the highest possible index in palette)
+ GrayGetSrcPixel(Src, SrcInfo, Gray, Alpha);
+ Idx := Gray.A shr (16 - Shift);
+ IndexSetDstPixel(Dst, DstInfo, Idx);
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end;
+end;
+
+procedure FloatToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo);
+var
+ I: LongInt;
+ PixF: TColorFPRec;
+begin
+ for I := 0 to NumPixels - 1 do
+ begin
+ // general floating point conversion
+ FloatGetSrcPixel(Src, SrcInfo, PixF);
+ FloatSetDstPixel(Dst, DstInfo, PixF);
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end;
+end;
+
+procedure FloatToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo);
+var
+ I: LongInt;
+ Pix64: TColor64Rec;
+ PixF: TColorFPRec;
+begin
+ for I := 0 to NumPixels - 1 do
+ begin
+ FloatGetSrcPixel(Src, SrcInfo, PixF);
+ ClampFloatPixel(PixF);
+
+ // floating point channel values are scaled to 1.0
+ Pix64.A := ClampToWord(Round(PixF.A * 65535));
+ Pix64.R := ClampToWord(Round(PixF.R * 65535));
+ Pix64.G := ClampToWord(Round(PixF.G * 65535));
+ Pix64.B := ClampToWord(Round(PixF.B * 65535));
+
+ ChannelSetDstPixel(Dst, DstInfo, Pix64);
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end;
+end;
+
+procedure FloatToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo);
+var
+ I: LongInt;
+ PixF: TColorFPRec;
+ Gray: TColor64Rec;
+ Alpha: Word;
+begin
+ for I := 0 to NumPixels - 1 do
+ begin
+ FloatGetSrcPixel(Src, SrcInfo, PixF);
+ ClampFloatPixel(PixF);
+
+ // alpha is saved from source pixel to Alpha,
+ // Gray value is computed and set to highest word of Pix64 so
+ // Pix64.Color contains grayscale value scaled to 64 bits
+ Alpha := ClampToWord(Round(PixF.A * 65535.0));
+ Gray.A := ClampToWord(Round((GrayConv.R * PixF.R + GrayConv.G * PixF.G +
+ GrayConv.B * PixF.B) * 65535.0));
+
+ GraySetDstPixel(Dst, DstInfo, Gray, Alpha);
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end;
+end;
+
+procedure FloatToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo; DstPal: PPalette32);
+begin
+ ReduceColorsMedianCut(NumPixels, Src, Dst, SrcInfo, DstInfo, DstInfo.PaletteEntries,
+ GetOption(ImagingColorReductionMask), DstPal);
+end;
+
+procedure IndexToIndex(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo; SrcPal, DstPal: PPalette32);
+var
+ I: LongInt;
+begin
+ // there is only one indexed format now, so it is just a copy
+ for I := 0 to NumPixels - 1 do
+ begin
+ Dst^ := Src^;
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end;
+ for I := 0 to SrcInfo.PaletteEntries - 1 do
+ DstPal[I] := SrcPal[I];
+end;
+
+procedure IndexToChannel(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo; SrcPal: PPalette32);
+var
+ I: LongInt;
+ Pix64: TColor64Rec;
+ Idx: LongWord;
+begin
+ // two most common conversions (Index8->R8G8B8 nad Index8->A8R8G8B8)
+ // are made separately from general conversions to make them faster
+ if (SrcInfo.Format = ifIndex8) and (DstInfo.Format in [ifR8G8B8, ifA8R8G8B8]) then
+ for I := 0 to NumPixels - 1 do
+ begin
+ with PColor24Rec(Dst)^ do
+ begin
+ R := SrcPal[Src^].R;
+ G := SrcPal[Src^].G;
+ B := SrcPal[Src^].B;
+ end;
+ if DstInfo.Format = ifA8R8G8B8 then
+ PColor32Rec(Dst).A := SrcPal[Src^].A;
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end
+ else
+ for I := 0 to NumPixels - 1 do
+ begin
+ // index to palette is read from source and color
+ // is retrieved from palette entry. Color is then
+ // scaled to 16bits and written to dest
+ IndexGetSrcPixel(Src, SrcInfo, Idx);
+ with Pix64 do
+ begin
+ A := SrcPal[Idx].A shl 8;
+ R := SrcPal[Idx].R shl 8;
+ G := SrcPal[Idx].G shl 8;
+ B := SrcPal[Idx].B shl 8;
+ end;
+ ChannelSetDstPixel(Dst, DstInfo, Pix64);
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end;
+end;
+
+procedure IndexToGray(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo; SrcPal: PPalette32);
+var
+ I: LongInt;
+ Gray: TColor64Rec;
+ Alpha: Word;
+ Idx: LongWord;
+begin
+ // most common conversion (Index8->Gray8)
+ // is made separately from general conversions to make it faster
+ if (SrcInfo.Format = ifIndex8) and (DstInfo.Format = ifGray8) then
+ begin
+ for I := 0 to NumPixels - 1 do
+ begin
+ Dst^ := Round(GrayConv.R * SrcPal[Src^].R + GrayConv.G * SrcPal[Src^].G +
+ GrayConv.B * SrcPal[Src^].B);
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end
+ end
+ else
+ for I := 0 to NumPixels - 1 do
+ begin
+ // index to palette is read from source and color
+ // is retrieved from palette entry. Color is then
+ // transformed to grayscale and assigned to the highest
+ // byte of Gray value
+ IndexGetSrcPixel(Src, SrcInfo, Idx);
+ Alpha := SrcPal[Idx].A shl 8;
+ Gray.A := MulDiv(Round(GrayConv.R * SrcPal[Idx].R + GrayConv.G * SrcPal[Idx].G +
+ GrayConv.B * SrcPal[Idx].B), 65535, 255);
+ GraySetDstPixel(Dst, DstInfo, Gray, Alpha);
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end;
+end;
+
+procedure IndexToFloat(NumPixels: LongInt; Src, Dst: PByte; SrcInfo,
+ DstInfo: PImageFormatInfo; SrcPal: PPalette32);
+var
+ I: LongInt;
+ Idx: LongWord;
+ PixF: TColorFPRec;
+begin
+ for I := 0 to NumPixels - 1 do
+ begin
+ // index to palette is read from source and color
+ // is retrieved from palette entry. Color is then
+ // scaled to 0..1 and written to dest
+ IndexGetSrcPixel(Src, SrcInfo, Idx);
+ with PixF do
+ begin
+ A := SrcPal[Idx].A * OneDiv8Bit;
+ R := SrcPal[Idx].R * OneDiv8Bit;
+ G := SrcPal[Idx].G * OneDiv8Bit;
+ B := SrcPal[Idx].B * OneDiv8Bit;
+ end;
+ FloatSetDstPixel(Dst, DstInfo, PixF);
+ Inc(Src, SrcInfo.BytesPerPixel);
+ Inc(Dst, DstInfo.BytesPerPixel);
+ end;
+end;
+
+
+{ Special formats conversion functions }
+
+type
+ // DXT RGB color block
+ TDXTColorBlock = packed record
+ Color0, Color1: Word;
+ Mask: LongWord;
+ end;
+ PDXTColorBlock = ^TDXTColorBlock;
+
+ // DXT explicit alpha for a block
+ TDXTAlphaBlockExp = packed record
+ Alphas: array[0..3] of Word;
+ end;
+ PDXTAlphaBlockExp = ^TDXTAlphaBlockExp;
+
+ // DXT interpolated alpha for a block
+ TDXTAlphaBlockInt = packed record
+ Alphas: array[0..7] of Byte;
+ end;
+ PDXTAlphaBlockInt = ^TDXTAlphaBlockInt;
+
+ TPixelInfo = record
+ Color: Word;
+ Alpha: Byte;
+ Orig: TColor32Rec;
+ end;
+
+ TPixelBlock = array[0..15] of TPixelInfo;
+
+function DecodeCol(Color: Word): TColor32Rec;
+{$IFDEF USE_INLINE} inline; {$ENDIF}
+begin
+ Result.A := $FF;
+{ Result.R := ((Color and $F800) shr 11) shl 3;
+ Result.G := ((Color and $07E0) shr 5) shl 2;
+ Result.B := (Color and $001F) shl 3;}
+ // this color expansion is slower but gives better results
+ Result.R := (Color shr 11) * 255 div 31;
+ Result.G := ((Color shr 5) and $3F) * 255 div 63;
+ Result.B := (Color and $1F) * 255 div 31;
+end;
+
+procedure DecodeDXT1(SrcBits, DestBits: PByte; Width, Height: LongInt);
+var
+ Sel, X, Y, I, J, K: LongInt;
+ Block: TDXTColorBlock;
+ Colors: array[0..3] of TColor32Rec;
+begin
+ for Y := 0 to Height div 4 - 1 do
+ for X := 0 to Width div 4 - 1 do
+ begin
+ Block := PDXTColorBlock(SrcBits)^;
+ Inc(SrcBits, SizeOf(Block));
+ // we read and decode endpoint colors
+ Colors[0] := DecodeCol(Block.Color0);
+ Colors[1] := DecodeCol(Block.Color1);
+ // and interpolate between them
+ if Block.Color0 > Block.Color1 then
+ begin
+ // interpolation for block without alpha
+ Colors[2].A := $FF;
+ Colors[2].R := (Colors[0].R shl 1 + Colors[1].R + 1) div 3;
+ Colors[2].G := (Colors[0].G shl 1 + Colors[1].G + 1) div 3;
+ Colors[2].B := (Colors[0].B shl 1 + Colors[1].B + 1) div 3;
+ Colors[3].A := $FF;
+ Colors[3].R := (Colors[0].R + Colors[1].R shl 1 + 1) div 3;
+ Colors[3].G := (Colors[0].G + Colors[1].G shl 1 + 1) div 3;
+ Colors[3].B := (Colors[0].B + Colors[1].B shl 1 + 1) div 3;
+ end
+ else
+ begin
+ // interpolation for block with alpha
+ Colors[2].A := $FF;
+ Colors[2].R := (Colors[0].R + Colors[1].R) shr 1;
+ Colors[2].G := (Colors[0].G + Colors[1].G) shr 1;
+ Colors[2].B := (Colors[0].B + Colors[1].B) shr 1;
+ Colors[3].A := 0;
+ Colors[3].R := (Colors[0].R + Colors[1].R shl 1 + 1) div 3;
+ Colors[3].G := (Colors[0].G + Colors[1].G shl 1 + 1) div 3;
+ Colors[3].B := (Colors[0].B + Colors[1].B shl 1 + 1) div 3;
+ end;
+
+ // we distribute the dxt block colors across the 4x4 block of the
+ // destination image accroding to the dxt block mask
+ K := 0;
+ for J := 0 to 3 do
+ for I := 0 to 3 do
+ begin
+ Sel := (Block.Mask and (3 shl (K shl 1))) shr (K shl 1);
+ if ((X shl 2 + I) < Width) and ((Y shl 2 + J) < Height) then
+ PPalette32(DestBits)[(Y shl 2 + J) * Width + X shl 2 + I] :=
+ Colors[Sel];
+ Inc(K);
+ end;
+ end;
+end;
+
+procedure DecodeDXT3(SrcBits, DestBits: PByte; Width, Height: LongInt);
+var
+ Sel, X, Y, I, J, K: LongInt;
+ Block: TDXTColorBlock;
+ AlphaBlock: TDXTAlphaBlockExp;
+ Colors: array[0..3] of TColor32Rec;
+ AWord: Word;
+begin
+ for Y := 0 to Height div 4 - 1 do
+ for X := 0 to Width div 4 - 1 do
+ begin
+ AlphaBlock := PDXTAlphaBlockExp(SrcBits)^;
+ Inc(SrcBits, SizeOf(AlphaBlock));
+ Block := PDXTColorBlock(SrcBits)^;
+ Inc(SrcBits, SizeOf(Block));
+ // we read and decode endpoint colors
+ Colors[0] := DecodeCol(Block.Color0);
+ Colors[1] := DecodeCol(Block.Color1);
+ // and interpolate between them
+ Colors[2].R := (Colors[0].R shl 1 + Colors[1].R + 1) div 3;
+ Colors[2].G := (Colors[0].G shl 1 + Colors[1].G + 1) div 3;
+ Colors[2].B := (Colors[0].B shl 1 + Colors[1].B + 1) div 3;
+ Colors[3].R := (Colors[0].R + Colors[1].R shl 1 + 1) div 3;
+ Colors[3].G := (Colors[0].G + Colors[1].G shl 1 + 1) div 3;
+ Colors[3].B := (Colors[0].B + Colors[1].B shl 1 + 1) div 3;
+
+ // we distribute the dxt block colors and alphas
+ // across the 4x4 block of the destination image
+ // accroding to the dxt block mask and alpha block
+ K := 0;
+ for J := 0 to 3 do
+ begin
+ AWord := AlphaBlock.Alphas[J];
+ for I := 0 to 3 do
+ begin
+ Sel := (Block.Mask and (3 shl (K shl 1))) shr (K shl 1);
+ if (X shl 2 + I < Width) and (Y shl 2 + J < Height) then
+ begin
+ Colors[Sel].A := AWord and $0F;
+ Colors[Sel].A := Colors[Sel].A or (Colors[Sel].A shl 4);
+ PPalette32(DestBits)[(Y shl 2 + J) * Width + X shl 2 + I] :=
+ Colors[Sel];
+ end;
+ Inc(K);
+ AWord := AWord shr 4;
+ 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);
+var
+ Sel, X, Y, I, J, K: LongInt;
+ Block: TDXTColorBlock;
+ AlphaBlock: TDXTAlphaBlockInt;
+ Colors: array[0..3] of TColor32Rec;
+ AMask: 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
+ AlphaBlock := PDXTAlphaBlockInt(SrcBits)^;
+ Inc(SrcBits, SizeOf(AlphaBlock));
+ Block := PDXTColorBlock(SrcBits)^;
+ Inc(SrcBits, SizeOf(Block));
+ // we read and decode endpoint colors
+ Colors[0] := DecodeCol(Block.Color0);
+ Colors[1] := DecodeCol(Block.Color1);
+ // and interpolate between them
+ Colors[2].R := (Colors[0].R shl 1 + Colors[1].R + 1) div 3;
+ Colors[2].G := (Colors[0].G shl 1 + Colors[1].G + 1) div 3;
+ Colors[2].B := (Colors[0].B shl 1 + Colors[1].B + 1) div 3;
+ Colors[3].R := (Colors[0].R + Colors[1].R shl 1 + 1) div 3;
+ Colors[3].G := (Colors[0].G + Colors[1].G shl 1 + 1) div 3;
+ Colors[3].B := (Colors[0].B + Colors[1].B shl 1 + 1) div 3;
+ // 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 colors and alphas
+ // across the 4x4 block of the destination image
+ // accroding to the dxt block mask and alpha block mask
+ K := 0;
+ for J := 0 to 3 do
+ for I := 0 to 3 do
+ begin
+ Sel := (Block.Mask and (3 shl (K shl 1))) shr (K shl 1);
+ if ((X shl 2 + I) < Width) and ((Y shl 2 + J) < Height) then
+ begin
+ Colors[Sel].A := AlphaBlock.Alphas[AMask[J shr 1] and 7];
+ PPalette32(DestBits)[(Y shl 2 + J) * Width + (X shl 2 + I)] :=
+ Colors[Sel];
+ end;
+ Inc(K);
+ AMask[J shr 1] := AMask[J shr 1] shr 3;
+ end;
+ end;
+end;
+
+procedure GetBlock(var Block: TPixelBlock; SrcBits: Pointer; XPos, YPos,
+ Width, Height: LongInt);
+var
+ X, Y, I: LongInt;
+ Src: PColor32Rec;
+begin
+ I := 0;
+ // 4x4 pixel block is filled with information about every
+ // pixel in the block: alpha, original color, 565 color
+ for Y := 0 to 3 do
+ for X := 0 to 3 do
+ begin
+ Src := @PPalette32(SrcBits)[(YPos shl 2 + Y) * Width + XPos shl 2 + X];
+ Block[I].Color := ((Src.R shr 3) shl 11) or ((Src.G shr 2) shl 5) or
+ (Src.B shr 3);
+ Block[I].Alpha := Src.A;
+ Block[I].Orig := Src^;
+ Inc(I);
+ end;
+end;
+
+function ColorDistance(const C1, C2: TColor32Rec): LongInt;
+{$IFDEF USE_INLINE} inline;{$ENDIF}
+begin
+ Result := (C1.R - C2.R) * (C1.R - C2.R) +
+ (C1.G - C2.G) * (C1.G - C2.G) + (C1.B - C2.B) * (C1.B - C2.B);
+end;
+
+procedure GetEndpoints(const Block: TPixelBlock; var Ep0, Ep1: Word);
+var
+ I, J, Farthest, Dist: LongInt;
+ Colors: array[0..15] of TColor32Rec;
+begin
+ // we choose two colors from the pixel block which has the
+ // largest distance between them
+ for I := 0 to 15 do
+ Colors[I] := Block[I].Orig;
+ Farthest := -1;
+ for I := 0 to 15 do
+ for J := I + 1 to 15 do
+ begin
+ Dist := ColorDistance(Colors[I], Colors[J]);
+ if Dist > Farthest then
+ begin
+ Farthest := Dist;
+ Ep0 := Block[I].Color;
+ Ep1 := Block[J].Color;
+ end;
+ end;
+end;
+
+procedure GetAlphaEndpoints(const Block: TPixelBlock; var Min, Max: Byte);
+var
+ I: LongInt;
+begin
+ Min := 255;
+ Max := 0;
+ // we choose the lowest and the highest alpha values
+ for I := 0 to 15 do
+ begin
+ if Block[I].Alpha < Min then
+ Min := Block[I].Alpha;
+ if Block[I].Alpha > Max then
+ Max := Block[I].Alpha;
+ end;
+end;
+
+procedure FixEndpoints(var Ep0, Ep1: Word; HasAlpha: Boolean);
+var
+ Temp: Word;
+begin
+ // if dxt block has alpha information, Ep0 must be smaller
+ // than Ep1, if the block has no alpha Ep1 must be smaller
+ if HasAlpha then
+ begin
+ if Ep0 > Ep1 then
+ begin
+ Temp := Ep0;
+ Ep0 := Ep1;
+ Ep1 := Temp;
+ end;
+ end
+ else
+ if Ep0 < Ep1 then
+ begin
+ Temp := Ep0;
+ Ep0 := Ep1;
+ Ep1 := Temp;
+ end;
+end;
+
+function GetColorMask(Ep0, Ep1: Word; NumCols: LongInt;
+ const Block: TPixelBlock): LongWord;
+var
+ I, J, Closest, Dist: LongInt;
+ Colors: array[0..3] of TColor32Rec;
+ Mask: array[0..15] of Byte;
+begin
+ // we decode endpoint colors
+ Colors[0] := DecodeCol(Ep0);
+ Colors[1] := DecodeCol(Ep1);
+ // and interpolate colors between (3 for DXT1 with alpha, 4 for the others)
+ if NumCols = 3 then
+ begin
+ Colors[2].R := (Colors[0].R + Colors[1].R) shr 1;
+ Colors[2].G := (Colors[0].G + Colors[1].G) shr 1;
+ Colors[2].B := (Colors[0].B + Colors[1].B) shr 1;
+ Colors[3].R := (Colors[0].R + Colors[1].R) shr 1;
+ Colors[3].G := (Colors[0].G + Colors[1].G) shr 1;
+ Colors[3].B := (Colors[0].B + Colors[1].B) shr 1;
+ end
+ else
+ begin
+ Colors[2].R := (Colors[0].R shl 1 + Colors[1].R + 1) div 3;
+ Colors[2].G := (Colors[0].G shl 1 + Colors[1].G + 1) div 3;
+ Colors[2].B := (Colors[0].B shl 1 + Colors[1].B + 1) div 3;
+ Colors[3].R := (Colors[0].R + Colors[1].R shl 1 + 1) div 3;
+ Colors[3].G := (Colors[0].G + Colors[1].G shl 1 + 1) div 3;
+ Colors[3].B := (Colors[0].B + Colors[1].B shl 1 + 1) div 3;
+ end;
+
+ for I := 0 to 15 do
+ begin
+ // this is only for DXT1 with alpha
+ if (Block[I].Alpha < 128) and (NumCols = 3) then
+ begin
+ Mask[I] := 3;
+ Continue;
+ end;
+ // for each of the 16 input pixels the nearest color in the
+ // 4 dxt colors is found
+ Closest := MaxInt;
+ for J := 0 to NumCols - 1 do
+ begin
+ Dist := ColorDistance(Block[I].Orig, Colors[J]);
+ if Dist < Closest then
+ begin
+ Closest := Dist;
+ Mask[I] := J;
+ end;
+ end;
+ end;
+
+ Result := 0;
+ for I := 0 to 15 do
+ Result := Result or (Mask[I] shl (I shl 1));
+end;
+
+procedure GetAlphaMask(Ep0, Ep1: Byte; var Block: TPixelBlock; Mask: PByteArray);
+var
+ Alphas: array[0..7] of Byte;
+ M: array[0..15] of Byte;
+ I, J, Closest, Dist: LongInt;
+begin
+ Alphas[0] := Ep0;
+ Alphas[1] := Ep1;
+ // interpolation between two given alpha endpoints
+ // (I use 6 interpolated values mode)
+ 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;
+
+ // the closest interpolated values for each of the input alpha
+ // is found
+ for I := 0 to 15 do
+ begin
+ Closest := MaxInt;
+ for J := 0 to 7 do
+ begin
+ Dist := Abs(Alphas[J] - Block[I].Alpha);
+ if Dist < Closest then
+ begin
+ Closest := Dist;
+ M[I] := J;
+ end;
+ end;
+ end;
+
+ Mask[0] := M[0] or (M[1] shl 3) or ((M[2] and 3) shl 6);
+ Mask[1] := ((M[2] and 4) shr 2) or (M[3] shl 1) or (M[4] shl 4) or
+ ((M[5] and 1) shl 7);
+ Mask[2] := ((M[5] and 6) shr 1) or (M[6] shl 2) or (M[7] shl 5);
+ Mask[3] := M[8] or (M[9] shl 3) or ((M[10] and 3) shl 6);
+ Mask[4] := ((M[10] and 4) shr 2) or (M[11] shl 1) or (M[12] shl 4) or
+ ((M[13] and 1) shl 7);
+ Mask[5] := ((M[13] and 6) shr 1) or (M[14] shl 2) or (M[15] shl 5);
+end;
+
+
+procedure EncodeDXT1(SrcBits: PByte; DestBits: PByte; Width, Height: LongInt);
+var
+ X, Y, I: LongInt;
+ HasAlpha: Boolean;
+ Block: TDXTColorBlock;
+ Pixels: TPixelBlock;
+begin
+ for Y := 0 to Height div 4 - 1 do
+ for X := 0 to Width div 4 - 1 do
+ begin
+ GetBlock(Pixels, SrcBits, X, Y, Width, Height);
+ HasAlpha := False;
+ for I := 0 to 15 do
+ if Pixels[I].Alpha < 128 then
+ begin
+ HasAlpha := True;
+ Break;
+ end;
+ GetEndpoints(Pixels, Block.Color0, Block.Color1);
+ FixEndpoints(Block.Color0, Block.Color1, HasAlpha);
+ if HasAlpha then
+ Block.Mask := GetColorMask(Block.Color0, Block.Color1, 3, Pixels)
+ else
+ Block.Mask := GetColorMask(Block.Color0, Block.Color1, 4, Pixels);
+ PDXTColorBlock(DestBits)^ := Block;
+ Inc(DestBits, SizeOf(Block));
+ end;
+end;
+
+procedure EncodeDXT3(SrcBits: Pointer; DestBits: PByte; Width, Height: LongInt);
+var
+ X, Y, I: LongInt;
+ Block: TDXTColorBlock;
+ AlphaBlock: TDXTAlphaBlockExp;
+ Pixels: TPixelBlock;
+begin
+ for Y := 0 to Height div 4 - 1 do
+ for X := 0 to Width div 4 - 1 do
+ begin
+ GetBlock(Pixels, SrcBits, X, Y, Width, Height);
+ for I := 0 to 7 do
+ PByteArray(@AlphaBlock.Alphas)[I] :=
+ (Pixels[I shl 1].Alpha shr 4) or ((Pixels[I shl 1 + 1].Alpha shr 4) shl 4);
+ GetEndpoints(Pixels, Block.Color0, Block.Color1);
+ FixEndpoints(Block.Color0, Block.Color1, False);
+ Block.Mask := GetColorMask(Block.Color0, Block.Color1, 4, Pixels);
+ PDXTAlphaBlockExp(DestBits)^ := AlphaBlock;
+ Inc(DestBits, SizeOf(AlphaBlock));
+ PDXTColorBlock(DestBits)^ := Block;
+ Inc(DestBits, SizeOf(Block));
+ end;
+end;
+
+procedure EncodeDXT5(SrcBits: Pointer; DestBits: PByte; Width, Height: LongInt);
+var
+ X, Y: LongInt;
+ Block: TDXTColorBlock;
+ AlphaBlock: TDXTAlphaBlockInt;
+ Pixels: TPixelBlock;
+begin
+ for Y := 0 to Height div 4 - 1 do
+ for X := 0 to Width div 4 - 1 do
+ begin
+ GetBlock(Pixels, SrcBits, X, Y, Width, Height);
+ GetEndpoints(Pixels, Block.Color0, Block.Color1);
+ FixEndpoints(Block.Color0, Block.Color1, False);
+ Block.Mask := GetColorMask(Block.Color0, Block.Color1, 4, Pixels);
+ 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));
+ PDXTColorBlock(DestBits)^ := Block;
+ Inc(DestBits, SizeOf(Block));
+ end;
+end;
+
+type
+ TBTCBlock = packed record
+ MLower, MUpper: Byte;
+ BitField: Word;
+ end;
+ PBTCBlock = ^TBTCBlock;
+
+procedure EncodeBTC(SrcBits: Pointer; DestBits: PByte; Width, Height: Integer);
+var
+ X, Y, I, J: Integer;
+ Block: TBTCBlock;
+ M, MLower, MUpper, K: Integer;
+ Pixels: array[0..15] of Byte;
+begin
+ for Y := 0 to Height div 4 - 1 do
+ for X := 0 to Width div 4 - 1 do
+ begin
+ M := 0;
+ MLower := 0;
+ MUpper := 0;
+ FillChar(Block, SizeOf(Block), 0);
+ K := 0;
+
+ // Store 4x4 pixels and compute average, lower, and upper intensity levels
+ for I := 0 to 3 do
+ for J := 0 to 3 do
+ begin
+ Pixels[K] := PByteArray(SrcBits)[(Y shl 2 + I) * Width + X shl 2 + J];
+ Inc(M, Pixels[K]);
+ Inc(K);
+ end;
+
+ M := M div 16;
+ K := 0;
+
+ // Now compute upper and lower levels, number of upper pixels,
+ // and update bit field (1 when pixel is above avg. level M)
+ for I := 0 to 15 do
+ begin
+ if Pixels[I] > M then
+ begin
+ Inc(MUpper, Pixels[I]);
+ Inc(K);
+ Block.BitField := Block.BitField or (1 shl I);
+ end
+ else
+ Inc(MLower, Pixels[I]);
+ end;
+
+ // Scale levels and save them to block
+ if K > 0 then
+ Block.MUpper := ClampToByte(MUpper div K)
+ else
+ Block.MUpper := 0;
+ Block.MLower := ClampToByte(MLower div (16 - K));
+
+ // Finally save block to dest data
+ PBTCBlock(DestBits)^ := Block;
+ Inc(DestBits, SizeOf(Block));
+ end;
+end;
+
+procedure GetOneChannelBlock(var Block: TPixelBlock; SrcBits: Pointer; XPos, YPos,
+ Width, Height, BytesPP, ChannelIdx: Integer);
+var
+ X, Y, I: Integer;
+ Src: PByte;
+begin
+ I := 0;
+ // 4x4 pixel block is filled with information about every pixel in the block,
+ // but only one channel value is stored in Alpha field
+ for Y := 0 to 3 do
+ for X := 0 to 3 do
+ begin
+ Src := @PByteArray(SrcBits)[(YPos * 4 + Y) * Width * BytesPP +
+ (XPos * 4 + X) * BytesPP + ChannelIdx];
+ Block[I].Alpha := Src^;
+ Inc(I);
+ end;
+end;
+
+procedure EncodeATI1N(SrcBits: Pointer; DestBits: PByte; Width, Height: Integer);
+var
+ X, Y: Integer;
+ AlphaBlock: TDXTAlphaBlockInt;
+ Pixels: TPixelBlock;
+begin
+ for Y := 0 to Height div 4 - 1 do
+ for X := 0 to Width div 4 - 1 do
+ begin
+ // Encode one channel
+ GetOneChannelBlock(Pixels, SrcBits, X, Y, Width, Height, 1, 0);
+ GetAlphaEndPoints(Pixels, AlphaBlock.Alphas[1], AlphaBlock.Alphas[0]);
+ GetAlphaMask(AlphaBlock.Alphas[0], AlphaBlock.Alphas[1], Pixels,
+ PByteArray(@AlphaBlock.Alphas[2]));
+ PDXTAlphaBlockInt(DestBits)^ := AlphaBlock;
+ Inc(DestBits, SizeOf(AlphaBlock));
+ end;
+end;
+
+procedure EncodeATI2N(SrcBits: Pointer; DestBits: PByte; Width, Height: Integer);
+var
+ X, Y: Integer;
+ AlphaBlock: TDXTAlphaBlockInt;
+ Pixels: TPixelBlock;
+begin
+ for Y := 0 to Height div 4 - 1 do
+ for X := 0 to Width div 4 - 1 do
+ begin
+ // Encode Red/X channel
+ GetOneChannelBlock(Pixels, SrcBits, X, Y, Width, Height, 4, ChannelRed);
+ GetAlphaEndPoints(Pixels, AlphaBlock.Alphas[1], AlphaBlock.Alphas[0]);
+ GetAlphaMask(AlphaBlock.Alphas[0], AlphaBlock.Alphas[1], Pixels,
+ PByteArray(@AlphaBlock.Alphas[2]));
+ PDXTAlphaBlockInt(DestBits)^ := AlphaBlock;
+ Inc(DestBits, SizeOf(AlphaBlock));
+ // Encode Green/Y channel
+ GetOneChannelBlock(Pixels, SrcBits, X, Y, Width, Height, 4, ChannelGreen);
+ GetAlphaEndPoints(Pixels, AlphaBlock.Alphas[1], AlphaBlock.Alphas[0]);
+ GetAlphaMask(AlphaBlock.Alphas[0], AlphaBlock.Alphas[1], Pixels,
+ PByteArray(@AlphaBlock.Alphas[2]));
+ PDXTAlphaBlockInt(DestBits)^ := AlphaBlock;
+ Inc(DestBits, SizeOf(AlphaBlock));
+ end;
+end;
+
+procedure DecodeBTC(SrcBits, DestBits: PByte; Width, Height: Integer);
+var
+ X, Y, I, J, K: Integer;
+ Block: TBTCBlock;
+ Dest: PByte;
+begin
+ for Y := 0 to Height div 4 - 1 do
+ for X := 0 to Width div 4 - 1 do
+ begin
+ Block := PBTCBlock(SrcBits)^;
+ Inc(SrcBits, SizeOf(Block));
+ K := 0;
+
+ // Just write MUpper when there is '1' in bit field and MLower
+ // when there is '0'
+ for I := 0 to 3 do
+ for J := 0 to 3 do
+ begin
+ Dest := @PByteArray(DestBits)[(Y shl 2 + I) * Width + X shl 2 + J];
+ if Block.BitField and (1 shl K) <> 0 then
+ Dest^ := Block.MUpper
+ else
+ Dest^ := Block.MLower;
+ Inc(K);
+ end;
+ end;
+end;
+
+procedure DecodeATI1N(SrcBits, DestBits: PByte; Width, Height: Integer);
+var
+ X, Y, I, J: Integer;
+ AlphaBlock: TDXTAlphaBlockInt;
+ AMask: 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
+ AlphaBlock := PDXTAlphaBlockInt(SrcBits)^;
+ Inc(SrcBits, SizeOf(AlphaBlock));
+ // 6 bit alpha mask is copied into two long words for
+ // easier usage
+ AMask[0] := PLongWord(@AlphaBlock.Alphas[2])^ and $00FFFFFF;
+ AMask[1] := PLongWord(@AlphaBlock.Alphas[5])^ and $00FFFFFF;
+ // alpha interpolation between two endpoint alphas
+ GetInterpolatedAlphas(AlphaBlock);
+
+ // we distribute the dxt block alphas
+ // across the 4x4 block of the destination image
+ for J := 0 to 3 do
+ for I := 0 to 3 do
+ begin
+ PByteArray(DestBits)[(Y shl 2 + J) * Width + (X shl 2 + I)] :=
+ AlphaBlock.Alphas[AMask[J shr 1] and 7];
+ AMask[J shr 1] := AMask[J shr 1] shr 3;
+ end;
+ end;
+end;
+
+procedure DecodeATI2N(SrcBits, DestBits: PByte; Width, Height: Integer);
+var
+ X, Y, I, J: Integer;
+ Color: TColor32Rec;
+ AlphaBlock1, AlphaBlock2: TDXTAlphaBlockInt;
+ AMask1: array[0..1] of LongWord;
+ AMask2: array[0..1] of LongWord;
+begin
+ for Y := 0 to Height div 4 - 1 do
+ for X := 0 to Width div 4 - 1 do
+ begin
+ // Read the first alpha block and get masks
+ AlphaBlock1 := PDXTAlphaBlockInt(SrcBits)^;
+ Inc(SrcBits, SizeOf(AlphaBlock1));
+ AMask1[0] := PLongWord(@AlphaBlock1.Alphas[2])^ and $00FFFFFF;
+ AMask1[1] := PLongWord(@AlphaBlock1.Alphas[5])^ and $00FFFFFF;
+ // Read the secind alpha block and get masks
+ AlphaBlock2 := PDXTAlphaBlockInt(SrcBits)^;
+ Inc(SrcBits, SizeOf(AlphaBlock2));
+ AMask2[0] := PLongWord(@AlphaBlock2.Alphas[2])^ and $00FFFFFF;
+ AMask2[1] := PLongWord(@AlphaBlock2.Alphas[5])^ and $00FFFFFF;
+ // alpha interpolation between two endpoint alphas
+ GetInterpolatedAlphas(AlphaBlock1);
+ GetInterpolatedAlphas(AlphaBlock2);
+
+ Color.A := $FF;
+ Color.B := 0;
+
+ // Distribute alpha block values across 4x4 pixel block,
+ // first alpha block represents Red channel, second is Green.
+ for J := 0 to 3 do
+ for I := 0 to 3 do
+ begin
+ Color.R := AlphaBlock1.Alphas[AMask1[J shr 1] and 7];
+ Color.G := AlphaBlock2.Alphas[AMask2[J shr 1] and 7];
+ PColor32RecArray(DestBits)[(Y shl 2 + J) * Width + (X shl 2 + I)] := Color;
+ AMask1[J shr 1] := AMask1[J shr 1] shr 3;
+ AMask2[J shr 1] := AMask2[J shr 1] shr 3;
+ end;
+ end;
+end;
+
+procedure SpecialToUnSpecial(const SrcImage: TImageData; DestBits: Pointer;
+ SpecialFormat: TImageFormat);
+begin
+ case SpecialFormat of
+ ifDXT1: DecodeDXT1(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
+ ifDXT3: DecodeDXT3(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
+ ifDXT5: DecodeDXT5(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
+ ifBTC: DecodeBTC (SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
+ ifATI1N: DecodeATI1N(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
+ ifATI2N: DecodeATI2N(SrcImage.Bits, DestBits, SrcImage.Width, SrcImage.Height);
+ end;
+end;
+
+procedure UnSpecialToSpecial(SrcBits: Pointer; const DestImage: TImageData;
+ SpecialFormat: TImageFormat);
+begin
+ case SpecialFormat of
+ ifDXT1: EncodeDXT1(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
+ ifDXT3: EncodeDXT3(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
+ ifDXT5: EncodeDXT5(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
+ ifBTC: EncodeBTC (SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
+ ifATI1N: EncodeATI1N(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
+ ifATI2N: EncodeATI2N(SrcBits, DestImage.Bits, DestImage.Width, DestImage.Height);
+ end;
+end;
+
+procedure ConvertSpecial(var Image: TImageData;
+ SrcInfo, DstInfo: PImageFormatInfo);
+var
+ WorkImage: TImageData;
+
+ procedure CheckSize(var Img: TImageData; Info: PImageFormatInfo);
+ var
+ Width, Height: Integer;
+ begin
+ Width := Img.Width;
+ Height := Img.Height;
+ DstInfo.CheckDimensions(Info.Format, Width, Height);
+ ResizeImage(Img, Width, Height, rfNearest);
+ end;
+
+begin
+ if SrcInfo.IsSpecial and DstInfo.IsSpecial then
+ begin
+ // Convert source to nearest 'normal' format
+ InitImage(WorkImage);
+ NewImage(Image.Width, Image.Height, SrcInfo.SpecialNearestFormat, WorkImage);
+ SpecialToUnSpecial(Image, WorkImage.Bits, SrcInfo.Format);
+ FreeImage(Image);
+ // Make sure output of SpecialToUnSpecial is the same as input of
+ // UnSpecialToSpecial
+ if SrcInfo.SpecialNearestFormat <> DstInfo.SpecialNearestFormat then
+ ConvertImage(WorkImage, DstInfo.SpecialNearestFormat);
+ // Convert work image to dest special format
+ CheckSize(WorkImage, DstInfo);
+ NewImage(WorkImage.Width, WorkImage.Height, DstInfo.Format, Image);
+ UnSpecialToSpecial(WorkImage.Bits, Image, DstInfo.Format);
+ FreeImage(WorkImage);
+ end
+ else if SrcInfo.IsSpecial and not DstInfo.IsSpecial then
+ begin
+ // Convert source to nearest 'normal' format
+ InitImage(WorkImage);
+ NewImage(Image.Width, Image.Height, SrcInfo.SpecialNearestFormat, WorkImage);
+ SpecialToUnSpecial(Image, WorkImage.Bits, SrcInfo.Format);
+ FreeImage(Image);
+ // Now convert to dest format
+ ConvertImage(WorkImage, DstInfo.Format);
+ Image := WorkImage;
+ end
+ else if not SrcInfo.IsSpecial and DstInfo.IsSpecial then
+ begin
+ // Convert source to nearest format
+ WorkImage := Image;
+ ConvertImage(WorkImage, DstInfo.SpecialNearestFormat);
+ // Now convert from nearest to dest
+ CheckSize(WorkImage, DstInfo);
+ InitImage(Image);
+ NewImage(WorkImage.Width, WorkImage.Height, DstInfo.Format, Image);
+ UnSpecialToSpecial(WorkImage.Bits, Image, DstInfo.Format);
+ FreeImage(WorkImage);
+ end;
+end;
+
+function GetStdPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt;
+begin
+ if FInfos[Format] <> nil then
+ Result := Width * Height * FInfos[Format].BytesPerPixel
+ else
+ Result := 0;
+end;
+
+procedure CheckStdDimensions(Format: TImageFormat; var Width, Height: LongInt);
+begin
+end;
+
+function GetDXTPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt;
+begin
+ // DXT can be used only for images with dimensions that are
+ // multiples of four
+ CheckDXTDimensions(Format, Width, Height);
+ Result := Width * Height;
+ if Format in [ifDXT1, ifATI1N] then
+ Result := Result div 2;
+end;
+
+procedure CheckDXTDimensions(Format: TImageFormat; var Width, Height: LongInt);
+begin
+ // DXT image dimensions must be multiples of four
+ Width := (Width + 3) and not 3; // div 4 * 4;
+ Height := (Height + 3) and not 3; // div 4 * 4;
+end;
+
+function GetBTCPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt;
+begin
+ // BTC can be used only for images with dimensions that are
+ // multiples of four
+ CheckDXTDimensions(Format, Width, Height);
+ Result := Width * Height div 4; // 2bits/pixel
+end;
+
+{ Optimized pixel readers/writers for 32bit and FP colors to be stored in TImageFormatInfo }
+
+function GetPixel32ifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColor32Rec;
+begin
+ Result.Color := PLongWord(Bits)^;
+end;
+
+procedure SetPixel32ifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColor32Rec);
+begin
+ PLongWord(Bits)^ := Color.Color;
+end;
+
+function GetPixelFPifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec;
+begin
+ Result.A := PColor32Rec(Bits).A * OneDiv8Bit;
+ Result.R := PColor32Rec(Bits).R * OneDiv8Bit;
+ Result.G := PColor32Rec(Bits).G * OneDiv8Bit;
+ Result.B := PColor32Rec(Bits).B * OneDiv8Bit;
+end;
+
+procedure SetPixelFPifA8R8G8B8(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec);
+begin
+ PColor32Rec(Bits).A := ClampToByte(Round(Color.A * 255.0));
+ PColor32Rec(Bits).R := ClampToByte(Round(Color.R * 255.0));
+ PColor32Rec(Bits).G := ClampToByte(Round(Color.G * 255.0));
+ PColor32Rec(Bits).B := ClampToByte(Round(Color.B * 255.0));
+end;
+
+function GetPixel32Channel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColor32Rec;
+begin
+ case Info.Format of
+ ifR8G8B8, ifX8R8G8B8:
+ begin
+ Result.A := $FF;
+ PColor24Rec(@Result)^ := PColor24Rec(Bits)^;
+ end;
+ ifGray8, ifA8Gray8:
+ begin
+ if Info.HasAlphaChannel then
+ Result.A := PWordRec(Bits).High
+ else
+ Result.A := $FF;
+ Result.R := PWordRec(Bits).Low;
+ Result.G := PWordRec(Bits).Low;
+ Result.B := PWordRec(Bits).Low;
+ end;
+ end;
+end;
+
+procedure SetPixel32Channel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColor32Rec);
+begin
+ case Info.Format of
+ ifR8G8B8, ifX8R8G8B8:
+ begin
+ PColor24Rec(Bits)^ := PColor24Rec(@Color)^;
+ end;
+ ifGray8, ifA8Gray8:
+ begin
+ if Info.HasAlphaChannel then
+ PWordRec(Bits).High := Color.A;
+ PWordRec(Bits).Low := Round(GrayConv.R * Color.R + GrayConv.G * Color.G +
+ GrayConv.B * Color.B);
+ end;
+ end;
+end;
+
+function GetPixelFPChannel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec;
+begin
+ case Info.Format of
+ ifR8G8B8, ifX8R8G8B8:
+ begin
+ Result.A := 1.0;
+ Result.R := PColor24Rec(Bits).R * OneDiv8Bit;
+ Result.G := PColor24Rec(Bits).G * OneDiv8Bit;
+ Result.B := PColor24Rec(Bits).B * OneDiv8Bit;
+ end;
+ ifGray8, ifA8Gray8:
+ begin
+ if Info.HasAlphaChannel then
+ Result.A := PWordRec(Bits).High * OneDiv8Bit
+ else
+ Result.A := 1.0;
+ Result.R := PWordRec(Bits).Low * OneDiv8Bit;
+ Result.G := PWordRec(Bits).Low * OneDiv8Bit;
+ Result.B := PWordRec(Bits).Low * OneDiv8Bit;
+ end;
+ end;
+end;
+
+procedure SetPixelFPChannel8Bit(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec);
+begin
+ case Info.Format of
+ ifR8G8B8, ifX8R8G8B8:
+ begin
+ PColor24Rec(Bits).R := ClampToByte(Round(Color.R * 255.0));
+ PColor24Rec(Bits).G := ClampToByte(Round(Color.G * 255.0));
+ PColor24Rec(Bits).B := ClampToByte(Round(Color.B * 255.0));
+ end;
+ ifGray8, ifA8Gray8:
+ begin
+ if Info.HasAlphaChannel then
+ PWordRec(Bits).High := ClampToByte(Round(Color.A * 255.0));
+ PWordRec(Bits).Low := ClampToByte(Round((GrayConv.R * Color.R + GrayConv.G * Color.G +
+ GrayConv.B * Color.B) * 255.0));
+ end;
+ end;
+end;
+
+function GetPixelFPFloat32(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32): TColorFPRec;
+begin
+ case Info.Format of
+ ifA32R32G32B32F:
+ begin
+ Result := PColorFPRec(Bits)^;
+ end;
+ ifA32B32G32R32F:
+ begin
+ Result := PColorFPRec(Bits)^;
+ SwapValues(Result.R, Result.B);
+ end;
+ ifR32F:
+ begin
+ Result.A := 1.0;
+ Result.R := PSingle(Bits)^;
+ Result.G := 0.0;
+ Result.B := 0.0;
+ end;
+ end;
+end;
+
+procedure SetPixelFPFloat32(Bits: Pointer; Info: PImageFormatInfo; Palette: PPalette32; const Color: TColorFPRec);
+begin
+ case Info.Format of
+ ifA32R32G32B32F:
+ begin
+ PColorFPRec(Bits)^ := Color;
+ end;
+ ifA32B32G32R32F:
+ begin
+ PColorFPRec(Bits)^ := Color;
+ SwapValues(PColorFPRec(Bits).R, PColorFPRec(Bits).B);
+ end;
+ ifR32F:
+ begin
+ PSingle(Bits)^ := Color.R;
+ 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:
+
+ -- TODOS ----------------------------------------------------
+ - nothing now
+
+ -- 0.26.3 Changes/Bug Fixes -----------------------------------
+ - Filtered resampling ~10% faster now.
+ - Fixed DXT3 alpha encoding.
+ - ifIndex8 format now has HasAlphaChannel=True.
+
+ -- 0.25.0 Changes/Bug Fixes -----------------------------------
+ - Made some resampling stuff public so that it can be used in canvas class.
+ - Added some color constructors.
+ - Added VisualizePalette helper function.
+ - Fixed ConvertSpecial, not very readable before and error when
+ converting special->special.
+
+ -- 0.24.3 Changes/Bug Fixes -----------------------------------
+ - Some refactorings a changes to DXT based formats.
+ - Added ifATI1N and ifATI2N image data formats support structures and functions.
+
+ -- 0.23 Changes/Bug Fixes -----------------------------------
+ - Added ifBTC image format support structures and functions.
+
+ -- 0.21 Changes/Bug Fixes -----------------------------------
+ - FillMipMapLevel now works well with indexed and special formats too.
+ - Moved Convert1To8 and Convert4To8 functions from ImagingBitmaps here
+ and created new Convert2To8 function. They are now used by more than one
+ file format loader.
+
+ -- 0.19 Changes/Bug Fixes -----------------------------------
+ - StretchResample now uses pixel get/set functions stored in
+ TImageFormatInfo so it is much faster for formats that override
+ them with optimized ones
+ - added pixel set/get functions optimized for various image formats
+ (to be stored in TImageFormatInfo)
+ - bug in ConvertSpecial caused problems when converting DXTC images
+ to bitmaps in ImagingCoponents
+ - bug in StretchRect caused that it didn't work with ifR32F and
+ ifR16F formats
+ - removed leftover code in FillMipMapLevel which disabled
+ filtered resizing of images witch ChannelSize <> 8bits
+ - added half float converting functions and support for half based
+ image formats where needed
+ - added TranslatePixel and IsImageFormatValid functions
+ - fixed possible range overflows when converting from FP to integer images
+ - added pixel set/get functions: GetPixel32Generic, GetPixelFPGeneric,
+ SetPixel32Generic, SetPixelFPGeneric
+ - fixed occasional range overflows in StretchResample
+
+ -- 0.17 Changes/Bug Fixes -----------------------------------
+ - added StretchNearest, StretchResample and some sampling functions
+ - added ChannelCount values to TImageFormatInfo constants
+ - added resolution validity check to GetDXTPixelsSize
+
+ -- 0.15 Changes/Bug Fixes -----------------------------------
+ - added RBSwapFormat values to some TImageFromatInfo definitions
+ - fixed bug in ConvertSpecial (causing DXT images to convert only to 32bit)
+ - added CopyPixel, ComparePixels helper functions
+
+ -- 0.13 Changes/Bug Fixes -----------------------------------
+ - replaced pixel format conversions for colors not to be
+ darkened when converting from low bit counts
+ - ReduceColorsMedianCut was updated to support creating one
+ optimal palette for more images and it is somewhat faster
+ now too
+ - there was ugly bug in DXTC dimensions checking
+}
+
+end.
+
diff --git a/Imaging/ImagingGif.pas b/Imaging/ImagingGif.pas
index 0264df8..7fe42e9 100644
--- a/Imaging/ImagingGif.pas
+++ b/Imaging/ImagingGif.pas
@@ -1,1239 +1,1239 @@
-{
- $Id: ImagingGif.pas 157 2009-02-15 14:24:58Z galfar $
- Vampyre Imaging Library
- by Marek Mauder
- http://imaginglib.sourceforge.net
-
- The contents of this file are used with permission, subject to the Mozilla
- Public License Version 1.1 (the "License"); you may not use this file except
- in compliance with the License. You may obtain a copy of the License at
- http://www.mozilla.org/MPL/MPL-1.1.html
-
- Software distributed under the License is distributed on an "AS IS" basis,
- WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
- the specific language governing rights and limitations under the License.
-
- Alternatively, the contents of this file may be used under the terms of the
- GNU Lesser General Public License (the "LGPL License"), in which case the
- provisions of the LGPL License are applicable instead of those above.
- If you wish to allow use of your version of this file only under the terms
- of the LGPL License and not to allow others to use your version of this file
- under the MPL, indicate your decision by deleting the provisions above and
- replace them with the notice and other provisions required by the LGPL
- License. If you do not delete the provisions above, a recipient may use
- your version of this file under either the MPL or the LGPL License.
-
- For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
-}
-
-{ This unit contains image format loader/saver for GIF images.}
-unit ImagingGif;
-
-{$I ImagingOptions.inc}
-
-interface
-
-uses
- SysUtils, Classes, Imaging, ImagingTypes, ImagingIO, ImagingUtility;
-
-type
- { GIF (Graphics Interchange Format) loader/saver class. GIF was
- (and is still used) popular format for storing images supporting
- multiple images per file and single color transparency.
- Pixel format is 8 bit indexed where each image frame can have
- its own color palette. GIF uses lossless LZW compression
- (patent expired few years ago).
- Imaging can load and save all GIFs with all frames and supports
- transparency. Imaging can load just raw ifIndex8 frames or
- also animate them in ifA8R8G8B8 format. See ImagingGIFLoadAnimated option.}
- TGIFFileFormat = class(TImageFileFormat)
- private
- FLoadAnimated: LongBool;
- function InterlaceStep(Y, Height: Integer; var Pass: Integer): Integer;
- procedure LZWDecompress(Stream: TStream; Handle: TImagingHandle;
- Width, Height: Integer; Interlaced: Boolean; Data: Pointer);
- procedure LZWCompress(const IO: TIOFunctions; Handle: TImagingHandle;
- Width, Height, BitCount: Integer; Interlaced: Boolean; Data: Pointer);
- protected
- function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
- OnlyFirstLevel: Boolean): Boolean; override;
- function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
- Index: LongInt): Boolean; override;
- procedure ConvertToSupported(var Image: TImageData;
- const Info: TImageFormatInfo); override;
- public
- constructor Create; override;
- function TestFormat(Handle: TImagingHandle): Boolean; override;
- published
- property LoadAnimated: LongBool read FLoadAnimated write FLoadAnimated;
- end;
-
-implementation
-
-const
- SGIFFormatName = 'Graphics Interchange Format';
- SGIFMasks = '*.gif';
- GIFSupportedFormats: TImageFormats = [ifIndex8];
- GIFDefaultLoadAnimated = True;
-
-type
- TGIFVersion = (gv87, gv89);
- TDisposalMethod = (dmNoRemoval, dmLeave, dmRestoreBackground,
- dmRestorePrevious, dmReserved4, dmReserved5, dmReserved6, dmReserved7);
-
-const
- GIFSignature: TChar3 = 'GIF';
- GIFVersions: array[TGIFVersion] of TChar3 = ('87a', '89a');
-
- // Masks for accessing fields in PackedFields of TGIFHeader
- GIFGlobalColorTable = $80;
- GIFColorResolution = $70;
- GIFColorTableSorted = $08;
- GIFColorTableSize = $07;
-
- // Masks for accessing fields in PackedFields of TImageDescriptor
- GIFLocalColorTable = $80;
- GIFInterlaced = $40;
- GIFLocalTableSorted = $20;
-
- // Block identifiers
- GIFPlainText: Byte = $01;
- GIFGraphicControlExtension: Byte = $F9;
- GIFCommentExtension: Byte = $FE;
- GIFApplicationExtension: Byte = $FF;
- GIFImageDescriptor: Byte = Ord(',');
- GIFExtensionIntroducer: Byte = Ord('!');
- GIFTrailer: Byte = Ord(';');
- GIFBlockTerminator: Byte = $00;
-
- // Masks for accessing fields in PackedFields of TGraphicControlExtension
- GIFTransparent = $01;
- GIFUserInput = $02;
- GIFDisposalMethod = $1C;
-
-type
- TGIFHeader = packed record
- // File header part
- Signature: TChar3; // Header Signature (always "GIF")
- Version: TChar3; // GIF format version("87a" or "89a")
- // Logical Screen Descriptor part
- ScreenWidth: Word; // Width of Display Screen in Pixels
- ScreenHeight: Word; // Height of Display Screen in Pixels
- PackedFields: Byte; // Screen and color map information
- BackgroundColorIndex: Byte; // Background color index (in global color table)
- AspectRatio: Byte; // Pixel aspect ratio, ratio = (AspectRatio + 15) / 64
- end;
-
- TImageDescriptor = packed record
- //Separator: Byte; // leave that out since we always read one bye ahead
- Left: Word; // X position of image with respect to logical screen
- Top: Word; // Y position
- Width: Word;
- Height: Word;
- PackedFields: Byte;
- end;
-
-const
- // GIF extension labels
- GIFExtTypeGraphic = $F9;
- GIFExtTypePlainText = $01;
- GIFExtTypeApplication = $FF;
- GIFExtTypeComment = $FE;
-
-type
- TGraphicControlExtension = packed record
- BlockSize: Byte;
- PackedFields: Byte;
- DelayTime: Word;
- TransparentColorIndex: Byte;
- Terminator: Byte;
- end;
-
-const
- // Netscape sub block types
- GIFAppLoopExtension = 1;
- GIFAppBufferExtension = 2;
-
-type
- TGIFIdentifierCode = array[0..7] of AnsiChar;
- TGIFAuthenticationCode = array[0..2] of AnsiChar;
- TGIFApplicationRec = packed record
- Identifier: TGIFIdentifierCode;
- Authentication: TGIFAuthenticationCode;
- end;
-
-const
- CodeTableSize = 4096;
- HashTableSize = 17777;
-
-type
- TReadContext = record
- Inx: Integer;
- Size: Integer;
- Buf: array [0..255 + 4] of Byte;
- CodeSize: Integer;
- ReadMask: Integer;
- end;
- PReadContext = ^TReadContext;
-
- TWriteContext = record
- Inx: Integer;
- CodeSize: Integer;
- Buf: array [0..255 + 4] of Byte;
- end;
- PWriteContext = ^TWriteContext;
-
- TOutputContext = record
- W: Integer;
- H: Integer;
- X: Integer;
- Y: Integer;
- BitsPerPixel: Integer;
- Pass: Integer;
- Interlace: Boolean;
- LineIdent: Integer;
- Data: Pointer;
- CurrLineData: Pointer;
- end;
-
- TImageDict = record
- Tail: Word;
- Index: Word;
- Col: Byte;
- end;
- PImageDict = ^TImageDict;
-
- PIntCodeTable = ^TIntCodeTable;
- TIntCodeTable = array [0..CodeTableSize - 1] of Word;
-
- TDictTable = array [0..CodeTableSize - 1] of TImageDict;
- PDictTable = ^TDictTable;
-
-resourcestring
- SGIFDecodingError = 'Error when decoding GIF LZW data';
-
-{
- TGIFFileFormat implementation
-}
-
-constructor TGIFFileFormat.Create;
-begin
- inherited Create;
- FName := SGIFFormatName;
- FCanLoad := True;
- FCanSave := True;
- FIsMultiImageFormat := True;
- FSupportedFormats := GIFSupportedFormats;
- FLoadAnimated := GIFDefaultLoadAnimated;
-
- AddMasks(SGIFMasks);
- RegisterOption(ImagingGIFLoadAnimated, @FLoadAnimated);
-end;
-
-function TGIFFileFormat.InterlaceStep(Y, Height: Integer; var Pass: Integer): Integer;
-begin
- Result := Y;
- case Pass of
- 0, 1:
- Inc(Result, 8);
- 2:
- Inc(Result, 4);
- 3:
- Inc(Result, 2);
- end;
- if Result >= Height then
- begin
- if Pass = 0 then
- begin
- Pass := 1;
- Result := 4;
- if Result < Height then
- Exit;
- end;
- if Pass = 1 then
- begin
- Pass := 2;
- Result := 2;
- if Result < Height then
- Exit;
- end;
- if Pass = 2 then
- begin
- Pass := 3;
- Result := 1;
- end;
- end;
-end;
-
-{ GIF LZW decompresion code is from JVCL JvGIF.pas unit.}
-procedure TGIFFileFormat.LZWDecompress(Stream: TStream; Handle: TImagingHandle; Width, Height: Integer;
- Interlaced: Boolean; Data: Pointer);
-var
- MinCodeSize: Byte;
- MaxCode, BitMask, InitCodeSize: Integer;
- ClearCode, EndingCode, FirstFreeCode, FreeCode: Word;
- I, OutCount, Code: Integer;
- CurCode, OldCode, InCode, FinalChar: Word;
- Prefix, Suffix, OutCode: PIntCodeTable;
- ReadCtxt: TReadContext;
- OutCtxt: TOutputContext;
- TableFull: Boolean;
-
- function ReadCode(var Context: TReadContext): Integer;
- var
- RawCode: Integer;
- ByteIndex: Integer;
- Bytes: Byte;
- BytesToLose: Integer;
- begin
- while (Context.Inx + Context.CodeSize > Context.Size) and
- (Stream.Position < Stream.Size) do
- begin
- // Not enough bits in buffer - refill it - Not very efficient, but infrequently called
- BytesToLose := Context.Inx shr 3;
- // Note biggest Code Size is 12 bits. And this can at worst span 3 Bytes
- Move(Context.Buf[Word(BytesToLose)], Context.Buf[0], 3);
- Context.Inx := Context.Inx and 7;
- Context.Size := Context.Size - (BytesToLose shl 3);
- Stream.Read(Bytes, 1);
- if Bytes > 0 then
- Stream.Read(Context.Buf[Word(Context.Size shr 3)], Bytes);
- Context.Size := Context.Size + (Bytes shl 3);
- end;
- ByteIndex := Context.Inx shr 3;
- RawCode := Context.Buf[Word(ByteIndex)] +
- (Word(Context.Buf[Word(ByteIndex + 1)]) shl 8);
- if Context.CodeSize > 8 then
- RawCode := RawCode + (LongInt(Context.Buf[ByteIndex + 2]) shl 16);
- RawCode := RawCode shr (Context.Inx and 7);
- Context.Inx := Context.Inx + Byte(Context.CodeSize);
- Result := RawCode and Context.ReadMask;
- end;
-
- procedure Output(Value: Byte; var Context: TOutputContext);
- var
- P: PByte;
- begin
- if Context.Y >= Context.H then
- Exit;
-
- // Only ifIndex8 supported
- P := @PByteArray(Context.CurrLineData)[Context.X];
- P^ := Value;
-
- {case Context.BitsPerPixel of
- 1:
- begin
- P := @PByteArray(Context.CurrLineData)[Context.X shr 3];
- if (Context.X and $07) <> 0 then
- P^ := P^ or Word(Value shl (7 - (Word(Context.X and 7))))
- else
- P^ := Byte(Value shl 7);
- end;
- 4:
- begin
- P := @PByteArray(Context.CurrLineData)[Context.X shr 1];
- if (Context.X and 1) <> 0 then
- P^ := P^ or Value
- else
- P^ := Byte(Value shl 4);
- end;
- 8:
- begin
- P := @PByteArray(Context.CurrLineData)[Context.X];
- P^ := Value;
- end;
- end;}
- Inc(Context.X);
-
- if Context.X < Context.W then
- Exit;
- Context.X := 0;
- if Context.Interlace then
- Context.Y := InterlaceStep(Context.Y, Context.H, Context.Pass)
- else
- Inc(Context.Y);
-
- Context.CurrLineData := @PByteArray(Context.Data)[Context.Y * Context.LineIdent];
- end;
-
-begin
- OutCount := 0;
- OldCode := 0;
- FinalChar := 0;
- TableFull := False;
- GetMem(Prefix, SizeOf(TIntCodeTable));
- GetMem(Suffix, SizeOf(TIntCodeTable));
- GetMem(OutCode, SizeOf(TIntCodeTable) + SizeOf(Word));
- try
- Stream.Read(MinCodeSize, 1);
- if (MinCodeSize < 2) or (MinCodeSize > 9) then
- RaiseImaging(SGIFDecodingError, []);
- // Initial read context
- ReadCtxt.Inx := 0;
- ReadCtxt.Size := 0;
- ReadCtxt.CodeSize := MinCodeSize + 1;
- ReadCtxt.ReadMask := (1 shl ReadCtxt.CodeSize) - 1;
- // Initialise pixel-output context
- OutCtxt.X := 0;
- OutCtxt.Y := 0;
- OutCtxt.Pass := 0;
- OutCtxt.W := Width;
- OutCtxt.H := Height;
- OutCtxt.BitsPerPixel := MinCodeSize;
- OutCtxt.Interlace := Interlaced;
- OutCtxt.LineIdent := Width;
- OutCtxt.Data := Data;
- OutCtxt.CurrLineData := Data;
- BitMask := (1 shl OutCtxt.BitsPerPixel) - 1;
- // 2 ^ MinCodeSize accounts for all colours in file
- ClearCode := 1 shl MinCodeSize;
- EndingCode := ClearCode + 1;
- FreeCode := ClearCode + 2;
- FirstFreeCode := FreeCode;
- // 2^ (MinCodeSize + 1) includes clear and eoi Code and space too
- InitCodeSize := ReadCtxt.CodeSize;
- MaxCode := 1 shl ReadCtxt.CodeSize;
- Code := ReadCode(ReadCtxt);
- while (Code <> EndingCode) and (Code <> $FFFF) and
- (OutCtxt.Y < OutCtxt.H) do
- begin
- if Code = ClearCode then
- begin
- ReadCtxt.CodeSize := InitCodeSize;
- MaxCode := 1 shl ReadCtxt.CodeSize;
- ReadCtxt.ReadMask := MaxCode - 1;
- FreeCode := FirstFreeCode;
- Code := ReadCode(ReadCtxt);
- CurCode := Code;
- OldCode := Code;
- if Code = $FFFF then
- Break;
- FinalChar := (CurCode and BitMask);
- Output(Byte(FinalChar), OutCtxt);
- TableFull := False;
- end
- else
- begin
- CurCode := Code;
- InCode := Code;
- if CurCode >= FreeCode then
- begin
- CurCode := OldCode;
- OutCode^[OutCount] := FinalChar;
- Inc(OutCount);
- end;
- while CurCode > BitMask do
- begin
- if OutCount > CodeTableSize then
- RaiseImaging(SGIFDecodingError, []);
- OutCode^[OutCount] := Suffix^[CurCode];
- Inc(OutCount);
- CurCode := Prefix^[CurCode];
- end;
-
- FinalChar := CurCode and BitMask;
- OutCode^[OutCount] := FinalChar;
- Inc(OutCount);
- for I := OutCount - 1 downto 0 do
- Output(Byte(OutCode^[I]), OutCtxt);
- OutCount := 0;
- // Update dictionary
- if not TableFull then
- begin
- Prefix^[FreeCode] := OldCode;
- Suffix^[FreeCode] := FinalChar;
- // Advance to next free slot
- Inc(FreeCode);
- if FreeCode >= MaxCode then
- begin
- if ReadCtxt.CodeSize < 12 then
- begin
- Inc(ReadCtxt.CodeSize);
- MaxCode := MaxCode shl 1;
- ReadCtxt.ReadMask := (1 shl ReadCtxt.CodeSize) - 1;
- end
- else
- TableFull := True;
- end;
- end;
- OldCode := InCode;
- end;
- Code := ReadCode(ReadCtxt);
- end;
- if Code = $FFFF then
- RaiseImaging(SGIFDecodingError, []);
- finally
- FreeMem(Prefix);
- FreeMem(OutCode);
- FreeMem(Suffix);
- end;
-end;
-
-{ GIF LZW compresion code is from JVCL JvGIF.pas unit.}
-procedure TGIFFileFormat.LZWCompress(const IO: TIOFunctions; Handle: TImagingHandle; Width, Height, BitCount: Integer;
- Interlaced: Boolean; Data: Pointer);
-var
- LineIdent: Integer;
- MinCodeSize, Col: Byte;
- InitCodeSize, X, Y: Integer;
- Pass: Integer;
- MaxCode: Integer; { 1 shl CodeSize }
- ClearCode, EndingCode, LastCode, Tail: Integer;
- I, HashValue: Integer;
- LenString: Word;
- Dict: PDictTable;
- HashTable: TList;
- PData: PByte;
- WriteCtxt: TWriteContext;
-
- function InitHash(P: Integer): Integer;
- begin
- Result := (P + 3) * 301;
- end;
-
- procedure WriteCode(Code: Integer; var Context: TWriteContext);
- var
- BufIndex: Integer;
- Bytes: Byte;
- begin
- BufIndex := Context.Inx shr 3;
- Code := Code shl (Context.Inx and 7);
- Context.Buf[BufIndex] := Context.Buf[BufIndex] or Byte(Code);
- Context.Buf[BufIndex + 1] := Byte(Code shr 8);
- Context.Buf[BufIndex + 2] := Byte(Code shr 16);
- Context.Inx := Context.Inx + Context.CodeSize;
- if Context.Inx >= 255 * 8 then
- begin
- // Flush out full buffer
- Bytes := 255;
- IO.Write(Handle, @Bytes, 1);
- IO.Write(Handle, @Context.Buf, Bytes);
- Move(Context.Buf[255], Context.Buf[0], 2);
- FillChar(Context.Buf[2], 255, 0);
- Context.Inx := Context.Inx - (255 * 8);
- end;
- end;
-
- procedure FlushCode(var Context: TWriteContext);
- var
- Bytes: Byte;
- begin
- Bytes := (Context.Inx + 7) shr 3;
- if Bytes > 0 then
- begin
- IO.Write(Handle, @Bytes, 1);
- IO.Write(Handle, @Context.Buf, Bytes);
- end;
- // Data block terminator - a block of zero Size
- Bytes := 0;
- IO.Write(Handle, @Bytes, 1);
- end;
-
-begin
- LineIdent := Width;
- Tail := 0;
- HashValue := 0;
- Col := 0;
- HashTable := TList.Create;
- GetMem(Dict, SizeOf(TDictTable));
- try
- for I := 0 to HashTableSize - 1 do
- HashTable.Add(nil);
-
- // Initialise encoder variables
- InitCodeSize := BitCount + 1;
- if InitCodeSize = 2 then
- Inc(InitCodeSize);
- MinCodeSize := InitCodeSize - 1;
- IO.Write(Handle, @MinCodeSize, 1);
- ClearCode := 1 shl MinCodeSize;
- EndingCode := ClearCode + 1;
- LastCode := EndingCode;
- MaxCode := 1 shl InitCodeSize;
- LenString := 0;
- // Setup write context
- WriteCtxt.Inx := 0;
- WriteCtxt.CodeSize := InitCodeSize;
- FillChar(WriteCtxt.Buf, SizeOf(WriteCtxt.Buf), 0);
- WriteCode(ClearCode, WriteCtxt);
- Y := 0;
- Pass := 0;
-
- while Y < Height do
- begin
- PData := @PByteArray(Data)[Y * LineIdent];
- for X := 0 to Width - 1 do
- begin
- // Only ifIndex8 support
- case BitCount of
- 8:
- begin
- Col := PData^;
- PData := @PByteArray(PData)[1];
- end;
- {4:
- begin
- if X and 1 <> 0 then
- begin
- Col := PData^ and $0F;
- PData := @PByteArray(PData)[1];
- end
- else
- Col := PData^ shr 4;
- end;
- 1:
- begin
- if X and 7 = 7 then
- begin
- Col := PData^ and 1;
- PData := @PByteArray(PData)[1];
- end
- else
- Col := (PData^ shr (7 - (X and $07))) and $01;
- end;}
- end;
- Inc(LenString);
- if LenString = 1 then
- begin
- Tail := Col;
- HashValue := InitHash(Col);
- end
- else
- begin
- HashValue := HashValue * (Col + LenString + 4);
- I := HashValue mod HashTableSize;
- HashValue := HashValue mod HashTableSize;
- while (HashTable[I] <> nil) and
- ((PImageDict(HashTable[I])^.Tail <> Tail) or
- (PImageDict(HashTable[I])^.Col <> Col)) do
- begin
- Inc(I);
- if I >= HashTableSize then
- I := 0;
- end;
- if HashTable[I] <> nil then // Found in the strings table
- Tail := PImageDict(HashTable[I])^.Index
- else
- begin
- // Not found
- WriteCode(Tail, WriteCtxt);
- Inc(LastCode);
- HashTable[I] := @Dict^[LastCode];
- PImageDict(HashTable[I])^.Index := LastCode;
- PImageDict(HashTable[I])^.Tail := Tail;
- PImageDict(HashTable[I])^.Col := Col;
- Tail := Col;
- HashValue := InitHash(Col);
- LenString := 1;
- if LastCode >= MaxCode then
- begin
- // Next Code will be written longer
- MaxCode := MaxCode shl 1;
- Inc(WriteCtxt.CodeSize);
- end
- else
- if LastCode >= CodeTableSize - 2 then
- begin
- // Reset tables
- WriteCode(Tail, WriteCtxt);
- WriteCode(ClearCode, WriteCtxt);
- LenString := 0;
- LastCode := EndingCode;
- WriteCtxt.CodeSize := InitCodeSize;
- MaxCode := 1 shl InitCodeSize;
- for I := 0 to HashTableSize - 1 do
- HashTable[I] := nil;
- end;
- end;
- end;
- end;
- if Interlaced then
- Y := InterlaceStep(Y, Height, Pass)
- else
- Inc(Y);
- end;
- WriteCode(Tail, WriteCtxt);
- WriteCode(EndingCode, WriteCtxt);
- FlushCode(WriteCtxt);
- finally
- HashTable.Free;
- FreeMem(Dict);
- end;
-end;
-
-function TGIFFileFormat.LoadData(Handle: TImagingHandle;
- var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
-type
- TFrameInfo = record
- Left, Top: Integer;
- Width, Height: Integer;
- Disposal: TDisposalMethod;
- HasTransparency: Boolean;
- HasLocalPal: Boolean;
- TransIndex: Integer;
- BackIndex: Integer;
- end;
-var
- Header: TGIFHeader;
- HasGlobalPal: Boolean;
- GlobalPalLength: Integer;
- GlobalPal: TPalette32Size256;
- ScreenWidth, ScreenHeight, I, CachedIndex: Integer;
- BlockID: Byte;
- HasGraphicExt: Boolean;
- GraphicExt: TGraphicControlExtension;
- FrameInfos: array of TFrameInfo;
- AppRead: Boolean;
- CachedFrame: TImageData;
- AnimFrames: TDynImageDataArray;
-
- function ReadBlockID: Byte;
- begin
- Result := GIFTrailer;
- if GetIO.Read(Handle, @Result, SizeOf(Result)) < SizeOf(Result) then
- Result := GIFTrailer;
- end;
-
- procedure ReadExtensions;
- var
- BlockSize, BlockType, ExtType: Byte;
- AppRec: TGIFApplicationRec;
- LoopCount: SmallInt;
-
- procedure SkipBytes;
- begin
- with GetIO do
- repeat
- // Read block sizes and skip them
- Read(Handle, @BlockSize, SizeOf(BlockSize));
- Seek(Handle, BlockSize, smFromCurrent);
- until BlockSize = 0;
- end;
-
- begin
- HasGraphicExt := False;
- AppRead := False;
-
- // Read extensions until image descriptor is found. Only graphic extension
- // is stored now (for transparency), others are skipped.
- while BlockID = GIFExtensionIntroducer do
- with GetIO do
- begin
- Read(Handle, @ExtType, SizeOf(ExtType));
-
- while ExtType in [GIFGraphicControlExtension, GIFCommentExtension, GIFApplicationExtension, GIFPlainText] do
- begin
- if ExtType = GIFGraphicControlExtension then
- begin
- HasGraphicExt := True;
- Read(Handle, @GraphicExt, SizeOf(GraphicExt));
- end
- else if (ExtType = GIFApplicationExtension) and not AppRead then
- begin
- Read(Handle, @BlockSize, SizeOf(BlockSize));
- if BlockSize >= SizeOf(AppRec) then
- begin
- Read(Handle, @AppRec, SizeOf(AppRec));
- if (AppRec.Identifier = 'NETSCAPE') and (AppRec.Authentication = '2.0') then
- begin
- Read(Handle, @BlockSize, SizeOf(BlockSize));
- while BlockSize <> 0 do
- begin
- BlockType := ReadBlockID;
- Dec(BlockSize);
-
- case BlockType of
- GIFAppLoopExtension:
- if (BlockSize >= SizeOf(LoopCount)) then
- begin
- // Read loop count
- Read(Handle, @LoopCount, SizeOf(LoopCount));
- Dec(BlockSize, SizeOf(LoopCount));
- end;
- GIFAppBufferExtension:
- begin
- Dec(BlockSize, SizeOf(Word));
- Seek(Handle, SizeOf(Word), smFromCurrent);
- end;
- end;
- end;
- SkipBytes;
- AppRead := True;
- end
- else
- begin
- // Revert all bytes reading
- Seek(Handle, - SizeOf(AppRec) - SizeOf(BlockSize), smFromCurrent);
- SkipBytes;
- end;
- end
- else
- begin
- Seek(Handle, - BlockSize - SizeOf(BlockSize), smFromCurrent);
- SkipBytes;
- end;
- end
- else if ExtType in [GIFCommentExtension, GIFApplicationExtension, GIFPlainText] then
- repeat
- // Read block sizes and skip them
- Read(Handle, @BlockSize, SizeOf(BlockSize));
- Seek(Handle, BlockSize, smFromCurrent);
- until BlockSize = 0;
-
- // Read ID of following block
- BlockID := ReadBlockID;
- ExtType := BlockID;
- 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;
- var
- ImageDesc: TImageDescriptor;
- Interlaced: Boolean;
- I, Idx, LocalPalLength: Integer;
- LocalPal: TPalette32Size256;
- LZWStream: TMemoryStream;
-
- procedure RemoveBadFrame;
- begin
- FreeImage(Images[Idx]);
- SetLength(Images, Length(Images) - 1);
- end;
-
- begin
- Idx := Length(Images);
- SetLength(Images, Idx + 1);
- SetLength(FrameInfos, Idx + 1);
- FillChar(LocalPal, SizeOf(LocalPal), 0);
-
- with GetIO do
- begin
- // Read and parse image descriptor
- Read(Handle, @ImageDesc, SizeOf(ImageDesc));
- FrameInfos[Idx].HasLocalPal := (ImageDesc.PackedFields and GIFLocalColorTable) = GIFLocalColorTable;
- Interlaced := (ImageDesc.PackedFields and GIFInterlaced) = GIFInterlaced;
- LocalPalLength := ImageDesc.PackedFields and GIFColorTableSize;
- LocalPalLength := 1 shl (LocalPalLength + 1); // Total pal length is 2^(n+1)
-
- // From Mozilla source
- if (ImageDesc.Width = 0) or (ImageDesc.Width > Header.ScreenWidth) then
- ImageDesc.Width := Header.ScreenWidth;
- if (ImageDesc.Height = 0) or (ImageDesc.Height > Header.ScreenHeight) then
- ImageDesc.Height := Header.ScreenHeight;
-
- FrameInfos[Idx].Left := ImageDesc.Left;
- FrameInfos[Idx].Top := ImageDesc.Top;
- FrameInfos[Idx].Width := ImageDesc.Width;
- FrameInfos[Idx].Height := ImageDesc.Height;
- FrameInfos[Idx].BackIndex := Header.BackgroundColorIndex;
-
- // Create new image for this frame which would be later pasted onto logical screen
- NewImage(ImageDesc.Width, ImageDesc.Height, ifIndex8, Images[Idx]);
-
- // Load local palette if there is any
- if FrameInfos[Idx].HasLocalPal then
- for I := 0 to LocalPalLength - 1 do
- begin
- LocalPal[I].A := 255;
- Read(Handle, @LocalPal[I].R, SizeOf(LocalPal[I].R));
- Read(Handle, @LocalPal[I].G, SizeOf(LocalPal[I].G));
- Read(Handle, @LocalPal[I].B, SizeOf(LocalPal[I].B));
- end;
-
- // Use local pal if present or global pal if present or create
- // default pal if neither of them is present
- if FrameInfos[Idx].HasLocalPal then
- Move(LocalPal, Images[Idx].Palette^, SizeOf(LocalPal))
- else if HasGlobalPal then
- Move(GlobalPal, Images[Idx].Palette^, SizeOf(GlobalPal))
- else
- FillCustomPalette(Images[Idx].Palette, GlobalPalLength, 3, 3, 2);
-
- if (ImageDesc.Left <= Header.ScreenWidth + 1) and (ImageDesc.Top <= Header.ScreenHeight + 1) then
- begin
- // Resize the screen if needed to fit the frame
- ScreenWidth := Max(ScreenWidth, ImageDesc.Width + ImageDesc.Left);
- ScreenHeight := Max(ScreenHeight, ImageDesc.Height + ImageDesc.Top);
- end
- else
- begin
- // Remove frame outside logical screen
- RemoveBadFrame;
- Exit;
- end;
-
- // If Grahic Control Extension is present make use of it
- if HasGraphicExt then
- begin
- FrameInfos[Idx].HasTransparency := (GraphicExt.PackedFields and GIFTransparent) = GIFTransparent;
- FrameInfos[Idx].Disposal := TDisposalMethod((GraphicExt.PackedFields and GIFDisposalMethod) shr 2);
- if FrameInfos[Idx].HasTransparency then
- begin
- FrameInfos[Idx].TransIndex := GraphicExt.TransparentColorIndex;
- Images[Idx].Palette[FrameInfos[Idx].TransIndex].A := 0;
- end;
- end
- else
- FrameInfos[Idx].HasTransparency := False;
-
- LZWStream := TMemoryStream.Create;
- try
- try
- // Copy LZW data to temp stream, needed for correct decompression
- CopyLZWData(LZWStream);
- LZWStream.Position := 0;
- // Data decompression finally
- LZWDecompress(LZWStream, Handle, ImageDesc.Width, ImageDesc.Height, Interlaced, Images[Idx].Bits);
- except
- RemoveBadFrame;
- Exit;
- end;
- finally
- LZWStream.Free;
- end;
- end;
- end;
-
- procedure CopyFrameTransparent32(const Image, Frame: TImageData; Left, Top: Integer);
- var
- X, Y: Integer;
- Src: PByte;
- Dst: PColor32;
- begin
- Src := Frame.Bits;
-
- // Copy all pixels from frame to log screen but ignore the transparent ones
- for Y := 0 to Frame.Height - 1 do
- begin
- Dst := @PColor32RecArray(Image.Bits)[(Top + Y) * Image.Width + Left];
- for X := 0 to Frame.Width - 1 do
- begin
- if (Frame.Palette[Src^].A <> 0) then
- Dst^ := Frame.Palette[Src^].Color;
- Inc(Src);
- Inc(Dst);
- end;
- end;
- end;
-
- procedure AnimateFrame(Index: Integer; var AnimFrame: TImageData);
- var
- I, First, Last: Integer;
- UseCache: Boolean;
- BGColor: TColor32;
- begin
- // We may need to use raw frame 0 to n to correctly animate n-th frame
- Last := Index;
- First := Max(0, Last);
- // See if we can use last animate frame as a basis for this one
- // (so we don't have to use previous raw frames).
- UseCache := TestImage(CachedFrame) and (CachedIndex = Index - 1) and (CachedIndex >= 0) and
- (FrameInfos[CachedIndex].Disposal <> dmRestorePrevious);
-
- // Reuse or release cache
- if UseCache then
- CloneImage(CachedFrame, AnimFrame)
- else
- FreeImage(CachedFrame);
-
- // Default color for clearing of the screen
- BGColor := Images[Index].Palette[FrameInfos[Index].BackIndex].Color;
-
- // Now prepare logical screen for drawing of raw frame at Index.
- // We may need to use all previous raw frames to get the screen
- // to proper state (according to their disposal methods).
-
- if not UseCache then
- begin
- if FrameInfos[Index].HasTransparency then
- BGColor := Images[Index].Palette[FrameInfos[Index].TransIndex].Color;
- // Clear whole screen
- FillMemoryLongWord(AnimFrame.Bits, AnimFrame.Size, BGColor);
-
- // Try to maximize First so we don't have to use all 0 to n raw frames
- while First > 0 do
- begin
- if (ScreenWidth = Images[First].Width) and (ScreenHeight = Images[First].Height) then
- begin
- if (FrameInfos[First].Disposal = dmRestoreBackground) and (First < Last) then
- Break;
- end;
- Dec(First);
- end;
-
- for I := First to Last - 1 do
- begin
- case FrameInfos[I].Disposal of
- dmNoRemoval, dmLeave:
- begin
- // Copy previous raw frame onto screen
- CopyFrameTransparent32(AnimFrame, Images[I], FrameInfos[I].Left, FrameInfos[I].Top);
- end;
- dmRestoreBackground:
- if (I > First) then
- begin
- // Restore background color
- FillRect(AnimFrame, FrameInfos[I].Left, FrameInfos[I].Top,
- FrameInfos[I].Width, FrameInfos[I].Height, @BGColor);
- end;
- dmRestorePrevious: ; // Do nothing - previous state is already on screen
- end;
- end;
- end
- else if FrameInfos[CachedIndex].Disposal = dmRestoreBackground then
- begin
- // We have our cached result but also need to restore
- // background in a place of cached frame
- if FrameInfos[CachedIndex].HasTransparency then
- BGColor := Images[CachedIndex].Palette[FrameInfos[CachedIndex].TransIndex].Color;
- FillRect(AnimFrame, FrameInfos[CachedIndex].Left, FrameInfos[CachedIndex].Top,
- FrameInfos[CachedIndex].Width, FrameInfos[CachedIndex].Height, @BGColor);
- end;
-
- // Copy current raw frame to prepared screen
- CopyFrameTransparent32(AnimFrame, Images[Index], FrameInfos[Index].Left, FrameInfos[Index].Top);
-
- // Cache animated result
- CloneImage(AnimFrame, CachedFrame);
- CachedIndex := Index;
- end;
-
-begin
- AppRead := False;
-
- SetLength(Images, 0);
- FillChar(GlobalPal, SizeOf(GlobalPal), 0);
-
- with GetIO do
- begin
- // Read GIF header
- Read(Handle, @Header, SizeOf(Header));
- ScreenWidth := Header.ScreenWidth;
- ScreenHeight := Header.ScreenHeight;
- HasGlobalPal := Header.PackedFields and GIFGlobalColorTable = GIFGlobalColorTable; // Bit 7
- GlobalPalLength := Header.PackedFields and GIFColorTableSize; // Bits 0-2
- GlobalPalLength := 1 shl (GlobalPalLength + 1); // Total pal length is 2^(n+1)
-
- // Read global palette from file if present
- if HasGlobalPal then
- begin
- for I := 0 to GlobalPalLength - 1 do
- begin
- GlobalPal[I].A := 255;
- Read(Handle, @GlobalPal[I].R, SizeOf(GlobalPal[I].R));
- Read(Handle, @GlobalPal[I].G, SizeOf(GlobalPal[I].G));
- Read(Handle, @GlobalPal[I].B, SizeOf(GlobalPal[I].B));
- end;
- end;
-
- // Read ID of the first block
- BlockID := ReadBlockID;
-
- // Now read all data blocks in the file until file trailer is reached
- while BlockID <> GIFTrailer do
- begin
- // Read blocks until we find the one of known type
- while not (BlockID in [GIFTrailer, GIFExtensionIntroducer, GIFImageDescriptor]) do
- BlockID := ReadBlockID;
- // Read supported and skip unsupported extensions
- ReadExtensions;
- // If image frame is found read it
- if BlockID = GIFImageDescriptor then
- ReadFrame;
- // Read next block's ID
- BlockID := ReadBlockID;
- // If block ID is unknown set it to end-of-GIF marker
- if not (BlockID in [GIFExtensionIntroducer, GIFTrailer, GIFImageDescriptor]) then
- BlockID := GIFTrailer;
- end;
-
- if FLoadAnimated then
- begin
- // Aniated frames will be stored in AnimFrames
- SetLength(AnimFrames, Length(Images));
- InitImage(CachedFrame);
- CachedIndex := -1;
-
- for I := 0 to High(Images) do
- begin
- // Create new logical screen
- NewImage(ScreenWidth, ScreenHeight, ifA8R8G8B8, AnimFrames[I]);
- // Animate frames to current log screen
- AnimateFrame(I, AnimFrames[I]);
- end;
-
- // Now release raw 8bit frames and put animated 32bit ones
- // to output array
- FreeImage(CachedFrame);
- for I := 0 to High(AnimFrames) do
- begin
- FreeImage(Images[I]);
- Images[I] := AnimFrames[I];
- end;
- end;
-
- Result := True;
- end;
-end;
-
-function TGIFFileFormat.SaveData(Handle: TImagingHandle;
- const Images: TDynImageDataArray; Index: Integer): Boolean;
-var
- Header: TGIFHeader;
- ImageDesc: TImageDescriptor;
- ImageToSave: TImageData;
- MustBeFreed: Boolean;
- I, J: Integer;
- GraphicExt: TGraphicControlExtension;
-
- procedure FindMaxDimensions(var MaxWidth, MaxHeight: Word);
- var
- I: Integer;
- begin
- MaxWidth := Images[FFirstIdx].Width;
- MaxHeight := Images[FFirstIdx].Height;
-
- for I := FFirstIdx + 1 to FLastIdx do
- begin
- MaxWidth := Iff(Images[I].Width > MaxWidth, Images[I].Width, MaxWidth);
- MaxHeight := Iff(Images[I].Height > MaxWidth, Images[I].Height, MaxHeight);
- end;
- end;
-
-begin
- // Fill header with data, select size of largest image in array as
- // logical screen size
- FillChar(Header, Sizeof(Header), 0);
- Header.Signature := GIFSignature;
- Header.Version := GIFVersions[gv89];
- FindMaxDimensions(Header.ScreenWidth, Header.ScreenHeight);
- Header.PackedFields := GIFColorResolution; // Color resolution is 256
- GetIO.Write(Handle, @Header, SizeOf(Header));
-
- // Prepare default GC extension with delay
- FillChar(GraphicExt, Sizeof(GraphicExt), 0);
- GraphicExt.DelayTime := 65;
- GraphicExt.BlockSize := 4;
-
- for I := FFirstIdx to FLastIdx do
- begin
- if MakeCompatible(Images[I], ImageToSave, MustBeFreed) then
- with GetIO, ImageToSave do
- try
- // Write Graphic Control Extension with default delay
- Write(Handle, @GIFExtensionIntroducer, SizeOf(GIFExtensionIntroducer));
- Write(Handle, @GIFGraphicControlExtension, SizeOf(GIFGraphicControlExtension));
- Write(Handle, @GraphicExt, SizeOf(GraphicExt));
- // Write frame marker and fill and write image descriptor for this frame
- Write(Handle, @GIFImageDescriptor, SizeOf(GIFImageDescriptor));
- FillChar(ImageDesc, Sizeof(ImageDesc), 0);
- ImageDesc.Width := Width;
- ImageDesc.Height := Height;
- ImageDesc.PackedFields := GIFLocalColorTable or GIFColorTableSize; // Use lccal color table with 256 entries
- Write(Handle, @ImageDesc, SizeOf(ImageDesc));
-
- // Write local color table for each frame
- for J := 0 to 255 do
- begin
- Write(Handle, @Palette[J].R, SizeOf(Palette[J].R));
- Write(Handle, @Palette[J].G, SizeOf(Palette[J].G));
- Write(Handle, @Palette[J].B, SizeOf(Palette[J].B));
- end;
-
- // Fonally compress image data
- LZWCompress(GetIO, Handle, Width, Height, 8, False, Bits);
-
- finally
- if MustBeFreed then
- FreeImage(ImageToSave);
- end;
- end;
-
- GetIO.Write(Handle, @GIFTrailer, SizeOf(GIFTrailer));
- Result := True;
-end;
-
-procedure TGIFFileFormat.ConvertToSupported(var Image: TImageData;
- const Info: TImageFormatInfo);
-begin
- ConvertImage(Image, ifIndex8);
-end;
-
-function TGIFFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
-var
- Header: TGIFHeader;
- ReadCount: LongInt;
-begin
- Result := False;
- if Handle <> nil then
- begin
- ReadCount := GetIO.Read(Handle, @Header, SizeOf(Header));
- GetIO.Seek(Handle, -ReadCount, smFromCurrent);
- Result := (ReadCount >= SizeOf(Header)) and
- (Header.Signature = GIFSignature) and
- ((Header.Version = GIFVersions[gv87]) or (Header.Version = GIFVersions[gv89]));
- end;
-end;
-
-initialization
- RegisterImageFileFormat(TGIFFileFormat);
-
-{
- File Notes:
-
- -- TODOS ----------------------------------------------------
- - nothing now
-
- -- 0.26.3 Changes/Bug Fixes ---------------------------------
- - Fixed bug - loading of GIF with NETSCAPE app extensions
- failed with Delphi 2009.
-
- -- 0.26.1 Changes/Bug Fixes ---------------------------------
- - GIF loading and animation mostly rewritten, based on
- modification by Sergey Galezdinov (ExtraGIF in Extras/Contrib).
-
- -- 0.25.0 Changes/Bug Fixes ---------------------------------
- - Fixed loading of some rare GIFs, problems with LZW
- decompression.
-
- -- 0.24.3 Changes/Bug Fixes ---------------------------------
- - Better solution to transparency for some GIFs. Background not
- transparent by default.
-
- -- 0.24.1 Changes/Bug Fixes ---------------------------------
- - Made backround color transparent by default (alpha = 0).
-
- -- 0.23 Changes/Bug Fixes -----------------------------------
- - Fixed other loading bugs (local pal size, transparency).
- - Added GIF saving.
- - Fixed bug when loading multiframe GIFs and implemented few animation
- features (disposal methods, ...).
- - Loading of GIFs working.
- - Unit created with initial stuff!
-}
-
-end.
+{
+ $Id: ImagingGif.pas 157 2009-02-15 14:24:58Z galfar $
+ Vampyre Imaging Library
+ by Marek Mauder
+ http://imaginglib.sourceforge.net
+
+ The contents of this file are used with permission, subject to the Mozilla
+ Public License Version 1.1 (the "License"); you may not use this file except
+ in compliance with the License. You may obtain a copy of the License at
+ http://www.mozilla.org/MPL/MPL-1.1.html
+
+ Software distributed under the License is distributed on an "AS IS" basis,
+ WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
+ the specific language governing rights and limitations under the License.
+
+ Alternatively, the contents of this file may be used under the terms of the
+ GNU Lesser General Public License (the "LGPL License"), in which case the
+ provisions of the LGPL License are applicable instead of those above.
+ If you wish to allow use of your version of this file only under the terms
+ of the LGPL License and not to allow others to use your version of this file
+ under the MPL, indicate your decision by deleting the provisions above and
+ replace them with the notice and other provisions required by the LGPL
+ License. If you do not delete the provisions above, a recipient may use
+ your version of this file under either the MPL or the LGPL License.
+
+ For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
+}
+
+{ This unit contains image format loader/saver for GIF images.}
+unit ImagingGif;
+
+{$I ImagingOptions.inc}
+
+interface
+
+uses
+ SysUtils, Classes, Imaging, ImagingTypes, ImagingIO, ImagingUtility;
+
+type
+ { GIF (Graphics Interchange Format) loader/saver class. GIF was
+ (and is still used) popular format for storing images supporting
+ multiple images per file and single color transparency.
+ Pixel format is 8 bit indexed where each image frame can have
+ its own color palette. GIF uses lossless LZW compression
+ (patent expired few years ago).
+ Imaging can load and save all GIFs with all frames and supports
+ transparency. Imaging can load just raw ifIndex8 frames or
+ also animate them in ifA8R8G8B8 format. See ImagingGIFLoadAnimated option.}
+ TGIFFileFormat = class(TImageFileFormat)
+ private
+ FLoadAnimated: LongBool;
+ function InterlaceStep(Y, Height: Integer; var Pass: Integer): Integer;
+ procedure LZWDecompress(Stream: TStream; Handle: TImagingHandle;
+ Width, Height: Integer; Interlaced: Boolean; Data: Pointer);
+ procedure LZWCompress(const IO: TIOFunctions; Handle: TImagingHandle;
+ Width, Height, BitCount: Integer; Interlaced: Boolean; Data: Pointer);
+ protected
+ function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
+ OnlyFirstLevel: Boolean): Boolean; override;
+ function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
+ Index: LongInt): Boolean; override;
+ procedure ConvertToSupported(var Image: TImageData;
+ const Info: TImageFormatInfo); override;
+ public
+ constructor Create; override;
+ function TestFormat(Handle: TImagingHandle): Boolean; override;
+ published
+ property LoadAnimated: LongBool read FLoadAnimated write FLoadAnimated;
+ end;
+
+implementation
+
+const
+ SGIFFormatName = 'Graphics Interchange Format';
+ SGIFMasks = '*.gif';
+ GIFSupportedFormats: TImageFormats = [ifIndex8];
+ GIFDefaultLoadAnimated = True;
+
+type
+ TGIFVersion = (gv87, gv89);
+ TDisposalMethod = (dmNoRemoval, dmLeave, dmRestoreBackground,
+ dmRestorePrevious, dmReserved4, dmReserved5, dmReserved6, dmReserved7);
+
+const
+ GIFSignature: TChar3 = 'GIF';
+ GIFVersions: array[TGIFVersion] of TChar3 = ('87a', '89a');
+
+ // Masks for accessing fields in PackedFields of TGIFHeader
+ GIFGlobalColorTable = $80;
+ GIFColorResolution = $70;
+ GIFColorTableSorted = $08;
+ GIFColorTableSize = $07;
+
+ // Masks for accessing fields in PackedFields of TImageDescriptor
+ GIFLocalColorTable = $80;
+ GIFInterlaced = $40;
+ GIFLocalTableSorted = $20;
+
+ // Block identifiers
+ GIFPlainText: Byte = $01;
+ GIFGraphicControlExtension: Byte = $F9;
+ GIFCommentExtension: Byte = $FE;
+ GIFApplicationExtension: Byte = $FF;
+ GIFImageDescriptor: Byte = Ord(',');
+ GIFExtensionIntroducer: Byte = Ord('!');
+ GIFTrailer: Byte = Ord(';');
+ GIFBlockTerminator: Byte = $00;
+
+ // Masks for accessing fields in PackedFields of TGraphicControlExtension
+ GIFTransparent = $01;
+ GIFUserInput = $02;
+ GIFDisposalMethod = $1C;
+
+type
+ TGIFHeader = packed record
+ // File header part
+ Signature: TChar3; // Header Signature (always "GIF")
+ Version: TChar3; // GIF format version("87a" or "89a")
+ // Logical Screen Descriptor part
+ ScreenWidth: Word; // Width of Display Screen in Pixels
+ ScreenHeight: Word; // Height of Display Screen in Pixels
+ PackedFields: Byte; // Screen and color map information
+ BackgroundColorIndex: Byte; // Background color index (in global color table)
+ AspectRatio: Byte; // Pixel aspect ratio, ratio = (AspectRatio + 15) / 64
+ end;
+
+ TImageDescriptor = packed record
+ //Separator: Byte; // leave that out since we always read one bye ahead
+ Left: Word; // X position of image with respect to logical screen
+ Top: Word; // Y position
+ Width: Word;
+ Height: Word;
+ PackedFields: Byte;
+ end;
+
+const
+ // GIF extension labels
+ GIFExtTypeGraphic = $F9;
+ GIFExtTypePlainText = $01;
+ GIFExtTypeApplication = $FF;
+ GIFExtTypeComment = $FE;
+
+type
+ TGraphicControlExtension = packed record
+ BlockSize: Byte;
+ PackedFields: Byte;
+ DelayTime: Word;
+ TransparentColorIndex: Byte;
+ Terminator: Byte;
+ end;
+
+const
+ // Netscape sub block types
+ GIFAppLoopExtension = 1;
+ GIFAppBufferExtension = 2;
+
+type
+ TGIFIdentifierCode = array[0..7] of AnsiChar;
+ TGIFAuthenticationCode = array[0..2] of AnsiChar;
+ TGIFApplicationRec = packed record
+ Identifier: TGIFIdentifierCode;
+ Authentication: TGIFAuthenticationCode;
+ end;
+
+const
+ CodeTableSize = 4096;
+ HashTableSize = 17777;
+
+type
+ TReadContext = record
+ Inx: Integer;
+ Size: Integer;
+ Buf: array [0..255 + 4] of Byte;
+ CodeSize: Integer;
+ ReadMask: Integer;
+ end;
+ PReadContext = ^TReadContext;
+
+ TWriteContext = record
+ Inx: Integer;
+ CodeSize: Integer;
+ Buf: array [0..255 + 4] of Byte;
+ end;
+ PWriteContext = ^TWriteContext;
+
+ TOutputContext = record
+ W: Integer;
+ H: Integer;
+ X: Integer;
+ Y: Integer;
+ BitsPerPixel: Integer;
+ Pass: Integer;
+ Interlace: Boolean;
+ LineIdent: Integer;
+ Data: Pointer;
+ CurrLineData: Pointer;
+ end;
+
+ TImageDict = record
+ Tail: Word;
+ Index: Word;
+ Col: Byte;
+ end;
+ PImageDict = ^TImageDict;
+
+ PIntCodeTable = ^TIntCodeTable;
+ TIntCodeTable = array [0..CodeTableSize - 1] of Word;
+
+ TDictTable = array [0..CodeTableSize - 1] of TImageDict;
+ PDictTable = ^TDictTable;
+
+resourcestring
+ SGIFDecodingError = 'Error when decoding GIF LZW data';
+
+{
+ TGIFFileFormat implementation
+}
+
+constructor TGIFFileFormat.Create;
+begin
+ inherited Create;
+ FName := SGIFFormatName;
+ FCanLoad := True;
+ FCanSave := True;
+ FIsMultiImageFormat := True;
+ FSupportedFormats := GIFSupportedFormats;
+ FLoadAnimated := GIFDefaultLoadAnimated;
+
+ AddMasks(SGIFMasks);
+ RegisterOption(ImagingGIFLoadAnimated, @FLoadAnimated);
+end;
+
+function TGIFFileFormat.InterlaceStep(Y, Height: Integer; var Pass: Integer): Integer;
+begin
+ Result := Y;
+ case Pass of
+ 0, 1:
+ Inc(Result, 8);
+ 2:
+ Inc(Result, 4);
+ 3:
+ Inc(Result, 2);
+ end;
+ if Result >= Height then
+ begin
+ if Pass = 0 then
+ begin
+ Pass := 1;
+ Result := 4;
+ if Result < Height then
+ Exit;
+ end;
+ if Pass = 1 then
+ begin
+ Pass := 2;
+ Result := 2;
+ if Result < Height then
+ Exit;
+ end;
+ if Pass = 2 then
+ begin
+ Pass := 3;
+ Result := 1;
+ end;
+ end;
+end;
+
+{ GIF LZW decompresion code is from JVCL JvGIF.pas unit.}
+procedure TGIFFileFormat.LZWDecompress(Stream: TStream; Handle: TImagingHandle; Width, Height: Integer;
+ Interlaced: Boolean; Data: Pointer);
+var
+ MinCodeSize: Byte;
+ MaxCode, BitMask, InitCodeSize: Integer;
+ ClearCode, EndingCode, FirstFreeCode, FreeCode: Word;
+ I, OutCount, Code: Integer;
+ CurCode, OldCode, InCode, FinalChar: Word;
+ Prefix, Suffix, OutCode: PIntCodeTable;
+ ReadCtxt: TReadContext;
+ OutCtxt: TOutputContext;
+ TableFull: Boolean;
+
+ function ReadCode(var Context: TReadContext): Integer;
+ var
+ RawCode: Integer;
+ ByteIndex: Integer;
+ Bytes: Byte;
+ BytesToLose: Integer;
+ begin
+ while (Context.Inx + Context.CodeSize > Context.Size) and
+ (Stream.Position < Stream.Size) do
+ begin
+ // Not enough bits in buffer - refill it - Not very efficient, but infrequently called
+ BytesToLose := Context.Inx shr 3;
+ // Note biggest Code Size is 12 bits. And this can at worst span 3 Bytes
+ Move(Context.Buf[Word(BytesToLose)], Context.Buf[0], 3);
+ Context.Inx := Context.Inx and 7;
+ Context.Size := Context.Size - (BytesToLose shl 3);
+ Stream.Read(Bytes, 1);
+ if Bytes > 0 then
+ Stream.Read(Context.Buf[Word(Context.Size shr 3)], Bytes);
+ Context.Size := Context.Size + (Bytes shl 3);
+ end;
+ ByteIndex := Context.Inx shr 3;
+ RawCode := Context.Buf[Word(ByteIndex)] +
+ (Word(Context.Buf[Word(ByteIndex + 1)]) shl 8);
+ if Context.CodeSize > 8 then
+ RawCode := RawCode + (LongInt(Context.Buf[ByteIndex + 2]) shl 16);
+ RawCode := RawCode shr (Context.Inx and 7);
+ Context.Inx := Context.Inx + Byte(Context.CodeSize);
+ Result := RawCode and Context.ReadMask;
+ end;
+
+ procedure Output(Value: Byte; var Context: TOutputContext);
+ var
+ P: PByte;
+ begin
+ if Context.Y >= Context.H then
+ Exit;
+
+ // Only ifIndex8 supported
+ P := @PByteArray(Context.CurrLineData)[Context.X];
+ P^ := Value;
+
+ {case Context.BitsPerPixel of
+ 1:
+ begin
+ P := @PByteArray(Context.CurrLineData)[Context.X shr 3];
+ if (Context.X and $07) <> 0 then
+ P^ := P^ or Word(Value shl (7 - (Word(Context.X and 7))))
+ else
+ P^ := Byte(Value shl 7);
+ end;
+ 4:
+ begin
+ P := @PByteArray(Context.CurrLineData)[Context.X shr 1];
+ if (Context.X and 1) <> 0 then
+ P^ := P^ or Value
+ else
+ P^ := Byte(Value shl 4);
+ end;
+ 8:
+ begin
+ P := @PByteArray(Context.CurrLineData)[Context.X];
+ P^ := Value;
+ end;
+ end;}
+ Inc(Context.X);
+
+ if Context.X < Context.W then
+ Exit;
+ Context.X := 0;
+ if Context.Interlace then
+ Context.Y := InterlaceStep(Context.Y, Context.H, Context.Pass)
+ else
+ Inc(Context.Y);
+
+ Context.CurrLineData := @PByteArray(Context.Data)[Context.Y * Context.LineIdent];
+ end;
+
+begin
+ OutCount := 0;
+ OldCode := 0;
+ FinalChar := 0;
+ TableFull := False;
+ GetMem(Prefix, SizeOf(TIntCodeTable));
+ GetMem(Suffix, SizeOf(TIntCodeTable));
+ GetMem(OutCode, SizeOf(TIntCodeTable) + SizeOf(Word));
+ try
+ Stream.Read(MinCodeSize, 1);
+ if (MinCodeSize < 2) or (MinCodeSize > 9) then
+ RaiseImaging(SGIFDecodingError, []);
+ // Initial read context
+ ReadCtxt.Inx := 0;
+ ReadCtxt.Size := 0;
+ ReadCtxt.CodeSize := MinCodeSize + 1;
+ ReadCtxt.ReadMask := (1 shl ReadCtxt.CodeSize) - 1;
+ // Initialise pixel-output context
+ OutCtxt.X := 0;
+ OutCtxt.Y := 0;
+ OutCtxt.Pass := 0;
+ OutCtxt.W := Width;
+ OutCtxt.H := Height;
+ OutCtxt.BitsPerPixel := MinCodeSize;
+ OutCtxt.Interlace := Interlaced;
+ OutCtxt.LineIdent := Width;
+ OutCtxt.Data := Data;
+ OutCtxt.CurrLineData := Data;
+ BitMask := (1 shl OutCtxt.BitsPerPixel) - 1;
+ // 2 ^ MinCodeSize accounts for all colours in file
+ ClearCode := 1 shl MinCodeSize;
+ EndingCode := ClearCode + 1;
+ FreeCode := ClearCode + 2;
+ FirstFreeCode := FreeCode;
+ // 2^ (MinCodeSize + 1) includes clear and eoi Code and space too
+ InitCodeSize := ReadCtxt.CodeSize;
+ MaxCode := 1 shl ReadCtxt.CodeSize;
+ Code := ReadCode(ReadCtxt);
+ while (Code <> EndingCode) and (Code <> $FFFF) and
+ (OutCtxt.Y < OutCtxt.H) do
+ begin
+ if Code = ClearCode then
+ begin
+ ReadCtxt.CodeSize := InitCodeSize;
+ MaxCode := 1 shl ReadCtxt.CodeSize;
+ ReadCtxt.ReadMask := MaxCode - 1;
+ FreeCode := FirstFreeCode;
+ Code := ReadCode(ReadCtxt);
+ CurCode := Code;
+ OldCode := Code;
+ if Code = $FFFF then
+ Break;
+ FinalChar := (CurCode and BitMask);
+ Output(Byte(FinalChar), OutCtxt);
+ TableFull := False;
+ end
+ else
+ begin
+ CurCode := Code;
+ InCode := Code;
+ if CurCode >= FreeCode then
+ begin
+ CurCode := OldCode;
+ OutCode^[OutCount] := FinalChar;
+ Inc(OutCount);
+ end;
+ while CurCode > BitMask do
+ begin
+ if OutCount > CodeTableSize then
+ RaiseImaging(SGIFDecodingError, []);
+ OutCode^[OutCount] := Suffix^[CurCode];
+ Inc(OutCount);
+ CurCode := Prefix^[CurCode];
+ end;
+
+ FinalChar := CurCode and BitMask;
+ OutCode^[OutCount] := FinalChar;
+ Inc(OutCount);
+ for I := OutCount - 1 downto 0 do
+ Output(Byte(OutCode^[I]), OutCtxt);
+ OutCount := 0;
+ // Update dictionary
+ if not TableFull then
+ begin
+ Prefix^[FreeCode] := OldCode;
+ Suffix^[FreeCode] := FinalChar;
+ // Advance to next free slot
+ Inc(FreeCode);
+ if FreeCode >= MaxCode then
+ begin
+ if ReadCtxt.CodeSize < 12 then
+ begin
+ Inc(ReadCtxt.CodeSize);
+ MaxCode := MaxCode shl 1;
+ ReadCtxt.ReadMask := (1 shl ReadCtxt.CodeSize) - 1;
+ end
+ else
+ TableFull := True;
+ end;
+ end;
+ OldCode := InCode;
+ end;
+ Code := ReadCode(ReadCtxt);
+ end;
+ if Code = $FFFF then
+ RaiseImaging(SGIFDecodingError, []);
+ finally
+ FreeMem(Prefix);
+ FreeMem(OutCode);
+ FreeMem(Suffix);
+ end;
+end;
+
+{ GIF LZW compresion code is from JVCL JvGIF.pas unit.}
+procedure TGIFFileFormat.LZWCompress(const IO: TIOFunctions; Handle: TImagingHandle; Width, Height, BitCount: Integer;
+ Interlaced: Boolean; Data: Pointer);
+var
+ LineIdent: Integer;
+ MinCodeSize, Col: Byte;
+ InitCodeSize, X, Y: Integer;
+ Pass: Integer;
+ MaxCode: Integer; { 1 shl CodeSize }
+ ClearCode, EndingCode, LastCode, Tail: Integer;
+ I, HashValue: Integer;
+ LenString: Word;
+ Dict: PDictTable;
+ HashTable: TList;
+ PData: PByte;
+ WriteCtxt: TWriteContext;
+
+ function InitHash(P: Integer): Integer;
+ begin
+ Result := (P + 3) * 301;
+ end;
+
+ procedure WriteCode(Code: Integer; var Context: TWriteContext);
+ var
+ BufIndex: Integer;
+ Bytes: Byte;
+ begin
+ BufIndex := Context.Inx shr 3;
+ Code := Code shl (Context.Inx and 7);
+ Context.Buf[BufIndex] := Context.Buf[BufIndex] or Byte(Code);
+ Context.Buf[BufIndex + 1] := Byte(Code shr 8);
+ Context.Buf[BufIndex + 2] := Byte(Code shr 16);
+ Context.Inx := Context.Inx + Context.CodeSize;
+ if Context.Inx >= 255 * 8 then
+ begin
+ // Flush out full buffer
+ Bytes := 255;
+ IO.Write(Handle, @Bytes, 1);
+ IO.Write(Handle, @Context.Buf, Bytes);
+ Move(Context.Buf[255], Context.Buf[0], 2);
+ FillChar(Context.Buf[2], 255, 0);
+ Context.Inx := Context.Inx - (255 * 8);
+ end;
+ end;
+
+ procedure FlushCode(var Context: TWriteContext);
+ var
+ Bytes: Byte;
+ begin
+ Bytes := (Context.Inx + 7) shr 3;
+ if Bytes > 0 then
+ begin
+ IO.Write(Handle, @Bytes, 1);
+ IO.Write(Handle, @Context.Buf, Bytes);
+ end;
+ // Data block terminator - a block of zero Size
+ Bytes := 0;
+ IO.Write(Handle, @Bytes, 1);
+ end;
+
+begin
+ LineIdent := Width;
+ Tail := 0;
+ HashValue := 0;
+ Col := 0;
+ HashTable := TList.Create;
+ GetMem(Dict, SizeOf(TDictTable));
+ try
+ for I := 0 to HashTableSize - 1 do
+ HashTable.Add(nil);
+
+ // Initialise encoder variables
+ InitCodeSize := BitCount + 1;
+ if InitCodeSize = 2 then
+ Inc(InitCodeSize);
+ MinCodeSize := InitCodeSize - 1;
+ IO.Write(Handle, @MinCodeSize, 1);
+ ClearCode := 1 shl MinCodeSize;
+ EndingCode := ClearCode + 1;
+ LastCode := EndingCode;
+ MaxCode := 1 shl InitCodeSize;
+ LenString := 0;
+ // Setup write context
+ WriteCtxt.Inx := 0;
+ WriteCtxt.CodeSize := InitCodeSize;
+ FillChar(WriteCtxt.Buf, SizeOf(WriteCtxt.Buf), 0);
+ WriteCode(ClearCode, WriteCtxt);
+ Y := 0;
+ Pass := 0;
+
+ while Y < Height do
+ begin
+ PData := @PByteArray(Data)[Y * LineIdent];
+ for X := 0 to Width - 1 do
+ begin
+ // Only ifIndex8 support
+ case BitCount of
+ 8:
+ begin
+ Col := PData^;
+ PData := @PByteArray(PData)[1];
+ end;
+ {4:
+ begin
+ if X and 1 <> 0 then
+ begin
+ Col := PData^ and $0F;
+ PData := @PByteArray(PData)[1];
+ end
+ else
+ Col := PData^ shr 4;
+ end;
+ 1:
+ begin
+ if X and 7 = 7 then
+ begin
+ Col := PData^ and 1;
+ PData := @PByteArray(PData)[1];
+ end
+ else
+ Col := (PData^ shr (7 - (X and $07))) and $01;
+ end;}
+ end;
+ Inc(LenString);
+ if LenString = 1 then
+ begin
+ Tail := Col;
+ HashValue := InitHash(Col);
+ end
+ else
+ begin
+ HashValue := HashValue * (Col + LenString + 4);
+ I := HashValue mod HashTableSize;
+ HashValue := HashValue mod HashTableSize;
+ while (HashTable[I] <> nil) and
+ ((PImageDict(HashTable[I])^.Tail <> Tail) or
+ (PImageDict(HashTable[I])^.Col <> Col)) do
+ begin
+ Inc(I);
+ if I >= HashTableSize then
+ I := 0;
+ end;
+ if HashTable[I] <> nil then // Found in the strings table
+ Tail := PImageDict(HashTable[I])^.Index
+ else
+ begin
+ // Not found
+ WriteCode(Tail, WriteCtxt);
+ Inc(LastCode);
+ HashTable[I] := @Dict^[LastCode];
+ PImageDict(HashTable[I])^.Index := LastCode;
+ PImageDict(HashTable[I])^.Tail := Tail;
+ PImageDict(HashTable[I])^.Col := Col;
+ Tail := Col;
+ HashValue := InitHash(Col);
+ LenString := 1;
+ if LastCode >= MaxCode then
+ begin
+ // Next Code will be written longer
+ MaxCode := MaxCode shl 1;
+ Inc(WriteCtxt.CodeSize);
+ end
+ else
+ if LastCode >= CodeTableSize - 2 then
+ begin
+ // Reset tables
+ WriteCode(Tail, WriteCtxt);
+ WriteCode(ClearCode, WriteCtxt);
+ LenString := 0;
+ LastCode := EndingCode;
+ WriteCtxt.CodeSize := InitCodeSize;
+ MaxCode := 1 shl InitCodeSize;
+ for I := 0 to HashTableSize - 1 do
+ HashTable[I] := nil;
+ end;
+ end;
+ end;
+ end;
+ if Interlaced then
+ Y := InterlaceStep(Y, Height, Pass)
+ else
+ Inc(Y);
+ end;
+ WriteCode(Tail, WriteCtxt);
+ WriteCode(EndingCode, WriteCtxt);
+ FlushCode(WriteCtxt);
+ finally
+ HashTable.Free;
+ FreeMem(Dict);
+ end;
+end;
+
+function TGIFFileFormat.LoadData(Handle: TImagingHandle;
+ var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
+type
+ TFrameInfo = record
+ Left, Top: Integer;
+ Width, Height: Integer;
+ Disposal: TDisposalMethod;
+ HasTransparency: Boolean;
+ HasLocalPal: Boolean;
+ TransIndex: Integer;
+ BackIndex: Integer;
+ end;
+var
+ Header: TGIFHeader;
+ HasGlobalPal: Boolean;
+ GlobalPalLength: Integer;
+ GlobalPal: TPalette32Size256;
+ ScreenWidth, ScreenHeight, I, CachedIndex: Integer;
+ BlockID: Byte;
+ HasGraphicExt: Boolean;
+ GraphicExt: TGraphicControlExtension;
+ FrameInfos: array of TFrameInfo;
+ AppRead: Boolean;
+ CachedFrame: TImageData;
+ AnimFrames: TDynImageDataArray;
+
+ function ReadBlockID: Byte;
+ begin
+ Result := GIFTrailer;
+ if GetIO.Read(Handle, @Result, SizeOf(Result)) < SizeOf(Result) then
+ Result := GIFTrailer;
+ end;
+
+ procedure ReadExtensions;
+ var
+ BlockSize, BlockType, ExtType: Byte;
+ AppRec: TGIFApplicationRec;
+ LoopCount: SmallInt;
+
+ procedure SkipBytes;
+ begin
+ with GetIO do
+ repeat
+ // Read block sizes and skip them
+ Read(Handle, @BlockSize, SizeOf(BlockSize));
+ Seek(Handle, BlockSize, smFromCurrent);
+ until BlockSize = 0;
+ end;
+
+ begin
+ HasGraphicExt := False;
+ AppRead := False;
+
+ // Read extensions until image descriptor is found. Only graphic extension
+ // is stored now (for transparency), others are skipped.
+ while BlockID = GIFExtensionIntroducer do
+ with GetIO do
+ begin
+ Read(Handle, @ExtType, SizeOf(ExtType));
+
+ while ExtType in [GIFGraphicControlExtension, GIFCommentExtension, GIFApplicationExtension, GIFPlainText] do
+ begin
+ if ExtType = GIFGraphicControlExtension then
+ begin
+ HasGraphicExt := True;
+ Read(Handle, @GraphicExt, SizeOf(GraphicExt));
+ end
+ else if (ExtType = GIFApplicationExtension) and not AppRead then
+ begin
+ Read(Handle, @BlockSize, SizeOf(BlockSize));
+ if BlockSize >= SizeOf(AppRec) then
+ begin
+ Read(Handle, @AppRec, SizeOf(AppRec));
+ if (AppRec.Identifier = 'NETSCAPE') and (AppRec.Authentication = '2.0') then
+ begin
+ Read(Handle, @BlockSize, SizeOf(BlockSize));
+ while BlockSize <> 0 do
+ begin
+ BlockType := ReadBlockID;
+ Dec(BlockSize);
+
+ case BlockType of
+ GIFAppLoopExtension:
+ if (BlockSize >= SizeOf(LoopCount)) then
+ begin
+ // Read loop count
+ Read(Handle, @LoopCount, SizeOf(LoopCount));
+ Dec(BlockSize, SizeOf(LoopCount));
+ end;
+ GIFAppBufferExtension:
+ begin
+ Dec(BlockSize, SizeOf(Word));
+ Seek(Handle, SizeOf(Word), smFromCurrent);
+ end;
+ end;
+ end;
+ SkipBytes;
+ AppRead := True;
+ end
+ else
+ begin
+ // Revert all bytes reading
+ Seek(Handle, - SizeOf(AppRec) - SizeOf(BlockSize), smFromCurrent);
+ SkipBytes;
+ end;
+ end
+ else
+ begin
+ Seek(Handle, - BlockSize - SizeOf(BlockSize), smFromCurrent);
+ SkipBytes;
+ end;
+ end
+ else if ExtType in [GIFCommentExtension, GIFApplicationExtension, GIFPlainText] then
+ repeat
+ // Read block sizes and skip them
+ Read(Handle, @BlockSize, SizeOf(BlockSize));
+ Seek(Handle, BlockSize, smFromCurrent);
+ until BlockSize = 0;
+
+ // Read ID of following block
+ BlockID := ReadBlockID;
+ ExtType := BlockID;
+ 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;
+ var
+ ImageDesc: TImageDescriptor;
+ Interlaced: Boolean;
+ I, Idx, LocalPalLength: Integer;
+ LocalPal: TPalette32Size256;
+ LZWStream: TMemoryStream;
+
+ procedure RemoveBadFrame;
+ begin
+ FreeImage(Images[Idx]);
+ SetLength(Images, Length(Images) - 1);
+ end;
+
+ begin
+ Idx := Length(Images);
+ SetLength(Images, Idx + 1);
+ SetLength(FrameInfos, Idx + 1);
+ FillChar(LocalPal, SizeOf(LocalPal), 0);
+
+ with GetIO do
+ begin
+ // Read and parse image descriptor
+ Read(Handle, @ImageDesc, SizeOf(ImageDesc));
+ FrameInfos[Idx].HasLocalPal := (ImageDesc.PackedFields and GIFLocalColorTable) = GIFLocalColorTable;
+ Interlaced := (ImageDesc.PackedFields and GIFInterlaced) = GIFInterlaced;
+ LocalPalLength := ImageDesc.PackedFields and GIFColorTableSize;
+ LocalPalLength := 1 shl (LocalPalLength + 1); // Total pal length is 2^(n+1)
+
+ // From Mozilla source
+ if (ImageDesc.Width = 0) or (ImageDesc.Width > Header.ScreenWidth) then
+ ImageDesc.Width := Header.ScreenWidth;
+ if (ImageDesc.Height = 0) or (ImageDesc.Height > Header.ScreenHeight) then
+ ImageDesc.Height := Header.ScreenHeight;
+
+ FrameInfos[Idx].Left := ImageDesc.Left;
+ FrameInfos[Idx].Top := ImageDesc.Top;
+ FrameInfos[Idx].Width := ImageDesc.Width;
+ FrameInfos[Idx].Height := ImageDesc.Height;
+ FrameInfos[Idx].BackIndex := Header.BackgroundColorIndex;
+
+ // Create new image for this frame which would be later pasted onto logical screen
+ NewImage(ImageDesc.Width, ImageDesc.Height, ifIndex8, Images[Idx]);
+
+ // Load local palette if there is any
+ if FrameInfos[Idx].HasLocalPal then
+ for I := 0 to LocalPalLength - 1 do
+ begin
+ LocalPal[I].A := 255;
+ Read(Handle, @LocalPal[I].R, SizeOf(LocalPal[I].R));
+ Read(Handle, @LocalPal[I].G, SizeOf(LocalPal[I].G));
+ Read(Handle, @LocalPal[I].B, SizeOf(LocalPal[I].B));
+ end;
+
+ // Use local pal if present or global pal if present or create
+ // default pal if neither of them is present
+ if FrameInfos[Idx].HasLocalPal then
+ Move(LocalPal, Images[Idx].Palette^, SizeOf(LocalPal))
+ else if HasGlobalPal then
+ Move(GlobalPal, Images[Idx].Palette^, SizeOf(GlobalPal))
+ else
+ FillCustomPalette(Images[Idx].Palette, GlobalPalLength, 3, 3, 2);
+
+ if (ImageDesc.Left <= Header.ScreenWidth + 1) and (ImageDesc.Top <= Header.ScreenHeight + 1) then
+ begin
+ // Resize the screen if needed to fit the frame
+ ScreenWidth := Max(ScreenWidth, ImageDesc.Width + ImageDesc.Left);
+ ScreenHeight := Max(ScreenHeight, ImageDesc.Height + ImageDesc.Top);
+ end
+ else
+ begin
+ // Remove frame outside logical screen
+ RemoveBadFrame;
+ Exit;
+ end;
+
+ // If Grahic Control Extension is present make use of it
+ if HasGraphicExt then
+ begin
+ FrameInfos[Idx].HasTransparency := (GraphicExt.PackedFields and GIFTransparent) = GIFTransparent;
+ FrameInfos[Idx].Disposal := TDisposalMethod((GraphicExt.PackedFields and GIFDisposalMethod) shr 2);
+ if FrameInfos[Idx].HasTransparency then
+ begin
+ FrameInfos[Idx].TransIndex := GraphicExt.TransparentColorIndex;
+ Images[Idx].Palette[FrameInfos[Idx].TransIndex].A := 0;
+ end;
+ end
+ else
+ FrameInfos[Idx].HasTransparency := False;
+
+ LZWStream := TMemoryStream.Create;
+ try
+ try
+ // Copy LZW data to temp stream, needed for correct decompression
+ CopyLZWData(LZWStream);
+ LZWStream.Position := 0;
+ // Data decompression finally
+ LZWDecompress(LZWStream, Handle, ImageDesc.Width, ImageDesc.Height, Interlaced, Images[Idx].Bits);
+ except
+ RemoveBadFrame;
+ Exit;
+ end;
+ finally
+ LZWStream.Free;
+ end;
+ end;
+ end;
+
+ procedure CopyFrameTransparent32(const Image, Frame: TImageData; Left, Top: Integer);
+ var
+ X, Y: Integer;
+ Src: PByte;
+ Dst: PColor32;
+ begin
+ Src := Frame.Bits;
+
+ // Copy all pixels from frame to log screen but ignore the transparent ones
+ for Y := 0 to Frame.Height - 1 do
+ begin
+ Dst := @PColor32RecArray(Image.Bits)[(Top + Y) * Image.Width + Left];
+ for X := 0 to Frame.Width - 1 do
+ begin
+ if (Frame.Palette[Src^].A <> 0) then
+ Dst^ := Frame.Palette[Src^].Color;
+ Inc(Src);
+ Inc(Dst);
+ end;
+ end;
+ end;
+
+ procedure AnimateFrame(Index: Integer; var AnimFrame: TImageData);
+ var
+ I, First, Last: Integer;
+ UseCache: Boolean;
+ BGColor: TColor32;
+ begin
+ // We may need to use raw frame 0 to n to correctly animate n-th frame
+ Last := Index;
+ First := Max(0, Last);
+ // See if we can use last animate frame as a basis for this one
+ // (so we don't have to use previous raw frames).
+ UseCache := TestImage(CachedFrame) and (CachedIndex = Index - 1) and (CachedIndex >= 0) and
+ (FrameInfos[CachedIndex].Disposal <> dmRestorePrevious);
+
+ // Reuse or release cache
+ if UseCache then
+ CloneImage(CachedFrame, AnimFrame)
+ else
+ FreeImage(CachedFrame);
+
+ // Default color for clearing of the screen
+ BGColor := Images[Index].Palette[FrameInfos[Index].BackIndex].Color;
+
+ // Now prepare logical screen for drawing of raw frame at Index.
+ // We may need to use all previous raw frames to get the screen
+ // to proper state (according to their disposal methods).
+
+ if not UseCache then
+ begin
+ if FrameInfos[Index].HasTransparency then
+ BGColor := Images[Index].Palette[FrameInfos[Index].TransIndex].Color;
+ // Clear whole screen
+ FillMemoryLongWord(AnimFrame.Bits, AnimFrame.Size, BGColor);
+
+ // Try to maximize First so we don't have to use all 0 to n raw frames
+ while First > 0 do
+ begin
+ if (ScreenWidth = Images[First].Width) and (ScreenHeight = Images[First].Height) then
+ begin
+ if (FrameInfos[First].Disposal = dmRestoreBackground) and (First < Last) then
+ Break;
+ end;
+ Dec(First);
+ end;
+
+ for I := First to Last - 1 do
+ begin
+ case FrameInfos[I].Disposal of
+ dmNoRemoval, dmLeave:
+ begin
+ // Copy previous raw frame onto screen
+ CopyFrameTransparent32(AnimFrame, Images[I], FrameInfos[I].Left, FrameInfos[I].Top);
+ end;
+ dmRestoreBackground:
+ if (I > First) then
+ begin
+ // Restore background color
+ FillRect(AnimFrame, FrameInfos[I].Left, FrameInfos[I].Top,
+ FrameInfos[I].Width, FrameInfos[I].Height, @BGColor);
+ end;
+ dmRestorePrevious: ; // Do nothing - previous state is already on screen
+ end;
+ end;
+ end
+ else if FrameInfos[CachedIndex].Disposal = dmRestoreBackground then
+ begin
+ // We have our cached result but also need to restore
+ // background in a place of cached frame
+ if FrameInfos[CachedIndex].HasTransparency then
+ BGColor := Images[CachedIndex].Palette[FrameInfos[CachedIndex].TransIndex].Color;
+ FillRect(AnimFrame, FrameInfos[CachedIndex].Left, FrameInfos[CachedIndex].Top,
+ FrameInfos[CachedIndex].Width, FrameInfos[CachedIndex].Height, @BGColor);
+ end;
+
+ // Copy current raw frame to prepared screen
+ CopyFrameTransparent32(AnimFrame, Images[Index], FrameInfos[Index].Left, FrameInfos[Index].Top);
+
+ // Cache animated result
+ CloneImage(AnimFrame, CachedFrame);
+ CachedIndex := Index;
+ end;
+
+begin
+ AppRead := False;
+
+ SetLength(Images, 0);
+ FillChar(GlobalPal, SizeOf(GlobalPal), 0);
+
+ with GetIO do
+ begin
+ // Read GIF header
+ Read(Handle, @Header, SizeOf(Header));
+ ScreenWidth := Header.ScreenWidth;
+ ScreenHeight := Header.ScreenHeight;
+ HasGlobalPal := Header.PackedFields and GIFGlobalColorTable = GIFGlobalColorTable; // Bit 7
+ GlobalPalLength := Header.PackedFields and GIFColorTableSize; // Bits 0-2
+ GlobalPalLength := 1 shl (GlobalPalLength + 1); // Total pal length is 2^(n+1)
+
+ // Read global palette from file if present
+ if HasGlobalPal then
+ begin
+ for I := 0 to GlobalPalLength - 1 do
+ begin
+ GlobalPal[I].A := 255;
+ Read(Handle, @GlobalPal[I].R, SizeOf(GlobalPal[I].R));
+ Read(Handle, @GlobalPal[I].G, SizeOf(GlobalPal[I].G));
+ Read(Handle, @GlobalPal[I].B, SizeOf(GlobalPal[I].B));
+ end;
+ end;
+
+ // Read ID of the first block
+ BlockID := ReadBlockID;
+
+ // Now read all data blocks in the file until file trailer is reached
+ while BlockID <> GIFTrailer do
+ begin
+ // Read blocks until we find the one of known type
+ while not (BlockID in [GIFTrailer, GIFExtensionIntroducer, GIFImageDescriptor]) do
+ BlockID := ReadBlockID;
+ // Read supported and skip unsupported extensions
+ ReadExtensions;
+ // If image frame is found read it
+ if BlockID = GIFImageDescriptor then
+ ReadFrame;
+ // Read next block's ID
+ BlockID := ReadBlockID;
+ // If block ID is unknown set it to end-of-GIF marker
+ if not (BlockID in [GIFExtensionIntroducer, GIFTrailer, GIFImageDescriptor]) then
+ BlockID := GIFTrailer;
+ end;
+
+ if FLoadAnimated then
+ begin
+ // Aniated frames will be stored in AnimFrames
+ SetLength(AnimFrames, Length(Images));
+ InitImage(CachedFrame);
+ CachedIndex := -1;
+
+ for I := 0 to High(Images) do
+ begin
+ // Create new logical screen
+ NewImage(ScreenWidth, ScreenHeight, ifA8R8G8B8, AnimFrames[I]);
+ // Animate frames to current log screen
+ AnimateFrame(I, AnimFrames[I]);
+ end;
+
+ // Now release raw 8bit frames and put animated 32bit ones
+ // to output array
+ FreeImage(CachedFrame);
+ for I := 0 to High(AnimFrames) do
+ begin
+ FreeImage(Images[I]);
+ Images[I] := AnimFrames[I];
+ end;
+ end;
+
+ Result := True;
+ end;
+end;
+
+function TGIFFileFormat.SaveData(Handle: TImagingHandle;
+ const Images: TDynImageDataArray; Index: Integer): Boolean;
+var
+ Header: TGIFHeader;
+ ImageDesc: TImageDescriptor;
+ ImageToSave: TImageData;
+ MustBeFreed: Boolean;
+ I, J: Integer;
+ GraphicExt: TGraphicControlExtension;
+
+ procedure FindMaxDimensions(var MaxWidth, MaxHeight: Word);
+ var
+ I: Integer;
+ begin
+ MaxWidth := Images[FFirstIdx].Width;
+ MaxHeight := Images[FFirstIdx].Height;
+
+ for I := FFirstIdx + 1 to FLastIdx do
+ begin
+ MaxWidth := Iff(Images[I].Width > MaxWidth, Images[I].Width, MaxWidth);
+ MaxHeight := Iff(Images[I].Height > MaxWidth, Images[I].Height, MaxHeight);
+ end;
+ end;
+
+begin
+ // Fill header with data, select size of largest image in array as
+ // logical screen size
+ FillChar(Header, Sizeof(Header), 0);
+ Header.Signature := GIFSignature;
+ Header.Version := GIFVersions[gv89];
+ FindMaxDimensions(Header.ScreenWidth, Header.ScreenHeight);
+ Header.PackedFields := GIFColorResolution; // Color resolution is 256
+ GetIO.Write(Handle, @Header, SizeOf(Header));
+
+ // Prepare default GC extension with delay
+ FillChar(GraphicExt, Sizeof(GraphicExt), 0);
+ GraphicExt.DelayTime := 65;
+ GraphicExt.BlockSize := 4;
+
+ for I := FFirstIdx to FLastIdx do
+ begin
+ if MakeCompatible(Images[I], ImageToSave, MustBeFreed) then
+ with GetIO, ImageToSave do
+ try
+ // Write Graphic Control Extension with default delay
+ Write(Handle, @GIFExtensionIntroducer, SizeOf(GIFExtensionIntroducer));
+ Write(Handle, @GIFGraphicControlExtension, SizeOf(GIFGraphicControlExtension));
+ Write(Handle, @GraphicExt, SizeOf(GraphicExt));
+ // Write frame marker and fill and write image descriptor for this frame
+ Write(Handle, @GIFImageDescriptor, SizeOf(GIFImageDescriptor));
+ FillChar(ImageDesc, Sizeof(ImageDesc), 0);
+ ImageDesc.Width := Width;
+ ImageDesc.Height := Height;
+ ImageDesc.PackedFields := GIFLocalColorTable or GIFColorTableSize; // Use lccal color table with 256 entries
+ Write(Handle, @ImageDesc, SizeOf(ImageDesc));
+
+ // Write local color table for each frame
+ for J := 0 to 255 do
+ begin
+ Write(Handle, @Palette[J].R, SizeOf(Palette[J].R));
+ Write(Handle, @Palette[J].G, SizeOf(Palette[J].G));
+ Write(Handle, @Palette[J].B, SizeOf(Palette[J].B));
+ end;
+
+ // Fonally compress image data
+ LZWCompress(GetIO, Handle, Width, Height, 8, False, Bits);
+
+ finally
+ if MustBeFreed then
+ FreeImage(ImageToSave);
+ end;
+ end;
+
+ GetIO.Write(Handle, @GIFTrailer, SizeOf(GIFTrailer));
+ Result := True;
+end;
+
+procedure TGIFFileFormat.ConvertToSupported(var Image: TImageData;
+ const Info: TImageFormatInfo);
+begin
+ ConvertImage(Image, ifIndex8);
+end;
+
+function TGIFFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
+var
+ Header: TGIFHeader;
+ ReadCount: LongInt;
+begin
+ Result := False;
+ if Handle <> nil then
+ begin
+ ReadCount := GetIO.Read(Handle, @Header, SizeOf(Header));
+ GetIO.Seek(Handle, -ReadCount, smFromCurrent);
+ Result := (ReadCount >= SizeOf(Header)) and
+ (Header.Signature = GIFSignature) and
+ ((Header.Version = GIFVersions[gv87]) or (Header.Version = GIFVersions[gv89]));
+ end;
+end;
+
+initialization
+ RegisterImageFileFormat(TGIFFileFormat);
+
+{
+ File Notes:
+
+ -- TODOS ----------------------------------------------------
+ - nothing now
+
+ -- 0.26.3 Changes/Bug Fixes ---------------------------------
+ - Fixed bug - loading of GIF with NETSCAPE app extensions
+ failed with Delphi 2009.
+
+ -- 0.26.1 Changes/Bug Fixes ---------------------------------
+ - GIF loading and animation mostly rewritten, based on
+ modification by Sergey Galezdinov (ExtraGIF in Extras/Contrib).
+
+ -- 0.25.0 Changes/Bug Fixes ---------------------------------
+ - Fixed loading of some rare GIFs, problems with LZW
+ decompression.
+
+ -- 0.24.3 Changes/Bug Fixes ---------------------------------
+ - Better solution to transparency for some GIFs. Background not
+ transparent by default.
+
+ -- 0.24.1 Changes/Bug Fixes ---------------------------------
+ - Made backround color transparent by default (alpha = 0).
+
+ -- 0.23 Changes/Bug Fixes -----------------------------------
+ - Fixed other loading bugs (local pal size, transparency).
+ - Added GIF saving.
+ - Fixed bug when loading multiframe GIFs and implemented few animation
+ features (disposal methods, ...).
+ - Loading of GIFs working.
+ - Unit created with initial stuff!
+}
+
+end.
diff --git a/Imaging/ImagingIO.pas b/Imaging/ImagingIO.pas
index e598091..04c0256 100644
--- a/Imaging/ImagingIO.pas
+++ b/Imaging/ImagingIO.pas
@@ -1,574 +1,574 @@
-{
- $Id: ImagingIO.pas 100 2007-06-28 21:09:52Z galfar $
- Vampyre Imaging Library
- by Marek Mauder
- http://imaginglib.sourceforge.net
-
- The contents of this file are used with permission, subject to the Mozilla
- Public License Version 1.1 (the "License"); you may not use this file except
- in compliance with the License. You may obtain a copy of the License at
- http://www.mozilla.org/MPL/MPL-1.1.html
-
- Software distributed under the License is distributed on an "AS IS" basis,
- WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
- the specific language governing rights and limitations under the License.
-
- Alternatively, the contents of this file may be used under the terms of the
- GNU Lesser General Public License (the "LGPL License"), in which case the
- provisions of the LGPL License are applicable instead of those above.
- If you wish to allow use of your version of this file only under the terms
- of the LGPL License and not to allow others to use your version of this file
- under the MPL, indicate your decision by deleting the provisions above and
- replace them with the notice and other provisions required by the LGPL
- License. If you do not delete the provisions above, a recipient may use
- your version of this file under either the MPL or the LGPL License.
-
- For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
-}
-
-{ This unit contains default IO functions for reading from/writting to
- files, streams and memory.}
-unit ImagingIO;
-
-{$I ImagingOptions.inc}
-
-interface
-
-uses
- SysUtils, Classes, ImagingTypes, Imaging, ImagingUtility;
-
-type
- TMemoryIORec = record
- Data: ImagingUtility.PByteArray;
- Position: LongInt;
- Size: LongInt;
- end;
- PMemoryIORec = ^TMemoryIORec;
-
-var
- OriginalFileIO: TIOFunctions;
- FileIO: TIOFunctions;
- StreamIO: TIOFunctions;
- MemoryIO: TIOFunctions;
-
-{ Helper function that returns size of input (from current position to the end)
- represented by Handle (and opened and operated on by members of IOFunctions).}
-function GetInputSize(IOFunctions: TIOFunctions; Handle: TImagingHandle): LongInt;
-{ Helper function that initializes TMemoryIORec with given params.}
-function PrepareMemIO(Data: Pointer; Size: LongInt): TMemoryIORec;
-
-implementation
-
-const
- DefaultBufferSize = 16 * 1024;
-
-type
- { Based on TaaBufferedStream
- Copyright (c) Julian M Bucknall 1997, 1999 }
- TBufferedStream = class(TObject)
- private
- FBuffer: PByteArray;
- FBufSize: Integer;
- FBufStart: Integer;
- FBufPos: Integer;
- FBytesInBuf: Integer;
- FSize: Integer;
- FDirty: Boolean;
- FStream: TStream;
- function GetPosition: Integer;
- function GetSize: Integer;
- procedure ReadBuffer;
- procedure WriteBuffer;
- procedure SetPosition(const Value: Integer);
- public
- constructor Create(AStream: TStream);
- destructor Destroy; override;
- function Read(var Buffer; Count: Integer): Integer;
- function Write(const Buffer; Count: Integer): Integer;
- function Seek(Offset: Integer; Origin: Word): Integer;
- procedure Commit;
- property Stream: TStream read FStream;
- property Position: Integer read GetPosition write SetPosition;
- property Size: Integer read GetSize;
- end;
-
-constructor TBufferedStream.Create(AStream: TStream);
-begin
- inherited Create;
- FStream := AStream;
- FBufSize := DefaultBufferSize;
- GetMem(FBuffer, FBufSize);
- FBufPos := 0;
- FBytesInBuf := 0;
- FBufStart := 0;
- FDirty := False;
- FSize := AStream.Size;
-end;
-
-destructor TBufferedStream.Destroy;
-begin
- if FBuffer <> nil then
- begin
- Commit;
- FreeMem(FBuffer);
- end;
- FStream.Position := Position; // Make sure source stream has right position
- inherited Destroy;
-end;
-
-function TBufferedStream.GetPosition: Integer;
-begin
- Result := FBufStart + FBufPos;
-end;
-
-procedure TBufferedStream.SetPosition(const Value: Integer);
-begin
- Seek(Value, soFromCurrent);
-end;
-
-function TBufferedStream.GetSize: Integer;
-begin
- Result := FSize;
-end;
-
-procedure TBufferedStream.ReadBuffer;
-var
- SeekResult: Integer;
-begin
- SeekResult := FStream.Seek(FBufStart, 0);
- if SeekResult = -1 then
- raise Exception.Create('TBufferedStream.ReadBuffer: seek failed');
- FBytesInBuf := FStream.Read(FBuffer^, FBufSize);
- if FBytesInBuf <= 0 then
- raise Exception.Create('TBufferedStream.ReadBuffer: read failed');
-end;
-
-procedure TBufferedStream.WriteBuffer;
-var
- SeekResult: Integer;
- BytesWritten: Integer;
-begin
- SeekResult := FStream.Seek(FBufStart, 0);
- if SeekResult = -1 then
- raise Exception.Create('TBufferedStream.WriteBuffer: seek failed');
- BytesWritten := FStream.Write(FBuffer^, FBytesInBuf);
- if BytesWritten <> FBytesInBuf then
- raise Exception.Create('TBufferedStream.WriteBuffer: write failed');
-end;
-
-procedure TBufferedStream.Commit;
-begin
- if FDirty then
- begin
- WriteBuffer;
- FDirty := False;
- end;
-end;
-
-function TBufferedStream.Read(var Buffer; Count: Integer): Integer;
-var
- BufAsBytes : TByteArray absolute Buffer;
- BufIdx, BytesToGo, BytesToRead: Integer;
-begin
- // Calculate the actual number of bytes we can read - this depends on
- // the current position and size of the stream as well as the number
- // of bytes requested.
- BytesToGo := Count;
- if FSize < (FBufStart + FBufPos + Count) then
- BytesToGo := FSize - (FBufStart + FBufPos);
-
- if BytesToGo <= 0 then
- begin
- Result := 0;
- Exit;
- end;
- // Remember to return the result of our calculation
- Result := BytesToGo;
-
- BufIdx := 0;
- if FBytesInBuf = 0 then
- ReadBuffer;
- // Calculate the number of bytes we can read prior to the loop
- BytesToRead := FBytesInBuf - FBufPos;
- if BytesToRead > BytesToGo then
- BytesToRead := BytesToGo;
- // Copy from the stream buffer to the caller's buffer
- Move(FBuffer^[FBufPos], BufAsBytes[BufIdx], BytesToRead);
- // Calculate the number of bytes still to read}
- Dec(BytesToGo, BytesToRead);
-
- // while we have bytes to read, read them
- while BytesToGo > 0 do
- begin
- Inc(BufIdx, BytesToRead);
- // As we've exhausted this buffer-full, advance to the next, check
- // to see whether we need to write the buffer out first
- if FDirty then
- begin
- WriteBuffer;
- FDirty := false;
- end;
- Inc(FBufStart, FBufSize);
- FBufPos := 0;
- ReadBuffer;
- // Calculate the number of bytes we can read in this cycle
- BytesToRead := FBytesInBuf;
- if BytesToRead > BytesToGo then
- BytesToRead := BytesToGo;
- // Ccopy from the stream buffer to the caller's buffer
- Move(FBuffer^, BufAsBytes[BufIdx], BytesToRead);
- // Calculate the number of bytes still to read
- Dec(BytesToGo, BytesToRead);
- end;
- // Remember our new position
- Inc(FBufPos, BytesToRead);
- if FBufPos = FBufSize then
- begin
- Inc(FBufStart, FBufSize);
- FBufPos := 0;
- FBytesInBuf := 0;
- end;
-end;
-
-function TBufferedStream.Seek(Offset: Integer; Origin: Word): Integer;
-var
- NewBufStart, NewPos: Integer;
-begin
- // Calculate the new position
- case Origin of
- soFromBeginning : NewPos := Offset;
- soFromCurrent : NewPos := FBufStart + FBufPos + Offset;
- soFromEnd : NewPos := FSize + Offset;
- else
- raise Exception.Create('TBufferedStream.Seek: invalid origin');
- end;
-
- if (NewPos < 0) or (NewPos > FSize) then
- begin
- //NewPos := ClampInt(NewPos, 0, FSize); don't do this - for writing
- end;
- // Calculate which page of the file we need to be at
- NewBufStart := NewPos and not Pred(FBufSize);
- // If the new page is different than the old, mark the buffer as being
- // ready to be replenished, and if need be write out any dirty data
- if NewBufStart <> FBufStart then
- begin
- if FDirty then
- begin
- WriteBuffer;
- FDirty := False;
- end;
- FBufStart := NewBufStart;
- FBytesInBuf := 0;
- end;
- // Save the new position
- FBufPos := NewPos - NewBufStart;
- Result := NewPos;
-end;
-
-function TBufferedStream.Write(const Buffer; Count: Integer): Integer;
-var
- BufAsBytes: TByteArray absolute Buffer;
- BufIdx, BytesToGo, BytesToWrite: Integer;
-begin
- // When we write to this stream we always assume that we can write the
- // requested number of bytes: if we can't (eg, the disk is full) we'll
- // get an exception somewhere eventually.
- BytesToGo := Count;
- // Remember to return the result of our calculation
- Result := BytesToGo;
-
- BufIdx := 0;
- if (FBytesInBuf = 0) and (FSize > FBufStart) then
- ReadBuffer;
- // Calculate the number of bytes we can write prior to the loop
- BytesToWrite := FBufSize - FBufPos;
- if BytesToWrite > BytesToGo then
- BytesToWrite := BytesToGo;
- // Copy from the caller's buffer to the stream buffer
- Move(BufAsBytes[BufIdx], FBuffer^[FBufPos], BytesToWrite);
- // Mark our stream buffer as requiring a save to the actual stream,
- // note that this will suffice for the rest of the routine as well: no
- // inner routine will turn off the dirty flag.
- FDirty := True;
- // Calculate the number of bytes still to write
- Dec(BytesToGo, BytesToWrite);
-
- // While we have bytes to write, write them
- while BytesToGo > 0 do
- begin
- Inc(BufIdx, BytesToWrite);
- // As we've filled this buffer, write it out to the actual stream
- // and advance to the next buffer, reading it if required
- FBytesInBuf := FBufSize;
- WriteBuffer;
- Inc(FBufStart, FBufSize);
- FBufPos := 0;
- FBytesInBuf := 0;
- if FSize > FBufStart then
- ReadBuffer;
- // Calculate the number of bytes we can write in this cycle
- BytesToWrite := FBufSize;
- if BytesToWrite > BytesToGo then
- BytesToWrite := BytesToGo;
- // Copy from the caller's buffer to our buffer
- Move(BufAsBytes[BufIdx], FBuffer^, BytesToWrite);
- // Calculate the number of bytes still to write
- Dec(BytesToGo, BytesToWrite);
- end;
- // Remember our new position
- Inc(FBufPos, BytesToWrite);
- // Make sure the count of valid bytes is correct
- if FBytesInBuf < FBufPos then
- FBytesInBuf := FBufPos;
- // Make sure the stream size is correct
- if FSize < (FBufStart + FBytesInBuf) then
- FSize := FBufStart + FBytesInBuf;
- // If we're at the end of the buffer, write it out and advance to the
- // start of the next page
- if FBufPos = FBufSize then
- begin
- WriteBuffer;
- FDirty := False;
- Inc(FBufStart, FBufSize);
- FBufPos := 0;
- FBytesInBuf := 0;
- end;
-end;
-
-{ File IO functions }
-
-function FileOpenRead(FileName: PChar): TImagingHandle; cdecl;
-begin
- Result := TBufferedStream.Create(TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite));
-end;
-
-function FileOpenWrite(FileName: PChar): TImagingHandle; cdecl;
-begin
- Result := TBufferedStream.Create(TFileStream.Create(FileName, fmCreate or fmShareDenyWrite));
-end;
-
-procedure FileClose(Handle: TImagingHandle); cdecl;
-var
- Stream: TStream;
-begin
- Stream := TBufferedStream(Handle).Stream;
- TBufferedStream(Handle).Free;
- Stream.Free;
-end;
-
-function FileEof(Handle: TImagingHandle): Boolean; cdecl;
-begin
- Result := TBufferedStream(Handle).Position = TBufferedStream(Handle).Size;
-end;
-
-function FileSeek(Handle: TImagingHandle; Offset: LongInt; Mode: TSeekMode):
- LongInt; cdecl;
-begin
- Result := TBufferedStream(Handle).Seek(Offset, LongInt(Mode));
-end;
-
-function FileTell(Handle: TImagingHandle): LongInt; cdecl;
-begin
- Result := TBufferedStream(Handle).Position;
-end;
-
-function FileRead(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt):
- LongInt; cdecl;
-begin
- Result := TBufferedStream(Handle).Read(Buffer^, Count);
-end;
-
-function FileWrite(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt):
- LongInt; cdecl;
-begin
- Result := TBufferedStream(Handle).Write(Buffer^, Count);
-end;
-
-{ Stream IO functions }
-
-function StreamOpenRead(FileName: PChar): TImagingHandle; cdecl;
-begin
- Result := FileName;
-end;
-
-function StreamOpenWrite(FileName: PChar): TImagingHandle; cdecl;
-begin
- Result := FileName;
-end;
-
-procedure StreamClose(Handle: TImagingHandle); cdecl;
-begin
-end;
-
-function StreamEof(Handle: TImagingHandle): Boolean; cdecl;
-begin
- Result := TStream(Handle).Position = TStream(Handle).Size;
-end;
-
-function StreamSeek(Handle: TImagingHandle; Offset: LongInt; Mode: TSeekMode):
- LongInt; cdecl;
-begin
- Result := TStream(Handle).Seek(Offset, LongInt(Mode));
-end;
-
-function StreamTell(Handle: TImagingHandle): LongInt; cdecl;
-begin
- Result := TStream(Handle).Position;
-end;
-
-function StreamRead(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt):
- LongInt; cdecl;
-begin
- Result := TStream(Handle).Read(Buffer^, Count);
-end;
-
-function StreamWrite(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt):
- LongInt; cdecl;
-begin
- Result := TStream(Handle).Write(Buffer^, Count);
-end;
-
-{ Memory IO functions }
-
-function MemoryOpenRead(FileName: PChar): TImagingHandle; cdecl;
-begin
- Result := FileName;
-end;
-
-function MemoryOpenWrite(FileName: PChar): TImagingHandle; cdecl;
-begin
- Result := FileName;
-end;
-
-procedure MemoryClose(Handle: TImagingHandle); cdecl;
-begin
-end;
-
-function MemoryEof(Handle: TImagingHandle): Boolean; cdecl;
-begin
- Result := PMemoryIORec(Handle).Position = PMemoryIORec(Handle).Size;
-end;
-
-function MemorySeek(Handle: TImagingHandle; Offset: LongInt; Mode: TSeekMode):
- LongInt; cdecl;
-begin
- Result := PMemoryIORec(Handle).Position;
- case Mode of
- smFromBeginning: Result := Offset;
- smFromCurrent: Result := PMemoryIORec(Handle).Position + Offset;
- smFromEnd: Result := PMemoryIORec(Handle).Size + Offset;
- end;
- //Result := ClampInt(Result, 0, PMemoryIORec(Handle).Size); don't do this - some file formats use it
- PMemoryIORec(Handle).Position := Result;
-end;
-
-function MemoryTell(Handle: TImagingHandle): LongInt; cdecl;
-begin
- Result := PMemoryIORec(Handle).Position;
-end;
-
-function MemoryRead(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt):
- LongInt; cdecl;
-var
- Rec: PMemoryIORec;
-begin
- Rec := PMemoryIORec(Handle);
- Result := Count;
- if Rec.Position + Count > Rec.Size then
- Result := Rec.Size - Rec.Position;
- Move(Rec.Data[Rec.Position], Buffer^, Result);
- Rec.Position := Rec.Position + Result;
-end;
-
-function MemoryWrite(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt):
- LongInt; cdecl;
-var
- Rec: PMemoryIORec;
-begin
- Rec := PMemoryIORec(Handle);
- Result := Count;
- if Rec.Position + Count > Rec.Size then
- Result := Rec.Size - Rec.Position;
- Move(Buffer^, Rec.Data[Rec.Position], Result);
- Rec.Position := Rec.Position + Result;
-end;
-
-{ Helper IO functions }
-
-function GetInputSize(IOFunctions: TIOFunctions; Handle: TImagingHandle): LongInt;
-var
- OldPos: Int64;
-begin
- OldPos := IOFunctions.Tell(Handle);
- IOFunctions.Seek(Handle, 0, smFromEnd);
- Result := IOFunctions.Tell(Handle);
- IOFunctions.Seek(Handle, OldPos, smFromBeginning);
-end;
-
-function PrepareMemIO(Data: Pointer; Size: LongInt): TMemoryIORec;
-begin
- Result.Data := Data;
- Result.Position := 0;
- Result.Size := Size;
-end;
-
-initialization
- OriginalFileIO.OpenRead := FileOpenRead;
- OriginalFileIO.OpenWrite := FileOpenWrite;
- OriginalFileIO.Close := FileClose;
- OriginalFileIO.Eof := FileEof;
- OriginalFileIO.Seek := FileSeek;
- OriginalFileIO.Tell := FileTell;
- OriginalFileIO.Read := FileRead;
- OriginalFileIO.Write := FileWrite;
-
- StreamIO.OpenRead := StreamOpenRead;
- StreamIO.OpenWrite := StreamOpenWrite;
- StreamIO.Close := StreamClose;
- StreamIO.Eof := StreamEof;
- StreamIO.Seek := StreamSeek;
- StreamIO.Tell := StreamTell;
- StreamIO.Read := StreamRead;
- StreamIO.Write := StreamWrite;
-
- MemoryIO.OpenRead := MemoryOpenRead;
- MemoryIO.OpenWrite := MemoryOpenWrite;
- MemoryIO.Close := MemoryClose;
- MemoryIO.Eof := MemoryEof;
- MemoryIO.Seek := MemorySeek;
- MemoryIO.Tell := MemoryTell;
- MemoryIO.Read := MemoryRead;
- MemoryIO.Write := MemoryWrite;
-
- ResetFileIO;
-
-{
- File Notes:
-
- -- TODOS ----------------------------------------------------
- - nothing now
-
- -- 0.23 Changes/Bug Fixes -----------------------------------
- - Added merge between buffered read-only and write-only file
- stream adapters - TIFF saving needed both reading and writing.
- - Fixed bug causing wrong value of TBufferedWriteFile.Size
- (needed to add buffer pos to size).
-
- -- 0.21 Changes/Bug Fixes -----------------------------------
- - Removed TMemoryIORec.Written, use Position to get proper memory
- position (Written didn't take Seeks into account).
- - Added TBufferedReadFile and TBufferedWriteFile classes for
- buffered file reading/writting. File IO functions now use these
- classes resulting in performance increase mainly in file formats
- that read/write many small chunks.
- - Added fmShareDenyWrite to FileOpenRead. You can now read
- files opened for reading by Imaging from other apps.
- - Added GetInputSize and PrepareMemIO helper functions.
-
- -- 0.19 Changes/Bug Fixes -----------------------------------
- - changed behaviour of MemorySeek to act as TStream
- based Seeks
-}
-end.
-
+{
+ $Id: ImagingIO.pas 100 2007-06-28 21:09:52Z galfar $
+ Vampyre Imaging Library
+ by Marek Mauder
+ http://imaginglib.sourceforge.net
+
+ The contents of this file are used with permission, subject to the Mozilla
+ Public License Version 1.1 (the "License"); you may not use this file except
+ in compliance with the License. You may obtain a copy of the License at
+ http://www.mozilla.org/MPL/MPL-1.1.html
+
+ Software distributed under the License is distributed on an "AS IS" basis,
+ WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
+ the specific language governing rights and limitations under the License.
+
+ Alternatively, the contents of this file may be used under the terms of the
+ GNU Lesser General Public License (the "LGPL License"), in which case the
+ provisions of the LGPL License are applicable instead of those above.
+ If you wish to allow use of your version of this file only under the terms
+ of the LGPL License and not to allow others to use your version of this file
+ under the MPL, indicate your decision by deleting the provisions above and
+ replace them with the notice and other provisions required by the LGPL
+ License. If you do not delete the provisions above, a recipient may use
+ your version of this file under either the MPL or the LGPL License.
+
+ For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
+}
+
+{ This unit contains default IO functions for reading from/writting to
+ files, streams and memory.}
+unit ImagingIO;
+
+{$I ImagingOptions.inc}
+
+interface
+
+uses
+ SysUtils, Classes, ImagingTypes, Imaging, ImagingUtility;
+
+type
+ TMemoryIORec = record
+ Data: ImagingUtility.PByteArray;
+ Position: LongInt;
+ Size: LongInt;
+ end;
+ PMemoryIORec = ^TMemoryIORec;
+
+var
+ OriginalFileIO: TIOFunctions;
+ FileIO: TIOFunctions;
+ StreamIO: TIOFunctions;
+ MemoryIO: TIOFunctions;
+
+{ Helper function that returns size of input (from current position to the end)
+ represented by Handle (and opened and operated on by members of IOFunctions).}
+function GetInputSize(IOFunctions: TIOFunctions; Handle: TImagingHandle): LongInt;
+{ Helper function that initializes TMemoryIORec with given params.}
+function PrepareMemIO(Data: Pointer; Size: LongInt): TMemoryIORec;
+
+implementation
+
+const
+ DefaultBufferSize = 16 * 1024;
+
+type
+ { Based on TaaBufferedStream
+ Copyright (c) Julian M Bucknall 1997, 1999 }
+ TBufferedStream = class(TObject)
+ private
+ FBuffer: PByteArray;
+ FBufSize: Integer;
+ FBufStart: Integer;
+ FBufPos: Integer;
+ FBytesInBuf: Integer;
+ FSize: Integer;
+ FDirty: Boolean;
+ FStream: TStream;
+ function GetPosition: Integer;
+ function GetSize: Integer;
+ procedure ReadBuffer;
+ procedure WriteBuffer;
+ procedure SetPosition(const Value: Integer);
+ public
+ constructor Create(AStream: TStream);
+ destructor Destroy; override;
+ function Read(var Buffer; Count: Integer): Integer;
+ function Write(const Buffer; Count: Integer): Integer;
+ function Seek(Offset: Integer; Origin: Word): Integer;
+ procedure Commit;
+ property Stream: TStream read FStream;
+ property Position: Integer read GetPosition write SetPosition;
+ property Size: Integer read GetSize;
+ end;
+
+constructor TBufferedStream.Create(AStream: TStream);
+begin
+ inherited Create;
+ FStream := AStream;
+ FBufSize := DefaultBufferSize;
+ GetMem(FBuffer, FBufSize);
+ FBufPos := 0;
+ FBytesInBuf := 0;
+ FBufStart := 0;
+ FDirty := False;
+ FSize := AStream.Size;
+end;
+
+destructor TBufferedStream.Destroy;
+begin
+ if FBuffer <> nil then
+ begin
+ Commit;
+ FreeMem(FBuffer);
+ end;
+ FStream.Position := Position; // Make sure source stream has right position
+ inherited Destroy;
+end;
+
+function TBufferedStream.GetPosition: Integer;
+begin
+ Result := FBufStart + FBufPos;
+end;
+
+procedure TBufferedStream.SetPosition(const Value: Integer);
+begin
+ Seek(Value, soFromCurrent);
+end;
+
+function TBufferedStream.GetSize: Integer;
+begin
+ Result := FSize;
+end;
+
+procedure TBufferedStream.ReadBuffer;
+var
+ SeekResult: Integer;
+begin
+ SeekResult := FStream.Seek(FBufStart, 0);
+ if SeekResult = -1 then
+ raise Exception.Create('TBufferedStream.ReadBuffer: seek failed');
+ FBytesInBuf := FStream.Read(FBuffer^, FBufSize);
+ if FBytesInBuf <= 0 then
+ raise Exception.Create('TBufferedStream.ReadBuffer: read failed');
+end;
+
+procedure TBufferedStream.WriteBuffer;
+var
+ SeekResult: Integer;
+ BytesWritten: Integer;
+begin
+ SeekResult := FStream.Seek(FBufStart, 0);
+ if SeekResult = -1 then
+ raise Exception.Create('TBufferedStream.WriteBuffer: seek failed');
+ BytesWritten := FStream.Write(FBuffer^, FBytesInBuf);
+ if BytesWritten <> FBytesInBuf then
+ raise Exception.Create('TBufferedStream.WriteBuffer: write failed');
+end;
+
+procedure TBufferedStream.Commit;
+begin
+ if FDirty then
+ begin
+ WriteBuffer;
+ FDirty := False;
+ end;
+end;
+
+function TBufferedStream.Read(var Buffer; Count: Integer): Integer;
+var
+ BufAsBytes : TByteArray absolute Buffer;
+ BufIdx, BytesToGo, BytesToRead: Integer;
+begin
+ // Calculate the actual number of bytes we can read - this depends on
+ // the current position and size of the stream as well as the number
+ // of bytes requested.
+ BytesToGo := Count;
+ if FSize < (FBufStart + FBufPos + Count) then
+ BytesToGo := FSize - (FBufStart + FBufPos);
+
+ if BytesToGo <= 0 then
+ begin
+ Result := 0;
+ Exit;
+ end;
+ // Remember to return the result of our calculation
+ Result := BytesToGo;
+
+ BufIdx := 0;
+ if FBytesInBuf = 0 then
+ ReadBuffer;
+ // Calculate the number of bytes we can read prior to the loop
+ BytesToRead := FBytesInBuf - FBufPos;
+ if BytesToRead > BytesToGo then
+ BytesToRead := BytesToGo;
+ // Copy from the stream buffer to the caller's buffer
+ Move(FBuffer^[FBufPos], BufAsBytes[BufIdx], BytesToRead);
+ // Calculate the number of bytes still to read}
+ Dec(BytesToGo, BytesToRead);
+
+ // while we have bytes to read, read them
+ while BytesToGo > 0 do
+ begin
+ Inc(BufIdx, BytesToRead);
+ // As we've exhausted this buffer-full, advance to the next, check
+ // to see whether we need to write the buffer out first
+ if FDirty then
+ begin
+ WriteBuffer;
+ FDirty := false;
+ end;
+ Inc(FBufStart, FBufSize);
+ FBufPos := 0;
+ ReadBuffer;
+ // Calculate the number of bytes we can read in this cycle
+ BytesToRead := FBytesInBuf;
+ if BytesToRead > BytesToGo then
+ BytesToRead := BytesToGo;
+ // Ccopy from the stream buffer to the caller's buffer
+ Move(FBuffer^, BufAsBytes[BufIdx], BytesToRead);
+ // Calculate the number of bytes still to read
+ Dec(BytesToGo, BytesToRead);
+ end;
+ // Remember our new position
+ Inc(FBufPos, BytesToRead);
+ if FBufPos = FBufSize then
+ begin
+ Inc(FBufStart, FBufSize);
+ FBufPos := 0;
+ FBytesInBuf := 0;
+ end;
+end;
+
+function TBufferedStream.Seek(Offset: Integer; Origin: Word): Integer;
+var
+ NewBufStart, NewPos: Integer;
+begin
+ // Calculate the new position
+ case Origin of
+ soFromBeginning : NewPos := Offset;
+ soFromCurrent : NewPos := FBufStart + FBufPos + Offset;
+ soFromEnd : NewPos := FSize + Offset;
+ else
+ raise Exception.Create('TBufferedStream.Seek: invalid origin');
+ end;
+
+ if (NewPos < 0) or (NewPos > FSize) then
+ begin
+ //NewPos := ClampInt(NewPos, 0, FSize); don't do this - for writing
+ end;
+ // Calculate which page of the file we need to be at
+ NewBufStart := NewPos and not Pred(FBufSize);
+ // If the new page is different than the old, mark the buffer as being
+ // ready to be replenished, and if need be write out any dirty data
+ if NewBufStart <> FBufStart then
+ begin
+ if FDirty then
+ begin
+ WriteBuffer;
+ FDirty := False;
+ end;
+ FBufStart := NewBufStart;
+ FBytesInBuf := 0;
+ end;
+ // Save the new position
+ FBufPos := NewPos - NewBufStart;
+ Result := NewPos;
+end;
+
+function TBufferedStream.Write(const Buffer; Count: Integer): Integer;
+var
+ BufAsBytes: TByteArray absolute Buffer;
+ BufIdx, BytesToGo, BytesToWrite: Integer;
+begin
+ // When we write to this stream we always assume that we can write the
+ // requested number of bytes: if we can't (eg, the disk is full) we'll
+ // get an exception somewhere eventually.
+ BytesToGo := Count;
+ // Remember to return the result of our calculation
+ Result := BytesToGo;
+
+ BufIdx := 0;
+ if (FBytesInBuf = 0) and (FSize > FBufStart) then
+ ReadBuffer;
+ // Calculate the number of bytes we can write prior to the loop
+ BytesToWrite := FBufSize - FBufPos;
+ if BytesToWrite > BytesToGo then
+ BytesToWrite := BytesToGo;
+ // Copy from the caller's buffer to the stream buffer
+ Move(BufAsBytes[BufIdx], FBuffer^[FBufPos], BytesToWrite);
+ // Mark our stream buffer as requiring a save to the actual stream,
+ // note that this will suffice for the rest of the routine as well: no
+ // inner routine will turn off the dirty flag.
+ FDirty := True;
+ // Calculate the number of bytes still to write
+ Dec(BytesToGo, BytesToWrite);
+
+ // While we have bytes to write, write them
+ while BytesToGo > 0 do
+ begin
+ Inc(BufIdx, BytesToWrite);
+ // As we've filled this buffer, write it out to the actual stream
+ // and advance to the next buffer, reading it if required
+ FBytesInBuf := FBufSize;
+ WriteBuffer;
+ Inc(FBufStart, FBufSize);
+ FBufPos := 0;
+ FBytesInBuf := 0;
+ if FSize > FBufStart then
+ ReadBuffer;
+ // Calculate the number of bytes we can write in this cycle
+ BytesToWrite := FBufSize;
+ if BytesToWrite > BytesToGo then
+ BytesToWrite := BytesToGo;
+ // Copy from the caller's buffer to our buffer
+ Move(BufAsBytes[BufIdx], FBuffer^, BytesToWrite);
+ // Calculate the number of bytes still to write
+ Dec(BytesToGo, BytesToWrite);
+ end;
+ // Remember our new position
+ Inc(FBufPos, BytesToWrite);
+ // Make sure the count of valid bytes is correct
+ if FBytesInBuf < FBufPos then
+ FBytesInBuf := FBufPos;
+ // Make sure the stream size is correct
+ if FSize < (FBufStart + FBytesInBuf) then
+ FSize := FBufStart + FBytesInBuf;
+ // If we're at the end of the buffer, write it out and advance to the
+ // start of the next page
+ if FBufPos = FBufSize then
+ begin
+ WriteBuffer;
+ FDirty := False;
+ Inc(FBufStart, FBufSize);
+ FBufPos := 0;
+ FBytesInBuf := 0;
+ end;
+end;
+
+{ File IO functions }
+
+function FileOpenRead(FileName: PChar): TImagingHandle; cdecl;
+begin
+ Result := TBufferedStream.Create(TFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite));
+end;
+
+function FileOpenWrite(FileName: PChar): TImagingHandle; cdecl;
+begin
+ Result := TBufferedStream.Create(TFileStream.Create(FileName, fmCreate or fmShareDenyWrite));
+end;
+
+procedure FileClose(Handle: TImagingHandle); cdecl;
+var
+ Stream: TStream;
+begin
+ Stream := TBufferedStream(Handle).Stream;
+ TBufferedStream(Handle).Free;
+ Stream.Free;
+end;
+
+function FileEof(Handle: TImagingHandle): Boolean; cdecl;
+begin
+ Result := TBufferedStream(Handle).Position = TBufferedStream(Handle).Size;
+end;
+
+function FileSeek(Handle: TImagingHandle; Offset: LongInt; Mode: TSeekMode):
+ LongInt; cdecl;
+begin
+ Result := TBufferedStream(Handle).Seek(Offset, LongInt(Mode));
+end;
+
+function FileTell(Handle: TImagingHandle): LongInt; cdecl;
+begin
+ Result := TBufferedStream(Handle).Position;
+end;
+
+function FileRead(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt):
+ LongInt; cdecl;
+begin
+ Result := TBufferedStream(Handle).Read(Buffer^, Count);
+end;
+
+function FileWrite(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt):
+ LongInt; cdecl;
+begin
+ Result := TBufferedStream(Handle).Write(Buffer^, Count);
+end;
+
+{ Stream IO functions }
+
+function StreamOpenRead(FileName: PChar): TImagingHandle; cdecl;
+begin
+ Result := FileName;
+end;
+
+function StreamOpenWrite(FileName: PChar): TImagingHandle; cdecl;
+begin
+ Result := FileName;
+end;
+
+procedure StreamClose(Handle: TImagingHandle); cdecl;
+begin
+end;
+
+function StreamEof(Handle: TImagingHandle): Boolean; cdecl;
+begin
+ Result := TStream(Handle).Position = TStream(Handle).Size;
+end;
+
+function StreamSeek(Handle: TImagingHandle; Offset: LongInt; Mode: TSeekMode):
+ LongInt; cdecl;
+begin
+ Result := TStream(Handle).Seek(Offset, LongInt(Mode));
+end;
+
+function StreamTell(Handle: TImagingHandle): LongInt; cdecl;
+begin
+ Result := TStream(Handle).Position;
+end;
+
+function StreamRead(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt):
+ LongInt; cdecl;
+begin
+ Result := TStream(Handle).Read(Buffer^, Count);
+end;
+
+function StreamWrite(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt):
+ LongInt; cdecl;
+begin
+ Result := TStream(Handle).Write(Buffer^, Count);
+end;
+
+{ Memory IO functions }
+
+function MemoryOpenRead(FileName: PChar): TImagingHandle; cdecl;
+begin
+ Result := FileName;
+end;
+
+function MemoryOpenWrite(FileName: PChar): TImagingHandle; cdecl;
+begin
+ Result := FileName;
+end;
+
+procedure MemoryClose(Handle: TImagingHandle); cdecl;
+begin
+end;
+
+function MemoryEof(Handle: TImagingHandle): Boolean; cdecl;
+begin
+ Result := PMemoryIORec(Handle).Position = PMemoryIORec(Handle).Size;
+end;
+
+function MemorySeek(Handle: TImagingHandle; Offset: LongInt; Mode: TSeekMode):
+ LongInt; cdecl;
+begin
+ Result := PMemoryIORec(Handle).Position;
+ case Mode of
+ smFromBeginning: Result := Offset;
+ smFromCurrent: Result := PMemoryIORec(Handle).Position + Offset;
+ smFromEnd: Result := PMemoryIORec(Handle).Size + Offset;
+ end;
+ //Result := ClampInt(Result, 0, PMemoryIORec(Handle).Size); don't do this - some file formats use it
+ PMemoryIORec(Handle).Position := Result;
+end;
+
+function MemoryTell(Handle: TImagingHandle): LongInt; cdecl;
+begin
+ Result := PMemoryIORec(Handle).Position;
+end;
+
+function MemoryRead(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt):
+ LongInt; cdecl;
+var
+ Rec: PMemoryIORec;
+begin
+ Rec := PMemoryIORec(Handle);
+ Result := Count;
+ if Rec.Position + Count > Rec.Size then
+ Result := Rec.Size - Rec.Position;
+ Move(Rec.Data[Rec.Position], Buffer^, Result);
+ Rec.Position := Rec.Position + Result;
+end;
+
+function MemoryWrite(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt):
+ LongInt; cdecl;
+var
+ Rec: PMemoryIORec;
+begin
+ Rec := PMemoryIORec(Handle);
+ Result := Count;
+ if Rec.Position + Count > Rec.Size then
+ Result := Rec.Size - Rec.Position;
+ Move(Buffer^, Rec.Data[Rec.Position], Result);
+ Rec.Position := Rec.Position + Result;
+end;
+
+{ Helper IO functions }
+
+function GetInputSize(IOFunctions: TIOFunctions; Handle: TImagingHandle): LongInt;
+var
+ OldPos: Int64;
+begin
+ OldPos := IOFunctions.Tell(Handle);
+ IOFunctions.Seek(Handle, 0, smFromEnd);
+ Result := IOFunctions.Tell(Handle);
+ IOFunctions.Seek(Handle, OldPos, smFromBeginning);
+end;
+
+function PrepareMemIO(Data: Pointer; Size: LongInt): TMemoryIORec;
+begin
+ Result.Data := Data;
+ Result.Position := 0;
+ Result.Size := Size;
+end;
+
+initialization
+ OriginalFileIO.OpenRead := FileOpenRead;
+ OriginalFileIO.OpenWrite := FileOpenWrite;
+ OriginalFileIO.Close := FileClose;
+ OriginalFileIO.Eof := FileEof;
+ OriginalFileIO.Seek := FileSeek;
+ OriginalFileIO.Tell := FileTell;
+ OriginalFileIO.Read := FileRead;
+ OriginalFileIO.Write := FileWrite;
+
+ StreamIO.OpenRead := StreamOpenRead;
+ StreamIO.OpenWrite := StreamOpenWrite;
+ StreamIO.Close := StreamClose;
+ StreamIO.Eof := StreamEof;
+ StreamIO.Seek := StreamSeek;
+ StreamIO.Tell := StreamTell;
+ StreamIO.Read := StreamRead;
+ StreamIO.Write := StreamWrite;
+
+ MemoryIO.OpenRead := MemoryOpenRead;
+ MemoryIO.OpenWrite := MemoryOpenWrite;
+ MemoryIO.Close := MemoryClose;
+ MemoryIO.Eof := MemoryEof;
+ MemoryIO.Seek := MemorySeek;
+ MemoryIO.Tell := MemoryTell;
+ MemoryIO.Read := MemoryRead;
+ MemoryIO.Write := MemoryWrite;
+
+ ResetFileIO;
+
+{
+ File Notes:
+
+ -- TODOS ----------------------------------------------------
+ - nothing now
+
+ -- 0.23 Changes/Bug Fixes -----------------------------------
+ - Added merge between buffered read-only and write-only file
+ stream adapters - TIFF saving needed both reading and writing.
+ - Fixed bug causing wrong value of TBufferedWriteFile.Size
+ (needed to add buffer pos to size).
+
+ -- 0.21 Changes/Bug Fixes -----------------------------------
+ - Removed TMemoryIORec.Written, use Position to get proper memory
+ position (Written didn't take Seeks into account).
+ - Added TBufferedReadFile and TBufferedWriteFile classes for
+ buffered file reading/writting. File IO functions now use these
+ classes resulting in performance increase mainly in file formats
+ that read/write many small chunks.
+ - Added fmShareDenyWrite to FileOpenRead. You can now read
+ files opened for reading by Imaging from other apps.
+ - Added GetInputSize and PrepareMemIO helper functions.
+
+ -- 0.19 Changes/Bug Fixes -----------------------------------
+ - changed behaviour of MemorySeek to act as TStream
+ based Seeks
+}
+end.
+
diff --git a/Imaging/ImagingJpeg.pas b/Imaging/ImagingJpeg.pas
index 0c831bd..35d2281 100644
--- a/Imaging/ImagingJpeg.pas
+++ b/Imaging/ImagingJpeg.pas
@@ -1,597 +1,597 @@
-{
- $Id: ImagingJpeg.pas 168 2009-08-22 18:50:21Z galfar $
- Vampyre Imaging Library
- by Marek Mauder
- http://imaginglib.sourceforge.net
-
- The contents of this file are used with permission, subject to the Mozilla
- Public License Version 1.1 (the "License"); you may not use this file except
- in compliance with the License. You may obtain a copy of the License at
- http://www.mozilla.org/MPL/MPL-1.1.html
-
- Software distributed under the License is distributed on an "AS IS" basis,
- WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
- the specific language governing rights and limitations under the License.
-
- Alternatively, the contents of this file may be used under the terms of the
- GNU Lesser General Public License (the "LGPL License"), in which case the
- provisions of the LGPL License are applicable instead of those above.
- If you wish to allow use of your version of this file only under the terms
- of the LGPL License and not to allow others to use your version of this file
- under the MPL, indicate your decision by deleting the provisions above and
- replace them with the notice and other provisions required by the LGPL
- License. If you do not delete the provisions above, a recipient may use
- your version of this file under either the MPL or the LGPL License.
-
- For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
-}
-
-{ This unit contains image format loader/saver for Jpeg images.}
-unit ImagingJpeg;
-
-{$I ImagingOptions.inc}
-
-{ You can choose which Pascal JpegLib implementation will be used.
- IMJPEGLIB is version bundled with Imaging which works with all supported
- compilers and platforms.
- PASJPEG is original JpegLib translation or version modified for FPC
- (and shipped with it). You can use PASJPEG if this version is already
- linked with another part of your program and you don't want to have
- two quite large almost the same libraries linked to your exe.
- This is the case with Lazarus applications for example.}
-
-{$DEFINE IMJPEGLIB}
-{ $DEFINE PASJPEG}
-
-{ Automatically use FPC's PasJpeg when compiling with Lazarus. But not when
- WINDOWS is defined. See http://galfar.vevb.net/imaging/smf/index.php/topic,90.0.html}
-{$IF Defined(LCL) and not Defined(WINDOWS)}
- {$UNDEF IMJPEGLIB}
- {$DEFINE PASJPEG}
-{$IFEND}
-
-interface
-
-uses
- SysUtils, ImagingTypes, Imaging, ImagingColors,
-{$IF Defined(IMJPEGLIB)}
- imjpeglib, imjmorecfg, imjcomapi, imjdapimin, imjdeferr, imjerror,
- imjdapistd, imjcapimin, imjcapistd, imjdmarker, imjcparam,
-{$ELSEIF Defined(PASJPEG)}
- jpeglib, jmorecfg, jcomapi, jdapimin, jdeferr, jerror,
- jdapistd, jcapimin, jcapistd, jdmarker, jcparam,
-{$IFEND}
- ImagingUtility;
-
-{$IF Defined(FPC) and Defined(PASJPEG)}
- { When using FPC's pasjpeg in FPC the channel order is BGR instead of RGB}
- {$DEFINE RGBSWAPPED}
-{$IFEND}
-
-type
- { Class for loading/saving Jpeg images. Supports load/save of
- 8 bit grayscale and 24 bit RGB images. Jpegs can be saved with optional
- progressive encoding.
- Based on IJG's JpegLib so doesn't support alpha channels and lossless
- coding.}
- TJpegFileFormat = class(TImageFileFormat)
- private
- FGrayScale: Boolean;
- protected
- FQuality: LongInt;
- FProgressive: LongBool;
- procedure SetJpegIO(const JpegIO: TIOFunctions); virtual;
- function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
- OnlyFirstLevel: Boolean): Boolean; override;
- function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
- Index: LongInt): Boolean; override;
- procedure ConvertToSupported(var Image: TImageData;
- const Info: TImageFormatInfo); override;
- public
- constructor Create; override;
- function TestFormat(Handle: TImagingHandle): Boolean; override;
- procedure CheckOptionsValidity; override;
- published
- { Controls Jpeg save compression quality. It is number in range 1..100.
- 1 means small/ugly file, 100 means large/nice file. Accessible trough
- ImagingJpegQuality option.}
- property Quality: LongInt read FQuality write FQuality;
- { If True Jpeg images are saved in progressive format. Accessible trough
- ImagingJpegProgressive option.}
- property Progressive: LongBool read FProgressive write FProgressive;
- end;
-
-implementation
-
-const
- SJpegFormatName = 'Joint Photographic Experts Group Image';
- SJpegMasks = '*.jpg,*.jpeg,*.jfif,*.jpe,*.jif';
- JpegSupportedFormats: TImageFormats = [ifR8G8B8, ifGray8];
- JpegDefaultQuality = 90;
- JpegDefaultProgressive = False;
-
-const
- { Jpeg file identifiers.}
- JpegMagic: TChar2 = #$FF#$D8;
- BufferSize = 16384;
-
-resourcestring
- SJpegError = 'JPEG Error';
-
-type
- TJpegContext = record
- case Byte of
- 0: (common: jpeg_common_struct);
- 1: (d: jpeg_decompress_struct);
- 2: (c: jpeg_compress_struct);
- end;
-
- TSourceMgr = record
- Pub: jpeg_source_mgr;
- Input: TImagingHandle;
- Buffer: JOCTETPTR;
- StartOfFile: Boolean;
- end;
- PSourceMgr = ^TSourceMgr;
-
- TDestMgr = record
- Pub: jpeg_destination_mgr;
- Output: TImagingHandle;
- Buffer: JOCTETPTR;
- end;
- PDestMgr = ^TDestMgr;
-
-var
- JIO: TIOFunctions;
- JpegErrorMgr: jpeg_error_mgr;
-
-{ Intenal unit jpeglib support functions }
-
-procedure JpegError(CInfo: j_common_ptr);
-var
- Buffer: string;
-begin
- { Create the message and raise exception }
- CInfo^.err^.format_message(CInfo, buffer);
- raise EImagingError.CreateFmt(SJPEGError + ' %d: ' + Buffer, [CInfo.err^.msg_code]);
-end;
-
-procedure OutputMessage(CurInfo: j_common_ptr);
-begin
-end;
-
-procedure ReleaseContext(var jc: TJpegContext);
-begin
- if jc.common.err = nil then
- Exit;
- jpeg_destroy(@jc.common);
- jpeg_destroy_decompress(@jc.d);
- jpeg_destroy_compress(@jc.c);
- jc.common.err := nil;
-end;
-
-procedure InitSource(cinfo: j_decompress_ptr);
-begin
- PSourceMgr(cinfo.src).StartOfFile := True;
-end;
-
-function FillInputBuffer(cinfo: j_decompress_ptr): Boolean;
-var
- NBytes: LongInt;
- Src: PSourceMgr;
-begin
- Src := PSourceMgr(cinfo.src);
- NBytes := JIO.Read(Src.Input, Src.Buffer, BufferSize);
-
- if NBytes <= 0 then
- begin
- PChar(Src.Buffer)[0] := #$FF;
- PChar(Src.Buffer)[1] := Char(JPEG_EOI);
- NBytes := 2;
- end;
- Src.Pub.next_input_byte := Src.Buffer;
- Src.Pub.bytes_in_buffer := NBytes;
- Src.StartOfFile := False;
- Result := True;
-end;
-
-procedure SkipInputData(cinfo: j_decompress_ptr; num_bytes: LongInt);
-var
- Src: PSourceMgr;
-begin
- Src := PSourceMgr(cinfo.src);
- if num_bytes > 0 then
- begin
- while num_bytes > Src.Pub.bytes_in_buffer do
- begin
- Dec(num_bytes, Src.Pub.bytes_in_buffer);
- FillInputBuffer(cinfo);
- end;
- Src.Pub.next_input_byte := @PByteArray(Src.Pub.next_input_byte)[num_bytes];
- //Inc(LongInt(Src.Pub.next_input_byte), num_bytes);
- Dec(Src.Pub.bytes_in_buffer, num_bytes);
- end;
-end;
-
-procedure TermSource(cinfo: j_decompress_ptr);
-var
- Src: PSourceMgr;
-begin
- Src := PSourceMgr(cinfo.src);
- // Move stream position back just after EOI marker so that more that one
- // JPEG images can be loaded from one stream
- JIO.Seek(Src.Input, -Src.Pub.bytes_in_buffer, smFromCurrent);
-end;
-
-procedure JpegStdioSrc(var cinfo: jpeg_decompress_struct; Handle:
- TImagingHandle);
-var
- Src: PSourceMgr;
-begin
- if cinfo.src = nil then
- begin
- cinfo.src := cinfo.mem.alloc_small(j_common_ptr(@cinfo), JPOOL_PERMANENT,
- SizeOf(TSourceMgr));
- Src := PSourceMgr(cinfo.src);
- Src.Buffer := cinfo.mem.alloc_small(j_common_ptr(@cinfo), JPOOL_PERMANENT,
- BufferSize * SizeOf(JOCTET));
- end;
- Src := PSourceMgr(cinfo.src);
- Src.Pub.init_source := InitSource;
- Src.Pub.fill_input_buffer := FillInputBuffer;
- Src.Pub.skip_input_data := SkipInputData;
- Src.Pub.resync_to_restart := jpeg_resync_to_restart;
- Src.Pub.term_source := TermSource;
- Src.Input := Handle;
- Src.Pub.bytes_in_buffer := 0;
- Src.Pub.next_input_byte := nil;
-end;
-
-procedure InitDest(cinfo: j_compress_ptr);
-var
- Dest: PDestMgr;
-begin
- Dest := PDestMgr(cinfo.dest);
- Dest.Pub.next_output_byte := Dest.Buffer;
- Dest.Pub.free_in_buffer := BufferSize;
-end;
-
-function EmptyOutput(cinfo: j_compress_ptr): Boolean;
-var
- Dest: PDestMgr;
-begin
- Dest := PDestMgr(cinfo.dest);
- JIO.Write(Dest.Output, Dest.Buffer, BufferSize);
- Dest.Pub.next_output_byte := Dest.Buffer;
- Dest.Pub.free_in_buffer := BufferSize;
- Result := True;
-end;
-
-procedure TermDest(cinfo: j_compress_ptr);
-var
- Dest: PDestMgr;
- DataCount: LongInt;
-begin
- Dest := PDestMgr(cinfo.dest);
- DataCount := BufferSize - Dest.Pub.free_in_buffer;
- if DataCount > 0 then
- JIO.Write(Dest.Output, Dest.Buffer, DataCount);
-end;
-
-procedure JpegStdioDest(var cinfo: jpeg_compress_struct; Handle:
- TImagingHandle);
-var
- Dest: PDestMgr;
-begin
- if cinfo.dest = nil then
- cinfo.dest := cinfo.mem.alloc_small(j_common_ptr(@cinfo),
- JPOOL_PERMANENT, SizeOf(TDestMgr));
- Dest := PDestMgr(cinfo.dest);
- Dest.Buffer := cinfo.mem.alloc_small(j_common_ptr(@cinfo), JPOOL_IMAGE,
- BufferSize * SIZEOF(JOCTET));
- Dest.Pub.init_destination := InitDest;
- Dest.Pub.empty_output_buffer := EmptyOutput;
- Dest.Pub.term_destination := TermDest;
- Dest.Output := Handle;
-end;
-
-procedure InitDecompressor(Handle: TImagingHandle; var jc: TJpegContext);
-begin
- FillChar(jc, sizeof(jc), 0);
- // Set standard error handlers and then override some
- jc.common.err := jpeg_std_error(JpegErrorMgr);
- jc.common.err.error_exit := JpegError;
- jc.common.err.output_message := OutputMessage;
-
- jpeg_CreateDecompress(@jc.d, JPEG_LIB_VERSION, sizeof(jc.d));
- JpegStdioSrc(jc.d, Handle);
- jpeg_read_header(@jc.d, True);
- jc.d.scale_num := 1;
- jc.d.scale_denom := 1;
- jc.d.do_block_smoothing := True;
- if jc.d.out_color_space = JCS_GRAYSCALE then
- begin
- jc.d.quantize_colors := True;
- jc.d.desired_number_of_colors := 256;
- end;
-end;
-
-procedure InitCompressor(Handle: TImagingHandle; var jc: TJpegContext;
- Saver: TJpegFileFormat);
-begin
- FillChar(jc, sizeof(jc), 0);
- // Set standard error handlers and then override some
- jc.common.err := jpeg_std_error(JpegErrorMgr);
- jc.common.err.error_exit := JpegError;
- jc.common.err.output_message := OutputMessage;
-
- jpeg_CreateCompress(@jc.c, JPEG_LIB_VERSION, sizeof(jc.c));
- JpegStdioDest(jc.c, Handle);
- if Saver.FGrayScale then
- jc.c.in_color_space := JCS_GRAYSCALE
- else
- jc.c.in_color_space := JCS_YCbCr;
- jpeg_set_defaults(@jc.c);
- jpeg_set_quality(@jc.c, Saver.FQuality, True);
- if Saver.FProgressive then
- jpeg_simple_progression(@jc.c);
-end;
-
-{ TJpegFileFormat class implementation }
-
-constructor TJpegFileFormat.Create;
-begin
- inherited Create;
- FName := SJpegFormatName;
- FCanLoad := True;
- FCanSave := True;
- FIsMultiImageFormat := False;
- FSupportedFormats := JpegSupportedFormats;
-
- FQuality := JpegDefaultQuality;
- FProgressive := JpegDefaultProgressive;
-
- AddMasks(SJpegMasks);
- RegisterOption(ImagingJpegQuality, @FQuality);
- RegisterOption(ImagingJpegProgressive, @FProgressive);
-end;
-
-procedure TJpegFileFormat.CheckOptionsValidity;
-begin
- // Check if option values are valid
- if not (FQuality in [1..100]) then
- FQuality := JpegDefaultQuality;
-end;
-
-function TJpegFileFormat.LoadData(Handle: TImagingHandle;
- var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
-var
- PtrInc, LinesPerCall, LinesRead, I: Integer;
- Dest: PByte;
- jc: TJpegContext;
- Info: TImageFormatInfo;
- Col32: PColor32Rec;
-{$IFDEF RGBSWAPPED}
- Pix: PColor24Rec;
-{$ENDIF}
-begin
- // Copy IO functions to global var used in JpegLib callbacks
- Result := False;
- SetJpegIO(GetIO);
- SetLength(Images, 1);
-
- with JIO, Images[0] do
- try
- InitDecompressor(Handle, jc);
- case jc.d.out_color_space of
- JCS_GRAYSCALE: Format := ifGray8;
- JCS_RGB: Format := ifR8G8B8;
- JCS_CMYK: Format := ifA8R8G8B8;
- else
- Exit;
- end;
- NewImage(jc.d.image_width, jc.d.image_height, Format, Images[0]);
- jpeg_start_decompress(@jc.d);
- GetImageFormatInfo(Format, Info);
- PtrInc := Width * Info.BytesPerPixel;
- LinesPerCall := 1;
- Dest := Bits;
-
- while jc.d.output_scanline < jc.d.output_height do
- begin
- LinesRead := jpeg_read_scanlines(@jc.d, @Dest, LinesPerCall);
- {$IFDEF RGBSWAPPED}
- if Format = ifR8G8B8 then
- begin
- Pix := PColor24Rec(Dest);
- for I := 0 to Width - 1 do
- begin
- SwapValues(Pix.R, Pix.B);
- Inc(Pix);
- end;
- end;
- {$ENDIF}
- Inc(Dest, PtrInc * LinesRead);
- end;
-
- if jc.d.out_color_space = JCS_CMYK then
- begin
- Col32 := Bits;
- // Translate from CMYK to RGB
- for I := 0 to Width * Height - 1 do
- begin
- CMYKToRGB(255 - Col32.B, 255 - Col32.G, 255 - Col32.R, 255 - Col32.A,
- Col32.R, Col32.G, Col32.B);
- Col32.A := 255;
- Inc(Col32);
- end;
- end;
-
- jpeg_finish_output(@jc.d);
- jpeg_finish_decompress(@jc.d);
- Result := True;
- finally
- ReleaseContext(jc);
- end;
-end;
-
-function TJpegFileFormat.SaveData(Handle: TImagingHandle;
- const Images: TDynImageDataArray; Index: LongInt): Boolean;
-var
- PtrInc, LinesWritten: LongInt;
- Src, Line: PByte;
- jc: TJpegContext;
- ImageToSave: TImageData;
- Info: TImageFormatInfo;
- MustBeFreed: Boolean;
-{$IFDEF RGBSWAPPED}
- I: LongInt;
- Pix: PColor24Rec;
-{$ENDIF}
-begin
- Result := False;
- // Copy IO functions to global var used in JpegLib callbacks
- SetJpegIO(GetIO);
- // Makes image to save compatible with Jpeg saving capabilities
- if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then
- with JIO, ImageToSave do
- try
- GetImageFormatInfo(Format, Info);
- FGrayScale := Format = ifGray8;
- InitCompressor(Handle, jc, Self);
- jc.c.image_width := Width;
- jc.c.image_height := Height;
- if FGrayScale then
- begin
- jc.c.input_components := 1;
- jc.c.in_color_space := JCS_GRAYSCALE;
- end
- else
- begin
- jc.c.input_components := 3;
- jc.c.in_color_space := JCS_RGB;
- end;
-
- PtrInc := Width * Info.BytesPerPixel;
- Src := Bits;
-
- {$IFDEF RGBSWAPPED}
- GetMem(Line, PtrInc);
- {$ENDIF}
-
- jpeg_start_compress(@jc.c, True);
- while (jc.c.next_scanline < jc.c.image_height) do
- begin
- {$IFDEF RGBSWAPPED}
- if Format = ifR8G8B8 then
- begin
- Move(Src^, Line^, PtrInc);
- Pix := PColor24Rec(Line);
- for I := 0 to Width - 1 do
- begin
- SwapValues(Pix.R, Pix.B);
- Inc(Pix, 1);
- end;
- end;
- {$ELSE}
- Line := Src;
- {$ENDIF}
-
- LinesWritten := jpeg_write_scanlines(@jc.c, @Line, 1);
- Inc(Src, PtrInc * LinesWritten);
- end;
-
- jpeg_finish_compress(@jc.c);
- Result := True;
- finally
- ReleaseContext(jc);
- if MustBeFreed then
- FreeImage(ImageToSave);
- {$IFDEF RGBSWAPPED}
- FreeMem(Line);
- {$ENDIF}
- end;
-end;
-
-procedure TJpegFileFormat.ConvertToSupported(var Image: TImageData;
- const Info: TImageFormatInfo);
-begin
- if Info.HasGrayChannel then
- ConvertImage(Image, ifGray8)
- else
- ConvertImage(Image, ifR8G8B8);
-end;
-
-function TJpegFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
-var
- ReadCount: LongInt;
- ID: array[0..9] of AnsiChar;
-begin
- Result := False;
- if Handle <> nil then
- with GetIO do
- begin
- FillChar(ID, SizeOf(ID), 0);
- ReadCount := Read(Handle, @ID, SizeOf(ID));
- Seek(Handle, -ReadCount, smFromCurrent);
- Result := (ReadCount = SizeOf(ID)) and
- CompareMem(@ID, @JpegMagic, SizeOf(JpegMagic));
- end;
-end;
-
-procedure TJpegFileFormat.SetJpegIO(const JpegIO: TIOFunctions);
-begin
- JIO := JpegIO;
-end;
-
-initialization
- RegisterImageFileFormat(TJpegFileFormat);
-
-{
- File Notes:
-
- -- TODOS ----------------------------------------------------
- - nothing now
-
- -- 0.26.3 Changes/Bug Fixes ---------------------------------
- - Changed the Jpeg error manager, messages were not properly formated.
-
- -- 0.26.1 Changes/Bug Fixes ---------------------------------
- - Fixed wrong color space setting in InitCompressor.
- - Fixed problem with progressive Jpegs in FPC (modified JpegLib,
- can't use FPC's PasJpeg in Windows).
-
- -- 0.25.0 Changes/Bug Fixes ---------------------------------
- - FPC's PasJpeg wasn't really used in last version, fixed.
-
- -- 0.24.1 Changes/Bug Fixes ---------------------------------
- - Fixed loading of CMYK jpeg images. Could cause heap corruption
- and loaded image looked wrong.
-
- -- 0.23 Changes/Bug Fixes -----------------------------------
- - Removed JFIF/EXIF detection from TestFormat. Found JPEGs
- with different headers (Lavc) which weren't recognized.
-
- -- 0.21 Changes/Bug Fixes -----------------------------------
- - MakeCompatible method moved to base class, put ConvertToSupported here.
- GetSupportedFormats removed, it is now set in constructor.
- - Made public properties for options registered to SetOption/GetOption
- functions.
- - Changed extensions to filename masks.
- - Changed SaveData, LoadData, and MakeCompatible methods according
- to changes in base class in Imaging unit.
- - Changes in TestFormat, now reads JFIF and EXIF signatures too.
-
- -- 0.19 Changes/Bug Fixes -----------------------------------
- - input position is now set correctly to the end of the image
- after loading is done. Loading of sequence of JPEG files stored in
- single stream works now
- - when loading and saving images in FPC with PASJPEG read and
- blue channels are swapped to have the same chanel order as IMJPEGLIB
- - you can now choose between IMJPEGLIB and PASJPEG implementations
-
- -- 0.17 Changes/Bug Fixes -----------------------------------
- - added SetJpegIO method which is used by JNG image format
-}
-end.
-
+{
+ $Id: ImagingJpeg.pas 168 2009-08-22 18:50:21Z galfar $
+ Vampyre Imaging Library
+ by Marek Mauder
+ http://imaginglib.sourceforge.net
+
+ The contents of this file are used with permission, subject to the Mozilla
+ Public License Version 1.1 (the "License"); you may not use this file except
+ in compliance with the License. You may obtain a copy of the License at
+ http://www.mozilla.org/MPL/MPL-1.1.html
+
+ Software distributed under the License is distributed on an "AS IS" basis,
+ WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
+ the specific language governing rights and limitations under the License.
+
+ Alternatively, the contents of this file may be used under the terms of the
+ GNU Lesser General Public License (the "LGPL License"), in which case the
+ provisions of the LGPL License are applicable instead of those above.
+ If you wish to allow use of your version of this file only under the terms
+ of the LGPL License and not to allow others to use your version of this file
+ under the MPL, indicate your decision by deleting the provisions above and
+ replace them with the notice and other provisions required by the LGPL
+ License. If you do not delete the provisions above, a recipient may use
+ your version of this file under either the MPL or the LGPL License.
+
+ For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
+}
+
+{ This unit contains image format loader/saver for Jpeg images.}
+unit ImagingJpeg;
+
+{$I ImagingOptions.inc}
+
+{ You can choose which Pascal JpegLib implementation will be used.
+ IMJPEGLIB is version bundled with Imaging which works with all supported
+ compilers and platforms.
+ PASJPEG is original JpegLib translation or version modified for FPC
+ (and shipped with it). You can use PASJPEG if this version is already
+ linked with another part of your program and you don't want to have
+ two quite large almost the same libraries linked to your exe.
+ This is the case with Lazarus applications for example.}
+
+{$DEFINE IMJPEGLIB}
+{ $DEFINE PASJPEG}
+
+{ Automatically use FPC's PasJpeg when compiling with Lazarus. But not when
+ WINDOWS is defined. See http://galfar.vevb.net/imaging/smf/index.php/topic,90.0.html}
+{$IF Defined(LCL) and not Defined(WINDOWS)}
+ {$UNDEF IMJPEGLIB}
+ {$DEFINE PASJPEG}
+{$IFEND}
+
+interface
+
+uses
+ SysUtils, ImagingTypes, Imaging, ImagingColors,
+{$IF Defined(IMJPEGLIB)}
+ imjpeglib, imjmorecfg, imjcomapi, imjdapimin, imjdeferr, imjerror,
+ imjdapistd, imjcapimin, imjcapistd, imjdmarker, imjcparam,
+{$ELSEIF Defined(PASJPEG)}
+ jpeglib, jmorecfg, jcomapi, jdapimin, jdeferr, jerror,
+ jdapistd, jcapimin, jcapistd, jdmarker, jcparam,
+{$IFEND}
+ ImagingUtility;
+
+{$IF Defined(FPC) and Defined(PASJPEG)}
+ { When using FPC's pasjpeg in FPC the channel order is BGR instead of RGB}
+ {$DEFINE RGBSWAPPED}
+{$IFEND}
+
+type
+ { Class for loading/saving Jpeg images. Supports load/save of
+ 8 bit grayscale and 24 bit RGB images. Jpegs can be saved with optional
+ progressive encoding.
+ Based on IJG's JpegLib so doesn't support alpha channels and lossless
+ coding.}
+ TJpegFileFormat = class(TImageFileFormat)
+ private
+ FGrayScale: Boolean;
+ protected
+ FQuality: LongInt;
+ FProgressive: LongBool;
+ procedure SetJpegIO(const JpegIO: TIOFunctions); virtual;
+ function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
+ OnlyFirstLevel: Boolean): Boolean; override;
+ function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
+ Index: LongInt): Boolean; override;
+ procedure ConvertToSupported(var Image: TImageData;
+ const Info: TImageFormatInfo); override;
+ public
+ constructor Create; override;
+ function TestFormat(Handle: TImagingHandle): Boolean; override;
+ procedure CheckOptionsValidity; override;
+ published
+ { Controls Jpeg save compression quality. It is number in range 1..100.
+ 1 means small/ugly file, 100 means large/nice file. Accessible trough
+ ImagingJpegQuality option.}
+ property Quality: LongInt read FQuality write FQuality;
+ { If True Jpeg images are saved in progressive format. Accessible trough
+ ImagingJpegProgressive option.}
+ property Progressive: LongBool read FProgressive write FProgressive;
+ end;
+
+implementation
+
+const
+ SJpegFormatName = 'Joint Photographic Experts Group Image';
+ SJpegMasks = '*.jpg,*.jpeg,*.jfif,*.jpe,*.jif';
+ JpegSupportedFormats: TImageFormats = [ifR8G8B8, ifGray8];
+ JpegDefaultQuality = 90;
+ JpegDefaultProgressive = False;
+
+const
+ { Jpeg file identifiers.}
+ JpegMagic: TChar2 = #$FF#$D8;
+ BufferSize = 16384;
+
+resourcestring
+ SJpegError = 'JPEG Error';
+
+type
+ TJpegContext = record
+ case Byte of
+ 0: (common: jpeg_common_struct);
+ 1: (d: jpeg_decompress_struct);
+ 2: (c: jpeg_compress_struct);
+ end;
+
+ TSourceMgr = record
+ Pub: jpeg_source_mgr;
+ Input: TImagingHandle;
+ Buffer: JOCTETPTR;
+ StartOfFile: Boolean;
+ end;
+ PSourceMgr = ^TSourceMgr;
+
+ TDestMgr = record
+ Pub: jpeg_destination_mgr;
+ Output: TImagingHandle;
+ Buffer: JOCTETPTR;
+ end;
+ PDestMgr = ^TDestMgr;
+
+var
+ JIO: TIOFunctions;
+ JpegErrorMgr: jpeg_error_mgr;
+
+{ Intenal unit jpeglib support functions }
+
+procedure JpegError(CInfo: j_common_ptr);
+var
+ Buffer: string;
+begin
+ { Create the message and raise exception }
+ CInfo^.err^.format_message(CInfo, buffer);
+ raise EImagingError.CreateFmt(SJPEGError + ' %d: ' + Buffer, [CInfo.err^.msg_code]);
+end;
+
+procedure OutputMessage(CurInfo: j_common_ptr);
+begin
+end;
+
+procedure ReleaseContext(var jc: TJpegContext);
+begin
+ if jc.common.err = nil then
+ Exit;
+ jpeg_destroy(@jc.common);
+ jpeg_destroy_decompress(@jc.d);
+ jpeg_destroy_compress(@jc.c);
+ jc.common.err := nil;
+end;
+
+procedure InitSource(cinfo: j_decompress_ptr);
+begin
+ PSourceMgr(cinfo.src).StartOfFile := True;
+end;
+
+function FillInputBuffer(cinfo: j_decompress_ptr): Boolean;
+var
+ NBytes: LongInt;
+ Src: PSourceMgr;
+begin
+ Src := PSourceMgr(cinfo.src);
+ NBytes := JIO.Read(Src.Input, Src.Buffer, BufferSize);
+
+ if NBytes <= 0 then
+ begin
+ PChar(Src.Buffer)[0] := #$FF;
+ PChar(Src.Buffer)[1] := Char(JPEG_EOI);
+ NBytes := 2;
+ end;
+ Src.Pub.next_input_byte := Src.Buffer;
+ Src.Pub.bytes_in_buffer := NBytes;
+ Src.StartOfFile := False;
+ Result := True;
+end;
+
+procedure SkipInputData(cinfo: j_decompress_ptr; num_bytes: LongInt);
+var
+ Src: PSourceMgr;
+begin
+ Src := PSourceMgr(cinfo.src);
+ if num_bytes > 0 then
+ begin
+ while num_bytes > Src.Pub.bytes_in_buffer do
+ begin
+ Dec(num_bytes, Src.Pub.bytes_in_buffer);
+ FillInputBuffer(cinfo);
+ end;
+ Src.Pub.next_input_byte := @PByteArray(Src.Pub.next_input_byte)[num_bytes];
+ //Inc(LongInt(Src.Pub.next_input_byte), num_bytes);
+ Dec(Src.Pub.bytes_in_buffer, num_bytes);
+ end;
+end;
+
+procedure TermSource(cinfo: j_decompress_ptr);
+var
+ Src: PSourceMgr;
+begin
+ Src := PSourceMgr(cinfo.src);
+ // Move stream position back just after EOI marker so that more that one
+ // JPEG images can be loaded from one stream
+ JIO.Seek(Src.Input, -Src.Pub.bytes_in_buffer, smFromCurrent);
+end;
+
+procedure JpegStdioSrc(var cinfo: jpeg_decompress_struct; Handle:
+ TImagingHandle);
+var
+ Src: PSourceMgr;
+begin
+ if cinfo.src = nil then
+ begin
+ cinfo.src := cinfo.mem.alloc_small(j_common_ptr(@cinfo), JPOOL_PERMANENT,
+ SizeOf(TSourceMgr));
+ Src := PSourceMgr(cinfo.src);
+ Src.Buffer := cinfo.mem.alloc_small(j_common_ptr(@cinfo), JPOOL_PERMANENT,
+ BufferSize * SizeOf(JOCTET));
+ end;
+ Src := PSourceMgr(cinfo.src);
+ Src.Pub.init_source := InitSource;
+ Src.Pub.fill_input_buffer := FillInputBuffer;
+ Src.Pub.skip_input_data := SkipInputData;
+ Src.Pub.resync_to_restart := jpeg_resync_to_restart;
+ Src.Pub.term_source := TermSource;
+ Src.Input := Handle;
+ Src.Pub.bytes_in_buffer := 0;
+ Src.Pub.next_input_byte := nil;
+end;
+
+procedure InitDest(cinfo: j_compress_ptr);
+var
+ Dest: PDestMgr;
+begin
+ Dest := PDestMgr(cinfo.dest);
+ Dest.Pub.next_output_byte := Dest.Buffer;
+ Dest.Pub.free_in_buffer := BufferSize;
+end;
+
+function EmptyOutput(cinfo: j_compress_ptr): Boolean;
+var
+ Dest: PDestMgr;
+begin
+ Dest := PDestMgr(cinfo.dest);
+ JIO.Write(Dest.Output, Dest.Buffer, BufferSize);
+ Dest.Pub.next_output_byte := Dest.Buffer;
+ Dest.Pub.free_in_buffer := BufferSize;
+ Result := True;
+end;
+
+procedure TermDest(cinfo: j_compress_ptr);
+var
+ Dest: PDestMgr;
+ DataCount: LongInt;
+begin
+ Dest := PDestMgr(cinfo.dest);
+ DataCount := BufferSize - Dest.Pub.free_in_buffer;
+ if DataCount > 0 then
+ JIO.Write(Dest.Output, Dest.Buffer, DataCount);
+end;
+
+procedure JpegStdioDest(var cinfo: jpeg_compress_struct; Handle:
+ TImagingHandle);
+var
+ Dest: PDestMgr;
+begin
+ if cinfo.dest = nil then
+ cinfo.dest := cinfo.mem.alloc_small(j_common_ptr(@cinfo),
+ JPOOL_PERMANENT, SizeOf(TDestMgr));
+ Dest := PDestMgr(cinfo.dest);
+ Dest.Buffer := cinfo.mem.alloc_small(j_common_ptr(@cinfo), JPOOL_IMAGE,
+ BufferSize * SIZEOF(JOCTET));
+ Dest.Pub.init_destination := InitDest;
+ Dest.Pub.empty_output_buffer := EmptyOutput;
+ Dest.Pub.term_destination := TermDest;
+ Dest.Output := Handle;
+end;
+
+procedure InitDecompressor(Handle: TImagingHandle; var jc: TJpegContext);
+begin
+ FillChar(jc, sizeof(jc), 0);
+ // Set standard error handlers and then override some
+ jc.common.err := jpeg_std_error(JpegErrorMgr);
+ jc.common.err.error_exit := JpegError;
+ jc.common.err.output_message := OutputMessage;
+
+ jpeg_CreateDecompress(@jc.d, JPEG_LIB_VERSION, sizeof(jc.d));
+ JpegStdioSrc(jc.d, Handle);
+ jpeg_read_header(@jc.d, True);
+ jc.d.scale_num := 1;
+ jc.d.scale_denom := 1;
+ jc.d.do_block_smoothing := True;
+ if jc.d.out_color_space = JCS_GRAYSCALE then
+ begin
+ jc.d.quantize_colors := True;
+ jc.d.desired_number_of_colors := 256;
+ end;
+end;
+
+procedure InitCompressor(Handle: TImagingHandle; var jc: TJpegContext;
+ Saver: TJpegFileFormat);
+begin
+ FillChar(jc, sizeof(jc), 0);
+ // Set standard error handlers and then override some
+ jc.common.err := jpeg_std_error(JpegErrorMgr);
+ jc.common.err.error_exit := JpegError;
+ jc.common.err.output_message := OutputMessage;
+
+ jpeg_CreateCompress(@jc.c, JPEG_LIB_VERSION, sizeof(jc.c));
+ JpegStdioDest(jc.c, Handle);
+ if Saver.FGrayScale then
+ jc.c.in_color_space := JCS_GRAYSCALE
+ else
+ jc.c.in_color_space := JCS_YCbCr;
+ jpeg_set_defaults(@jc.c);
+ jpeg_set_quality(@jc.c, Saver.FQuality, True);
+ if Saver.FProgressive then
+ jpeg_simple_progression(@jc.c);
+end;
+
+{ TJpegFileFormat class implementation }
+
+constructor TJpegFileFormat.Create;
+begin
+ inherited Create;
+ FName := SJpegFormatName;
+ FCanLoad := True;
+ FCanSave := True;
+ FIsMultiImageFormat := False;
+ FSupportedFormats := JpegSupportedFormats;
+
+ FQuality := JpegDefaultQuality;
+ FProgressive := JpegDefaultProgressive;
+
+ AddMasks(SJpegMasks);
+ RegisterOption(ImagingJpegQuality, @FQuality);
+ RegisterOption(ImagingJpegProgressive, @FProgressive);
+end;
+
+procedure TJpegFileFormat.CheckOptionsValidity;
+begin
+ // Check if option values are valid
+ if not (FQuality in [1..100]) then
+ FQuality := JpegDefaultQuality;
+end;
+
+function TJpegFileFormat.LoadData(Handle: TImagingHandle;
+ var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
+var
+ PtrInc, LinesPerCall, LinesRead, I: Integer;
+ Dest: PByte;
+ jc: TJpegContext;
+ Info: TImageFormatInfo;
+ Col32: PColor32Rec;
+{$IFDEF RGBSWAPPED}
+ Pix: PColor24Rec;
+{$ENDIF}
+begin
+ // Copy IO functions to global var used in JpegLib callbacks
+ Result := False;
+ SetJpegIO(GetIO);
+ SetLength(Images, 1);
+
+ with JIO, Images[0] do
+ try
+ InitDecompressor(Handle, jc);
+ case jc.d.out_color_space of
+ JCS_GRAYSCALE: Format := ifGray8;
+ JCS_RGB: Format := ifR8G8B8;
+ JCS_CMYK: Format := ifA8R8G8B8;
+ else
+ Exit;
+ end;
+ NewImage(jc.d.image_width, jc.d.image_height, Format, Images[0]);
+ jpeg_start_decompress(@jc.d);
+ GetImageFormatInfo(Format, Info);
+ PtrInc := Width * Info.BytesPerPixel;
+ LinesPerCall := 1;
+ Dest := Bits;
+
+ while jc.d.output_scanline < jc.d.output_height do
+ begin
+ LinesRead := jpeg_read_scanlines(@jc.d, @Dest, LinesPerCall);
+ {$IFDEF RGBSWAPPED}
+ if Format = ifR8G8B8 then
+ begin
+ Pix := PColor24Rec(Dest);
+ for I := 0 to Width - 1 do
+ begin
+ SwapValues(Pix.R, Pix.B);
+ Inc(Pix);
+ end;
+ end;
+ {$ENDIF}
+ Inc(Dest, PtrInc * LinesRead);
+ end;
+
+ if jc.d.out_color_space = JCS_CMYK then
+ begin
+ Col32 := Bits;
+ // Translate from CMYK to RGB
+ for I := 0 to Width * Height - 1 do
+ begin
+ CMYKToRGB(255 - Col32.B, 255 - Col32.G, 255 - Col32.R, 255 - Col32.A,
+ Col32.R, Col32.G, Col32.B);
+ Col32.A := 255;
+ Inc(Col32);
+ end;
+ end;
+
+ jpeg_finish_output(@jc.d);
+ jpeg_finish_decompress(@jc.d);
+ Result := True;
+ finally
+ ReleaseContext(jc);
+ end;
+end;
+
+function TJpegFileFormat.SaveData(Handle: TImagingHandle;
+ const Images: TDynImageDataArray; Index: LongInt): Boolean;
+var
+ PtrInc, LinesWritten: LongInt;
+ Src, Line: PByte;
+ jc: TJpegContext;
+ ImageToSave: TImageData;
+ Info: TImageFormatInfo;
+ MustBeFreed: Boolean;
+{$IFDEF RGBSWAPPED}
+ I: LongInt;
+ Pix: PColor24Rec;
+{$ENDIF}
+begin
+ Result := False;
+ // Copy IO functions to global var used in JpegLib callbacks
+ SetJpegIO(GetIO);
+ // Makes image to save compatible with Jpeg saving capabilities
+ if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then
+ with JIO, ImageToSave do
+ try
+ GetImageFormatInfo(Format, Info);
+ FGrayScale := Format = ifGray8;
+ InitCompressor(Handle, jc, Self);
+ jc.c.image_width := Width;
+ jc.c.image_height := Height;
+ if FGrayScale then
+ begin
+ jc.c.input_components := 1;
+ jc.c.in_color_space := JCS_GRAYSCALE;
+ end
+ else
+ begin
+ jc.c.input_components := 3;
+ jc.c.in_color_space := JCS_RGB;
+ end;
+
+ PtrInc := Width * Info.BytesPerPixel;
+ Src := Bits;
+
+ {$IFDEF RGBSWAPPED}
+ GetMem(Line, PtrInc);
+ {$ENDIF}
+
+ jpeg_start_compress(@jc.c, True);
+ while (jc.c.next_scanline < jc.c.image_height) do
+ begin
+ {$IFDEF RGBSWAPPED}
+ if Format = ifR8G8B8 then
+ begin
+ Move(Src^, Line^, PtrInc);
+ Pix := PColor24Rec(Line);
+ for I := 0 to Width - 1 do
+ begin
+ SwapValues(Pix.R, Pix.B);
+ Inc(Pix, 1);
+ end;
+ end;
+ {$ELSE}
+ Line := Src;
+ {$ENDIF}
+
+ LinesWritten := jpeg_write_scanlines(@jc.c, @Line, 1);
+ Inc(Src, PtrInc * LinesWritten);
+ end;
+
+ jpeg_finish_compress(@jc.c);
+ Result := True;
+ finally
+ ReleaseContext(jc);
+ if MustBeFreed then
+ FreeImage(ImageToSave);
+ {$IFDEF RGBSWAPPED}
+ FreeMem(Line);
+ {$ENDIF}
+ end;
+end;
+
+procedure TJpegFileFormat.ConvertToSupported(var Image: TImageData;
+ const Info: TImageFormatInfo);
+begin
+ if Info.HasGrayChannel then
+ ConvertImage(Image, ifGray8)
+ else
+ ConvertImage(Image, ifR8G8B8);
+end;
+
+function TJpegFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
+var
+ ReadCount: LongInt;
+ ID: array[0..9] of AnsiChar;
+begin
+ Result := False;
+ if Handle <> nil then
+ with GetIO do
+ begin
+ FillChar(ID, SizeOf(ID), 0);
+ ReadCount := Read(Handle, @ID, SizeOf(ID));
+ Seek(Handle, -ReadCount, smFromCurrent);
+ Result := (ReadCount = SizeOf(ID)) and
+ CompareMem(@ID, @JpegMagic, SizeOf(JpegMagic));
+ end;
+end;
+
+procedure TJpegFileFormat.SetJpegIO(const JpegIO: TIOFunctions);
+begin
+ JIO := JpegIO;
+end;
+
+initialization
+ RegisterImageFileFormat(TJpegFileFormat);
+
+{
+ File Notes:
+
+ -- TODOS ----------------------------------------------------
+ - nothing now
+
+ -- 0.26.3 Changes/Bug Fixes ---------------------------------
+ - Changed the Jpeg error manager, messages were not properly formated.
+
+ -- 0.26.1 Changes/Bug Fixes ---------------------------------
+ - Fixed wrong color space setting in InitCompressor.
+ - Fixed problem with progressive Jpegs in FPC (modified JpegLib,
+ can't use FPC's PasJpeg in Windows).
+
+ -- 0.25.0 Changes/Bug Fixes ---------------------------------
+ - FPC's PasJpeg wasn't really used in last version, fixed.
+
+ -- 0.24.1 Changes/Bug Fixes ---------------------------------
+ - Fixed loading of CMYK jpeg images. Could cause heap corruption
+ and loaded image looked wrong.
+
+ -- 0.23 Changes/Bug Fixes -----------------------------------
+ - Removed JFIF/EXIF detection from TestFormat. Found JPEGs
+ with different headers (Lavc) which weren't recognized.
+
+ -- 0.21 Changes/Bug Fixes -----------------------------------
+ - MakeCompatible method moved to base class, put ConvertToSupported here.
+ GetSupportedFormats removed, it is now set in constructor.
+ - Made public properties for options registered to SetOption/GetOption
+ functions.
+ - Changed extensions to filename masks.
+ - Changed SaveData, LoadData, and MakeCompatible methods according
+ to changes in base class in Imaging unit.
+ - Changes in TestFormat, now reads JFIF and EXIF signatures too.
+
+ -- 0.19 Changes/Bug Fixes -----------------------------------
+ - input position is now set correctly to the end of the image
+ after loading is done. Loading of sequence of JPEG files stored in
+ single stream works now
+ - when loading and saving images in FPC with PASJPEG read and
+ blue channels are swapped to have the same chanel order as IMJPEGLIB
+ - you can now choose between IMJPEGLIB and PASJPEG implementations
+
+ -- 0.17 Changes/Bug Fixes -----------------------------------
+ - added SetJpegIO method which is used by JNG image format
+}
+end.
+
diff --git a/Imaging/ImagingNetworkGraphics.pas b/Imaging/ImagingNetworkGraphics.pas
index cfb7763..5b7dc02 100644
--- a/Imaging/ImagingNetworkGraphics.pas
+++ b/Imaging/ImagingNetworkGraphics.pas
@@ -1,2573 +1,2573 @@
-{
- $Id: ImagingNetworkGraphics.pas 171 2009-09-02 01:34:19Z galfar $
- Vampyre Imaging Library
- by Marek Mauder
- http://imaginglib.sourceforge.net
-
- The contents of this file are used with permission, subject to the Mozilla
- Public License Version 1.1 (the "License"); you may not use this file except
- in compliance with the License. You may obtain a copy of the License at
- http://www.mozilla.org/MPL/MPL-1.1.html
-
- Software distributed under the License is distributed on an "AS IS" basis,
- WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
- the specific language governing rights and limitations under the License.
-
- Alternatively, the contents of this file may be used under the terms of the
- GNU Lesser General Public License (the "LGPL License"), in which case the
- provisions of the LGPL License are applicable instead of those above.
- If you wish to allow use of your version of this file only under the terms
- of the LGPL License and not to allow others to use your version of this file
- under the MPL, indicate your decision by deleting the provisions above and
- replace them with the notice and other provisions required by the LGPL
- License. If you do not delete the provisions above, a recipient may use
- your version of this file under either the MPL or the LGPL License.
-
- For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
-}
-
-{ This unit contains image format loaders/savers for Network Graphics image
- file formats PNG, MNG, and JNG.}
-unit ImagingNetworkGraphics;
-
-interface
-
-{$I ImagingOptions.inc}
-
-{ If MN support is enabled we must make sure PNG and JNG are enabled too.}
-{$IFNDEF DONT_LINK_MNG}
- {$UNDEF DONT_LINK_PNG}
- {$UNDEF DONT_LINK_JNG}
-{$ENDIF}
-
-uses
- Types, SysUtils, Classes, ImagingTypes, Imaging, ImagingUtility, ImagingFormats, dzlib;
-
-type
- { Basic class for Network Graphics file formats loaders/savers.}
- TNetworkGraphicsFileFormat = class(TImageFileFormat)
- protected
- FSignature: TChar8;
- FPreFilter: LongInt;
- FCompressLevel: LongInt;
- FLossyCompression: LongBool;
- FLossyAlpha: LongBool;
- FQuality: LongInt;
- FProgressive: LongBool;
- function GetSupportedFormats: TImageFormats; override;
- procedure ConvertToSupported(var Image: TImageData;
- const Info: TImageFormatInfo); override;
- public
- constructor Create; override;
- function TestFormat(Handle: TImagingHandle): Boolean; override;
- procedure CheckOptionsValidity; override;
- published
- { Sets precompression filter used when saving images with lossless compression.
- Allowed values are: 0 (none), 1 (sub), 2 (up), 3 (average), 4 (paeth),
- 5 (use 0 for indexed/gray images and 4 for RGB/ARGB images),
- 6 (adaptive filtering - use best filter for each scanline - very slow).
- Note that filters 3 and 4 are much slower than filters 1 and 2.
- Default value is 5.}
- property PreFilter: LongInt read FPreFilter write FPreFilter;
- { Sets ZLib compression level used when saving images with lossless compression.
- Allowed values are in range 0 (no compresstion) to 9 (best compression).
- Default value is 5.}
- property CompressLevel: LongInt read FCompressLevel write FCompressLevel;
- { Specifies whether MNG animation frames are saved with lossy or lossless
- compression. Lossless frames are saved as PNG images and lossy frames are
- saved as JNG images. Allowed values are 0 (False) and 1 (True).
- Default value is 0.}
- property LossyCompression: LongBool read FLossyCompression write FLossyCompression;
- { Defines whether alpha channel of lossy MNG frames or JNG images
- is lossy compressed too. Allowed values are 0 (False) and 1 (True).
- Default value is 0.}
- property LossyAlpha: LongBool read FLossyAlpha write FLossyAlpha;
- { Specifies compression quality used when saving lossy MNG frames or JNG images.
- For details look at ImagingJpegQuality option.}
- property Quality: LongInt read FQuality write FQuality;
- { Specifies whether images are saved in progressive format when saving lossy
- MNG frames or JNG images. For details look at ImagingJpegProgressive.}
- property Progressive: LongBool read FProgressive write FProgressive;
- end;
-
- { Class for loading Portable Network Graphics Images.
- Loads all types of this image format (all images in png test suite)
- and saves all types with bitcount >= 8 (non-interlaced only).
- Compression level and filtering can be set by options interface.
-
- Supported ancillary chunks (loading):
- tRNS, bKGD
- (for indexed images transparency contains alpha values for palette,
- RGB/Gray images with transparency are converted to formats with alpha
- and pixels with transparent color are replaced with background color
- with alpha = 0).}
- TPNGFileFormat = class(TNetworkGraphicsFileFormat)
- private
- FLoadAnimated: LongBool;
- protected
- function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
- OnlyFirstLevel: Boolean): Boolean; override;
- function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
- Index: LongInt): Boolean; override;
- public
- constructor Create; override;
- published
- property LoadAnimated: LongBool read FLoadAnimated write FLoadAnimated;
- end;
-
-{$IFNDEF DONT_LINK_MNG}
- { Class for loading Multiple Network Graphics files.
- This format has complex animation capabilities but Imaging only
- extracts frames. Individual frames are stored as standard PNG or JNG
- images. Loads all types of these frames stored in IHDR-IEND and
- JHDR-IEND streams (Note that there are MNG chunks
- like BASI which define images but does not contain image data itself,
- those are ignored).
- Imaging saves MNG files as MNG-VLC (very low complexity) so it is basicaly
- an array of image frames without MNG animation chunks. Frames can be saved
- as lossless PNG or lossy JNG images (look at TPNGFileFormat and
- TJNGFileFormat for info). Every frame can be in different data format.
-
- Many frame compression settings can be modified by options interface.}
- TMNGFileFormat = class(TNetworkGraphicsFileFormat)
- protected
- function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
- OnlyFirstLevel: Boolean): Boolean; override;
- function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
- Index: LongInt): Boolean; override;
- public
- constructor Create; override;
- end;
-{$ENDIF}
-
-{$IFNDEF DONT_LINK_JNG}
- { Class for loading JPEG Network Graphics Images.
- Loads all types of this image format (all images in jng test suite)
- and saves all types except 12 bit JPEGs.
- Alpha channel in JNG images is stored separately from color/gray data and
- can be lossy (as JPEG image) or lossless (as PNG image) compressed.
- Type of alpha compression, compression level and quality,
- and filtering can be set by options interface.
-
- Supported ancillary chunks (loading):
- tRNS, bKGD
- (Images with transparency are converted to formats with alpha
- and pixels with transparent color are replaced with background color
- with alpha = 0).}
- TJNGFileFormat = class(TNetworkGraphicsFileFormat)
- protected
- function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
- OnlyFirstLevel: Boolean): Boolean; override;
- function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
- Index: LongInt): Boolean; override;
- public
- constructor Create; override;
- end;
-{$ENDIF}
-
-
-implementation
-
-uses
-{$IFNDEF DONT_LINK_JNG}
- ImagingJpeg, ImagingIO,
-{$ENDIF}
- ImagingCanvases;
-
-const
- NGDefaultPreFilter = 5;
- NGDefaultCompressLevel = 5;
- NGDefaultLossyAlpha = False;
- NGDefaultLossyCompression = False;
- NGDefaultProgressive = False;
- NGDefaultQuality = 90;
- NGLosslessFormats: TImageFormats = [ifIndex8, ifGray8, ifA8Gray8, ifGray16,
- ifA16Gray16, ifR8G8B8, ifA8R8G8B8, ifR16G16B16, ifA16R16G16B16, ifB16G16R16,
- ifA16B16G16R16];
- NGLossyFormats: TImageFormats = [ifGray8, ifA8Gray8, ifR8G8B8, ifA8R8G8B8];
- PNGDefaultLoadAnimated = True;
-
- SPNGFormatName = 'Portable Network Graphics';
- SPNGMasks = '*.png';
- SMNGFormatName = 'Multiple Network Graphics';
- SMNGMasks = '*.mng';
- SJNGFormatName = 'JPEG Network Graphics';
- SJNGMasks = '*.jng';
-
-resourcestring
- SErrorLoadingChunk = 'Error when reading %s chunk data. File may be corrupted.';
-
-type
- { Chunk header.}
- TChunkHeader = packed record
- DataSize: LongWord;
- ChunkID: TChar4;
- end;
-
- { IHDR chunk format - PNG header.}
- TIHDR = packed record
- Width: LongWord; // Image width
- Height: LongWord; // Image height
- BitDepth: Byte; // Bits per pixel or bits per sample (for truecolor)
- ColorType: Byte; // 0 = grayscale, 2 = truecolor, 3 = palette,
- // 4 = gray + alpha, 6 = truecolor + alpha
- Compression: Byte; // Compression type: 0 = ZLib
- Filter: Byte; // Used precompress filter
- Interlacing: Byte; // Used interlacing: 0 = no int, 1 = Adam7
- end;
- PIHDR = ^TIHDR;
-
- { MHDR chunk format - MNG header.}
- TMHDR = packed record
- FrameWidth: LongWord; // Frame width
- FrameHeight: LongWord; // Frame height
- TicksPerSecond: LongWord; // FPS of animation
- NominalLayerCount: LongWord; // Number of layers in file
- NominalFrameCount: LongWord; // Number of frames in file
- NominalPlayTime: LongWord; // Play time of animation in ticks
- SimplicityProfile: LongWord; // Defines which MNG features are used in this file
- end;
- PMHDR = ^TMHDR;
-
- { JHDR chunk format - JNG header.}
- TJHDR = packed record
- Width: LongWord; // Image width
- Height: LongWord; // Image height
- ColorType: Byte; // 8 = grayscale (Y), 10 = color (YCbCr),
- // 12 = gray + alpha (Y-alpha), 14 = color + alpha (YCbCr-alpha)
- SampleDepth: Byte; // 8, 12 or 20 (8 and 12 samples together) bit
- Compression: Byte; // Compression type: 8 = Huffman coding
- Interlacing: Byte; // 0 = single scan, 8 = progressive
- AlphaSampleDepth: Byte; // 0, 1, 2, 4, 8, 16 if alpha compression is 0 (PNG)
- // 8 if alpha compression is 8 (JNG)
- AlphaCompression: Byte; // 0 = PNG graysscale IDAT, 8 = grayscale 8-bit JPEG
- AlphaFilter: Byte; // 0 = PNG filter or no filter (JPEG)
- AlphaInterlacing: Byte; // 0 = non interlaced
- end;
- PJHDR = ^TJHDR;
-
- { acTL chunk format - APNG animation control.}
- TacTL = packed record
- NumFrames: LongWord; // Number of frames
- NumPlay: LongWord; // Number of times to loop the animation (0 = inf)
- end;
- PacTL =^TacTL;
-
- { fcTL chunk format - APNG frame control.}
- TfcTL = packed record
- SeqNumber: LongWord; // Sequence number of the animation chunk, starting from 0
- Width: LongWord; // Width of the following frame
- Height: LongWord; // Height of the following frame
- XOffset: LongWord; // X position at which to render the following frame
- YOffset: LongWord; // Y position at which to render the following frame
- DelayNumer: Word; // Frame delay fraction numerator
- DelayDenom: Word; // Frame delay fraction denominator
- DisposeOp: Byte; // Type of frame area disposal to be done after rendering this frame
- BlendOp: Byte; // Type of frame area rendering for this frame
- end;
- PfcTL = ^TfcTL;
-
-const
- { PNG file identifier.}
- PNGSignature: TChar8 = #$89'PNG'#$0D#$0A#$1A#$0A;
- { MNG file identifier.}
- MNGSignature: TChar8 = #$8A'MNG'#$0D#$0A#$1A#$0A;
- { JNG file identifier.}
- JNGSignature: TChar8 = #$8B'JNG'#$0D#$0A#$1A#$0A;
-
- { Constants for chunk identifiers and signature identifiers.
- They are in big-endian format.}
- IHDRChunk: TChar4 = 'IHDR';
- IENDChunk: TChar4 = 'IEND';
- MHDRChunk: TChar4 = 'MHDR';
- MENDChunk: TChar4 = 'MEND';
- JHDRChunk: TChar4 = 'JHDR';
- IDATChunk: TChar4 = 'IDAT';
- JDATChunk: TChar4 = 'JDAT';
- JDAAChunk: TChar4 = 'JDAA';
- JSEPChunk: TChar4 = 'JSEP';
- PLTEChunk: TChar4 = 'PLTE';
- BACKChunk: TChar4 = 'BACK';
- DEFIChunk: TChar4 = 'DEFI';
- TERMChunk: TChar4 = 'TERM';
- tRNSChunk: TChar4 = 'tRNS';
- bKGDChunk: TChar4 = 'bKGD';
- gAMAChunk: TChar4 = 'gAMA';
- acTLChunk: TChar4 = 'acTL';
- fcTLChunk: TChar4 = 'fcTL';
- fdATChunk: TChar4 = 'fdAT';
-
- { APNG frame dispose operations.}
- DisposeOpNone = 0;
- DisposeOpBackground = 1;
- DisposeOpPrevious = 2;
-
- { APNG frame blending modes}
- BlendOpSource = 0;
- BlendOpOver = 1;
-
- { Interlace start and offsets.}
- RowStart: array[0..6] of LongInt = (0, 0, 4, 0, 2, 0, 1);
- ColumnStart: array[0..6] of LongInt = (0, 4, 0, 2, 0, 1, 0);
- RowIncrement: array[0..6] of LongInt = (8, 8, 8, 4, 4, 2, 2);
- ColumnIncrement: array[0..6] of LongInt = (8, 8, 4, 4, 2, 2, 1);
-
-type
- { Helper class that holds information about MNG frame in PNG or JNG format.}
- TFrameInfo = class(TObject)
- public
- FrameWidth, FrameHeight: LongInt;
- IsJpegFrame: Boolean;
- IHDR: TIHDR;
- JHDR: TJHDR;
- fcTL: TfcTL;
- Palette: PPalette24;
- PaletteEntries: LongInt;
- Transparency: Pointer;
- TransparencySize: LongInt;
- Background: Pointer;
- BackgroundSize: LongInt;
- IDATMemory: TMemoryStream;
- JDATMemory: TMemoryStream;
- JDAAMemory: TMemoryStream;
- constructor Create;
- destructor Destroy; override;
- procedure AssignSharedProps(Source: TFrameInfo);
- end;
-
- { Defines type of Network Graphics file.}
- TNGFileType = (ngPNG, ngAPNG, ngMNG, ngJNG);
-
- TNGFileHandler = class(TObject)
- public
- FileType: TNGFileType;
- Frames: array of TFrameInfo;
- MHDR: TMHDR; // Main header for MNG files
- acTL: TacTL; // Global anim control for APNG files
- GlobalPalette: PPalette24;
- GlobalPaletteEntries: LongInt;
- GlobalTransparency: Pointer;
- GlobalTransparencySize: LongInt;
- destructor Destroy; override;
- procedure Clear;
- function GetLastFrame: TFrameInfo;
- function AddFrameInfo: TFrameInfo;
- end;
-
- { Network Graphics file parser and frame converter.}
- TNGFileLoader = class(TNGFileHandler)
- public
- function LoadFile(Handle: TImagingHandle): Boolean;
- procedure LoadImageFromPNGFrame(FrameWidth, FrameHeight: LongInt; const IHDR: TIHDR; IDATStream: TMemoryStream; var Image: TImageData);
-{$IFNDEF DONT_LINK_JNG}
- procedure LoadImageFromJNGFrame(FrameWidth, FrameHeight: LongInt; const JHDR: TJHDR; IDATStream, JDATStream, JDAAStream: TMemoryStream; var Image: TImageData);
-{$ENDIF}
- procedure ApplyFrameSettings(Frame: TFrameInfo; var Image: TImageData);
- end;
-
- TNGFileSaver = class(TNGFileHandler)
- public
- PreFilter: LongInt;
- CompressLevel: LongInt;
- LossyAlpha: Boolean;
- Quality: LongInt;
- Progressive: Boolean;
- function SaveFile(Handle: TImagingHandle): Boolean;
- procedure AddFrame(const Image: TImageData; IsJpegFrame: Boolean);
- procedure StoreImageToPNGFrame(const IHDR: TIHDR; Bits: Pointer; FmtInfo: TImageFormatInfo; IDATStream: TMemoryStream);
-{$IFNDEF DONT_LINK_JNG}
- procedure StoreImageToJNGFrame(const JHDR: TJHDR; const Image: TImageData; IDATStream, JDATStream, JDAAStream: TMemoryStream);
-{$ENDIF}
- procedure SetFileOptions(FileFormat: TNetworkGraphicsFileFormat);
- end;
-
-{$IFNDEF DONT_LINK_JNG}
- TCustomIOJpegFileFormat = class(TJpegFileFormat)
- protected
- FCustomIO: TIOFunctions;
- procedure SetJpegIO(const JpegIO: TIOFunctions); override;
- procedure SetCustomIO(const CustomIO: TIOFunctions);
- end;
-{$ENDIF}
-
- TAPNGAnimator = class
- public
- class procedure Animate(var Images: TDynImageDataArray; const acTL: TacTL; const SrcFrames: array of TFrameInfo);
- end;
-
-{ Helper routines }
-
-function PaethPredictor(A, B, C: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
-var
- P, PA, PB, PC: LongInt;
-begin
- P := A + B - C;
- PA := Abs(P - A);
- PB := Abs(P - B);
- PC := Abs(P - C);
- if (PA <= PB) and (PA <= PC) then
- Result := A
- else
- if PB <= PC then
- Result := B
- else
- Result := C;
-end;
-
-procedure SwapRGB(Line: PByte; Width, SampleDepth, BytesPerPixel: LongInt);
-var
- I: LongInt;
- Tmp: Word;
-begin
- case SampleDepth of
- 8:
- for I := 0 to Width - 1 do
- with PColor24Rec(Line)^ do
- begin
- Tmp := R;
- R := B;
- B := Tmp;
- Inc(Line, BytesPerPixel);
- end;
- 16:
- for I := 0 to Width - 1 do
- with PColor48Rec(Line)^ do
- begin
- Tmp := R;
- R := B;
- B := Tmp;
- Inc(Line, BytesPerPixel);
- end;
- end;
- end;
-
-const
- { Helper constants for 1/2/4 bit to 8 bit conversions.}
- Mask1: array[0..7] of Byte = ($80, $40, $20, $10, $08, $04, $02, $01);
- Shift1: array[0..7] of Byte = (7, 6, 5, 4, 3, 2, 1, 0);
- Mask2: array[0..3] of Byte = ($C0, $30, $0C, $03);
- Shift2: array[0..3] of Byte = (6, 4, 2, 0);
- Mask4: array[0..1] of Byte = ($F0, $0F);
- Shift4: array[0..1] of Byte = (4, 0);
-
-function Get1BitPixel(Line: PByteArray; X: LongInt): Byte;
-begin
- Result := (Line[X shr 3] and Mask1[X and 7]) shr
- Shift1[X and 7];
-end;
-
-function Get2BitPixel(Line: PByteArray; X: LongInt): Byte;
-begin
- Result := (Line[X shr 2] and Mask2[X and 3]) shr
- Shift2[X and 3];
-end;
-
-function Get4BitPixel(Line: PByteArray; X: LongInt): Byte;
-begin
- Result := (Line[X shr 1] and Mask4[X and 1]) shr
- Shift4[X and 1];
-end;
-
-{$IFNDEF DONT_LINK_JNG}
-
-{ TCustomIOJpegFileFormat class implementation }
-
-procedure TCustomIOJpegFileFormat.SetCustomIO(const CustomIO: TIOFunctions);
-begin
- FCustomIO := CustomIO;
-end;
-
-procedure TCustomIOJpegFileFormat.SetJpegIO(const JpegIO: TIOFunctions);
-begin
- inherited SetJpegIO(FCustomIO);
-end;
-
-{$ENDIF}
-
-{ TFrameInfo class implementation }
-
-constructor TFrameInfo.Create;
-begin
- IDATMemory := TMemoryStream.Create;
- JDATMemory := TMemoryStream.Create;
- JDAAMemory := TMemoryStream.Create;
-end;
-
-destructor TFrameInfo.Destroy;
-begin
- FreeMem(Palette);
- FreeMem(Transparency);
- FreeMem(Background);
- IDATMemory.Free;
- JDATMemory.Free;
- JDAAMemory.Free;
- inherited Destroy;
-end;
-
-procedure TFrameInfo.AssignSharedProps(Source: TFrameInfo);
-begin
- IHDR := Source.IHDR;
- JHDR := Source.JHDR;
- PaletteEntries := Source.PaletteEntries;
- GetMem(Palette, PaletteEntries * SizeOf(TColor24Rec));
- Move(Source.Palette^, Palette^, PaletteEntries * SizeOf(TColor24Rec));
- TransparencySize := Source.TransparencySize;
- GetMem(Transparency, TransparencySize);
- Move(Source.Transparency^, Transparency^, TransparencySize);
-end;
-
-{ TNGFileHandler class implementation}
-
-destructor TNGFileHandler.Destroy;
-begin
- Clear;
- inherited Destroy;
-end;
-
-procedure TNGFileHandler.Clear;
-var
- I: LongInt;
-begin
- for I := 0 to Length(Frames) - 1 do
- Frames[I].Free;
- SetLength(Frames, 0);
- FreeMemNil(GlobalPalette);
- GlobalPaletteEntries := 0;
- FreeMemNil(GlobalTransparency);
- GlobalTransparencySize := 0;
-end;
-
-function TNGFileHandler.GetLastFrame: TFrameInfo;
-var
- Len: LongInt;
-begin
- Len := Length(Frames);
- if Len > 0 then
- Result := Frames[Len - 1]
- else
- Result := nil;
-end;
-
-function TNGFileHandler.AddFrameInfo: TFrameInfo;
-var
- Len: LongInt;
-begin
- Len := Length(Frames);
- SetLength(Frames, Len + 1);
- Result := TFrameInfo.Create;
- Frames[Len] := Result;
-end;
-
-{ TNGFileLoader class implementation}
-
-function TNGFileLoader.LoadFile(Handle: TImagingHandle): Boolean;
-var
- Sig: TChar8;
- Chunk: TChunkHeader;
- ChunkData: Pointer;
- ChunkCrc: LongWord;
-
- procedure ReadChunk;
- begin
- GetIO.Read(Handle, @Chunk, SizeOf(Chunk));
- Chunk.DataSize := SwapEndianLongWord(Chunk.DataSize);
- end;
-
- procedure ReadChunkData;
- var
- ReadBytes: LongWord;
- begin
- FreeMemNil(ChunkData);
- GetMem(ChunkData, Chunk.DataSize);
- ReadBytes := GetIO.Read(Handle, ChunkData, Chunk.DataSize);
- GetIO.Read(Handle, @ChunkCrc, SizeOf(ChunkCrc));
- if ReadBytes <> Chunk.DataSize then
- RaiseImaging(SErrorLoadingChunk, [string(Chunk.ChunkID)]);
- end;
-
- procedure SkipChunkData;
- begin
- GetIO.Seek(Handle, Chunk.DataSize + SizeOf(ChunkCrc), smFromCurrent);
- end;
-
- procedure StartNewPNGImage;
- var
- Frame: TFrameInfo;
- begin
- ReadChunkData;
-
- if Chunk.ChunkID = fcTLChunk then
- begin
- if (Length(Frames) = 1) and (Frames[0].IDATMemory.Size = 0) then
- begin
- // First fcTL chunk maybe for first IDAT frame which is alredy created
- Frame := Frames[0];
- end
- else
- begin
- // Subsequent APNG frames with data in fdAT
- Frame := AddFrameInfo;
- // Copy some shared props from first frame (IHDR is the same for all APNG frames, palette etc)
- Frame.AssignSharedProps(Frames[0]);
- end;
- Frame.fcTL := PfcTL(ChunkData)^;
- SwapEndianLongWord(@Frame.fcTL, 5);
- Frame.fcTL.DelayNumer := SwapEndianWord(Frame.fcTL.DelayNumer);
- Frame.fcTL.DelayDenom := SwapEndianWord(Frame.fcTL.DelayDenom);
- Frame.FrameWidth := Frame.fcTL.Width;
- Frame.FrameHeight := Frame.fcTL.Height;
- end
- else
- begin
- // This is frame defined by IHDR chunk
- Frame := AddFrameInfo;
- Frame.IHDR := PIHDR(ChunkData)^;
- SwapEndianLongWord(@Frame.IHDR, 2);
- Frame.FrameWidth := Frame.IHDR.Width;
- Frame.FrameHeight := Frame.IHDR.Height;
- end;
- Frame.IsJpegFrame := False;
- end;
-
- procedure StartNewJNGImage;
- var
- Frame: TFrameInfo;
- begin
- ReadChunkData;
- Frame := AddFrameInfo;
- Frame.IsJpegFrame := True;
- Frame.JHDR := PJHDR(ChunkData)^;
- SwapEndianLongWord(@Frame.JHDR, 2);
- Frame.FrameWidth := Frame.JHDR.Width;
- Frame.FrameHeight := Frame.JHDR.Height;
- end;
-
- procedure AppendIDAT;
- begin
- ReadChunkData;
- // Append current IDAT/fdAT chunk to storage stream
- if Chunk.ChunkID = IDATChunk then
- GetLastFrame.IDATMemory.Write(ChunkData^, Chunk.DataSize)
- else if Chunk.ChunkID = fdATChunk then
- GetLastFrame.IDATMemory.Write(PByteArray(ChunkData)[4], Chunk.DataSize - SizeOf(LongWord));
- end;
-
- procedure AppendJDAT;
- begin
- ReadChunkData;
- // Append current JDAT chunk to storage stream
- GetLastFrame.JDATMemory.Write(ChunkData^, Chunk.DataSize);
- end;
-
- procedure AppendJDAA;
- begin
- ReadChunkData;
- // Append current JDAA chunk to storage stream
- GetLastFrame.JDAAMemory.Write(ChunkData^, Chunk.DataSize);
- end;
-
- procedure LoadPLTE;
- begin
- ReadChunkData;
- if GetLastFrame = nil then
- begin
- // Load global palette
- GetMem(GlobalPalette, Chunk.DataSize);
- Move(ChunkData^, GlobalPalette^, Chunk.DataSize);
- GlobalPaletteEntries := Chunk.DataSize div 3;
- end
- else if GetLastFrame.Palette = nil then
- begin
- if (Chunk.DataSize = 0) and (GlobalPalette <> nil) then
- begin
- // Use global palette
- GetMem(GetLastFrame.Palette, GlobalPaletteEntries * SizeOf(TColor24Rec));
- Move(GlobalPalette^, GetLastFrame.Palette^, GlobalPaletteEntries * SizeOf(TColor24Rec));
- GetLastFrame.PaletteEntries := GlobalPaletteEntries;
- end
- else
- begin
- // Load pal from PLTE chunk
- GetMem(GetLastFrame.Palette, Chunk.DataSize);
- Move(ChunkData^, GetLastFrame.Palette^, Chunk.DataSize);
- GetLastFrame.PaletteEntries := Chunk.DataSize div 3;
- end;
- end;
- end;
-
- procedure LoadtRNS;
- begin
- ReadChunkData;
- if GetLastFrame = nil then
- begin
- // Load global transparency
- GetMem(GlobalTransparency, Chunk.DataSize);
- Move(ChunkData^, GlobalTransparency^, Chunk.DataSize);
- GlobalTransparencySize := Chunk.DataSize;
- end
- else if GetLastFrame.Transparency = nil then
- begin
- if (Chunk.DataSize = 0) and (GlobalTransparency <> nil) then
- begin
- // Use global transparency
- GetMem(GetLastFrame.Transparency, GlobalTransparencySize);
- Move(GlobalTransparency^, GetLastFrame.Transparency^, Chunk.DataSize);
- GetLastFrame.TransparencySize := GlobalTransparencySize;
- end
- else
- begin
- // Load pal from tRNS chunk
- GetMem(GetLastFrame.Transparency, Chunk.DataSize);
- Move(ChunkData^, GetLastFrame.Transparency^, Chunk.DataSize);
- GetLastFrame.TransparencySize := Chunk.DataSize;
- end;
- end;
- end;
-
- procedure LoadbKGD;
- begin
- ReadChunkData;
- if GetLastFrame.Background = nil then
- begin
- GetMem(GetLastFrame.Background, Chunk.DataSize);
- Move(ChunkData^, GetLastFrame.Background^, Chunk.DataSize);
- GetLastFrame.BackgroundSize := Chunk.DataSize;
- end;
- end;
-
- procedure HandleacTL;
- begin
- FileType := ngAPNG;
- ReadChunkData;
- acTL := PacTL(ChunkData)^;
- SwapEndianLongWord(@acTL, SizeOf(acTL) div SizeOf(LongWord));
- end;
-
-begin
- Result := False;
- Clear;
- ChunkData := nil;
- with GetIO do
- try
- Read(Handle, @Sig, SizeOf(Sig));
- // Set file type according to the signature
- if Sig = PNGSignature then FileType := ngPNG
- else if Sig = MNGSignature then FileType := ngMNG
- else if Sig = JNGSignature then FileType := ngJNG
- else Exit;
-
- if FileType = ngMNG then
- begin
- // Store MNG header if present
- ReadChunk;
- ReadChunkData;
- MHDR := PMHDR(ChunkData)^;
- SwapEndianLongWord(@MHDR, SizeOf(MHDR) div SizeOf(LongWord));
- end;
-
- // Read chunks until ending chunk or EOF is reached
- repeat
- ReadChunk;
- if (Chunk.ChunkID = IHDRChunk) or (Chunk.ChunkID = fcTLChunk) then StartNewPNGImage
- else if Chunk.ChunkID = JHDRChunk then StartNewJNGImage
- else if (Chunk.ChunkID = IDATChunk) or (Chunk.ChunkID = fdATChunk) then AppendIDAT
- else if Chunk.ChunkID = JDATChunk then AppendJDAT
- else if Chunk.ChunkID = JDAAChunk then AppendJDAA
- else if Chunk.ChunkID = PLTEChunk then LoadPLTE
- else if Chunk.ChunkID = tRNSChunk then LoadtRNS
- else if Chunk.ChunkID = bKGDChunk then LoadbKGD
- else if Chunk.ChunkID = acTLChunk then HandleacTL
- else SkipChunkData;
- until Eof(Handle) or (Chunk.ChunkID = MENDChunk) or
- ((FileType <> ngMNG) and (Chunk.ChunkID = IENDChunk));
-
- Result := True;
- finally
- FreeMemNil(ChunkData);
- end;
-end;
-
-procedure TNGFileLoader.LoadImageFromPNGFrame(FrameWidth, FrameHeight: LongInt; const IHDR: TIHDR;
- IDATStream: TMemoryStream; var Image: TImageData);
-type
- TGetPixelFunc = function(Line: PByteArray; X: LongInt): Byte;
-var
- LineBuffer: array[Boolean] of PByteArray;
- ActLine: Boolean;
- Data, TotalBuffer, ZeroLine, PrevLine: Pointer;
- BitCount, TotalSize, TotalPos, BytesPerPixel, I, Pass,
- SrcDataSize, BytesPerLine, InterlaceLineBytes, InterlaceWidth: LongInt;
-
- procedure DecodeAdam7;
- const
- BitTable: array[1..8] of LongInt = ($1, $3, 0, $F, 0, 0, 0, $FF);
- StartBit: array[1..8] of LongInt = (7, 6, 0, 4, 0, 0, 0, 0);
- var
- Src, Dst, Dst2: PByte;
- CurBit, Col: LongInt;
- begin
- Src := @LineBuffer[ActLine][1];
- Col := ColumnStart[Pass];
- with Image do
- case BitCount of
- 1, 2, 4:
- begin
- Dst := @PByteArray(Data)[I * BytesPerLine];
- repeat
- CurBit := StartBit[BitCount];
- repeat
- Dst2 := @PByteArray(Dst)[(BitCount * Col) shr 3];
- Dst2^ := Dst2^ or ((Src^ shr CurBit) and BitTable[BitCount])
- shl (StartBit[BitCount] - (Col * BitCount mod 8));
- Inc(Col, ColumnIncrement[Pass]);
- Dec(CurBit, BitCount);
- until CurBit < 0;
- Inc(Src);
- until Col >= Width;
- end;
- else
- begin
- Dst := @PByteArray(Data)[I * BytesPerLine + Col * BytesPerPixel];
- repeat
- CopyPixel(Src, Dst, BytesPerPixel);
- Inc(Dst, BytesPerPixel);
- Inc(Src, BytesPerPixel);
- Inc(Dst, ColumnIncrement[Pass] * BytesPerPixel - BytesPerPixel);
- Inc(Col, ColumnIncrement[Pass]);
- until Col >= Width;
- end;
- end;
- end;
-
- procedure FilterScanline(Filter: Byte; BytesPerPixel: LongInt; Line, PrevLine, Target: PByteArray;
- BytesPerLine: LongInt);
- var
- I: LongInt;
- begin
- case Filter of
- 0:
- begin
- // No filter
- Move(Line^, Target^, BytesPerLine);
- end;
- 1:
- begin
- // Sub filter
- Move(Line^, Target^, BytesPerPixel);
- for I := BytesPerPixel to BytesPerLine - 1 do
- Target[I] := (Line[I] + Target[I - BytesPerPixel]) and $FF;
- end;
- 2:
- begin
- // Up filter
- for I := 0 to BytesPerLine - 1 do
- Target[I] := (Line[I] + PrevLine[I]) and $FF;
- end;
- 3:
- begin
- // Average filter
- for I := 0 to BytesPerPixel - 1 do
- Target[I] := (Line[I] + PrevLine[I] shr 1) and $FF;
- for I := BytesPerPixel to BytesPerLine - 1 do
- Target[I] := (Line[I] + (Target[I - BytesPerPixel] + PrevLine[I]) shr 1) and $FF;
- end;
- 4:
- begin
- // Paeth filter
- for I := 0 to BytesPerPixel - 1 do
- Target[I] := (Line[I] + PaethPredictor(0, PrevLine[I], 0)) and $FF;
- for I := BytesPerPixel to BytesPerLine - 1 do
- Target[I] := (Line[I] + PaethPredictor(Target[I - BytesPerPixel], PrevLine[I], PrevLine[I - BytesPerPixel])) and $FF;
- end;
- end;
- end;
-
- procedure Convert124To8(DataIn: Pointer; DataOut: Pointer; Width, Height,
- WidthBytes: LongInt; Indexed: Boolean);
- var
- X, Y, Mul: LongInt;
- GetPixel: TGetPixelFunc;
- begin
- GetPixel := Get1BitPixel;
- Mul := 255;
- case IHDR.BitDepth of
- 2:
- begin
- Mul := 85;
- GetPixel := Get2BitPixel;
- end;
- 4:
- begin
- Mul := 17;
- GetPixel := Get4BitPixel;
- end;
- end;
- if Indexed then Mul := 1;
-
- for Y := 0 to Height - 1 do
- for X := 0 to Width - 1 do
- PByteArray(DataOut)[Y * Width + X] :=
- GetPixel(@PByteArray(DataIn)[Y * WidthBytes], X) * Mul;
- end;
-
- procedure TransformLOCOToRGB(Data: PByte; NumPixels, BytesPerPixel: LongInt);
- var
- I: LongInt;
- begin
- for I := 0 to NumPixels - 1 do
- begin
- if IHDR.BitDepth = 8 then
- begin
- PColor32Rec(Data).R := Byte(PColor32Rec(Data).R + PColor32Rec(Data).G);
- PColor32Rec(Data).B := Byte(PColor32Rec(Data).B + PColor32Rec(Data).G);
- end
- else
- begin
- PColor64Rec(Data).R := Word(PColor64Rec(Data).R + PColor64Rec(Data).G);
- PColor64Rec(Data).B := Word(PColor64Rec(Data).B + PColor64Rec(Data).G);
- end;
- Inc(Data, BytesPerPixel);
- end;
- end;
-
-begin
- Image.Width := FrameWidth;
- Image.Height := FrameHeight;
- Image.Format := ifUnknown;
-
- case IHDR.ColorType of
- 0:
- begin
- // Gray scale image
- case IHDR.BitDepth of
- 1, 2, 4, 8: Image.Format := ifGray8;
- 16: Image.Format := ifGray16;
- end;
- BitCount := IHDR.BitDepth;
- end;
- 2:
- begin
- // RGB image
- case IHDR.BitDepth of
- 8: Image.Format := ifR8G8B8;
- 16: Image.Format := ifR16G16B16;
- end;
- BitCount := IHDR.BitDepth * 3;
- end;
- 3:
- begin
- // Indexed image
- case IHDR.BitDepth of
- 1, 2, 4, 8: Image.Format := ifIndex8;
- end;
- BitCount := IHDR.BitDepth;
- end;
- 4:
- begin
- // Grayscale + alpha image
- case IHDR.BitDepth of
- 8: Image.Format := ifA8Gray8;
- 16: Image.Format := ifA16Gray16;
- end;
- BitCount := IHDR.BitDepth * 2;
- end;
- 6:
- begin
- // ARGB image
- case IHDR.BitDepth of
- 8: Image.Format := ifA8R8G8B8;
- 16: Image.Format := ifA16R16G16B16;
- end;
- BitCount := IHDR.BitDepth * 4;
- end;
- end;
-
- // Start decoding
- LineBuffer[True] := nil;
- LineBuffer[False] := nil;
- TotalBuffer := nil;
- ZeroLine := nil;
- BytesPerPixel := (BitCount + 7) div 8;
- ActLine := True;
- with Image do
- try
- BytesPerLine := (Width * BitCount + 7) div 8;
- SrcDataSize := Height * BytesPerLine;
- GetMem(Data, SrcDataSize);
- FillChar(Data^, SrcDataSize, 0);
- GetMem(ZeroLine, BytesPerLine);
- FillChar(ZeroLine^, BytesPerLine, 0);
-
- if IHDR.Interlacing = 1 then
- begin
- // Decode interlaced images
- TotalPos := 0;
- DecompressBuf(IDATStream.Memory, IDATStream.Size, 0,
- Pointer(TotalBuffer), TotalSize);
- GetMem(LineBuffer[True], BytesPerLine + 1);
- GetMem(LineBuffer[False], BytesPerLine + 1);
- for Pass := 0 to 6 do
- begin
- // Prepare next interlace run
- if Width <= ColumnStart[Pass] then
- Continue;
- InterlaceWidth := (Width + ColumnIncrement[Pass] - 1 -
- ColumnStart[Pass]) div ColumnIncrement[Pass];
- InterlaceLineBytes := (InterlaceWidth * BitCount + 7) shr 3;
- I := RowStart[Pass];
- FillChar(LineBuffer[True][0], BytesPerLine + 1, 0);
- FillChar(LineBuffer[False][0], BytesPerLine + 1, 0);
- while I < Height do
- begin
- // Copy line from decompressed data to working buffer
- Move(PByteArray(TotalBuffer)[TotalPos],
- LineBuffer[ActLine][0], InterlaceLineBytes + 1);
- Inc(TotalPos, InterlaceLineBytes + 1);
- // Swap red and blue channels if necessary
- if (IHDR.ColorType in [2, 6]) then
- SwapRGB(@LineBuffer[ActLine][1], InterlaceWidth, IHDR.BitDepth, BytesPerPixel);
- // Reverse-filter current scanline
- FilterScanline(LineBuffer[ActLine][0], BytesPerPixel,
- @LineBuffer[ActLine][1], @LineBuffer[not ActLine][1],
- @LineBuffer[ActLine][1], InterlaceLineBytes);
- // Decode Adam7 interlacing
- DecodeAdam7;
- ActLine := not ActLine;
- // Continue with next row in interlaced order
- Inc(I, RowIncrement[Pass]);
- end;
- end;
- end
- else
- begin
- // Decode non-interlaced images
- PrevLine := ZeroLine;
- DecompressBuf(IDATStream.Memory, IDATStream.Size, SrcDataSize + Height,
- Pointer(TotalBuffer), TotalSize);
- for I := 0 to Height - 1 do
- begin
- // Swap red and blue channels if necessary
- if IHDR.ColorType in [2, 6] then
- SwapRGB(@PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + 1], Width,
- IHDR.BitDepth, BytesPerPixel);
- // reverse-filter current scanline
- FilterScanline(PByteArray(TotalBuffer)[I * (BytesPerLine + 1)],
- BytesPerPixel, @PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + 1],
- PrevLine, @PByteArray(Data)[I * BytesPerLine], BytesPerLine);
- PrevLine := @PByteArray(Data)[I * BytesPerLine];
- end;
- end;
-
- Size := Width * Height * BytesPerPixel;
-
- if Size <> SrcDataSize then
- begin
- // If source data size is different from size of image in assigned
- // format we must convert it (it is in 1/2/4 bit count)
- GetMem(Bits, Size);
- case IHDR.ColorType of
- 0: Convert124To8(Data, Bits, Width, Height, BytesPerLine, False);
- 3: Convert124To8(Data, Bits, Width, Height, BytesPerLine, True);
- end;
- FreeMem(Data);
- end
- else
- begin
- // If source data size is the same as size of
- // image Bits in assigned format we simply copy pointer reference
- Bits := Data;
- end;
-
- // LOCO transformation was used too (only for color types 2 and 6)
- if (IHDR.Filter = 64) and (IHDR.ColorType in [2, 6]) then
- TransformLOCOToRGB(Bits, Width * Height, BytesPerPixel);
-
- // Images with 16 bit channels must be swapped because of PNG's big endianity
- if IHDR.BitDepth = 16 then
- SwapEndianWord(Bits, Width * Height * BytesPerPixel div SizeOf(Word));
- finally
- FreeMem(LineBuffer[True]);
- FreeMem(LineBuffer[False]);
- FreeMem(TotalBuffer);
- FreeMem(ZeroLine);
- end;
-end;
-
-{$IFNDEF DONT_LINK_JNG}
-
-procedure TNGFileLoader.LoadImageFromJNGFrame(FrameWidth, FrameHeight: LongInt; const JHDR: TJHDR; IDATStream,
- JDATStream, JDAAStream: TMemoryStream; var Image: TImageData);
-var
- AlphaImage: TImageData;
- FakeIHDR: TIHDR;
- FmtInfo: TImageFormatInfo;
- I: LongInt;
- AlphaPtr: PByte;
- GrayPtr: PWordRec;
- ColorPtr: PColor32Rec;
-
- procedure LoadJpegFromStream(Stream: TStream; var DestImage: TImageData);
- var
- JpegFormat: TCustomIOJpegFileFormat;
- Handle: TImagingHandle;
- DynImages: TDynImageDataArray;
- begin
- if JHDR.SampleDepth <> 12 then
- begin
- JpegFormat := TCustomIOJpegFileFormat.Create;
- JpegFormat.SetCustomIO(StreamIO);
- Stream.Position := 0;
- Handle := StreamIO.OpenRead(Pointer(Stream));
- try
- JpegFormat.LoadData(Handle, DynImages, True);
- DestImage := DynImages[0];
- finally
- StreamIO.Close(Handle);
- JpegFormat.Free;
- SetLength(DynImages, 0);
- end;
- end
- else
- NewImage(FrameWidth, FrameHeight, ifR8G8B8, DestImage);
- end;
-
-begin
- LoadJpegFromStream(JDATStream, Image);
-
- // If present separate alpha channel is processed
- if (JHDR.ColorType in [12, 14]) and (Image.Format in [ifGray8, ifR8G8B8]) then
- begin
- InitImage(AlphaImage);
- if JHDR.AlphaCompression = 0 then
- begin
- // Alpha channel is PNG compressed
- FakeIHDR.Width := JHDR.Width;
- FakeIHDR.Height := JHDR.Height;
- FakeIHDR.ColorType := 0;
- FakeIHDR.BitDepth := JHDR.AlphaSampleDepth;
- FakeIHDR.Filter := JHDR.AlphaFilter;
- FakeIHDR.Interlacing := JHDR.AlphaInterlacing;
-
- LoadImageFromPNGFrame(FrameWidth, FrameHeight, FakeIHDR, IDATStream, AlphaImage);
- end
- else
- begin
- // Alpha channel is JPEG compressed
- LoadJpegFromStream(JDAAStream, AlphaImage);
- end;
-
- // Check if alpha channel is the same size as image
- if (Image.Width <> AlphaImage.Width) and (Image.Height <> AlphaImage.Height) then
- ResizeImage(AlphaImage, Image.Width, Image.Height, rfNearest);
-
- // Check alpha channels data format
- GetImageFormatInfo(AlphaImage.Format, FmtInfo);
- if (FmtInfo.BytesPerPixel > 1) or (not FmtInfo.HasGrayChannel) then
- ConvertImage(AlphaImage, ifGray8);
-
- // Convert image to fromat with alpha channel
- if Image.Format = ifGray8 then
- ConvertImage(Image, ifA8Gray8)
- else
- ConvertImage(Image, ifA8R8G8B8);
-
- // Combine alpha channel with image
- AlphaPtr := AlphaImage.Bits;
- if Image.Format = ifA8Gray8 then
- begin
- GrayPtr := Image.Bits;
- for I := 0 to Image.Width * Image.Height - 1 do
- begin
- GrayPtr.High := AlphaPtr^;
- Inc(GrayPtr);
- Inc(AlphaPtr);
- end;
- end
- else
- begin
- ColorPtr := Image.Bits;
- for I := 0 to Image.Width * Image.Height - 1 do
- begin
- ColorPtr.A := AlphaPtr^;
- Inc(ColorPtr);
- Inc(AlphaPtr);
- end;
- end;
-
- FreeImage(AlphaImage);
- end;
-end;
-
-{$ENDIF}
-
-procedure TNGFileLoader.ApplyFrameSettings(Frame: TFrameInfo; var Image: TImageData);
-var
- FmtInfo: TImageFormatInfo;
- BackGroundColor: TColor64Rec;
- ColorKey: TColor64Rec;
- Alphas: PByteArray;
- AlphasSize: LongInt;
- IsColorKeyPresent: Boolean;
- IsBackGroundPresent: Boolean;
- IsColorFormat: Boolean;
-
- procedure ConverttRNS;
- begin
- if FmtInfo.IsIndexed then
- begin
- if Alphas = nil then
- begin
- GetMem(Alphas, Frame.TransparencySize);
- Move(Frame.Transparency^, Alphas^, Frame.TransparencySize);
- AlphasSize := Frame.TransparencySize;
- end;
- end
- else if not FmtInfo.HasAlphaChannel then
- begin
- FillChar(ColorKey, SizeOf(ColorKey), 0);
- Move(Frame.Transparency^, ColorKey, Min(Frame.TransparencySize, SizeOf(ColorKey)));
- if IsColorFormat then
- SwapValues(ColorKey.R, ColorKey.B);
- SwapEndianWord(@ColorKey, 3);
- // 1/2/4 bit images were converted to 8 bit so we must convert color key too
- if (not Frame.IsJpegFrame) and (Frame.IHDR.ColorType in [0, 4]) then
- case Frame.IHDR.BitDepth of
- 1: ColorKey.B := Word(ColorKey.B * 255);
- 2: ColorKey.B := Word(ColorKey.B * 85);
- 4: ColorKey.B := Word(ColorKey.B * 17);
- end;
- IsColorKeyPresent := True;
- end;
- end;
-
- procedure ConvertbKGD;
- begin
- FillChar(BackGroundColor, SizeOf(BackGroundColor), 0);
- Move(Frame.Background^, BackGroundColor, Min(Frame.BackgroundSize,
- SizeOf(BackGroundColor)));
- if IsColorFormat then
- SwapValues(BackGroundColor.R, BackGroundColor.B);
- SwapEndianWord(@BackGroundColor, 3);
- // 1/2/4 bit images were converted to 8 bit so we must convert back color too
- if (not Frame.IsJpegFrame) and (Frame.IHDR.ColorType in [0, 4]) then
- case Frame.IHDR.BitDepth of
- 1: BackGroundColor.B := Word(BackGroundColor.B * 255);
- 2: BackGroundColor.B := Word(BackGroundColor.B * 85);
- 4: BackGroundColor.B := Word(BackGroundColor.B * 17);
- end;
- IsBackGroundPresent := True;
- end;
-
- procedure ReconstructPalette;
- var
- I: LongInt;
- begin
- with Image do
- begin
- GetMem(Palette, FmtInfo.PaletteEntries * SizeOf(TColor32Rec));
- FillChar(Palette^, FmtInfo.PaletteEntries * SizeOf(TColor32Rec), $FF);
- // if RGB palette was loaded from file then use it
- if Frame.Palette <> nil then
- for I := 0 to Min(Frame.PaletteEntries, FmtInfo.PaletteEntries) - 1 do
- with Palette[I] do
- begin
- R := Frame.Palette[I].B;
- G := Frame.Palette[I].G;
- B := Frame.Palette[I].R;
- end;
- // if palette alphas were loaded from file then use them
- if Alphas <> nil then
- for I := 0 to Min(AlphasSize, FmtInfo.PaletteEntries) - 1 do
- Palette[I].A := Alphas[I];
- end;
- end;
-
- procedure ApplyColorKey;
- var
- DestFmt: TImageFormat;
- OldPixel, NewPixel: Pointer;
- begin
- case Image.Format of
- ifGray8: DestFmt := ifA8Gray8;
- ifGray16: DestFmt := ifA16Gray16;
- ifR8G8B8: DestFmt := ifA8R8G8B8;
- ifR16G16B16: DestFmt := ifA16R16G16B16;
- else
- DestFmt := ifUnknown;
- end;
- if DestFmt <> ifUnknown then
- begin
- if not IsBackGroundPresent then
- BackGroundColor := ColorKey;
- ConvertImage(Image, DestFmt);
- OldPixel := @ColorKey;
- NewPixel := @BackGroundColor;
- // Now back color and color key must be converted to image's data format, looks ugly
- case Image.Format of
- ifA8Gray8:
- begin
- TColor32Rec(TInt64Rec(ColorKey).Low).B := Byte(ColorKey.B);
- TColor32Rec(TInt64Rec(ColorKey).Low).G := $FF;
- TColor32Rec(TInt64Rec(BackGroundColor).Low).B := Byte(BackGroundColor.B);
- end;
- ifA16Gray16:
- begin
- ColorKey.G := $FFFF;
- end;
- ifA8R8G8B8:
- begin
- TColor32Rec(TInt64Rec(ColorKey).Low).R := Byte(ColorKey.R);
- TColor32Rec(TInt64Rec(ColorKey).Low).G := Byte(ColorKey.G);
- TColor32Rec(TInt64Rec(ColorKey).Low).B := Byte(ColorKey.B);
- TColor32Rec(TInt64Rec(ColorKey).Low).A := $FF;
- TColor32Rec(TInt64Rec(BackGroundColor).Low).R := Byte(BackGroundColor.R);
- TColor32Rec(TInt64Rec(BackGroundColor).Low).G := Byte(BackGroundColor.G);
- TColor32Rec(TInt64Rec(BackGroundColor).Low).B := Byte(BackGroundColor.B);
- end;
- ifA16R16G16B16:
- begin
- ColorKey.A := $FFFF;
- end;
- end;
- ReplaceColor(Image, 0, 0, Image.Width, Image.Height, OldPixel, NewPixel);
- end;
- end;
-
-begin
- Alphas := nil;
- IsColorKeyPresent := False;
- IsBackGroundPresent := False;
- GetImageFormatInfo(Image.Format, FmtInfo);
-
- IsColorFormat := (Frame.IsJpegFrame and (Frame.JHDR.ColorType in [10, 14])) or
- (not Frame.IsJpegFrame and (Frame.IHDR.ColorType in [2, 6]));
-
- // Convert some chunk data to useful format
- if Frame.Transparency <> nil then
- ConverttRNS;
- if Frame.Background <> nil then
- ConvertbKGD;
-
- // Build palette for indexed images
- if FmtInfo.IsIndexed then
- ReconstructPalette;
-
- // Apply color keying
- if IsColorKeyPresent and not FmtInfo.HasAlphaChannel then
- ApplyColorKey;
-
- FreeMemNil(Alphas);
-end;
-
-{ TNGFileSaver class implementation }
-
-procedure TNGFileSaver.StoreImageToPNGFrame(const IHDR: TIHDR; Bits: Pointer;
- FmtInfo: TImageFormatInfo; IDATStream: TMemoryStream);
-var
- TotalBuffer, CompBuffer, ZeroLine, PrevLine: Pointer;
- FilterLines: array[0..4] of PByteArray;
- TotalSize, CompSize, I, BytesPerLine, BytesPerPixel: LongInt;
- Filter: Byte;
- Adaptive: Boolean;
-
- procedure FilterScanline(Filter: Byte; BytesPerPixel: LongInt; Line, PrevLine, Target: PByteArray);
- var
- I: LongInt;
- begin
- case Filter of
- 0:
- begin
- // No filter
- Move(Line^, Target^, BytesPerLine);
- end;
- 1:
- begin
- // Sub filter
- Move(Line^, Target^, BytesPerPixel);
- for I := BytesPerPixel to BytesPerLine - 1 do
- Target[I] := (Line[I] - Line[I - BytesPerPixel]) and $FF;
- end;
- 2:
- begin
- // Up filter
- for I := 0 to BytesPerLine - 1 do
- Target[I] := (Line[I] - PrevLine[I]) and $FF;
- end;
- 3:
- begin
- // Average filter
- for I := 0 to BytesPerPixel - 1 do
- Target[I] := (Line[I] - PrevLine[I] shr 1) and $FF;
- for I := BytesPerPixel to BytesPerLine - 1 do
- Target[I] := (Line[I] - (Line[I - BytesPerPixel] + PrevLine[I]) shr 1) and $FF;
- end;
- 4:
- begin
- // Paeth filter
- for I := 0 to BytesPerPixel - 1 do
- Target[I] := (Line[I] - PaethPredictor(0, PrevLine[I], 0)) and $FF;
- for I := BytesPerPixel to BytesPerLine - 1 do
- Target[I] := (Line[I] - PaethPredictor(Line[I - BytesPerPixel], PrevLine[I], PrevLine[I - BytesPerPixel])) and $FF;
- end;
- end;
- end;
-
- procedure AdaptiveFilter(var Filter: Byte; BytesPerPixel: LongInt; Line, PrevLine, Target: PByteArray);
- var
- I, J, BestTest: LongInt;
- Sums: array[0..4] of LongInt;
- begin
- // Compute the output scanline using all five filters,
- // and select the filter that gives the smallest sum of
- // absolute values of outputs
- FillChar(Sums, SizeOf(Sums), 0);
- BestTest := MaxInt;
- for I := 0 to 4 do
- begin
- FilterScanline(I, BytesPerPixel, Line, PrevLine, FilterLines[I]);
- for J := 0 to BytesPerLine - 1 do
- Sums[I] := Sums[I] + Abs(ShortInt(FilterLines[I][J]));
- if Sums[I] < BestTest then
- begin
- Filter := I;
- BestTest := Sums[I];
- end;
- end;
- Move(FilterLines[Filter]^, Target^, BytesPerLine);
- end;
-
-begin
- // Select precompression filter and compression level
- Adaptive := False;
- Filter := 0;
- case PreFilter of
- 6:
- if not ((IHDR.BitDepth < 8) or (IHDR.ColorType = 3))
- then Adaptive := True;
- 0..4: Filter := PreFilter;
- else
- if IHDR.ColorType in [2, 6] then
- Filter := 4
- end;
- // Prepare data for compression
- CompBuffer := nil;
- FillChar(FilterLines, SizeOf(FilterLines), 0);
- BytesPerPixel := FmtInfo.BytesPerPixel;
- BytesPerLine := LongInt(IHDR.Width) * BytesPerPixel;
- TotalSize := (BytesPerLine + 1) * LongInt(IHDR.Height);
- GetMem(TotalBuffer, TotalSize);
- GetMem(ZeroLine, BytesPerLine);
- FillChar(ZeroLine^, BytesPerLine, 0);
- if Adaptive then
- for I := 0 to 4 do
- GetMem(FilterLines[I], BytesPerLine);
- PrevLine := ZeroLine;
- try
- // Process next scanlines
- for I := 0 to IHDR.Height - 1 do
- begin
- // Filter scanline
- if Adaptive then
- AdaptiveFilter(Filter, BytesPerPixel, @PByteArray(Bits)[I * BytesPerLine],
- PrevLine, @PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + 1])
- else
- FilterScanline(Filter, BytesPerPixel, @PByteArray(Bits)[I * BytesPerLine],
- PrevLine, @PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + 1]);
- PrevLine := @PByteArray(Bits)[I * BytesPerLine];
- // Swap red and blue if necessary
- if (IHDR.ColorType in [2, 6]) and not FmtInfo.IsRBSwapped then
- SwapRGB(@PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + 1],
- IHDR.Width, IHDR.BitDepth, FmtInfo.BytesPerPixel);
- // Images with 16 bit channels must be swapped because of PNG's big endianess
- if IHDR.BitDepth = 16 then
- SwapEndianWord(@PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + 1],
- BytesPerLine div SizeOf(Word));
- // Set filter used for this scanline
- PByteArray(TotalBuffer)[I * (BytesPerLine + 1)] := Filter;
- end;
- // Compress IDAT data
- CompressBuf(TotalBuffer, TotalSize, CompBuffer, CompSize, CompressLevel);
- // Write IDAT data to stream
- IDATStream.WriteBuffer(CompBuffer^, CompSize);
- finally
- FreeMem(TotalBuffer);
- FreeMem(CompBuffer);
- FreeMem(ZeroLine);
- if Adaptive then
- for I := 0 to 4 do
- FreeMem(FilterLines[I]);
- end;
-end;
-
-{$IFNDEF DONT_LINK_JNG}
-
-procedure TNGFileSaver.StoreImageToJNGFrame(const JHDR: TJHDR;
- const Image: TImageData; IDATStream, JDATStream,
- JDAAStream: TMemoryStream);
-var
- ColorImage, AlphaImage: TImageData;
- FmtInfo: TImageFormatInfo;
- AlphaPtr: PByte;
- GrayPtr: PWordRec;
- ColorPtr: PColor32Rec;
- I: LongInt;
- FakeIHDR: TIHDR;
-
- procedure SaveJpegToStream(Stream: TStream; const Image: TImageData);
- var
- JpegFormat: TCustomIOJpegFileFormat;
- Handle: TImagingHandle;
- DynImages: TDynImageDataArray;
- begin
- JpegFormat := TCustomIOJpegFileFormat.Create;
- JpegFormat.SetCustomIO(StreamIO);
- // Only JDAT stream can be saved progressive
- if Stream = JDATStream then
- JpegFormat.FProgressive := Progressive
- else
- JpegFormat.FProgressive := False;
- JpegFormat.FQuality := Quality;
- SetLength(DynImages, 1);
- DynImages[0] := Image;
- Handle := StreamIO.OpenWrite(Pointer(Stream));
- try
- JpegFormat.SaveData(Handle, DynImages, 0);
- finally
- StreamIO.Close(Handle);
- SetLength(DynImages, 0);
- JpegFormat.Free;
- end;
- end;
-
-begin
- GetImageFormatInfo(Image.Format, FmtInfo);
- InitImage(ColorImage);
- InitImage(AlphaImage);
-
- if FmtInfo.HasAlphaChannel then
- begin
- // Create new image for alpha channel and color image without alpha
- CloneImage(Image, ColorImage);
- NewImage(Image.Width, Image.Height, ifGray8, AlphaImage);
- case Image.Format of
- ifA8Gray8: ConvertImage(ColorImage, ifGray8);
- ifA8R8G8B8: ConvertImage(ColorImage, ifR8G8B8);
- end;
-
- // Store source image's alpha to separate image
- AlphaPtr := AlphaImage.Bits;
- if Image.Format = ifA8Gray8 then
- begin
- GrayPtr := Image.Bits;
- for I := 0 to Image.Width * Image.Height - 1 do
- begin
- AlphaPtr^ := GrayPtr.High;
- Inc(GrayPtr);
- Inc(AlphaPtr);
- end;
- end
- else
- begin
- ColorPtr := Image.Bits;
- for I := 0 to Image.Width * Image.Height - 1 do
- begin
- AlphaPtr^ := ColorPtr.A;
- Inc(ColorPtr);
- Inc(AlphaPtr);
- end;
- end;
-
- // Write color image to stream as JPEG
- SaveJpegToStream(JDATStream, ColorImage);
-
- if LossyAlpha then
- begin
- // Write alpha image to stream as JPEG
- SaveJpegToStream(JDAAStream, AlphaImage);
- end
- else
- begin
- // Alpha channel is PNG compressed
- FakeIHDR.Width := JHDR.Width;
- FakeIHDR.Height := JHDR.Height;
- FakeIHDR.ColorType := 0;
- FakeIHDR.BitDepth := JHDR.AlphaSampleDepth;
- FakeIHDR.Filter := JHDR.AlphaFilter;
- FakeIHDR.Interlacing := JHDR.AlphaInterlacing;
-
- GetImageFormatInfo(AlphaImage.Format, FmtInfo);
- StoreImageToPNGFrame(FakeIHDR, AlphaImage.Bits, FmtInfo, IDATStream);
- end;
-
- FreeImage(ColorImage);
- FreeImage(AlphaImage);
- end
- else
- begin
- // Simply write JPEG to stream
- SaveJpegToStream(JDATStream, Image);
- end;
-end;
-
-{$ENDIF}
-
-procedure TNGFileSaver.AddFrame(const Image: TImageData; IsJpegFrame: Boolean);
-var
- Frame: TFrameInfo;
- FmtInfo: TImageFormatInfo;
-
- procedure StorePalette;
- var
- Pal: PPalette24;
- Alphas: PByteArray;
- I, PalBytes: LongInt;
- AlphasDiffer: Boolean;
- begin
- // Fill and save RGB part of palette to PLTE chunk
- PalBytes := FmtInfo.PaletteEntries * SizeOf(TColor24Rec);
- GetMem(Pal, PalBytes);
- AlphasDiffer := False;
- for I := 0 to FmtInfo.PaletteEntries - 1 do
- begin
- Pal[I].B := Image.Palette[I].R;
- Pal[I].G := Image.Palette[I].G;
- Pal[I].R := Image.Palette[I].B;
- if Image.Palette[I].A < 255 then
- AlphasDiffer := True;
- end;
- Frame.Palette := Pal;
- Frame.PaletteEntries := FmtInfo.PaletteEntries;
- // Fill and save alpha part (if there are any alphas < 255) of palette to tRNS chunk
- if AlphasDiffer then
- begin
- PalBytes := FmtInfo.PaletteEntries * SizeOf(Byte);
- GetMem(Alphas, PalBytes);
- for I := 0 to FmtInfo.PaletteEntries - 1 do
- Alphas[I] := Image.Palette[I].A;
- Frame.Transparency := Alphas;
- Frame.TransparencySize := PalBytes;
- end;
- end;
-
-begin
- // Add new frame
- Frame := AddFrameInfo;
- Frame.IsJpegFrame := IsJpegFrame;
-
- with Frame do
- begin
- GetImageFormatInfo(Image.Format, FmtInfo);
-
- if IsJpegFrame then
- begin
-{$IFNDEF DONT_LINK_JNG}
- // Fill JNG header
- JHDR.Width := Image.Width;
- JHDR.Height := Image.Height;
- case Image.Format of
- ifGray8: JHDR.ColorType := 8;
- ifR8G8B8: JHDR.ColorType := 10;
- ifA8Gray8: JHDR.ColorType := 12;
- ifA8R8G8B8: JHDR.ColorType := 14;
- end;
- JHDR.SampleDepth := 8; // 8-bit samples and quantization tables
- JHDR.Compression := 8; // Huffman coding
- JHDR.Interlacing := Iff(Progressive, 8, 0);
- JHDR.AlphaSampleDepth := Iff(FmtInfo.HasAlphaChannel, 8, 0);
- JHDR.AlphaCompression := Iff(LossyAlpha, 8, 0);
- JHDR.AlphaFilter := 0;
- JHDR.AlphaInterlacing := 0;
-
- StoreImageToJNGFrame(JHDR, Image, IDATMemory, JDATMemory, JDAAMemory);
-
- // Finally swap endian
- SwapEndianLongWord(@JHDR, 2);
-{$ENDIF}
- end
- else
- begin
- // Fill PNG header
- IHDR.Width := Image.Width;
- IHDR.Height := Image.Height;
- IHDR.Compression := 0;
- IHDR.Filter := 0;
- IHDR.Interlacing := 0;
- IHDR.BitDepth := FmtInfo.BytesPerPixel * 8;
-
- // Select appropiate PNG color type and modify bitdepth
- if FmtInfo.HasGrayChannel then
- begin
- IHDR.ColorType := 0;
- if FmtInfo.HasAlphaChannel then
- begin
- IHDR.ColorType := 4;
- IHDR.BitDepth := IHDR.BitDepth div 2;
- end;
- end
- else
- begin
- if FmtInfo.IsIndexed then
- IHDR.ColorType := 3
- else
- if FmtInfo.HasAlphaChannel then
- begin
- IHDR.ColorType := 6;
- IHDR.BitDepth := IHDR.BitDepth div 4;
- end
- else
- begin
- IHDR.ColorType := 2;
- IHDR.BitDepth := IHDR.BitDepth div 3;
- end;
- end;
-
- if FileType = ngAPNG then
- begin
- // Fill fcTL chunk of APNG file
- fcTL.SeqNumber := 0; // Decided when writing to file
- fcTL.Width := IHDR.Width;
- fcTL.Height := IHDR.Height;
- fcTL.XOffset := 0;
- fcTL.YOffset := 0;
- fcTL.DelayNumer := 1;
- fcTL.DelayDenom := 3;
- fcTL.DisposeOp := DisposeOpNone;
- fcTL.BlendOp := BlendOpSource;
- SwapEndianLongWord(@fcTL, 5);
- fcTL.DelayNumer := SwapEndianWord(fcTL.DelayNumer);
- fcTL.DelayDenom := SwapEndianWord(fcTL.DelayDenom);
- end;
-
- // Compress PNG image and store it to stream
- StoreImageToPNGFrame(IHDR, Image.Bits, FmtInfo, IDATMemory);
- // Store palette if necesary
- if FmtInfo.IsIndexed then
- StorePalette;
-
- // Finally swap endian
- SwapEndianLongWord(@IHDR, 2);
- end;
- end;
-end;
-
-function TNGFileSaver.SaveFile(Handle: TImagingHandle): Boolean;
-var
- I: LongInt;
- Chunk: TChunkHeader;
- SeqNo: LongWord;
-
- function GetNextSeqNo: LongWord;
- begin
- // Seq numbers of fcTL and fdAT are "interleaved" as they share the counter.
- // Example: first fcTL for IDAT has seq=0, next is fcTL for seond frame with
- // seq=1, then first fdAT with seq=2, fcTL seq=3, fdAT=4, ...
- Result := SwapEndianLongWord(SeqNo);
- Inc(SeqNo);
- end;
-
- function CalcChunkCrc(const ChunkHdr: TChunkHeader; Data: Pointer;
- Size: LongInt): LongWord;
- begin
- Result := $FFFFFFFF;
- CalcCrc32(Result, @ChunkHdr.ChunkID, SizeOf(ChunkHdr.ChunkID));
- CalcCrc32(Result, Data, Size);
- Result := SwapEndianLongWord(Result xor $FFFFFFFF);
- end;
-
- procedure WriteChunk(var Chunk: TChunkHeader; ChunkData: Pointer);
- var
- ChunkCrc: LongWord;
- SizeToWrite: LongInt;
- begin
- SizeToWrite := Chunk.DataSize;
- Chunk.DataSize := SwapEndianLongWord(Chunk.DataSize);
- ChunkCrc := CalcChunkCrc(Chunk, ChunkData, SizeToWrite);
- GetIO.Write(Handle, @Chunk, SizeOf(Chunk));
- if SizeToWrite <> 0 then
- GetIO.Write(Handle, ChunkData, SizeToWrite);
- GetIO.Write(Handle, @ChunkCrc, SizeOf(ChunkCrc));
- end;
-
- procedure WritefdAT(Frame: TFrameInfo);
- var
- ChunkCrc: LongWord;
- ChunkSeqNo: LongWord;
- begin
- Chunk.ChunkID := fdATChunk;
- ChunkSeqNo := GetNextSeqNo;
- // fdAT saves seq number LongWord before compressed pixels
- Chunk.DataSize := Frame.IDATMemory.Size + SizeOf(LongWord);
- Chunk.DataSize := SwapEndianLongWord(Chunk.DataSize);
- // Calc CRC
- ChunkCrc := $FFFFFFFF;
- CalcCrc32(ChunkCrc, @Chunk.ChunkID, SizeOf(Chunk.ChunkID));
- CalcCrc32(ChunkCrc, @ChunkSeqNo, SizeOf(ChunkSeqNo));
- CalcCrc32(ChunkCrc, Frame.IDATMemory.Memory, Frame.IDATMemory.Size);
- ChunkCrc := SwapEndianLongWord(ChunkCrc xor $FFFFFFFF);
- // Write out all fdAT data
- GetIO.Write(Handle, @Chunk, SizeOf(Chunk));
- GetIO.Write(Handle, @ChunkSeqNo, SizeOf(ChunkSeqNo));
- GetIO.Write(Handle, Frame.IDATMemory.Memory, Frame.IDATMemory.Size);
- GetIO.Write(Handle, @ChunkCrc, SizeOf(ChunkCrc));
- end;
-
- procedure WritePNGMainImageChunks(Frame: TFrameInfo);
- begin
- with Frame do
- begin
- // Write IHDR chunk
- Chunk.DataSize := SizeOf(IHDR);
- Chunk.ChunkID := IHDRChunk;
- WriteChunk(Chunk, @IHDR);
- // Write PLTE chunk if data is present
- if Palette <> nil then
- begin
- Chunk.DataSize := PaletteEntries * SizeOf(TColor24Rec);
- Chunk.ChunkID := PLTEChunk;
- WriteChunk(Chunk, Palette);
- end;
- // Write tRNS chunk if data is present
- if Transparency <> nil then
- begin
- Chunk.DataSize := TransparencySize;
- Chunk.ChunkID := tRNSChunk;
- WriteChunk(Chunk, Transparency);
- end;
- end;
- end;
-
-begin
- Result := False;
- SeqNo := 0;
-
- case FileType of
- ngPNG, ngAPNG: GetIO.Write(Handle, @PNGSignature, SizeOf(TChar8));
- ngMNG: GetIO.Write(Handle, @MNGSignature, SizeOf(TChar8));
- ngJNG: GetIO.Write(Handle, @JNGSignature, SizeOf(TChar8));
- end;
-
- if FileType = ngMNG then
- begin
- SwapEndianLongWord(@MHDR, SizeOf(MHDR) div SizeOf(LongWord));
- Chunk.DataSize := SizeOf(MHDR);
- Chunk.ChunkID := MHDRChunk;
- WriteChunk(Chunk, @MHDR);
- end;
-
- for I := 0 to Length(Frames) - 1 do
- with Frames[I] do
- begin
- if IsJpegFrame then
- begin
- // Write JHDR chunk
- Chunk.DataSize := SizeOf(JHDR);
- Chunk.ChunkID := JHDRChunk;
- WriteChunk(Chunk, @JHDR);
- // Write JNG image data
- Chunk.DataSize := JDATMemory.Size;
- Chunk.ChunkID := JDATChunk;
- WriteChunk(Chunk, JDATMemory.Memory);
- // Write alpha channel if present
- if JHDR.AlphaSampleDepth > 0 then
- begin
- if JHDR.AlphaCompression = 0 then
- begin
- // Alpha is PNG compressed
- Chunk.DataSize := IDATMemory.Size;
- Chunk.ChunkID := IDATChunk;
- WriteChunk(Chunk, IDATMemory.Memory);
- end
- else
- begin
- // Alpha is JNG compressed
- Chunk.DataSize := JDAAMemory.Size;
- Chunk.ChunkID := JDAAChunk;
- WriteChunk(Chunk, JDAAMemory.Memory);
- end;
- end;
- // Write image end
- Chunk.DataSize := 0;
- Chunk.ChunkID := IENDChunk;
- WriteChunk(Chunk, nil);
- end
- else if FileType <> ngAPNG then
- begin
- // Regular PNG frame (single PNG image or MNG frame)
- WritePNGMainImageChunks(Frames[I]);
- // Write PNG image data
- Chunk.DataSize := IDATMemory.Size;
- Chunk.ChunkID := IDATChunk;
- WriteChunk(Chunk, IDATMemory.Memory);
- // Write image end
- Chunk.DataSize := 0;
- Chunk.ChunkID := IENDChunk;
- WriteChunk(Chunk, nil);
- end
- else if FileType = ngAPNG then
- begin
- // APNG frame - first frame must have acTL and fcTL before IDAT,
- // subsequent frames have fcTL and fdAT.
- if I = 0 then
- begin
- WritePNGMainImageChunks(Frames[I]);
- Chunk.DataSize := SizeOf(acTL);
- Chunk.ChunkID := acTLChunk;
- WriteChunk(Chunk, @acTL);
- end;
- // Write fcTL before frame data
- Chunk.DataSize := SizeOf(fcTL);
- Chunk.ChunkID := fcTLChunk;
- fcTl.SeqNumber := GetNextSeqNo;
- WriteChunk(Chunk, @fcTL);
- // Write data - IDAT for first frame and fdAT for following ones
- if I = 0 then
- begin
- Chunk.DataSize := IDATMemory.Size;
- Chunk.ChunkID := IDATChunk;
- WriteChunk(Chunk, IDATMemory.Memory);
- end
- else
- WritefdAT(Frames[I]);
- // Write image end after last frame
- if I = Length(Frames) - 1 then
- begin
- Chunk.DataSize := 0;
- Chunk.ChunkID := IENDChunk;
- WriteChunk(Chunk, nil);
- end;
- end;
- end;
-
- if FileType = ngMNG then
- begin
- Chunk.DataSize := 0;
- Chunk.ChunkID := MENDChunk;
- WriteChunk(Chunk, nil);
- end;
-end;
-
-procedure TNGFileSaver.SetFileOptions(FileFormat: TNetworkGraphicsFileFormat);
-begin
- PreFilter := FileFormat.FPreFilter;
- CompressLevel := FileFormat.FCompressLevel;
- LossyAlpha := FileFormat.FLossyAlpha;
- Quality := FileFormat.FQuality;
- Progressive := FileFormat.FProgressive;
-end;
-
-{ TAPNGAnimator class implemnetation }
-
-class procedure TAPNGAnimator.Animate(var Images: TDynImageDataArray;
- const acTL: TacTL; const SrcFrames: array of TFrameInfo);
-var
- I, SrcIdx, Offset, Len: Integer;
- DestFrames: TDynImageDataArray;
- SrcCanvas, DestCanvas: TImagingCanvas;
- PreviousCache: TImageData;
-
- function AnimatingNeeded: Boolean;
- var
- I: Integer;
- begin
- Result := False;
- for I := 0 to Len - 1 do
- with SrcFrames[I] do
- begin
- if (FrameWidth <> IHDR.Width) or (FrameHeight <> IHDR.Height) or (Len <> acTL.NumFrames) or
- (not ((fcTL.DisposeOp = DisposeOpNone) and (fcTL.BlendOp = BlendOpSource)) and
- not ((fcTL.DisposeOp = DisposeOpBackground) and (fcTL.BlendOp = BlendOpSource)) and
- not ((fcTL.DisposeOp = DisposeOpBackground) and (fcTL.BlendOp = BlendOpOver))) then
- begin
- Result := True;
- Exit;
- end;
- end;
- end;
-
-begin
- Len := Length(SrcFrames);
- if (Len = 0) or not AnimatingNeeded then
- Exit;
-
- if (Len = acTL.NumFrames + 1) and (SrcFrames[0].fcTL.Width = 0) then
- begin
- // If default image (stored in IDAT chunk) isn't part of animation we ignore it
- Offset := 1;
- Len := Len - 1;
- end
- else
- Offset := 0;
-
- SetLength(DestFrames, Len);
- DestCanvas := ImagingCanvases.FindBestCanvasForImage(Images[0]).Create;
- SrcCanvas := ImagingCanvases.FindBestCanvasForImage(Images[0]).Create;
- InitImage(PreviousCache);
- NewImage(SrcFrames[0].IHDR.Width, SrcFrames[0].IHDR.Height, Images[0].Format, PreviousCache);
-
- for I := 0 to Len - 1 do
- begin
- SrcIdx := I + Offset;
- NewImage(SrcFrames[SrcIdx].IHDR.Width, SrcFrames[SrcIdx].IHDR.Height,
- Images[SrcIdx].Format, DestFrames[I]);
- if DestFrames[I].Format = ifIndex8 then
- Move(Images[SrcIdx].Palette^, DestFrames[I].Palette^, 256 * SizeOf(TColor32));
- DestCanvas.CreateForData(@DestFrames[I]);
-
- if (SrcFrames[SrcIdx].fcTL.DisposeOp = DisposeOpPrevious) and (SrcFrames[SrcIdx - 1].fcTL.DisposeOp <> DisposeOpPrevious) then
- begin
- // Cache current output buffer so we may return to it later (previous dispose op)
- CopyRect(DestFrames[I - 1], 0, 0, DestFrames[I - 1].Width, DestFrames[I - 1].Height,
- PreviousCache, 0, 0);
- end;
-
- if (I = 0) or (SrcIdx = 0) then
- begin
- // Clear whole frame with transparent black color (default for first frame)
- DestCanvas.FillColor32 := pcClear;
- DestCanvas.Clear;
- end
- else if SrcFrames[SrcIdx - 1].fcTL.DisposeOp = DisposeOpBackground then
- begin
- // Restore background color (clear) on previous frame's area and leave previous content outside of it
- CopyRect(DestFrames[I - 1], 0, 0, DestFrames[I - 1].Width, DestFrames[I - 1].Height,
- DestFrames[I], 0, 0);
- DestCanvas.FillColor32 := pcClear;
- DestCanvas.FillRect(BoundsToRect(SrcFrames[SrcIdx - 1].fcTL.XOffset, SrcFrames[SrcIdx - 1].fcTL.YOffset,
- SrcFrames[SrcIdx - 1].FrameWidth, SrcFrames[SrcIdx - 1].FrameHeight));
- end
- else if SrcFrames[SrcIdx - 1].fcTL.DisposeOp = DisposeOpNone then
- begin
- // Clone previous frame - no change to output buffer
- CopyRect(DestFrames[I - 1], 0, 0, DestFrames[I - 1].Width, DestFrames[I - 1].Height,
- DestFrames[I], 0, 0);
- end
- else if SrcFrames[SrcIdx - 1].fcTL.DisposeOp = DisposeOpPrevious then
- begin
- // Revert to previous frame (cached, can't just restore DestFrames[I - 2])
- CopyRect(PreviousCache, 0, 0, PreviousCache.Width, PreviousCache.Height,
- DestFrames[I], 0, 0);
- end;
-
- // Copy pixels or alpha blend them over
- if SrcFrames[SrcIdx].fcTL.BlendOp = BlendOpSource then
- begin
- CopyRect(Images[SrcIdx], 0, 0, Images[SrcIdx].Width, Images[SrcIdx].Height,
- DestFrames[I], SrcFrames[SrcIdx].fcTL.XOffset, SrcFrames[SrcIdx].fcTL.YOffset);
- end
- else if SrcFrames[SrcIdx].fcTL.BlendOp = BlendOpOver then
- begin
- SrcCanvas.CreateForData(@Images[SrcIdx]);
- SrcCanvas.DrawAlpha(SrcCanvas.ClipRect, DestCanvas,
- SrcFrames[SrcIdx].fcTL.XOffset, SrcFrames[SrcIdx].fcTL.YOffset);
- end;
-
- FreeImage(Images[SrcIdx]);
- end;
-
- DestCanvas.Free;
- SrcCanvas.Free;
- FreeImage(PreviousCache);
-
- // Assign dest frames to final output images
- Images := DestFrames;
-end;
-
-{ TNetworkGraphicsFileFormat class implementation }
-
-constructor TNetworkGraphicsFileFormat.Create;
-begin
- inherited Create;
- FCanLoad := True;
- FCanSave := True;
- FIsMultiImageFormat := False;
-
- FPreFilter := NGDefaultPreFilter;
- FCompressLevel := NGDefaultCompressLevel;
- FLossyAlpha := NGDefaultLossyAlpha;
- FLossyCompression := NGDefaultLossyCompression;
- FQuality := NGDefaultQuality;
- FProgressive := NGDefaultProgressive;
-end;
-
-procedure TNetworkGraphicsFileFormat.CheckOptionsValidity;
-begin
- // Just check if save options has valid values
- if not (FPreFilter in [0..6]) then
- FPreFilter := NGDefaultPreFilter;
- if not (FCompressLevel in [0..9]) then
- FCompressLevel := NGDefaultCompressLevel;
- if not (FQuality in [1..100]) then
- FQuality := NGDefaultQuality;
-end;
-
-function TNetworkGraphicsFileFormat.GetSupportedFormats: TImageFormats;
-begin
- if FLossyCompression then
- Result := NGLossyFormats
- else
- Result := NGLosslessFormats;
-end;
-
-procedure TNetworkGraphicsFileFormat.ConvertToSupported(var Image: TImageData;
- const Info: TImageFormatInfo);
-var
- ConvFormat: TImageFormat;
-begin
- if not FLossyCompression then
- begin
- // Convert formats for lossless compression
- if Info.HasGrayChannel then
- begin
- if Info.HasAlphaChannel then
- begin
- if Info.BytesPerPixel <= 2 then
- // Convert <= 16bit grayscale images with alpha to ifA8Gray8
- ConvFormat := ifA8Gray8
- else
- // Convert > 16bit grayscale images with alpha to ifA16Gray16
- ConvFormat := ifA16Gray16
- end
- else
- // Convert grayscale images without alpha to ifGray16
- ConvFormat := ifGray16;
- end
- else
- if Info.IsFloatingPoint then
- // Convert floating point images to 64 bit ARGB (or RGB if no alpha)
- ConvFormat := IffFormat(Info.HasAlphaChannel, ifA16B16G16R16, ifB16G16R16)
- else if Info.HasAlphaChannel or Info.IsSpecial then
- // Convert all other images with alpha or special images to A8R8G8B8
- ConvFormat := ifA8R8G8B8
- else
- // Convert images without alpha to R8G8B8
- ConvFormat := ifR8G8B8;
- end
- else
- begin
- // Convert formats for lossy compression
- if Info.HasGrayChannel then
- ConvFormat := IffFormat(Info.HasAlphaChannel, ifA8Gray8, ifGray8)
- else
- ConvFormat := IffFormat(Info.HasAlphaChannel, ifA8R8G8B8, ifR8G8B8);
- end;
-
- ConvertImage(Image, ConvFormat);
-end;
-
-function TNetworkGraphicsFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
-var
- ReadCount: LongInt;
- Sig: TChar8;
-begin
- Result := False;
- if Handle <> nil then
- with GetIO do
- begin
- FillChar(Sig, SizeOf(Sig), 0);
- ReadCount := Read(Handle, @Sig, SizeOf(Sig));
- Seek(Handle, -ReadCount, smFromCurrent);
- Result := (ReadCount = SizeOf(Sig)) and (Sig = FSignature);
- end;
-end;
-
-{ TPNGFileFormat class implementation }
-
-constructor TPNGFileFormat.Create;
-begin
- inherited Create;
- FName := SPNGFormatName;
- FIsMultiImageFormat := True;
- FLoadAnimated := PNGDefaultLoadAnimated;
- AddMasks(SPNGMasks);
-
- FSignature := PNGSignature;
-
- RegisterOption(ImagingPNGPreFilter, @FPreFilter);
- RegisterOption(ImagingPNGCompressLevel, @FCompressLevel);
- RegisterOption(ImagingPNGLoadAnimated, @FLoadAnimated);
-end;
-
-function TPNGFileFormat.LoadData(Handle: TImagingHandle;
- var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
-var
- I, Len: LongInt;
- NGFileLoader: TNGFileLoader;
-begin
- Result := False;
- NGFileLoader := TNGFileLoader.Create;
- try
- // Use NG file parser to load file
- if NGFileLoader.LoadFile(Handle) and (Length(NGFileLoader.Frames) > 0) then
- begin
- Len := Length(NGFileLoader.Frames);
- SetLength(Images, Len);
- for I := 0 to Len - 1 do
- with NGFileLoader.Frames[I] do
- begin
- // Build actual image bits
- if not IsJpegFrame then
- NGFileLoader.LoadImageFromPNGFrame(FrameWidth, FrameHeight, IHDR, IDATMemory, Images[I]);
- // Build palette, aply color key or background
- NGFileLoader.ApplyFrameSettings(NGFileLoader.Frames[I], Images[I]);
- Result := True;
- end;
- // Animate APNG images
- if (NGFileLoader.FileType = ngAPNG) and FLoadAnimated then
- TAPNGAnimator.Animate(Images, NGFileLoader.acTL, NGFileLoader.Frames);
- end;
- finally
- NGFileLoader.Free;
- end;
-end;
-
-function TPNGFileFormat.SaveData(Handle: TImagingHandle;
- const Images: TDynImageDataArray; Index: LongInt): Boolean;
-var
- I: Integer;
- ImageToSave: TImageData;
- MustBeFreed: Boolean;
- NGFileSaver: TNGFileSaver;
- DefaultFormat: TImageFormat;
- Screen: TImageData;
- AnimWidth, AnimHeight: Integer;
-begin
- Result := False;
- DefaultFormat := ifDefault;
- AnimWidth := 0;
- AnimHeight := 0;
- NGFileSaver := TNGFileSaver.Create;
-
- // Save images with more frames as APNG format
- if Length(Images) > 1 then
- begin
- NGFileSaver.FileType := ngAPNG;
- NGFileSaver.acTL.NumFrames := FLastIdx - FFirstIdx + 1;
- NGFileSaver.acTL.NumPlay := 1;
- SwapEndianLongWord(@NGFileSaver.acTL, SizeOf(NGFileSaver.acTL) div SizeOf(LongWord));
- // Get max dimensions of frames
- AnimWidth := Images[FFirstIdx].Width;
- AnimHeight := Images[FFirstIdx].Height;
- for I := FFirstIdx + 1 to FLastIdx do
- begin
- AnimWidth := Max(AnimWidth, Images[I].Width);
- AnimHeight := Max(AnimHeight, Images[I].Height);
- end;
- end
- else
- NGFileSaver.FileType := ngPNG;
- NGFileSaver.SetFileOptions(Self);
-
- with NGFileSaver do
- try
- // Store all frames to be saved frames file saver
- for I := FFirstIdx to FLastIdx do
- begin
- if MakeCompatible(Images[I], ImageToSave, MustBeFreed) then
- try
- if FileType = ngAPNG then
- begin
- // IHDR chunk is shared for all frames so all frames must have the
- // same data format as the first image.
- if I = FFirstIdx then
- begin
- DefaultFormat := ImageToSave.Format;
- // Subsequenet frames may be bigger than the first one.
- // APNG doens't support this - max allowed size is what's written in
- // IHDR - size of main/default/first image. If some frame is
- // bigger than the first one we need to resize (create empty bigger
- // image and copy) the first frame so all following frames could fit to
- // its area.
- if (ImageToSave.Width <> AnimWidth) or (ImageToSave.Height <> AnimHeight) then
- begin
- InitImage(Screen);
- NewImage(AnimWidth, AnimHeight, ImageToSave.Format, Screen);
- CopyRect(ImageToSave, 0, 0, ImageToSave.Width, ImageToSave.Height, Screen, 0, 0);
- if MustBeFreed then
- FreeImage(ImageToSave);
- ImageToSave := Screen;
- end;
- end
- else if ImageToSave.Format <> DefaultFormat then
- begin
- if MustBeFreed then
- ConvertImage(ImageToSave, DefaultFormat)
- else
- begin
- CloneImage(Images[I], ImageToSave);
- ConvertImage(ImageToSave, DefaultFormat);
- MustBeFreed := True;
- end;
- end;
- end;
-
- // Add image as PNG frame
- AddFrame(ImageToSave, False);
- finally
- if MustBeFreed then
- FreeImage(ImageToSave);
- end
- else
- Exit;
- end;
-
- // Finally save PNG file
- SaveFile(Handle);
- Result := True;
- finally
- NGFileSaver.Free;
- end;
-end;
-
-{$IFNDEF DONT_LINK_MNG}
-
-{ TMNGFileFormat class implementation }
-
-constructor TMNGFileFormat.Create;
-begin
- inherited Create;
- FName := SMNGFormatName;
- FIsMultiImageFormat := True;
- AddMasks(SMNGMasks);
-
- FSignature := MNGSignature;
-
- RegisterOption(ImagingMNGLossyCompression, @FLossyCompression);
- RegisterOption(ImagingMNGLossyAlpha, @FLossyAlpha);
- RegisterOption(ImagingMNGPreFilter, @FPreFilter);
- RegisterOption(ImagingMNGCompressLevel, @FCompressLevel);
- RegisterOption(ImagingMNGQuality, @FQuality);
- RegisterOption(ImagingMNGProgressive, @FProgressive);
-end;
-
-function TMNGFileFormat.LoadData(Handle: TImagingHandle;
- var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
-var
- NGFileLoader: TNGFileLoader;
- I, Len: LongInt;
-begin
- Result := False;
- NGFileLoader := TNGFileLoader.Create;
- try
- // Use NG file parser to load file
- if NGFileLoader.LoadFile(Handle) then
- begin
- Len := Length(NGFileLoader.Frames);
- if Len > 0 then
- begin
- SetLength(Images, Len);
- for I := 0 to Len - 1 do
- with NGFileLoader.Frames[I] do
- begin
- // Build actual image bits
- if IsJpegFrame then
- NGFileLoader.LoadImageFromJNGFrame(FrameWidth, FrameHeight, JHDR, IDATMemory, JDATMemory, JDAAMemory, Images[I])
- else
- NGFileLoader.LoadImageFromPNGFrame(FrameWidth, FrameHeight, IHDR, IDATMemory, Images[I]);
- // Build palette, aply color key or background
- NGFileLoader.ApplyFrameSettings(NGFileLoader.Frames[I], Images[I]);
- end;
- end
- else
- begin
- // Some MNG files (with BASI-IEND streams) dont have actual pixel data
- SetLength(Images, 1);
- NewImage(NGFileLoader.MHDR.FrameWidth, NGFileLoader.MHDR.FrameWidth, ifDefault, Images[0]);
- end;
- Result := True;
- end;
- finally
- NGFileLoader.Free;
- end;
-end;
-
-function TMNGFileFormat.SaveData(Handle: TImagingHandle;
- const Images: TDynImageDataArray; Index: LongInt): Boolean;
-var
- NGFileSaver: TNGFileSaver;
- I, LargestWidth, LargestHeight: LongInt;
- ImageToSave: TImageData;
- MustBeFreed: Boolean;
-begin
- Result := False;
- LargestWidth := 0;
- LargestHeight := 0;
-
- NGFileSaver := TNGFileSaver.Create;
- NGFileSaver.FileType := ngMNG;
- NGFileSaver.SetFileOptions(Self);
-
- with NGFileSaver do
- try
- // Store all frames to be saved frames file saver
- for I := FFirstIdx to FLastIdx do
- begin
- if MakeCompatible(Images[I], ImageToSave, MustBeFreed) then
- try
- // Add image as PNG or JNG frame
- AddFrame(ImageToSave, FLossyCompression);
- // Remember largest frame width and height
- LargestWidth := Iff(LargestWidth < ImageToSave.Width, ImageToSave.Width, LargestWidth);
- LargestHeight := Iff(LargestHeight < ImageToSave.Height, ImageToSave.Height, LargestHeight);
- finally
- if MustBeFreed then
- FreeImage(ImageToSave);
- end
- else
- Exit;
- end;
-
- // Fill MNG header
- MHDR.FrameWidth := LargestWidth;
- MHDR.FrameHeight := LargestHeight;
- MHDR.TicksPerSecond := 0;
- MHDR.NominalLayerCount := 0;
- MHDR.NominalFrameCount := Length(Frames);
- MHDR.NominalPlayTime := 0;
- MHDR.SimplicityProfile := 473; // 111011001 binary, defines MNG-VLC with transparency and JNG support
-
- // Finally save MNG file
- SaveFile(Handle);
- Result := True;
- finally
- NGFileSaver.Free;
- end;
-end;
-
-{$ENDIF}
-
-{$IFNDEF DONT_LINK_JNG}
-
-{ TJNGFileFormat class implementation }
-
-constructor TJNGFileFormat.Create;
-begin
- inherited Create;
- FName := SJNGFormatName;
- AddMasks(SJNGMasks);
-
- FSignature := JNGSignature;
- FLossyCompression := True;
-
- RegisterOption(ImagingJNGLossyAlpha, @FLossyAlpha);
- RegisterOption(ImagingJNGAlphaPreFilter, @FPreFilter);
- RegisterOption(ImagingJNGAlphaCompressLevel, @FCompressLevel);
- RegisterOption(ImagingJNGQuality, @FQuality);
- RegisterOption(ImagingJNGProgressive, @FProgressive);
-end;
-
-function TJNGFileFormat.LoadData(Handle: TImagingHandle;
- var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
-var
- NGFileLoader: TNGFileLoader;
-begin
- Result := False;
- NGFileLoader := TNGFileLoader.Create;
- try
- // Use NG file parser to load file
- if NGFileLoader.LoadFile(Handle) and (Length(NGFileLoader.Frames) > 0) then
- with NGFileLoader.Frames[0] do
- begin
- SetLength(Images, 1);
- // Build actual image bits
- if IsJpegFrame then
- NGFileLoader.LoadImageFromJNGFrame(FrameWidth, FrameHeight, JHDR, IDATMemory, JDATMemory, JDAAMemory, Images[0]);
- // Build palette, aply color key or background
- NGFileLoader.ApplyFrameSettings(NGFileLoader.Frames[0], Images[0]);
- Result := True;
- end;
- finally
- NGFileLoader.Free;
- end;
-end;
-
-function TJNGFileFormat.SaveData(Handle: TImagingHandle;
- const Images: TDynImageDataArray; Index: LongInt): Boolean;
-var
- NGFileSaver: TNGFileSaver;
- ImageToSave: TImageData;
- MustBeFreed: Boolean;
-begin
- // Make image JNG compatible, store it in saver, and save it to file
- Result := MakeCompatible(Images[Index], ImageToSave, MustBeFreed);
- if Result then
- begin
- NGFileSaver := TNGFileSaver.Create;
- with NGFileSaver do
- try
- FileType := ngJNG;
- SetFileOptions(Self);
- AddFrame(ImageToSave, True);
- SaveFile(Handle);
- finally
- // Free NG saver and compatible image
- NGFileSaver.Free;
- if MustBeFreed then
- FreeImage(ImageToSave);
- end;
- end;
-end;
-
-{$ENDIF}
-
-initialization
- RegisterImageFileFormat(TPNGFileFormat);
-{$IFNDEF DONT_LINK_MNG}
- RegisterImageFileFormat(TMNGFileFormat);
-{$ENDIF}
-{$IFNDEF DONT_LINK_JNG}
- RegisterImageFileFormat(TJNGFileFormat);
-{$ENDIF}
-finalization
-
-{
- File Notes:
-
- -- TODOS ----------------------------------------------------
- - nothing now
-
- -- 0.26.3 Changes/Bug Fixes ---------------------------------
- - Added APNG saving support.
- - Added APNG support to NG loader and animating to PNG loader.
-
- -- 0.26.1 Changes/Bug Fixes ---------------------------------
- - Changed file format conditional compilation to reflect changes
- in LINK symbols.
-
- -- 0.24.3 Changes/Bug Fixes ---------------------------------
- - Changes for better thread safety.
-
- -- 0.23 Changes/Bug Fixes -----------------------------------
- - Added loading of global palettes and transparencies in MNG files
- (and by doing so fixed crash when loading images with global PLTE or tRNS).
-
- -- 0.21 Changes/Bug Fixes -----------------------------------
- - Small changes in converting to supported formats.
- - MakeCompatible method moved to base class, put ConvertToSupported here.
- GetSupportedFormats removed, it is now set in constructor.
- - Made public properties for options registered to SetOption/GetOption
- functions.
- - Changed extensions to filename masks.
- - Changed SaveData, LoadData, and MakeCompatible methods according
- to changes in base class in Imaging unit.
-
- -- 0.17 Changes/Bug Fixes -----------------------------------
- - MNG and JNG support added, PNG support redesigned to support NG file handlers
- - added classes for working with NG file formats
- - stuff from old ImagingPng unit added and that unit was deleted
- - unit created and initial stuff added
-
- -- 0.15 Changes/Bug Fixes -----------------------------------
- - when saving indexed images save alpha to tRNS?
- - added some defines and ifdefs to dzlib unit to allow choosing
- impaszlib, fpc's paszlib, zlibex or other zlib implementation
- - added colorkeying support
- - fixed 16bit channel image handling - pixels were not swapped
- - fixed arithmetic overflow (in paeth filter) in FPC
- - data of unknown chunks are skipped and not needlesly loaded
-
- -- 0.13 Changes/Bug Fixes -----------------------------------
- - adaptive filtering added to PNG saving
- - TPNGFileFormat class added
-}
-
-end.
+{
+ $Id: ImagingNetworkGraphics.pas 171 2009-09-02 01:34:19Z galfar $
+ Vampyre Imaging Library
+ by Marek Mauder
+ http://imaginglib.sourceforge.net
+
+ The contents of this file are used with permission, subject to the Mozilla
+ Public License Version 1.1 (the "License"); you may not use this file except
+ in compliance with the License. You may obtain a copy of the License at
+ http://www.mozilla.org/MPL/MPL-1.1.html
+
+ Software distributed under the License is distributed on an "AS IS" basis,
+ WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
+ the specific language governing rights and limitations under the License.
+
+ Alternatively, the contents of this file may be used under the terms of the
+ GNU Lesser General Public License (the "LGPL License"), in which case the
+ provisions of the LGPL License are applicable instead of those above.
+ If you wish to allow use of your version of this file only under the terms
+ of the LGPL License and not to allow others to use your version of this file
+ under the MPL, indicate your decision by deleting the provisions above and
+ replace them with the notice and other provisions required by the LGPL
+ License. If you do not delete the provisions above, a recipient may use
+ your version of this file under either the MPL or the LGPL License.
+
+ For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
+}
+
+{ This unit contains image format loaders/savers for Network Graphics image
+ file formats PNG, MNG, and JNG.}
+unit ImagingNetworkGraphics;
+
+interface
+
+{$I ImagingOptions.inc}
+
+{ If MN support is enabled we must make sure PNG and JNG are enabled too.}
+{$IFNDEF DONT_LINK_MNG}
+ {$UNDEF DONT_LINK_PNG}
+ {$UNDEF DONT_LINK_JNG}
+{$ENDIF}
+
+uses
+ Types, SysUtils, Classes, ImagingTypes, Imaging, ImagingUtility, ImagingFormats, dzlib;
+
+type
+ { Basic class for Network Graphics file formats loaders/savers.}
+ TNetworkGraphicsFileFormat = class(TImageFileFormat)
+ protected
+ FSignature: TChar8;
+ FPreFilter: LongInt;
+ FCompressLevel: LongInt;
+ FLossyCompression: LongBool;
+ FLossyAlpha: LongBool;
+ FQuality: LongInt;
+ FProgressive: LongBool;
+ function GetSupportedFormats: TImageFormats; override;
+ procedure ConvertToSupported(var Image: TImageData;
+ const Info: TImageFormatInfo); override;
+ public
+ constructor Create; override;
+ function TestFormat(Handle: TImagingHandle): Boolean; override;
+ procedure CheckOptionsValidity; override;
+ published
+ { Sets precompression filter used when saving images with lossless compression.
+ Allowed values are: 0 (none), 1 (sub), 2 (up), 3 (average), 4 (paeth),
+ 5 (use 0 for indexed/gray images and 4 for RGB/ARGB images),
+ 6 (adaptive filtering - use best filter for each scanline - very slow).
+ Note that filters 3 and 4 are much slower than filters 1 and 2.
+ Default value is 5.}
+ property PreFilter: LongInt read FPreFilter write FPreFilter;
+ { Sets ZLib compression level used when saving images with lossless compression.
+ Allowed values are in range 0 (no compresstion) to 9 (best compression).
+ Default value is 5.}
+ property CompressLevel: LongInt read FCompressLevel write FCompressLevel;
+ { Specifies whether MNG animation frames are saved with lossy or lossless
+ compression. Lossless frames are saved as PNG images and lossy frames are
+ saved as JNG images. Allowed values are 0 (False) and 1 (True).
+ Default value is 0.}
+ property LossyCompression: LongBool read FLossyCompression write FLossyCompression;
+ { Defines whether alpha channel of lossy MNG frames or JNG images
+ is lossy compressed too. Allowed values are 0 (False) and 1 (True).
+ Default value is 0.}
+ property LossyAlpha: LongBool read FLossyAlpha write FLossyAlpha;
+ { Specifies compression quality used when saving lossy MNG frames or JNG images.
+ For details look at ImagingJpegQuality option.}
+ property Quality: LongInt read FQuality write FQuality;
+ { Specifies whether images are saved in progressive format when saving lossy
+ MNG frames or JNG images. For details look at ImagingJpegProgressive.}
+ property Progressive: LongBool read FProgressive write FProgressive;
+ end;
+
+ { Class for loading Portable Network Graphics Images.
+ Loads all types of this image format (all images in png test suite)
+ and saves all types with bitcount >= 8 (non-interlaced only).
+ Compression level and filtering can be set by options interface.
+
+ Supported ancillary chunks (loading):
+ tRNS, bKGD
+ (for indexed images transparency contains alpha values for palette,
+ RGB/Gray images with transparency are converted to formats with alpha
+ and pixels with transparent color are replaced with background color
+ with alpha = 0).}
+ TPNGFileFormat = class(TNetworkGraphicsFileFormat)
+ private
+ FLoadAnimated: LongBool;
+ protected
+ function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
+ OnlyFirstLevel: Boolean): Boolean; override;
+ function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
+ Index: LongInt): Boolean; override;
+ public
+ constructor Create; override;
+ published
+ property LoadAnimated: LongBool read FLoadAnimated write FLoadAnimated;
+ end;
+
+{$IFNDEF DONT_LINK_MNG}
+ { Class for loading Multiple Network Graphics files.
+ This format has complex animation capabilities but Imaging only
+ extracts frames. Individual frames are stored as standard PNG or JNG
+ images. Loads all types of these frames stored in IHDR-IEND and
+ JHDR-IEND streams (Note that there are MNG chunks
+ like BASI which define images but does not contain image data itself,
+ those are ignored).
+ Imaging saves MNG files as MNG-VLC (very low complexity) so it is basicaly
+ an array of image frames without MNG animation chunks. Frames can be saved
+ as lossless PNG or lossy JNG images (look at TPNGFileFormat and
+ TJNGFileFormat for info). Every frame can be in different data format.
+
+ Many frame compression settings can be modified by options interface.}
+ TMNGFileFormat = class(TNetworkGraphicsFileFormat)
+ protected
+ function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
+ OnlyFirstLevel: Boolean): Boolean; override;
+ function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
+ Index: LongInt): Boolean; override;
+ public
+ constructor Create; override;
+ end;
+{$ENDIF}
+
+{$IFNDEF DONT_LINK_JNG}
+ { Class for loading JPEG Network Graphics Images.
+ Loads all types of this image format (all images in jng test suite)
+ and saves all types except 12 bit JPEGs.
+ Alpha channel in JNG images is stored separately from color/gray data and
+ can be lossy (as JPEG image) or lossless (as PNG image) compressed.
+ Type of alpha compression, compression level and quality,
+ and filtering can be set by options interface.
+
+ Supported ancillary chunks (loading):
+ tRNS, bKGD
+ (Images with transparency are converted to formats with alpha
+ and pixels with transparent color are replaced with background color
+ with alpha = 0).}
+ TJNGFileFormat = class(TNetworkGraphicsFileFormat)
+ protected
+ function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
+ OnlyFirstLevel: Boolean): Boolean; override;
+ function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
+ Index: LongInt): Boolean; override;
+ public
+ constructor Create; override;
+ end;
+{$ENDIF}
+
+
+implementation
+
+uses
+{$IFNDEF DONT_LINK_JNG}
+ ImagingJpeg, ImagingIO,
+{$ENDIF}
+ ImagingCanvases;
+
+const
+ NGDefaultPreFilter = 5;
+ NGDefaultCompressLevel = 5;
+ NGDefaultLossyAlpha = False;
+ NGDefaultLossyCompression = False;
+ NGDefaultProgressive = False;
+ NGDefaultQuality = 90;
+ NGLosslessFormats: TImageFormats = [ifIndex8, ifGray8, ifA8Gray8, ifGray16,
+ ifA16Gray16, ifR8G8B8, ifA8R8G8B8, ifR16G16B16, ifA16R16G16B16, ifB16G16R16,
+ ifA16B16G16R16];
+ NGLossyFormats: TImageFormats = [ifGray8, ifA8Gray8, ifR8G8B8, ifA8R8G8B8];
+ PNGDefaultLoadAnimated = True;
+
+ SPNGFormatName = 'Portable Network Graphics';
+ SPNGMasks = '*.png';
+ SMNGFormatName = 'Multiple Network Graphics';
+ SMNGMasks = '*.mng';
+ SJNGFormatName = 'JPEG Network Graphics';
+ SJNGMasks = '*.jng';
+
+resourcestring
+ SErrorLoadingChunk = 'Error when reading %s chunk data. File may be corrupted.';
+
+type
+ { Chunk header.}
+ TChunkHeader = packed record
+ DataSize: LongWord;
+ ChunkID: TChar4;
+ end;
+
+ { IHDR chunk format - PNG header.}
+ TIHDR = packed record
+ Width: LongWord; // Image width
+ Height: LongWord; // Image height
+ BitDepth: Byte; // Bits per pixel or bits per sample (for truecolor)
+ ColorType: Byte; // 0 = grayscale, 2 = truecolor, 3 = palette,
+ // 4 = gray + alpha, 6 = truecolor + alpha
+ Compression: Byte; // Compression type: 0 = ZLib
+ Filter: Byte; // Used precompress filter
+ Interlacing: Byte; // Used interlacing: 0 = no int, 1 = Adam7
+ end;
+ PIHDR = ^TIHDR;
+
+ { MHDR chunk format - MNG header.}
+ TMHDR = packed record
+ FrameWidth: LongWord; // Frame width
+ FrameHeight: LongWord; // Frame height
+ TicksPerSecond: LongWord; // FPS of animation
+ NominalLayerCount: LongWord; // Number of layers in file
+ NominalFrameCount: LongWord; // Number of frames in file
+ NominalPlayTime: LongWord; // Play time of animation in ticks
+ SimplicityProfile: LongWord; // Defines which MNG features are used in this file
+ end;
+ PMHDR = ^TMHDR;
+
+ { JHDR chunk format - JNG header.}
+ TJHDR = packed record
+ Width: LongWord; // Image width
+ Height: LongWord; // Image height
+ ColorType: Byte; // 8 = grayscale (Y), 10 = color (YCbCr),
+ // 12 = gray + alpha (Y-alpha), 14 = color + alpha (YCbCr-alpha)
+ SampleDepth: Byte; // 8, 12 or 20 (8 and 12 samples together) bit
+ Compression: Byte; // Compression type: 8 = Huffman coding
+ Interlacing: Byte; // 0 = single scan, 8 = progressive
+ AlphaSampleDepth: Byte; // 0, 1, 2, 4, 8, 16 if alpha compression is 0 (PNG)
+ // 8 if alpha compression is 8 (JNG)
+ AlphaCompression: Byte; // 0 = PNG graysscale IDAT, 8 = grayscale 8-bit JPEG
+ AlphaFilter: Byte; // 0 = PNG filter or no filter (JPEG)
+ AlphaInterlacing: Byte; // 0 = non interlaced
+ end;
+ PJHDR = ^TJHDR;
+
+ { acTL chunk format - APNG animation control.}
+ TacTL = packed record
+ NumFrames: LongWord; // Number of frames
+ NumPlay: LongWord; // Number of times to loop the animation (0 = inf)
+ end;
+ PacTL =^TacTL;
+
+ { fcTL chunk format - APNG frame control.}
+ TfcTL = packed record
+ SeqNumber: LongWord; // Sequence number of the animation chunk, starting from 0
+ Width: LongWord; // Width of the following frame
+ Height: LongWord; // Height of the following frame
+ XOffset: LongWord; // X position at which to render the following frame
+ YOffset: LongWord; // Y position at which to render the following frame
+ DelayNumer: Word; // Frame delay fraction numerator
+ DelayDenom: Word; // Frame delay fraction denominator
+ DisposeOp: Byte; // Type of frame area disposal to be done after rendering this frame
+ BlendOp: Byte; // Type of frame area rendering for this frame
+ end;
+ PfcTL = ^TfcTL;
+
+const
+ { PNG file identifier.}
+ PNGSignature: TChar8 = #$89'PNG'#$0D#$0A#$1A#$0A;
+ { MNG file identifier.}
+ MNGSignature: TChar8 = #$8A'MNG'#$0D#$0A#$1A#$0A;
+ { JNG file identifier.}
+ JNGSignature: TChar8 = #$8B'JNG'#$0D#$0A#$1A#$0A;
+
+ { Constants for chunk identifiers and signature identifiers.
+ They are in big-endian format.}
+ IHDRChunk: TChar4 = 'IHDR';
+ IENDChunk: TChar4 = 'IEND';
+ MHDRChunk: TChar4 = 'MHDR';
+ MENDChunk: TChar4 = 'MEND';
+ JHDRChunk: TChar4 = 'JHDR';
+ IDATChunk: TChar4 = 'IDAT';
+ JDATChunk: TChar4 = 'JDAT';
+ JDAAChunk: TChar4 = 'JDAA';
+ JSEPChunk: TChar4 = 'JSEP';
+ PLTEChunk: TChar4 = 'PLTE';
+ BACKChunk: TChar4 = 'BACK';
+ DEFIChunk: TChar4 = 'DEFI';
+ TERMChunk: TChar4 = 'TERM';
+ tRNSChunk: TChar4 = 'tRNS';
+ bKGDChunk: TChar4 = 'bKGD';
+ gAMAChunk: TChar4 = 'gAMA';
+ acTLChunk: TChar4 = 'acTL';
+ fcTLChunk: TChar4 = 'fcTL';
+ fdATChunk: TChar4 = 'fdAT';
+
+ { APNG frame dispose operations.}
+ DisposeOpNone = 0;
+ DisposeOpBackground = 1;
+ DisposeOpPrevious = 2;
+
+ { APNG frame blending modes}
+ BlendOpSource = 0;
+ BlendOpOver = 1;
+
+ { Interlace start and offsets.}
+ RowStart: array[0..6] of LongInt = (0, 0, 4, 0, 2, 0, 1);
+ ColumnStart: array[0..6] of LongInt = (0, 4, 0, 2, 0, 1, 0);
+ RowIncrement: array[0..6] of LongInt = (8, 8, 8, 4, 4, 2, 2);
+ ColumnIncrement: array[0..6] of LongInt = (8, 8, 4, 4, 2, 2, 1);
+
+type
+ { Helper class that holds information about MNG frame in PNG or JNG format.}
+ TFrameInfo = class(TObject)
+ public
+ FrameWidth, FrameHeight: LongInt;
+ IsJpegFrame: Boolean;
+ IHDR: TIHDR;
+ JHDR: TJHDR;
+ fcTL: TfcTL;
+ Palette: PPalette24;
+ PaletteEntries: LongInt;
+ Transparency: Pointer;
+ TransparencySize: LongInt;
+ Background: Pointer;
+ BackgroundSize: LongInt;
+ IDATMemory: TMemoryStream;
+ JDATMemory: TMemoryStream;
+ JDAAMemory: TMemoryStream;
+ constructor Create;
+ destructor Destroy; override;
+ procedure AssignSharedProps(Source: TFrameInfo);
+ end;
+
+ { Defines type of Network Graphics file.}
+ TNGFileType = (ngPNG, ngAPNG, ngMNG, ngJNG);
+
+ TNGFileHandler = class(TObject)
+ public
+ FileType: TNGFileType;
+ Frames: array of TFrameInfo;
+ MHDR: TMHDR; // Main header for MNG files
+ acTL: TacTL; // Global anim control for APNG files
+ GlobalPalette: PPalette24;
+ GlobalPaletteEntries: LongInt;
+ GlobalTransparency: Pointer;
+ GlobalTransparencySize: LongInt;
+ destructor Destroy; override;
+ procedure Clear;
+ function GetLastFrame: TFrameInfo;
+ function AddFrameInfo: TFrameInfo;
+ end;
+
+ { Network Graphics file parser and frame converter.}
+ TNGFileLoader = class(TNGFileHandler)
+ public
+ function LoadFile(Handle: TImagingHandle): Boolean;
+ procedure LoadImageFromPNGFrame(FrameWidth, FrameHeight: LongInt; const IHDR: TIHDR; IDATStream: TMemoryStream; var Image: TImageData);
+{$IFNDEF DONT_LINK_JNG}
+ procedure LoadImageFromJNGFrame(FrameWidth, FrameHeight: LongInt; const JHDR: TJHDR; IDATStream, JDATStream, JDAAStream: TMemoryStream; var Image: TImageData);
+{$ENDIF}
+ procedure ApplyFrameSettings(Frame: TFrameInfo; var Image: TImageData);
+ end;
+
+ TNGFileSaver = class(TNGFileHandler)
+ public
+ PreFilter: LongInt;
+ CompressLevel: LongInt;
+ LossyAlpha: Boolean;
+ Quality: LongInt;
+ Progressive: Boolean;
+ function SaveFile(Handle: TImagingHandle): Boolean;
+ procedure AddFrame(const Image: TImageData; IsJpegFrame: Boolean);
+ procedure StoreImageToPNGFrame(const IHDR: TIHDR; Bits: Pointer; FmtInfo: TImageFormatInfo; IDATStream: TMemoryStream);
+{$IFNDEF DONT_LINK_JNG}
+ procedure StoreImageToJNGFrame(const JHDR: TJHDR; const Image: TImageData; IDATStream, JDATStream, JDAAStream: TMemoryStream);
+{$ENDIF}
+ procedure SetFileOptions(FileFormat: TNetworkGraphicsFileFormat);
+ end;
+
+{$IFNDEF DONT_LINK_JNG}
+ TCustomIOJpegFileFormat = class(TJpegFileFormat)
+ protected
+ FCustomIO: TIOFunctions;
+ procedure SetJpegIO(const JpegIO: TIOFunctions); override;
+ procedure SetCustomIO(const CustomIO: TIOFunctions);
+ end;
+{$ENDIF}
+
+ TAPNGAnimator = class
+ public
+ class procedure Animate(var Images: TDynImageDataArray; const acTL: TacTL; const SrcFrames: array of TFrameInfo);
+ end;
+
+{ Helper routines }
+
+function PaethPredictor(A, B, C: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
+var
+ P, PA, PB, PC: LongInt;
+begin
+ P := A + B - C;
+ PA := Abs(P - A);
+ PB := Abs(P - B);
+ PC := Abs(P - C);
+ if (PA <= PB) and (PA <= PC) then
+ Result := A
+ else
+ if PB <= PC then
+ Result := B
+ else
+ Result := C;
+end;
+
+procedure SwapRGB(Line: PByte; Width, SampleDepth, BytesPerPixel: LongInt);
+var
+ I: LongInt;
+ Tmp: Word;
+begin
+ case SampleDepth of
+ 8:
+ for I := 0 to Width - 1 do
+ with PColor24Rec(Line)^ do
+ begin
+ Tmp := R;
+ R := B;
+ B := Tmp;
+ Inc(Line, BytesPerPixel);
+ end;
+ 16:
+ for I := 0 to Width - 1 do
+ with PColor48Rec(Line)^ do
+ begin
+ Tmp := R;
+ R := B;
+ B := Tmp;
+ Inc(Line, BytesPerPixel);
+ end;
+ end;
+ end;
+
+const
+ { Helper constants for 1/2/4 bit to 8 bit conversions.}
+ Mask1: array[0..7] of Byte = ($80, $40, $20, $10, $08, $04, $02, $01);
+ Shift1: array[0..7] of Byte = (7, 6, 5, 4, 3, 2, 1, 0);
+ Mask2: array[0..3] of Byte = ($C0, $30, $0C, $03);
+ Shift2: array[0..3] of Byte = (6, 4, 2, 0);
+ Mask4: array[0..1] of Byte = ($F0, $0F);
+ Shift4: array[0..1] of Byte = (4, 0);
+
+function Get1BitPixel(Line: PByteArray; X: LongInt): Byte;
+begin
+ Result := (Line[X shr 3] and Mask1[X and 7]) shr
+ Shift1[X and 7];
+end;
+
+function Get2BitPixel(Line: PByteArray; X: LongInt): Byte;
+begin
+ Result := (Line[X shr 2] and Mask2[X and 3]) shr
+ Shift2[X and 3];
+end;
+
+function Get4BitPixel(Line: PByteArray; X: LongInt): Byte;
+begin
+ Result := (Line[X shr 1] and Mask4[X and 1]) shr
+ Shift4[X and 1];
+end;
+
+{$IFNDEF DONT_LINK_JNG}
+
+{ TCustomIOJpegFileFormat class implementation }
+
+procedure TCustomIOJpegFileFormat.SetCustomIO(const CustomIO: TIOFunctions);
+begin
+ FCustomIO := CustomIO;
+end;
+
+procedure TCustomIOJpegFileFormat.SetJpegIO(const JpegIO: TIOFunctions);
+begin
+ inherited SetJpegIO(FCustomIO);
+end;
+
+{$ENDIF}
+
+{ TFrameInfo class implementation }
+
+constructor TFrameInfo.Create;
+begin
+ IDATMemory := TMemoryStream.Create;
+ JDATMemory := TMemoryStream.Create;
+ JDAAMemory := TMemoryStream.Create;
+end;
+
+destructor TFrameInfo.Destroy;
+begin
+ FreeMem(Palette);
+ FreeMem(Transparency);
+ FreeMem(Background);
+ IDATMemory.Free;
+ JDATMemory.Free;
+ JDAAMemory.Free;
+ inherited Destroy;
+end;
+
+procedure TFrameInfo.AssignSharedProps(Source: TFrameInfo);
+begin
+ IHDR := Source.IHDR;
+ JHDR := Source.JHDR;
+ PaletteEntries := Source.PaletteEntries;
+ GetMem(Palette, PaletteEntries * SizeOf(TColor24Rec));
+ Move(Source.Palette^, Palette^, PaletteEntries * SizeOf(TColor24Rec));
+ TransparencySize := Source.TransparencySize;
+ GetMem(Transparency, TransparencySize);
+ Move(Source.Transparency^, Transparency^, TransparencySize);
+end;
+
+{ TNGFileHandler class implementation}
+
+destructor TNGFileHandler.Destroy;
+begin
+ Clear;
+ inherited Destroy;
+end;
+
+procedure TNGFileHandler.Clear;
+var
+ I: LongInt;
+begin
+ for I := 0 to Length(Frames) - 1 do
+ Frames[I].Free;
+ SetLength(Frames, 0);
+ FreeMemNil(GlobalPalette);
+ GlobalPaletteEntries := 0;
+ FreeMemNil(GlobalTransparency);
+ GlobalTransparencySize := 0;
+end;
+
+function TNGFileHandler.GetLastFrame: TFrameInfo;
+var
+ Len: LongInt;
+begin
+ Len := Length(Frames);
+ if Len > 0 then
+ Result := Frames[Len - 1]
+ else
+ Result := nil;
+end;
+
+function TNGFileHandler.AddFrameInfo: TFrameInfo;
+var
+ Len: LongInt;
+begin
+ Len := Length(Frames);
+ SetLength(Frames, Len + 1);
+ Result := TFrameInfo.Create;
+ Frames[Len] := Result;
+end;
+
+{ TNGFileLoader class implementation}
+
+function TNGFileLoader.LoadFile(Handle: TImagingHandle): Boolean;
+var
+ Sig: TChar8;
+ Chunk: TChunkHeader;
+ ChunkData: Pointer;
+ ChunkCrc: LongWord;
+
+ procedure ReadChunk;
+ begin
+ GetIO.Read(Handle, @Chunk, SizeOf(Chunk));
+ Chunk.DataSize := SwapEndianLongWord(Chunk.DataSize);
+ end;
+
+ procedure ReadChunkData;
+ var
+ ReadBytes: LongWord;
+ begin
+ FreeMemNil(ChunkData);
+ GetMem(ChunkData, Chunk.DataSize);
+ ReadBytes := GetIO.Read(Handle, ChunkData, Chunk.DataSize);
+ GetIO.Read(Handle, @ChunkCrc, SizeOf(ChunkCrc));
+ if ReadBytes <> Chunk.DataSize then
+ RaiseImaging(SErrorLoadingChunk, [string(Chunk.ChunkID)]);
+ end;
+
+ procedure SkipChunkData;
+ begin
+ GetIO.Seek(Handle, Chunk.DataSize + SizeOf(ChunkCrc), smFromCurrent);
+ end;
+
+ procedure StartNewPNGImage;
+ var
+ Frame: TFrameInfo;
+ begin
+ ReadChunkData;
+
+ if Chunk.ChunkID = fcTLChunk then
+ begin
+ if (Length(Frames) = 1) and (Frames[0].IDATMemory.Size = 0) then
+ begin
+ // First fcTL chunk maybe for first IDAT frame which is alredy created
+ Frame := Frames[0];
+ end
+ else
+ begin
+ // Subsequent APNG frames with data in fdAT
+ Frame := AddFrameInfo;
+ // Copy some shared props from first frame (IHDR is the same for all APNG frames, palette etc)
+ Frame.AssignSharedProps(Frames[0]);
+ end;
+ Frame.fcTL := PfcTL(ChunkData)^;
+ SwapEndianLongWord(@Frame.fcTL, 5);
+ Frame.fcTL.DelayNumer := SwapEndianWord(Frame.fcTL.DelayNumer);
+ Frame.fcTL.DelayDenom := SwapEndianWord(Frame.fcTL.DelayDenom);
+ Frame.FrameWidth := Frame.fcTL.Width;
+ Frame.FrameHeight := Frame.fcTL.Height;
+ end
+ else
+ begin
+ // This is frame defined by IHDR chunk
+ Frame := AddFrameInfo;
+ Frame.IHDR := PIHDR(ChunkData)^;
+ SwapEndianLongWord(@Frame.IHDR, 2);
+ Frame.FrameWidth := Frame.IHDR.Width;
+ Frame.FrameHeight := Frame.IHDR.Height;
+ end;
+ Frame.IsJpegFrame := False;
+ end;
+
+ procedure StartNewJNGImage;
+ var
+ Frame: TFrameInfo;
+ begin
+ ReadChunkData;
+ Frame := AddFrameInfo;
+ Frame.IsJpegFrame := True;
+ Frame.JHDR := PJHDR(ChunkData)^;
+ SwapEndianLongWord(@Frame.JHDR, 2);
+ Frame.FrameWidth := Frame.JHDR.Width;
+ Frame.FrameHeight := Frame.JHDR.Height;
+ end;
+
+ procedure AppendIDAT;
+ begin
+ ReadChunkData;
+ // Append current IDAT/fdAT chunk to storage stream
+ if Chunk.ChunkID = IDATChunk then
+ GetLastFrame.IDATMemory.Write(ChunkData^, Chunk.DataSize)
+ else if Chunk.ChunkID = fdATChunk then
+ GetLastFrame.IDATMemory.Write(PByteArray(ChunkData)[4], Chunk.DataSize - SizeOf(LongWord));
+ end;
+
+ procedure AppendJDAT;
+ begin
+ ReadChunkData;
+ // Append current JDAT chunk to storage stream
+ GetLastFrame.JDATMemory.Write(ChunkData^, Chunk.DataSize);
+ end;
+
+ procedure AppendJDAA;
+ begin
+ ReadChunkData;
+ // Append current JDAA chunk to storage stream
+ GetLastFrame.JDAAMemory.Write(ChunkData^, Chunk.DataSize);
+ end;
+
+ procedure LoadPLTE;
+ begin
+ ReadChunkData;
+ if GetLastFrame = nil then
+ begin
+ // Load global palette
+ GetMem(GlobalPalette, Chunk.DataSize);
+ Move(ChunkData^, GlobalPalette^, Chunk.DataSize);
+ GlobalPaletteEntries := Chunk.DataSize div 3;
+ end
+ else if GetLastFrame.Palette = nil then
+ begin
+ if (Chunk.DataSize = 0) and (GlobalPalette <> nil) then
+ begin
+ // Use global palette
+ GetMem(GetLastFrame.Palette, GlobalPaletteEntries * SizeOf(TColor24Rec));
+ Move(GlobalPalette^, GetLastFrame.Palette^, GlobalPaletteEntries * SizeOf(TColor24Rec));
+ GetLastFrame.PaletteEntries := GlobalPaletteEntries;
+ end
+ else
+ begin
+ // Load pal from PLTE chunk
+ GetMem(GetLastFrame.Palette, Chunk.DataSize);
+ Move(ChunkData^, GetLastFrame.Palette^, Chunk.DataSize);
+ GetLastFrame.PaletteEntries := Chunk.DataSize div 3;
+ end;
+ end;
+ end;
+
+ procedure LoadtRNS;
+ begin
+ ReadChunkData;
+ if GetLastFrame = nil then
+ begin
+ // Load global transparency
+ GetMem(GlobalTransparency, Chunk.DataSize);
+ Move(ChunkData^, GlobalTransparency^, Chunk.DataSize);
+ GlobalTransparencySize := Chunk.DataSize;
+ end
+ else if GetLastFrame.Transparency = nil then
+ begin
+ if (Chunk.DataSize = 0) and (GlobalTransparency <> nil) then
+ begin
+ // Use global transparency
+ GetMem(GetLastFrame.Transparency, GlobalTransparencySize);
+ Move(GlobalTransparency^, GetLastFrame.Transparency^, Chunk.DataSize);
+ GetLastFrame.TransparencySize := GlobalTransparencySize;
+ end
+ else
+ begin
+ // Load pal from tRNS chunk
+ GetMem(GetLastFrame.Transparency, Chunk.DataSize);
+ Move(ChunkData^, GetLastFrame.Transparency^, Chunk.DataSize);
+ GetLastFrame.TransparencySize := Chunk.DataSize;
+ end;
+ end;
+ end;
+
+ procedure LoadbKGD;
+ begin
+ ReadChunkData;
+ if GetLastFrame.Background = nil then
+ begin
+ GetMem(GetLastFrame.Background, Chunk.DataSize);
+ Move(ChunkData^, GetLastFrame.Background^, Chunk.DataSize);
+ GetLastFrame.BackgroundSize := Chunk.DataSize;
+ end;
+ end;
+
+ procedure HandleacTL;
+ begin
+ FileType := ngAPNG;
+ ReadChunkData;
+ acTL := PacTL(ChunkData)^;
+ SwapEndianLongWord(@acTL, SizeOf(acTL) div SizeOf(LongWord));
+ end;
+
+begin
+ Result := False;
+ Clear;
+ ChunkData := nil;
+ with GetIO do
+ try
+ Read(Handle, @Sig, SizeOf(Sig));
+ // Set file type according to the signature
+ if Sig = PNGSignature then FileType := ngPNG
+ else if Sig = MNGSignature then FileType := ngMNG
+ else if Sig = JNGSignature then FileType := ngJNG
+ else Exit;
+
+ if FileType = ngMNG then
+ begin
+ // Store MNG header if present
+ ReadChunk;
+ ReadChunkData;
+ MHDR := PMHDR(ChunkData)^;
+ SwapEndianLongWord(@MHDR, SizeOf(MHDR) div SizeOf(LongWord));
+ end;
+
+ // Read chunks until ending chunk or EOF is reached
+ repeat
+ ReadChunk;
+ if (Chunk.ChunkID = IHDRChunk) or (Chunk.ChunkID = fcTLChunk) then StartNewPNGImage
+ else if Chunk.ChunkID = JHDRChunk then StartNewJNGImage
+ else if (Chunk.ChunkID = IDATChunk) or (Chunk.ChunkID = fdATChunk) then AppendIDAT
+ else if Chunk.ChunkID = JDATChunk then AppendJDAT
+ else if Chunk.ChunkID = JDAAChunk then AppendJDAA
+ else if Chunk.ChunkID = PLTEChunk then LoadPLTE
+ else if Chunk.ChunkID = tRNSChunk then LoadtRNS
+ else if Chunk.ChunkID = bKGDChunk then LoadbKGD
+ else if Chunk.ChunkID = acTLChunk then HandleacTL
+ else SkipChunkData;
+ until Eof(Handle) or (Chunk.ChunkID = MENDChunk) or
+ ((FileType <> ngMNG) and (Chunk.ChunkID = IENDChunk));
+
+ Result := True;
+ finally
+ FreeMemNil(ChunkData);
+ end;
+end;
+
+procedure TNGFileLoader.LoadImageFromPNGFrame(FrameWidth, FrameHeight: LongInt; const IHDR: TIHDR;
+ IDATStream: TMemoryStream; var Image: TImageData);
+type
+ TGetPixelFunc = function(Line: PByteArray; X: LongInt): Byte;
+var
+ LineBuffer: array[Boolean] of PByteArray;
+ ActLine: Boolean;
+ Data, TotalBuffer, ZeroLine, PrevLine: Pointer;
+ BitCount, TotalSize, TotalPos, BytesPerPixel, I, Pass,
+ SrcDataSize, BytesPerLine, InterlaceLineBytes, InterlaceWidth: LongInt;
+
+ procedure DecodeAdam7;
+ const
+ BitTable: array[1..8] of LongInt = ($1, $3, 0, $F, 0, 0, 0, $FF);
+ StartBit: array[1..8] of LongInt = (7, 6, 0, 4, 0, 0, 0, 0);
+ var
+ Src, Dst, Dst2: PByte;
+ CurBit, Col: LongInt;
+ begin
+ Src := @LineBuffer[ActLine][1];
+ Col := ColumnStart[Pass];
+ with Image do
+ case BitCount of
+ 1, 2, 4:
+ begin
+ Dst := @PByteArray(Data)[I * BytesPerLine];
+ repeat
+ CurBit := StartBit[BitCount];
+ repeat
+ Dst2 := @PByteArray(Dst)[(BitCount * Col) shr 3];
+ Dst2^ := Dst2^ or ((Src^ shr CurBit) and BitTable[BitCount])
+ shl (StartBit[BitCount] - (Col * BitCount mod 8));
+ Inc(Col, ColumnIncrement[Pass]);
+ Dec(CurBit, BitCount);
+ until CurBit < 0;
+ Inc(Src);
+ until Col >= Width;
+ end;
+ else
+ begin
+ Dst := @PByteArray(Data)[I * BytesPerLine + Col * BytesPerPixel];
+ repeat
+ CopyPixel(Src, Dst, BytesPerPixel);
+ Inc(Dst, BytesPerPixel);
+ Inc(Src, BytesPerPixel);
+ Inc(Dst, ColumnIncrement[Pass] * BytesPerPixel - BytesPerPixel);
+ Inc(Col, ColumnIncrement[Pass]);
+ until Col >= Width;
+ end;
+ end;
+ end;
+
+ procedure FilterScanline(Filter: Byte; BytesPerPixel: LongInt; Line, PrevLine, Target: PByteArray;
+ BytesPerLine: LongInt);
+ var
+ I: LongInt;
+ begin
+ case Filter of
+ 0:
+ begin
+ // No filter
+ Move(Line^, Target^, BytesPerLine);
+ end;
+ 1:
+ begin
+ // Sub filter
+ Move(Line^, Target^, BytesPerPixel);
+ for I := BytesPerPixel to BytesPerLine - 1 do
+ Target[I] := (Line[I] + Target[I - BytesPerPixel]) and $FF;
+ end;
+ 2:
+ begin
+ // Up filter
+ for I := 0 to BytesPerLine - 1 do
+ Target[I] := (Line[I] + PrevLine[I]) and $FF;
+ end;
+ 3:
+ begin
+ // Average filter
+ for I := 0 to BytesPerPixel - 1 do
+ Target[I] := (Line[I] + PrevLine[I] shr 1) and $FF;
+ for I := BytesPerPixel to BytesPerLine - 1 do
+ Target[I] := (Line[I] + (Target[I - BytesPerPixel] + PrevLine[I]) shr 1) and $FF;
+ end;
+ 4:
+ begin
+ // Paeth filter
+ for I := 0 to BytesPerPixel - 1 do
+ Target[I] := (Line[I] + PaethPredictor(0, PrevLine[I], 0)) and $FF;
+ for I := BytesPerPixel to BytesPerLine - 1 do
+ Target[I] := (Line[I] + PaethPredictor(Target[I - BytesPerPixel], PrevLine[I], PrevLine[I - BytesPerPixel])) and $FF;
+ end;
+ end;
+ end;
+
+ procedure Convert124To8(DataIn: Pointer; DataOut: Pointer; Width, Height,
+ WidthBytes: LongInt; Indexed: Boolean);
+ var
+ X, Y, Mul: LongInt;
+ GetPixel: TGetPixelFunc;
+ begin
+ GetPixel := Get1BitPixel;
+ Mul := 255;
+ case IHDR.BitDepth of
+ 2:
+ begin
+ Mul := 85;
+ GetPixel := Get2BitPixel;
+ end;
+ 4:
+ begin
+ Mul := 17;
+ GetPixel := Get4BitPixel;
+ end;
+ end;
+ if Indexed then Mul := 1;
+
+ for Y := 0 to Height - 1 do
+ for X := 0 to Width - 1 do
+ PByteArray(DataOut)[Y * Width + X] :=
+ GetPixel(@PByteArray(DataIn)[Y * WidthBytes], X) * Mul;
+ end;
+
+ procedure TransformLOCOToRGB(Data: PByte; NumPixels, BytesPerPixel: LongInt);
+ var
+ I: LongInt;
+ begin
+ for I := 0 to NumPixels - 1 do
+ begin
+ if IHDR.BitDepth = 8 then
+ begin
+ PColor32Rec(Data).R := Byte(PColor32Rec(Data).R + PColor32Rec(Data).G);
+ PColor32Rec(Data).B := Byte(PColor32Rec(Data).B + PColor32Rec(Data).G);
+ end
+ else
+ begin
+ PColor64Rec(Data).R := Word(PColor64Rec(Data).R + PColor64Rec(Data).G);
+ PColor64Rec(Data).B := Word(PColor64Rec(Data).B + PColor64Rec(Data).G);
+ end;
+ Inc(Data, BytesPerPixel);
+ end;
+ end;
+
+begin
+ Image.Width := FrameWidth;
+ Image.Height := FrameHeight;
+ Image.Format := ifUnknown;
+
+ case IHDR.ColorType of
+ 0:
+ begin
+ // Gray scale image
+ case IHDR.BitDepth of
+ 1, 2, 4, 8: Image.Format := ifGray8;
+ 16: Image.Format := ifGray16;
+ end;
+ BitCount := IHDR.BitDepth;
+ end;
+ 2:
+ begin
+ // RGB image
+ case IHDR.BitDepth of
+ 8: Image.Format := ifR8G8B8;
+ 16: Image.Format := ifR16G16B16;
+ end;
+ BitCount := IHDR.BitDepth * 3;
+ end;
+ 3:
+ begin
+ // Indexed image
+ case IHDR.BitDepth of
+ 1, 2, 4, 8: Image.Format := ifIndex8;
+ end;
+ BitCount := IHDR.BitDepth;
+ end;
+ 4:
+ begin
+ // Grayscale + alpha image
+ case IHDR.BitDepth of
+ 8: Image.Format := ifA8Gray8;
+ 16: Image.Format := ifA16Gray16;
+ end;
+ BitCount := IHDR.BitDepth * 2;
+ end;
+ 6:
+ begin
+ // ARGB image
+ case IHDR.BitDepth of
+ 8: Image.Format := ifA8R8G8B8;
+ 16: Image.Format := ifA16R16G16B16;
+ end;
+ BitCount := IHDR.BitDepth * 4;
+ end;
+ end;
+
+ // Start decoding
+ LineBuffer[True] := nil;
+ LineBuffer[False] := nil;
+ TotalBuffer := nil;
+ ZeroLine := nil;
+ BytesPerPixel := (BitCount + 7) div 8;
+ ActLine := True;
+ with Image do
+ try
+ BytesPerLine := (Width * BitCount + 7) div 8;
+ SrcDataSize := Height * BytesPerLine;
+ GetMem(Data, SrcDataSize);
+ FillChar(Data^, SrcDataSize, 0);
+ GetMem(ZeroLine, BytesPerLine);
+ FillChar(ZeroLine^, BytesPerLine, 0);
+
+ if IHDR.Interlacing = 1 then
+ begin
+ // Decode interlaced images
+ TotalPos := 0;
+ DecompressBuf(IDATStream.Memory, IDATStream.Size, 0,
+ Pointer(TotalBuffer), TotalSize);
+ GetMem(LineBuffer[True], BytesPerLine + 1);
+ GetMem(LineBuffer[False], BytesPerLine + 1);
+ for Pass := 0 to 6 do
+ begin
+ // Prepare next interlace run
+ if Width <= ColumnStart[Pass] then
+ Continue;
+ InterlaceWidth := (Width + ColumnIncrement[Pass] - 1 -
+ ColumnStart[Pass]) div ColumnIncrement[Pass];
+ InterlaceLineBytes := (InterlaceWidth * BitCount + 7) shr 3;
+ I := RowStart[Pass];
+ FillChar(LineBuffer[True][0], BytesPerLine + 1, 0);
+ FillChar(LineBuffer[False][0], BytesPerLine + 1, 0);
+ while I < Height do
+ begin
+ // Copy line from decompressed data to working buffer
+ Move(PByteArray(TotalBuffer)[TotalPos],
+ LineBuffer[ActLine][0], InterlaceLineBytes + 1);
+ Inc(TotalPos, InterlaceLineBytes + 1);
+ // Swap red and blue channels if necessary
+ if (IHDR.ColorType in [2, 6]) then
+ SwapRGB(@LineBuffer[ActLine][1], InterlaceWidth, IHDR.BitDepth, BytesPerPixel);
+ // Reverse-filter current scanline
+ FilterScanline(LineBuffer[ActLine][0], BytesPerPixel,
+ @LineBuffer[ActLine][1], @LineBuffer[not ActLine][1],
+ @LineBuffer[ActLine][1], InterlaceLineBytes);
+ // Decode Adam7 interlacing
+ DecodeAdam7;
+ ActLine := not ActLine;
+ // Continue with next row in interlaced order
+ Inc(I, RowIncrement[Pass]);
+ end;
+ end;
+ end
+ else
+ begin
+ // Decode non-interlaced images
+ PrevLine := ZeroLine;
+ DecompressBuf(IDATStream.Memory, IDATStream.Size, SrcDataSize + Height,
+ Pointer(TotalBuffer), TotalSize);
+ for I := 0 to Height - 1 do
+ begin
+ // Swap red and blue channels if necessary
+ if IHDR.ColorType in [2, 6] then
+ SwapRGB(@PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + 1], Width,
+ IHDR.BitDepth, BytesPerPixel);
+ // reverse-filter current scanline
+ FilterScanline(PByteArray(TotalBuffer)[I * (BytesPerLine + 1)],
+ BytesPerPixel, @PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + 1],
+ PrevLine, @PByteArray(Data)[I * BytesPerLine], BytesPerLine);
+ PrevLine := @PByteArray(Data)[I * BytesPerLine];
+ end;
+ end;
+
+ Size := Width * Height * BytesPerPixel;
+
+ if Size <> SrcDataSize then
+ begin
+ // If source data size is different from size of image in assigned
+ // format we must convert it (it is in 1/2/4 bit count)
+ GetMem(Bits, Size);
+ case IHDR.ColorType of
+ 0: Convert124To8(Data, Bits, Width, Height, BytesPerLine, False);
+ 3: Convert124To8(Data, Bits, Width, Height, BytesPerLine, True);
+ end;
+ FreeMem(Data);
+ end
+ else
+ begin
+ // If source data size is the same as size of
+ // image Bits in assigned format we simply copy pointer reference
+ Bits := Data;
+ end;
+
+ // LOCO transformation was used too (only for color types 2 and 6)
+ if (IHDR.Filter = 64) and (IHDR.ColorType in [2, 6]) then
+ TransformLOCOToRGB(Bits, Width * Height, BytesPerPixel);
+
+ // Images with 16 bit channels must be swapped because of PNG's big endianity
+ if IHDR.BitDepth = 16 then
+ SwapEndianWord(Bits, Width * Height * BytesPerPixel div SizeOf(Word));
+ finally
+ FreeMem(LineBuffer[True]);
+ FreeMem(LineBuffer[False]);
+ FreeMem(TotalBuffer);
+ FreeMem(ZeroLine);
+ end;
+end;
+
+{$IFNDEF DONT_LINK_JNG}
+
+procedure TNGFileLoader.LoadImageFromJNGFrame(FrameWidth, FrameHeight: LongInt; const JHDR: TJHDR; IDATStream,
+ JDATStream, JDAAStream: TMemoryStream; var Image: TImageData);
+var
+ AlphaImage: TImageData;
+ FakeIHDR: TIHDR;
+ FmtInfo: TImageFormatInfo;
+ I: LongInt;
+ AlphaPtr: PByte;
+ GrayPtr: PWordRec;
+ ColorPtr: PColor32Rec;
+
+ procedure LoadJpegFromStream(Stream: TStream; var DestImage: TImageData);
+ var
+ JpegFormat: TCustomIOJpegFileFormat;
+ Handle: TImagingHandle;
+ DynImages: TDynImageDataArray;
+ begin
+ if JHDR.SampleDepth <> 12 then
+ begin
+ JpegFormat := TCustomIOJpegFileFormat.Create;
+ JpegFormat.SetCustomIO(StreamIO);
+ Stream.Position := 0;
+ Handle := StreamIO.OpenRead(Pointer(Stream));
+ try
+ JpegFormat.LoadData(Handle, DynImages, True);
+ DestImage := DynImages[0];
+ finally
+ StreamIO.Close(Handle);
+ JpegFormat.Free;
+ SetLength(DynImages, 0);
+ end;
+ end
+ else
+ NewImage(FrameWidth, FrameHeight, ifR8G8B8, DestImage);
+ end;
+
+begin
+ LoadJpegFromStream(JDATStream, Image);
+
+ // If present separate alpha channel is processed
+ if (JHDR.ColorType in [12, 14]) and (Image.Format in [ifGray8, ifR8G8B8]) then
+ begin
+ InitImage(AlphaImage);
+ if JHDR.AlphaCompression = 0 then
+ begin
+ // Alpha channel is PNG compressed
+ FakeIHDR.Width := JHDR.Width;
+ FakeIHDR.Height := JHDR.Height;
+ FakeIHDR.ColorType := 0;
+ FakeIHDR.BitDepth := JHDR.AlphaSampleDepth;
+ FakeIHDR.Filter := JHDR.AlphaFilter;
+ FakeIHDR.Interlacing := JHDR.AlphaInterlacing;
+
+ LoadImageFromPNGFrame(FrameWidth, FrameHeight, FakeIHDR, IDATStream, AlphaImage);
+ end
+ else
+ begin
+ // Alpha channel is JPEG compressed
+ LoadJpegFromStream(JDAAStream, AlphaImage);
+ end;
+
+ // Check if alpha channel is the same size as image
+ if (Image.Width <> AlphaImage.Width) and (Image.Height <> AlphaImage.Height) then
+ ResizeImage(AlphaImage, Image.Width, Image.Height, rfNearest);
+
+ // Check alpha channels data format
+ GetImageFormatInfo(AlphaImage.Format, FmtInfo);
+ if (FmtInfo.BytesPerPixel > 1) or (not FmtInfo.HasGrayChannel) then
+ ConvertImage(AlphaImage, ifGray8);
+
+ // Convert image to fromat with alpha channel
+ if Image.Format = ifGray8 then
+ ConvertImage(Image, ifA8Gray8)
+ else
+ ConvertImage(Image, ifA8R8G8B8);
+
+ // Combine alpha channel with image
+ AlphaPtr := AlphaImage.Bits;
+ if Image.Format = ifA8Gray8 then
+ begin
+ GrayPtr := Image.Bits;
+ for I := 0 to Image.Width * Image.Height - 1 do
+ begin
+ GrayPtr.High := AlphaPtr^;
+ Inc(GrayPtr);
+ Inc(AlphaPtr);
+ end;
+ end
+ else
+ begin
+ ColorPtr := Image.Bits;
+ for I := 0 to Image.Width * Image.Height - 1 do
+ begin
+ ColorPtr.A := AlphaPtr^;
+ Inc(ColorPtr);
+ Inc(AlphaPtr);
+ end;
+ end;
+
+ FreeImage(AlphaImage);
+ end;
+end;
+
+{$ENDIF}
+
+procedure TNGFileLoader.ApplyFrameSettings(Frame: TFrameInfo; var Image: TImageData);
+var
+ FmtInfo: TImageFormatInfo;
+ BackGroundColor: TColor64Rec;
+ ColorKey: TColor64Rec;
+ Alphas: PByteArray;
+ AlphasSize: LongInt;
+ IsColorKeyPresent: Boolean;
+ IsBackGroundPresent: Boolean;
+ IsColorFormat: Boolean;
+
+ procedure ConverttRNS;
+ begin
+ if FmtInfo.IsIndexed then
+ begin
+ if Alphas = nil then
+ begin
+ GetMem(Alphas, Frame.TransparencySize);
+ Move(Frame.Transparency^, Alphas^, Frame.TransparencySize);
+ AlphasSize := Frame.TransparencySize;
+ end;
+ end
+ else if not FmtInfo.HasAlphaChannel then
+ begin
+ FillChar(ColorKey, SizeOf(ColorKey), 0);
+ Move(Frame.Transparency^, ColorKey, Min(Frame.TransparencySize, SizeOf(ColorKey)));
+ if IsColorFormat then
+ SwapValues(ColorKey.R, ColorKey.B);
+ SwapEndianWord(@ColorKey, 3);
+ // 1/2/4 bit images were converted to 8 bit so we must convert color key too
+ if (not Frame.IsJpegFrame) and (Frame.IHDR.ColorType in [0, 4]) then
+ case Frame.IHDR.BitDepth of
+ 1: ColorKey.B := Word(ColorKey.B * 255);
+ 2: ColorKey.B := Word(ColorKey.B * 85);
+ 4: ColorKey.B := Word(ColorKey.B * 17);
+ end;
+ IsColorKeyPresent := True;
+ end;
+ end;
+
+ procedure ConvertbKGD;
+ begin
+ FillChar(BackGroundColor, SizeOf(BackGroundColor), 0);
+ Move(Frame.Background^, BackGroundColor, Min(Frame.BackgroundSize,
+ SizeOf(BackGroundColor)));
+ if IsColorFormat then
+ SwapValues(BackGroundColor.R, BackGroundColor.B);
+ SwapEndianWord(@BackGroundColor, 3);
+ // 1/2/4 bit images were converted to 8 bit so we must convert back color too
+ if (not Frame.IsJpegFrame) and (Frame.IHDR.ColorType in [0, 4]) then
+ case Frame.IHDR.BitDepth of
+ 1: BackGroundColor.B := Word(BackGroundColor.B * 255);
+ 2: BackGroundColor.B := Word(BackGroundColor.B * 85);
+ 4: BackGroundColor.B := Word(BackGroundColor.B * 17);
+ end;
+ IsBackGroundPresent := True;
+ end;
+
+ procedure ReconstructPalette;
+ var
+ I: LongInt;
+ begin
+ with Image do
+ begin
+ GetMem(Palette, FmtInfo.PaletteEntries * SizeOf(TColor32Rec));
+ FillChar(Palette^, FmtInfo.PaletteEntries * SizeOf(TColor32Rec), $FF);
+ // if RGB palette was loaded from file then use it
+ if Frame.Palette <> nil then
+ for I := 0 to Min(Frame.PaletteEntries, FmtInfo.PaletteEntries) - 1 do
+ with Palette[I] do
+ begin
+ R := Frame.Palette[I].B;
+ G := Frame.Palette[I].G;
+ B := Frame.Palette[I].R;
+ end;
+ // if palette alphas were loaded from file then use them
+ if Alphas <> nil then
+ for I := 0 to Min(AlphasSize, FmtInfo.PaletteEntries) - 1 do
+ Palette[I].A := Alphas[I];
+ end;
+ end;
+
+ procedure ApplyColorKey;
+ var
+ DestFmt: TImageFormat;
+ OldPixel, NewPixel: Pointer;
+ begin
+ case Image.Format of
+ ifGray8: DestFmt := ifA8Gray8;
+ ifGray16: DestFmt := ifA16Gray16;
+ ifR8G8B8: DestFmt := ifA8R8G8B8;
+ ifR16G16B16: DestFmt := ifA16R16G16B16;
+ else
+ DestFmt := ifUnknown;
+ end;
+ if DestFmt <> ifUnknown then
+ begin
+ if not IsBackGroundPresent then
+ BackGroundColor := ColorKey;
+ ConvertImage(Image, DestFmt);
+ OldPixel := @ColorKey;
+ NewPixel := @BackGroundColor;
+ // Now back color and color key must be converted to image's data format, looks ugly
+ case Image.Format of
+ ifA8Gray8:
+ begin
+ TColor32Rec(TInt64Rec(ColorKey).Low).B := Byte(ColorKey.B);
+ TColor32Rec(TInt64Rec(ColorKey).Low).G := $FF;
+ TColor32Rec(TInt64Rec(BackGroundColor).Low).B := Byte(BackGroundColor.B);
+ end;
+ ifA16Gray16:
+ begin
+ ColorKey.G := $FFFF;
+ end;
+ ifA8R8G8B8:
+ begin
+ TColor32Rec(TInt64Rec(ColorKey).Low).R := Byte(ColorKey.R);
+ TColor32Rec(TInt64Rec(ColorKey).Low).G := Byte(ColorKey.G);
+ TColor32Rec(TInt64Rec(ColorKey).Low).B := Byte(ColorKey.B);
+ TColor32Rec(TInt64Rec(ColorKey).Low).A := $FF;
+ TColor32Rec(TInt64Rec(BackGroundColor).Low).R := Byte(BackGroundColor.R);
+ TColor32Rec(TInt64Rec(BackGroundColor).Low).G := Byte(BackGroundColor.G);
+ TColor32Rec(TInt64Rec(BackGroundColor).Low).B := Byte(BackGroundColor.B);
+ end;
+ ifA16R16G16B16:
+ begin
+ ColorKey.A := $FFFF;
+ end;
+ end;
+ ReplaceColor(Image, 0, 0, Image.Width, Image.Height, OldPixel, NewPixel);
+ end;
+ end;
+
+begin
+ Alphas := nil;
+ IsColorKeyPresent := False;
+ IsBackGroundPresent := False;
+ GetImageFormatInfo(Image.Format, FmtInfo);
+
+ IsColorFormat := (Frame.IsJpegFrame and (Frame.JHDR.ColorType in [10, 14])) or
+ (not Frame.IsJpegFrame and (Frame.IHDR.ColorType in [2, 6]));
+
+ // Convert some chunk data to useful format
+ if Frame.Transparency <> nil then
+ ConverttRNS;
+ if Frame.Background <> nil then
+ ConvertbKGD;
+
+ // Build palette for indexed images
+ if FmtInfo.IsIndexed then
+ ReconstructPalette;
+
+ // Apply color keying
+ if IsColorKeyPresent and not FmtInfo.HasAlphaChannel then
+ ApplyColorKey;
+
+ FreeMemNil(Alphas);
+end;
+
+{ TNGFileSaver class implementation }
+
+procedure TNGFileSaver.StoreImageToPNGFrame(const IHDR: TIHDR; Bits: Pointer;
+ FmtInfo: TImageFormatInfo; IDATStream: TMemoryStream);
+var
+ TotalBuffer, CompBuffer, ZeroLine, PrevLine: Pointer;
+ FilterLines: array[0..4] of PByteArray;
+ TotalSize, CompSize, I, BytesPerLine, BytesPerPixel: LongInt;
+ Filter: Byte;
+ Adaptive: Boolean;
+
+ procedure FilterScanline(Filter: Byte; BytesPerPixel: LongInt; Line, PrevLine, Target: PByteArray);
+ var
+ I: LongInt;
+ begin
+ case Filter of
+ 0:
+ begin
+ // No filter
+ Move(Line^, Target^, BytesPerLine);
+ end;
+ 1:
+ begin
+ // Sub filter
+ Move(Line^, Target^, BytesPerPixel);
+ for I := BytesPerPixel to BytesPerLine - 1 do
+ Target[I] := (Line[I] - Line[I - BytesPerPixel]) and $FF;
+ end;
+ 2:
+ begin
+ // Up filter
+ for I := 0 to BytesPerLine - 1 do
+ Target[I] := (Line[I] - PrevLine[I]) and $FF;
+ end;
+ 3:
+ begin
+ // Average filter
+ for I := 0 to BytesPerPixel - 1 do
+ Target[I] := (Line[I] - PrevLine[I] shr 1) and $FF;
+ for I := BytesPerPixel to BytesPerLine - 1 do
+ Target[I] := (Line[I] - (Line[I - BytesPerPixel] + PrevLine[I]) shr 1) and $FF;
+ end;
+ 4:
+ begin
+ // Paeth filter
+ for I := 0 to BytesPerPixel - 1 do
+ Target[I] := (Line[I] - PaethPredictor(0, PrevLine[I], 0)) and $FF;
+ for I := BytesPerPixel to BytesPerLine - 1 do
+ Target[I] := (Line[I] - PaethPredictor(Line[I - BytesPerPixel], PrevLine[I], PrevLine[I - BytesPerPixel])) and $FF;
+ end;
+ end;
+ end;
+
+ procedure AdaptiveFilter(var Filter: Byte; BytesPerPixel: LongInt; Line, PrevLine, Target: PByteArray);
+ var
+ I, J, BestTest: LongInt;
+ Sums: array[0..4] of LongInt;
+ begin
+ // Compute the output scanline using all five filters,
+ // and select the filter that gives the smallest sum of
+ // absolute values of outputs
+ FillChar(Sums, SizeOf(Sums), 0);
+ BestTest := MaxInt;
+ for I := 0 to 4 do
+ begin
+ FilterScanline(I, BytesPerPixel, Line, PrevLine, FilterLines[I]);
+ for J := 0 to BytesPerLine - 1 do
+ Sums[I] := Sums[I] + Abs(ShortInt(FilterLines[I][J]));
+ if Sums[I] < BestTest then
+ begin
+ Filter := I;
+ BestTest := Sums[I];
+ end;
+ end;
+ Move(FilterLines[Filter]^, Target^, BytesPerLine);
+ end;
+
+begin
+ // Select precompression filter and compression level
+ Adaptive := False;
+ Filter := 0;
+ case PreFilter of
+ 6:
+ if not ((IHDR.BitDepth < 8) or (IHDR.ColorType = 3))
+ then Adaptive := True;
+ 0..4: Filter := PreFilter;
+ else
+ if IHDR.ColorType in [2, 6] then
+ Filter := 4
+ end;
+ // Prepare data for compression
+ CompBuffer := nil;
+ FillChar(FilterLines, SizeOf(FilterLines), 0);
+ BytesPerPixel := FmtInfo.BytesPerPixel;
+ BytesPerLine := LongInt(IHDR.Width) * BytesPerPixel;
+ TotalSize := (BytesPerLine + 1) * LongInt(IHDR.Height);
+ GetMem(TotalBuffer, TotalSize);
+ GetMem(ZeroLine, BytesPerLine);
+ FillChar(ZeroLine^, BytesPerLine, 0);
+ if Adaptive then
+ for I := 0 to 4 do
+ GetMem(FilterLines[I], BytesPerLine);
+ PrevLine := ZeroLine;
+ try
+ // Process next scanlines
+ for I := 0 to IHDR.Height - 1 do
+ begin
+ // Filter scanline
+ if Adaptive then
+ AdaptiveFilter(Filter, BytesPerPixel, @PByteArray(Bits)[I * BytesPerLine],
+ PrevLine, @PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + 1])
+ else
+ FilterScanline(Filter, BytesPerPixel, @PByteArray(Bits)[I * BytesPerLine],
+ PrevLine, @PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + 1]);
+ PrevLine := @PByteArray(Bits)[I * BytesPerLine];
+ // Swap red and blue if necessary
+ if (IHDR.ColorType in [2, 6]) and not FmtInfo.IsRBSwapped then
+ SwapRGB(@PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + 1],
+ IHDR.Width, IHDR.BitDepth, FmtInfo.BytesPerPixel);
+ // Images with 16 bit channels must be swapped because of PNG's big endianess
+ if IHDR.BitDepth = 16 then
+ SwapEndianWord(@PByteArray(TotalBuffer)[I * (BytesPerLine + 1) + 1],
+ BytesPerLine div SizeOf(Word));
+ // Set filter used for this scanline
+ PByteArray(TotalBuffer)[I * (BytesPerLine + 1)] := Filter;
+ end;
+ // Compress IDAT data
+ CompressBuf(TotalBuffer, TotalSize, CompBuffer, CompSize, CompressLevel);
+ // Write IDAT data to stream
+ IDATStream.WriteBuffer(CompBuffer^, CompSize);
+ finally
+ FreeMem(TotalBuffer);
+ FreeMem(CompBuffer);
+ FreeMem(ZeroLine);
+ if Adaptive then
+ for I := 0 to 4 do
+ FreeMem(FilterLines[I]);
+ end;
+end;
+
+{$IFNDEF DONT_LINK_JNG}
+
+procedure TNGFileSaver.StoreImageToJNGFrame(const JHDR: TJHDR;
+ const Image: TImageData; IDATStream, JDATStream,
+ JDAAStream: TMemoryStream);
+var
+ ColorImage, AlphaImage: TImageData;
+ FmtInfo: TImageFormatInfo;
+ AlphaPtr: PByte;
+ GrayPtr: PWordRec;
+ ColorPtr: PColor32Rec;
+ I: LongInt;
+ FakeIHDR: TIHDR;
+
+ procedure SaveJpegToStream(Stream: TStream; const Image: TImageData);
+ var
+ JpegFormat: TCustomIOJpegFileFormat;
+ Handle: TImagingHandle;
+ DynImages: TDynImageDataArray;
+ begin
+ JpegFormat := TCustomIOJpegFileFormat.Create;
+ JpegFormat.SetCustomIO(StreamIO);
+ // Only JDAT stream can be saved progressive
+ if Stream = JDATStream then
+ JpegFormat.FProgressive := Progressive
+ else
+ JpegFormat.FProgressive := False;
+ JpegFormat.FQuality := Quality;
+ SetLength(DynImages, 1);
+ DynImages[0] := Image;
+ Handle := StreamIO.OpenWrite(Pointer(Stream));
+ try
+ JpegFormat.SaveData(Handle, DynImages, 0);
+ finally
+ StreamIO.Close(Handle);
+ SetLength(DynImages, 0);
+ JpegFormat.Free;
+ end;
+ end;
+
+begin
+ GetImageFormatInfo(Image.Format, FmtInfo);
+ InitImage(ColorImage);
+ InitImage(AlphaImage);
+
+ if FmtInfo.HasAlphaChannel then
+ begin
+ // Create new image for alpha channel and color image without alpha
+ CloneImage(Image, ColorImage);
+ NewImage(Image.Width, Image.Height, ifGray8, AlphaImage);
+ case Image.Format of
+ ifA8Gray8: ConvertImage(ColorImage, ifGray8);
+ ifA8R8G8B8: ConvertImage(ColorImage, ifR8G8B8);
+ end;
+
+ // Store source image's alpha to separate image
+ AlphaPtr := AlphaImage.Bits;
+ if Image.Format = ifA8Gray8 then
+ begin
+ GrayPtr := Image.Bits;
+ for I := 0 to Image.Width * Image.Height - 1 do
+ begin
+ AlphaPtr^ := GrayPtr.High;
+ Inc(GrayPtr);
+ Inc(AlphaPtr);
+ end;
+ end
+ else
+ begin
+ ColorPtr := Image.Bits;
+ for I := 0 to Image.Width * Image.Height - 1 do
+ begin
+ AlphaPtr^ := ColorPtr.A;
+ Inc(ColorPtr);
+ Inc(AlphaPtr);
+ end;
+ end;
+
+ // Write color image to stream as JPEG
+ SaveJpegToStream(JDATStream, ColorImage);
+
+ if LossyAlpha then
+ begin
+ // Write alpha image to stream as JPEG
+ SaveJpegToStream(JDAAStream, AlphaImage);
+ end
+ else
+ begin
+ // Alpha channel is PNG compressed
+ FakeIHDR.Width := JHDR.Width;
+ FakeIHDR.Height := JHDR.Height;
+ FakeIHDR.ColorType := 0;
+ FakeIHDR.BitDepth := JHDR.AlphaSampleDepth;
+ FakeIHDR.Filter := JHDR.AlphaFilter;
+ FakeIHDR.Interlacing := JHDR.AlphaInterlacing;
+
+ GetImageFormatInfo(AlphaImage.Format, FmtInfo);
+ StoreImageToPNGFrame(FakeIHDR, AlphaImage.Bits, FmtInfo, IDATStream);
+ end;
+
+ FreeImage(ColorImage);
+ FreeImage(AlphaImage);
+ end
+ else
+ begin
+ // Simply write JPEG to stream
+ SaveJpegToStream(JDATStream, Image);
+ end;
+end;
+
+{$ENDIF}
+
+procedure TNGFileSaver.AddFrame(const Image: TImageData; IsJpegFrame: Boolean);
+var
+ Frame: TFrameInfo;
+ FmtInfo: TImageFormatInfo;
+
+ procedure StorePalette;
+ var
+ Pal: PPalette24;
+ Alphas: PByteArray;
+ I, PalBytes: LongInt;
+ AlphasDiffer: Boolean;
+ begin
+ // Fill and save RGB part of palette to PLTE chunk
+ PalBytes := FmtInfo.PaletteEntries * SizeOf(TColor24Rec);
+ GetMem(Pal, PalBytes);
+ AlphasDiffer := False;
+ for I := 0 to FmtInfo.PaletteEntries - 1 do
+ begin
+ Pal[I].B := Image.Palette[I].R;
+ Pal[I].G := Image.Palette[I].G;
+ Pal[I].R := Image.Palette[I].B;
+ if Image.Palette[I].A < 255 then
+ AlphasDiffer := True;
+ end;
+ Frame.Palette := Pal;
+ Frame.PaletteEntries := FmtInfo.PaletteEntries;
+ // Fill and save alpha part (if there are any alphas < 255) of palette to tRNS chunk
+ if AlphasDiffer then
+ begin
+ PalBytes := FmtInfo.PaletteEntries * SizeOf(Byte);
+ GetMem(Alphas, PalBytes);
+ for I := 0 to FmtInfo.PaletteEntries - 1 do
+ Alphas[I] := Image.Palette[I].A;
+ Frame.Transparency := Alphas;
+ Frame.TransparencySize := PalBytes;
+ end;
+ end;
+
+begin
+ // Add new frame
+ Frame := AddFrameInfo;
+ Frame.IsJpegFrame := IsJpegFrame;
+
+ with Frame do
+ begin
+ GetImageFormatInfo(Image.Format, FmtInfo);
+
+ if IsJpegFrame then
+ begin
+{$IFNDEF DONT_LINK_JNG}
+ // Fill JNG header
+ JHDR.Width := Image.Width;
+ JHDR.Height := Image.Height;
+ case Image.Format of
+ ifGray8: JHDR.ColorType := 8;
+ ifR8G8B8: JHDR.ColorType := 10;
+ ifA8Gray8: JHDR.ColorType := 12;
+ ifA8R8G8B8: JHDR.ColorType := 14;
+ end;
+ JHDR.SampleDepth := 8; // 8-bit samples and quantization tables
+ JHDR.Compression := 8; // Huffman coding
+ JHDR.Interlacing := Iff(Progressive, 8, 0);
+ JHDR.AlphaSampleDepth := Iff(FmtInfo.HasAlphaChannel, 8, 0);
+ JHDR.AlphaCompression := Iff(LossyAlpha, 8, 0);
+ JHDR.AlphaFilter := 0;
+ JHDR.AlphaInterlacing := 0;
+
+ StoreImageToJNGFrame(JHDR, Image, IDATMemory, JDATMemory, JDAAMemory);
+
+ // Finally swap endian
+ SwapEndianLongWord(@JHDR, 2);
+{$ENDIF}
+ end
+ else
+ begin
+ // Fill PNG header
+ IHDR.Width := Image.Width;
+ IHDR.Height := Image.Height;
+ IHDR.Compression := 0;
+ IHDR.Filter := 0;
+ IHDR.Interlacing := 0;
+ IHDR.BitDepth := FmtInfo.BytesPerPixel * 8;
+
+ // Select appropiate PNG color type and modify bitdepth
+ if FmtInfo.HasGrayChannel then
+ begin
+ IHDR.ColorType := 0;
+ if FmtInfo.HasAlphaChannel then
+ begin
+ IHDR.ColorType := 4;
+ IHDR.BitDepth := IHDR.BitDepth div 2;
+ end;
+ end
+ else
+ begin
+ if FmtInfo.IsIndexed then
+ IHDR.ColorType := 3
+ else
+ if FmtInfo.HasAlphaChannel then
+ begin
+ IHDR.ColorType := 6;
+ IHDR.BitDepth := IHDR.BitDepth div 4;
+ end
+ else
+ begin
+ IHDR.ColorType := 2;
+ IHDR.BitDepth := IHDR.BitDepth div 3;
+ end;
+ end;
+
+ if FileType = ngAPNG then
+ begin
+ // Fill fcTL chunk of APNG file
+ fcTL.SeqNumber := 0; // Decided when writing to file
+ fcTL.Width := IHDR.Width;
+ fcTL.Height := IHDR.Height;
+ fcTL.XOffset := 0;
+ fcTL.YOffset := 0;
+ fcTL.DelayNumer := 1;
+ fcTL.DelayDenom := 3;
+ fcTL.DisposeOp := DisposeOpNone;
+ fcTL.BlendOp := BlendOpSource;
+ SwapEndianLongWord(@fcTL, 5);
+ fcTL.DelayNumer := SwapEndianWord(fcTL.DelayNumer);
+ fcTL.DelayDenom := SwapEndianWord(fcTL.DelayDenom);
+ end;
+
+ // Compress PNG image and store it to stream
+ StoreImageToPNGFrame(IHDR, Image.Bits, FmtInfo, IDATMemory);
+ // Store palette if necesary
+ if FmtInfo.IsIndexed then
+ StorePalette;
+
+ // Finally swap endian
+ SwapEndianLongWord(@IHDR, 2);
+ end;
+ end;
+end;
+
+function TNGFileSaver.SaveFile(Handle: TImagingHandle): Boolean;
+var
+ I: LongInt;
+ Chunk: TChunkHeader;
+ SeqNo: LongWord;
+
+ function GetNextSeqNo: LongWord;
+ begin
+ // Seq numbers of fcTL and fdAT are "interleaved" as they share the counter.
+ // Example: first fcTL for IDAT has seq=0, next is fcTL for seond frame with
+ // seq=1, then first fdAT with seq=2, fcTL seq=3, fdAT=4, ...
+ Result := SwapEndianLongWord(SeqNo);
+ Inc(SeqNo);
+ end;
+
+ function CalcChunkCrc(const ChunkHdr: TChunkHeader; Data: Pointer;
+ Size: LongInt): LongWord;
+ begin
+ Result := $FFFFFFFF;
+ CalcCrc32(Result, @ChunkHdr.ChunkID, SizeOf(ChunkHdr.ChunkID));
+ CalcCrc32(Result, Data, Size);
+ Result := SwapEndianLongWord(Result xor $FFFFFFFF);
+ end;
+
+ procedure WriteChunk(var Chunk: TChunkHeader; ChunkData: Pointer);
+ var
+ ChunkCrc: LongWord;
+ SizeToWrite: LongInt;
+ begin
+ SizeToWrite := Chunk.DataSize;
+ Chunk.DataSize := SwapEndianLongWord(Chunk.DataSize);
+ ChunkCrc := CalcChunkCrc(Chunk, ChunkData, SizeToWrite);
+ GetIO.Write(Handle, @Chunk, SizeOf(Chunk));
+ if SizeToWrite <> 0 then
+ GetIO.Write(Handle, ChunkData, SizeToWrite);
+ GetIO.Write(Handle, @ChunkCrc, SizeOf(ChunkCrc));
+ end;
+
+ procedure WritefdAT(Frame: TFrameInfo);
+ var
+ ChunkCrc: LongWord;
+ ChunkSeqNo: LongWord;
+ begin
+ Chunk.ChunkID := fdATChunk;
+ ChunkSeqNo := GetNextSeqNo;
+ // fdAT saves seq number LongWord before compressed pixels
+ Chunk.DataSize := Frame.IDATMemory.Size + SizeOf(LongWord);
+ Chunk.DataSize := SwapEndianLongWord(Chunk.DataSize);
+ // Calc CRC
+ ChunkCrc := $FFFFFFFF;
+ CalcCrc32(ChunkCrc, @Chunk.ChunkID, SizeOf(Chunk.ChunkID));
+ CalcCrc32(ChunkCrc, @ChunkSeqNo, SizeOf(ChunkSeqNo));
+ CalcCrc32(ChunkCrc, Frame.IDATMemory.Memory, Frame.IDATMemory.Size);
+ ChunkCrc := SwapEndianLongWord(ChunkCrc xor $FFFFFFFF);
+ // Write out all fdAT data
+ GetIO.Write(Handle, @Chunk, SizeOf(Chunk));
+ GetIO.Write(Handle, @ChunkSeqNo, SizeOf(ChunkSeqNo));
+ GetIO.Write(Handle, Frame.IDATMemory.Memory, Frame.IDATMemory.Size);
+ GetIO.Write(Handle, @ChunkCrc, SizeOf(ChunkCrc));
+ end;
+
+ procedure WritePNGMainImageChunks(Frame: TFrameInfo);
+ begin
+ with Frame do
+ begin
+ // Write IHDR chunk
+ Chunk.DataSize := SizeOf(IHDR);
+ Chunk.ChunkID := IHDRChunk;
+ WriteChunk(Chunk, @IHDR);
+ // Write PLTE chunk if data is present
+ if Palette <> nil then
+ begin
+ Chunk.DataSize := PaletteEntries * SizeOf(TColor24Rec);
+ Chunk.ChunkID := PLTEChunk;
+ WriteChunk(Chunk, Palette);
+ end;
+ // Write tRNS chunk if data is present
+ if Transparency <> nil then
+ begin
+ Chunk.DataSize := TransparencySize;
+ Chunk.ChunkID := tRNSChunk;
+ WriteChunk(Chunk, Transparency);
+ end;
+ end;
+ end;
+
+begin
+ Result := False;
+ SeqNo := 0;
+
+ case FileType of
+ ngPNG, ngAPNG: GetIO.Write(Handle, @PNGSignature, SizeOf(TChar8));
+ ngMNG: GetIO.Write(Handle, @MNGSignature, SizeOf(TChar8));
+ ngJNG: GetIO.Write(Handle, @JNGSignature, SizeOf(TChar8));
+ end;
+
+ if FileType = ngMNG then
+ begin
+ SwapEndianLongWord(@MHDR, SizeOf(MHDR) div SizeOf(LongWord));
+ Chunk.DataSize := SizeOf(MHDR);
+ Chunk.ChunkID := MHDRChunk;
+ WriteChunk(Chunk, @MHDR);
+ end;
+
+ for I := 0 to Length(Frames) - 1 do
+ with Frames[I] do
+ begin
+ if IsJpegFrame then
+ begin
+ // Write JHDR chunk
+ Chunk.DataSize := SizeOf(JHDR);
+ Chunk.ChunkID := JHDRChunk;
+ WriteChunk(Chunk, @JHDR);
+ // Write JNG image data
+ Chunk.DataSize := JDATMemory.Size;
+ Chunk.ChunkID := JDATChunk;
+ WriteChunk(Chunk, JDATMemory.Memory);
+ // Write alpha channel if present
+ if JHDR.AlphaSampleDepth > 0 then
+ begin
+ if JHDR.AlphaCompression = 0 then
+ begin
+ // Alpha is PNG compressed
+ Chunk.DataSize := IDATMemory.Size;
+ Chunk.ChunkID := IDATChunk;
+ WriteChunk(Chunk, IDATMemory.Memory);
+ end
+ else
+ begin
+ // Alpha is JNG compressed
+ Chunk.DataSize := JDAAMemory.Size;
+ Chunk.ChunkID := JDAAChunk;
+ WriteChunk(Chunk, JDAAMemory.Memory);
+ end;
+ end;
+ // Write image end
+ Chunk.DataSize := 0;
+ Chunk.ChunkID := IENDChunk;
+ WriteChunk(Chunk, nil);
+ end
+ else if FileType <> ngAPNG then
+ begin
+ // Regular PNG frame (single PNG image or MNG frame)
+ WritePNGMainImageChunks(Frames[I]);
+ // Write PNG image data
+ Chunk.DataSize := IDATMemory.Size;
+ Chunk.ChunkID := IDATChunk;
+ WriteChunk(Chunk, IDATMemory.Memory);
+ // Write image end
+ Chunk.DataSize := 0;
+ Chunk.ChunkID := IENDChunk;
+ WriteChunk(Chunk, nil);
+ end
+ else if FileType = ngAPNG then
+ begin
+ // APNG frame - first frame must have acTL and fcTL before IDAT,
+ // subsequent frames have fcTL and fdAT.
+ if I = 0 then
+ begin
+ WritePNGMainImageChunks(Frames[I]);
+ Chunk.DataSize := SizeOf(acTL);
+ Chunk.ChunkID := acTLChunk;
+ WriteChunk(Chunk, @acTL);
+ end;
+ // Write fcTL before frame data
+ Chunk.DataSize := SizeOf(fcTL);
+ Chunk.ChunkID := fcTLChunk;
+ fcTl.SeqNumber := GetNextSeqNo;
+ WriteChunk(Chunk, @fcTL);
+ // Write data - IDAT for first frame and fdAT for following ones
+ if I = 0 then
+ begin
+ Chunk.DataSize := IDATMemory.Size;
+ Chunk.ChunkID := IDATChunk;
+ WriteChunk(Chunk, IDATMemory.Memory);
+ end
+ else
+ WritefdAT(Frames[I]);
+ // Write image end after last frame
+ if I = Length(Frames) - 1 then
+ begin
+ Chunk.DataSize := 0;
+ Chunk.ChunkID := IENDChunk;
+ WriteChunk(Chunk, nil);
+ end;
+ end;
+ end;
+
+ if FileType = ngMNG then
+ begin
+ Chunk.DataSize := 0;
+ Chunk.ChunkID := MENDChunk;
+ WriteChunk(Chunk, nil);
+ end;
+end;
+
+procedure TNGFileSaver.SetFileOptions(FileFormat: TNetworkGraphicsFileFormat);
+begin
+ PreFilter := FileFormat.FPreFilter;
+ CompressLevel := FileFormat.FCompressLevel;
+ LossyAlpha := FileFormat.FLossyAlpha;
+ Quality := FileFormat.FQuality;
+ Progressive := FileFormat.FProgressive;
+end;
+
+{ TAPNGAnimator class implemnetation }
+
+class procedure TAPNGAnimator.Animate(var Images: TDynImageDataArray;
+ const acTL: TacTL; const SrcFrames: array of TFrameInfo);
+var
+ I, SrcIdx, Offset, Len: Integer;
+ DestFrames: TDynImageDataArray;
+ SrcCanvas, DestCanvas: TImagingCanvas;
+ PreviousCache: TImageData;
+
+ function AnimatingNeeded: Boolean;
+ var
+ I: Integer;
+ begin
+ Result := False;
+ for I := 0 to Len - 1 do
+ with SrcFrames[I] do
+ begin
+ if (FrameWidth <> IHDR.Width) or (FrameHeight <> IHDR.Height) or (Len <> acTL.NumFrames) or
+ (not ((fcTL.DisposeOp = DisposeOpNone) and (fcTL.BlendOp = BlendOpSource)) and
+ not ((fcTL.DisposeOp = DisposeOpBackground) and (fcTL.BlendOp = BlendOpSource)) and
+ not ((fcTL.DisposeOp = DisposeOpBackground) and (fcTL.BlendOp = BlendOpOver))) then
+ begin
+ Result := True;
+ Exit;
+ end;
+ end;
+ end;
+
+begin
+ Len := Length(SrcFrames);
+ if (Len = 0) or not AnimatingNeeded then
+ Exit;
+
+ if (Len = acTL.NumFrames + 1) and (SrcFrames[0].fcTL.Width = 0) then
+ begin
+ // If default image (stored in IDAT chunk) isn't part of animation we ignore it
+ Offset := 1;
+ Len := Len - 1;
+ end
+ else
+ Offset := 0;
+
+ SetLength(DestFrames, Len);
+ DestCanvas := ImagingCanvases.FindBestCanvasForImage(Images[0]).Create;
+ SrcCanvas := ImagingCanvases.FindBestCanvasForImage(Images[0]).Create;
+ InitImage(PreviousCache);
+ NewImage(SrcFrames[0].IHDR.Width, SrcFrames[0].IHDR.Height, Images[0].Format, PreviousCache);
+
+ for I := 0 to Len - 1 do
+ begin
+ SrcIdx := I + Offset;
+ NewImage(SrcFrames[SrcIdx].IHDR.Width, SrcFrames[SrcIdx].IHDR.Height,
+ Images[SrcIdx].Format, DestFrames[I]);
+ if DestFrames[I].Format = ifIndex8 then
+ Move(Images[SrcIdx].Palette^, DestFrames[I].Palette^, 256 * SizeOf(TColor32));
+ DestCanvas.CreateForData(@DestFrames[I]);
+
+ if (SrcFrames[SrcIdx].fcTL.DisposeOp = DisposeOpPrevious) and (SrcFrames[SrcIdx - 1].fcTL.DisposeOp <> DisposeOpPrevious) then
+ begin
+ // Cache current output buffer so we may return to it later (previous dispose op)
+ CopyRect(DestFrames[I - 1], 0, 0, DestFrames[I - 1].Width, DestFrames[I - 1].Height,
+ PreviousCache, 0, 0);
+ end;
+
+ if (I = 0) or (SrcIdx = 0) then
+ begin
+ // Clear whole frame with transparent black color (default for first frame)
+ DestCanvas.FillColor32 := pcClear;
+ DestCanvas.Clear;
+ end
+ else if SrcFrames[SrcIdx - 1].fcTL.DisposeOp = DisposeOpBackground then
+ begin
+ // Restore background color (clear) on previous frame's area and leave previous content outside of it
+ CopyRect(DestFrames[I - 1], 0, 0, DestFrames[I - 1].Width, DestFrames[I - 1].Height,
+ DestFrames[I], 0, 0);
+ DestCanvas.FillColor32 := pcClear;
+ DestCanvas.FillRect(BoundsToRect(SrcFrames[SrcIdx - 1].fcTL.XOffset, SrcFrames[SrcIdx - 1].fcTL.YOffset,
+ SrcFrames[SrcIdx - 1].FrameWidth, SrcFrames[SrcIdx - 1].FrameHeight));
+ end
+ else if SrcFrames[SrcIdx - 1].fcTL.DisposeOp = DisposeOpNone then
+ begin
+ // Clone previous frame - no change to output buffer
+ CopyRect(DestFrames[I - 1], 0, 0, DestFrames[I - 1].Width, DestFrames[I - 1].Height,
+ DestFrames[I], 0, 0);
+ end
+ else if SrcFrames[SrcIdx - 1].fcTL.DisposeOp = DisposeOpPrevious then
+ begin
+ // Revert to previous frame (cached, can't just restore DestFrames[I - 2])
+ CopyRect(PreviousCache, 0, 0, PreviousCache.Width, PreviousCache.Height,
+ DestFrames[I], 0, 0);
+ end;
+
+ // Copy pixels or alpha blend them over
+ if SrcFrames[SrcIdx].fcTL.BlendOp = BlendOpSource then
+ begin
+ CopyRect(Images[SrcIdx], 0, 0, Images[SrcIdx].Width, Images[SrcIdx].Height,
+ DestFrames[I], SrcFrames[SrcIdx].fcTL.XOffset, SrcFrames[SrcIdx].fcTL.YOffset);
+ end
+ else if SrcFrames[SrcIdx].fcTL.BlendOp = BlendOpOver then
+ begin
+ SrcCanvas.CreateForData(@Images[SrcIdx]);
+ SrcCanvas.DrawAlpha(SrcCanvas.ClipRect, DestCanvas,
+ SrcFrames[SrcIdx].fcTL.XOffset, SrcFrames[SrcIdx].fcTL.YOffset);
+ end;
+
+ FreeImage(Images[SrcIdx]);
+ end;
+
+ DestCanvas.Free;
+ SrcCanvas.Free;
+ FreeImage(PreviousCache);
+
+ // Assign dest frames to final output images
+ Images := DestFrames;
+end;
+
+{ TNetworkGraphicsFileFormat class implementation }
+
+constructor TNetworkGraphicsFileFormat.Create;
+begin
+ inherited Create;
+ FCanLoad := True;
+ FCanSave := True;
+ FIsMultiImageFormat := False;
+
+ FPreFilter := NGDefaultPreFilter;
+ FCompressLevel := NGDefaultCompressLevel;
+ FLossyAlpha := NGDefaultLossyAlpha;
+ FLossyCompression := NGDefaultLossyCompression;
+ FQuality := NGDefaultQuality;
+ FProgressive := NGDefaultProgressive;
+end;
+
+procedure TNetworkGraphicsFileFormat.CheckOptionsValidity;
+begin
+ // Just check if save options has valid values
+ if not (FPreFilter in [0..6]) then
+ FPreFilter := NGDefaultPreFilter;
+ if not (FCompressLevel in [0..9]) then
+ FCompressLevel := NGDefaultCompressLevel;
+ if not (FQuality in [1..100]) then
+ FQuality := NGDefaultQuality;
+end;
+
+function TNetworkGraphicsFileFormat.GetSupportedFormats: TImageFormats;
+begin
+ if FLossyCompression then
+ Result := NGLossyFormats
+ else
+ Result := NGLosslessFormats;
+end;
+
+procedure TNetworkGraphicsFileFormat.ConvertToSupported(var Image: TImageData;
+ const Info: TImageFormatInfo);
+var
+ ConvFormat: TImageFormat;
+begin
+ if not FLossyCompression then
+ begin
+ // Convert formats for lossless compression
+ if Info.HasGrayChannel then
+ begin
+ if Info.HasAlphaChannel then
+ begin
+ if Info.BytesPerPixel <= 2 then
+ // Convert <= 16bit grayscale images with alpha to ifA8Gray8
+ ConvFormat := ifA8Gray8
+ else
+ // Convert > 16bit grayscale images with alpha to ifA16Gray16
+ ConvFormat := ifA16Gray16
+ end
+ else
+ // Convert grayscale images without alpha to ifGray16
+ ConvFormat := ifGray16;
+ end
+ else
+ if Info.IsFloatingPoint then
+ // Convert floating point images to 64 bit ARGB (or RGB if no alpha)
+ ConvFormat := IffFormat(Info.HasAlphaChannel, ifA16B16G16R16, ifB16G16R16)
+ else if Info.HasAlphaChannel or Info.IsSpecial then
+ // Convert all other images with alpha or special images to A8R8G8B8
+ ConvFormat := ifA8R8G8B8
+ else
+ // Convert images without alpha to R8G8B8
+ ConvFormat := ifR8G8B8;
+ end
+ else
+ begin
+ // Convert formats for lossy compression
+ if Info.HasGrayChannel then
+ ConvFormat := IffFormat(Info.HasAlphaChannel, ifA8Gray8, ifGray8)
+ else
+ ConvFormat := IffFormat(Info.HasAlphaChannel, ifA8R8G8B8, ifR8G8B8);
+ end;
+
+ ConvertImage(Image, ConvFormat);
+end;
+
+function TNetworkGraphicsFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
+var
+ ReadCount: LongInt;
+ Sig: TChar8;
+begin
+ Result := False;
+ if Handle <> nil then
+ with GetIO do
+ begin
+ FillChar(Sig, SizeOf(Sig), 0);
+ ReadCount := Read(Handle, @Sig, SizeOf(Sig));
+ Seek(Handle, -ReadCount, smFromCurrent);
+ Result := (ReadCount = SizeOf(Sig)) and (Sig = FSignature);
+ end;
+end;
+
+{ TPNGFileFormat class implementation }
+
+constructor TPNGFileFormat.Create;
+begin
+ inherited Create;
+ FName := SPNGFormatName;
+ FIsMultiImageFormat := True;
+ FLoadAnimated := PNGDefaultLoadAnimated;
+ AddMasks(SPNGMasks);
+
+ FSignature := PNGSignature;
+
+ RegisterOption(ImagingPNGPreFilter, @FPreFilter);
+ RegisterOption(ImagingPNGCompressLevel, @FCompressLevel);
+ RegisterOption(ImagingPNGLoadAnimated, @FLoadAnimated);
+end;
+
+function TPNGFileFormat.LoadData(Handle: TImagingHandle;
+ var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
+var
+ I, Len: LongInt;
+ NGFileLoader: TNGFileLoader;
+begin
+ Result := False;
+ NGFileLoader := TNGFileLoader.Create;
+ try
+ // Use NG file parser to load file
+ if NGFileLoader.LoadFile(Handle) and (Length(NGFileLoader.Frames) > 0) then
+ begin
+ Len := Length(NGFileLoader.Frames);
+ SetLength(Images, Len);
+ for I := 0 to Len - 1 do
+ with NGFileLoader.Frames[I] do
+ begin
+ // Build actual image bits
+ if not IsJpegFrame then
+ NGFileLoader.LoadImageFromPNGFrame(FrameWidth, FrameHeight, IHDR, IDATMemory, Images[I]);
+ // Build palette, aply color key or background
+ NGFileLoader.ApplyFrameSettings(NGFileLoader.Frames[I], Images[I]);
+ Result := True;
+ end;
+ // Animate APNG images
+ if (NGFileLoader.FileType = ngAPNG) and FLoadAnimated then
+ TAPNGAnimator.Animate(Images, NGFileLoader.acTL, NGFileLoader.Frames);
+ end;
+ finally
+ NGFileLoader.Free;
+ end;
+end;
+
+function TPNGFileFormat.SaveData(Handle: TImagingHandle;
+ const Images: TDynImageDataArray; Index: LongInt): Boolean;
+var
+ I: Integer;
+ ImageToSave: TImageData;
+ MustBeFreed: Boolean;
+ NGFileSaver: TNGFileSaver;
+ DefaultFormat: TImageFormat;
+ Screen: TImageData;
+ AnimWidth, AnimHeight: Integer;
+begin
+ Result := False;
+ DefaultFormat := ifDefault;
+ AnimWidth := 0;
+ AnimHeight := 0;
+ NGFileSaver := TNGFileSaver.Create;
+
+ // Save images with more frames as APNG format
+ if Length(Images) > 1 then
+ begin
+ NGFileSaver.FileType := ngAPNG;
+ NGFileSaver.acTL.NumFrames := FLastIdx - FFirstIdx + 1;
+ NGFileSaver.acTL.NumPlay := 1;
+ SwapEndianLongWord(@NGFileSaver.acTL, SizeOf(NGFileSaver.acTL) div SizeOf(LongWord));
+ // Get max dimensions of frames
+ AnimWidth := Images[FFirstIdx].Width;
+ AnimHeight := Images[FFirstIdx].Height;
+ for I := FFirstIdx + 1 to FLastIdx do
+ begin
+ AnimWidth := Max(AnimWidth, Images[I].Width);
+ AnimHeight := Max(AnimHeight, Images[I].Height);
+ end;
+ end
+ else
+ NGFileSaver.FileType := ngPNG;
+ NGFileSaver.SetFileOptions(Self);
+
+ with NGFileSaver do
+ try
+ // Store all frames to be saved frames file saver
+ for I := FFirstIdx to FLastIdx do
+ begin
+ if MakeCompatible(Images[I], ImageToSave, MustBeFreed) then
+ try
+ if FileType = ngAPNG then
+ begin
+ // IHDR chunk is shared for all frames so all frames must have the
+ // same data format as the first image.
+ if I = FFirstIdx then
+ begin
+ DefaultFormat := ImageToSave.Format;
+ // Subsequenet frames may be bigger than the first one.
+ // APNG doens't support this - max allowed size is what's written in
+ // IHDR - size of main/default/first image. If some frame is
+ // bigger than the first one we need to resize (create empty bigger
+ // image and copy) the first frame so all following frames could fit to
+ // its area.
+ if (ImageToSave.Width <> AnimWidth) or (ImageToSave.Height <> AnimHeight) then
+ begin
+ InitImage(Screen);
+ NewImage(AnimWidth, AnimHeight, ImageToSave.Format, Screen);
+ CopyRect(ImageToSave, 0, 0, ImageToSave.Width, ImageToSave.Height, Screen, 0, 0);
+ if MustBeFreed then
+ FreeImage(ImageToSave);
+ ImageToSave := Screen;
+ end;
+ end
+ else if ImageToSave.Format <> DefaultFormat then
+ begin
+ if MustBeFreed then
+ ConvertImage(ImageToSave, DefaultFormat)
+ else
+ begin
+ CloneImage(Images[I], ImageToSave);
+ ConvertImage(ImageToSave, DefaultFormat);
+ MustBeFreed := True;
+ end;
+ end;
+ end;
+
+ // Add image as PNG frame
+ AddFrame(ImageToSave, False);
+ finally
+ if MustBeFreed then
+ FreeImage(ImageToSave);
+ end
+ else
+ Exit;
+ end;
+
+ // Finally save PNG file
+ SaveFile(Handle);
+ Result := True;
+ finally
+ NGFileSaver.Free;
+ end;
+end;
+
+{$IFNDEF DONT_LINK_MNG}
+
+{ TMNGFileFormat class implementation }
+
+constructor TMNGFileFormat.Create;
+begin
+ inherited Create;
+ FName := SMNGFormatName;
+ FIsMultiImageFormat := True;
+ AddMasks(SMNGMasks);
+
+ FSignature := MNGSignature;
+
+ RegisterOption(ImagingMNGLossyCompression, @FLossyCompression);
+ RegisterOption(ImagingMNGLossyAlpha, @FLossyAlpha);
+ RegisterOption(ImagingMNGPreFilter, @FPreFilter);
+ RegisterOption(ImagingMNGCompressLevel, @FCompressLevel);
+ RegisterOption(ImagingMNGQuality, @FQuality);
+ RegisterOption(ImagingMNGProgressive, @FProgressive);
+end;
+
+function TMNGFileFormat.LoadData(Handle: TImagingHandle;
+ var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
+var
+ NGFileLoader: TNGFileLoader;
+ I, Len: LongInt;
+begin
+ Result := False;
+ NGFileLoader := TNGFileLoader.Create;
+ try
+ // Use NG file parser to load file
+ if NGFileLoader.LoadFile(Handle) then
+ begin
+ Len := Length(NGFileLoader.Frames);
+ if Len > 0 then
+ begin
+ SetLength(Images, Len);
+ for I := 0 to Len - 1 do
+ with NGFileLoader.Frames[I] do
+ begin
+ // Build actual image bits
+ if IsJpegFrame then
+ NGFileLoader.LoadImageFromJNGFrame(FrameWidth, FrameHeight, JHDR, IDATMemory, JDATMemory, JDAAMemory, Images[I])
+ else
+ NGFileLoader.LoadImageFromPNGFrame(FrameWidth, FrameHeight, IHDR, IDATMemory, Images[I]);
+ // Build palette, aply color key or background
+ NGFileLoader.ApplyFrameSettings(NGFileLoader.Frames[I], Images[I]);
+ end;
+ end
+ else
+ begin
+ // Some MNG files (with BASI-IEND streams) dont have actual pixel data
+ SetLength(Images, 1);
+ NewImage(NGFileLoader.MHDR.FrameWidth, NGFileLoader.MHDR.FrameWidth, ifDefault, Images[0]);
+ end;
+ Result := True;
+ end;
+ finally
+ NGFileLoader.Free;
+ end;
+end;
+
+function TMNGFileFormat.SaveData(Handle: TImagingHandle;
+ const Images: TDynImageDataArray; Index: LongInt): Boolean;
+var
+ NGFileSaver: TNGFileSaver;
+ I, LargestWidth, LargestHeight: LongInt;
+ ImageToSave: TImageData;
+ MustBeFreed: Boolean;
+begin
+ Result := False;
+ LargestWidth := 0;
+ LargestHeight := 0;
+
+ NGFileSaver := TNGFileSaver.Create;
+ NGFileSaver.FileType := ngMNG;
+ NGFileSaver.SetFileOptions(Self);
+
+ with NGFileSaver do
+ try
+ // Store all frames to be saved frames file saver
+ for I := FFirstIdx to FLastIdx do
+ begin
+ if MakeCompatible(Images[I], ImageToSave, MustBeFreed) then
+ try
+ // Add image as PNG or JNG frame
+ AddFrame(ImageToSave, FLossyCompression);
+ // Remember largest frame width and height
+ LargestWidth := Iff(LargestWidth < ImageToSave.Width, ImageToSave.Width, LargestWidth);
+ LargestHeight := Iff(LargestHeight < ImageToSave.Height, ImageToSave.Height, LargestHeight);
+ finally
+ if MustBeFreed then
+ FreeImage(ImageToSave);
+ end
+ else
+ Exit;
+ end;
+
+ // Fill MNG header
+ MHDR.FrameWidth := LargestWidth;
+ MHDR.FrameHeight := LargestHeight;
+ MHDR.TicksPerSecond := 0;
+ MHDR.NominalLayerCount := 0;
+ MHDR.NominalFrameCount := Length(Frames);
+ MHDR.NominalPlayTime := 0;
+ MHDR.SimplicityProfile := 473; // 111011001 binary, defines MNG-VLC with transparency and JNG support
+
+ // Finally save MNG file
+ SaveFile(Handle);
+ Result := True;
+ finally
+ NGFileSaver.Free;
+ end;
+end;
+
+{$ENDIF}
+
+{$IFNDEF DONT_LINK_JNG}
+
+{ TJNGFileFormat class implementation }
+
+constructor TJNGFileFormat.Create;
+begin
+ inherited Create;
+ FName := SJNGFormatName;
+ AddMasks(SJNGMasks);
+
+ FSignature := JNGSignature;
+ FLossyCompression := True;
+
+ RegisterOption(ImagingJNGLossyAlpha, @FLossyAlpha);
+ RegisterOption(ImagingJNGAlphaPreFilter, @FPreFilter);
+ RegisterOption(ImagingJNGAlphaCompressLevel, @FCompressLevel);
+ RegisterOption(ImagingJNGQuality, @FQuality);
+ RegisterOption(ImagingJNGProgressive, @FProgressive);
+end;
+
+function TJNGFileFormat.LoadData(Handle: TImagingHandle;
+ var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
+var
+ NGFileLoader: TNGFileLoader;
+begin
+ Result := False;
+ NGFileLoader := TNGFileLoader.Create;
+ try
+ // Use NG file parser to load file
+ if NGFileLoader.LoadFile(Handle) and (Length(NGFileLoader.Frames) > 0) then
+ with NGFileLoader.Frames[0] do
+ begin
+ SetLength(Images, 1);
+ // Build actual image bits
+ if IsJpegFrame then
+ NGFileLoader.LoadImageFromJNGFrame(FrameWidth, FrameHeight, JHDR, IDATMemory, JDATMemory, JDAAMemory, Images[0]);
+ // Build palette, aply color key or background
+ NGFileLoader.ApplyFrameSettings(NGFileLoader.Frames[0], Images[0]);
+ Result := True;
+ end;
+ finally
+ NGFileLoader.Free;
+ end;
+end;
+
+function TJNGFileFormat.SaveData(Handle: TImagingHandle;
+ const Images: TDynImageDataArray; Index: LongInt): Boolean;
+var
+ NGFileSaver: TNGFileSaver;
+ ImageToSave: TImageData;
+ MustBeFreed: Boolean;
+begin
+ // Make image JNG compatible, store it in saver, and save it to file
+ Result := MakeCompatible(Images[Index], ImageToSave, MustBeFreed);
+ if Result then
+ begin
+ NGFileSaver := TNGFileSaver.Create;
+ with NGFileSaver do
+ try
+ FileType := ngJNG;
+ SetFileOptions(Self);
+ AddFrame(ImageToSave, True);
+ SaveFile(Handle);
+ finally
+ // Free NG saver and compatible image
+ NGFileSaver.Free;
+ if MustBeFreed then
+ FreeImage(ImageToSave);
+ end;
+ end;
+end;
+
+{$ENDIF}
+
+initialization
+ RegisterImageFileFormat(TPNGFileFormat);
+{$IFNDEF DONT_LINK_MNG}
+ RegisterImageFileFormat(TMNGFileFormat);
+{$ENDIF}
+{$IFNDEF DONT_LINK_JNG}
+ RegisterImageFileFormat(TJNGFileFormat);
+{$ENDIF}
+finalization
+
+{
+ File Notes:
+
+ -- TODOS ----------------------------------------------------
+ - nothing now
+
+ -- 0.26.3 Changes/Bug Fixes ---------------------------------
+ - Added APNG saving support.
+ - Added APNG support to NG loader and animating to PNG loader.
+
+ -- 0.26.1 Changes/Bug Fixes ---------------------------------
+ - Changed file format conditional compilation to reflect changes
+ in LINK symbols.
+
+ -- 0.24.3 Changes/Bug Fixes ---------------------------------
+ - Changes for better thread safety.
+
+ -- 0.23 Changes/Bug Fixes -----------------------------------
+ - Added loading of global palettes and transparencies in MNG files
+ (and by doing so fixed crash when loading images with global PLTE or tRNS).
+
+ -- 0.21 Changes/Bug Fixes -----------------------------------
+ - Small changes in converting to supported formats.
+ - MakeCompatible method moved to base class, put ConvertToSupported here.
+ GetSupportedFormats removed, it is now set in constructor.
+ - Made public properties for options registered to SetOption/GetOption
+ functions.
+ - Changed extensions to filename masks.
+ - Changed SaveData, LoadData, and MakeCompatible methods according
+ to changes in base class in Imaging unit.
+
+ -- 0.17 Changes/Bug Fixes -----------------------------------
+ - MNG and JNG support added, PNG support redesigned to support NG file handlers
+ - added classes for working with NG file formats
+ - stuff from old ImagingPng unit added and that unit was deleted
+ - unit created and initial stuff added
+
+ -- 0.15 Changes/Bug Fixes -----------------------------------
+ - when saving indexed images save alpha to tRNS?
+ - added some defines and ifdefs to dzlib unit to allow choosing
+ impaszlib, fpc's paszlib, zlibex or other zlib implementation
+ - added colorkeying support
+ - fixed 16bit channel image handling - pixels were not swapped
+ - fixed arithmetic overflow (in paeth filter) in FPC
+ - data of unknown chunks are skipped and not needlesly loaded
+
+ -- 0.13 Changes/Bug Fixes -----------------------------------
+ - adaptive filtering added to PNG saving
+ - TPNGFileFormat class added
+}
+
+end.
diff --git a/Imaging/ImagingPortableMaps.pas b/Imaging/ImagingPortableMaps.pas
index a0ac809..570261c 100644
--- a/Imaging/ImagingPortableMaps.pas
+++ b/Imaging/ImagingPortableMaps.pas
@@ -1,1020 +1,1020 @@
-{
- $Id: ImagingPortableMaps.pas 163 2009-07-28 21:44:10Z galfar $
- Vampyre Imaging Library
- by Marek Mauder
- http://imaginglib.sourceforge.net
-
- The contents of this file are used with permission, subject to the Mozilla
- Public License Version 1.1 (the "License"); you may not use this file except
- in compliance with the License. You may obtain a copy of the License at
- http://www.mozilla.org/MPL/MPL-1.1.html
-
- Software distributed under the License is distributed on an "AS IS" basis,
- WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
- the specific language governing rights and limitations under the License.
-
- Alternatively, the contents of this file may be used under the terms of the
- GNU Lesser General Public License (the "LGPL License"), in which case the
- provisions of the LGPL License are applicable instead of those above.
- If you wish to allow use of your version of this file only under the terms
- of the LGPL License and not to allow others to use your version of this file
- under the MPL, indicate your decision by deleting the provisions above and
- replace them with the notice and other provisions required by the LGPL
- License. If you do not delete the provisions above, a recipient may use
- your version of this file under either the MPL or the LGPL License.
-
- For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
-}
-
-{ This unit contains loader/saver for Portable Maps file format family (or PNM).
- That includes PBM, PGM, PPM, PAM, and PFM formats.}
-unit ImagingPortableMaps;
-
-{$I ImagingOptions.inc}
-
-interface
-
-uses
- SysUtils, ImagingTypes, Imaging, ImagingFormats, ImagingUtility;
-
-type
- { Types of pixels of PNM images.}
- TTupleType = (ttInvalid, ttBlackAndWhite, ttGrayScale, ttRGB, ttBlackAndWhiteAlpha,
- ttGrayScaleAlpha, ttRGBAlpha, ttGrayScaleFP, ttRGBFP);
-
- { Record with info about PNM image used in both loading and saving functions.}
- TPortableMapInfo = record
- Width: LongInt;
- Height: LongInt;
- FormatId: AnsiChar;
- MaxVal: LongInt;
- BitCount: LongInt;
- Depth: LongInt;
- TupleType: TTupleType;
- Binary: Boolean;
- HasPAMHeader: Boolean;
- IsBigEndian: Boolean;
- end;
-
- { Base class for Portable Map file formats (or Portable AnyMaps or PNM).
- There are several types of PNM file formats that share common
- (simple) structure. This class can actually load all supported PNM formats.
- Saving is also done by this class but descendants (each for different PNM
- format) control it.}
- TPortableMapFileFormat = class(TImageFileFormat)
- protected
- FIdNumbers: TChar2;
- FSaveBinary: LongBool;
- function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
- OnlyFirstLevel: Boolean): Boolean; override;
- function SaveDataInternal(Handle: TImagingHandle; const Images: TDynImageDataArray;
- Index: LongInt; var MapInfo: TPortableMapInfo): Boolean;
- public
- constructor Create; override;
- function TestFormat(Handle: TImagingHandle): Boolean; override;
- published
- { If set to True images will be saved in binary format. If it is False
- they will be saved in text format (which could result in 5-10x bigger file).
- Default is value True. Note that PAM and PFM files are always saved in binary.}
- property SaveBinary: LongBool read FSaveBinary write FSaveBinary;
- end;
-
- { Portable Bit Map is used to store monochrome 1bit images. Raster data
- can be saved as text or binary data. Either way value of 0 represents white
- and 1 is black. As Imaging does not have support for 1bit data formats
- PBM images can be loaded but not saved. Loaded images are returned in
- ifGray8 format (witch pixel values scaled from 1bit to 8bit).}
- TPBMFileFormat = class(TPortableMapFileFormat)
- public
- constructor Create; override;
- end;
-
- { Portable Gray Map is used to store grayscale 8bit or 16bit images.
- Raster data can be saved as text or binary data.}
- TPGMFileFormat = class(TPortableMapFileFormat)
- protected
- function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
- Index: LongInt): Boolean; override;
- procedure ConvertToSupported(var Image: TImageData;
- const Info: TImageFormatInfo); override;
- public
- constructor Create; override;
- end;
-
- { Portable Pixel Map is used to store RGB images with 8bit or 16bit channels.
- Raster data can be saved as text or binary data.}
- TPPMFileFormat = class(TPortableMapFileFormat)
- protected
- function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
- Index: LongInt): Boolean; override;
- procedure ConvertToSupported(var Image: TImageData;
- const Info: TImageFormatInfo); override;
- public
- constructor Create; override;
- end;
-
- { Portable Arbitrary Map is format that can store image data formats
- of PBM, PGM, and PPM formats with optional alpha channel. Raster data
- can be stored only in binary format. All data formats supported
- by this format are ifGray8, ifGray16, ifA8Gray8, ifA16Gray16,
- ifR8G8B8, ifR16G16R16, ifA8R8G8B8, and ifA16R16G16B16.}
- TPAMFileFormat = class(TPortableMapFileFormat)
- protected
- function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
- Index: LongInt): Boolean; override;
- procedure ConvertToSupported(var Image: TImageData;
- const Info: TImageFormatInfo); override;
- public
- constructor Create; override;
- end;
-
- { Portable Float Map is unofficial extension of PNM format family which
- can store images with floating point pixels. Raster data is saved in
- binary format as array of IEEE 32 bit floating point numbers. One channel
- or RGB images are supported by PFM format (so no alpha).}
- TPFMFileFormat = class(TPortableMapFileFormat)
- protected
- function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
- Index: LongInt): Boolean; override;
- procedure ConvertToSupported(var Image: TImageData;
- const Info: TImageFormatInfo); override;
- public
- constructor Create; override;
- end;
-
-implementation
-
-const
- PortableMapDefaultBinary = True;
-
- SPBMFormatName = 'Portable Bit Map';
- SPBMMasks = '*.pbm';
- SPGMFormatName = 'Portable Gray Map';
- SPGMMasks = '*.pgm';
- PGMSupportedFormats = [ifGray8, ifGray16];
- SPPMFormatName = 'Portable Pixel Map';
- SPPMMasks = '*.ppm';
- PPMSupportedFormats = [ifR8G8B8, ifR16G16B16];
- SPAMFormatName = 'Portable Arbitrary Map';
- SPAMMasks = '*.pam';
- PAMSupportedFormats = [ifGray8, ifGray16, ifA8Gray8, ifA16Gray16,
- ifR8G8B8, ifR16G16B16, ifA8R8G8B8, ifA16R16G16B16];
- SPFMFormatName = 'Portable Float Map';
- SPFMMasks = '*.pfm';
- PFMSupportedFormats = [ifR32F, ifA32B32G32R32F];
-
-const
- { TAB, CR, LF, and Space are used as seperators in Portable map headers and data.}
- WhiteSpaces = [#9, #10, #13, #32];
- SPAMWidth = 'WIDTH';
- SPAMHeight = 'HEIGHT';
- SPAMDepth = 'DEPTH';
- SPAMMaxVal = 'MAXVAL';
- SPAMTupleType = 'TUPLTYPE';
- SPAMEndHdr = 'ENDHDR';
-
- { Size of buffer used to speed up text PNM loading/saving.}
- LineBufferCapacity = 16 * 1024;
-
- TupleTypeNames: array[TTupleType] of string = (
- 'INVALID', 'BLACKANDWHITE', 'GRAYSCALE', 'RGB',
- 'BLACKANDWHITE_ALPHA', 'GRAYSCALE_ALPHA', 'RGB_ALPHA', 'GRAYSCALEFP',
- 'RGBFP');
-
-{ TPortableMapFileFormat }
-
-constructor TPortableMapFileFormat.Create;
-begin
- inherited Create;
- FCanLoad := True;
- FCanSave := True;
- FIsMultiImageFormat := False;
- FSaveBinary := PortableMapDefaultBinary;
-end;
-
-function TPortableMapFileFormat.LoadData(Handle: TImagingHandle;
- var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
-var
- I, ScanLineSize, MonoSize: LongInt;
- Dest: PByte;
- MonoData: Pointer;
- Info: TImageFormatInfo;
- PixelFP: TColorFPRec;
- LineBuffer: array[0..LineBufferCapacity - 1] of AnsiChar;
- LineEnd, LinePos: LongInt;
- MapInfo: TPortableMapInfo;
- LineBreak: string;
-
- procedure CheckBuffer;
- begin
- if (LineEnd = 0) or (LinePos = LineEnd) then
- begin
- // Reload buffer if its is empty or its end was reached
- LineEnd := GetIO.Read(Handle, @LineBuffer[0], LineBufferCapacity);
- LinePos := 0;
- end;
- end;
-
- procedure FixInputPos;
- begin
- // Sets input's position to its real pos as it would be without buffering
- if LineEnd > 0 then
- begin
- GetIO.Seek(Handle, -LineEnd + LinePos, smFromCurrent);
- LineEnd := 0;
- end;
- end;
-
- function ReadString: string;
- var
- S: AnsiString;
- C: AnsiChar;
- begin
- // First skip all whitespace chars
- SetLength(S, 1);
- repeat
- CheckBuffer;
- S[1] := LineBuffer[LinePos];
- Inc(LinePos);
- if S[1] = '#' then
- repeat
- // Comment detected, skip everything until next line is reached
- CheckBuffer;
- S[1] := LineBuffer[LinePos];
- Inc(LinePos);
- until S[1] = #10;
- until not(S[1] in WhiteSpaces);
- // Now we have reached some chars other than white space, read them until
- // there is whitespace again
- repeat
- SetLength(S, Length(S) + 1);
- CheckBuffer;
- S[Length(S)] := LineBuffer[LinePos];
- Inc(LinePos);
- // Repeat until current char is whitespace or end of file is reached
- // (Line buffer has 0 bytes which happens only on EOF)
- until (S[Length(S)] in WhiteSpaces) or (LineEnd = 0);
- // Get rid of last char - whitespace or null
- SetLength(S, Length(S) - 1);
- // Move position to the beginning of next string (skip white space - needed
- // to make the loader stop at the right input position)
- repeat
- CheckBuffer;
- C := LineBuffer[LinePos];
- Inc(LinePos);
- until not (C in WhiteSpaces) or (LineEnd = 0);
- // Dec pos, current is the begining of the the string
- Dec(LinePos);
-
- Result := string(S);
- end;
-
- function ReadIntValue: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
- begin
- Result := StrToInt(ReadString);
- end;
-
- procedure FindLineBreak;
- var
- C: AnsiChar;
- begin
- LineBreak := #10;
- repeat
- CheckBuffer;
- C := LineBuffer[LinePos];
- Inc(LinePos);
-
- if C = #13 then
- LineBreak := #13#10;
-
- until C = #10;
- end;
-
- function ParseHeader: Boolean;
- var
- Id: TChar2;
- I: TTupleType;
- TupleTypeName: string;
- Scale: Single;
- OldSeparator: Char;
- begin
- Result := False;
- with GetIO do
- begin
- FillChar(MapInfo, SizeOf(MapInfo), 0);
- Read(Handle, @Id, SizeOf(Id));
- FindLineBreak;
-
- if Id[1] in ['1'..'6'] then
- begin
- // Read header for PBM, PGM, and PPM files
- MapInfo.Width := ReadIntValue;
- MapInfo.Height := ReadIntValue;
-
- if Id[1] in ['1', '4'] then
- begin
- MapInfo.MaxVal := 1;
- MapInfo.BitCount := 1
- end
- else
- begin
- // Read channel max value, <=255 for 8bit images, >255 for 16bit images
- // but some programs think its max colors so put <=256 here
- MapInfo.MaxVal := ReadIntValue;
- MapInfo.BitCount := Iff(MapInfo.MaxVal <= 256, 8, 16);
- end;
-
- MapInfo.Depth := 1;
- case Id[1] of
- '1', '4': MapInfo.TupleType := ttBlackAndWhite;
- '2', '5': MapInfo.TupleType := ttGrayScale;
- '3', '6':
- begin
- MapInfo.TupleType := ttRGB;
- MapInfo.Depth := 3;
- end;
- end;
- end
- else if Id[1] = '7' then
- begin
- // Read values from PAM header
- // WIDTH
- if (ReadString <> SPAMWidth) then Exit;
- MapInfo.Width := ReadIntValue;
- // HEIGHT
- if (ReadString <> SPAMheight) then Exit;
- MapInfo.Height := ReadIntValue;
- // DEPTH
- if (ReadString <> SPAMDepth) then Exit;
- MapInfo.Depth := ReadIntValue;
- // MAXVAL
- if (ReadString <> SPAMMaxVal) then Exit;
- MapInfo.MaxVal := ReadIntValue;
- MapInfo.BitCount := Iff(MapInfo.MaxVal <= 256, 8, 16);
- // TUPLETYPE
- if (ReadString <> SPAMTupleType) then Exit;
- TupleTypeName := ReadString;
- for I := Low(TTupleType) to High(TTupleType) do
- if SameText(TupleTypeName, TupleTypeNames[I]) then
- begin
- MapInfo.TupleType := I;
- Break;
- end;
- // ENDHDR
- if (ReadString <> SPAMEndHdr) then Exit;
- end
- else if Id[1] in ['F', 'f'] then
- begin
- // Read header of PFM file
- MapInfo.Width := ReadIntValue;
- MapInfo.Height := ReadIntValue;
- OldSeparator := DecimalSeparator;
- DecimalSeparator := '.';
- Scale := StrToFloatDef(ReadString, 0);
- DecimalSeparator := OldSeparator;
- MapInfo.IsBigEndian := Scale > 0.0;
- if Id[1] = 'F' then
- MapInfo.TupleType := ttRGBFP
- else
- MapInfo.TupleType := ttGrayScaleFP;
- MapInfo.Depth := Iff(MapInfo.TupleType = ttRGBFP, 3, 1);
- MapInfo.BitCount := Iff(MapInfo.TupleType = ttRGBFP, 96, 32);
- end;
-
- FixInputPos;
- MapInfo.Binary := (Id[1] in ['4', '5', '6', '7', 'F', 'f']);
-
- if MapInfo.Binary and not (Id[1] in ['F', 'f']) then
- begin
- // Mimic the behaviour of Photoshop and other editors/viewers:
- // If linenreaks in file are DOS CR/LF 16bit binary values are
- // little endian, Unix LF only linebreak indicates big endian.
- MapInfo.IsBigEndian := LineBreak = #10;
- end;
-
- // Check if values found in header are valid
- Result := (MapInfo.Width > 0) and (MapInfo.Height > 0) and
- (MapInfo.BitCount in [1, 8, 16, 32, 96]) and (MapInfo.TupleType <> ttInvalid);
- // Now check if image has proper number of channels (PAM)
- if Result then
- case MapInfo.TupleType of
- ttBlackAndWhite, ttGrayScale: Result := MapInfo.Depth = 1;
- ttBlackAndWhiteAlpha, ttGrayScaleAlpha: Result := MapInfo.Depth = 2;
- ttRGB: Result := MapInfo.Depth = 3;
- ttRGBAlpha: Result := MapInfo.Depth = 4;
- end;
- end;
- end;
-
-begin
- Result := False;
- LineEnd := 0;
- LinePos := 0;
- SetLength(Images, 1);
- with GetIO, Images[0] do
- begin
- Format := ifUnknown;
- // Try to parse file header
- if not ParseHeader then Exit;
- // Select appropriate data format based on values read from file header
- case MapInfo.TupleType of
- ttBlackAndWhite: Format := ifGray8;
- ttBlackAndWhiteAlpha: Format := ifA8Gray8;
- ttGrayScale: Format := IffFormat(MapInfo.BitCount = 8, ifGray8, ifGray16);
- ttGrayScaleAlpha: Format := IffFormat(MapInfo.BitCount = 8, ifA8Gray8, ifA16Gray16);
- ttRGB: Format := IffFormat(MapInfo.BitCount = 8, ifR8G8B8, ifR16G16B16);
- ttRGBAlpha: Format := IffFormat(MapInfo.BitCount = 8, ifA8R8G8B8, ifA16R16G16B16);
- ttGrayScaleFP: Format := ifR32F;
- ttRGBFP: Format := ifA32B32G32R32F;
- end;
- // Exit if no matching data format was found
- if Format = ifUnknown then Exit;
-
- NewImage(MapInfo.Width, MapInfo.Height, Format, Images[0]);
- Info := GetFormatInfo(Format);
-
- // Now read pixels from file to dest image
- if not MapInfo.Binary then
- begin
- Dest := Bits;
- for I := 0 to Width * Height - 1 do
- begin
- case Format of
- ifGray8:
- begin
- Dest^ := ReadIntValue;
- if MapInfo.BitCount = 1 then
- // If source is 1bit mono image (where 0=white, 1=black)
- // we must scale it to 8bits
- Dest^ := 255 - Dest^ * 255;
- end;
- ifGray16: PWord(Dest)^ := ReadIntValue;
- ifR8G8B8:
- with PColor24Rec(Dest)^ do
- begin
- R := ReadIntValue;
- G := ReadIntValue;
- B := ReadIntValue;
- end;
- ifR16G16B16:
- with PColor48Rec(Dest)^ do
- begin
- R := ReadIntValue;
- G := ReadIntValue;
- B := ReadIntValue;
- end;
- end;
- Inc(Dest, Info.BytesPerPixel);
- end;
- end
- else
- begin
- if MapInfo.BitCount > 1 then
- begin
- if not (MapInfo.TupleType in [ttGrayScaleFP, ttRGBFP]) then
- begin
- // Just copy bytes from binary Portable Maps (non 1bit, non FP)
- Read(Handle, Bits, Size);
- end
- else
- begin
- Dest := Bits;
- // FP images are in BGR order and endian swap maybe needed.
- // Some programs store scanlines in bottom-up order but
- // I will stick with Photoshops behaviour here
- for I := 0 to Width * Height - 1 do
- begin
- Read(Handle, @PixelFP, MapInfo.BitCount div 8);
- if MapInfo.TupleType = ttRGBFP then
- with PColorFPRec(Dest)^ do
- begin
- A := 1.0;
- R := PixelFP.R;
- G := PixelFP.G;
- B := PixelFP.B;
- if MapInfo.IsBigEndian then
- SwapEndianLongWord(PLongWord(Dest), 3);
- end
- else
- begin
- PSingle(Dest)^ := PixelFP.B;
- if MapInfo.IsBigEndian then
- SwapEndianLongWord(PLongWord(Dest), 1);
- end;
- Inc(Dest, Info.BytesPerPixel);
- end;
- end;
-
- if MapInfo.TupleType in [ttBlackAndWhite, ttBlackAndWhiteAlpha] then
- begin
- // Black and white PAM files must be scaled to 8bits. Note that
- // in PAM files 1=white, 0=black (reverse of PBM)
- for I := 0 to Width * Height * Iff(MapInfo.TupleType = ttBlackAndWhiteAlpha, 2, 1) - 1 do
- PByteArray(Bits)[I] := PByteArray(Bits)[I] * 255;
- end
- else if MapInfo.TupleType in [ttRGB, ttRGBAlpha] then
- begin
- // Swap channels of RGB/ARGB images. Binary RGB image files use BGR order.
- SwapChannels(Images[0], ChannelBlue, ChannelRed);
- end;
-
- // Swap byte order if needed
- if (MapInfo.BitCount = 16) and MapInfo.IsBigEndian then
- SwapEndianWord(Bits, Width * Height * Info.BytesPerPixel div SizeOf(Word));
- end
- else
- begin
- // Handle binary PBM files (ttBlackAndWhite 1bit)
- ScanLineSize := (Width + 7) div 8;
- // Get total binary data size, read it from file to temp
- // buffer and convert the data to Gray8
- MonoSize := ScanLineSize * Height;
- GetMem(MonoData, MonoSize);
- try
- Read(Handle, MonoData, MonoSize);
- Convert1To8(MonoData, Bits, Width, Height, ScanLineSize);
- // 1bit mono images must be scaled to 8bit (where 0=white, 1=black)
- for I := 0 to Width * Height - 1 do
- PByteArray(Bits)[I] := 255 - PByteArray(Bits)[I] * 255;
- finally
- FreeMem(MonoData);
- end;
- end;
- end;
-
- FixInputPos;
-
- if (MapInfo.MaxVal <> Pow2Int(MapInfo.BitCount) - 1) and
- (MapInfo.TupleType in [ttGrayScale, ttGrayScaleAlpha, ttRGB, ttRGBAlpha]) then
- begin
- Dest := Bits;
- // Scale color values according to MaxVal we got from header
- // if necessary.
- for I := 0 to Width * Height * Info.BytesPerPixel div (MapInfo.BitCount shr 3) - 1 do
- begin
- if MapInfo.BitCount = 8 then
- Dest^ := Dest^ * 255 div MapInfo.MaxVal
- else
- PWord(Dest)^ := PWord(Dest)^ * 65535 div MapInfo.MaxVal;
- Inc(Dest, MapInfo.BitCount shr 3);
- end;
- end;
-
- Result := True;
- end;
-end;
-
-function TPortableMapFileFormat.SaveDataInternal(Handle: TImagingHandle;
- const Images: TDynImageDataArray; Index: Integer; var MapInfo: TPortableMapInfo): Boolean;
-const
- // Use Unix linebreak, for many viewers/editors it means that
- // 16bit samples are stored as big endian - so we need to swap byte order
- // before saving
- LineDelimiter = #10;
- PixelDelimiter = #32;
-var
- ImageToSave: TImageData;
- MustBeFreed: Boolean;
- Info: TImageFormatInfo;
- I, LineLength: LongInt;
- Src: PByte;
- Pixel32: TColor32Rec;
- Pixel64: TColor64Rec;
- W: Word;
-
- procedure WriteString(S: string; Delimiter: Char = LineDelimiter);
- begin
- SetLength(S, Length(S) + 1);
- S[Length(S)] := Delimiter;
- {$IF Defined(DCC) and Defined(UNICODE)}
- GetIO.Write(Handle, @AnsiString(S)[1], Length(S));
- {$ELSE}
- GetIO.Write(Handle, @S[1], Length(S));
- {$IFEND}
- Inc(LineLength, Length(S));
- end;
-
- procedure WriteHeader;
- var
- OldSeparator: Char;
- begin
- WriteString('P' + MapInfo.FormatId);
- if not MapInfo.HasPAMHeader then
- begin
- // Write header of PGM, PPM, and PFM files
- WriteString(IntToStr(ImageToSave.Width));
- WriteString(IntToStr(ImageToSave.Height));
- case MapInfo.TupleType of
- ttGrayScale, ttRGB: WriteString(IntToStr(Pow2Int(MapInfo.BitCount) - 1));
- ttGrayScaleFP, ttRGBFP:
- begin
- OldSeparator := DecimalSeparator;
- DecimalSeparator := '.';
- // Negative value indicates that raster data is saved in little endian
- WriteString(FloatToStr(-1.0));
- DecimalSeparator := OldSeparator;
- end;
- end;
- end
- else
- begin
- // Write PAM file header
- WriteString(Format('%s %d', [SPAMWidth, ImageToSave.Width]));
- WriteString(Format('%s %d', [SPAMHeight, ImageToSave.Height]));
- WriteString(Format('%s %d', [SPAMDepth, MapInfo.Depth]));
- WriteString(Format('%s %d', [SPAMMaxVal, Pow2Int(MapInfo.BitCount) - 1]));
- WriteString(Format('%s %s', [SPAMTupleType, TupleTypeNames[MapInfo.TupleType]]));
- WriteString(SPAMEndHdr);
- end;
- end;
-
-begin
- Result := False;
- if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then
- with GetIO, ImageToSave do
- try
- Info := GetFormatInfo(Format);
- // Fill values of MapInfo record that were not filled by
- // descendants in their SaveData methods
- MapInfo.BitCount := (Info.BytesPerPixel div Info.ChannelCount) * 8;
- MapInfo.Depth := Info.ChannelCount;
- if MapInfo.TupleType = ttInvalid then
- begin
- if Info.HasGrayChannel then
- begin
- if Info.HasAlphaChannel then
- MapInfo.TupleType := ttGrayScaleAlpha
- else
- MapInfo.TupleType := ttGrayScale;
- end
- else
- begin
- if Info.HasAlphaChannel then
- MapInfo.TupleType := ttRGBAlpha
- else
- MapInfo.TupleType := ttRGB;
- end;
- end;
- // Write file header
- WriteHeader;
-
- if not MapInfo.Binary then
- begin
- Src := Bits;
- LineLength := 0;
- // For each pixel find its text representation and write it to file
- for I := 0 to Width * Height - 1 do
- begin
- case Format of
- ifGray8: WriteString(IntToStr(Src^), PixelDelimiter);
- ifGray16: WriteString(IntToStr(PWord(Src)^), PixelDelimiter);
- ifR8G8B8:
- with PColor24Rec(Src)^ do
- WriteString(SysUtils.Format('%d %d %d', [R, G, B]), PixelDelimiter);
- ifR16G16B16:
- with PColor48Rec(Src)^ do
- WriteString(SysUtils.Format('%d %d %d', [R, G, B]), PixelDelimiter);
- end;
- // Lines in text PNM images should have length <70
- if LineLength > 65 then
- begin
- LineLength := 0;
- WriteString('', LineDelimiter);
- end;
- Inc(Src, Info.BytesPerPixel);
- end;
- end
- else
- begin
- // Write binary images
- if not (MapInfo.TupleType in [ttGrayScaleFP, ttRGBFP]) then
- begin
- // Save integer binary images
- if MapInfo.BitCount = 8 then
- begin
- if MapInfo.TupleType in [ttGrayScale, ttGrayScaleAlpha] then
- begin
- // 8bit grayscale images can be written in one Write call
- Write(Handle, Bits, Size);
- end
- else
- begin
- // 8bit RGB/ARGB images: read and blue must be swapped and
- // 3 or 4 bytes must be written
- Src := Bits;
- for I := 0 to Width * Height - 1 do
- with PColor32Rec(Src)^ do
- begin
- if MapInfo.TupleType = ttRGBAlpha then
- Pixel32.A := A;
- Pixel32.R := B;
- Pixel32.G := G;
- Pixel32.B := R;
- Write(Handle, @Pixel32, Info.BytesPerPixel);
- Inc(Src, Info.BytesPerPixel);
- end;
- end;
- end
- else
- begin
- // Images with 16bit channels: make sure that channel values are saved in big endian
- Src := Bits;
- if MapInfo.TupleType in [ttGrayScale, ttGrayScaleAlpha] then
- begin
- // 16bit grayscale image
- for I := 0 to Width * Height * Info.BytesPerPixel div SizeOf(Word) - 1 do
- begin
- W := SwapEndianWord(PWord(Src)^);
- Write(Handle, @W, SizeOf(Word));
- Inc(Src, SizeOf(Word));
- end;
- end
- else
- begin
- // RGB images with 16bit channels: swap RB and endian too
- for I := 0 to Width * Height - 1 do
- with PColor64Rec(Src)^ do
- begin
- if MapInfo.TupleType = ttRGBAlpha then
- Pixel64.A := SwapEndianWord(A);
- Pixel64.R := SwapEndianWord(B);
- Pixel64.G := SwapEndianWord(G);
- Pixel64.B := SwapEndianWord(R);
- Write(Handle, @Pixel64, Info.BytesPerPixel);
- Inc(Src, Info.BytesPerPixel);
- end;
- end;
- end;
- end
- else
- begin
- // Floating point images (no need to swap endian here - little
- // endian is specified in file header)
- if MapInfo.TupleType = ttGrayScaleFP then
- begin
- // Grayscale images can be written in one Write call
- Write(Handle, Bits, Size);
- end
- else
- begin
- // Expected data format of PFM RGB file is B32G32R32F which is not
- // supported by Imaging. We must write pixels one by one and
- // write only RGB part of A32B32G32B32 image.
- Src := Bits;
- for I := 0 to Width * Height - 1 do
- begin
- Write(Handle, Src, SizeOf(Single) * 3);
- Inc(Src, Info.BytesPerPixel);
- end;
- end;
- end;
- end;
- Result := True;
- finally
- if MustBeFreed then
- FreeImage(ImageToSave);
- end;
-end;
-
-function TPortableMapFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
-var
- Id: TChar4;
- ReadCount: LongInt;
-begin
- Result := False;
- if Handle <> nil then
- with GetIO do
- begin
- ReadCount := Read(Handle, @Id, SizeOf(Id));
- Seek(Handle, -ReadCount, smFromCurrent);
- Result := (Id[0] = 'P') and (Id[1] in [FIdNumbers[0], FIdNumbers[1]]) and
- (Id[2] in WhiteSpaces);
- end;
-end;
-
-{ TPBMFileFormat }
-
-constructor TPBMFileFormat.Create;
-begin
- inherited Create;
- FName := SPBMFormatName;
- FCanSave := False;
- AddMasks(SPBMMasks);
- FIdNumbers := '14';
-end;
-
-{ TPGMFileFormat }
-
-constructor TPGMFileFormat.Create;
-begin
- inherited Create;
- FName := SPGMFormatName;
- FSupportedFormats := PGMSupportedFormats;
- AddMasks(SPGMMasks);
- RegisterOption(ImagingPGMSaveBinary, @FSaveBinary);
- FIdNumbers := '25';
-end;
-
-function TPGMFileFormat.SaveData(Handle: TImagingHandle;
- const Images: TDynImageDataArray; Index: Integer): Boolean;
-var
- MapInfo: TPortableMapInfo;
-begin
- FillChar(MapInfo, SizeOf(MapInfo), 0);
- if FSaveBinary then
- MapInfo.FormatId := FIdNumbers[1]
- else
- MapInfo.FormatId := FIdNumbers[0];
- MapInfo.Binary := FSaveBinary;
- Result := SaveDataInternal(Handle, Images, Index, MapInfo);
-end;
-
-procedure TPGMFileFormat.ConvertToSupported(var Image: TImageData;
- const Info: TImageFormatInfo);
-var
- ConvFormat: TImageFormat;
-begin
- if Info.IsFloatingPoint then
- // All FP images go to 16bit
- ConvFormat := ifGray16
- else if Info.HasGrayChannel then
- // Grayscale will be 8 or 16 bit - depends on input's bitcount
- ConvFormat := IffFormat(Info.BytesPerPixel div Info.ChannelCount > 1,
- ifGray16, ifGray8)
- else if Info.BytesPerPixel > 4 then
- // Large bitcounts -> 16bit
- ConvFormat := ifGray16
- else
- // Rest of the formats -> 8bit
- ConvFormat := ifGray8;
-
- ConvertImage(Image, ConvFormat);
-end;
-
-{ TPPMFileFormat }
-
-constructor TPPMFileFormat.Create;
-begin
- inherited Create;
- FName := SPPMFormatName;
- FSupportedFormats := PPMSupportedFormats;
- AddMasks(SPPMMasks);
- RegisterOption(ImagingPPMSaveBinary, @FSaveBinary);
- FIdNumbers := '36';
-end;
-
-function TPPMFileFormat.SaveData(Handle: TImagingHandle;
- const Images: TDynImageDataArray; Index: Integer): Boolean;
-var
- MapInfo: TPortableMapInfo;
-begin
- FillChar(MapInfo, SizeOf(MapInfo), 0);
- if FSaveBinary then
- MapInfo.FormatId := FIdNumbers[1]
- else
- MapInfo.FormatId := FIdNumbers[0];
- MapInfo.Binary := FSaveBinary;
- Result := SaveDataInternal(Handle, Images, Index, MapInfo);
-end;
-
-procedure TPPMFileFormat.ConvertToSupported(var Image: TImageData;
- const Info: TImageFormatInfo);
-var
- ConvFormat: TImageFormat;
-begin
- if Info.IsFloatingPoint then
- // All FP images go to 48bit RGB
- ConvFormat := ifR16G16B16
- else if Info.HasGrayChannel then
- // Grayscale will be 24 or 48 bit RGB - depends on input's bitcount
- ConvFormat := IffFormat(Info.BytesPerPixel div Info.ChannelCount > 1,
- ifR16G16B16, ifR8G8B8)
- else if Info.BytesPerPixel > 4 then
- // Large bitcounts -> 48bit RGB
- ConvFormat := ifR16G16B16
- else
- // Rest of the formats -> 24bit RGB
- ConvFormat := ifR8G8B8;
-
- ConvertImage(Image, ConvFormat);
-end;
-
-{ TPAMFileFormat }
-
-constructor TPAMFileFormat.Create;
-begin
- inherited Create;
- FName := SPAMFormatName;
- FSupportedFormats := PAMSupportedFormats;
- AddMasks(SPAMMasks);
- FIdNumbers := '77';
-end;
-
-function TPAMFileFormat.SaveData(Handle: TImagingHandle;
- const Images: TDynImageDataArray; Index: Integer): Boolean;
-var
- MapInfo: TPortableMapInfo;
-begin
- FillChar(MapInfo, SizeOf(MapInfo), 0);
- MapInfo.FormatId := FIdNumbers[0];
- MapInfo.Binary := True;
- MapInfo.HasPAMHeader := True;
- Result := SaveDataInternal(Handle, Images, Index, MapInfo);
-end;
-
-procedure TPAMFileFormat.ConvertToSupported(var Image: TImageData;
- const Info: TImageFormatInfo);
-var
- ConvFormat: TImageFormat;
-begin
- if Info.IsFloatingPoint then
- ConvFormat := IffFormat(Info.HasAlphaChannel, ifA16R16G16B16, ifR16G16B16)
- else if Info.HasGrayChannel then
- ConvFormat := IffFormat(Info.HasAlphaChannel, ifA16Gray16, ifGray16)
- else
- begin
- if Info.BytesPerPixel <= 4 then
- ConvFormat := IffFormat(Info.HasAlphaChannel, ifA8R8G8B8, ifR8G8B8)
- else
- ConvFormat := IffFormat(Info.HasAlphaChannel, ifA16R16G16B16, ifR16G16B16);
- end;
- ConvertImage(Image, ConvFormat);
-end;
-
-{ TPFMFileFormat }
-
-constructor TPFMFileFormat.Create;
-begin
- inherited Create;
- FName := SPFMFormatName;
- AddMasks(SPFMMasks);
- FIdNumbers := 'Ff';
- FSupportedFormats := PFMSupportedFormats;
-end;
-
-function TPFMFileFormat.SaveData(Handle: TImagingHandle;
- const Images: TDynImageDataArray; Index: Integer): Boolean;
-var
- Info: TImageFormatInfo;
- MapInfo: TPortableMapInfo;
-begin
- FillChar(MapInfo, SizeOf(MapInfo), 0);
- Info := GetFormatInfo(Images[Index].Format);
-
- if (Info.ChannelCount > 1) or Info.IsIndexed then
- MapInfo.TupleType := ttRGBFP
- else
- MapInfo.TupleType := ttGrayScaleFP;
-
- if MapInfo.TupleType = ttGrayScaleFP then
- MapInfo.FormatId := FIdNumbers[1]
- else
- MapInfo.FormatId := FIdNumbers[0];
-
- MapInfo.Binary := True;
- Result := SaveDataInternal(Handle, Images, Index, MapInfo);
-end;
-
-procedure TPFMFileFormat.ConvertToSupported(var Image: TImageData;
- const Info: TImageFormatInfo);
-begin
- if (Info.ChannelCount > 1) or Info.IsIndexed then
- ConvertImage(Image, ifA32B32G32R32F)
- else
- ConvertImage(Image, ifR32F);
-end;
-
-initialization
- RegisterImageFileFormat(TPBMFileFormat);
- RegisterImageFileFormat(TPGMFileFormat);
- RegisterImageFileFormat(TPPMFileFormat);
- RegisterImageFileFormat(TPAMFileFormat);
- RegisterImageFileFormat(TPFMFileFormat);
-
-{
- File Notes:
-
- -- TODOS ----------------------------------------------------
- - nothing now
-
- -- 0.26.3 Changes/Bug Fixes -----------------------------------
- - Fixed D2009 Unicode related bug in PNM saving.
-
- -- 0.24.3 Changes/Bug Fixes -----------------------------------
- - Improved compatibility of 16bit/component image loading.
- - Changes for better thread safety.
-
- -- 0.21 Changes/Bug Fixes -----------------------------------
- - Made modifications to ASCII PNM loading to be more "stream-safe".
- - Fixed bug: indexed images saved as grayscale in PFM.
- - Changed converting to supported formats little bit.
- - Added scaling of channel values (non-FP and non-mono images) according
- to MaxVal.
- - Added buffering to loading of PNM files. More than 10x faster now
- for text files.
- - Added saving support to PGM, PPM, PAM, and PFM format.
- - Added PFM file format.
- - Initial version created.
-}
-
-end.
+{
+ $Id: ImagingPortableMaps.pas 163 2009-07-28 21:44:10Z galfar $
+ Vampyre Imaging Library
+ by Marek Mauder
+ http://imaginglib.sourceforge.net
+
+ The contents of this file are used with permission, subject to the Mozilla
+ Public License Version 1.1 (the "License"); you may not use this file except
+ in compliance with the License. You may obtain a copy of the License at
+ http://www.mozilla.org/MPL/MPL-1.1.html
+
+ Software distributed under the License is distributed on an "AS IS" basis,
+ WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
+ the specific language governing rights and limitations under the License.
+
+ Alternatively, the contents of this file may be used under the terms of the
+ GNU Lesser General Public License (the "LGPL License"), in which case the
+ provisions of the LGPL License are applicable instead of those above.
+ If you wish to allow use of your version of this file only under the terms
+ of the LGPL License and not to allow others to use your version of this file
+ under the MPL, indicate your decision by deleting the provisions above and
+ replace them with the notice and other provisions required by the LGPL
+ License. If you do not delete the provisions above, a recipient may use
+ your version of this file under either the MPL or the LGPL License.
+
+ For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
+}
+
+{ This unit contains loader/saver for Portable Maps file format family (or PNM).
+ That includes PBM, PGM, PPM, PAM, and PFM formats.}
+unit ImagingPortableMaps;
+
+{$I ImagingOptions.inc}
+
+interface
+
+uses
+ SysUtils, ImagingTypes, Imaging, ImagingFormats, ImagingUtility;
+
+type
+ { Types of pixels of PNM images.}
+ TTupleType = (ttInvalid, ttBlackAndWhite, ttGrayScale, ttRGB, ttBlackAndWhiteAlpha,
+ ttGrayScaleAlpha, ttRGBAlpha, ttGrayScaleFP, ttRGBFP);
+
+ { Record with info about PNM image used in both loading and saving functions.}
+ TPortableMapInfo = record
+ Width: LongInt;
+ Height: LongInt;
+ FormatId: AnsiChar;
+ MaxVal: LongInt;
+ BitCount: LongInt;
+ Depth: LongInt;
+ TupleType: TTupleType;
+ Binary: Boolean;
+ HasPAMHeader: Boolean;
+ IsBigEndian: Boolean;
+ end;
+
+ { Base class for Portable Map file formats (or Portable AnyMaps or PNM).
+ There are several types of PNM file formats that share common
+ (simple) structure. This class can actually load all supported PNM formats.
+ Saving is also done by this class but descendants (each for different PNM
+ format) control it.}
+ TPortableMapFileFormat = class(TImageFileFormat)
+ protected
+ FIdNumbers: TChar2;
+ FSaveBinary: LongBool;
+ function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
+ OnlyFirstLevel: Boolean): Boolean; override;
+ function SaveDataInternal(Handle: TImagingHandle; const Images: TDynImageDataArray;
+ Index: LongInt; var MapInfo: TPortableMapInfo): Boolean;
+ public
+ constructor Create; override;
+ function TestFormat(Handle: TImagingHandle): Boolean; override;
+ published
+ { If set to True images will be saved in binary format. If it is False
+ they will be saved in text format (which could result in 5-10x bigger file).
+ Default is value True. Note that PAM and PFM files are always saved in binary.}
+ property SaveBinary: LongBool read FSaveBinary write FSaveBinary;
+ end;
+
+ { Portable Bit Map is used to store monochrome 1bit images. Raster data
+ can be saved as text or binary data. Either way value of 0 represents white
+ and 1 is black. As Imaging does not have support for 1bit data formats
+ PBM images can be loaded but not saved. Loaded images are returned in
+ ifGray8 format (witch pixel values scaled from 1bit to 8bit).}
+ TPBMFileFormat = class(TPortableMapFileFormat)
+ public
+ constructor Create; override;
+ end;
+
+ { Portable Gray Map is used to store grayscale 8bit or 16bit images.
+ Raster data can be saved as text or binary data.}
+ TPGMFileFormat = class(TPortableMapFileFormat)
+ protected
+ function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
+ Index: LongInt): Boolean; override;
+ procedure ConvertToSupported(var Image: TImageData;
+ const Info: TImageFormatInfo); override;
+ public
+ constructor Create; override;
+ end;
+
+ { Portable Pixel Map is used to store RGB images with 8bit or 16bit channels.
+ Raster data can be saved as text or binary data.}
+ TPPMFileFormat = class(TPortableMapFileFormat)
+ protected
+ function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
+ Index: LongInt): Boolean; override;
+ procedure ConvertToSupported(var Image: TImageData;
+ const Info: TImageFormatInfo); override;
+ public
+ constructor Create; override;
+ end;
+
+ { Portable Arbitrary Map is format that can store image data formats
+ of PBM, PGM, and PPM formats with optional alpha channel. Raster data
+ can be stored only in binary format. All data formats supported
+ by this format are ifGray8, ifGray16, ifA8Gray8, ifA16Gray16,
+ ifR8G8B8, ifR16G16R16, ifA8R8G8B8, and ifA16R16G16B16.}
+ TPAMFileFormat = class(TPortableMapFileFormat)
+ protected
+ function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
+ Index: LongInt): Boolean; override;
+ procedure ConvertToSupported(var Image: TImageData;
+ const Info: TImageFormatInfo); override;
+ public
+ constructor Create; override;
+ end;
+
+ { Portable Float Map is unofficial extension of PNM format family which
+ can store images with floating point pixels. Raster data is saved in
+ binary format as array of IEEE 32 bit floating point numbers. One channel
+ or RGB images are supported by PFM format (so no alpha).}
+ TPFMFileFormat = class(TPortableMapFileFormat)
+ protected
+ function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
+ Index: LongInt): Boolean; override;
+ procedure ConvertToSupported(var Image: TImageData;
+ const Info: TImageFormatInfo); override;
+ public
+ constructor Create; override;
+ end;
+
+implementation
+
+const
+ PortableMapDefaultBinary = True;
+
+ SPBMFormatName = 'Portable Bit Map';
+ SPBMMasks = '*.pbm';
+ SPGMFormatName = 'Portable Gray Map';
+ SPGMMasks = '*.pgm';
+ PGMSupportedFormats = [ifGray8, ifGray16];
+ SPPMFormatName = 'Portable Pixel Map';
+ SPPMMasks = '*.ppm';
+ PPMSupportedFormats = [ifR8G8B8, ifR16G16B16];
+ SPAMFormatName = 'Portable Arbitrary Map';
+ SPAMMasks = '*.pam';
+ PAMSupportedFormats = [ifGray8, ifGray16, ifA8Gray8, ifA16Gray16,
+ ifR8G8B8, ifR16G16B16, ifA8R8G8B8, ifA16R16G16B16];
+ SPFMFormatName = 'Portable Float Map';
+ SPFMMasks = '*.pfm';
+ PFMSupportedFormats = [ifR32F, ifA32B32G32R32F];
+
+const
+ { TAB, CR, LF, and Space are used as seperators in Portable map headers and data.}
+ WhiteSpaces = [#9, #10, #13, #32];
+ SPAMWidth = 'WIDTH';
+ SPAMHeight = 'HEIGHT';
+ SPAMDepth = 'DEPTH';
+ SPAMMaxVal = 'MAXVAL';
+ SPAMTupleType = 'TUPLTYPE';
+ SPAMEndHdr = 'ENDHDR';
+
+ { Size of buffer used to speed up text PNM loading/saving.}
+ LineBufferCapacity = 16 * 1024;
+
+ TupleTypeNames: array[TTupleType] of string = (
+ 'INVALID', 'BLACKANDWHITE', 'GRAYSCALE', 'RGB',
+ 'BLACKANDWHITE_ALPHA', 'GRAYSCALE_ALPHA', 'RGB_ALPHA', 'GRAYSCALEFP',
+ 'RGBFP');
+
+{ TPortableMapFileFormat }
+
+constructor TPortableMapFileFormat.Create;
+begin
+ inherited Create;
+ FCanLoad := True;
+ FCanSave := True;
+ FIsMultiImageFormat := False;
+ FSaveBinary := PortableMapDefaultBinary;
+end;
+
+function TPortableMapFileFormat.LoadData(Handle: TImagingHandle;
+ var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
+var
+ I, ScanLineSize, MonoSize: LongInt;
+ Dest: PByte;
+ MonoData: Pointer;
+ Info: TImageFormatInfo;
+ PixelFP: TColorFPRec;
+ LineBuffer: array[0..LineBufferCapacity - 1] of AnsiChar;
+ LineEnd, LinePos: LongInt;
+ MapInfo: TPortableMapInfo;
+ LineBreak: string;
+
+ procedure CheckBuffer;
+ begin
+ if (LineEnd = 0) or (LinePos = LineEnd) then
+ begin
+ // Reload buffer if its is empty or its end was reached
+ LineEnd := GetIO.Read(Handle, @LineBuffer[0], LineBufferCapacity);
+ LinePos := 0;
+ end;
+ end;
+
+ procedure FixInputPos;
+ begin
+ // Sets input's position to its real pos as it would be without buffering
+ if LineEnd > 0 then
+ begin
+ GetIO.Seek(Handle, -LineEnd + LinePos, smFromCurrent);
+ LineEnd := 0;
+ end;
+ end;
+
+ function ReadString: string;
+ var
+ S: AnsiString;
+ C: AnsiChar;
+ begin
+ // First skip all whitespace chars
+ SetLength(S, 1);
+ repeat
+ CheckBuffer;
+ S[1] := LineBuffer[LinePos];
+ Inc(LinePos);
+ if S[1] = '#' then
+ repeat
+ // Comment detected, skip everything until next line is reached
+ CheckBuffer;
+ S[1] := LineBuffer[LinePos];
+ Inc(LinePos);
+ until S[1] = #10;
+ until not(S[1] in WhiteSpaces);
+ // Now we have reached some chars other than white space, read them until
+ // there is whitespace again
+ repeat
+ SetLength(S, Length(S) + 1);
+ CheckBuffer;
+ S[Length(S)] := LineBuffer[LinePos];
+ Inc(LinePos);
+ // Repeat until current char is whitespace or end of file is reached
+ // (Line buffer has 0 bytes which happens only on EOF)
+ until (S[Length(S)] in WhiteSpaces) or (LineEnd = 0);
+ // Get rid of last char - whitespace or null
+ SetLength(S, Length(S) - 1);
+ // Move position to the beginning of next string (skip white space - needed
+ // to make the loader stop at the right input position)
+ repeat
+ CheckBuffer;
+ C := LineBuffer[LinePos];
+ Inc(LinePos);
+ until not (C in WhiteSpaces) or (LineEnd = 0);
+ // Dec pos, current is the begining of the the string
+ Dec(LinePos);
+
+ Result := string(S);
+ end;
+
+ function ReadIntValue: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
+ begin
+ Result := StrToInt(ReadString);
+ end;
+
+ procedure FindLineBreak;
+ var
+ C: AnsiChar;
+ begin
+ LineBreak := #10;
+ repeat
+ CheckBuffer;
+ C := LineBuffer[LinePos];
+ Inc(LinePos);
+
+ if C = #13 then
+ LineBreak := #13#10;
+
+ until C = #10;
+ end;
+
+ function ParseHeader: Boolean;
+ var
+ Id: TChar2;
+ I: TTupleType;
+ TupleTypeName: string;
+ Scale: Single;
+ OldSeparator: Char;
+ begin
+ Result := False;
+ with GetIO do
+ begin
+ FillChar(MapInfo, SizeOf(MapInfo), 0);
+ Read(Handle, @Id, SizeOf(Id));
+ FindLineBreak;
+
+ if Id[1] in ['1'..'6'] then
+ begin
+ // Read header for PBM, PGM, and PPM files
+ MapInfo.Width := ReadIntValue;
+ MapInfo.Height := ReadIntValue;
+
+ if Id[1] in ['1', '4'] then
+ begin
+ MapInfo.MaxVal := 1;
+ MapInfo.BitCount := 1
+ end
+ else
+ begin
+ // Read channel max value, <=255 for 8bit images, >255 for 16bit images
+ // but some programs think its max colors so put <=256 here
+ MapInfo.MaxVal := ReadIntValue;
+ MapInfo.BitCount := Iff(MapInfo.MaxVal <= 256, 8, 16);
+ end;
+
+ MapInfo.Depth := 1;
+ case Id[1] of
+ '1', '4': MapInfo.TupleType := ttBlackAndWhite;
+ '2', '5': MapInfo.TupleType := ttGrayScale;
+ '3', '6':
+ begin
+ MapInfo.TupleType := ttRGB;
+ MapInfo.Depth := 3;
+ end;
+ end;
+ end
+ else if Id[1] = '7' then
+ begin
+ // Read values from PAM header
+ // WIDTH
+ if (ReadString <> SPAMWidth) then Exit;
+ MapInfo.Width := ReadIntValue;
+ // HEIGHT
+ if (ReadString <> SPAMheight) then Exit;
+ MapInfo.Height := ReadIntValue;
+ // DEPTH
+ if (ReadString <> SPAMDepth) then Exit;
+ MapInfo.Depth := ReadIntValue;
+ // MAXVAL
+ if (ReadString <> SPAMMaxVal) then Exit;
+ MapInfo.MaxVal := ReadIntValue;
+ MapInfo.BitCount := Iff(MapInfo.MaxVal <= 256, 8, 16);
+ // TUPLETYPE
+ if (ReadString <> SPAMTupleType) then Exit;
+ TupleTypeName := ReadString;
+ for I := Low(TTupleType) to High(TTupleType) do
+ if SameText(TupleTypeName, TupleTypeNames[I]) then
+ begin
+ MapInfo.TupleType := I;
+ Break;
+ end;
+ // ENDHDR
+ if (ReadString <> SPAMEndHdr) then Exit;
+ end
+ else if Id[1] in ['F', 'f'] then
+ begin
+ // Read header of PFM file
+ MapInfo.Width := ReadIntValue;
+ MapInfo.Height := ReadIntValue;
+ OldSeparator := DecimalSeparator;
+ DecimalSeparator := '.';
+ Scale := StrToFloatDef(ReadString, 0);
+ DecimalSeparator := OldSeparator;
+ MapInfo.IsBigEndian := Scale > 0.0;
+ if Id[1] = 'F' then
+ MapInfo.TupleType := ttRGBFP
+ else
+ MapInfo.TupleType := ttGrayScaleFP;
+ MapInfo.Depth := Iff(MapInfo.TupleType = ttRGBFP, 3, 1);
+ MapInfo.BitCount := Iff(MapInfo.TupleType = ttRGBFP, 96, 32);
+ end;
+
+ FixInputPos;
+ MapInfo.Binary := (Id[1] in ['4', '5', '6', '7', 'F', 'f']);
+
+ if MapInfo.Binary and not (Id[1] in ['F', 'f']) then
+ begin
+ // Mimic the behaviour of Photoshop and other editors/viewers:
+ // If linenreaks in file are DOS CR/LF 16bit binary values are
+ // little endian, Unix LF only linebreak indicates big endian.
+ MapInfo.IsBigEndian := LineBreak = #10;
+ end;
+
+ // Check if values found in header are valid
+ Result := (MapInfo.Width > 0) and (MapInfo.Height > 0) and
+ (MapInfo.BitCount in [1, 8, 16, 32, 96]) and (MapInfo.TupleType <> ttInvalid);
+ // Now check if image has proper number of channels (PAM)
+ if Result then
+ case MapInfo.TupleType of
+ ttBlackAndWhite, ttGrayScale: Result := MapInfo.Depth = 1;
+ ttBlackAndWhiteAlpha, ttGrayScaleAlpha: Result := MapInfo.Depth = 2;
+ ttRGB: Result := MapInfo.Depth = 3;
+ ttRGBAlpha: Result := MapInfo.Depth = 4;
+ end;
+ end;
+ end;
+
+begin
+ Result := False;
+ LineEnd := 0;
+ LinePos := 0;
+ SetLength(Images, 1);
+ with GetIO, Images[0] do
+ begin
+ Format := ifUnknown;
+ // Try to parse file header
+ if not ParseHeader then Exit;
+ // Select appropriate data format based on values read from file header
+ case MapInfo.TupleType of
+ ttBlackAndWhite: Format := ifGray8;
+ ttBlackAndWhiteAlpha: Format := ifA8Gray8;
+ ttGrayScale: Format := IffFormat(MapInfo.BitCount = 8, ifGray8, ifGray16);
+ ttGrayScaleAlpha: Format := IffFormat(MapInfo.BitCount = 8, ifA8Gray8, ifA16Gray16);
+ ttRGB: Format := IffFormat(MapInfo.BitCount = 8, ifR8G8B8, ifR16G16B16);
+ ttRGBAlpha: Format := IffFormat(MapInfo.BitCount = 8, ifA8R8G8B8, ifA16R16G16B16);
+ ttGrayScaleFP: Format := ifR32F;
+ ttRGBFP: Format := ifA32B32G32R32F;
+ end;
+ // Exit if no matching data format was found
+ if Format = ifUnknown then Exit;
+
+ NewImage(MapInfo.Width, MapInfo.Height, Format, Images[0]);
+ Info := GetFormatInfo(Format);
+
+ // Now read pixels from file to dest image
+ if not MapInfo.Binary then
+ begin
+ Dest := Bits;
+ for I := 0 to Width * Height - 1 do
+ begin
+ case Format of
+ ifGray8:
+ begin
+ Dest^ := ReadIntValue;
+ if MapInfo.BitCount = 1 then
+ // If source is 1bit mono image (where 0=white, 1=black)
+ // we must scale it to 8bits
+ Dest^ := 255 - Dest^ * 255;
+ end;
+ ifGray16: PWord(Dest)^ := ReadIntValue;
+ ifR8G8B8:
+ with PColor24Rec(Dest)^ do
+ begin
+ R := ReadIntValue;
+ G := ReadIntValue;
+ B := ReadIntValue;
+ end;
+ ifR16G16B16:
+ with PColor48Rec(Dest)^ do
+ begin
+ R := ReadIntValue;
+ G := ReadIntValue;
+ B := ReadIntValue;
+ end;
+ end;
+ Inc(Dest, Info.BytesPerPixel);
+ end;
+ end
+ else
+ begin
+ if MapInfo.BitCount > 1 then
+ begin
+ if not (MapInfo.TupleType in [ttGrayScaleFP, ttRGBFP]) then
+ begin
+ // Just copy bytes from binary Portable Maps (non 1bit, non FP)
+ Read(Handle, Bits, Size);
+ end
+ else
+ begin
+ Dest := Bits;
+ // FP images are in BGR order and endian swap maybe needed.
+ // Some programs store scanlines in bottom-up order but
+ // I will stick with Photoshops behaviour here
+ for I := 0 to Width * Height - 1 do
+ begin
+ Read(Handle, @PixelFP, MapInfo.BitCount div 8);
+ if MapInfo.TupleType = ttRGBFP then
+ with PColorFPRec(Dest)^ do
+ begin
+ A := 1.0;
+ R := PixelFP.R;
+ G := PixelFP.G;
+ B := PixelFP.B;
+ if MapInfo.IsBigEndian then
+ SwapEndianLongWord(PLongWord(Dest), 3);
+ end
+ else
+ begin
+ PSingle(Dest)^ := PixelFP.B;
+ if MapInfo.IsBigEndian then
+ SwapEndianLongWord(PLongWord(Dest), 1);
+ end;
+ Inc(Dest, Info.BytesPerPixel);
+ end;
+ end;
+
+ if MapInfo.TupleType in [ttBlackAndWhite, ttBlackAndWhiteAlpha] then
+ begin
+ // Black and white PAM files must be scaled to 8bits. Note that
+ // in PAM files 1=white, 0=black (reverse of PBM)
+ for I := 0 to Width * Height * Iff(MapInfo.TupleType = ttBlackAndWhiteAlpha, 2, 1) - 1 do
+ PByteArray(Bits)[I] := PByteArray(Bits)[I] * 255;
+ end
+ else if MapInfo.TupleType in [ttRGB, ttRGBAlpha] then
+ begin
+ // Swap channels of RGB/ARGB images. Binary RGB image files use BGR order.
+ SwapChannels(Images[0], ChannelBlue, ChannelRed);
+ end;
+
+ // Swap byte order if needed
+ if (MapInfo.BitCount = 16) and MapInfo.IsBigEndian then
+ SwapEndianWord(Bits, Width * Height * Info.BytesPerPixel div SizeOf(Word));
+ end
+ else
+ begin
+ // Handle binary PBM files (ttBlackAndWhite 1bit)
+ ScanLineSize := (Width + 7) div 8;
+ // Get total binary data size, read it from file to temp
+ // buffer and convert the data to Gray8
+ MonoSize := ScanLineSize * Height;
+ GetMem(MonoData, MonoSize);
+ try
+ Read(Handle, MonoData, MonoSize);
+ Convert1To8(MonoData, Bits, Width, Height, ScanLineSize);
+ // 1bit mono images must be scaled to 8bit (where 0=white, 1=black)
+ for I := 0 to Width * Height - 1 do
+ PByteArray(Bits)[I] := 255 - PByteArray(Bits)[I] * 255;
+ finally
+ FreeMem(MonoData);
+ end;
+ end;
+ end;
+
+ FixInputPos;
+
+ if (MapInfo.MaxVal <> Pow2Int(MapInfo.BitCount) - 1) and
+ (MapInfo.TupleType in [ttGrayScale, ttGrayScaleAlpha, ttRGB, ttRGBAlpha]) then
+ begin
+ Dest := Bits;
+ // Scale color values according to MaxVal we got from header
+ // if necessary.
+ for I := 0 to Width * Height * Info.BytesPerPixel div (MapInfo.BitCount shr 3) - 1 do
+ begin
+ if MapInfo.BitCount = 8 then
+ Dest^ := Dest^ * 255 div MapInfo.MaxVal
+ else
+ PWord(Dest)^ := PWord(Dest)^ * 65535 div MapInfo.MaxVal;
+ Inc(Dest, MapInfo.BitCount shr 3);
+ end;
+ end;
+
+ Result := True;
+ end;
+end;
+
+function TPortableMapFileFormat.SaveDataInternal(Handle: TImagingHandle;
+ const Images: TDynImageDataArray; Index: Integer; var MapInfo: TPortableMapInfo): Boolean;
+const
+ // Use Unix linebreak, for many viewers/editors it means that
+ // 16bit samples are stored as big endian - so we need to swap byte order
+ // before saving
+ LineDelimiter = #10;
+ PixelDelimiter = #32;
+var
+ ImageToSave: TImageData;
+ MustBeFreed: Boolean;
+ Info: TImageFormatInfo;
+ I, LineLength: LongInt;
+ Src: PByte;
+ Pixel32: TColor32Rec;
+ Pixel64: TColor64Rec;
+ W: Word;
+
+ procedure WriteString(S: string; Delimiter: Char = LineDelimiter);
+ begin
+ SetLength(S, Length(S) + 1);
+ S[Length(S)] := Delimiter;
+ {$IF Defined(DCC) and Defined(UNICODE)}
+ GetIO.Write(Handle, @AnsiString(S)[1], Length(S));
+ {$ELSE}
+ GetIO.Write(Handle, @S[1], Length(S));
+ {$IFEND}
+ Inc(LineLength, Length(S));
+ end;
+
+ procedure WriteHeader;
+ var
+ OldSeparator: Char;
+ begin
+ WriteString('P' + MapInfo.FormatId);
+ if not MapInfo.HasPAMHeader then
+ begin
+ // Write header of PGM, PPM, and PFM files
+ WriteString(IntToStr(ImageToSave.Width));
+ WriteString(IntToStr(ImageToSave.Height));
+ case MapInfo.TupleType of
+ ttGrayScale, ttRGB: WriteString(IntToStr(Pow2Int(MapInfo.BitCount) - 1));
+ ttGrayScaleFP, ttRGBFP:
+ begin
+ OldSeparator := DecimalSeparator;
+ DecimalSeparator := '.';
+ // Negative value indicates that raster data is saved in little endian
+ WriteString(FloatToStr(-1.0));
+ DecimalSeparator := OldSeparator;
+ end;
+ end;
+ end
+ else
+ begin
+ // Write PAM file header
+ WriteString(Format('%s %d', [SPAMWidth, ImageToSave.Width]));
+ WriteString(Format('%s %d', [SPAMHeight, ImageToSave.Height]));
+ WriteString(Format('%s %d', [SPAMDepth, MapInfo.Depth]));
+ WriteString(Format('%s %d', [SPAMMaxVal, Pow2Int(MapInfo.BitCount) - 1]));
+ WriteString(Format('%s %s', [SPAMTupleType, TupleTypeNames[MapInfo.TupleType]]));
+ WriteString(SPAMEndHdr);
+ end;
+ end;
+
+begin
+ Result := False;
+ if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then
+ with GetIO, ImageToSave do
+ try
+ Info := GetFormatInfo(Format);
+ // Fill values of MapInfo record that were not filled by
+ // descendants in their SaveData methods
+ MapInfo.BitCount := (Info.BytesPerPixel div Info.ChannelCount) * 8;
+ MapInfo.Depth := Info.ChannelCount;
+ if MapInfo.TupleType = ttInvalid then
+ begin
+ if Info.HasGrayChannel then
+ begin
+ if Info.HasAlphaChannel then
+ MapInfo.TupleType := ttGrayScaleAlpha
+ else
+ MapInfo.TupleType := ttGrayScale;
+ end
+ else
+ begin
+ if Info.HasAlphaChannel then
+ MapInfo.TupleType := ttRGBAlpha
+ else
+ MapInfo.TupleType := ttRGB;
+ end;
+ end;
+ // Write file header
+ WriteHeader;
+
+ if not MapInfo.Binary then
+ begin
+ Src := Bits;
+ LineLength := 0;
+ // For each pixel find its text representation and write it to file
+ for I := 0 to Width * Height - 1 do
+ begin
+ case Format of
+ ifGray8: WriteString(IntToStr(Src^), PixelDelimiter);
+ ifGray16: WriteString(IntToStr(PWord(Src)^), PixelDelimiter);
+ ifR8G8B8:
+ with PColor24Rec(Src)^ do
+ WriteString(SysUtils.Format('%d %d %d', [R, G, B]), PixelDelimiter);
+ ifR16G16B16:
+ with PColor48Rec(Src)^ do
+ WriteString(SysUtils.Format('%d %d %d', [R, G, B]), PixelDelimiter);
+ end;
+ // Lines in text PNM images should have length <70
+ if LineLength > 65 then
+ begin
+ LineLength := 0;
+ WriteString('', LineDelimiter);
+ end;
+ Inc(Src, Info.BytesPerPixel);
+ end;
+ end
+ else
+ begin
+ // Write binary images
+ if not (MapInfo.TupleType in [ttGrayScaleFP, ttRGBFP]) then
+ begin
+ // Save integer binary images
+ if MapInfo.BitCount = 8 then
+ begin
+ if MapInfo.TupleType in [ttGrayScale, ttGrayScaleAlpha] then
+ begin
+ // 8bit grayscale images can be written in one Write call
+ Write(Handle, Bits, Size);
+ end
+ else
+ begin
+ // 8bit RGB/ARGB images: read and blue must be swapped and
+ // 3 or 4 bytes must be written
+ Src := Bits;
+ for I := 0 to Width * Height - 1 do
+ with PColor32Rec(Src)^ do
+ begin
+ if MapInfo.TupleType = ttRGBAlpha then
+ Pixel32.A := A;
+ Pixel32.R := B;
+ Pixel32.G := G;
+ Pixel32.B := R;
+ Write(Handle, @Pixel32, Info.BytesPerPixel);
+ Inc(Src, Info.BytesPerPixel);
+ end;
+ end;
+ end
+ else
+ begin
+ // Images with 16bit channels: make sure that channel values are saved in big endian
+ Src := Bits;
+ if MapInfo.TupleType in [ttGrayScale, ttGrayScaleAlpha] then
+ begin
+ // 16bit grayscale image
+ for I := 0 to Width * Height * Info.BytesPerPixel div SizeOf(Word) - 1 do
+ begin
+ W := SwapEndianWord(PWord(Src)^);
+ Write(Handle, @W, SizeOf(Word));
+ Inc(Src, SizeOf(Word));
+ end;
+ end
+ else
+ begin
+ // RGB images with 16bit channels: swap RB and endian too
+ for I := 0 to Width * Height - 1 do
+ with PColor64Rec(Src)^ do
+ begin
+ if MapInfo.TupleType = ttRGBAlpha then
+ Pixel64.A := SwapEndianWord(A);
+ Pixel64.R := SwapEndianWord(B);
+ Pixel64.G := SwapEndianWord(G);
+ Pixel64.B := SwapEndianWord(R);
+ Write(Handle, @Pixel64, Info.BytesPerPixel);
+ Inc(Src, Info.BytesPerPixel);
+ end;
+ end;
+ end;
+ end
+ else
+ begin
+ // Floating point images (no need to swap endian here - little
+ // endian is specified in file header)
+ if MapInfo.TupleType = ttGrayScaleFP then
+ begin
+ // Grayscale images can be written in one Write call
+ Write(Handle, Bits, Size);
+ end
+ else
+ begin
+ // Expected data format of PFM RGB file is B32G32R32F which is not
+ // supported by Imaging. We must write pixels one by one and
+ // write only RGB part of A32B32G32B32 image.
+ Src := Bits;
+ for I := 0 to Width * Height - 1 do
+ begin
+ Write(Handle, Src, SizeOf(Single) * 3);
+ Inc(Src, Info.BytesPerPixel);
+ end;
+ end;
+ end;
+ end;
+ Result := True;
+ finally
+ if MustBeFreed then
+ FreeImage(ImageToSave);
+ end;
+end;
+
+function TPortableMapFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
+var
+ Id: TChar4;
+ ReadCount: LongInt;
+begin
+ Result := False;
+ if Handle <> nil then
+ with GetIO do
+ begin
+ ReadCount := Read(Handle, @Id, SizeOf(Id));
+ Seek(Handle, -ReadCount, smFromCurrent);
+ Result := (Id[0] = 'P') and (Id[1] in [FIdNumbers[0], FIdNumbers[1]]) and
+ (Id[2] in WhiteSpaces);
+ end;
+end;
+
+{ TPBMFileFormat }
+
+constructor TPBMFileFormat.Create;
+begin
+ inherited Create;
+ FName := SPBMFormatName;
+ FCanSave := False;
+ AddMasks(SPBMMasks);
+ FIdNumbers := '14';
+end;
+
+{ TPGMFileFormat }
+
+constructor TPGMFileFormat.Create;
+begin
+ inherited Create;
+ FName := SPGMFormatName;
+ FSupportedFormats := PGMSupportedFormats;
+ AddMasks(SPGMMasks);
+ RegisterOption(ImagingPGMSaveBinary, @FSaveBinary);
+ FIdNumbers := '25';
+end;
+
+function TPGMFileFormat.SaveData(Handle: TImagingHandle;
+ const Images: TDynImageDataArray; Index: Integer): Boolean;
+var
+ MapInfo: TPortableMapInfo;
+begin
+ FillChar(MapInfo, SizeOf(MapInfo), 0);
+ if FSaveBinary then
+ MapInfo.FormatId := FIdNumbers[1]
+ else
+ MapInfo.FormatId := FIdNumbers[0];
+ MapInfo.Binary := FSaveBinary;
+ Result := SaveDataInternal(Handle, Images, Index, MapInfo);
+end;
+
+procedure TPGMFileFormat.ConvertToSupported(var Image: TImageData;
+ const Info: TImageFormatInfo);
+var
+ ConvFormat: TImageFormat;
+begin
+ if Info.IsFloatingPoint then
+ // All FP images go to 16bit
+ ConvFormat := ifGray16
+ else if Info.HasGrayChannel then
+ // Grayscale will be 8 or 16 bit - depends on input's bitcount
+ ConvFormat := IffFormat(Info.BytesPerPixel div Info.ChannelCount > 1,
+ ifGray16, ifGray8)
+ else if Info.BytesPerPixel > 4 then
+ // Large bitcounts -> 16bit
+ ConvFormat := ifGray16
+ else
+ // Rest of the formats -> 8bit
+ ConvFormat := ifGray8;
+
+ ConvertImage(Image, ConvFormat);
+end;
+
+{ TPPMFileFormat }
+
+constructor TPPMFileFormat.Create;
+begin
+ inherited Create;
+ FName := SPPMFormatName;
+ FSupportedFormats := PPMSupportedFormats;
+ AddMasks(SPPMMasks);
+ RegisterOption(ImagingPPMSaveBinary, @FSaveBinary);
+ FIdNumbers := '36';
+end;
+
+function TPPMFileFormat.SaveData(Handle: TImagingHandle;
+ const Images: TDynImageDataArray; Index: Integer): Boolean;
+var
+ MapInfo: TPortableMapInfo;
+begin
+ FillChar(MapInfo, SizeOf(MapInfo), 0);
+ if FSaveBinary then
+ MapInfo.FormatId := FIdNumbers[1]
+ else
+ MapInfo.FormatId := FIdNumbers[0];
+ MapInfo.Binary := FSaveBinary;
+ Result := SaveDataInternal(Handle, Images, Index, MapInfo);
+end;
+
+procedure TPPMFileFormat.ConvertToSupported(var Image: TImageData;
+ const Info: TImageFormatInfo);
+var
+ ConvFormat: TImageFormat;
+begin
+ if Info.IsFloatingPoint then
+ // All FP images go to 48bit RGB
+ ConvFormat := ifR16G16B16
+ else if Info.HasGrayChannel then
+ // Grayscale will be 24 or 48 bit RGB - depends on input's bitcount
+ ConvFormat := IffFormat(Info.BytesPerPixel div Info.ChannelCount > 1,
+ ifR16G16B16, ifR8G8B8)
+ else if Info.BytesPerPixel > 4 then
+ // Large bitcounts -> 48bit RGB
+ ConvFormat := ifR16G16B16
+ else
+ // Rest of the formats -> 24bit RGB
+ ConvFormat := ifR8G8B8;
+
+ ConvertImage(Image, ConvFormat);
+end;
+
+{ TPAMFileFormat }
+
+constructor TPAMFileFormat.Create;
+begin
+ inherited Create;
+ FName := SPAMFormatName;
+ FSupportedFormats := PAMSupportedFormats;
+ AddMasks(SPAMMasks);
+ FIdNumbers := '77';
+end;
+
+function TPAMFileFormat.SaveData(Handle: TImagingHandle;
+ const Images: TDynImageDataArray; Index: Integer): Boolean;
+var
+ MapInfo: TPortableMapInfo;
+begin
+ FillChar(MapInfo, SizeOf(MapInfo), 0);
+ MapInfo.FormatId := FIdNumbers[0];
+ MapInfo.Binary := True;
+ MapInfo.HasPAMHeader := True;
+ Result := SaveDataInternal(Handle, Images, Index, MapInfo);
+end;
+
+procedure TPAMFileFormat.ConvertToSupported(var Image: TImageData;
+ const Info: TImageFormatInfo);
+var
+ ConvFormat: TImageFormat;
+begin
+ if Info.IsFloatingPoint then
+ ConvFormat := IffFormat(Info.HasAlphaChannel, ifA16R16G16B16, ifR16G16B16)
+ else if Info.HasGrayChannel then
+ ConvFormat := IffFormat(Info.HasAlphaChannel, ifA16Gray16, ifGray16)
+ else
+ begin
+ if Info.BytesPerPixel <= 4 then
+ ConvFormat := IffFormat(Info.HasAlphaChannel, ifA8R8G8B8, ifR8G8B8)
+ else
+ ConvFormat := IffFormat(Info.HasAlphaChannel, ifA16R16G16B16, ifR16G16B16);
+ end;
+ ConvertImage(Image, ConvFormat);
+end;
+
+{ TPFMFileFormat }
+
+constructor TPFMFileFormat.Create;
+begin
+ inherited Create;
+ FName := SPFMFormatName;
+ AddMasks(SPFMMasks);
+ FIdNumbers := 'Ff';
+ FSupportedFormats := PFMSupportedFormats;
+end;
+
+function TPFMFileFormat.SaveData(Handle: TImagingHandle;
+ const Images: TDynImageDataArray; Index: Integer): Boolean;
+var
+ Info: TImageFormatInfo;
+ MapInfo: TPortableMapInfo;
+begin
+ FillChar(MapInfo, SizeOf(MapInfo), 0);
+ Info := GetFormatInfo(Images[Index].Format);
+
+ if (Info.ChannelCount > 1) or Info.IsIndexed then
+ MapInfo.TupleType := ttRGBFP
+ else
+ MapInfo.TupleType := ttGrayScaleFP;
+
+ if MapInfo.TupleType = ttGrayScaleFP then
+ MapInfo.FormatId := FIdNumbers[1]
+ else
+ MapInfo.FormatId := FIdNumbers[0];
+
+ MapInfo.Binary := True;
+ Result := SaveDataInternal(Handle, Images, Index, MapInfo);
+end;
+
+procedure TPFMFileFormat.ConvertToSupported(var Image: TImageData;
+ const Info: TImageFormatInfo);
+begin
+ if (Info.ChannelCount > 1) or Info.IsIndexed then
+ ConvertImage(Image, ifA32B32G32R32F)
+ else
+ ConvertImage(Image, ifR32F);
+end;
+
+initialization
+ RegisterImageFileFormat(TPBMFileFormat);
+ RegisterImageFileFormat(TPGMFileFormat);
+ RegisterImageFileFormat(TPPMFileFormat);
+ RegisterImageFileFormat(TPAMFileFormat);
+ RegisterImageFileFormat(TPFMFileFormat);
+
+{
+ File Notes:
+
+ -- TODOS ----------------------------------------------------
+ - nothing now
+
+ -- 0.26.3 Changes/Bug Fixes -----------------------------------
+ - Fixed D2009 Unicode related bug in PNM saving.
+
+ -- 0.24.3 Changes/Bug Fixes -----------------------------------
+ - Improved compatibility of 16bit/component image loading.
+ - Changes for better thread safety.
+
+ -- 0.21 Changes/Bug Fixes -----------------------------------
+ - Made modifications to ASCII PNM loading to be more "stream-safe".
+ - Fixed bug: indexed images saved as grayscale in PFM.
+ - Changed converting to supported formats little bit.
+ - Added scaling of channel values (non-FP and non-mono images) according
+ to MaxVal.
+ - Added buffering to loading of PNM files. More than 10x faster now
+ for text files.
+ - Added saving support to PGM, PPM, PAM, and PFM format.
+ - Added PFM file format.
+ - Initial version created.
+}
+
+end.
diff --git a/Imaging/ImagingTarga.pas b/Imaging/ImagingTarga.pas
index 65d3ff5..fedc8b8 100644
--- a/Imaging/ImagingTarga.pas
+++ b/Imaging/ImagingTarga.pas
@@ -1,623 +1,623 @@
-{
- $Id: ImagingTarga.pas 139 2008-09-18 02:01:42Z galfar $
- Vampyre Imaging Library
- by Marek Mauder
- http://imaginglib.sourceforge.net
-
- The contents of this file are used with permission, subject to the Mozilla
- Public License Version 1.1 (the "License"); you may not use this file except
- in compliance with the License. You may obtain a copy of the License at
- http://www.mozilla.org/MPL/MPL-1.1.html
-
- Software distributed under the License is distributed on an "AS IS" basis,
- WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
- the specific language governing rights and limitations under the License.
-
- Alternatively, the contents of this file may be used under the terms of the
- GNU Lesser General Public License (the "LGPL License"), in which case the
- provisions of the LGPL License are applicable instead of those above.
- If you wish to allow use of your version of this file only under the terms
- of the LGPL License and not to allow others to use your version of this file
- under the MPL, indicate your decision by deleting the provisions above and
- replace them with the notice and other provisions required by the LGPL
- License. If you do not delete the provisions above, a recipient may use
- your version of this file under either the MPL or the LGPL License.
-
- For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
-}
-
-{ This unit contains image format loader/saver for Targa images.}
-unit ImagingTarga;
-
-{$I ImagingOptions.inc}
-
-interface
-
-uses
- ImagingTypes, Imaging, ImagingFormats, ImagingUtility;
-
-type
- { Class for loading and saving Truevision Targa images.
- It can load/save 8bit indexed or grayscale, 16 bit RGB or grayscale,
- 24 bit RGB and 32 bit ARGB images with or without RLE compression.}
- TTargaFileFormat = class(TImageFileFormat)
- protected
- FUseRLE: LongBool;
- function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
- OnlyFirstLevel: Boolean): Boolean; override;
- function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
- Index: LongInt): Boolean; override;
- procedure ConvertToSupported(var Image: TImageData;
- const Info: TImageFormatInfo); override;
- public
- constructor Create; override;
- function TestFormat(Handle: TImagingHandle): Boolean; override;
- published
- { Controls that RLE compression is used during saving. Accessible trough
- ImagingTargaRLE option.}
- property UseRLE: LongBool read FUseRLE write FUseRLE;
- end;
-
-implementation
-
-const
- STargaFormatName = 'Truevision Targa Image';
- STargaMasks = '*.tga';
- TargaSupportedFormats: TImageFormats = [ifIndex8, ifGray8, ifA1R5G5B5,
- ifR8G8B8, ifA8R8G8B8];
- TargaDefaultRLE = False;
-
-const
- STargaSignature = 'TRUEVISION-XFILE';
-
-type
- { Targa file header.}
- TTargaHeader = packed record
- IDLength: Byte;
- ColorMapType: Byte;
- ImageType: Byte;
- ColorMapOff: Word;
- ColorMapLength: Word;
- ColorEntrySize: Byte;
- XOrg: SmallInt;
- YOrg: SmallInt;
- Width: SmallInt;
- Height: SmallInt;
- PixelSize: Byte;
- Desc: Byte;
- end;
-
- { Footer at the end of TGA file.}
- TTargaFooter = packed record
- ExtOff: LongWord; // Extension Area Offset
- DevDirOff: LongWord; // Developer Directory Offset
- Signature: TChar16; // TRUEVISION-XFILE
- Reserved: Byte; // ASCII period '.'
- NullChar: Byte; // 0
- end;
-
-
-{ TTargaFileFormat class implementation }
-
-constructor TTargaFileFormat.Create;
-begin
- inherited Create;
- FName := STargaFormatName;
- FCanLoad := True;
- FCanSave := True;
- FIsMultiImageFormat := False;
- FSupportedFormats := TargaSupportedFormats;
-
- FUseRLE := TargaDefaultRLE;
-
- AddMasks(STargaMasks);
- RegisterOption(ImagingTargaRLE, @FUseRLE);
-end;
-
-function TTargaFileFormat.LoadData(Handle: TImagingHandle;
- var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
-var
- Hdr: TTargaHeader;
- Foo: TTargaFooter;
- FooterFound, ExtFound: Boolean;
- I, PSize, PalSize: LongWord;
- Pal: Pointer;
- FmtInfo: TImageFormatInfo;
- WordValue: Word;
-
- procedure LoadRLE;
- var
- I, CPixel, Cnt: LongInt;
- Bpp, Rle: Byte;
- Buffer, Dest, Src: PByte;
- BufSize: LongInt;
- begin
- with GetIO, Images[0] do
- begin
- // Alocates buffer large enough to hold the worst case
- // RLE compressed data and reads then from input
- BufSize := Width * Height * FmtInfo.BytesPerPixel;
- BufSize := BufSize + BufSize div 2 + 1;
- GetMem(Buffer, BufSize);
- Src := Buffer;
- Dest := Bits;
- BufSize := Read(Handle, Buffer, BufSize);
-
- Cnt := Width * Height;
- Bpp := FmtInfo.BytesPerPixel;
- CPixel := 0;
- while CPixel < Cnt do
- begin
- Rle := Src^;
- Inc(Src);
- if Rle < 128 then
- begin
- // Process uncompressed pixel
- Rle := Rle + 1;
- CPixel := CPixel + Rle;
- for I := 0 to Rle - 1 do
- begin
- // Copy pixel from src to dest
- case Bpp of
- 1: Dest^ := Src^;
- 2: PWord(Dest)^ := PWord(Src)^;
- 3: PColor24Rec(Dest)^ := PColor24Rec(Src)^;
- 4: PLongWord(Dest)^ := PLongWord(Src)^;
- end;
- Inc(Src, Bpp);
- Inc(Dest, Bpp);
- end;
- end
- else
- begin
- // Process compressed pixels
- Rle := Rle - 127;
- CPixel := CPixel + Rle;
- // Copy one pixel from src to dest (many times there)
- for I := 0 to Rle - 1 do
- begin
- case Bpp of
- 1: Dest^ := Src^;
- 2: PWord(Dest)^ := PWord(Src)^;
- 3: PColor24Rec(Dest)^ := PColor24Rec(Src)^;
- 4: PLongWord(Dest)^ := PLongWord(Src)^;
- end;
- Inc(Dest, Bpp);
- end;
- Inc(Src, Bpp);
- end;
- end;
- // set position in source to real end of compressed data
- Seek(Handle, -(BufSize - LongInt(LongWord(Src) - LongWord(Buffer))),
- smFromCurrent);
- FreeMem(Buffer);
- end;
- end;
-
-begin
- SetLength(Images, 1);
- with GetIO, Images[0] do
- begin
- // Read targa header
- Read(Handle, @Hdr, SizeOf(Hdr));
- // Skip image ID info
- Seek(Handle, Hdr.IDLength, smFromCurrent);
- // Determine image format
- Format := ifUnknown;
- case Hdr.ImageType of
- 1, 9: Format := ifIndex8;
- 2, 10: case Hdr.PixelSize of
- 15: Format := ifX1R5G5B5;
- 16: Format := ifA1R5G5B5;
- 24: Format := ifR8G8B8;
- 32: Format := ifA8R8G8B8;
- end;
- 3, 11: Format := ifGray8;
- end;
- // Format was not assigned by previous testing (it should be in
- // well formed targas), so formats which reflects bit dept are selected
- if Format = ifUnknown then
- case Hdr.PixelSize of
- 8: Format := ifGray8;
- 15: Format := ifX1R5G5B5;
- 16: Format := ifA1R5G5B5;
- 24: Format := ifR8G8B8;
- 32: Format := ifA8R8G8B8;
- end;
- NewImage(Hdr.Width, Hdr.Height, Format, Images[0]);
- FmtInfo := GetFormatInfo(Format);
-
- if (Hdr.ColorMapType = 1) and (Hdr.ImageType in [1, 9]) then
- begin
- // Read palette
- PSize := Hdr.ColorMapLength * (Hdr.ColorEntrySize shr 3);
- GetMem(Pal, PSize);
- try
- Read(Handle, Pal, PSize);
- // Process palette
- PalSize := Iff(Hdr.ColorMapLength > FmtInfo.PaletteEntries,
- FmtInfo.PaletteEntries, Hdr.ColorMapLength);
- for I := 0 to PalSize - 1 do
- case Hdr.ColorEntrySize of
- 24:
- with Palette[I] do
- begin
- A := $FF;
- R := PPalette24(Pal)[I].R;
- G := PPalette24(Pal)[I].G;
- B := PPalette24(Pal)[I].B;
- end;
- // I've never seen tga with these palettes so they are untested
- 16:
- with Palette[I] do
- begin
- A := (PWordArray(Pal)[I] and $8000) shr 12;
- R := (PWordArray(Pal)[I] and $FC00) shr 7;
- G := (PWordArray(Pal)[I] and $03E0) shr 2;
- B := (PWordArray(Pal)[I] and $001F) shl 3;
- end;
- 32:
- with Palette[I] do
- begin
- A := PPalette32(Pal)[I].A;
- R := PPalette32(Pal)[I].R;
- G := PPalette32(Pal)[I].G;
- B := PPalette32(Pal)[I].B;
- end;
- end;
- finally
- FreeMemNil(Pal);
- end;
- end;
-
- case Hdr.ImageType of
- 0, 1, 2, 3:
- // Load uncompressed mode images
- Read(Handle, Bits, Size);
- 9, 10, 11:
- // Load RLE compressed mode images
- LoadRLE;
- end;
-
- // Check if there is alpha channel present in A1R5GB5 images, if it is not
- // change format to X1R5G5B5
- if Format = ifA1R5G5B5 then
- begin
- if not Has16BitImageAlpha(Width * Height, Bits) then
- Format := ifX1R5G5B5;
- end;
-
- // We must find true end of file and set input' position to it
- // paint programs appends extra info at the end of Targas
- // some of them multiple times (PSP Pro 8)
- repeat
- ExtFound := False;
- FooterFound := False;
-
- if Read(Handle, @WordValue, 2) = 2 then
- begin
- // 495 = size of Extension Area
- if WordValue = 495 then
- begin
- Seek(Handle, 493, smFromCurrent);
- ExtFound := True;
- end
- else
- Seek(Handle, -2, smFromCurrent);
- end;
-
- if Read(Handle, @Foo, SizeOf(Foo)) = SizeOf(Foo) then
- begin
- if Foo.Signature = STargaSignature then
- FooterFound := True
- else
- Seek(Handle, -SizeOf(Foo), smFromCurrent);
- end;
- until (not ExtFound) and (not FooterFound);
-
- // Some editors save targas flipped
- if Hdr.Desc < 31 then
- FlipImage(Images[0]);
-
- Result := True;
- end;
-end;
-
-function TTargaFileFormat.SaveData(Handle: TImagingHandle;
- const Images: TDynImageDataArray; Index: LongInt): Boolean;
-var
- I: LongInt;
- Hdr: TTargaHeader;
- FmtInfo: TImageFormatInfo;
- Pal: PPalette24;
- ImageToSave: TImageData;
- MustBeFreed: Boolean;
-
- procedure SaveRLE;
- var
- Dest: PByte;
- WidthBytes, Written, I, Total, DestSize: LongInt;
-
- function CountDiff(Data: PByte; Bpp, PixelCount: Longint): LongInt;
- var
- Pixel: LongWord;
- NextPixel: LongWord;
- N: LongInt;
- begin
- N := 0;
- Pixel := 0;
- NextPixel := 0;
- if PixelCount = 1 then
- begin
- Result := PixelCount;
- Exit;
- end;
- case Bpp of
- 1: Pixel := Data^;
- 2: Pixel := PWord(Data)^;
- 3: PColor24Rec(@Pixel)^ := PColor24Rec(Data)^;
- 4: Pixel := PLongWord(Data)^;
- end;
- while PixelCount > 1 do
- begin
- Inc(Data, Bpp);
- case Bpp of
- 1: NextPixel := Data^;
- 2: NextPixel := PWord(Data)^;
- 3: PColor24Rec(@NextPixel)^ := PColor24Rec(Data)^;
- 4: NextPixel := PLongWord(Data)^;
- end;
- if NextPixel = Pixel then
- Break;
- Pixel := NextPixel;
- N := N + 1;
- PixelCount := PixelCount - 1;
- end;
- if NextPixel = Pixel then
- Result := N
- else
- Result := N + 1;
- end;
-
- function CountSame(Data: PByte; Bpp, PixelCount: LongInt): LongInt;
- var
- Pixel: LongWord;
- NextPixel: LongWord;
- N: LongInt;
- begin
- N := 1;
- Pixel := 0;
- NextPixel := 0;
- case Bpp of
- 1: Pixel := Data^;
- 2: Pixel := PWord(Data)^;
- 3: PColor24Rec(@Pixel)^ := PColor24Rec(Data)^;
- 4: Pixel := PLongWord(Data)^;
- end;
- PixelCount := PixelCount - 1;
- while PixelCount > 0 do
- begin
- Inc(Data, Bpp);
- case Bpp of
- 1: NextPixel := Data^;
- 2: NextPixel := PWord(Data)^;
- 3: PColor24Rec(@NextPixel)^ := PColor24Rec(Data)^;
- 4: NextPixel := PLongWord(Data)^;
- end;
- if NextPixel <> Pixel then
- Break;
- N := N + 1;
- PixelCount := PixelCount - 1;
- end;
- Result := N;
- end;
-
- procedure RleCompressLine(Data: PByte; PixelCount, Bpp: LongInt; Dest:
- PByte; var Written: LongInt);
- const
- MaxRun = 128;
- var
- DiffCount: LongInt;
- SameCount: LongInt;
- RleBufSize: LongInt;
- begin
- RleBufSize := 0;
- while PixelCount > 0 do
- begin
- DiffCount := CountDiff(Data, Bpp, PixelCount);
- SameCount := CountSame(Data, Bpp, PixelCount);
- if (DiffCount > MaxRun) then
- DiffCount := MaxRun;
- if (SameCount > MaxRun) then
- SameCount := MaxRun;
- if (DiffCount > 0) then
- begin
- Dest^ := Byte(DiffCount - 1);
- Inc(Dest);
- PixelCount := PixelCount - DiffCount;
- RleBufSize := RleBufSize + (DiffCount * Bpp) + 1;
- Move(Data^, Dest^, DiffCount * Bpp);
- Inc(Data, DiffCount * Bpp);
- Inc(Dest, DiffCount * Bpp);
- end;
- if SameCount > 1 then
- begin
- Dest^ := Byte((SameCount - 1) or $80);
- Inc(Dest);
- PixelCount := PixelCount - SameCount;
- RleBufSize := RleBufSize + Bpp + 1;
- Inc(Data, (SameCount - 1) * Bpp);
- case Bpp of
- 1: Dest^ := Data^;
- 2: PWord(Dest)^ := PWord(Data)^;
- 3: PColor24Rec(Dest)^ := PColor24Rec(Data)^;
- 4: PLongWord(Dest)^ := PLongWord(Data)^;
- end;
- Inc(Data, Bpp);
- Inc(Dest, Bpp);
- end;
- end;
- Written := RleBufSize;
- end;
-
- begin
- with ImageToSave do
- begin
- // Allocate enough space to hold the worst case compression
- // result and then compress source's scanlines
- WidthBytes := Width * FmtInfo.BytesPerPixel;
- DestSize := WidthBytes * Height;
- DestSize := DestSize + DestSize div 2 + 1;
- GetMem(Dest, DestSize);
- Total := 0;
- try
- for I := 0 to Height - 1 do
- begin
- RleCompressLine(@PByteArray(Bits)[I * WidthBytes], Width,
- FmtInfo.BytesPerPixel, @PByteArray(Dest)[Total], Written);
- Total := Total + Written;
- end;
- GetIO.Write(Handle, Dest, Total);
- finally
- FreeMem(Dest);
- end;
- end;
- end;
-
-begin
- Result := False;
- if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then
- with GetIO, ImageToSave do
- try
- FmtInfo := GetFormatInfo(Format);
- // Fill targa header
- FillChar(Hdr, SizeOf(Hdr), 0);
- Hdr.IDLength := 0;
- Hdr.ColorMapType := Iff(FmtInfo.PaletteEntries > 0, 1, 0);
- Hdr.Width := Width;
- Hdr.Height := Height;
- Hdr.PixelSize := FmtInfo.BytesPerPixel * 8;
- Hdr.ColorMapLength := FmtInfo.PaletteEntries;
- Hdr.ColorEntrySize := Iff(FmtInfo.PaletteEntries > 0, 24, 0);
- Hdr.ColorMapOff := 0;
- // This indicates that targa is stored in top-left format
- // as our images -> no flipping is needed.
- Hdr.Desc := 32;
- // Set alpha channel size in descriptor (mostly ignored by other software though)
- if Format = ifA8R8G8B8 then
- Hdr.Desc := Hdr.Desc or 8
- else if Format = ifA1R5G5B5 then
- Hdr.Desc := Hdr.Desc or 1;
-
- // Choose image type
- if FmtInfo.IsIndexed then
- Hdr.ImageType := Iff(FUseRLE, 9, 1)
- else
- if FmtInfo.HasGrayChannel then
- Hdr.ImageType := Iff(FUseRLE, 11, 3)
- else
- Hdr.ImageType := Iff(FUseRLE, 10, 2);
-
- Write(Handle, @Hdr, SizeOf(Hdr));
-
- // Write palette
- if FmtInfo.PaletteEntries > 0 then
- begin
- GetMem(Pal, FmtInfo.PaletteEntries * SizeOf(TColor24Rec));
- try
- for I := 0 to FmtInfo.PaletteEntries - 1 do
- with Pal[I] do
- begin
- R := Palette[I].R;
- G := Palette[I].G;
- B := Palette[I].B;
- end;
- Write(Handle, Pal, FmtInfo.PaletteEntries * SizeOf(TColor24Rec));
- finally
- FreeMemNil(Pal);
- end;
- end;
-
- if FUseRLE then
- // Save rle compressed mode images
- SaveRLE
- else
- // Save uncompressed mode images
- Write(Handle, Bits, Size);
-
- Result := True;
- finally
- if MustBeFreed then
- FreeImage(ImageToSave);
- end;
-end;
-
-procedure TTargaFileFormat.ConvertToSupported(var Image: TImageData;
- const Info: TImageFormatInfo);
-var
- ConvFormat: TImageFormat;
-begin
- if Info.HasGrayChannel then
- // Convert all grayscale images to Gray8 (preserve alpha of AxGrayx formats)
- ConvFormat := IffFormat(not Info.HasAlphaChannel, ifGray8, ifA8R8G8B8)
- else if Info.IsIndexed then
- // Convert all indexed images to Index8
- ConvFormat := ifIndex8
- else if Info.HasAlphaChannel then
- // Convert images with alpha channel to A8R8G8B8
- ConvFormat := ifA8R8G8B8
- else if Info.UsePixelFormat then
- // Convert 16bit images (without alpha channel) to A1R5G5B5
- ConvFormat := ifA1R5G5B5
- else
- // Convert all other formats to R8G8B8
- ConvFormat := ifR8G8B8;
-
- ConvertImage(Image, ConvFormat);
-end;
-
-function TTargaFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
-var
- Hdr: TTargaHeader;
- ReadCount: LongInt;
-begin
- Result := False;
- if Handle <> nil then
- begin
- ReadCount := GetIO.Read(Handle, @Hdr, SizeOf(Hdr));
- GetIO.Seek(Handle, -ReadCount, smFromCurrent);
- Result := (ReadCount >= SizeOf(Hdr)) and
- (Hdr.ImageType in [0, 1, 2, 3, 9, 10, 11]) and
- (Hdr.PixelSize in [1, 8, 15, 16, 24, 32]) and
- (Hdr.ColorEntrySize in [0, 16, 24, 32]);
- end;
-end;
-
-initialization
- RegisterImageFileFormat(TTargaFileFormat);
-
-{
- File Notes:
-
- -- TODOS ----------------------------------------------------
- - nothing now
-
- -- 0.21 Changes/Bug Fixes -----------------------------------
- - MakeCompatible method moved to base class, put ConvertToSupported here.
- GetSupportedFormats removed, it is now set in constructor.
- - Made public properties for options registered to SetOption/GetOption
- functions.
- - Changed extensions to filename masks.
- - Changed SaveData, LoadData, and MakeCompatible methods according
- to changes in base class in Imaging unit.
-
- -- 0.17 Changes/Bug Fixes -----------------------------------
- - 16 bit images are usually without alpha but some has alpha
- channel and there is no indication of it - so I have added
- a check: if all pixels of image are with alpha = 0 image is treated
- as X1R5G5B5 otherwise as A1R5G5B5
- - fixed problems with some nonstandard 15 bit images
-}
-
-end.
-
+{
+ $Id: ImagingTarga.pas 139 2008-09-18 02:01:42Z galfar $
+ Vampyre Imaging Library
+ by Marek Mauder
+ http://imaginglib.sourceforge.net
+
+ The contents of this file are used with permission, subject to the Mozilla
+ Public License Version 1.1 (the "License"); you may not use this file except
+ in compliance with the License. You may obtain a copy of the License at
+ http://www.mozilla.org/MPL/MPL-1.1.html
+
+ Software distributed under the License is distributed on an "AS IS" basis,
+ WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
+ the specific language governing rights and limitations under the License.
+
+ Alternatively, the contents of this file may be used under the terms of the
+ GNU Lesser General Public License (the "LGPL License"), in which case the
+ provisions of the LGPL License are applicable instead of those above.
+ If you wish to allow use of your version of this file only under the terms
+ of the LGPL License and not to allow others to use your version of this file
+ under the MPL, indicate your decision by deleting the provisions above and
+ replace them with the notice and other provisions required by the LGPL
+ License. If you do not delete the provisions above, a recipient may use
+ your version of this file under either the MPL or the LGPL License.
+
+ For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
+}
+
+{ This unit contains image format loader/saver for Targa images.}
+unit ImagingTarga;
+
+{$I ImagingOptions.inc}
+
+interface
+
+uses
+ ImagingTypes, Imaging, ImagingFormats, ImagingUtility;
+
+type
+ { Class for loading and saving Truevision Targa images.
+ It can load/save 8bit indexed or grayscale, 16 bit RGB or grayscale,
+ 24 bit RGB and 32 bit ARGB images with or without RLE compression.}
+ TTargaFileFormat = class(TImageFileFormat)
+ protected
+ FUseRLE: LongBool;
+ function LoadData(Handle: TImagingHandle; var Images: TDynImageDataArray;
+ OnlyFirstLevel: Boolean): Boolean; override;
+ function SaveData(Handle: TImagingHandle; const Images: TDynImageDataArray;
+ Index: LongInt): Boolean; override;
+ procedure ConvertToSupported(var Image: TImageData;
+ const Info: TImageFormatInfo); override;
+ public
+ constructor Create; override;
+ function TestFormat(Handle: TImagingHandle): Boolean; override;
+ published
+ { Controls that RLE compression is used during saving. Accessible trough
+ ImagingTargaRLE option.}
+ property UseRLE: LongBool read FUseRLE write FUseRLE;
+ end;
+
+implementation
+
+const
+ STargaFormatName = 'Truevision Targa Image';
+ STargaMasks = '*.tga';
+ TargaSupportedFormats: TImageFormats = [ifIndex8, ifGray8, ifA1R5G5B5,
+ ifR8G8B8, ifA8R8G8B8];
+ TargaDefaultRLE = False;
+
+const
+ STargaSignature = 'TRUEVISION-XFILE';
+
+type
+ { Targa file header.}
+ TTargaHeader = packed record
+ IDLength: Byte;
+ ColorMapType: Byte;
+ ImageType: Byte;
+ ColorMapOff: Word;
+ ColorMapLength: Word;
+ ColorEntrySize: Byte;
+ XOrg: SmallInt;
+ YOrg: SmallInt;
+ Width: SmallInt;
+ Height: SmallInt;
+ PixelSize: Byte;
+ Desc: Byte;
+ end;
+
+ { Footer at the end of TGA file.}
+ TTargaFooter = packed record
+ ExtOff: LongWord; // Extension Area Offset
+ DevDirOff: LongWord; // Developer Directory Offset
+ Signature: TChar16; // TRUEVISION-XFILE
+ Reserved: Byte; // ASCII period '.'
+ NullChar: Byte; // 0
+ end;
+
+
+{ TTargaFileFormat class implementation }
+
+constructor TTargaFileFormat.Create;
+begin
+ inherited Create;
+ FName := STargaFormatName;
+ FCanLoad := True;
+ FCanSave := True;
+ FIsMultiImageFormat := False;
+ FSupportedFormats := TargaSupportedFormats;
+
+ FUseRLE := TargaDefaultRLE;
+
+ AddMasks(STargaMasks);
+ RegisterOption(ImagingTargaRLE, @FUseRLE);
+end;
+
+function TTargaFileFormat.LoadData(Handle: TImagingHandle;
+ var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
+var
+ Hdr: TTargaHeader;
+ Foo: TTargaFooter;
+ FooterFound, ExtFound: Boolean;
+ I, PSize, PalSize: LongWord;
+ Pal: Pointer;
+ FmtInfo: TImageFormatInfo;
+ WordValue: Word;
+
+ procedure LoadRLE;
+ var
+ I, CPixel, Cnt: LongInt;
+ Bpp, Rle: Byte;
+ Buffer, Dest, Src: PByte;
+ BufSize: LongInt;
+ begin
+ with GetIO, Images[0] do
+ begin
+ // Alocates buffer large enough to hold the worst case
+ // RLE compressed data and reads then from input
+ BufSize := Width * Height * FmtInfo.BytesPerPixel;
+ BufSize := BufSize + BufSize div 2 + 1;
+ GetMem(Buffer, BufSize);
+ Src := Buffer;
+ Dest := Bits;
+ BufSize := Read(Handle, Buffer, BufSize);
+
+ Cnt := Width * Height;
+ Bpp := FmtInfo.BytesPerPixel;
+ CPixel := 0;
+ while CPixel < Cnt do
+ begin
+ Rle := Src^;
+ Inc(Src);
+ if Rle < 128 then
+ begin
+ // Process uncompressed pixel
+ Rle := Rle + 1;
+ CPixel := CPixel + Rle;
+ for I := 0 to Rle - 1 do
+ begin
+ // Copy pixel from src to dest
+ case Bpp of
+ 1: Dest^ := Src^;
+ 2: PWord(Dest)^ := PWord(Src)^;
+ 3: PColor24Rec(Dest)^ := PColor24Rec(Src)^;
+ 4: PLongWord(Dest)^ := PLongWord(Src)^;
+ end;
+ Inc(Src, Bpp);
+ Inc(Dest, Bpp);
+ end;
+ end
+ else
+ begin
+ // Process compressed pixels
+ Rle := Rle - 127;
+ CPixel := CPixel + Rle;
+ // Copy one pixel from src to dest (many times there)
+ for I := 0 to Rle - 1 do
+ begin
+ case Bpp of
+ 1: Dest^ := Src^;
+ 2: PWord(Dest)^ := PWord(Src)^;
+ 3: PColor24Rec(Dest)^ := PColor24Rec(Src)^;
+ 4: PLongWord(Dest)^ := PLongWord(Src)^;
+ end;
+ Inc(Dest, Bpp);
+ end;
+ Inc(Src, Bpp);
+ end;
+ end;
+ // set position in source to real end of compressed data
+ Seek(Handle, -(BufSize - LongInt(LongWord(Src) - LongWord(Buffer))),
+ smFromCurrent);
+ FreeMem(Buffer);
+ end;
+ end;
+
+begin
+ SetLength(Images, 1);
+ with GetIO, Images[0] do
+ begin
+ // Read targa header
+ Read(Handle, @Hdr, SizeOf(Hdr));
+ // Skip image ID info
+ Seek(Handle, Hdr.IDLength, smFromCurrent);
+ // Determine image format
+ Format := ifUnknown;
+ case Hdr.ImageType of
+ 1, 9: Format := ifIndex8;
+ 2, 10: case Hdr.PixelSize of
+ 15: Format := ifX1R5G5B5;
+ 16: Format := ifA1R5G5B5;
+ 24: Format := ifR8G8B8;
+ 32: Format := ifA8R8G8B8;
+ end;
+ 3, 11: Format := ifGray8;
+ end;
+ // Format was not assigned by previous testing (it should be in
+ // well formed targas), so formats which reflects bit dept are selected
+ if Format = ifUnknown then
+ case Hdr.PixelSize of
+ 8: Format := ifGray8;
+ 15: Format := ifX1R5G5B5;
+ 16: Format := ifA1R5G5B5;
+ 24: Format := ifR8G8B8;
+ 32: Format := ifA8R8G8B8;
+ end;
+ NewImage(Hdr.Width, Hdr.Height, Format, Images[0]);
+ FmtInfo := GetFormatInfo(Format);
+
+ if (Hdr.ColorMapType = 1) and (Hdr.ImageType in [1, 9]) then
+ begin
+ // Read palette
+ PSize := Hdr.ColorMapLength * (Hdr.ColorEntrySize shr 3);
+ GetMem(Pal, PSize);
+ try
+ Read(Handle, Pal, PSize);
+ // Process palette
+ PalSize := Iff(Hdr.ColorMapLength > FmtInfo.PaletteEntries,
+ FmtInfo.PaletteEntries, Hdr.ColorMapLength);
+ for I := 0 to PalSize - 1 do
+ case Hdr.ColorEntrySize of
+ 24:
+ with Palette[I] do
+ begin
+ A := $FF;
+ R := PPalette24(Pal)[I].R;
+ G := PPalette24(Pal)[I].G;
+ B := PPalette24(Pal)[I].B;
+ end;
+ // I've never seen tga with these palettes so they are untested
+ 16:
+ with Palette[I] do
+ begin
+ A := (PWordArray(Pal)[I] and $8000) shr 12;
+ R := (PWordArray(Pal)[I] and $FC00) shr 7;
+ G := (PWordArray(Pal)[I] and $03E0) shr 2;
+ B := (PWordArray(Pal)[I] and $001F) shl 3;
+ end;
+ 32:
+ with Palette[I] do
+ begin
+ A := PPalette32(Pal)[I].A;
+ R := PPalette32(Pal)[I].R;
+ G := PPalette32(Pal)[I].G;
+ B := PPalette32(Pal)[I].B;
+ end;
+ end;
+ finally
+ FreeMemNil(Pal);
+ end;
+ end;
+
+ case Hdr.ImageType of
+ 0, 1, 2, 3:
+ // Load uncompressed mode images
+ Read(Handle, Bits, Size);
+ 9, 10, 11:
+ // Load RLE compressed mode images
+ LoadRLE;
+ end;
+
+ // Check if there is alpha channel present in A1R5GB5 images, if it is not
+ // change format to X1R5G5B5
+ if Format = ifA1R5G5B5 then
+ begin
+ if not Has16BitImageAlpha(Width * Height, Bits) then
+ Format := ifX1R5G5B5;
+ end;
+
+ // We must find true end of file and set input' position to it
+ // paint programs appends extra info at the end of Targas
+ // some of them multiple times (PSP Pro 8)
+ repeat
+ ExtFound := False;
+ FooterFound := False;
+
+ if Read(Handle, @WordValue, 2) = 2 then
+ begin
+ // 495 = size of Extension Area
+ if WordValue = 495 then
+ begin
+ Seek(Handle, 493, smFromCurrent);
+ ExtFound := True;
+ end
+ else
+ Seek(Handle, -2, smFromCurrent);
+ end;
+
+ if Read(Handle, @Foo, SizeOf(Foo)) = SizeOf(Foo) then
+ begin
+ if Foo.Signature = STargaSignature then
+ FooterFound := True
+ else
+ Seek(Handle, -SizeOf(Foo), smFromCurrent);
+ end;
+ until (not ExtFound) and (not FooterFound);
+
+ // Some editors save targas flipped
+ if Hdr.Desc < 31 then
+ FlipImage(Images[0]);
+
+ Result := True;
+ end;
+end;
+
+function TTargaFileFormat.SaveData(Handle: TImagingHandle;
+ const Images: TDynImageDataArray; Index: LongInt): Boolean;
+var
+ I: LongInt;
+ Hdr: TTargaHeader;
+ FmtInfo: TImageFormatInfo;
+ Pal: PPalette24;
+ ImageToSave: TImageData;
+ MustBeFreed: Boolean;
+
+ procedure SaveRLE;
+ var
+ Dest: PByte;
+ WidthBytes, Written, I, Total, DestSize: LongInt;
+
+ function CountDiff(Data: PByte; Bpp, PixelCount: Longint): LongInt;
+ var
+ Pixel: LongWord;
+ NextPixel: LongWord;
+ N: LongInt;
+ begin
+ N := 0;
+ Pixel := 0;
+ NextPixel := 0;
+ if PixelCount = 1 then
+ begin
+ Result := PixelCount;
+ Exit;
+ end;
+ case Bpp of
+ 1: Pixel := Data^;
+ 2: Pixel := PWord(Data)^;
+ 3: PColor24Rec(@Pixel)^ := PColor24Rec(Data)^;
+ 4: Pixel := PLongWord(Data)^;
+ end;
+ while PixelCount > 1 do
+ begin
+ Inc(Data, Bpp);
+ case Bpp of
+ 1: NextPixel := Data^;
+ 2: NextPixel := PWord(Data)^;
+ 3: PColor24Rec(@NextPixel)^ := PColor24Rec(Data)^;
+ 4: NextPixel := PLongWord(Data)^;
+ end;
+ if NextPixel = Pixel then
+ Break;
+ Pixel := NextPixel;
+ N := N + 1;
+ PixelCount := PixelCount - 1;
+ end;
+ if NextPixel = Pixel then
+ Result := N
+ else
+ Result := N + 1;
+ end;
+
+ function CountSame(Data: PByte; Bpp, PixelCount: LongInt): LongInt;
+ var
+ Pixel: LongWord;
+ NextPixel: LongWord;
+ N: LongInt;
+ begin
+ N := 1;
+ Pixel := 0;
+ NextPixel := 0;
+ case Bpp of
+ 1: Pixel := Data^;
+ 2: Pixel := PWord(Data)^;
+ 3: PColor24Rec(@Pixel)^ := PColor24Rec(Data)^;
+ 4: Pixel := PLongWord(Data)^;
+ end;
+ PixelCount := PixelCount - 1;
+ while PixelCount > 0 do
+ begin
+ Inc(Data, Bpp);
+ case Bpp of
+ 1: NextPixel := Data^;
+ 2: NextPixel := PWord(Data)^;
+ 3: PColor24Rec(@NextPixel)^ := PColor24Rec(Data)^;
+ 4: NextPixel := PLongWord(Data)^;
+ end;
+ if NextPixel <> Pixel then
+ Break;
+ N := N + 1;
+ PixelCount := PixelCount - 1;
+ end;
+ Result := N;
+ end;
+
+ procedure RleCompressLine(Data: PByte; PixelCount, Bpp: LongInt; Dest:
+ PByte; var Written: LongInt);
+ const
+ MaxRun = 128;
+ var
+ DiffCount: LongInt;
+ SameCount: LongInt;
+ RleBufSize: LongInt;
+ begin
+ RleBufSize := 0;
+ while PixelCount > 0 do
+ begin
+ DiffCount := CountDiff(Data, Bpp, PixelCount);
+ SameCount := CountSame(Data, Bpp, PixelCount);
+ if (DiffCount > MaxRun) then
+ DiffCount := MaxRun;
+ if (SameCount > MaxRun) then
+ SameCount := MaxRun;
+ if (DiffCount > 0) then
+ begin
+ Dest^ := Byte(DiffCount - 1);
+ Inc(Dest);
+ PixelCount := PixelCount - DiffCount;
+ RleBufSize := RleBufSize + (DiffCount * Bpp) + 1;
+ Move(Data^, Dest^, DiffCount * Bpp);
+ Inc(Data, DiffCount * Bpp);
+ Inc(Dest, DiffCount * Bpp);
+ end;
+ if SameCount > 1 then
+ begin
+ Dest^ := Byte((SameCount - 1) or $80);
+ Inc(Dest);
+ PixelCount := PixelCount - SameCount;
+ RleBufSize := RleBufSize + Bpp + 1;
+ Inc(Data, (SameCount - 1) * Bpp);
+ case Bpp of
+ 1: Dest^ := Data^;
+ 2: PWord(Dest)^ := PWord(Data)^;
+ 3: PColor24Rec(Dest)^ := PColor24Rec(Data)^;
+ 4: PLongWord(Dest)^ := PLongWord(Data)^;
+ end;
+ Inc(Data, Bpp);
+ Inc(Dest, Bpp);
+ end;
+ end;
+ Written := RleBufSize;
+ end;
+
+ begin
+ with ImageToSave do
+ begin
+ // Allocate enough space to hold the worst case compression
+ // result and then compress source's scanlines
+ WidthBytes := Width * FmtInfo.BytesPerPixel;
+ DestSize := WidthBytes * Height;
+ DestSize := DestSize + DestSize div 2 + 1;
+ GetMem(Dest, DestSize);
+ Total := 0;
+ try
+ for I := 0 to Height - 1 do
+ begin
+ RleCompressLine(@PByteArray(Bits)[I * WidthBytes], Width,
+ FmtInfo.BytesPerPixel, @PByteArray(Dest)[Total], Written);
+ Total := Total + Written;
+ end;
+ GetIO.Write(Handle, Dest, Total);
+ finally
+ FreeMem(Dest);
+ end;
+ end;
+ end;
+
+begin
+ Result := False;
+ if MakeCompatible(Images[Index], ImageToSave, MustBeFreed) then
+ with GetIO, ImageToSave do
+ try
+ FmtInfo := GetFormatInfo(Format);
+ // Fill targa header
+ FillChar(Hdr, SizeOf(Hdr), 0);
+ Hdr.IDLength := 0;
+ Hdr.ColorMapType := Iff(FmtInfo.PaletteEntries > 0, 1, 0);
+ Hdr.Width := Width;
+ Hdr.Height := Height;
+ Hdr.PixelSize := FmtInfo.BytesPerPixel * 8;
+ Hdr.ColorMapLength := FmtInfo.PaletteEntries;
+ Hdr.ColorEntrySize := Iff(FmtInfo.PaletteEntries > 0, 24, 0);
+ Hdr.ColorMapOff := 0;
+ // This indicates that targa is stored in top-left format
+ // as our images -> no flipping is needed.
+ Hdr.Desc := 32;
+ // Set alpha channel size in descriptor (mostly ignored by other software though)
+ if Format = ifA8R8G8B8 then
+ Hdr.Desc := Hdr.Desc or 8
+ else if Format = ifA1R5G5B5 then
+ Hdr.Desc := Hdr.Desc or 1;
+
+ // Choose image type
+ if FmtInfo.IsIndexed then
+ Hdr.ImageType := Iff(FUseRLE, 9, 1)
+ else
+ if FmtInfo.HasGrayChannel then
+ Hdr.ImageType := Iff(FUseRLE, 11, 3)
+ else
+ Hdr.ImageType := Iff(FUseRLE, 10, 2);
+
+ Write(Handle, @Hdr, SizeOf(Hdr));
+
+ // Write palette
+ if FmtInfo.PaletteEntries > 0 then
+ begin
+ GetMem(Pal, FmtInfo.PaletteEntries * SizeOf(TColor24Rec));
+ try
+ for I := 0 to FmtInfo.PaletteEntries - 1 do
+ with Pal[I] do
+ begin
+ R := Palette[I].R;
+ G := Palette[I].G;
+ B := Palette[I].B;
+ end;
+ Write(Handle, Pal, FmtInfo.PaletteEntries * SizeOf(TColor24Rec));
+ finally
+ FreeMemNil(Pal);
+ end;
+ end;
+
+ if FUseRLE then
+ // Save rle compressed mode images
+ SaveRLE
+ else
+ // Save uncompressed mode images
+ Write(Handle, Bits, Size);
+
+ Result := True;
+ finally
+ if MustBeFreed then
+ FreeImage(ImageToSave);
+ end;
+end;
+
+procedure TTargaFileFormat.ConvertToSupported(var Image: TImageData;
+ const Info: TImageFormatInfo);
+var
+ ConvFormat: TImageFormat;
+begin
+ if Info.HasGrayChannel then
+ // Convert all grayscale images to Gray8 (preserve alpha of AxGrayx formats)
+ ConvFormat := IffFormat(not Info.HasAlphaChannel, ifGray8, ifA8R8G8B8)
+ else if Info.IsIndexed then
+ // Convert all indexed images to Index8
+ ConvFormat := ifIndex8
+ else if Info.HasAlphaChannel then
+ // Convert images with alpha channel to A8R8G8B8
+ ConvFormat := ifA8R8G8B8
+ else if Info.UsePixelFormat then
+ // Convert 16bit images (without alpha channel) to A1R5G5B5
+ ConvFormat := ifA1R5G5B5
+ else
+ // Convert all other formats to R8G8B8
+ ConvFormat := ifR8G8B8;
+
+ ConvertImage(Image, ConvFormat);
+end;
+
+function TTargaFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
+var
+ Hdr: TTargaHeader;
+ ReadCount: LongInt;
+begin
+ Result := False;
+ if Handle <> nil then
+ begin
+ ReadCount := GetIO.Read(Handle, @Hdr, SizeOf(Hdr));
+ GetIO.Seek(Handle, -ReadCount, smFromCurrent);
+ Result := (ReadCount >= SizeOf(Hdr)) and
+ (Hdr.ImageType in [0, 1, 2, 3, 9, 10, 11]) and
+ (Hdr.PixelSize in [1, 8, 15, 16, 24, 32]) and
+ (Hdr.ColorEntrySize in [0, 16, 24, 32]);
+ end;
+end;
+
+initialization
+ RegisterImageFileFormat(TTargaFileFormat);
+
+{
+ File Notes:
+
+ -- TODOS ----------------------------------------------------
+ - nothing now
+
+ -- 0.21 Changes/Bug Fixes -----------------------------------
+ - MakeCompatible method moved to base class, put ConvertToSupported here.
+ GetSupportedFormats removed, it is now set in constructor.
+ - Made public properties for options registered to SetOption/GetOption
+ functions.
+ - Changed extensions to filename masks.
+ - Changed SaveData, LoadData, and MakeCompatible methods according
+ to changes in base class in Imaging unit.
+
+ -- 0.17 Changes/Bug Fixes -----------------------------------
+ - 16 bit images are usually without alpha but some has alpha
+ channel and there is no indication of it - so I have added
+ a check: if all pixels of image are with alpha = 0 image is treated
+ as X1R5G5B5 otherwise as A1R5G5B5
+ - fixed problems with some nonstandard 15 bit images
+}
+
+end.
+
diff --git a/Imaging/ImagingTypes.pas b/Imaging/ImagingTypes.pas
index 91bb794..abdcdc8 100644
--- a/Imaging/ImagingTypes.pas
+++ b/Imaging/ImagingTypes.pas
@@ -1,499 +1,499 @@
-{
- $Id: ImagingTypes.pas 171 2009-09-02 01:34:19Z galfar $
- Vampyre Imaging Library
- by Marek Mauder
- http://imaginglib.sourceforge.net
-
- The contents of this file are used with permission, subject to the Mozilla
- Public License Version 1.1 (the "License"); you may not use this file except
- in compliance with the License. You may obtain a copy of the License at
- http://www.mozilla.org/MPL/MPL-1.1.html
-
- Software distributed under the License is distributed on an "AS IS" basis,
- WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
- the specific language governing rights and limitations under the License.
-
- Alternatively, the contents of this file may be used under the terms of the
- GNU Lesser General Public License (the "LGPL License"), in which case the
- provisions of the LGPL License are applicable instead of those above.
- If you wish to allow use of your version of this file only under the terms
- of the LGPL License and not to allow others to use your version of this file
- under the MPL, indicate your decision by deleting the provisions above and
- replace them with the notice and other provisions required by the LGPL
- License. If you do not delete the provisions above, a recipient may use
- your version of this file under either the MPL or the LGPL License.
-
- For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
-}
-
-{ This unit contains basic types and constants used by Imaging library.}
-unit ImagingTypes;
-
-{$I ImagingOptions.inc}
-
-interface
-
-const
- { Current Major version of Imaging.}
- ImagingVersionMajor = 0;
- { Current Minor version of Imaging.}
- ImagingVersionMinor = 26;
- { Current patch of Imaging.}
- ImagingVersionPatch = 4;
-
- { Imaging Option Ids whose values can be set/get by SetOption/
- GetOption functions.}
-
- { Defines Jpeg compression quality, ranges from 1 (ugly/small) to 100 (nice/large).
- Default value is 90.}
- ImagingJpegQuality = 10;
- { Specifies whether Jpeg images are saved in progressive format,
- can be 0 or 1. Default value is 0.}
- ImagingJpegProgressive = 11;
-
- { Specifies whether Windows Bitmaps are saved using RLE compression
- (only for 1/4/8 bit images), can be 0 or 1. Default value is 1.}
- ImagingBitmapRLE = 12;
-
- { Specifies whether Targa images are saved using RLE compression,
- can be 0 or 1. Default value is 0.}
- ImagingTargaRLE = 13;
-
- { Value of this option is non-zero if last loaded DDS file was cube map.}
- ImagingDDSLoadedCubeMap = 14;
- { Value of this option is non-zero if last loaded DDS file was volume texture.}
- ImagingDDSLoadedVolume = 15;
- { Value of this option is number of mipmap levels of last loaded DDS image.}
- ImagingDDSLoadedMipMapCount = 16;
- { Value of this option is depth (slices of volume texture or faces of
- cube map) of last loaded DDS image.}
- ImagingDDSLoadedDepth = 17;
- { If it is non-zero next saved DDS file should be stored as cube map.}
- ImagingDDSSaveCubeMap = 18;
- { If it is non-zero next saved DDS file should be stored as volume texture.}
- ImagingDDSSaveVolume = 19;
- { Sets the number of mipmaps which should be stored in the next saved DDS file.
- Only applies to cube maps and volumes, ordinary 2D textures save all
- levels present in input.}
- ImagingDDSSaveMipMapCount = 20;
- { Sets the depth (slices of volume texture or faces of cube map)
- of the next saved DDS file.}
- ImagingDDSSaveDepth = 21;
-
- { Sets precompression filter used when saving PNG images. Allowed values
- are: 0 (none), 1 (sub), 2 (up), 3 (average), 4 (paeth),
- 5 (use 0 for indexed/gray images and 4 for RGB/ARGB images),
- 6 (adaptive filtering - use best filter for each scanline - very slow).
- Note that filters 3 and 4 are much slower than filters 1 and 2.
- Default value is 5.}
- ImagingPNGPreFilter = 25;
- { Sets ZLib compression level used when saving PNG images.
- Allowed values are in range 0 (no compresstion) to 9 (best compression).
- Default value is 5.}
- ImagingPNGCompressLevel = 26;
- { Boolean option that specifies whether PNG images with more frames (APNG format)
- are animated by Imaging (according to frame disposal/blend methods) or just
- raw frames are loaded and sent to user (if you want to animate APNG yourself).
- Default value is 1.}
- ImagingPNGLoadAnimated = 27;
-
- { Specifies whether MNG animation frames are saved with lossy or lossless
- compression. Lossless frames are saved as PNG images and lossy frames are
- saved as JNG images. Allowed values are 0 (False) and 1 (True).
- Default value is 0.}
- ImagingMNGLossyCompression = 28;
- { Defines whether alpha channel of lossy compressed MNG frames
- (when ImagingMNGLossyCompression is 1) is lossy compressed too.
- Allowed values are 0 (False) and 1 (True). Default value is 0.}
- ImagingMNGLossyAlpha = 29;
- { Sets precompression filter used when saving MNG frames as PNG images.
- For details look at ImagingPNGPreFilter.}
- ImagingMNGPreFilter = 30;
- { Sets ZLib compression level used when saving MNG frames as PNG images.
- For details look at ImagingPNGCompressLevel.}
- ImagingMNGCompressLevel = 31;
- { Specifies compression quality used when saving MNG frames as JNG images.
- For details look at ImagingJpegQuality.}
- ImagingMNGQuality = 32;
- { Specifies whether images are saved in progressive format when saving MNG
- frames as JNG images. For details look at ImagingJpegProgressive.}
- ImagingMNGProgressive = 33;
-
- { Specifies whether alpha channels of JNG images are lossy compressed.
- Allowed values are 0 (False) and 1 (True). Default value is 0.}
- ImagingJNGLossyAlpha = 40;
- { Sets precompression filter used when saving lossless alpha channels.
- For details look at ImagingPNGPreFilter.}
- ImagingJNGAlphaPreFilter = 41;
- { Sets ZLib compression level used when saving lossless alpha channels.
- For details look at ImagingPNGCompressLevel.}
- ImagingJNGAlphaCompressLevel = 42;
- { Defines compression quality used when saving JNG images (and lossy alpha channels).
- For details look at ImagingJpegQuality.}
- ImagingJNGQuality = 43;
- { Specifies whether JNG images are saved in progressive format.
- For details look at ImagingJpegProgressive.}
- ImagingJNGProgressive = 44;
- { Specifies whether PGM files are stored in text or in binary format.
- Allowed values are 0 (store as text - very! large files) and 1 (save binary).
- Default value is 1.}
- ImagingPGMSaveBinary = 50;
- { Specifies whether PPM files are stored in text or in binary format.
- Allowed values are 0 (store as text - very! large files) and 1 (save binary).
- Default value is 1.}
- ImagingPPMSaveBinary = 51;
- { Boolean option that specifies whether GIF images with more frames
- are animated by Imaging (according to frame disposal methods) or just
- raw frames are loaded and sent to user (if you want to animate GIF yourself).
- Default value is 1.
- Raw frames are 256 color indexed images (ifIndex8), whereas
- animated frames are always in 32bit ifA8R8G8B8 format (simplifies animating).}
- ImagingGIFLoadAnimated = 56;
-
- { This option is used when reducing number of colors used in
- image (mainly when converting from ARGB image to indexed
- format). Mask is 'anded' (bitwise AND) with every pixel's
- channel value when creating color histogram. If $FF is used
- all 8bits of color channels are used which can result in very
- slow proccessing of large images with many colors so you can
- use lower masks to speed it up (FC, F8 and F0 are good
- choices). Allowed values are in range <0, $FF> and default is
- $FE. }
- ImagingColorReductionMask = 128;
- { This option can be used to override image data format during image
- loading. If set to format different from ifUnknown all loaded images
- are automaticaly converted to this format. Useful when you have
- many files in various formats but you want them all in one format for
- further proccessing. Allowed values are in
- range and
- default value is ifUnknown.}
- ImagingLoadOverrideFormat = 129;
- { This option can be used to override image data format during image
- saving. If set to format different from ifUnknown all images
- to be saved are automaticaly internaly converted to this format.
- Note that image file formats support only a subset of Imaging data formats
- so final saved file may in different format than this override.
- Allowed values are in range
- and default value is ifUnknown.}
- ImagingSaveOverrideFormat = 130;
- { Specifies resampling filter used when generating mipmaps. It is used
- in GenerateMipMaps low level function and Direct3D and OpenGL extensions.
- Allowed values are in range
-
- and default value is 1 (linear filter).}
- ImagingMipMapFilter = 131;
-
- { Returned by GetOption if given Option Id is invalid.}
- InvalidOption = -$7FFFFFFF;
-
- { Indices that can be used to access channel values in array parts
- of structures like TColor32Rec. Note that this order can be
- used only for ARGB images. For ABGR image you must swap Red and Blue.}
- ChannelBlue = 0;
- ChannelGreen = 1;
- ChannelRed = 2;
- ChannelAlpha = 3;
-
-type
- { Enum defining image data format. In formats with more channels,
- first channel after "if" is stored in the most significant bits and channel
- before end is stored in the least significant.}
- TImageFormat = (
- ifUnknown = 0,
- ifDefault = 1,
- { Indexed formats using palette.}
- ifIndex8 = 10,
- { Grayscale/Luminance formats.}
- ifGray8 = 40,
- ifA8Gray8 = 41,
- ifGray16 = 42,
- ifGray32 = 43,
- ifGray64 = 44,
- ifA16Gray16 = 45,
- { ARGB formats.}
- ifX5R1G1B1 = 80,
- ifR3G3B2 = 81,
- ifR5G6B5 = 82,
- ifA1R5G5B5 = 83,
- ifA4R4G4B4 = 84,
- ifX1R5G5B5 = 85,
- ifX4R4G4B4 = 86,
- ifR8G8B8 = 87,
- ifA8R8G8B8 = 88,
- ifX8R8G8B8 = 89,
- ifR16G16B16 = 90,
- ifA16R16G16B16 = 91,
- ifB16G16R16 = 92,
- ifA16B16G16R16 = 93,
- { Floating point formats.}
- ifR32F = 170,
- ifA32R32G32B32F = 171,
- ifA32B32G32R32F = 172,
- ifR16F = 173,
- ifA16R16G16B16F = 174,
- ifA16B16G16R16F = 175,
- { Special formats.}
- ifDXT1 = 220,
- ifDXT3 = 221,
- ifDXT5 = 222,
- ifBTC = 223,
- ifATI1N = 224,
- ifATI2N = 225);
-
- { Color value for 32 bit images.}
- TColor32 = LongWord;
- PColor32 = ^TColor32;
-
- { Color value for 64 bit images.}
- TColor64 = type Int64;
- PColor64 = ^TColor64;
-
- { Color record for 24 bit images, which allows access to individual color
- channels.}
- TColor24Rec = packed record
- case LongInt of
- 0: (B, G, R: Byte);
- 1: (Channels: array[0..2] of Byte);
- end;
- PColor24Rec = ^TColor24Rec;
- TColor24RecArray = array[0..MaxInt div SizeOf(TColor24Rec) - 1] of TColor24Rec;
- PColor24RecArray = ^TColor24RecArray;
-
- { Color record for 32 bit images, which allows access to individual color
- channels.}
- TColor32Rec = packed record
- case LongInt of
- 0: (Color: TColor32);
- 1: (B, G, R, A: Byte);
- 2: (Channels: array[0..3] of Byte);
- 3: (Color24Rec: TColor24Rec);
- end;
- PColor32Rec = ^TColor32Rec;
- TColor32RecArray = array[0..MaxInt div SizeOf(TColor32Rec) - 1] of TColor32Rec;
- PColor32RecArray = ^TColor32RecArray;
-
- { Color record for 48 bit images, which allows access to individual color
- channels.}
- TColor48Rec = packed record
- case LongInt of
- 0: (B, G, R: Word);
- 1: (Channels: array[0..2] of Word);
- end;
- PColor48Rec = ^TColor48Rec;
- TColor48RecArray = array[0..MaxInt div SizeOf(TColor48Rec) - 1] of TColor48Rec;
- PColor48RecArray = ^TColor48RecArray;
-
- { Color record for 64 bit images, which allows access to individual color
- channels.}
- TColor64Rec = packed record
- case LongInt of
- 0: (Color: TColor64);
- 1: (B, G, R, A: Word);
- 2: (Channels: array[0..3] of Word);
- 3: (Color48Rec: TColor48Rec);
- end;
- PColor64Rec = ^TColor64Rec;
- TColor64RecArray = array[0..MaxInt div SizeOf(TColor64Rec) - 1] of TColor64Rec;
- PColor64RecArray = ^TColor64RecArray;
-
- { Color record for 128 bit floating point images, which allows access to
- individual color channels.}
- TColorFPRec = packed record
- case LongInt of
- 0: (B, G, R, A: Single);
- 1: (Channels: array[0..3] of Single);
- end;
- PColorFPRec = ^TColorFPRec;
- TColorFPRecArray = array[0..MaxInt div SizeOf(TColorFPRec) - 1] of TColorFPRec;
- PColorFPRecArray = ^TColorFPRecArray;
-
- { 16 bit floating-point value. It has 1 sign bit, 5 exponent bits,
- and 10 mantissa bits.}
- THalfFloat = type Word;
- PHalfFloat = ^THalfFloat;
-
- { Color record for 64 bit floating point images, which allows access to
- individual color channels.}
- TColorHFRec = packed record
- case LongInt of
- 0: (B, G, R, A: THalfFloat);
- 1: (Channels: array[0..3] of THalfFloat);
- end;
- PColorHFRec = ^TColorHFRec;
- TColorHFRecArray = array[0..MaxInt div SizeOf(TColorHFRec) - 1] of TColorHFRec;
- PColorHFRecArray = ^TColorHFRecArray;
-
- { Palette for indexed mode images with 32 bit colors.}
- TPalette32 = TColor32RecArray;
- TPalette32Size256 = array[0..255] of TColor32Rec;
- PPalette32 = ^TPalette32;
-
- { Palette for indexd mode images with 24 bit colors.}
- TPalette24 = TColor24RecArray;
- TPalette24Size256 = array[0..255] of TColor24Rec;
- PPalette24 = ^TPalette24;
-
- { Record that stores single image data and information describing it.}
- TImageData = packed record
- Width: LongInt; // Width of image in pixels
- Height: LongInt; // Height of image in pixels
- Format: TImageFormat; // Data format of image
- Size: LongInt; // Size of image bits in Bytes
- Bits: Pointer; // Pointer to memory containing image bits
- Palette: PPalette32; // Image palette for indexed images
- end;
- PImageData = ^TImageData;
-
- { Pixel format information used in conversions to/from 16 and 8 bit ARGB
- image formats.}
- TPixelFormatInfo = packed record
- ABitCount, RBitCount, GBitCount, BBitCount: Byte;
- ABitMask, RBitMask, GBitMask, BBitMask: LongWord;
- AShift, RShift, GShift, BShift: Byte;
- ARecDiv, RRecDiv, GRecDiv, BRecDiv: Byte;
- end;
- PPixelFormatInfo = ^TPixelFormatInfo;
-
- PImageFormatInfo = ^TImageFormatInfo;
-
- { Look at TImageFormatInfo.GetPixelsSize for details.}
- TFormatGetPixelsSizeFunc = function(Format: TImageFormat; Width,
- Height: LongInt): LongInt;
- { Look at TImageFormatInfo.CheckDimensions for details.}
- TFormatCheckDimensionsProc = procedure(Format: TImageFormat; var Width,
- Height: LongInt);
- { Function for getting pixel colors. Native pixel is read from Image and
- then translated to 32 bit ARGB.}
- TGetPixel32Func = function(Bits: Pointer; Info: PImageFormatInfo;
- Palette: PPalette32): TColor32Rec;
- { Function for getting pixel colors. Native pixel is read from Image and
- then translated to FP ARGB.}
- TGetPixelFPFunc = function(Bits: Pointer; Info: PImageFormatInfo;
- Palette: PPalette32): TColorFPRec;
- { Procedure for setting pixel colors. Input 32 bit ARGB color is translated to
- native format and then written to Image.}
- TSetPixel32Proc = procedure(Bits: Pointer; Info: PImageFormatInfo;
- Palette: PPalette32;const Color: TColor32Rec);
- { Procedure for setting pixel colors. Input FP ARGB color is translated to
- native format and then written to Image.}
- TSetPixelFPProc = procedure(Bits: Pointer; Info: PImageFormatInfo;
- Palette: PPalette32; const Color: TColorFPRec);
-
- { Additional information for each TImageFormat value.}
- TImageFormatInfo = packed record
- Format: TImageFormat; // Format described by this record
- Name: array[0..15] of Char; // Symbolic name of format
- BytesPerPixel: LongInt; // Number of bytes per pixel (note: it is
- // 0 for formats where BitsPerPixel < 8 (e.g. DXT).
- // Use GetPixelsSize function to get size of
- // image data.
- ChannelCount: LongInt; // Number of image channels (R, G, B, A, Gray)
- PaletteEntries: LongInt; // Number of palette entries
- HasGrayChannel: Boolean; // True if image has grayscale channel
- HasAlphaChannel: Boolean; // True if image has alpha channel
- IsFloatingPoint: Boolean; // True if image has floating point pixels
- UsePixelFormat: Boolean; // True if image uses pixel format
- IsRBSwapped: Boolean; // True if Red and Blue channels are swapped
- // e.g. A16B16G16R16 has IsRBSwapped True
- RBSwapFormat: TImageFormat; // Indicates supported format with swapped
- // Red and Blue channels, ifUnknown if such
- // format does not exist
- IsIndexed: Boolean; // True if image uses palette
- IsSpecial: Boolean; // True if image is in special format
- PixelFormat: PPixelFormatInfo; // Pixel format structure
- GetPixelsSize: TFormatGetPixelsSizeFunc; // Returns size in bytes of
- // Width * Height pixels of image
- CheckDimensions: TFormatCheckDimensionsProc; // some formats have limited
- // values of Width and Height. This
- // procedure checks and changes dimensions
- // to be valid for given format.
- GetPixel32: TGetPixel32Func; // 32bit ARGB pixel get function
- GetPixelFP: TGetPixelFPFunc; // FP ARGB pixel get function
- SetPixel32: TSetPixel32Proc; // 32bit ARGB pixel set procedure
- SetPixelFP: TSetPixelFPProc; // FP ARGB pixel set procedure
- SpecialNearestFormat: TImageFormat; // Regular image format used when
- // compressing/decompressing special images
- // as source/target
- end;
-
- { Handle to list of image data records.}
- TImageDataList = Pointer;
- PImageDataList = ^TImageDataList;
-
- { Handle to input/output.}
- TImagingHandle = Pointer;
-
- { Filters used in functions that resize images or their portions.}
- TResizeFilter = (
- rfNearest = 0,
- rfBilinear = 1,
- rfBicubic = 2);
-
- { Seek origin mode for IO function Seek.}
- TSeekMode = (
- smFromBeginning = 0,
- smFromCurrent = 1,
- smFromEnd = 2);
-
- { IO functions used for reading and writing images from/to input/output.}
- TOpenReadProc = function(Source: PChar): TImagingHandle; cdecl;
- TOpenWriteProc = function(Source: PChar): TImagingHandle; cdecl;
- TCloseProc = procedure(Handle: TImagingHandle); cdecl;
- TEofProc = function(Handle: TImagingHandle): Boolean; cdecl;
- TSeekProc = function(Handle: TImagingHandle; Offset: LongInt; Mode: TSeekMode): LongInt; cdecl;
- TTellProc = function(Handle: TImagingHandle): LongInt; cdecl;
- TReadProc = function(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt): LongInt; cdecl;
- TWriteProc = function(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt): LongInt; cdecl;
-
-implementation
-
-{
- File Notes:
-
- -- TODOS ----------------------------------------------------
- - add lookup tables to pixel formats for fast conversions
-
- -- 0.24.3 Changes/Bug Fixes ---------------------------------
- - Added ifATI1N and ifATI2N image data formats.
-
- -- 0.23 Changes/Bug Fixes -----------------------------------
- - Added ifBTC image format and SpecialNearestFormat field
- to TImageFormatInfo.
-
- -- 0.21 Changes/Bug Fixes -----------------------------------
- - Added option constants for PGM and PPM file formats.
- - Added TPalette32Size256 and TPalette24Size256 types.
-
- -- 0.19 Changes/Bug Fixes -----------------------------------
- - added ImagingVersionPatch constant so bug fix only releases
- can be distinguished from ordinary major/minor releases
- - renamed TPixelFormat to TPixelFormatInfo to avoid name collisions
- with Graphics.TPixelFormat
- - added new image data formats: ifR16F, ifA16R16G16B16F,
- ifA16B16G16R16F
- - added pixel get/set function pointers to TImageFormatInfo
- - added 16bit half float type and color record
- - renamed TColorFRec to TColorFPRec (and related types too)
-
- -- 0.17 Changes/Bug Fixes -----------------------------------
- - added option ImagingMipMapFilter which now controls resampling filter
- used when generating mipmaps
- - added TResizeFilter type
- - added ChannelCount to TImageFormatInfo
- - added new option constants for MNG and JNG images
-
- -- 0.15 Changes/Bug Fixes -----------------------------------
- - added RBSwapFormat to TImageFormatInfo for faster conversions
- between swapped formats (it just calls SwapChannels now if
- RBSwapFormat is not ifUnknown)
- - moved TImageFormatInfo and required types from Imaging unit
- here, removed TImageFormatShortInfo
- - added new options: ImagingLoadOverrideFormat, ImagingSaveOverrideFormat
-
- -- 0.13 Changes/Bug Fixes -----------------------------------
- - new ImagingColorReductionMask option added
- - new image format added: ifA16Gray16
-
-}
-
-end.
+{
+ $Id: ImagingTypes.pas 171 2009-09-02 01:34:19Z galfar $
+ Vampyre Imaging Library
+ by Marek Mauder
+ http://imaginglib.sourceforge.net
+
+ The contents of this file are used with permission, subject to the Mozilla
+ Public License Version 1.1 (the "License"); you may not use this file except
+ in compliance with the License. You may obtain a copy of the License at
+ http://www.mozilla.org/MPL/MPL-1.1.html
+
+ Software distributed under the License is distributed on an "AS IS" basis,
+ WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for
+ the specific language governing rights and limitations under the License.
+
+ Alternatively, the contents of this file may be used under the terms of the
+ GNU Lesser General Public License (the "LGPL License"), in which case the
+ provisions of the LGPL License are applicable instead of those above.
+ If you wish to allow use of your version of this file only under the terms
+ of the LGPL License and not to allow others to use your version of this file
+ under the MPL, indicate your decision by deleting the provisions above and
+ replace them with the notice and other provisions required by the LGPL
+ License. If you do not delete the provisions above, a recipient may use
+ your version of this file under either the MPL or the LGPL License.
+
+ For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
+}
+
+{ This unit contains basic types and constants used by Imaging library.}
+unit ImagingTypes;
+
+{$I ImagingOptions.inc}
+
+interface
+
+const
+ { Current Major version of Imaging.}
+ ImagingVersionMajor = 0;
+ { Current Minor version of Imaging.}
+ ImagingVersionMinor = 26;
+ { Current patch of Imaging.}
+ ImagingVersionPatch = 4;
+
+ { Imaging Option Ids whose values can be set/get by SetOption/
+ GetOption functions.}
+
+ { Defines Jpeg compression quality, ranges from 1 (ugly/small) to 100 (nice/large).
+ Default value is 90.}
+ ImagingJpegQuality = 10;
+ { Specifies whether Jpeg images are saved in progressive format,
+ can be 0 or 1. Default value is 0.}
+ ImagingJpegProgressive = 11;
+
+ { Specifies whether Windows Bitmaps are saved using RLE compression
+ (only for 1/4/8 bit images), can be 0 or 1. Default value is 1.}
+ ImagingBitmapRLE = 12;
+
+ { Specifies whether Targa images are saved using RLE compression,
+ can be 0 or 1. Default value is 0.}
+ ImagingTargaRLE = 13;
+
+ { Value of this option is non-zero if last loaded DDS file was cube map.}
+ ImagingDDSLoadedCubeMap = 14;
+ { Value of this option is non-zero if last loaded DDS file was volume texture.}
+ ImagingDDSLoadedVolume = 15;
+ { Value of this option is number of mipmap levels of last loaded DDS image.}
+ ImagingDDSLoadedMipMapCount = 16;
+ { Value of this option is depth (slices of volume texture or faces of
+ cube map) of last loaded DDS image.}
+ ImagingDDSLoadedDepth = 17;
+ { If it is non-zero next saved DDS file should be stored as cube map.}
+ ImagingDDSSaveCubeMap = 18;
+ { If it is non-zero next saved DDS file should be stored as volume texture.}
+ ImagingDDSSaveVolume = 19;
+ { Sets the number of mipmaps which should be stored in the next saved DDS file.
+ Only applies to cube maps and volumes, ordinary 2D textures save all
+ levels present in input.}
+ ImagingDDSSaveMipMapCount = 20;
+ { Sets the depth (slices of volume texture or faces of cube map)
+ of the next saved DDS file.}
+ ImagingDDSSaveDepth = 21;
+
+ { Sets precompression filter used when saving PNG images. Allowed values
+ are: 0 (none), 1 (sub), 2 (up), 3 (average), 4 (paeth),
+ 5 (use 0 for indexed/gray images and 4 for RGB/ARGB images),
+ 6 (adaptive filtering - use best filter for each scanline - very slow).
+ Note that filters 3 and 4 are much slower than filters 1 and 2.
+ Default value is 5.}
+ ImagingPNGPreFilter = 25;
+ { Sets ZLib compression level used when saving PNG images.
+ Allowed values are in range 0 (no compresstion) to 9 (best compression).
+ Default value is 5.}
+ ImagingPNGCompressLevel = 26;
+ { Boolean option that specifies whether PNG images with more frames (APNG format)
+ are animated by Imaging (according to frame disposal/blend methods) or just
+ raw frames are loaded and sent to user (if you want to animate APNG yourself).
+ Default value is 1.}
+ ImagingPNGLoadAnimated = 27;
+
+ { Specifies whether MNG animation frames are saved with lossy or lossless
+ compression. Lossless frames are saved as PNG images and lossy frames are
+ saved as JNG images. Allowed values are 0 (False) and 1 (True).
+ Default value is 0.}
+ ImagingMNGLossyCompression = 28;
+ { Defines whether alpha channel of lossy compressed MNG frames
+ (when ImagingMNGLossyCompression is 1) is lossy compressed too.
+ Allowed values are 0 (False) and 1 (True). Default value is 0.}
+ ImagingMNGLossyAlpha = 29;
+ { Sets precompression filter used when saving MNG frames as PNG images.
+ For details look at ImagingPNGPreFilter.}
+ ImagingMNGPreFilter = 30;
+ { Sets ZLib compression level used when saving MNG frames as PNG images.
+ For details look at ImagingPNGCompressLevel.}
+ ImagingMNGCompressLevel = 31;
+ { Specifies compression quality used when saving MNG frames as JNG images.
+ For details look at ImagingJpegQuality.}
+ ImagingMNGQuality = 32;
+ { Specifies whether images are saved in progressive format when saving MNG
+ frames as JNG images. For details look at ImagingJpegProgressive.}
+ ImagingMNGProgressive = 33;
+
+ { Specifies whether alpha channels of JNG images are lossy compressed.
+ Allowed values are 0 (False) and 1 (True). Default value is 0.}
+ ImagingJNGLossyAlpha = 40;
+ { Sets precompression filter used when saving lossless alpha channels.
+ For details look at ImagingPNGPreFilter.}
+ ImagingJNGAlphaPreFilter = 41;
+ { Sets ZLib compression level used when saving lossless alpha channels.
+ For details look at ImagingPNGCompressLevel.}
+ ImagingJNGAlphaCompressLevel = 42;
+ { Defines compression quality used when saving JNG images (and lossy alpha channels).
+ For details look at ImagingJpegQuality.}
+ ImagingJNGQuality = 43;
+ { Specifies whether JNG images are saved in progressive format.
+ For details look at ImagingJpegProgressive.}
+ ImagingJNGProgressive = 44;
+ { Specifies whether PGM files are stored in text or in binary format.
+ Allowed values are 0 (store as text - very! large files) and 1 (save binary).
+ Default value is 1.}
+ ImagingPGMSaveBinary = 50;
+ { Specifies whether PPM files are stored in text or in binary format.
+ Allowed values are 0 (store as text - very! large files) and 1 (save binary).
+ Default value is 1.}
+ ImagingPPMSaveBinary = 51;
+ { Boolean option that specifies whether GIF images with more frames
+ are animated by Imaging (according to frame disposal methods) or just
+ raw frames are loaded and sent to user (if you want to animate GIF yourself).
+ Default value is 1.
+ Raw frames are 256 color indexed images (ifIndex8), whereas
+ animated frames are always in 32bit ifA8R8G8B8 format (simplifies animating).}
+ ImagingGIFLoadAnimated = 56;
+
+ { This option is used when reducing number of colors used in
+ image (mainly when converting from ARGB image to indexed
+ format). Mask is 'anded' (bitwise AND) with every pixel's
+ channel value when creating color histogram. If $FF is used
+ all 8bits of color channels are used which can result in very
+ slow proccessing of large images with many colors so you can
+ use lower masks to speed it up (FC, F8 and F0 are good
+ choices). Allowed values are in range <0, $FF> and default is
+ $FE. }
+ ImagingColorReductionMask = 128;
+ { This option can be used to override image data format during image
+ loading. If set to format different from ifUnknown all loaded images
+ are automaticaly converted to this format. Useful when you have
+ many files in various formats but you want them all in one format for
+ further proccessing. Allowed values are in
+ range and
+ default value is ifUnknown.}
+ ImagingLoadOverrideFormat = 129;
+ { This option can be used to override image data format during image
+ saving. If set to format different from ifUnknown all images
+ to be saved are automaticaly internaly converted to this format.
+ Note that image file formats support only a subset of Imaging data formats
+ so final saved file may in different format than this override.
+ Allowed values are in range
+ and default value is ifUnknown.}
+ ImagingSaveOverrideFormat = 130;
+ { Specifies resampling filter used when generating mipmaps. It is used
+ in GenerateMipMaps low level function and Direct3D and OpenGL extensions.
+ Allowed values are in range
+
+ and default value is 1 (linear filter).}
+ ImagingMipMapFilter = 131;
+
+ { Returned by GetOption if given Option Id is invalid.}
+ InvalidOption = -$7FFFFFFF;
+
+ { Indices that can be used to access channel values in array parts
+ of structures like TColor32Rec. Note that this order can be
+ used only for ARGB images. For ABGR image you must swap Red and Blue.}
+ ChannelBlue = 0;
+ ChannelGreen = 1;
+ ChannelRed = 2;
+ ChannelAlpha = 3;
+
+type
+ { Enum defining image data format. In formats with more channels,
+ first channel after "if" is stored in the most significant bits and channel
+ before end is stored in the least significant.}
+ TImageFormat = (
+ ifUnknown = 0,
+ ifDefault = 1,
+ { Indexed formats using palette.}
+ ifIndex8 = 10,
+ { Grayscale/Luminance formats.}
+ ifGray8 = 40,
+ ifA8Gray8 = 41,
+ ifGray16 = 42,
+ ifGray32 = 43,
+ ifGray64 = 44,
+ ifA16Gray16 = 45,
+ { ARGB formats.}
+ ifX5R1G1B1 = 80,
+ ifR3G3B2 = 81,
+ ifR5G6B5 = 82,
+ ifA1R5G5B5 = 83,
+ ifA4R4G4B4 = 84,
+ ifX1R5G5B5 = 85,
+ ifX4R4G4B4 = 86,
+ ifR8G8B8 = 87,
+ ifA8R8G8B8 = 88,
+ ifX8R8G8B8 = 89,
+ ifR16G16B16 = 90,
+ ifA16R16G16B16 = 91,
+ ifB16G16R16 = 92,
+ ifA16B16G16R16 = 93,
+ { Floating point formats.}
+ ifR32F = 170,
+ ifA32R32G32B32F = 171,
+ ifA32B32G32R32F = 172,
+ ifR16F = 173,
+ ifA16R16G16B16F = 174,
+ ifA16B16G16R16F = 175,
+ { Special formats.}
+ ifDXT1 = 220,
+ ifDXT3 = 221,
+ ifDXT5 = 222,
+ ifBTC = 223,
+ ifATI1N = 224,
+ ifATI2N = 225);
+
+ { Color value for 32 bit images.}
+ TColor32 = LongWord;
+ PColor32 = ^TColor32;
+
+ { Color value for 64 bit images.}
+ TColor64 = type Int64;
+ PColor64 = ^TColor64;
+
+ { Color record for 24 bit images, which allows access to individual color
+ channels.}
+ TColor24Rec = packed record
+ case LongInt of
+ 0: (B, G, R: Byte);
+ 1: (Channels: array[0..2] of Byte);
+ end;
+ PColor24Rec = ^TColor24Rec;
+ TColor24RecArray = array[0..MaxInt div SizeOf(TColor24Rec) - 1] of TColor24Rec;
+ PColor24RecArray = ^TColor24RecArray;
+
+ { Color record for 32 bit images, which allows access to individual color
+ channels.}
+ TColor32Rec = packed record
+ case LongInt of
+ 0: (Color: TColor32);
+ 1: (B, G, R, A: Byte);
+ 2: (Channels: array[0..3] of Byte);
+ 3: (Color24Rec: TColor24Rec);
+ end;
+ PColor32Rec = ^TColor32Rec;
+ TColor32RecArray = array[0..MaxInt div SizeOf(TColor32Rec) - 1] of TColor32Rec;
+ PColor32RecArray = ^TColor32RecArray;
+
+ { Color record for 48 bit images, which allows access to individual color
+ channels.}
+ TColor48Rec = packed record
+ case LongInt of
+ 0: (B, G, R: Word);
+ 1: (Channels: array[0..2] of Word);
+ end;
+ PColor48Rec = ^TColor48Rec;
+ TColor48RecArray = array[0..MaxInt div SizeOf(TColor48Rec) - 1] of TColor48Rec;
+ PColor48RecArray = ^TColor48RecArray;
+
+ { Color record for 64 bit images, which allows access to individual color
+ channels.}
+ TColor64Rec = packed record
+ case LongInt of
+ 0: (Color: TColor64);
+ 1: (B, G, R, A: Word);
+ 2: (Channels: array[0..3] of Word);
+ 3: (Color48Rec: TColor48Rec);
+ end;
+ PColor64Rec = ^TColor64Rec;
+ TColor64RecArray = array[0..MaxInt div SizeOf(TColor64Rec) - 1] of TColor64Rec;
+ PColor64RecArray = ^TColor64RecArray;
+
+ { Color record for 128 bit floating point images, which allows access to
+ individual color channels.}
+ TColorFPRec = packed record
+ case LongInt of
+ 0: (B, G, R, A: Single);
+ 1: (Channels: array[0..3] of Single);
+ end;
+ PColorFPRec = ^TColorFPRec;
+ TColorFPRecArray = array[0..MaxInt div SizeOf(TColorFPRec) - 1] of TColorFPRec;
+ PColorFPRecArray = ^TColorFPRecArray;
+
+ { 16 bit floating-point value. It has 1 sign bit, 5 exponent bits,
+ and 10 mantissa bits.}
+ THalfFloat = type Word;
+ PHalfFloat = ^THalfFloat;
+
+ { Color record for 64 bit floating point images, which allows access to
+ individual color channels.}
+ TColorHFRec = packed record
+ case LongInt of
+ 0: (B, G, R, A: THalfFloat);
+ 1: (Channels: array[0..3] of THalfFloat);
+ end;
+ PColorHFRec = ^TColorHFRec;
+ TColorHFRecArray = array[0..MaxInt div SizeOf(TColorHFRec) - 1] of TColorHFRec;
+ PColorHFRecArray = ^TColorHFRecArray;
+
+ { Palette for indexed mode images with 32 bit colors.}
+ TPalette32 = TColor32RecArray;
+ TPalette32Size256 = array[0..255] of TColor32Rec;
+ PPalette32 = ^TPalette32;
+
+ { Palette for indexd mode images with 24 bit colors.}
+ TPalette24 = TColor24RecArray;
+ TPalette24Size256 = array[0..255] of TColor24Rec;
+ PPalette24 = ^TPalette24;
+
+ { Record that stores single image data and information describing it.}
+ TImageData = packed record
+ Width: LongInt; // Width of image in pixels
+ Height: LongInt; // Height of image in pixels
+ Format: TImageFormat; // Data format of image
+ Size: LongInt; // Size of image bits in Bytes
+ Bits: Pointer; // Pointer to memory containing image bits
+ Palette: PPalette32; // Image palette for indexed images
+ end;
+ PImageData = ^TImageData;
+
+ { Pixel format information used in conversions to/from 16 and 8 bit ARGB
+ image formats.}
+ TPixelFormatInfo = packed record
+ ABitCount, RBitCount, GBitCount, BBitCount: Byte;
+ ABitMask, RBitMask, GBitMask, BBitMask: LongWord;
+ AShift, RShift, GShift, BShift: Byte;
+ ARecDiv, RRecDiv, GRecDiv, BRecDiv: Byte;
+ end;
+ PPixelFormatInfo = ^TPixelFormatInfo;
+
+ PImageFormatInfo = ^TImageFormatInfo;
+
+ { Look at TImageFormatInfo.GetPixelsSize for details.}
+ TFormatGetPixelsSizeFunc = function(Format: TImageFormat; Width,
+ Height: LongInt): LongInt;
+ { Look at TImageFormatInfo.CheckDimensions for details.}
+ TFormatCheckDimensionsProc = procedure(Format: TImageFormat; var Width,
+ Height: LongInt);
+ { Function for getting pixel colors. Native pixel is read from Image and
+ then translated to 32 bit ARGB.}
+ TGetPixel32Func = function(Bits: Pointer; Info: PImageFormatInfo;
+ Palette: PPalette32): TColor32Rec;
+ { Function for getting pixel colors. Native pixel is read from Image and
+ then translated to FP ARGB.}
+ TGetPixelFPFunc = function(Bits: Pointer; Info: PImageFormatInfo;
+ Palette: PPalette32): TColorFPRec;
+ { Procedure for setting pixel colors. Input 32 bit ARGB color is translated to
+ native format and then written to Image.}
+ TSetPixel32Proc = procedure(Bits: Pointer; Info: PImageFormatInfo;
+ Palette: PPalette32;const Color: TColor32Rec);
+ { Procedure for setting pixel colors. Input FP ARGB color is translated to
+ native format and then written to Image.}
+ TSetPixelFPProc = procedure(Bits: Pointer; Info: PImageFormatInfo;
+ Palette: PPalette32; const Color: TColorFPRec);
+
+ { Additional information for each TImageFormat value.}
+ TImageFormatInfo = packed record
+ Format: TImageFormat; // Format described by this record
+ Name: array[0..15] of Char; // Symbolic name of format
+ BytesPerPixel: LongInt; // Number of bytes per pixel (note: it is
+ // 0 for formats where BitsPerPixel < 8 (e.g. DXT).
+ // Use GetPixelsSize function to get size of
+ // image data.
+ ChannelCount: LongInt; // Number of image channels (R, G, B, A, Gray)
+ PaletteEntries: LongInt; // Number of palette entries
+ HasGrayChannel: Boolean; // True if image has grayscale channel
+ HasAlphaChannel: Boolean; // True if image has alpha channel
+ IsFloatingPoint: Boolean; // True if image has floating point pixels
+ UsePixelFormat: Boolean; // True if image uses pixel format
+ IsRBSwapped: Boolean; // True if Red and Blue channels are swapped
+ // e.g. A16B16G16R16 has IsRBSwapped True
+ RBSwapFormat: TImageFormat; // Indicates supported format with swapped
+ // Red and Blue channels, ifUnknown if such
+ // format does not exist
+ IsIndexed: Boolean; // True if image uses palette
+ IsSpecial: Boolean; // True if image is in special format
+ PixelFormat: PPixelFormatInfo; // Pixel format structure
+ GetPixelsSize: TFormatGetPixelsSizeFunc; // Returns size in bytes of
+ // Width * Height pixels of image
+ CheckDimensions: TFormatCheckDimensionsProc; // some formats have limited
+ // values of Width and Height. This
+ // procedure checks and changes dimensions
+ // to be valid for given format.
+ GetPixel32: TGetPixel32Func; // 32bit ARGB pixel get function
+ GetPixelFP: TGetPixelFPFunc; // FP ARGB pixel get function
+ SetPixel32: TSetPixel32Proc; // 32bit ARGB pixel set procedure
+ SetPixelFP: TSetPixelFPProc; // FP ARGB pixel set procedure
+ SpecialNearestFormat: TImageFormat; // Regular image format used when
+ // compressing/decompressing special images
+ // as source/target
+ end;
+
+ { Handle to list of image data records.}
+ TImageDataList = Pointer;
+ PImageDataList = ^TImageDataList;
+
+ { Handle to input/output.}
+ TImagingHandle = Pointer;
+
+ { Filters used in functions that resize images or their portions.}
+ TResizeFilter = (
+ rfNearest = 0,
+ rfBilinear = 1,
+ rfBicubic = 2);
+
+ { Seek origin mode for IO function Seek.}
+ TSeekMode = (
+ smFromBeginning = 0,
+ smFromCurrent = 1,
+ smFromEnd = 2);
+
+ { IO functions used for reading and writing images from/to input/output.}
+ TOpenReadProc = function(Source: PChar): TImagingHandle; cdecl;
+ TOpenWriteProc = function(Source: PChar): TImagingHandle; cdecl;
+ TCloseProc = procedure(Handle: TImagingHandle); cdecl;
+ TEofProc = function(Handle: TImagingHandle): Boolean; cdecl;
+ TSeekProc = function(Handle: TImagingHandle; Offset: LongInt; Mode: TSeekMode): LongInt; cdecl;
+ TTellProc = function(Handle: TImagingHandle): LongInt; cdecl;
+ TReadProc = function(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt): LongInt; cdecl;
+ TWriteProc = function(Handle: TImagingHandle; Buffer: Pointer; Count: LongInt): LongInt; cdecl;
+
+implementation
+
+{
+ File Notes:
+
+ -- TODOS ----------------------------------------------------
+ - add lookup tables to pixel formats for fast conversions
+
+ -- 0.24.3 Changes/Bug Fixes ---------------------------------
+ - Added ifATI1N and ifATI2N image data formats.
+
+ -- 0.23 Changes/Bug Fixes -----------------------------------
+ - Added ifBTC image format and SpecialNearestFormat field
+ to TImageFormatInfo.
+
+ -- 0.21 Changes/Bug Fixes -----------------------------------
+ - Added option constants for PGM and PPM file formats.
+ - Added TPalette32Size256 and TPalette24Size256 types.
+
+ -- 0.19 Changes/Bug Fixes -----------------------------------
+ - added ImagingVersionPatch constant so bug fix only releases
+ can be distinguished from ordinary major/minor releases
+ - renamed TPixelFormat to TPixelFormatInfo to avoid name collisions
+ with Graphics.TPixelFormat
+ - added new image data formats: ifR16F, ifA16R16G16B16F,
+ ifA16B16G16R16F
+ - added pixel get/set function pointers to TImageFormatInfo
+ - added 16bit half float type and color record
+ - renamed TColorFRec to TColorFPRec (and related types too)
+
+ -- 0.17 Changes/Bug Fixes -----------------------------------
+ - added option ImagingMipMapFilter which now controls resampling filter
+ used when generating mipmaps
+ - added TResizeFilter type
+ - added ChannelCount to TImageFormatInfo
+ - added new option constants for MNG and JNG images
+
+ -- 0.15 Changes/Bug Fixes -----------------------------------
+ - added RBSwapFormat to TImageFormatInfo for faster conversions
+ between swapped formats (it just calls SwapChannels now if
+ RBSwapFormat is not ifUnknown)
+ - moved TImageFormatInfo and required types from Imaging unit
+ here, removed TImageFormatShortInfo
+ - added new options: ImagingLoadOverrideFormat, ImagingSaveOverrideFormat
+
+ -- 0.13 Changes/Bug Fixes -----------------------------------
+ - new ImagingColorReductionMask option added
+ - new image format added: ifA16Gray16
+
+}
+
+end.
diff --git a/Server/UAccount.pas b/Server/UAccount.pas
index 14e5b8c..3ffd129 100644
--- a/Server/UAccount.pas
+++ b/Server/UAccount.pas
@@ -21,7 +21,7 @@
* CDDL HEADER END
*
*
- * Portions Copyright 2008 Andreas Schneider
+ * Portions Copyright 2013 Andreas Schneider
*)
unit UAccount;
@@ -37,7 +37,7 @@ type
{ TAccount }
TAccount = class(TObject, ISerializable, IInvalidate)
- constructor Create(AOwner: IInvalidate; AName, APasswordHash: string;
+ constructor Create(AOwner: IInvalidate; AName, APassword: string;
AAccessLevel: TAccessLevel; ARegions: TStringList);
constructor Deserialize(AOwner: IInvalidate; AElement: TDOMElement);
destructor Destroy; override;
@@ -58,7 +58,9 @@ type
property PasswordHash: string read FPasswordHash write SetPasswordHash;
property LastPos: TPoint read FLastPos write SetLastPos;
property Regions: TStringList read FRegions;
+ function CheckPassword(APassword: String): Boolean;
procedure Invalidate;
+ procedure UpdatePassword(APassword: String);
end;
{ TAccountList }
@@ -79,17 +81,17 @@ type
implementation
uses
- UCEDServer, UConfig;
+ UCEDServer, UConfig, md5;
{ TAccount }
-constructor TAccount.Create(AOwner: IInvalidate; AName, APasswordHash: string;
+constructor TAccount.Create(AOwner: IInvalidate; AName, APassword: string;
AAccessLevel: TAccessLevel; ARegions: TStringList);
begin
inherited Create;
FOwner := AOwner;
FName := AName;
- FPasswordHash := APasswordHash;
+ FPasswordHash := MD5Print(MD5String(APassword));
FAccessLevel := AAccessLevel;
if ARegions <> nil then
FRegions := ARegions
@@ -154,11 +156,27 @@ begin
Invalidate;
end;
+function TAccount.CheckPassword(APassword: String): Boolean;
+var
+ testHash: String;
+begin
+ //Since I want to change to PBKDF2 sometime, we compare strings instead
+ //of MD5Digest, so we can (later) check what type of hash the string has
+ //been created with.
+ testHash := MD5Print(MD5String(APassword));
+ Result := FPasswordHash = testHash;
+end;
+
procedure TAccount.Invalidate;
begin
FOwner.Invalidate;
end;
+procedure TAccount.UpdatePassword(APassword: String);
+begin
+ PasswordHash := MD5Print(MD5String(APassword));
+end;
+
procedure TAccount.Serialize(AElement: TDOMElement);
var
i: Integer;
diff --git a/Server/UAdminHandling.pas b/Server/UAdminHandling.pas
index 149e17c..553367b 100644
--- a/Server/UAdminHandling.pas
+++ b/Server/UAdminHandling.pas
@@ -21,7 +21,7 @@
* CDDL HEADER END
*
*
- * Portions Copyright 2008 Andreas Schneider
+ * Portions Copyright 2013 Andreas Schneider
*)
unit UAdminHandling;
@@ -88,7 +88,7 @@ var
implementation
uses
- md5, UCEDServer, UPackets, UClientHandling;
+ UCEDServer, UPackets, UClientHandling;
procedure AdminBroadcast(AAccessLevel: TAccessLevel; APacket: TPacket);
var
@@ -146,7 +146,7 @@ begin
if account <> nil then
begin
if password <> '' then
- account.PasswordHash := MD5Print(MD5String(password));
+ account.UpdatePassword(password);
account.AccessLevel := accessLevel;
@@ -181,8 +181,8 @@ begin
for i := 0 to regionCount - 1 do
regions.Add(ABuffer.ReadStringNull);
- account := TAccount.Create(Config.Accounts, username,
- MD5Print(MD5String(password)), accessLevel, regions);
+ account := TAccount.Create(Config.Accounts, username, password,
+ accessLevel, regions);
Config.Accounts.Add(account);
Config.Accounts.Invalidate;
diff --git a/Server/UCEDServer.pas b/Server/UCEDServer.pas
index f7b63ee..5e35d4b 100644
--- a/Server/UCEDServer.pas
+++ b/Server/UCEDServer.pas
@@ -217,7 +217,7 @@ begin
try
buffer := ANetState.ReceiveQueue;
buffer.Position := 0;
- while (buffer.Size >= 1) and ANetState.Socket.Connected do
+ while (buffer.Size >= 1) and (ANetState.Socket.ConnectionStatus = scConnected) do
begin
packetID := buffer.ReadByte;
packetHandler := PacketHandlers[packetID];
@@ -268,7 +268,7 @@ begin
netState := TNetState(FTCPServer.Iterator.UserData);
if netState <> nil then
begin
- if FTCPServer.Iterator.Connected then
+ if FTCPServer.Iterator.ConnectionStatus = scConnected then
begin
if (SecondsBetween(netState.LastAction, Now) > 120) then
begin
@@ -326,7 +326,7 @@ begin
while FTCPServer.IterNext do
begin
netState := TNetState(FTCPServer.Iterator.UserData);
- if (netState <> nil) and (FTCPServer.Iterator.Connected) then
+ if (netState <> nil) and (FTCPServer.Iterator.ConnectionStatus = scConnected) then
begin
netState.SendQueue.Seek(0, soFromEnd);
netState.SendQueue.CopyFrom(APacket.Stream, 0);
@@ -340,7 +340,7 @@ end;
procedure TCEDServer.Disconnect(ASocket: TLSocket);
begin
- if ASocket.Connected then
+ if ASocket.ConnectionStatus = scConnected then
begin
ASocket.Disconnect;
//OnDisconnect(ASocket);
diff --git a/Server/UClientHandling.pas b/Server/UClientHandling.pas
index 6c614ba..18a4f7e 100644
--- a/Server/UClientHandling.pas
+++ b/Server/UClientHandling.pas
@@ -71,6 +71,12 @@ type
constructor Create(AAccount: TAccount);
end;
+ { TPasswordChangeStatusPacket }
+
+ TPasswordChangeStatusPacket = class(TPacket)
+ constructor Create(AResult: TPasswordChangeStatus);
+ end;
+
procedure OnClientHandlerPacket(ABuffer: TEnhancedMemoryStream;
ANetState: TNetState);
procedure OnUpdateClientPosPacket(ABuffer: TEnhancedMemoryStream;
@@ -79,6 +85,8 @@ procedure OnChatMessagePacket(ABuffer: TEnhancedMemoryStream;
ANetState: TNetState);
procedure OnGotoClientPosPacket(ABuffer: TEnhancedMemoryStream;
ANetState: TNetState);
+procedure OnChangePasswordPacket(ABuffer: TEnhancedMemoryStream;
+ ANetState: TNetState);
procedure WriteAccountRestrictions(AStream: TEnhancedMemoryStream;
AAccount: TAccount);
@@ -130,6 +138,44 @@ begin
TSetClientPosPacket.Create(account.LastPos));
end;
+procedure OnChangePasswordPacket(ABuffer: TEnhancedMemoryStream;
+ ANetState: TNetState);
+var
+ oldPwd, newPwd: String;
+begin
+ oldPwd := ABuffer.ReadStringNull;
+ newPwd := ABuffer.ReadStringNull;
+ if ANetState.Account.CheckPassword(oldPwd) then
+ begin
+ //Check if the passwords actually differ. Changing them isn't allowed
+ //otherwise. Might be open for configuration, though.
+ if oldPwd <> newPwd then
+ begin
+ //Just a simple restriction to disallow too easy passwords.
+ //TODO: Configurable restrictions
+ if Length(newPwd) >= 4 then
+ begin
+ //Everything fine, update the password and report success.
+ ANetState.Account.UpdatePassword(newPwd);
+ CEDServerInstance.SendPacket(ANetState,
+ TPasswordChangeStatusPacket.Create(pcSuccess));
+ end else
+ begin
+ CEDServerInstance.SendPacket(ANetState,
+ TPasswordChangeStatusPacket.Create(pcNewPwInvalid));
+ end;
+ end else
+ begin
+ CEDServerInstance.SendPacket(ANetState,
+ TPasswordChangeStatusPacket.Create(pcIdentical));
+ end;
+ end else
+ begin
+ CEDServerInstance.SendPacket(ANetState,
+ TPasswordChangeStatusPacket.Create(pcOldPwInvalid));
+ end;
+end;
+
procedure WriteAccountRestrictions(AStream: TEnhancedMemoryStream;
AAccount: TAccount);
var
@@ -236,6 +282,15 @@ begin
WriteAccountRestrictions(FStream, AAccount);
end;
+{ TPasswordChangeStatusPacket }
+
+constructor TPasswordChangeStatusPacket.Create(AResult: TPasswordChangeStatus);
+begin
+ inherited Create($0C, 0);
+ FStream.WriteByte($08);
+ FStream.WriteByte(Byte(AResult));
+end;
+
{$WARNINGS OFF}
var
i: Integer;
@@ -246,6 +301,7 @@ initialization
ClientPacketHandlers[$04] := TPacketHandler.Create(0, @OnUpdateClientPosPacket);
ClientPacketHandlers[$05] := TPacketHandler.Create(0, @OnChatMessagePacket);
ClientPacketHandlers[$06] := TPacketHandler.Create(0, @OnGotoClientPosPacket);
+ ClientPacketHandlers[$08] := TPacketHandler.Create(0, @OnChangePasswordPacket);
finalization
for i := 0 to $FF do
if ClientPacketHandlers[i] <> nil then
diff --git a/Server/UConfig.pas b/Server/UConfig.pas
index e99d44b..581dcaa 100644
--- a/Server/UConfig.pas
+++ b/Server/UConfig.pas
@@ -21,7 +21,7 @@
* CDDL HEADER END
*
*
- * Portions Copyright 2008 Andreas Schneider
+ * Portions Copyright 2013 Andreas Schneider
*)
unit UConfig;
@@ -30,8 +30,8 @@ unit UConfig;
interface
uses
- Classes, SysUtils, DOM, XMLRead, XMLWrite, md5, Keyboard, UAccount,
- UXmlHelper, UInterfaces, UEnums, URegions;
+ Classes, SysUtils, DOM, XMLRead, XMLWrite, Keyboard, UAccount, UXmlHelper,
+ UInterfaces, UEnums, URegions;
type
@@ -292,8 +292,8 @@ begin
until stringValue <> '';
Write ('Password [hidden]: ');
password := QueryPassword;
- FAccounts.Add(TAccount.Create(FAccounts, stringValue,
- MD5Print(MD5String(password)), alAdministrator, nil));
+ FAccounts.Add(TAccount.Create(FAccounts, stringValue, password,
+ alAdministrator, nil));
FChanged := True;
end;
diff --git a/Server/UConnectionHandling.pas b/Server/UConnectionHandling.pas
index e56520d..cdc1f53 100644
--- a/Server/UConnectionHandling.pas
+++ b/Server/UConnectionHandling.pas
@@ -21,7 +21,7 @@
* CDDL HEADER END
*
*
- * Portions Copyright 2008 Andreas Schneider
+ * Portions Copyright 2013 Andreas Schneider
*)
unit UConnectionHandling;
@@ -63,7 +63,7 @@ var
implementation
uses
- md5, UCEDServer, UClientHandling, UPackets;
+ UCEDServer, UClientHandling, UPackets;
procedure OnConnectionHandlerPacket(ABuffer: TEnhancedMemoryStream; ANetState: TNetState);
var
@@ -77,19 +77,19 @@ end;
procedure OnLoginRequestPacket(ABuffer: TEnhancedMemoryStream;
ANetState: TNetState);
var
- username, passwordHash: string;
+ username, password: string;
account: TAccount;
netState: TNetState;
invalid: Boolean;
begin
username := ABuffer.ReadStringNull;
- passwordHash := MD5Print(MD5String(ABuffer.ReadStringNull));
+ password := ABuffer.ReadStringNull;
account := Config.Accounts.Find(username);
if account <> nil then
begin
if account.AccessLevel > alNone then
begin
- if account.PasswordHash = passwordHash then
+ if account.CheckPassword(password) then
begin
invalid := False;
CEDServerInstance.TCPServer.IterReset;
diff --git a/Server/UPackets.pas b/Server/UPackets.pas
index 48f401a..8a40ecc 100644
--- a/Server/UPackets.pas
+++ b/Server/UPackets.pas
@@ -139,7 +139,7 @@ begin
begin
subscriptions := CEDServerInstance.Landscape.BlockSubscriptions[ACoords[i].X, ACoords[i].Y];
subscriptions.Delete(ANetState);
- subscriptions.Add(Integer(ANetState), ANetState);
+ subscriptions.Add(PtrInt(ANetState), ANetState);
if ANetState.Subscriptions.IndexOf(subscriptions) = -1 then
ANetState.Subscriptions.Add(subscriptions);
end;
diff --git a/Server/cedserver.lpi b/Server/cedserver.lpi
index 8ceaf72..04bb89d 100644
--- a/Server/cedserver.lpi
+++ b/Server/cedserver.lpi
@@ -1,4 +1,4 @@
-
+
@@ -13,9 +13,9 @@
-
+
-
+
@@ -69,7 +69,7 @@
-
+
@@ -115,6 +115,10 @@
+
+
+
+
@@ -231,7 +235,6 @@
-
diff --git a/UEnhancedMemoryStream.pas b/UEnhancedMemoryStream.pas
index bb9a49d..d07bb6f 100644
--- a/UEnhancedMemoryStream.pas
+++ b/UEnhancedMemoryStream.pas
@@ -118,7 +118,7 @@ var
length: Integer;
begin
Result := '';
- buffer := Pointer(LongInt(Memory) + Position);
+ buffer := Pointer(PtrInt(Memory) + Position);
length := 0;
while (buffer[length] <> #0) and (length < (Size - Position)) do
begin
@@ -138,7 +138,7 @@ var
length: Integer;
begin
Result := '';
- buffer := Pointer(LongInt(FMemory) + FPosition);
+ buffer := Pointer(PtrInt(FMemory) + FPosition);
length := 0;
while (length < ALength) and (length < (FSize - (FPosition - FLockOffset))) do
begin
@@ -158,7 +158,7 @@ var
length: Integer;
begin
Result := '';
- buffer := Pointer(LongInt(FMemory) + FPosition);
+ buffer := Pointer(PtrInt(FMemory) + FPosition);
length := 0;
while (buffer^[length] <> 0) and (length < (FSize - (FPosition - FLockOffset))) do
begin
diff --git a/UEnums.pas b/UEnums.pas
index c4ef38c..6c5c621 100644
--- a/UEnums.pas
+++ b/UEnums.pas
@@ -56,6 +56,11 @@ type
mrModified = 1);
TDeleteRegionStatus = (drNotFound = 0,
drDeleted = 1);
+
+ TPasswordChangeStatus = (pcSuccess = 0,
+ pcOldPwInvalid = 1,
+ pcNewPwInvalid = 2,
+ pcIdentical = 3);
function GetAccessLevelString(AAccessLevel: TAccessLevel): string;
diff --git a/bin/CentrED.dat b/bin/CentrED.dat
index 5c46c34..0c5266c 100644
Binary files a/bin/CentrED.dat and b/bin/CentrED.dat differ
diff --git a/version.inc b/version.inc
index ab17349..5b7a3ad 100644
--- a/version.inc
+++ b/version.inc
@@ -1,2 +1,2 @@
const
- ProtocolVersion = 6;
+ ProtocolVersion = 7;